never executed always true always false
1 module PureClaw.Security.Vault
2 ( -- * Config and status
3 VaultConfig (..)
4 , UnlockMode (..)
5 , VaultStatus (..)
6 -- * Handle
7 , VaultHandle (..)
8 -- * Constructor
9 , openVault
10 ) where
11
12 import Control.Concurrent.MVar
13 import Control.Concurrent.STM
14 import Data.Aeson qualified as Aeson
15 import Data.ByteString (ByteString)
16 import Data.ByteString qualified as BS
17 import Data.ByteString.Base64 qualified as B64
18 import Data.Map.Strict (Map)
19 import Data.Map.Strict qualified as Map
20 import Data.Text (Text)
21 import Data.Text qualified as T
22 import System.Directory (doesFileExist, renameFile)
23 import System.Posix.Files (setFileMode)
24
25 import PureClaw.Security.Vault.Age
26
27 -- | When the vault is automatically unlocked.
28 data UnlockMode
29 = UnlockStartup -- ^ Must be explicitly unlocked; returns VaultLocked if locked.
30 | UnlockOnDemand -- ^ Unlocks automatically on first access if locked.
31 | UnlockPerAccess -- ^ Decrypts from disk on every operation; TVar unused.
32 deriving stock (Show, Eq)
33
34 -- | Configuration for a vault.
35 data VaultConfig = VaultConfig
36 { _vc_path :: FilePath
37 , _vc_recipient :: Text -- ^ age recipient string
38 , _vc_identity :: Text -- ^ age identity path or plugin string
39 , _vc_unlock :: UnlockMode
40 }
41 deriving stock (Show, Eq)
42
43 -- | Runtime status of the vault.
44 data VaultStatus = VaultStatus
45 { _vs_locked :: Bool
46 , _vs_secretCount :: Int
47 , _vs_keyType :: Text -- ^ derived from recipient prefix
48 }
49 deriving stock (Show, Eq)
50
51 -- | Capability handle for vault operations.
52 data VaultHandle = VaultHandle
53 { _vh_init :: IO (Either VaultError ())
54 , _vh_get :: Text -> IO (Either VaultError ByteString)
55 , _vh_put :: Text -> ByteString -> IO (Either VaultError ())
56 , _vh_delete :: Text -> IO (Either VaultError ())
57 , _vh_list :: IO (Either VaultError [Text])
58 , _vh_lock :: IO ()
59 , _vh_unlock :: IO (Either VaultError ())
60 , _vh_status :: IO VaultStatus
61 }
62
63 -- Internal state, not exported.
64 data VaultState = VaultState
65 { _vst_config :: VaultConfig
66 , _vst_encryptor :: AgeEncryptor
67 , _vst_tvar :: TVar (Maybe (Map Text ByteString))
68 , _vst_writeLock :: MVar () -- ^ serialises init/put/delete
69 }
70
71 -- | Construct a 'VaultHandle'. Does not unlock; caller decides when.
72 openVault :: VaultConfig -> AgeEncryptor -> IO VaultHandle
73 openVault cfg enc = do
74 tvar <- newTVarIO Nothing
75 mvar <- newMVar ()
76 let st = VaultState cfg enc tvar mvar
77 pure VaultHandle
78 { _vh_init = vaultInit st
79 , _vh_get = vaultGet st
80 , _vh_put = vaultPut st
81 , _vh_delete = vaultDelete st
82 , _vh_list = vaultList st
83 , _vh_lock = vaultLock st
84 , _vh_unlock = vaultUnlock st
85 , _vh_status = vaultStatus st
86 }
87
88 -- ---------------------------------------------------------------------------
89 -- Operations
90 -- ---------------------------------------------------------------------------
91
92 vaultInit :: VaultState -> IO (Either VaultError ())
93 vaultInit st = withMVar (_vst_writeLock st) $ \_ -> do
94 exists <- doesFileExist (_vc_path (_vst_config st))
95 if exists
96 then pure (Left VaultAlreadyExists)
97 else do
98 let emptyMap = Map.empty :: Map Text ByteString
99 jsonBs = BS.toStrict (Aeson.encode (encodedMap emptyMap))
100 encrypted <- _ae_encrypt (_vst_encryptor st)
101 (AgeRecipient (_vc_recipient (_vst_config st)))
102 jsonBs
103 case encrypted of
104 Left err -> pure (Left err)
105 Right ciphertext -> do
106 atomicWrite (_vc_path (_vst_config st)) ciphertext
107 pure (Right ())
108
109 vaultUnlock :: VaultState -> IO (Either VaultError ())
110 vaultUnlock st = do
111 fileBs <- BS.readFile (_vc_path (_vst_config st))
112 plainResult <- _ae_decrypt (_vst_encryptor st)
113 (AgeIdentity (_vc_identity (_vst_config st)))
114 fileBs
115 case plainResult of
116 Left err -> pure (Left err)
117 Right plain ->
118 case Aeson.decodeStrict plain of
119 Nothing -> pure (Left (VaultCorrupted "invalid JSON"))
120 Just encoded ->
121 case decodeMap encoded of
122 Nothing -> pure (Left (VaultCorrupted "invalid base64 in vault"))
123 Just m -> do
124 atomically (writeTVar (_vst_tvar st) (Just m))
125 pure (Right ())
126
127 vaultLock :: VaultState -> IO ()
128 vaultLock st = atomically (writeTVar (_vst_tvar st) Nothing)
129
130 vaultGet :: VaultState -> Text -> IO (Either VaultError ByteString)
131 vaultGet st key =
132 case _vc_unlock (_vst_config st) of
133 UnlockPerAccess -> do
134 mapResult <- readAndDecryptMap st
135 case mapResult of
136 Left err -> pure (Left err)
137 Right m -> pure (lookupKey key m)
138 UnlockStartup -> do
139 current <- readTVarIO (_vst_tvar st)
140 case current of
141 Nothing -> pure (Left VaultLocked)
142 Just m -> pure (lookupKey key m)
143 UnlockOnDemand -> do
144 ensureUnlocked st
145 current <- readTVarIO (_vst_tvar st)
146 case current of
147 Nothing -> pure (Left VaultLocked)
148 Just m -> pure (lookupKey key m)
149
150 vaultPut :: VaultState -> Text -> ByteString -> IO (Either VaultError ())
151 vaultPut st key value =
152 case _vc_unlock (_vst_config st) of
153 UnlockPerAccess -> withMVar (_vst_writeLock st) $ \_ -> do
154 mapResult <- readAndDecryptMap st
155 case mapResult of
156 Left err -> pure (Left err)
157 Right m -> encryptAndWrite st (Map.insert key value m)
158 UnlockOnDemand -> do
159 -- Unlock outside the write lock to avoid deadlock
160 ensureUnlocked st
161 withMVar (_vst_writeLock st) $ \_ -> do
162 current <- readTVarIO (_vst_tvar st)
163 case current of
164 Nothing -> pure (Left VaultLocked)
165 Just m -> do
166 let m' = Map.insert key value m
167 result <- encryptAndWrite st m'
168 case result of
169 Left err -> pure (Left err)
170 Right () -> do
171 atomically (writeTVar (_vst_tvar st) (Just m'))
172 pure (Right ())
173 UnlockStartup -> withMVar (_vst_writeLock st) $ \_ -> do
174 current <- readTVarIO (_vst_tvar st)
175 case current of
176 Nothing -> pure (Left VaultLocked)
177 Just m -> do
178 let m' = Map.insert key value m
179 result <- encryptAndWrite st m'
180 case result of
181 Left err -> pure (Left err)
182 Right () -> do
183 atomically (writeTVar (_vst_tvar st) (Just m'))
184 pure (Right ())
185
186 vaultDelete :: VaultState -> Text -> IO (Either VaultError ())
187 vaultDelete st key =
188 case _vc_unlock (_vst_config st) of
189 UnlockPerAccess -> withMVar (_vst_writeLock st) $ \_ -> do
190 mapResult <- readAndDecryptMap st
191 case mapResult of
192 Left err -> pure (Left err)
193 Right m ->
194 if Map.member key m
195 then encryptAndWrite st (Map.delete key m)
196 else pure (Left (VaultCorrupted "key not found"))
197 UnlockOnDemand -> do
198 ensureUnlocked st
199 withMVar (_vst_writeLock st) $ \_ -> do
200 current <- readTVarIO (_vst_tvar st)
201 case current of
202 Nothing -> pure (Left VaultLocked)
203 Just m ->
204 if Map.member key m
205 then do
206 let m' = Map.delete key m
207 result <- encryptAndWrite st m'
208 case result of
209 Left err -> pure (Left err)
210 Right () -> do
211 atomically (writeTVar (_vst_tvar st) (Just m'))
212 pure (Right ())
213 else pure (Left (VaultCorrupted "key not found"))
214 UnlockStartup -> withMVar (_vst_writeLock st) $ \_ -> do
215 current <- readTVarIO (_vst_tvar st)
216 case current of
217 Nothing -> pure (Left VaultLocked)
218 Just m ->
219 if Map.member key m
220 then do
221 let m' = Map.delete key m
222 result <- encryptAndWrite st m'
223 case result of
224 Left err -> pure (Left err)
225 Right () -> do
226 atomically (writeTVar (_vst_tvar st) (Just m'))
227 pure (Right ())
228 else pure (Left (VaultCorrupted "key not found"))
229
230 vaultList :: VaultState -> IO (Either VaultError [Text])
231 vaultList st =
232 case _vc_unlock (_vst_config st) of
233 UnlockPerAccess -> do
234 mapResult <- readAndDecryptMap st
235 case mapResult of
236 Left err -> pure (Left err)
237 Right m -> pure (Right (Map.keys m))
238 UnlockStartup -> do
239 current <- readTVarIO (_vst_tvar st)
240 case current of
241 Nothing -> pure (Left VaultLocked)
242 Just m -> pure (Right (Map.keys m))
243 UnlockOnDemand -> do
244 ensureUnlocked st
245 current <- readTVarIO (_vst_tvar st)
246 case current of
247 Nothing -> pure (Left VaultLocked)
248 Just m -> pure (Right (Map.keys m))
249
250 vaultStatus :: VaultState -> IO VaultStatus
251 vaultStatus st = do
252 current <- readTVarIO (_vst_tvar st)
253 let locked = case current of
254 Nothing -> True
255 Just _ -> False
256 count = maybe 0 Map.size current
257 keyTy = inferKeyType (_vc_recipient (_vst_config st))
258 pure VaultStatus
259 { _vs_locked = locked
260 , _vs_secretCount = count
261 , _vs_keyType = keyTy
262 }
263
264 -- ---------------------------------------------------------------------------
265 -- Internal helpers
266 -- ---------------------------------------------------------------------------
267
268 -- | Read vault file and decrypt to a map.
269 readAndDecryptMap :: VaultState -> IO (Either VaultError (Map Text ByteString))
270 readAndDecryptMap st = do
271 fileBs <- BS.readFile (_vc_path (_vst_config st))
272 plainResult <- _ae_decrypt (_vst_encryptor st)
273 (AgeIdentity (_vc_identity (_vst_config st)))
274 fileBs
275 case plainResult of
276 Left err -> pure (Left err)
277 Right plain ->
278 case Aeson.decodeStrict plain of
279 Nothing -> pure (Left (VaultCorrupted "invalid JSON"))
280 Just encoded ->
281 case decodeMap encoded of
282 Nothing -> pure (Left (VaultCorrupted "invalid base64 in vault"))
283 Just m -> pure (Right m)
284
285 -- | Serialise map to JSON, encrypt, and atomically write to disk.
286 encryptAndWrite :: VaultState -> Map Text ByteString -> IO (Either VaultError ())
287 encryptAndWrite st m = do
288 let jsonBs = BS.toStrict (Aeson.encode (encodedMap m))
289 encrypted <- _ae_encrypt (_vst_encryptor st)
290 (AgeRecipient (_vc_recipient (_vst_config st)))
291 jsonBs
292 case encrypted of
293 Left err -> pure (Left err)
294 Right ciphertext -> do
295 atomicWrite (_vc_path (_vst_config st)) ciphertext
296 pure (Right ())
297
298 -- | For UnlockOnDemand: unlock the vault if the TVar is empty.
299 -- Guarded by write lock to prevent double-init from concurrent calls.
300 ensureUnlocked :: VaultState -> IO ()
301 ensureUnlocked st =
302 withMVar (_vst_writeLock st) $ \_ -> do
303 current <- readTVarIO (_vst_tvar st)
304 case current of
305 Just _ -> pure () -- already unlocked by a concurrent call
306 Nothing -> do
307 result <- vaultUnlock st
308 case result of
309 Right () -> pure ()
310 Left _ -> pure () -- best-effort; callers check TVar afterward
311
312 -- | Look up a key or return the appropriate error.
313 lookupKey :: Text -> Map Text ByteString -> Either VaultError ByteString
314 lookupKey key m =
315 case Map.lookup key m of
316 Nothing -> Left (VaultCorrupted "no such key")
317 Just v -> Right v
318
319 -- | Atomically write file: write to .tmp, chmod 0600, then rename.
320 atomicWrite :: FilePath -> ByteString -> IO ()
321 atomicWrite path bs = do
322 let tmp = path <> ".tmp"
323 BS.writeFile tmp bs
324 setFileMode tmp 0o600
325 renameFile tmp path
326
327 -- | Encode a map's values as base64 for JSON serialisation.
328 -- The vault format stores values as base64-encoded strings so that
329 -- binary secrets survive JSON round-trips intact.
330 encodedMap :: Map Text ByteString -> Map Text Text
331 encodedMap = Map.map (decodeUtf8Lenient . B64.encode)
332 where
333 -- B64.encode produces valid ASCII; decoding cannot fail.
334 decodeUtf8Lenient :: ByteString -> Text
335 decodeUtf8Lenient = T.pack . map (toEnum . fromIntegral) . BS.unpack
336
337 -- | Decode base64 values from the JSON representation back to ByteStrings.
338 decodeMap :: Map Text Text -> Maybe (Map Text ByteString)
339 decodeMap = traverse decodeValue
340 where
341 decodeValue :: Text -> Maybe ByteString
342 decodeValue t =
343 case B64.decode (encodeUtf8 t) of
344 Left _ -> Nothing
345 Right v -> Just v
346
347 encodeUtf8 :: Text -> ByteString
348 encodeUtf8 = BS.pack . map (fromIntegral . fromEnum) . T.unpack
349
350 -- | Infer a human-readable key type from the age recipient prefix.
351 inferKeyType :: Text -> Text
352 inferKeyType recipient
353 | "age-plugin-yubikey" `T.isPrefixOf` recipient = "YubiKey PIV"
354 | "age1" `T.isPrefixOf` recipient = "X25519"
355 | otherwise = "Unknown"