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 Control.Exception (IOException, try)
15 import Control.Monad (when)
16 import Data.Aeson qualified as Aeson
17 import Data.ByteString (ByteString)
18 import Data.ByteString qualified as BS
19 import Data.ByteString.Base64 qualified as B64
20 import Data.IORef
21 import Data.Map.Strict (Map)
22 import Data.Map.Strict qualified as Map
23 import Data.Text (Text)
24 import Data.Text qualified as T
25 import System.Directory (doesFileExist, removeFile, renameFile)
26 import System.Posix.Files (setFileMode)
27
28 import PureClaw.Security.Vault.Age
29
30 -- | When the vault is automatically unlocked.
31 data UnlockMode
32 = UnlockStartup -- ^ Must be explicitly unlocked; returns VaultLocked if locked.
33 | UnlockOnDemand -- ^ Unlocks automatically on first access if locked.
34 | UnlockPerAccess -- ^ Decrypts from disk on every operation; TVar unused.
35 deriving stock (Show, Eq)
36
37 -- | Configuration for a vault.
38 data VaultConfig = VaultConfig
39 { _vc_path :: FilePath
40 , _vc_keyType :: Text -- ^ human-readable key type for /vault status
41 , _vc_unlock :: UnlockMode
42 }
43 deriving stock (Show, Eq)
44
45 -- | Runtime status of the vault.
46 data VaultStatus = VaultStatus
47 { _vs_locked :: Bool
48 , _vs_secretCount :: Int
49 , _vs_keyType :: Text -- ^ derived from recipient prefix
50 }
51 deriving stock (Show, Eq)
52
53 -- | Capability handle for vault operations.
54 data VaultHandle = VaultHandle
55 { _vh_init :: IO (Either VaultError ())
56 , _vh_get :: Text -> IO (Either VaultError ByteString)
57 , _vh_put :: Text -> ByteString -> IO (Either VaultError ())
58 , _vh_delete :: Text -> IO (Either VaultError ())
59 , _vh_list :: IO (Either VaultError [Text])
60 , _vh_lock :: IO ()
61 , _vh_unlock :: IO (Either VaultError ())
62 , _vh_status :: IO VaultStatus
63 , _vh_rekey :: VaultEncryptor -> Text -> (Text -> IO Bool) -> IO (Either VaultError ())
64 -- ^ Re-encrypt the vault with a new encryptor.
65 -- Args: new encryptor, new key type label, confirmation callback.
66 }
67
68 -- Internal state, not exported.
69 data VaultState = VaultState
70 { _vst_config :: VaultConfig
71 , _vst_encryptor :: IORef VaultEncryptor
72 , _vst_keyType :: IORef Text
73 , _vst_tvar :: TVar (Maybe (Map Text ByteString))
74 , _vst_writeLock :: MVar () -- ^ serialises init/put/delete
75 }
76
77 -- | Construct a 'VaultHandle'. Does not unlock; caller decides when.
78 openVault :: VaultConfig -> VaultEncryptor -> IO VaultHandle
79 openVault cfg enc = do
80 encRef <- newIORef enc
81 ktRef <- newIORef (_vc_keyType cfg)
82 tvar <- newTVarIO Nothing
83 mvar <- newMVar ()
84 let st = VaultState cfg encRef ktRef tvar mvar
85 pure VaultHandle
86 { _vh_init = vaultInit st
87 , _vh_get = vaultGet st
88 , _vh_put = vaultPut st
89 , _vh_delete = vaultDelete st
90 , _vh_list = vaultList st
91 , _vh_lock = vaultLock st
92 , _vh_unlock = vaultUnlock st
93 , _vh_status = vaultStatus st
94 , _vh_rekey = vaultRekey st
95 }
96
97 -- ---------------------------------------------------------------------------
98 -- Operations
99 -- ---------------------------------------------------------------------------
100
101 vaultInit :: VaultState -> IO (Either VaultError ())
102 vaultInit st = withMVar (_vst_writeLock st) $ \_ -> do
103 exists <- doesFileExist (_vc_path (_vst_config st))
104 if exists
105 then pure (Left VaultAlreadyExists)
106 else do
107 enc <- readIORef (_vst_encryptor st)
108 let emptyMap = Map.empty :: Map Text ByteString
109 jsonBs = BS.toStrict (Aeson.encode (encodedMap emptyMap))
110 encrypted <- _ve_encrypt enc jsonBs
111 case encrypted of
112 Left err -> pure (Left err)
113 Right ciphertext -> do
114 atomicWrite (_vc_path (_vst_config st)) ciphertext
115 pure (Right ())
116
117 vaultUnlock :: VaultState -> IO (Either VaultError ())
118 vaultUnlock st = do
119 enc <- readIORef (_vst_encryptor st)
120 fileResult <- try @IOException (BS.readFile (_vc_path (_vst_config st)))
121 case fileResult of
122 Left _ -> pure (Left VaultNotFound)
123 Right fileBs -> do
124 plainResult <- _ve_decrypt enc fileBs
125 case plainResult of
126 Left err -> pure (Left err)
127 Right plain ->
128 case Aeson.decodeStrict plain of
129 Nothing -> pure (Left (VaultCorrupted "invalid JSON"))
130 Just encoded ->
131 case decodeMap encoded of
132 Nothing -> pure (Left (VaultCorrupted "invalid base64 in vault"))
133 Just m -> do
134 atomically (writeTVar (_vst_tvar st) (Just m))
135 pure (Right ())
136
137 vaultLock :: VaultState -> IO ()
138 vaultLock st = atomically (writeTVar (_vst_tvar st) Nothing)
139
140 vaultGet :: VaultState -> Text -> IO (Either VaultError ByteString)
141 vaultGet st key =
142 case _vc_unlock (_vst_config st) of
143 UnlockPerAccess -> do
144 mapResult <- readAndDecryptMap st
145 case mapResult of
146 Left err -> pure (Left err)
147 Right m -> pure (lookupKey key m)
148 UnlockStartup -> do
149 current <- readTVarIO (_vst_tvar st)
150 case current of
151 Nothing -> pure (Left VaultLocked)
152 Just m -> pure (lookupKey key m)
153 UnlockOnDemand -> do
154 ensureUnlocked st
155 current <- readTVarIO (_vst_tvar st)
156 case current of
157 Nothing -> pure (Left VaultLocked)
158 Just m -> pure (lookupKey key m)
159
160 vaultPut :: VaultState -> Text -> ByteString -> IO (Either VaultError ())
161 vaultPut st key value =
162 case _vc_unlock (_vst_config st) of
163 UnlockPerAccess -> withMVar (_vst_writeLock st) $ \_ -> do
164 mapResult <- readAndDecryptMap st
165 case mapResult of
166 Left err -> pure (Left err)
167 Right m -> encryptAndWrite st (Map.insert key value m)
168 UnlockOnDemand -> do
169 -- Unlock outside the write lock to avoid deadlock
170 ensureUnlocked st
171 withMVar (_vst_writeLock st) $ \_ -> do
172 current <- readTVarIO (_vst_tvar st)
173 case current of
174 Nothing -> pure (Left VaultLocked)
175 Just m -> do
176 let m' = Map.insert key value m
177 result <- encryptAndWrite st m'
178 case result of
179 Left err -> pure (Left err)
180 Right () -> do
181 atomically (writeTVar (_vst_tvar st) (Just m'))
182 pure (Right ())
183 UnlockStartup -> withMVar (_vst_writeLock st) $ \_ -> do
184 current <- readTVarIO (_vst_tvar st)
185 case current of
186 Nothing -> pure (Left VaultLocked)
187 Just m -> do
188 let m' = Map.insert key value m
189 result <- encryptAndWrite st m'
190 case result of
191 Left err -> pure (Left err)
192 Right () -> do
193 atomically (writeTVar (_vst_tvar st) (Just m'))
194 pure (Right ())
195
196 vaultDelete :: VaultState -> Text -> IO (Either VaultError ())
197 vaultDelete st key =
198 case _vc_unlock (_vst_config st) of
199 UnlockPerAccess -> withMVar (_vst_writeLock st) $ \_ -> do
200 mapResult <- readAndDecryptMap st
201 case mapResult of
202 Left err -> pure (Left err)
203 Right m ->
204 if Map.member key m
205 then encryptAndWrite st (Map.delete key m)
206 else pure (Left (VaultCorrupted "key not found"))
207 UnlockOnDemand -> do
208 ensureUnlocked st
209 withMVar (_vst_writeLock st) $ \_ -> do
210 current <- readTVarIO (_vst_tvar st)
211 case current of
212 Nothing -> pure (Left VaultLocked)
213 Just m ->
214 if Map.member key m
215 then do
216 let m' = Map.delete key m
217 result <- encryptAndWrite st m'
218 case result of
219 Left err -> pure (Left err)
220 Right () -> do
221 atomically (writeTVar (_vst_tvar st) (Just m'))
222 pure (Right ())
223 else pure (Left (VaultCorrupted "key not found"))
224 UnlockStartup -> withMVar (_vst_writeLock st) $ \_ -> do
225 current <- readTVarIO (_vst_tvar st)
226 case current of
227 Nothing -> pure (Left VaultLocked)
228 Just m ->
229 if Map.member key m
230 then do
231 let m' = Map.delete key m
232 result <- encryptAndWrite st m'
233 case result of
234 Left err -> pure (Left err)
235 Right () -> do
236 atomically (writeTVar (_vst_tvar st) (Just m'))
237 pure (Right ())
238 else pure (Left (VaultCorrupted "key not found"))
239
240 vaultList :: VaultState -> IO (Either VaultError [Text])
241 vaultList st =
242 case _vc_unlock (_vst_config st) of
243 UnlockPerAccess -> do
244 mapResult <- readAndDecryptMap st
245 case mapResult of
246 Left err -> pure (Left err)
247 Right m -> pure (Right (Map.keys m))
248 UnlockStartup -> do
249 current <- readTVarIO (_vst_tvar st)
250 case current of
251 Nothing -> pure (Left VaultLocked)
252 Just m -> pure (Right (Map.keys m))
253 UnlockOnDemand -> do
254 ensureUnlocked st
255 current <- readTVarIO (_vst_tvar st)
256 case current of
257 Nothing -> pure (Left VaultLocked)
258 Just m -> pure (Right (Map.keys m))
259
260 vaultStatus :: VaultState -> IO VaultStatus
261 vaultStatus st = do
262 current <- readTVarIO (_vst_tvar st)
263 keyType <- readIORef (_vst_keyType st)
264 let locked = case current of
265 Nothing -> True
266 Just _ -> False
267 count = maybe 0 Map.size current
268 pure VaultStatus
269 { _vs_locked = locked
270 , _vs_secretCount = count
271 , _vs_keyType = keyType
272 }
273
274 -- | Re-encrypt the vault with a new encryptor.
275 -- Safe rekey: write to .new, verify, then atomically replace.
276 vaultRekey :: VaultState -> VaultEncryptor -> Text -> (Text -> IO Bool) -> IO (Either VaultError ())
277 vaultRekey st newEnc newKeyType confirm = withMVar (_vst_writeLock st) $ \_ -> do
278 let path = _vc_path (_vst_config st)
279 newPath = path <> ".new"
280 -- Step 1: Decrypt all secrets with current encryptor
281 mapResult <- readAndDecryptMap st
282 case mapResult of
283 Left err -> pure (Left err)
284 Right plainMap -> do
285 -- Step 2: Re-encrypt with NEW encryptor, write to .new
286 let jsonBs = BS.toStrict (Aeson.encode (encodedMap plainMap))
287 encrypted <- _ve_encrypt newEnc jsonBs
288 case encrypted of
289 Left err -> pure (Left err)
290 Right ciphertext -> do
291 atomicWrite newPath ciphertext
292 -- Step 3: Verify: read .new, decrypt with new encryptor, compare
293 verifyResult <- try @IOException (BS.readFile newPath)
294 case verifyResult of
295 Left _ -> do
296 cleanupNewFile newPath
297 pure (Left (VaultCorrupted "rekey verification failed"))
298 Right verifyBs -> do
299 decResult <- _ve_decrypt newEnc verifyBs
300 case decResult of
301 Left _ -> do
302 cleanupNewFile newPath
303 pure (Left (VaultCorrupted "rekey verification failed"))
304 Right decrypted -> do
305 -- Compare decoded map byte-for-byte with original
306 case Aeson.decodeStrict decrypted of
307 Nothing -> do
308 cleanupNewFile newPath
309 pure (Left (VaultCorrupted "rekey verification failed"))
310 Just encoded ->
311 case decodeMap encoded of
312 Nothing -> do
313 cleanupNewFile newPath
314 pure (Left (VaultCorrupted "rekey verification failed"))
315 Just verifiedMap
316 | verifiedMap /= plainMap -> do
317 cleanupNewFile newPath
318 pure (Left (VaultCorrupted "rekey verification failed"))
319 | otherwise -> do
320 -- Step 4: Ask for confirmation
321 oldKeyType <- readIORef (_vst_keyType st)
322 let secretCount = Map.size plainMap
323 msg = "Replace vault? Old: " <> oldKeyType
324 <> ", New: " <> newKeyType
325 <> ", " <> T.pack (show secretCount)
326 <> " secrets verified identical"
327 confirmed <- confirm msg
328 if confirmed
329 then do
330 -- Step 5: Atomic replace
331 renameFile newPath path
332 writeIORef (_vst_encryptor st) newEnc
333 writeIORef (_vst_keyType st) newKeyType
334 atomically (writeTVar (_vst_tvar st) (Just plainMap))
335 pure (Right ())
336 else do
337 cleanupNewFile newPath
338 pure (Left (VaultCorrupted "rekey cancelled by user"))
339
340 -- | Remove the .new file, ignoring errors if it doesn't exist.
341 cleanupNewFile :: FilePath -> IO ()
342 cleanupNewFile path = do
343 exists <- doesFileExist path
344 when exists $ removeFile path
345
346 -- ---------------------------------------------------------------------------
347 -- Internal helpers
348 -- ---------------------------------------------------------------------------
349
350 -- | Read vault file and decrypt to a map.
351 readAndDecryptMap :: VaultState -> IO (Either VaultError (Map Text ByteString))
352 readAndDecryptMap st = do
353 enc <- readIORef (_vst_encryptor st)
354 fileResult <- try @IOException (BS.readFile (_vc_path (_vst_config st)))
355 case fileResult of
356 Left _ -> pure (Left VaultNotFound)
357 Right fileBs -> do
358 plainResult <- _ve_decrypt enc fileBs
359 case plainResult of
360 Left err -> pure (Left err)
361 Right plain ->
362 case Aeson.decodeStrict plain of
363 Nothing -> pure (Left (VaultCorrupted "invalid JSON"))
364 Just encoded ->
365 case decodeMap encoded of
366 Nothing -> pure (Left (VaultCorrupted "invalid base64 in vault"))
367 Just m -> pure (Right m)
368
369 -- | Serialise map to JSON, encrypt, and atomically write to disk.
370 encryptAndWrite :: VaultState -> Map Text ByteString -> IO (Either VaultError ())
371 encryptAndWrite st m = do
372 enc <- readIORef (_vst_encryptor st)
373 let jsonBs = BS.toStrict (Aeson.encode (encodedMap m))
374 encrypted <- _ve_encrypt enc jsonBs
375 case encrypted of
376 Left err -> pure (Left err)
377 Right ciphertext -> do
378 atomicWrite (_vc_path (_vst_config st)) ciphertext
379 pure (Right ())
380
381 -- | For UnlockOnDemand: unlock the vault if the TVar is empty.
382 -- Guarded by write lock to prevent double-init from concurrent calls.
383 ensureUnlocked :: VaultState -> IO ()
384 ensureUnlocked st =
385 withMVar (_vst_writeLock st) $ \_ -> do
386 current <- readTVarIO (_vst_tvar st)
387 case current of
388 Just _ -> pure () -- already unlocked by a concurrent call
389 Nothing -> do
390 result <- vaultUnlock st
391 case result of
392 Right () -> pure ()
393 Left _ -> pure () -- best-effort; callers check TVar afterward
394
395 -- | Look up a key or return the appropriate error.
396 lookupKey :: Text -> Map Text ByteString -> Either VaultError ByteString
397 lookupKey key m =
398 case Map.lookup key m of
399 Nothing -> Left (VaultCorrupted "no such key")
400 Just v -> Right v
401
402 -- | Atomically write file: write to .tmp, chmod 0600, then rename.
403 atomicWrite :: FilePath -> ByteString -> IO ()
404 atomicWrite path bs = do
405 let tmp = path <> ".tmp"
406 BS.writeFile tmp bs
407 setFileMode tmp 0o600
408 renameFile tmp path
409
410 -- | Encode a map's values as base64 for JSON serialisation.
411 -- The vault format stores values as base64-encoded strings so that
412 -- binary secrets survive JSON round-trips intact.
413 encodedMap :: Map Text ByteString -> Map Text Text
414 encodedMap = Map.map (decodeUtf8Lenient . B64.encode)
415 where
416 -- B64.encode produces valid ASCII; decoding cannot fail.
417 decodeUtf8Lenient :: ByteString -> Text
418 decodeUtf8Lenient = T.pack . map (toEnum . fromIntegral) . BS.unpack
419
420 -- | Decode base64 values from the JSON representation back to ByteStrings.
421 decodeMap :: Map Text Text -> Maybe (Map Text ByteString)
422 decodeMap = traverse decodeValue
423 where
424 decodeValue :: Text -> Maybe ByteString
425 decodeValue t =
426 case B64.decode (encodeUtf8 t) of
427 Left _ -> Nothing
428 Right v -> Just v
429
430 encodeUtf8 :: Text -> ByteString
431 encodeUtf8 = BS.pack . map (fromIntegral . fromEnum) . T.unpack
432