erebos 0.2.1 → 0.2.2

raw patch · 22 files changed

+935/−407 lines, 22 filesdep ~timePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: time

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• README.md +5/−2
• erebos.cabal +4/−2
• main/Main.hs +77/−30
• main/Terminal.hs +66/−8
• main/Test.hs +39/−6
• main/WebSocket.hs +33/−10
• src/Erebos/Chatroom.hs +8/−1
• src/Erebos/Conversation.hs +28/−8
• src/Erebos/Conversation/Class.hs +18/−1
• src/Erebos/DirectMessage.hs +108/−44
• src/Erebos/Network.hs +26/−13
• src/Erebos/Object.hs +1/−0
• src/Erebos/Object/Internal.hs +107/−80
• src/Erebos/Storable.hs +2/−1
• src/Erebos/Storable/Internal.hs +100/−0
• src/Erebos/Storage.hs +1/−0
• src/Erebos/Storage/Graph.hs +292/−0
• src/Erebos/Storage/Head.hs +2/−2
• src/Erebos/Storage/Internal.hs +5/−51
• src/Erebos/Storage/Key.hs +3/−1
• src/Erebos/Storage/Merge.hs +3/−147

@@ -1,5 +1,12 @@ # Revision history for erebos +## 0.2.2 -- 2026-06-25++* Initial support for `chunked` and `dir` object types.+* Added `/seen` command to mark messages as seen.+* Improved display of unread/seen messages.+* Avoid binding the same UDP port from multiple server instances on a single host.+ ## 0.2.1 -- 2026-03-15  * Initial support for `ondemand` object type.

@@ -95,12 +95,12 @@ `/conversations`   : List started conversations with contacts or other peers. -`/new`+`/new`   : List conversations with new (unread) messages.  `/<number>`   : Select conversation, contact or peer `<number>` based on the last-  `/conversations`, `/contacts` or `/peers` output list.+  `/conversations`, `/contacts`, `/peers` or `/new` output list.  `<message>`   : Send `<message>` to selected conversation.@@ -112,6 +112,9 @@ `/details [<number>]`   : Show information about the selected conversations, contact or peer; or the   one identified by `<number>` if given.++`/seen`  +: Mark all messages in the current conversation as seen.  ### Chatrooms 

@@ -1,7 +1,7 @@ Cabal-Version:       3.0  Name:                erebos-Version:             0.2.1+Version:             0.2.2 Synopsis:            Decentralized messaging and synchronization Description:     Library and simple CLI interface implementing the Erebos identity@@ -109,6 +109,7 @@         Erebos.Storable         Erebos.Storage         Erebos.Storage.Backend+        Erebos.Storage.Graph         Erebos.Storage.Head         Erebos.Storage.Key         Erebos.Storage.Merge@@ -123,6 +124,7 @@         Erebos.Network.Channel         Erebos.Network.Protocol         Erebos.Object.Internal+        Erebos.Storable.Internal         Erebos.Storage.Disk         Erebos.Storage.Internal         Erebos.Storage.Memory@@ -168,7 +170,7 @@         network ^>= { 3.1, 3.2 },         stm >=2.5 && <2.6,         text >= 1.2 && <2.2,-        time ^>= { 1.8, 1.9, 1.10, 1.11, 1.12, 1.13, 1.14 },+        time ^>= { 1.8, 1.9, 1.10, 1.11, 1.12, 1.13, 1.14, 1.15, 1.16 },         uuid-types ^>= { 1.0.4 },         zlib >=0.6 && <0.8 

@@ -24,7 +24,6 @@ import Data.Text qualified as T import Data.Text.Encoding qualified as T import Data.Text.IO qualified as T-import Data.Time.Format import Data.Time.LocalTime import Data.Typeable @@ -70,6 +69,7 @@     , optChatroomAutoSubscribe :: Maybe Int     , optDmBotEcho :: Maybe Text     , optWebSocketServer :: Maybe Int+    , optWebSocketDebugLog :: Bool     , optShowHelp :: Bool     , optShowVersion :: Bool     }@@ -95,6 +95,7 @@     , optChatroomAutoSubscribe = Nothing     , optDmBotEcho = Nothing     , optWebSocketServer = Nothing+    , optWebSocketDebugLog = False     , optShowHelp = False     , optShowVersion = False     }@@ -120,7 +121,7 @@ options :: [ OptDescr (Options -> Writer [ String ] Options) ] options =     [ Option [ 'p' ] [ "port" ]-        (ReqArg (\p -> so $ \opts -> opts { serverPort = read p }) "<port>")+        (ReqArg (\p -> so $ \opts -> opts { serverPort = read p, serverRetryUnspecifiedPort = False }) "<port>")         "local port to bind"     , Option [ 's' ] [ "silent" ]         (NoArg (so $ \opts -> opts { serverLocalDiscovery = False }))@@ -209,6 +210,9 @@     [ Option [] [ "discovery-debug-log" ]         (NoArg (serviceAttr $ \attrs -> return attrs { discoveryDebugLog = True }))         ""+    , Option [] [ "websocket-debug-log" ]+        (NoArg (\opts -> return opts { optWebSocketDebugLog = True }))+        ""     ]   where     updateService :: (Service s, Monad m, Typeable m) => (ServiceAttributes s -> m (ServiceAttributes s)) -> SomeService -> m SomeService@@ -380,7 +384,9 @@                 Right prompt -> return prompt             lift $ setPrompt term $ plainText $ T.pack prompt             join $ lift $ getInputLine term $ \case-                Just input@('/' : _) -> KeepPrompt $ return input+                Just input@('/' : _)+                    | "/seen" : _ <- words input -> ErasePrompt $ return input+                    | otherwise -> KeepPrompt $ return input                 Just input -> ErasePrompt $ case reverse input of                     _ | all isSpace input -> getInputLinesTui eprompt                     '\\':rest -> (reverse ('\n':rest) ++) <$> getInputLinesTui (Right ">> ")@@ -408,12 +414,25 @@     let getInputCommand = getInputCommandTui . Left      contextVar <- liftIO $ newMVar NoContext+    currentLinesVar <- liftIO $ newMVar []      _ <- liftIO $ do         tzone <- getCurrentTimeZone         let self = finalOwner $ headLocalIdentity erebosHead-        watchDirectMessageThreads erebosHead $ \prev cur -> do-            forM_ (reverse $ dmThreadToListSince prev cur) $ \msg -> do+        watchDirectMessageThreads erebosHead $ \prev cur -> holdFlush term $ do+            let ( remove, messages ) = dmThreadToListChange prev cur+            when (remove > 0) $ do+                modifyMVar_ currentLinesVar $ \clines -> if+                    | l : ls <- drop (remove - 1) clines -> do+                        eraseLinesSince l+                        return ls+                    | _ : _ <- clines -> do+                        eraseLinesSince (last clines)+                        return []+                    | otherwise -> do+                        return []++            forM_ (reverse messages) $ \( msg, new ) -> do                 withMVar contextVar $ \ctx -> do                     mbpid <- case ctx of                         SelectedPeer peer -> getPeerIdentity peer >>= return . \case@@ -424,7 +443,8 @@                         SelectedConversation conv -> return $ conversationPeer conv                         _ -> return Nothing                     when (not tui || maybe False (msgPeer cur `sameIdentity`) mbpid) $ do-                        extPrintLn $ plainText $ T.pack $ formatDirectMessage tzone msg+                        line <- printLine term $ formatMessageLine tzone $ makeMessage new msg+                        modifyMVar_ currentLinesVar $ return . (line :)                  case optDmBotEcho opts of                     Just prefix@@ -460,7 +480,10 @@             map soptService $ filter soptEnabled $ optServices opts      case optWebSocketServer opts of-        Just port -> startWebsocketServer server "::" port (extPrintLn . plainText . T.pack)+        Just port -> startWebsocketServer server (extPrintLn . plainText . T.pack) defaultWebSocketOptions+            { wsPort = port+            , wsDebugLog = optWebSocketDebugLog opts+            }         Nothing -> return ()      void $ liftIO $ forkIO $ void $ forever $ do@@ -469,27 +492,24 @@             pid@(PeerIdentityFull _) -> do                 dropped <- isPeerDropped peer                 shown <- showPeer pid <$> getPeerAddress peer-                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 ) )+                let update [] = ( [ ( peer, shown ) ], ( Nothing, optionLabelNew ) )                     update ((p,s):ps)-                        | p == peer && dropped = ( ps, ( Nothing, labelDel ) )-                        | p == peer = ( ( peer, shown ) : ps, ( Just s, labelUpd ) )+                        | p == peer && dropped = ( ps, ( Nothing, optionLabelDel ) )+                        | p == peer = ( ( peer, shown ) : ps, ( Just s, optionLabelUpd ) )                         | 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 labelDel else updateType+                let updateType' = if dropped then optionLabelDel 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 $ "[" <> withStyle contextIndexStyle (plainText $ T.pack $ show idx) <> "] PEER " <> updateType' <> " " <> plainText shown+                            extPrintLn $ formatSelectOption idx $ "PEER " <> updateType' <> " " <> plainText shown                         return ( Just WatchPeers, clist' )                     cur -> return cur             _ -> return ()@@ -515,6 +535,7 @@                     , ciSetContextOptions = \watch ctxs -> liftIO $ modifyMVar_ contextOptions $ const $ return ( Just watch, ctxs )                     , ciContextVar = contextVar                     , ciContextOptionsVar = contextOptions+                    , ciCurrentLinesVar = currentLinesVar                     , ciChatroomSetVar = chatroomSetVar                     }                 return ( either (const ctx) csContext res, res )@@ -541,9 +562,17 @@ contextIndexStyle = setForegroundColor BrightCyan noStyle  printSelectOption :: Int -> FormattedText -> CommandM ()-printSelectOption i label = cmdPutStrLn $ "[" <> withStyle contextIndexStyle (plainText $ T.pack $ show i) <> "] " <> label+printSelectOption i label = cmdPutStrLn $ formatSelectOption i label +formatSelectOption :: Int -> FormattedText -> FormattedText+formatSelectOption i label = "[" <> withStyle contextIndexStyle (plainText $ T.pack $ show i) <> "] " <> label +optionLabelNew, optionLabelUpd, optionLabelDel :: FormattedText+optionLabelNew = withStyle (setForegroundColor Green noStyle) $ plainText "NEW"+optionLabelUpd = withStyle (setForegroundColor Yellow noStyle) $ plainText "UPD"+optionLabelDel = withStyle (setForegroundColor Red noStyle) $ plainText "DEL"++ data CommandInput = CommandInput     { ciServer :: Server     , ciTerminal :: Terminal@@ -555,6 +584,7 @@     , ciSetContextOptions :: ContextWatchOptions -> [ CommandContext ] -> Command     , ciContextVar :: MVar CommandContext     , ciContextOptionsVar :: MVar ( Maybe ContextWatchOptions, [ CommandContext ] )+    , ciCurrentLinesVar :: MVar [ TerminalLine ]     , ciChatroomSetVar :: MVar (Set ChatroomState)     } @@ -685,6 +715,7 @@     , ( "invite-accept", cmdInviteAccept )     , ( "conversations", cmdConversations )     , ( "new", cmdNew )+    , ( "seen", cmdSeen )     , ( "details", cmdDetails )     , ( "discovery", cmdDiscovery )     , ( "join", cmdJoin )@@ -708,6 +739,18 @@     term <- asks ciTerminal     void $ liftIO $ printLine term str +formatMessageLine :: TimeZone -> Message -> FormattedText+formatMessageLine tzone msg = mconcat+    [ formatMessageStatus msg+    , formatMessageFT tzone msg+    ]++formatMessageStatus :: Message -> FormattedText+formatMessageStatus msg+    | messageUnread msg = withStyle (setForegroundColor BrightYellow noStyle) $ plainText " * "+    | otherwise = plainText "   "++ cmdUnknown :: String -> Command cmdUnknown cmd = cmdPutStrLn $ withStyle (setForegroundColor BrightRed noStyle) $ plainText $ "Unknown command: ‘" <> T.pack cmd <> "’" @@ -808,7 +851,10 @@         Right conv -> do             liftIO $ updatePromptStatus term h (Just conv)             tzone <- liftIO $ getCurrentTimeZone-            mapM_ (cmdPutStrLn . formatMessageFT tzone) $ takeWhile messageUnread $ conversationHistory conv+            tlines <- liftIO $ mapM (printLine term . formatMessageLine tzone) $+                reverse $ takeWhile messageUnread $ conversationHistory conv+            var <- asks ciCurrentLinesVar+            liftIO $ modifyMVar_ var $ \_ -> return (reverse tlines)         Left _ -> do             liftIO $ updatePromptStatus term h Nothing @@ -829,7 +875,10 @@     case conversationHistory conv of         thread@(_:_) -> do             tzone <- liftIO $ getCurrentTimeZone-            mapM_ (cmdPutStrLn . formatMessageFT tzone) $ reverse $ take 50 thread+            term <- asks ciTerminal+            tlines <- liftIO $ mapM (printLine term . formatMessageLine tzone) $ reverse $ take 50 thread+            var <- asks ciCurrentLinesVar+            liftIO $ modifyMVar_ var $ \_ -> return (reverse tlines)         [] -> do             cmdPutStrLn $ withStyle (setForegroundColor BrightBlack noStyle) $ plainText "(empty history)" @@ -877,17 +926,17 @@                 | currentRoots <- filterAncestors (concatMap storedRoots $ roomStateData rstate)                 , any ((`intersectsSorted` currentRoots) . storedRoots) $ roomStateData rstate'                 -> do-                    eprint $ plainText $ T.pack $ "[" <> show idx <> "] CHATROOM " <> updateType <> " " <> name+                    eprint $ formatSelectOption idx $ "CHATROOM " <> updateType <> " " <> name                     return (SelectedChatroom rstate : rest)             selected : rest                 -> do                     (selected : ) <$> ctxUpdate updateType (idx + 1) rstate rest             []                 -> do-                    eprint $ plainText $ T.pack $ "[" <> show idx <> "] CHATROOM " <> updateType <> " " <> name+                    eprint $ formatSelectOption idx $ "CHATROOM " <> updateType <> " " <> name                     return [ SelectedChatroom rstate ]           where-            name = maybe "<unnamed>" T.unpack $ roomName =<< roomStateRoom rstate+            name = maybe "<unnamed>" plainText $ roomName =<< roomStateRoom rstate      watchChatrooms h $ \set -> \case         Nothing -> do@@ -913,12 +962,12 @@                   | watch == Just WatchChatrooms || not tui                   -> do                     let upd c = \case-                            AddedChatroom rstate -> ctxUpdate "NEW" 1 rstate c-                            RemovedChatroom rstate -> ctxUpdate "DEL" 1 rstate c+                            AddedChatroom rstate -> ctxUpdate optionLabelNew 1 rstate c+                            RemovedChatroom rstate -> ctxUpdate optionLabelDel 1 rstate c                             UpdatedChatroom _ rstate                                 | any ((\rsd -> not (null (rsdRoom rsd))) . fromStored) (roomStateData rstate)                                 -> do-                                    ctxUpdate "UPD" 1 rstate c+                                    ctxUpdate optionLabelUpd 1 rstate c                                 | otherwise -> return c                     ( watch, ) <$> foldM upd clist diff                 cur -> return cur@@ -940,12 +989,7 @@                             when (not tui || isSelected) $ do                                 tzone <- getCurrentTimeZone                                 forM_ (reverse $ getMessagesSinceState rstate oldroom) $ \msg -> do-                                    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") ((": " <>)) $ cmsgText msg-                                        ]+                                    eprint $ formatMessageLine tzone $ makeMessage False msg                     modifyMVar_ subscribedNumVar $ return                         . (if roomStateSubscribe rstate then (+ 1) else id)                         . (if roomStateSubscribe oldroom then subtract 1 else id)@@ -1081,6 +1125,9 @@         , messageUnread msg         = Just ( conv, msg )     checkNew _ = Nothing++cmdSeen :: Command+cmdSeen = markAllSeen =<< getSelectedConversation   cmdDetails :: Command

@@ -5,6 +5,7 @@     Terminal,     hasTerminalUI,     withTerminal,+    holdFlush,     setPrompt,     setPromptStatus,     showPrompt, hidePrompt,@@ -13,6 +14,9 @@      TerminalLine,     printLine,+    updateLine,+    updateLinePart,+    eraseLinesSince,      printBottomLines,     clearBottomLines,@@ -55,10 +59,13 @@     , termHistory :: TVar [ String ]     , termHistoryPos :: TVar Int     , termHistoryStash :: TVar ( String, String )+    , termBottomIndex :: TVar Int+    , termHoldFlush :: TVar Int     }  data TerminalLine = TerminalLine     { tlTerminal :: Terminal+    , tlLineIndex :: Int     , tlLineCount :: Int     } @@ -102,6 +109,8 @@     termHistory <- newTVarIO []     termHistoryPos <- newTVarIO 0     termHistoryStash <- newTVarIO ( "", "" )+    termBottomIndex <- newTVarIO 0+    termHoldFlush <- newTVarIO 0     return Terminal {..}  bracketSet :: IO a -> (a -> IO b) -> a -> IO c -> IO c@@ -117,6 +126,22 @@             act term  +termFlush :: Terminal -> IO ()+termFlush Terminal {..} = do+    join $ atomically $ do+        readTVar termHoldFlush >>= \case+            0 -> return $ hFlush stdout+            _ -> return $ return ()++holdFlush :: Terminal -> IO a -> IO a+holdFlush term@Terminal {..} act = do+    atomically $ writeTVar termHoldFlush . (+ 1) =<< readTVar termHoldFlush+    x <- act+    atomically $ writeTVar termHoldFlush . subtract 1 =<< readTVar termHoldFlush+    termFlush term+    return x++ putAnsi :: AnsiText -> IO () putAnsi = T.putStr . fromAnsiText @@ -166,7 +191,9 @@             writeTVar termHistoryPos 0      ( x, clear ) <- case handleResult mbLine of-        KeepPrompt x -> return ( x, \statusLen -> AnsiText $ "\ESC[" <> T.pack (show statusLen) <> "G\ESC[1K\n\ESC[J" )+        KeepPrompt x -> do+            atomically $ writeTVar termBottomIndex . (+ 1) =<< readTVar termBottomIndex+            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@@ -193,7 +220,7 @@                             writeTVar termInput ( pre', post )                             getCurrentPromptLine term                         putAnsi $ "\r" <> prompt-                        hFlush stdout+                        termFlush term                  termCompletionFunc ( T.pack pre, T.pack post ) >>= \case @@ -302,7 +329,7 @@             str <- atomically $ f =<< readTVar termInput             when (termAnsi && not (T.null $ fromAnsiText str)) $ do                 putAnsi str-                hFlush stdout+                termFlush term         go  @@ -324,7 +351,7 @@     promptLine <- getCurrentPromptLine term     return $ do         putAnsi $ "\r\ESC[K" <> promptLine-        hFlush stdout+        termFlush term  setPrompt :: Terminal -> FormattedText -> IO () setPrompt Terminal { termAnsi = False } _ = do@@ -390,10 +417,41 @@           else do             T.putStr $ renderPlainText $ endWithNewline str -        hFlush stdout+        tlLineIndex <- atomically $ do+            bindex <- readTVar termBottomIndex+            writeTVar termBottomIndex $ bindex + tlLineCount+            return bindex++        termFlush tlTerminal         return TerminalLine {..} +updateLine :: TerminalLine -> FormattedText -> IO ()+updateLine tl str = updateLinePart tl 0 (str <> "\ESC[K") +updateLinePart :: TerminalLine -> Int -> FormattedText -> IO ()+updateLinePart TerminalLine {..} offset str = do+    let Terminal {..} = tlTerminal+    when termAnsi $ do+        withMVar termLock $ \_ -> do+            let updLineCount = formattedTextHeight str+            bindex <- atomically $ readTVar termBottomIndex+            putAnsi $ mconcat+                [ AnsiText $ "\ESC[s\ESC[" <> T.pack (show (bindex - tlLineIndex)) <> "F\ESC[" <> T.pack (show (offset + 1)) <> "G"+                , renderAnsiText str+                , mconcat $ replicate (tlLineCount - updLineCount) $ AnsiText "\r\ESC[K"+                , AnsiText $ "\ESC[u"+                ]++eraseLinesSince :: TerminalLine -> IO ()+eraseLinesSince TerminalLine {..} = do+    let Terminal {..} = tlTerminal+    when termAnsi $ do+        withMVar termLock $ \_ -> do+            bindex <- atomically $ readTVar termBottomIndex+            putAnsi $ AnsiText $ "\ESC[" <> T.pack (show (bindex - tlLineIndex)) <> "F\ESC[J"+            atomically $ writeTVar termBottomIndex tlLineIndex++ printBottomLines :: Terminal -> String -> IO () printBottomLines Terminal { termAnsi = False } _ = do     return ()@@ -404,19 +462,19 @@             withMVar termLock $ \_ -> do                 atomically $ writeTVar termBottomLines blines                 drawBottomLines term-                hFlush stdout+                termFlush term  clearBottomLines :: Terminal -> IO () clearBottomLines Terminal { termAnsi = False } = do     return ()-clearBottomLines Terminal {..} = do+clearBottomLines term@Terminal {..} = do     withMVar termLock $ \_ -> do         atomically (readTVar termBottomLines) >>= \case             []  -> return ()             _:_ -> do                 atomically $ writeTVar termBottomLines []                 putStr $ "\ESC[s\n\ESC[J\ESC[u"-                hFlush stdout+                termFlush term  drawBottomLines :: Terminal -> IO () drawBottomLines Terminal {..} = do

@@ -51,6 +51,7 @@ import Erebos.State import Erebos.Storable import Erebos.Storage+import Erebos.Storage.Graph import Erebos.Storage.Head import Erebos.Storage.Merge import Erebos.Sync@@ -94,19 +95,21 @@ data TestInput = TestInput     { tiOutput :: Output     , tiStorage :: Storage-    , tiParams :: [Text]+    , tiParams :: [ Text ]+    , tiDmLogChange :: MVar Bool     }   runTestTool :: Storage -> IO () runTestTool st = do     out <- newMVar ()+    changeVar <- newMVar False     let testLoop = getLineMb >>= \case             Just line -> do                 case T.words line of                     (cname:params)                         | Just (CommandM cmd) <- lookup cname commands -> do-                            runReaderT cmd $ TestInput out st params+                            runReaderT cmd $ TestInput out st params changeVar                         | otherwise -> fail $ "Unknown command '" ++ T.unpack cname ++ "'"                     [] -> return ()                 testLoop@@ -246,9 +249,15 @@         afterCommit $ outLine out $ "invite-reply " <> showInviteToken token <> " invalid"     } -dmThreadWatcher :: ComposedIdentity -> Output -> DirectMessageThread -> DirectMessageThread -> IO ()-dmThreadWatcher self out prev cur = do-    forM_ (reverse $ dmThreadToListSinceUnread prev cur) $ \( msg, new ) -> do+dmThreadWatcher :: MVar Bool -> ComposedIdentity -> Output -> DirectMessageThread -> DirectMessageThread -> IO ()+dmThreadWatcher changeVar self out prev cur = do+    change <- readMVar changeVar+    let ( removed, added )+            | change = dmThreadToListChange prev cur+            | otherwise = ( 0, dmThreadToListSinceUnread prev cur )+    when (removed > 0) $ do+        outLine out $ unwords [ "dm-removed", show removed ]+    forM_ (reverse added) $ \( msg, new ) -> do         outLine out $ unwords             [ if sameIdentity self (msgFrom msg)                  then "dm-sent"@@ -291,6 +300,7 @@     , ( "stored-roots", cmdStoredRoots )     , ( "stored-set-add", cmdStoredSetAdd )     , ( "stored-set-list", cmdStoredSetList )+    , ( "stored-common-ancestors", cmdStoredCommonAncestors )     , ( "stored-difference", cmdStoredDifference )     , ( "head-create", cmdHeadCreate )     , ( "head-replace", cmdHeadReplace )@@ -324,6 +334,7 @@     , ( "contact-reject", cmdContactReject )     , ( "contact-list", cmdContactList )     , ( "contact-set-name", cmdContactSetName )+    , ( "dm-log-change", cmdDmLogChange )     , ( "dm-send-peer", cmdDmSendPeer )     , ( "dm-send-contact", cmdDmSendContact )     , ( "dm-send-identity", cmdDmSendIdentity )@@ -402,6 +413,8 @@                     Blob {} -> "blob"                     Rec {} -> "rec"                     OnDemand {} -> "ondemand"+                    Chunked {} -> "chunked"+                    Dir {} -> "dir"                     ZeroObject {} -> "zero"                     UnknownObject utype _ -> "unknown " <> decodeUtf8 utype             cmdOut $ "load-type " <> T.unpack otype@@ -459,6 +472,19 @@         cmdOut $ "stored-set-item" ++ concatMap ((' ':) . show . refDigest . storedRef) item     cmdOut $ "stored-set-done" +cmdStoredCommonAncestors :: Command+cmdStoredCommonAncestors = do+    st <- asks tiStorage+    ( trefs1, "|" : trefs2 ) <- span (/= "|") <$> asks tiParams++    let loadObjs = mapM (maybe (fail "invalid ref") (return . wrappedLoad @Object) <=< liftIO . readRef st . encodeUtf8)+    objs1 <- loadObjs trefs1+    objs2 <- loadObjs trefs2++    forM_ (commonAncestors objs1 objs2) $ \item -> do+        cmdOut $ "stored-common-ancestors-item " ++ (show $ refDigest $ storedRef item)+    cmdOut $ "stored-common-ancestors-done"+ cmdStoredDifference :: Command cmdStoredDifference = do     st <- asks tiStorage@@ -527,7 +553,8 @@ initTestHead :: Head LocalState -> Command initTestHead h = do     let self = finalOwner $ headLocalIdentity h-    _ <- liftIO . watchDirectMessageThreads h . dmThreadWatcher self =<< asks tiOutput+    changeVar <- asks tiDmLogChange+    _ <- liftIO . watchDirectMessageThreads h . dmThreadWatcher changeVar self =<< asks tiOutput     modify $ \s -> s { tsHead = Just h }  loadTestHead :: CommandM (Head LocalState)@@ -917,6 +944,12 @@     contact <- getContact cid     updateLocalState_ $ updateSharedState_ $ contactSetName contact name     cmdOut "contact-set-name-done"++cmdDmLogChange :: Command+cmdDmLogChange = do+    var <- asks tiDmLogChange+    liftIO $ modifyMVar_ var $ return . const True+    cmdOut "dm-log-change-done"  cmdDmSendPeer :: Command cmdDmSendPeer = do

@@ -1,5 +1,8 @@+{-# LANGUAGE OverloadedStrings #-}+ module WebSocket (     WebSocketAddress(..),+    WebSocketOptions(..), defaultWebSocketOptions,     startWebsocketServer, ) where @@ -7,6 +10,7 @@ import Control.Exception import Control.Monad +import Data.ByteString.Char8 qualified as BC import Data.ByteString.Lazy qualified as BL import Data.Unique @@ -15,32 +19,51 @@ import Network.WebSockets qualified as WS  -data WebSocketAddress = WebSocketAddress Unique WS.Connection+data WebSocketAddress = WebSocketAddress Unique (Maybe String) WS.Connection  instance Eq WebSocketAddress where-    WebSocketAddress u _ == WebSocketAddress u' _ = u == u'+    WebSocketAddress u _ _ == WebSocketAddress u' _ _ = u == u'  instance Ord WebSocketAddress where-    compare (WebSocketAddress u _) (WebSocketAddress u' _) = compare u u'+    compare (WebSocketAddress u _ _) (WebSocketAddress u' _ _) = compare u u'  instance Show WebSocketAddress where-    show (WebSocketAddress _ _) = "websocket"+    show (WebSocketAddress _ Nothing _) = "websocket"+    show (WebSocketAddress _ (Just addr) _) = "websocket " <> addr  instance PeerAddressType WebSocketAddress where-    sendBytesToAddress (WebSocketAddress _ conn) msg = do+    sendBytesToAddress (WebSocketAddress _ _ conn) msg = do         WS.sendDataMessage conn $ WS.Binary $ BL.fromStrict msg-    connectionToAddressClosed (WebSocketAddress _ conn) = do+    connectionToAddressClosed (WebSocketAddress _ _ conn) = do         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++data WebSocketOptions = WebSocketOptions+    { wsAddress :: String+    , wsPort :: Int+    , wsDebugLog :: Bool+    }++defaultWebSocketOptions :: WebSocketOptions+defaultWebSocketOptions = WebSocketOptions+    { wsAddress = "::"+    , wsPort = 80+    , wsDebugLog = False+    }+++startWebsocketServer :: Server -> (String -> IO ()) -> WebSocketOptions -> IO ()+startWebsocketServer server logd WebSocketOptions {..} = do     void $ forkIO $ do-        WS.runServer addr port $ \pending -> do+        WS.runServer wsAddress wsPort $ \pending -> do+            when wsDebugLog $ do+                logd $ "WebSocket request: " <> show (WS.pendingRequest pending)             conn <- WS.acceptRequest pending             u <- newUnique-            let paddr = WebSocketAddress u conn+            let mbaddr = fmap BC.unpack $ lookup "X-Real-IP" $ WS.requestHeaders $ WS.pendingRequest pending+            let paddr = WebSocketAddress u mbaddr conn             void $ serverPeerCustom server paddr              let handler e

@@ -67,10 +67,17 @@     convMessageTime = cmsgTime     convMessageText = cmsgText +    convMessageExtra msg+        | cmsgLeave msg = [ UserLeft ]+        | Nothing <- cmsgText msg = [ UserJoined ]+        | otherwise = []+     convReference = refDigest . storedRef . head . filterAncestors . concatMap storedRoots . roomStateData -    convMessageListSince mbSince cstate =+    convMessageListSince mbSince cstate = ( 0, ) $         map (, False) $ threadToListSince (maybe [] roomStateMessageData mbSince) (roomStateMessageData cstate)++    convMarkAllSeen _ = return ()   data ChatroomData = ChatroomData

@@ -2,6 +2,7 @@  module Erebos.Conversation (     Message,+    makeMessage,     messageFrom,     messageTime,     messageText,@@ -23,9 +24,11 @@     conversationName,     conversationPeer,     conversationHistory,+    conversationHistoryChange,      sendMessage,     deleteConversation,+    markAllSeen, ) where  import Control.Monad.Except@@ -49,6 +52,9 @@  data Message = forall conv msg. ConversationType conv msg => Message msg Bool +makeMessage :: ConversationType conv msg => Bool -> msg -> Message+makeMessage = flip Message+ withMessage :: (forall conv msg. ConversationType conv msg => msg -> a) -> Message -> a withMessage f (Message msg _) = f msg @@ -68,12 +74,15 @@ 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-        ]+formatMessageFT tzone msg = mconcat $ concat+    [ [ PlainText $ T.pack $ formatTime defaultTimeLocale "[%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ messageTime msg ]+    , [ maybe "<unnamed>" PlainText $ idName $ messageFrom msg ]+    , map formatExtra $ withMessage convMessageExtra msg+    , [ maybe "" ((": " <>) . PlainText) $ messageText msg ]+    ]+  where+    formatExtra UserJoined = " " <> withStyle (setForegroundColor BrightMagenta noStyle) (plainText "joined")+    formatExtra UserLeft = " " <> withStyle (setForegroundColor Magenta noStyle) (plainText "left")   data Conversation@@ -84,6 +93,11 @@ withConversation f (DirectMessageConversation conv) = f conv withConversation f (ChatroomConversation conv) = f conv +withConversations :: (forall conv msg. ConversationType conv msg => Maybe conv -> conv -> a) -> Conversation -> Conversation -> a+withConversations f (DirectMessageConversation conv) (DirectMessageConversation conv') = f (Just conv) conv'+withConversations f (ChatroomConversation conv) (ChatroomConversation conv') = f (Just conv) conv'+withConversations f _ conv = withConversation (f Nothing) conv+ isSameConversation :: Conversation -> Conversation -> Bool isSameConversation (DirectMessageConversation t) (DirectMessageConversation t')     = sameIdentity (msgPeer t) (msgPeer t')@@ -95,7 +109,7 @@     createOrUpdateDirectMessagePeer peer     (find (sameIdentity peer . msgPeer) . dmThreadList . lookupSharedValue . lsShared . fromStored <$> getLocalHead) >>= \case         Just thread -> return $ DirectMessageConversation thread-        Nothing -> return $ DirectMessageConversation $ DirectMessageThread peer [] [] [] []+        Nothing -> return $ DirectMessageConversation $ dmEmptyThread peer  chatroomConversation :: MonadHead LocalState m => ChatroomState -> m (Maybe Conversation) chatroomConversation rstate = chatroomConversationByStateData (head $ roomStateData rstate)@@ -131,9 +145,12 @@ conversationPeer (ChatroomConversation _) = Nothing  conversationHistory :: Conversation -> [ Message ]-conversationHistory = withConversation $ map (uncurry Message) . convMessageListSince Nothing+conversationHistory = withConversation $ map (uncurry Message) . snd . convMessageListSince Nothing +conversationHistoryChange :: Conversation -> Conversation -> ( Int, [ Message ] )+conversationHistoryChange = withConversations $ \since -> fmap (map (uncurry Message)) . convMessageListSince since + sendMessage :: (MonadHead LocalState m, MonadError e m, FromErebosError e) => Conversation -> Text -> m () sendMessage (DirectMessageConversation thread) text = sendDirectMessage (msgPeer thread) text sendMessage (ChatroomConversation rstate) text = sendChatroomMessage rstate text@@ -141,3 +158,6 @@ deleteConversation :: (MonadHead LocalState m, MonadError e m, FromErebosError e) => Conversation -> m () deleteConversation (DirectMessageConversation _) = throwOtherError "deleting direct message conversation is not supported" deleteConversation (ChatroomConversation rstate) = deleteChatroomByStateData (head $ roomStateData rstate)++markAllSeen :: (MonadHead LocalState m, MonadError e m, FromErebosError e) => Conversation -> m ()+markAllSeen = withConversation convMarkAllSeen

@@ -1,20 +1,37 @@ module Erebos.Conversation.Class (     ConversationType(..),+    MessageExtra(..),     RefDigest, ) where +import Control.Monad.Except+ import Data.Text (Text) import Data.Time.LocalTime import Data.Typeable +import Erebos.Error import Erebos.Identity import Erebos.Object+import Erebos.State  +data MessageExtra+    = UserJoined+    | UserLeft++ class (Typeable conv, Typeable msg) => ConversationType conv msg | conv -> msg, msg -> conv where     convMessageFrom :: msg -> ComposedIdentity     convMessageTime :: msg -> ZonedTime     convMessageText :: msg -> Maybe Text+    convMessageExtra :: msg -> [ MessageExtra ]+    convMessageExtra _ = []      convReference :: conv -> RefDigest-    convMessageListSince :: Maybe conv -> conv -> [ ( msg, Bool ) ]+    convMessageListSince+        :: Maybe conv -- ^ Original state to diff from+        -> conv       -- ^ Current state+        -> ( Int, [ ( msg, Bool ) ] ) -- ^ Number of removed, list of added messages++    convMarkAllSeen :: (MonadHead LocalState m, MonadError e m, FromErebosError e) => conv -> m ()

@@ -11,8 +11,10 @@     DirectMessageThreads,     dmThreadList, -    DirectMessageThread(..),+    DirectMessageThread(msgPeer, msgHead, msgSent, msgSeen, msgReceived),+    dmEmptyThread,     dmThreadToList, dmThreadToListSince, dmThreadToListUnread, dmThreadToListSinceUnread,+    dmThreadToListChange,     dmThreadView,      watchDirectMessageThreads,@@ -25,6 +27,7 @@ import Control.Monad.Reader  import Data.List+import Data.Maybe import Data.Ord import Data.Proxy import Data.Set (Set)@@ -42,6 +45,7 @@ import Erebos.Service import Erebos.State import Erebos.Storable+import Erebos.Storage.Graph import Erebos.Storage.Head import Erebos.Storage.Merge @@ -53,10 +57,12 @@      convReference = refDigest . storedRef . head . idDataF . msgPeer -    convMessageListSince mbSince thread =-        threadToListHelper (msgSeen thread) (maybe S.empty (S.fromAscList . msgHead) mbSince) (msgHead thread)+    convMessageListSince Nothing      thread = ( 0, ) $ dmThreadToListUnread thread+    convMessageListSince (Just since) thread = dmThreadToListChange since thread +    convMarkAllSeen DirectMessageThread {..} = dmMarkAsSeen msgPeer + data DirectMessage = DirectMessage     { msgFrom :: ComposedIdentity     , msgPrev :: [ Stored DirectMessage ]@@ -86,6 +92,10 @@     { dmOwnerMismatch = svcPrint "Owner mismatch"     } +data DirectMessagePeerState = DirectMessagePeerState+    { dmpsLastThread :: Maybe DirectMessageThread+    }+ data DirectMessageGlobalState = DirectMessageGlobalState     { dmgsLastState :: Maybe [ Stored MessageState ]     }@@ -96,6 +106,11 @@     type ServiceAttributes DirectMessage = DirectMessageAttributes     defaultServiceAttributes _ = defaultDirectMessageAttributes +    type ServiceState DirectMessage = DirectMessagePeerState+    emptyServiceState _ = DirectMessagePeerState+        { dmpsLastThread = Nothing+        }+     type ServiceGlobalState DirectMessage = DirectMessageGlobalState     emptyServiceGlobalState _ = DirectMessageGlobalState         { dmgsLastState = Nothing@@ -106,8 +121,8 @@         powner <- asks $ finalOwner . svcPeerIdentity         erb <- svcGetLocal         let DirectMessageThreads prev _ = lookupSharedValue $ lsShared $ fromStored erb-            sent = findMsgProperty powner msSent prev-            received = findMsgProperty powner msReceived prev+            sent = concat $ propertyValue $ findMsgProperty powner msSent prev+            received = concat $ propertyValue $ findMsgProperty powner msReceived prev             received' = filterAncestors $ smsg : received         if powner `sameIdentity` msgFrom msg ||                filterAncestors sent == filterAncestors (smsg : sent)@@ -185,21 +200,27 @@ instance SharedType DirectMessageThreads where     sharedTypeID _ = mkSharedTypeID "ee793681-5976-466a-b0f0-4e1907d3fade" -findMsgProperty :: Foldable m => Identity m -> (MessageState -> [ a ]) -> [ Stored MessageState ] -> [ a ]-findMsgProperty pid sel mss = concat $ flip findProperty mss $ \x -> do+msgPropertySelector :: Foldable m => Identity m -> (MessageState -> [ a ]) -> MessageState -> Maybe [ a ]+msgPropertySelector pid sel x = do     guard $ msPeer x `sameIdentity` pid     guard $ not $ null $ sel x     return $ sel x +findMsgProperty :: Foldable m => Identity m -> (MessageState -> [ a ]) -> [ Stored MessageState ] -> Property MessageState [ a ]+findMsgProperty pid sel mss = flip findProperty' mss $ msgPropertySelector pid sel +findMsgPropertyUpdate :: Property MessageState [ a ] -> [ Stored MessageState ] -> Property MessageState [ a ]+findMsgPropertyUpdate prev mss = findPropertyUpdate prev mss++ sendDirectMessage :: (Foldable f, Applicative f, MonadHead LocalState m)                   => Identity f -> Text -> m () sendDirectMessage pid text = updateLocalState_ $ \ls -> do     let self = localIdentity $ fromStored ls         powner = finalOwner pid     flip updateSharedState_ ls $ \(DirectMessageThreads prev _) -> do-        let ready = findMsgProperty powner msReady prev-            received = findMsgProperty powner msReceived prev+        let ready = concat $ propertyValue $ findMsgProperty powner msReady prev+            received = concat $ propertyValue $ findMsgProperty powner msReceived prev          time <- liftIO getZonedTime         smsg <- mstore DirectMessage@@ -224,7 +245,7 @@ dmMarkAsSeen pid = do     updateLocalState_ $ updateSharedState_ $ \(DirectMessageThreads prev _) -> do         let powner = finalOwner pid-            received = findMsgProperty powner msReceived prev+            received = concat $ propertyValue $ findMsgProperty powner msReceived prev         next <- mstore MessageState             { msPrev = prev             , msPeer = powner@@ -279,28 +300,25 @@ syncDirectMessageToPeer (DirectMessageThreads mss _) = do     pid <- finalOwner <$> asks svcPeerIdentity     peer <- asks svcPeer-    let thread = messageThreadFor pid mss+    pthread <- fromMaybe (dmEmptyThread pid) . dmpsLastThread <$> svcGet+    let thread = messageThreadFor pthread mss     mapM_ (sendToPeerStored peer) $ msgHead thread-    updateLocalState_ $ \ls -> do-        let powner = finalOwner pid-        flip updateSharedState_ ls $ \unchanged@(DirectMessageThreads prev _) -> do-            let ready = findMsgProperty powner msReady prev-                sent = findMsgProperty powner msSent prev-                sent' = filterAncestors (ready ++ sent)--            if sent' /= sent-              then do+    when (msgHead thread /= msgSent thread) $ do+        updateLocalState_ $ \ls -> do+            let powner = finalOwner pid+            flip updateSharedState_ ls $ \_ -> do                 next <- mstore MessageState-                    { msPrev = prev+                    { msPrev = mss                     , msPeer = powner                     , msReady = []-                    , msSent = sent'+                    , msSent = msgHead thread                     , msReceived = []                     , msSeen = []                     }                 return $ DirectMessageThreads [ next ] (dmThreadView [ next ])-              else do-                return unchanged+    svcModify $ \s -> s+        { dmpsLastThread = Just thread+        }  findMissingPeers :: Server -> DirectMessageThreads -> ExceptT ErebosError IO () findMissingPeers server (DirectMessageThreads states threads) = do@@ -319,8 +337,25 @@     , msgSent :: [ Stored DirectMessage ]     , msgSeen :: [ Stored DirectMessage ]     , msgReceived :: [ Stored DirectMessage ]+    , msgPropReady :: Property MessageState [ Stored DirectMessage ]+    , msgPropSent :: Property MessageState [ Stored DirectMessage ]+    , msgPropReceived :: Property MessageState [ Stored DirectMessage ]+    , msgPropSeen :: Property MessageState [ Stored DirectMessage ]     } +dmEmptyThread :: ComposedIdentity -> DirectMessageThread+dmEmptyThread peer = DirectMessageThread+    { msgPeer = peer+    , msgHead = []+    , msgSent = []+    , msgSeen = []+    , msgReceived = []+    , msgPropReady = emptyProperty $ msgPropertySelector peer msReady+    , msgPropSent = emptyProperty $ msgPropertySelector peer msSent+    , msgPropReceived = emptyProperty $ msgPropertySelector peer msReceived+    , msgPropSeen = emptyProperty $ msgPropertySelector peer msSeen+    }+ dmThreadToList :: DirectMessageThread -> [ DirectMessage ] dmThreadToList thread = map fst $ threadToListHelper (msgSeen thread) S.empty $ msgHead thread @@ -334,13 +369,23 @@ 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 = []+threadToListHelper seen used msgs = map (\msg -> ( fromStored msg, isNew msg )) $ graphToList cmp $ graphRemoveTips (S.toList used) $ graphFromTips msgs   where-    cmpView msg = (zonedTimeToUTC $ msgTime $ fromStored msg, msg)+    cmp = comparing $ zonedTimeToUTC . msgTime . fromStored+    isNew msg = not $ any (msg `precedesOrEquals`) seen +dmThreadToListChange :: DirectMessageThread -> DirectMessageThread -> ( Int, [ ( DirectMessage, Bool ) ] )+dmThreadToListChange since thread =+    ( graphSize $ graphRemoveTips bottom $ graphFromTips (msgHead since)+    , map (\msg -> ( fromStored msg, isNew msg )) $ graphToList cmp $ graphRemoveTips bottom $ graphFromTips (msgHead thread)+    )+  where+    cmp = comparing $ zonedTimeToUTC . msgTime . fromStored+    isNew msg = not $ any (msg `precedesOrEquals`) (msgSeen thread)+    bottom+        | msgSeen since == msgSeen thread = msgHead since+        | otherwise = commonAncestors (msgHead since) (msgSeen since)+ dmThreadView :: [ Stored MessageState ] -> [ DirectMessageThread ] dmThreadView = helper []     where helper used ms' = case filterAncestors ms' of@@ -349,43 +394,62 @@                       helper used $ msPrev (fromStored sms) ++ rest                   | otherwise ->                       let peer = msPeer $ fromStored sms-                       in messageThreadFor peer mss : helper (peer : used) (msPrev (fromStored sms) ++ rest)+                       in messageThreadFor (dmEmptyThread peer) mss : helper (peer : used) (msPrev (fromStored sms) ++ rest)               _ -> [] -messageThreadFor :: ComposedIdentity -> [ Stored MessageState ] -> DirectMessageThread-messageThreadFor peer mss =-    let ready = findMsgProperty peer msReady mss-        sent = findMsgProperty peer msSent mss-        received = findMsgProperty peer msReceived mss-        seen = findMsgProperty peer msSeen mss+messageThreadFor :: DirectMessageThread -> [ Stored MessageState ] -> DirectMessageThread+messageThreadFor pthread mss =+    let readyProp = findMsgPropertyUpdate (msgPropReady pthread) mss+        ready = concat $ propertyValue readyProp+        sentProp = findMsgPropertyUpdate (msgPropSent pthread) mss+        sent = concat $ propertyValue sentProp+        receivedProp = findMsgPropertyUpdate (msgPropReceived pthread) mss+        received = concat $ propertyValue receivedProp+        seenProp = findMsgPropertyUpdate (msgPropSeen pthread) mss+        seen = concat $ propertyValue seenProp       in DirectMessageThread-         { msgPeer = peer+         { msgPeer = msgPeer pthread          , msgHead = filterAncestors $ ready ++ received          , msgSent = filterAncestors $ sent ++ received          , msgSeen = filterAncestors $ ready ++ seen          , msgReceived = filterAncestors $ received+         , msgPropReady = readyProp+         , msgPropSent = sentProp+         , msgPropReceived = receivedProp+         , msgPropSeen = seenProp          }   watchDirectMessageThreads :: Head LocalState -> (DirectMessageThread -> DirectMessageThread -> IO ()) -> IO WatchedHead-watchDirectMessageThreads h f = do+watchDirectMessageThreads h callback = do     prevVar <- newMVar Nothing     watchHeadWith h (lookupSharedValue . lsShared . headObject) $ \(DirectMessageThreads sms _) -> do         modifyMVar_ prevVar $ \case-            Just prev -> do+            Just ( prev, prevPeers ) -> do                 let addPeer (p : ps) p'                         | p `sameIdentity` p' = p : ps                         | otherwise = p : addPeer ps p'                     addPeer [] p' = [ p' ]+                let changedPeers = foldl' addPeer [] $ map (msPeer . fromStored) $ storedDifference prev sms -                let peers = foldl' addPeer [] $ map (msPeer . fromStored) $ storedDifference prev sms-                forM_ peers $ \peer -> do-                    f (messageThreadFor peer prev) (messageThreadFor peer sms)-                return (Just sms)+                let updatePeer (px@( p, x ) : ps) p' f+                        | p `sameIdentity` p' = let x' = f x in ( ( x, x' ), ( p', x' ) : ps )+                        | otherwise = (px :) <$> updatePeer ps p' f+                    updatePeer [] p' f =+                        let x = dmEmptyThread p'; x' = f x+                         in ( ( x, x' ), [ ( p', x' ) ] ) +                peers <- (\f -> foldM f prevPeers changedPeers) $ \peers peer -> do+                    let ( ( t, t' ), peers' ) = updatePeer peers peer $ \pt ->+                            messageThreadFor pt sms+                    callback t t'+                    return peers'+                return (Just ( sms, peers ))+             Nothing -> do-                return (Just sms)+                return (Just ( sms, [] ))+  formatDirectMessage :: TimeZone -> DirectMessage -> String formatDirectMessage tzone msg = concat

@@ -62,6 +62,8 @@ import Network.Socket hiding (ControlMessage) import Network.Socket.ByteString qualified as S +import System.IO.Error+ import Erebos.Error import Erebos.Identity import Erebos.Network.Address@@ -71,6 +73,7 @@ import Erebos.PubKey import Erebos.Service import Erebos.State+import Erebos.Storable.Internal import Erebos.Storage import Erebos.Storage.Key import Erebos.Storage.Merge@@ -93,6 +96,7 @@     , serverIdentity_ :: MVar UnifiedIdentity     , serverThreads :: MVar [ThreadId]     , serverSocket :: MVar Socket+    , serverSocketClosed :: MVar ()     , serverRawPath :: SymFlow (PeerAddress, BC.ByteString)     , serverControlFlow :: Flow (ControlMessage PeerAddress) (ControlRequest PeerAddress)     , serverDataResponse :: TQueue (Peer, Maybe PartialRef)@@ -115,6 +119,7 @@  data ServerOptions = ServerOptions     { serverPort :: PortNumber+    , serverRetryUnspecifiedPort :: Bool     , serverLocalDiscovery :: Bool     , serverErrorPrefix :: String     , serverTestLog :: Bool@@ -123,6 +128,7 @@ defaultServerOptions :: ServerOptions defaultServerOptions = ServerOptions     { serverPort = discoveryPort+    , serverRetryUnspecifiedPort = True     , serverLocalDiscovery = True     , serverErrorPrefix = ""     , serverTestLog = False@@ -260,6 +266,7 @@     serverIdentity_ <- newMVar $ headLocalIdentity serverOrigHead     serverThreads <- newMVar []     serverSocket <- newEmptyMVar+    serverSocketClosed <- newEmptyMVar     (serverRawPath, protocolRawPath) <- newFlowIO     (serverControlFlow, protocolControlFlow) <- newFlowIO     serverDataResponse <- newTQueueIO@@ -290,16 +297,7 @@         either (atomically . logd . showErebosError) return =<< runExceptT =<<             atomically (readTQueue serverIOActions) -    let open addr = do-            sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)-            putMVar serverSocket sock-            setSocketOption sock ReuseAddr 1-            setSocketOption sock Broadcast 1-            withFdSocket sock setCloseOnExecIfNeeded-            bind sock (addrAddress addr)-            return sock--        loop sock = do+    let loop sock = do             when (serverLocalDiscovery serverOptions) $ forkServerThread server "discovery" $ do                 announceAddreses <- fmap concat $ sequence $                     [ map (SockAddrInet6 discoveryPort 0 discoveryMulticastGroup) <$> joinMulticast sock@@ -335,11 +333,11 @@             forM_ serverServices $ \(SomeService service _) -> do                 forM_ (serviceStorageWatchers service) $ \case                     SomeStorageWatcher sel act -> do-                        watchHeadWith serverOrigHead (sel . headStoredObject) $ \x -> do+                        watchHeadWith serverOrigHead (sel . headStoredObject) $ \_ -> do                             withMVar serverPeers $ mapM_ $ \peer -> atomically $ do                                 readTVar (peerIdentityVar peer) >>= \case                                     PeerIdentityFull _ -> writeTQueue serverIOActions $ do-                                        runPeerService peer $ act x+                                        runPeerService peer $ act . sel =<< svcGetLocal                                     _ -> return ()                     GlobalStorageWatcher sel act -> do                         watchHeadWith serverOrigHead (sel . headStoredObject) $ \x -> do@@ -423,7 +421,21 @@               , addrSocketType = Datagram               }         addr:_ <- getAddrInfo (Just hints) Nothing (Just $ show $ serverPort serverOptions)-        bracket (open addr) close loop+        let open = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)+            closeAndNotify sock = close sock >> putMVar serverSocketClosed ()+        bracket open closeAndNotify $ \sock -> do+            withFdSocket sock setCloseOnExecIfNeeded+            setSocketOption sock Broadcast 1+            bind sock (addrAddress addr) `catchIOError` \e -> if+                | isAlreadyInUseError e && serverRetryUnspecifiedPort serverOptions+                , SockAddrInet6 _ f h s <- addrAddress addr+                -> do atomically $ logd $ if serverPort serverOptions == discoveryPort+                        then "Failed to bind default discovery port, will not receive discovery packets on local network."+                        else "Failed to bind port " <> show (serverPort serverOptions) <> ", retrying with ephemeral one."+                      bind sock (SockAddrInet6 0 f h s)+                | otherwise -> ioError e+            putMVar serverSocket sock+            loop sock      forkServerThread server "service-handler" $ forever $ do         ( peer, paddr, svc, ref, streams ) <- atomically $ readTQueue chanSvc@@ -449,6 +461,7 @@                     _ -> emptyServiceState proxy             serviceStopServer proxy server gs ps         mapM_ killThread =<< takeMVar serverThreads+    takeMVar serverSocketClosed  dataResponseWorker :: Server -> IO () dataResponseWorker server = forever $ do

@@ -11,6 +11,7 @@     storeRawBytes, lazyLoadBytes,      RecItem, RecItem'(..),+    DirItem(..),      Ref, PartialRef, RefDigest,     refDigest, refFromDigest,

@@ -1,22 +1,23 @@ module Erebos.Object.Internal (     Storage, PartialStorage, StorageCompleteness, -    Ref, PartialRef, RefDigest,+    Ref, PartialRef, RefDigest, Ref'(..),     refDigest, refFromDigest,+    refStorage,     readRef, showRef,     readRefDigest, showRefDigest,     refDigestFromByteString, hashToRefDigest,-    copyRef, partialRef, partialRefFromDigest,+    copyRef, copyRef', partialRef, partialRefFromDigest,+    zeroRef, -    Object, PartialObject, Object'(..), RecItem, RecItem'(..),+    Object, PartialObject, Object'(..),+    RecItem, RecItem'(..),+    DirItem(..),     serializeObject, deserializeObject, deserializeObjects,     ioLoadObject, ioLoadBytes,     storeRawBytes, lazyLoadBytes,     storeObject,-    collectObjects, collectStoredObjects, -    MonadStorage(..),-     Storable(..), ZeroStorable(..),     StorableText(..), StorableDate(..), StorableUUID(..), @@ -38,12 +39,6 @@     loadMbEmpty, loadMbInt, loadMbNum, loadMbText, loadMbBinary, loadMbDate, loadMbUUID, loadMbRef, loadMbRawRef, loadMbRawWeak,     loadTexts, loadBinaries, loadRefs, loadRawRefs, loadRawWeaks,     loadZRef,--    Stored,-    fromStored, storedRef,-    wrappedStore, wrappedLoad,-    copyStored,-    unsafeMapStored, ) where  import Control.Applicative@@ -65,10 +60,9 @@ import Data.ByteString.Lazy.Char8 qualified as BLC import Data.Char import Data.Function+import Data.Hashable import Data.Maybe import Data.Ratio-import Data.Set (Set)-import Data.Set qualified as S import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding@@ -88,6 +82,33 @@ import Erebos.Util  +data Ref' c = Ref (Storage' c) RefDigest++type Ref = Ref' Complete+type PartialRef = Ref' Partial++instance Eq (Ref' c) where+    Ref _ d1 == Ref _ d2  =  d1 == d2++instance Show (Ref' c) where+    show ref@(Ref st _) = show st ++ ":" ++ BC.unpack (showRef ref)++instance BA.ByteArrayAccess (Ref' c) where+    length (Ref _ dgst) = BA.length dgst+    withByteArray (Ref _ dgst) = BA.withByteArray dgst++instance Hashable (Ref' c) where+    hashWithSalt salt = hashWithSalt salt . refDigest++refStorage :: Ref' c -> Storage' c+refStorage (Ref st _) = st++refDigest :: Ref' c -> RefDigest+refDigest (Ref _ dgst) = dgst++showRef :: Ref' c -> ByteString+showRef = showRefDigest . refDigest+ zeroRef :: Storage' c -> Ref' c zeroRef s = Ref s (RefDigest h)     where h = case digestFromByteString $ B.replicate (hashDigestSize $ digestAlgo h) 0 of@@ -133,6 +154,8 @@ 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' _ (Chunked size dgsts) = return $ return $ Chunked size dgsts+copyObject' _ (Dir items) = return $ return $ Dir items copyObject' _ ZeroObject = return $ return ZeroObject copyObject' _ (UnknownObject otype content) = return $ return $ UnknownObject otype content @@ -156,6 +179,8 @@     = Blob ByteString     | Rec [ ( ByteString, RecItem' c ) ]     | OnDemand Word64 RefDigest+    | Chunked Word64 [ RefDigest ]+    | Dir [ DirItem ]     | ZeroObject     | UnknownObject ByteString ByteString     deriving (Show)@@ -178,6 +203,14 @@  type RecItem = RecItem' Complete +data DirItem = DirItem+    { dirItemData :: RefDigest+    , dirItemMetadata :: RefDigest+    , dirItemFilename :: Text+    }+    deriving (Show)++ serializeObject :: Object' c -> BL.ByteString serializeObject = \case     Blob cnt -> BL.fromChunks [BC.pack "blob ", BC.pack (show $ B.length cnt), BC.singleton '\n', cnt]@@ -187,6 +220,12 @@     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 ]+    Chunked size dgsts ->+        let cnt = BC.unlines $ BC.pack (show size) : map showRefDigest dgsts+         in BL.fromChunks [ BC.pack "chunked ", BC.pack (show $ B.length cnt), BC.singleton '\n', cnt ]+    Dir items ->+        let cnt = BL.fromChunks $ map (\(DirItem d m f) -> BC.concat [ showRefDigest d, BC.singleton ' ', showRefDigest m, BC.singleton ' ', serializeText f, BC.singleton '\n' ]) items+         in BL.fromChunks [ BC.pack "dir ", BC.pack (show $ BL.length cnt), BC.singleton '\n' ] `BL.append` cnt     ZeroObject -> BL.empty     UnknownObject otype cnt -> BL.fromChunks [ otype, BC.singleton ' ', BC.pack (show $ B.length cnt), BC.singleton '\n', cnt ] @@ -213,10 +252,7 @@ serializeRecItem name (RecEmpty) = [name, BC.pack ":e", BC.singleton ' ', BC.singleton '\n'] serializeRecItem name (RecInt x) = [name, BC.pack ":i", BC.singleton ' ', BC.pack (show x), BC.singleton '\n'] serializeRecItem name (RecNum x) = [name, BC.pack ":n", BC.singleton ' ', BC.pack (showRatio x), BC.singleton '\n']-serializeRecItem name (RecText x) = [name, BC.pack ":t", BC.singleton ' ', escaped, BC.singleton '\n']-    where escaped = BC.concatMap escape $ encodeUtf8 x-          escape '\n' = BC.pack "\n\t"-          escape c    = BC.singleton c+serializeRecItem name (RecText x) = [name, BC.pack ":t", BC.singleton ' ', serializeText x, BC.singleton '\n'] serializeRecItem name (RecBinary x) = [name, BC.pack ":b ", showHex x, BC.singleton '\n'] serializeRecItem name (RecDate x) = [name, BC.pack ":d", BC.singleton ' ', BC.pack (formatTime defaultTimeLocale "%s %z" x), BC.singleton '\n'] serializeRecItem name (RecUUID x) = [name, BC.pack ":u", BC.singleton ' ', U.toASCIIBytes x, BC.singleton '\n']@@ -224,6 +260,12 @@ serializeRecItem name (RecWeak x) = [name, BC.pack ":w ", showRefDigest x, BC.singleton '\n'] serializeRecItem name (RecUnknown t x) = [ name, BC.singleton ':', t, BC.singleton ' ', x, BC.singleton '\n' ] +serializeText :: Text -> ByteString+serializeText = BC.concatMap escape . encodeUtf8+  where+    escape '\n' = BC.pack "\n\t"+    escape c    = BC.singleton c+ lazyLoadObject :: forall c. StorageCompleteness c => Ref' c -> LoadResult c (Object' c) lazyLoadObject = returnLoadResult . unsafePerformIO . ioLoadObject @@ -244,6 +286,9 @@ lazyLoadBytes ref | isZeroRef ref = returnLoadResult (return BL.empty :: c BL.ByteString) lazyLoadBytes ref = returnLoadResult $ unsafePerformIO $ ioLoadBytes ref +ioLoadBytes :: StorageCompleteness c => Ref' c -> IO (c BL.ByteString)+ioLoadBytes (Ref st dgst) = unsafeLoadBytes st dgst+ unsafeDeserializeObject :: Storage' c -> BL.ByteString -> Except ErebosError (Object' c, BL.ByteString) unsafeDeserializeObject _  bytes | BL.null bytes = return (ZeroObject, bytes) unsafeDeserializeObject st bytes =@@ -260,6 +305,12 @@                 | otype == BC.pack "ondemand"                 , Just ondemand <- parseOnDemand st content                     -> return ondemand+                | otype == BC.pack "chunked"+                , Just chunked <- parseChunked st content+                    -> return chunked+                | otype == BC.pack "dir"+                , Just dir <- parseDir st content+                    -> return dir                 | otherwise                     -> return $ UnknownObject otype content         _ -> throwOtherError $ "malformed object"@@ -317,7 +368,37 @@     dgst <- readRefDigest $ B.take newline2 $ B.drop (newline1 + 1) body     return $ OnDemand (fromIntegral size) dgst +parseChunked :: Storage' c -> ByteString -> Maybe (Object' c)+parseChunked _ body = do+    tsize : trefs <- strictLines body+    ( size, sizeRest ) <- BC.readInt tsize+    guard (B.null sizeRest)+    dgsts <- mapM readRefDigest trefs+    return $ Chunked (fromIntegral size) dgsts+  where+    strictLines bs+        | B.null bs = Just []+        | otherwise = do+            newline <- BC.elemIndex '\n' bs+            (B.take newline bs :) <$> strictLines (B.drop (newline + 1) bs) +parseDir :: Storage' c -> ByteString -> Maybe (Object' c)+parseDir st body = Dir <$> parseDirBody st body++parseDirBody :: Storage' c -> ByteString -> Maybe [ DirItem ]+parseDirBody _ body | B.null body = Just []+parseDirBody st body = do+    space1 <- BC.elemIndex ' ' body+    space2 <- BC.elemIndex ' ' $ B.drop (space1 + 1) body+    ( filenameB, remainingBody ) <- parseTabEscapedLines $ B.drop (space1 + space2 + 2) body+    let dataRefB = B.take space1 body+        metaRefB = B.take space2 $ B.drop (space1 + 1) body+        filename = decodeUtf8With lenientDecode filenameB+    dataRef <- readRefDigest dataRefB+    metaRef <- readRefDigest metaRefB+    (DirItem dataRef metaRef filename :) <$> parseDirBody st remainingBody++ deserializeObject :: PartialStorage -> BL.ByteString -> Except ErebosError (PartialObject, BL.ByteString) deserializeObject = unsafeDeserializeObject @@ -327,40 +408,10 @@                                  (obj:) <$> deserializeObjects st rest  -collectObjects :: Object -> [Object]-collectObjects obj = obj : map fromStored (fst $ collectOtherStored S.empty obj)--collectStoredObjects :: Stored Object -> [Stored Object]-collectStoredObjects obj = obj : (fst $ collectOtherStored S.empty $ fromStored obj)--collectOtherStored :: Set RefDigest -> Object -> ([Stored Object], Set RefDigest)-collectOtherStored seen (Rec items) = foldr helper ([], seen) $ map snd items-    where helper (RecRef ref) (xs, s) | r <- refDigest ref-                                      , r `S.notMember` s-                                      = let o = wrappedLoad ref-                                            (xs', s') = collectOtherStored (S.insert r s) $ fromStored o-                                         in ((o : xs') ++ xs, s')-          helper _          (xs, s) = (xs, s)-collectOtherStored seen _ = ([], seen)-- deriving instance StorableUUID HeadID deriving instance StorableUUID HeadTypeID  -class Monad m => MonadStorage m where-    getStorage :: m Storage-    mstore :: Storable a => a -> m (Stored a)--    default mstore :: MonadIO m => Storable a => a -> m (Stored a)-    mstore x = do-        st <- getStorage-        wrappedStore st x--instance MonadIO m => MonadStorage (ReaderT Storage m) where-    getStorage = ask-- class Storable a where     store' :: a -> Store     load' :: Load a@@ -375,8 +426,10 @@  data Store     = StoreBlob ByteString-    | StoreRec (forall c. StorageCompleteness c => Storage' c -> [IO [(ByteString, RecItem' c)]])+    | StoreRec (forall c. StorageCompleteness c => Storage' c -> [ IO [ ( ByteString, RecItem' c ) ]])     | StoreOnDemand Word64 RefDigest+    | StoreChunked Word64 [ RefDigest ]+    | StoreDir [ DirItem ]     | StoreZero     | StoreUnknown ByteString ByteString @@ -387,10 +440,12 @@ evalStoreObject _ (StoreBlob x) = return $ Blob x evalStoreObject s (StoreRec f) = Rec . concat <$> sequence (f s) evalStoreObject _ (StoreOnDemand size dgst) = return $ OnDemand size dgst+evalStoreObject _ (StoreChunked size dgsts) = return $ Chunked size dgsts+evalStoreObject _ (StoreDir items) = return $ Dir items evalStoreObject _ StoreZero = return ZeroObject evalStoreObject _ (StoreUnknown otype content) = return $ UnknownObject otype content -newtype StoreRecM c a = StoreRecM (ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) a)+newtype StoreRecM c a = StoreRecM (ReaderT (Storage' c) (Writer [ IO [ ( ByteString, RecItem' c ) ]]) a)     deriving (Functor, Applicative, Monad)  type StoreRec c = StoreRecM c ()@@ -424,6 +479,8 @@         Rec xs' <- copyObject st (Rec xs)         return xs'     store' (OnDemand size dgst) = StoreOnDemand size dgst+    store' (Chunked size dgsts) = StoreChunked size dgsts+    store' (Dir items) = StoreDir items     store' ZeroObject = StoreZero     store' (UnknownObject otype content) = StoreUnknown otype content @@ -745,36 +802,6 @@     p ( name', RecRef x )  | name' == bname = Just (refDigest x)     p ( name', RecWeak x ) | name' == bname = Just x     p _                                     = Nothing----instance Storable a => Storable (Stored a) where-    store st = copyRef st . storedRef-    store' (Stored _ x) = store' x-    load' = Stored <$> loadCurrentRef <*> load'--instance ZeroStorable a => ZeroStorable (Stored a) where-    fromZero st = Stored (zeroRef st) $ fromZero st--fromStored :: Stored a -> a-fromStored = storedObject'--storedRef :: Stored a -> Ref-storedRef = storedRef'--wrappedStore :: MonadIO m => Storable a => Storage -> a -> m (Stored a)-wrappedStore st x = do ref <- liftIO $ store st x-                       return $ Stored ref x--wrappedLoad :: Storable a => Ref -> Stored a-wrappedLoad ref = Stored ref (load ref)--copyStored :: forall m a. MonadIO m => Storage -> Stored a -> m (Stored a)-copyStored st (Stored ref' x) = liftIO $ returnLoadResult . fmap (\r -> Stored r x) <$> copyRef' st ref'---- |Passed function needs to preserve the object representation to be safe-unsafeMapStored :: (a -> b) -> Stored a -> Stored b-unsafeMapStored f (Stored ref x) = Stored ref (f x)   showRatio :: Rational -> String

@@ -11,7 +11,7 @@ module Erebos.Storable (     Storable(..), ZeroStorable(..),     StorableText(..), StorableDate(..), StorableUUID(..),-    StorageCompleteness(..),+    StorageCompleteness,      Store, StoreRec,     storeBlob, storeRec, storeZero,@@ -43,3 +43,4 @@  import Erebos.Error import Erebos.Object.Internal+import Erebos.Storable.Internal

@@ -0,0 +1,100 @@+module Erebos.Storable.Internal (+    Storable(..), ZeroStorable(..),+    StorableText(..), StorableDate(..), StorableUUID(..),++    Stored(..),+    fromStored, storedRef,+    storedStorage,+    wrappedStore, wrappedLoad,+    copyStored,+    unsafeMapStored,++    collectObjects, collectStoredObjects,++    MonadStorage(..),+) where++import Control.Monad.Reader++import Data.Function+import Data.Set (Set)+import Data.Set qualified as S++import Erebos.Storage.Internal++import Erebos.Object.Internal+++data Stored a = Stored+    { storedRef' :: Ref+    , storedObject' :: a+    }+    deriving (Show)++instance Eq (Stored a) where+    (==)  =  (==) `on` (refDigest . storedRef')++instance Ord (Stored a) where+    compare  =  compare `on` (refDigest . storedRef')++instance Storable a => Storable (Stored a) where+    store st = copyRef st . storedRef+    store' (Stored _ x) = store' x+    load' = Stored <$> loadCurrentRef <*> load'++instance ZeroStorable a => ZeroStorable (Stored a) where+    fromZero st = Stored (zeroRef st) $ fromZero st++fromStored :: Stored a -> a+fromStored = storedObject'++storedRef :: Stored a -> Ref+storedRef = storedRef'++storedStorage :: Stored a -> Storage+storedStorage = refStorage . storedRef'++wrappedStore :: MonadIO m => Storable a => Storage -> a -> m (Stored a)+wrappedStore st x = do ref <- liftIO $ store st x+                       return $ Stored ref x++wrappedLoad :: Storable a => Ref -> Stored a+wrappedLoad ref = Stored ref (load ref)++copyStored :: forall m a. MonadIO m => Storage -> Stored a -> m (Stored a)+copyStored st (Stored ref' x) = liftIO $ returnLoadResult . fmap (\r -> Stored r x) <$> copyRef' st ref'++-- |Passed function needs to preserve the object representation to be safe+unsafeMapStored :: (a -> b) -> Stored a -> Stored b+unsafeMapStored f (Stored ref x) = Stored ref (f x)++collectStoredObjects :: Stored Object -> [ Stored Object ]+collectStoredObjects obj = obj : (fst $ collectOtherStored S.empty $ fromStored obj)+++collectObjects :: Object -> [Object]+collectObjects obj = obj : map fromStored (fst $ collectOtherStored S.empty obj)++collectOtherStored :: Set RefDigest -> Object -> ( [ Stored Object ], Set RefDigest )+collectOtherStored seen (Rec items) = foldr helper ( [], seen ) $ map snd items+    where helper (RecRef ref) (xs, s)+              | r <- refDigest ref+              , r `S.notMember` s+              = let o = wrappedLoad ref+                    (xs', s') = collectOtherStored (S.insert r s) $ fromStored o+                 in ((o : xs') ++ xs, s')+          helper _ ( xs, s ) = ( xs, s )+collectOtherStored seen _ = ( [], seen )+++class Monad m => MonadStorage m where+    getStorage :: m Storage+    mstore :: Storable a => a -> m (Stored a)++    default mstore :: MonadIO m => Storable a => a -> m (Stored a)+    mstore x = do+        st <- getStorage+        wrappedStore st x++instance MonadIO m => MonadStorage (ReaderT Storage m) where+    getStorage = ask

@@ -24,6 +24,7 @@ ) where  import Erebos.Object.Internal+import Erebos.Storable.Internal import Erebos.Storage.Disk import Erebos.Storage.Head import Erebos.Storage.Memory

@@ -0,0 +1,292 @@+module Erebos.Storage.Graph (+    Generation,+    showGeneration,+    compareGeneration, generationMax,+    storedGeneration,++    generations, generationsBy,+    ancestors,+    precedes,+    precedesOrEquals,+    filterAncestors,+    commonAncestors,+    storedRoots,+    walkAncestors,++    Property,+    emptyProperty,+    propertyValue, propertyValueFirst,+    findProperty', findPropertyUpdate,+    findProperty,+    findPropertyFirst,++    storedDifference,++    Graph,+    graphFromTips, graphRemoveTips,+    graphSize,+    graphToList,+) where++import Control.Arrow+import Control.Concurrent.MVar++import Data.ByteString.Char8 qualified as BC+import Data.HashTable.IO qualified as HT+import Data.List+import Data.List.NonEmpty (NonEmpty)+import Data.List.NonEmpty qualified as NE+import Data.Maybe+import Data.Ord+import Data.Set (Set)+import Data.Set qualified as S++import System.IO.Unsafe (unsafePerformIO)++import Erebos.Object.Internal+import Erebos.Storable.Internal+import Erebos.Storage.Internal+import Erebos.Util+++previous :: Storable a => Stored a -> [Stored a]+previous (Stored ref _) = case load ref of+    Rec items | Just (RecRef dref) <- lookup (BC.pack "SDATA") items+              , Rec ditems <- load dref ->+                    map wrappedLoad $ catMaybes $ map (\case RecRef r -> Just r; _ -> Nothing) $+                        map snd $ filter ((`elem` [ BC.pack "SPREV", BC.pack "SBASE" ]) . fst) ditems++              | otherwise ->+                    map wrappedLoad $ catMaybes $ map (\case RecRef r -> Just r; _ -> Nothing) $+                        map snd $ filter ((`elem` [ BC.pack "PREV", BC.pack "BASE" ]) . fst) items+    _ -> []+++nextGeneration :: [Generation] -> Generation+nextGeneration = foldl' helper (Generation 0)+    where helper (Generation c) (Generation n) | c <= n    = Generation (n + 1)+                                               | otherwise = Generation c++showGeneration :: Generation -> String+showGeneration (Generation x) = show x++compareGeneration :: Generation -> Generation -> Maybe Ordering+compareGeneration (Generation x) (Generation y) = Just $ compare x y++generationMax :: Storable a => [Stored a] -> Maybe (Stored a)+generationMax (x : xs) = Just $ snd $ foldl' helper (storedGeneration x, x) xs+    where helper (mg, mx) y = let yg = storedGeneration y+                               in case compareGeneration mg yg of+                                       Just LT -> (yg, y)+                                       _       -> (mg, mx)+generationMax [] = Nothing++storedGeneration :: Storable a => Stored a -> Generation+storedGeneration x =+    unsafePerformIO $ withMVar (stRefGeneration $ refStorage $ storedRef x) $ \ht -> do+        let doLookup y = HT.lookup ht (refDigest $ storedRef y) >>= \case+                Just gen -> return gen+                Nothing -> do+                    gen <- nextGeneration <$> mapM doLookup (previous y)+                    HT.insert ht (refDigest $ storedRef y) gen+                    return gen+        doLookup x+++-- |Returns list of sets starting with the set of given objects and+-- intcrementally adding parents.+generations :: Storable a => [ Stored a ] -> NonEmpty (Set (Stored a))+generations = generationsBy previous++-- |Returns list of sets starting with the set of given objects and+-- intcrementally adding parents, with the first parameter being+-- a function to get all the parents of given object.+generationsBy :: Ord a => (a -> [ a ]) -> [ a ] -> NonEmpty (Set a)+generationsBy parents xs = NE.unfoldr gen ( xs, S.fromList xs )+  where+    gen ( hs, cur ) = ( cur, ) $+        case filter (`S.notMember` cur) (parents =<< hs) of+            []    -> Nothing+            added -> let next = foldr S.insert cur added+                      in Just ( added, next )+++type StoredTips a = [ Stored a ]++-- |Returns set containing all given objects and their ancestors+ancestors :: Storable a => [Stored a] -> Set (Stored a)+ancestors = NE.last . generations++precedes :: Storable a => Stored a -> Stored a -> Bool+precedes x y = not $ x `elem` filterAncestors [x, y]++precedesOrEquals :: Storable a => Stored a -> Stored a -> Bool+precedesOrEquals x y = filterAncestors [ x, y ] == [ y ]++filterAncestors :: Storable a => [ Stored a ] -> StoredTips a+filterAncestors [ x ] = [ x ]+filterAncestors xs = let xs' = uniq $ sort xs+                      in helper xs' xs'+    where helper remains walk = case generationMax walk of+                                     Just x -> let px = previous x+                                                   remains' = filter (\r -> all (/=r) px) remains+                                                in helper remains' $ uniq $ sort (px ++ filter (/=x) walk)+                                     Nothing -> remains++commonAncestors :: Storable a => [ Stored a ] -> [ Stored a ] -> StoredTips a+commonAncestors [] _ = []+commonAncestors _ [] = []+commonAncestors oxs oys = sort $ gom oxs' oys'+  where+    maximumGen = maximumBy (comparing (\(Generation n) ->  n))+    oxs' = map (storedGeneration &&& id) oxs+    oys' = map (storedGeneration &&& id) oys++    gom [] _ = []+    gom _ [] = []+    gom xs ys = go (maximumGen (map fst xs ++ map fst ys)) xs ys++    go g xs ys =+        let ( cxs, nxs ) = partition ((g ==) . fst) xs+            ( cys, nys ) = partition ((g ==) . fst) ys+            ( common, ( cxs', cys' ) ) = takeCommon (uniq $ sort $ map snd cxs) (uniq $ sort $ map snd cys)+            pxs = map (storedGeneration &&& id) $ concatMap previous cxs'+            pys = map (storedGeneration &&& id) $ concatMap previous cys'+         in case ( pxs, pys ) of+                ( [], [] ) -> common ++ gom nxs nys+                ( _ , _  ) -> common ++ go (maximumGen (map fst pxs ++ map fst pys)) (pxs ++ nxs) (pys ++ nys)++    takeCommon (x : xs) (y : ys)+        | x < y = second (first  (x :)) $ takeCommon xs (y : ys)+        | y < x = second (second (y :)) $ takeCommon (x : xs) ys+        | otherwise = first (x :) $ takeCommon xs ys+    takeCommon [] ys = ( [], ( [], ys ))+    takeCommon xs [] = ( [], ( xs, [] ))+++storedRoots :: Storable a => Stored a -> [ Stored a ]+storedRoots x = do+    let st = refStorage $ storedRef x+    unsafePerformIO $ withMVar (stRefRoots st) $ \ht -> do+        let doLookup y = HT.lookup ht (refDigest $ storedRef y) >>= \case+                Just roots -> return roots+                Nothing -> do+                    roots <- case previous y of+                        [] -> return [ refDigest $ storedRef y ]+                        ps -> foldl' mergeUniq [] <$> mapM doLookup ps+                    HT.insert ht (refDigest $ storedRef y) roots+                    return roots+        map (wrappedLoad . Ref st) <$> doLookup x++walkAncestors :: (Storable a, Monoid m) => (Stored a -> m) -> [Stored a] -> m+walkAncestors f = helper . sortBy cmp+  where+    helper (x : y : xs) | x == y = helper (x : xs)+    helper (x : xs) = f x <> helper (mergeBy cmp (sortBy cmp (previous x)) xs)+    helper [] = mempty++    cmp x y = case compareGeneration (storedGeneration x) (storedGeneration y) of+                   Just LT -> GT+                   Just GT -> LT+                   _ -> compare x y+++data Property a b = Property+    { propSelector :: Stored a -> Maybe b+    , propSource :: [ Stored a ]+    , propHeads :: StoredTips a+    }++emptyProperty :: (a -> Maybe b) -> Property a b+emptyProperty sel = Property+    { propSelector = sel . fromStored+    , propSource = []+    , propHeads = []+    }++propertyValue :: Property a b -> [ b ]+propertyValue Property {..} = map (fromJust . propSelector) $ propHeads++propertyValueFirst :: Property a b -> Maybe b+propertyValueFirst Property {..} = fmap (fromJust . propSelector) $ listToMaybe $ propHeads++findProperty' :: forall a b. Storable a => (a -> Maybe b) -> [ Stored a ] -> Property a b+findProperty' sel propSource =+    let propSelector = sel . fromStored+        propHeads = filterAncestors $ findPropHeads (isJust . propSelector) =<< propSource+     in Property {..}++findPropertyUpdate :: forall a b. Storable a => Property a b -> [ Stored a ] -> Property a b+findPropertyUpdate prop source = prop+    { propSource = source+    , propHeads = secondPass+    }+  where+    selectedOrOldSource x = x `elem` propSource prop || isJust (propSelector prop x)+    firstPass = findPropHeads selectedOrOldSource =<< source+    ( foundOldSource, foundNewHeads ) = partition (`elem` propSource prop) firstPass+    secondPass = filterAncestors $ if+        | sort foundOldSource == propSource prop -> propHeads prop ++ foundNewHeads+        | otherwise -> (findPropHeads (isJust . propSelector prop) =<< foundOldSource) ++ foundNewHeads++findProperty :: forall a b. Storable a => (a -> Maybe b) -> [ Stored a ] -> [ b ]+findProperty sel = propertyValue . findProperty' sel++findPropertyFirst :: forall a b. Storable a => (a -> Maybe b) -> [ Stored a ] -> Maybe b+findPropertyFirst sel = propertyValueFirst . findProperty' sel++findPropHeads :: forall a. Storable a => (Stored a -> Bool) -> Stored a -> [ Stored a ]+findPropHeads sel sobj+    | sel sobj = [ sobj ]+    | otherwise = findPropHeads sel =<< previous sobj+++-- | Compute symmetrict difference between two stored histories. In other+-- words, return all 'Stored a' objects reachable (via 'previous') from first+-- given set, but not from the second; and vice versa.+storedDifference :: Storable a => [ Stored a ] -> [ Stored a ] -> [ Stored a ]+storedDifference xs' ys' =+    let xs = filterAncestors xs'+        ys = filterAncestors ys'++        filteredPrevious blocked zs = filterAncestors (previous zs ++ blocked) `diffSorted` blocked+        xg = S.toAscList $ NE.last $ generationsBy (filteredPrevious ys) $ filterAncestors (xs ++ ys) `diffSorted` ys+        yg = S.toAscList $ NE.last $ generationsBy (filteredPrevious xs) $ filterAncestors (ys ++ xs) `diffSorted` xs++     in xg `mergeUniq` yg+++data Graph a = Graph+    { graphHead :: StoredTips a+    , graphTail :: StoredTips a+    }++graphFromTips :: StoredTips a -> Graph a+graphFromTips h = Graph h []++graphRemoveTips :: Storable a => StoredTips a -> Graph a -> Graph a+graphRemoveTips remove g =+    let gheads = filter (\h -> not $ any (h `precedesOrEquals`) remove) (graphHead g)+        gtails = commonAncestors gheads $ graphTail g ++ remove+     in Graph { graphHead = gheads, graphTail = gtails }++graphSize :: Storable a => Graph a -> Int+graphSize = length . graphToList (\_ _ -> EQ)++graphToList :: Storable a => (Stored a -> Stored a -> Ordering) -> Graph a -> [ Stored a ]+graphToList cmp Graph {..} = go S.empty graphHead+  where+    go _ [] = []+    go used (x : xs)+        | ( x', xs' ) <- selectMax x xs+        = x' : go (S.insert x used) (xs' ++ filter (\(p :: Stored a) -> not $ p `S.member` used || any (p `precedesOrEquals`) graphTail) (previous x))++    cmp' x y = case cmp x y of EQ -> compare x y+                               o  -> o++    selectMax y (x : xs)+        = case cmp' y x of+              LT -> (y :) <$> selectMax x xs+              EQ -> selectMax y xs+              GT -> (x :) <$> selectMax y xs+    selectMax y [] = ( y, [] )

@@ -29,8 +29,8 @@ import Data.Bifunctor import Data.Typeable -import Erebos.Object-import Erebos.Storable+import Erebos.Object.Internal+import Erebos.Storable.Internal import Erebos.Storage.Backend import Erebos.Storage.Internal import Erebos.UUID qualified as U

@@ -1,13 +1,11 @@ module Erebos.Storage.Internal (     Storage'(..), Storage, PartialStorage,-    Ref'(..), Ref, PartialRef,     RefDigest(..),     WatchID, startWatchID, nextWatchID,     WatchList(..), WatchListItem(..), watchListAdd, watchListDel, -    refStorage,-    refDigest, refDigestFromByteString,-    showRef, showRefDigest, showRefDigestParts,+    refDigestFromByteString,+    showRefDigest, showRefDigestParts,     readRefDigest,     hashToRefDigest, @@ -19,7 +17,6 @@      Generation(..),     HeadID(..), HeadTypeID(..),-    Stored(..), storedStorage, ) where  import Control.Arrow@@ -35,7 +32,6 @@ import Data.ByteString (ByteString) import Data.ByteString.Char8 qualified as BC import Data.ByteString.Lazy qualified as BL-import Data.Function import Data.HashTable.IO qualified as HT import Data.Hashable import Data.Kind@@ -178,36 +174,9 @@ instance Show RefDigest where     show = BC.unpack . showRefDigest -data Ref' c = Ref (Storage' c) RefDigest--type Ref = Ref' Complete-type PartialRef = Ref' Partial--instance Eq (Ref' c) where-    Ref _ d1 == Ref _ d2  =  d1 == d2--instance Show (Ref' c) where-    show ref@(Ref st _) = show st ++ ":" ++ BC.unpack (showRef ref)--instance ByteArrayAccess (Ref' c) where-    length (Ref _ dgst) = BA.length dgst-    withByteArray (Ref _ dgst) = BA.withByteArray dgst- instance Hashable RefDigest where     hashWithSalt salt ref = salt `xor` unsafePerformIO (BA.withByteArray ref peek) -instance Hashable (Ref' c) where-    hashWithSalt salt ref = salt `xor` unsafePerformIO (BA.withByteArray ref peek)--refStorage :: Ref' c -> Storage' c-refStorage (Ref st _) = st--refDigest :: Ref' c -> RefDigest-refDigest (Ref _ dgst) = dgst--showRef :: Ref' c -> ByteString-showRef = showRefDigest . refDigest- showRefDigestParts :: RefDigest -> (ByteString, ByteString) showRefDigestParts x = (BC.pack "blake2", showHex x) @@ -238,40 +207,25 @@ newtype HeadTypeID = HeadTypeID UUID     deriving (Eq, Ord) -data Stored a = Stored-    { storedRef' :: Ref-    , storedObject' :: a-    }-    deriving (Show) -instance Eq (Stored a) where-    (==)  =  (==) `on` (refDigest . storedRef')--instance Ord (Stored a) where-    compare  =  compare `on` (refDigest . storedRef')--storedStorage :: Stored a -> Storage-storedStorage = refStorage . storedRef'-- type Complete = Identity type Partial = Either RefDigest  class (Traversable compl, Monad compl, Typeable compl) => StorageCompleteness compl where     type LoadResult compl a :: Type     returnLoadResult :: compl a -> LoadResult compl a-    ioLoadBytes :: Ref' compl -> IO (compl BL.ByteString)+    unsafeLoadBytes :: Storage' compl -> RefDigest -> IO (compl BL.ByteString)  instance StorageCompleteness Complete where     type LoadResult Complete a = a     returnLoadResult = runIdentity-    ioLoadBytes ref@(Ref st dgst) = maybe (error $ "Ref not found in complete storage: "++show ref) Identity+    unsafeLoadBytes st dgst = maybe (error $ "Ref not found in complete storage: "++show dgst) Identity         <$> ioLoadBytesFromStorage st dgst  instance StorageCompleteness Partial where     type LoadResult Partial a = Either RefDigest a     returnLoadResult = id-    ioLoadBytes (Ref st dgst) = maybe (Left dgst) Right <$> ioLoadBytesFromStorage st dgst+    unsafeLoadBytes st dgst = maybe (Left dgst) Right <$> ioLoadBytesFromStorage st dgst  ioLoadBytesFromStorage :: Storage' c -> RefDigest -> IO (Maybe BL.ByteString) ioLoadBytesFromStorage Storage {..} dgst =

@@ -11,7 +11,9 @@ import Data.ByteArray import Data.Typeable -import Erebos.Storable+import Erebos.Error+import Erebos.Object.Internal+import Erebos.Storable.Internal import Erebos.Storage.Internal  class Storable pub => KeyPair sec pub | sec -> pub, pub -> sec where

@@ -21,25 +21,13 @@     storedDifference, ) where -import Control.Concurrent.MVar--import Data.ByteString.Char8 qualified as BC-import Data.HashTable.IO qualified as HT import Data.Kind-import Data.List-import Data.List.NonEmpty (NonEmpty)-import Data.List.NonEmpty qualified as NE-import Data.Maybe-import Data.Set (Set)-import Data.Set qualified as S -import System.IO.Unsafe (unsafePerformIO)- import Erebos.Object-import Erebos.Storable-import Erebos.Storage.Internal-import Erebos.Util+import Erebos.Storable.Internal+import Erebos.Storage.Graph + class Storable (Component a) => Mergeable a where     type Component a :: Type     mergeSorted :: [Stored (Component a)] -> a@@ -57,135 +45,3 @@ storeMerge :: (Mergeable a, Storable a) => [Stored (Component a)] -> IO (Stored a) storeMerge [] = error "merge: empty list" storeMerge xs@(x : _) = wrappedStore (storedStorage x) $ mergeSorted $ filterAncestors xs--previous :: Storable a => Stored a -> [Stored a]-previous (Stored ref _) = case load ref of-    Rec items | Just (RecRef dref) <- lookup (BC.pack "SDATA") items-              , Rec ditems <- load dref ->-                    map wrappedLoad $ catMaybes $ map (\case RecRef r -> Just r; _ -> Nothing) $-                        map snd $ filter ((`elem` [ BC.pack "SPREV", BC.pack "SBASE" ]) . fst) ditems--              | otherwise ->-                    map wrappedLoad $ catMaybes $ map (\case RecRef r -> Just r; _ -> Nothing) $-                        map snd $ filter ((`elem` [ BC.pack "PREV", BC.pack "BASE" ]) . fst) items-    _ -> []---nextGeneration :: [Generation] -> Generation-nextGeneration = foldl' helper (Generation 0)-    where helper (Generation c) (Generation n) | c <= n    = Generation (n + 1)-                                               | otherwise = Generation c--showGeneration :: Generation -> String-showGeneration (Generation x) = show x--compareGeneration :: Generation -> Generation -> Maybe Ordering-compareGeneration (Generation x) (Generation y) = Just $ compare x y--generationMax :: Storable a => [Stored a] -> Maybe (Stored a)-generationMax (x : xs) = Just $ snd $ foldl' helper (storedGeneration x, x) xs-    where helper (mg, mx) y = let yg = storedGeneration y-                               in case compareGeneration mg yg of-                                       Just LT -> (yg, y)-                                       _       -> (mg, mx)-generationMax [] = Nothing--storedGeneration :: Storable a => Stored a -> Generation-storedGeneration x =-    unsafePerformIO $ withMVar (stRefGeneration $ refStorage $ storedRef x) $ \ht -> do-        let doLookup y = HT.lookup ht (refDigest $ storedRef y) >>= \case-                Just gen -> return gen-                Nothing -> do-                    gen <- nextGeneration <$> mapM doLookup (previous y)-                    HT.insert ht (refDigest $ storedRef y) gen-                    return gen-        doLookup x----- |Returns list of sets starting with the set of given objects and--- intcrementally adding parents.-generations :: Storable a => [ Stored a ] -> NonEmpty (Set (Stored a))-generations = generationsBy previous---- |Returns list of sets starting with the set of given objects and--- intcrementally adding parents, with the first parameter being--- a function to get all the parents of given object.-generationsBy :: Ord a => (a -> [ a ]) -> [ a ] -> NonEmpty (Set a)-generationsBy parents xs = NE.unfoldr gen ( xs, S.fromList xs )-  where-    gen ( hs, cur ) = ( cur, ) $-        case filter (`S.notMember` cur) (parents =<< hs) of-            []    -> Nothing-            added -> let next = foldr S.insert cur added-                      in Just ( added, next )---- |Returns set containing all given objects and their ancestors-ancestors :: Storable a => [Stored a] -> Set (Stored a)-ancestors = NE.last . generations--precedes :: Storable a => Stored a -> Stored a -> Bool-precedes x y = not $ x `elem` filterAncestors [x, y]--precedesOrEquals :: Storable a => Stored a -> Stored a -> Bool-precedesOrEquals x y = filterAncestors [ x, y ] == [ y ]--filterAncestors :: Storable a => [Stored a] -> [Stored a]-filterAncestors [x] = [x]-filterAncestors xs = let xs' = uniq $ sort xs-                      in helper xs' xs'-    where helper remains walk = case generationMax walk of-                                     Just x -> let px = previous x-                                                   remains' = filter (\r -> all (/=r) px) remains-                                                in helper remains' $ uniq $ sort (px ++ filter (/=x) walk)-                                     Nothing -> remains--storedRoots :: Storable a => Stored a -> [Stored a]-storedRoots x = do-    let st = refStorage $ storedRef x-    unsafePerformIO $ withMVar (stRefRoots st) $ \ht -> do-        let doLookup y = HT.lookup ht (refDigest $ storedRef y) >>= \case-                Just roots -> return roots-                Nothing -> do-                    roots <- case previous y of-                        [] -> return [refDigest $ storedRef y]-                        ps -> map (refDigest . storedRef) . filterAncestors . map (wrappedLoad @Object . Ref st) . concat <$> mapM doLookup ps-                    HT.insert ht (refDigest $ storedRef y) roots-                    return roots-        map (wrappedLoad . Ref st) <$> doLookup x--walkAncestors :: (Storable a, Monoid m) => (Stored a -> m) -> [Stored a] -> m-walkAncestors f = helper . sortBy cmp-  where-    helper (x : y : xs) | x == y = helper (x : xs)-    helper (x : xs) = f x <> helper (mergeBy cmp (sortBy cmp (previous x)) xs)-    helper [] = mempty--    cmp x y = case compareGeneration (storedGeneration x) (storedGeneration y) of-                   Just LT -> GT-                   Just GT -> LT-                   _ -> compare x y--findProperty :: forall a b. Storable a => (a -> Maybe b) -> [Stored a] -> [b]-findProperty sel = map (fromJust . sel . fromStored) . filterAncestors . (findPropHeads sel =<<)--findPropertyFirst :: forall a b. Storable a => (a -> Maybe b) -> [Stored a] -> Maybe b-findPropertyFirst sel = fmap (fromJust . sel . fromStored) . listToMaybe . filterAncestors . (findPropHeads sel =<<)--findPropHeads :: forall a b. Storable a => (a -> Maybe b) -> Stored a -> [Stored a]-findPropHeads sel sobj | Just _ <- sel $ fromStored sobj = [sobj]-                       | otherwise = findPropHeads sel =<< previous sobj----- | Compute symmetrict difference between two stored histories. In other--- words, return all 'Stored a' objects reachable (via 'previous') from first--- given set, but not from the second; and vice versa.-storedDifference :: Storable a => [ Stored a ] -> [ Stored a ] -> [ Stored a ]-storedDifference xs' ys' =-    let xs = filterAncestors xs'-        ys = filterAncestors ys'--        filteredPrevious blocked zs = filterAncestors (previous zs ++ blocked) `diffSorted` blocked-        xg = S.toAscList $ NE.last $ generationsBy (filteredPrevious ys) $ filterAncestors (xs ++ ys) `diffSorted` ys-        yg = S.toAscList $ NE.last $ generationsBy (filteredPrevious xs) $ filterAncestors (ys ++ xs) `diffSorted` xs--     in xg `mergeUniq` yg