erebos 0.1.9 → 0.2.0

raw patch · 49 files changed

+4604/−2740 lines, 49 filesdep +ansi-terminaldep +uuid-typesdep +websocketsdep −haskelinedep −uuiddep ~stmPVP ok

version bump matches the API change (PVP)

Dependencies added: ansi-terminal, uuid-types, websockets

Dependencies removed: haskeline, uuid

Dependency ranges changed: stm

API changes (from Hackage documentation)

Files

• CHANGELOG.md +28/−0
• README.md +8/−2
• erebos.cabal +25/−10
• main/Main.hs +364/−313
• main/State.hs +115/−0
• main/Terminal.hs +421/−0
• main/Test.hs +248/−124
• main/Test/Service.hs +22/−2
• main/WebSocket.hs +48/−0
• src/Erebos/Attach.hs +6/−6
• src/Erebos/Channel.hs +0/−175
• src/Erebos/Chatroom.hs +27/−22
• src/Erebos/Contact.hs +9/−11
• src/Erebos/Conversation.hs +29/−15
• src/Erebos/DirectMessage.hs +345/−0
• src/Erebos/Discovery.hs +330/−113
• src/Erebos/Error.hs +39/−0
• src/Erebos/ICE.chs +32/−21
• src/Erebos/ICE/pjproject.c +10/−10
• src/Erebos/ICE/pjproject.h +8/−8
• src/Erebos/Identity.hs +24/−21
• src/Erebos/Message.hs +0/−283
• src/Erebos/Network.hs +174/−125
• src/Erebos/Network.hs-boot +2/−1
• src/Erebos/Network/Address.hs +65/−0
• src/Erebos/Network/Channel.hs +175/−0
• src/Erebos/Network/Protocol.hs +67/−30
• src/Erebos/Network/ifaddrs.c +5/−5
• src/Erebos/Network/ifaddrs.h +3/−3
• src/Erebos/Object.hs +23/−0
• src/Erebos/Object/Internal.hs +772/−0
• src/Erebos/Pairing.hs +36/−34
• src/Erebos/PubKey.hs +5/−6
• src/Erebos/Service.hs +18/−13
• src/Erebos/Service/Stream.hs +74/−0
• src/Erebos/Set.hs +6/−6
• src/Erebos/State.hs +58/−77
• src/Erebos/Storable.hs +44/−0
• src/Erebos/Storage.hs +29/−1087
• src/Erebos/Storage/Backend.hs +28/−0
• src/Erebos/Storage/Disk.hs +230/−0
• src/Erebos/Storage/Head.hs +258/−0
• src/Erebos/Storage/Internal.hs +163/−143
• src/Erebos/Storage/Key.hs +22/−56
• src/Erebos/Storage/Memory.hs +107/−0
• src/Erebos/Storage/Merge.hs +38/−10
• src/Erebos/Sync.hs +3/−2
• src/Erebos/UUID.hs +24/−0
• src/Erebos/Util.hs +37/−6

@@ -1,5 +1,33 @@ # Revision history for erebos +## 0.2.0 -- 2025-08-06++* Weak references in records+* Use XDG data directory for default storage path+* Added `/identity` command to show details of current identity+* Support tunnel for peers in discovery service+* New CLI prompt implementation providing cleaner interface+    * Avoids displaying sent messages twice – both in previous prompt and in message history+    * Print received messages only for selected conversation+    * Clear tab completion options after use++* API+    * Split `Erebos.Storage` into multiple modules+    * Removed deprecated `Message.formatMessage` alias+    * Renamed `Erebos.Message` module to `Erebos.DirectMessage`+    * Added `StorageBackend` type class to allow custom storage implementation+    * `MonadError` constraints use generic error type+    * Replaced `Erebos.Network.peerAddress` with `getPeerAddress` and added `getPeerAddresses`+    * Renamed `Erebos.Network.peerIdentity` to `getPeerIdentity`+    * Renamed some functions in `Erebos.DirectMessage` module to make clear they are related only to direct messages+    * `Erebos.Storage.Merge.generations`/`generationsBy` return `NonEmpty`+    * Replaced `watchReceivedDirectMessages` with `watchDirectMessageThreads`+    * Return type of `sendMessage` and `sendDirectMessage` is now `()`+    * Some functions use `MonadStorage` instead of explicit `Storage` parameter:+        * `Erebos.Set.storeSetAdd`+        * `Erebos.State.makeSharedStateUpdate`+        * `Erebos.Identity.createIdentity`+ ## 0.1.9 -- 2025-07-08  * Option to show details or delete a conversation by giving index parameter without first selecting it

@@ -216,6 +216,9 @@ : Drop the currently selected peer. Afterwards, the connection can be   re-established by either side. +`/identity`  +: Show details of current identity+ `/update-identity`   : Interactively update current identity information @@ -226,8 +229,11 @@ Storage ------- -Data are by default stored within `.erebos` subdirectory of the current working-directory. This can be overriden by `EREBOS_DIR` environment variable.+Data are by default stored under `XDG_DATA_HOME`, typically+`$HOME/.local/share/erebos`, unless there is an erebos storage already+in `.erebos` subdirectory of the current working directory, in which case the+latter one in used instead. This can be overriden by `EREBOS_DIR` environment+variable.  Private keys are currently stored in plaintext under the `keys` subdirectory of the erebos directory.

@@ -1,7 +1,7 @@ Cabal-Version:       3.0  Name:                erebos-Version:             0.1.9+Version:             0.2.0 Synopsis:            Decentralized messaging and synchronization Description:     Library and simple CLI interface implementing the Erebos identity@@ -100,30 +100,40 @@     hs-source-dirs:      src     exposed-modules:         Erebos.Attach-        Erebos.Channel         Erebos.Chatroom         Erebos.Contact         Erebos.Conversation+        Erebos.DirectMessage         Erebos.Discovery+        Erebos.Error         Erebos.Identity-        Erebos.Message         Erebos.Network-        Erebos.Network.Protocol+        Erebos.Object         Erebos.Pairing         Erebos.PubKey         Erebos.Service+        Erebos.Service.Stream         Erebos.Set         Erebos.State+        Erebos.Storable         Erebos.Storage+        Erebos.Storage.Backend+        Erebos.Storage.Head         Erebos.Storage.Key         Erebos.Storage.Merge         Erebos.Sync -        -- Used by test tool:-        Erebos.Storage.Internal     other-modules:         Erebos.Flow+        Erebos.Network.Address+        Erebos.Network.Channel+        Erebos.Network.Protocol+        Erebos.Object.Internal+        Erebos.Storage.Disk+        Erebos.Storage.Internal+        Erebos.Storage.Memory         Erebos.Storage.Platform+        Erebos.UUID         Erebos.Util      c-sources:@@ -134,7 +144,7 @@         src/Erebos/Network/ifaddrs.h      if flag(ice)-        exposed-modules:+        other-modules:             Erebos.ICE         c-sources:             src/Erebos/ICE/pjproject.c@@ -164,7 +174,7 @@         stm >=2.5 && <2.6,         text >= 1.2 && <2.2,         time ^>= { 1.8, 1.9, 1.10, 1.11, 1.12, 1.13, 1.14 },-        uuid >=1.3 && <1.4,+        uuid-types ^>= { 1.0.4 },         zlib >=0.6 && <0.8      if !flag(cryptonite)@@ -192,26 +202,31 @@     main-is:             Main.hs     other-modules:         Paths_erebos+        State+        Terminal         Test         Test.Service         Version         Version.Git+        WebSocket     autogen-modules:         Paths_erebos      build-depends:+        ansi-terminal ^>= { 0.11, 1.0, 1.1 },         bytestring,         directory,         erebos,-        haskeline >=0.7 && <0.9,         mtl,         network,         process >=1.6 && <1.7,+        stm,         template-haskell ^>= { 2.17, 2.18, 2.19, 2.20, 2.21, 2.22, 2.23 },         text,         time,         transformers >= 0.5 && <0.7,-        uuid,+        uuid-types,+        websockets ^>= { 0.12.7, 0.13 },      if !flag(cryptonite)         build-depends:

@@ -1,9 +1,7 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}  module Main (main) where -import Control.Arrow (first) import Control.Concurrent import Control.Exception import Control.Monad@@ -11,11 +9,13 @@ import Control.Monad.Reader import Control.Monad.State import Control.Monad.Trans.Maybe+import Control.Monad.Writer  import Crypto.Random -import qualified Data.ByteString.Char8 as BC-import qualified Data.ByteString.Lazy as BL+import Data.Bifunctor+import Data.ByteString.Char8 qualified as BC+import Data.ByteString.Lazy qualified as BL import Data.Char import Data.List import Data.Maybe@@ -31,7 +31,7 @@ import Network.Socket  import System.Console.GetOpt-import System.Console.Haskeline+import System.Directory import System.Environment import System.Exit import System.IO@@ -40,30 +40,34 @@ import Erebos.Contact import Erebos.Chatroom import Erebos.Conversation+import Erebos.DirectMessage import Erebos.Discovery-#ifdef ENABLE_ICE_SUPPORT-import Erebos.ICE-#endif import Erebos.Identity-import Erebos.Message hiding (formatMessage) import Erebos.Network+import Erebos.Object import Erebos.PubKey import Erebos.Service import Erebos.Set import Erebos.State+import Erebos.Storable import Erebos.Storage import Erebos.Storage.Merge import Erebos.Sync +import State+import Terminal import Test import Version+import WebSocket  data Options = Options     { optServer :: ServerOptions     , optServices :: [ServiceOption]     , optStorage :: StorageOption+    , optCreateIdentity :: Maybe ( Maybe Text, [ Maybe Text ] )     , optChatroomAutoSubscribe :: Maybe Int     , optDmBotEcho :: Maybe Text+    , optWebSocketServer :: Maybe Int     , optShowHelp :: Bool     , optShowVersion :: Bool     }@@ -84,8 +88,10 @@     { optServer = defaultServerOptions     , optServices = availableServices     , optStorage = DefaultStorage+    , optCreateIdentity = Nothing     , optChatroomAutoSubscribe = Nothing     , optDmBotEcho = Nothing+    , optWebSocketServer = Nothing     , optShowHelp = False     , optShowVersion = False     }@@ -106,7 +112,7 @@         True "peer discovery"     ] -options :: [OptDescr (Options -> Options)]+options :: [ OptDescr (Options -> Writer [ String ] Options) ] options =     [ Option ['p'] ["port"]         (ReqArg (\p -> so $ \opts -> opts { serverPort = read p }) "<port>")@@ -115,57 +121,92 @@         (NoArg (so $ \opts -> opts { serverLocalDiscovery = False }))         "do not send announce packets for local discovery"     , Option [] [ "storage" ]-        (ReqArg (\path -> \opts -> opts { optStorage = FilesystemStorage path }) "<path>")+        (ReqArg (\path -> \opts -> return opts { optStorage = FilesystemStorage path }) "<path>")         "use storage in <path>"     , Option [] [ "memory-storage" ]-        (NoArg (\opts -> opts { optStorage = MemoryStorage }))+        (NoArg (\opts -> return opts { optStorage = MemoryStorage }))         "use memory storage"+    , Option [] [ "create-identity" ]+        (OptArg (\value -> \opts -> return opts+            { optCreateIdentity =+                let devName = T.pack <$> value+                 in maybe (Just ( devName, [] )) (Just . first (const devName)) (optCreateIdentity opts)+            }) "<name>")+        "create a new (device) identity in a new local state"+    , Option [] [ "create-owner" ]+        (OptArg (\value -> \opts -> return opts+            { optCreateIdentity =+                let ownerName = T.pack <$> value+                 in maybe (Just ( Nothing, [ ownerName ] )) (Just . second (ownerName :)) (optCreateIdentity opts)+            }) "<name>")+        "create owner for a new device identity"     , Option [] ["chatroom-auto-subscribe"]-        (ReqArg (\count -> \opts -> opts { optChatroomAutoSubscribe = Just (read count) }) "<count>")+        (ReqArg (\count -> \opts -> return opts { optChatroomAutoSubscribe = Just (read count) }) "<count>")         "automatically subscribe for up to <count> chatrooms"-#ifdef ENABLE_ICE_SUPPORT     , Option [] [ "discovery-stun-port" ]-        (ReqArg (\value -> serviceAttr $ \attrs -> attrs { discoveryStunPort = Just (read value) }) "<port>")+        (ReqArg (\value -> serviceAttr $ \attrs -> return attrs { discoveryStunPort = Just (read value) }) "<port>")         "offer specified <port> to discovery peers for STUN protocol"     , Option [] [ "discovery-stun-server" ]-        (ReqArg (\value -> serviceAttr $ \attrs -> attrs { discoveryStunServer = Just (read value) }) "<server>")+        (ReqArg (\value -> serviceAttr $ \attrs -> return attrs { discoveryStunServer = Just (read value) }) "<server>")         "offer <server> (domain name or IP address) to discovery peers for STUN protocol"     , Option [] [ "discovery-turn-port" ]-        (ReqArg (\value -> serviceAttr $ \attrs -> attrs { discoveryTurnPort = Just (read value) }) "<port>")+        (ReqArg (\value -> serviceAttr $ \attrs -> return attrs { discoveryTurnPort = Just (read value) }) "<port>")         "offer specified <port> to discovery peers for TURN protocol"     , Option [] [ "discovery-turn-server" ]-        (ReqArg (\value -> serviceAttr $ \attrs -> attrs { discoveryTurnServer = Just (read value) }) "<server>")+        (ReqArg (\value -> serviceAttr $ \attrs -> return attrs { discoveryTurnServer = Just (read value) }) "<server>")         "offer <server> (domain name or IP address) to discovery peers for TURN protocol"-#endif+    , Option [] [ "discovery-tunnel" ]+        (OptArg (\value -> \opts -> do+            fun <- provideTunnelFun value+            serviceAttr (\attrs -> return attrs { discoveryProvideTunnel = fun }) opts) "<peer-type>")+        "offer to provide tunnel for peers of given <peer-type>, possible values: all, none, websocket"     , Option [] ["dm-bot-echo"]-        (ReqArg (\prefix -> \opts -> opts { optDmBotEcho = Just (T.pack prefix) }) "<prefix>")+        (ReqArg (\prefix -> \opts -> return opts { optDmBotEcho = Just (T.pack prefix) }) "<prefix>")         "automatically reply to direct messages with the same text prefixed with <prefix>"+    , Option [] [ "websocket-server" ]+        (ReqArg (\value -> \opts -> return opts { optWebSocketServer = Just (read value) }) "<port>")+        "start WebSocket server on given port"     , Option ['h'] ["help"]-        (NoArg $ \opts -> opts { optShowHelp = True })+        (NoArg $ \opts -> return opts { optShowHelp = True })         "show this help and exit"     , Option ['V'] ["version"]-        (NoArg $ \opts -> opts { optShowVersion = True })+        (NoArg $ \opts -> return opts { optShowVersion = True })         "show version and exit"     ]   where-    so f opts = opts { optServer = f $ optServer opts }+    so f opts = return opts { optServer = f $ optServer opts } -    updateService :: Service s => (ServiceAttributes s -> ServiceAttributes s) -> SomeService -> SomeService+    updateService :: (Service s, Monad m, Typeable m) => (ServiceAttributes s -> m (ServiceAttributes s)) -> SomeService -> m SomeService     updateService f some@(SomeService proxy attrs)-        | Just f' <- cast f = SomeService proxy (f' attrs)-        | otherwise = some+        | Just f' <- cast f = SomeService proxy <$> f' attrs+        | otherwise = return some -    serviceAttr :: Service s => (ServiceAttributes s -> ServiceAttributes s) -> Options -> Options-    serviceAttr f opts = opts { optServices = map (\sopt -> sopt { soptService = updateService f (soptService sopt) }) (optServices opts) }+    serviceAttr :: (Service s, Monad m, Typeable m) => (ServiceAttributes s -> m (ServiceAttributes s)) -> Options -> m Options+    serviceAttr f opts = do+        services' <- forM (optServices opts) $ \sopt -> do+            service <- updateService f (soptService sopt)+            return sopt { soptService = service }+        return opts { optServices = services' } -servicesOptions :: [OptDescr (Options -> Options)]+    provideTunnelFun :: Maybe String -> Writer [ String ] (Peer -> PeerAddress -> Bool)+    provideTunnelFun Nothing = return $ \_ _ -> True+    provideTunnelFun (Just "all") = return $ \_ _ -> True+    provideTunnelFun (Just "none") = return $ \_ _ -> False+    provideTunnelFun (Just "websocket") = return $ \_ -> \case+        CustomPeerAddress addr | Just WebSocketAddress {} <- cast addr -> True+        _ -> False+    provideTunnelFun (Just name) = do+        tell [ "Invalid value of --discovery-tunnel: ‘" <> name <> "’\n" ]+        return $ \_ _ -> False++servicesOptions :: [ OptDescr (Options -> Writer [ String ] Options) ] servicesOptions = concatMap helper $ "all" : map soptName availableServices   where     helper name =-        [ Option [] ["enable-" <> name] (NoArg $ so $ change name $ \sopt -> sopt { soptEnabled = True }) ""-        , Option [] ["disable-" <> name] (NoArg $ so $ change name $ \sopt -> sopt { soptEnabled = False }) ""+        [ Option [] [ "enable-" <> name ] (NoArg $ so $ change name $ \sopt -> sopt { soptEnabled = True }) ""+        , Option [] [ "disable-" <> name ] (NoArg $ so $ change name $ \sopt -> sopt { soptEnabled = False }) ""         ]-    so f opts = opts { optServices = f $ optServices opts }+    so f opts = return opts { optServices = f $ optServices opts }     change :: String -> (ServiceOption -> ServiceOption) -> [ServiceOption] -> [ServiceOption]     change name f (s : ss)         | soptName s == name || name == "all"@@ -173,18 +214,29 @@         | otherwise =   s : change name f ss     change _ _ []   = [] +getDefaultStorageDir :: IO FilePath+getDefaultStorageDir = do+    lookupEnv "EREBOS_DIR" >>= \case+        Just dir -> return dir+        Nothing -> doesFileExist "./.erebos/erebos-storage" >>= \case+            True -> return "./.erebos"+            False -> getXdgDirectory XdgData "erebos"+ main :: IO () main = do-    (opts, args) <- (getOpt RequireOrder (options ++ servicesOptions) <$> getArgs) >>= \case-        (o, args, []) -> do-            return (foldl (flip id) defaultOptions o, args)-        (_, _, errs) -> do+    let printErrors errs = do             progName <- getProgName             hPutStrLn stderr $ concat errs <> "Try `" <> progName <> " --help' for more information."             exitFailure+    (opts, args) <- (getOpt RequireOrder (options ++ servicesOptions) <$> getArgs) >>= \case+        (wo, args, []) ->+            case runWriter (foldM (flip ($)) defaultOptions wo) of+                ( o, [] )   -> return ( o, args )+                ( _, errs ) -> printErrors errs+        (_, _, errs) -> printErrors errs      st <- liftIO $ case optStorage opts of-        DefaultStorage         -> openStorage . fromMaybe "./.erebos" =<< lookupEnv "EREBOS_DIR"+        DefaultStorage         -> openStorage =<< getDefaultStorageDir         FilesystemStorage path -> openStorage path         MemoryStorage          -> memoryStorage @@ -224,17 +276,28 @@             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+        [ "identity" ] -> do+            loadHeads st >>= \case+                (h : _) -> do+                    T.putStr $ showIdentityDetails $ headLocalIdentity h+                [] -> do+                    T.putStrLn "no local state head"+                    exitFailure +        ["update-identity"] -> do+            withTerminal noCompletion $ \term -> do+                either (fail . showErebosError) return <=< runExceptT $ do+                    runReaderT (updateSharedIdentity term) =<< runReaderT (loadLocalStateHead term) 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"+            withTerminal noCompletion $ \term -> 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 . showErebosError) return <=< runExceptT $ runReaderT (interactiveIdentityUpdate term idt) st)+                        | otherwise -> error "invalid identity"          ["test"] -> runTestTool st @@ -264,27 +327,24 @@             exitFailure  -inputSettings :: Settings IO-inputSettings = setComplete commandCompletion $ defaultSettings- interactiveLoop :: Storage -> Options -> IO ()-interactiveLoop st opts = runInputT inputSettings $ do-    erebosHead <- liftIO $ loadLocalStateHead st-    outputStrLn $ T.unpack $ displayIdentity $ headLocalIdentity erebosHead+interactiveLoop st opts = withTerminal commandCompletion $ \term -> do+    erebosHead <- either (fail . showErebosError) return <=< runExceptT . flip runReaderT st $ do+        case optCreateIdentity opts of+            Nothing -> loadLocalStateHead term+            Just ( devName, names ) -> createLocalStateHead (names ++ [ devName ])+    void $ printLine term $ T.unpack $ displayIdentity $ headLocalIdentity erebosHead -    tui <- haveTerminalUI-    extPrint <- getExternalPrint-    let extPrintLn str = do-            let str' = case reverse str of ('\n':_) -> str-                                           _ -> str ++ "\n";-            extPrint $! str' -- evaluate str before calling extPrint to avoid blinking+    let tui = hasTerminalUI term+    let extPrintLn = void . printLine term -    let getInputLinesTui eprompt = do+    let getInputLinesTui :: Either CommandState String -> MaybeT IO String+        getInputLinesTui eprompt = do             prompt <- case eprompt of                 Left cstate -> do                     pname <- case csContext cstate of                         NoContext -> return ""-                        SelectedPeer peer -> peerIdentity peer >>= return . \case+                        SelectedPeer peer -> getPeerIdentity peer >>= return . \case                             PeerIdentityFull pid -> maybe "<unnamed>" T.unpack $ idName $ finalOwner pid                             PeerIdentityRef wref _ -> "<" ++ BC.unpack (showRefDigest $ wrDigest wref) ++ ">"                             PeerIdentityUnknown _  -> "<unknown>"@@ -293,69 +353,92 @@                         SelectedConversation conv -> return $ T.unpack $ conversationName conv                     return $ pname ++ "> "                 Right prompt -> return prompt-            Just input <- lift $ getInputLine prompt-            case reverse input of-                 _ | all isSpace input -> getInputLinesTui eprompt-                 '\\':rest -> (reverse ('\n':rest) ++) <$> getInputLinesTui (Right ">> ")-                 _         -> return input+            lift $ setPrompt term prompt+            join $ lift $ getInputLine term $ \case+                Just input@('/' : _) -> KeepPrompt $ return input+                Just input -> ErasePrompt $ case reverse input of+                    _ | all isSpace input -> getInputLinesTui eprompt+                    '\\':rest -> (reverse ('\n':rest) ++) <$> getInputLinesTui (Right ">> ")+                    _         -> return input+                Nothing+                    | tui       -> KeepPrompt mzero+                    | otherwise -> KeepPrompt $ liftIO $ forever $ threadDelay 100000000          getInputCommandTui cstate = do-            input <- getInputLinesTui cstate-            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, scmd)-                                       else (fromMaybe (cmdUnknown scmd) $ lookup scmd commands, args)-                    _        -> (cmdSend, input)-            return (cmd, line)+            let parseCommand cmdline =+                    case dropWhile isSpace <$> span (\c -> isAlphaNum c || c == '-') cmdline of+                        ( scmd, args )+                            | not (null scmd) && all isDigit scmd+                            -> ( cmdSelectContext, scmd ) -        getInputLinesPipe = do-            lift (getInputLine "") >>= \case-                Just input -> return input-                Nothing -> liftIO $ forever $ threadDelay 100000000+                            | otherwise+                            -> ( fromMaybe (cmdUnknown scmd) $ lookup scmd commands, args ) -        getInputCommandPipe _ = do-            input <- getInputLinesPipe-            let (scmd, args) = dropWhile isSpace <$> span (\c -> isAlphaNum c || c == '-') input-            let (CommandM cmd, line) = (fromMaybe (cmdUnknown scmd) $ lookup scmd commands, args)-            return (cmd, line)+            ( CommandM cmd, line ) <- getInputLinesTui cstate >>= return . \case+                '/' : input     -> parseCommand input+                input | not tui -> parseCommand input+                input           -> ( cmdSend, input )+            return ( cmd, line ) -    let getInputCommand = if tui then getInputCommandTui . Left-                                 else getInputCommandPipe+    let getInputCommand = getInputCommandTui . Left +    contextVar <- liftIO $ newMVar NoContext+     _ <- liftIO $ do         tzone <- getCurrentTimeZone-        watchReceivedMessages erebosHead $ \smsg -> do-            let msg = fromStored smsg-            extPrintLn $ formatDirectMessage tzone msg-            case optDmBotEcho opts of-                Nothing -> return ()-                Just prefix -> do-                    res <- runExceptT $ flip runReaderT erebosHead $ sendDirectMessage (msgFrom msg) (prefix <> msgText msg)-                    case res of-                        Right reply -> extPrintLn $ formatDirectMessage tzone $ fromStored reply-                        Left err -> extPrintLn $ "Failed to send dm echo: " <> err+        let self = finalOwner $ headLocalIdentity erebosHead+        watchDirectMessageThreads erebosHead $ \prev cur -> do+            forM_ (reverse $ dmThreadToListSince prev cur) $ \msg -> do+                withMVar contextVar $ \ctx -> do+                    mbpid <- case ctx of+                        SelectedPeer peer -> getPeerIdentity peer >>= return . \case+                            PeerIdentityFull pid -> Just $ finalOwner pid+                            _ -> Nothing+                        SelectedContact contact+                            | Just cid <- contactIdentity contact -> return (Just cid)+                        SelectedConversation conv -> return $ conversationPeer conv+                        _ -> return Nothing+                    when (not tui || maybe False (msgPeer cur `sameIdentity`) mbpid) $ do+                        extPrintLn $ formatDirectMessage tzone msg +                case optDmBotEcho opts of+                    Just prefix+                        | not (msgFrom msg `sameIdentity` self)+                        -> do+                            void $ forkIO $ do+                                res <- runExceptT $ flip runReaderT erebosHead $ sendDirectMessage (msgFrom msg) (prefix <> msgText msg)+                                case res of+                                    Right _ -> return ()+                                    Left err -> extPrintLn $ "Failed to send dm echo: " <> err+                    _ -> return ()+     peers <- liftIO $ newMVar []-    contextOptions <- liftIO $ newMVar []+    contextOptions <- liftIO $ newMVar ( Nothing, [] )     chatroomSetVar <- liftIO $ newEmptyMVar      let autoSubscribe = optChatroomAutoSubscribe opts         chatroomList = fromSetBy (comparing roomStateData) . lookupSharedValue . lsShared . headObject $ erebosHead     watched <- if isJust autoSubscribe || any roomStateSubscribe chatroomList-        then fmap Just $ liftIO $ watchChatroomsForCli extPrintLn erebosHead chatroomSetVar contextOptions autoSubscribe-        else return Nothing+      then do+        fmap Just $ liftIO $ watchChatroomsForCli tui extPrintLn erebosHead+            chatroomSetVar contextVar contextOptions autoSubscribe+      else do+        return Nothing      server <- liftIO $ do         startServer (optServer opts) erebosHead extPrintLn $             map soptService $ filter soptEnabled $ optServices opts +    case optWebSocketServer opts of+        Just port -> startWebsocketServer server "::" port extPrintLn+        Nothing -> return ()+     void $ liftIO $ forkIO $ void $ forever $ do         peer <- getNextPeerChange server-        peerIdentity peer >>= \case+        getPeerIdentity peer >>= \case             pid@(PeerIdentityFull _) -> do                 dropped <- isPeerDropped peer-                let shown = showPeer pid $ peerAddress peer+                shown <- showPeer pid <$> getPeerAddress peer                 let update [] = ([(peer, shown)], (Nothing, "NEW"))                     update ((p,s):ps)                         | p == peer && dropped = (ps, (Nothing, "DEL"))@@ -367,36 +450,47 @@                         | otherwise = first (ctx:) $ ctxUpdate (n + 1) ctxs                 (op, updateType) <- modifyMVar peers (return . update)                 let updateType' = if dropped then "DEL" else updateType-                idx <- modifyMVar contextOptions (return . ctxUpdate (1 :: Int))-                when (Just shown /= op) $ extPrintLn $ "[" <> show idx <> "] PEER " <> updateType' <> " " <> shown+                modifyMVar_ contextOptions $ \case+                    ( watch, clist )+                      | watch == Just WatchPeers || not tui+                      -> do+                        let ( clist', idx ) = ctxUpdate (1 :: Int) clist+                        when (Just shown /= op) $ do+                            extPrintLn $ "[" <> show idx <> "] PEER " <> updateType' <> " " <> shown+                        return ( Just WatchPeers, clist' )+                    cur -> return cur             _ -> return () -    let process :: CommandState -> MaybeT (InputT IO) CommandState+    let process :: CommandState -> MaybeT IO CommandState         process cstate = do             (cmd, line) <- getInputCommand cstate             h <- liftIO (reloadHead $ csHead cstate) >>= \case                 Just h  -> return h-                Nothing -> do lift $ lift $ extPrintLn "current head deleted"+                Nothing -> do lift $ extPrintLn "current head deleted"                               mzero-            res <- liftIO $ runExceptT $ flip execStateT cstate { csHead = h } $ runReaderT cmd CommandInput-                { ciServer = server-                , ciLine = line-                , ciPrint = extPrintLn-                , ciOptions = opts-                , ciPeers = liftIO $ modifyMVar peers $ \ps -> do-                    ps' <- filterM (fmap not . isPeerDropped . fst) ps-                    return (ps', ps')-                , ciContextOptions = liftIO $ readMVar contextOptions-                , ciSetContextOptions = \ctxs -> liftIO $ modifyMVar_ contextOptions $ const $ return ctxs-                , ciContextOptionsVar = contextOptions-                , ciChatroomSetVar = chatroomSetVar-                }+            res <- liftIO $ modifyMVar contextVar $ \ctx -> do+                res <- runExceptT $ flip execStateT cstate { csHead = h, csContext = ctx } $ runReaderT cmd CommandInput+                    { ciServer = server+                    , ciTerminal = term+                    , ciLine = line+                    , ciPrint = extPrintLn+                    , ciOptions = opts+                    , ciPeers = liftIO $ modifyMVar peers $ \ps -> do+                        ps' <- filterM (fmap not . isPeerDropped . fst) ps+                        return (ps', ps')+                    , ciContextOptions = liftIO $ snd <$> readMVar contextOptions+                    , ciSetContextOptions = \watch ctxs -> liftIO $ modifyMVar_ contextOptions $ const $ return ( Just watch, ctxs )+                    , ciContextVar = contextVar+                    , ciContextOptionsVar = contextOptions+                    , ciChatroomSetVar = chatroomSetVar+                    }+                return ( either (const ctx) csContext res, res )             case res of                 Right cstate'                     | csQuit cstate' -> mzero                     | otherwise      -> return cstate'                 Left err -> do-                    lift $ lift $ extPrintLn $ "Error: " ++ err+                    lift $ extPrintLn $ "Error: " ++ showErebosError err                     return cstate      let loop (Just cstate) = runMaybeT (process cstate) >>= loop@@ -404,10 +498,6 @@     loop $ Just $ CommandState         { csHead = erebosHead         , csContext = NoContext-#ifdef ENABLE_ICE_SUPPORT-        , csIceSessions = []-#endif-        , csIcePeer = Nothing         , csWatchChatrooms = watched         , csQuit = False         }@@ -415,42 +505,48 @@  data CommandInput = CommandInput     { ciServer :: Server+    , ciTerminal :: Terminal     , ciLine :: String     , ciPrint :: String -> IO ()     , ciOptions :: Options     , ciPeers :: CommandM [(Peer, String)]-    , ciContextOptions :: CommandM [CommandContext]-    , ciSetContextOptions :: [CommandContext] -> Command-    , ciContextOptionsVar :: MVar [ CommandContext ]+    , ciContextOptions :: CommandM [ CommandContext ]+    , ciSetContextOptions :: ContextWatchOptions -> [ CommandContext ] -> Command+    , ciContextVar :: MVar CommandContext+    , ciContextOptionsVar :: MVar ( Maybe ContextWatchOptions, [ CommandContext ] )     , ciChatroomSetVar :: MVar (Set ChatroomState)     }  data CommandState = CommandState     { csHead :: Head LocalState     , csContext :: CommandContext-#ifdef ENABLE_ICE_SUPPORT-    , csIceSessions :: [IceSession]-#endif-    , csIcePeer :: Maybe Peer     , csWatchChatrooms :: Maybe WatchedHead     , csQuit :: Bool     } -data CommandContext = NoContext-                    | SelectedPeer Peer-                    | SelectedContact Contact-                    | SelectedChatroom ChatroomState-                    | SelectedConversation Conversation+data CommandContext+    = NoContext+    | SelectedPeer Peer+    | SelectedContact Contact+    | SelectedChatroom ChatroomState+    | SelectedConversation Conversation -newtype CommandM a = CommandM (ReaderT CommandInput (StateT CommandState (ExceptT String IO)) a)-    deriving (Functor, Applicative, Monad, MonadReader CommandInput, MonadState CommandState, MonadError String)+data ContextWatchOptions+    = WatchPeers+    | WatchContacts+    | WatchChatrooms+    | WatchConversations+    deriving (Eq) +newtype CommandM a = CommandM (ReaderT CommandInput (StateT CommandState (ExceptT ErebosError IO)) a)+    deriving (Functor, Applicative, Monad, MonadReader CommandInput, MonadState CommandState, MonadError ErebosError)+ instance MonadFail CommandM where-    fail = throwError+    fail = throwOtherError  instance MonadIO CommandM where     liftIO act = CommandM (liftIO (try act)) >>= \case-        Left (e :: SomeException) -> throwError (show e)+        Left (e :: SomeException) -> throwOtherError (show e)         Right x -> return x  instance MonadRandom CommandM where@@ -471,41 +567,42 @@ getSelectedPeer :: CommandM Peer getSelectedPeer = gets csContext >>= \case     SelectedPeer peer -> return peer-    _ -> throwError "no peer selected"+    _ -> throwOtherError "no peer selected"  getSelectedChatroom :: CommandM ChatroomState getSelectedChatroom = gets csContext >>= \case     SelectedChatroom rstate -> return rstate-    _ -> throwError "no chatroom selected"+    _ -> throwOtherError "no chatroom selected"  getSelectedConversation :: CommandM Conversation getSelectedConversation = gets csContext >>= getConversationFromContext  getConversationFromContext :: CommandContext -> CommandM Conversation getConversationFromContext = \case-    SelectedPeer peer -> peerIdentity peer >>= \case+    SelectedPeer peer -> getPeerIdentity peer >>= \case         PeerIdentityFull pid -> directMessageConversation $ finalOwner pid-        _ -> throwError "incomplete peer identity"+        _ -> throwOtherError "incomplete peer identity"     SelectedContact contact -> case contactIdentity contact of         Just cid -> directMessageConversation cid-        Nothing -> throwError "contact without erebos identity"+        Nothing -> throwOtherError "contact without erebos identity"     SelectedChatroom rstate ->         chatroomConversation rstate >>= \case             Just conv -> return conv-            Nothing -> throwError "invalid chatroom"+            Nothing -> throwOtherError "invalid chatroom"     SelectedConversation conv -> reloadConversation conv-    _ -> throwError "no contact, peer or conversation selected"+    _ -> throwOtherError "no contact, peer or conversation selected"  getSelectedOrManualContext :: CommandM CommandContext getSelectedOrManualContext = do     asks ciLine >>= \case         "" -> gets csContext-        str | all isDigit str -> getContextByIndex (read str)-        _ -> throwError "invalid index"+        str | all isDigit str -> getContextByIndex id (read str)+        _ -> throwOtherError "invalid index"  commands :: [(String, Command)] commands =     [ ("history", cmdHistory)+    , ("identity", cmdIdentity)     , ("peers", cmdPeers)     , ("peer-add", cmdPeerAdd)     , ("peer-add-public", cmdPeerAddPublic)@@ -524,15 +621,7 @@     , ("contact-reject", cmdContactReject)     , ("conversations", cmdConversations)     , ("details", cmdDetails)-    , ("discovery-init", cmdDiscoveryInit)     , ("discovery", cmdDiscovery)-#ifdef ENABLE_ICE_SUPPORT-    , ("ice-create", cmdIceCreate)-    , ("ice-destroy", cmdIceDestroy)-    , ("ice-show", cmdIceShow)-    , ("ice-connect", cmdIceConnect)-    , ("ice-send", cmdIceSend)-#endif     , ("join", cmdJoin)     , ("join-as", cmdJoinAs)     , ("leave", cmdLeave)@@ -549,16 +638,21 @@     sortedCommandNames = sort $ map fst commands  +cmdPutStrLn :: String -> Command+cmdPutStrLn str = do+    term <- asks ciTerminal+    void $ liftIO $ printLine term str+ cmdUnknown :: String -> Command-cmdUnknown cmd = liftIO $ putStrLn $ "Unknown command: " ++ cmd+cmdUnknown cmd = cmdPutStrLn $ "Unknown command: " ++ cmd  cmdPeers :: Command cmdPeers = do     peers <- join $ asks ciPeers     set <- asks ciSetContextOptions-    set $ map (SelectedPeer . fst) peers+    set WatchPeers $ map (SelectedPeer . fst) peers     forM_ (zip [1..] peers) $ \(i :: Int, (_, name)) -> do-        liftIO $ putStrLn $ "[" ++ show i ++ "] " ++ name+        cmdPutStrLn $ "[" ++ show i ++ "] " ++ name  cmdPeerAdd :: Command cmdPeerAdd = void $ do@@ -566,13 +660,17 @@     (hostname, port) <- (words <$> asks ciLine) >>= \case         hostname:p:_ -> return (hostname, p)         [hostname] -> return (hostname, show discoveryPort)-        [] -> throwError "missing peer address"+        [] -> throwOtherError "missing peer address"     addr:_ <- liftIO $ getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just hostname) (Just port)+    contextOptsVar <- asks ciContextOptionsVar+    liftIO $ modifyMVar_ contextOptsVar $ return . first (const $ Just WatchPeers)     liftIO $ serverPeer server (addrAddress addr)  cmdPeerAddPublic :: Command cmdPeerAddPublic = do     server <- asks ciServer+    contextOptsVar <- asks ciContextOptionsVar+    liftIO $ modifyMVar_ contextOptsVar $ return . first (const $ Just WatchPeers)     liftIO $ mapM_ (serverPeer server . addrAddress) =<< gather 'a'   where     gather c@@ -606,8 +704,7 @@ cmdJoinAs :: Command cmdJoinAs = do     name <- asks ciLine-    st <- getStorage-    identity <- liftIO $ createIdentity st (Just $ T.pack name) Nothing+    identity <- createIdentity (Just $ T.pack name) Nothing     joinChatroomAs identity =<< getSelectedChatroom  cmdLeave :: Command@@ -617,18 +714,22 @@ cmdMembers = do     Just room <- findChatroomByStateData . head . roomStateData =<< getSelectedChatroom     forM_ (chatroomMembers room) $ \x -> do-        liftIO $ putStrLn $ maybe "<unnamed>" T.unpack $ idName x+        cmdPutStrLn $ maybe "<unnamed>" T.unpack $ idName x -getContextByIndex :: Int -> CommandM CommandContext-getContextByIndex n = do-    join (asks ciContextOptions) >>= \ctxs -> if-        | n > 0, (ctx : _) <- drop (n - 1) ctxs -> return ctx-        | otherwise -> throwError "invalid index"+getContextByIndex :: (Maybe ContextWatchOptions -> Maybe ContextWatchOptions) -> Int -> CommandM CommandContext+getContextByIndex f n = do+    contextOptsVar <- asks ciContextOptionsVar+    join $ liftIO $ modifyMVar contextOptsVar $ \cur@( watch, ctxs ) -> if+        | n > 0, (ctx : _) <- drop (n - 1) ctxs+        -> return ( ( f watch, ctxs ), return ctx ) +        | otherwise+        -> return ( cur, throwOtherError "invalid index" )+ cmdSelectContext :: Command cmdSelectContext = do     n <- read <$> asks ciLine-    ctx <- getContextByIndex n+    ctx <- getContextByIndex (const Nothing) n     modify $ \s -> s { csContext = ctx }     case ctx of         SelectedChatroom rstate -> do@@ -640,11 +741,7 @@ cmdSend = void $ do     text <- asks ciLine     conv <- getSelectedConversation-    sendMessage conv (T.pack text) >>= \case-        Just msg -> do-            tzone <- liftIO $ getCurrentTimeZone-            liftIO $ putStrLn $ formatMessage tzone msg-        Nothing -> return ()+    sendMessage conv (T.pack text)  cmdDelete :: Command cmdDelete = void $ do@@ -657,13 +754,32 @@     case conversationHistory conv of         thread@(_:_) -> do             tzone <- liftIO $ getCurrentTimeZone-            liftIO $ mapM_ (putStrLn . formatMessage tzone) $ reverse $ take 50 thread+            mapM_ (cmdPutStrLn . formatMessage tzone) $ reverse $ take 50 thread         [] -> do-            liftIO $ putStrLn $ "<empty history>"+            cmdPutStrLn $ "<empty history>" +showIdentityDetails :: Foldable f => Identity f -> Text+showIdentityDetails identity = T.unlines $ go $ reverse $ unfoldOwners identity+  where+    go (i : is) = concat+        [ maybeToList $ ("Name: " <>) <$> idName i+        , map (("Ref: " <>) . T.pack . show . refDigest . storedRef) $ idDataF i+        , map (("ExtRef: " <>) . T.pack . show . refDigest . storedRef) $ filter isExtension $ idExtDataF i+        , do guard $ not (null is)+             "" : "Device:" : map ("  " <>) (go is)+        ]+    go [] = []+    isExtension x = case fromSigned x of BaseIdentityData {} -> False+                                         _ -> True++cmdIdentity :: Command+cmdIdentity = do+    cmdPutStrLn . T.unpack . showIdentityDetails . localIdentity . fromStored =<< getLocalHead+ cmdUpdateIdentity :: Command cmdUpdateIdentity = void $ do-    runReaderT updateSharedIdentity =<< gets csHead+    term <- asks ciTerminal+    runReaderT (updateSharedIdentity term) =<< gets csHead  cmdAttach :: Command cmdAttach = attachToOwner =<< getSelectedPeer@@ -674,8 +790,11 @@ cmdAttachReject :: Command cmdAttachReject = attachReject =<< getSelectedPeer -watchChatroomsForCli :: (String -> IO ()) -> Head LocalState -> MVar (Set ChatroomState) -> MVar [ CommandContext ] -> Maybe Int -> IO WatchedHead-watchChatroomsForCli eprint h chatroomSetVar contextVar autoSubscribe = do+watchChatroomsForCli+    :: Bool -> (String -> IO ()) -> Head LocalState -> MVar (Set ChatroomState)+    -> MVar CommandContext -> MVar ( Maybe ContextWatchOptions, [ CommandContext ] )+    -> Maybe Int -> IO WatchedHead+watchChatroomsForCli tui eprint h chatroomSetVar contextVar contextOptsVar autoSubscribe = do     subscribedNumVar <- newEmptyMVar      let ctxUpdate updateType (idx :: Int) rstate = \case@@ -710,32 +829,48 @@                     forM_ (take (num - subscribedNum) notSubscribed) $ \rstate -> do                         (runExceptT $ flip runReaderT h $ chatroomSetSubscribe (head $ roomStateData rstate) True) >>= \case                              Right () -> return ()-                             Left err -> eprint err+                             Left err -> eprint (showErebosError err)          Just diff -> do             modifyMVar_ chatroomSetVar $ return . const set+            modifyMVar_ contextOptsVar $ \case+                ( watch, clist )+                  | watch == Just WatchChatrooms || not tui+                  -> do+                    let upd c = \case+                            AddedChatroom rstate -> ctxUpdate "NEW" 1 rstate c+                            RemovedChatroom rstate -> ctxUpdate "DEL" 1 rstate c+                            UpdatedChatroom _ rstate+                                | any ((\rsd -> not (null (rsdRoom rsd))) . fromStored) (roomStateData rstate)+                                -> do+                                    ctxUpdate "UPD" 1 rstate c+                                | otherwise -> return c+                    ( watch, ) <$> foldM upd clist diff+                cur -> return cur+             forM_ diff $ \case                 AddedChatroom rstate -> do-                    modifyMVar_ contextVar $ ctxUpdate "NEW" 1 rstate                     modifyMVar_ subscribedNumVar $ return . if roomStateSubscribe rstate then (+ 1) else id                  RemovedChatroom rstate -> do-                    modifyMVar_ contextVar $ ctxUpdate "DEL" 1 rstate                     modifyMVar_ subscribedNumVar $ return . if roomStateSubscribe rstate then subtract 1 else id                  UpdatedChatroom oldroom rstate -> do-                    when (any ((\rsd -> not (null (rsdRoom rsd))) . fromStored) (roomStateData rstate)) $ do-                        modifyMVar_ contextVar $ ctxUpdate "UPD" 1 rstate                     when (any (not . null . rsdMessages . fromStored) (roomStateData rstate)) $ do-                        tzone <- getCurrentTimeZone-                        forM_ (reverse $ getMessagesSinceState rstate oldroom) $ \msg -> do-                            eprint $ concat $-                                [ maybe "<unnamed>" T.unpack $ roomName =<< cmsgRoom msg-                                , formatTime defaultTimeLocale " [%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ cmsgTime msg-                                , maybe "<unnamed>" T.unpack $ idName $ cmsgFrom msg-                                , if cmsgLeave msg then " left" else ""-                                , maybe (if cmsgLeave msg then "" else " joined") ((": " ++) . T.unpack) $ cmsgText msg-                                ]+                        withMVar contextVar $ \ctx -> do+                            isSelected <- case ctx of+                                SelectedChatroom rstate' -> return $ isSameChatroom rstate' rstate+                                SelectedConversation conv -> return $ isChatroomStateConversation rstate conv+                                _ -> return False+                            when (not tui || isSelected) $ do+                                tzone <- getCurrentTimeZone+                                forM_ (reverse $ getMessagesSinceState rstate oldroom) $ \msg -> do+                                    eprint $ concat $+                                        [ formatTime defaultTimeLocale "[%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ cmsgTime msg+                                        , maybe "<unnamed>" T.unpack $ idName $ cmsgFrom msg+                                        , if cmsgLeave msg then " left" else ""+                                        , maybe (if cmsgLeave msg then "" else " joined") ((": " ++) . T.unpack) $ cmsgText msg+                                        ]                     modifyMVar_ subscribedNumVar $ return                         . (if roomStateSubscribe rstate then (+ 1) else id)                         . (if roomStateSubscribe oldroom then subtract 1 else id)@@ -747,9 +882,11 @@             eprint <- asks ciPrint             h <- gets csHead             chatroomSetVar <- asks ciChatroomSetVar-            contextVar <- asks ciContextOptionsVar+            contextVar <- asks ciContextVar+            contextOptsVar <- asks ciContextOptionsVar             autoSubscribe <- asks $ optChatroomAutoSubscribe . ciOptions-            watched <- liftIO $ watchChatroomsForCli eprint h chatroomSetVar contextVar autoSubscribe+            tui <- asks $ hasTerminalUI . ciTerminal+            watched <- liftIO $ watchChatroomsForCli tui eprint h chatroomSetVar contextVar contextOptsVar autoSubscribe             modify $ \s -> s { csWatchChatrooms = Just watched }         Just _ -> return () @@ -759,20 +896,22 @@     chatroomSetVar <- asks ciChatroomSetVar     chatroomList <- filter (not . roomStateDeleted) . fromSetBy (comparing roomStateData) <$> liftIO (readMVar chatroomSetVar)     set <- asks ciSetContextOptions-    set $ map SelectedChatroom chatroomList+    set WatchChatrooms $ map SelectedChatroom chatroomList     forM_ (zip [1..] chatroomList) $ \(i :: Int, rstate) -> do-        liftIO $ putStrLn $ "[" ++ show i ++ "] " ++ maybe "<unnamed>" T.unpack (roomName =<< roomStateRoom rstate)+        cmdPutStrLn $ "[" ++ show i ++ "] " ++ maybe "<unnamed>" T.unpack (roomName =<< roomStateRoom rstate)  cmdChatroomCreatePublic :: Command cmdChatroomCreatePublic = do+    term <- asks ciTerminal     name <- asks ciLine >>= \case         line | not (null line) -> return $ T.pack line         _ -> liftIO $ do-            T.putStr $ T.pack "Name: "-            hFlush stdout-            T.getLine+            setPrompt term "Name: "+            getInputLine term $ KeepPrompt . maybe T.empty T.pack      ensureWatchedChatrooms+    contextOptsVar <- asks ciContextOptionsVar+    liftIO $ modifyMVar_ contextOptsVar $ return . first (const $ Just WatchChatrooms)     void $ createChatroom         (if T.null name then Nothing else Just name)         Nothing@@ -785,9 +924,9 @@     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+    set WatchContacts $ map SelectedContact contacts+    forM_ (zip [1..] contacts) $ \(i :: Int, c) -> do+        cmdPutStrLn $ T.unpack $ T.concat             [ "[", T.pack (show i), "] ", contactName c             , case contactIdentity c of                    Just idt | cname <- displayIdentity idt@@ -811,38 +950,39 @@ cmdConversations = do     conversations <- lookupConversations     set <- asks ciSetContextOptions-    set $ map SelectedConversation conversations+    set WatchConversations $ map SelectedConversation conversations     forM_ (zip [1..] conversations) $ \(i :: Int, conv) -> do-        liftIO $ putStrLn $ "[" ++ show i ++ "] " ++ T.unpack (conversationName conv)+        cmdPutStrLn $ "[" ++ show i ++ "] " ++ T.unpack (conversationName conv)  cmdDetails :: Command cmdDetails = do     getSelectedOrManualContext >>= \case         SelectedPeer peer -> do-            liftIO $ putStr $ unlines+            paddr <- getPeerAddress peer+            cmdPutStrLn $ unlines                 [ "Network peer:"-                , "  " <> show (peerAddress peer)+                , "  " <> show paddr                 ]-            peerIdentity peer >>= \case-                PeerIdentityUnknown _ -> liftIO $ do-                    putStrLn $ "unknown identity"-                PeerIdentityRef wref _ -> liftIO $ do-                    putStrLn $ "Identity ref:"-                    putStrLn $ "  " <> BC.unpack (showRefDigest $ wrDigest wref)+            getPeerIdentity peer >>= \case+                PeerIdentityUnknown _ -> do+                    cmdPutStrLn $ "unknown identity"+                PeerIdentityRef wref _ -> do+                    cmdPutStrLn $ "Identity ref:"+                    cmdPutStrLn $ "  " <> BC.unpack (showRefDigest $ wrDigest wref)                 PeerIdentityFull pid -> printContactOrIdentityDetails pid          SelectedContact contact -> do             printContactDetails contact          SelectedChatroom rstate -> do-            liftIO $ putStrLn $ "Chatroom: " <> (T.unpack $ fromMaybe (T.pack "<unnamed>") $ roomName =<< roomStateRoom rstate)+            cmdPutStrLn $ "Chatroom: " <> (T.unpack $ fromMaybe (T.pack "<unnamed>") $ roomName =<< roomStateRoom rstate)          SelectedConversation conv -> do             case conversationPeer conv of                 Just pid -> printContactOrIdentityDetails pid-                Nothing -> liftIO $ putStrLn $ "(conversation without peer)"+                Nothing -> cmdPutStrLn $ "(conversation without peer)" -        NoContext -> liftIO $ putStrLn "nothing selected"+        NoContext -> cmdPutStrLn "nothing selected"   where     printContactOrIdentityDetails cid = do         contacts <- fromSetBy (comparing contactName) . lookupSharedValue . lsShared . fromStored <$> getLocalHead@@ -850,11 +990,11 @@             Just contact -> printContactDetails contact             Nothing -> printIdentityDetails cid -    printContactDetails contact = liftIO $ do-        putStrLn $ "Contact:"+    printContactDetails contact = do+        cmdPutStrLn $ "Contact:"         prefix <- case contactCustomName contact of             Just name -> do-                putStrLn $ "  " <> T.unpack name+                cmdPutStrLn $ "  " <> T.unpack name                 return $ Just "alias of"             Nothing -> do                 return $ Nothing@@ -863,117 +1003,28 @@             Just cid -> do                 printIdentityDetailsBody prefix cid             Nothing -> do-                putStrLn $ "  (without erebos identity)"+                cmdPutStrLn $ "  (without erebos identity)" -    printIdentityDetails identity = liftIO $ do-        putStrLn $ "Identity:"+    printIdentityDetails identity = do+        cmdPutStrLn $ "Identity:"         printIdentityDetailsBody Nothing identity      printIdentityDetailsBody prefix identity = do         forM_ (zip (False : repeat True) $ unfoldOwners identity) $ \(owned, cpid) -> do-            putStrLn $ unwords $ concat+            cmdPutStrLn $ unwords $ concat                 [ [ "  " ]                 , if owned then [ "owned by" ] else maybeToList prefix                 , [ maybe "<unnamed>" T.unpack (idName cpid) ]                 , map (BC.unpack . showRefDigest . refDigest . storedRef) $ idExtDataF cpid                 ] -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" ] Nothing-    modify $ \s -> s { csIcePeer = Just peer }- cmdDiscovery :: Command cmdDiscovery = void $ do     server <- asks ciServer-    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 $ discoverySearch server ref-            case res of-                 Right _ -> return ()-                 Left err -> eprint err--#ifdef ENABLE_ICE_SUPPORT--cmdIceCreate :: Command-cmdIceCreate = do-    let getRole = \case-            'm':_ -> PjIceSessRoleControlling-            's':_ -> PjIceSessRoleControlled-            _ -> PjIceSessRoleUnknown--    ( role, stun, turn ) <- asks (words . ciLine) >>= \case-        [] -> return ( PjIceSessRoleControlling, Nothing, Nothing )-        [ role ] -> return-            ( getRole role, Nothing, Nothing )-        [ role, server ] -> return-            ( getRole role-            , Just ( T.pack server, 0 )-            , Just ( T.pack server, 0 )-            )-        [ role, server, port ] -> return-            ( getRole role-            , Just ( T.pack server, read port )-            , Just ( T.pack server, read port )-            )-        [ role, stunServer, stunPort, turnServer, turnPort ] -> return-            ( getRole role-            , Just ( T.pack stunServer, read stunPort )-            , Just ( T.pack turnServer, read turnPort )-            )-        _ -> throwError "invalid parameters"--    eprint <- asks ciPrint-    Just cfg <- liftIO $ iceCreateConfig stun turn-    sess <- liftIO $ iceCreateSession cfg 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--#endif+    case readRefDigest (BC.pack sref) of+        Nothing -> throwOtherError "failed to parse ref"+        Just dgst -> discoverySearch server dgst  cmdQuit :: Command cmdQuit = modify $ \s -> s { csQuit = True }

@@ -0,0 +1,115 @@+module State (+    loadLocalStateHead,+    createLocalStateHead,+    updateSharedIdentity,+    interactiveIdentityUpdate,+) where++import Control.Monad+import Control.Monad.Except+import Control.Monad.IO.Class++import Data.Foldable+import Data.Proxy+import Data.Text (Text)+import Data.Text qualified as T++import Erebos.Error+import Erebos.Identity+import Erebos.PubKey+import Erebos.State+import Erebos.Storable+import Erebos.Storage++import Terminal+++loadLocalStateHead+    :: (MonadStorage m, MonadError e m, FromErebosError e, MonadIO m)+    => Terminal -> m (Head LocalState)+loadLocalStateHead term = getStorage >>= loadHeads >>= \case+    (h : _) -> return h+    [] -> do+        name <- liftIO $ do+            setPrompt term "Name: "+            getInputLine term $ KeepPrompt . maybe T.empty T.pack++        devName <- liftIO $ do+            setPrompt term "Device: "+            getInputLine term $ KeepPrompt . maybe T.empty T.pack++        ( owner, shared ) <- if+            | T.null name -> do+                return ( Nothing, [] )+            | otherwise -> do+                owner <- createIdentity (Just name) Nothing+                shared <- mstore SharedState+                    { ssPrev = []+                    , ssType = Just $ sharedTypeID @(Maybe ComposedIdentity) Proxy+                    , ssValue = [ storedRef $ idExtData owner ]+                    }+                return ( Just owner, [ shared ] )++        identity <- createIdentity (if T.null devName then Nothing else Just devName) owner++        st <- getStorage+        storeHead st $ LocalState+            { lsPrev = Nothing+            , lsIdentity = idExtData identity+            , lsShared = shared+            , lsOther = []+            }++createLocalStateHead+    :: (MonadStorage m, MonadError e m, FromErebosError e, MonadIO m)+    => [ Maybe Text ] -> m (Head LocalState)+createLocalStateHead [] = throwOtherError "createLocalStateHead: empty name list"+createLocalStateHead ( ownerName : names ) = do+    owner <- createIdentity ownerName Nothing+    identity <- foldM createSingleIdentity owner names+    shared <- case names of+        [] -> return []+        _ : _ -> do+            fmap (: []) $ mstore SharedState+                { ssPrev = []+                , ssType = Just $ sharedTypeID @(Maybe ComposedIdentity) Proxy+                , ssValue = [ storedRef $ idExtData owner ]+                }+    st <- getStorage+    storeHead st $ LocalState+        { lsPrev = Nothing+        , lsIdentity = idExtData identity+        , lsShared = shared+        , lsOther = []+        }+  where+    createSingleIdentity owner name = createIdentity name (Just owner)+++updateSharedIdentity :: (MonadHead LocalState m, MonadError e m, FromErebosError e) => Terminal -> m ()+updateSharedIdentity term = updateLocalState_ $ updateSharedState_ $ \case+    Just identity -> do+        Just . toComposedIdentity <$> interactiveIdentityUpdate term identity+    Nothing -> throwOtherError "no existing shared identity"++interactiveIdentityUpdate :: (Foldable f, MonadStorage m, MonadIO m, MonadError e m, FromErebosError e) => Terminal -> Identity f -> m UnifiedIdentity+interactiveIdentityUpdate term fidentity = do+    identity <- mergeIdentity fidentity+    name <- liftIO $ do+        setPrompt term $ T.unpack $ T.concat $ concat+            [ [ T.pack "Name" ]+            , case idName identity of+                   Just name -> [T.pack " [", name, T.pack "]"]+                   Nothing -> []+            , [ T.pack ": " ]+            ]+        getInputLine term $ KeepPrompt . maybe T.empty T.pack++    if  | T.null name -> return identity+        | otherwise -> do+            secret <- loadKey $ idKeyIdentity identity+            maybe (throwOtherError "created invalid identity") return . validateExtendedIdentity =<<+                mstore =<< sign secret =<< mstore . ExtendedIdentityData =<< return (emptyIdentityExtension $ idData identity)+                { idePrev = toList $ idExtDataF identity+                , ideName = Just name+                }

@@ -0,0 +1,421 @@+{-# LANGUAGE CPP #-}++module Terminal (+    Terminal,+    hasTerminalUI,+    withTerminal,+    setPrompt,+    getInputLine,+    InputHandling(..),++    TerminalLine,+    printLine,++    printBottomLines,+    clearBottomLines,++    CompletionFunc, Completion,+    noCompletion,+    simpleCompletion,+    completeWordWithPrev,+) where++import Control.Arrow+import Control.Concurrent+import Control.Concurrent.STM+import Control.Exception+import Control.Monad++import Data.Char+import Data.List+import Data.Text (Text)+import Data.Text qualified as T++import System.Console.ANSI+import System.IO+import System.IO.Error+++data Terminal = Terminal+    { termLock :: MVar ()+    , termAnsi :: Bool+    , termCompletionFunc :: CompletionFunc IO+    , termPrompt :: TVar String+    , termShowPrompt :: TVar Bool+    , termInput :: TVar ( String, String )+    , termBottomLines :: TVar [ String ]+    , termHistory :: TVar [ String ]+    , termHistoryPos :: TVar Int+    , termHistoryStash :: TVar ( String, String )+    }++data TerminalLine = TerminalLine+    { tlTerminal :: Terminal+    , tlLineCount :: Int+    }++data Input+    = InputChar Char+    | InputMoveUp+    | InputMoveDown+    | InputMoveRight+    | InputMoveLeft+    | InputMoveEnd+    | InputMoveStart+    | InputBackspace+    | InputClear+    | InputBackWord+    | InputEnd+    | InputEscape String+    deriving (Eq, Ord, Show)+++data InputHandling a+    = KeepPrompt a+    | ErasePrompt a+++hasTerminalUI :: Terminal -> Bool+hasTerminalUI = termAnsi++initTerminal :: CompletionFunc IO -> IO Terminal+initTerminal termCompletionFunc = do+    termLock <- newMVar ()+#if MIN_VERSION_ansi_terminal(1, 0, 1)+    termAnsi <- hNowSupportsANSI stdout+#else+    termAnsi <- hSupportsANSI stdout+#endif+    termPrompt <- newTVarIO ""+    termShowPrompt <- newTVarIO False+    termInput <- newTVarIO ( "", "" )+    termBottomLines <- newTVarIO []+    termHistory <- newTVarIO []+    termHistoryPos <- newTVarIO 0+    termHistoryStash <- newTVarIO ( "", "" )+    return Terminal {..}++bracketSet :: IO a -> (a -> IO b) -> a -> IO c -> IO c+bracketSet get set val = bracket (get <* set val) set . const++withTerminal :: CompletionFunc IO -> (Terminal -> IO a) -> IO a+withTerminal compl act = do+    term <- initTerminal compl++    bracketSet (hGetEcho stdin) (hSetEcho stdin) False $+        bracketSet (hGetBuffering stdin) (hSetBuffering stdin) NoBuffering $+        bracketSet (hGetBuffering stdout) (hSetBuffering stdout) (BlockBuffering Nothing) $+            act term+++termPutStr :: Terminal -> String -> IO ()+termPutStr Terminal {..} str = do+    withMVar termLock $ \_ -> do+        putStr str+        hFlush stdout+++getInput :: IO Input+getInput = do+    handleJust (guard . isEOFError) (\() -> return InputEnd) $ getChar >>= \case+        '\ESC' -> do+            esc <- readEsc+            case parseEsc esc of+                Just ( 'A' , [] ) -> return InputMoveUp+                Just ( 'B' , [] ) -> return InputMoveDown+                Just ( 'C' , [] ) -> return InputMoveRight+                Just ( 'D' , [] ) -> return InputMoveLeft+                _ -> return (InputEscape esc)+        '\b' -> return InputBackspace+        '\DEL' -> return InputBackspace+        '\NAK' -> return InputClear+        '\ETB' -> return InputBackWord+        '\DLE' -> return InputMoveUp+        '\SO'  -> return InputMoveDown+        '\SOH' -> return InputMoveStart+        '\ENQ' -> return InputMoveEnd+        '\EOT' -> return InputEnd+        c -> return (InputChar c)+  where+    readEsc = getChar >>= \case+        c | c == '\ESC' || isAlpha c -> return [ c ]+          | otherwise -> (c :) <$> readEsc++    parseEsc = \case+        '[' : c : [] -> do+            Just ( c, [] )+        _ -> Nothing+++getInputLine :: Terminal -> (Maybe String -> InputHandling a) -> IO a+getInputLine term@Terminal {..} handleResult = do+    when termAnsi $ do+        withMVar termLock $ \_ -> do+            prompt <- atomically $ do+                writeTVar termShowPrompt True+                readTVar termPrompt+            putStr $ prompt <> "\ESC[K"+            drawBottomLines term+            hFlush stdout++    mbLine <- go+    forM_ mbLine $ \line -> do+        let addLine xs+                | null line = xs+                | (x : _) <- xs, x == line = xs+                | otherwise = line : xs+        atomically $ do+            writeTVar termHistory . addLine =<< readTVar termHistory+            writeTVar termHistoryPos 0++    case handleResult mbLine of+        KeepPrompt x -> do+            when termAnsi $ do+                termPutStr term "\n\ESC[J"+            return x+        ErasePrompt x -> do+            when termAnsi $ do+                termPutStr term "\r\ESC[J"+            return x+  where+    go = getInput >>= \case+        InputChar '\n' -> do+            atomically $ do+                ( pre, post ) <- readTVar termInput+                writeTVar termInput ( "", "" )+                when termAnsi $ do+                    writeTVar termShowPrompt False+                    writeTVar termBottomLines []+                return $ Just $ pre ++ post++        InputChar '\t' | termAnsi -> do+            options <- withMVar termLock $ const $ do+                ( pre, post ) <- atomically $ readTVar termInput+                let updatePrompt pre' = do+                        prompt <- atomically $ do+                            writeTVar termInput ( pre', post )+                            getCurrentPromptLine term+                        putStr $ "\r" <> prompt+                        hFlush stdout++                termCompletionFunc ( T.pack pre, T.pack post ) >>= \case++                    ( unused, [ compl ] ) -> do+                        updatePrompt $ T.unpack unused ++ T.unpack (replacement compl) ++ if isFinished compl then " " else ""+                        return []++                    ( unused, completions@(c : cs) ) -> do+                        let commonPrefixes' x y = fmap (\( common, _, _ ) -> common) $ T.commonPrefixes x y+                        case foldl' (\mbcommon cur -> commonPrefixes' cur =<< mbcommon) (Just $ replacement c) (fmap replacement cs) of+                            Just common | T.unpack common /= pre -> do+                                updatePrompt $ T.unpack unused ++ T.unpack common+                                return []+                            _ -> do+                                return $ map replacement completions++                    ( _, [] ) -> do+                        return []++            printBottomLines term $ T.unpack $ T.unlines options+            go++        InputChar c | isPrint c -> withInput $ \case+            ( _, post ) -> do+                writeTVar termInput . first (++ [ c ]) =<< readTVar termInput+                return $ c : (if null post then "" else "\ESC[s" <> post <> "\ESC[u")++        InputChar _ -> go++        InputMoveUp -> withInput $ \prepost -> do+            hist <- readTVar termHistory+            pos <- readTVar termHistoryPos+            case drop pos hist of+                ( h : _ ) -> do+                    when (pos == 0) $ do+                        writeTVar termHistoryStash prepost+                    writeTVar termHistoryPos (pos + 1)+                    writeTVar termInput ( h, "" )+                    ("\r\ESC[K" <>) <$> getCurrentPromptLine term+                [] -> do+                    return ""++        InputMoveDown -> withInput $ \_ -> do+            readTVar termHistoryPos >>= \case+                0 -> do+                    return ""+                1 -> do+                    writeTVar termHistoryPos 0+                    writeTVar termInput =<< readTVar termHistoryStash+                    ("\r\ESC[K" <>) <$> getCurrentPromptLine term+                pos -> do+                    writeTVar termHistoryPos (pos - 1)+                    hist <- readTVar termHistory+                    case drop (pos - 2) hist of+                        ( h : _ ) -> do+                            writeTVar termInput ( h, "" )+                            ("\r\ESC[K" <>) <$> getCurrentPromptLine term+                        [] -> do+                            return ""++        InputMoveRight -> withInput $ \case+            ( pre, c : post ) -> do+                writeTVar termInput ( pre ++ [ c ], post )+                return $ "\ESC[C"+            _ -> return ""++        InputMoveLeft -> withInput $ \case+            ( pre@(_ : _), post ) -> do+                writeTVar termInput ( init pre, last pre : post )+                return $ "\ESC[D"+            _ -> return ""++        InputBackspace -> withInput $ \case+            ( pre@(_ : _), post ) -> do+                writeTVar termInput ( init pre, post )+                return $ "\b\ESC[K" <> (if null post then "" else "\ESC[s" <> post <> "\ESC[u")+            _ -> return ""++        InputClear -> withInput $ \_ -> do+            writeTVar termInput ( "", "" )+            ("\r\ESC[K" <>) <$> getCurrentPromptLine term++        InputBackWord -> withInput $ \( pre, post ) -> do+            let pre' = reverse $ dropWhile (not . isSpace) $ dropWhile isSpace $ reverse pre+            writeTVar termInput ( pre', post )+            ("\r\ESC[K" <>) <$> getCurrentPromptLine term++        InputMoveStart -> withInput $ \( pre, post ) -> do+            writeTVar termInput ( "", pre <> post )+            return $ "\ESC[" <> show (length pre) <> "D"++        InputMoveEnd -> withInput $ \( pre, post ) -> do+            writeTVar termInput ( pre <> post, "" )+            return $ "\ESC[" <> show (length post) <> "C"++        InputEnd -> do+            atomically (readTVar termInput) >>= \case+                ( "", "" ) -> return Nothing+                _          -> go++        InputEscape _ -> go++    withInput f = do+        withMVar termLock $ const $ do+            str <- atomically $ f =<< readTVar termInput+            when (termAnsi && not (null str)) $ do+                putStr str+                hFlush stdout+        go+++getCurrentPromptLine :: Terminal -> STM String+getCurrentPromptLine Terminal {..} = do+    prompt <- readTVar termPrompt+    ( pre, post ) <- readTVar termInput+    return $ prompt <> pre <> "\ESC[s" <> post <> "\ESC[u"++setPrompt :: Terminal -> String -> IO ()+setPrompt Terminal { termAnsi = False } _ = do+    return ()+setPrompt term@Terminal {..} prompt = do+    withMVar termLock $ \_ -> do+        join $ atomically $ do+            writeTVar termPrompt prompt+            readTVar termShowPrompt >>= \case+                True -> do+                    promptLine <- getCurrentPromptLine term+                    return $ do+                        putStr $ "\r\ESC[K" <> promptLine+                        hFlush stdout+                False -> return $ return ()++printLine :: Terminal -> String -> IO TerminalLine+printLine tlTerminal@Terminal {..} str = do+    withMVar termLock $ \_ -> do+        let strLines = lines str+            tlLineCount = length strLines+        if termAnsi+          then do+            promptLine <- atomically $ do+                readTVar termShowPrompt >>= \case+                    True -> getCurrentPromptLine tlTerminal+                    False -> return ""+            putStr $ "\r\ESC[K" <> unlines strLines <> "\ESC[K" <> promptLine+            drawBottomLines tlTerminal+          else do+            putStr $ unlines strLines++        hFlush stdout+        return TerminalLine {..}+++printBottomLines :: Terminal -> String -> IO ()+printBottomLines Terminal { termAnsi = False } _ = do+    return ()+printBottomLines term@Terminal {..} str = do+    case lines str of+        [] -> clearBottomLines term+        blines -> do+            withMVar termLock $ \_ -> do+                atomically $ writeTVar termBottomLines blines+                drawBottomLines term+                hFlush stdout++clearBottomLines :: Terminal -> IO ()+clearBottomLines Terminal { termAnsi = False } = do+    return ()+clearBottomLines Terminal {..} = do+    withMVar termLock $ \_ -> do+        atomically (readTVar termBottomLines) >>= \case+            []  -> return ()+            _:_ -> do+                atomically $ writeTVar termBottomLines []+                putStr $ "\ESC[s\n\ESC[J\ESC[u"+                hFlush stdout++drawBottomLines :: Terminal -> IO ()+drawBottomLines Terminal {..} = do+    atomically (readTVar termBottomLines) >>= \case+        blines@( firstLine : otherLines ) -> do+            ( shift ) <- atomically $ do+                readTVar termShowPrompt >>= \case+                    True -> do+                        prompt <- readTVar termPrompt+                        ( pre, _ ) <- readTVar termInput+                        return (displayWidth (prompt <> pre) + 1)+                    False -> do+                        return 0+            putStr $ concat+                [ "\n\ESC[J", firstLine, concat (map ('\n' :) otherLines)+                , "\ESC[", show (length blines), "F"+                , "\ESC[", show shift, "G"+                ]+        [] -> return ()+++displayWidth :: String -> Int+displayWidth = \case+    ('\ESC' : '[' : rest) -> displayWidth $ drop 1 $ dropWhile (not . isAlpha) rest+    ('\ESC' : _ : rest) -> displayWidth rest+    (_ : rest) -> 1 + displayWidth rest+    [] -> 0+++type CompletionFunc m = ( Text, Text ) -> m ( Text, [ Completion ] )++data Completion = Completion+    { replacement :: Text+    , isFinished :: Bool+    }++noCompletion :: Monad m => CompletionFunc m+noCompletion ( l, _ ) = return ( l, [] )++completeWordWithPrev :: Monad m => Maybe Char -> [ Char ] -> (String -> String -> m [ Completion ]) -> CompletionFunc m+completeWordWithPrev _ spaceChars fun ( l, _ ) = do+    let lastSpaceIndex = snd $ T.foldl' (\( i, found ) c -> if c `elem` spaceChars then ( i + 1, i ) else ( i + 1, found )) ( 1, 0 ) l+    let ( pre, word ) = T.splitAt lastSpaceIndex l+    ( pre, ) <$> fun (T.unpack pre) (T.unpack word)++simpleCompletion :: String -> Completion+simpleCompletion str = Completion (T.pack str) True

@@ -26,7 +26,7 @@ import Data.Text.Encoding import Data.Text.IO qualified as T import Data.Typeable-import Data.UUID qualified as U+import Data.UUID.Types qualified as U  import Network.Socket @@ -36,17 +36,20 @@ import Erebos.Attach import Erebos.Chatroom import Erebos.Contact+import Erebos.DirectMessage import Erebos.Discovery import Erebos.Identity-import Erebos.Message import Erebos.Network+import Erebos.Object import Erebos.Pairing import Erebos.PubKey import Erebos.Service+import Erebos.Service.Stream import Erebos.Set import Erebos.State+import Erebos.Storable import Erebos.Storage-import Erebos.Storage.Internal (unsafeStoreRawBytes)+import Erebos.Storage.Head import Erebos.Storage.Merge import Erebos.Sync @@ -64,10 +67,17 @@  data RunningServer = RunningServer     { rsServer :: Server-    , rsPeers :: MVar (Int, [(Int, Peer)])+    , rsPeers :: MVar ( Int, [ TestPeer ] )     , rsPeerThread :: ThreadId     } +data TestPeer = TestPeer+    { tpIndex :: Int+    , tpPeer :: Peer+    , tpStreamReaders :: MVar [ (Int, StreamReader ) ]+    , tpStreamWriters :: MVar [ (Int, StreamWriter ) ]+    }+ initTestState :: TestState initTestState = TestState     { tsHead = Nothing@@ -101,7 +111,7 @@             Nothing -> return ()      runExceptT (evalStateT testLoop initTestState) >>= \case-        Left x -> B.hPutStr stderr $ (`BC.snoc` '\n') $ BC.pack x+        Left x -> B.hPutStr stderr $ (`BC.snoc` '\n') $ BC.pack (showErebosError x)         Right () -> return ()  getLineMb :: MonadIO m => m (Maybe Text)@@ -135,17 +145,20 @@   getPeer :: Text -> CommandM Peer-getPeer spidx = do+getPeer spidx = tpPeer <$> getTestPeer spidx++getTestPeer :: Text -> CommandM TestPeer+getTestPeer spidx = do     Just RunningServer {..} <- gets tsServer-    Just peer <- lookup (read $ T.unpack spidx) . snd <$> liftIO (readMVar rsPeers)+    Just peer <- find (((read $ T.unpack spidx) ==) . tpIndex) . snd <$> liftIO (readMVar rsPeers)     return peer -getPeerIndex :: MVar (Int, [(Int, Peer)]) -> ServiceHandler (PairingService a) Int+getPeerIndex :: MVar ( Int, [ TestPeer ] ) -> ServiceHandler s Int getPeerIndex pmvar = do     peer <- asks svcPeer-    maybe 0 fst . find ((==peer) . snd) . snd <$> liftIO (readMVar pmvar)+    maybe 0 tpIndex . find ((peer ==) . tpPeer) . snd <$> liftIO (readMVar pmvar) -pairingAttributes :: PairingResult a => proxy (PairingService a) -> Output -> MVar (Int, [(Int, Peer)]) -> String -> PairingAttributes a+pairingAttributes :: PairingResult a => proxy (PairingService a) -> Output -> MVar ( Int, [ TestPeer ] ) -> String -> PairingAttributes a pairingAttributes _ out peers prefix = PairingAttributes     { pairingHookRequest = return () @@ -173,7 +186,7 @@     , pairingHookFailed = \case         PairingUserRejected -> failed "user"         PairingUnexpectedMessage pstate packet -> failed $ "unexpected " ++ strState pstate ++ " " ++ strPacket packet-        PairingFailedOther str -> failed $ "other " ++ str+        PairingFailedOther err -> failed $ "other " ++ showErebosError err     , pairingHookVerifyFailed = failed "verify"     , pairingHookRejected = failed "rejected"     }@@ -214,21 +227,28 @@     { 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-        ]+discoveryAttributes :: DiscoveryAttributes+discoveryAttributes = (defaultServiceAttributes Proxy)+    { discoveryProvideTunnel = \_ _ -> False+    } +dmThreadWatcher :: ComposedIdentity -> Output -> DirectMessageThread -> DirectMessageThread -> IO ()+dmThreadWatcher self out prev cur = do+    forM_ (reverse $ dmThreadToListSince prev cur) $ \msg -> do+        outLine out $ unwords+            [ if sameIdentity self (msgFrom msg)+                 then "dm-sent"+                 else "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) +newtype CommandM a = CommandM (ReaderT TestInput (StateT TestState (ExceptT ErebosError IO)) a)+    deriving (Functor, Applicative, Monad, MonadIO, MonadReader TestInput, MonadState TestState, MonadError ErebosError)+ instance MonadFail CommandM where-    fail = throwError+    fail = throwOtherError  instance MonadRandom CommandM where     getRandomBytes = liftIO . getRandomBytes@@ -245,72 +265,85 @@  type Command = CommandM () -commands :: [(Text, Command)]-commands = map (T.pack *** id)-    [ ("store", cmdStore)-    , ("load", cmdLoad)-    , ("stored-generation", cmdStoredGeneration)-    , ("stored-roots", cmdStoredRoots)-    , ("stored-set-add", cmdStoredSetAdd)-    , ("stored-set-list", cmdStoredSetList)-    , ("head-create", cmdHeadCreate)-    , ("head-replace", cmdHeadReplace)-    , ("head-watch", cmdHeadWatch)-    , ("head-unwatch", cmdHeadUnwatch)-    , ("create-identity", cmdCreateIdentity)-    , ("identity-info", cmdIdentityInfo)-    , ("start-server", cmdStartServer)-    , ("stop-server", cmdStopServer)-    , ("peer-add", cmdPeerAdd)-    , ("peer-drop", cmdPeerDrop)-    , ("peer-list", cmdPeerList)-    , ("test-message-send", cmdTestMessageSend)-    , ("local-state-get", cmdLocalStateGet)-    , ("local-state-replace", cmdLocalStateReplace)-    , ("local-state-wait", cmdLocalStateWait)-    , ("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-send-identity", cmdDmSendIdentity)-    , ("dm-list-peer", cmdDmListPeer)-    , ("dm-list-contact", cmdDmListContact)-    , ("chatroom-create", cmdChatroomCreate)-    , ("chatroom-delete", cmdChatroomDelete)-    , ("chatroom-list-local", cmdChatroomListLocal)-    , ("chatroom-watch-local", cmdChatroomWatchLocal)-    , ("chatroom-set-name", cmdChatroomSetName)-    , ("chatroom-subscribe", cmdChatroomSubscribe)-    , ("chatroom-unsubscribe", cmdChatroomUnsubscribe)-    , ("chatroom-members", cmdChatroomMembers)-    , ("chatroom-join", cmdChatroomJoin)-    , ("chatroom-join-as", cmdChatroomJoinAs)-    , ("chatroom-leave", cmdChatroomLeave)-    , ("chatroom-message-send", cmdChatroomMessageSend)-    , ("discovery-connect", cmdDiscoveryConnect)+commands :: [ ( Text, Command ) ]+commands =+    [ ( "store", cmdStore )+    , ( "load", cmdLoad )+    , ( "stored-generation", cmdStoredGeneration )+    , ( "stored-roots", cmdStoredRoots )+    , ( "stored-set-add", cmdStoredSetAdd )+    , ( "stored-set-list", cmdStoredSetList )+    , ( "stored-difference", cmdStoredDifference )+    , ( "head-create", cmdHeadCreate )+    , ( "head-replace", cmdHeadReplace )+    , ( "head-watch", cmdHeadWatch )+    , ( "head-unwatch", cmdHeadUnwatch )+    , ( "create-identity", cmdCreateIdentity )+    , ( "identity-info", cmdIdentityInfo )+    , ( "start-server", cmdStartServer )+    , ( "stop-server", cmdStopServer )+    , ( "peer-add", cmdPeerAdd )+    , ( "peer-drop", cmdPeerDrop )+    , ( "peer-list", cmdPeerList )+    , ( "test-message-send", cmdTestMessageSend )+    , ( "test-stream-open", cmdTestStreamOpen )+    , ( "test-stream-close", cmdTestStreamClose )+    , ( "test-stream-send", cmdTestStreamSend )+    , ( "local-state-get", cmdLocalStateGet )+    , ( "local-state-replace", cmdLocalStateReplace )+    , ( "local-state-wait", cmdLocalStateWait )+    , ( "shared-state-get", cmdSharedStateGet )+    , ( "shared-state-wait", cmdSharedStateWait )+    , ( "watch-local-identity", cmdWatchLocalIdentity )+    , ( "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-send-identity", cmdDmSendIdentity )+    , ( "dm-list-peer", cmdDmListPeer )+    , ( "dm-list-contact", cmdDmListContact )+    , ( "chatroom-create", cmdChatroomCreate )+    , ( "chatroom-delete", cmdChatroomDelete )+    , ( "chatroom-list-local", cmdChatroomListLocal )+    , ( "chatroom-watch-local", cmdChatroomWatchLocal )+    , ( "chatroom-set-name", cmdChatroomSetName )+    , ( "chatroom-subscribe", cmdChatroomSubscribe )+    , ( "chatroom-unsubscribe", cmdChatroomUnsubscribe )+    , ( "chatroom-members", cmdChatroomMembers )+    , ( "chatroom-join", cmdChatroomJoin )+    , ( "chatroom-join-as", cmdChatroomJoinAs )+    , ( "chatroom-leave", cmdChatroomLeave )+    , ( "chatroom-message-send", cmdChatroomMessageSend )+    , ( "discovery-connect", cmdDiscoveryConnect )+    , ( "discovery-tunnel", cmdDiscoveryTunnel )     ]  cmdStore :: Command cmdStore = do     st <- asks tiStorage+    pst <- liftIO $ derivePartialStorage st     [otype] <- asks tiParams     ls <- getLines      let cnt = encodeUtf8 $ T.unlines ls-    ref <- liftIO $ unsafeStoreRawBytes st $ BL.fromChunks [encodeUtf8 otype, BC.singleton ' ', BC.pack (show $ B.length cnt), BC.singleton '\n', cnt]-    cmdOut $ "store-done " ++ show (refDigest ref)+        full = BL.fromChunks+            [ encodeUtf8 otype+            , BC.singleton ' '+            , BC.pack (show $ B.length cnt)+            , BC.singleton '\n', cnt+            ]+    liftIO (copyRef st =<< storeRawBytes pst full) >>= \case+        Right ref -> cmdOut $ "store-done " ++ show (refDigest ref)+        Left _ -> cmdOut $ "store-failed"  cmdLoad :: Command cmdLoad = do@@ -345,7 +378,7 @@         [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+    set' <- storeSetAdd [ item ] set     cmdOut $ "stored-set-add" ++ concatMap ((' ':) . show . refDigest . storedRef) (toComponents set')  cmdStoredSetList :: Command@@ -358,6 +391,19 @@         cmdOut $ "stored-set-item" ++ concatMap ((' ':) . show . refDigest . storedRef) item     cmdOut $ "stored-set-done" +cmdStoredDifference :: Command+cmdStoredDifference = do+    st <- asks tiStorage+    ( trefs1, "|" : trefs2 ) <- span (/= "|") <$> asks tiParams++    let loadObjs = mapM (maybe (fail "invalid ref") (return . wrappedLoad @Object) <=< liftIO . readRef st . encodeUtf8)+    objs1 <- loadObjs trefs1+    objs2 <- loadObjs trefs2++    forM_ (storedDifference objs1 objs2) $ \item -> do+        cmdOut $ "stored-difference-item " ++ (show $ refDigest $ storedRef item)+    cmdOut $ "stored-difference-done"+ cmdHeadCreate :: Command cmdHeadCreate = do     [ ttid, tref ] <- asks tiParams@@ -412,7 +458,8 @@  initTestHead :: Head LocalState -> Command initTestHead h = do-    _ <- liftIO . watchReceivedMessages h . dmReceivedWatcher =<< asks tiOutput+    let self = finalOwner $ headLocalIdentity h+    _ <- liftIO . watchDirectMessageThreads h . dmThreadWatcher self =<< asks tiOutput     modify $ \s -> s { tsHead = Just h }  loadTestHead :: CommandM (Head LocalState)@@ -435,17 +482,18 @@     st <- asks tiStorage     names <- asks tiParams -    h <- liftIO $ do+    h <- do         Just identity <- if null names-            then Just <$> createIdentity st Nothing Nothing-            else foldrM (\n o -> Just <$> createIdentity st (Just n) o) Nothing names+            then Just <$> createIdentity Nothing Nothing+            else foldrM (\n o -> Just <$> createIdentity (Just n) o) Nothing names          shared <- case names of-            _:_:_ -> (:[]) <$> makeSharedStateUpdate st (Just $ finalOwner identity) []+            _:_:_ -> (: []) <$> makeSharedStateUpdate (Just $ finalOwner identity) []             _ -> return []          storeHead st $ LocalState-            { lsIdentity = idExtData identity+            { lsPrev = Nothing+            , lsIdentity = idExtData identity             , lsShared = shared             , lsOther = []             }@@ -473,43 +521,79 @@      let parseParams = \case             (name : value : rest)-                | name == "services" -> T.splitOn "," value+                | name == "services" -> second ( map splitServiceParams (T.splitOn "," value) ++ ) (parseParams rest)+            (name : rest)+                | name == "test-log" -> first (\o -> o { serverTestLog = True }) (parseParams rest)                 | otherwise -> parseParams rest-            _ -> []-    serviceNames <- parseParams <$> asks tiParams+            _ -> ( defaultServerOptions { serverErrorPrefix = "server-error-message " }, [] ) +        splitServiceParams svc =+            case T.splitOn ":" svc of+                name : params -> ( name, params )+                _ -> ( svc, [] )++    ( serverOptions, serviceNames ) <- parseParams <$> asks tiParams+     h <- getOrLoadHead     rsPeers <- liftIO $ newMVar (1, [])     services <- forM serviceNames $ \case-        "attach" -> return $ someServiceAttr $ pairingAttributes (Proxy @AttachService) out rsPeers "attach"-        "chatroom" -> return $ someService @ChatroomService Proxy-        "contact" -> return $ someServiceAttr $ pairingAttributes (Proxy @ContactService) out rsPeers "contact"-        "discovery" -> return $ someService @DiscoveryService Proxy-        "dm" -> return $ someServiceAttr $ directMessageAttributes out-        "sync" -> return $ someService @SyncService Proxy-        "test" -> return $ someServiceAttr $ (defaultServiceAttributes Proxy)+        ( "attach", _ ) -> return $ someServiceAttr $ pairingAttributes (Proxy @AttachService) out rsPeers "attach"+        ( "chatroom", _ ) -> return $ someService @ChatroomService Proxy+        ( "contact", _ ) -> return $ someServiceAttr $ pairingAttributes (Proxy @ContactService) out rsPeers "contact"+        ( "discovery", params ) -> return $ someServiceAttr $ discoveryAttributes+            { discoveryProvideTunnel = \_ _ -> "tunnel" `elem` params+            }+        ( "dm", _ ) -> return $ someServiceAttr $ directMessageAttributes out+        ( "sync", _ ) -> return $ someService @SyncService Proxy+        ( "test", _ ) -> return $ someServiceAttr $ (defaultServiceAttributes Proxy)             { testMessageReceived = \obj otype len sref -> do                 liftIO $ do                     void $ store (headStorage h) obj-                    outLine out $ unwords ["test-message-received", otype, len, sref]+                    outLine out $ unwords [ "test-message-received", otype, len, sref ]+            , testStreamsReceived = \streams -> do+                pidx <- getPeerIndex rsPeers+                liftIO $ do+                    nums <- mapM getStreamReaderNumber streams+                    outLine out $ unwords $ "test-stream-open-from" : show pidx : map show nums+                    forM_ (zip nums streams) $ \( num, stream ) -> void $ forkIO $ do+                        let go = readStreamPacket stream >>= \case+                                StreamData seqNum bytes -> do+                                    outLine out $ unwords [ "test-stream-received", show pidx, show num, show seqNum, BC.unpack bytes ]+                                    go+                                StreamClosed seqNum -> do+                                    outLine out $ unwords [ "test-stream-closed-from", show pidx, show num, show seqNum ]+                        go             }-        sname -> throwError $ "unknown service `" <> T.unpack sname <> "'"+        ( sname, _ ) -> throwOtherError $ "unknown service `" <> T.unpack sname <> "'" -    rsServer <- liftIO $ startServer defaultServerOptions h (B.hPutStr stderr . (`BC.snoc` '\n') . BC.pack) services+    let logPrint str = do BC.hPutStrLn stdout (BC.pack str)+                          hFlush stdout+    rsServer <- liftIO $ startServer serverOptions h logPrint services      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+        let printPeer TestPeer {..} = do+                params <- getPeerIdentity tpPeer >>= \case+                    PeerIdentityFull pid -> do+                        return $ ("id":) $ map (maybe "<unnamed>" T.unpack . idName) (unfoldOwners pid)+                    _ -> do+                        paddr <- getPeerAddress tpPeer+                        return $ [ "addr", show paddr ]+                outLine out $ unwords $ [ "peer", show tpIndex ] ++ 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)+            update ( tpIndex, [] ) = do+                tpPeer <- return peer+                tpStreamReaders <- newMVar []+                tpStreamWriters <- newMVar []+                let tp = TestPeer {..}+                printPeer tp+                return ( tpIndex + 1, [ tp ] ) +            update cur@( nid, p : ps )+                | tpPeer p == peer = printPeer p >> return cur+                | otherwise = fmap (p :) <$> update ( nid, ps )+         modifyMVar_ rsPeers update      modify $ \s -> s { tsServer = Just RunningServer {..} }@@ -545,11 +629,12 @@     peers <- liftIO $ getCurrentPeerList rsServer     tpeers <- liftIO $ readMVar rsPeers     forM_ peers $ \peer -> do-        Just (n, _) <- return $ find ((peer==).snd) . snd $ tpeers-        mbpid <- peerIdentity peer+        Just tp <- return $ find ((peer ==) . tpPeer) . snd $ tpeers+        mbpid <- getPeerIdentity peer+        paddr <- getPeerAddress peer         cmdOut $ unwords $ concat-            [ [ "peer-list-item", show n ]-            , [ "addr", show (peerAddress peer) ]+            [ [ "peer-list-item", show (tpIndex tp) ]+            , [ "addr", show paddr ]             , case mbpid of PeerIdentityFull pid -> ("id":) $ map (maybe "<unnamed>" T.unpack . idName) (unfoldOwners pid)                             _ -> []             ]@@ -565,6 +650,40 @@     sendManyToPeer peer $ map (TestMessage . wrappedLoad) refs     cmdOut "test-message-send done" +cmdTestStreamOpen :: Command+cmdTestStreamOpen = do+    spidx : rest <- asks tiParams+    tp <- getTestPeer spidx+    count <- case rest of+        [] -> return 1+        tcount : _ -> return $ read $ T.unpack tcount++    out <- asks tiOutput+    runPeerService (tpPeer tp) $ do+        streams <- openTestStreams count+        afterCommit $ do+            nums <- mapM getStreamWriterNumber streams+            modifyMVar_ (tpStreamWriters tp) $ return . (++ zip nums streams)+            outLine out $ unwords $ "test-stream-open-done"+                : T.unpack spidx+                : map show nums++cmdTestStreamClose :: Command+cmdTestStreamClose = do+    [ spidx, sid ] <- asks tiParams+    tp <- getTestPeer spidx+    Just stream <- lookup (read $ T.unpack sid) <$> liftIO (readMVar (tpStreamWriters tp))+    liftIO $ closeStream stream+    cmdOut $ unwords [ "test-stream-close-done", T.unpack spidx, T.unpack sid ]++cmdTestStreamSend :: Command+cmdTestStreamSend = do+    [ spidx, sid, content ] <- asks tiParams+    tp <- getTestPeer spidx+    Just stream <- lookup (read $ T.unpack sid) <$> liftIO (readMVar (tpStreamWriters tp))+    liftIO $ writeStream stream $ encodeUtf8 content+    cmdOut $ unwords [ "test-stream-send-done", T.unpack spidx, T.unpack sid ]+ cmdLocalStateGet :: Command cmdLocalStateGet = do     h <- getHead@@ -637,7 +756,7 @@ cmdUpdateLocalIdentity :: Command cmdUpdateLocalIdentity = do     [name] <- asks tiParams-    updateLocalHead_ $ \ls -> do+    updateLocalState_ $ \ls -> do         Just identity <- return $ validateExtendedIdentity $ lsIdentity $ fromStored ls         let public = idKeyIdentity identity @@ -652,8 +771,8 @@ cmdUpdateSharedIdentity :: Command cmdUpdateSharedIdentity = do     [name] <- asks tiParams-    updateLocalHead_ $ updateSharedState_ $ \case-        Nothing -> throwError "no existing shared identity"+    updateLocalState_ $ updateSharedState_ $ \case+        Nothing -> throwOtherError "no existing shared identity"         Just identity -> do             let public = idKeyIdentity identity             secret <- loadKey public@@ -722,13 +841,13 @@ cmdContactSetName = do     [cid, name] <- asks tiParams     contact <- getContact cid-    updateLocalHead_ $ updateSharedState_ $ contactSetName contact name+    updateLocalState_ $ updateSharedState_ $ contactSetName contact name     cmdOut "contact-set-name-done"  cmdDmSendPeer :: Command cmdDmSendPeer = do     [spidx, msg] <- asks tiParams-    PeerIdentityFull to <- peerIdentity =<< getPeer spidx+    PeerIdentityFull to <- getPeerIdentity =<< getPeer spidx     void $ sendDirectMessage to msg  cmdDmSendContact :: Command@@ -747,10 +866,10 @@  dmList :: Foldable f => Identity f -> Command dmList peer = do-    threads <- toThreadList . lookupSharedValue . lsShared . headObject <$> getHead+    threads <- dmThreadList . lookupSharedValue . lsShared . headObject <$> getHead     case find (sameIdentity peer . msgPeer) threads of         Just thread -> do-            forM_ (reverse $ threadToList thread) $ \DirectMessage {..} -> cmdOut $ "dm-list-item"+            forM_ (reverse $ dmThreadToList thread) $ \DirectMessage {..} -> cmdOut $ "dm-list-item"                 <> " from " <> (maybe "<unnamed>" T.unpack $ idName msgFrom)                 <> " text " <> (T.unpack msgText)         Nothing -> return ()@@ -759,7 +878,7 @@ cmdDmListPeer :: Command cmdDmListPeer = do     [spidx] <- asks tiParams-    PeerIdentityFull to <- peerIdentity =<< getPeer spidx+    PeerIdentityFull to <- getPeerIdentity =<< getPeer spidx     dmList to  cmdDmListContact :: Command@@ -867,8 +986,7 @@ cmdChatroomJoinAs :: Command cmdChatroomJoinAs = do     [ cid, name ] <- asks tiParams-    st <- asks tiStorage-    identity <- liftIO $ createIdentity st (Just name) Nothing+    identity <- createIdentity (Just name) Nothing     joinChatroomAsByStateData identity =<< getChatroomStateData cid     cmdOut $ unwords [ "chatroom-join-as-done", T.unpack cid ] @@ -886,8 +1004,14 @@  cmdDiscoveryConnect :: Command cmdDiscoveryConnect = do-    st <- asks tiStorage     [ tref ] <- asks tiParams-    Just ref <- liftIO $ readRef st $ encodeUtf8 tref+    Just dgst <- return $ readRefDigest $ encodeUtf8 tref     Just RunningServer {..} <- gets tsServer-    discoverySearch rsServer ref+    discoverySearch rsServer dgst++cmdDiscoveryTunnel :: Command+cmdDiscoveryTunnel = do+    [ tvia, ttarget ] <- asks tiParams+    via <- getPeer tvia+    Just target <- return $ readRefDigest $ encodeUtf8 ttarget+    liftIO $ discoverySetupTunnel via target

@@ -1,20 +1,26 @@ module Test.Service (     TestMessage(..),     TestMessageAttributes(..),++    openTestStreams, ) where +import Control.Monad import Control.Monad.Reader  import Data.ByteString.Lazy.Char8 qualified as BL  import Erebos.Network+import Erebos.Object import Erebos.Service-import Erebos.Storage+import Erebos.Service.Stream+import Erebos.Storable  data TestMessage = TestMessage (Stored Object)  data TestMessageAttributes = TestMessageAttributes     { testMessageReceived :: Object -> String -> String -> String -> ServiceHandler TestMessage ()+    , testStreamsReceived :: [ StreamReader ] -> ServiceHandler TestMessage ()     }  instance Storable TestMessage where@@ -25,7 +31,10 @@     serviceID _ = mkServiceID "cb46b92c-9203-4694-8370-8742d8ac9dc8"      type ServiceAttributes TestMessage = TestMessageAttributes-    defaultServiceAttributes _ = TestMessageAttributes (\_ _ _ _ -> return ())+    defaultServiceAttributes _ = TestMessageAttributes+        { testMessageReceived = \_ _ _ _ -> return ()+        , testStreamsReceived = \_ -> return ()+        }      serviceHandler smsg = do         let TestMessage sobj = fromStored smsg@@ -35,3 +44,14 @@                 cb <- asks $ testMessageReceived . svcAttributes                 cb obj otype len (show $ refDigest $ storedRef sobj)             _ -> return ()++        streams <- receivedStreams+        when (not $ null streams) $ do+            cb <- asks $ testStreamsReceived . svcAttributes+            cb streams+++openTestStreams :: Int -> ServiceHandler TestMessage [ StreamWriter ]+openTestStreams count = do+    replyPacket . TestMessage =<< mstore (Rec [])+    replicateM count openStream

@@ -0,0 +1,48 @@+module WebSocket (+    WebSocketAddress(..),+    startWebsocketServer,+) where++import Control.Concurrent+import Control.Exception+import Control.Monad++import Data.ByteString.Lazy qualified as BL+import Data.Unique++import Erebos.Network++import Network.WebSockets qualified as WS+++data WebSocketAddress = WebSocketAddress Unique WS.Connection++instance Eq WebSocketAddress where+    WebSocketAddress u _ == WebSocketAddress u' _ = u == u'++instance Ord WebSocketAddress where+    compare (WebSocketAddress u _) (WebSocketAddress u' _) = compare u u'++instance Show WebSocketAddress where+    show (WebSocketAddress _ _) = "websocket"++instance PeerAddressType WebSocketAddress where+    sendBytesToAddress (WebSocketAddress _ conn) msg = do+        WS.sendDataMessage conn $ WS.Binary $ BL.fromStrict msg+    connectionToAddressClosed (WebSocketAddress _ conn) = do+        WS.sendClose conn BL.empty++startWebsocketServer :: Server -> String -> Int -> (String -> IO ()) -> IO ()+startWebsocketServer server addr port logd = do+    void $ forkIO $ do+        WS.runServer addr port $ \pending -> do+            conn <- WS.acceptRequest pending+            u <- newUnique+            let paddr = WebSocketAddress u conn+            void $ serverPeerCustom server paddr+            handle (\(e :: SomeException) -> logd $ "WebSocket thread exception: " ++ show e) $ do+                WS.withPingThread conn 30 (return ()) $ do+                    forever $ do+                        WS.receiveDataMessage conn >>= \case+                            WS.Binary msg -> receivedFromCustomAddress server paddr $ BL.toStrict msg+                            WS.Text {} -> logd $ "unexpected websocket text message"

@@ -20,7 +20,7 @@ import Erebos.PubKey import Erebos.Service import Erebos.State-import Erebos.Storage+import Erebos.Storable import Erebos.Storage.Key  type AttachService = PairingService AttachIdentity@@ -52,14 +52,14 @@             guard $ iddPrev (fromSigned $ idData identity) == [eiddStoredBase curid]             return (identity, keys) -    pairingFinalizeRequest (identity, keys) = updateLocalHead_ $ \slocal -> do+    pairingFinalizeRequest (identity, keys) = updateLocalState_ $ \slocal -> do         let owner = finalOwner identity         st <- getStorage         pkeys <- mapM (copyStored st) [ idKeyIdentity owner, idKeyMessage owner ]         liftIO $ mapM_ storeKey $ catMaybes [ keyFromData sec pub | sec <- keys, pub <- pkeys ]          identity' <- mergeIdentity $ updateIdentity [ lsIdentity $ fromStored slocal ] identity-        shared <- makeSharedStateUpdate st (Just owner) (lsShared $ fromStored slocal)+        shared <- makeSharedStateUpdate (Just owner) (lsShared $ fromStored slocal)         mstore (fromStored slocal)             { lsIdentity = idExtData identity'             , lsShared = [ shared ]@@ -113,11 +113,11 @@             svcPrint $ "Attachement failed"         } -attachToOwner :: (MonadIO m, MonadError String m) => Peer -> m ()+attachToOwner :: (MonadIO m, MonadError e m, FromErebosError e) => Peer -> m () attachToOwner = pairingRequest @AttachIdentity Proxy -attachAccept :: (MonadIO m, MonadError String m) => Peer -> m ()+attachAccept :: (MonadIO m, MonadError e m, FromErebosError e) => Peer -> m () attachAccept = pairingAccept @AttachIdentity Proxy -attachReject :: (MonadIO m, MonadError String m) => Peer -> m ()+attachReject :: (MonadIO m, MonadError e m, FromErebosError e) => Peer -> m () attachReject = pairingReject @AttachIdentity Proxy

@@ -1,175 +0,0 @@-module Erebos.Channel (-    Channel,-    ChannelRequest, ChannelRequestData(..),-    ChannelAccept, ChannelAcceptData(..),--    createChannelRequest,-    acceptChannelRequest,-    acceptedChannel,--    channelEncrypt,-    channelDecrypt,-) where--import Control.Concurrent.MVar-import Control.Monad-import Control.Monad.Except-import Control.Monad.IO.Class--import Crypto.Cipher.ChaChaPoly1305-import Crypto.Error--import Data.Binary-import Data.ByteArray (ByteArray, Bytes, ScrubbedBytes, convert)-import Data.ByteArray qualified as BA-import Data.ByteString.Lazy qualified as BL-import Data.List--import Erebos.Identity-import Erebos.PubKey-import Erebos.Storage--data Channel = Channel-    { chPeers :: [Stored (Signed IdentityData)]-    , chKey :: ScrubbedBytes-    , chNonceFixedOur :: Bytes-    , chNonceFixedPeer :: Bytes-    , chCounterNextOut :: MVar Word64-    , chCounterNextIn :: MVar Word64-    }--type ChannelRequest = Signed ChannelRequestData--data ChannelRequestData = ChannelRequest-    { crPeers :: [Stored (Signed IdentityData)]-    , crKey :: Stored PublicKexKey-    }-    deriving (Show)--type ChannelAccept = Signed ChannelAcceptData--data ChannelAcceptData = ChannelAccept-    { caRequest :: Stored ChannelRequest-    , caKey :: Stored PublicKexKey-    }---instance Storable ChannelRequestData where-    store' cr = storeRec $ do-        mapM_ (storeRef "peer") $ crPeers cr-        storeRef "key" $ crKey cr--    load' = loadRec $ do-        ChannelRequest-            <$> loadRefs "peer"-            <*> loadRef "key"--instance Storable ChannelAcceptData where-    store' ca = storeRec $ do-        storeRef "req" $ caRequest ca-        storeRef "key" $ caKey ca--    load' = loadRec $ do-        ChannelAccept-            <$> loadRef "req"-            <*> loadRef "key"---keySize :: Int-keySize = 32--createChannelRequest :: (MonadStorage m, MonadIO m, MonadError String m) => UnifiedIdentity -> UnifiedIdentity -> m (Stored ChannelRequest)-createChannelRequest self peer = do-    (_, xpublic) <- liftIO . generateKeys =<< getStorage-    skey <- loadKey $ idKeyMessage self-    mstore =<< sign skey =<< mstore ChannelRequest { crPeers = sort [idData self, idData peer], crKey = xpublic }--acceptChannelRequest :: (MonadStorage m, MonadIO m, MonadError String m) => UnifiedIdentity -> UnifiedIdentity -> Stored ChannelRequest -> m (Stored ChannelAccept, Channel)-acceptChannelRequest self peer req = do-    case sequence $ map validateIdentity $ crPeers $ fromStored $ signedData $ fromStored req of-        Nothing -> throwError $ "invalid peers in channel request"-        Just peers -> do-            when (not $ any (self `sameIdentity`) peers) $-                throwError $ "self identity missing in channel request peers"-            when (not $ any (peer `sameIdentity`) peers) $-                throwError $ "peer identity missing in channel request peers"-    when (idKeyMessage peer `notElem` (map (sigKey . fromStored) $ signedSignature $ fromStored req)) $-        throwError $ "channel requent not signed by peer"--    (xsecret, xpublic) <- liftIO . generateKeys =<< getStorage-    skey <- loadKey $ idKeyMessage self-    acc <- mstore =<< sign skey =<< mstore ChannelAccept { caRequest = req, caKey = xpublic }-    liftIO $ do-        let chPeers = crPeers $ fromStored $ signedData $ fromStored req-            chKey = BA.take keySize $ dhSecret xsecret $-                fromStored $ crKey $ fromStored $ signedData $ fromStored req-            chNonceFixedOur  = BA.pack [ 2, 0, 0, 0 ]-            chNonceFixedPeer = BA.pack [ 1, 0, 0, 0 ]-        chCounterNextOut <- newMVar 0-        chCounterNextIn <- newMVar 0--        return (acc, Channel {..})--acceptedChannel :: (MonadIO m, MonadError String m) => UnifiedIdentity -> UnifiedIdentity -> Stored ChannelAccept -> m Channel-acceptedChannel self peer acc = do-    let req = caRequest $ fromStored $ signedData $ fromStored acc-    case sequence $ map validateIdentity $ crPeers $ fromStored $ signedData $ fromStored req of-        Nothing -> throwError $ "invalid peers in channel accept"-        Just peers -> do-            when (not $ any (self `sameIdentity`) peers) $-                throwError $ "self identity missing in channel accept peers"-            when (not $ any (peer `sameIdentity`) peers) $-                throwError $ "peer identity missing in channel accept peers"-    when (idKeyMessage peer `notElem` (map (sigKey . fromStored) $ signedSignature $ fromStored acc)) $-        throwError $ "channel accept not signed by peer"-    when (idKeyMessage self `notElem` (map (sigKey . fromStored) $ signedSignature $ fromStored req)) $-        throwError $ "original channel request not signed by us"--    xsecret <- loadKey $ crKey $ fromStored $ signedData $ fromStored req-    let chPeers = crPeers $ fromStored $ signedData $ fromStored req-        chKey = BA.take keySize $ dhSecret xsecret $-            fromStored $ caKey $ fromStored $ signedData $ fromStored acc-        chNonceFixedOur  = BA.pack [ 1, 0, 0, 0 ]-        chNonceFixedPeer = BA.pack [ 2, 0, 0, 0 ]-    chCounterNextOut <- liftIO $ newMVar 0-    chCounterNextIn <- liftIO $ newMVar 0--    return Channel {..}---channelEncrypt :: (ByteArray ba, MonadIO m, MonadError String m) => Channel -> ba -> m (ba, Word64)-channelEncrypt Channel {..} plain = do-    count <- liftIO $ modifyMVar chCounterNextOut $ \c -> return (c + 1, c)-    let cbytes = convert $ BL.toStrict $ encode count-        nonce = nonce8 chNonceFixedOur cbytes-    state <- case initialize chKey =<< nonce of-        CryptoPassed state -> return state-        CryptoFailed err -> throwError $ "failed to init chacha-poly1305 cipher: " <> show err--    let (ctext, state') = encrypt plain state-        tag = finalize state'-    return (BA.concat [ convert $ BA.drop 7 cbytes, ctext, convert tag ], count)--channelDecrypt :: (ByteArray ba, MonadIO m, MonadError String m) => Channel -> ba -> m (ba, Word64)-channelDecrypt Channel {..} body = do-    when (BA.length body < 17) $ do-        throwError $ "invalid encrypted data length"--    expectedCount <- liftIO $ readMVar chCounterNextIn-    let countByte = body `BA.index` 0-        body' = BA.dropView body 1-        guessedCount = expectedCount - 128 + fromIntegral (countByte - fromIntegral expectedCount + 128 :: Word8)-        nonce = nonce8 chNonceFixedPeer $ convert $ BL.toStrict $ encode guessedCount-        blen = BA.length body' - 16-        ctext = BA.takeView body' blen-        tag = BA.dropView body' blen-    state <- case initialize chKey =<< nonce of-        CryptoPassed state -> return state-        CryptoFailed err -> throwError $ "failed to init chacha-poly1305 cipher: " <> show err--    let (plain, state') = decrypt (convert ctext) state-    when (not $ tag `BA.constEq` finalize state') $ do-        throwError $ "tag validation falied"--    liftIO $ modifyMVar_ chCounterNextIn $ return . max (guessedCount + 1)-    return (plain, guessedCount)

@@ -17,6 +17,7 @@     joinChatroomAs, joinChatroomAsByStateData,     leaveChatroom, leaveChatroomByStateData,     getMessagesSinceState,+    isSameChatroom,      ChatroomSetChange(..),     watchChatrooms,@@ -54,7 +55,8 @@ import Erebos.Service import Erebos.Set import Erebos.State-import Erebos.Storage+import Erebos.Storable+import Erebos.Storage.Head import Erebos.Storage.Merge import Erebos.Util @@ -180,17 +182,17 @@     cmpView msg = (zonedTimeToUTC $ mdTime $ fromSigned msg, msg)  sendChatroomMessage-    :: (MonadStorage m, MonadHead LocalState m, MonadError String m)+    :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e)     => ChatroomState -> Text -> m () sendChatroomMessage rstate msg = sendChatroomMessageByStateData (head $ roomStateData rstate) msg  sendChatroomMessageByStateData-    :: (MonadStorage m, MonadHead LocalState m, MonadError String m)+    :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e)     => Stored ChatroomStateData -> Text -> m () sendChatroomMessageByStateData lookupData msg = sendRawChatroomMessageByStateData lookupData Nothing Nothing (Just msg) False  sendRawChatroomMessageByStateData-    :: (MonadStorage m, MonadHead LocalState m, MonadError String m)+    :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e)     => Stored ChatroomStateData -> Maybe UnifiedIdentity -> Maybe (Stored (Signed ChatMessageData)) -> Maybe Text -> Bool -> m () sendRawChatroomMessageByStateData lookupData mbIdentity mdReplyTo mdText mdLeave = void $ findAndUpdateChatroomState $ \cstate -> do     guard $ any (lookupData `precedesOrEquals`) $ roomStateData cstate@@ -282,7 +284,7 @@ instance SharedType (Set ChatroomState) where     sharedTypeID _ = mkSharedTypeID "7bc71cbf-bc43-42b1-b413-d3a2c9a2aae0" -createChatroom :: (MonadStorage m, MonadHead LocalState m, MonadIO m, MonadError String m) => Maybe Text -> Maybe Text -> m ChatroomState+createChatroom :: (MonadStorage m, MonadHead LocalState m, MonadIO m, MonadError e m, FromErebosError e) => Maybe Text -> Maybe Text -> m ChatroomState createChatroom rdName rdDescription = do     (secret, rdKey) <- liftIO . generateKeys =<< getStorage     let rdPrev = []@@ -292,31 +294,29 @@         , rsdSubscribe = Just True         } -    updateLocalHead $ updateSharedState $ \rooms -> do-        st <- getStorage-        (, cstate) <$> storeSetAdd st cstate rooms+    updateLocalState $ updateSharedState $ \rooms -> do+        (, cstate) <$> storeSetAdd cstate rooms  findAndUpdateChatroomState     :: (MonadStorage m, MonadHead LocalState m)     => (ChatroomState -> Maybe (m ChatroomState))     -> m (Maybe ChatroomState) findAndUpdateChatroomState f = do-    updateLocalHead $ updateSharedState $ \roomSet -> do+    updateLocalState $ updateSharedState $ \roomSet -> do         let roomList = fromSetBy (comparing $ roomName <=< roomStateRoom) roomSet         case catMaybes $ map (\x -> (x,) <$> f x) roomList of             ((orig, act) : _) -> do                 upd <- act                 if roomStateData orig /= roomStateData upd                   then do-                    st <- getStorage-                    roomSet' <- storeSetAdd st upd roomSet+                    roomSet' <- storeSetAdd upd roomSet                     return (roomSet', Just upd)                   else do                     return (roomSet, Just upd)             [] -> return (roomSet, Nothing)  deleteChatroomByStateData-    :: (MonadStorage m, MonadHead LocalState m, MonadError String m)+    :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e)     => Stored ChatroomStateData -> m () deleteChatroomByStateData lookupData = void $ findAndUpdateChatroomState $ \cstate -> do     guard $ any (lookupData `precedesOrEquals`) $ roomStateData cstate@@ -327,7 +327,7 @@             }  updateChatroomByStateData-    :: (MonadStorage m, MonadHead LocalState m, MonadError String m)+    :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e)     => Stored ChatroomStateData     -> Maybe Text     -> Maybe Text@@ -368,7 +368,7 @@ findChatroomByStateData cdata = findChatroom $ any (cdata `precedesOrEquals`) . roomStateData  chatroomSetSubscribe-    :: (MonadStorage m, MonadHead LocalState m, MonadError String m)+    :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e)     => Stored ChatroomStateData -> Bool -> m () chatroomSetSubscribe lookupData subscribe = void $ findAndUpdateChatroomState $ \cstate -> do     guard $ any (lookupData `precedesOrEquals`) $ roomStateData cstate@@ -389,39 +389,44 @@     toList $ ancestors $ roomStateMessageData  joinChatroom-    :: (MonadStorage m, MonadHead LocalState m, MonadError String m)+    :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e)     => ChatroomState -> m () joinChatroom rstate = joinChatroomByStateData (head $ roomStateData rstate)  joinChatroomByStateData-    :: (MonadStorage m, MonadHead LocalState m, MonadError String m)+    :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e)     => Stored ChatroomStateData -> m () joinChatroomByStateData lookupData = sendRawChatroomMessageByStateData lookupData Nothing Nothing Nothing False  joinChatroomAs-    :: (MonadStorage m, MonadHead LocalState m, MonadError String m)+    :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e)     => UnifiedIdentity -> ChatroomState -> m () joinChatroomAs identity rstate = joinChatroomAsByStateData identity (head $ roomStateData rstate)  joinChatroomAsByStateData-    :: (MonadStorage m, MonadHead LocalState m, MonadError String m)+    :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e)     => UnifiedIdentity -> Stored ChatroomStateData -> m () joinChatroomAsByStateData identity lookupData = sendRawChatroomMessageByStateData lookupData (Just identity) Nothing Nothing False  leaveChatroom-    :: (MonadStorage m, MonadHead LocalState m, MonadError String m)+    :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e)     => ChatroomState -> m () leaveChatroom rstate = leaveChatroomByStateData (head $ roomStateData rstate)  leaveChatroomByStateData-    :: (MonadStorage m, MonadHead LocalState m, MonadError String m)+    :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e)     => Stored ChatroomStateData -> m () leaveChatroomByStateData lookupData = sendRawChatroomMessageByStateData lookupData Nothing Nothing Nothing True  getMessagesSinceState :: ChatroomState -> ChatroomState -> [ChatMessage] getMessagesSinceState cur old = threadToListSince (roomStateMessageData old) (roomStateMessageData cur) +isSameChatroom :: ChatroomState -> ChatroomState -> Bool+isSameChatroom rstate rstate' =+    let roots = filterAncestors . concatMap storedRoots . roomStateData+     in intersectsSorted (roots rstate) (roots rstate') + data ChatroomSetChange = AddedChatroom ChatroomState                        | RemovedChatroom ChatroomState                        | UpdatedChatroom ChatroomState ChatroomState@@ -522,7 +527,7 @@                 }          when (not $ null chatRoomInfo) $ do-            updateLocalHead_ $ updateSharedState_ $ \roomSet -> do+            updateLocalState_ $ updateSharedState_ $ \roomSet -> do                 let rooms = fromSetBy (comparing $ roomName <=< roomStateRoom) roomSet                     upd set (roomInfo :: Stored (Signed ChatroomData)) = do                         let currentRoots = storedRoots roomInfo@@ -561,7 +566,7 @@                 svcModify $ \ps -> ps { psSubscribedTo = filter (/= leastRoot) (psSubscribedTo ps) }          when (not (null chatRoomMessage)) $ do-            updateLocalHead_ $ updateSharedState_ $ \roomSet -> do+            updateLocalState_ $ updateSharedState_ $ \roomSet -> do                 let rooms = fromSetBy (comparing $ roomName <=< roomStateRoom) roomSet                     upd set (msgData :: Stored (Signed ChatMessageData))                         | Just msg <- validateSingleMessage msgData = do

@@ -28,7 +28,7 @@ import Erebos.Service import Erebos.Set import Erebos.State-import Erebos.Storage+import Erebos.Storable import Erebos.Storage.Merge  data Contact = Contact@@ -83,13 +83,12 @@  contactSetName :: MonadHead LocalState m => Contact -> Text -> Set Contact -> m (Set Contact) contactSetName contact name set = do-    st <- getStorage-    cdata <- wrappedStore st ContactData+    cdata <- mstore ContactData         { cdPrev = toComponents contact         , cdIdentity = []         , cdName = Just name         }-    storeSetAdd st (mergeSorted @Contact [cdata]) set+    storeSetAdd (mergeSorted @Contact [cdata]) set   type ContactService = PairingService ContactAccepted@@ -155,21 +154,20 @@             svcPrint $ "Contact failed"         } -contactRequest :: (MonadIO m, MonadError String m) => Peer -> m ()+contactRequest :: (MonadIO m, MonadError e m, FromErebosError e) => Peer -> m () contactRequest = pairingRequest @ContactAccepted Proxy -contactAccept :: (MonadIO m, MonadError String m) => Peer -> m ()+contactAccept :: (MonadIO m, MonadError e m, FromErebosError e) => Peer -> m () contactAccept = pairingAccept @ContactAccepted Proxy -contactReject :: (MonadIO m, MonadError String m) => Peer -> m ()+contactReject :: (MonadIO m, MonadError e m, FromErebosError e) => Peer -> m () contactReject = pairingReject @ContactAccepted Proxy  finalizeContact :: MonadHead LocalState m => UnifiedIdentity -> m ()-finalizeContact identity = updateLocalHead_ $ updateSharedState_ $ \contacts -> do-    st <- getStorage-    cdata <- wrappedStore st ContactData+finalizeContact identity = updateLocalState_ $ updateSharedState_ $ \contacts -> do+    cdata <- mstore ContactData         { cdPrev = []         , cdIdentity = idExtDataF $ finalOwner identity         , cdName = Nothing         }-    storeSetAdd st (mergeSorted @Contact [cdata]) contacts+    storeSetAdd (mergeSorted @Contact [cdata]) contacts

@@ -7,9 +7,11 @@     formatMessage,      Conversation,+    isSameConversation,     directMessageConversation,     chatroomConversation,     chatroomConversationByStateData,+    isChatroomStateConversation,     reloadConversation,     lookupConversations, @@ -30,11 +32,11 @@ import Data.Time.Format import Data.Time.LocalTime -import Erebos.Identity import Erebos.Chatroom-import Erebos.Message hiding (formatMessage)+import Erebos.DirectMessage+import Erebos.Identity import Erebos.State-import Erebos.Storage+import Erebos.Storable   data Message = DirectMessageMessage DirectMessage Bool@@ -64,12 +66,20 @@     ]  -data Conversation = DirectMessageConversation DirectMessageThread-                  | ChatroomConversation ChatroomState+data Conversation+    = DirectMessageConversation DirectMessageThread+    | ChatroomConversation ChatroomState +isSameConversation :: Conversation -> Conversation -> Bool+isSameConversation (DirectMessageConversation t) (DirectMessageConversation t')+    = sameIdentity (msgPeer t) (msgPeer t')+isSameConversation (ChatroomConversation rstate) (ChatroomConversation rstate') = isSameChatroom rstate rstate'+isSameConversation _ _ = False+ directMessageConversation :: MonadHead LocalState m => ComposedIdentity -> m Conversation directMessageConversation peer = do-    (find (sameIdentity peer . msgPeer) . toThreadList . lookupSharedValue . lsShared . fromStored <$> getLocalHead) >>= \case+    createOrUpdateDirectMessagePeer peer+    (find (sameIdentity peer . msgPeer) . dmThreadList . lookupSharedValue . lsShared . fromStored <$> getLocalHead) >>= \case         Just thread -> return $ DirectMessageConversation thread         Nothing -> return $ DirectMessageConversation $ DirectMessageThread peer [] [] [] [] @@ -79,13 +89,17 @@ chatroomConversationByStateData :: MonadHead LocalState m => Stored ChatroomStateData -> m (Maybe Conversation) chatroomConversationByStateData sdata = fmap ChatroomConversation <$> findChatroomByStateData sdata +isChatroomStateConversation :: ChatroomState -> Conversation -> Bool+isChatroomStateConversation rstate (ChatroomConversation rstate') = isSameChatroom rstate rstate'+isChatroomStateConversation _ _ = False+ reloadConversation :: MonadHead LocalState m => Conversation -> m Conversation reloadConversation (DirectMessageConversation thread) = directMessageConversation (msgPeer thread) reloadConversation cur@(ChatroomConversation rstate) =     fromMaybe cur <$> chatroomConversation rstate -lookupConversations :: MonadHead LocalState m => m [Conversation]-lookupConversations = map DirectMessageConversation . toThreadList . lookupSharedValue . lsShared . fromStored <$> getLocalHead+lookupConversations :: MonadHead LocalState m => m [ Conversation ]+lookupConversations = map DirectMessageConversation . dmThreadList . lookupSharedValue . lsShared . fromStored <$> getLocalHead   conversationName :: Conversation -> Text@@ -96,15 +110,15 @@ conversationPeer (DirectMessageConversation thread) = Just $ msgPeer thread conversationPeer (ChatroomConversation _) = Nothing -conversationHistory :: Conversation -> [Message]-conversationHistory (DirectMessageConversation thread) = map (\msg -> DirectMessageMessage msg False) $ threadToList thread+conversationHistory :: Conversation -> [ Message ]+conversationHistory (DirectMessageConversation thread) = map (\msg -> DirectMessageMessage msg False) $ dmThreadToList thread conversationHistory (ChatroomConversation rstate) = map (\msg -> ChatroomMessage msg False) $ roomStateMessages rstate  -sendMessage :: (MonadHead LocalState m, MonadError String m) => Conversation -> Text -> m (Maybe Message)-sendMessage (DirectMessageConversation thread) text = fmap Just $ DirectMessageMessage <$> (fromStored <$> sendDirectMessage (msgPeer thread) text) <*> pure False-sendMessage (ChatroomConversation rstate) text = sendChatroomMessage rstate text >> return Nothing+sendMessage :: (MonadHead LocalState m, MonadError e m, FromErebosError e) => Conversation -> Text -> m ()+sendMessage (DirectMessageConversation thread) text = sendDirectMessage (msgPeer thread) text+sendMessage (ChatroomConversation rstate) text = sendChatroomMessage rstate text -deleteConversation :: (MonadHead LocalState m, MonadError String m) => Conversation -> m ()-deleteConversation (DirectMessageConversation _) = throwError "deleting direct message conversation is not supported"+deleteConversation :: (MonadHead LocalState m, MonadError e m, FromErebosError e) => Conversation -> m ()+deleteConversation (DirectMessageConversation _) = throwOtherError "deleting direct message conversation is not supported" deleteConversation (ChatroomConversation rstate) = deleteChatroomByStateData (head $ roomStateData rstate)

@@ -0,0 +1,345 @@+module Erebos.DirectMessage (+    DirectMessage(..),+    sendDirectMessage,+    updateDirectMessagePeer,+    createOrUpdateDirectMessagePeer,++    DirectMessageAttributes(..),+    defaultDirectMessageAttributes,++    DirectMessageThreads,+    dmThreadList,++    DirectMessageThread(..),+    dmThreadToList, dmThreadToListSince,+    dmThreadView,++    watchDirectMessageThreads,+    formatDirectMessage,+) where++import Control.Concurrent.MVar+import Control.Monad+import Control.Monad.Except+import Control.Monad.Reader++import Data.List+import Data.Ord+import Data.Set (Set)+import Data.Set qualified as S+import Data.Text (Text)+import Data.Text qualified as T+import Data.Time.Format+import Data.Time.LocalTime++import Erebos.Discovery+import Erebos.Identity+import Erebos.Network+import Erebos.Object+import Erebos.Service+import Erebos.State+import Erebos.Storable+import Erebos.Storage.Head+import Erebos.Storage.Merge++data DirectMessage = DirectMessage+    { msgFrom :: ComposedIdentity+    , msgPrev :: [ Stored DirectMessage ]+    , msgTime :: ZonedTime+    , msgText :: Text+    }++instance Storable DirectMessage where+    store' msg = storeRec $ do+        mapM_ (storeRef "from") $ idExtDataF $ msgFrom msg+        mapM_ (storeRef "PREV") $ msgPrev msg+        storeDate "time" $ msgTime msg+        storeText "text" $ msgText msg++    load' = loadRec $ DirectMessage+        <$> loadIdentity "from"+        <*> loadRefs "PREV"+        <*> loadDate "time"+        <*> loadText "text"++data DirectMessageAttributes = DirectMessageAttributes+    { dmOwnerMismatch :: ServiceHandler DirectMessage ()+    }++defaultDirectMessageAttributes :: DirectMessageAttributes+defaultDirectMessageAttributes = DirectMessageAttributes+    { dmOwnerMismatch = svcPrint "Owner mismatch"+    }++instance Service DirectMessage where+    serviceID _ = mkServiceID "c702076c-4928-4415-8b6b-3e839eafcb0d"++    type ServiceAttributes DirectMessage = DirectMessageAttributes+    defaultServiceAttributes _ = defaultDirectMessageAttributes++    serviceHandler smsg = do+        let msg = fromStored smsg+        powner <- asks $ finalOwner . svcPeerIdentity+        erb <- svcGetLocal+        let DirectMessageThreads prev _ = lookupSharedValue $ lsShared $ fromStored erb+            sent = findMsgProperty powner msSent prev+            received = findMsgProperty powner msReceived prev+            received' = filterAncestors $ smsg : received+        if powner `sameIdentity` msgFrom msg ||+               filterAncestors sent == filterAncestors (smsg : sent)+           then do+               when (received' /= received) $ do+                   next <- mstore MessageState+                       { msPrev = prev+                       , msPeer = powner+                       , msReady = []+                       , msSent = []+                       , msReceived = received'+                       , msSeen = []+                       }+                   let threads = DirectMessageThreads [ next ] (dmThreadView [ next ])+                   shared <- makeSharedStateUpdate threads (lsShared $ fromStored erb)+                   svcSetLocal =<< mstore (fromStored erb) { lsShared = [ shared ] }++               when (powner `sameIdentity` msgFrom msg) $ do+                   replyStoredRef smsg++           else join $ asks $ dmOwnerMismatch . svcAttributes++    serviceNewPeer = do+        syncDirectMessageToPeer . lookupSharedValue . lsShared . fromStored =<< svcGetLocal++    serviceUpdatedPeer = do+        updateDirectMessagePeer . finalOwner =<< asks svcPeerIdentity++    serviceStorageWatchers _ =+        [ SomeStorageWatcher (lookupSharedValue . lsShared . fromStored) syncDirectMessageToPeer+        , GlobalStorageWatcher (lookupSharedValue . lsShared . fromStored) findMissingPeers+        ]+++data MessageState = MessageState+    { msPrev :: [ Stored MessageState ]+    , msPeer :: ComposedIdentity+    , msReady :: [ Stored DirectMessage ]+    , msSent :: [ Stored DirectMessage ]+    , msReceived :: [ Stored DirectMessage ]+    , msSeen :: [ Stored DirectMessage ]+    }++data DirectMessageThreads = DirectMessageThreads [ Stored MessageState ] [ DirectMessageThread ]++instance Eq DirectMessageThreads where+    DirectMessageThreads mss _ == DirectMessageThreads mss' _ = mss == mss'++dmThreadList :: DirectMessageThreads -> [ DirectMessageThread ]+dmThreadList (DirectMessageThreads _ threads) = threads++instance Storable MessageState where+    store' MessageState {..} = storeRec $ do+        mapM_ (storeRef "PREV") msPrev+        mapM_ (storeRef "peer") $ idExtDataF msPeer+        mapM_ (storeRef "ready") msReady+        mapM_ (storeRef "sent") msSent+        mapM_ (storeRef "received") msReceived+        mapM_ (storeRef "seen") msSeen++    load' = loadRec $ do+        msPrev <- loadRefs "PREV"+        msPeer <- loadIdentity "peer"+        msReady <- loadRefs "ready"+        msSent <- loadRefs "sent"+        msReceived <- loadRefs "received"+        msSeen <- loadRefs "seen"+        return MessageState {..}++instance Mergeable DirectMessageThreads where+    type Component DirectMessageThreads = MessageState+    mergeSorted mss = DirectMessageThreads mss (dmThreadView mss)+    toComponents (DirectMessageThreads mss _) = mss++instance SharedType DirectMessageThreads where+    sharedTypeID _ = mkSharedTypeID "ee793681-5976-466a-b0f0-4e1907d3fade"++findMsgProperty :: Foldable m => Identity m -> (MessageState -> [ a ]) -> [ Stored MessageState ] -> [ a ]+findMsgProperty pid sel mss = concat $ flip findProperty mss $ \x -> do+    guard $ msPeer x `sameIdentity` pid+    guard $ not $ null $ sel x+    return $ sel x+++sendDirectMessage :: (Foldable f, Applicative f, MonadHead LocalState m)+                  => Identity f -> Text -> m ()+sendDirectMessage pid text = updateLocalState_ $ \ls -> do+    let self = localIdentity $ fromStored ls+        powner = finalOwner pid+    flip updateSharedState_ ls $ \(DirectMessageThreads prev _) -> do+        let ready = findMsgProperty powner msReady prev+            received = findMsgProperty powner msReceived prev++        time <- liftIO getZonedTime+        smsg <- mstore DirectMessage+            { msgFrom = toComposedIdentity $ finalOwner self+            , msgPrev = filterAncestors $ ready ++ received+            , msgTime = time+            , msgText = text+            }+        next <- mstore MessageState+            { msPrev = prev+            , msPeer = powner+            , msReady = [ smsg ]+            , msSent = []+            , msReceived = []+            , msSeen = []+            }+        return $ DirectMessageThreads [ next ] (dmThreadView [ next ])++updateDirectMessagePeer+    :: (Foldable f, Applicative f, MonadHead LocalState m)+    => Identity f -> m ()+updateDirectMessagePeer = createOrUpdateDirectMessagePeer' False++createOrUpdateDirectMessagePeer+    :: (Foldable f, Applicative f, MonadHead LocalState m)+    => Identity f -> m ()+createOrUpdateDirectMessagePeer = createOrUpdateDirectMessagePeer' True++createOrUpdateDirectMessagePeer'+    :: (Foldable f, Applicative f, MonadHead LocalState m)+    => Bool -> Identity f -> m ()+createOrUpdateDirectMessagePeer' create pid = do+    let powner = finalOwner pid+    updateLocalState_ $ updateSharedState_ $ \old@(DirectMessageThreads prev threads) -> do+        let updatePeerThread = do+                next <- mstore MessageState+                    { msPrev = prev+                    , msPeer = powner+                    , msReady = []+                    , msSent = []+                    , msReceived = []+                    , msSeen = []+                    }+                return $ DirectMessageThreads [ next ] (dmThreadView [ next ])+        case find (sameIdentity powner . msgPeer) threads of+            Nothing+                | create+                -> updatePeerThread++            Just thread+                | oldPeer <- msgPeer thread+                , newPeer <- updateIdentity (idExtDataF powner) oldPeer+                , oldPeer /= newPeer+                -> updatePeerThread++            _ -> return old+++syncDirectMessageToPeer :: DirectMessageThreads -> ServiceHandler DirectMessage ()+syncDirectMessageToPeer (DirectMessageThreads mss _) = do+    pid <- finalOwner <$> asks svcPeerIdentity+    peer <- asks svcPeer+    let thread = messageThreadFor pid mss+    mapM_ (sendToPeerStored peer) $ msgHead thread+    updateLocalState_ $ \ls -> do+        let powner = finalOwner pid+        flip updateSharedState_ ls $ \unchanged@(DirectMessageThreads prev _) -> do+            let ready = findMsgProperty powner msReady prev+                sent = findMsgProperty powner msSent prev+                sent' = filterAncestors (ready ++ sent)++            if sent' /= sent+              then do+                next <- mstore MessageState+                    { msPrev = prev+                    , msPeer = powner+                    , msReady = []+                    , msSent = sent'+                    , msReceived = []+                    , msSeen = []+                    }+                return $ DirectMessageThreads [ next ] (dmThreadView [ next ])+              else do+                return unchanged++findMissingPeers :: Server -> DirectMessageThreads -> ExceptT ErebosError IO ()+findMissingPeers server threads = do+    forM_ (dmThreadList threads) $ \thread -> do+        when (msgHead thread /= msgReceived thread) $ do+            mapM_ (discoverySearch server) $ map (refDigest . storedRef) $ idDataF $ msgPeer thread+++data DirectMessageThread = DirectMessageThread+    { msgPeer :: ComposedIdentity+    , msgHead :: [ Stored DirectMessage ]+    , msgSent :: [ Stored DirectMessage ]+    , msgSeen :: [ Stored DirectMessage ]+    , msgReceived :: [ Stored DirectMessage ]+    }++dmThreadToList :: DirectMessageThread -> [ DirectMessage ]+dmThreadToList thread = threadToListHelper S.empty $ msgHead thread++dmThreadToListSince :: DirectMessageThread -> DirectMessageThread -> [ DirectMessage ]+dmThreadToListSince since thread = threadToListHelper (S.fromAscList $ msgHead since) (msgHead thread)++threadToListHelper :: Set (Stored DirectMessage) -> [ Stored DirectMessage ] -> [ DirectMessage ]+threadToListHelper seen msgs+    | msg : msgs' <- filter (`S.notMember` seen) $ reverse $ sortBy (comparing cmpView) msgs =+        fromStored msg : threadToListHelper (S.insert msg seen) (msgs' ++ msgPrev (fromStored msg))+    | otherwise = []+  where+    cmpView msg = (zonedTimeToUTC $ msgTime $ fromStored msg, msg)++dmThreadView :: [ Stored MessageState ] -> [ DirectMessageThread ]+dmThreadView = helper []+    where helper used ms' = case filterAncestors ms' of+              mss@(sms : rest)+                  | any (sameIdentity $ msPeer $ fromStored sms) used ->+                      helper used $ msPrev (fromStored sms) ++ rest+                  | otherwise ->+                      let peer = msPeer $ fromStored sms+                       in messageThreadFor peer mss : helper (peer : used) (msPrev (fromStored sms) ++ rest)+              _ -> []++messageThreadFor :: ComposedIdentity -> [ Stored MessageState ] -> DirectMessageThread+messageThreadFor peer mss =+    let ready = findMsgProperty peer msReady mss+        sent = findMsgProperty peer msSent mss+        received = findMsgProperty peer msReceived mss+        seen = findMsgProperty peer msSeen mss++     in DirectMessageThread+         { msgPeer = peer+         , msgHead = filterAncestors $ ready ++ received+         , msgSent = filterAncestors $ sent ++ received+         , msgSeen = filterAncestors $ ready ++ seen+         , msgReceived = filterAncestors $ received+         }+++watchDirectMessageThreads :: Head LocalState -> (DirectMessageThread -> DirectMessageThread -> IO ()) -> IO WatchedHead+watchDirectMessageThreads h f = do+    prevVar <- newMVar Nothing+    watchHeadWith h (lookupSharedValue . lsShared . headObject) $ \(DirectMessageThreads sms _) -> do+        modifyMVar_ prevVar $ \case+            Just prev -> do+                let addPeer (p : ps) p'+                        | p `sameIdentity` p' = p : ps+                        | otherwise = p : addPeer ps p'+                    addPeer [] p' = [ p' ]++                let peers = foldl' addPeer [] $ map (msPeer . fromStored) $ storedDifference prev sms+                forM_ peers $ \peer -> do+                    f (messageThreadFor peer prev) (messageThreadFor peer sms)+                return (Just sms)++            Nothing -> do+                return (Just sms)++formatDirectMessage :: TimeZone -> DirectMessage -> String+formatDirectMessage tzone msg = concat+    [ formatTime defaultTimeLocale "[%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ msgTime msg+    , maybe "<unnamed>" T.unpack $ idName $ msgFrom msg+    , ": "+    , T.unpack $ msgText msg+    ]

@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}  module Erebos.Discovery (     DiscoveryService(..),@@ -6,6 +7,7 @@     DiscoveryConnection(..),      discoverySearch,+    discoverySetupTunnel, ) where  import Control.Concurrent@@ -13,7 +15,6 @@ import Control.Monad.Except import Control.Monad.Reader -import Data.IP qualified as IP import Data.List import Data.Map.Strict (Map) import Data.Map.Strict qualified as M@@ -25,15 +26,18 @@ import Data.Text qualified as T import Data.Word -import Network.Socket+import Text.Read  #ifdef ENABLE_ICE_SUPPORT import Erebos.ICE #endif import Erebos.Identity import Erebos.Network+import Erebos.Network.Address+import Erebos.Object import Erebos.Service-import Erebos.Storage+import Erebos.Service.Stream+import Erebos.Storable   #ifndef ENABLE_ICE_SUPPORT@@ -44,18 +48,25 @@   data DiscoveryService-    = DiscoverySelf [ Text ] (Maybe Int)-    | DiscoveryAcknowledged [ Text ] (Maybe Text) (Maybe Word16) (Maybe Text) (Maybe Word16)-    | DiscoverySearch Ref-    | DiscoveryResult Ref [ Text ]+    = DiscoverySelf [ DiscoveryAddress ] (Maybe Int)+    | DiscoveryAcknowledged [ DiscoveryAddress ] (Maybe Text) (Maybe Word16) (Maybe Text) (Maybe Word16)+    | DiscoverySearch (Either Ref RefDigest)+    | DiscoveryResult (Either Ref RefDigest) [ DiscoveryAddress ]     | DiscoveryConnectionRequest DiscoveryConnection     | DiscoveryConnectionResponse DiscoveryConnection +data DiscoveryAddress+    = DiscoveryIP InetAddress PortNumber+    | DiscoveryICE+    | DiscoveryTunnel+    | DiscoveryOther Text+ data DiscoveryAttributes = DiscoveryAttributes     { discoveryStunPort :: Maybe Word16     , discoveryStunServer :: Maybe Text     , discoveryTurnPort :: Maybe Word16     , discoveryTurnServer :: Maybe Text+    , discoveryProvideTunnel :: Peer -> PeerAddress -> Bool     }  defaultDiscoveryAttributes :: DiscoveryAttributes@@ -64,19 +75,22 @@     , discoveryStunServer = Nothing     , discoveryTurnPort = Nothing     , discoveryTurnServer = Nothing+    , discoveryProvideTunnel = \_ _ -> False     }  data DiscoveryConnection = DiscoveryConnection-    { dconnSource :: Ref-    , dconnTarget :: Ref+    { dconnSource :: Either Ref RefDigest+    , dconnTarget :: Either Ref RefDigest     , dconnAddress :: Maybe Text+    , dconnTunnel :: Bool     , dconnIceInfo :: Maybe IceRemoteInfo     } -emptyConnection :: Ref -> Ref -> DiscoveryConnection+emptyConnection :: Either Ref RefDigest -> Either Ref RefDigest -> DiscoveryConnection emptyConnection dconnSource dconnTarget = DiscoveryConnection {..}   where     dconnAddress = Nothing+    dconnTunnel = False     dconnIceInfo = Nothing  instance Storable DiscoveryService where@@ -92,19 +106,20 @@                 storeMbInt "stun-port" stunPort                 storeMbText "turn-server" turnServer                 storeMbInt "turn-port" turnPort-            DiscoverySearch ref -> storeRawRef "search" ref-            DiscoveryResult ref addr -> do-                storeRawRef "result" ref+            DiscoverySearch edgst -> either (storeRawRef "search") (storeRawWeak "search") edgst+            DiscoveryResult edgst addr -> do+                either (storeRawRef "result") (storeRawWeak "result") edgst                 mapM_ (storeText "address") addr             DiscoveryConnectionRequest conn -> storeConnection "request" conn             DiscoveryConnectionResponse conn -> storeConnection "response" conn        where-        storeConnection ctype DiscoveryConnection {..} = do+        storeConnection (ctype :: Text) DiscoveryConnection {..} = do             storeText "connection" $ ctype-            storeRawRef "source" dconnSource-            storeRawRef "target" dconnTarget+            either (storeRawRef "source") (storeRawWeak "source") dconnSource+            either (storeRawRef "target") (storeRawWeak "target") dconnTarget             storeMbText "address" dconnAddress+            when dconnTunnel $ storeEmpty "tunnel"             storeMbRef "ice-info" dconnIceInfo      load' = loadRec $ msum@@ -123,27 +138,63 @@                     <*> loadMbInt "stun-port"                     <*> loadMbText "turn-server"                     <*> loadMbInt "turn-port"-            , DiscoverySearch <$> loadRawRef "search"+            , DiscoverySearch <$> msum+                [ Left <$> loadRawRef "search"+                , Right <$> loadRawWeak "search"+                ]             , DiscoveryResult-                <$> loadRawRef "result"+                <$> msum+                    [ Left <$> loadRawRef "result"+                    , Right <$> loadRawWeak "result"+                    ]                 <*> loadTexts "address"             , loadConnection "request" DiscoveryConnectionRequest             , loadConnection "response" DiscoveryConnectionResponse             ]       where-        loadConnection ctype ctor = do+        loadConnection (ctype :: Text) ctor = do             ctype' <- loadText "connection"             guard $ ctype == ctype'-            dconnSource <- loadRawRef "source"-            dconnTarget <- loadRawRef "target"+            dconnSource <- msum+                [ Left <$> loadRawRef "source"+                , Right <$> loadRawWeak "source"+                ]+            dconnTarget <- msum+                [ Left <$> loadRawRef "target"+                , Right <$> loadRawWeak "target"+                ]             dconnAddress <- loadMbText "address"+            dconnTunnel <- isJust <$> loadMbEmpty "tunnel"             dconnIceInfo <- loadMbRef "ice-info"             return $ ctor DiscoveryConnection {..} +instance StorableText DiscoveryAddress where+    toText = \case+        DiscoveryIP addr port -> T.unwords [ T.pack $ show addr, T.pack $ show port ]+        DiscoveryICE -> "ICE"+        DiscoveryTunnel -> "tunnel"+        DiscoveryOther str -> str++    fromText str = return $ if+        | [ addrStr, portStr ] <- T.words str+        , Just addr <- readMaybe $ T.unpack addrStr+        , Just port <- readMaybe $ T.unpack portStr+        -> DiscoveryIP addr port++        | "ice" <- T.toLower str+        -> DiscoveryICE++        | "tunnel" <- str+        -> DiscoveryTunnel++        | otherwise+        -> DiscoveryOther str++ data DiscoveryPeer = DiscoveryPeer     { dpPriority :: Int     , dpPeer :: Maybe Peer-    , dpAddress :: [ Text ]+    , dpAddress :: [ DiscoveryAddress ]     , dpIceSession :: Maybe IceSession     } @@ -156,7 +207,11 @@     }  data DiscoveryPeerState = DiscoveryPeerState-    { dpsStunServer :: Maybe ( Text, Word16 )+    { dpsOurTunnelRequests :: [ ( RefDigest, StreamWriter ) ]+    -- ( original target, our write stream )+    , dpsRelayedTunnelRequests :: [ ( RefDigest, ( StreamReader, StreamWriter )) ]+    -- ( original source, ( from source, to target ))+    , dpsStunServer :: Maybe ( Text, Word16 )     , dpsTurnServer :: Maybe ( Text, Word16 )     , dpsIceConfig :: Maybe IceConfig     }@@ -174,7 +229,9 @@      type ServiceState DiscoveryService = DiscoveryPeerState     emptyServiceState _ = DiscoveryPeerState-        { dpsStunServer = Nothing+        { dpsOurTunnelRequests = []+        , dpsRelayedTunnelRequests = []+        , dpsStunServer = Nothing         , dpsTurnServer = Nothing         , dpsIceConfig = Nothing         }@@ -189,26 +246,22 @@         DiscoverySelf addrs priority -> do             pid <- asks svcPeerIdentity             peer <- asks svcPeer+            paddrs <- getPeerAddresses peer+             let insertHelper new old | dpPriority new > dpPriority old = new                                      | otherwise                       = old-            matchedAddrs <- fmap catMaybes $ forM addrs $ \addr -> if-                | addr == T.pack "ICE" -> do-                    return $ Just addr -                | [ ipaddr, port ] <- words (T.unpack addr)-                , DatagramAddress paddr <- peerAddress peer -> do-                    saddr <- liftIO $ head <$> getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just ipaddr) (Just port)-                    return $ if paddr == addrAddress saddr-                                then Just addr-                                else Nothing--                | otherwise -> return Nothing+            let matchedAddrs = flip filter addrs $ \case+                    DiscoveryICE -> True+                    DiscoveryIP ipaddr port ->+                        DatagramAddress (inetToSockAddr ( ipaddr, port )) `elem` paddrs+                    _ -> False              forM_ (idDataF =<< unfoldOwners pid) $ \sdata -> do                 let dp = DiscoveryPeer                         { dpPriority = fromMaybe 0 priority                         , dpPeer = Just peer-                        , dpAddress = addrs+                        , dpAddress = matchedAddrs                         , dpIceSession = Nothing                         }                 svcModifyGlobal $ \s -> s { dgsPeers = M.insertWith insertHelper (refDigest $ storedRef sdata) dp $ dgsPeers s }@@ -220,14 +273,8 @@                 (discoveryTurnPort attrs)          DiscoveryAcknowledged _ stunServer stunPort turnServer turnPort -> do-            paddr <- asks (peerAddress . svcPeer) >>= return . \case-                (DatagramAddress saddr) -> case IP.fromSockAddr saddr of-                    Just (IP.IPv6 ipv6, _)-                        | (0, 0, 0xffff, ipv4) <- IP.fromIPv6w ipv6-                        -> Just $ T.pack $ show (IP.toIPv4w ipv4)-                    Just (addr, _)-                        -> Just $ T.pack $ show addr-                    _ -> Nothing+            paddr <- asks svcPeerAddress >>= return . \case+                (DatagramAddress saddr) -> T.pack . show . fst <$> inetFromSockAddr saddr                 _ -> Nothing              let toIceServer Nothing Nothing = Nothing@@ -240,65 +287,105 @@                 , dpsTurnServer = toIceServer turnServer turnPort                 } -        DiscoverySearch ref -> do-            dpeer <- M.lookup (refDigest ref) . dgsPeers <$> svcGetGlobal-            replyPacket $ DiscoveryResult ref $ maybe [] dpAddress dpeer+        DiscoverySearch edgst -> do+            dpeer <- M.lookup (either refDigest id edgst) . dgsPeers <$> svcGetGlobal+            peer <- asks svcPeer+            paddr <- asks svcPeerAddress+            attrs <- asks svcAttributes+            let offerTunnel+                    | discoveryProvideTunnel attrs peer paddr = (++ [ DiscoveryTunnel ])+                    | otherwise                               = id+            replyPacket $ DiscoveryResult edgst $ maybe [] (offerTunnel . dpAddress) dpeer          DiscoveryResult _ [] -> do             -- not found             return () -        DiscoveryResult ref addrs -> do-            let dgst = refDigest ref+        DiscoveryResult edgst addrs -> do+            let dgst = either refDigest id edgst             -- TODO: check if we really requested that             server <- asks svcServer+            st <- getStorage             self <- svcSelf             discoveryPeer <- asks svcPeer             let runAsService = runPeerService @DiscoveryService discoveryPeer -            forM_ addrs $ \addr -> if-                | addr == T.pack "ICE"-                -> do+            let tryAddresses = \case+                    DiscoveryIP ipaddr port : _ -> do+                        void $ liftIO $ forkIO $ do+                            let saddr = inetToSockAddr ( ipaddr, port )+                            peer <- serverPeer server saddr+                            runAsService $ do+                                let upd dp = dp { dpPeer = Just peer }+                                svcModifyGlobal $ \s -> s { dgsPeers = M.alter (Just . upd . fromMaybe emptyPeer) dgst $ dgsPeers s }++                    DiscoveryICE : rest -> do #ifdef ENABLE_ICE_SUPPORT-                    getIceConfig >>= \case-                        Just config -> void $ liftIO $ forkIO $ do-                            ice <- iceCreateSession config PjIceSessRoleControlling $ \ice -> do-                                rinfo <- iceRemoteInfo ice+                        getIceConfig >>= \case+                            Just config -> do+                                void $ liftIO $ forkIO $ do+                                    ice <- iceCreateSession config PjIceSessRoleControlling $ \ice -> do+                                        rinfo <- iceRemoteInfo ice -                                res <- runExceptT $ sendToPeer discoveryPeer $-                                    DiscoveryConnectionRequest (emptyConnection (storedRef $ idData self) ref) { dconnIceInfo = Just rinfo }-                                case res of-                                    Right _ -> return ()-                                    Left err -> putStrLn $ "Discovery: failed to send connection request: " ++ err+                                        -- Try to promote weak ref to normal one for older peers:+                                        edgst' <- case edgst of+                                            Left  r -> return (Left r)+                                            Right d -> refFromDigest st d >>= \case+                                                Just  r -> return (Left  r)+                                                Nothing -> return (Right d) -                            runAsService $ do-                                let upd dp = dp { dpIceSession = Just ice }-                                svcModifyGlobal $ \s -> s { dgsPeers = M.alter (Just . upd . fromMaybe emptyPeer) dgst $ dgsPeers s }+                                        res <- runExceptT $ sendToPeer discoveryPeer $+                                            DiscoveryConnectionRequest (emptyConnection (Left $ storedRef $ idData self) edgst') { dconnIceInfo = Just rinfo }+                                        case res of+                                            Right _ -> return ()+                                            Left err -> putStrLn $ "Discovery: failed to send connection request: " ++ err -                        Nothing -> do-                            return ()+                                    runAsService $ do+                                        let upd dp = dp { dpIceSession = Just ice }+                                        svcModifyGlobal $ \s -> s { dgsPeers = M.alter (Just . upd . fromMaybe emptyPeer) dgst $ dgsPeers s }++                            Nothing -> do #endif-                    return ()+                                tryAddresses rest -                | [ ipaddr, port ] <- words (T.unpack addr) -> do-                    void $ liftIO $ forkIO $ do-                        saddr <- head <$>-                            getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just ipaddr) (Just port)-                        peer <- serverPeer server (addrAddress saddr)-                        runAsService $ do-                            let upd dp = dp { dpPeer = Just peer }-                            svcModifyGlobal $ \s -> s { dgsPeers = M.alter (Just . upd . fromMaybe emptyPeer) dgst $ dgsPeers s }+                    DiscoveryTunnel : _ -> do+                        discoverySetupTunnelResponse dgst -                | otherwise -> do-                    svcPrint $ "Discovery: invalid address in result: " ++ T.unpack addr+                    addr : rest -> do+                        svcPrint $ "Discovery: unsupported address in result: " ++ T.unpack (toText addr)+                        tryAddresses rest +                    [] -> svcPrint $ "Discovery: no (supported) address received for " <> show dgst++            tryAddresses addrs+         DiscoveryConnectionRequest conn -> do             self <- svcSelf+            attrs <- asks svcAttributes             let rconn = emptyConnection (dconnSource conn) (dconnTarget conn)-            if refDigest (dconnTarget conn) `elem` identityDigests self+            if either refDigest id (dconnTarget conn) `elem` identityDigests self               then if+                -- request for us, create ICE sesssion or tunnel+                | dconnTunnel conn -> do+                    receivedStreams >>= \case+                        (tunnelReader : _) -> do+                            tunnelWriter <- openStream+                            replyPacket $ DiscoveryConnectionResponse rconn+                                { dconnTunnel = True+                                }+                            tunnelVia <- asks svcPeer+                            tunnelIdentity <- asks svcPeerIdentity+                            server <- asks svcServer+                            void $ liftIO $ forkIO $ do+                                tunnelStreamNumber <- getStreamWriterNumber tunnelWriter+                                let addr = TunnelAddress {..}+                                void $ serverPeerCustom server addr+                                receiveFromTunnel server addr++                        [] -> do+                            svcPrint $ "Discovery: missing stream on tunnel request (endpoint)"+ #ifdef ENABLE_ICE_SUPPORT-                -- request for us, create ICE sesssion                 | Just prinfo <- dconnIceInfo conn -> do                     server <- asks svcServer                     peer <- asks svcPeer@@ -318,58 +405,123 @@                     svcPrint $ "Discovery: unsupported connection request"                else do-                    -- request to some of our peers, relay-                    mbdp <- M.lookup (refDigest $ dconnTarget conn) . dgsPeers <$> svcGetGlobal-                    case mbdp of+                -- request to some of our peers, relay+                peer <- asks svcPeer+                paddr <- asks svcPeerAddress+                mbdp <- M.lookup (either refDigest id $ dconnTarget conn) . dgsPeers <$> svcGetGlobal+                streams <- receivedStreams+                case mbdp of                         Nothing -> replyPacket $ DiscoveryConnectionResponse rconn                         Just dp-                            | Just dpeer <- dpPeer dp -> do-                                sendToPeer dpeer $ DiscoveryConnectionRequest conn+                            | Just dpeer <- dpPeer dp -> if+                                | dconnTunnel conn -> if+                                    | not (discoveryProvideTunnel attrs peer paddr) -> do+                                        replyPacket $ DiscoveryConnectionResponse rconn+                                    | fromSource : _ <- streams -> do+                                        void $ liftIO $ forkIO $ runPeerService @DiscoveryService dpeer $ do+                                            toTarget <- openStream+                                            svcModify $ \s -> s { dpsRelayedTunnelRequests =+                                                ( either refDigest id $ dconnSource conn, ( fromSource, toTarget )) : dpsRelayedTunnelRequests s }+                                            replyPacket $ DiscoveryConnectionRequest conn+                                    | otherwise -> do+                                        svcPrint $ "Discovery: missing stream on tunnel request (relay)"+                                | otherwise -> do+                                    sendToPeer dpeer $ DiscoveryConnectionRequest conn                             | otherwise -> svcPrint $ "Discovery: failed to relay connection request"          DiscoveryConnectionResponse conn -> do             self <- svcSelf+            dps <- svcGet             dpeers <- dgsPeers <$> svcGetGlobal-            if refDigest (dconnSource conn) `elem` identityDigests self-               then do++            if either refDigest id (dconnSource conn) `elem` identityDigests self+              then do                     -- response to our request, try to connect to the peer                     server <- asks svcServer-                    if  | Just addr <- dconnAddress conn-                        , [ipaddr, port] <- words (T.unpack addr) -> do-                            saddr <- liftIO $ head <$>-                                getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just ipaddr) (Just port)-                            peer <- liftIO $ serverPeer server (addrAddress saddr)+                    if+                        | Just addr <- dconnAddress conn+                        , [ addrStr, portStr ] <- words (T.unpack addr)+                        , Just ipaddr <- readMaybe addrStr+                        , Just port <- readMaybe portStr+                        -> do+                            let saddr = inetToSockAddr ( ipaddr, port )+                            peer <- liftIO $ serverPeer server saddr                             let upd dp = dp { dpPeer = Just peer }                             svcModifyGlobal $ \s -> s-                                { dgsPeers = M.alter (Just . upd . fromMaybe emptyPeer) (refDigest $ dconnTarget conn) $ dgsPeers s }+                                { dgsPeers = M.alter (Just . upd . fromMaybe emptyPeer) (either refDigest id $ dconnTarget conn) $ dgsPeers s } +                        | dconnTunnel conn+                        , Just tunnelWriter <- lookup (either refDigest id (dconnTarget conn)) (dpsOurTunnelRequests dps)+                        -> do+                            receivedStreams >>= \case+                                tunnelReader : _ -> do+                                    tunnelVia <- asks svcPeer+                                    tunnelIdentity <- asks svcPeerIdentity+                                    void $ liftIO $ forkIO $ do+                                        tunnelStreamNumber <- getStreamWriterNumber tunnelWriter+                                        let addr = TunnelAddress {..}+                                        void $ serverPeerCustom server addr+                                        receiveFromTunnel server addr+                                [] -> do+                                    svcPrint $ "Discovery: missing stream in tunnel response"+                                    liftIO $ closeStream tunnelWriter++                        | Just tunnelWriter <- lookup (either refDigest id (dconnTarget conn)) (dpsOurTunnelRequests dps)+                        -> do+                            svcPrint $ "Discovery: tunnel request failed"+                            liftIO $ closeStream tunnelWriter+ #ifdef ENABLE_ICE_SUPPORT-                        | Just dp <- M.lookup (refDigest $ dconnTarget conn) dpeers+                        | Just dp <- M.lookup (either refDigest id $ dconnTarget conn) dpeers                         , Just ice <- dpIceSession dp                         , Just rinfo <- dconnIceInfo conn -> do                             liftIO $ iceConnect ice rinfo $ void $ serverPeerIce server ice #endif                          | otherwise -> svcPrint $ "Discovery: connection request failed"-               else do-                    -- response to relayed request-                    case M.lookup (refDigest $ dconnSource conn) dpeers of-                        Just dp | Just dpeer <- dpPeer dp -> do+              else do+                -- response to relayed request+                streams <- receivedStreams+                svcModify $ \s -> s { dpsRelayedTunnelRequests =+                    filter ((either refDigest id (dconnSource conn) /=) . fst) (dpsRelayedTunnelRequests s) }++                case M.lookup (either refDigest id $ dconnSource conn) dpeers of+                    Just dp | Just dpeer <- dpPeer dp -> if+                        -- successful tunnel request+                        | dconnTunnel conn+                        , Just ( fromSource, toTarget ) <- lookup (either refDigest id (dconnSource conn)) (dpsRelayedTunnelRequests dps)+                        , fromTarget : _ <- streams+                        -> liftIO $ do+                            toSourceVar <- newEmptyMVar+                            void $ forkIO $ runPeerService @DiscoveryService dpeer $ do+                                liftIO . putMVar toSourceVar =<< openStream+                                svcModify $ \s -> s { dpsRelayedTunnelRequests =+                                    ( either refDigest id $ dconnSource conn, ( fromSource, toTarget )) : dpsRelayedTunnelRequests s }+                                replyPacket $ DiscoveryConnectionResponse conn+                            void $ forkIO $ do+                                relayStream fromSource toTarget+                            void $ forkIO $ do+                                toSource <- readMVar toSourceVar+                                relayStream fromTarget toSource++                        -- failed tunnel request+                        | Just ( _, toTarget ) <- lookup (either refDigest id (dconnSource conn)) (dpsRelayedTunnelRequests dps)+                        -> do+                            liftIO $ closeStream toTarget                             sendToPeer dpeer $ DiscoveryConnectionResponse conn-                        _ -> svcPrint $ "Discovery: failed to relay connection response" +                        | otherwise -> do+                            sendToPeer dpeer $ DiscoveryConnectionResponse conn+                    _ -> svcPrint $ "Discovery: failed to relay connection response"+     serviceNewPeer = do         server <- asks svcServer         peer <- asks svcPeer-        st <- getStorage -        let addrToText saddr = do-                ( addr, port ) <- IP.fromSockAddr saddr-                Just $ T.pack $ show addr <> " " <> show port         addrs <- concat <$> sequence-            [ catMaybes . map addrToText <$> liftIO (getServerAddresses server)+            [ catMaybes . map (fmap (uncurry DiscoveryIP) . inetFromSockAddr) <$> liftIO (getServerAddresses server) #ifdef ENABLE_ICE_SUPPORT-            , return [ T.pack "ICE" ]+            , return [ DiscoveryICE ] #endif             ] @@ -381,9 +533,7 @@         when (not $ null addrs) $ do             sendToPeer peer $ DiscoverySelf addrs Nothing         forM_ searchingFor $ \dgst -> do-            liftIO (refFromDigest st dgst) >>= \case-                Just ref -> sendToPeer peer $ DiscoverySearch ref-                Nothing -> return ()+            sendToPeer peer $ DiscoverySearch (Right dgst)  #ifdef ENABLE_ICE_SUPPORT     serviceStopServer _ _ _ pstates = do@@ -416,17 +566,84 @@ #endif  -discoverySearch :: (MonadIO m, MonadError String m) => Server -> Ref -> m ()-discoverySearch server ref = do+discoverySearch :: (MonadIO m, MonadError e m, FromErebosError e) => Server -> RefDigest -> m ()+discoverySearch server dgst = do     peers <- liftIO $ getCurrentPeerList server     match <- forM peers $ \peer -> do-        peerIdentity peer >>= \case+        getPeerIdentity peer >>= \case             PeerIdentityFull pid -> do-                return $ refDigest ref `elem` identityDigests pid+                return $ dgst `elem` identityDigests pid             _ -> return False     when (not $ or match) $ do         modifyServiceGlobalState server (Proxy @DiscoveryService) $ \s -> (, ()) s-            { dgsSearchingFor = S.insert (refDigest ref) $ dgsSearchingFor s+            { dgsSearchingFor = S.insert dgst $ dgsSearchingFor s             }         forM_ peers $ \peer -> do-            sendToPeer peer $ DiscoverySearch ref+            sendToPeer peer $ DiscoverySearch $ Right dgst+++data TunnelAddress = TunnelAddress+    { tunnelVia :: Peer+    , tunnelIdentity :: UnifiedIdentity+    , tunnelStreamNumber :: Int+    , tunnelReader :: StreamReader+    , tunnelWriter :: StreamWriter+    }++instance Eq TunnelAddress where+    x == y  =  (==)+        (idData (tunnelIdentity x), tunnelStreamNumber x)+        (idData (tunnelIdentity y), tunnelStreamNumber y)++instance Ord TunnelAddress where+    compare x y = compare+        (idData (tunnelIdentity x), tunnelStreamNumber x)+        (idData (tunnelIdentity y), tunnelStreamNumber y)++instance Show TunnelAddress where+    show tunnel = concat+        [ "tunnel@"+        , show $ refDigest $ storedRef $ idData $ tunnelIdentity tunnel+        , "/" <> show (tunnelStreamNumber tunnel)+        ]++instance PeerAddressType TunnelAddress where+    sendBytesToAddress TunnelAddress {..} bytes = do+        writeStream tunnelWriter bytes++    connectionToAddressClosed TunnelAddress {..} = do+        closeStream tunnelWriter++relayStream :: StreamReader -> StreamWriter -> IO ()+relayStream r w = do+    p <- readStreamPacket r+    writeStreamPacket w p+    case p of+        StreamClosed {} -> return ()+        _ -> relayStream r w++receiveFromTunnel :: Server -> TunnelAddress -> IO ()+receiveFromTunnel server taddr = do+    p <- readStreamPacket (tunnelReader taddr)+    case p of+        StreamData {..} -> do+            receivedFromCustomAddress server taddr stpData+            receiveFromTunnel server taddr+        StreamClosed {} -> do+            return ()+++discoverySetupTunnel :: Peer -> RefDigest -> IO ()+discoverySetupTunnel via target = do+    runPeerService via $ do+        discoverySetupTunnelResponse target++discoverySetupTunnelResponse :: RefDigest -> ServiceHandler DiscoveryService ()+discoverySetupTunnelResponse target = do+        self <- refDigest . storedRef . idData <$> svcSelf+        stream <- openStream+        svcModify $ \s -> s { dpsOurTunnelRequests = ( target, stream ) : dpsOurTunnelRequests s }+        replyPacket $ DiscoveryConnectionRequest+            (emptyConnection (Right self) (Right target))+            { dconnTunnel = True+            }

@@ -0,0 +1,39 @@+module Erebos.Error (+    ErebosError(..),+    showErebosError,++    FromErebosError(..),+    throwOtherError,+) where++import Control.Monad.Except+++data ErebosError+    = ManyErrors [ ErebosError ]+    | OtherError String++showErebosError :: ErebosError -> String+showErebosError (ManyErrors errs) = unlines $ map showErebosError errs+showErebosError (OtherError str) = str++instance Semigroup ErebosError where+    ManyErrors [] <> b = b+    a <> ManyErrors [] = a+    ManyErrors a <> ManyErrors b = ManyErrors (a ++ b)+    ManyErrors a <> b = ManyErrors (a ++ [ b ])+    a <> ManyErrors b = ManyErrors (a : b)+    a@OtherError {} <> b@OtherError {} = ManyErrors [ a, b ]++instance Monoid ErebosError where+    mempty = ManyErrors []+++class FromErebosError e where+    fromErebosError :: ErebosError -> e++instance FromErebosError ErebosError where+    fromErebosError = id++throwOtherError :: (MonadError e m, FromErebosError e) => String -> m a+throwOtherError = throwError . fromErebosError . OtherError

@@ -16,13 +16,12 @@     iceConnect,     iceSend, -    iceSetChan,+    serverPeerIce, ) where  import Control.Arrow import Control.Concurrent import Control.Monad-import Control.Monad.Except import Control.Monad.Identity  import Data.ByteString (ByteString, packCStringLen, useAsCString)@@ -33,7 +32,6 @@ import Data.Text qualified as T import Data.Text.Encoding qualified as T import Data.Text.Read qualified as T-import Data.Void import Data.Word  import Foreign.C.String@@ -44,7 +42,9 @@ import Foreign.Ptr import Foreign.StablePtr -import Erebos.Flow+import Erebos.Network+import Erebos.Object+import Erebos.Storable import Erebos.Storage  #include "pjproject.h"@@ -52,7 +52,7 @@ data IceSession = IceSession     { isStrans :: PjIceStrans     , _isConfig :: IceConfig-    , isChan :: MVar (Either [ByteString] (Flow Void ByteString))+    , isChan :: MVar (Either [ ByteString ] (ByteString -> IO ()))     }  instance Eq IceSession where@@ -64,7 +64,11 @@ instance Show IceSession where     show _ = "<ICE>" +instance PeerAddressType IceSession where+    sendBytesToAddress = iceSend+    connectionToAddressClosed = iceDestroy + data IceRemoteInfo = IceRemoteInfo     { iriUsernameFrament :: Text     , iriPassword :: Text@@ -117,7 +121,7 @@                 , icandPort = port                 , icandType = ctype                 }-        _ -> throwError "failed to parse candidate"+        _ -> throwOtherError "failed to parse candidate"   {#enum pj_ice_sess_role as IceSessionRole {underscoreToCase} deriving (Show, Eq) #}@@ -125,9 +129,9 @@ data PjIceStransCfg newtype IceConfig = IceConfig (ForeignPtr PjIceStransCfg) -foreign import ccall unsafe "pjproject.h &ice_cfg_free"+foreign import ccall unsafe "pjproject.h &erebos_ice_cfg_free"     ice_cfg_free :: FunPtr (Ptr PjIceStransCfg -> IO ())-foreign import ccall unsafe "pjproject.h ice_cfg_create"+foreign import ccall unsafe "pjproject.h erebos_ice_cfg_create"     ice_cfg_create :: CString -> Word16 -> CString -> Word16 -> IO (Ptr PjIceStransCfg)  iceCreateConfig :: Maybe ( Text, Word16 ) -> Maybe ( Text, Word16 ) -> IO (Maybe IceConfig)@@ -139,7 +143,7 @@           then return Nothing           else Just . IceConfig <$> newForeignPtr ice_cfg_free cfg -foreign import ccall unsafe "pjproject.h ice_cfg_stop_thread"+foreign import ccall unsafe "pjproject.h erebos_ice_cfg_stop_thread"     ice_cfg_stop_thread :: Ptr PjIceStransCfg -> IO ()  iceStopThread :: IceConfig -> IO ()@@ -157,13 +161,13 @@             forkIO $ cb sess         sess <- IceSession             <$> (withForeignPtr fcfg $ \cfg ->-                    {#call ice_create #} (castPtr cfg) (fromIntegral $ fromEnum role) (castStablePtrToPtr sptr) (castStablePtrToPtr cbptr)+                    {#call erebos_ice_create #} (castPtr cfg) (fromIntegral $ fromEnum role) (castStablePtrToPtr sptr) (castStablePtrToPtr cbptr)                 )             <*> pure icfg             <*> (newMVar $ Left [])     return $ sess -{#fun ice_destroy as ^ { isStrans `IceSession' } -> `()' #}+{#fun erebos_ice_destroy as iceDestroy { isStrans `IceSession' } -> `()' #}  iceRemoteInfo :: IceSession -> IO IceRemoteInfo iceRemoteInfo sess = do@@ -178,7 +182,7 @@         let cptrs = take maxcand $ iterate (`plusPtr` maxlen) bytes         pokeArray carr $ take maxcand cptrs -        ncand <- {#call ice_encode_session #} (isStrans sess) ufrag pass def carr (fromIntegral maxlen) (fromIntegral maxcand)+        ncand <- {#call erebos_ice_encode_session #} (isStrans sess) ufrag pass def carr (fromIntegral maxlen) (fromIntegral maxcand)         if ncand < 0 then fail "failed to generate ICE remote info"                      else IceRemoteInfo                               <$> (T.pack <$> peekCString ufrag)@@ -195,13 +199,13 @@ iceConnect :: IceSession -> IceRemoteInfo -> (IO ()) -> IO () iceConnect sess remote cb = do     cbptr <- newStablePtr $ cb-    ice_connect sess cbptr+    erebos_ice_connect sess cbptr         (iriUsernameFrament remote)         (iriPassword remote)         (iriDefaultCandidate remote)         (iriCandidates remote) -{#fun ice_connect { isStrans `IceSession', castStablePtrToPtr `StablePtr (IO ())',+{#fun erebos_ice_connect { isStrans `IceSession', castStablePtrToPtr `StablePtr (IO ())',     withText* `Text',  withText* `Text', withText* `Text', withTextArray* `[Text]'& } -> `()' #}  withText :: Text -> (Ptr CChar -> IO a) -> IO a@@ -217,19 +221,19 @@ withByteStringLen :: Num n => ByteString -> ((Ptr CChar, n) -> IO a) -> IO a withByteStringLen t f = unsafeUseAsCStringLen t (f . (id *** fromIntegral)) -{#fun ice_send as ^ { isStrans `IceSession', withByteStringLen* `ByteString'& } -> `()' #}+{#fun erebos_ice_send as iceSend { isStrans `IceSession', withByteStringLen* `ByteString'& } -> `()' #}  foreign export ccall ice_call_cb :: StablePtr (IO ()) -> IO () ice_call_cb :: StablePtr (IO ()) -> IO () ice_call_cb = join . deRefStablePtr -iceSetChan :: IceSession -> Flow Void ByteString -> IO ()-iceSetChan sess chan = do+iceSetServer :: IceSession -> Server -> IO ()+iceSetServer sess server = do     modifyMVar_ (isChan sess) $ \orig -> do         case orig of-             Left buf -> mapM_ (writeFlowIO chan) $ reverse buf+             Left buf -> mapM_ (receivedFromCustomAddress server sess) $ reverse buf              Right _ -> return ()-        return $ Right chan+        return $ Right $ receivedFromCustomAddress server sess  foreign export ccall ice_rx_data :: StablePtr IceSession -> Ptr CChar -> Int -> IO () ice_rx_data :: StablePtr IceSession -> Ptr CChar -> Int -> IO ()@@ -237,5 +241,12 @@     sess <- deRefStablePtr sptr     bs <- packCStringLen (buf, len)     modifyMVar_ (isChan sess) $ \case-            mc@(Right chan) -> writeFlowIO chan bs >> return mc-            Left bss -> return $ Left (bs:bss)+        mc@(Right sendToServer) -> sendToServer bs >> return mc+        Left bss -> return $ Left (bs : bss)+++serverPeerIce :: Server -> IceSession -> IO Peer+serverPeerIce server ice = do+    peer <- serverPeerCustom server ice+    iceSetServer ice server+    return peer

@@ -78,7 +78,7 @@ { 	if (status != PJ_SUCCESS) { 		ice_perror("cb_on_ice_complete", status);-		ice_destroy(strans);+		erebos_ice_destroy(strans); 		return; 	} @@ -139,7 +139,7 @@ 	pthread_mutex_unlock(&mutex); } -struct erebos_ice_cfg * ice_cfg_create( const char * stun_server, uint16_t stun_port,+struct erebos_ice_cfg * erebos_ice_cfg_create( const char * stun_server, uint16_t stun_port, 		const char * turn_server, uint16_t turn_port ) { 	ice_init();@@ -189,11 +189,11 @@  	return ecfg; fail:-	ice_cfg_free( ecfg );+	erebos_ice_cfg_free( ecfg ); 	return NULL; } -void ice_cfg_free( struct erebos_ice_cfg * ecfg )+void erebos_ice_cfg_free( struct erebos_ice_cfg * ecfg ) { 	if( ! ecfg ) 		return;@@ -216,14 +216,14 @@ 	free( ecfg ); } -void ice_cfg_stop_thread( struct erebos_ice_cfg * ecfg )+void erebos_ice_cfg_stop_thread( struct erebos_ice_cfg * ecfg ) { 	if( ! ecfg ) 		return; 	ecfg->exit = true; } -pj_ice_strans * ice_create( const struct erebos_ice_cfg * ecfg, pj_ice_sess_role role,+pj_ice_strans * erebos_ice_create( const struct erebos_ice_cfg * ecfg, pj_ice_sess_role role, 		HsStablePtr sptr, HsStablePtr cb ) { 	ice_init();@@ -249,7 +249,7 @@ 	return res; } -void ice_destroy(pj_ice_strans * strans)+void erebos_ice_destroy(pj_ice_strans * strans) { 	struct user_data * udata = pj_ice_strans_get_user_data(strans); 	if (udata->sptr)@@ -264,7 +264,7 @@ 	pj_ice_strans_destroy(strans); } -ssize_t ice_encode_session(pj_ice_strans * strans, char * ufrag, char * pass,+ssize_t erebos_ice_encode_session(pj_ice_strans * strans, char * ufrag, char * pass, 		char * def, char * candidates[], size_t maxlen, size_t maxcand) { 	int n;@@ -318,7 +318,7 @@ 	return cand_cnt; } -void ice_connect(pj_ice_strans * strans, HsStablePtr cb,+void erebos_ice_connect(pj_ice_strans * strans, HsStablePtr cb, 		const char * ufrag, const char * pass, 		const char * defcand, const char * tcandidates[], size_t ncand) {@@ -409,7 +409,7 @@ 	} } -void ice_send(pj_ice_strans * strans, const char * data, size_t len)+void erebos_ice_send(pj_ice_strans * strans, const char * data, size_t len) { 	if (!pj_ice_strans_sess_is_complete(strans)) { 		fprintf(stderr, "ICE: negotiation has not been started or is in progress\n");

@@ -3,18 +3,18 @@ #include <pjnath.h> #include <HsFFI.h> -struct erebos_ice_cfg * ice_cfg_create( const char * stun_server, uint16_t stun_port,+struct erebos_ice_cfg * erebos_ice_cfg_create( const char * stun_server, uint16_t stun_port, 		const char * turn_server, uint16_t turn_port );-void ice_cfg_free( struct erebos_ice_cfg * cfg );-void ice_cfg_stop_thread( struct erebos_ice_cfg * cfg );+void erebos_ice_cfg_free( struct erebos_ice_cfg * cfg );+void erebos_ice_cfg_stop_thread( struct erebos_ice_cfg * cfg ); -pj_ice_strans * ice_create( const struct erebos_ice_cfg *, pj_ice_sess_role role,+pj_ice_strans * erebos_ice_create( const struct erebos_ice_cfg *, pj_ice_sess_role role, 		HsStablePtr sptr, HsStablePtr cb );-void ice_destroy(pj_ice_strans * strans);+void erebos_ice_destroy(pj_ice_strans * strans); -ssize_t ice_encode_session(pj_ice_strans *, char * ufrag, char * pass,+ssize_t erebos_ice_encode_session(pj_ice_strans *, char * ufrag, char * pass, 		char * def, char * candidates[], size_t maxlen, size_t maxcand);-void ice_connect(pj_ice_strans * strans, HsStablePtr cb,+void erebos_ice_connect(pj_ice_strans * strans, HsStablePtr cb, 		const char * ufrag, const char * pass, 		const char * defcand, const char * candidates[], size_t ncand);-void ice_send(pj_ice_strans *, const char * data, size_t len);+void erebos_ice_send(pj_ice_strans *, const char * data, size_t len);

@@ -41,7 +41,7 @@ import qualified Data.Text as T  import Erebos.PubKey-import Erebos.Storage+import Erebos.Storable import Erebos.Storage.Merge import Erebos.Util @@ -214,29 +214,33 @@                                      _ -> True  -createIdentity :: Storage -> Maybe Text -> Maybe UnifiedIdentity -> IO UnifiedIdentity-createIdentity st name owner = do-    (secret, public) <- generateKeys st-    (_secretMsg, publicMsg) <- generateKeys st+createIdentity+    :: forall m e. (MonadStorage m, MonadError e m, FromErebosError e, MonadIO m)+    => Maybe Text -> Maybe UnifiedIdentity -> m UnifiedIdentity+createIdentity name owner = do+    st <- getStorage+    ( secret, public ) <- liftIO $ generateKeys st+    ( _secretMsg, publicMsg ) <- liftIO $ generateKeys st -    let signOwner :: Signed a -> ReaderT Storage IO (Signed a)+    let signOwner :: Signed a -> m (Signed a)         signOwner idd             | Just o <- owner = do-                Just ownerSecret <- loadKeyMb (iddKeyIdentity $ fromSigned $ idData o)+                ownerSecret <- maybe (throwOtherError "failed to load private key") return =<<+                    loadKeyMb (iddKeyIdentity $ fromSigned $ idData o)                 signAdd ownerSecret idd             | otherwise = return idd -    Just identity <- flip runReaderT st $ do-        baseData <- mstore =<< signOwner =<< sign secret =<<-            mstore (emptyIdentityData public)-                { iddOwner = idData <$> owner-                , iddKeyMessage = Just publicMsg-                }-        let extOwner = do-                odata <- idExtData <$> owner-                guard $ isExtension odata-                return odata+    baseData <- mstore =<< signOwner =<< sign secret =<<+        mstore (emptyIdentityData public)+            { iddOwner = idData <$> owner+            , iddKeyMessage = Just publicMsg+            }+    let extOwner = do+            odata <- idExtData <$> owner+            guard $ isExtension odata+            return odata +    maybe (throwOtherError "created invalid identity") return =<< do         validateExtendedIdentityF . I.Identity <$>             if isJust name || isJust extOwner                then mstore =<< signOwner =<< sign secret =<<@@ -245,7 +249,6 @@                        , ideOwner = extOwner                        }                else return $ baseToExtended baseData-    return identity  validateIdentity :: Stored (Signed IdentityData) -> Maybe UnifiedIdentity validateIdentity = validateIdentityF . I.Identity@@ -280,13 +283,13 @@                  Just mk -> return mk  loadIdentity :: String -> LoadRec ComposedIdentity-loadIdentity name = maybe (throwError "identity validation failed") return . validateExtendedIdentityF =<< loadRefs name+loadIdentity name = maybe (throwOtherError "identity validation failed") return . validateExtendedIdentityF =<< loadRefs name  loadMbIdentity :: String -> LoadRec (Maybe ComposedIdentity) loadMbIdentity name = return . validateExtendedIdentityF =<< loadRefs name  loadUnifiedIdentity :: String -> LoadRec UnifiedIdentity-loadUnifiedIdentity name = maybe (throwError "identity validation failed") return . validateExtendedIdentity =<< loadRef name+loadUnifiedIdentity name = maybe (throwOtherError "identity validation failed") return . validateExtendedIdentity =<< loadRef name  loadMbUnifiedIdentity :: String -> LoadRec (Maybe UnifiedIdentity) loadMbUnifiedIdentity name = return . (validateExtendedIdentity =<<) =<< loadMbRef name@@ -322,7 +325,7 @@     findResult [] = Nothing     findResult xs = sel $ fromSigned $ minimum xs -mergeIdentity :: (MonadStorage m, MonadError String m, MonadIO m) => Identity f -> m UnifiedIdentity+mergeIdentity :: (MonadStorage m, MonadError e m, FromErebosError e, MonadIO m) => Identity f -> m UnifiedIdentity mergeIdentity idt | Just idt' <- toUnifiedIdentity idt = return idt' mergeIdentity idt@Identity {..} = do     (owner, ownerData) <- case idOwner_ of

@@ -1,283 +0,0 @@-module Erebos.Message (-    DirectMessage(..),-    sendDirectMessage,--    DirectMessageAttributes(..),-    defaultDirectMessageAttributes,--    DirectMessageThreads,-    toThreadList,--    DirectMessageThread(..),-    threadToList,-    messageThreadView,--    watchReceivedMessages,-    formatMessage,-    formatDirectMessage,-) where--import Control.Monad-import Control.Monad.Except-import Control.Monad.Reader--import Data.List-import Data.Ord-import qualified Data.Set as S-import Data.Text (Text)-import qualified Data.Text as T-import Data.Time.Format-import Data.Time.LocalTime--import Erebos.Discovery-import Erebos.Identity-import Erebos.Network-import Erebos.Service-import Erebos.State-import Erebos.Storage-import Erebos.Storage.Merge--data DirectMessage = DirectMessage-    { msgFrom :: ComposedIdentity-    , msgPrev :: [Stored DirectMessage]-    , msgTime :: ZonedTime-    , msgText :: Text-    }--instance Storable DirectMessage where-    store' msg = storeRec $ do-        mapM_ (storeRef "from") $ idExtDataF $ msgFrom msg-        mapM_ (storeRef "PREV") $ msgPrev msg-        storeDate "time" $ msgTime msg-        storeText "text" $ msgText msg--    load' = loadRec $ DirectMessage-        <$> loadIdentity "from"-        <*> loadRefs "PREV"-        <*> loadDate "time"-        <*> loadText "text"--data DirectMessageAttributes = DirectMessageAttributes-    { dmOwnerMismatch :: ServiceHandler DirectMessage ()-    }--defaultDirectMessageAttributes :: DirectMessageAttributes-defaultDirectMessageAttributes = DirectMessageAttributes-    { dmOwnerMismatch = svcPrint "Owner mismatch"-    }--instance Service DirectMessage where-    serviceID _ = mkServiceID "c702076c-4928-4415-8b6b-3e839eafcb0d"--    type ServiceAttributes DirectMessage = DirectMessageAttributes-    defaultServiceAttributes _ = defaultDirectMessageAttributes--    serviceHandler smsg = do-        let msg = fromStored smsg-        powner <- asks $ finalOwner . svcPeerIdentity-        erb <- svcGetLocal-        st <- getStorage-        let DirectMessageThreads prev _ = lookupSharedValue $ lsShared $ fromStored erb-            sent = findMsgProperty powner msSent prev-            received = findMsgProperty powner msReceived prev-            received' = filterAncestors $ smsg : received-        if powner `sameIdentity` msgFrom msg ||-               filterAncestors sent == filterAncestors (smsg : sent)-           then do-               when (received' /= received) $ do-                   next <- wrappedStore st $ MessageState-                       { msPrev = prev-                       , msPeer = powner-                       , msReady = []-                       , msSent = []-                       , msReceived = received'-                       , msSeen = []-                       }-                   let threads = DirectMessageThreads [next] (messageThreadView [next])-                   shared <- makeSharedStateUpdate st threads (lsShared $ fromStored erb)-                   svcSetLocal =<< wrappedStore st (fromStored erb) { lsShared = [shared] }--               when (powner `sameIdentity` msgFrom msg) $ do-                   replyStoredRef smsg--           else join $ asks $ dmOwnerMismatch . svcAttributes--    serviceNewPeer = syncDirectMessageToPeer . lookupSharedValue . lsShared . fromStored =<< svcGetLocal--    serviceStorageWatchers _ =-        [ SomeStorageWatcher (lookupSharedValue . lsShared . fromStored) syncDirectMessageToPeer-        , GlobalStorageWatcher (lookupSharedValue . lsShared . fromStored) findMissingPeers-        ]---data MessageState = MessageState-    { msPrev :: [Stored MessageState]-    , msPeer :: ComposedIdentity-    , msReady :: [Stored DirectMessage]-    , msSent :: [Stored DirectMessage]-    , msReceived :: [Stored DirectMessage]-    , msSeen :: [Stored DirectMessage]-    }--data DirectMessageThreads = DirectMessageThreads [Stored MessageState] [DirectMessageThread]--instance Eq DirectMessageThreads where-    DirectMessageThreads mss _ == DirectMessageThreads mss' _ = mss == mss'--toThreadList :: DirectMessageThreads -> [DirectMessageThread]-toThreadList (DirectMessageThreads _ threads) = threads--instance Storable MessageState where-    store' MessageState {..} = storeRec $ do-        mapM_ (storeRef "PREV") msPrev-        mapM_ (storeRef "peer") $ idExtDataF msPeer-        mapM_ (storeRef "ready") msReady-        mapM_ (storeRef "sent") msSent-        mapM_ (storeRef "received") msReceived-        mapM_ (storeRef "seen") msSeen--    load' = loadRec $ do-        msPrev <- loadRefs "PREV"-        msPeer <- loadIdentity "peer"-        msReady <- loadRefs "ready"-        msSent <- loadRefs "sent"-        msReceived <- loadRefs "received"-        msSeen <- loadRefs "seen"-        return MessageState {..}--instance Mergeable DirectMessageThreads where-    type Component DirectMessageThreads = MessageState-    mergeSorted mss = DirectMessageThreads mss (messageThreadView mss)-    toComponents (DirectMessageThreads mss _) = mss--instance SharedType DirectMessageThreads where-    sharedTypeID _ = mkSharedTypeID "ee793681-5976-466a-b0f0-4e1907d3fade"--findMsgProperty :: Foldable m => Identity m -> (MessageState -> [a]) -> [Stored MessageState] -> [a]-findMsgProperty pid sel mss = concat $ flip findProperty mss $ \x -> do-    guard $ msPeer x `sameIdentity` pid-    guard $ not $ null $ sel x-    return $ sel x---sendDirectMessage :: (Foldable f, Applicative f, MonadHead LocalState m, MonadError String m)-                  => Identity f -> Text -> m (Stored DirectMessage)-sendDirectMessage pid text = updateLocalHead $ \ls -> do-    let self = localIdentity $ fromStored ls-        powner = finalOwner pid-    flip updateSharedState ls $ \(DirectMessageThreads prev _) -> do-        let ready = findMsgProperty powner msReady prev-            received = findMsgProperty powner msReceived prev--        time <- liftIO getZonedTime-        smsg <- mstore DirectMessage-            { msgFrom = toComposedIdentity $ finalOwner self-            , msgPrev = filterAncestors $ ready ++ received-            , msgTime = time-            , msgText = text-            }-        next <- mstore MessageState-            { msPrev = prev-            , msPeer = powner-            , msReady = [smsg]-            , msSent = []-            , msReceived = []-            , msSeen = []-            }-        return (DirectMessageThreads [next] (messageThreadView [next]), smsg)--syncDirectMessageToPeer :: DirectMessageThreads -> ServiceHandler DirectMessage ()-syncDirectMessageToPeer (DirectMessageThreads mss _) = do-    pid <- finalOwner <$> asks svcPeerIdentity-    peer <- asks svcPeer-    let thread = messageThreadFor pid mss-    mapM_ (sendToPeerStored peer) $ msgHead thread-    updateLocalHead_ $ \ls -> do-        let powner = finalOwner pid-        flip updateSharedState_ ls $ \unchanged@(DirectMessageThreads prev _) -> do-            let ready = findMsgProperty powner msReady prev-                sent = findMsgProperty powner msSent prev-                sent' = filterAncestors (ready ++ sent)--            if sent' /= sent-              then do-                next <- mstore MessageState-                    { msPrev = prev-                    , msPeer = powner-                    , msReady = []-                    , msSent = sent'-                    , msReceived = []-                    , msSeen = []-                    }-                return $ DirectMessageThreads [next] (messageThreadView [next])-              else do-                return unchanged--findMissingPeers :: Server -> DirectMessageThreads -> ExceptT String IO ()-findMissingPeers server threads = do-    forM_ (toThreadList threads) $ \thread -> do-        when (msgHead thread /= msgReceived thread) $ do-            mapM_ (discoverySearch server) $ map storedRef $ idDataF $ msgPeer thread---data DirectMessageThread = DirectMessageThread-    { msgPeer :: ComposedIdentity-    , msgHead :: [ Stored DirectMessage ]-    , msgSent :: [ Stored DirectMessage ]-    , msgSeen :: [ Stored DirectMessage ]-    , msgReceived :: [ Stored DirectMessage ]-    }--threadToList :: DirectMessageThread -> [DirectMessage]-threadToList thread = helper S.empty $ msgHead thread-    where helper seen msgs-              | msg : msgs' <- filter (`S.notMember` seen) $ reverse $ sortBy (comparing cmpView) msgs =-                  fromStored msg : helper (S.insert msg seen) (msgs' ++ msgPrev (fromStored msg))-              | otherwise = []-          cmpView msg = (zonedTimeToUTC $ msgTime $ fromStored msg, msg)--messageThreadView :: [Stored MessageState] -> [DirectMessageThread]-messageThreadView = helper []-    where helper used ms' = case filterAncestors ms' of-              mss@(sms : rest)-                  | any (sameIdentity $ msPeer $ fromStored sms) used ->-                      helper used $ msPrev (fromStored sms) ++ rest-                  | otherwise ->-                      let peer = msPeer $ fromStored sms-                       in messageThreadFor peer mss : helper (peer : used) (msPrev (fromStored sms) ++ rest)-              _ -> []--messageThreadFor :: ComposedIdentity -> [Stored MessageState] -> DirectMessageThread-messageThreadFor peer mss =-    let ready = findMsgProperty peer msReady mss-        sent = findMsgProperty peer msSent mss-        received = findMsgProperty peer msReceived mss-        seen = findMsgProperty peer msSeen mss--     in DirectMessageThread-         { msgPeer = peer-         , msgHead = filterAncestors $ ready ++ received-         , msgSent = filterAncestors $ sent ++ received-         , msgSeen = filterAncestors $ ready ++ seen-         , msgReceived = filterAncestors $ received-         }---watchReceivedMessages :: Head LocalState -> (Stored DirectMessage -> IO ()) -> IO WatchedHead-watchReceivedMessages h f = do-    let self = finalOwner $ localIdentity $ headObject h-    watchHeadWith h (lookupSharedValue . lsShared . headObject) $ \(DirectMessageThreads sms _) -> do-        forM_ (map fromStored sms) $ \ms -> do-            mapM_ f $ filter (not . sameIdentity self . msgFrom . fromStored) $ msReceived ms--{-# DEPRECATED formatMessage "use formatDirectMessage instead" #-}-formatMessage :: TimeZone -> DirectMessage -> String-formatMessage = formatDirectMessage--formatDirectMessage :: TimeZone -> DirectMessage -> String-formatDirectMessage tzone msg = concat-    [ formatTime defaultTimeLocale "[%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ msgTime msg-    , maybe "<unnamed>" T.unpack $ idName $ msgFrom msg-    , ": "-    , T.unpack $ msgText msg-    ]

@@ -1,5 +1,3 @@-{-# LANGUAGE CPP #-}- module Erebos.Network (     Server,     startServer,@@ -10,14 +8,17 @@     ServerOptions(..), serverIdentity, defaultServerOptions,      Peer, peerServer, peerStorage,-    PeerAddress(..), peerAddress,-    PeerIdentity(..), peerIdentity,+    PeerAddress(..), getPeerAddress, getPeerAddresses,+    PeerIdentity(..), getPeerIdentity,     WaitingRef, wrDigest,     Service(..),++    PeerAddressType(..),+    receivedFromCustomAddress,+     serverPeer,-#ifdef ENABLE_ICE_SUPPORT-    serverPeerIce,-#endif+    serverPeerCustom,+    findPeer,     dropPeer,     isPeerDropped,     sendToPeer, sendManyToPeer,@@ -37,13 +38,14 @@ import Control.Monad.Reader import Control.Monad.State +import Data.ByteString (ByteString) import Data.ByteString.Char8 qualified as BC import Data.ByteString.Lazy qualified as BL import Data.Function import Data.IP qualified as IP import Data.List import Data.Map (Map)-import qualified Data.Map as M+import Data.Map qualified as M import Data.Maybe import Data.Typeable import Data.Word@@ -57,14 +59,14 @@ import GHC.Conc.Sync (unsafeIOToSTM)  import Network.Socket hiding (ControlMessage)-import qualified Network.Socket.ByteString as S+import Network.Socket.ByteString qualified as S -import Erebos.Channel-#ifdef ENABLE_ICE_SUPPORT-import Erebos.ICE-#endif+import Erebos.Error import Erebos.Identity+import Erebos.Network.Address+import Erebos.Network.Channel import Erebos.Network.Protocol+import Erebos.Object.Internal import Erebos.PubKey import Erebos.Service import Erebos.State@@ -93,7 +95,7 @@     , serverRawPath :: SymFlow (PeerAddress, BC.ByteString)     , serverControlFlow :: Flow (ControlMessage PeerAddress) (ControlRequest PeerAddress)     , serverDataResponse :: TQueue (Peer, Maybe PartialRef)-    , serverIOActions :: TQueue (ExceptT String IO ())+    , serverIOActions :: TQueue (ExceptT ErebosError IO ())     , serverServices :: [SomeService]     , serverServiceStates :: TMVar (M.Map ServiceID SomeServiceGlobalState)     , serverPeers :: MVar (Map PeerAddress Peer)@@ -113,12 +115,16 @@ data ServerOptions = ServerOptions     { serverPort :: PortNumber     , serverLocalDiscovery :: Bool+    , serverErrorPrefix :: String+    , serverTestLog :: Bool     }  defaultServerOptions :: ServerOptions defaultServerOptions = ServerOptions     { serverPort = discoveryPort     , serverLocalDiscovery = True+    , serverErrorPrefix = ""+    , serverTestLog = False     }  @@ -133,6 +139,14 @@     , peerWaitingRefs :: TMVar [WaitingRef]     } +-- | Get current main address of the peer (used to send new packets).+getPeerAddress :: MonadIO m => Peer -> m PeerAddress+getPeerAddress = liftIO . return . peerAddress++-- | Get all known addresses of given peer.+getPeerAddresses :: MonadIO m => Peer -> m [ PeerAddress ]+getPeerAddresses = fmap (: []) . getPeerAddress+ peerServer :: Peer -> Server peerServer = peerServer_ @@ -156,50 +170,52 @@ instance Eq Peer where     (==) = (==) `on` peerIdentityVar -data PeerAddress = DatagramAddress SockAddr-#ifdef ENABLE_ICE_SUPPORT-                 | PeerIceSession IceSession-#endif+class (Eq addr, Ord addr, Show addr, Typeable addr) => PeerAddressType addr where+    sendBytesToAddress :: addr -> ByteString -> IO ()+    connectionToAddressClosed :: addr -> IO () +data PeerAddress+    = forall addr. PeerAddressType addr => CustomPeerAddress addr+    | DatagramAddress SockAddr+ instance Show PeerAddress where-    show (DatagramAddress saddr) = unwords $ case IP.fromSockAddr saddr of-        Just (IP.IPv6 ipv6, port)-            | (0, 0, 0xffff, ipv4) <- IP.fromIPv6w ipv6-            -> [show (IP.toIPv4w ipv4), show port]-        Just (addr, port)-            -> [show addr, show port]-        _ -> [show saddr]-#ifdef ENABLE_ICE_SUPPORT-    show (PeerIceSession ice) = show ice-#endif+    show (CustomPeerAddress addr) = show addr +    show (DatagramAddress saddr) =+        case inetFromSockAddr saddr of+            Just ( addr, port ) -> unwords [ show addr, show port ]+            _ -> show saddr+ instance Eq PeerAddress where+    CustomPeerAddress addr == CustomPeerAddress addr'+        | Just addr'' <- cast addr' = addr == addr''     DatagramAddress addr == DatagramAddress addr' = addr == addr'-#ifdef ENABLE_ICE_SUPPORT-    PeerIceSession ice   == PeerIceSession ice'   = ice == ice'     _                    == _                     = False-#endif  instance Ord PeerAddress where+    compare (CustomPeerAddress addr) (CustomPeerAddress addr')+        | Just addr'' <- cast addr' = compare addr addr''+        | otherwise = compare (typeOf addr) (typeOf addr')+    compare (CustomPeerAddress _   ) _                         = LT+    compare _                        (CustomPeerAddress _    ) = GT+     compare (DatagramAddress addr) (DatagramAddress addr') = compare addr addr'-#ifdef ENABLE_ICE_SUPPORT-    compare (DatagramAddress _   ) _                       = LT-    compare _                      (DatagramAddress _    ) = GT-    compare (PeerIceSession ice  ) (PeerIceSession ice')   = compare ice ice'-#endif  -data PeerIdentity = PeerIdentityUnknown (TVar [UnifiedIdentity -> ExceptT String IO ()])-                  | PeerIdentityRef WaitingRef (TVar [UnifiedIdentity -> ExceptT String IO ()])-                  | PeerIdentityFull UnifiedIdentity+data PeerIdentity+    = PeerIdentityUnknown (TVar [ UnifiedIdentity -> ExceptT ErebosError IO () ])+    | PeerIdentityRef WaitingRef (TVar [ UnifiedIdentity -> ExceptT ErebosError IO () ])+    | PeerIdentityFull UnifiedIdentity -peerIdentity :: MonadIO m => Peer -> m PeerIdentity-peerIdentity = liftIO . atomically . readTVar . peerIdentityVar+-- | Get currently known identity of the given peer+getPeerIdentity :: MonadIO m => Peer -> m PeerIdentity+getPeerIdentity = liftIO . atomically . readTVar . peerIdentityVar  -data PeerState = PeerInit [(SecurityRequirement, TransportPacket Ref, [TransportHeaderItem])]-               | PeerConnected (Connection PeerAddress)-               | PeerDropped+data PeerState+    = PeerInit [ ( SecurityRequirement, TransportPacket Ref, [ TransportHeaderItem ] ) ]+    | PeerConnected (Connection PeerAddress)+    | PeerDropped   lookupServiceType :: [TransportHeaderItem] -> Maybe ServiceID@@ -251,11 +267,20 @@      let logd = writeTQueue serverErrorLog     forkServerThread server $ forever $ do-        logd' =<< atomically (readTQueue serverErrorLog)+        logd' . (serverErrorPrefix serverOptions <>) =<< atomically (readTQueue serverErrorLog) +    logt <- if+        | serverTestLog serverOptions -> do+            serverTestLog <- newTQueueIO+            forkServerThread server $ forever $ do+                logd' =<< atomically (readTQueue serverTestLog)+            return $ writeTQueue serverTestLog+        | otherwise -> do+            return $ \_ -> return ()+     forkServerThread server $ dataResponseWorker server     forkServerThread server $ forever $ do-        either (atomically . logd) return =<< runExceptT =<<+        either (atomically . logd . showErebosError) return =<< runExceptT =<<             atomically (readTQueue serverIOActions)      let open addr = do@@ -320,12 +345,10 @@              forkServerThread server $ forever $ do                 (paddr, msg) <- readFlowIO serverRawPath-                handle (\(e :: IOException) -> atomically . logd $ "failed to send packet to " ++ show paddr ++ ": " ++ show e) $ do+                handle (\(e :: SomeException) -> atomically . logd $ "failed to send packet to " ++ show paddr ++ ": " ++ show e) $ do                     case paddr of+                        CustomPeerAddress addr -> sendBytesToAddress addr msg                         DatagramAddress addr -> void $ S.sendTo sock msg addr-#ifdef ENABLE_ICE_SUPPORT-                        PeerIceSession ice   -> iceSend ice msg-#endif              forkServerThread server $ forever $ do                 readFlowIO serverControlFlow >>= \case@@ -367,9 +390,13 @@                                         prefs <- forM objs $ storeObject $ peerInStorage peer                                         identity <- readMVar serverIdentity_                                         let svcs = map someServiceID serverServices-                                        handlePacket identity secure peer chanSvc svcs header prefs+                                        handlePacket paddr identity secure peer chanSvc svcs header prefs                                         peerLoop                                     Nothing -> do+                                        case paddr of+                                            DatagramAddress _ -> return ()+                                            CustomPeerAddress caddr -> connectionToAddressClosed caddr+                                         dropPeer peer                                         atomically $ writeTChan serverChanPeer peer                             peerLoop@@ -377,7 +404,7 @@                     ReceivedAnnounce addr _ -> do                         void $ serverPeer' server addr -            erebosNetworkProtocol (headLocalIdentity serverOrigHead) logd protocolRawPath protocolControlFlow+            erebosNetworkProtocol (headLocalIdentity serverOrigHead) logd logt protocolRawPath protocolControlFlow      forkServerThread server $ withSocketsDo $ do         let hints = defaultHints@@ -389,9 +416,9 @@         bracket (open addr) close loop      forkServerThread server $ forever $ do-        (peer, svc, ref) <- atomically $ readTQueue chanSvc+        ( peer, paddr, svc, ref, streams ) <- atomically $ readTQueue chanSvc         case find ((svc ==) . someServiceID) serverServices of-            Just service@(SomeService (_ :: Proxy s) attr) -> runPeerServiceOn (Just (service, attr)) peer (serviceHandler $ wrappedLoad @s ref)+            Just service@(SomeService (_ :: Proxy s) attr) -> runPeerServiceOn (Just ( service, attr )) streams paddr peer (serviceHandler $ wrappedLoad @s ref)             _ -> atomically $ logd $ "unhandled service '" ++ show (toUUID svc) ++ "'"      return server@@ -425,7 +452,7 @@                           Right ref -> do                               atomically (writeTVar tvar $ Right ref)                               forkServerThread server $ runExceptT (wrefAction wr ref) >>= \case-                                  Left err -> atomically $ writeTQueue (serverErrorLog server) err+                                  Left err -> atomically $ writeTQueue (serverErrorLog server) (showErebosError err)                                   Right () -> return ()                                return (Nothing, [])@@ -519,9 +546,7 @@     conn <- readTVarP peerState >>= \case         PeerConnected conn -> return conn         _                  -> throwError "can't open stream without established connection"-    (hdr, writer, handler) <- liftSTM (connAddWriteStream conn) >>= \case-        Right res -> return res-        Left err -> throwError err+    (hdr, writer, handler) <- liftEither =<< liftSTM (connAddWriteStream conn)      liftSTM $ writeTQueue (serverIOActions peerServer_) (liftIO $ forkServerThread peerServer_ handler)     addHeader hdr@@ -540,10 +565,10 @@                         | otherwise = y : appendDistinct x ys appendDistinct x [] = [x] -handlePacket :: UnifiedIdentity -> Bool-    -> Peer -> TQueue (Peer, ServiceID, Ref) -> [ServiceID]-    -> TransportHeader -> [PartialRef] -> IO ()-handlePacket identity secure peer chanSvc svcs (TransportHeader headers) prefs = atomically $ do+handlePacket :: PeerAddress -> UnifiedIdentity -> Bool+    -> Peer -> TQueue ( Peer, PeerAddress, ServiceID, Ref, [ RawStreamReader ] ) -> [ ServiceID ]+    -> TransportHeader -> [ PartialRef ] -> IO ()+handlePacket paddr identity secure peer chanSvc svcs (TransportHeader headers) prefs = atomically $ do     let server = peerServer peer     ochannel <- getPeerChannel peer     let sidentity = idData identity@@ -604,7 +629,7 @@                     liftSTM $ writeTQueue (serverIOActions server) $ void $ liftIO $ forkIO $ do                         (runExcept <$> readObjectsFromStream (peerInStorage peer) streamReader) >>= \case                             Left err -> atomically $ writeTQueue (serverErrorLog server) $-                                "failed to receive object from stream: " <> err+                                "failed to receive object from stream: " <> showErebosError err                             Right objs -> do                                 forM_ objs $ \obj -> do                                     pref <- storeObject (peerInStorage peer) obj@@ -676,17 +701,18 @@                 | Just svc <- lookupServiceType headers -> if                     | svc `elem` svcs -> do                         if dgst `elem` map refDigest prefs || True {- TODO: used by Message service to confirm receive -}-                           then do-                                void $ newWaitingRef dgst $ \ref ->-                                    liftIO $ atomically $ writeTQueue chanSvc (peer, svc, ref)-                           else throwError $ "missing service object " ++ show dgst+                          then do+                            streamReaders <- mapM acceptStream $ lookupNewStreams headers+                            void $ newWaitingRef dgst $ \ref ->+                               liftIO $ atomically $ writeTQueue chanSvc ( peer, paddr, svc, ref, streamReaders )+                          else throwError $ "missing service object " ++ show dgst                     | otherwise -> addHeader $ Rejected dgst                 | otherwise -> throwError $ "service ref without type"              _ -> return ()  -withPeerIdentity :: MonadIO m => Peer -> (UnifiedIdentity -> ExceptT String IO ()) -> m ()+withPeerIdentity :: MonadIO m => Peer -> (UnifiedIdentity -> ExceptT ErebosError IO ()) -> m () withPeerIdentity peer act = liftIO $ atomically $ readTVar (peerIdentityVar peer) >>= \case     PeerIdentityUnknown tvar -> modifyTVar' tvar (act:)     PeerIdentityRef _ tvar -> modifyTVar' tvar (act:)@@ -742,7 +768,7 @@                         sendToPeerS peer [] $ TransportPacket (TransportHeader [Acknowledged $ refDigest accref]) []                         finalizedChannel peer ch identity -                Left dgst -> throwError $ "missing accept data " ++ BC.unpack (showRefDigest dgst)+                Left dgst -> throwOtherError $ "missing accept data " ++ BC.unpack (showRefDigest dgst)   finalizedChannel :: Peer -> Channel -> UnifiedIdentity -> STM ()@@ -758,7 +784,7 @@      -- Notify services about new peer     readTVar peerIdentityVar >>= \case-        PeerIdentityFull _ -> notifyServicesOfPeer peer+        PeerIdentityFull _ -> notifyServicesOfPeer True peer         _ -> return ()  @@ -784,7 +810,7 @@         PeerIdentityFull pid             | idData pid `precedes` wrappedLoad ref             -> validateAndUpdate (idUpdates pid) $ \_ -> do-                notifyServicesOfPeer peer+                notifyServicesOfPeer False peer          _ -> return () @@ -796,17 +822,24 @@         -> do             writeTVar (peerIdentityVar peer) $ PeerIdentityFull pid'             writeTChan (serverChanPeer $ peerServer peer) peer-            when (idData pid /= idData pid') $ notifyServicesOfPeer peer+            when (pid /= pid') $ do+                notifyServicesOfPeer False peer          | otherwise -> return () -notifyServicesOfPeer :: Peer -> STM ()-notifyServicesOfPeer peer@Peer { peerServer_ = Server {..} } = do+notifyServicesOfPeer :: Bool -> Peer -> STM ()+notifyServicesOfPeer new peer@Peer { peerServer_ = Server {..} } = do     writeTQueue serverIOActions $ do+        paddr <- getPeerAddress peer         forM_ serverServices $ \service@(SomeService _ attrs) ->-            runPeerServiceOn (Just (service, attrs)) peer serviceNewPeer+            runPeerServiceOn (Just ( service, attrs )) [] paddr peer $+                if new then serviceNewPeer else serviceUpdatedPeer  +receivedFromCustomAddress :: PeerAddressType addr => Server -> addr -> ByteString -> IO ()+receivedFromCustomAddress Server {..} addr msg = do+    writeFlowIO serverRawPath ( CustomPeerAddress addr, msg )+ mkPeer :: Server -> PeerAddress -> IO Peer mkPeer peerServer_ peerAddress = do     peerState <- newTVarIO (PeerInit [])@@ -825,14 +858,8 @@             _   -> paddr     serverPeer' server (DatagramAddress paddr') -#ifdef ENABLE_ICE_SUPPORT-serverPeerIce :: Server -> IceSession -> IO Peer-serverPeerIce server@Server {..} ice = do-    let paddr = PeerIceSession ice-    peer <- serverPeer' server paddr-    iceSetChan ice $ mapFlow undefined (paddr,) serverRawPath-    return peer-#endif+serverPeerCustom :: PeerAddressType addr => Server -> addr -> IO Peer+serverPeerCustom server addr = serverPeer' server (CustomPeerAddress addr)  serverPeer' :: Server -> PeerAddress -> IO Peer serverPeer' server paddr = do@@ -846,6 +873,13 @@         writeFlow (serverControlFlow server) (RequestConnection paddr)     return peer +findPeer :: Server -> (Peer -> IO Bool) -> IO (Maybe Peer)+findPeer server test = withMVar (serverPeers server) (helper . M.elems)+  where+    helper (p : ps) = test p >>= \case True  -> return (Just p)+                                       False -> helper ps+    helper []       = return Nothing+ dropPeer :: MonadIO m => Peer -> m () dropPeer peer = liftIO $ do     modifyMVar_ (serverPeers $ peerServer peer) $ \pvalue -> do@@ -873,20 +907,50 @@ sendManyToPeerStored :: (Service s, MonadIO m) => Peer -> [ Stored s ] -> m () sendManyToPeerStored peer = sendToPeerList peer . map (\part -> ServiceReply (Right part) True) -sendToPeerList :: (Service s, MonadIO m) => Peer -> [ServiceReply s] -> m ()+sendToPeerList :: (Service s, MonadIO m) => Peer -> [ ServiceReply s ] -> m () sendToPeerList peer parts = do     let st = peerStorage peer-    srefs <- liftIO $ fmap catMaybes $ forM parts $ \case-        ServiceReply (Left x) use -> Just . (,use) <$> store st x-        ServiceReply (Right sx) use -> return $ Just (storedRef sx, use)-        ServiceFinally act -> act >> return Nothing-    let dgsts = map (refDigest . fst) srefs-    let content = map fst $ filter (\(ref, use) -> use && BL.length (lazyLoadBytes ref) < 500) srefs -- TODO: MTU-        header = TransportHeader (ServiceType (serviceID $ head parts) : map ServiceRef dgsts)-        packet = TransportPacket header content-        ackedBy = concat [[ Acknowledged r, Rejected r, DataRequest r ] | r <- dgsts ]-    liftIO $ atomically $ sendToPeerS peer ackedBy packet+    res <- runExceptT $ do+        srefs <- liftIO $ fmap catMaybes $ forM parts $ \case+            ServiceReply (Left x) use -> Just . (,use) <$> store st x+            ServiceReply (Right sx) use -> return $ Just (storedRef sx, use)+            _ -> return Nothing +        streamHeaders <- concat <$> do+            (liftEither =<<) $ liftIO $ atomically $ runExceptT $ do+                forM parts $ \case+                    ServiceOpenStream cb -> do+                        conn <- lift (readTVar (peerState peer)) >>= \case+                            PeerConnected conn -> return conn+                            _                  -> throwError "can't open stream without established connection"+                        (hdr, writer, handler) <- liftEither =<< lift (connAddWriteStream conn)++                        lift $ writeTQueue (serverIOActions (peerServer peer)) $ do+                            liftIO $ forkServerThread (peerServer peer) handler+                        return [ ( hdr, cb writer ) ]+                    _ -> return []+        liftIO $ sequence_ $ map snd streamHeaders++        liftIO $ forM_ parts $ \case+            ServiceFinally act -> act+            _ -> return ()++        let dgsts = map (refDigest . fst) srefs+        let content = map fst $ filter (\(ref, use) -> use && BL.length (lazyLoadBytes ref) < 500) srefs -- TODO: MTU+            header = TransportHeader $ concat+                [ [ ServiceType (serviceID $ head parts) ]+                , map ServiceRef dgsts+                , map fst streamHeaders+                ]+            packet = TransportPacket header content+            ackedBy = concat [[ Acknowledged r, Rejected r, DataRequest r ] | r <- dgsts ]+        liftIO $ atomically $ sendToPeerS peer ackedBy packet++    case res of+        Right () -> return ()+        Left err -> liftIO $ atomically $ writeTQueue (serverErrorLog $ peerServer peer) $+            "failed to send packet to " <> show (peerAddress peer) <> ": " <> err+ sendToPeerS' :: SecurityRequirement -> Peer -> [TransportHeaderItem] -> TransportPacket Ref -> STM () sendToPeerS' secure Peer {..} ackedBy packet = do     readTVar peerState >>= \case@@ -900,7 +964,7 @@ sendToPeerPlain :: Peer -> [TransportHeaderItem] -> TransportPacket Ref -> STM () sendToPeerPlain = sendToPeerS' PlaintextAllowed -sendToPeerWith :: forall s m. (Service s, MonadIO m, MonadError String m) => Peer -> (ServiceState s -> ExceptT String IO (Maybe s, ServiceState s)) -> m ()+sendToPeerWith :: forall s m e. (Service s, MonadIO m, MonadError e m, FromErebosError e) => Peer -> (ServiceState s -> ExceptT ErebosError IO (Maybe s, ServiceState s)) -> m () sendToPeerWith peer fobj = do     let sproxy = Proxy @s         sid = serviceID sproxy@@ -915,7 +979,7 @@     case res of          Right (Just obj) -> sendToPeer peer obj          Right Nothing -> return ()-         Left err -> throwError err+         Left err -> throwError $ fromErebosError err   lookupService :: forall s proxy. Service s => proxy s -> [SomeService] -> Maybe (SomeService, ServiceAttributes s)@@ -925,10 +989,12 @@ lookupService _ [] = Nothing  runPeerService :: forall s m. (Service s, MonadIO m) => Peer -> ServiceHandler s () -> m ()-runPeerService = runPeerServiceOn Nothing+runPeerService peer handler = do+    paddr <- getPeerAddress peer+    runPeerServiceOn Nothing [] paddr peer handler -runPeerServiceOn :: forall s m. (Service s, MonadIO m) => Maybe (SomeService, ServiceAttributes s) -> Peer -> ServiceHandler s () -> m ()-runPeerServiceOn mbservice peer handler = liftIO $ do+runPeerServiceOn :: forall s m. (Service s, MonadIO m) => Maybe ( SomeService, ServiceAttributes s ) -> [ RawStreamReader ] -> PeerAddress -> Peer -> ServiceHandler s () -> m ()+runPeerServiceOn mbservice newStreams paddr peer handler = liftIO $ do     let server = peerServer peer         proxy = Proxy @s         svc = serviceID proxy@@ -950,9 +1016,11 @@                             let inp = ServiceInput                                     { svcAttributes = attr                                     , svcPeer = peer+                                    , svcPeerAddress = paddr                                     , svcPeerIdentity = peerId                                     , svcServer = server                                     , svcPrintOp = atomically . logd+                                    , svcNewStreams = newStreams                                     }                             reloadHead (serverOrigHead server) >>= \case                                 Nothing -> atomically $ do@@ -968,13 +1036,13 @@                                         putTMVar (peerServiceState peer) $ M.insert svc (SomeServiceState proxy s') svcs                                         putTMVar (serverServiceStates server) $ M.insert svc (SomeServiceGlobalState proxy gs') global                 _ -> do-                    atomically $ logd $ "can't run service handler on peer with incomplete identity " ++ show (peerAddress peer)+                    atomically $ logd $ "can't run service handler on peer with incomplete identity " ++ show paddr          _ -> atomically $ do             logd $ "unhandled service '" ++ show (toUUID svc) ++ "'"  modifyServiceGlobalState-    :: forall s a m proxy. (Service s, MonadIO m, MonadError String m)+    :: forall s a m e proxy. (Service s, MonadIO m, MonadError e m, FromErebosError e)     => Server -> proxy s     -> (ServiceGlobalState s -> ( ServiceGlobalState s, a ))     -> m a@@ -992,33 +1060,14 @@                 putTMVar (serverServiceStates server) global'                 return res         Nothing -> do-            throwError $ "unhandled service '" ++ show (toUUID svc) ++ "'"+            throwOtherError $ "unhandled service '" ++ show (toUUID svc) ++ "'"  -foreign import ccall unsafe "Network/ifaddrs.h join_multicast" cJoinMulticast :: CInt -> Ptr CSize -> IO (Ptr Word32)-foreign import ccall unsafe "Network/ifaddrs.h local_addresses" cLocalAddresses :: Ptr CSize -> IO (Ptr InetAddress)-foreign import ccall unsafe "Network/ifaddrs.h broadcast_addresses" cBroadcastAddresses :: IO (Ptr Word32)+foreign import ccall unsafe "Network/ifaddrs.h erebos_join_multicast" cJoinMulticast :: CInt -> Ptr CSize -> IO (Ptr Word32)+foreign import ccall unsafe "Network/ifaddrs.h erebos_local_addresses" cLocalAddresses :: Ptr CSize -> IO (Ptr InetAddress)+foreign import ccall unsafe "Network/ifaddrs.h erebos_broadcast_addresses" cBroadcastAddresses :: IO (Ptr Word32) foreign import ccall unsafe "stdlib.h free" cFree :: Ptr a -> IO () -data InetAddress = InetAddress { fromInetAddress :: IP.IP }--instance F.Storable InetAddress where-    sizeOf _ = sizeOf (undefined :: CInt) + 16-    alignment _ = 8--    peek ptr = (unpackFamily <$> peekByteOff ptr 0) >>= \case-        AF_INET -> InetAddress . IP.IPv4 . IP.fromHostAddress <$> peekByteOff ptr (sizeOf (undefined :: CInt))-        AF_INET6 -> InetAddress . IP.IPv6 . IP.toIPv6b . map fromIntegral <$> peekArray 16 (ptr `plusPtr` sizeOf (undefined :: CInt) :: Ptr Word8)-        _ -> fail "InetAddress: unknown family"--    poke ptr (InetAddress addr) = case addr of-        IP.IPv4 ip -> do-            pokeByteOff ptr 0 (packFamily AF_INET)-            pokeByteOff ptr (sizeOf (undefined :: CInt)) (IP.toHostAddress ip)-        IP.IPv6 ip -> do-            pokeByteOff ptr 0 (packFamily AF_INET6)-            pokeArray (ptr `plusPtr` sizeOf (undefined :: CInt) :: Ptr Word8) (map fromIntegral $ IP.fromIPv6b ip)- joinMulticast :: Socket -> IO [ Word32 ] joinMulticast sock =     withFdSocket sock $ \fd ->@@ -1045,7 +1094,7 @@             count <- fromIntegral <$> peek pcount             res <- peekArray count ptr             cFree ptr-            return $ map (IP.toSockAddr . (, serverPort serverOptions ) . fromInetAddress) res+            return $ map (inetToSockAddr . (, serverPort serverOptions )) res  getBroadcastAddresses :: PortNumber -> IO [SockAddr] getBroadcastAddresses port = do

@@ -1,8 +1,9 @@ module Erebos.Network where -import Erebos.Storage+import Erebos.Object.Internal  data Server data Peer+data PeerAddress  peerStorage :: Peer -> Storage

@@ -0,0 +1,65 @@+module Erebos.Network.Address (+    InetAddress(..),+    inetFromSockAddr,+    inetToSockAddr,++    SockAddr, PortNumber,+) where++import Data.Bifunctor+import Data.IP qualified as IP+import Data.Word++import Foreign.C.Types+import Foreign.Marshal.Array+import Foreign.Ptr+import Foreign.Storable as F++import Network.Socket++import Text.Read+++newtype InetAddress = InetAddress { fromInetAddress :: IP.IP }+    deriving (Eq, Ord)++instance Show InetAddress where+    show (InetAddress ipaddr)+        | IP.IPv6 ipv6 <- ipaddr+        , ( 0, 0, 0xffff, ipv4 ) <- IP.fromIPv6w ipv6+        = show (IP.toIPv4w ipv4)++        | otherwise+        = show ipaddr++instance Read InetAddress where+    readPrec = do+        readPrec >>= return . InetAddress . \case+            IP.IPv4 ipv4 -> IP.IPv6 $ IP.toIPv6w ( 0, 0, 0xffff, IP.fromIPv4w ipv4 )+            ipaddr       -> ipaddr++    readListPrec = readListPrecDefault++instance F.Storable InetAddress where+    sizeOf _ = sizeOf (undefined :: CInt) + 16+    alignment _ = 8++    peek ptr = (unpackFamily <$> peekByteOff ptr 0) >>= \case+        AF_INET -> InetAddress . IP.IPv4 . IP.fromHostAddress <$> peekByteOff ptr (sizeOf (undefined :: CInt))+        AF_INET6 -> InetAddress . IP.IPv6 . IP.toIPv6b . map fromIntegral <$> peekArray 16 (ptr `plusPtr` sizeOf (undefined :: CInt) :: Ptr Word8)+        _ -> fail "InetAddress: unknown family"++    poke ptr (InetAddress addr) = case addr of+        IP.IPv4 ip -> do+            pokeByteOff ptr 0 (packFamily AF_INET)+            pokeByteOff ptr (sizeOf (undefined :: CInt)) (IP.toHostAddress ip)+        IP.IPv6 ip -> do+            pokeByteOff ptr 0 (packFamily AF_INET6)+            pokeArray (ptr `plusPtr` sizeOf (undefined :: CInt) :: Ptr Word8) (map fromIntegral $ IP.fromIPv6b ip)+++inetFromSockAddr :: SockAddr -> Maybe ( InetAddress, PortNumber )+inetFromSockAddr saddr = first InetAddress <$> IP.fromSockAddr saddr++inetToSockAddr :: ( InetAddress, PortNumber ) -> SockAddr+inetToSockAddr = IP.toSockAddr . first fromInetAddress

@@ -0,0 +1,175 @@+module Erebos.Network.Channel (+    Channel,+    ChannelRequest, ChannelRequestData(..),+    ChannelAccept, ChannelAcceptData(..),++    createChannelRequest,+    acceptChannelRequest,+    acceptedChannel,++    channelEncrypt,+    channelDecrypt,+) where++import Control.Concurrent.MVar+import Control.Monad+import Control.Monad.Except+import Control.Monad.IO.Class++import Crypto.Cipher.ChaChaPoly1305+import Crypto.Error++import Data.Binary+import Data.ByteArray (ByteArray, Bytes, ScrubbedBytes, convert)+import Data.ByteArray qualified as BA+import Data.ByteString.Lazy qualified as BL+import Data.List++import Erebos.Identity+import Erebos.PubKey+import Erebos.Storable++data Channel = Channel+    { chPeers :: [Stored (Signed IdentityData)]+    , chKey :: ScrubbedBytes+    , chNonceFixedOur :: Bytes+    , chNonceFixedPeer :: Bytes+    , chCounterNextOut :: MVar Word64+    , chCounterNextIn :: MVar Word64+    }++type ChannelRequest = Signed ChannelRequestData++data ChannelRequestData = ChannelRequest+    { crPeers :: [Stored (Signed IdentityData)]+    , crKey :: Stored PublicKexKey+    }+    deriving (Show)++type ChannelAccept = Signed ChannelAcceptData++data ChannelAcceptData = ChannelAccept+    { caRequest :: Stored ChannelRequest+    , caKey :: Stored PublicKexKey+    }+++instance Storable ChannelRequestData where+    store' cr = storeRec $ do+        mapM_ (storeRef "peer") $ crPeers cr+        storeRef "key" $ crKey cr++    load' = loadRec $ do+        ChannelRequest+            <$> loadRefs "peer"+            <*> loadRef "key"++instance Storable ChannelAcceptData where+    store' ca = storeRec $ do+        storeRef "req" $ caRequest ca+        storeRef "key" $ caKey ca++    load' = loadRec $ do+        ChannelAccept+            <$> loadRef "req"+            <*> loadRef "key"+++keySize :: Int+keySize = 32++createChannelRequest :: (MonadStorage m, MonadIO m, MonadError e m, FromErebosError e) => UnifiedIdentity -> UnifiedIdentity -> m (Stored ChannelRequest)+createChannelRequest self peer = do+    (_, xpublic) <- liftIO . generateKeys =<< getStorage+    skey <- loadKey $ idKeyMessage self+    mstore =<< sign skey =<< mstore ChannelRequest { crPeers = sort [idData self, idData peer], crKey = xpublic }++acceptChannelRequest :: (MonadStorage m, MonadIO m, MonadError e m, FromErebosError e) => UnifiedIdentity -> UnifiedIdentity -> Stored ChannelRequest -> m (Stored ChannelAccept, Channel)+acceptChannelRequest self peer req = do+    case sequence $ map validateIdentity $ crPeers $ fromStored $ signedData $ fromStored req of+        Nothing -> throwOtherError $ "invalid peers in channel request"+        Just peers -> do+            when (not $ any (self `sameIdentity`) peers) $+                throwOtherError $ "self identity missing in channel request peers"+            when (not $ any (peer `sameIdentity`) peers) $+                throwOtherError $ "peer identity missing in channel request peers"+    when (idKeyMessage peer `notElem` (map (sigKey . fromStored) $ signedSignature $ fromStored req)) $+        throwOtherError $ "channel requent not signed by peer"++    (xsecret, xpublic) <- liftIO . generateKeys =<< getStorage+    skey <- loadKey $ idKeyMessage self+    acc <- mstore =<< sign skey =<< mstore ChannelAccept { caRequest = req, caKey = xpublic }+    liftIO $ do+        let chPeers = crPeers $ fromStored $ signedData $ fromStored req+            chKey = BA.take keySize $ dhSecret xsecret $+                fromStored $ crKey $ fromStored $ signedData $ fromStored req+            chNonceFixedOur  = BA.pack [ 2, 0, 0, 0 ]+            chNonceFixedPeer = BA.pack [ 1, 0, 0, 0 ]+        chCounterNextOut <- newMVar 0+        chCounterNextIn <- newMVar 0++        return (acc, Channel {..})++acceptedChannel :: (MonadIO m, MonadError e m, FromErebosError e) => UnifiedIdentity -> UnifiedIdentity -> Stored ChannelAccept -> m Channel+acceptedChannel self peer acc = do+    let req = caRequest $ fromStored $ signedData $ fromStored acc+    case sequence $ map validateIdentity $ crPeers $ fromStored $ signedData $ fromStored req of+        Nothing -> throwOtherError $ "invalid peers in channel accept"+        Just peers -> do+            when (not $ any (self `sameIdentity`) peers) $+                throwOtherError $ "self identity missing in channel accept peers"+            when (not $ any (peer `sameIdentity`) peers) $+                throwOtherError $ "peer identity missing in channel accept peers"+    when (idKeyMessage peer `notElem` (map (sigKey . fromStored) $ signedSignature $ fromStored acc)) $+        throwOtherError $ "channel accept not signed by peer"+    when (idKeyMessage self `notElem` (map (sigKey . fromStored) $ signedSignature $ fromStored req)) $+        throwOtherError $ "original channel request not signed by us"++    xsecret <- loadKey $ crKey $ fromStored $ signedData $ fromStored req+    let chPeers = crPeers $ fromStored $ signedData $ fromStored req+        chKey = BA.take keySize $ dhSecret xsecret $+            fromStored $ caKey $ fromStored $ signedData $ fromStored acc+        chNonceFixedOur  = BA.pack [ 1, 0, 0, 0 ]+        chNonceFixedPeer = BA.pack [ 2, 0, 0, 0 ]+    chCounterNextOut <- liftIO $ newMVar 0+    chCounterNextIn <- liftIO $ newMVar 0++    return Channel {..}+++channelEncrypt :: (ByteArray ba, MonadIO m, MonadError e m, FromErebosError e) => Channel -> ba -> m (ba, Word64)+channelEncrypt Channel {..} plain = do+    count <- liftIO $ modifyMVar chCounterNextOut $ \c -> return (c + 1, c)+    let cbytes = convert $ BL.toStrict $ encode count+        nonce = nonce8 chNonceFixedOur cbytes+    state <- case initialize chKey =<< nonce of+        CryptoPassed state -> return state+        CryptoFailed err -> throwOtherError $ "failed to init chacha-poly1305 cipher: " <> show err++    let (ctext, state') = encrypt plain state+        tag = finalize state'+    return (BA.concat [ convert $ BA.drop 7 cbytes, ctext, convert tag ], count)++channelDecrypt :: (ByteArray ba, MonadIO m, MonadError e m, FromErebosError e) => Channel -> ba -> m (ba, Word64)+channelDecrypt Channel {..} body = do+    when (BA.length body < 17) $ do+        throwOtherError $ "invalid encrypted data length"++    expectedCount <- liftIO $ readMVar chCounterNextIn+    let countByte = body `BA.index` 0+        body' = BA.dropView body 1+        guessedCount = expectedCount - 128 + fromIntegral (countByte - fromIntegral expectedCount + 128 :: Word8)+        nonce = nonce8 chNonceFixedPeer $ convert $ BL.toStrict $ encode guessedCount+        blen = BA.length body' - 16+        ctext = BA.takeView body' blen+        tag = BA.dropView body' blen+    state <- case initialize chKey =<< nonce of+        CryptoPassed state -> return state+        CryptoFailed err -> throwOtherError $ "failed to init chacha-poly1305 cipher: " <> show err++    let (plain, state') = decrypt (convert ctext) state+    when (not $ tag `BA.constEq` finalize state') $ do+        throwOtherError $ "tag validation falied"++    liftIO $ modifyMVar_ chCounterNextIn $ return . max (guessedCount + 1)+    return (plain, guessedCount)

@@ -3,6 +3,7 @@     transportToObject,     TransportHeader(..),     TransportHeaderItem(..),+    ServiceID(..),     SecurityRequirement(..),      WaitingRef(..),@@ -22,7 +23,8 @@     connSetChannel,     connClose, -    RawStreamReader, RawStreamWriter,+    RawStreamReader(..), RawStreamWriter(..),+    StreamPacket(..),     connAddWriteStream,     connAddReadStream,     readStreamToList,@@ -65,11 +67,13 @@  import System.Clock -import Erebos.Channel import Erebos.Flow import Erebos.Identity-import Erebos.Service+import Erebos.Network.Channel+import Erebos.Object+import Erebos.Storable import Erebos.Storage+import Erebos.UUID (UUID)   protocolVersion :: Text@@ -106,6 +110,9 @@     | StreamOpen Word8     deriving (Eq, Show) +newtype ServiceID = ServiceID UUID+    deriving (Eq, Ord, Show, StorableUUID)+ newtype Cookie = Cookie ByteString     deriving (Eq, Show) @@ -206,6 +213,7 @@     , gControlFlow :: Flow (ControlRequest addr) (ControlMessage addr)     , gNextUp :: TMVar (Connection addr, (Bool, TransportPacket PartialObject))     , gLog :: String -> STM ()+    , gTestLog :: String -> STM ()     , gStorage :: PartialStorage     , gStartTime :: TimeSpec     , gNowVar :: TVar TimeSpec@@ -242,6 +250,12 @@ connAddress :: Connection addr -> addr connAddress = cAddress +showConnAddress :: forall addr. Connection addr -> String+showConnAddress Connection {..} = helper cGlobalState cAddress+  where+    helper :: GlobalState addr -> addr -> String+    helper GlobalState {} = show+ connData :: Connection addr -> Flow     (Maybe (Bool, TransportPacket PartialObject))     (SecurityRequirement, TransportPacket Ref, [TransportHeaderItem])@@ -266,6 +280,7 @@  connAddWriteStream :: Connection addr -> STM (Either String (TransportHeaderItem, RawStreamWriter, IO ())) connAddWriteStream conn@Connection {..} = do+    let GlobalState {..} = cGlobalState     outStreams <- readTVar cOutStreams     let doInsert :: Word8 -> [(Word8, Stream)] -> ExceptT String STM ((Word8, Stream), [(Word8, Stream)])         doInsert n (s@(n', _) : rest) | n == n' =@@ -282,10 +297,16 @@     runExceptT $ do         ((streamNumber, stream), outStreams') <- doInsert 1 outStreams         lift $ writeTVar cOutStreams outStreams'-        return (StreamOpen streamNumber, sFlowIn stream, go cGlobalState streamNumber stream)+        lift $ gTestLog $ "net-ostream-open " <> showConnAddress conn <> " " <> show streamNumber <> " " <> show (length outStreams')+        return+            ( StreamOpen streamNumber+            , RawStreamWriter (fromIntegral streamNumber) (sFlowIn stream)+            , go streamNumber stream+            )    where-    go gs@GlobalState {..} streamNumber stream = do+    go streamNumber stream = do+            let GlobalState {..} = cGlobalState             (reserved, msg) <- atomically $ do                 readTVar (sState stream) >>= \case                     StreamRunning -> return ()@@ -298,6 +319,8 @@                     return (stpData, True, return ())                 StreamClosed {} -> do                     atomically $ do+                        gTestLog $ "net-ostream-close-send " <> showConnAddress conn <> " " <> show streamNumber+                    atomically $ do                         -- wait for ack on all sent stream data                         waits <- readTVar (sWaitingForAck stream)                         when (waits > 0) retry@@ -322,7 +345,7 @@                         Right (ctext, counter) -> do                             let isAcked = True                             return $ Just (0x80 `B.cons` ctext, if isAcked then [ AcknowledgedSingle $ fromIntegral counter ] else [])-                        Left err -> do atomically $ gLog $ "Failed to encrypt data: " ++ err+                        Left err -> do atomically $ gLog $ "Failed to encrypt data: " ++ showErebosError err                                        return Nothing                 Nothing | secure    -> return Nothing                         | otherwise -> return $ Just (plain, plainAckedBy)@@ -341,7 +364,7 @@                     sendBytes conn mbReserved' bs                 Nothing -> return () -            when cont $ go gs streamNumber stream+            when cont $ go streamNumber stream  connAddReadStream :: Connection addr -> Word8 -> STM RawStreamReader connAddReadStream Connection {..} streamNumber = do@@ -355,15 +378,22 @@             sNextSequence <- newTVar 0             sWaitingForAck <- newTVar 0             let stream = Stream {..}-            return (stream, (streamNumber, stream) : streams)-    (stream, inStreams') <- doInsert inStreams+            return ( streamNumber, stream, (streamNumber, stream) : streams )+    ( num, stream, inStreams' ) <- doInsert inStreams     writeTVar cInStreams inStreams'-    return $ sFlowOut stream+    return $ RawStreamReader (fromIntegral num) (sFlowOut stream)  -type RawStreamReader = Flow StreamPacket Void-type RawStreamWriter = Flow Void StreamPacket+data RawStreamReader = RawStreamReader+    { rsrNum :: Int+    , rsrFlow :: Flow StreamPacket Void+    } +data RawStreamWriter = RawStreamWriter+    { rswNum :: Int+    , rswFlow :: Flow Void StreamPacket+    }+ data Stream = Stream     { sState :: TVar StreamState     , sFlowIn :: Flow Void StreamPacket@@ -393,24 +423,26 @@         Nothing -> return ()  streamClosed :: Connection addr -> Word8 -> IO ()-streamClosed Connection {..} snum = atomically $ do-    modifyTVar' cOutStreams $ filter ((snum /=) . fst)+streamClosed conn@Connection {..} snum = atomically $ do+    streams <- filter ((snum /=) . fst) <$> readTVar cOutStreams+    writeTVar cOutStreams streams+    gTestLog cGlobalState $ "net-ostream-close-ack " <> showConnAddress conn <> " " <> show snum <> " " <> show (length streams)  readStreamToList :: RawStreamReader -> IO (Word64, [(Word64, BC.ByteString)])-readStreamToList stream = readFlowIO stream >>= \case+readStreamToList stream = readFlowIO (rsrFlow stream) >>= \case     StreamData sq bytes -> fmap ((sq, bytes) :) <$> readStreamToList stream     StreamClosed sqEnd  -> return (sqEnd, []) -readObjectsFromStream :: PartialStorage -> RawStreamReader -> IO (Except String [PartialObject])+readObjectsFromStream :: PartialStorage -> RawStreamReader -> IO (Except ErebosError [PartialObject]) readObjectsFromStream st stream = do     (seqEnd, list) <- readStreamToList stream     let validate s ((s', bytes) : rest)             | s == s'   = (bytes : ) <$> validate (s + 1) rest             | s >  s'   = validate s rest-            | otherwise = throwError "missing object chunk"+            | otherwise = throwOtherError "missing object chunk"         validate s []             | s == seqEnd = return []-            | otherwise = throwError "content length mismatch"+            | otherwise = throwOtherError "content length mismatch"     return $ do         content <- BL.fromChunks <$> validate 0 list         deserializeObjects st content@@ -419,10 +451,10 @@ writeByteStringToStream stream = go 0   where     go seqNum bstr-        | BL.null bstr = writeFlowIO stream $ StreamClosed seqNum+        | BL.null bstr = writeFlowIO (rswFlow stream) $ StreamClosed seqNum         | otherwise    = do             let (cur, rest) = BL.splitAt 500 bstr -- TODO: MTU-            writeFlowIO stream $ StreamData seqNum (BL.toStrict cur)+            writeFlowIO (rswFlow stream) $ StreamData seqNum (BL.toStrict cur)             go (seqNum + 1) rest  @@ -433,7 +465,7 @@     , wrefStatus :: TVar (Either [RefDigest] Ref)     } -type WaitingRefCallback = ExceptT String IO ()+type WaitingRefCallback = ExceptT ErebosError IO ()  wrDigest :: WaitingRef -> RefDigest wrDigest = refDigest . wrefPartial@@ -476,10 +508,11 @@ erebosNetworkProtocol :: (Eq addr, Ord addr, Show addr)                       => UnifiedIdentity                       -> (String -> STM ())+                      -> (String -> STM ())                       -> SymFlow (addr, ByteString)                       -> Flow (ControlRequest addr) (ControlMessage addr)                       -> IO ()-erebosNetworkProtocol initialIdentity gLog gDataFlow gControlFlow = do+erebosNetworkProtocol initialIdentity gLog gTestLog gDataFlow gControlFlow = do     gIdentity <- newTVarIO (initialIdentity, [])     gConnections <- newTVarIO []     gNextUp <- newEmptyTMVarIO@@ -543,6 +576,7 @@     cOutStreams <- newTVar []     let conn = Connection {..} +    gTestLog $ "net-conn-new " <> show cAddress     writeTVar gConnections (conn : conns)     return conn @@ -572,7 +606,7 @@         let parse = case B.uncons msg of                 Just (b, enc)                     | b .&. 0xE0 == 0x80 -> do-                        ch <- maybe (throwError "unexpected encrypted packet") return mbch+                        ch <- maybe (throwOtherError "unexpected encrypted packet") return mbch                         (dec, counter) <- channelDecrypt ch enc                          case B.uncons dec of@@ -587,18 +621,18 @@                                     return $ Right (snum, seq8, content, counter)                              Just (_, _) -> do-                                throwError "unexpected stream header"+                                throwOtherError "unexpected stream header"                              Nothing -> do-                                throwError "empty decrypted content"+                                throwOtherError "empty decrypted content"                      | b .&. 0xE0 == 0x60 -> do                         objs <- deserialize msg                         return $ Left (False, objs, Nothing) -                    | otherwise -> throwError "invalid packet"+                    | otherwise -> throwOtherError "invalid packet" -                Nothing -> throwError "empty packet"+                Nothing -> throwOtherError "empty packet"          now <- getTime Monotonic         runExceptT parse >>= \case@@ -649,7 +683,7 @@                     atomically $ gLog $ show addr <> ": stream packet without connection"              Left err -> do-                atomically $ gLog $ show addr <> ": failed to parse packet: " <> err+                atomically $ gLog $ show addr <> ": failed to parse packet: " <> showErebosError err  processPacket :: GlobalState addr -> Either addr (Connection addr) -> Bool -> TransportPacket a -> IO (Maybe (Connection addr, Maybe (TransportPacket a))) processPacket gs@GlobalState {..} econn secure packet@(TransportPacket (TransportHeader header) _) = if@@ -883,7 +917,7 @@                             Right (ctext, counter) -> do                                 let isAcked = any isHeaderItemAcknowledged hitems                                 return $ Just (0x80 `B.cons` ctext, if isAcked then [ AcknowledgedSingle $ fromIntegral counter ] else [])-                            Left err -> do atomically $ gLog $ "Failed to encrypt data: " ++ err+                            Left err -> do atomically $ gLog $ "Failed to encrypt data: " ++ showErebosError err                                            return Nothing                  mbs <- case (secure, mbch) of@@ -899,7 +933,10 @@                                 , rsOnAck = rsOnAck rs >> onAck                                 }) <$> mbReserved                         sendBytes conn mbReserved' bs-                    Nothing -> return ()+                    Nothing -> do+                        when (isJust mbReserved) $ do+                            atomically $ do+                                modifyTVar' cReservedPackets (subtract 1)      let waitUntil :: TimeSpec -> TimeSpec -> STM ()         waitUntil now till = do

@@ -22,7 +22,7 @@  #define DISCOVERY_MULTICAST_GROUP "ff12:b6a4:6b1f:969:caee:acc2:5c93:73e1" -uint32_t * join_multicast(int fd, size_t * count)+uint32_t * erebos_join_multicast(int fd, size_t * count) { 	size_t capacity = 16; 	*count = 0;@@ -117,7 +117,7 @@  #ifndef _WIN32 -struct InetAddress * local_addresses( size_t * count )+struct InetAddress * erebos_local_addresses( size_t * count ) { 	struct ifaddrs * addrs; 	if( getifaddrs( &addrs ) < 0 )@@ -153,7 +153,7 @@ 	return ret; } -uint32_t * broadcast_addresses(void)+uint32_t * erebos_broadcast_addresses(void) { 	struct ifaddrs * addrs; 	if (getifaddrs(&addrs) < 0)@@ -196,7 +196,7 @@  #pragma comment(lib, "ws2_32.lib") -struct InetAddress * local_addresses( size_t * count )+struct InetAddress * erebos_local_addresses( size_t * count ) { 	* count = 0; 	struct InetAddress * ret = NULL;@@ -237,7 +237,7 @@ 	return ret; } -uint32_t * broadcast_addresses(void)+uint32_t * erebos_broadcast_addresses(void) { 	uint32_t * ret = NULL; 	SOCKET wsock = INVALID_SOCKET;

@@ -13,6 +13,6 @@ 	uint8_t addr[16]; } __attribute__((packed)); -uint32_t * join_multicast(int fd, size_t * count);-struct InetAddress * local_addresses( size_t * count );-uint32_t * broadcast_addresses(void);+uint32_t * erebos_join_multicast(int fd, size_t * count);+struct InetAddress * erebos_local_addresses( size_t * count );+uint32_t * erebos_broadcast_addresses(void);

@@ -0,0 +1,23 @@+{-|+Description: Core Erebos objects and references++Data types and functions for working with "raw" Erebos objects and references.+-}++module Erebos.Object (+    Object, PartialObject, Object'(..),+    serializeObject, deserializeObject, deserializeObjects,+    ioLoadObject, ioLoadBytes,+    storeRawBytes, lazyLoadBytes,++    RecItem, RecItem'(..),++    Ref, PartialRef, RefDigest,+    refDigest, refFromDigest,+    readRef, showRef,+    readRefDigest, showRefDigest,+    refDigestFromByteString, hashToRefDigest,+    copyRef, partialRef, partialRefFromDigest,+) where++import Erebos.Object.Internal

@@ -0,0 +1,772 @@+module Erebos.Object.Internal (+    Storage, PartialStorage, StorageCompleteness,++    Ref, PartialRef, RefDigest,+    refDigest, refFromDigest,+    readRef, showRef,+    readRefDigest, showRefDigest,+    refDigestFromByteString, hashToRefDigest,+    copyRef, partialRef, partialRefFromDigest,++    Object, PartialObject, Object'(..), RecItem, RecItem'(..),+    serializeObject, deserializeObject, deserializeObjects,+    ioLoadObject, ioLoadBytes,+    storeRawBytes, lazyLoadBytes,+    storeObject,+    collectObjects, collectStoredObjects,++    MonadStorage(..),++    Storable(..), ZeroStorable(..),+    StorableText(..), StorableDate(..), StorableUUID(..),++    Store, StoreRec,+    evalStore, evalStoreObject,+    storeBlob, storeRec, storeZero,+    storeEmpty, storeInt, storeNum, storeText, storeBinary, storeDate, storeUUID, storeRef, storeRawRef, storeWeak, storeRawWeak,+    storeMbEmpty, storeMbInt, storeMbNum, storeMbText, storeMbBinary, storeMbDate, storeMbUUID, storeMbRef, storeMbRawRef, storeMbWeak, storeMbRawWeak,+    storeZRef, storeZWeak,+    storeRecItems,++    Load, LoadRec,+    evalLoad,+    loadCurrentRef, loadCurrentObject,+    loadRecCurrentRef, loadRecItems,++    loadBlob, loadRec, loadZero,+    loadEmpty, loadInt, loadNum, loadText, loadBinary, loadDate, loadUUID, loadRef, loadRawRef, loadRawWeak,+    loadMbEmpty, loadMbInt, loadMbNum, loadMbText, loadMbBinary, loadMbDate, loadMbUUID, loadMbRef, loadMbRawRef, loadMbRawWeak,+    loadTexts, loadBinaries, loadRefs, loadRawRefs, loadRawWeaks,+    loadZRef,++    Stored,+    fromStored, storedRef,+    wrappedStore, wrappedLoad,+    copyStored,+    unsafeMapStored,+) where++import Control.Applicative+import Control.Monad+import Control.Monad.Except+import Control.Monad.Reader+import Control.Monad.Writer++import Crypto.Hash++import Data.Bifunctor+import Data.ByteString (ByteString)+import qualified Data.ByteArray as BA+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as BLC+import Data.Char+import Data.Function+import Data.Maybe+import Data.Ratio+import Data.Set (Set)+import qualified Data.Set as S+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding+import Data.Text.Encoding.Error+import Data.Time.Calendar+import Data.Time.Clock+import Data.Time.Format+import Data.Time.LocalTime++import System.IO.Unsafe++import Erebos.Error+import Erebos.Storage.Internal+import Erebos.UUID (UUID)+import Erebos.UUID qualified as U+import Erebos.Util+++zeroRef :: Storage' c -> Ref' c+zeroRef s = Ref s (RefDigest h)+    where h = case digestFromByteString $ B.replicate (hashDigestSize $ digestAlgo h) 0 of+                   Nothing -> error $ "Failed to create zero hash"+                   Just h' -> h'+          digestAlgo :: Digest a -> a+          digestAlgo = undefined++isZeroRef :: Ref' c -> Bool+isZeroRef (Ref _ h) = all (==0) $ BA.unpack h+++refFromDigest :: Storage' c -> RefDigest -> IO (Maybe (Ref' c))+refFromDigest st dgst = fmap (const $ Ref st dgst) <$> ioLoadBytesFromStorage st dgst++readRef :: Storage -> ByteString -> IO (Maybe Ref)+readRef s b =+    case readRefDigest b of+         Nothing -> return Nothing+         Just dgst -> refFromDigest s dgst++copyRef' :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> Ref' c -> IO (c (Ref' c'))+copyRef' st ref'@(Ref _ dgst) = refFromDigest st dgst >>= \case Just ref -> return $ return ref+                                                                Nothing  -> doCopy+    where doCopy = do mbobj' <- ioLoadObject ref'+                      mbobj <- sequence $ copyObject' st <$> mbobj'+                      sequence $ unsafeStoreObject st <$> join mbobj++copyRecItem' :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> RecItem' c -> IO (c (RecItem' c'))+copyRecItem' st = \case+    RecEmpty -> return $ return $ RecEmpty+    RecInt x -> return $ return $ RecInt x+    RecNum x -> return $ return $ RecNum x+    RecText x -> return $ return $ RecText x+    RecBinary x -> return $ return $ RecBinary x+    RecDate x -> return $ return $ RecDate x+    RecUUID x -> return $ return $ RecUUID x+    RecRef x -> fmap RecRef <$> copyRef' st x+    RecWeak x -> return $ return $ RecWeak x+    RecUnknown t x -> return $ return $ RecUnknown t x++copyObject' :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> Object' c -> IO (c (Object' c'))+copyObject' _ (Blob bs) = return $ return $ Blob bs+copyObject' st (Rec rs) = fmap Rec . sequence <$> mapM (\( n, item ) -> fmap ( n, ) <$> copyRecItem' st item) rs+copyObject' _ ZeroObject = return $ return ZeroObject+copyObject' _ (UnknownObject otype content) = return $ return $ UnknownObject otype content++copyRef :: forall c c' m. (StorageCompleteness c, StorageCompleteness c', MonadIO m) => Storage' c' -> Ref' c -> m (LoadResult c (Ref' c'))+copyRef st ref' = liftIO $ returnLoadResult <$> copyRef' st ref'++copyRecItem :: forall c c' m. (StorageCompleteness c, StorageCompleteness c', MonadIO m) => Storage' c' -> RecItem' c -> m (LoadResult c (RecItem' c'))+copyRecItem st item' = liftIO $ returnLoadResult <$> copyRecItem' st item'++copyObject :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> Object' c -> IO (LoadResult c (Object' c'))+copyObject st obj' = returnLoadResult <$> copyObject' st obj'++partialRef :: PartialStorage -> Ref -> PartialRef+partialRef st (Ref _ dgst) = Ref st dgst++partialRefFromDigest :: PartialStorage -> RefDigest -> PartialRef+partialRefFromDigest st dgst = Ref st dgst+++data Object' c+    = Blob ByteString+    | Rec [(ByteString, RecItem' c)]+    | ZeroObject+    | UnknownObject ByteString ByteString+    deriving (Show)++type Object = Object' Complete+type PartialObject = Object' Partial++data RecItem' c+    = RecEmpty+    | RecInt Integer+    | RecNum Rational+    | RecText Text+    | RecBinary ByteString+    | RecDate ZonedTime+    | RecUUID UUID+    | RecRef (Ref' c)+    | RecWeak RefDigest+    | RecUnknown ByteString ByteString+    deriving (Show)++type RecItem = RecItem' Complete++serializeObject :: Object' c -> BL.ByteString+serializeObject = \case+    Blob cnt -> BL.fromChunks [BC.pack "blob ", BC.pack (show $ B.length cnt), BC.singleton '\n', cnt]+    Rec rec -> let cnt = BL.fromChunks $ concatMap (uncurry serializeRecItem) rec+                in BL.fromChunks [BC.pack "rec ", BC.pack (show $ BL.length cnt), BC.singleton '\n'] `BL.append` cnt+    ZeroObject -> BL.empty+    UnknownObject otype cnt -> BL.fromChunks [ otype, BC.singleton ' ', BC.pack (show $ B.length cnt), BC.singleton '\n', cnt ]++-- |Serializes and stores object data without ony dependencies, so is safe only+-- if all the referenced objects are already stored or reference is partial.+unsafeStoreObject :: Storage' c -> Object' c -> IO (Ref' c)+unsafeStoreObject storage = \case+    ZeroObject -> return $ zeroRef storage+    obj -> unsafeStoreRawBytes storage $ serializeObject obj++storeObject :: PartialStorage -> PartialObject -> IO PartialRef+storeObject = unsafeStoreObject++storeRawBytes :: PartialStorage -> BL.ByteString -> IO PartialRef+storeRawBytes = unsafeStoreRawBytes++serializeRecItem :: ByteString -> RecItem' c -> [ByteString]+serializeRecItem name (RecEmpty) = [name, BC.pack ":e", BC.singleton ' ', BC.singleton '\n']+serializeRecItem name (RecInt x) = [name, BC.pack ":i", BC.singleton ' ', BC.pack (show x), BC.singleton '\n']+serializeRecItem name (RecNum x) = [name, BC.pack ":n", BC.singleton ' ', BC.pack (showRatio x), BC.singleton '\n']+serializeRecItem name (RecText x) = [name, BC.pack ":t", BC.singleton ' ', escaped, BC.singleton '\n']+    where escaped = BC.concatMap escape $ encodeUtf8 x+          escape '\n' = BC.pack "\n\t"+          escape c    = BC.singleton c+serializeRecItem name (RecBinary x) = [name, BC.pack ":b ", showHex x, BC.singleton '\n']+serializeRecItem name (RecDate x) = [name, BC.pack ":d", BC.singleton ' ', BC.pack (formatTime defaultTimeLocale "%s %z" x), BC.singleton '\n']+serializeRecItem name (RecUUID x) = [name, BC.pack ":u", BC.singleton ' ', U.toASCIIBytes x, BC.singleton '\n']+serializeRecItem name (RecRef x) = [name, BC.pack ":r ", showRef x, BC.singleton '\n']+serializeRecItem name (RecWeak x) = [name, BC.pack ":w ", showRefDigest x, BC.singleton '\n']+serializeRecItem name (RecUnknown t x) = [ name, BC.singleton ':', t, BC.singleton ' ', x, BC.singleton '\n' ]++lazyLoadObject :: forall c. StorageCompleteness c => Ref' c -> LoadResult c (Object' c)+lazyLoadObject = returnLoadResult . unsafePerformIO . ioLoadObject++ioLoadObject :: forall c. StorageCompleteness c => Ref' c -> IO (c (Object' c))+ioLoadObject ref | isZeroRef ref = return $ return ZeroObject+ioLoadObject ref@(Ref st rhash) = do+    file' <- ioLoadBytes ref+    return $ do+        file <- file'+        let chash = hashToRefDigest file+        when (chash /= rhash) $ error $ "Hash mismatch on object " ++ BC.unpack (showRef ref) {- TODO throw -}+        return $ case runExcept $ unsafeDeserializeObject st file of+                      Left err -> error $ showErebosError err ++ ", ref " ++ BC.unpack (showRef ref) {- TODO throw -}+                      Right (x, rest) | BL.null rest -> x+                                      | otherwise -> error $ "Superfluous content after " ++ BC.unpack (showRef ref) {- TODO throw -}++lazyLoadBytes :: forall c. StorageCompleteness c => Ref' c -> LoadResult c BL.ByteString+lazyLoadBytes ref | isZeroRef ref = returnLoadResult (return BL.empty :: c BL.ByteString)+lazyLoadBytes ref = returnLoadResult $ unsafePerformIO $ ioLoadBytes ref++unsafeDeserializeObject :: Storage' c -> BL.ByteString -> Except ErebosError (Object' c, BL.ByteString)+unsafeDeserializeObject _  bytes | BL.null bytes = return (ZeroObject, bytes)+unsafeDeserializeObject st bytes =+    case BLC.break (=='\n') bytes of+        (line, rest) | Just (otype, len) <- splitObjPrefix line -> do+            let (content, next) = first BL.toStrict $ BL.splitAt (fromIntegral len) $ BL.drop 1 rest+            guard $ B.length content == len+            (,next) <$> case otype of+                 _ | otype == BC.pack "blob" -> return $ Blob content+                   | otype == BC.pack "rec" -> maybe (throwOtherError $ "malformed record item ")+                                                   (return . Rec) $ sequence $ map parseRecLine $ mergeCont [] $ BC.lines content+                   | otherwise -> return $ UnknownObject otype content+        _ -> throwOtherError $ "malformed object"+    where splitObjPrefix line = do+              [otype, tlen] <- return $ BLC.words line+              (len, rest) <- BLC.readInt tlen+              guard $ BL.null rest+              return (BL.toStrict otype, len)++          mergeCont cs (a:b:rest) | Just ('\t', b') <- BC.uncons b = mergeCont (b':BC.pack "\n":cs) (a:rest)+          mergeCont cs (a:rest) = B.concat (a : reverse cs) : mergeCont [] rest+          mergeCont _ [] = []++          parseRecLine line = do+              colon <- BC.elemIndex ':' line+              space <- BC.elemIndex ' ' line+              guard $ colon < space+              let name = B.take colon line+                  itype = B.take (space-colon-1) $ B.drop (colon+1) line+                  content = B.drop (space+1) line++              let val = fromMaybe (RecUnknown itype content) $+                      case BC.unpack itype of+                          "e" -> do guard $ B.null content+                                    return RecEmpty+                          "i" -> do (num, rest) <- BC.readInteger content+                                    guard $ B.null rest+                                    return $ RecInt num+                          "n" -> RecNum <$> parseRatio content+                          "t" -> return $ RecText $ decodeUtf8With lenientDecode content+                          "b" -> RecBinary <$> readHex content+                          "d" -> RecDate <$> parseTimeM False defaultTimeLocale "%s %z" (BC.unpack content)+                          "u" -> RecUUID <$> U.fromASCIIBytes content+                          "r" -> RecRef . Ref st <$> readRefDigest content+                          "w" -> RecWeak <$> readRefDigest content+                          _   -> Nothing+              return (name, val)++deserializeObject :: PartialStorage -> BL.ByteString -> Except ErebosError (PartialObject, BL.ByteString)+deserializeObject = unsafeDeserializeObject++deserializeObjects :: PartialStorage -> BL.ByteString -> Except ErebosError [PartialObject]+deserializeObjects _  bytes | BL.null bytes = return []+deserializeObjects st bytes = do (obj, rest) <- deserializeObject st bytes+                                 (obj:) <$> deserializeObjects st rest+++collectObjects :: Object -> [Object]+collectObjects obj = obj : map fromStored (fst $ collectOtherStored S.empty obj)++collectStoredObjects :: Stored Object -> [Stored Object]+collectStoredObjects obj = obj : (fst $ collectOtherStored S.empty $ fromStored obj)++collectOtherStored :: Set RefDigest -> Object -> ([Stored Object], Set RefDigest)+collectOtherStored seen (Rec items) = foldr helper ([], seen) $ map snd items+    where helper (RecRef ref) (xs, s) | r <- refDigest ref+                                      , r `S.notMember` s+                                      = let o = wrappedLoad ref+                                            (xs', s') = collectOtherStored (S.insert r s) $ fromStored o+                                         in ((o : xs') ++ xs, s')+          helper _          (xs, s) = (xs, s)+collectOtherStored seen _ = ([], seen)+++deriving instance StorableUUID HeadID+deriving instance StorableUUID HeadTypeID+++class Monad m => MonadStorage m where+    getStorage :: m Storage+    mstore :: Storable a => a -> m (Stored a)++    default mstore :: MonadIO m => Storable a => a -> m (Stored a)+    mstore x = do+        st <- getStorage+        wrappedStore st x++instance MonadIO m => MonadStorage (ReaderT Storage m) where+    getStorage = ask+++class Storable a where+    store' :: a -> Store+    load' :: Load a++    store :: StorageCompleteness c => Storage' c -> a -> IO (Ref' c)+    store st = evalStore st . store'+    load :: Ref -> a+    load = evalLoad load'++class Storable a => ZeroStorable a where+    fromZero :: Storage -> a++data Store = StoreBlob ByteString+           | StoreRec (forall c. StorageCompleteness c => Storage' c -> [IO [(ByteString, RecItem' c)]])+           | StoreZero+           | StoreUnknown ByteString ByteString++evalStore :: StorageCompleteness c => Storage' c -> Store -> IO (Ref' c)+evalStore st = unsafeStoreObject st <=< evalStoreObject st++evalStoreObject :: StorageCompleteness c => Storage' c -> Store -> IO (Object' c)+evalStoreObject _ (StoreBlob x) = return $ Blob x+evalStoreObject s (StoreRec f) = Rec . concat <$> sequence (f s)+evalStoreObject _ StoreZero = return ZeroObject+evalStoreObject _ (StoreUnknown otype content) = return $ UnknownObject otype content++newtype StoreRecM c a = StoreRecM (ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) a)+    deriving (Functor, Applicative, Monad)++type StoreRec c = StoreRecM c ()++newtype Load a = Load (ReaderT (Ref, Object) (Except ErebosError) a)+    deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadError ErebosError)++evalLoad :: Load a -> Ref -> a+evalLoad (Load f) ref = either (error {- TODO throw -} . ((BC.unpack (showRef ref) ++ ": ") ++) . showErebosError) id $+    runExcept $ runReaderT f (ref, lazyLoadObject ref)++loadCurrentRef :: Load Ref+loadCurrentRef = Load $ asks fst++loadCurrentObject :: Load Object+loadCurrentObject = Load $ asks snd++newtype LoadRec a = LoadRec (ReaderT (Ref, [(ByteString, RecItem)]) (Except ErebosError) a)+    deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadError ErebosError)++loadRecCurrentRef :: LoadRec Ref+loadRecCurrentRef = LoadRec $ asks fst++loadRecItems :: LoadRec [(ByteString, RecItem)]+loadRecItems = LoadRec $ asks snd+++instance Storable Object where+    store' (Blob bs) = StoreBlob bs+    store' (Rec xs) = StoreRec $ \st -> return $ do+        Rec xs' <- copyObject st (Rec xs)+        return xs'+    store' ZeroObject = StoreZero+    store' (UnknownObject otype content) = StoreUnknown otype content++    load' = loadCurrentObject++    store st = unsafeStoreObject st <=< copyObject st+    load = lazyLoadObject++instance Storable ByteString where+    store' = storeBlob+    load' = loadBlob id++instance Storable a => Storable [a] where+    store' []     = storeZero+    store' (x:xs) = storeRec $ do+        storeRef "i" x+        storeRef "n" xs++    load' = loadCurrentObject >>= \case+                ZeroObject -> return []+                _          -> loadRec $ (:)+                                  <$> loadRef "i"+                                  <*> loadRef "n"++instance Storable a => ZeroStorable [a] where+    fromZero _ = []+++storeBlob :: ByteString -> Store+storeBlob = StoreBlob++storeRec :: (forall c. StorageCompleteness c => StoreRec c) -> Store+storeRec sr = StoreRec $ do+    let StoreRecM r = sr+    execWriter . runReaderT r++storeZero :: Store+storeZero = StoreZero+++class StorableText a where+    toText :: a -> Text+    fromText :: MonadError ErebosError m => Text -> m a++instance StorableText Text where+    toText = id; fromText = return++instance StorableText [Char] where+    toText = T.pack; fromText = return . T.unpack+++class StorableDate a where+    toDate :: a -> ZonedTime+    fromDate :: ZonedTime -> a++instance StorableDate ZonedTime where+    toDate = id; fromDate = id++instance StorableDate UTCTime where+    toDate = utcToZonedTime utc+    fromDate = zonedTimeToUTC++instance StorableDate Day where+    toDate day = toDate $ UTCTime day 0+    fromDate = utctDay . fromDate+++class StorableUUID a where+    toUUID :: a -> UUID+    fromUUID :: UUID -> a++instance StorableUUID UUID where+    toUUID = id; fromUUID = id+++storeEmpty :: String -> StoreRec c+storeEmpty name = StoreRecM $ tell [return [(BC.pack name, RecEmpty)]]++storeMbEmpty :: String -> Maybe () -> StoreRec c+storeMbEmpty name = maybe (return ()) (const $ storeEmpty name)++storeInt :: Integral a => String -> a -> StoreRec c+storeInt name x = StoreRecM $ tell [return [(BC.pack name, RecInt $ toInteger x)]]++storeMbInt :: Integral a => String -> Maybe a -> StoreRec c+storeMbInt name = maybe (return ()) (storeInt name)++storeNum :: (Real a, Fractional a) => String -> a -> StoreRec c+storeNum name x = StoreRecM $ tell [return [(BC.pack name, RecNum $ toRational x)]]++storeMbNum :: (Real a, Fractional a) => String -> Maybe a -> StoreRec c+storeMbNum name = maybe (return ()) (storeNum name)++storeText :: StorableText a => String -> a -> StoreRec c+storeText name x = StoreRecM $ tell [return [(BC.pack name, RecText $ toText x)]]++storeMbText :: StorableText a => String -> Maybe a -> StoreRec c+storeMbText name = maybe (return ()) (storeText name)++storeBinary :: BA.ByteArrayAccess a => String -> a -> StoreRec c+storeBinary name x = StoreRecM $ tell [return [(BC.pack name, RecBinary $ BA.convert x)]]++storeMbBinary :: BA.ByteArrayAccess a => String -> Maybe a -> StoreRec c+storeMbBinary name = maybe (return ()) (storeBinary name)++storeDate :: StorableDate a => String -> a -> StoreRec c+storeDate name x = StoreRecM $ tell [return [(BC.pack name, RecDate $ toDate x)]]++storeMbDate :: StorableDate a => String -> Maybe a -> StoreRec c+storeMbDate name = maybe (return ()) (storeDate name)++storeUUID :: StorableUUID a => String -> a -> StoreRec c+storeUUID name x = StoreRecM $ tell [return [(BC.pack name, RecUUID $ toUUID x)]]++storeMbUUID :: StorableUUID a => String -> Maybe a -> StoreRec c+storeMbUUID name = maybe (return ()) (storeUUID name)++storeRef :: Storable a => StorageCompleteness c => String -> a -> StoreRec c+storeRef name x = StoreRecM $ do+    s <- ask+    tell $ (:[]) $ do+        ref <- store s x+        return [(BC.pack name, RecRef ref)]++storeMbRef :: Storable a => StorageCompleteness c => String -> Maybe a -> StoreRec c+storeMbRef name = maybe (return ()) (storeRef name)++storeRawRef :: StorageCompleteness c => String -> Ref -> StoreRec c+storeRawRef name ref = StoreRecM $ do+    st <- ask+    tell $ (:[]) $ do+        ref' <- copyRef st ref+        return [(BC.pack name, RecRef ref')]++storeMbRawRef :: StorageCompleteness c => String -> Maybe Ref -> StoreRec c+storeMbRawRef name = maybe (return ()) (storeRawRef name)++storeZRef :: (ZeroStorable a, StorageCompleteness c) => String -> a -> StoreRec c+storeZRef name x = StoreRecM $ do+    s <- ask+    tell $ (:[]) $ do+        ref <- store s x+        return $ if isZeroRef ref then []+                                  else [(BC.pack name, RecRef ref)]++storeWeak :: Storable a => StorageCompleteness c => String -> a -> StoreRec c+storeWeak name x = StoreRecM $ do+    s <- ask+    tell $ (:[]) $ do+        ref <- store s x+        return [ ( BC.pack name, RecWeak $ refDigest ref ) ]++storeMbWeak :: Storable a => StorageCompleteness c => String -> Maybe a -> StoreRec c+storeMbWeak name = maybe (return ()) (storeWeak name)++storeRawWeak :: StorageCompleteness c => String -> RefDigest -> StoreRec c+storeRawWeak name dgst = StoreRecM $ do+    tell $ (:[]) $ do+        return [ ( BC.pack name, RecWeak dgst ) ]++storeMbRawWeak :: StorageCompleteness c => String -> Maybe RefDigest -> StoreRec c+storeMbRawWeak name = maybe (return ()) (storeRawWeak name)++storeZWeak :: (ZeroStorable a, StorageCompleteness c) => String -> a -> StoreRec c+storeZWeak name x = StoreRecM $ do+    s <- ask+    tell $ (:[]) $ do+        ref <- store s x+        return $ if isZeroRef ref then []+                                  else [ ( BC.pack name, RecWeak $ refDigest ref ) ]+++storeRecItems :: StorageCompleteness c => [ ( ByteString, RecItem ) ] -> StoreRec c+storeRecItems items = StoreRecM $ do+    st <- ask+    tell $ flip map items $ \( name, value ) -> do+        value' <- copyRecItem st value+        return [ ( name, value' ) ]++loadBlob :: (ByteString -> a) -> Load a+loadBlob f = loadCurrentObject >>= \case+    Blob x -> return $ f x+    _      -> throwOtherError "Expecting blob"++loadRec :: LoadRec a -> Load a+loadRec (LoadRec lrec) = loadCurrentObject >>= \case+    Rec rs -> do+        ref <- loadCurrentRef+        either throwError return $ runExcept $ runReaderT lrec (ref, rs)+    _ -> throwOtherError "Expecting record"++loadZero :: a -> Load a+loadZero x = loadCurrentObject >>= \case+    ZeroObject -> return x+    _          -> throwOtherError "Expecting zero"+++loadEmpty :: String -> LoadRec ()+loadEmpty name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbEmpty name++loadMbEmpty :: String -> LoadRec (Maybe ())+loadMbEmpty name = listToMaybe . mapMaybe p <$> loadRecItems+  where+    bname = BC.pack name+    p ( name', RecEmpty ) | name' == bname+        = Just ()+    p _ = Nothing++loadInt :: Num a => String -> LoadRec a+loadInt name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbInt name++loadMbInt :: Num a => String -> LoadRec (Maybe a)+loadMbInt name = listToMaybe . mapMaybe p <$> loadRecItems+  where+    bname = BC.pack name+    p ( name', RecInt x ) | name' == bname+        = Just (fromInteger x)+    p _ = Nothing++loadNum :: (Real a, Fractional a) => String -> LoadRec a+loadNum name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbNum name++loadMbNum :: (Real a, Fractional a) => String -> LoadRec (Maybe a)+loadMbNum name = listToMaybe . mapMaybe p <$> loadRecItems+  where+    bname = BC.pack name+    p ( name', RecNum x ) | name' == bname+        = Just (fromRational x)+    p _ = Nothing++loadText :: StorableText a => String -> LoadRec a+loadText name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbText name++loadMbText :: StorableText a => String -> LoadRec (Maybe a)+loadMbText name = listToMaybe <$> loadTexts name++loadTexts :: StorableText a => String -> LoadRec [a]+loadTexts name = sequence . mapMaybe p =<< loadRecItems+  where+    bname = BC.pack name+    p ( name', RecText x ) | name' == bname+        = Just (fromText x)+    p _ = Nothing++loadBinary :: BA.ByteArray a => String -> LoadRec a+loadBinary name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbBinary name++loadMbBinary :: BA.ByteArray a => String -> LoadRec (Maybe a)+loadMbBinary name = listToMaybe <$> loadBinaries name++loadBinaries :: BA.ByteArray a => String -> LoadRec [a]+loadBinaries name = mapMaybe p <$> loadRecItems+  where+    bname = BC.pack name+    p ( name', RecBinary x ) | name' == bname+        = Just (BA.convert x)+    p _ = Nothing++loadDate :: StorableDate a => String -> LoadRec a+loadDate name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbDate name++loadMbDate :: StorableDate a => String -> LoadRec (Maybe a)+loadMbDate name = listToMaybe . mapMaybe p <$> loadRecItems+  where+    bname = BC.pack name+    p ( name', RecDate x ) | name' == bname+        = Just (fromDate x)+    p _ = Nothing++loadUUID :: StorableUUID a => String -> LoadRec a+loadUUID name = maybe (throwOtherError $ "Missing record iteem '"++name++"'") return =<< loadMbUUID name++loadMbUUID :: StorableUUID a => String -> LoadRec (Maybe a)+loadMbUUID name = listToMaybe . mapMaybe p <$> loadRecItems+  where+    bname = BC.pack name+    p ( name', RecUUID x ) | name' == bname+        = Just (fromUUID x)+    p _ = Nothing++loadRawRef :: String -> LoadRec Ref+loadRawRef name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbRawRef name++loadMbRawRef :: String -> LoadRec (Maybe Ref)+loadMbRawRef name = listToMaybe <$> loadRawRefs name++loadRawRefs :: String -> LoadRec [Ref]+loadRawRefs name = mapMaybe p <$> loadRecItems+  where+    bname = BC.pack name+    p ( name', RecRef x ) | name' == bname = Just x+    p _                                    = Nothing++loadRef :: Storable a => String -> LoadRec a+loadRef name = load <$> loadRawRef name++loadMbRef :: Storable a => String -> LoadRec (Maybe a)+loadMbRef name = fmap load <$> loadMbRawRef name++loadRefs :: Storable a => String -> LoadRec [a]+loadRefs name = map load <$> loadRawRefs name++loadZRef :: ZeroStorable a => String -> LoadRec a+loadZRef name = loadMbRef name >>= \case+                    Nothing -> do Ref st _ <- loadRecCurrentRef+                                  return $ fromZero st+                    Just x  -> return x++loadRawWeak :: String -> LoadRec RefDigest+loadRawWeak name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbRawWeak name++loadMbRawWeak :: String -> LoadRec (Maybe RefDigest)+loadMbRawWeak name = listToMaybe <$> loadRawWeaks name++loadRawWeaks :: String -> LoadRec [ RefDigest ]+loadRawWeaks name = mapMaybe p <$> loadRecItems+  where+    bname = BC.pack name+    p ( name', RecRef x )  | name' == bname = Just (refDigest x)+    p ( name', RecWeak x ) | name' == bname = Just x+    p _                                     = Nothing++++instance Storable a => Storable (Stored a) where+    store st = copyRef st . storedRef+    store' (Stored _ x) = store' x+    load' = Stored <$> loadCurrentRef <*> load'++instance ZeroStorable a => ZeroStorable (Stored a) where+    fromZero st = Stored (zeroRef st) $ fromZero st++fromStored :: Stored a -> a+fromStored = storedObject'++storedRef :: Stored a -> Ref+storedRef = storedRef'++wrappedStore :: MonadIO m => Storable a => Storage -> a -> m (Stored a)+wrappedStore st x = do ref <- liftIO $ store st x+                       return $ Stored ref x++wrappedLoad :: Storable a => Ref -> Stored a+wrappedLoad ref = Stored ref (load ref)++copyStored :: forall m a. MonadIO m => Storage -> Stored a -> m (Stored a)+copyStored st (Stored ref' x) = liftIO $ returnLoadResult . fmap (\r -> Stored r x) <$> copyRef' st ref'++-- |Passed function needs to preserve the object representation to be safe+unsafeMapStored :: (a -> b) -> Stored a -> Stored b+unsafeMapStored f (Stored ref x) = Stored ref (f x)+++showRatio :: Rational -> String+showRatio r = case decimalRatio r of+                   Just (n, 1) -> show n+                   Just (n', d) -> let n = abs n'+                                    in (if n' < 0 then "-" else "") ++ show (n `div` d) ++ "." +++                                       (concatMap (show.(`mod` 10).snd) $ reverse $ takeWhile ((>1).fst) $ zip (iterate (`div` 10) d) (iterate (`div` 10) (n `mod` d)))+                   Nothing -> show (numerator r) ++ "/" ++ show (denominator r)++decimalRatio :: Rational -> Maybe (Integer, Integer)+decimalRatio r = do+    let n = numerator r+        d = denominator r+        (c2, d') = takeFactors 2 d+        (c5, d'') = takeFactors 5 d'+    guard $ d'' == 1+    let m = if c2 > c5 then 5 ^ (c2 - c5)+                       else 2 ^ (c5 - c2)+    return (n * m, d * m)++takeFactors :: Integer -> Integer -> (Integer, Integer)+takeFactors f n | n `mod` f == 0 = let (c, n') = takeFactors f (n `div` f)+                                    in (c+1, n')+                | otherwise = (0, n)++parseRatio :: ByteString -> Maybe Rational+parseRatio bs = case BC.groupBy ((==) `on` isNumber) bs of+                     (m:xs) | m == BC.pack "-" -> negate <$> positive xs+                     xs                        -> positive xs+    where positive = \case+              [bx] -> fromInteger . fst <$> BC.readInteger bx+              [bx, op, by] -> do+                  (x, _) <- BC.readInteger bx+                  (y, _) <- BC.readInteger by+                  case BC.unpack op of+                       "." -> return $ (x % 1) + (y % (10 ^ BC.length by))+                       "/" -> return $ x % y+                       _   -> Nothing+              _ -> Nothing

@@ -17,9 +17,10 @@ import Crypto.Random  import Data.Bits-import Data.ByteArray (Bytes, convert)-import qualified Data.ByteArray as BA-import qualified Data.ByteString.Char8 as BC+import Data.ByteArray qualified as BA+import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.ByteString.Char8 qualified as BC import Data.Kind import Data.Maybe import Data.Typeable@@ -27,28 +28,29 @@  import Erebos.Identity import Erebos.Network+import Erebos.Object import Erebos.PubKey import Erebos.Service import Erebos.State-import Erebos.Storage+import Erebos.Storable  data PairingService a = PairingRequest (Stored (Signed IdentityData)) (Stored (Signed IdentityData)) RefDigest-                      | PairingResponse Bytes-                      | PairingRequestNonce Bytes+                      | PairingResponse ByteString+                      | PairingRequestNonce ByteString                       | PairingAccept a                       | PairingReject  data PairingState a = NoPairing-                    | OurRequest UnifiedIdentity UnifiedIdentity Bytes+                    | OurRequest UnifiedIdentity UnifiedIdentity ByteString                     | OurRequestConfirm (Maybe (PairingVerifiedResult a))                     | OurRequestReady-                    | PeerRequest UnifiedIdentity UnifiedIdentity Bytes RefDigest+                    | PeerRequest UnifiedIdentity UnifiedIdentity ByteString RefDigest                     | PeerRequestConfirm                     | PairingDone  data PairingFailureReason a = PairingUserRejected                             | PairingUnexpectedMessage (PairingState a) (PairingService a)-                            | PairingFailedOther String+                            | PairingFailedOther ErebosError  data PairingAttributes a = PairingAttributes     { pairingHookRequest :: ServiceHandler (PairingService a) ()@@ -87,7 +89,7 @@      load' = do         res <- loadRec $ do-            (req :: Maybe Bytes) <- loadMbBinary "request"+            (req :: Maybe ByteString) <- loadMbBinary "request"             idReq <- loadMbRef "id-req"             idRsp <- loadMbRef "id-rsp"             rsp <- loadMbBinary "response"@@ -115,16 +117,16 @@      serviceHandler spacket = ((,fromStored spacket) <$> svcGet) >>= \case         (NoPairing, PairingRequest pdata sdata confirm) -> do-            self <- maybe (throwError "failed to validate received identity") return $ validateIdentity sdata-            self' <- maybe (throwError "failed to validate own identity") return .+            self <- maybe (throwOtherError "failed to validate received identity") return $ validateIdentity sdata+            self' <- maybe (throwOtherError "failed to validate own identity") return .                 validateExtendedIdentity . lsIdentity . fromStored =<< svcGetLocal             when (not $ self `sameIdentity` self') $ do-                throwError "pairing request to different identity"+                throwOtherError "pairing request to different identity" -            peer <- maybe (throwError "failed to validate received peer identity") return $ validateIdentity pdata+            peer <- maybe (throwOtherError "failed to validate received peer identity") return $ validateIdentity pdata             peer' <- asks $ svcPeerIdentity             when (not $ peer `sameIdentity` peer') $ do-                throwError "pairing request from different identity"+                throwOtherError "pairing request from different identity"              join $ asks $ pairingHookRequest . svcAttributes             nonce <- liftIO $ getRandomBytes 32@@ -166,11 +168,11 @@                         svcSet $ PairingDone                     Nothing -> do                         join $ asks $ pairingHookVerifyFailed . svcAttributes-                        throwError ""+                        throwOtherError ""         x@(OurRequestReady, _) -> reject $ uncurry PairingUnexpectedMessage x          (PeerRequest peer self nonce dgst, PairingRequestNonce pnonce) -> do-            if dgst == nonceDigest peer self pnonce BA.empty+            if dgst == nonceDigest peer self pnonce BS.empty                then do hook <- asks $ pairingHookRequestNonce . svcAttributes                        hook $ confirmationNumber $ nonceDigest peer self pnonce nonce                        svcSet PeerRequestConfirm@@ -187,12 +189,12 @@     replyPacket PairingReject  -nonceDigest :: UnifiedIdentity -> UnifiedIdentity -> Bytes -> Bytes -> RefDigest+nonceDigest :: UnifiedIdentity -> UnifiedIdentity -> ByteString -> ByteString -> RefDigest nonceDigest idReq idRsp nonceReq nonceRsp = hashToRefDigest $ serializeObject $ Rec         [ (BC.pack "id-req", RecRef $ storedRef $ idData idReq)         , (BC.pack "id-rsp", RecRef $ storedRef $ idData idRsp)-        , (BC.pack "nonce-req", RecBinary $ convert nonceReq)-        , (BC.pack "nonce-rsp", RecBinary $ convert nonceRsp)+        , (BC.pack "nonce-req", RecBinary nonceReq)+        , (BC.pack "nonce-rsp", RecBinary nonceRsp)         ]  confirmationNumber :: RefDigest -> String@@ -203,22 +205,22 @@          _ -> ""     where len = 6 -pairingRequest :: forall a m proxy. (PairingResult a, MonadIO m, MonadError String m) => proxy a -> Peer -> m ()+pairingRequest :: forall a m e proxy. (PairingResult a, MonadIO m, MonadError e m, FromErebosError e) => proxy a -> Peer -> m () pairingRequest _ peer = do     self <- liftIO $ serverIdentity $ peerServer peer     nonce <- liftIO $ getRandomBytes 32-    pid <- peerIdentity peer >>= \case+    pid <- getPeerIdentity peer >>= \case         PeerIdentityFull pid -> return pid-        _ -> throwError "incomplete peer identity"+        _ -> throwOtherError "incomplete peer identity"     sendToPeerWith @(PairingService a) peer $ \case-        NoPairing -> return (Just $ PairingRequest (idData self) (idData pid) (nonceDigest self pid nonce BA.empty), OurRequest self pid nonce)-        _ -> throwError "already in progress"+        NoPairing -> return (Just $ PairingRequest (idData self) (idData pid) (nonceDigest self pid nonce BS.empty), OurRequest self pid nonce)+        _ -> throwOtherError "already in progress" -pairingAccept :: forall a m proxy. (PairingResult a, MonadIO m, MonadError String m) => proxy a -> Peer -> m ()+pairingAccept :: forall a m e proxy. (PairingResult a, MonadIO m, MonadError e m, FromErebosError e) => proxy a -> Peer -> m () pairingAccept _ peer = runPeerService @(PairingService a) peer $ do     svcGet >>= \case-        NoPairing -> throwError $ "none in progress"-        OurRequest {} -> throwError $ "waiting for peer"+        NoPairing -> throwOtherError $ "none in progress"+        OurRequest {} -> throwOtherError $ "waiting for peer"         OurRequestConfirm Nothing -> do             join $ asks $ pairingHookConfirmedResponse . svcAttributes             svcSet OurRequestReady@@ -226,17 +228,17 @@             join $ asks $ pairingHookAcceptedResponse . svcAttributes             pairingFinalizeRequest verified             svcSet PairingDone-        OurRequestReady -> throwError $ "already accepted, waiting for peer"-        PeerRequest {} -> throwError $ "waiting for peer"+        OurRequestReady -> throwOtherError $ "already accepted, waiting for peer"+        PeerRequest {} -> throwOtherError $ "waiting for peer"         PeerRequestConfirm -> do             join $ asks $ pairingHookAcceptedRequest . svcAttributes             replyPacket . PairingAccept =<< pairingFinalizeResponse             svcSet PairingDone-        PairingDone -> throwError $ "already done"+        PairingDone -> throwOtherError $ "already done" -pairingReject :: forall a m proxy. (PairingResult a, MonadIO m, MonadError String m) => proxy a -> Peer -> m ()+pairingReject :: forall a m e proxy. (PairingResult a, MonadIO m, MonadError e m, FromErebosError e) => proxy a -> Peer -> m () pairingReject _ peer = runPeerService @(PairingService a) peer $ do     svcGet >>= \case-        NoPairing -> throwError $ "none in progress"-        PairingDone -> throwError $ "already done"+        NoPairing -> throwOtherError $ "none in progress"+        PairingDone -> throwOtherError $ "already done"         _ -> reject PairingUserRejected