Key handling in MonadStorage class

11 files changed, 65 insertions, 41 deletions

diff --git a/src/Erebos/Chatroom.hs b/src/Erebos/Chatroom.hs
index c050381..a7ba46d 100644
--- a/src/Erebos/Chatroom.hs
+++ b/src/Erebos/Chatroom.hs
@@ -201,17 +201,17 @@ threadToListSince since thread = helper (S.fromList since) thread
     cmpView msg = (zonedTimeToUTC $ mdTime $ fromSigned msg, msg)
 
 sendChatroomMessage
-    :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e)
+    :: (MonadHead LocalState m, MonadIO m, MonadError e m, FromErebosError e)
     => ChatroomState -> Text -> m ()
 sendChatroomMessage rstate msg = sendChatroomMessageByStateData (head $ roomStateData rstate) msg
 
 sendChatroomMessageByStateData
-    :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e)
+    :: (MonadHead LocalState m, MonadIO m, MonadError e m, FromErebosError e)
     => Stored ChatroomStateData -> Text -> m ()
 sendChatroomMessageByStateData lookupData msg = sendRawChatroomMessageByStateData lookupData Nothing Nothing (Just msg) False
 
 sendRawChatroomMessageByStateData
-    :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e)
+    :: (MonadHead LocalState m, MonadIO m, MonadError e m, FromErebosError e)
     => Stored ChatroomStateData -> Maybe UnifiedIdentity -> Maybe (Stored (Signed ChatMessageData)) -> Maybe Text -> Bool -> m ()
 sendRawChatroomMessageByStateData lookupData mbIdentity mdReplyTo mdText mdLeave = void $ findAndUpdateChatroomState $ \cstate -> do
     guard $ any (lookupData `precedesOrEquals`) $ roomStateData cstate
@@ -220,7 +220,7 @@ sendRawChatroomMessageByStateData lookupData mbIdentity mdReplyTo mdText mdLeave
             | Just identity <- mbIdentity -> return identity
             | Just identity <- roomStateIdentity cstate -> return identity
             | otherwise -> localIdentity . fromStored <$> getLocalHead
-        secret <- loadKey $ idKeyMessage mdFrom
+        secret <- mloadKey $ idKeyMessage mdFrom
         mdTime <- liftIO getZonedTime
         let mdPrev = roomStateMessageData cstate
             mdRoom = if null (roomStateMessageData cstate)
@@ -317,7 +317,7 @@ createChatroom rdName rdDescription = do
         (, cstate) <$> storeSetAdd cstate rooms
 
 findAndUpdateChatroomState
-    :: (MonadStorage m, MonadHead LocalState m)
+    :: (MonadHead LocalState m, MonadError e m, FromErebosError e)
     => (ChatroomState -> Maybe (m ChatroomState))
     -> m (Maybe ChatroomState)
 findAndUpdateChatroomState f = do
@@ -335,7 +335,7 @@ findAndUpdateChatroomState f = do
             [] -> return (roomSet, Nothing)
 
 deleteChatroomByStateData
-    :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e)
+    :: (MonadHead LocalState m, MonadError e m, FromErebosError e)
     => Stored ChatroomStateData -> m ()
 deleteChatroomByStateData lookupData = void $ findAndUpdateChatroomState $ \cstate -> do
     guard $ any (lookupData `precedesOrEquals`) $ roomStateData cstate
@@ -346,7 +346,7 @@ deleteChatroomByStateData lookupData = void $ findAndUpdateChatroomState $ \csta
             }
 
 updateChatroomByStateData
-    :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e)
+    :: (MonadHead LocalState m, MonadError e m, FromErebosError e)
     => Stored ChatroomStateData
     -> Maybe Text
     -> Maybe Text
@@ -355,7 +355,7 @@ updateChatroomByStateData lookupData newName newDesc = findAndUpdateChatroomStat
     guard $ any (lookupData `precedesOrEquals`) $ roomStateData cstate
     room <- roomStateRoom cstate
     Just $ do
-        secret <- loadKey $ roomKey room
+        secret <- mloadKey $ roomKey room
         rdata <- mstore =<< sign secret =<< mstore ChatroomData
             { rdPrev = roomData room
             , rdName = newName
@@ -386,7 +386,7 @@ findChatroomByStateData :: MonadHead LocalState m => Stored ChatroomStateData ->
 findChatroomByStateData cdata = findChatroom $ any (cdata `precedesOrEquals`) . roomStateData
 
 chatroomSetSubscribe
-    :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e)
+    :: (MonadHead LocalState m, MonadError e m, FromErebosError e)
     => Stored ChatroomStateData -> Bool -> m ()
 chatroomSetSubscribe lookupData subscribe = void $ findAndUpdateChatroomState $ \cstate -> do
     guard $ any (lookupData `precedesOrEquals`) $ roomStateData cstate
@@ -407,32 +407,32 @@ chatroomMembers ChatroomState {..} =
     toList $ ancestors $ roomStateMessageData
 
 joinChatroom
-    :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e)
+    :: (MonadHead LocalState m, MonadIO m, MonadError e m, FromErebosError e)
     => ChatroomState -> m ()
 joinChatroom rstate = joinChatroomByStateData (head $ roomStateData rstate)
 
 joinChatroomByStateData
-    :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e)
+    :: (MonadHead LocalState m, MonadIO m, MonadError e m, FromErebosError e)
     => Stored ChatroomStateData -> m ()
 joinChatroomByStateData lookupData = sendRawChatroomMessageByStateData lookupData Nothing Nothing Nothing False
 
 joinChatroomAs
-    :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e)
+    :: (MonadHead LocalState m, MonadIO m, MonadError e m, FromErebosError e)
     => UnifiedIdentity -> ChatroomState -> m ()
 joinChatroomAs identity rstate = joinChatroomAsByStateData identity (head $ roomStateData rstate)
 
 joinChatroomAsByStateData
-    :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e)
+    :: (MonadHead LocalState m, MonadIO m, MonadError e m, FromErebosError e)
     => UnifiedIdentity -> Stored ChatroomStateData -> m ()
 joinChatroomAsByStateData identity lookupData = sendRawChatroomMessageByStateData lookupData (Just identity) Nothing Nothing False
 
 leaveChatroom
-    :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e)
+    :: (MonadHead LocalState m, MonadIO m, MonadError e m, FromErebosError e)
     => ChatroomState -> m ()
 leaveChatroom rstate = leaveChatroomByStateData (head $ roomStateData rstate)
 
 leaveChatroomByStateData
-    :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e)
+    :: (MonadHead LocalState m, MonadIO m, MonadError e m, FromErebosError e)
     => Stored ChatroomStateData -> m ()
 leaveChatroomByStateData lookupData = sendRawChatroomMessageByStateData lookupData Nothing Nothing Nothing True
 
diff --git a/src/Erebos/Conversation.hs b/src/Erebos/Conversation.hs
index 844b5dd..15792e1 100644
--- a/src/Erebos/Conversation.hs
+++ b/src/Erebos/Conversation.hs
@@ -33,6 +33,7 @@ module Erebos.Conversation (
 ) where
 
 import Control.Monad.Except
+import Control.Monad.IO.Class
 
 import Data.List
 import Data.Maybe
@@ -159,7 +160,7 @@ conversationHistoryChange :: Conversation -> Conversation -> ( Int, [ Message ]
 conversationHistoryChange = withConversations $ \since -> fmap (map (uncurry Message)) . convMessageListSince since
 
 
-sendMessage :: (MonadHead LocalState m, MonadError e m, FromErebosError e) => Conversation -> Text -> m ()
+sendMessage :: (MonadHead LocalState m, MonadIO m, MonadError e m, FromErebosError e) => Conversation -> Text -> m ()
 sendMessage (DirectMessageConversation thread) text = sendDirectMessage (msgPeer thread) text
 sendMessage (ChatroomConversation rstate) text = sendChatroomMessage rstate text
 
diff --git a/src/Erebos/DirectMessage.hs b/src/Erebos/DirectMessage.hs
index ed2c2b4..e3e5e97 100644
--- a/src/Erebos/DirectMessage.hs
+++ b/src/Erebos/DirectMessage.hs
@@ -213,7 +213,7 @@ findMsgPropertyUpdate :: Property MessageState [ a ] -> [ Stored MessageState ]
 findMsgPropertyUpdate prev mss = findPropertyUpdate prev mss
 
 
-sendDirectMessage :: (Foldable f, Applicative f, MonadHead LocalState m)
+sendDirectMessage :: (Foldable f, Applicative f, MonadHead LocalState m, MonadIO m)
                   => Identity f -> Text -> m ()
 sendDirectMessage pid text = updateLocalState_ $ \ls -> do
     let self = localIdentity $ fromStored ls
diff --git a/src/Erebos/Identity.hs b/src/Erebos/Identity.hs
index 491df6e..8c3760c 100644
--- a/src/Erebos/Identity.hs
+++ b/src/Erebos/Identity.hs
@@ -325,7 +325,7 @@ lookupProperty sel topHeads = findResult propHeads
     findResult [] = Nothing
     findResult xs = sel $ fromSigned $ minimum xs
 
-mergeIdentity :: (MonadStorage m, MonadError e m, FromErebosError e, MonadIO m) => Identity f -> m UnifiedIdentity
+mergeIdentity :: (MonadStorage m, MonadError e m, FromErebosError e) => Identity f -> m UnifiedIdentity
 mergeIdentity idt | Just idt' <- toUnifiedIdentity idt = return idt'
 mergeIdentity idt@Identity {..} = do
     (owner, ownerData) <- case idOwner_ of
@@ -335,7 +335,7 @@ mergeIdentity idt@Identity {..} = do
                                       return (Just owner, Just $ idData owner)
 
     let public = idKeyIdentity idt
-    secret <- loadKey public
+    secret <- mloadKey public
 
     unifiedBaseData <-
         case toList $ idDataF idt of
diff --git a/src/Erebos/Invite.hs b/src/Erebos/Invite.hs
index 5b35506..890450b 100644
--- a/src/Erebos/Invite.hs
+++ b/src/Erebos/Invite.hs
@@ -165,7 +165,7 @@ instance SharedType (Set AcceptedInvite) where
     sharedTypeID _ = mkSharedTypeID "b1ebf228-4892-476b-ba04-0c26320139b1"
 
 
-createSingleContactInvite :: MonadHead LocalState m => Text -> m Invite
+createSingleContactInvite :: (MonadHead LocalState m, MonadIO m) => Text -> m Invite
 createSingleContactInvite name = do
     time <- liftIO getZonedTime
     token <- liftIO $ getRandomBytes 32
diff --git a/src/Erebos/State.hs b/src/Erebos/State.hs
index d930248..d74dddb 100644
--- a/src/Erebos/State.hs
+++ b/src/Erebos/State.hs
@@ -112,7 +112,7 @@ instance SharedType (Maybe ComposedIdentity) where
     sharedTypeID _ = mkSharedTypeID "0c6c1fe0-f2d7-4891-926b-c332449f7871"
 
 
-class (MonadIO m, MonadStorage m, HeadType a) => MonadHead a m where
+class (MonadStorage m, HeadType a) => MonadHead a m where
     updateLocalHead :: (Stored a -> m (Stored a, b)) -> m b
     getLocalHead :: m (Stored a)
     getLocalHead = updateLocalHead $ \x -> return (x, x)
diff --git a/src/Erebos/Storable.hs b/src/Erebos/Storable.hs
index ddbe06c..72e9c6e 100644
--- a/src/Erebos/Storable.hs
+++ b/src/Erebos/Storable.hs
@@ -36,7 +36,7 @@ module Erebos.Storable (
     copyStored,
     unsafeMapStored,
 
-    Storage, MonadStorage(..),
+    Storage, MonadStorage(..), mloadKey,
 
     module Erebos.Error,
 ) where
@@ -44,3 +44,4 @@ module Erebos.Storable (
 import Erebos.Error
 import Erebos.Object.Internal
 import Erebos.Storable.Internal
+import Erebos.Storage.Monad
diff --git a/src/Erebos/Storable/Internal.hs b/src/Erebos/Storable/Internal.hs
index 70b5fdc..72b70e1 100644
--- a/src/Erebos/Storable/Internal.hs
+++ b/src/Erebos/Storable/Internal.hs
@@ -10,8 +10,6 @@ module Erebos.Storable.Internal (
     unsafeMapStored,
 
     collectObjects, collectStoredObjects,
-
-    MonadStorage(..),
 ) where
 
 import Control.Monad.Reader
@@ -20,9 +18,8 @@ import Data.Function
 import Data.Set (Set)
 import Data.Set qualified as S
 
-import Erebos.Storage.Internal
-
 import Erebos.Object.Internal
+import Erebos.Storage.Internal
 
 
 data Stored a = Stored
@@ -88,16 +85,3 @@ collectOtherStored seen (Rec items) = foldr helper ( [], seen ) $ map snd items
                  in ((o : xs') ++ xs, s')
           helper _ ( xs, s ) = ( xs, s )
 collectOtherStored seen _ = ( [], seen )
-
-
-class Monad m => MonadStorage m where
-    getStorage :: m Storage
-    mstore :: Storable a => a -> m (Stored a)
-
-    default mstore :: MonadIO m => Storable a => a -> m (Stored a)
-    mstore x = do
-        st <- getStorage
-        wrappedStore st x
-
-instance MonadIO m => MonadStorage (ReaderT Storage m) where
-    getStorage = ask
diff --git a/src/Erebos/Storage.hs b/src/Erebos/Storage.hs
index f6ee200..a2d497f 100644
--- a/src/Erebos/Storage.hs
+++ b/src/Erebos/Storage.hs
@@ -20,11 +20,11 @@ module Erebos.Storage (
     watchHead, watchHeadWith, unwatchHead,
     watchHeadRaw,
 
-    MonadStorage(..),
+    MonadStorage(..), mloadKey,
 ) where
 
 import Erebos.Object.Internal
-import Erebos.Storable.Internal
 import Erebos.Storage.Disk
 import Erebos.Storage.Head
 import Erebos.Storage.Memory
+import Erebos.Storage.Monad
diff --git a/src/Erebos/Storage/Head.hs b/src/Erebos/Storage/Head.hs
index 343669a..7e38af8 100644
--- a/src/Erebos/Storage/Head.hs
+++ b/src/Erebos/Storage/Head.hs
@@ -36,6 +36,7 @@ import Erebos.Object.Internal
 import Erebos.Storable.Internal
 import Erebos.Storage.Backend
 import Erebos.Storage.Internal
+import Erebos.Storage.Monad
 import Erebos.UUID qualified as U
 
 
diff --git a/src/Erebos/Storage/Monad.hs b/src/Erebos/Storage/Monad.hs
new file mode 100644
index 0000000..6af3ae1
--- /dev/null
+++ b/src/Erebos/Storage/Monad.hs
@@ -0,0 +1,37 @@
+module Erebos.Storage.Monad (
+    MonadStorage(..),
+    mloadKey,
+) where
+
+import Control.Monad.Except
+import Control.Monad.Reader
+
+import Erebos.Error
+import Erebos.Object.Internal
+import Erebos.Storable.Internal
+import Erebos.Storage.Key
+
+
+class Monad m => MonadStorage m where
+    getStorage :: m Storage
+    mstore :: Storable a => a -> m (Stored a)
+
+    default mstore :: MonadIO m => Storable a => a -> m (Stored a)
+    mstore x = do
+        st <- getStorage
+        wrappedStore st x
+
+    mstoreKey :: KeyPair sec pub => sec -> m ()
+    default mstoreKey :: (KeyPair sec pub, MonadIO m) => sec -> m ()
+    mstoreKey = liftIO . storeKey
+
+    mloadKeyMb :: KeyPair sec pub => Stored pub -> m (Maybe sec)
+    default mloadKeyMb :: (KeyPair sec pub, MonadIO m) => Stored pub -> m (Maybe sec)
+    mloadKeyMb = loadKeyMb
+
+mloadKey :: (KeyPair sec pub, MonadStorage m, MonadError e m, FromErebosError e) => Stored pub -> m sec
+mloadKey pub = maybe (throwOtherError $ "secret key not found for " <> show (storedRef pub)) return =<< mloadKeyMb pub
+
+
+instance MonadIO m => MonadStorage (ReaderT Storage m) where
+    getStorage = ask