summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2023-07-02 21:38:45 +0200
committerRoman Smrž <roman.smrz@seznam.cz>2023-07-02 21:52:57 +0200
commit2278e5f103ed9c4f0e2c28bed82aae3639e7b46f (patch)
tree29103482b8e8d701e7277784857852770bdf7f9c /src
parentedafccea465f1f9448a1a7ae555b8615e5b5ac1b (diff)
Send direct message using local head monad
Diffstat (limited to 'src')
-rw-r--r--src/Main.hs2
-rw-r--r--src/Message.hs51
-rw-r--r--src/Test.hs3
3 files changed, 28 insertions, 28 deletions
diff --git a/src/Main.hs b/src/Main.hs
index cdaa9ae..1aaa4f7 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -288,7 +288,7 @@ cmdSend = void $ do
ehead <- asks ciHead
Just peer <- gets csPeer
text <- asks ciLine
- smsg <- sendDirectMessage ehead peer $ T.pack text
+ smsg <- flip runReaderT ehead $ sendDirectMessage peer $ T.pack text
tzone <- liftIO $ getCurrentTimeZone
liftIO $ putStrLn $ formatMessage tzone $ fromStored smsg
diff --git a/src/Message.hs b/src/Message.hs
index ba45518..39e13dd 100644
--- a/src/Message.hs
+++ b/src/Message.hs
@@ -147,33 +147,34 @@ findMsgProperty pid sel mss = concat $ flip findProperty mss $ \x -> do
return $ sel x
-sendDirectMessage :: (MonadIO m, MonadError String m) => Head LocalState -> Peer -> Text -> m (Stored DirectMessage)
-sendDirectMessage h peer text = do
+sendDirectMessage :: (MonadHead LocalState m, MonadError String m) => Peer -> Text -> m (Stored DirectMessage)
+sendDirectMessage peer text = do
pid <- peerIdentity peer >>= \case PeerIdentityFull pid -> return pid
_ -> throwError "incomplete peer identity"
- let st = refStorage $ headRef h
- self = headLocalIdentity h
- powner = finalOwner pid
-
- smsg <- flip runReaderT h $ updateLocalHead $ updateSharedState $ \(DirectMessageThreads prev _) -> liftIO $ do
- let sent = findMsgProperty powner msSent prev
- received = findMsgProperty powner msReceived prev
-
- time <- getZonedTime
- smsg <- wrappedStore st DirectMessage
- { msgFrom = toComposedIdentity $ finalOwner self
- , msgPrev = filterAncestors $ sent ++ received
- , msgTime = time
- , msgText = text
- }
- next <- wrappedStore st $ MessageState
- { msPrev = prev
- , msPeer = powner
- , msSent = [smsg]
- , msReceived = []
- , msSeen = []
- }
- return (DirectMessageThreads [next] (messageThreadView [next]), smsg)
+ let powner = finalOwner pid
+
+ smsg <- updateLocalHead $ \ls -> do
+ let st = storedStorage ls
+ self = localIdentity $ fromStored ls
+ flip updateSharedState ls $ \(DirectMessageThreads prev _) -> liftIO $ do
+ let sent = findMsgProperty powner msSent prev
+ received = findMsgProperty powner msReceived prev
+
+ time <- getZonedTime
+ smsg <- wrappedStore st DirectMessage
+ { msgFrom = toComposedIdentity $ finalOwner self
+ , msgPrev = filterAncestors $ sent ++ received
+ , msgTime = time
+ , msgText = text
+ }
+ next <- wrappedStore st $ MessageState
+ { msPrev = prev
+ , msPeer = powner
+ , msSent = [smsg]
+ , msReceived = []
+ , msSeen = []
+ }
+ return (DirectMessageThreads [next] (messageThreadView [next]), smsg)
sendToPeerStored peer smsg
return smsg
diff --git a/src/Test.hs b/src/Test.hs
index 84505c2..678be18 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -492,6 +492,5 @@ cmdContactSetName = do
cmdDmSendPeer :: Command
cmdDmSendPeer = do
[spidx, msg] <- asks tiParams
- h <- getHead
peer <- getPeer spidx
- void $ sendDirectMessage h peer msg
+ void $ sendDirectMessage peer msg