summaryrefslogtreecommitdiff
path: root/main/Test.hs
diff options
context:
space:
mode:
Diffstat (limited to 'main/Test.hs')
-rw-r--r--main/Test.hs91
1 files changed, 74 insertions, 17 deletions
diff --git a/main/Test.hs b/main/Test.hs
index 628e351..08ad880 100644
--- a/main/Test.hs
+++ b/main/Test.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
module Test (
runTestTool,
) where
@@ -35,6 +37,7 @@ import Erebos.Attach
import Erebos.Chatroom
import Erebos.Contact
import Erebos.DirectMessage
+import Erebos.Discovery
import Erebos.Identity
import Erebos.Network
import Erebos.Object
@@ -46,7 +49,6 @@ import Erebos.State
import Erebos.Storable
import Erebos.Storage
import Erebos.Storage.Head
-import Erebos.Storage.Internal (unsafeStoreRawBytes)
import Erebos.Storage.Merge
import Erebos.Sync
@@ -101,7 +103,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)
@@ -173,7 +175,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"
}
@@ -224,11 +226,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
@@ -258,6 +260,7 @@ 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)
@@ -286,6 +289,7 @@ commands = map (T.pack *** id)
, ("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)
@@ -296,17 +300,26 @@ commands = map (T.pack *** id)
, ("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
@@ -446,26 +459,52 @@ cmdCreateIdentity = do
, 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)
+ 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]
}
- ]
+ 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
@@ -623,7 +662,7 @@ cmdUpdateSharedIdentity :: Command
cmdUpdateSharedIdentity = do
[name] <- asks tiParams
updateLocalHead_ $ updateSharedState_ $ \case
- Nothing -> throwError "no existing shared identity"
+ Nothing -> throwOtherError "no existing shared identity"
Just identity -> do
let public = idKeyIdentity identity
secret <- loadKey public
@@ -736,6 +775,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
@@ -838,3 +884,14 @@ cmdChatroomMessageSend = do
[cid, msg] <- asks tiParams
to <- getChatroomStateData cid
void $ sendChatroomMessageByStateData to msg
+
+cmdDiscoveryConnect :: Command
+cmdDiscoveryConnect = do
+ st <- asks tiStorage
+ [ tref ] <- asks tiParams
+ Just ref <- liftIO $ readRef st $ encodeUtf8 tref
+
+ Just RunningServer {..} <- gets tsServer
+ peers <- liftIO $ getCurrentPeerList rsServer
+ forM_ peers $ \peer -> do
+ sendToPeer peer $ DiscoverySearch ref
generated by cgit v1.2.3 (git 2.25.1) at 2025-07-04 18:36:49 +0000