diff options
Diffstat (limited to 'main/Test.hs')
| -rw-r--r-- | main/Test.hs | 355 |
1 files changed, 253 insertions, 102 deletions
diff --git a/main/Test.hs b/main/Test.hs index a119b0f..da49257 100644 --- a/main/Test.hs +++ b/main/Test.hs @@ -15,10 +15,12 @@ import Control.Monad.State import Crypto.Random import Data.Bool +import Data.ByteString (ByteString) import Data.ByteString qualified as B import Data.ByteString.Char8 qualified as BC import Data.ByteString.Lazy qualified as BL import Data.ByteString.Lazy.Char8 qualified as BL +import Data.Char import Data.Foldable import Data.Ord import Data.Text (Text) @@ -39,6 +41,7 @@ import Erebos.Contact import Erebos.DirectMessage import Erebos.Discovery import Erebos.Identity +import Erebos.Invite import Erebos.Network import Erebos.Object import Erebos.Pairing @@ -117,9 +120,9 @@ runTestTool st = do getLineMb :: MonadIO m => m (Maybe Text) getLineMb = liftIO $ catchIOError (Just <$> T.getLine) (\e -> if isEOFError e then return Nothing else ioError e) -getLines :: MonadIO m => m [Text] -getLines = getLineMb >>= \case - Just line | not (T.null line) -> (line:) <$> getLines +getLines :: MonadIO m => Text -> m [ Text ] +getLines eof = getLineMb >>= \case + Just line | line /= eof -> (line :) <$> getLines eof _ -> return [] getHead :: CommandM (Head LocalState) @@ -128,6 +131,26 @@ getHead = do modify $ \s -> s { tsHead = Just h } return h +showHex :: ByteString -> ByteString +showHex = B.concat . map showHexByte . B.unpack + where showHexChar x | x < 10 = x + o '0' + | otherwise = x + o 'a' - 10 + showHexByte x = B.pack [ showHexChar (x `div` 16), showHexChar (x `mod` 16) ] + o = fromIntegral . ord + +readHex :: ByteString -> Maybe ByteString +readHex = return . B.concat <=< readHex' + where readHex' bs | B.null bs = Just [] + readHex' bs = do (bx, bs') <- B.uncons bs + (by, bs'') <- B.uncons bs' + x <- hexDigit bx + y <- hexDigit by + (B.singleton (x * 16 + y) :) <$> readHex' bs'' + hexDigit x | x >= o '0' && x <= o '9' = Just $ x - o '0' + | x >= o 'a' && x <= o 'z' = Just $ x - o 'a' + 10 + | otherwise = Nothing + o = fromIntegral . ord + type Output = MVar () @@ -227,14 +250,33 @@ directMessageAttributes out = DirectMessageAttributes { 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 - ] +discoveryAttributes :: DiscoveryAttributes +discoveryAttributes = (defaultServiceAttributes Proxy) + { discoveryProvideTunnel = \_ _ -> False + } + +inviteAttributes :: Output -> InviteServiceAttributes +inviteAttributes out = (defaultServiceAttributes Proxy) + { inviteHookAccepted = \token -> do + pid <- asks svcPeerIdentity + afterCommit $ outLine out $ "invite-accepted " <> BC.unpack (showHex token) <> " " <> (BC.unpack $ showRef $ storedRef $ idExtData pid) + , inviteHookReplyContact = \token _ -> do + afterCommit $ outLine out $ "invite-accept-done " <> BC.unpack (showHex token) <> " contact" + , inviteHookReplyInvalid = \token -> do + afterCommit $ outLine out $ "invite-accept-done " <> BC.unpack (showHex token) <> " invalid" + } + +dmThreadWatcher :: ComposedIdentity -> Output -> DirectMessageThread -> DirectMessageThread -> IO () +dmThreadWatcher self out prev cur = do + forM_ (reverse $ dmThreadToListSinceUnread prev cur) $ \( msg, new ) -> do + outLine out $ unwords + [ if sameIdentity self (msgFrom msg) + then "dm-sent" + else "dm-received" + , "from", maybe "<unnamed>" T.unpack $ idName $ msgFrom msg + , "new", if new then "yes" else "no" + , "text", T.unpack $ msgText msg + ] newtype CommandM a = CommandM (ReaderT TestInput (StateT TestState (ExceptT ErebosError IO)) a) @@ -258,63 +300,72 @@ instance MonadHead LocalState CommandM where type Command = CommandM () -commands :: [(Text, Command)] -commands = map (T.pack *** id) - [ ("store", cmdStore) - , ("load", cmdLoad) - , ("stored-generation", cmdStoredGeneration) - , ("stored-roots", cmdStoredRoots) - , ("stored-set-add", cmdStoredSetAdd) - , ("stored-set-list", cmdStoredSetList) - , ("head-create", cmdHeadCreate) - , ("head-replace", cmdHeadReplace) - , ("head-watch", cmdHeadWatch) - , ("head-unwatch", cmdHeadUnwatch) - , ("create-identity", cmdCreateIdentity) - , ("identity-info", cmdIdentityInfo) - , ("start-server", cmdStartServer) - , ("stop-server", cmdStopServer) - , ("peer-add", cmdPeerAdd) - , ("peer-drop", cmdPeerDrop) - , ("peer-list", cmdPeerList) - , ("test-message-send", cmdTestMessageSend) - , ("test-stream-open", cmdTestStreamOpen) - , ("test-stream-close", cmdTestStreamClose) - , ("test-stream-send", cmdTestStreamSend) - , ("local-state-get", cmdLocalStateGet) - , ("local-state-replace", cmdLocalStateReplace) - , ("local-state-wait", cmdLocalStateWait) - , ("shared-state-get", cmdSharedStateGet) - , ("shared-state-wait", cmdSharedStateWait) - , ("watch-local-identity", cmdWatchLocalIdentity) - , ("watch-shared-identity", cmdWatchSharedIdentity) - , ("update-local-identity", cmdUpdateLocalIdentity) - , ("update-shared-identity", cmdUpdateSharedIdentity) - , ("attach-to", cmdAttachTo) - , ("attach-accept", cmdAttachAccept) - , ("attach-reject", cmdAttachReject) - , ("contact-request", cmdContactRequest) - , ("contact-accept", cmdContactAccept) - , ("contact-reject", cmdContactReject) - , ("contact-list", cmdContactList) - , ("contact-set-name", cmdContactSetName) - , ("dm-send-peer", cmdDmSendPeer) - , ("dm-send-contact", cmdDmSendContact) - , ("dm-list-peer", cmdDmListPeer) - , ("dm-list-contact", cmdDmListContact) - , ("chatroom-create", cmdChatroomCreate) - , ("chatroom-delete", cmdChatroomDelete) - , ("chatroom-list-local", cmdChatroomListLocal) - , ("chatroom-watch-local", cmdChatroomWatchLocal) - , ("chatroom-set-name", cmdChatroomSetName) - , ("chatroom-subscribe", cmdChatroomSubscribe) - , ("chatroom-unsubscribe", cmdChatroomUnsubscribe) - , ("chatroom-members", cmdChatroomMembers) - , ("chatroom-join", cmdChatroomJoin) - , ("chatroom-join-as", cmdChatroomJoinAs) - , ("chatroom-leave", cmdChatroomLeave) - , ("chatroom-message-send", cmdChatroomMessageSend) - , ("discovery-connect", cmdDiscoveryConnect) +commands :: [ ( Text, Command ) ] +commands = + [ ( "store", cmdStore ) + , ( "store-raw", cmdStoreRaw ) + , ( "load", cmdLoad ) + , ( "load-type", cmdLoadType ) + , ( "stored-generation", cmdStoredGeneration ) + , ( "stored-roots", cmdStoredRoots ) + , ( "stored-set-add", cmdStoredSetAdd ) + , ( "stored-set-list", cmdStoredSetList ) + , ( "stored-difference", cmdStoredDifference ) + , ( "head-create", cmdHeadCreate ) + , ( "head-replace", cmdHeadReplace ) + , ( "head-watch", cmdHeadWatch ) + , ( "head-unwatch", cmdHeadUnwatch ) + , ( "create-identity", cmdCreateIdentity ) + , ( "identity-info", cmdIdentityInfo ) + , ( "start-server", cmdStartServer ) + , ( "stop-server", cmdStopServer ) + , ( "peer-add", cmdPeerAdd ) + , ( "peer-drop", cmdPeerDrop ) + , ( "peer-list", cmdPeerList ) + , ( "test-message-send", cmdTestMessageSend ) + , ( "test-stream-open", cmdTestStreamOpen ) + , ( "test-stream-close", cmdTestStreamClose ) + , ( "test-stream-send", cmdTestStreamSend ) + , ( "local-state-get", cmdLocalStateGet ) + , ( "local-state-replace", cmdLocalStateReplace ) + , ( "local-state-wait", cmdLocalStateWait ) + , ( "shared-state-get", cmdSharedStateGet ) + , ( "shared-state-wait", cmdSharedStateWait ) + , ( "watch-local-identity", cmdWatchLocalIdentity ) + , ( "watch-shared-identity", cmdWatchSharedIdentity ) + , ( "update-local-identity", cmdUpdateLocalIdentity ) + , ( "update-shared-identity", cmdUpdateSharedIdentity ) + , ( "attach-to", cmdAttachTo ) + , ( "attach-accept", cmdAttachAccept ) + , ( "attach-reject", cmdAttachReject ) + , ( "contact-request", cmdContactRequest ) + , ( "contact-accept", cmdContactAccept ) + , ( "contact-reject", cmdContactReject ) + , ( "contact-list", cmdContactList ) + , ( "contact-set-name", cmdContactSetName ) + , ( "dm-send-peer", cmdDmSendPeer ) + , ( "dm-send-contact", cmdDmSendContact ) + , ( "dm-send-identity", cmdDmSendIdentity ) + , ( "dm-list-peer", cmdDmListPeer ) + , ( "dm-list-contact", cmdDmListContact ) + , ( "dm-list-identity", cmdDmListIdentity ) + , ( "dm-mark-seen", cmdDmMarkSeen ) + , ( "chatroom-create", cmdChatroomCreate ) + , ( "chatroom-delete", cmdChatroomDelete ) + , ( "chatroom-list-local", cmdChatroomListLocal ) + , ( "chatroom-watch-local", cmdChatroomWatchLocal ) + , ( "chatroom-set-name", cmdChatroomSetName ) + , ( "chatroom-subscribe", cmdChatroomSubscribe ) + , ( "chatroom-unsubscribe", cmdChatroomUnsubscribe ) + , ( "chatroom-members", cmdChatroomMembers ) + , ( "chatroom-join", cmdChatroomJoin ) + , ( "chatroom-join-as", cmdChatroomJoinAs ) + , ( "chatroom-leave", cmdChatroomLeave ) + , ( "chatroom-message-send", cmdChatroomMessageSend ) + , ( "discovery-connect", cmdDiscoveryConnect ) + , ( "discovery-tunnel", cmdDiscoveryTunnel ) + , ( "invite-contact-create", cmdInviteContactCreate ) + , ( "invite-accept", cmdInviteAccept ) ] cmdStore :: Command @@ -322,7 +373,7 @@ cmdStore = do st <- asks tiStorage pst <- liftIO $ derivePartialStorage st [otype] <- asks tiParams - ls <- getLines + ls <- getLines T.empty let cnt = encodeUtf8 $ T.unlines ls full = BL.fromChunks @@ -335,6 +386,18 @@ cmdStore = do Right ref -> cmdOut $ "store-done " ++ show (refDigest ref) Left _ -> cmdOut $ "store-failed" +cmdStoreRaw :: Command +cmdStoreRaw = do + st <- asks tiStorage + pst <- liftIO $ derivePartialStorage st + [ eof ] <- asks tiParams + ls <- getLines eof + + let full = BL.fromStrict $ BC.init $ encodeUtf8 $ T.unlines ls + liftIO (copyRef st =<< storeRawBytes pst full) >>= \case + Right ref -> cmdOut $ "store-done " ++ show (refDigest ref) + Left _ -> cmdOut $ "store-failed" + cmdLoad :: Command cmdLoad = do st <- asks tiStorage @@ -347,6 +410,20 @@ cmdLoad = do cmdOut $ "load-line " <> T.unpack (decodeUtf8 $ BL.toStrict line) cmdOut "load-done" +cmdLoadType :: Command +cmdLoadType = do + st <- asks tiStorage + [ tref ] <- asks tiParams + Just ref <- liftIO $ readRef st $ encodeUtf8 tref + let obj = load @Object ref + let otype = case obj of + Blob {} -> "blob" + Rec {} -> "rec" + OnDemand {} -> "ondemand" + ZeroObject {} -> "zero" + UnknownObject utype _ -> "unknown " <> decodeUtf8 utype + cmdOut $ "load-type " <> T.unpack otype + cmdStoredGeneration :: Command cmdStoredGeneration = do st <- asks tiStorage @@ -368,7 +445,7 @@ cmdStoredSetAdd = do [Just iref, Just sref] -> return (wrappedLoad iref, loadSet @[Stored Object] sref) [Just iref] -> return (wrappedLoad iref, emptySet) _ -> fail "unexpected parameters" - set' <- storeSetAdd st [item] set + set' <- storeSetAdd [ item ] set cmdOut $ "stored-set-add" ++ concatMap ((' ':) . show . refDigest . storedRef) (toComponents set') cmdStoredSetList :: Command @@ -381,6 +458,19 @@ cmdStoredSetList = do cmdOut $ "stored-set-item" ++ concatMap ((' ':) . show . refDigest . storedRef) item cmdOut $ "stored-set-done" +cmdStoredDifference :: Command +cmdStoredDifference = do + st <- asks tiStorage + ( trefs1, "|" : trefs2 ) <- span (/= "|") <$> asks tiParams + + let loadObjs = mapM (maybe (fail "invalid ref") (return . wrappedLoad @Object) <=< liftIO . readRef st . encodeUtf8) + objs1 <- loadObjs trefs1 + objs2 <- loadObjs trefs2 + + forM_ (storedDifference objs1 objs2) $ \item -> do + cmdOut $ "stored-difference-item " ++ (show $ refDigest $ storedRef item) + cmdOut $ "stored-difference-done" + cmdHeadCreate :: Command cmdHeadCreate = do [ ttid, tref ] <- asks tiParams @@ -435,7 +525,8 @@ cmdHeadUnwatch = do initTestHead :: Head LocalState -> Command initTestHead h = do - _ <- liftIO . watchReceivedMessages h . dmReceivedWatcher =<< asks tiOutput + let self = finalOwner $ headLocalIdentity h + _ <- liftIO . watchDirectMessageThreads h . dmThreadWatcher self =<< asks tiOutput modify $ \s -> s { tsHead = Just h } loadTestHead :: CommandM (Head LocalState) @@ -458,13 +549,13 @@ cmdCreateIdentity = do st <- asks tiStorage names <- asks tiParams - h <- liftIO $ do + h <- do Just identity <- if null names - then Just <$> createIdentity st Nothing Nothing - else foldrM (\n o -> Just <$> createIdentity st (Just n) o) Nothing names + then Just <$> createIdentity Nothing Nothing + else foldrM (\n o -> Just <$> createIdentity (Just n) o) Nothing names shared <- case names of - _:_:_ -> (:[]) <$> makeSharedStateUpdate st (Just $ finalOwner identity) [] + _:_:_ -> (: []) <$> makeSharedStateUpdate (Just $ finalOwner identity) [] _ -> return [] storeHead st $ LocalState @@ -497,21 +588,32 @@ cmdStartServer = do let parseParams = \case (name : value : rest) - | name == "services" -> T.splitOn "," value + | name == "services" -> second ( map splitServiceParams (T.splitOn "," value) ++ ) (parseParams rest) + (name : rest) + | name == "test-log" -> first (\o -> o { serverTestLog = True }) (parseParams rest) | otherwise -> parseParams rest - _ -> [] - serviceNames <- parseParams <$> asks tiParams + _ -> ( defaultServerOptions { serverErrorPrefix = "server-error-message " }, [] ) + + splitServiceParams svc = + case T.splitOn ":" svc of + name : params -> ( name, params ) + _ -> ( svc, [] ) + + ( serverOptions, serviceNames ) <- parseParams <$> asks tiParams h <- getOrLoadHead rsPeers <- liftIO $ newMVar (1, []) services <- forM serviceNames $ \case - "attach" -> return $ someServiceAttr $ pairingAttributes (Proxy @AttachService) out rsPeers "attach" - "chatroom" -> return $ someService @ChatroomService Proxy - "contact" -> return $ someServiceAttr $ pairingAttributes (Proxy @ContactService) out rsPeers "contact" - "discovery" -> return $ someService @DiscoveryService Proxy - "dm" -> return $ someServiceAttr $ directMessageAttributes out - "sync" -> return $ someService @SyncService Proxy - "test" -> return $ someServiceAttr $ (defaultServiceAttributes Proxy) + ( "attach", _ ) -> return $ someServiceAttr $ pairingAttributes (Proxy @AttachService) out rsPeers "attach" + ( "chatroom", _ ) -> return $ someService @ChatroomService Proxy + ( "contact", _ ) -> return $ someServiceAttr $ pairingAttributes (Proxy @ContactService) out rsPeers "contact" + ( "discovery", params ) -> return $ someServiceAttr $ discoveryAttributes + { discoveryProvideTunnel = \_ _ -> "tunnel" `elem` params + } + ( "dm", _ ) -> return $ someServiceAttr $ directMessageAttributes out + ( "invite", _ ) -> return $ someServiceAttr $ inviteAttributes out + ( "sync", _ ) -> return $ someService @SyncService Proxy + ( "test", _ ) -> return $ someServiceAttr $ (defaultServiceAttributes Proxy) { testMessageReceived = \obj otype len sref -> do liftIO $ do void $ store (headStorage h) obj @@ -530,17 +632,22 @@ cmdStartServer = do outLine out $ unwords [ "test-stream-closed-from", show pidx, show num, show seqNum ] go } - sname -> throwOtherError $ "unknown service `" <> T.unpack sname <> "'" + ( sname, _ ) -> throwOtherError $ "unknown service `" <> T.unpack sname <> "'" - rsServer <- liftIO $ startServer defaultServerOptions h (B.hPutStr stderr . (`BC.snoc` '\n') . BC.pack) services + let logPrint str = do BC.hPutStrLn stdout (BC.pack str) + hFlush stdout + rsServer <- liftIO $ startServer serverOptions h logPrint services rsPeerThread <- liftIO $ forkIO $ void $ forever $ do peer <- getNextPeerChange rsServer let printPeer TestPeer {..} = do - params <- peerIdentity tpPeer >>= return . \case - PeerIdentityFull pid -> ("id":) $ map (maybe "<unnamed>" T.unpack . idName) (unfoldOwners pid) - _ -> [ "addr", show (peerAddress tpPeer) ] + params <- getPeerIdentity tpPeer >>= \case + PeerIdentityFull pid -> do + return $ ("id":) $ map (maybe "<unnamed>" T.unpack . idName) (unfoldOwners pid) + _ -> do + paddr <- getPeerAddress tpPeer + return $ [ "addr", show paddr ] outLine out $ unwords $ [ "peer", show tpIndex ] ++ params update ( tpIndex, [] ) = do @@ -591,10 +698,11 @@ cmdPeerList = do tpeers <- liftIO $ readMVar rsPeers forM_ peers $ \peer -> do Just tp <- return $ find ((peer ==) . tpPeer) . snd $ tpeers - mbpid <- peerIdentity peer + mbpid <- getPeerIdentity peer + paddr <- getPeerAddress peer cmdOut $ unwords $ concat [ [ "peer-list-item", show (tpIndex tp) ] - , [ "addr", show (peerAddress peer) ] + , [ "addr", show paddr ] , case mbpid of PeerIdentityFull pid -> ("id":) $ map (maybe "<unnamed>" T.unpack . idName) (unfoldOwners pid) _ -> [] ] @@ -807,7 +915,7 @@ cmdContactSetName = do cmdDmSendPeer :: Command cmdDmSendPeer = do [spidx, msg] <- asks tiParams - PeerIdentityFull to <- peerIdentity =<< getPeer spidx + PeerIdentityFull to <- getPeerIdentity =<< getPeer spidx void $ sendDirectMessage to msg cmdDmSendContact :: Command @@ -816,13 +924,22 @@ cmdDmSendContact = do Just to <- contactIdentity <$> getContact cid void $ sendDirectMessage to msg +cmdDmSendIdentity :: Command +cmdDmSendIdentity = do + st <- asks tiStorage + [ tid, msg ] <- asks tiParams + Just ref <- liftIO $ readRef st $ encodeUtf8 tid + Just to <- return $ validateExtendedIdentity $ wrappedLoad ref + void $ sendDirectMessage to msg + dmList :: Foldable f => Identity f -> Command dmList peer = do - threads <- toThreadList . lookupSharedValue . lsShared . headObject <$> getHead + threads <- dmThreadList . lookupSharedValue . lsShared . headObject <$> getHead case find (sameIdentity peer . msgPeer) threads of Just thread -> do - forM_ (reverse $ threadToList thread) $ \DirectMessage {..} -> cmdOut $ "dm-list-item" + forM_ (reverse $ dmThreadToListUnread thread) $ \( DirectMessage {..}, new ) -> cmdOut $ "dm-list-item" <> " from " <> (maybe "<unnamed>" T.unpack $ idName msgFrom) + <> " new " <> (if new then "yes" else "no") <> " text " <> (T.unpack msgText) Nothing -> return () cmdOut "dm-list-done" @@ -830,7 +947,7 @@ dmList peer = do cmdDmListPeer :: Command cmdDmListPeer = do [spidx] <- asks tiParams - PeerIdentityFull to <- peerIdentity =<< getPeer spidx + PeerIdentityFull to <- getPeerIdentity =<< getPeer spidx dmList to cmdDmListContact :: Command @@ -839,6 +956,23 @@ cmdDmListContact = do Just to <- contactIdentity <$> getContact cid dmList to +cmdDmListIdentity :: Command +cmdDmListIdentity = do + st <- asks tiStorage + [ tid ] <- asks tiParams + Just ref <- liftIO $ readRef st $ encodeUtf8 tid + Just pid <- return $ validateExtendedIdentity $ wrappedLoad ref + dmList pid + +cmdDmMarkSeen :: Command +cmdDmMarkSeen = do + st <- asks tiStorage + [ tid ] <- asks tiParams + Just ref <- liftIO $ readRef st $ encodeUtf8 tid + Just pid <- return $ validateExtendedIdentity $ wrappedLoad ref + dmMarkAsSeen pid + cmdOut $ unwords [ "dm-mark-seen-done", T.unpack tid ] + cmdChatroomCreate :: Command cmdChatroomCreate = do [name] <- asks tiParams @@ -938,8 +1072,7 @@ cmdChatroomJoin = do cmdChatroomJoinAs :: Command cmdChatroomJoinAs = do [ cid, name ] <- asks tiParams - st <- asks tiStorage - identity <- liftIO $ createIdentity st (Just name) Nothing + identity <- createIdentity (Just name) Nothing joinChatroomAsByStateData identity =<< getChatroomStateData cid cmdOut $ unwords [ "chatroom-join-as-done", T.unpack cid ] @@ -959,8 +1092,26 @@ cmdDiscoveryConnect :: Command cmdDiscoveryConnect = do [ tref ] <- asks tiParams Just dgst <- return $ readRefDigest $ encodeUtf8 tref - Just RunningServer {..} <- gets tsServer - peers <- liftIO $ getCurrentPeerList rsServer - forM_ peers $ \peer -> do - sendToPeer peer $ DiscoverySearch $ Right dgst + discoverySearch rsServer dgst + +cmdDiscoveryTunnel :: Command +cmdDiscoveryTunnel = do + [ tvia, ttarget ] <- asks tiParams + via <- getPeer tvia + Just target <- return $ readRefDigest $ encodeUtf8 ttarget + liftIO $ discoverySetupTunnel via target + +cmdInviteContactCreate :: Command +cmdInviteContactCreate = do + [ name ] <- asks tiParams + Just token <- inviteToken <$> createSingleContactInvite name + cmdOut $ unwords [ "invite-contact-create-done", BC.unpack (showHex token) ] + +cmdInviteAccept :: Command +cmdInviteAccept = do + [ tokenText, idref ] <- asks tiParams + Just token <- return $ readHex $ encodeUtf8 tokenText + Just from <- return $ readRefDigest $ encodeUtf8 idref + Just RunningServer {..} <- gets tsServer + acceptInvite rsServer from token |