Send direct messages using identity

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