diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Message.hs | 26 | ||||
| -rw-r--r-- | 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 |