summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Message.hs26
-rw-r--r--src/Test.hs35
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