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