diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Main.hs | 5 | ||||
| -rw-r--r-- | src/Message.hs | 52 | ||||
| -rw-r--r-- | src/Test.hs | 22 |
3 files changed, 46 insertions, 33 deletions
diff --git a/src/Main.hs b/src/Main.hs index aee0cc6..a84e820 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -303,7 +303,10 @@ cmdSend :: Command cmdSend = void $ do Just peer <- gets csPeer text <- asks ciLine - smsg <- sendDirectMessage peer $ T.pack text + powner <- peerIdentity peer >>= \case + PeerIdentityFull pid -> return $ finalOwner pid + _ -> throwError "incomplete peer identity" + smsg <- sendDirectMessage powner $ T.pack text tzone <- liftIO $ getCurrentTimeZone liftIO $ putStrLn $ formatMessage tzone $ fromStored smsg diff --git a/src/Message.hs b/src/Message.hs index 53283a5..41a88b0 100644 --- a/src/Message.hs +++ b/src/Message.hs @@ -150,33 +150,31 @@ findMsgProperty pid sel mss = concat $ flip findProperty mss $ \x -> do return $ sel x -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 powner = finalOwner pid - 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) +sendDirectMessage :: (Foldable f, Applicative f, MonadHead LocalState m, MonadError String m) + => Identity f -> Text -> m (Stored DirectMessage) +sendDirectMessage pid text = updateLocalHead $ \ls -> do + let st = storedStorage ls + self = localIdentity $ fromStored ls + powner = finalOwner pid + 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) syncDirectMessageToPeer :: DirectMessageThreads -> ServiceHandler DirectMessage () syncDirectMessageToPeer (DirectMessageThreads mss _) = do diff --git a/src/Test.hs b/src/Test.hs index c0b8aed..7694322 100644 --- a/src/Test.hs +++ b/src/Test.hs @@ -249,6 +249,7 @@ commands = map (T.pack *** id) , ("contact-list", cmdContactList) , ("contact-set-name", cmdContactSetName) , ("dm-send-peer", cmdDmSendPeer) + , ("dm-send-contact", cmdDmSendContact) ] cmdStore :: Command @@ -480,19 +481,30 @@ cmdContactList = do ] cmdOut "contact-list-done" -cmdContactSetName :: Command -cmdContactSetName = do - [cid, name] <- asks tiParams +getContact :: Text -> CommandM Contact +getContact cid = do h <- getHead let contacts = fromSetBy (comparing contactName) . lookupSharedValue . lsShared . headObject $ h [contact] <- flip filterM contacts $ \c -> do r:_ <- return $ filterAncestors $ concatMap storedRoots $ toComponents c return $ T.pack (show $ refDigest $ storedRef r) == cid + return contact + +cmdContactSetName :: Command +cmdContactSetName = do + [cid, name] <- asks tiParams + contact <- getContact cid updateLocalHead_ $ updateSharedState_ $ contactSetName contact name cmdOut "contact-set-name-done" cmdDmSendPeer :: Command cmdDmSendPeer = do [spidx, msg] <- asks tiParams - peer <- getPeer spidx - void $ sendDirectMessage peer msg + PeerIdentityFull to <- peerIdentity =<< getPeer spidx + void $ sendDirectMessage to msg + +cmdDmSendContact :: Command +cmdDmSendContact = do + [cid, msg] <- asks tiParams + Just to <- contactIdentity <$> getContact cid + void $ sendDirectMessage to msg |