module Erebos.Storage.Key ( KeyPair(..), storeKey, loadKey, loadKeyMb, moveKeys, ) where import Control.Concurrent.MVar import Control.Monad import Control.Monad.Except import Control.Monad.IO.Class 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 Erebos.Storage import Erebos.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 :: forall sec pub. KeyPair sec pub => FilePath -> Stored pub -> FilePath keyFilePath FilePath sdir Stored pub pkey = FilePath sdir FilePath -> FilePath -> FilePath </> FilePath "keys" FilePath -> FilePath -> FilePath </> (ByteString -> FilePath BC.unpack (ByteString -> FilePath) -> ByteString -> FilePath forall a b. (a -> b) -> a -> b $ Ref' Complete -> ByteString forall (c :: * -> *). Ref' c -> ByteString showRef (Ref' Complete -> ByteString) -> Ref' Complete -> ByteString forall a b. (a -> b) -> a -> b $ Stored pub -> Ref' Complete forall a. Stored a -> Ref' Complete storedRef Stored pub pkey) storeKey :: KeyPair sec pub => sec -> IO () storeKey :: forall sec pub. KeyPair sec pub => sec -> IO () storeKey sec key = do let spub :: Stored pub spub = sec -> Stored pub forall sec pub. KeyPair sec pub => sec -> Stored pub keyGetPublic sec key case Storage' Complete -> StorageBacking Complete forall (c :: * -> *). Storage' c -> StorageBacking c stBacking (Storage' Complete -> StorageBacking Complete) -> Storage' Complete -> StorageBacking Complete forall a b. (a -> b) -> a -> b $ Stored pub -> Storage' Complete forall (c :: * -> *) a. Stored' c a -> Storage' c storedStorage Stored pub spub of StorageDir { dirPath :: forall (c :: * -> *). StorageBacking c -> FilePath dirPath = FilePath dir } -> FilePath -> ByteString -> IO () writeFileOnce (FilePath -> Stored pub -> FilePath forall sec pub. KeyPair sec pub => FilePath -> Stored pub -> FilePath keyFilePath FilePath dir Stored pub spub) (ByteString -> ByteString BL.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString forall a b. (a -> b) -> a -> b $ ScrubbedBytes -> ByteString forall bin bout. (ByteArrayAccess bin, ByteArray bout) => bin -> bout convert (ScrubbedBytes -> ByteString) -> ScrubbedBytes -> ByteString forall a b. (a -> b) -> a -> b $ sec -> ScrubbedBytes forall sec pub. KeyPair sec pub => sec -> ScrubbedBytes keyGetData sec key) StorageMemory { memKeys :: forall (c :: * -> *). StorageBacking c -> MVar (Map RefDigest ScrubbedBytes) memKeys = MVar (Map RefDigest ScrubbedBytes) kstore } -> MVar (Map RefDigest ScrubbedBytes) -> (Map RefDigest ScrubbedBytes -> IO (Map RefDigest ScrubbedBytes)) -> IO () forall a. MVar a -> (a -> IO a) -> IO () modifyMVar_ MVar (Map RefDigest ScrubbedBytes) kstore ((Map RefDigest ScrubbedBytes -> IO (Map RefDigest ScrubbedBytes)) -> IO ()) -> (Map RefDigest ScrubbedBytes -> IO (Map RefDigest ScrubbedBytes)) -> IO () forall a b. (a -> b) -> a -> b $ Map RefDigest ScrubbedBytes -> IO (Map RefDigest ScrubbedBytes) forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return (Map RefDigest ScrubbedBytes -> IO (Map RefDigest ScrubbedBytes)) -> (Map RefDigest ScrubbedBytes -> Map RefDigest ScrubbedBytes) -> Map RefDigest ScrubbedBytes -> IO (Map RefDigest ScrubbedBytes) forall b c a. (b -> c) -> (a -> b) -> a -> c . RefDigest -> ScrubbedBytes -> Map RefDigest ScrubbedBytes -> Map RefDigest ScrubbedBytes forall k a. Ord k => k -> a -> Map k a -> Map k a M.insert (Ref' Complete -> RefDigest forall (c :: * -> *). Ref' c -> RefDigest refDigest (Ref' Complete -> RefDigest) -> Ref' Complete -> RefDigest forall a b. (a -> b) -> a -> b $ Stored pub -> Ref' Complete forall a. Stored a -> Ref' Complete storedRef Stored pub spub) (sec -> ScrubbedBytes forall sec pub. KeyPair sec pub => sec -> ScrubbedBytes keyGetData sec key) loadKey :: (KeyPair sec pub, MonadIO m, MonadError String m) => Stored pub -> m sec loadKey :: forall sec pub (m :: * -> *). (KeyPair sec pub, MonadIO m, MonadError FilePath m) => Stored pub -> m sec loadKey Stored pub pub = m sec -> (sec -> m sec) -> Maybe sec -> m sec forall b a. b -> (a -> b) -> Maybe a -> b maybe (FilePath -> m sec forall a. FilePath -> m a forall e (m :: * -> *) a. MonadError e m => e -> m a throwError (FilePath -> m sec) -> FilePath -> m sec forall a b. (a -> b) -> a -> b $ FilePath "secret key not found for " FilePath -> FilePath -> FilePath forall a. Semigroup a => a -> a -> a <> Ref' Complete -> FilePath forall a. Show a => a -> FilePath show (Stored pub -> Ref' Complete forall a. Stored a -> Ref' Complete storedRef Stored pub pub)) sec -> m sec forall a. a -> m a forall (m :: * -> *) a. Monad m => a -> m a return (Maybe sec -> m sec) -> m (Maybe sec) -> m sec forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< Stored pub -> m (Maybe sec) forall sec pub (m :: * -> *). (KeyPair sec pub, MonadIO m) => Stored pub -> m (Maybe sec) loadKeyMb Stored pub pub loadKeyMb :: (KeyPair sec pub, MonadIO m) => Stored pub -> m (Maybe sec) loadKeyMb :: forall sec pub (m :: * -> *). (KeyPair sec pub, MonadIO m) => Stored pub -> m (Maybe sec) loadKeyMb Stored pub spub = IO (Maybe sec) -> m (Maybe sec) forall a. IO a -> m a forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO (Maybe sec) -> m (Maybe sec)) -> IO (Maybe sec) -> m (Maybe sec) forall a b. (a -> b) -> a -> b $ Storage' Complete -> IO (Maybe sec) run (Storage' Complete -> IO (Maybe sec)) -> Storage' Complete -> IO (Maybe sec) forall a b. (a -> b) -> a -> b $ Stored pub -> Storage' Complete forall (c :: * -> *) a. Stored' c a -> Storage' c storedStorage Stored pub spub where run :: Storage' Complete -> IO (Maybe sec) run Storage' Complete st = StorageBacking Complete -> IO (Maybe sec) tryOneLevel (Storage' Complete -> StorageBacking Complete forall (c :: * -> *). Storage' c -> StorageBacking c stBacking Storage' Complete st) IO (Maybe sec) -> (Maybe sec -> IO (Maybe sec)) -> IO (Maybe sec) forall a b. IO a -> (a -> IO b) -> IO b forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \case key :: Maybe sec key@Just {} -> Maybe sec -> IO (Maybe sec) forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return Maybe sec key Maybe sec Nothing | Just Storage' Complete parent <- Storage' Complete -> Maybe (Storage' Complete) forall (c :: * -> *). Storage' c -> Maybe (Storage' Complete) stParent Storage' Complete st -> Storage' Complete -> IO (Maybe sec) run Storage' Complete parent | Bool otherwise -> Maybe sec -> IO (Maybe sec) forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return Maybe sec forall a. Maybe a Nothing tryOneLevel :: StorageBacking Complete -> IO (Maybe sec) tryOneLevel = \case StorageDir { dirPath :: forall (c :: * -> *). StorageBacking c -> FilePath dirPath = FilePath dir } -> IO ByteString -> IO (Either IOError ByteString) forall a. IO a -> IO (Either IOError a) tryIOError (FilePath -> IO ByteString BC.readFile (FilePath -> Stored pub -> FilePath forall sec pub. KeyPair sec pub => FilePath -> Stored pub -> FilePath keyFilePath FilePath dir Stored pub spub)) IO (Either IOError ByteString) -> (Either IOError ByteString -> IO (Maybe sec)) -> IO (Maybe sec) forall a b. IO a -> (a -> IO b) -> IO b forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \case Right ByteString kdata -> Maybe sec -> IO (Maybe sec) forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return (Maybe sec -> IO (Maybe sec)) -> Maybe sec -> IO (Maybe sec) forall a b. (a -> b) -> a -> b $ ScrubbedBytes -> Stored pub -> Maybe sec forall sec pub. KeyPair sec pub => ScrubbedBytes -> Stored pub -> Maybe sec keyFromData (ByteString -> ScrubbedBytes forall bin bout. (ByteArrayAccess bin, ByteArray bout) => bin -> bout convert ByteString kdata) Stored pub spub Left IOError _ -> Maybe sec -> IO (Maybe sec) forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return Maybe sec forall a. Maybe a Nothing StorageMemory { memKeys :: forall (c :: * -> *). StorageBacking c -> MVar (Map RefDigest ScrubbedBytes) memKeys = MVar (Map RefDigest ScrubbedBytes) kstore } -> ((ScrubbedBytes -> Stored pub -> Maybe sec) -> Stored pub -> ScrubbedBytes -> Maybe sec forall a b c. (a -> b -> c) -> b -> a -> c flip ScrubbedBytes -> Stored pub -> Maybe sec forall sec pub. KeyPair sec pub => ScrubbedBytes -> Stored pub -> Maybe sec keyFromData Stored pub spub (ScrubbedBytes -> Maybe sec) -> (Map RefDigest ScrubbedBytes -> Maybe ScrubbedBytes) -> Map RefDigest ScrubbedBytes -> Maybe sec forall (m :: * -> *) b c a. Monad m => (b -> m c) -> (a -> m b) -> a -> m c <=< RefDigest -> Map RefDigest ScrubbedBytes -> Maybe ScrubbedBytes forall k a. Ord k => k -> Map k a -> Maybe a M.lookup (Ref' Complete -> RefDigest forall (c :: * -> *). Ref' c -> RefDigest refDigest (Ref' Complete -> RefDigest) -> Ref' Complete -> RefDigest forall a b. (a -> b) -> a -> b $ Stored pub -> Ref' Complete forall a. Stored a -> Ref' Complete storedRef Stored pub spub)) (Map RefDigest ScrubbedBytes -> Maybe sec) -> IO (Map RefDigest ScrubbedBytes) -> IO (Maybe sec) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> MVar (Map RefDigest ScrubbedBytes) -> IO (Map RefDigest ScrubbedBytes) forall a. MVar a -> IO a readMVar MVar (Map RefDigest ScrubbedBytes) kstore moveKeys :: MonadIO m => Storage -> Storage -> m () moveKeys :: forall (m :: * -> *). MonadIO m => Storage' Complete -> Storage' Complete -> m () moveKeys Storage' Complete from Storage' Complete to = IO () -> m () forall a. IO a -> m a forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO () -> m ()) -> IO () -> m () forall a b. (a -> b) -> a -> b $ do case (Storage' Complete -> StorageBacking Complete forall (c :: * -> *). Storage' c -> StorageBacking c stBacking Storage' Complete from, Storage' Complete -> StorageBacking Complete forall (c :: * -> *). Storage' c -> StorageBacking c stBacking Storage' Complete to) of (StorageDir { dirPath :: forall (c :: * -> *). StorageBacking c -> FilePath dirPath = FilePath fromPath }, StorageDir { dirPath :: forall (c :: * -> *). StorageBacking c -> FilePath dirPath = FilePath toPath }) -> do [FilePath] files <- FilePath -> IO [FilePath] listDirectory (FilePath fromPath FilePath -> FilePath -> FilePath </> FilePath "keys") [FilePath] -> (FilePath -> IO ()) -> IO () forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => t a -> (a -> m b) -> m () forM_ [FilePath] files ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO () forall a b. (a -> b) -> a -> b $ \FilePath file -> do FilePath -> FilePath -> IO () renameFile (FilePath fromPath FilePath -> FilePath -> FilePath </> FilePath "keys" FilePath -> FilePath -> FilePath </> FilePath file) (FilePath toPath FilePath -> FilePath -> FilePath </> FilePath "keys" FilePath -> FilePath -> FilePath </> FilePath file) (StorageDir { dirPath :: forall (c :: * -> *). StorageBacking c -> FilePath dirPath = FilePath fromPath }, StorageMemory { memKeys :: forall (c :: * -> *). StorageBacking c -> MVar (Map RefDigest ScrubbedBytes) memKeys = MVar (Map RefDigest ScrubbedBytes) toKeys }) -> do let move :: Map RefDigest ScrubbedBytes -> FilePath -> IO (Map RefDigest ScrubbedBytes) move Map RefDigest ScrubbedBytes m FilePath file | Just RefDigest dgst <- ByteString -> Maybe RefDigest readRefDigest (FilePath -> ByteString BC.pack FilePath file) = do let path :: FilePath path = FilePath fromPath FilePath -> FilePath -> FilePath </> FilePath "keys" FilePath -> FilePath -> FilePath </> FilePath file ScrubbedBytes key <- ByteString -> ScrubbedBytes forall bin bout. (ByteArrayAccess bin, ByteArray bout) => bin -> bout convert (ByteString -> ScrubbedBytes) -> IO ByteString -> IO ScrubbedBytes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> FilePath -> IO ByteString BC.readFile FilePath path FilePath -> IO () removeFile FilePath path Map RefDigest ScrubbedBytes -> IO (Map RefDigest ScrubbedBytes) forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return (Map RefDigest ScrubbedBytes -> IO (Map RefDigest ScrubbedBytes)) -> Map RefDigest ScrubbedBytes -> IO (Map RefDigest ScrubbedBytes) forall a b. (a -> b) -> a -> b $ RefDigest -> ScrubbedBytes -> Map RefDigest ScrubbedBytes -> Map RefDigest ScrubbedBytes forall k a. Ord k => k -> a -> Map k a -> Map k a M.insert RefDigest dgst ScrubbedBytes key Map RefDigest ScrubbedBytes m | Bool otherwise = Map RefDigest ScrubbedBytes -> IO (Map RefDigest ScrubbedBytes) forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return Map RefDigest ScrubbedBytes m [FilePath] files <- FilePath -> IO [FilePath] listDirectory (FilePath fromPath FilePath -> FilePath -> FilePath </> FilePath "keys") MVar (Map RefDigest ScrubbedBytes) -> (Map RefDigest ScrubbedBytes -> IO (Map RefDigest ScrubbedBytes)) -> IO () forall a. MVar a -> (a -> IO a) -> IO () modifyMVar_ MVar (Map RefDigest ScrubbedBytes) toKeys ((Map RefDigest ScrubbedBytes -> IO (Map RefDigest ScrubbedBytes)) -> IO ()) -> (Map RefDigest ScrubbedBytes -> IO (Map RefDigest ScrubbedBytes)) -> IO () forall a b. (a -> b) -> a -> b $ \Map RefDigest ScrubbedBytes keys -> (Map RefDigest ScrubbedBytes -> FilePath -> IO (Map RefDigest ScrubbedBytes)) -> Map RefDigest ScrubbedBytes -> [FilePath] -> IO (Map RefDigest ScrubbedBytes) forall (t :: * -> *) (m :: * -> *) b a. (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m b foldM Map RefDigest ScrubbedBytes -> FilePath -> IO (Map RefDigest ScrubbedBytes) move Map RefDigest ScrubbedBytes keys [FilePath] files (StorageMemory { memKeys :: forall (c :: * -> *). StorageBacking c -> MVar (Map RefDigest ScrubbedBytes) memKeys = MVar (Map RefDigest ScrubbedBytes) fromKeys }, StorageDir { dirPath :: forall (c :: * -> *). StorageBacking c -> FilePath dirPath = FilePath toPath }) -> do MVar (Map RefDigest ScrubbedBytes) -> (Map RefDigest ScrubbedBytes -> IO (Map RefDigest ScrubbedBytes)) -> IO () forall a. MVar a -> (a -> IO a) -> IO () modifyMVar_ MVar (Map RefDigest ScrubbedBytes) fromKeys ((Map RefDigest ScrubbedBytes -> IO (Map RefDigest ScrubbedBytes)) -> IO ()) -> (Map RefDigest ScrubbedBytes -> IO (Map RefDigest ScrubbedBytes)) -> IO () forall a b. (a -> b) -> a -> b $ \Map RefDigest ScrubbedBytes keys -> do [(RefDigest, ScrubbedBytes)] -> ((RefDigest, ScrubbedBytes) -> IO ()) -> IO () forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => t a -> (a -> m b) -> m () forM_ (Map RefDigest ScrubbedBytes -> [(RefDigest, ScrubbedBytes)] forall k a. Map k a -> [(k, a)] M.assocs Map RefDigest ScrubbedBytes keys) (((RefDigest, ScrubbedBytes) -> IO ()) -> IO ()) -> ((RefDigest, ScrubbedBytes) -> IO ()) -> IO () forall a b. (a -> b) -> a -> b $ \(RefDigest dgst, ScrubbedBytes key) -> FilePath -> ByteString -> IO () writeFileOnce (FilePath toPath FilePath -> FilePath -> FilePath </> FilePath "keys" FilePath -> FilePath -> FilePath </> (ByteString -> FilePath BC.unpack (ByteString -> FilePath) -> ByteString -> FilePath forall a b. (a -> b) -> a -> b $ RefDigest -> ByteString showRefDigest RefDigest dgst)) (ByteString -> ByteString BL.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString forall a b. (a -> b) -> a -> b $ ScrubbedBytes -> ByteString forall bin bout. (ByteArrayAccess bin, ByteArray bout) => bin -> bout convert ScrubbedBytes key) Map RefDigest ScrubbedBytes -> IO (Map RefDigest ScrubbedBytes) forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return Map RefDigest ScrubbedBytes forall k a. Map k a M.empty (StorageMemory { memKeys :: forall (c :: * -> *). StorageBacking c -> MVar (Map RefDigest ScrubbedBytes) memKeys = MVar (Map RefDigest ScrubbedBytes) fromKeys }, StorageMemory { memKeys :: forall (c :: * -> *). StorageBacking c -> MVar (Map RefDigest ScrubbedBytes) memKeys = MVar (Map RefDigest ScrubbedBytes) toKeys }) -> do MVar (Map RefDigest ScrubbedBytes) -> (Map RefDigest ScrubbedBytes -> IO (Map RefDigest ScrubbedBytes)) -> IO () forall a. MVar a -> (a -> IO a) -> IO () modifyMVar_ MVar (Map RefDigest ScrubbedBytes) fromKeys ((Map RefDigest ScrubbedBytes -> IO (Map RefDigest ScrubbedBytes)) -> IO ()) -> (Map RefDigest ScrubbedBytes -> IO (Map RefDigest ScrubbedBytes)) -> IO () forall a b. (a -> b) -> a -> b $ \Map RefDigest ScrubbedBytes fkeys -> do MVar (Map RefDigest ScrubbedBytes) -> (Map RefDigest ScrubbedBytes -> IO (Map RefDigest ScrubbedBytes)) -> IO () forall a. MVar a -> (a -> IO a) -> IO () modifyMVar_ MVar (Map RefDigest ScrubbedBytes) toKeys ((Map RefDigest ScrubbedBytes -> IO (Map RefDigest ScrubbedBytes)) -> IO ()) -> (Map RefDigest ScrubbedBytes -> IO (Map RefDigest ScrubbedBytes)) -> IO () forall a b. (a -> b) -> a -> b $ Map RefDigest ScrubbedBytes -> IO (Map RefDigest ScrubbedBytes) forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return (Map RefDigest ScrubbedBytes -> IO (Map RefDigest ScrubbedBytes)) -> (Map RefDigest ScrubbedBytes -> Map RefDigest ScrubbedBytes) -> Map RefDigest ScrubbedBytes -> IO (Map RefDigest ScrubbedBytes) forall b c a. (b -> c) -> (a -> b) -> a -> c . Map RefDigest ScrubbedBytes -> Map RefDigest ScrubbedBytes -> Map RefDigest ScrubbedBytes forall k a. Ord k => Map k a -> Map k a -> Map k a M.union Map RefDigest ScrubbedBytes fkeys Map RefDigest ScrubbedBytes -> IO (Map RefDigest ScrubbedBytes) forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return Map RefDigest ScrubbedBytes forall k a. Map k a M.empty