diff options
| -rw-r--r-- | src/Main.hs | 2 | ||||
| -rw-r--r-- | src/Message.hs | 51 | ||||
| -rw-r--r-- | src/Test.hs | 3 |
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 |