summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2023-07-17 21:30:21 +0200
committerRoman Smrž <roman.smrz@seznam.cz>2023-07-19 23:26:39 +0200
commitaa83cb804105594d43c2002352f2b1d9f9db3c45 (patch)
treef1f1caa82ca74ce5d9c628e91f43e47999177692 /src
parent95449bb4b93cf10468c47b27f20396d916c46778 (diff)
Send direct messages using identity
Diffstat (limited to 'src')
-rw-r--r--src/Main.hs5
-rw-r--r--src/Message.hs52
-rw-r--r--src/Test.hs22
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