diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -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.
diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -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
 
diff --git a/erebos.cabal b/erebos.cabal
--- a/erebos.cabal
+++ b/erebos.cabal
@@ -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
 
diff --git a/main/Main.hs b/main/Main.hs
--- a/main/Main.hs
+++ b/main/Main.hs
@@ -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
diff --git a/main/Terminal.hs b/main/Terminal.hs
--- a/main/Terminal.hs
+++ b/main/Terminal.hs
@@ -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
diff --git a/main/Test.hs b/main/Test.hs
--- a/main/Test.hs
+++ b/main/Test.hs
@@ -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
diff --git a/main/WebSocket.hs b/main/WebSocket.hs
--- a/main/WebSocket.hs
+++ b/main/WebSocket.hs
@@ -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
diff --git a/src/Erebos/Chatroom.hs b/src/Erebos/Chatroom.hs
--- a/src/Erebos/Chatroom.hs
+++ b/src/Erebos/Chatroom.hs
@@ -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
diff --git a/src/Erebos/Conversation.hs b/src/Erebos/Conversation.hs
--- a/src/Erebos/Conversation.hs
+++ b/src/Erebos/Conversation.hs
@@ -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
diff --git a/src/Erebos/Conversation/Class.hs b/src/Erebos/Conversation/Class.hs
--- a/src/Erebos/Conversation/Class.hs
+++ b/src/Erebos/Conversation/Class.hs
@@ -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 ()
diff --git a/src/Erebos/DirectMessage.hs b/src/Erebos/DirectMessage.hs
--- a/src/Erebos/DirectMessage.hs
+++ b/src/Erebos/DirectMessage.hs
@@ -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
diff --git a/src/Erebos/Network.hs b/src/Erebos/Network.hs
--- a/src/Erebos/Network.hs
+++ b/src/Erebos/Network.hs
@@ -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
diff --git a/src/Erebos/Object.hs b/src/Erebos/Object.hs
--- a/src/Erebos/Object.hs
+++ b/src/Erebos/Object.hs
@@ -11,6 +11,7 @@
     storeRawBytes, lazyLoadBytes,
 
     RecItem, RecItem'(..),
+    DirItem(..),
 
     Ref, PartialRef, RefDigest,
     refDigest, refFromDigest,
diff --git a/src/Erebos/Object/Internal.hs b/src/Erebos/Object/Internal.hs
--- a/src/Erebos/Object/Internal.hs
+++ b/src/Erebos/Object/Internal.hs
@@ -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
diff --git a/src/Erebos/Storable.hs b/src/Erebos/Storable.hs
--- a/src/Erebos/Storable.hs
+++ b/src/Erebos/Storable.hs
@@ -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
diff --git a/src/Erebos/Storable/Internal.hs b/src/Erebos/Storable/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Erebos/Storable/Internal.hs
@@ -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
diff --git a/src/Erebos/Storage.hs b/src/Erebos/Storage.hs
--- a/src/Erebos/Storage.hs
+++ b/src/Erebos/Storage.hs
@@ -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
diff --git a/src/Erebos/Storage/Graph.hs b/src/Erebos/Storage/Graph.hs
new file mode 100644
--- /dev/null
+++ b/src/Erebos/Storage/Graph.hs
@@ -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, [] )
diff --git a/src/Erebos/Storage/Head.hs b/src/Erebos/Storage/Head.hs
--- a/src/Erebos/Storage/Head.hs
+++ b/src/Erebos/Storage/Head.hs
@@ -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
diff --git a/src/Erebos/Storage/Internal.hs b/src/Erebos/Storage/Internal.hs
--- a/src/Erebos/Storage/Internal.hs
+++ b/src/Erebos/Storage/Internal.hs
@@ -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 =
diff --git a/src/Erebos/Storage/Key.hs b/src/Erebos/Storage/Key.hs
--- a/src/Erebos/Storage/Key.hs
+++ b/src/Erebos/Storage/Key.hs
@@ -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
diff --git a/src/Erebos/Storage/Merge.hs b/src/Erebos/Storage/Merge.hs
--- a/src/Erebos/Storage/Merge.hs
+++ b/src/Erebos/Storage/Merge.hs
@@ -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