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 Data.Aeson qualified as Aeson
16 import Data.ByteString (ByteString)
17 import Data.ByteString qualified as BS
18 import Data.ByteString.Base64 qualified as B64
19 import Data.Map.Strict (Map)
20 import Data.Map.Strict qualified as Map
21 import Data.Text (Text)
22 import Data.Text qualified as T
23 import System.Directory (doesFileExist, renameFile)
24 import System.Posix.Files (setFileMode)
25
26 import PureClaw.Security.Vault.Age
27
28 -- | When the vault is automatically unlocked.
29 data UnlockMode
30 = UnlockStartup -- ^ Must be explicitly unlocked; returns VaultLocked if locked.
31 | UnlockOnDemand -- ^ Unlocks automatically on first access if locked.
32 | UnlockPerAccess -- ^ Decrypts from disk on every operation; TVar unused.
33 deriving stock (Show, Eq)
34
35 -- | Configuration for a vault.
36 data VaultConfig = VaultConfig
37 { _vc_path :: FilePath
38 , _vc_keyType :: Text -- ^ human-readable key type for /vault status
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 :: VaultEncryptor
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 -> VaultEncryptor -> 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 <- _ve_encrypt (_vst_encryptor st) jsonBs
101 case encrypted of
102 Left err -> pure (Left err)
103 Right ciphertext -> do
104 atomicWrite (_vc_path (_vst_config st)) ciphertext
105 pure (Right ())
106
107 vaultUnlock :: VaultState -> IO (Either VaultError ())
108 vaultUnlock st = do
109 fileResult <- try @IOException (BS.readFile (_vc_path (_vst_config st)))
110 case fileResult of
111 Left _ -> pure (Left VaultNotFound)
112 Right fileBs -> do
113 plainResult <- _ve_decrypt (_vst_encryptor st) fileBs
114 case plainResult of
115 Left err -> pure (Left err)
116 Right plain ->
117 case Aeson.decodeStrict plain of
118 Nothing -> pure (Left (VaultCorrupted "invalid JSON"))
119 Just encoded ->
120 case decodeMap encoded of
121 Nothing -> pure (Left (VaultCorrupted "invalid base64 in vault"))
122 Just m -> do
123 atomically (writeTVar (_vst_tvar st) (Just m))
124 pure (Right ())
125
126 vaultLock :: VaultState -> IO ()
127 vaultLock st = atomically (writeTVar (_vst_tvar st) Nothing)
128
129 vaultGet :: VaultState -> Text -> IO (Either VaultError ByteString)
130 vaultGet st key =
131 case _vc_unlock (_vst_config st) of
132 UnlockPerAccess -> do
133 mapResult <- readAndDecryptMap st
134 case mapResult of
135 Left err -> pure (Left err)
136 Right m -> pure (lookupKey key m)
137 UnlockStartup -> do
138 current <- readTVarIO (_vst_tvar st)
139 case current of
140 Nothing -> pure (Left VaultLocked)
141 Just m -> pure (lookupKey key m)
142 UnlockOnDemand -> do
143 ensureUnlocked st
144 current <- readTVarIO (_vst_tvar st)
145 case current of
146 Nothing -> pure (Left VaultLocked)
147 Just m -> pure (lookupKey key m)
148
149 vaultPut :: VaultState -> Text -> ByteString -> IO (Either VaultError ())
150 vaultPut st key value =
151 case _vc_unlock (_vst_config st) of
152 UnlockPerAccess -> withMVar (_vst_writeLock st) $ \_ -> do
153 mapResult <- readAndDecryptMap st
154 case mapResult of
155 Left err -> pure (Left err)
156 Right m -> encryptAndWrite st (Map.insert key value m)
157 UnlockOnDemand -> do
158 -- Unlock outside the write lock to avoid deadlock
159 ensureUnlocked st
160 withMVar (_vst_writeLock st) $ \_ -> do
161 current <- readTVarIO (_vst_tvar st)
162 case current of
163 Nothing -> pure (Left VaultLocked)
164 Just m -> do
165 let m' = Map.insert key value m
166 result <- encryptAndWrite st m'
167 case result of
168 Left err -> pure (Left err)
169 Right () -> do
170 atomically (writeTVar (_vst_tvar st) (Just m'))
171 pure (Right ())
172 UnlockStartup -> withMVar (_vst_writeLock st) $ \_ -> do
173 current <- readTVarIO (_vst_tvar st)
174 case current of
175 Nothing -> pure (Left VaultLocked)
176 Just m -> do
177 let m' = Map.insert key value m
178 result <- encryptAndWrite st m'
179 case result of
180 Left err -> pure (Left err)
181 Right () -> do
182 atomically (writeTVar (_vst_tvar st) (Just m'))
183 pure (Right ())
184
185 vaultDelete :: VaultState -> Text -> IO (Either VaultError ())
186 vaultDelete st key =
187 case _vc_unlock (_vst_config st) of
188 UnlockPerAccess -> withMVar (_vst_writeLock st) $ \_ -> do
189 mapResult <- readAndDecryptMap st
190 case mapResult of
191 Left err -> pure (Left err)
192 Right m ->
193 if Map.member key m
194 then encryptAndWrite st (Map.delete key m)
195 else pure (Left (VaultCorrupted "key not found"))
196 UnlockOnDemand -> do
197 ensureUnlocked st
198 withMVar (_vst_writeLock st) $ \_ -> do
199 current <- readTVarIO (_vst_tvar st)
200 case current of
201 Nothing -> pure (Left VaultLocked)
202 Just m ->
203 if Map.member key m
204 then do
205 let m' = Map.delete key m
206 result <- encryptAndWrite st m'
207 case result of
208 Left err -> pure (Left err)
209 Right () -> do
210 atomically (writeTVar (_vst_tvar st) (Just m'))
211 pure (Right ())
212 else pure (Left (VaultCorrupted "key not found"))
213 UnlockStartup -> withMVar (_vst_writeLock st) $ \_ -> do
214 current <- readTVarIO (_vst_tvar st)
215 case current of
216 Nothing -> pure (Left VaultLocked)
217 Just m ->
218 if Map.member key m
219 then do
220 let m' = Map.delete key m
221 result <- encryptAndWrite st m'
222 case result of
223 Left err -> pure (Left err)
224 Right () -> do
225 atomically (writeTVar (_vst_tvar st) (Just m'))
226 pure (Right ())
227 else pure (Left (VaultCorrupted "key not found"))
228
229 vaultList :: VaultState -> IO (Either VaultError [Text])
230 vaultList st =
231 case _vc_unlock (_vst_config st) of
232 UnlockPerAccess -> do
233 mapResult <- readAndDecryptMap st
234 case mapResult of
235 Left err -> pure (Left err)
236 Right m -> pure (Right (Map.keys m))
237 UnlockStartup -> do
238 current <- readTVarIO (_vst_tvar st)
239 case current of
240 Nothing -> pure (Left VaultLocked)
241 Just m -> pure (Right (Map.keys m))
242 UnlockOnDemand -> do
243 ensureUnlocked st
244 current <- readTVarIO (_vst_tvar st)
245 case current of
246 Nothing -> pure (Left VaultLocked)
247 Just m -> pure (Right (Map.keys m))
248
249 vaultStatus :: VaultState -> IO VaultStatus
250 vaultStatus st = do
251 current <- readTVarIO (_vst_tvar st)
252 let locked = case current of
253 Nothing -> True
254 Just _ -> False
255 count = maybe 0 Map.size current
256 pure VaultStatus
257 { _vs_locked = locked
258 , _vs_secretCount = count
259 , _vs_keyType = _vc_keyType (_vst_config st)
260 }
261
262 -- ---------------------------------------------------------------------------
263 -- Internal helpers
264 -- ---------------------------------------------------------------------------
265
266 -- | Read vault file and decrypt to a map.
267 readAndDecryptMap :: VaultState -> IO (Either VaultError (Map Text ByteString))
268 readAndDecryptMap st = do
269 fileResult <- try @IOException (BS.readFile (_vc_path (_vst_config st)))
270 case fileResult of
271 Left _ -> pure (Left VaultNotFound)
272 Right fileBs -> do
273 plainResult <- _ve_decrypt (_vst_encryptor st) fileBs
274 case plainResult of
275 Left err -> pure (Left err)
276 Right plain ->
277 case Aeson.decodeStrict plain of
278 Nothing -> pure (Left (VaultCorrupted "invalid JSON"))
279 Just encoded ->
280 case decodeMap encoded of
281 Nothing -> pure (Left (VaultCorrupted "invalid base64 in vault"))
282 Just m -> pure (Right m)
283
284 -- | Serialise map to JSON, encrypt, and atomically write to disk.
285 encryptAndWrite :: VaultState -> Map Text ByteString -> IO (Either VaultError ())
286 encryptAndWrite st m = do
287 let jsonBs = BS.toStrict (Aeson.encode (encodedMap m))
288 encrypted <- _ve_encrypt (_vst_encryptor st) jsonBs
289 case encrypted of
290 Left err -> pure (Left err)
291 Right ciphertext -> do
292 atomicWrite (_vc_path (_vst_config st)) ciphertext
293 pure (Right ())
294
295 -- | For UnlockOnDemand: unlock the vault if the TVar is empty.
296 -- Guarded by write lock to prevent double-init from concurrent calls.
297 ensureUnlocked :: VaultState -> IO ()
298 ensureUnlocked st =
299 withMVar (_vst_writeLock st) $ \_ -> do
300 current <- readTVarIO (_vst_tvar st)
301 case current of
302 Just _ -> pure () -- already unlocked by a concurrent call
303 Nothing -> do
304 result <- vaultUnlock st
305 case result of
306 Right () -> pure ()
307 Left _ -> pure () -- best-effort; callers check TVar afterward
308
309 -- | Look up a key or return the appropriate error.
310 lookupKey :: Text -> Map Text ByteString -> Either VaultError ByteString
311 lookupKey key m =
312 case Map.lookup key m of
313 Nothing -> Left (VaultCorrupted "no such key")
314 Just v -> Right v
315
316 -- | Atomically write file: write to .tmp, chmod 0600, then rename.
317 atomicWrite :: FilePath -> ByteString -> IO ()
318 atomicWrite path bs = do
319 let tmp = path <> ".tmp"
320 BS.writeFile tmp bs
321 setFileMode tmp 0o600
322 renameFile tmp path
323
324 -- | Encode a map's values as base64 for JSON serialisation.
325 -- The vault format stores values as base64-encoded strings so that
326 -- binary secrets survive JSON round-trips intact.
327 encodedMap :: Map Text ByteString -> Map Text Text
328 encodedMap = Map.map (decodeUtf8Lenient . B64.encode)
329 where
330 -- B64.encode produces valid ASCII; decoding cannot fail.
331 decodeUtf8Lenient :: ByteString -> Text
332 decodeUtf8Lenient = T.pack . map (toEnum . fromIntegral) . BS.unpack
333
334 -- | Decode base64 values from the JSON representation back to ByteStrings.
335 decodeMap :: Map Text Text -> Maybe (Map Text ByteString)
336 decodeMap = traverse decodeValue
337 where
338 decodeValue :: Text -> Maybe ByteString
339 decodeValue t =
340 case B64.decode (encodeUtf8 t) of
341 Left _ -> Nothing
342 Right v -> Just v
343
344 encodeUtf8 :: Text -> ByteString
345 encodeUtf8 = BS.pack . map (fromIntegral . fromEnum) . T.unpack
346