1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
|
module Storage.Key (
KeyPair(..),
storeKey, loadKey, loadKeyMb,
moveKeys,
) where
import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.Except
import Data.ByteArray
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy as BL
import qualified Data.Map as M
import System.Directory
import System.FilePath
import System.IO.Error
import Storage
import Storage.Internal
class Storable pub => KeyPair sec pub | sec -> pub, pub -> sec where
generateKeys :: Storage -> IO (sec, Stored pub)
keyGetPublic :: sec -> Stored pub
keyGetData :: sec -> ScrubbedBytes
keyFromData :: ScrubbedBytes -> Stored pub -> Maybe sec
keyFilePath :: KeyPair sec pub => FilePath -> Stored pub -> FilePath
keyFilePath sdir pkey = sdir </> "keys" </> (BC.unpack $ showRef $ storedRef pkey)
storeKey :: KeyPair sec pub => sec -> IO ()
storeKey key = do
let spub = keyGetPublic key
case stBacking $ storedStorage spub of
StorageDir { dirPath = dir } -> writeFileOnce (keyFilePath dir spub) (BL.fromStrict $ convert $ keyGetData key)
StorageMemory { memKeys = kstore } -> modifyMVar_ kstore $ return . M.insert (refDigest $ storedRef spub) (keyGetData key)
loadKey :: (KeyPair sec pub, MonadIO m, MonadError String m) => Stored pub -> m sec
loadKey pub = maybe (throwError $ "secret key not found for " <> show (storedRef pub)) return =<< loadKeyMb pub
loadKeyMb :: (KeyPair sec pub, MonadIO m) => Stored pub -> m (Maybe sec)
loadKeyMb spub = liftIO $ run $ storedStorage spub
where
run st = tryOneLevel (stBacking st) >>= \case
key@Just {} -> return key
Nothing | Just parent <- stParent st -> run parent
| otherwise -> return Nothing
tryOneLevel = \case
StorageDir { dirPath = dir } -> tryIOError (BC.readFile (keyFilePath dir spub)) >>= \case
Right kdata -> return $ keyFromData (convert kdata) spub
Left _ -> return Nothing
StorageMemory { memKeys = kstore } -> (flip keyFromData spub <=< M.lookup (refDigest $ storedRef spub)) <$> readMVar kstore
moveKeys :: MonadIO m => Storage -> Storage -> m ()
moveKeys from to = liftIO $ do
case (stBacking from, stBacking to) of
(StorageDir { dirPath = fromPath }, StorageDir { dirPath = toPath }) -> do
files <- listDirectory (fromPath </> "keys")
forM_ files $ \file -> do
renameFile (fromPath </> "keys" </> file) (toPath </> "keys" </> file)
(StorageDir { dirPath = fromPath }, StorageMemory { memKeys = toKeys }) -> do
let move m file
| Just dgst <- readRefDigest (BC.pack file) = do
let path = fromPath </> "keys" </> file
key <- convert <$> BC.readFile path
removeFile path
return $ M.insert dgst key m
| otherwise = return m
files <- listDirectory (fromPath </> "keys")
modifyMVar_ toKeys $ \keys -> foldM move keys files
(StorageMemory { memKeys = fromKeys }, StorageDir { dirPath = toPath }) -> do
modifyMVar_ fromKeys $ \keys -> do
forM_ (M.assocs keys) $ \(dgst, key) ->
writeFileOnce (toPath </> "keys" </> (BC.unpack $ showRefDigest dgst)) (BL.fromStrict $ convert key)
return M.empty
(StorageMemory { memKeys = fromKeys }, StorageMemory { memKeys = toKeys }) -> do
modifyMVar_ fromKeys $ \fkeys -> do
modifyMVar_ toKeys $ return . M.union fkeys
return M.empty
|