From f93392b5f716220e33c3e59a2d70206aee49d65e Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Fri, 7 Apr 2023 20:36:35 +0200
Subject: Test: direct messages to peer

---
 src/Message.hs | 26 +++++++++++++++++++++++---
 src/Test.hs    | 35 ++++++++++++++++++++++++++++++++---
 2 files changed, 55 insertions(+), 6 deletions(-)

diff --git a/src/Message.hs b/src/Message.hs
index 06117fe..a97e52f 100644
--- a/src/Message.hs
+++ b/src/Message.hs
@@ -2,6 +2,9 @@ module Message (
     DirectMessage(..),
     sendDirectMessage,
 
+    DirectMessageAttributes(..),
+    defaultDirectMessageAttributes,
+
     DirectMessageThreads,
     toThreadList,
 
@@ -50,13 +53,29 @@ instance Storable DirectMessage where
         <*> loadDate "time"
         <*> loadText "text"
 
+data DirectMessageAttributes = DirectMessageAttributes
+    { dmReceived :: Stored DirectMessage -> ServiceHandler DirectMessage ()
+    , dmOwnerMismatch :: ServiceHandler DirectMessage ()
+    }
+
+defaultDirectMessageAttributes :: DirectMessageAttributes
+defaultDirectMessageAttributes = DirectMessageAttributes
+    { dmReceived = \msg -> do
+        tzone <- liftIO $ getCurrentTimeZone
+        svcPrint $ formatMessage tzone $ fromStored msg
+
+    , dmOwnerMismatch = svcPrint "Owner mismatch"
+    }
+
 instance Service DirectMessage where
     serviceID _ = mkServiceID "c702076c-4928-4415-8b6b-3e839eafcb0d"
 
+    type ServiceAttributes DirectMessage = DirectMessageAttributes
+    defaultServiceAttributes _ = defaultDirectMessageAttributes
+
     serviceHandler smsg = do
         let msg = fromStored smsg
         powner <- asks $ finalOwner . svcPeerIdentity
-        tzone <- liftIO $ getCurrentTimeZone
         erb <- svcGetLocal
         let st = storedStorage erb
             DirectMessageThreads prev _ = lookupSharedValue $ lsShared $ fromStored erb
@@ -78,10 +97,11 @@ instance Service DirectMessage where
                    wrappedStore st (fromStored erb) { lsShared = [shared] }
                svcSetLocal erb'
                when (powner `sameIdentity` msgFrom msg) $ do
-                   svcPrint $ formatMessage tzone msg
+                   hook <- asks $ dmReceived . svcAttributes
+                   hook smsg
                    replyStoredRef smsg
 
-           else svcPrint "Owner mismatch"
+           else join $ asks $ dmOwnerMismatch . svcAttributes
 
 
 data MessageState = MessageState
diff --git a/src/Test.hs b/src/Test.hs
index 7b06831..f9f764b 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -28,6 +28,7 @@ import System.IO.Error
 import Attach
 import Contact
 import Identity
+import Message
 import Network
 import Pairing
 import PubKey
@@ -91,6 +92,12 @@ getLines = getLineMb >>= \case
     Just line | not (T.null line) -> (line:) <$> getLines
     _ -> return []
 
+getHead :: CommandM (Head LocalState)
+getHead = do
+    h <- maybe (fail "failed to reload head") return =<< maybe (fail "no current head") reloadHead =<< gets tsHead
+    modify $ \s -> s { tsHead = Just h }
+    return h
+
 
 type Output = MVar ()
 
@@ -180,6 +187,19 @@ pairingAttributes _ out peers prefix = PairingAttributes
             PairingAccept {} -> "accept"
             PairingReject -> "reject"
 
+directMessageAttributes :: Output -> DirectMessageAttributes
+directMessageAttributes out = DirectMessageAttributes
+    { dmReceived = \smsg -> do
+        let msg = fromStored smsg
+        afterCommit $ outLine out $ unwords
+            [ "dm-received"
+            , "from", maybe "<unnamed>" T.unpack $ idName $ msgFrom msg
+            , "text", T.unpack $ msgText msg
+            ]
+
+    , dmOwnerMismatch = afterCommit $ outLine out "dm-owner-mismatch"
+    }
+
 
 newtype CommandM a = CommandM (ReaderT TestInput (StateT TestState (ExceptT String IO)) a)
     deriving (Functor, Applicative, Monad, MonadIO, MonadReader TestInput, MonadState TestState, MonadError String)
@@ -225,6 +245,7 @@ commands = map (T.pack *** id)
     , ("contact-reject", cmdContactReject)
     , ("contact-list", cmdContactList)
     , ("contact-set-name", cmdContactSetName)
+    , ("dm-send-peer", cmdDmSendPeer)
     ]
 
 cmdStore :: Command
@@ -301,6 +322,7 @@ cmdStartServer = do
     server <- liftIO $ startServer defaultServerOptions h (hPutStrLn stderr)
         [ someServiceAttr $ pairingAttributes (Proxy @AttachService) out peers "attach"
         , someServiceAttr $ pairingAttributes (Proxy @ContactService) out peers "contact"
+        , someServiceAttr $ directMessageAttributes out
         , someService @SyncService Proxy
         ]
 
@@ -327,7 +349,7 @@ cmdStartServer = do
 
 cmdSharedStateGet :: Command
 cmdSharedStateGet = do
-    h <- maybe (fail "failed to reload head") return =<< maybe (fail "no current head") reloadHead =<< gets tsHead
+    h <- getHead
     cmdOut $ unwords $ "shared-state-get" : map (show . refDigest . storedRef) (lsShared $ headObject h)
 
 cmdSharedStateWait :: Command
@@ -435,7 +457,7 @@ cmdContactReject = do
 
 cmdContactList :: Command
 cmdContactList = do
-    h <- maybe (fail "failed to reload head") return =<< maybe (fail "no current head") reloadHead =<< gets tsHead
+    h <- getHead
     let contacts = fromSetBy (comparing contactName) . lookupSharedValue . lsShared . headObject $ h
     forM_ contacts $ \c -> do
         r:_ <- return $ filterAncestors $ concatMap storedRoots $ toComponents c
@@ -451,10 +473,17 @@ cmdContactList = do
 cmdContactSetName :: Command
 cmdContactSetName = do
     [cid, name] <- asks tiParams
-    h <- maybe (fail "failed to reload head") return =<< maybe (fail "no current head") reloadHead =<< gets tsHead
+    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
     updateSharedState_ $ contactSetName contact name
     cmdOut "contact-set-name-done"
+
+cmdDmSendPeer :: Command
+cmdDmSendPeer = do
+    [spidx, msg] <- asks tiParams
+    h <- getHead
+    peer <- getPeer spidx
+    void $ sendDirectMessage h peer msg
-- 
cgit v1.2.3