Split to library and executable parts

2 files changed, 1020 insertions, 0 deletions

diff --git a/main/Main.hs b/main/Main.hs
new file mode 100644
index 0000000..72af295
--- /dev/null
+++ b/main/Main.hs
@@ -0,0 +1,470 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main (main) where
+
+import Control.Arrow (first)
+import Control.Concurrent
+import Control.Monad
+import Control.Monad.Except
+import Control.Monad.Reader
+import Control.Monad.State
+import Control.Monad.Trans.Maybe
+
+import Crypto.Random
+
+import qualified Data.ByteString.Char8 as BC
+import qualified Data.ByteString.Lazy as BL
+import Data.Char
+import Data.List
+import Data.Maybe
+import Data.Ord
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import qualified Data.Text.IO as T
+import Data.Time.LocalTime
+import Data.Typeable
+
+import Network.Socket
+
+import System.Console.GetOpt
+import System.Console.Haskeline
+import System.Environment
+
+import Erebos.Attach
+import Erebos.Contact
+import Erebos.Discovery
+import Erebos.ICE
+import Erebos.Identity
+import Erebos.Message
+import Erebos.Network
+import Erebos.PubKey
+import Erebos.Service
+import Erebos.Set
+import Erebos.State
+import Erebos.Storage
+import Erebos.Storage.Merge
+import Erebos.Sync
+
+import Test
+
+data Options = Options
+    { optServer :: ServerOptions
+    }
+
+defaultOptions :: Options
+defaultOptions = Options
+    { optServer = defaultServerOptions
+    }
+
+options :: [OptDescr (Options -> Options)]
+options =
+    [ Option ['p'] ["port"]
+        (ReqArg (\p -> so $ \opts -> opts { serverPort = read p }) "PORT")
+        "local port to bind"
+    , Option ['s'] ["silent"]
+        (NoArg (so $ \opts -> opts { serverLocalDiscovery = False }))
+        "do not send announce packets for local discovery"
+    ]
+    where so f opts = opts { optServer = f $ optServer opts }
+
+main :: IO ()
+main = do
+    st <- liftIO $ openStorage . fromMaybe "./.erebos" =<< lookupEnv "EREBOS_DIR"
+    getArgs >>= \case
+        ["cat-file", sref] -> do
+            readRef st (BC.pack sref) >>= \case
+                Nothing -> error "ref does not exist"
+                Just ref -> BL.putStr $ lazyLoadBytes ref
+
+        ("cat-file" : objtype : srefs@(_:_)) -> do
+            sequence <$> (mapM (readRef st . BC.pack) srefs) >>= \case
+                Nothing -> error "ref does not exist"
+                Just refs -> case objtype of
+                    "signed" -> forM_ refs $ \ref -> do
+                        let signed = load ref :: Signed Object
+                        BL.putStr $ lazyLoadBytes $ storedRef $ signedData signed
+                        forM_ (signedSignature signed) $ \sig -> do
+                            putStr $ "SIG "
+                            BC.putStrLn $ showRef $ storedRef $ sigKey $ fromStored sig
+                    "identity" -> case validateIdentityF (wrappedLoad <$> refs) of
+                        Just identity -> do
+                            let disp :: Identity m -> IO ()
+                                disp idt = do
+                                    maybe (return ()) (T.putStrLn . (T.pack "Name: " `T.append`)) $ idName idt
+                                    BC.putStrLn . (BC.pack "KeyId: " `BC.append`) . showRefDigest . refDigest . storedRef $ idKeyIdentity idt
+                                    BC.putStrLn . (BC.pack "KeyMsg: " `BC.append`) . showRefDigest . refDigest . storedRef $ idKeyMessage idt
+                                    case idOwner idt of
+                                         Nothing -> return ()
+                                         Just owner -> do
+                                             mapM_ (putStrLn . ("OWNER " ++) . BC.unpack . showRefDigest . refDigest . storedRef) $ idDataF owner
+                                             disp owner
+                            disp identity
+                        Nothing -> putStrLn $ "Identity verification failed"
+                    _ -> error $ "unknown object type '" ++ objtype ++ "'"
+
+        ["show-generation", sref] -> readRef st (BC.pack sref) >>= \case
+            Nothing -> error "ref does not exist"
+            Just ref -> print $ storedGeneration (wrappedLoad ref :: Stored Object)
+
+        ["update-identity"] -> either fail return <=< runExceptT $ do
+            runReaderT updateSharedIdentity =<< loadLocalStateHead st
+
+        ("update-identity" : srefs) -> do
+            sequence <$> mapM (readRef st . BC.pack) srefs >>= \case
+                Nothing -> error "ref does not exist"
+                Just refs
+                    | Just idt <- validateIdentityF $ map wrappedLoad refs -> do
+                        BC.putStrLn . showRefDigest . refDigest . storedRef . idData =<<
+                            (either fail return <=< runExceptT $ runReaderT (interactiveIdentityUpdate idt) st)
+                    | otherwise -> error "invalid identity"
+
+        ["test"] -> runTestTool st
+
+        args -> do
+            opts <- case getOpt Permute options args of
+                (o, [], []) -> return (foldl (flip id) defaultOptions o)
+                (_, _, errs) -> ioError (userError (concat errs ++ usageInfo header options))
+                    where header = "Usage: erebos [OPTION...]"
+            interactiveLoop st opts
+
+
+interactiveLoop :: Storage -> Options -> IO ()
+interactiveLoop st opts = runInputT defaultSettings $ do
+    erebosHead <- liftIO $ loadLocalStateHead st
+    outputStrLn $ T.unpack $ displayIdentity $ headLocalIdentity erebosHead
+
+    haveTerminalUI >>= \case True -> return ()
+                             False -> error "Requires terminal"
+    extPrint <- getExternalPrint
+    let extPrintLn str = extPrint $ case reverse str of ('\n':_) -> str
+                                                        _ -> str ++ "\n";
+
+    _ <- liftIO $ do
+        tzone <- getCurrentTimeZone
+        watchReceivedMessages erebosHead $
+            extPrintLn . formatMessage tzone . fromStored
+
+    server <- liftIO $ do
+        startServer (optServer opts) erebosHead extPrintLn
+            [ someService @AttachService Proxy
+            , someService @SyncService Proxy
+            , someService @ContactService Proxy
+            , someService @DirectMessage Proxy
+            , someService @DiscoveryService Proxy
+            ]
+
+    peers <- liftIO $ newMVar []
+    contextOptions <- liftIO $ newMVar []
+
+    void $ liftIO $ forkIO $ void $ forever $ do
+        peer <- getNextPeerChange server
+        peerIdentity peer >>= \case
+            pid@(PeerIdentityFull _) -> do
+                let shown = showPeer pid $ peerAddress peer
+                let update [] = ([(peer, shown)], Nothing)
+                    update ((p,s):ps) | p == peer = ((peer, shown) : ps, Just s)
+                                      | otherwise = first ((p,s):) $ update ps
+                let ctxUpdate n [] = ([SelectedPeer peer], n)
+                    ctxUpdate n (ctx:ctxs)
+                        | SelectedPeer p <- ctx, p == peer = (ctx:ctxs, n)
+                        | otherwise = first (ctx:) $ ctxUpdate (n + 1) ctxs
+                op <- modifyMVar peers (return . update)
+                idx <- modifyMVar contextOptions (return . ctxUpdate (1 :: Int))
+                when (Just shown /= op) $ extPrint $ "[" <> show idx <> "] PEER " <> shown
+            _ -> return ()
+
+    let getInputLines prompt = do
+            Just input <- lift $ getInputLine prompt
+            case reverse input of
+                 _ | all isSpace input -> getInputLines prompt
+                 '\\':rest -> (reverse ('\n':rest) ++) <$> getInputLines ">> "
+                 _         -> return input
+
+    let process :: CommandState -> MaybeT (InputT IO) CommandState
+        process cstate = do
+            pname <- case csContext cstate of
+                        NoContext -> return ""
+                        SelectedPeer peer -> peerIdentity peer >>= return . \case
+                            PeerIdentityFull pid -> maybe "<unnamed>" T.unpack $ idName $ finalOwner pid
+                            PeerIdentityRef wref _ -> "<" ++ BC.unpack (showRefDigest $ wrDigest wref) ++ ">"
+                            PeerIdentityUnknown _  -> "<unknown>"
+                        SelectedContact contact -> return $ T.unpack $ contactName contact
+            input <- getInputLines $ pname ++ "> "
+            let (CommandM cmd, line) = case input of
+                    '/':rest -> let (scmd, args) = dropWhile isSpace <$> span (\c -> isAlphaNum c || c == '-') rest
+                                 in if not (null scmd) && all isDigit scmd
+                                       then (cmdSelectContext $ read scmd, args)
+                                       else (fromMaybe (cmdUnknown scmd) $ lookup scmd commands, args)
+                    _        -> (cmdSend, input)
+            h <- liftIO (reloadHead $ csHead cstate) >>= \case
+                Just h  -> return h
+                Nothing -> do lift $ lift $ extPrint "current head deleted"
+                              mzero
+            res <- liftIO $ runExceptT $ flip execStateT cstate { csHead = h } $ runReaderT cmd CommandInput
+                { ciServer = server
+                , ciLine = line
+                , ciPrint = extPrintLn
+                , ciPeers = liftIO $ readMVar peers
+                , ciContextOptions = liftIO $ readMVar contextOptions
+                , ciSetContextOptions = \ctxs -> liftIO $ modifyMVar_ contextOptions $ const $ return ctxs
+                }
+            case res of
+                 Right cstate' -> return cstate'
+                 Left err -> do lift $ lift $ extPrint $ "Error: " ++ err
+                                return cstate
+
+    let loop (Just cstate) = runMaybeT (process cstate) >>= loop
+        loop Nothing = return ()
+    loop $ Just $ CommandState
+        { csHead = erebosHead
+        , csContext = NoContext
+        , csIceSessions = []
+        , csIcePeer = Nothing
+        }
+
+
+data CommandInput = CommandInput
+    { ciServer :: Server
+    , ciLine :: String
+    , ciPrint :: String -> IO ()
+    , ciPeers :: CommandM [(Peer, String)]
+    , ciContextOptions :: CommandM [CommandContext]
+    , ciSetContextOptions :: [CommandContext] -> Command
+    }
+
+data CommandState = CommandState
+    { csHead :: Head LocalState
+    , csContext :: CommandContext
+    , csIceSessions :: [IceSession]
+    , csIcePeer :: Maybe Peer
+    }
+
+data CommandContext = NoContext
+                    | SelectedPeer Peer
+                    | SelectedContact Contact
+
+newtype CommandM a = CommandM (ReaderT CommandInput (StateT CommandState (ExceptT String IO)) a)
+    deriving (Functor, Applicative, Monad, MonadIO, MonadReader CommandInput, MonadState CommandState, MonadError String)
+
+instance MonadFail CommandM where
+    fail = throwError
+
+instance MonadRandom CommandM where
+    getRandomBytes = liftIO . getRandomBytes
+
+instance MonadStorage CommandM where
+    getStorage = gets $ headStorage . csHead
+
+instance MonadHead LocalState CommandM where
+    updateLocalHead f = do
+        h <- gets csHead
+        (Just h', x) <- maybe (fail "failed to reload head") (flip updateHead f) =<< reloadHead h
+        modify $ \s -> s { csHead = h' }
+        return x
+
+type Command = CommandM ()
+
+getSelectedPeer :: CommandM Peer
+getSelectedPeer = gets csContext >>= \case
+    SelectedPeer peer -> return peer
+    _ -> throwError "no peer selected"
+
+getSelectedIdentity :: CommandM ComposedIdentity
+getSelectedIdentity = gets csContext >>= \case
+    SelectedPeer peer -> peerIdentity peer >>= \case
+        PeerIdentityFull pid -> return $ toComposedIdentity pid
+        _ -> throwError "incomplete peer identity"
+    SelectedContact contact -> case contactIdentity contact of
+        Just cid -> return cid
+        Nothing -> throwError "contact without erebos identity"
+    _ -> throwError "no contact or peer selected"
+
+commands :: [(String, Command)]
+commands =
+    [ ("history", cmdHistory)
+    , ("peers", cmdPeers)
+    , ("peer-add", cmdPeerAdd)
+    , ("send", cmdSend)
+    , ("update-identity", cmdUpdateIdentity)
+    , ("attach", cmdAttach)
+    , ("attach-accept", cmdAttachAccept)
+    , ("attach-reject", cmdAttachReject)
+    , ("contacts", cmdContacts)
+    , ("contact-add", cmdContactAdd)
+    , ("contact-accept", cmdContactAccept)
+    , ("contact-reject", cmdContactReject)
+    , ("discovery-init", cmdDiscoveryInit)
+    , ("discovery", cmdDiscovery)
+    , ("ice-create", cmdIceCreate)
+    , ("ice-destroy", cmdIceDestroy)
+    , ("ice-show", cmdIceShow)
+    , ("ice-connect", cmdIceConnect)
+    , ("ice-send", cmdIceSend)
+    ]
+
+cmdUnknown :: String -> Command
+cmdUnknown cmd = liftIO $ putStrLn $ "Unknown command: " ++ cmd
+
+cmdPeers :: Command
+cmdPeers = do
+    peers <- join $ asks ciPeers
+    set <- asks ciSetContextOptions
+    set $ map (SelectedPeer . fst) peers
+    forM_ (zip [1..] peers) $ \(i :: Int, (_, name)) -> do
+        liftIO $ putStrLn $ "[" ++ show i ++ "] " ++ name
+
+cmdPeerAdd :: Command
+cmdPeerAdd = void $ do
+    server <- asks ciServer
+    (hostname, port) <- (words <$> asks ciLine) >>= \case
+        hostname:p:_ -> return (hostname, p)
+        [hostname] -> return (hostname, show discoveryPort)
+        [] -> throwError "missing peer address"
+    addr:_ <- liftIO $ getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just hostname) (Just port)
+    liftIO $ serverPeer server (addrAddress addr)
+
+showPeer :: PeerIdentity -> PeerAddress -> String
+showPeer pidentity paddr =
+    let name = case pidentity of
+                    PeerIdentityUnknown _  -> "<noid>"
+                    PeerIdentityRef wref _ -> "<" ++ BC.unpack (showRefDigest $ wrDigest wref) ++ ">"
+                    PeerIdentityFull pid   -> T.unpack $ displayIdentity pid
+     in name ++ " [" ++ show paddr ++ "]"
+
+cmdSelectContext :: Int -> Command
+cmdSelectContext n = join (asks ciContextOptions) >>= \ctxs -> if
+    | n > 0, (ctx : _) <- drop (n - 1) ctxs -> modify $ \s -> s { csContext = ctx }
+    | otherwise -> throwError "invalid index"
+
+cmdSend :: Command
+cmdSend = void $ do
+    text <- asks ciLine
+    powner <- finalOwner <$> getSelectedIdentity
+    smsg <- sendDirectMessage powner $ T.pack text
+    tzone <- liftIO $ getCurrentTimeZone
+    liftIO $ putStrLn $ formatMessage tzone $ fromStored smsg
+
+cmdHistory :: Command
+cmdHistory = void $ do
+    ehead <- gets csHead
+    powner <- finalOwner <$> getSelectedIdentity
+
+    case find (sameIdentity powner . msgPeer) $
+            toThreadList $ lookupSharedValue $ lsShared $ headObject ehead of
+        Just thread -> do
+            tzone <- liftIO $ getCurrentTimeZone
+            liftIO $ mapM_ (putStrLn . formatMessage tzone) $ reverse $ take 50 $ threadToList thread
+        Nothing -> do
+            liftIO $ putStrLn $ "<empty history>"
+
+cmdUpdateIdentity :: Command
+cmdUpdateIdentity = void $ do
+    runReaderT updateSharedIdentity =<< gets csHead
+
+cmdAttach :: Command
+cmdAttach = attachToOwner =<< getSelectedPeer
+
+cmdAttachAccept :: Command
+cmdAttachAccept = attachAccept =<< getSelectedPeer
+
+cmdAttachReject :: Command
+cmdAttachReject = attachReject =<< getSelectedPeer
+
+cmdContacts :: Command
+cmdContacts = do
+    args <- words <$> asks ciLine
+    ehead <- gets csHead
+    let contacts = fromSetBy (comparing contactName) $ lookupSharedValue $ lsShared $ headObject ehead
+        verbose = "-v" `elem` args
+    set <- asks ciSetContextOptions
+    set $ map SelectedContact contacts
+    forM_ (zip [1..] contacts) $ \(i :: Int, c) -> liftIO $ do
+        T.putStrLn $ T.concat
+            [ "[", T.pack (show i), "] ", contactName c
+            , case contactIdentity c of
+                   Just idt | cname <- displayIdentity idt
+                            , cname /= contactName c
+                            -> " (" <> cname <> ")"
+                   _ -> ""
+            , if verbose then " " <> (T.unwords $ map (T.decodeUtf8 . showRef . storedRef) $ maybe [] idDataF $ contactIdentity c)
+                         else ""
+            ]
+
+cmdContactAdd :: Command
+cmdContactAdd = contactRequest =<< getSelectedPeer
+
+cmdContactAccept :: Command
+cmdContactAccept = contactAccept =<< getSelectedPeer
+
+cmdContactReject :: Command
+cmdContactReject = contactReject =<< getSelectedPeer
+
+cmdDiscoveryInit :: Command
+cmdDiscoveryInit = void $ do
+    server <- asks ciServer
+
+    (hostname, port) <- (words <$> asks ciLine) >>= return . \case
+        hostname:p:_ -> (hostname, p)
+        [hostname] -> (hostname, show discoveryPort)
+        [] -> ("discovery.erebosprotocol.net", show discoveryPort)
+    addr:_ <- liftIO $ getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just hostname) (Just port)
+    peer <- liftIO $ serverPeer server (addrAddress addr)
+    sendToPeer peer $ DiscoverySelf (T.pack "ICE") 0
+    modify $ \s -> s { csIcePeer = Just peer }
+
+cmdDiscovery :: Command
+cmdDiscovery = void $ do
+    Just peer <- gets csIcePeer
+    st <- getStorage
+    sref <- asks ciLine
+    eprint <- asks ciPrint
+    liftIO $ readRef st (BC.pack sref) >>= \case
+        Nothing -> error "ref does not exist"
+        Just ref -> do
+            res <- runExceptT $ sendToPeer peer $ DiscoverySearch ref
+            case res of
+                 Right _ -> return ()
+                 Left err -> eprint err
+
+cmdIceCreate :: Command
+cmdIceCreate = do
+    role <- asks ciLine >>= return . \case
+        'm':_ -> PjIceSessRoleControlling
+        's':_ -> PjIceSessRoleControlled
+        _ -> PjIceSessRoleUnknown
+    eprint <- asks ciPrint
+    sess <- liftIO $ iceCreate role $ eprint <=< iceShow
+    modify $ \s -> s { csIceSessions = sess : csIceSessions s }
+
+cmdIceDestroy :: Command
+cmdIceDestroy = do
+    s:ss <- gets csIceSessions
+    modify $ \st -> st { csIceSessions = ss }
+    liftIO $ iceDestroy s
+
+cmdIceShow :: Command
+cmdIceShow = do
+    sess <- gets csIceSessions
+    eprint <- asks ciPrint
+    liftIO $ forM_ (zip [1::Int ..] sess) $ \(i, s) -> do
+        eprint $ "[" ++ show i ++ "]"
+        eprint =<< iceShow s
+
+cmdIceConnect :: Command
+cmdIceConnect = do
+    s:_ <- gets csIceSessions
+    server <- asks ciServer
+    let loadInfo = BC.getLine >>= \case line | BC.null line -> return []
+                                             | otherwise    -> (line:) <$> loadInfo
+    Right remote <- liftIO $ do
+        st <- memoryStorage
+        pst <- derivePartialStorage st
+        rbytes <- (BL.fromStrict . BC.unlines) <$> loadInfo
+        copyRef st =<< storeRawBytes pst (BL.fromChunks [ BC.pack "rec ", BC.pack (show (BL.length rbytes)), BC.singleton '\n' ] `BL.append` rbytes)
+    liftIO $ iceConnect s (load remote) $ void $ serverPeerIce server s
+
+cmdIceSend :: Command
+cmdIceSend = void $ do
+    s:_ <- gets csIceSessions
+    server <- asks ciServer
+    liftIO $ serverPeerIce server s
diff --git a/main/Test.hs b/main/Test.hs
new file mode 100644
index 0000000..7f0f7d9
--- /dev/null
+++ b/main/Test.hs
@@ -0,0 +1,550 @@
+module Test (
+    runTestTool,
+) where
+
+import Control.Arrow
+import Control.Concurrent
+import Control.Exception
+import Control.Monad.Except
+import Control.Monad.Reader
+import Control.Monad.State
+
+import Crypto.Random
+
+import Data.ByteString qualified as B
+import Data.ByteString.Char8 qualified as BC
+import Data.ByteString.Lazy qualified as BL
+import Data.Foldable
+import Data.Ord
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Text.Encoding
+import Data.Text.IO qualified as T
+import Data.Typeable
+
+import Network.Socket
+
+import System.IO
+import System.IO.Error
+
+import Erebos.Attach
+import Erebos.Contact
+import Erebos.Identity
+import Erebos.Message
+import Erebos.Network
+import Erebos.Pairing
+import Erebos.PubKey
+import Erebos.Service
+import Erebos.Set
+import Erebos.State
+import Erebos.Storage
+import Erebos.Storage.Internal (unsafeStoreRawBytes)
+import Erebos.Storage.Merge
+import Erebos.Sync
+
+
+data TestState = TestState
+    { tsHead :: Maybe (Head LocalState)
+    , tsServer :: Maybe RunningServer
+    , tsWatchedLocalIdentity :: Maybe WatchedHead
+    , tsWatchedSharedIdentity :: Maybe WatchedHead
+    }
+
+data RunningServer = RunningServer
+    { rsServer :: Server
+    , rsPeers :: MVar (Int, [(Int, Peer)])
+    , rsPeerThread :: ThreadId
+    }
+
+initTestState :: TestState
+initTestState = TestState
+    { tsHead = Nothing
+    , tsServer = Nothing
+    , tsWatchedLocalIdentity = Nothing
+    , tsWatchedSharedIdentity = Nothing
+    }
+
+data TestInput = TestInput
+    { tiOutput :: Output
+    , tiStorage :: Storage
+    , tiParams :: [Text]
+    }
+
+
+runTestTool :: Storage -> IO ()
+runTestTool st = do
+    out <- newMVar ()
+    let testLoop = 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 ()
+
+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
+    _ -> 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 ()
+
+outLine :: Output -> String -> IO ()
+outLine mvar line = do
+    evaluate $ foldl' (flip seq) () line
+    withMVar mvar $ \() -> do
+        putStrLn line
+        hFlush stdout
+
+cmdOut :: String -> Command
+cmdOut line = do
+    out <- asks tiOutput
+    liftIO $ outLine out line
+
+
+getPeer :: Text -> CommandM Peer
+getPeer spidx = do
+    Just RunningServer {..} <- gets tsServer
+    Just peer <- lookup (read $ T.unpack spidx) . snd <$> liftIO (readMVar rsPeers)
+    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
+        afterCommit $ outLine out $ unwords [prefix ++ "-response", index, confirm]
+
+    , pairingHookRequestNonce = \confirm -> do
+        index <- show <$> getPeerIndex peers
+        afterCommit $ outLine out $ unwords [prefix ++ "-request", index, confirm]
+
+    , pairingHookRequestNonceFailed = failed "nonce"
+
+    , pairingHookConfirmedResponse = return ()
+    , pairingHookConfirmedRequest = return ()
+
+    , pairingHookAcceptedResponse = do
+        index <- show <$> getPeerIndex peers
+        afterCommit $ outLine out $ unwords [prefix ++ "-response-done", index]
+
+    , pairingHookAcceptedRequest = do
+        index <- show <$> getPeerIndex peers
+        afterCommit $ outLine out $ unwords [prefix ++ "-request-done", index]
+
+    , pairingHookFailed = \case
+        PairingUserRejected -> failed "user"
+        PairingUnexpectedMessage pstate packet -> failed $ "unexpected " ++ strState pstate ++ " " ++ strPacket packet
+        PairingFailedOther str -> failed $ "other " ++ str
+    , pairingHookVerifyFailed = failed "verify"
+    , pairingHookRejected = failed "rejected"
+    }
+    where
+        failed :: PairingResult a => String -> ServiceHandler (PairingService a) ()
+        failed detail = do
+            ptype <- svcGet >>= return . \case
+                OurRequest {} -> "response"
+                OurRequestConfirm {} -> "response"
+                OurRequestReady -> "response"
+                PeerRequest {} -> "request"
+                PeerRequestConfirm -> "request"
+                _ -> fail "unexpected pairing state"
+
+            index <- show <$> getPeerIndex peers
+            afterCommit $ outLine out $ prefix ++ "-" ++ ptype ++ "-failed " ++ index ++ " " ++ detail
+
+        strState :: PairingState a -> String
+        strState = \case
+            NoPairing -> "none"
+            OurRequest {} -> "our-request"
+            OurRequestConfirm {} -> "our-request-confirm"
+            OurRequestReady -> "our-request-ready"
+            PeerRequest {} -> "peer-request"
+            PeerRequestConfirm -> "peer-request-confirm"
+            PairingDone -> "done"
+
+        strPacket :: PairingService a -> String
+        strPacket = \case
+            PairingRequest {} -> "request"
+            PairingResponse {} -> "response"
+            PairingRequestNonce {} -> "nonce"
+            PairingAccept {} -> "accept"
+            PairingReject -> "reject"
+
+directMessageAttributes :: Output -> DirectMessageAttributes
+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
+        ]
+
+
+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 MonadStorage CommandM where
+    getStorage = asks tiStorage
+
+instance MonadHead LocalState CommandM where
+    updateLocalHead f = do
+        Just h <- gets tsHead
+        (Just h', x) <- 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)
+    [ ("store", cmdStore)
+    , ("stored-generation", cmdStoredGeneration)
+    , ("stored-roots", cmdStoredRoots)
+    , ("stored-set-add", cmdStoredSetAdd)
+    , ("stored-set-list", cmdStoredSetList)
+    , ("create-identity", cmdCreateIdentity)
+    , ("start-server", cmdStartServer)
+    , ("stop-server", cmdStopServer)
+    , ("peer-add", cmdPeerAdd)
+    , ("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)
+    ]
+
+cmdStore :: Command
+cmdStore = do
+    st <- asks tiStorage
+    [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)
+
+cmdStoredGeneration :: Command
+cmdStoredGeneration = do
+    st <- asks tiStorage
+    [tref] <- asks tiParams
+    Just ref <- liftIO $ readRef st (encodeUtf8 tref)
+    cmdOut $ "stored-generation " ++ T.unpack tref ++ " " ++ showGeneration (storedGeneration $ wrappedLoad @Object ref)
+
+cmdStoredRoots :: Command
+cmdStoredRoots = do
+    st <- asks tiStorage
+    [tref] <- asks tiParams
+    Just ref <- liftIO $ readRef st (encodeUtf8 tref)
+    cmdOut $ "stored-roots " ++ T.unpack tref ++ concatMap ((' ':) . show . refDigest . storedRef) (storedRoots $ wrappedLoad @Object ref)
+
+cmdStoredSetAdd :: Command
+cmdStoredSetAdd = do
+    st <- asks tiStorage
+    (item, set) <- asks tiParams >>= liftIO . mapM (readRef st . encodeUtf8) >>= \case
+        [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
+    cmdOut $ "stored-set-add" ++ concatMap ((' ':) . show . refDigest . storedRef) (toComponents set')
+
+cmdStoredSetList :: Command
+cmdStoredSetList = do
+    st <- asks tiStorage
+    [tref] <- asks tiParams
+    Just ref <- liftIO $ readRef st (encodeUtf8 tref)
+    let items = fromSetBy compare $ loadSet @[Stored Object] ref
+    forM_ items $ \item -> do
+        cmdOut $ "stored-set-item" ++ concatMap ((' ':) . show . refDigest . storedRef) item
+    cmdOut $ "stored-set-done"
+
+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 (Just $ finalOwner identity) []
+            _ -> return []
+
+        storeHead st $ LocalState
+            { lsIdentity = idExtData identity
+            , lsShared = shared
+            }
+
+    _ <- liftIO . watchReceivedMessages h . dmReceivedWatcher =<< asks tiOutput
+    modify $ \s -> s { tsHead = Just h }
+
+cmdStartServer :: Command
+cmdStartServer = do
+    out <- asks tiOutput
+
+    Just h <- gets tsHead
+    rsPeers <- liftIO $ newMVar (1, [])
+    rsServer <- liftIO $ startServer defaultServerOptions h (hPutStrLn stderr)
+        [ someServiceAttr $ pairingAttributes (Proxy @AttachService) out rsPeers "attach"
+        , someServiceAttr $ pairingAttributes (Proxy @ContactService) out rsPeers "contact"
+        , someServiceAttr $ directMessageAttributes out
+        , someService @SyncService Proxy
+        ]
+
+    rsPeerThread <- liftIO $ forkIO $ void $ forever $ do
+        peer <- getNextPeerChange rsServer
+
+        let printPeer (idx, p) = do
+                params <- peerIdentity p >>= return . \case
+                    PeerIdentityFull pid -> ("id":) $ map (maybe "<unnamed>" T.unpack . idName) (unfoldOwners pid)
+                    _ -> [ "addr", show (peerAddress p) ]
+                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_ rsPeers update
+
+    modify $ \s -> s { tsServer = Just RunningServer {..} }
+
+cmdStopServer :: Command
+cmdStopServer = do
+    Just RunningServer {..} <- gets tsServer
+    liftIO $ do
+        killThread rsPeerThread
+        stopServer rsServer
+    modify $ \s -> s { tsServer = Nothing }
+    cmdOut "stop-server-done"
+
+cmdPeerAdd :: Command
+cmdPeerAdd = do
+    Just RunningServer {..} <- gets tsServer
+    host:rest <- map T.unpack <$> asks tiParams
+
+    let port = case rest of [] -> show discoveryPort
+                            (p:_) -> p
+    addr:_ <- liftIO $ getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just host) (Just port)
+    void $ liftIO $ serverPeer rsServer (addrAddress addr)
+
+cmdSharedStateGet :: Command
+cmdSharedStateGet = do
+    h <- getHead
+    cmdOut $ unwords $ "shared-state-get" : map (show . refDigest . storedRef) (lsShared $ headObject h)
+
+cmdSharedStateWait :: Command
+cmdSharedStateWait = do
+    st <- asks tiStorage
+    out <- asks tiOutput
+    Just h <- gets tsHead
+    trefs <- asks tiParams
+
+    liftIO $ do
+        mvar <- newEmptyMVar
+        w <- watchHeadWith h (lsShared . headObject) $ \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
+                    void $ forkIO $ unwatchHead =<< takeMVar mvar
+                _ -> return ()
+        putMVar mvar w
+
+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 "<unnamed>" 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) $ \case
+        Just (idt :: ComposedIdentity) -> do
+            outLine out $ unwords $ "shared-identity" : map (maybe "<unnamed>" T.unpack . idName) (unfoldOwners idt)
+        Nothing -> do
+            outLine out $ "shared-identity-failed"
+    modify $ \s -> s { tsWatchedSharedIdentity = Just w }
+
+cmdUpdateLocalIdentity :: Command
+cmdUpdateLocalIdentity = do
+    [name] <- asks tiParams
+    updateLocalHead_ $ \ls -> do
+        Just identity <- return $ validateExtendedIdentity $ lsIdentity $ fromStored ls
+        let public = idKeyIdentity identity
+
+        secret <- loadKey public
+        nidata <- maybe (error "created invalid identity") (return . idExtData) . validateExtendedIdentity =<<
+            mstore =<< sign secret =<< mstore . ExtendedIdentityData =<< return (emptyIdentityExtension $ idData identity)
+            { idePrev = toList $ idExtDataF identity
+            , ideName = Just name
+            }
+        mstore (fromStored ls) { lsIdentity = nidata }
+
+cmdUpdateSharedIdentity :: Command
+cmdUpdateSharedIdentity = do
+    [name] <- asks tiParams
+    updateLocalHead_ $ updateSharedState_ $ \case
+        Nothing -> throwError "no existing shared identity"
+        Just identity -> do
+            let public = idKeyIdentity identity
+            secret <- loadKey public
+            uidentity <- mergeIdentity identity
+            maybe (error "created invalid identity") (return . Just . toComposedIdentity) . validateExtendedIdentity =<<
+                mstore =<< sign secret =<< mstore . ExtendedIdentityData =<< return (emptyIdentityExtension $ idData uidentity)
+                { idePrev = toList $ idExtDataF identity
+                , ideName = 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
+
+cmdContactRequest :: Command
+cmdContactRequest = do
+    [spidx] <- asks tiParams
+    contactRequest =<< getPeer spidx
+
+cmdContactAccept :: Command
+cmdContactAccept = do
+    [spidx] <- asks tiParams
+    contactAccept =<< getPeer spidx
+
+cmdContactReject :: Command
+cmdContactReject = do
+    [spidx] <- asks tiParams
+    contactReject =<< getPeer spidx
+
+cmdContactList :: Command
+cmdContactList = do
+    h <- getHead
+    let contacts = fromSetBy (comparing contactName) . lookupSharedValue . lsShared . headObject $ h
+    forM_ contacts $ \c -> do
+        r:_ <- return $ filterAncestors $ concatMap storedRoots $ toComponents c
+        cmdOut $ concat
+            [ "contact-list-item "
+            , show $ refDigest $ storedRef r
+            , " "
+            , T.unpack $ contactName c
+            , case contactIdentity c of Nothing -> ""; Just idt -> " " ++ T.unpack (displayIdentity idt)
+            ]
+    cmdOut "contact-list-done"
+
+getContact :: Text -> CommandM Contact
+getContact cid = do
+    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
+    return contact
+
+cmdContactSetName :: Command
+cmdContactSetName = do
+    [cid, name] <- asks tiParams
+    contact <- getContact cid
+    updateLocalHead_ $ updateSharedState_ $ contactSetName contact name
+    cmdOut "contact-set-name-done"
+
+cmdDmSendPeer :: Command
+cmdDmSendPeer = do
+    [spidx, msg] <- asks tiParams
+    PeerIdentityFull to <- peerIdentity =<< getPeer spidx
+    void $ sendDirectMessage to msg
+
+cmdDmSendContact :: Command
+cmdDmSendContact = do
+    [cid, msg] <- asks tiParams
+    Just to <- contactIdentity <$> getContact cid
+    void $ sendDirectMessage to msg
+
+dmList :: Foldable f => Identity f -> Command
+dmList peer = do
+    threads <- toThreadList . lookupSharedValue . lsShared . headObject <$> getHead
+    case find (sameIdentity peer . msgPeer) threads of
+        Just thread -> do
+            forM_ (reverse $ threadToList thread) $ \DirectMessage {..} -> cmdOut $ "dm-list-item"
+                <> " from " <> (maybe "<unnamed>" T.unpack $ idName msgFrom)
+                <> " text " <> (T.unpack msgText)
+        Nothing -> return ()
+    cmdOut "dm-list-done"
+
+cmdDmListPeer :: Command
+cmdDmListPeer = do
+    [spidx] <- asks tiParams
+    PeerIdentityFull to <- peerIdentity =<< getPeer spidx
+    dmList to
+
+cmdDmListContact :: Command
+cmdDmListContact = do
+    [cid] <- asks tiParams
+    Just to <- contactIdentity <$> getContact cid
+    dmList to