diff options
| author | Roman Smrž <roman.smrz@seznam.cz> | 2023-07-13 18:39:01 +0200 |
|---|---|---|
| committer | Roman Smrž <roman.smrz@seznam.cz> | 2023-07-19 23:26:39 +0200 |
| commit | 95449bb4b93cf10468c47b27f20396d916c46778 (patch) | |
| tree | 29c1b971fa691a7b9e046c263c0b20f88dc5585c /src/Test.hs | |
| parent | ba636680dc5fdd7d5db81248e4fa737d026f985f (diff) | |
Send and receive direct messages through storage
Diffstat (limited to 'src/Test.hs')
| -rw-r--r-- | src/Test.hs | 20 |
1 files changed, 11 insertions, 9 deletions
diff --git a/src/Test.hs b/src/Test.hs index 678be18..c0b8aed 100644 --- a/src/Test.hs +++ b/src/Test.hs @@ -190,17 +190,18 @@ pairingAttributes _ out peers prefix = PairingAttributes 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" + { dmOwnerMismatch = afterCommit $ outLine out "dm-owner-mismatch" } +dmReceivedWatcher :: Output -> Stored DirectMessage -> IO () +dmReceivedWatcher out smsg = do + let msg = fromStored smsg + outLine out $ unwords + [ "dm-received" + , "from", maybe "<unnamed>" T.unpack $ idName $ msgFrom msg + , "text", T.unpack $ msgText msg + ] + newtype CommandM a = CommandM (ReaderT TestInput (StateT TestState (ExceptT String IO)) a) deriving (Functor, Applicative, Monad, MonadIO, MonadReader TestInput, MonadState TestState, MonadError String) @@ -313,6 +314,7 @@ cmdCreateIdentity = do , lsShared = shared } + _ <- liftIO . watchReceivedMessages h . dmReceivedWatcher =<< asks tiOutput modify $ \s -> s { tsHead = Just h } cmdStartServer :: Command |