erebos 0.2.0 → 0.2.1

raw patch · 30 files changed

+1649/−315 lines, 30 filesdep ~mtlPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: mtl

API changes (from Hackage documentation)

Files

• CHANGELOG.md +11/−1
• README.md +15/−1
• erebos.cabal +8/−13
• main/Main.hs +218/−89
• main/State.hs +8/−5
• main/Terminal.hs +92/−54
• main/Test.hs +112/−6
• main/Test/Service.hs +13/−0
• main/WebSocket.hs +12/−2
• src/Erebos/Chatroom.hs +12/−0
• src/Erebos/Contact.hs +2/−0
• src/Erebos/Conversation.hs +36/−17
• src/Erebos/Conversation/Class.hs +20/−0
• src/Erebos/DirectMessage.hs +60/−9
• src/Erebos/Discovery.hs +69/−17
• src/Erebos/Error.hs +12/−2
• src/Erebos/Identity.hs +3/−3
• src/Erebos/Invite.hs +385/−0
• src/Erebos/Network.hs +65/−34
• src/Erebos/Network/Protocol.hs +15/−3
• src/Erebos/Network/Protocol.hs-boot +6/−0
• src/Erebos/Object.hs +38/−0
• src/Erebos/Object/Deferred.hs +108/−0
• src/Erebos/Object/Internal.hs +95/−50
• src/Erebos/Storable.hs +2/−1
• src/Erebos/Storage/Backend.hs +12/−0
• src/Erebos/Storage/Internal.hs +0/−8
• src/Erebos/TextFormat.hs +79/−0
• src/Erebos/TextFormat/Ansi.hs +83/−0
• src/Erebos/TextFormat/Types.hs +58/−0

@@ -1,5 +1,15 @@ # Revision history for erebos +## 0.2.1 -- 2026-03-15++* Initial support for `ondemand` object type.+* New service and shared state for invites.+* Show the number of conversations with unread messages in CLI prompt.+* Show unread messages when selecting conversation.+* Added `/new` command to list conversations with new (unread) messages.+* Gracefully handle invalid record objects.+* Fixes and improvements in discovery service and tunnel support.+ ## 0.2.0 -- 2025-08-06  * Weak references in records@@ -11,7 +21,7 @@     * Print received messages only for selected conversation     * Clear tab completion options after use -* API+* Library API     * Split `Erebos.Storage` into multiple modules     * Removed deprecated `Message.formatMessage` alias     * Renamed `Erebos.Message` module to `Erebos.DirectMessage`

@@ -95,6 +95,9 @@ `/conversations`   : List started conversations with contacts or other peers. +`/new`+: List conversations with new (unread) messages.+ `/<number>`   : Select conversation, contact or peer `<number>` based on the last   `/conversations`, `/contacts` or `/peers` output list.@@ -147,7 +150,7 @@   history, but the chatroom will no longer be listed as available and no futher   updates for this chatroom will be collected or shared with other peers. -### Add contacts+### Contact list  To ensure the identity of the contact and prevent man-in-the-middle attack, generated verification code needs to be confirmed on both devices to add@@ -171,6 +174,17 @@  `/contact-reject`   : Reject contact request or verification code of selected peer.++`/invite-contact <name>`+: Create an invite in the form of URL, which can be sent via means outside of+  the erebos protocol. The recipient can accept it using the `invite-accept`+  command. After accepting, contact entry is created with the given `<name>`.+  The created invite can be used only once.++`/invite-accept <URL>`+: Accept received URL-formatted invite. The erebos tool will try to find and+  connect to a device belonging to the issuing identity to confirm the invite.+  If successful, corresponding contact entry will be created.  ### Attach other devices 

@@ -1,7 +1,7 @@ Cabal-Version:       3.0  Name:                erebos-Version:             0.2.0+Version:             0.2.1 Synopsis:            Decentralized messaging and synchronization Description:     Library and simple CLI interface implementing the Erebos identity@@ -34,11 +34,6 @@ Flag ice     Description:    Enable peer discovery with ICE support using pjproject -Flag ci-    description:    Options for CI testing-    default: False-    manual: True- Flag cryptonite     description:    Use deprecated 'cryptonite' package     default: False@@ -53,12 +48,6 @@         -Wno-x-partial         -fdefer-typed-holes -    if flag(ci)-        ghc-options:-            -Werror-            -- sometimes needed for backward/forward compatibility:-            -Wno-error=unused-imports-     build-depends:         base ^>= { 4.15, 4.16, 4.17, 4.18, 4.19, 4.20, 4.21 }, @@ -107,8 +96,10 @@         Erebos.Discovery         Erebos.Error         Erebos.Identity+        Erebos.Invite         Erebos.Network         Erebos.Object+        Erebos.Object.Deferred         Erebos.Pairing         Erebos.PubKey         Erebos.Service@@ -122,8 +113,11 @@         Erebos.Storage.Key         Erebos.Storage.Merge         Erebos.Sync+        Erebos.TextFormat+        Erebos.TextFormat.Ansi      other-modules:+        Erebos.Conversation.Class         Erebos.Flow         Erebos.Network.Address         Erebos.Network.Channel@@ -133,6 +127,7 @@         Erebos.Storage.Internal         Erebos.Storage.Memory         Erebos.Storage.Platform+        Erebos.TextFormat.Types         Erebos.UUID         Erebos.Util @@ -169,7 +164,7 @@         hashtables ^>= { 1.2, 1.3, 1.4 },         iproute >=1.7.12 && <1.8,         memory >=0.14 && <0.19,-        mtl >=2.2 && <2.4,+        mtl ^>= { 2.2.2, 2.3 },         network ^>= { 3.1, 3.2 },         stm >=2.5 && <2.6,         text >= 1.2 && <2.2,

@@ -37,12 +37,13 @@ import System.IO  import Erebos.Attach-import Erebos.Contact import Erebos.Chatroom+import Erebos.Contact import Erebos.Conversation import Erebos.DirectMessage import Erebos.Discovery import Erebos.Identity+import Erebos.Invite import Erebos.Network import Erebos.Object import Erebos.PubKey@@ -53,6 +54,7 @@ import Erebos.Storage import Erebos.Storage.Merge import Erebos.Sync+import Erebos.TextFormat  import State import Terminal@@ -72,9 +74,10 @@     , optShowVersion :: Bool     } -data StorageOption = DefaultStorage-                   | FilesystemStorage FilePath-                   | MemoryStorage+data StorageOption+    = DefaultStorage+    | FilesystemStorage FilePath+    | MemoryStorage  data ServiceOption = ServiceOption     { soptName :: String@@ -110,14 +113,16 @@         True "direct messages"     , ServiceOption "discovery" (someService @DiscoveryService Proxy)         True "peer discovery"+    , ServiceOption "invite" (someService @InviteService Proxy)+        True "invites handling"     ]  options :: [ OptDescr (Options -> Writer [ String ] Options) ] options =-    [ Option ['p'] ["port"]+    [ Option [ 'p' ] [ "port" ]         (ReqArg (\p -> so $ \opts -> opts { serverPort = read p }) "<port>")         "local port to bind"-    , Option ['s'] ["silent"]+    , Option [ 's' ] [ "silent" ]         (NoArg (so $ \opts -> opts { serverLocalDiscovery = False }))         "do not send announce packets for local discovery"     , Option [] [ "storage" ]@@ -140,7 +145,7 @@                  in maybe (Just ( Nothing, [ ownerName ] )) (Just . second (ownerName :)) (optCreateIdentity opts)             }) "<name>")         "create owner for a new device identity"-    , Option [] ["chatroom-auto-subscribe"]+    , Option [] [ "chatroom-auto-subscribe" ]         (ReqArg (\count -> \opts -> return opts { optChatroomAutoSubscribe = Just (read count) }) "<count>")         "automatically subscribe for up to <count> chatrooms"     , Option [] [ "discovery-stun-port" ]@@ -160,16 +165,16 @@             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"]+    , Option [] [ "dm-bot-echo" ]         (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"]+    , Option [ 'h' ] [ "help" ]         (NoArg $ \opts -> return opts { optShowHelp = True })         "show this help and exit"-    , Option ['V'] ["version"]+    , Option [ 'V' ] [ "version" ]         (NoArg $ \opts -> return opts { optShowVersion = True })         "show version and exit"     ]@@ -199,6 +204,25 @@         tell [ "Invalid value of --discovery-tunnel: ‘" <> name <> "’\n" ]         return $ \_ _ -> False +debugOptions :: [ OptDescr (Options -> Writer [ String ] Options) ]+debugOptions =+    [ Option [] [ "discovery-debug-log" ]+        (NoArg (serviceAttr $ \attrs -> return attrs { discoveryDebugLog = True }))+        ""+    ]+  where+    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 = return some++    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 -> Writer [ String ] Options) ] servicesOptions = concatMap helper $ "all" : map soptName availableServices   where@@ -228,7 +252,7 @@             progName <- getProgName             hPutStrLn stderr $ concat errs <> "Try `" <> progName <> " --help' for more information."             exitFailure-    (opts, args) <- (getOpt RequireOrder (options ++ servicesOptions) <$> getArgs) >>= \case+    (opts, args) <- (getOpt RequireOrder (options ++ servicesOptions ++ debugOptions) <$> getArgs) >>= \case         (wo, args, []) ->             case runWriter (foldM (flip ($)) defaultOptions wo) of                 ( o, [] )   -> return ( o, args )@@ -241,7 +265,7 @@         MemoryStorage          -> memoryStorage      case args of-        ["cat-file", sref] -> do+        [ "cat-file", sref ] -> do             readRef st (BC.pack sref) >>= \case                 Nothing -> error "ref does not exist"                 Just ref -> BL.putStr $ lazyLoadBytes ref@@ -272,7 +296,7 @@                         Nothing -> putStrLn $ "Identity verification failed"                     _ -> error $ "unknown object type '" ++ objtype ++ "'" -        ["show-generation", sref] -> readRef st (BC.pack sref) >>= \case+        [ "show-generation", sref ] -> readRef st (BC.pack sref) >>= \case             Nothing -> error "ref does not exist"             Just ref -> print $ storedGeneration (wrappedLoad ref :: Stored Object) @@ -284,7 +308,7 @@                     T.putStrLn "no local state head"                     exitFailure -        ["update-identity"] -> do+        [ "update-identity" ] -> do             withTerminal noCompletion $ \term -> do                 either (fail . showErebosError) return <=< runExceptT $ do                     runReaderT (updateSharedIdentity term) =<< runReaderT (loadLocalStateHead term) st@@ -299,7 +323,7 @@                                 (either (fail . showErebosError) return <=< runExceptT $ runReaderT (interactiveIdentityUpdate term idt) st)                         | otherwise -> error "invalid identity" -        ["test"] -> runTestTool st+        [ "test" ] -> runTestTool st          [] -> do             let header = "Usage: erebos [OPTION...]"@@ -323,17 +347,18 @@                | otherwise -> interactiveLoop st opts          (cmdname : _) -> do-            hPutStrLn stderr $ "Unknown command `" <> cmdname <> "'"+            hPutStrLn stderr $ "Unknown command ‘" <> cmdname <> "’"             exitFailure   interactiveLoop :: Storage -> Options -> IO () interactiveLoop st opts = withTerminal commandCompletion $ \term -> do+    showPrompt term     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+    void $ printLine term $ plainText $ displayIdentity $ headLocalIdentity erebosHead      let tui = hasTerminalUI term     let extPrintLn = void . printLine term@@ -353,7 +378,7 @@                         SelectedConversation conv -> return $ T.unpack $ conversationName conv                     return $ pname ++ "> "                 Right prompt -> return prompt-            lift $ setPrompt term prompt+            lift $ setPrompt term $ plainText $ T.pack prompt             join $ lift $ getInputLine term $ \case                 Just input@('/' : _) -> KeepPrompt $ return input                 Just input -> ErasePrompt $ case reverse input of@@ -399,7 +424,7 @@                         SelectedConversation conv -> return $ conversationPeer conv                         _ -> return Nothing                     when (not tui || maybe False (msgPeer cur `sameIdentity`) mbpid) $ do-                        extPrintLn $ formatDirectMessage tzone msg+                        extPrintLn $ plainText $ T.pack $ formatDirectMessage tzone msg                  case optDmBotEcho opts of                     Just prefix@@ -412,6 +437,11 @@                                     Left err -> extPrintLn $ "Failed to send dm echo: " <> err                     _ -> return () +            withMVar contextVar $ \ctx -> do+                updatePromptStatus term erebosHead . either (const Nothing) Just =<<+                    (runExceptT $ flip runReaderT erebosHead $ getConversationFromContext ctx)+    updatePromptStatus term erebosHead Nothing+     peers <- liftIO $ newMVar []     contextOptions <- liftIO $ newMVar ( Nothing, [] )     chatroomSetVar <- liftIO $ newEmptyMVar@@ -426,11 +456,11 @@         return Nothing      server <- liftIO $ do-        startServer (optServer opts) erebosHead extPrintLn $+        startServer (optServer opts) erebosHead (extPrintLn . plainText . T.pack) $             map soptService $ filter soptEnabled $ optServices opts      case optWebSocketServer opts of-        Just port -> startWebsocketServer server "::" port extPrintLn+        Just port -> startWebsocketServer server "::" port (extPrintLn . plainText . T.pack)         Nothing -> return ()      void $ liftIO $ forkIO $ void $ forever $ do@@ -439,24 +469,27 @@             pid@(PeerIdentityFull _) -> do                 dropped <- isPeerDropped peer                 shown <- showPeer pid <$> getPeerAddress peer-                let update [] = ([(peer, shown)], (Nothing, "NEW"))+                let labelNew = withStyle (setForegroundColor Green noStyle) $ plainText "NEW"+                    labelUpd = withStyle (setForegroundColor Yellow noStyle) $ plainText "UPD"+                    labelDel = withStyle (setForegroundColor Red noStyle) $ plainText "DEL"+                let update [] = ( [ ( peer, shown ) ], ( Nothing, labelNew ) )                     update ((p,s):ps)-                        | p == peer && dropped = (ps, (Nothing, "DEL"))-                        | p == peer = ((peer, shown) : ps, (Just s, "UPD"))+                        | p == peer && dropped = ( ps, ( Nothing, labelDel ) )+                        | p == peer = ( ( peer, shown ) : ps, ( Just s, labelUpd ) )                         | otherwise = first ((p,s):) $ update ps                 let ctxUpdate n [] = ([SelectedPeer peer], n)                     ctxUpdate n (ctx:ctxs)                         | SelectedPeer p <- ctx, p == peer = (ctx:ctxs, n)                         | otherwise = first (ctx:) $ ctxUpdate (n + 1) ctxs-                (op, updateType) <- modifyMVar peers (return . update)-                let updateType' = if dropped then "DEL" else updateType+                ( op, updateType ) <- modifyMVar peers (return . update)+                let updateType' = if dropped then labelDel else updateType                 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+                            extPrintLn $ "[" <> withStyle contextIndexStyle (plainText $ T.pack $ show idx) <> "] PEER " <> updateType' <> " " <> plainText shown                         return ( Just WatchPeers, clist' )                     cur -> return cur             _ -> return ()@@ -490,7 +523,7 @@                     | csQuit cstate' -> mzero                     | otherwise      -> return cstate'                 Left err -> do-                    lift $ extPrintLn $ "Error: " ++ showErebosError err+                    lift $ extPrintLn $ withStyle (setForegroundColor BrightRed noStyle) $ plainText $ T.pack $ "Error: " ++ showErebosError err                     return cstate      let loop (Just cstate) = runMaybeT (process cstate) >>= loop@@ -501,15 +534,23 @@         , csWatchChatrooms = watched         , csQuit = False         }+    hidePrompt term  +contextIndexStyle :: TextStyle+contextIndexStyle = setForegroundColor BrightCyan noStyle++printSelectOption :: Int -> FormattedText -> CommandM ()+printSelectOption i label = cmdPutStrLn $ "[" <> withStyle contextIndexStyle (plainText $ T.pack $ show i) <> "] " <> label++ data CommandInput = CommandInput     { ciServer :: Server     , ciTerminal :: Terminal     , ciLine :: String-    , ciPrint :: String -> IO ()+    , ciPrint :: FormattedText -> IO ()     , ciOptions :: Options-    , ciPeers :: CommandM [(Peer, String)]+    , ciPeers :: CommandM [ ( Peer, Text ) ]     , ciContextOptions :: CommandM [ CommandContext ]     , ciSetContextOptions :: ContextWatchOptions -> [ CommandContext ] -> Command     , ciContextVar :: MVar CommandContext@@ -577,7 +618,9 @@ getSelectedConversation :: CommandM Conversation getSelectedConversation = gets csContext >>= getConversationFromContext -getConversationFromContext :: CommandContext -> CommandM Conversation+getConversationFromContext+    :: (MonadIO m, MonadError ErebosError m, MonadHead LocalState m)+    => CommandContext -> m Conversation getConversationFromContext = \case     SelectedPeer peer -> getPeerIdentity peer >>= \case         PeerIdentityFull pid -> directMessageConversation $ finalOwner pid@@ -599,35 +642,57 @@         str | all isDigit str -> getContextByIndex id (read str)         _ -> throwOtherError "invalid index" +updatePromptStatus :: Terminal -> Head LocalState -> Maybe Conversation -> IO ()+updatePromptStatus term h current = do+    conversations <- mapMaybe checkNew <$> flip runReaderT h lookupConversations+    setPromptStatus term $ withStyle (setForegroundColor BrightYellow noStyle) $ formatStatus (length conversations) <> " "+  where+    checkNew conv+        | (msg : _) <- conversationHistory conv+        , messageUnread msg+        , maybe True (not . isSameConversation conv) current+        = Just ( conv, msg )+    checkNew _ = Nothing++    formatStatus 0 = withStyle (setForegroundColor BrightBlack noStyle) "--"+    formatStatus 1 = withStyle (setForegroundColor BrightYellow noStyle) " *"+    formatStatus n+        | n < 10 = withStyle (setForegroundColor BrightYellow noStyle) $ plainText $ T.pack (show n) <> "*"+        | otherwise = withStyle (setForegroundColor BrightYellow noStyle) $ plainText $ "X*"++ commands :: [(String, Command)] commands =-    [ ("history", cmdHistory)-    , ("identity", cmdIdentity)-    , ("peers", cmdPeers)-    , ("peer-add", cmdPeerAdd)-    , ("peer-add-public", cmdPeerAddPublic)-    , ("peer-drop", cmdPeerDrop)-    , ("send", cmdSend)-    , ("delete", cmdDelete)-    , ("update-identity", cmdUpdateIdentity)-    , ("attach", cmdAttach)-    , ("attach-accept", cmdAttachAccept)-    , ("attach-reject", cmdAttachReject)-    , ("chatrooms", cmdChatrooms)-    , ("chatroom-create-public", cmdChatroomCreatePublic)-    , ("contacts", cmdContacts)-    , ("contact-add", cmdContactAdd)-    , ("contact-accept", cmdContactAccept)-    , ("contact-reject", cmdContactReject)-    , ("conversations", cmdConversations)-    , ("details", cmdDetails)-    , ("discovery", cmdDiscovery)-    , ("join", cmdJoin)-    , ("join-as", cmdJoinAs)-    , ("leave", cmdLeave)-    , ("members", cmdMembers)-    , ("select", cmdSelectContext)-    , ("quit", cmdQuit)+    [ ( "history", cmdHistory )+    , ( "identity", cmdIdentity )+    , ( "peers", cmdPeers )+    , ( "peer-add", cmdPeerAdd )+    , ( "peer-add-public", cmdPeerAddPublic )+    , ( "peer-drop", cmdPeerDrop )+    , ( "send", cmdSend )+    , ( "delete", cmdDelete )+    , ( "update-identity", cmdUpdateIdentity )+    , ( "attach", cmdAttach )+    , ( "attach-accept", cmdAttachAccept )+    , ( "attach-reject", cmdAttachReject )+    , ( "chatrooms", cmdChatrooms )+    , ( "chatroom-create-public", cmdChatroomCreatePublic )+    , ( "contacts", cmdContacts )+    , ( "contact-add", cmdContactAdd )+    , ( "contact-accept", cmdContactAccept )+    , ( "contact-reject", cmdContactReject )+    , ( "invite-contact", cmdInviteContact )+    , ( "invite-accept", cmdInviteAccept )+    , ( "conversations", cmdConversations )+    , ( "new", cmdNew )+    , ( "details", cmdDetails )+    , ( "discovery", cmdDiscovery )+    , ( "join", cmdJoin )+    , ( "join-as", cmdJoinAs )+    , ( "leave", cmdLeave )+    , ( "members", cmdMembers )+    , ( "select", cmdSelectContext )+    , ( "quit", cmdQuit )     ]  commandCompletion :: CompletionFunc IO@@ -638,13 +703,13 @@     sortedCommandNames = sort $ map fst commands  -cmdPutStrLn :: String -> Command+cmdPutStrLn :: FormattedText -> Command cmdPutStrLn str = do     term <- asks ciTerminal     void $ liftIO $ printLine term str  cmdUnknown :: String -> Command-cmdUnknown cmd = cmdPutStrLn $ "Unknown command: " ++ cmd+cmdUnknown cmd = cmdPutStrLn $ withStyle (setForegroundColor BrightRed noStyle) $ plainText $ "Unknown command: ‘" <> T.pack cmd <> "’"  cmdPeers :: Command cmdPeers = do@@ -652,7 +717,7 @@     set <- asks ciSetContextOptions     set WatchPeers $ map (SelectedPeer . fst) peers     forM_ (zip [1..] peers) $ \(i :: Int, (_, name)) -> do-        cmdPutStrLn $ "[" ++ show i ++ "] " ++ name+        printSelectOption i $ plainText name  cmdPeerAdd :: Command cmdPeerAdd = void $ do@@ -690,13 +755,13 @@     dropPeer =<< getSelectedPeer     modify $ \s -> s { csContext = NoContext } -showPeer :: PeerIdentity -> PeerAddress -> String+showPeer :: PeerIdentity -> PeerAddress -> Text showPeer pidentity paddr =     let name = case pidentity of                     PeerIdentityUnknown _  -> "<noid>"-                    PeerIdentityRef wref _ -> "<" ++ BC.unpack (showRefDigest $ wrDigest wref) ++ ">"-                    PeerIdentityFull pid   -> T.unpack $ displayIdentity pid-     in name ++ " [" ++ show paddr ++ "]"+                    PeerIdentityRef wref _ -> "<" <> T.decodeUtf8 (showRefDigest $ wrDigest wref) <> ">"+                    PeerIdentityFull pid   -> displayIdentity pid+     in name <> " [" <> T.pack (show paddr) <> "]"  cmdJoin :: Command cmdJoin = joinChatroom =<< getSelectedChatroom@@ -714,7 +779,7 @@ cmdMembers = do     Just room <- findChatroomByStateData . head . roomStateData =<< getSelectedChatroom     forM_ (chatroomMembers room) $ \x -> do-        cmdPutStrLn $ maybe "<unnamed>" T.unpack $ idName x+        cmdPutStrLn $ plainText $ fromMaybe "<unnamed>" $ idName x  getContextByIndex :: (Maybe ContextWatchOptions -> Maybe ContextWatchOptions) -> Int -> CommandM CommandContext getContextByIndex f n = do@@ -737,6 +802,16 @@                 chatroomSetSubscribe (head $ roomStateData rstate) True         _ -> return () +    term <- asks ciTerminal+    h <- gets csHead+    (runExceptT $ flip runReaderT h $ getConversationFromContext ctx) >>= \case+        Right conv -> do+            liftIO $ updatePromptStatus term h (Just conv)+            tzone <- liftIO $ getCurrentTimeZone+            mapM_ (cmdPutStrLn . formatMessageFT tzone) $ takeWhile messageUnread $ conversationHistory conv+        Left _ -> do+            liftIO $ updatePromptStatus term h Nothing+ cmdSend :: Command cmdSend = void $ do     text <- asks ciLine@@ -754,9 +829,9 @@     case conversationHistory conv of         thread@(_:_) -> do             tzone <- liftIO $ getCurrentTimeZone-            mapM_ (cmdPutStrLn . formatMessage tzone) $ reverse $ take 50 thread+            mapM_ (cmdPutStrLn . formatMessageFT tzone) $ reverse $ take 50 thread         [] -> do-            cmdPutStrLn $ "<empty history>"+            cmdPutStrLn $ withStyle (setForegroundColor BrightBlack noStyle) $ plainText "(empty history)"  showIdentityDetails :: Foldable f => Identity f -> Text showIdentityDetails identity = T.unlines $ go $ reverse $ unfoldOwners identity@@ -774,7 +849,7 @@  cmdIdentity :: Command cmdIdentity = do-    cmdPutStrLn . T.unpack . showIdentityDetails . localIdentity . fromStored =<< getLocalHead+    cmdPutStrLn . plainText . showIdentityDetails . localIdentity . fromStored =<< getLocalHead  cmdUpdateIdentity :: Command cmdUpdateIdentity = void $ do@@ -791,7 +866,7 @@ cmdAttachReject = attachReject =<< getSelectedPeer  watchChatroomsForCli-    :: Bool -> (String -> IO ()) -> Head LocalState -> MVar (Set ChatroomState)+    :: Bool -> (FormattedText -> 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@@ -802,14 +877,14 @@                 | currentRoots <- filterAncestors (concatMap storedRoots $ roomStateData rstate)                 , any ((`intersectsSorted` currentRoots) . storedRoots) $ roomStateData rstate'                 -> do-                    eprint $ "[" <> show idx <> "] CHATROOM " <> updateType <> " " <> name+                    eprint $ plainText $ T.pack $ "[" <> show idx <> "] CHATROOM " <> updateType <> " " <> name                     return (SelectedChatroom rstate : rest)             selected : rest                 -> do                     (selected : ) <$> ctxUpdate updateType (idx + 1) rstate rest             []                 -> do-                    eprint $ "[" <> show idx <> "] CHATROOM " <> updateType <> " " <> name+                    eprint $ plainText $ T.pack $ "[" <> show idx <> "] CHATROOM " <> updateType <> " " <> name                     return [ SelectedChatroom rstate ]           where             name = maybe "<unnamed>" T.unpack $ roomName =<< roomStateRoom rstate@@ -829,7 +904,7 @@                     forM_ (take (num - subscribedNum) notSubscribed) $ \rstate -> do                         (runExceptT $ flip runReaderT h $ chatroomSetSubscribe (head $ roomStateData rstate) True) >>= \case                              Right () -> return ()-                             Left err -> eprint (showErebosError err)+                             Left err -> eprint $ plainText $ T.pack $ showErebosError err          Just diff -> do             modifyMVar_ chatroomSetVar $ return . const set@@ -865,11 +940,11 @@                             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+                                    eprint $ plainText $ T.concat+                                        [ T.pack $ formatTime defaultTimeLocale "[%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ cmsgTime msg+                                        , fromMaybe "<unnamed>" $ idName $ cmsgFrom msg                                         , if cmsgLeave msg then " left" else ""-                                        , maybe (if cmsgLeave msg then "" else " joined") ((": " ++) . T.unpack) $ cmsgText msg+                                        , maybe (if cmsgLeave msg then "" else " joined") ((": " <>)) $ cmsgText msg                                         ]                     modifyMVar_ subscribedNumVar $ return                         . (if roomStateSubscribe rstate then (+ 1) else id)@@ -898,7 +973,7 @@     set <- asks ciSetContextOptions     set WatchChatrooms $ map SelectedChatroom chatroomList     forM_ (zip [1..] chatroomList) $ \(i :: Int, rstate) -> do-        cmdPutStrLn $ "[" ++ show i ++ "] " ++ maybe "<unnamed>" T.unpack (roomName =<< roomStateRoom rstate)+        printSelectOption i $ plainText $ fromMaybe "<unnamed>" (roomName =<< roomStateRoom rstate)  cmdChatroomCreatePublic :: Command cmdChatroomCreatePublic = do@@ -926,8 +1001,8 @@     set <- asks ciSetContextOptions     set WatchContacts $ map SelectedContact contacts     forM_ (zip [1..] contacts) $ \(i :: Int, c) -> do-        cmdPutStrLn $ T.unpack $ T.concat-            [ "[", T.pack (show i), "] ", contactName c+        printSelectOption i $ plainText $ T.concat+            [ contactName c             , case contactIdentity c of                    Just idt | cname <- displayIdentity idt                             , cname /= contactName c@@ -946,36 +1021,90 @@ cmdContactReject :: Command cmdContactReject = contactReject =<< getSelectedPeer +cmdInviteContact :: Command+cmdInviteContact = do+    term <- asks ciTerminal+    name <- asks ciLine >>= \case+        line | not (null line) -> return $ T.pack line+        _ -> liftIO $ do+            setPrompt term "Name: "+            getInputLine term $ KeepPrompt . maybe T.empty T.pack+    (lookupSharedValue . lsShared . fromStored <$> getLocalHead) >>= \case+        Just (self :: ComposedIdentity) -> do+            invite <- createSingleContactInvite name+            dgst : _ <- return $ refDigest . storedRef <$> idDataF self+            cmdPutStrLn $ plainText $ "https://app.erebosprotocol.net/#inv" <> (maybe "" (("=" <>) . textInviteToken) (inviteToken invite)) <> "&from=blake2%23" <> T.pack (drop 7 (show dgst))+        Nothing -> do+            throwOtherError "no shared identity"++cmdInviteAccept :: Command+cmdInviteAccept = do+    term <- asks ciTerminal+    url <- asks ciLine >>= \case+        line | not (null line) -> return $ T.pack line+        _ -> liftIO $ do+            setPrompt term "URL: "+            getInputLine term $ KeepPrompt . maybe T.empty T.pack+    case T.breakOn "://" url of+        ( proto, url' )+            | proto `elem` [ "http", "https" ]+            , ( _, url'' ) <- T.breakOn "#" url'+            , Just ( '#', params ) <- T.uncons url''+            , [ pfrom, pinv ] <- sort $ T.splitOn "&" params+            , ( nfrom, tfrom ) <- T.splitAt 14 pfrom, nfrom == "from=blake2%23"+            , ( ninv, tinv ) <- T.splitAt 4 pinv, ninv == "inv="+            , Just from <- readRefDigest $ T.encodeUtf8 $ "blake2#" <> tfrom+            , Just token <- parseInviteToken tinv+            -> do+                acceptInvite from token+        _ -> throwOtherError "invalit invite URL"+ cmdConversations :: Command cmdConversations = do     conversations <- lookupConversations     set <- asks ciSetContextOptions     set WatchConversations $ map SelectedConversation conversations     forM_ (zip [1..] conversations) $ \(i :: Int, conv) -> do-        cmdPutStrLn $ "[" ++ show i ++ "] " ++ T.unpack (conversationName conv)+        printSelectOption i $ plainText $ conversationName conv +cmdNew :: Command+cmdNew = do+    conversations <- mapMaybe checkNew <$> lookupConversations+    set <- asks ciSetContextOptions+    set WatchConversations $ map (SelectedConversation . fst) conversations+    tzone <- liftIO $ getCurrentTimeZone+    forM_ (zip [1..] conversations) $ \(i :: Int, ( conv, msg )) -> do+        printSelectOption i $ plainText (conversationName conv <> " ") <> formatMessageFT tzone msg+  where+    checkNew conv+        | (msg : _) <- conversationHistory conv+        , messageUnread msg+        = Just ( conv, msg )+    checkNew _ = Nothing++ cmdDetails :: Command cmdDetails = do     getSelectedOrManualContext >>= \case         SelectedPeer peer -> do             paddr <- getPeerAddress peer-            cmdPutStrLn $ unlines+            cmdPutStrLn $ plainText $ T.unlines                 [ "Network peer:"-                , "  " <> show paddr+                , "  " <> T.pack (show paddr)                 ]             getPeerIdentity peer >>= \case                 PeerIdentityUnknown _ -> do                     cmdPutStrLn $ "unknown identity"                 PeerIdentityRef wref _ -> do                     cmdPutStrLn $ "Identity ref:"-                    cmdPutStrLn $ "  " <> BC.unpack (showRefDigest $ wrDigest wref)+                    cmdPutStrLn $ plainText $ "  " <> T.decodeUtf8 (showRefDigest $ wrDigest wref)                 PeerIdentityFull pid -> printContactOrIdentityDetails pid          SelectedContact contact -> do             printContactDetails contact          SelectedChatroom rstate -> do-            cmdPutStrLn $ "Chatroom: " <> (T.unpack $ fromMaybe (T.pack "<unnamed>") $ roomName =<< roomStateRoom rstate)+            cmdPutStrLn $ plainText $ "Chatroom: " <> (fromMaybe "<unnamed>" $ roomName =<< roomStateRoom rstate)          SelectedConversation conv -> do             case conversationPeer conv of@@ -994,7 +1123,7 @@         cmdPutStrLn $ "Contact:"         prefix <- case contactCustomName contact of             Just name -> do-                cmdPutStrLn $ "  " <> T.unpack name+                cmdPutStrLn $ plainText $ "  " <> name                 return $ Just "alias of"             Nothing -> do                 return $ Nothing@@ -1011,11 +1140,11 @@      printIdentityDetailsBody prefix identity = do         forM_ (zip (False : repeat True) $ unfoldOwners identity) $ \(owned, cpid) -> do-            cmdPutStrLn $ unwords $ concat+            cmdPutStrLn $ plainText $ T.unwords $ concat                 [ [ "  " ]                 , if owned then [ "owned by" ] else maybeToList prefix-                , [ maybe "<unnamed>" T.unpack (idName cpid) ]-                , map (BC.unpack . showRefDigest . refDigest . storedRef) $ idExtDataF cpid+                , [ fromMaybe "<unnamed>" (idName cpid) ]+                , map (T.decodeUtf8 . showRefDigest . refDigest . storedRef) $ idExtDataF cpid                 ]  cmdDiscovery :: Command

@@ -1,3 +1,5 @@+{-# LANGUAGE OverloadedStrings #-}+ module State (     loadLocalStateHead,     createLocalStateHead,@@ -20,6 +22,7 @@ import Erebos.State import Erebos.Storable import Erebos.Storage+import Erebos.TextFormat  import Terminal @@ -96,12 +99,12 @@ interactiveIdentityUpdate term fidentity = do     identity <- mergeIdentity fidentity     name <- liftIO $ do-        setPrompt term $ T.unpack $ T.concat $ concat-            [ [ T.pack "Name" ]+        setPrompt term $ mconcat $ concat+            [ [ "Name" ]             , case idName identity of-                   Just name -> [T.pack " [", name, T.pack "]"]-                   Nothing -> []-            , [ T.pack ": " ]+                  Just name -> [ " [", plainText name, "]" ]+                  Nothing -> []+            , [ ": " ]             ]         getInputLine term $ KeepPrompt . maybe T.empty T.pack 

@@ -1,10 +1,13 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}  module Terminal (     Terminal,     hasTerminalUI,     withTerminal,     setPrompt,+    setPromptStatus,+    showPrompt, hidePrompt,     getInputLine,     InputHandling(..), @@ -30,17 +33,22 @@ import Data.List import Data.Text (Text) import Data.Text qualified as T+import Data.Text.IO qualified as T  import System.Console.ANSI import System.IO import System.IO.Error +import Erebos.TextFormat+import Erebos.TextFormat.Ansi + data Terminal = Terminal     { termLock :: MVar ()     , termAnsi :: Bool     , termCompletionFunc :: CompletionFunc IO-    , termPrompt :: TVar String+    , termPrompt :: TVar FormattedText+    , termPromptStatus :: TVar FormattedText     , termShowPrompt :: TVar Bool     , termInput :: TVar ( String, String )     , termBottomLines :: TVar [ String ]@@ -87,6 +95,7 @@     termAnsi <- hSupportsANSI stdout #endif     termPrompt <- newTVarIO ""+    termPromptStatus <- newTVarIO ""     termShowPrompt <- newTVarIO False     termInput <- newTVarIO ( "", "" )     termBottomLines <- newTVarIO []@@ -108,11 +117,8 @@             act term  -termPutStr :: Terminal -> String -> IO ()-termPutStr Terminal {..} str = do-    withMVar termLock $ \_ -> do-        putStr str-        hFlush stdout+putAnsi :: AnsiText -> IO ()+putAnsi = T.putStr . fromAnsiText   getInput :: IO Input@@ -149,15 +155,6 @@  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@@ -168,15 +165,16 @@             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+    ( x, clear ) <- case handleResult mbLine of+        KeepPrompt x -> return ( x, \statusLen -> AnsiText $ "\ESC[" <> T.pack (show statusLen) <> "G\ESC[1K\n\ESC[J" )+        ErasePrompt x -> return ( x, \_ -> AnsiText "\r\ESC[J" )+    when termAnsi $ do+        withMVar termLock $ \_ -> do+            status <- atomically $ readTVar termPromptStatus+            prompt <- atomically $ getCurrentPromptLine term+            putAnsi $ clear (formattedTextLength status) <> prompt+    return x+   where     go = getInput >>= \case         InputChar '\n' -> do@@ -184,7 +182,6 @@                 ( pre, post ) <- readTVar termInput                 writeTVar termInput ( "", "" )                 when termAnsi $ do-                    writeTVar termShowPrompt False                     writeTVar termBottomLines []                 return $ Just $ pre ++ post @@ -195,7 +192,7 @@                         prompt <- atomically $ do                             writeTVar termInput ( pre', post )                             getCurrentPromptLine term-                        putStr $ "\r" <> prompt+                        putAnsi $ "\r" <> prompt                         hFlush stdout                  termCompletionFunc ( T.pack pre, T.pack post ) >>= \case@@ -222,7 +219,7 @@         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")+                return $ AnsiText $ T.pack $ c : (if null post then "" else "\ESC[s" <> post <> "\ESC[u")          InputChar _ -> go @@ -272,7 +269,7 @@         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 $ AnsiText $ "\b\ESC[K" <> (if null post then "" else "\ESC[s" <> T.pack post <> "\ESC[u")             _ -> return ""          InputClear -> withInput $ \_ -> do@@ -286,11 +283,11 @@          InputMoveStart -> withInput $ \( pre, post ) -> do             writeTVar termInput ( "", pre <> post )-            return $ "\ESC[" <> show (length pre) <> "D"+            return $ AnsiText $ T.pack $ "\ESC[" <> show (length pre) <> "D"          InputMoveEnd -> withInput $ \( pre, post ) -> do             writeTVar termInput ( pre <> post, "" )-            return $ "\ESC[" <> show (length post) <> "C"+            return $ AnsiText $ T.pack $ "\ESC[" <> show (length post) <> "C"          InputEnd -> do             atomically (readTVar termInput) >>= \case@@ -299,22 +296,37 @@          InputEscape _ -> go +    withInput :: (( String, String ) -> STM AnsiText) -> IO (Maybe String)     withInput f = do         withMVar termLock $ const $ do             str <- atomically $ f =<< readTVar termInput-            when (termAnsi && not (null str)) $ do-                putStr str+            when (termAnsi && not (T.null $ fromAnsiText str)) $ do+                putAnsi str                 hFlush stdout         go  -getCurrentPromptLine :: Terminal -> STM String+getCurrentPromptLine :: Terminal -> STM AnsiText getCurrentPromptLine Terminal {..} = do-    prompt <- readTVar termPrompt+    sp <- readTVar termShowPrompt+    prompt <- if sp then readTVar termPrompt else return ""+    status <- if sp then readTVar termPromptStatus else return ""     ( pre, post ) <- readTVar termInput-    return $ prompt <> pre <> "\ESC[s" <> post <> "\ESC[u"+    return $ mconcat+        [ renderAnsiText status+        , renderAnsiText prompt+        , AnsiText (T.pack pre), "\ESC[s"+        , AnsiText (T.pack post), "\ESC[u"+        ] -setPrompt :: Terminal -> String -> IO ()+redrawPrompt :: Terminal -> STM (IO ())+redrawPrompt term = do+    promptLine <- getCurrentPromptLine term+    return $ do+        putAnsi $ "\r\ESC[K" <> promptLine+        hFlush stdout++setPrompt :: Terminal -> FormattedText -> IO () setPrompt Terminal { termAnsi = False } _ = do     return () setPrompt term@Terminal {..} prompt = do@@ -322,28 +334,61 @@         join $ atomically $ do             writeTVar termPrompt prompt             readTVar termShowPrompt >>= \case+                True -> redrawPrompt term+                False -> return $ return ()++setPromptStatus :: Terminal -> FormattedText -> IO ()+setPromptStatus Terminal { termAnsi = False } _ = do+    return ()+setPromptStatus term@Terminal {..} prompt = do+    withMVar termLock $ \_ -> do+        join $ atomically $ do+            writeTVar termPromptStatus prompt+            readTVar termShowPrompt >>= \case+                True -> redrawPrompt term+                False -> return $ return ()++showPrompt :: Terminal -> IO ()+showPrompt Terminal { termAnsi = False } = do+    return ()+showPrompt term@Terminal {..} = do+    withMVar termLock $ \_ -> do+        join $ atomically $ do+            readTVar termShowPrompt >>= \case+                False -> do+                    writeTVar termShowPrompt True+                    redrawPrompt term+                True -> return $ return ()++hidePrompt :: Terminal -> IO ()+hidePrompt Terminal { termAnsi = False } = do+    return ()+hidePrompt term@Terminal {..} = do+    withMVar termLock $ \_ -> do+        join $ atomically $ do+            readTVar termShowPrompt >>= \case                 True -> do-                    promptLine <- getCurrentPromptLine term-                    return $ do-                        putStr $ "\r\ESC[K" <> promptLine-                        hFlush stdout+                    writeTVar termShowPrompt False+                    redrawPrompt term                 False -> return $ return () -printLine :: Terminal -> String -> IO TerminalLine+printLine :: Terminal -> FormattedText -> IO TerminalLine printLine tlTerminal@Terminal {..} str = do     withMVar termLock $ \_ -> do-        let strLines = lines str-            tlLineCount = length strLines+        let tlLineCount = formattedTextHeight str         if termAnsi           then do             promptLine <- atomically $ do                 readTVar termShowPrompt >>= \case                     True -> getCurrentPromptLine tlTerminal                     False -> return ""-            putStr $ "\r\ESC[K" <> unlines strLines <> "\ESC[K" <> promptLine+            putAnsi $ mconcat+                [ AnsiText "\r\ESC[K", renderAnsiText $ endWithNewline str+                , AnsiText "\ESC[K", promptLine+                ]             drawBottomLines tlTerminal           else do-            putStr $ unlines strLines+            T.putStr $ renderPlainText $ endWithNewline str          hFlush stdout         return TerminalLine {..}@@ -381,8 +426,9 @@                 readTVar termShowPrompt >>= \case                     True -> do                         prompt <- readTVar termPrompt+                        status <- readTVar termPromptStatus                         ( pre, _ ) <- readTVar termInput-                        return (displayWidth (prompt <> pre) + 1)+                        return (formattedTextLength status + formattedTextLength prompt + length pre + 1)                     False -> do                         return 0             putStr $ concat@@ -391,14 +437,6 @@                 , "\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 ] )

@@ -39,8 +39,10 @@ import Erebos.DirectMessage import Erebos.Discovery import Erebos.Identity+import Erebos.Invite import Erebos.Network import Erebos.Object+import Erebos.Object.Deferred import Erebos.Pairing import Erebos.PubKey import Erebos.Service@@ -69,6 +71,7 @@     { rsServer :: Server     , rsPeers :: MVar ( Int, [ TestPeer ] )     , rsPeerThread :: ThreadId+    , rsDeferredObjects :: MVar [ Deferred Object ]     }  data TestPeer = TestPeer@@ -117,9 +120,9 @@ getLineMb :: MonadIO m => m (Maybe Text) getLineMb = liftIO $ catchIOError (Just <$> T.getLine) (\e -> if isEOFError e then return Nothing else ioError e) -getLines :: MonadIO m => m [Text]-getLines = getLineMb >>= \case-    Just line | not (T.null line) -> (line:) <$> getLines+getLines :: MonadIO m => Text -> m [ Text ]+getLines eof = getLineMb >>= \case+    Just line | line /= eof -> (line :) <$> getLines eof     _ -> return []  getHead :: CommandM (Head LocalState)@@ -232,14 +235,26 @@     { discoveryProvideTunnel = \_ _ -> False     } +inviteAttributes :: Output -> InviteServiceAttributes+inviteAttributes out = (defaultServiceAttributes Proxy)+    { inviteHookAccepted = \Invite {..} -> do+        pid <- asks svcPeerIdentity+        afterCommit $ outLine out $ "invite-accepted " <> maybe "<missing-token>" showInviteToken inviteToken <> " " <> (BC.unpack $ showRef $ storedRef $ idExtData pid)+    , inviteHookReplyContact = \token _ -> do+        afterCommit $ outLine out $ "invite-reply " <> showInviteToken token <> " contact"+    , inviteHookReplyInvalid = \token -> do+        afterCommit $ outLine out $ "invite-reply " <> showInviteToken token <> " invalid"+    }+ dmThreadWatcher :: ComposedIdentity -> Output -> DirectMessageThread -> DirectMessageThread -> IO () dmThreadWatcher self out prev cur = do-    forM_ (reverse $ dmThreadToListSince prev cur) $ \msg -> do+    forM_ (reverse $ dmThreadToListSinceUnread prev cur) $ \( msg, new ) -> do         outLine out $ unwords             [ if sameIdentity self (msgFrom msg)                  then "dm-sent"                  else "dm-received"             , "from", maybe "<unnamed>" T.unpack $ idName $ msgFrom msg+            , "new", if new then "yes" else "no"             , "text", T.unpack $ msgText msg             ] @@ -268,7 +283,10 @@ commands :: [ ( Text, Command ) ] commands =     [ ( "store", cmdStore )+    , ( "store-raw", cmdStoreRaw )     , ( "load", cmdLoad )+    , ( "load-type", cmdLoadType )+    , ( "load-deferred", cmdLoadDeferred )     , ( "stored-generation", cmdStoredGeneration )     , ( "stored-roots", cmdStoredRoots )     , ( "stored-set-add", cmdStoredSetAdd )@@ -311,6 +329,8 @@     , ( "dm-send-identity", cmdDmSendIdentity )     , ( "dm-list-peer", cmdDmListPeer )     , ( "dm-list-contact", cmdDmListContact )+    , ( "dm-list-identity", cmdDmListIdentity )+    , ( "dm-mark-seen", cmdDmMarkSeen )     , ( "chatroom-create", cmdChatroomCreate )     , ( "chatroom-delete", cmdChatroomDelete )     , ( "chatroom-list-local", cmdChatroomListLocal )@@ -325,6 +345,8 @@     , ( "chatroom-message-send", cmdChatroomMessageSend )     , ( "discovery-connect", cmdDiscoveryConnect )     , ( "discovery-tunnel", cmdDiscoveryTunnel )+    , ( "invite-contact-create", cmdInviteContactCreate )+    , ( "invite-accept", cmdInviteAccept )     ]  cmdStore :: Command@@ -332,7 +354,7 @@     st <- asks tiStorage     pst <- liftIO $ derivePartialStorage st     [otype] <- asks tiParams-    ls <- getLines+    ls <- getLines T.empty      let cnt = encodeUtf8 $ T.unlines ls         full = BL.fromChunks@@ -345,6 +367,18 @@         Right ref -> cmdOut $ "store-done " ++ show (refDigest ref)         Left _ -> cmdOut $ "store-failed" +cmdStoreRaw :: Command+cmdStoreRaw = do+    st <- asks tiStorage+    pst <- liftIO $ derivePartialStorage st+    [ eof ] <- asks tiParams+    ls <- getLines eof++    let full = BL.fromStrict $ BC.init $ encodeUtf8 $ T.unlines ls+    liftIO (copyRef st =<< storeRawBytes pst full) >>= \case+        Right ref -> cmdOut $ "store-done " ++ show (refDigest ref)+        Left _ -> cmdOut $ "store-failed"+ cmdLoad :: Command cmdLoad = do     st <- asks tiStorage@@ -357,6 +391,40 @@         cmdOut $ "load-line " <> T.unpack (decodeUtf8 $ BL.toStrict line)     cmdOut "load-done" +cmdLoadType :: Command+cmdLoadType = do+    st <- asks tiStorage+    [ tref ] <- asks tiParams+    liftIO (readRef st $ encodeUtf8 tref) >>= \case+        Just ref -> do+            let obj = load @Object ref+            let otype = case obj of+                    Blob {} -> "blob"+                    Rec {} -> "rec"+                    OnDemand {} -> "ondemand"+                    ZeroObject {} -> "zero"+                    UnknownObject utype _ -> "unknown " <> decodeUtf8 utype+            cmdOut $ "load-type " <> T.unpack otype+        Nothing -> do+            cmdOut $ "load-type-failed"++cmdLoadDeferred :: Command+cmdLoadDeferred = do+    st <- asks tiStorage+    [ tidx ] <- asks tiParams+    Just RunningServer {..} <- gets tsServer+    deferred <- (!! read (T.unpack tidx)) <$> liftIO (readMVar rsDeferredObjects)+    out <- asks tiOutput+    liftIO $ void $ forkIO $ deferredWait deferred >>= \case+        DeferredLoaded sobj -> do+            void $ copyRef st $ storedRef sobj+            header : _ <- return $ BL.lines $ serializeObject $ fromStored sobj+            outLine out $ T.unpack $ T.unwords [ "load-deferred-done", tidx, decodeUtf8 $ BL.toStrict header ]+        DeferredInvalid -> do+            outLine out $ T.unpack $ T.unwords [ "load-deferred-invalid", tidx ]+        DeferredFailed -> do+            outLine out $ T.unpack $ T.unwords [ "load-deferred-failed", tidx ]+ cmdStoredGeneration :: Command cmdStoredGeneration = do     st <- asks tiStorage@@ -536,6 +604,7 @@      h <- getOrLoadHead     rsPeers <- liftIO $ newMVar (1, [])+    rsDeferredObjects <- liftIO $ newMVar []     services <- forM serviceNames $ \case         ( "attach", _ ) -> return $ someServiceAttr $ pairingAttributes (Proxy @AttachService) out rsPeers "attach"         ( "chatroom", _ ) -> return $ someService @ChatroomService Proxy@@ -544,6 +613,7 @@             { discoveryProvideTunnel = \_ _ -> "tunnel" `elem` params             }         ( "dm", _ ) -> return $ someServiceAttr $ directMessageAttributes out+        ( "invite", _ ) -> return $ someServiceAttr $ inviteAttributes out         ( "sync", _ ) -> return $ someService @SyncService Proxy         ( "test", _ ) -> return $ someServiceAttr $ (defaultServiceAttributes Proxy)             { testMessageReceived = \obj otype len sref -> do@@ -563,6 +633,10 @@                                 StreamClosed seqNum -> do                                     outLine out $ unwords [ "test-stream-closed-from", show pidx, show num, show seqNum ]                         go+            , testOnDemandReceived = \size deferred -> do+                liftIO $ do+                    idx <- modifyMVar rsDeferredObjects (\ds -> return ( ds ++ [ deferred ], length ds ))+                    outLine out $ unwords [ "test-ondemand-received", show idx, show size, show $ deferredRef deferred ]             }         ( sname, _ ) -> throwOtherError $ "unknown service `" <> T.unpack sname <> "'" @@ -869,8 +943,9 @@     threads <- dmThreadList . lookupSharedValue . lsShared . headObject <$> getHead     case find (sameIdentity peer . msgPeer) threads of         Just thread -> do-            forM_ (reverse $ dmThreadToList thread) $ \DirectMessage {..} -> cmdOut $ "dm-list-item"+            forM_ (reverse $ dmThreadToListUnread thread) $ \( DirectMessage {..}, new ) -> cmdOut $ "dm-list-item"                 <> " from " <> (maybe "<unnamed>" T.unpack $ idName msgFrom)+                <> " new " <> (if new then "yes" else "no")                 <> " text " <> (T.unpack msgText)         Nothing -> return ()     cmdOut "dm-list-done"@@ -887,6 +962,23 @@     Just to <- contactIdentity <$> getContact cid     dmList to +cmdDmListIdentity :: Command+cmdDmListIdentity = do+    st <- asks tiStorage+    [ tid ] <- asks tiParams+    Just ref <- liftIO $ readRef st $ encodeUtf8 tid+    Just pid <- return $ validateExtendedIdentity $ wrappedLoad ref+    dmList pid++cmdDmMarkSeen :: Command+cmdDmMarkSeen = do+    st <- asks tiStorage+    [ tid ] <- asks tiParams+    Just ref <- liftIO $ readRef st $ encodeUtf8 tid+    Just pid <- return $ validateExtendedIdentity $ wrappedLoad ref+    dmMarkAsSeen pid+    cmdOut $ unwords [ "dm-mark-seen-done", T.unpack tid ]+ cmdChatroomCreate :: Command cmdChatroomCreate = do     [name] <- asks tiParams@@ -1015,3 +1107,17 @@     via <- getPeer tvia     Just target <- return $ readRefDigest $ encodeUtf8 ttarget     liftIO $ discoverySetupTunnel via target++cmdInviteContactCreate :: Command+cmdInviteContactCreate = do+    [ name ] <- asks tiParams+    Just token <- inviteToken <$> createSingleContactInvite name+    cmdOut $ unwords [ "invite-contact-create-done", showInviteToken token ]++cmdInviteAccept :: Command+cmdInviteAccept = do+    [ tokenText, idref ] <- asks tiParams+    Just token <- return $ parseInviteToken tokenText+    Just from <- return $ readRefDigest $ encodeUtf8 idref+    acceptInvite from token+    cmdOut $ unwords [ "invite-accept-done", showInviteToken token ]

@@ -9,9 +9,12 @@ import Control.Monad.Reader  import Data.ByteString.Lazy.Char8 qualified as BL+import Data.Word +import Erebos.Identity import Erebos.Network import Erebos.Object+import Erebos.Object.Deferred import Erebos.Service import Erebos.Service.Stream import Erebos.Storable@@ -21,6 +24,7 @@ data TestMessageAttributes = TestMessageAttributes     { testMessageReceived :: Object -> String -> String -> String -> ServiceHandler TestMessage ()     , testStreamsReceived :: [ StreamReader ] -> ServiceHandler TestMessage ()+    , testOnDemandReceived :: Word64 -> Deferred Object -> ServiceHandler TestMessage ()     }  instance Storable TestMessage where@@ -34,6 +38,7 @@     defaultServiceAttributes _ = TestMessageAttributes         { testMessageReceived = \_ _ _ _ -> return ()         , testStreamsReceived = \_ -> return ()+        , testOnDemandReceived = \_ _ -> return ()         }      serviceHandler smsg = do@@ -49,6 +54,14 @@         when (not $ null streams) $ do             cb <- asks $ testStreamsReceived . svcAttributes             cb streams++        case obj of+            OnDemand size dgst -> do+                cb <- asks $ testOnDemandReceived . svcAttributes+                server <- asks svcServer+                pid <- asks svcPeerIdentity+                cb size =<< liftIO (deferLoadWithServer dgst (DeferredExactSize size) server [ refDigest $ storedRef $ idData pid ])+            _ -> return ()   openTestStreams :: Int -> ServiceHandler TestMessage [ StreamWriter ]

@@ -30,7 +30,9 @@     sendBytesToAddress (WebSocketAddress _ conn) msg = do         WS.sendDataMessage conn $ WS.Binary $ BL.fromStrict msg     connectionToAddressClosed (WebSocketAddress _ conn) = do-        WS.sendClose conn BL.empty+        WS.sendClose conn BL.empty `catch` \e -> if+            | Just WS.ConnectionClosed <- fromException e -> return ()+            | otherwise -> throwIO e  startWebsocketServer :: Server -> String -> Int -> (String -> IO ()) -> IO () startWebsocketServer server addr port logd = do@@ -40,7 +42,15 @@             u <- newUnique             let paddr = WebSocketAddress u conn             void $ serverPeerCustom server paddr-            handle (\(e :: SomeException) -> logd $ "WebSocket thread exception: " ++ show e) $ do++            let handler e+                    | Just WS.CloseRequest {} <- fromException e = do+                        dropPeerAddress server $ CustomPeerAddress paddr+                    | Just WS.ConnectionClosed <- fromException e = do+                        dropPeerAddress server $ CustomPeerAddress paddr+                    | otherwise = do+                        logd $ "WebSocket thread exception: " ++ show e+            handle handler $ do                 WS.withPingThread conn 30 (return ()) $ do                     forever $ do                         WS.receiveDataMessage conn >>= \case

@@ -50,6 +50,7 @@ import Data.Text (Text) import Data.Time +import Erebos.Conversation.Class import Erebos.Identity import Erebos.PubKey import Erebos.Service@@ -59,6 +60,17 @@ import Erebos.Storage.Head import Erebos.Storage.Merge import Erebos.Util+++instance ConversationType ChatroomState ChatMessage where+    convMessageFrom = cmsgFrom+    convMessageTime = cmsgTime+    convMessageText = cmsgText++    convReference = refDigest . storedRef . head . filterAncestors . concatMap storedRoots . roomStateData++    convMessageListSince mbSince cstate =+        map (, False) $ threadToListSince (maybe [] roomStateMessageData mbSince) (roomStateMessageData cstate)   data ChatroomData = ChatroomData

@@ -4,6 +4,8 @@     contactCustomName,     contactName, +    ContactData(..),+     contactSetName,      ContactService,

@@ -1,3 +1,5 @@+{-# LANGUAGE OverloadedStrings #-}+ module Erebos.Conversation (     Message,     messageFrom,@@ -5,6 +7,7 @@     messageText,     messageUnread,     formatMessage,+    formatMessageFT,      Conversation,     isSameConversation,@@ -14,7 +17,9 @@     isChatroomStateConversation,     reloadConversation,     lookupConversations,+    lookupConversationByRef, +    conversationReference,     conversationName,     conversationPeer,     conversationHistory,@@ -33,43 +38,52 @@ import Data.Time.LocalTime  import Erebos.Chatroom+import Erebos.Conversation.Class import Erebos.DirectMessage import Erebos.Identity import Erebos.State import Erebos.Storable+import Erebos.TextFormat+import Erebos.TextFormat.Types  -data Message = DirectMessageMessage DirectMessage Bool-             | ChatroomMessage ChatMessage Bool+data Message = forall conv msg. ConversationType conv msg => Message msg Bool +withMessage :: (forall conv msg. ConversationType conv msg => msg -> a) -> Message -> a+withMessage f (Message msg _) = f msg+ messageFrom :: Message -> ComposedIdentity-messageFrom (DirectMessageMessage msg _) = msgFrom msg-messageFrom (ChatroomMessage msg _) = cmsgFrom msg+messageFrom = withMessage convMessageFrom  messageTime :: Message -> ZonedTime-messageTime (DirectMessageMessage msg _) = msgTime msg-messageTime (ChatroomMessage msg _) = cmsgTime msg+messageTime = withMessage convMessageTime  messageText :: Message -> Maybe Text-messageText (DirectMessageMessage msg _) = Just $ msgText msg-messageText (ChatroomMessage msg _) = cmsgText msg+messageText = withMessage convMessageText  messageUnread :: Message -> Bool-messageUnread (DirectMessageMessage _ unread) = unread-messageUnread (ChatroomMessage _ unread) = unread+messageUnread (Message _ unread) = unread  formatMessage :: TimeZone -> Message -> String-formatMessage tzone msg = concat-    [ formatTime defaultTimeLocale "[%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ messageTime msg-    , maybe "<unnamed>" T.unpack $ idName $ messageFrom msg-    , maybe "" ((": "<>) . T.unpack) $ messageText msg-    ]+formatMessage tzone = T.unpack . renderPlainText . formatMessageFT tzone +formatMessageFT :: TimeZone -> Message -> FormattedText+formatMessageFT tzone msg =+    (if messageUnread msg then FormattedText (CustomTextColor (Just BrightYellow) Nothing) else id) $ mconcat+        [ PlainText $ T.pack $ formatTime defaultTimeLocale "[%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ messageTime msg+        , maybe "<unnamed>" PlainText $ idName $ messageFrom msg+        , maybe "" ((": " <>) . PlainText) $ messageText msg+        ] + data Conversation     = DirectMessageConversation DirectMessageThread     | ChatroomConversation ChatroomState +withConversation :: (forall conv msg. ConversationType conv msg => conv -> a) -> Conversation -> a+withConversation f (DirectMessageConversation conv) = f conv+withConversation f (ChatroomConversation conv) = f conv+ isSameConversation :: Conversation -> Conversation -> Bool isSameConversation (DirectMessageConversation t) (DirectMessageConversation t')     = sameIdentity (msgPeer t) (msgPeer t')@@ -101,7 +115,13 @@ lookupConversations :: MonadHead LocalState m => m [ Conversation ] lookupConversations = map DirectMessageConversation . dmThreadList . lookupSharedValue . lsShared . fromStored <$> getLocalHead +lookupConversationByRef :: MonadHead LocalState m => RefDigest -> m (Maybe Conversation)+lookupConversationByRef dgst = find ((dgst ==) . conversationReference) <$> lookupConversations ++conversationReference :: Conversation -> RefDigest+conversationReference = withConversation convReference+ conversationName :: Conversation -> Text conversationName (DirectMessageConversation thread) = fromMaybe (T.pack "<unnamed>") $ idName $ msgPeer thread conversationName (ChatroomConversation rstate) = fromMaybe (T.pack "<unnamed>") $ roomName =<< roomStateRoom rstate@@ -111,8 +131,7 @@ conversationPeer (ChatroomConversation _) = Nothing  conversationHistory :: Conversation -> [ Message ]-conversationHistory (DirectMessageConversation thread) = map (\msg -> DirectMessageMessage msg False) $ dmThreadToList thread-conversationHistory (ChatroomConversation rstate) = map (\msg -> ChatroomMessage msg False) $ roomStateMessages rstate+conversationHistory = withConversation $ map (uncurry Message) . convMessageListSince Nothing   sendMessage :: (MonadHead LocalState m, MonadError e m, FromErebosError e) => Conversation -> Text -> m ()

@@ -0,0 +1,20 @@+module Erebos.Conversation.Class (+    ConversationType(..),+    RefDigest,+) where++import Data.Text (Text)+import Data.Time.LocalTime+import Data.Typeable++import Erebos.Identity+import Erebos.Object+++class (Typeable conv, Typeable msg) => ConversationType conv msg | conv -> msg, msg -> conv where+    convMessageFrom :: msg -> ComposedIdentity+    convMessageTime :: msg -> ZonedTime+    convMessageText :: msg -> Maybe Text++    convReference :: conv -> RefDigest+    convMessageListSince :: Maybe conv -> conv -> [ ( msg, Bool ) ]

@@ -1,6 +1,7 @@ module Erebos.DirectMessage (     DirectMessage(..),     sendDirectMessage,+    dmMarkAsSeen,     updateDirectMessagePeer,     createOrUpdateDirectMessagePeer, @@ -11,7 +12,7 @@     dmThreadList,      DirectMessageThread(..),-    dmThreadToList, dmThreadToListSince,+    dmThreadToList, dmThreadToListSince, dmThreadToListUnread, dmThreadToListSinceUnread,     dmThreadView,      watchDirectMessageThreads,@@ -25,6 +26,7 @@  import Data.List import Data.Ord+import Data.Proxy import Data.Set (Set) import Data.Set qualified as S import Data.Text (Text)@@ -32,6 +34,7 @@ import Data.Time.Format import Data.Time.LocalTime +import Erebos.Conversation.Class import Erebos.Discovery import Erebos.Identity import Erebos.Network@@ -42,6 +45,18 @@ import Erebos.Storage.Head import Erebos.Storage.Merge ++instance ConversationType DirectMessageThread DirectMessage where+    convMessageFrom = msgFrom+    convMessageTime = msgTime+    convMessageText = Just . msgText++    convReference = refDigest . storedRef . head . idDataF . msgPeer++    convMessageListSince mbSince thread =+        threadToListHelper (msgSeen thread) (maybe S.empty (S.fromAscList . msgHead) mbSince) (msgHead thread)++ data DirectMessage = DirectMessage     { msgFrom :: ComposedIdentity     , msgPrev :: [ Stored DirectMessage ]@@ -71,12 +86,21 @@     { dmOwnerMismatch = svcPrint "Owner mismatch"     } +data DirectMessageGlobalState = DirectMessageGlobalState+    { dmgsLastState :: Maybe [ Stored MessageState ]+    }+ instance Service DirectMessage where     serviceID _ = mkServiceID "c702076c-4928-4415-8b6b-3e839eafcb0d"      type ServiceAttributes DirectMessage = DirectMessageAttributes     defaultServiceAttributes _ = defaultDirectMessageAttributes +    type ServiceGlobalState DirectMessage = DirectMessageGlobalState+    emptyServiceGlobalState _ = DirectMessageGlobalState+        { dmgsLastState = Nothing+        }+     serviceHandler smsg = do         let msg = fromStored smsg         powner <- asks $ finalOwner . svcPeerIdentity@@ -194,6 +218,23 @@             }         return $ DirectMessageThreads [ next ] (dmThreadView [ next ]) +dmMarkAsSeen+    :: (Foldable f, Applicative f, MonadHead LocalState m)+    => Identity f -> m ()+dmMarkAsSeen pid = do+    updateLocalState_ $ updateSharedState_ $ \(DirectMessageThreads prev _) -> do+        let powner = finalOwner pid+            received = findMsgProperty powner msReceived prev+        next <- mstore MessageState+            { msPrev = prev+            , msPeer = powner+            , msReady = []+            , msSent = []+            , msReceived = []+            , msSeen = received+            }+        return $ DirectMessageThreads [ next ] (dmThreadView [ next ])+ updateDirectMessagePeer     :: (Foldable f, Applicative f, MonadHead LocalState m)     => Identity f -> m ()@@ -262,8 +303,12 @@                 return unchanged  findMissingPeers :: Server -> DirectMessageThreads -> ExceptT ErebosError IO ()-findMissingPeers server threads = do-    forM_ (dmThreadList threads) $ \thread -> do+findMissingPeers server (DirectMessageThreads states threads) = do+    prev <- modifyServiceGlobalState server (Proxy @DirectMessage) $ \gs ->+        ( gs { dmgsLastState = Just states }, dmgsLastState gs )+    let diffPeers = map (msPeer . fromStored) . storedDifference states <$> prev++    forM_ (takeWhile (\t -> maybe True (any (sameIdentity $ msgPeer t)) diffPeers) threads) $ \thread -> do         when (msgHead thread /= msgReceived thread) $ do             mapM_ (discoverySearch server) $ map (refDigest . storedRef) $ idDataF $ msgPeer thread @@ -277,15 +322,21 @@     }  dmThreadToList :: DirectMessageThread -> [ DirectMessage ]-dmThreadToList thread = threadToListHelper S.empty $ msgHead thread+dmThreadToList thread = map fst $ threadToListHelper (msgSeen thread) S.empty $ msgHead thread  dmThreadToListSince :: DirectMessageThread -> DirectMessageThread -> [ DirectMessage ]-dmThreadToListSince since thread = threadToListHelper (S.fromAscList $ msgHead since) (msgHead thread)+dmThreadToListSince since thread = map fst $ threadToListHelper (msgSeen thread) (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))+dmThreadToListUnread :: DirectMessageThread -> [ ( DirectMessage, Bool ) ]+dmThreadToListUnread thread = threadToListHelper (msgSeen thread) S.empty $ msgHead thread++dmThreadToListSinceUnread :: DirectMessageThread -> DirectMessageThread -> [ ( DirectMessage, Bool ) ]+dmThreadToListSinceUnread since thread = threadToListHelper (msgSeen thread) (S.fromAscList $ msgHead since) (msgHead thread)++threadToListHelper :: [ Stored DirectMessage ] -> Set (Stored DirectMessage) -> [ Stored DirectMessage ] -> [ ( DirectMessage, Bool ) ]+threadToListHelper seen used msgs+    | msg : msgs' <- filter (`S.notMember` used) $ reverse $ sortBy (comparing cmpView) msgs =+        ( fromStored msg, not $ any (msg `precedesOrEquals`) seen ) : threadToListHelper seen (S.insert msg used) (msgs' ++ msgPrev (fromStored msg))     | otherwise = []   where     cmpView msg = (zonedTimeToUTC $ msgTime $ fromStored msg, msg)

@@ -67,6 +67,7 @@     , discoveryTurnPort :: Maybe Word16     , discoveryTurnServer :: Maybe Text     , discoveryProvideTunnel :: Peer -> PeerAddress -> Bool+    , discoveryDebugLog :: Bool     }  defaultDiscoveryAttributes :: DiscoveryAttributes@@ -76,6 +77,7 @@     , discoveryTurnPort = Nothing     , discoveryTurnServer = Nothing     , discoveryProvideTunnel = \_ _ -> False+    , discoveryDebugLog = False     }  data DiscoveryConnection = DiscoveryConnection@@ -248,6 +250,13 @@             peer <- asks svcPeer             paddrs <- getPeerAddresses peer +            debugLog $ unwords+                [ "new peer"+                , show [ refDigest $ storedRef $ idData pid, refDigest $ storedRef $ idExtData pid ]+                , show $ map (refDigest . storedRef) $ idDataF $ finalOwner pid+                , show paddrs+                ]+             let insertHelper new old | dpPriority new > dpPriority old = new                                      | otherwise                       = old @@ -288,6 +297,7 @@                 }          DiscoverySearch edgst -> do+            pid <- asks svcPeerIdentity             dpeer <- M.lookup (either refDigest id edgst) . dgsPeers <$> svcGetGlobal             peer <- asks svcPeer             paddr <- asks svcPeerAddress@@ -295,7 +305,11 @@             let offerTunnel                     | discoveryProvideTunnel attrs peer paddr = (++ [ DiscoveryTunnel ])                     | otherwise                               = id-            replyPacket $ DiscoveryResult edgst $ maybe [] (offerTunnel . dpAddress) dpeer+            let results = maybe [] (offerTunnel . dpAddress) dpeer+            replyPacket $ DiscoveryResult edgst results+            debugLog $ "search by " <> show (refDigest $ storedRef $ idData pid) <>+                " for " <> show (either refDigest id edgst) <>+                " result [" <> T.unpack (T.intercalate "," $ map toText results) <> "]"          DiscoveryResult _ [] -> do             -- not found@@ -323,6 +337,7 @@ #ifdef ENABLE_ICE_SUPPORT                         getIceConfig >>= \case                             Just config -> do+                                printOp <- asks svcPrintOp                                 void $ liftIO $ forkIO $ do                                     ice <- iceCreateSession config PjIceSessRoleControlling $ \ice -> do                                         rinfo <- iceRemoteInfo ice@@ -338,7 +353,7 @@                                             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+                                            Left err -> printOp $ "Discovery: failed to send connection request: " ++ err                                      runAsService $ do                                         let upd dp = dp { dpIceSession = Just ice }@@ -391,12 +406,13 @@                     peer <- asks svcPeer                     getIceConfig >>= \case                         Just config -> do+                            printOp <- asks svcPrintOp                             liftIO $ void $ iceCreateSession config PjIceSessRoleControlled $ \ice -> do                                 rinfo <- iceRemoteInfo ice                                 res <- runExceptT $ sendToPeer peer $ DiscoveryConnectionResponse rconn { dconnIceInfo = Just rinfo }                                 case res of                                     Right _ -> iceConnect ice prinfo $ void $ serverPeerIce server ice-                                    Left err -> putStrLn $ "Discovery: failed to send connection response: " ++ err+                                    Left err -> printOp $ "Discovery: failed to send connection response: " ++ err                         Nothing -> do                             return () #endif@@ -419,6 +435,8 @@                                         replyPacket $ DiscoveryConnectionResponse rconn                                     | fromSource : _ <- streams -> do                                         void $ liftIO $ forkIO $ runPeerService @DiscoveryService dpeer $ do+                                            debugLog $ "setting up tunnel from " <> show (either refDigest id $ dconnSource conn) <>+                                                " to " <> show (either refDigest id $ dconnTarget conn)                                             toTarget <- openStream                                             svcModify $ \s -> s { dpsRelayedTunnelRequests =                                                 ( either refDigest id $ dconnSource conn, ( fromSource, toTarget )) : dpsRelayedTunnelRequests s }@@ -535,6 +553,19 @@         forM_ searchingFor $ \dgst -> do             sendToPeer peer $ DiscoverySearch (Right dgst) +    serviceUpdatedPeer = do+        pid <- asks svcPeerIdentity+        peer <- asks svcPeer+        isPeerDropped peer >>= \case+            True -> do+                peers <- dgsPeers <$> svcGetGlobal+                let peers' = M.filter ((Just peer /=) . dpPeer) peers+                svcModifyGlobal $ \s -> s { dgsPeers = peers' }+                debugLog $ "dropped peer " <> show [ refDigest $ storedRef $ idData pid, refDigest $ storedRef $ idExtData pid ] <>+                    ", map size " <> show (M.size peers) <> " -> " <> show (M.size peers')+            False -> do+                debugLog $ "updated peer " <> show [ refDigest $ storedRef $ idData pid, refDigest $ storedRef $ idExtData pid ]+ #ifdef ENABLE_ICE_SUPPORT     serviceStopServer _ _ _ pstates = do         forM_ pstates $ \( _, DiscoveryPeerState {..} ) -> do@@ -542,6 +573,13 @@ #endif  +debugLog :: String -> ServiceHandler DiscoveryService ()+debugLog str = do+    asks (discoveryDebugLog . svcAttributes) >>= \case+        True -> svcPrint $ "discovery: " <> str+        False -> return ()++ identityDigests :: Foldable f => Identity f -> [ RefDigest ] identityDigests pid = map (refDigest . storedRef) $ idDataF =<< unfoldOwners pid @@ -566,20 +604,34 @@ #endif  -discoverySearch :: (MonadIO m, MonadError e m, FromErebosError e) => Server -> RefDigest -> m ()+-- | Start search for an identity identified by given ref using the discovery+-- service.+discoverySearch+    :: forall m e. (MonadIO m, MonadError e m, FromErebosError e)+    => Server -- ^ `Server' object to run the discovery+    -> RefDigest -- ^ Reference identifying the intended peer+    -> m () discoverySearch server dgst = do-    peers <- liftIO $ getCurrentPeerList server-    match <- forM peers $ \peer -> do-        getPeerIdentity peer >>= \case-            PeerIdentityFull pid -> do-                return $ dgst `elem` identityDigests pid-            _ -> return False-    when (not $ or match) $ do-        modifyServiceGlobalState server (Proxy @DiscoveryService) $ \s -> (, ()) s-            { dgsSearchingFor = S.insert dgst $ dgsSearchingFor s-            }-        forM_ peers $ \peer -> do-            sendToPeer peer $ DiscoverySearch $ Right dgst+    flip catchError (\e -> case toErebosError e of+            Just (UnhandledService svc) | svc == serviceID (Proxy @DiscoveryService) -> return ()+            _ -> throwError e) $ do+        peers <- liftIO $ getCurrentPeerList server+        match <- forM peers $ \peer -> do+            getPeerIdentity peer >>= \case+                PeerIdentityFull pid -> do+                    return $ dgst `elem` identityDigests pid+                _ -> return False+        when (not $ or match) $ do+            alreadySearching <- modifyServiceGlobalState server (Proxy @DiscoveryService) $ \s ->+                let alreadySearching = S.member dgst $ dgsSearchingFor s+                 in ( if alreadySearching then s else s+                         { dgsSearchingFor =  S.insert dgst $ dgsSearchingFor s+                         }+                    , alreadySearching+                    )+            when (not alreadySearching) $ do+                forM_ peers $ \peer -> do+                    sendToPeer peer $ DiscoverySearch $ Right dgst   data TunnelAddress = TunnelAddress@@ -630,7 +682,7 @@             receivedFromCustomAddress server taddr stpData             receiveFromTunnel server taddr         StreamClosed {} -> do-            return ()+            dropPeerAddress server $ CustomPeerAddress taddr   discoverySetupTunnel :: Peer -> RefDigest -> IO ()

@@ -3,19 +3,24 @@     showErebosError,      FromErebosError(..),+    throwErebosError,     throwOtherError, ) where  import Control.Monad.Except +import {-# SOURCE #-} Erebos.Network.Protocol + data ErebosError     = ManyErrors [ ErebosError ]     | OtherError String+    | UnhandledService ServiceID  showErebosError :: ErebosError -> String showErebosError (ManyErrors errs) = unlines $ map showErebosError errs showErebosError (OtherError str) = str+showErebosError (UnhandledService svc) = "unhandled service ‘" ++ show svc ++ "’"  instance Semigroup ErebosError where     ManyErrors [] <> b = b@@ -23,7 +28,7 @@     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 ]+    a <> b = ManyErrors [ a, b ]  instance Monoid ErebosError where     mempty = ManyErrors []@@ -31,9 +36,14 @@  class FromErebosError e where     fromErebosError :: ErebosError -> e+    toErebosError :: e -> Maybe ErebosError  instance FromErebosError ErebosError where     fromErebosError = id+    toErebosError = Just +throwErebosError :: (MonadError e m, FromErebosError e) => ErebosError -> m a+throwErebosError = throwError . fromErebosError+ throwOtherError :: (MonadError e m, FromErebosError e) => String -> m a-throwOtherError = throwError . fromErebosError . OtherError+throwOtherError = throwErebosError . OtherError

@@ -391,13 +391,13 @@     roots idt = uniq $ sort $ concatMap storedRoots $ toList $ idDataF idt  -unfoldOwners :: (Foldable m) => Identity m -> [ComposedIdentity]+unfoldOwners :: Foldable m => Identity m -> [ComposedIdentity] unfoldOwners = unfoldr (fmap (\i -> (i, idOwner i))) . Just . toComposedIdentity -finalOwner :: (Foldable m, Applicative m) => Identity m -> ComposedIdentity+finalOwner :: Foldable m => Identity m -> ComposedIdentity finalOwner = last . unfoldOwners -displayIdentity :: (Foldable m, Applicative m) => Identity m -> Text+displayIdentity :: Foldable m => Identity m -> Text displayIdentity identity = T.concat     [ T.intercalate (T.pack " / ") $ map (fromMaybe (T.pack "<unnamed>") . idName) owners     ]

@@ -0,0 +1,385 @@+{-# LANGUAGE OverloadedStrings #-}++module Erebos.Invite (+    Invite(..),+    InviteData(..),+    AcceptedInvite(..),+    AcceptedInviteData(..),+    AcceptedInviteStatus(..),+    InviteToken, showInviteToken, textInviteToken, parseInviteToken,+    InviteService,+    InviteServiceAttributes(..),++    createSingleContactInvite,+    acceptInvite,+) where++import Control.Arrow+import Control.Monad+import Control.Monad.Except+import Control.Monad.IO.Class+import Control.Monad.Reader++import Crypto.Random++import Data.ByteArray (ByteArray, ByteArrayAccess)+import Data.ByteString (ByteString)+import Data.ByteString.Char8 qualified as BC+import Data.Foldable+import Data.Maybe+import Data.Ord+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding+import Data.Time.LocalTime++import Erebos.Contact+import Erebos.Discovery+import Erebos.Identity+import Erebos.Network+import Erebos.Object+import Erebos.PubKey+import Erebos.Service+import Erebos.Set+import Erebos.State+import Erebos.Storable+import Erebos.Storage.Merge+import Erebos.Util+++data Invite = Invite+    { inviteData :: [ Stored InviteData ]+    , inviteToken :: Maybe InviteToken+    , inviteCreated :: Maybe ZonedTime+    , inviteAccepted :: [ ( Stored (Signed ExtendedIdentityData), Maybe ZonedTime ) ]+    , inviteContact :: Maybe Text+    }++data InviteData = InviteData+    { invdPrev :: [ Stored InviteData ]+    , invdTime :: Maybe ZonedTime+    , invdToken :: Maybe InviteToken+    , invdAccepted :: Maybe (Stored (Signed ExtendedIdentityData))+    , invdContact :: Maybe Text+    }++instance Storable InviteData where+    store' x = storeRec $ do+        mapM_ (storeRef "PREV") $ invdPrev x+        mapM_ (storeDate "time") $ invdTime x+        mapM_ (storeBinary "token") $ invdToken x+        mapM_ (storeRef "accepted") $ invdAccepted x+        mapM_ (storeText "contact") $ invdContact x++    load' = loadRec $ InviteData+        <$> loadRefs "PREV"+        <*> loadMbDate "time"+        <*> loadMbBinary "token"+        <*> loadMbRef "accepted"+        <*> loadMbText "contact"+++newtype InviteToken = InviteToken ByteString+    deriving (Eq, Ord, Semigroup, Monoid, ByteArray, ByteArrayAccess)++showInviteToken :: InviteToken -> String+showInviteToken (InviteToken token) = BC.unpack (showHex token)++textInviteToken :: InviteToken -> Text+textInviteToken (InviteToken token) = decodeUtf8 (showHex token)++parseInviteToken :: Text -> Maybe InviteToken+parseInviteToken text = InviteToken <$> (readHex $ encodeUtf8 text)+++instance Mergeable Invite where+    type Component Invite = InviteData++    mergeSorted invdata = Invite+        { inviteData = invdata+        , inviteToken = findPropertyFirst invdToken invdata+        , inviteCreated = join $ findPropertyFirst (\invd -> (const $ invdTime invd) <$> invdTime invd) invdata+        , inviteAccepted = findProperty (\invd -> ( , invdTime invd ) <$> invdAccepted invd) invdata+        , inviteContact = findPropertyFirst invdContact invdata+        }++    toComponents = inviteData++instance SharedType (Set Invite) where+    sharedTypeID _ = mkSharedTypeID "78da787a-9380-432e-a51d-532a30d27b3d"+++data AcceptedInvite = AcceptedInvite+    { acceptedInviteData :: [ Stored AcceptedInviteData ]+    , acceptedInviteToken :: Maybe InviteToken+    , acceptedInviteFrom :: Maybe RefDigest+    , acceptedInviteStatus :: AcceptedInviteStatus+    }++data AcceptedInviteData = AcceptedInviteData+    { aidPrev :: [ Stored AcceptedInviteData ]+    , aidToken :: Maybe InviteToken+    , aidFrom :: Maybe RefDigest+    , aidConfirmed :: Bool+    , aidRejected :: Bool+    }++data AcceptedInviteStatus+    = AcceptedInvitePending+    | AcceptedInviteRejected+    | AcceptedInviteConfirmed++instance Storable AcceptedInviteData where+    store' AcceptedInviteData {..} = storeRec $ do+        mapM_ (storeRef "PREV") aidPrev+        mapM_ (storeBinary "token") aidToken+        mapM_ (storeRawWeak "from") aidFrom+        when aidConfirmed $ storeEmpty "confirmed"+        when aidRejected $ storeEmpty "rejected"++    load' = loadRec $ do+        aidPrev <- loadRefs "PREV"+        aidToken <- loadMbBinary "token"+        aidFrom <- loadMbRawWeak "from"+        aidConfirmed <- isJust <$> loadMbEmpty "confirmed"+        aidRejected <- isJust <$> loadMbEmpty "rejected"+        return AcceptedInviteData {..}++instance Mergeable AcceptedInvite where+    type Component AcceptedInvite = AcceptedInviteData++    mergeSorted aidata = AcceptedInvite+        { acceptedInviteData = aidata+        , acceptedInviteToken = findPropertyFirst aidToken aidata+        , acceptedInviteFrom = findPropertyFirst aidFrom aidata+        , acceptedInviteStatus = fromMaybe AcceptedInvitePending $ flip findPropertyFirst aidata $ \case+            AcceptedInviteData {..}+                | aidConfirmed -> Just AcceptedInviteConfirmed+                | aidRejected -> Just AcceptedInviteRejected+                | isJust aidToken -> Just AcceptedInvitePending+                | otherwise -> Nothing+        }+    toComponents = acceptedInviteData++instance SharedType (Set AcceptedInvite) where+    sharedTypeID _ = mkSharedTypeID "b1ebf228-4892-476b-ba04-0c26320139b1"+++createSingleContactInvite :: MonadHead LocalState m => Text -> m Invite+createSingleContactInvite name = do+    time <- liftIO getZonedTime+    token <- liftIO $ getRandomBytes 32+    invite <- mergeSorted @Invite . (: []) <$> mstore InviteData+        { invdPrev = []+        , invdTime = Just time+        , invdToken = Just token+        , invdAccepted = Nothing+        , invdContact = Just name+        }+    updateLocalState_ $ updateSharedState_ $ \invites -> do+        storeSetAdd invite invites+    return invite++-- | Accept an invite received outside of the Erebos protocol. The acceptance+-- is recorded in the shared state and will be confirmed with the issuer when a+-- connection with their device is established.+acceptInvite+    :: MonadHead LocalState m+    => RefDigest -- ^ Reference to the identity that issued the invite+    -> InviteToken -- ^ Invite token+    -> m ()+acceptInvite from token = do+    prev <- find ((Just token ==) . acceptedInviteToken)+        . fromSetBy (comparing acceptedInviteToken) . lookupSharedValue . lsShared . fromStored+        <$> getLocalHead+    accepted <- mergeSorted @AcceptedInvite . (: []) <$> mstore AcceptedInviteData+        { aidPrev = maybe [] acceptedInviteData prev+        , aidToken = Just token+        , aidFrom = Just from+        , aidConfirmed = False+        , aidRejected = False+        }+    updateLocalState_ $ updateSharedState_ $ storeSetAdd accepted+++data InviteService+    = AcceptInvite InviteToken+    | InvalidInvite InviteToken+    | ContactInvite InviteToken (Maybe Text)+    | UnknownInvitePacket++data InviteServiceAttributes = InviteServiceAttributes+    { inviteHookAccepted :: Invite -> ServiceHandler InviteService ()+    , inviteHookReplyContact :: InviteToken -> Maybe Text -> ServiceHandler InviteService ()+    , inviteHookReplyInvalid :: InviteToken -> ServiceHandler InviteService ()+    }++defaultInviteServiceAttributes :: InviteServiceAttributes+defaultInviteServiceAttributes = InviteServiceAttributes+    { inviteHookAccepted = \Invite {..} -> do+        pid <- asks $ svcPeerIdentity+        svcPrint $ T.unpack $ "Invite" <> maybe "" ((" for “" <>) . (<> "”")) inviteContact <> " accepted by " <> displayIdentity pid+            <> " (token: " <> maybe "??" textInviteToken inviteToken <> ")"+    , inviteHookReplyContact = \token mbName -> do+        pid <- asks $ svcPeerIdentity+        svcPrint $ T.unpack $ "Invite confirmed by " <> displayIdentity pid+            <> (maybe "" (" with name " <>) mbName)+            <> " (token: " <> textInviteToken token <> ")"+    , inviteHookReplyInvalid = \token -> do+        pid <- asks $ svcPeerIdentity+        svcPrint $ T.unpack $ "Invite rejected as invalid by " <> displayIdentity pid+            <> " (token: " <> textInviteToken token <> ")"+    }++instance Storable InviteService where+    store' x = storeRec $ case x of+        AcceptInvite token -> storeBinary "accept" token+        InvalidInvite token -> storeBinary "invalid" token+        ContactInvite token mbName -> do+            storeBinary "valid" token+            maybe (storeEmpty "contact") (storeText "contact") mbName+        UnknownInvitePacket -> return ()++    load' = loadRec $ msum+        [ AcceptInvite <$> loadBinary "accept"+        , InvalidInvite <$> loadBinary "invalid"+        , ContactInvite <$> loadBinary "valid" <*> msum+            [ return Nothing <* loadEmpty "contact"+            , Just <$> loadText "contact"+            ]+        , return UnknownInvitePacket+        ]++instance Service InviteService where+    serviceID _ = mkServiceID "70bff715-6856-43a0-8c58-007a06a26eb1"++    type ServiceState InviteService = [ InviteToken ] -- accepted invites, waiting for reply+    emptyServiceState _ = []++    type ServiceAttributes InviteService = InviteServiceAttributes+    defaultServiceAttributes _ = defaultInviteServiceAttributes++    serviceHandler = fromStored >>> \case+        AcceptInvite token -> do+            invites <- fromSetBy (comparing inviteToken) . lookupSharedValue . lsShared . fromStored <$> getLocalHead+            case find ((Just token ==) . inviteToken) invites of+                Just invite+                    | Just name <- inviteContact invite+                    , [] <- inviteAccepted invite+                    -> do+                        asks (inviteHookAccepted . svcAttributes) >>= ($ invite)+                        time <- liftIO getZonedTime+                        identity <- asks svcPeerIdentity+                        cdata <- mstore ContactData+                            { cdPrev = []+                            , cdIdentity = idExtDataF $ finalOwner identity+                            , cdName = Just name+                            }+                        invdata <- mstore InviteData+                            { invdPrev = inviteData invite+                            , invdTime = Just time+                            , invdToken = Nothing+                            , invdAccepted = Just (idExtData identity)+                            , invdContact = Nothing+                            }+                        updateLocalState_ $ updateSharedState_ $ storeSetAdd (mergeSorted @Contact [ cdata ])+                        updateLocalState_ $ updateSharedState_ $ storeSetAdd (mergeSorted @Invite [ invdata ])+                        replyPacket $ ContactInvite token Nothing++                    | otherwise -> do+                        replyPacket $ InvalidInvite token++                Nothing -> do+                    replyPacket $ InvalidInvite token++        InvalidInvite token -> do+            asks (inviteHookReplyInvalid . svcAttributes) >>= ($ token)+            svcModify $ filter (/= token)++            accepted <- fromSetBy (comparing acceptedInviteToken) . lookupSharedValue . lsShared . fromStored <$> getLocalHead+            case find ((Just token ==) . acceptedInviteToken) accepted of+                Just invite -> do+                    aidata <- mstore AcceptedInviteData+                        { aidPrev = acceptedInviteData invite+                        , aidToken = Nothing+                        , aidFrom = Nothing+                        , aidConfirmed = False+                        , aidRejected = True+                        }+                    updateLocalState_ $ updateSharedState_ $ storeSetAdd (mergeSorted @AcceptedInvite [ aidata ])+                Nothing -> return ()++        ContactInvite token mbName -> do+            asks (inviteHookReplyContact . svcAttributes) >>= ($ mbName) . ($ token)+            waitingTokens <- svcGet+            if token `elem` waitingTokens+              then do+                svcSet $ filter (/= token) waitingTokens++                accepted <- fromSetBy (comparing acceptedInviteToken) . lookupSharedValue . lsShared . fromStored <$> getLocalHead+                case find ((Just token ==) . acceptedInviteToken) accepted of+                    Just invite -> do+                        aidata <- mstore AcceptedInviteData+                            { aidPrev = acceptedInviteData invite+                            , aidToken = Nothing+                            , aidFrom = Nothing+                            , aidConfirmed = True+                            , aidRejected = False+                            }+                        updateLocalState_ $ updateSharedState_ $ storeSetAdd (mergeSorted @AcceptedInvite [ aidata ])+                    Nothing -> return ()++                identity <- asks svcPeerIdentity+                cdata <- mstore ContactData+                    { cdPrev = []+                    , cdIdentity = idExtDataF $ finalOwner identity+                    , cdName = Nothing+                    }+                updateLocalState_ $ updateSharedState_ $ storeSetAdd (mergeSorted @Contact [ cdata ])+              else do+                svcPrint $ "Received unexpected invite response for " <> BC.unpack (showHex token)++        UnknownInvitePacket -> do+            svcPrint $ "Received unknown invite packet"++    serviceNewPeer = do+        invites <- fromSetBy (comparing acceptedInviteToken) . lookupSharedValue . lsShared . fromStored <$> getLocalHead+        peerDigests <- asks $ identityOwnerDigests . svcPeerIdentity+        forM_ invites $ \case+            AcceptedInvite+                { acceptedInviteToken = Just token+                , acceptedInviteFrom = Just from+                , acceptedInviteStatus = AcceptedInvitePending+                } | from `elem` peerDigests -> do+                    svcModify (token :)+                    replyPacket $ AcceptInvite token+            _ -> return ()++    serviceStorageWatchers _ = (:[]) $+        GlobalStorageWatcher (lookupSharedValue . lsShared . fromStored) sendAcceptedInvites+++sendAcceptedInvites :: Server -> Set AcceptedInvite -> ExceptT ErebosError IO ()+sendAcceptedInvites server aiset = do+    forM_ (fromSetBy (comparing acceptedInviteToken) aiset) $ \case+        AcceptedInvite+            { acceptedInviteToken = Just token+            , acceptedInviteFrom = Just from+            , acceptedInviteStatus = AcceptedInvitePending+            } -> do+                let matchPeer peer = do+                        getPeerIdentity peer >>= \case+                            PeerIdentityFull pid -> do+                                return $ from `elem` identityOwnerDigests pid+                            _ -> return False++                liftIO (findPeer server matchPeer) >>= \case+                    Just peer -> runPeerService @InviteService peer $ do+                        svcModify (token :)+                        replyPacket $ AcceptInvite token+                    Nothing -> do+                        discoverySearch server from+        _ -> return ()++identityOwnerDigests :: Foldable f => Identity f -> [ RefDigest ]+identityOwnerDigests pid = map (refDigest . storedRef) $ concatMap toList $ toList $ generations $ idExtDataF $ finalOwner pid

@@ -19,13 +19,14 @@     serverPeer,     serverPeerCustom,     findPeer,-    dropPeer,+    dropPeer, dropPeerAddress,     isPeerDropped,     sendToPeer, sendManyToPeer,     sendToPeerStored, sendManyToPeerStored,     sendToPeerWith,     runPeerService,     modifyServiceGlobalState,+    requestDataFromPeer, DataRequestResult(..),      discoveryPort, ) where@@ -232,21 +233,27 @@ newWaitingRef :: RefDigest -> (Ref -> WaitingRefCallback) -> PacketHandler WaitingRef newWaitingRef dgst act = do     peer@Peer {..} <- gets phPeer-    wref <- WaitingRef peerStorage_ (partialRefFromDigest peerInStorage dgst) act <$> liftSTM (newTVar (Left []))+    let cb (DataRequestFulfilled ref) = act ref+        cb _                          = return ()+    wref <- WaitingRef peerStorage_ (partialRefFromDigest peerInStorage dgst) maxBound cb <$> liftSTM (newTVar (Left []))     modifyTMVarP peerWaitingRefs (wref:)     liftSTM $ writeTQueue (serverDataResponse $ peerServer peer) (peer, Nothing)     return wref  -forkServerThread :: Server -> IO () -> IO ()-forkServerThread server act = do+forkServerThread :: Server -> String -> IO () -> IO ()+forkServerThread server label act = do     modifyMVar_ (serverThreads server) $ \ts -> do         t <- forkIO $ do             t <- myThreadId-            act+            catchAndLogError act             modifyMVar_ (serverThreads server) $ return . filter (/=t)         return (t:ts)+  where+    catchAndLogError = handle $ \(e :: SomeException) ->+        atomically $ writeTQueue (serverErrorLog server) $ "server " <> label <> ": " <> show e + startServer :: ServerOptions -> Head LocalState -> (String -> IO ()) -> [SomeService] -> IO Server startServer serverOptions serverOrigHead logd' serverServices = do     let serverStorage = headStorage serverOrigHead@@ -266,20 +273,20 @@     chanSvc <- newTQueueIO      let logd = writeTQueue serverErrorLog-    forkServerThread server $ forever $ do+    forkServerThread server "logger" $ forever $ do         logd' . (serverErrorPrefix serverOptions <>) =<< atomically (readTQueue serverErrorLog)      logt <- if         | serverTestLog serverOptions -> do             serverTestLog <- newTQueueIO-            forkServerThread server $ forever $ do+            forkServerThread server "test-logger" $ forever $ do                 logd' =<< atomically (readTQueue serverTestLog)             return $ writeTQueue serverTestLog         | otherwise -> do             return $ \_ -> return () -    forkServerThread server $ dataResponseWorker server-    forkServerThread server $ forever $ do+    forkServerThread server "data-response-worker" $ dataResponseWorker server+    forkServerThread server "io-action-worker" $ forever $ do         either (atomically . logd . showErebosError) return =<< runExceptT =<<             atomically (readTQueue serverIOActions) @@ -293,7 +300,7 @@             return sock          loop sock = do-            when (serverLocalDiscovery serverOptions) $ forkServerThread server $ do+            when (serverLocalDiscovery serverOptions) $ forkServerThread server "discovery" $ do                 announceAddreses <- fmap concat $ sequence $                     [ map (SockAddrInet6 discoveryPort 0 discoveryMulticastGroup) <$> joinMulticast sock                     , getBroadcastAddresses discoveryPort@@ -339,18 +346,22 @@                             atomically $ writeTQueue serverIOActions $ do                                 act server x -            forkServerThread server $ forever $ do+            forkServerThread server "receiver" $ forever $ do                 (msg, saddr) <- S.recvFrom sock 4096                 writeFlowIO serverRawPath (DatagramAddress saddr, msg) -            forkServerThread server $ forever $ do-                (paddr, msg) <- readFlowIO serverRawPath-                handle (\(e :: SomeException) -> atomically . logd $ "failed to send packet to " ++ show paddr ++ ": " ++ show e) $ do+            forkServerThread server "sender" $ forever $ do+                ( paddr, msg ) <- readFlowIO serverRawPath+                let logAndDropAddress :: SomeException -> IO ()+                    logAndDropAddress e = do+                        atomically . logd $ "failed to send packet to " ++ show paddr ++ ": " ++ show e+                        dropPeerAddress server paddr+                handle logAndDropAddress $ do                     case paddr of                         CustomPeerAddress addr -> sendBytesToAddress addr msg                         DatagramAddress addr -> void $ S.sendTo sock msg addr -            forkServerThread server $ forever $ do+            forkServerThread server "control-handler" $ forever $ do                 readFlowIO serverControlFlow >>= \case                     NewConnection conn mbpid -> do                         let paddr = connAddress conn@@ -361,7 +372,7 @@                                     peer <- mkPeer server paddr                                     return (M.insert paddr peer pvalue, peer) -                        forkServerThread server $ do+                        forkServerThread server "peer-handler" $ do                             atomically $ do                                 readTVar (peerState peer) >>= \case                                     PeerInit packets -> do@@ -395,10 +406,9 @@                                     Nothing -> do                                         case paddr of                                             DatagramAddress _ -> return ()-                                            CustomPeerAddress caddr -> connectionToAddressClosed caddr-+                                            CustomPeerAddress caddr -> connectionToAddressClosed caddr `catch`+                                                \(e :: SomeException) -> atomically $ logd $ "connectionToAddressClosed on " <> show paddr <> " failed: " <> show e                                         dropPeer peer-                                        atomically $ writeTChan serverChanPeer peer                             peerLoop                      ReceivedAnnounce addr _ -> do@@ -406,7 +416,7 @@              erebosNetworkProtocol (headLocalIdentity serverOrigHead) logd logt protocolRawPath protocolControlFlow -    forkServerThread server $ withSocketsDo $ do+    forkServerThread server "main-loop" $ withSocketsDo $ do         let hints = defaultHints               { addrFlags = [AI_PASSIVE]               , addrFamily = AF_INET6@@ -415,7 +425,7 @@         addr:_ <- getAddrInfo (Just hints) Nothing (Just $ show $ serverPort serverOptions)         bracket (open addr) close loop -    forkServerThread server $ forever $ do+    forkServerThread server "service-handler" $ forever $ do         ( peer, paddr, svc, ref, streams ) <- atomically $ readTQueue chanSvc         case find ((svc ==) . someServiceID) serverServices of             Just service@(SomeService (_ :: Proxy s) attr) -> runPeerServiceOn (Just ( service, attr )) streams paddr peer (serviceHandler $ wrappedLoad @s ref)@@ -450,8 +460,8 @@             Left ds -> case maybe id (filter . (/=) . refDigest) npref $ ds of                 [] -> copyRef (wrefStorage wr) (wrefPartial wr) >>= \case                           Right ref -> do-                              atomically (writeTVar tvar $ Right ref)-                              forkServerThread server $ runExceptT (wrefAction wr ref) >>= \case+                              atomically (writeTVar tvar $ Right $ DataRequestFulfilled ref)+                              forkServerThread server "request-fulfilled" $ runExceptT (wrefAction wr $ DataRequestFulfilled ref) >>= \case                                   Left err -> atomically $ writeTQueue (serverErrorLog server) (showErebosError err)                                   Right () -> return () @@ -548,7 +558,7 @@         _                  -> throwError "can't open stream without established connection"     (hdr, writer, handler) <- liftEither =<< liftSTM (connAddWriteStream conn) -    liftSTM $ writeTQueue (serverIOActions peerServer_) (liftIO $ forkServerThread peerServer_ handler)+    liftSTM $ writeTQueue (serverIOActions peerServer_) (liftIO $ forkServerThread peerServer_ "stream-writer" handler)     addHeader hdr     return writer @@ -882,14 +892,27 @@  dropPeer :: MonadIO m => Peer -> m () dropPeer peer = liftIO $ do-    modifyMVar_ (serverPeers $ peerServer peer) $ \pvalue -> do-        atomically $ do-            readTVar (peerState peer) >>= \case-                PeerConnected conn -> connClose conn-                _ -> return()-            writeTVar (peerState peer) PeerDropped-        return $ M.delete (peerAddress peer) pvalue+    modifyMVar_ (serverPeers $ peerServer peer) $ dropPeerInner peer +dropPeerAddress :: MonadIO m => Server -> PeerAddress -> m ()+dropPeerAddress server paddr = liftIO $ do+    modifyMVar_ (serverPeers server) $ \pvalue -> do+        case find ((paddr ==) . peerAddress) pvalue of+            Just peer -> dropPeerInner peer pvalue+            Nothing -> return pvalue++dropPeerInner :: Peer -> Map PeerAddress Peer -> IO (Map PeerAddress Peer)+dropPeerInner peer pvalue = do+    atomically $ do+        readTVar (peerState peer) >>= \case+            PeerConnected conn -> do+                connClose conn+                writeTChan (serverChanPeer $ peerServer peer) peer+                notifyServicesOfPeer False peer+            _ -> return ()+        writeTVar (peerState peer) PeerDropped+    return $ M.delete (peerAddress peer) pvalue+ isPeerDropped :: MonadIO m => Peer -> m Bool isPeerDropped peer = liftIO $ atomically $ readTVar (peerState peer) >>= \case     PeerDropped -> return True@@ -926,7 +949,7 @@                         (hdr, writer, handler) <- liftEither =<< lift (connAddWriteStream conn)                          lift $ writeTQueue (serverIOActions (peerServer peer)) $ do-                            liftIO $ forkServerThread (peerServer peer) handler+                            liftIO $ forkServerThread (peerServer peer) "service-stream-writer" handler                         return [ ( hdr, cb writer ) ]                     _ -> return []         liftIO $ sequence_ $ map snd streamHeaders@@ -949,7 +972,7 @@     case res of         Right () -> return ()         Left err -> liftIO $ atomically $ writeTQueue (serverErrorLog $ peerServer peer) $-            "failed to send packet to " <> show (peerAddress peer) <> ": " <> err+            "failed to prepare packet to " <> show (peerAddress peer) <> ": " <> err  sendToPeerS' :: SecurityRequirement -> Peer -> [TransportHeaderItem] -> TransportPacket Ref -> STM () sendToPeerS' secure Peer {..} ackedBy packet = do@@ -1060,7 +1083,15 @@                 putTMVar (serverServiceStates server) global'                 return res         Nothing -> do-            throwOtherError $ "unhandled service '" ++ show (toUUID svc) ++ "'"+            throwErebosError $ UnhandledService svc+++requestDataFromPeer :: MonadIO m => Peer -> RefDigest -> Word64 -> (DataRequestResult -> ExceptT ErebosError IO ()) -> m ()+requestDataFromPeer peer@Peer {..} dgst bound callback = do+    liftIO $ atomically $ do+        wref <- WaitingRef peerStorage_ (partialRefFromDigest peerInStorage dgst) bound callback <$> newTVar (Left [])+        putTMVar peerWaitingRefs . (wref :) =<< takeTMVar peerWaitingRefs+        writeTQueue (serverDataResponse peerServer_) ( peer, Nothing )   foreign import ccall unsafe "Network/ifaddrs.h erebos_join_multicast" cJoinMulticast :: CInt -> Ptr CSize -> IO (Ptr Word32)

@@ -7,6 +7,7 @@     SecurityRequirement(..),      WaitingRef(..),+    DataRequestResult(..),     WaitingRefCallback,     wrDigest, @@ -111,8 +112,11 @@     deriving (Eq, Show)  newtype ServiceID = ServiceID UUID-    deriving (Eq, Ord, Show, StorableUUID)+    deriving (Eq, Ord, StorableUUID) +instance Show ServiceID where+    show = show . toUUID+ newtype Cookie = Cookie ByteString     deriving (Eq, Show) @@ -277,6 +281,8 @@             writeTVar cChannel ChannelClosed             writeTVar gConnections . filter (/=conn) =<< readTVar gConnections             writeFlow cDataInternal Nothing+            streams <- readTVar cInStreams+            forM_ streams $ \( _, s ) -> writeFlow (sFlowIn s) (StreamClosed 0)  connAddWriteStream :: Connection addr -> STM (Either String (TransportHeaderItem, RawStreamWriter, IO ())) connAddWriteStream conn@Connection {..} = do@@ -461,9 +467,15 @@ data WaitingRef = WaitingRef     { wrefStorage :: Storage     , wrefPartial :: PartialRef-    , wrefAction :: Ref -> WaitingRefCallback-    , wrefStatus :: TVar (Either [RefDigest] Ref)+    , wrefBound :: Word64+    , wrefAction :: DataRequestResult -> WaitingRefCallback+    , wrefStatus :: TVar (Either [ RefDigest ] DataRequestResult)     }++data DataRequestResult+    = DataRequestFulfilled Ref+    | DataRequestRejected+    | DataRequestBrokenBound  type WaitingRefCallback = ExceptT ErebosError IO () 

@@ -0,0 +1,6 @@+module Erebos.Network.Protocol where++import Erebos.UUID (UUID)++newtype ServiceID = ServiceID UUID+instance Show ServiceID

@@ -18,6 +18,44 @@     readRefDigest, showRefDigest,     refDigestFromByteString, hashToRefDigest,     copyRef, partialRef, partialRefFromDigest,++    componentSize,+    partialComponentSize, ) where +import Data.ByteString.Lazy qualified as BL+import Data.Maybe+import Data.Set qualified as S+import Data.Word+ import Erebos.Object.Internal+++componentSize :: Ref -> Word64+componentSize ref = go S.empty [ ref ]+  where+    go seen (r : rs)+        | refDigest r `S.member` seen = go seen rs+        | otherwise = objectSize r + go (S.insert (refDigest r) seen) (referredFrom r ++ rs)+    go _ [] = 0++    objectSize = fromIntegral . BL.length . lazyLoadBytes+    referredFrom r = case load r of+        Rec items -> mapMaybe ((\case RecRef r' -> Just r'; _ -> Nothing) . snd) items+        _ -> []++partialComponentSize :: PartialRef -> IO Word64+partialComponentSize ref = go S.empty [ ref ]+  where+    go seen (r : rs)+        | refDigest r `S.member` seen = go seen rs+        | otherwise = do+            size <- objectSize r+            referred <- referredFrom r+            (size +) <$> go (S.insert (refDigest r) seen) (referred ++ rs)+    go _ [] = return 0++    objectSize r = either (const 0) (fromIntegral . BL.length) <$> ioLoadBytes r+    referredFrom r = ioLoadObject r >>= return . \case+        Right (Rec items) -> mapMaybe ((\case RecRef r' -> Just r'; _ -> Nothing) . snd) items+        _ -> []

@@ -0,0 +1,108 @@+module Erebos.Object.Deferred (+    Deferred,+    DeferredSize(..),+    DeferredResult(..),++    deferredRef,+    deferredLoad,+    deferredWait,+    deferredCheck,++    deferLoadWithServer,+) where++import Control.Concurrent.MVar+import Control.Monad.IO.Class++import Data.Word++import Erebos.Identity+import Erebos.Network+import Erebos.Object+import Erebos.Storable+++-- | Deffered value, which can be loaded on request. Holds a reference (digest)+-- to an object and information about suitable network peers, from which the+-- data can be requested.+data Deferred a = Deferred+    { deferredRef_ :: RefDigest+    , deferredSize :: DeferredSize+    , deferredServer :: Server+    , deferredPeers :: [ RefDigest ]+    , deferredStatus :: MVar (Maybe (MVar (DeferredResult a)))+    }++-- | Size constraint for the deferred object.+data DeferredSize+    = DeferredExactSize Word64 -- ^ Component size of the referred data must be exactly the given value.+    | DeferredMaximumSize Word64 -- ^ Component size of the referred data must not exceed the given value.++-- | Result of the deferred load request.+data DeferredResult a+    = DeferredLoaded (Stored a) -- ^ Deferred object was sucessfully loaded.+    | DeferredInvalid -- ^ Deferred object was (partially) loaded, but failed to meet the size constraint or was an invalid object.+    | DeferredFailed -- ^ Failure to load the object, e.g. no suitable peer was found.++-- | Get the digest of the deferred object.+deferredRef :: Deferred a -> RefDigest+deferredRef = deferredRef_++-- | Request the deferred object to be loaded. Does nothing if that was already+-- requested before. The result can be received using `deferredWait` or+-- `deferredCheck` functions.+deferredLoad :: (Storable a, MonadIO m) => Deferred a -> m ()+deferredLoad Deferred {..} = liftIO $ do+    modifyMVar_ deferredStatus $ \case+        Nothing -> do+            mvar <- newEmptyMVar+            let matchPeer peer =+                    getPeerIdentity peer >>= \case+                        PeerIdentityFull pid -> do+                            return $ any (`elem` identityDigests pid) deferredPeers+                        _ -> return False++            liftIO (findPeer deferredServer matchPeer) >>= \case+                Just peer -> do+                    let bound = case deferredSize of+                            DeferredExactSize s -> s+                            DeferredMaximumSize s -> s++                        checkSize ref = case deferredSize of+                            DeferredExactSize s -> componentSize ref == s+                            DeferredMaximumSize s -> componentSize ref <= s++                    requestDataFromPeer peer deferredRef_ bound $ liftIO . \case+                        DataRequestFulfilled ref+                            | checkSize ref -> putMVar mvar $ DeferredLoaded $ wrappedLoad ref+                            | otherwise -> putMVar mvar DeferredInvalid+                        DataRequestRejected -> putMVar mvar DeferredFailed+                        DataRequestBrokenBound -> putMVar mvar DeferredInvalid++                Nothing -> putMVar mvar DeferredFailed+            return $ Just mvar+        cur@Just {} -> return cur++-- | Wait for a `Deferred` value to be loaded and return the result. Requests+-- the value to be loaded if that was not already done.+deferredWait :: (Storable a, MonadIO m) => Deferred a -> m (DeferredResult a)+deferredWait d@Deferred {..} = liftIO $ readMVar deferredStatus >>= \case+    Nothing -> deferredLoad d >> deferredWait d+    Just mvar -> readMVar mvar++-- | Check if a `Deferred` value has already been loaded and return it in+-- `Just` if so, otherwise return `Nothing`. Requests the value to be loaded if+-- that was not already done.+deferredCheck :: (Storable a, MonadIO m) => Deferred a -> m (Maybe (DeferredResult a))+deferredCheck d@Deferred {..} = liftIO $ readMVar deferredStatus >>= \case+    Nothing -> deferredLoad d >> deferredCheck d+    Just mvar -> tryReadMVar mvar++deferLoadWithServer :: (Storable a, MonadIO m) => RefDigest -> DeferredSize -> Server -> [ RefDigest ] -> m (Deferred a)+deferLoadWithServer deferredRef_ deferredSize deferredServer deferredPeers = do+    deferredStatus <- liftIO $ newMVar Nothing+    return Deferred {..}+++identityDigests :: Foldable f => Identity f -> [ RefDigest ]+identityDigests pid = map (refDigest . storedRef) $ idDataF =<< unfoldOwners pid

@@ -47,6 +47,8 @@ ) where  import Control.Applicative+import Control.DeepSeq+import Control.Exception import Control.Monad import Control.Monad.Except import Control.Monad.Reader@@ -55,26 +57,27 @@ import Crypto.Hash  import Data.Bifunctor+import Data.ByteArray qualified as BA 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.ByteString qualified as B+import Data.ByteString.Char8 qualified as BC+import Data.ByteString.Lazy qualified as BL+import Data.ByteString.Lazy.Char8 qualified 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.Set qualified as S import Data.Text (Text)-import qualified Data.Text as T+import Data.Text qualified 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 Data.Word  import System.IO.Unsafe @@ -129,6 +132,7 @@ 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' _ (OnDemand size dgst) = return $ return $ OnDemand size dgst copyObject' _ ZeroObject = return $ return ZeroObject copyObject' _ (UnknownObject otype content) = return $ return $ UnknownObject otype content @@ -150,7 +154,8 @@  data Object' c     = Blob ByteString-    | Rec [(ByteString, RecItem' c)]+    | Rec [ ( ByteString, RecItem' c ) ]+    | OnDemand Word64 RefDigest     | ZeroObject     | UnknownObject ByteString ByteString     deriving (Show)@@ -176,8 +181,12 @@ 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+    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+    OnDemand size dgst ->+        let cnt = BC.unlines [ BC.pack (show size), showRefDigest dgst ]+         in BL.fromChunks [ BC.pack "ondemand ", BC.pack (show $ B.length cnt), BC.singleton '\n', cnt ]     ZeroObject -> BL.empty     UnknownObject otype cnt -> BL.fromChunks [ otype, BC.singleton ' ', BC.pack (show $ B.length cnt), BC.singleton '\n', cnt ] @@ -194,6 +203,12 @@ storeRawBytes :: PartialStorage -> BL.ByteString -> IO PartialRef storeRawBytes = unsafeStoreRawBytes +unsafeStoreRawBytes :: Storage' c -> BL.ByteString -> IO (Ref' c)+unsafeStoreRawBytes st@Storage {..} raw = do+    dgst <- evaluate $ force $ hashToRefDigest raw+    backendStoreBytes stBackend dgst raw+    return $ Ref st dgst+ 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']@@ -236,47 +251,73 @@         (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+            (, next) <$> if+                | otype == BC.pack "blob"+                    -> return $ Blob content+                | otype == BC.pack "rec"+                , Just ritems <- parseRecordBody st content+                    -> return $ Rec ritems+                | otype == BC.pack "ondemand"+                , Just ondemand <- parseOnDemand st content+                    -> return ondemand+                | 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)+  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 _ [] = []+parseRecordBody :: Storage' c -> ByteString -> Maybe [ ( ByteString, RecItem' c ) ]+parseRecordBody _ body | B.null body = Just []+parseRecordBody st body = do+    colon <- BC.elemIndex ':' body+    space <- BC.elemIndex ' ' $ B.drop (colon + 1) body+    let name = B.take colon body+        itype = B.take space $ B.drop (colon + 1) body+    ( content, remainingBody ) <- parseTabEscapedLines $ B.drop (space + colon + 2) body -          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+    (( name, val ) :) <$> parseRecordBody st remainingBody -              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)+-- Split given ByteString on the first newline not preceded by tab; replace+-- "\t\n" in the first part with "\n".+parseTabEscapedLines :: ByteString -> Maybe ( ByteString, ByteString )+parseTabEscapedLines = parseLines []+  where+    parseLines linesReversed cur = do+        newline <- BC.elemIndex '\n' cur+        case ( BC.length cur > newline + 1, BC.index cur (newline + 1) ) of+            ( True, '\t' ) -> parseLines (B.take (newline + 1) cur : linesReversed) (B.drop (newline + 2) cur)+            _              -> Just ( BC.concat $ reverse $ B.take newline cur : linesReversed, B.drop (newline + 1) cur ) +parseOnDemand :: Storage' c -> ByteString -> Maybe (Object' c)+parseOnDemand _ body = do+    newline1 <- BC.elemIndex '\n' body+    newline2 <- BC.elemIndex '\n' $ B.drop (newline1 + 1) body+    guard (newline1 + newline2 + 2 == B.length body)+    ( size, sizeRest ) <- BC.readInt (B.take newline1 body)+    guard (B.null sizeRest)+    dgst <- readRefDigest $ B.take newline2 $ B.drop (newline1 + 1) body+    return $ OnDemand (fromIntegral size) dgst++ deserializeObject :: PartialStorage -> BL.ByteString -> Except ErebosError (PartialObject, BL.ByteString) deserializeObject = unsafeDeserializeObject @@ -332,10 +373,12 @@ 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+data Store+    = StoreBlob ByteString+    | StoreRec (forall c. StorageCompleteness c => Storage' c -> [IO [(ByteString, RecItem' c)]])+    | StoreOnDemand Word64 RefDigest+    | StoreZero+    | StoreUnknown ByteString ByteString  evalStore :: StorageCompleteness c => Storage' c -> Store -> IO (Ref' c) evalStore st = unsafeStoreObject st <=< evalStoreObject st@@ -343,6 +386,7 @@ 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 _ (StoreOnDemand size dgst) = return $ OnDemand size dgst evalStoreObject _ StoreZero = return ZeroObject evalStoreObject _ (StoreUnknown otype content) = return $ UnknownObject otype content @@ -379,6 +423,7 @@     store' (Rec xs) = StoreRec $ \st -> return $ do         Rec xs' <- copyObject st (Rec xs)         return xs'+    store' (OnDemand size dgst) = StoreOnDemand size dgst     store' ZeroObject = StoreZero     store' (UnknownObject otype content) = StoreUnknown otype content 

@@ -11,6 +11,7 @@ module Erebos.Storable (     Storable(..), ZeroStorable(..),     StorableText(..), StorableDate(..), StorableUUID(..),+    StorageCompleteness(..),      Store, StoreRec,     storeBlob, storeRec, storeZero,@@ -30,7 +31,7 @@     loadZRef,      Stored,-    fromStored, storedRef,+    fromStored, storedRef, refDigest,     wrappedStore, wrappedLoad,     copyStored,     unsafeMapStored,

@@ -9,12 +9,17 @@     Complete, Partial,     Storage, PartialStorage,     newStorage,+    withStorageBackend, +    refDigestBytes,+     WatchID, startWatchID, nextWatchID, ) where  import Control.Concurrent.MVar +import Data.ByteArray qualified as BA+import Data.ByteString (ByteString) import Data.HashTable.IO qualified as HT  import Erebos.Object.Internal@@ -26,3 +31,10 @@     stRefGeneration <- newMVar =<< HT.new     stRefRoots <- newMVar =<< HT.new     return Storage {..}++withStorageBackend :: Storage' c -> (forall bck. (StorageBackend bck, BackendCompleteness bck ~ c) => bck -> IO a) -> IO a+withStorageBackend Storage {..} f = f stBackend+++refDigestBytes :: RefDigest -> ByteString+refDigestBytes = BA.convert

@@ -15,7 +15,6 @@     StorageBackend(..),     Complete, Partial, -    unsafeStoreRawBytes,     ioLoadBytesFromStorage,      Generation(..),@@ -26,7 +25,6 @@ import Control.Arrow import Control.Concurrent import Control.DeepSeq-import Control.Exception import Control.Monad.Identity  import Crypto.Hash@@ -274,12 +272,6 @@     type LoadResult Partial a = Either RefDigest a     returnLoadResult = id     ioLoadBytes (Ref st dgst) = maybe (Left dgst) Right <$> ioLoadBytesFromStorage st dgst--unsafeStoreRawBytes :: Storage' c -> BL.ByteString -> IO (Ref' c)-unsafeStoreRawBytes st@Storage {..} raw = do-    dgst <- evaluate $ force $ hashToRefDigest raw-    backendStoreBytes stBackend dgst raw-    return $ Ref st dgst  ioLoadBytesFromStorage :: Storage' c -> RefDigest -> IO (Maybe BL.ByteString) ioLoadBytesFromStorage Storage {..} dgst =

@@ -0,0 +1,79 @@+{-# LANGUAGE OverloadedStrings #-}++module Erebos.TextFormat (+    FormattedText,+    plainText,++    TextStyle,+    withStyle, noStyle,++    Color(..),+    setForegroundColor, setBackgroundColor,++    endWithNewline,++    renderPlainText,+    formattedTextLength,+    formattedTextHeight,+) where++import Data.Text (Text)+import Data.Text qualified as T++import Erebos.TextFormat.Types+++plainText :: Text -> FormattedText+plainText = PlainText+++withStyle :: TextStyle -> FormattedText -> FormattedText+withStyle = FormattedText++noStyle :: TextStyle+noStyle = CustomTextColor Nothing Nothing++setForegroundColor :: Color -> TextStyle -> TextStyle+setForegroundColor color (CustomTextColor _ bg) = CustomTextColor (Just color) bg++setBackgroundColor :: Color -> TextStyle -> TextStyle+setBackgroundColor color (CustomTextColor fg _) = CustomTextColor fg (Just color)+++endWithNewline :: FormattedText -> FormattedText+endWithNewline = EndWithNewline+++renderPlainText :: FormattedText -> Text+renderPlainText = \case+    PlainText text -> text+    ConcatenatedText ftexts -> mconcat $ map renderPlainText ftexts+    FormattedText _ ftext -> renderPlainText ftext+    EndWithNewline ftext -> let res = renderPlainText ftext+                             in case T.unsnoc res of+                                    Just ( _, '\n') -> res+                                    _               -> res <> "\n"++formattedTextLength :: FormattedText -> Int+formattedTextLength = \case+    PlainText text -> T.length text+    ConcatenatedText ftexts -> sum $ map formattedTextLength ftexts+    FormattedText _ ftext -> formattedTextLength ftext+    EndWithNewline ftext -> formattedTextLength ftext++formattedTextHeight :: FormattedText -> Int+formattedTextHeight = countLines . collectParts+  where+    collectParts = \case+        PlainText text -> [ text ]+        ConcatenatedText ftexts -> concatMap collectParts ftexts+        FormattedText _ ftext -> collectParts ftext+        EndWithNewline ftext -> collectParts ftext+    countLines (t : ts)+        | T.null t = countLines ts+        | otherwise = 1 + countLines (dropLine (t : ts))+    countLines [] = 0+    dropLine (t : ts)+        | Just ( '\n', t' ) <- T.uncons (T.dropWhile (/= '\n') t) = t' : ts+        | otherwise = dropLine ts+    dropLine [] = []

@@ -0,0 +1,83 @@+{-# LANGUAGE OverloadedStrings #-}++module Erebos.TextFormat.Ansi (+    FormattedText,++    AnsiText(..),+    renderAnsiText,+) where++import Control.Applicative+import Control.Monad.State+import Control.Monad.Writer++import Data.String+import Data.Text (Text)+import Data.Text qualified as T++import Erebos.TextFormat.Types+++newtype AnsiText = AnsiText { fromAnsiText :: Text }+    deriving (Eq, Ord, Semigroup, Monoid, IsString)+++data RenderState = RenderState+    { rsEndedWithNewline :: Bool+    }++initialRenderState :: RenderState+initialRenderState = RenderState+    { rsEndedWithNewline = True+    }++renderAnsiText :: FormattedText -> AnsiText+renderAnsiText ft = AnsiText $ T.concat $ execWriter $ flip evalStateT initialRenderState $ go ( Nothing, Nothing ) ft+  where+    go :: ( Maybe Color, Maybe Color ) -> FormattedText -> StateT RenderState (Writer [ Text ]) ()+    go cur@( cfg, cbg ) = \case+        PlainText text -> do+            tell [ text ]+            case T.unsnoc text of+                Just ( _, c ) -> modify (\s -> s { rsEndedWithNewline = c == '\n' })+                Nothing -> return ()+        ConcatenatedText ftexts -> mconcat <$> mapM (go cur) ftexts+        FormattedText (CustomTextColor fg bg) ftext -> do+            tell [ ansiColor fg bg ]+            go ( fg <|> cfg, bg <|> cbg ) ftext+            tell [ ansiColor+                (if fg /= cfg then cfg <|> Just DefaultColor else Nothing)+                (if bg /= cbg then cbg <|> Just DefaultColor else Nothing)+                ]+        EndWithNewline ftext -> do+            go cur ftext+            gets rsEndedWithNewline >>= \case+                True -> return ()+                False -> tell [ "\n" ] >> modify (\s -> s { rsEndedWithNewline = True })+++ansiColor :: Maybe Color -> Maybe Color -> Text+ansiColor Nothing Nothing = ""+ansiColor (Just fg) Nothing = "\ESC[" <> T.pack (show (colorNum fg)) <> "m"+ansiColor Nothing (Just bg) = "\ESC[" <> T.pack (show (colorNum bg + 10)) <> "m"+ansiColor (Just fg) (Just bg) = "\ESC[" <> T.pack (show (colorNum fg)) <> ";" <> T.pack (show (colorNum bg + 10)) <> "m"++colorNum :: Color -> Int+colorNum = \case+    DefaultColor -> 39+    Black -> 30+    Red -> 31+    Green -> 32+    Yellow -> 33+    Blue -> 34+    Magenta -> 35+    Cyan -> 36+    White -> 37+    BrightBlack -> 90+    BrightRed -> 91+    BrightGreen -> 92+    BrightYellow -> 93+    BrightBlue -> 94+    BrightMagenta -> 95+    BrightCyan -> 96+    BrightWhite -> 97

@@ -0,0 +1,58 @@+module Erebos.TextFormat.Types (+    FormattedText(..),+    TextStyle(..),+    Color(..),+) where++import Data.String+import Data.Text (Text)+++data FormattedText+    = PlainText Text+    | ConcatenatedText [ FormattedText ]+    | FormattedText TextStyle FormattedText+    | EndWithNewline FormattedText++instance IsString FormattedText where+    fromString = PlainText . fromString++instance Semigroup FormattedText where+    ConcatenatedText xs <> ConcatenatedText ys = ConcatenatedText (xs ++ ys)+    x <> ConcatenatedText ys = ConcatenatedText (x : ys)+    ConcatenatedText xs <> y = ConcatenatedText (xs ++ [ y ])+    x <> y = ConcatenatedText [ x, y ]++instance Monoid FormattedText where+    mempty = ConcatenatedText []+    mconcat [] = ConcatenatedText []+    mconcat [ x ] = x+    mconcat xs = ConcatenatedText $ concatMap flatten xs+      where+        flatten (ConcatenatedText ys) = ys+        flatten y = [ y ]+++data TextStyle+    = CustomTextColor (Maybe Color) (Maybe Color)+++data Color+    = DefaultColor+    | Black+    | Red+    | Green+    | Yellow+    | Blue+    | Magenta+    | Cyan+    | White+    | BrightBlack+    | BrightRed+    | BrightGreen+    | BrightYellow+    | BrightBlue+    | BrightMagenta+    | BrightCyan+    | BrightWhite+    deriving (Eq)