summaryrefslogtreecommitdiff
path: root/src/Erebos
diff options
context:
space:
mode:
Diffstat (limited to 'src/Erebos')
-rw-r--r--src/Erebos/Chatroom.hs30
-rw-r--r--src/Erebos/Conversation.hs3
-rw-r--r--src/Erebos/DirectMessage.hs2
-rw-r--r--src/Erebos/Identity.hs4
-rw-r--r--src/Erebos/Invite.hs2
-rw-r--r--src/Erebos/State.hs2
-rw-r--r--src/Erebos/Storable.hs3
-rw-r--r--src/Erebos/Storable/Internal.hs18
-rw-r--r--src/Erebos/Storage.hs4
-rw-r--r--src/Erebos/Storage/Head.hs1
-rw-r--r--src/Erebos/Storage/Monad.hs37
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
generated by cgit v1.2.3 (git 2.25.1) at 2026-08-19 00:53:14 +0000