Split to library and executable parts

29 files changed, 111 insertions, 1130 deletions

diff --git a/src/Attach.hs b/src/Erebos/Attach.hs
index 436f786..4fd976f 100644
--- a/src/Attach.hs
+++ b/src/Erebos/Attach.hs
@@ -1,4 +1,4 @@
-module Attach (
+module Erebos.Attach (
     AttachService,
     attachToOwner,
     attachAccept,
@@ -13,14 +13,14 @@ import Data.Maybe
 import Data.Proxy
 import qualified Data.Text as T
 
-import Identity
-import Network
-import Pairing
-import PubKey
-import Service
-import State
-import Storage
-import Storage.Key
+import Erebos.Identity
+import Erebos.Network
+import Erebos.Pairing
+import Erebos.PubKey
+import Erebos.Service
+import Erebos.State
+import Erebos.Storage
+import Erebos.Storage.Key
 
 type AttachService = PairingService AttachIdentity
 
diff --git a/src/Channel.hs b/src/Erebos/Channel.hs
index 167c1ba..c10f971 100644
--- a/src/Channel.hs
+++ b/src/Erebos/Channel.hs
@@ -1,4 +1,4 @@
-module Channel (
+module Erebos.Channel (
     Channel,
     ChannelRequest, ChannelRequestData(..),
     ChannelAccept, ChannelAcceptData(..),
@@ -24,9 +24,9 @@ import Data.ByteArray qualified as BA
 import Data.ByteString.Lazy qualified as BL
 import Data.List
 
-import Identity
-import PubKey
-import Storage
+import Erebos.Identity
+import Erebos.PubKey
+import Erebos.Storage
 
 data Channel = Channel
     { chPeers :: [Stored (Signed IdentityData)]
diff --git a/src/Contact.hs b/src/Erebos/Contact.hs
index a232b8c..d90aa50 100644
--- a/src/Contact.hs
+++ b/src/Erebos/Contact.hs
@@ -1,4 +1,4 @@
-module Contact (
+module Erebos.Contact (
     Contact,
     contactIdentity,
     contactCustomName,
@@ -21,15 +21,15 @@ import Data.Proxy
 import Data.Text (Text)
 import qualified Data.Text as T
 
-import Identity
-import Network
-import Pairing
-import PubKey
-import Service
-import Set
-import State
-import Storage
-import Storage.Merge
+import Erebos.Identity
+import Erebos.Network
+import Erebos.Pairing
+import Erebos.PubKey
+import Erebos.Service
+import Erebos.Set
+import Erebos.State
+import Erebos.Storage
+import Erebos.Storage.Merge
 
 data Contact = Contact
     { contactData :: [Stored ContactData]
diff --git a/src/Discovery.hs b/src/Erebos/Discovery.hs
index a05fdac..86bdbe7 100644
--- a/src/Discovery.hs
+++ b/src/Erebos/Discovery.hs
@@ -1,4 +1,4 @@
-module Discovery (
+module Erebos.Discovery (
     DiscoveryService(..),
     DiscoveryConnection(..)
 ) where
@@ -15,11 +15,11 @@ import qualified Data.Text as T
 
 import Network.Socket
 
-import ICE
-import Identity
-import Network
-import Service
-import Storage
+import Erebos.ICE
+import Erebos.Identity
+import Erebos.Network
+import Erebos.Service
+import Erebos.Storage
 
 
 keepaliveSeconds :: Int
diff --git a/src/Flow.hs b/src/Erebos/Flow.hs
index b52712d..ba2607a 100644
--- a/src/Flow.hs
+++ b/src/Erebos/Flow.hs
@@ -1,4 +1,4 @@
-module Flow (
+module Erebos.Flow (
     Flow, SymFlow,
     newFlow, newFlowIO,
     readFlow, tryReadFlow, canReadFlow,
diff --git a/src/ICE.chs b/src/Erebos/ICE.chs
index d553a88..096ee0d 100644
--- a/src/ICE.chs
+++ b/src/Erebos/ICE.chs
@@ -1,7 +1,7 @@
 {-# LANGUAGE ForeignFunctionInterface #-}
 {-# LANGUAGE RecursiveDo #-}
 
-module ICE (
+module Erebos.ICE (
     IceSession,
     IceSessionRole(..),
     IceRemoteInfo,
@@ -39,8 +39,8 @@ import Foreign.Marshal.Array
 import Foreign.Ptr
 import Foreign.StablePtr
 
-import Flow
-import Storage
+import Erebos.Flow
+import Erebos.Storage
 
 #include "pjproject.h"
 
diff --git a/src/ICE/pjproject.c b/src/Erebos/ICE/pjproject.c
index 0ae69e9..bb06b1f 100644
--- a/src/ICE/pjproject.c
+++ b/src/Erebos/ICE/pjproject.c
@@ -1,5 +1,5 @@
 #include "pjproject.h"
-#include "ICE_stub.h"
+#include "Erebos/ICE_stub.h"
 
 #include <stdio.h>
 #include <stdlib.h>
diff --git a/src/ICE/pjproject.h b/src/Erebos/ICE/pjproject.h
index e230e75..e230e75 100644
--- a/src/ICE/pjproject.h
+++ b/src/Erebos/ICE/pjproject.h
diff --git a/src/Identity.hs b/src/Erebos/Identity.hs
index 7c49c9f..8761fde 100644
--- a/src/Identity.hs
+++ b/src/Erebos/Identity.hs
@@ -1,6 +1,6 @@
 {-# LANGUAGE UndecidableInstances #-}
 
-module Identity (
+module Erebos.Identity (
     Identity, ComposedIdentity, UnifiedIdentity,
     IdentityData(..), ExtendedIdentityData(..), IdentityExtension(..),
     idData, idDataF, idExtData, idExtDataF,
@@ -41,10 +41,10 @@ import qualified Data.Set as S
 import Data.Text (Text)
 import qualified Data.Text as T
 
-import PubKey
-import Storage
-import Storage.Merge
-import Util
+import Erebos.PubKey
+import Erebos.Storage
+import Erebos.Storage.Merge
+import Erebos.Util
 
 data Identity m = IdentityKind m => Identity
     { idData_ :: m (Stored (Signed ExtendedIdentityData))
diff --git a/src/Message.hs b/src/Erebos/Message.hs
index 334cd1e..7fe25e6 100644
--- a/src/Message.hs
+++ b/src/Erebos/Message.hs
@@ -1,4 +1,4 @@
-module Message (
+module Erebos.Message (
     DirectMessage(..),
     sendDirectMessage,
 
@@ -27,12 +27,12 @@ import qualified Data.Text as T
 import Data.Time.Format
 import Data.Time.LocalTime
 
-import Identity
-import Network
-import Service
-import State
-import Storage
-import Storage.Merge
+import Erebos.Identity
+import Erebos.Network
+import Erebos.Service
+import Erebos.State
+import Erebos.Storage
+import Erebos.Storage.Merge
 
 data DirectMessage = DirectMessage
     { msgFrom :: ComposedIdentity
diff --git a/src/Network.hs b/src/Erebos/Network.hs
index 58e9816..dc3df4b 100644
--- a/src/Network.hs
+++ b/src/Erebos/Network.hs
@@ -1,4 +1,4 @@
-module Network (
+module Erebos.Network (
     Server,
     startServer,
     stopServer,
@@ -43,16 +43,16 @@ import GHC.Conc.Sync (unsafeIOToSTM)
 import Network.Socket hiding (ControlMessage)
 import qualified Network.Socket.ByteString as S
 
-import Channel
-import ICE
-import Identity
-import Network.Protocol
-import PubKey
-import Service
-import State
-import Storage
-import Storage.Key
-import Storage.Merge
+import Erebos.Channel
+import Erebos.ICE
+import Erebos.Identity
+import Erebos.Network.Protocol
+import Erebos.PubKey
+import Erebos.Service
+import Erebos.State
+import Erebos.Storage
+import Erebos.Storage.Key
+import Erebos.Storage.Merge
 
 
 discoveryPort :: PortNumber
diff --git a/src/Network.hs-boot b/src/Erebos/Network.hs-boot
index f251e5e..849bfc1 100644
--- a/src/Network.hs-boot
+++ b/src/Erebos/Network.hs-boot
@@ -1,6 +1,6 @@
-module Network where
+module Erebos.Network where
 
-import Storage
+import Erebos.Storage
 
 data Server
 data Peer
diff --git a/src/Network/Protocol.hs b/src/Erebos/Network/Protocol.hs
index 1240fde..d7253e3 100644
--- a/src/Network/Protocol.hs
+++ b/src/Erebos/Network/Protocol.hs
@@ -1,4 +1,4 @@
-module Network.Protocol (
+module Erebos.Network.Protocol (
     TransportPacket(..),
     transportToObject,
     TransportHeader(..),
@@ -20,7 +20,7 @@ module Network.Protocol (
     connGetChannel,
     connSetChannel,
 
-    module Flow,
+    module Erebos.Flow,
 ) where
 
 import Control.Applicative
@@ -42,11 +42,11 @@ import Data.Text qualified as T
 
 import System.Clock
 
-import Channel
-import Flow
-import Identity
-import Service
-import Storage
+import Erebos.Channel
+import Erebos.Flow
+import Erebos.Identity
+import Erebos.Service
+import Erebos.Storage
 
 
 protocolVersion :: Text
diff --git a/src/Network/ifaddrs.c b/src/Erebos/Network/ifaddrs.c
index 37c3e00..37c3e00 100644
--- a/src/Network/ifaddrs.c
+++ b/src/Erebos/Network/ifaddrs.c
diff --git a/src/Network/ifaddrs.h b/src/Erebos/Network/ifaddrs.h
index 06d26ec..06d26ec 100644
--- a/src/Network/ifaddrs.h
+++ b/src/Erebos/Network/ifaddrs.h
diff --git a/src/Pairing.hs b/src/Erebos/Pairing.hs
index 0b31625..4541f6e 100644
--- a/src/Pairing.hs
+++ b/src/Erebos/Pairing.hs
@@ -1,4 +1,4 @@
-module Pairing (
+module Erebos.Pairing (
     PairingService(..),
     PairingState(..),
     PairingAttributes(..),
@@ -24,12 +24,12 @@ import Data.Maybe
 import Data.Typeable
 import Data.Word
 
-import Identity
-import Network
-import PubKey
-import Service
-import State
-import Storage
+import Erebos.Identity
+import Erebos.Network
+import Erebos.PubKey
+import Erebos.Service
+import Erebos.State
+import Erebos.Storage
 
 data PairingService a = PairingRequest (Stored (Signed IdentityData)) (Stored (Signed IdentityData)) RefDigest
                       | PairingResponse Bytes
diff --git a/src/PubKey.hs b/src/Erebos/PubKey.hs
index 5f235eb..09a8e02 100644
--- a/src/PubKey.hs
+++ b/src/Erebos/PubKey.hs
@@ -1,4 +1,4 @@
-module PubKey (
+module Erebos.PubKey (
     PublicKey, SecretKey,
     KeyPair(generateKeys), loadKey, loadKeyMb,
     Signature(sigKey), Signed, signedData, signedSignature,
@@ -21,8 +21,8 @@ import Data.ByteArray
 import Data.ByteString (ByteString)
 import qualified Data.Text as T
 
-import Storage
-import Storage.Key
+import Erebos.Storage
+import Erebos.Storage.Key
 
 data PublicKey = PublicKey ED.PublicKey
     deriving (Show)
diff --git a/src/Service.hs b/src/Erebos/Service.hs
index f15662e..f8428d1 100644
--- a/src/Service.hs
+++ b/src/Erebos/Service.hs
@@ -1,4 +1,4 @@
-module Service (
+module Erebos.Service (
     Service(..),
     SomeService(..), someService, someServiceAttr, someServiceID,
     SomeServiceState(..), fromServiceState, someServiceEmptyState,
@@ -32,10 +32,10 @@ import Data.Typeable
 import Data.UUID (UUID)
 import qualified Data.UUID as U
 
-import Identity
-import {-# SOURCE #-} Network
-import State
-import Storage
+import Erebos.Identity
+import {-# SOURCE #-} Erebos.Network
+import Erebos.State
+import Erebos.Storage
 
 class (Typeable s, Storable s, Typeable (ServiceState s), Typeable (ServiceGlobalState s)) => Service s where
     serviceID :: proxy s -> ServiceID
diff --git a/src/Set.hs b/src/Erebos/Set.hs
index 263103f..0abe02d 100644
--- a/src/Set.hs
+++ b/src/Erebos/Set.hs
@@ -1,4 +1,4 @@
-module Set (
+module Erebos.Set (
     Set,
 
     emptySet,
@@ -18,9 +18,9 @@ import Data.Map qualified as M
 import Data.Maybe
 import Data.Ord
 
-import Storage
-import Storage.Merge
-import Util
+import Erebos.Storage
+import Erebos.Storage.Merge
+import Erebos.Util
 
 data Set a = Set [Stored (SetItem (Component a))]
 
diff --git a/src/State.hs b/src/Erebos/State.hs
index e1ddcea..1f0bf7d 100644
--- a/src/State.hs
+++ b/src/Erebos/State.hs
@@ -1,4 +1,4 @@
-module State (
+module Erebos.State (
     LocalState(..),
     SharedState, SharedType(..),
     SharedTypeID, mkSharedTypeID,
@@ -32,10 +32,10 @@ import qualified Data.UUID as U
 
 import System.IO
 
-import Identity
-import PubKey
-import Storage
-import Storage.Merge
+import Erebos.Identity
+import Erebos.PubKey
+import Erebos.Storage
+import Erebos.Storage.Merge
 
 data LocalState = LocalState
     { lsIdentity :: Stored (Signed ExtendedIdentityData)
diff --git a/src/Storage.hs b/src/Erebos/Storage.hs
index 7edae8b..50e0241 100644
--- a/src/Storage.hs
+++ b/src/Erebos/Storage.hs
@@ -1,4 +1,4 @@
-module Storage (
+module Erebos.Storage (
     Storage, PartialStorage,
     openStorage, memoryStorage,
     deriveEphemeralStorage, derivePartialStorage,
@@ -104,7 +104,7 @@ import System.INotify
 import System.IO.Error
 import System.IO.Unsafe
 
-import Storage.Internal
+import Erebos.Storage.Internal
 
 
 type Storage = Storage' Complete
diff --git a/src/Storage/Internal.hs b/src/Erebos/Storage/Internal.hs
index 7b29193..47d344f 100644
--- a/src/Storage/Internal.hs
+++ b/src/Erebos/Storage/Internal.hs
@@ -1,4 +1,4 @@
-module Storage.Internal where
+module Erebos.Storage.Internal where
 
 import Codec.Compression.Zlib
 
diff --git a/src/Storage/Key.hs b/src/Erebos/Storage/Key.hs
index 7730f9f..4a97976 100644
--- a/src/Storage/Key.hs
+++ b/src/Erebos/Storage/Key.hs
@@ -1,4 +1,4 @@
-module Storage.Key (
+module Erebos.Storage.Key (
     KeyPair(..),
     storeKey, loadKey, loadKeyMb,
     moveKeys,
@@ -17,8 +17,8 @@ import System.Directory
 import System.FilePath
 import System.IO.Error
 
-import Storage
-import Storage.Internal
+import Erebos.Storage
+import Erebos.Storage.Internal
 
 class Storable pub => KeyPair sec pub | sec -> pub, pub -> sec where
     generateKeys :: Storage -> IO (sec, Stored pub)
diff --git a/src/Storage/List.hs b/src/Erebos/Storage/List.hs
index 2bef401..ef56c60 100644
--- a/src/Storage/List.hs
+++ b/src/Erebos/Storage/List.hs
@@ -1,4 +1,4 @@
-module Storage.List (
+module Erebos.Storage.List (
     StoredList,
     emptySList, fromSList, storedFromSList,
     slistAdd, slistAddS,
@@ -16,9 +16,9 @@ import Data.List
 import Data.Maybe
 import qualified Data.Set as S
 
-import Storage
-import Storage.Internal
-import Storage.Merge
+import Erebos.Storage
+import Erebos.Storage.Internal
+import Erebos.Storage.Merge
 
 data List a = ListNil
             | ListItem { listPrev :: [StoredList a]
diff --git a/src/Storage/Merge.hs b/src/Erebos/Storage/Merge.hs
index 7c6992f..7234b87 100644
--- a/src/Storage/Merge.hs
+++ b/src/Erebos/Storage/Merge.hs
@@ -1,4 +1,4 @@
-module Storage.Merge (
+module Erebos.Storage.Merge (
     Mergeable(..),
     merge, storeMerge,
 
@@ -30,9 +30,9 @@ import Data.Set qualified as S
 
 import System.IO.Unsafe (unsafePerformIO)
 
-import Storage
-import Storage.Internal
-import Util
+import Erebos.Storage
+import Erebos.Storage.Internal
+import Erebos.Util
 
 class Storable (Component a) => Mergeable a where
     type Component a :: Type
diff --git a/src/Sync.hs b/src/Erebos/Sync.hs
index dd801b5..04b5f11 100644
--- a/src/Sync.hs
+++ b/src/Erebos/Sync.hs
@@ -1,4 +1,4 @@
-module Sync (
+module Erebos.Sync (
     SyncService(..),
 ) where
 
@@ -7,11 +7,11 @@ import Control.Monad.Reader
 
 import Data.List
 
-import Identity
-import Service
-import State
-import Storage
-import Storage.Merge
+import Erebos.Identity
+import Erebos.Service
+import Erebos.State
+import Erebos.Storage
+import Erebos.Storage.Merge
 
 data SyncService = SyncPacket (Stored SharedState)
 
diff --git a/src/Util.hs b/src/Erebos/Util.hs
index c69adee..ffca9c7 100644
--- a/src/Util.hs
+++ b/src/Erebos/Util.hs
@@ -1,4 +1,4 @@
-module Util where
+module Erebos.Util where
 
 uniq :: Eq a => [a] -> [a]
 uniq (x:y:xs) | x == y    = uniq (x:xs)
diff --git a/src/Main.hs b/src/Main.hs
deleted file mode 100644
index cbefeb2..0000000
--- a/src/Main.hs
+++ /dev/null
@@ -1,469 +0,0 @@
-{-# 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 Attach
-import Contact
-import Discovery
-import ICE
-import Identity
-import Message
-import Network
-import PubKey
-import Service
-import Set
-import State
-import Storage
-import Storage.Merge
-import 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/src/Test.hs b/src/Test.hs
deleted file mode 100644
index ab9a78c..0000000
--- a/src/Test.hs
+++ /dev/null
@@ -1,550 +0,0 @@
-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 Attach
-import Contact
-import Identity
-import Message
-import Network
-import Pairing
-import PubKey
-import Service
-import Set
-import State
-import Storage
-import Storage.Internal (unsafeStoreRawBytes)
-import Storage.Merge
-import 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