summaryrefslogtreecommitdiff
path: root/main/Test.hs
diff options
context:
space:
mode:
Diffstat (limited to 'main/Test.hs')
-rw-r--r--main/Test.hs283
1 files changed, 235 insertions, 48 deletions
diff --git a/main/Test.hs b/main/Test.hs
index c6448b8..fa8501e 100644
--- a/main/Test.hs
+++ b/main/Test.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
module Test (
runTestTool,
) where
@@ -16,6 +18,7 @@ import Data.Bool
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.Foldable
import Data.Ord
import Data.Text (Text)
@@ -23,7 +26,7 @@ import Data.Text qualified as T
import Data.Text.Encoding
import Data.Text.IO qualified as T
import Data.Typeable
-import Data.UUID qualified as U
+import Data.UUID.Types qualified as U
import Network.Socket
@@ -33,16 +36,20 @@ import System.IO.Error
import Erebos.Attach
import Erebos.Chatroom
import Erebos.Contact
+import Erebos.DirectMessage
+import Erebos.Discovery
import Erebos.Identity
-import Erebos.Message
import Erebos.Network
+import Erebos.Object
import Erebos.Pairing
import Erebos.PubKey
import Erebos.Service
+import Erebos.Service.Stream
import Erebos.Set
import Erebos.State
+import Erebos.Storable
import Erebos.Storage
-import Erebos.Storage.Internal (unsafeStoreRawBytes)
+import Erebos.Storage.Head
import Erebos.Storage.Merge
import Erebos.Sync
@@ -60,10 +67,17 @@ data TestState = TestState
data RunningServer = RunningServer
{ rsServer :: Server
- , rsPeers :: MVar (Int, [(Int, Peer)])
+ , rsPeers :: MVar ( Int, [ TestPeer ] )
, rsPeerThread :: ThreadId
}
+data TestPeer = TestPeer
+ { tpIndex :: Int
+ , tpPeer :: Peer
+ , tpStreamReaders :: MVar [ (Int, StreamReader ) ]
+ , tpStreamWriters :: MVar [ (Int, StreamWriter ) ]
+ }
+
initTestState :: TestState
initTestState = TestState
{ tsHead = Nothing
@@ -97,7 +111,7 @@ runTestTool st = do
Nothing -> return ()
runExceptT (evalStateT testLoop initTestState) >>= \case
- Left x -> B.hPutStr stderr $ (`BC.snoc` '\n') $ BC.pack x
+ Left x -> B.hPutStr stderr $ (`BC.snoc` '\n') $ BC.pack (showErebosError x)
Right () -> return ()
getLineMb :: MonadIO m => m (Maybe Text)
@@ -131,17 +145,20 @@ cmdOut line = do
getPeer :: Text -> CommandM Peer
-getPeer spidx = do
+getPeer spidx = tpPeer <$> getTestPeer spidx
+
+getTestPeer :: Text -> CommandM TestPeer
+getTestPeer spidx = do
Just RunningServer {..} <- gets tsServer
- Just peer <- lookup (read $ T.unpack spidx) . snd <$> liftIO (readMVar rsPeers)
+ Just peer <- find (((read $ T.unpack spidx) ==) . tpIndex) . snd <$> liftIO (readMVar rsPeers)
return peer
-getPeerIndex :: MVar (Int, [(Int, Peer)]) -> ServiceHandler (PairingService a) Int
+getPeerIndex :: MVar ( Int, [ TestPeer ] ) -> ServiceHandler s Int
getPeerIndex pmvar = do
peer <- asks svcPeer
- maybe 0 fst . find ((==peer) . snd) . snd <$> liftIO (readMVar pmvar)
+ maybe 0 tpIndex . find ((peer ==) . tpPeer) . snd <$> liftIO (readMVar pmvar)
-pairingAttributes :: PairingResult a => proxy (PairingService a) -> Output -> MVar (Int, [(Int, Peer)]) -> String -> PairingAttributes a
+pairingAttributes :: PairingResult a => proxy (PairingService a) -> Output -> MVar ( Int, [ TestPeer ] ) -> String -> PairingAttributes a
pairingAttributes _ out peers prefix = PairingAttributes
{ pairingHookRequest = return ()
@@ -169,7 +186,7 @@ pairingAttributes _ out peers prefix = PairingAttributes
, pairingHookFailed = \case
PairingUserRejected -> failed "user"
PairingUnexpectedMessage pstate packet -> failed $ "unexpected " ++ strState pstate ++ " " ++ strPacket packet
- PairingFailedOther str -> failed $ "other " ++ str
+ PairingFailedOther err -> failed $ "other " ++ showErebosError err
, pairingHookVerifyFailed = failed "verify"
, pairingHookRejected = failed "rejected"
}
@@ -220,11 +237,11 @@ dmReceivedWatcher out smsg = do
]
-newtype CommandM a = CommandM (ReaderT TestInput (StateT TestState (ExceptT String IO)) a)
- deriving (Functor, Applicative, Monad, MonadIO, MonadReader TestInput, MonadState TestState, MonadError String)
+newtype CommandM a = CommandM (ReaderT TestInput (StateT TestState (ExceptT ErebosError IO)) a)
+ deriving (Functor, Applicative, Monad, MonadIO, MonadReader TestInput, MonadState TestState, MonadError ErebosError)
instance MonadFail CommandM where
- fail = throwError
+ fail = throwOtherError
instance MonadRandom CommandM where
getRandomBytes = liftIO . getRandomBytes
@@ -244,6 +261,7 @@ 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)
@@ -253,12 +271,19 @@ commands = map (T.pack *** id)
, ("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)
@@ -275,9 +300,11 @@ commands = map (T.pack *** id)
, ("contact-set-name", cmdContactSetName)
, ("dm-send-peer", cmdDmSendPeer)
, ("dm-send-contact", cmdDmSendContact)
+ , ("dm-send-identity", cmdDmSendIdentity)
, ("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)
@@ -285,19 +312,41 @@ commands = map (T.pack *** id)
, ("chatroom-unsubscribe", cmdChatroomUnsubscribe)
, ("chatroom-members", cmdChatroomMembers)
, ("chatroom-join", cmdChatroomJoin)
+ , ("chatroom-join-as", cmdChatroomJoinAs)
, ("chatroom-leave", cmdChatroomLeave)
, ("chatroom-message-send", cmdChatroomMessageSend)
+ , ("discovery-connect", cmdDiscoveryConnect)
]
cmdStore :: Command
cmdStore = do
st <- asks tiStorage
+ pst <- liftIO $ derivePartialStorage st
[otype] <- asks tiParams
ls <- getLines
let cnt = encodeUtf8 $ T.unlines ls
- ref <- liftIO $ unsafeStoreRawBytes st $ BL.fromChunks [encodeUtf8 otype, BC.singleton ' ', BC.pack (show $ B.length cnt), BC.singleton '\n', cnt]
- cmdOut $ "store-done " ++ show (refDigest ref)
+ full = BL.fromChunks
+ [ encodeUtf8 otype
+ , BC.singleton ' '
+ , BC.pack (show $ B.length cnt)
+ , BC.singleton '\n', cnt
+ ]
+ 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
+ [ tref ] <- asks tiParams
+ Just ref <- liftIO $ readRef st $ encodeUtf8 tref
+ let obj = load @Object ref
+ header : content <- return $ BL.lines $ serializeObject obj
+ cmdOut $ "load-type " <> T.unpack (decodeUtf8 $ BL.toStrict header)
+ forM_ content $ \line -> do
+ cmdOut $ "load-line " <> T.unpack (decodeUtf8 $ BL.toStrict line)
+ cmdOut "load-done"
cmdStoredGeneration :: Command
cmdStoredGeneration = do
@@ -420,41 +469,92 @@ cmdCreateIdentity = do
_ -> return []
storeHead st $ LocalState
- { lsIdentity = idExtData identity
+ { lsPrev = Nothing
+ , lsIdentity = idExtData identity
, lsShared = shared
+ , lsOther = []
}
initTestHead h
+ cmdOut $ unwords [ "create-identity-done", "ref", show $ refDigest $ storedRef $ lsIdentity $ headObject h ]
+
+cmdIdentityInfo :: Command
+cmdIdentityInfo = do
+ st <- asks tiStorage
+ [ tref ] <- asks tiParams
+ Just ref <- liftIO $ readRef st $ encodeUtf8 tref
+ let sidata = wrappedLoad ref
+ idata = fromSigned sidata
+ cmdOut $ unwords $ concat
+ [ [ "identity-info" ]
+ , [ "ref", T.unpack tref ]
+ , [ "base", show $ refDigest $ storedRef $ eiddStoredBase sidata ]
+ , maybe [] (\owner -> [ "owner", show $ refDigest $ storedRef owner ]) $ eiddOwner idata
+ , maybe [] (\name -> [ "name", T.unpack name ]) $ eiddName idata
+ ]
cmdStartServer :: Command
cmdStartServer = do
out <- asks tiOutput
+ let parseParams = \case
+ (name : value : rest)
+ | name == "services" -> T.splitOn "," value
+ | otherwise -> parseParams rest
+ _ -> []
+ serviceNames <- parseParams <$> asks tiParams
+
h <- getOrLoadHead
rsPeers <- liftIO $ newMVar (1, [])
- rsServer <- liftIO $ startServer defaultServerOptions h (B.hPutStr stderr . (`BC.snoc` '\n') . BC.pack)
- [ someServiceAttr $ pairingAttributes (Proxy @AttachService) out rsPeers "attach"
- , someServiceAttr $ pairingAttributes (Proxy @ContactService) out rsPeers "contact"
- , someServiceAttr $ directMessageAttributes out
- , someService @SyncService Proxy
- , someService @ChatroomService Proxy
- , someServiceAttr $ (defaultServiceAttributes Proxy)
- { testMessageReceived = \otype len sref ->
- liftIO $ outLine out $ unwords ["test-message-received", otype, len, sref]
+ 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)
+ { testMessageReceived = \obj otype len sref -> do
+ liftIO $ do
+ void $ store (headStorage h) obj
+ outLine out $ unwords [ "test-message-received", otype, len, sref ]
+ , testStreamsReceived = \streams -> do
+ pidx <- getPeerIndex rsPeers
+ liftIO $ do
+ nums <- mapM getStreamReaderNumber streams
+ outLine out $ unwords $ "test-stream-open-from" : show pidx : map show nums
+ forM_ (zip nums streams) $ \( num, stream ) -> void $ forkIO $ do
+ let go = readStreamPacket stream >>= \case
+ StreamData seqNum bytes -> do
+ outLine out $ unwords [ "test-stream-received", show pidx, show num, show seqNum, BC.unpack bytes ]
+ go
+ StreamClosed seqNum -> do
+ outLine out $ unwords [ "test-stream-closed-from", show pidx, show num, show seqNum ]
+ go
}
- ]
+ sname -> throwOtherError $ "unknown service `" <> T.unpack sname <> "'"
+
+ rsServer <- liftIO $ startServer defaultServerOptions h (B.hPutStr stderr . (`BC.snoc` '\n') . BC.pack) services
rsPeerThread <- liftIO $ forkIO $ void $ forever $ do
peer <- getNextPeerChange rsServer
- let printPeer (idx, p) = do
- params <- peerIdentity p >>= return . \case
+ let printPeer TestPeer {..} = do
+ params <- peerIdentity tpPeer >>= return . \case
PeerIdentityFull pid -> ("id":) $ map (maybe "<unnamed>" T.unpack . idName) (unfoldOwners pid)
- _ -> [ "addr", show (peerAddress p) ]
- outLine out $ unwords $ [ "peer", show idx ] ++ params
+ _ -> [ "addr", show (peerAddress tpPeer) ]
+ outLine out $ unwords $ [ "peer", show tpIndex ] ++ params
+
+ update ( tpIndex, [] ) = do
+ tpPeer <- return peer
+ tpStreamReaders <- newMVar []
+ tpStreamWriters <- newMVar []
+ let tp = TestPeer {..}
+ printPeer tp
+ return ( tpIndex + 1, [ tp ] )
- update (nid, []) = printPeer (nid, peer) >> return (nid + 1, [(nid, peer)])
- update cur@(nid, p:ps) | snd p == peer = printPeer p >> return cur
- | otherwise = fmap (p:) <$> update (nid, ps)
+ update cur@( nid, p : ps )
+ | tpPeer p == peer = printPeer p >> return cur
+ | otherwise = fmap (p :) <$> update ( nid, ps )
modifyMVar_ rsPeers update
@@ -491,10 +591,10 @@ cmdPeerList = do
peers <- liftIO $ getCurrentPeerList rsServer
tpeers <- liftIO $ readMVar rsPeers
forM_ peers $ \peer -> do
- Just (n, _) <- return $ find ((peer==).snd) . snd $ tpeers
+ Just tp <- return $ find ((peer ==) . tpPeer) . snd $ tpeers
mbpid <- peerIdentity peer
cmdOut $ unwords $ concat
- [ [ "peer-list-item", show n ]
+ [ [ "peer-list-item", show (tpIndex tp) ]
, [ "addr", show (peerAddress peer) ]
, case mbpid of PeerIdentityFull pid -> ("id":) $ map (maybe "<unnamed>" T.unpack . idName) (unfoldOwners pid)
_ -> []
@@ -511,13 +611,59 @@ cmdTestMessageSend = do
sendManyToPeer peer $ map (TestMessage . wrappedLoad) refs
cmdOut "test-message-send done"
-cmdSharedStateGet :: Command
-cmdSharedStateGet = do
+cmdTestStreamOpen :: Command
+cmdTestStreamOpen = do
+ spidx : rest <- asks tiParams
+ tp <- getTestPeer spidx
+ count <- case rest of
+ [] -> return 1
+ tcount : _ -> return $ read $ T.unpack tcount
+
+ out <- asks tiOutput
+ runPeerService (tpPeer tp) $ do
+ streams <- openTestStreams count
+ afterCommit $ do
+ nums <- mapM getStreamWriterNumber streams
+ modifyMVar_ (tpStreamWriters tp) $ return . (++ zip nums streams)
+ outLine out $ unwords $ "test-stream-open-done"
+ : T.unpack spidx
+ : map show nums
+
+cmdTestStreamClose :: Command
+cmdTestStreamClose = do
+ [ spidx, sid ] <- asks tiParams
+ tp <- getTestPeer spidx
+ Just stream <- lookup (read $ T.unpack sid) <$> liftIO (readMVar (tpStreamWriters tp))
+ liftIO $ closeStream stream
+ cmdOut $ unwords [ "test-stream-close-done", T.unpack spidx, T.unpack sid ]
+
+cmdTestStreamSend :: Command
+cmdTestStreamSend = do
+ [ spidx, sid, content ] <- asks tiParams
+ tp <- getTestPeer spidx
+ Just stream <- lookup (read $ T.unpack sid) <$> liftIO (readMVar (tpStreamWriters tp))
+ liftIO $ writeStream stream $ encodeUtf8 content
+ cmdOut $ unwords [ "test-stream-send-done", T.unpack spidx, T.unpack sid ]
+
+cmdLocalStateGet :: Command
+cmdLocalStateGet = do
h <- getHead
- cmdOut $ unwords $ "shared-state-get" : map (show . refDigest . storedRef) (lsShared $ headObject h)
+ cmdOut $ unwords $ "local-state-get" : map (show . refDigest . storedRef) [ headStoredObject h ]
-cmdSharedStateWait :: Command
-cmdSharedStateWait = do
+cmdLocalStateReplace :: Command
+cmdLocalStateReplace = do
+ st <- asks tiStorage
+ [ told, tnew ] <- asks tiParams
+ Just rold <- liftIO $ readRef st $ encodeUtf8 told
+ Just rnew <- liftIO $ readRef st $ encodeUtf8 tnew
+ ok <- updateLocalHead @LocalState $ \ls -> do
+ if storedRef ls == rold
+ then return ( wrappedLoad rnew, True )
+ else return ( ls, False )
+ cmdOut $ if ok then "local-state-replace-done" else "local-state-replace-failed"
+
+localStateWaitHelper :: Storable a => String -> (Head LocalState -> [ Stored a ]) -> Command
+localStateWaitHelper label sel = do
st <- asks tiStorage
out <- asks tiOutput
h <- getOrLoadHead
@@ -525,15 +671,26 @@ cmdSharedStateWait = do
liftIO $ do
mvar <- newEmptyMVar
- w <- watchHeadWith h (lsShared . headObject) $ \cur -> do
+ w <- watchHeadWith h sel $ \cur -> do
mbobjs <- mapM (readRef st . encodeUtf8) trefs
case map wrappedLoad <$> sequence mbobjs of
Just objs | filterAncestors (cur ++ objs) == cur -> do
- outLine out $ unwords $ "shared-state-wait" : map T.unpack trefs
+ outLine out $ unwords $ label : map T.unpack trefs
void $ forkIO $ unwatchHead =<< takeMVar mvar
_ -> return ()
putMVar mvar w
+cmdLocalStateWait :: Command
+cmdLocalStateWait = localStateWaitHelper "local-state-wait" ((: []) . headStoredObject)
+
+cmdSharedStateGet :: Command
+cmdSharedStateGet = do
+ h <- getHead
+ cmdOut $ unwords $ "shared-state-get" : map (show . refDigest . storedRef) (lsShared $ headObject h)
+
+cmdSharedStateWait :: Command
+cmdSharedStateWait = localStateWaitHelper "shared-state-wait" (lsShared . headObject)
+
cmdWatchLocalIdentity :: Command
cmdWatchLocalIdentity = do
h <- getOrLoadHead
@@ -560,7 +717,7 @@ cmdWatchSharedIdentity = do
cmdUpdateLocalIdentity :: Command
cmdUpdateLocalIdentity = do
[name] <- asks tiParams
- updateLocalHead_ $ \ls -> do
+ updateLocalState_ $ \ls -> do
Just identity <- return $ validateExtendedIdentity $ lsIdentity $ fromStored ls
let public = idKeyIdentity identity
@@ -575,8 +732,8 @@ cmdUpdateLocalIdentity = do
cmdUpdateSharedIdentity :: Command
cmdUpdateSharedIdentity = do
[name] <- asks tiParams
- updateLocalHead_ $ updateSharedState_ $ \case
- Nothing -> throwError "no existing shared identity"
+ updateLocalState_ $ updateSharedState_ $ \case
+ Nothing -> throwOtherError "no existing shared identity"
Just identity -> do
let public = idKeyIdentity identity
secret <- loadKey public
@@ -645,7 +802,7 @@ cmdContactSetName :: Command
cmdContactSetName = do
[cid, name] <- asks tiParams
contact <- getContact cid
- updateLocalHead_ $ updateSharedState_ $ contactSetName contact name
+ updateLocalState_ $ updateSharedState_ $ contactSetName contact name
cmdOut "contact-set-name-done"
cmdDmSendPeer :: Command
@@ -660,6 +817,14 @@ 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
@@ -689,6 +854,13 @@ cmdChatroomCreate = do
room <- createChatroom (Just name) Nothing
cmdOut $ unwords $ "chatroom-create-done" : chatroomInfo room
+cmdChatroomDelete :: Command
+cmdChatroomDelete = do
+ [ cid ] <- asks tiParams
+ sdata <- getChatroomStateData cid
+ deleteChatroomByStateData sdata
+ cmdOut $ unwords [ "chatroom-delete-done", T.unpack cid ]
+
getChatroomStateData :: Text -> CommandM (Stored ChatroomStateData)
getChatroomStateData tref = do
st <- asks tiStorage
@@ -714,7 +886,7 @@ cmdChatroomListLocal = do
cmdChatroomWatchLocal :: Command
cmdChatroomWatchLocal = do
[] <- asks tiParams
- h <- getHead
+ h <- getOrLoadHead
out <- asks tiOutput
void $ watchChatrooms h $ \_ -> \case
Nothing -> return ()
@@ -772,6 +944,14 @@ cmdChatroomJoin = do
joinChatroomByStateData =<< getChatroomStateData cid
cmdOut "chatroom-join-done"
+cmdChatroomJoinAs :: Command
+cmdChatroomJoinAs = do
+ [ cid, name ] <- asks tiParams
+ st <- asks tiStorage
+ identity <- liftIO $ createIdentity st (Just name) Nothing
+ joinChatroomAsByStateData identity =<< getChatroomStateData cid
+ cmdOut $ unwords [ "chatroom-join-as-done", T.unpack cid ]
+
cmdChatroomLeave :: Command
cmdChatroomLeave = do
[ cid ] <- asks tiParams
@@ -783,3 +963,10 @@ cmdChatroomMessageSend = do
[cid, msg] <- asks tiParams
to <- getChatroomStateData cid
void $ sendChatroomMessageByStateData to msg
+
+cmdDiscoveryConnect :: Command
+cmdDiscoveryConnect = do
+ [ tref ] <- asks tiParams
+ Just dgst <- return $ readRefDigest $ encodeUtf8 tref
+ Just RunningServer {..} <- gets tsServer
+ discoverySearch rsServer dgst
generated by cgit v1.2.3 (git 2.25.1) at 2025-07-02 23:54:41 +0000