From d1f00d188698c52c07a5881fc0088e4163976e5e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Thu, 30 Dec 2021 23:13:06 +0100 Subject: Test mode for erebos-tester --- src/Main.hs | 3 + src/Test.hs | 276 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 279 insertions(+) create mode 100644 src/Test.hs (limited to 'src') diff --git a/src/Main.hs b/src/Main.hs index 2c56a00..7fb6ff3 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -39,6 +39,7 @@ import State import Storage import Storage.Merge import Sync +import Test data Options = Options { optServer :: ServerOptions @@ -109,6 +110,8 @@ main = do BC.putStrLn . showRefDigest . refDigest . storedRef . idData =<< interactiveIdentityUpdate idt | otherwise -> error "invalid identity" + ["test"] -> runTestTool st + args -> do opts <- case getOpt Permute options args of (o, [], []) -> return (foldl (flip id) defaultOptions o) diff --git a/src/Test.hs b/src/Test.hs new file mode 100644 index 0000000..994f543 --- /dev/null +++ b/src/Test.hs @@ -0,0 +1,276 @@ +module Test ( + runTestTool, +) where + +import Control.Arrow +import Control.Concurrent +import Control.Monad.Except +import Control.Monad.Reader +import Control.Monad.State + +import Crypto.Random + +import Data.Foldable +import Data.IP (fromSockAddr) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.IO qualified as T +import Data.Typeable + +import System.IO +import System.IO.Error + +import Attach +import Identity +import Network +import Pairing +import PubKey +import Service +import State +import Storage +import Sync + + +data TestState = TestState + { tsHead :: Maybe (Head LocalState) + , tsServer :: Maybe Server + , tsPeers :: Maybe (MVar (Int, [(Int, Peer)])) + , tsWatchedLocalIdentity :: Maybe WatchedHead + , tsWatchedSharedIdentity :: Maybe WatchedHead + } + +initTestState :: TestState +initTestState = TestState + { tsHead = Nothing + , tsServer = Nothing + , tsPeers = Nothing + , tsWatchedLocalIdentity = Nothing + , tsWatchedSharedIdentity = Nothing + } + +data TestInput = TestInput + { tiOutput :: Output + , tiStorage :: Storage + , tiParams :: [Text] + } + + +runTestTool :: Storage -> IO () +runTestTool st = do + out <- newMVar () + let getLineMb = catchIOError (Just <$> T.getLine) (\e -> if isEOFError e then return Nothing else ioError e) + let testLoop = liftIO getLineMb >>= \case + Just line -> do + case T.words line of + (cname:params) + | Just (CommandM cmd) <- lookup cname commands -> do + runReaderT cmd $ TestInput out st params + | otherwise -> fail $ "Unknown command '" ++ T.unpack cname ++ "'" + [] -> return () + testLoop + + Nothing -> return () + + runExceptT (evalStateT testLoop initTestState) >>= \case + Left x -> hPutStrLn stderr x + Right () -> return () + + +type Output = MVar () + +outLine :: Output -> String -> IO () +outLine mvar line = withMVar mvar $ \() -> do + putStrLn line + hFlush stdout + + +getPeer :: Text -> CommandM Peer +getPeer spidx = do + Just pmvar <- gets tsPeers + Just peer <- lookup (read $ T.unpack spidx) . snd <$> liftIO (readMVar pmvar) + return peer + +getPeerIndex :: MVar (Int, [(Int, Peer)]) -> ServiceHandler (PairingService a) Int +getPeerIndex pmvar = do + peer <- asks svcPeer + maybe 0 fst . find ((==peer) . snd) . snd <$> liftIO (readMVar pmvar) + +pairingAttributes :: PairingResult a => proxy (PairingService a) -> Output -> MVar (Int, [(Int, Peer)]) -> String -> PairingAttributes a +pairingAttributes _ out peers prefix = PairingAttributes + { pairingHookRequest = return () + + , pairingHookResponse = \confirm -> do + index <- show <$> getPeerIndex peers + liftIO $ outLine out $ unwords [prefix ++ "-response", index, confirm] + + , pairingHookRequestNonce = \confirm -> do + index <- show <$> getPeerIndex peers + liftIO $ outLine out $ unwords [prefix ++ "-request", index, confirm] + + , pairingHookRequestNonceFailed = failed + + , pairingHookConfirmedResponse = return () + , pairingHookConfirmedRequest = return () + + , pairingHookAcceptedResponse = do + index <- show <$> getPeerIndex peers + liftIO $ outLine out $ unwords [prefix ++ "-response-done", index] + + , pairingHookAcceptedRequest = do + index <- show <$> getPeerIndex peers + liftIO $ outLine out $ unwords [prefix ++ "-request-done", index] + + , pairingHookFailed = failed + , pairingHookVerifyFailed = failed + , pairingHookRejected = failed + } + where + failed :: PairingResult a => ServiceHandler (PairingService a) () + failed = do + ptype <- svcGet >>= return . \case + OurRequest {} -> "response" + OurRequestConfirm {} -> "response" + OurRequestReady -> "response" + PeerRequest {} -> "request" + PeerRequestConfirm -> "request" + _ -> fail "unexpected pairing state" + + index <- show <$> getPeerIndex peers + liftIO $ outLine out $ prefix ++ "-" ++ ptype ++ "-failed " ++ index + + +newtype CommandM a = CommandM (ReaderT TestInput (StateT TestState (ExceptT String IO)) a) + deriving (Functor, Applicative, Monad, MonadIO, MonadReader TestInput, MonadState TestState, MonadError String) + +instance MonadFail CommandM where + fail = throwError + +instance MonadRandom CommandM where + getRandomBytes = liftIO . getRandomBytes + +instance MonadHead LocalState CommandM where + updateLocalHead f = do + Just h <- gets tsHead + (Just h', x) <- liftIO $ maybe (fail "failed to reload head") (flip updateHead f) =<< reloadHead h + modify $ \s -> s { tsHead = Just h' } + return x + +type Command = CommandM () + +commands :: [(Text, Command)] +commands = map (T.pack *** id) + [ ("create-identity", cmdCreateIdentity) + , ("start-server", cmdStartServer) + , ("watch-local-identity", cmdWatchLocalIdentity) + , ("watch-shared-identity", cmdWatchSharedIdentity) + , ("update-shared-identity", cmdUpdateSharedIdentity) + , ("attach-to", cmdAttachTo) + , ("attach-accept", cmdAttachAccept) + , ("attach-reject", cmdAttachReject) + ] + +cmdCreateIdentity :: Command +cmdCreateIdentity = do + st <- asks tiStorage + names <- asks tiParams + + h <- liftIO $ do + Just identity <- if null names + then Just <$> createIdentity st Nothing Nothing + else foldrM (\n o -> Just <$> createIdentity st (Just n) o) Nothing names + + shared <- case names of + _:_:_ -> (:[]) <$> makeSharedStateUpdate st (idDataF $ finalOwner identity) [] + _ -> return [] + + storeHead st $ LocalState + { lsIdentity = idData identity + , lsShared = shared + } + + modify $ \s -> s { tsHead = Just h } + +cmdStartServer :: Command +cmdStartServer = do + out <- asks tiOutput + + Just h <- gets tsHead + peers <- liftIO $ newMVar (1, []) + server <- liftIO $ startServer defaultServerOptions h (hPutStrLn stderr) + [ someServiceAttr $ pairingAttributes (Proxy @AttachService) out peers "attach" + , someService @SyncService Proxy + ] + + void $ liftIO $ forkIO $ void $ forever $ do + peer <- getNextPeerChange server + + let printPeer (idx, p) = do + params <- peerIdentity p >>= return . \case + PeerIdentityFull pid -> ("id":) $ map (maybe "" T.unpack . idName) (unfoldOwners pid) + _ -> ("addr":) $ case peerAddress p of + DatagramAddress _ saddr + | Just (addr, port) <- fromSockAddr saddr -> [show addr, show port] + | otherwise -> [] + PeerIceSession ice -> [show ice] + outLine out $ unwords $ [ "peer", show idx ] ++ params + + 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) + + modifyMVar_ peers update + + modify $ \s -> s { tsServer = Just server, tsPeers = Just peers } + +cmdWatchLocalIdentity :: Command +cmdWatchLocalIdentity = do + Just h <- gets tsHead + Nothing <- gets tsWatchedLocalIdentity + + out <- asks tiOutput + w <- liftIO $ watchHeadWith h headLocalIdentity $ \idt -> do + outLine out $ unwords $ "local-identity" : map (maybe "" T.unpack . idName) (unfoldOwners idt) + modify $ \s -> s { tsWatchedLocalIdentity = Just w } + +cmdWatchSharedIdentity :: Command +cmdWatchSharedIdentity = do + Just h <- gets tsHead + Nothing <- gets tsWatchedSharedIdentity + + out <- asks tiOutput + w <- liftIO $ watchHeadWith h (lookupSharedValue . lsShared . headObject) $ \sdata -> case validateIdentityF sdata of + Just idt -> do + outLine out $ unwords $ "shared-identity" : map (maybe "" T.unpack . idName) (unfoldOwners idt) + Nothing -> do + outLine out $ "shared-identity-failed" + modify $ \s -> s { tsWatchedSharedIdentity = Just w } + +cmdUpdateSharedIdentity :: Command +cmdUpdateSharedIdentity = do + [name] <- asks tiParams + updateSharedState_ $ \sdata -> do + let Just identity = validateIdentityF sdata + st = storedStorage $ head sdata + public = idKeyIdentity identity + + Just secret <- loadKey public + maybe (error "created invalid identity") (return . (:[]) . idData) . validateIdentity =<< + wrappedStore st =<< sign secret =<< wrappedStore st (emptyIdentityData public) + { iddPrev = toList $ idDataF identity + , iddName = Just name + } + +cmdAttachTo :: Command +cmdAttachTo = do + [spidx] <- asks tiParams + attachToOwner =<< getPeer spidx + +cmdAttachAccept :: Command +cmdAttachAccept = do + [spidx] <- asks tiParams + attachAccept =<< getPeer spidx + +cmdAttachReject :: Command +cmdAttachReject = do + [spidx] <- asks tiParams + attachReject =<< getPeer spidx -- cgit v1.2.3