diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,5 +1,15 @@
 # Revision history for erebos
 
+## 0.2.1 -- 2026-03-15
+
+* Initial support for `ondemand` object type.
+* New service and shared state for invites.
+* Show the number of conversations with unread messages in CLI prompt.
+* Show unread messages when selecting conversation.
+* Added `/new` command to list conversations with new (unread) messages.
+* Gracefully handle invalid record objects.
+* Fixes and improvements in discovery service and tunnel support.
+
 ## 0.2.0 -- 2025-08-06
 
 * Weak references in records
@@ -11,7 +21,7 @@
     * Print received messages only for selected conversation
     * Clear tab completion options after use
 
-* API
+* Library API
     * Split `Erebos.Storage` into multiple modules
     * Removed deprecated `Message.formatMessage` alias
     * Renamed `Erebos.Message` module to `Erebos.DirectMessage`
diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -95,6 +95,9 @@
 `/conversations`  
 : List started conversations with contacts or other peers.
 
+`/new`
+: List conversations with new (unread) messages.
+
 `/<number>`  
 : Select conversation, contact or peer `<number>` based on the last
   `/conversations`, `/contacts` or `/peers` output list.
@@ -147,7 +150,7 @@
   history, but the chatroom will no longer be listed as available and no futher
   updates for this chatroom will be collected or shared with other peers.
 
-### Add contacts
+### Contact list
 
 To ensure the identity of the contact and prevent man-in-the-middle attack,
 generated verification code needs to be confirmed on both devices to add
@@ -171,6 +174,17 @@
 
 `/contact-reject`  
 : Reject contact request or verification code of selected peer.
+
+`/invite-contact <name>`
+: Create an invite in the form of URL, which can be sent via means outside of
+  the erebos protocol. The recipient can accept it using the `invite-accept`
+  command. After accepting, contact entry is created with the given `<name>`.
+  The created invite can be used only once.
+
+`/invite-accept <URL>`
+: Accept received URL-formatted invite. The erebos tool will try to find and
+  connect to a device belonging to the issuing identity to confirm the invite.
+  If successful, corresponding contact entry will be created.
 
 ### Attach other devices
 
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.0
+Version:             0.2.1
 Synopsis:            Decentralized messaging and synchronization
 Description:
     Library and simple CLI interface implementing the Erebos identity
@@ -34,11 +34,6 @@
 Flag ice
     Description:    Enable peer discovery with ICE support using pjproject
 
-Flag ci
-    description:    Options for CI testing
-    default: False
-    manual: True
-
 Flag cryptonite
     description:    Use deprecated 'cryptonite' package
     default: False
@@ -53,12 +48,6 @@
         -Wno-x-partial
         -fdefer-typed-holes
 
-    if flag(ci)
-        ghc-options:
-            -Werror
-            -- sometimes needed for backward/forward compatibility:
-            -Wno-error=unused-imports
-
     build-depends:
         base ^>= { 4.15, 4.16, 4.17, 4.18, 4.19, 4.20, 4.21 },
 
@@ -107,8 +96,10 @@
         Erebos.Discovery
         Erebos.Error
         Erebos.Identity
+        Erebos.Invite
         Erebos.Network
         Erebos.Object
+        Erebos.Object.Deferred
         Erebos.Pairing
         Erebos.PubKey
         Erebos.Service
@@ -122,8 +113,11 @@
         Erebos.Storage.Key
         Erebos.Storage.Merge
         Erebos.Sync
+        Erebos.TextFormat
+        Erebos.TextFormat.Ansi
 
     other-modules:
+        Erebos.Conversation.Class
         Erebos.Flow
         Erebos.Network.Address
         Erebos.Network.Channel
@@ -133,6 +127,7 @@
         Erebos.Storage.Internal
         Erebos.Storage.Memory
         Erebos.Storage.Platform
+        Erebos.TextFormat.Types
         Erebos.UUID
         Erebos.Util
 
@@ -169,7 +164,7 @@
         hashtables ^>= { 1.2, 1.3, 1.4 },
         iproute >=1.7.12 && <1.8,
         memory >=0.14 && <0.19,
-        mtl >=2.2 && <2.4,
+        mtl ^>= { 2.2.2, 2.3 },
         network ^>= { 3.1, 3.2 },
         stm >=2.5 && <2.6,
         text >= 1.2 && <2.2,
diff --git a/main/Main.hs b/main/Main.hs
--- a/main/Main.hs
+++ b/main/Main.hs
@@ -37,12 +37,13 @@
 import System.IO
 
 import Erebos.Attach
-import Erebos.Contact
 import Erebos.Chatroom
+import Erebos.Contact
 import Erebos.Conversation
 import Erebos.DirectMessage
 import Erebos.Discovery
 import Erebos.Identity
+import Erebos.Invite
 import Erebos.Network
 import Erebos.Object
 import Erebos.PubKey
@@ -53,6 +54,7 @@
 import Erebos.Storage
 import Erebos.Storage.Merge
 import Erebos.Sync
+import Erebos.TextFormat
 
 import State
 import Terminal
@@ -72,9 +74,10 @@
     , optShowVersion :: Bool
     }
 
-data StorageOption = DefaultStorage
-                   | FilesystemStorage FilePath
-                   | MemoryStorage
+data StorageOption
+    = DefaultStorage
+    | FilesystemStorage FilePath
+    | MemoryStorage
 
 data ServiceOption = ServiceOption
     { soptName :: String
@@ -110,14 +113,16 @@
         True "direct messages"
     , ServiceOption "discovery" (someService @DiscoveryService Proxy)
         True "peer discovery"
+    , ServiceOption "invite" (someService @InviteService Proxy)
+        True "invites handling"
     ]
 
 options :: [ OptDescr (Options -> Writer [ String ] Options) ]
 options =
-    [ Option ['p'] ["port"]
+    [ Option [ 'p' ] [ "port" ]
         (ReqArg (\p -> so $ \opts -> opts { serverPort = read p }) "<port>")
         "local port to bind"
-    , Option ['s'] ["silent"]
+    , Option [ 's' ] [ "silent" ]
         (NoArg (so $ \opts -> opts { serverLocalDiscovery = False }))
         "do not send announce packets for local discovery"
     , Option [] [ "storage" ]
@@ -140,7 +145,7 @@
                  in maybe (Just ( Nothing, [ ownerName ] )) (Just . second (ownerName :)) (optCreateIdentity opts)
             }) "<name>")
         "create owner for a new device identity"
-    , Option [] ["chatroom-auto-subscribe"]
+    , Option [] [ "chatroom-auto-subscribe" ]
         (ReqArg (\count -> \opts -> return opts { optChatroomAutoSubscribe = Just (read count) }) "<count>")
         "automatically subscribe for up to <count> chatrooms"
     , Option [] [ "discovery-stun-port" ]
@@ -160,16 +165,16 @@
             fun <- provideTunnelFun value
             serviceAttr (\attrs -> return attrs { discoveryProvideTunnel = fun }) opts) "<peer-type>")
         "offer to provide tunnel for peers of given <peer-type>, possible values: all, none, websocket"
-    , Option [] ["dm-bot-echo"]
+    , Option [] [ "dm-bot-echo" ]
         (ReqArg (\prefix -> \opts -> return opts { optDmBotEcho = Just (T.pack prefix) }) "<prefix>")
         "automatically reply to direct messages with the same text prefixed with <prefix>"
     , Option [] [ "websocket-server" ]
         (ReqArg (\value -> \opts -> return opts { optWebSocketServer = Just (read value) }) "<port>")
         "start WebSocket server on given port"
-    , Option ['h'] ["help"]
+    , Option [ 'h' ] [ "help" ]
         (NoArg $ \opts -> return opts { optShowHelp = True })
         "show this help and exit"
-    , Option ['V'] ["version"]
+    , Option [ 'V' ] [ "version" ]
         (NoArg $ \opts -> return opts { optShowVersion = True })
         "show version and exit"
     ]
@@ -199,6 +204,25 @@
         tell [ "Invalid value of --discovery-tunnel: ‘" <> name <> "’\n" ]
         return $ \_ _ -> False
 
+debugOptions :: [ OptDescr (Options -> Writer [ String ] Options) ]
+debugOptions =
+    [ Option [] [ "discovery-debug-log" ]
+        (NoArg (serviceAttr $ \attrs -> return attrs { discoveryDebugLog = True }))
+        ""
+    ]
+  where
+    updateService :: (Service s, Monad m, Typeable m) => (ServiceAttributes s -> m (ServiceAttributes s)) -> SomeService -> m SomeService
+    updateService f some@(SomeService proxy attrs)
+        | Just f' <- cast f = SomeService proxy <$> f' attrs
+        | otherwise = return some
+
+    serviceAttr :: (Service s, Monad m, Typeable m) => (ServiceAttributes s -> m (ServiceAttributes s)) -> Options -> m Options
+    serviceAttr f opts = do
+        services' <- forM (optServices opts) $ \sopt -> do
+            service <- updateService f (soptService sopt)
+            return sopt { soptService = service }
+        return opts { optServices = services' }
+
 servicesOptions :: [ OptDescr (Options -> Writer [ String ] Options) ]
 servicesOptions = concatMap helper $ "all" : map soptName availableServices
   where
@@ -228,7 +252,7 @@
             progName <- getProgName
             hPutStrLn stderr $ concat errs <> "Try `" <> progName <> " --help' for more information."
             exitFailure
-    (opts, args) <- (getOpt RequireOrder (options ++ servicesOptions) <$> getArgs) >>= \case
+    (opts, args) <- (getOpt RequireOrder (options ++ servicesOptions ++ debugOptions) <$> getArgs) >>= \case
         (wo, args, []) ->
             case runWriter (foldM (flip ($)) defaultOptions wo) of
                 ( o, [] )   -> return ( o, args )
@@ -241,7 +265,7 @@
         MemoryStorage          -> memoryStorage
 
     case args of
-        ["cat-file", sref] -> do
+        [ "cat-file", sref ] -> do
             readRef st (BC.pack sref) >>= \case
                 Nothing -> error "ref does not exist"
                 Just ref -> BL.putStr $ lazyLoadBytes ref
@@ -272,7 +296,7 @@
                         Nothing -> putStrLn $ "Identity verification failed"
                     _ -> error $ "unknown object type '" ++ objtype ++ "'"
 
-        ["show-generation", sref] -> readRef st (BC.pack sref) >>= \case
+        [ "show-generation", sref ] -> readRef st (BC.pack sref) >>= \case
             Nothing -> error "ref does not exist"
             Just ref -> print $ storedGeneration (wrappedLoad ref :: Stored Object)
 
@@ -284,7 +308,7 @@
                     T.putStrLn "no local state head"
                     exitFailure
 
-        ["update-identity"] -> do
+        [ "update-identity" ] -> do
             withTerminal noCompletion $ \term -> do
                 either (fail . showErebosError) return <=< runExceptT $ do
                     runReaderT (updateSharedIdentity term) =<< runReaderT (loadLocalStateHead term) st
@@ -299,7 +323,7 @@
                                 (either (fail . showErebosError) return <=< runExceptT $ runReaderT (interactiveIdentityUpdate term idt) st)
                         | otherwise -> error "invalid identity"
 
-        ["test"] -> runTestTool st
+        [ "test" ] -> runTestTool st
 
         [] -> do
             let header = "Usage: erebos [OPTION...]"
@@ -323,17 +347,18 @@
                | otherwise -> interactiveLoop st opts
 
         (cmdname : _) -> do
-            hPutStrLn stderr $ "Unknown command `" <> cmdname <> "'"
+            hPutStrLn stderr $ "Unknown command ‘" <> cmdname <> "’"
             exitFailure
 
 
 interactiveLoop :: Storage -> Options -> IO ()
 interactiveLoop st opts = withTerminal commandCompletion $ \term -> do
+    showPrompt term
     erebosHead <- either (fail . showErebosError) return <=< runExceptT . flip runReaderT st $ do
         case optCreateIdentity opts of
             Nothing -> loadLocalStateHead term
             Just ( devName, names ) -> createLocalStateHead (names ++ [ devName ])
-    void $ printLine term $ T.unpack $ displayIdentity $ headLocalIdentity erebosHead
+    void $ printLine term $ plainText $ displayIdentity $ headLocalIdentity erebosHead
 
     let tui = hasTerminalUI term
     let extPrintLn = void . printLine term
@@ -353,7 +378,7 @@
                         SelectedConversation conv -> return $ T.unpack $ conversationName conv
                     return $ pname ++ "> "
                 Right prompt -> return prompt
-            lift $ setPrompt term prompt
+            lift $ setPrompt term $ plainText $ T.pack prompt
             join $ lift $ getInputLine term $ \case
                 Just input@('/' : _) -> KeepPrompt $ return input
                 Just input -> ErasePrompt $ case reverse input of
@@ -399,7 +424,7 @@
                         SelectedConversation conv -> return $ conversationPeer conv
                         _ -> return Nothing
                     when (not tui || maybe False (msgPeer cur `sameIdentity`) mbpid) $ do
-                        extPrintLn $ formatDirectMessage tzone msg
+                        extPrintLn $ plainText $ T.pack $ formatDirectMessage tzone msg
 
                 case optDmBotEcho opts of
                     Just prefix
@@ -412,6 +437,11 @@
                                     Left err -> extPrintLn $ "Failed to send dm echo: " <> err
                     _ -> return ()
 
+            withMVar contextVar $ \ctx -> do
+                updatePromptStatus term erebosHead . either (const Nothing) Just =<<
+                    (runExceptT $ flip runReaderT erebosHead $ getConversationFromContext ctx)
+    updatePromptStatus term erebosHead Nothing
+
     peers <- liftIO $ newMVar []
     contextOptions <- liftIO $ newMVar ( Nothing, [] )
     chatroomSetVar <- liftIO $ newEmptyMVar
@@ -426,11 +456,11 @@
         return Nothing
 
     server <- liftIO $ do
-        startServer (optServer opts) erebosHead extPrintLn $
+        startServer (optServer opts) erebosHead (extPrintLn . plainText . T.pack) $
             map soptService $ filter soptEnabled $ optServices opts
 
     case optWebSocketServer opts of
-        Just port -> startWebsocketServer server "::" port extPrintLn
+        Just port -> startWebsocketServer server "::" port (extPrintLn . plainText . T.pack)
         Nothing -> return ()
 
     void $ liftIO $ forkIO $ void $ forever $ do
@@ -439,24 +469,27 @@
             pid@(PeerIdentityFull _) -> do
                 dropped <- isPeerDropped peer
                 shown <- showPeer pid <$> getPeerAddress peer
-                let update [] = ([(peer, shown)], (Nothing, "NEW"))
+                let labelNew = withStyle (setForegroundColor Green noStyle) $ plainText "NEW"
+                    labelUpd = withStyle (setForegroundColor Yellow noStyle) $ plainText "UPD"
+                    labelDel = withStyle (setForegroundColor Red noStyle) $ plainText "DEL"
+                let update [] = ( [ ( peer, shown ) ], ( Nothing, labelNew ) )
                     update ((p,s):ps)
-                        | p == peer && dropped = (ps, (Nothing, "DEL"))
-                        | p == peer = ((peer, shown) : ps, (Just s, "UPD"))
+                        | p == peer && dropped = ( ps, ( Nothing, labelDel ) )
+                        | p == peer = ( ( peer, shown ) : ps, ( Just s, labelUpd ) )
                         | otherwise = first ((p,s):) $ update ps
                 let ctxUpdate n [] = ([SelectedPeer peer], n)
                     ctxUpdate n (ctx:ctxs)
                         | SelectedPeer p <- ctx, p == peer = (ctx:ctxs, n)
                         | otherwise = first (ctx:) $ ctxUpdate (n + 1) ctxs
-                (op, updateType) <- modifyMVar peers (return . update)
-                let updateType' = if dropped then "DEL" else updateType
+                ( op, updateType ) <- modifyMVar peers (return . update)
+                let updateType' = if dropped then labelDel else updateType
                 modifyMVar_ contextOptions $ \case
                     ( watch, clist )
                       | watch == Just WatchPeers || not tui
                       -> do
                         let ( clist', idx ) = ctxUpdate (1 :: Int) clist
                         when (Just shown /= op) $ do
-                            extPrintLn $ "[" <> show idx <> "] PEER " <> updateType' <> " " <> shown
+                            extPrintLn $ "[" <> withStyle contextIndexStyle (plainText $ T.pack $ show idx) <> "] PEER " <> updateType' <> " " <> plainText shown
                         return ( Just WatchPeers, clist' )
                     cur -> return cur
             _ -> return ()
@@ -490,7 +523,7 @@
                     | csQuit cstate' -> mzero
                     | otherwise      -> return cstate'
                 Left err -> do
-                    lift $ extPrintLn $ "Error: " ++ showErebosError err
+                    lift $ extPrintLn $ withStyle (setForegroundColor BrightRed noStyle) $ plainText $ T.pack $ "Error: " ++ showErebosError err
                     return cstate
 
     let loop (Just cstate) = runMaybeT (process cstate) >>= loop
@@ -501,15 +534,23 @@
         , csWatchChatrooms = watched
         , csQuit = False
         }
+    hidePrompt term
 
 
+contextIndexStyle :: TextStyle
+contextIndexStyle = setForegroundColor BrightCyan noStyle
+
+printSelectOption :: Int -> FormattedText -> CommandM ()
+printSelectOption i label = cmdPutStrLn $ "[" <> withStyle contextIndexStyle (plainText $ T.pack $ show i) <> "] " <> label
+
+
 data CommandInput = CommandInput
     { ciServer :: Server
     , ciTerminal :: Terminal
     , ciLine :: String
-    , ciPrint :: String -> IO ()
+    , ciPrint :: FormattedText -> IO ()
     , ciOptions :: Options
-    , ciPeers :: CommandM [(Peer, String)]
+    , ciPeers :: CommandM [ ( Peer, Text ) ]
     , ciContextOptions :: CommandM [ CommandContext ]
     , ciSetContextOptions :: ContextWatchOptions -> [ CommandContext ] -> Command
     , ciContextVar :: MVar CommandContext
@@ -577,7 +618,9 @@
 getSelectedConversation :: CommandM Conversation
 getSelectedConversation = gets csContext >>= getConversationFromContext
 
-getConversationFromContext :: CommandContext -> CommandM Conversation
+getConversationFromContext
+    :: (MonadIO m, MonadError ErebosError m, MonadHead LocalState m)
+    => CommandContext -> m Conversation
 getConversationFromContext = \case
     SelectedPeer peer -> getPeerIdentity peer >>= \case
         PeerIdentityFull pid -> directMessageConversation $ finalOwner pid
@@ -599,35 +642,57 @@
         str | all isDigit str -> getContextByIndex id (read str)
         _ -> throwOtherError "invalid index"
 
+updatePromptStatus :: Terminal -> Head LocalState -> Maybe Conversation -> IO ()
+updatePromptStatus term h current = do
+    conversations <- mapMaybe checkNew <$> flip runReaderT h lookupConversations
+    setPromptStatus term $ withStyle (setForegroundColor BrightYellow noStyle) $ formatStatus (length conversations) <> " "
+  where
+    checkNew conv
+        | (msg : _) <- conversationHistory conv
+        , messageUnread msg
+        , maybe True (not . isSameConversation conv) current
+        = Just ( conv, msg )
+    checkNew _ = Nothing
+
+    formatStatus 0 = withStyle (setForegroundColor BrightBlack noStyle) "--"
+    formatStatus 1 = withStyle (setForegroundColor BrightYellow noStyle) " *"
+    formatStatus n
+        | n < 10 = withStyle (setForegroundColor BrightYellow noStyle) $ plainText $ T.pack (show n) <> "*"
+        | otherwise = withStyle (setForegroundColor BrightYellow noStyle) $ plainText $ "X*"
+
+
 commands :: [(String, Command)]
 commands =
-    [ ("history", cmdHistory)
-    , ("identity", cmdIdentity)
-    , ("peers", cmdPeers)
-    , ("peer-add", cmdPeerAdd)
-    , ("peer-add-public", cmdPeerAddPublic)
-    , ("peer-drop", cmdPeerDrop)
-    , ("send", cmdSend)
-    , ("delete", cmdDelete)
-    , ("update-identity", cmdUpdateIdentity)
-    , ("attach", cmdAttach)
-    , ("attach-accept", cmdAttachAccept)
-    , ("attach-reject", cmdAttachReject)
-    , ("chatrooms", cmdChatrooms)
-    , ("chatroom-create-public", cmdChatroomCreatePublic)
-    , ("contacts", cmdContacts)
-    , ("contact-add", cmdContactAdd)
-    , ("contact-accept", cmdContactAccept)
-    , ("contact-reject", cmdContactReject)
-    , ("conversations", cmdConversations)
-    , ("details", cmdDetails)
-    , ("discovery", cmdDiscovery)
-    , ("join", cmdJoin)
-    , ("join-as", cmdJoinAs)
-    , ("leave", cmdLeave)
-    , ("members", cmdMembers)
-    , ("select", cmdSelectContext)
-    , ("quit", cmdQuit)
+    [ ( "history", cmdHistory )
+    , ( "identity", cmdIdentity )
+    , ( "peers", cmdPeers )
+    , ( "peer-add", cmdPeerAdd )
+    , ( "peer-add-public", cmdPeerAddPublic )
+    , ( "peer-drop", cmdPeerDrop )
+    , ( "send", cmdSend )
+    , ( "delete", cmdDelete )
+    , ( "update-identity", cmdUpdateIdentity )
+    , ( "attach", cmdAttach )
+    , ( "attach-accept", cmdAttachAccept )
+    , ( "attach-reject", cmdAttachReject )
+    , ( "chatrooms", cmdChatrooms )
+    , ( "chatroom-create-public", cmdChatroomCreatePublic )
+    , ( "contacts", cmdContacts )
+    , ( "contact-add", cmdContactAdd )
+    , ( "contact-accept", cmdContactAccept )
+    , ( "contact-reject", cmdContactReject )
+    , ( "invite-contact", cmdInviteContact )
+    , ( "invite-accept", cmdInviteAccept )
+    , ( "conversations", cmdConversations )
+    , ( "new", cmdNew )
+    , ( "details", cmdDetails )
+    , ( "discovery", cmdDiscovery )
+    , ( "join", cmdJoin )
+    , ( "join-as", cmdJoinAs )
+    , ( "leave", cmdLeave )
+    , ( "members", cmdMembers )
+    , ( "select", cmdSelectContext )
+    , ( "quit", cmdQuit )
     ]
 
 commandCompletion :: CompletionFunc IO
@@ -638,13 +703,13 @@
     sortedCommandNames = sort $ map fst commands
 
 
-cmdPutStrLn :: String -> Command
+cmdPutStrLn :: FormattedText -> Command
 cmdPutStrLn str = do
     term <- asks ciTerminal
     void $ liftIO $ printLine term str
 
 cmdUnknown :: String -> Command
-cmdUnknown cmd = cmdPutStrLn $ "Unknown command: " ++ cmd
+cmdUnknown cmd = cmdPutStrLn $ withStyle (setForegroundColor BrightRed noStyle) $ plainText $ "Unknown command: ‘" <> T.pack cmd <> "’"
 
 cmdPeers :: Command
 cmdPeers = do
@@ -652,7 +717,7 @@
     set <- asks ciSetContextOptions
     set WatchPeers $ map (SelectedPeer . fst) peers
     forM_ (zip [1..] peers) $ \(i :: Int, (_, name)) -> do
-        cmdPutStrLn $ "[" ++ show i ++ "] " ++ name
+        printSelectOption i $ plainText name
 
 cmdPeerAdd :: Command
 cmdPeerAdd = void $ do
@@ -690,13 +755,13 @@
     dropPeer =<< getSelectedPeer
     modify $ \s -> s { csContext = NoContext }
 
-showPeer :: PeerIdentity -> PeerAddress -> String
+showPeer :: PeerIdentity -> PeerAddress -> Text
 showPeer pidentity paddr =
     let name = case pidentity of
                     PeerIdentityUnknown _  -> "<noid>"
-                    PeerIdentityRef wref _ -> "<" ++ BC.unpack (showRefDigest $ wrDigest wref) ++ ">"
-                    PeerIdentityFull pid   -> T.unpack $ displayIdentity pid
-     in name ++ " [" ++ show paddr ++ "]"
+                    PeerIdentityRef wref _ -> "<" <> T.decodeUtf8 (showRefDigest $ wrDigest wref) <> ">"
+                    PeerIdentityFull pid   -> displayIdentity pid
+     in name <> " [" <> T.pack (show paddr) <> "]"
 
 cmdJoin :: Command
 cmdJoin = joinChatroom =<< getSelectedChatroom
@@ -714,7 +779,7 @@
 cmdMembers = do
     Just room <- findChatroomByStateData . head . roomStateData =<< getSelectedChatroom
     forM_ (chatroomMembers room) $ \x -> do
-        cmdPutStrLn $ maybe "<unnamed>" T.unpack $ idName x
+        cmdPutStrLn $ plainText $ fromMaybe "<unnamed>" $ idName x
 
 getContextByIndex :: (Maybe ContextWatchOptions -> Maybe ContextWatchOptions) -> Int -> CommandM CommandContext
 getContextByIndex f n = do
@@ -737,6 +802,16 @@
                 chatroomSetSubscribe (head $ roomStateData rstate) True
         _ -> return ()
 
+    term <- asks ciTerminal
+    h <- gets csHead
+    (runExceptT $ flip runReaderT h $ getConversationFromContext ctx) >>= \case
+        Right conv -> do
+            liftIO $ updatePromptStatus term h (Just conv)
+            tzone <- liftIO $ getCurrentTimeZone
+            mapM_ (cmdPutStrLn . formatMessageFT tzone) $ takeWhile messageUnread $ conversationHistory conv
+        Left _ -> do
+            liftIO $ updatePromptStatus term h Nothing
+
 cmdSend :: Command
 cmdSend = void $ do
     text <- asks ciLine
@@ -754,9 +829,9 @@
     case conversationHistory conv of
         thread@(_:_) -> do
             tzone <- liftIO $ getCurrentTimeZone
-            mapM_ (cmdPutStrLn . formatMessage tzone) $ reverse $ take 50 thread
+            mapM_ (cmdPutStrLn . formatMessageFT tzone) $ reverse $ take 50 thread
         [] -> do
-            cmdPutStrLn $ "<empty history>"
+            cmdPutStrLn $ withStyle (setForegroundColor BrightBlack noStyle) $ plainText "(empty history)"
 
 showIdentityDetails :: Foldable f => Identity f -> Text
 showIdentityDetails identity = T.unlines $ go $ reverse $ unfoldOwners identity
@@ -774,7 +849,7 @@
 
 cmdIdentity :: Command
 cmdIdentity = do
-    cmdPutStrLn . T.unpack . showIdentityDetails . localIdentity . fromStored =<< getLocalHead
+    cmdPutStrLn . plainText . showIdentityDetails . localIdentity . fromStored =<< getLocalHead
 
 cmdUpdateIdentity :: Command
 cmdUpdateIdentity = void $ do
@@ -791,7 +866,7 @@
 cmdAttachReject = attachReject =<< getSelectedPeer
 
 watchChatroomsForCli
-    :: Bool -> (String -> IO ()) -> Head LocalState -> MVar (Set ChatroomState)
+    :: Bool -> (FormattedText -> IO ()) -> Head LocalState -> MVar (Set ChatroomState)
     -> MVar CommandContext -> MVar ( Maybe ContextWatchOptions, [ CommandContext ] )
     -> Maybe Int -> IO WatchedHead
 watchChatroomsForCli tui eprint h chatroomSetVar contextVar contextOptsVar autoSubscribe = do
@@ -802,14 +877,14 @@
                 | currentRoots <- filterAncestors (concatMap storedRoots $ roomStateData rstate)
                 , any ((`intersectsSorted` currentRoots) . storedRoots) $ roomStateData rstate'
                 -> do
-                    eprint $ "[" <> show idx <> "] CHATROOM " <> updateType <> " " <> name
+                    eprint $ plainText $ T.pack $ "[" <> show idx <> "] CHATROOM " <> updateType <> " " <> name
                     return (SelectedChatroom rstate : rest)
             selected : rest
                 -> do
                     (selected : ) <$> ctxUpdate updateType (idx + 1) rstate rest
             []
                 -> do
-                    eprint $ "[" <> show idx <> "] CHATROOM " <> updateType <> " " <> name
+                    eprint $ plainText $ T.pack $ "[" <> show idx <> "] CHATROOM " <> updateType <> " " <> name
                     return [ SelectedChatroom rstate ]
           where
             name = maybe "<unnamed>" T.unpack $ roomName =<< roomStateRoom rstate
@@ -829,7 +904,7 @@
                     forM_ (take (num - subscribedNum) notSubscribed) $ \rstate -> do
                         (runExceptT $ flip runReaderT h $ chatroomSetSubscribe (head $ roomStateData rstate) True) >>= \case
                              Right () -> return ()
-                             Left err -> eprint (showErebosError err)
+                             Left err -> eprint $ plainText $ T.pack $ showErebosError err
 
         Just diff -> do
             modifyMVar_ chatroomSetVar $ return . const set
@@ -865,11 +940,11 @@
                             when (not tui || isSelected) $ do
                                 tzone <- getCurrentTimeZone
                                 forM_ (reverse $ getMessagesSinceState rstate oldroom) $ \msg -> do
-                                    eprint $ concat $
-                                        [ formatTime defaultTimeLocale "[%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ cmsgTime msg
-                                        , maybe "<unnamed>" T.unpack $ idName $ cmsgFrom msg
+                                    eprint $ plainText $ T.concat
+                                        [ T.pack $ formatTime defaultTimeLocale "[%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ cmsgTime msg
+                                        , fromMaybe "<unnamed>" $ idName $ cmsgFrom msg
                                         , if cmsgLeave msg then " left" else ""
-                                        , maybe (if cmsgLeave msg then "" else " joined") ((": " ++) . T.unpack) $ cmsgText msg
+                                        , maybe (if cmsgLeave msg then "" else " joined") ((": " <>)) $ cmsgText msg
                                         ]
                     modifyMVar_ subscribedNumVar $ return
                         . (if roomStateSubscribe rstate then (+ 1) else id)
@@ -898,7 +973,7 @@
     set <- asks ciSetContextOptions
     set WatchChatrooms $ map SelectedChatroom chatroomList
     forM_ (zip [1..] chatroomList) $ \(i :: Int, rstate) -> do
-        cmdPutStrLn $ "[" ++ show i ++ "] " ++ maybe "<unnamed>" T.unpack (roomName =<< roomStateRoom rstate)
+        printSelectOption i $ plainText $ fromMaybe "<unnamed>" (roomName =<< roomStateRoom rstate)
 
 cmdChatroomCreatePublic :: Command
 cmdChatroomCreatePublic = do
@@ -926,8 +1001,8 @@
     set <- asks ciSetContextOptions
     set WatchContacts $ map SelectedContact contacts
     forM_ (zip [1..] contacts) $ \(i :: Int, c) -> do
-        cmdPutStrLn $ T.unpack $ T.concat
-            [ "[", T.pack (show i), "] ", contactName c
+        printSelectOption i $ plainText $ T.concat
+            [ contactName c
             , case contactIdentity c of
                    Just idt | cname <- displayIdentity idt
                             , cname /= contactName c
@@ -946,36 +1021,90 @@
 cmdContactReject :: Command
 cmdContactReject = contactReject =<< getSelectedPeer
 
+cmdInviteContact :: Command
+cmdInviteContact = do
+    term <- asks ciTerminal
+    name <- asks ciLine >>= \case
+        line | not (null line) -> return $ T.pack line
+        _ -> liftIO $ do
+            setPrompt term "Name: "
+            getInputLine term $ KeepPrompt . maybe T.empty T.pack
+    (lookupSharedValue . lsShared . fromStored <$> getLocalHead) >>= \case
+        Just (self :: ComposedIdentity) -> do
+            invite <- createSingleContactInvite name
+            dgst : _ <- return $ refDigest . storedRef <$> idDataF self
+            cmdPutStrLn $ plainText $ "https://app.erebosprotocol.net/#inv" <> (maybe "" (("=" <>) . textInviteToken) (inviteToken invite)) <> "&from=blake2%23" <> T.pack (drop 7 (show dgst))
+        Nothing -> do
+            throwOtherError "no shared identity"
+
+cmdInviteAccept :: Command
+cmdInviteAccept = do
+    term <- asks ciTerminal
+    url <- asks ciLine >>= \case
+        line | not (null line) -> return $ T.pack line
+        _ -> liftIO $ do
+            setPrompt term "URL: "
+            getInputLine term $ KeepPrompt . maybe T.empty T.pack
+    case T.breakOn "://" url of
+        ( proto, url' )
+            | proto `elem` [ "http", "https" ]
+            , ( _, url'' ) <- T.breakOn "#" url'
+            , Just ( '#', params ) <- T.uncons url''
+            , [ pfrom, pinv ] <- sort $ T.splitOn "&" params
+            , ( nfrom, tfrom ) <- T.splitAt 14 pfrom, nfrom == "from=blake2%23"
+            , ( ninv, tinv ) <- T.splitAt 4 pinv, ninv == "inv="
+            , Just from <- readRefDigest $ T.encodeUtf8 $ "blake2#" <> tfrom
+            , Just token <- parseInviteToken tinv
+            -> do
+                acceptInvite from token
+        _ -> throwOtherError "invalit invite URL"
+
 cmdConversations :: Command
 cmdConversations = do
     conversations <- lookupConversations
     set <- asks ciSetContextOptions
     set WatchConversations $ map SelectedConversation conversations
     forM_ (zip [1..] conversations) $ \(i :: Int, conv) -> do
-        cmdPutStrLn $ "[" ++ show i ++ "] " ++ T.unpack (conversationName conv)
+        printSelectOption i $ plainText $ conversationName conv
 
+cmdNew :: Command
+cmdNew = do
+    conversations <- mapMaybe checkNew <$> lookupConversations
+    set <- asks ciSetContextOptions
+    set WatchConversations $ map (SelectedConversation . fst) conversations
+    tzone <- liftIO $ getCurrentTimeZone
+    forM_ (zip [1..] conversations) $ \(i :: Int, ( conv, msg )) -> do
+        printSelectOption i $ plainText (conversationName conv <> " ") <> formatMessageFT tzone msg
+  where
+    checkNew conv
+        | (msg : _) <- conversationHistory conv
+        , messageUnread msg
+        = Just ( conv, msg )
+    checkNew _ = Nothing
+
+
 cmdDetails :: Command
 cmdDetails = do
     getSelectedOrManualContext >>= \case
         SelectedPeer peer -> do
             paddr <- getPeerAddress peer
-            cmdPutStrLn $ unlines
+            cmdPutStrLn $ plainText $ T.unlines
                 [ "Network peer:"
-                , "  " <> show paddr
+                , "  " <> T.pack (show paddr)
                 ]
             getPeerIdentity peer >>= \case
                 PeerIdentityUnknown _ -> do
                     cmdPutStrLn $ "unknown identity"
                 PeerIdentityRef wref _ -> do
                     cmdPutStrLn $ "Identity ref:"
-                    cmdPutStrLn $ "  " <> BC.unpack (showRefDigest $ wrDigest wref)
+                    cmdPutStrLn $ plainText $ "  " <> T.decodeUtf8 (showRefDigest $ wrDigest wref)
                 PeerIdentityFull pid -> printContactOrIdentityDetails pid
 
         SelectedContact contact -> do
             printContactDetails contact
 
         SelectedChatroom rstate -> do
-            cmdPutStrLn $ "Chatroom: " <> (T.unpack $ fromMaybe (T.pack "<unnamed>") $ roomName =<< roomStateRoom rstate)
+            cmdPutStrLn $ plainText $ "Chatroom: " <> (fromMaybe "<unnamed>" $ roomName =<< roomStateRoom rstate)
 
         SelectedConversation conv -> do
             case conversationPeer conv of
@@ -994,7 +1123,7 @@
         cmdPutStrLn $ "Contact:"
         prefix <- case contactCustomName contact of
             Just name -> do
-                cmdPutStrLn $ "  " <> T.unpack name
+                cmdPutStrLn $ plainText $ "  " <> name
                 return $ Just "alias of"
             Nothing -> do
                 return $ Nothing
@@ -1011,11 +1140,11 @@
 
     printIdentityDetailsBody prefix identity = do
         forM_ (zip (False : repeat True) $ unfoldOwners identity) $ \(owned, cpid) -> do
-            cmdPutStrLn $ unwords $ concat
+            cmdPutStrLn $ plainText $ T.unwords $ concat
                 [ [ "  " ]
                 , if owned then [ "owned by" ] else maybeToList prefix
-                , [ maybe "<unnamed>" T.unpack (idName cpid) ]
-                , map (BC.unpack . showRefDigest . refDigest . storedRef) $ idExtDataF cpid
+                , [ fromMaybe "<unnamed>" (idName cpid) ]
+                , map (T.decodeUtf8 . showRefDigest . refDigest . storedRef) $ idExtDataF cpid
                 ]
 
 cmdDiscovery :: Command
diff --git a/main/State.hs b/main/State.hs
--- a/main/State.hs
+++ b/main/State.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 module State (
     loadLocalStateHead,
     createLocalStateHead,
@@ -20,6 +22,7 @@
 import Erebos.State
 import Erebos.Storable
 import Erebos.Storage
+import Erebos.TextFormat
 
 import Terminal
 
@@ -96,12 +99,12 @@
 interactiveIdentityUpdate term fidentity = do
     identity <- mergeIdentity fidentity
     name <- liftIO $ do
-        setPrompt term $ T.unpack $ T.concat $ concat
-            [ [ T.pack "Name" ]
+        setPrompt term $ mconcat $ concat
+            [ [ "Name" ]
             , case idName identity of
-                   Just name -> [T.pack " [", name, T.pack "]"]
-                   Nothing -> []
-            , [ T.pack ": " ]
+                  Just name -> [ " [", plainText name, "]" ]
+                  Nothing -> []
+            , [ ": " ]
             ]
         getInputLine term $ KeepPrompt . maybe T.empty T.pack
 
diff --git a/main/Terminal.hs b/main/Terminal.hs
--- a/main/Terminal.hs
+++ b/main/Terminal.hs
@@ -1,10 +1,13 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module Terminal (
     Terminal,
     hasTerminalUI,
     withTerminal,
     setPrompt,
+    setPromptStatus,
+    showPrompt, hidePrompt,
     getInputLine,
     InputHandling(..),
 
@@ -30,17 +33,22 @@
 import Data.List
 import Data.Text (Text)
 import Data.Text qualified as T
+import Data.Text.IO qualified as T
 
 import System.Console.ANSI
 import System.IO
 import System.IO.Error
 
+import Erebos.TextFormat
+import Erebos.TextFormat.Ansi
 
+
 data Terminal = Terminal
     { termLock :: MVar ()
     , termAnsi :: Bool
     , termCompletionFunc :: CompletionFunc IO
-    , termPrompt :: TVar String
+    , termPrompt :: TVar FormattedText
+    , termPromptStatus :: TVar FormattedText
     , termShowPrompt :: TVar Bool
     , termInput :: TVar ( String, String )
     , termBottomLines :: TVar [ String ]
@@ -87,6 +95,7 @@
     termAnsi <- hSupportsANSI stdout
 #endif
     termPrompt <- newTVarIO ""
+    termPromptStatus <- newTVarIO ""
     termShowPrompt <- newTVarIO False
     termInput <- newTVarIO ( "", "" )
     termBottomLines <- newTVarIO []
@@ -108,11 +117,8 @@
             act term
 
 
-termPutStr :: Terminal -> String -> IO ()
-termPutStr Terminal {..} str = do
-    withMVar termLock $ \_ -> do
-        putStr str
-        hFlush stdout
+putAnsi :: AnsiText -> IO ()
+putAnsi = T.putStr . fromAnsiText
 
 
 getInput :: IO Input
@@ -149,15 +155,6 @@
 
 getInputLine :: Terminal -> (Maybe String -> InputHandling a) -> IO a
 getInputLine term@Terminal {..} handleResult = do
-    when termAnsi $ do
-        withMVar termLock $ \_ -> do
-            prompt <- atomically $ do
-                writeTVar termShowPrompt True
-                readTVar termPrompt
-            putStr $ prompt <> "\ESC[K"
-            drawBottomLines term
-            hFlush stdout
-
     mbLine <- go
     forM_ mbLine $ \line -> do
         let addLine xs
@@ -168,15 +165,16 @@
             writeTVar termHistory . addLine =<< readTVar termHistory
             writeTVar termHistoryPos 0
 
-    case handleResult mbLine of
-        KeepPrompt x -> do
-            when termAnsi $ do
-                termPutStr term "\n\ESC[J"
-            return x
-        ErasePrompt x -> do
-            when termAnsi $ do
-                termPutStr term "\r\ESC[J"
-            return x
+    ( x, clear ) <- case handleResult mbLine of
+        KeepPrompt x -> return ( x, \statusLen -> AnsiText $ "\ESC[" <> T.pack (show statusLen) <> "G\ESC[1K\n\ESC[J" )
+        ErasePrompt x -> return ( x, \_ -> AnsiText "\r\ESC[J" )
+    when termAnsi $ do
+        withMVar termLock $ \_ -> do
+            status <- atomically $ readTVar termPromptStatus
+            prompt <- atomically $ getCurrentPromptLine term
+            putAnsi $ clear (formattedTextLength status) <> prompt
+    return x
+
   where
     go = getInput >>= \case
         InputChar '\n' -> do
@@ -184,7 +182,6 @@
                 ( pre, post ) <- readTVar termInput
                 writeTVar termInput ( "", "" )
                 when termAnsi $ do
-                    writeTVar termShowPrompt False
                     writeTVar termBottomLines []
                 return $ Just $ pre ++ post
 
@@ -195,7 +192,7 @@
                         prompt <- atomically $ do
                             writeTVar termInput ( pre', post )
                             getCurrentPromptLine term
-                        putStr $ "\r" <> prompt
+                        putAnsi $ "\r" <> prompt
                         hFlush stdout
 
                 termCompletionFunc ( T.pack pre, T.pack post ) >>= \case
@@ -222,7 +219,7 @@
         InputChar c | isPrint c -> withInput $ \case
             ( _, post ) -> do
                 writeTVar termInput . first (++ [ c ]) =<< readTVar termInput
-                return $ c : (if null post then "" else "\ESC[s" <> post <> "\ESC[u")
+                return $ AnsiText $ T.pack $ c : (if null post then "" else "\ESC[s" <> post <> "\ESC[u")
 
         InputChar _ -> go
 
@@ -272,7 +269,7 @@
         InputBackspace -> withInput $ \case
             ( pre@(_ : _), post ) -> do
                 writeTVar termInput ( init pre, post )
-                return $ "\b\ESC[K" <> (if null post then "" else "\ESC[s" <> post <> "\ESC[u")
+                return $ AnsiText $ "\b\ESC[K" <> (if null post then "" else "\ESC[s" <> T.pack post <> "\ESC[u")
             _ -> return ""
 
         InputClear -> withInput $ \_ -> do
@@ -286,11 +283,11 @@
 
         InputMoveStart -> withInput $ \( pre, post ) -> do
             writeTVar termInput ( "", pre <> post )
-            return $ "\ESC[" <> show (length pre) <> "D"
+            return $ AnsiText $ T.pack $ "\ESC[" <> show (length pre) <> "D"
 
         InputMoveEnd -> withInput $ \( pre, post ) -> do
             writeTVar termInput ( pre <> post, "" )
-            return $ "\ESC[" <> show (length post) <> "C"
+            return $ AnsiText $ T.pack $ "\ESC[" <> show (length post) <> "C"
 
         InputEnd -> do
             atomically (readTVar termInput) >>= \case
@@ -299,22 +296,37 @@
 
         InputEscape _ -> go
 
+    withInput :: (( String, String ) -> STM AnsiText) -> IO (Maybe String)
     withInput f = do
         withMVar termLock $ const $ do
             str <- atomically $ f =<< readTVar termInput
-            when (termAnsi && not (null str)) $ do
-                putStr str
+            when (termAnsi && not (T.null $ fromAnsiText str)) $ do
+                putAnsi str
                 hFlush stdout
         go
 
 
-getCurrentPromptLine :: Terminal -> STM String
+getCurrentPromptLine :: Terminal -> STM AnsiText
 getCurrentPromptLine Terminal {..} = do
-    prompt <- readTVar termPrompt
+    sp <- readTVar termShowPrompt
+    prompt <- if sp then readTVar termPrompt else return ""
+    status <- if sp then readTVar termPromptStatus else return ""
     ( pre, post ) <- readTVar termInput
-    return $ prompt <> pre <> "\ESC[s" <> post <> "\ESC[u"
+    return $ mconcat
+        [ renderAnsiText status
+        , renderAnsiText prompt
+        , AnsiText (T.pack pre), "\ESC[s"
+        , AnsiText (T.pack post), "\ESC[u"
+        ]
 
-setPrompt :: Terminal -> String -> IO ()
+redrawPrompt :: Terminal -> STM (IO ())
+redrawPrompt term = do
+    promptLine <- getCurrentPromptLine term
+    return $ do
+        putAnsi $ "\r\ESC[K" <> promptLine
+        hFlush stdout
+
+setPrompt :: Terminal -> FormattedText -> IO ()
 setPrompt Terminal { termAnsi = False } _ = do
     return ()
 setPrompt term@Terminal {..} prompt = do
@@ -322,28 +334,61 @@
         join $ atomically $ do
             writeTVar termPrompt prompt
             readTVar termShowPrompt >>= \case
+                True -> redrawPrompt term
+                False -> return $ return ()
+
+setPromptStatus :: Terminal -> FormattedText -> IO ()
+setPromptStatus Terminal { termAnsi = False } _ = do
+    return ()
+setPromptStatus term@Terminal {..} prompt = do
+    withMVar termLock $ \_ -> do
+        join $ atomically $ do
+            writeTVar termPromptStatus prompt
+            readTVar termShowPrompt >>= \case
+                True -> redrawPrompt term
+                False -> return $ return ()
+
+showPrompt :: Terminal -> IO ()
+showPrompt Terminal { termAnsi = False } = do
+    return ()
+showPrompt term@Terminal {..} = do
+    withMVar termLock $ \_ -> do
+        join $ atomically $ do
+            readTVar termShowPrompt >>= \case
+                False -> do
+                    writeTVar termShowPrompt True
+                    redrawPrompt term
+                True -> return $ return ()
+
+hidePrompt :: Terminal -> IO ()
+hidePrompt Terminal { termAnsi = False } = do
+    return ()
+hidePrompt term@Terminal {..} = do
+    withMVar termLock $ \_ -> do
+        join $ atomically $ do
+            readTVar termShowPrompt >>= \case
                 True -> do
-                    promptLine <- getCurrentPromptLine term
-                    return $ do
-                        putStr $ "\r\ESC[K" <> promptLine
-                        hFlush stdout
+                    writeTVar termShowPrompt False
+                    redrawPrompt term
                 False -> return $ return ()
 
-printLine :: Terminal -> String -> IO TerminalLine
+printLine :: Terminal -> FormattedText -> IO TerminalLine
 printLine tlTerminal@Terminal {..} str = do
     withMVar termLock $ \_ -> do
-        let strLines = lines str
-            tlLineCount = length strLines
+        let tlLineCount = formattedTextHeight str
         if termAnsi
           then do
             promptLine <- atomically $ do
                 readTVar termShowPrompt >>= \case
                     True -> getCurrentPromptLine tlTerminal
                     False -> return ""
-            putStr $ "\r\ESC[K" <> unlines strLines <> "\ESC[K" <> promptLine
+            putAnsi $ mconcat
+                [ AnsiText "\r\ESC[K", renderAnsiText $ endWithNewline str
+                , AnsiText "\ESC[K", promptLine
+                ]
             drawBottomLines tlTerminal
           else do
-            putStr $ unlines strLines
+            T.putStr $ renderPlainText $ endWithNewline str
 
         hFlush stdout
         return TerminalLine {..}
@@ -381,8 +426,9 @@
                 readTVar termShowPrompt >>= \case
                     True -> do
                         prompt <- readTVar termPrompt
+                        status <- readTVar termPromptStatus
                         ( pre, _ ) <- readTVar termInput
-                        return (displayWidth (prompt <> pre) + 1)
+                        return (formattedTextLength status + formattedTextLength prompt + length pre + 1)
                     False -> do
                         return 0
             putStr $ concat
@@ -391,14 +437,6 @@
                 , "\ESC[", show shift, "G"
                 ]
         [] -> return ()
-
-
-displayWidth :: String -> Int
-displayWidth = \case
-    ('\ESC' : '[' : rest) -> displayWidth $ drop 1 $ dropWhile (not . isAlpha) rest
-    ('\ESC' : _ : rest) -> displayWidth rest
-    (_ : rest) -> 1 + displayWidth rest
-    [] -> 0
 
 
 type CompletionFunc m = ( Text, Text ) -> m ( Text, [ Completion ] )
diff --git a/main/Test.hs b/main/Test.hs
--- a/main/Test.hs
+++ b/main/Test.hs
@@ -39,8 +39,10 @@
 import Erebos.DirectMessage
 import Erebos.Discovery
 import Erebos.Identity
+import Erebos.Invite
 import Erebos.Network
 import Erebos.Object
+import Erebos.Object.Deferred
 import Erebos.Pairing
 import Erebos.PubKey
 import Erebos.Service
@@ -69,6 +71,7 @@
     { rsServer :: Server
     , rsPeers :: MVar ( Int, [ TestPeer ] )
     , rsPeerThread :: ThreadId
+    , rsDeferredObjects :: MVar [ Deferred Object ]
     }
 
 data TestPeer = TestPeer
@@ -117,9 +120,9 @@
 getLineMb :: MonadIO m => m (Maybe Text)
 getLineMb = liftIO $ catchIOError (Just <$> T.getLine) (\e -> if isEOFError e then return Nothing else ioError e)
 
-getLines :: MonadIO m => m [Text]
-getLines = getLineMb >>= \case
-    Just line | not (T.null line) -> (line:) <$> getLines
+getLines :: MonadIO m => Text -> m [ Text ]
+getLines eof = getLineMb >>= \case
+    Just line | line /= eof -> (line :) <$> getLines eof
     _ -> return []
 
 getHead :: CommandM (Head LocalState)
@@ -232,14 +235,26 @@
     { discoveryProvideTunnel = \_ _ -> False
     }
 
+inviteAttributes :: Output -> InviteServiceAttributes
+inviteAttributes out = (defaultServiceAttributes Proxy)
+    { inviteHookAccepted = \Invite {..} -> do
+        pid <- asks svcPeerIdentity
+        afterCommit $ outLine out $ "invite-accepted " <> maybe "<missing-token>" showInviteToken inviteToken <> " " <> (BC.unpack $ showRef $ storedRef $ idExtData pid)
+    , inviteHookReplyContact = \token _ -> do
+        afterCommit $ outLine out $ "invite-reply " <> showInviteToken token <> " contact"
+    , inviteHookReplyInvalid = \token -> do
+        afterCommit $ outLine out $ "invite-reply " <> showInviteToken token <> " invalid"
+    }
+
 dmThreadWatcher :: ComposedIdentity -> Output -> DirectMessageThread -> DirectMessageThread -> IO ()
 dmThreadWatcher self out prev cur = do
-    forM_ (reverse $ dmThreadToListSince prev cur) $ \msg -> do
+    forM_ (reverse $ dmThreadToListSinceUnread prev cur) $ \( msg, new ) -> do
         outLine out $ unwords
             [ if sameIdentity self (msgFrom msg)
                  then "dm-sent"
                  else "dm-received"
             , "from", maybe "<unnamed>" T.unpack $ idName $ msgFrom msg
+            , "new", if new then "yes" else "no"
             , "text", T.unpack $ msgText msg
             ]
 
@@ -268,7 +283,10 @@
 commands :: [ ( Text, Command ) ]
 commands =
     [ ( "store", cmdStore )
+    , ( "store-raw", cmdStoreRaw )
     , ( "load", cmdLoad )
+    , ( "load-type", cmdLoadType )
+    , ( "load-deferred", cmdLoadDeferred )
     , ( "stored-generation", cmdStoredGeneration )
     , ( "stored-roots", cmdStoredRoots )
     , ( "stored-set-add", cmdStoredSetAdd )
@@ -311,6 +329,8 @@
     , ( "dm-send-identity", cmdDmSendIdentity )
     , ( "dm-list-peer", cmdDmListPeer )
     , ( "dm-list-contact", cmdDmListContact )
+    , ( "dm-list-identity", cmdDmListIdentity )
+    , ( "dm-mark-seen", cmdDmMarkSeen )
     , ( "chatroom-create", cmdChatroomCreate )
     , ( "chatroom-delete", cmdChatroomDelete )
     , ( "chatroom-list-local", cmdChatroomListLocal )
@@ -325,6 +345,8 @@
     , ( "chatroom-message-send", cmdChatroomMessageSend )
     , ( "discovery-connect", cmdDiscoveryConnect )
     , ( "discovery-tunnel", cmdDiscoveryTunnel )
+    , ( "invite-contact-create", cmdInviteContactCreate )
+    , ( "invite-accept", cmdInviteAccept )
     ]
 
 cmdStore :: Command
@@ -332,7 +354,7 @@
     st <- asks tiStorage
     pst <- liftIO $ derivePartialStorage st
     [otype] <- asks tiParams
-    ls <- getLines
+    ls <- getLines T.empty
 
     let cnt = encodeUtf8 $ T.unlines ls
         full = BL.fromChunks
@@ -345,6 +367,18 @@
         Right ref -> cmdOut $ "store-done " ++ show (refDigest ref)
         Left _ -> cmdOut $ "store-failed"
 
+cmdStoreRaw :: Command
+cmdStoreRaw = do
+    st <- asks tiStorage
+    pst <- liftIO $ derivePartialStorage st
+    [ eof ] <- asks tiParams
+    ls <- getLines eof
+
+    let full = BL.fromStrict $ BC.init $ encodeUtf8 $ T.unlines ls
+    liftIO (copyRef st =<< storeRawBytes pst full) >>= \case
+        Right ref -> cmdOut $ "store-done " ++ show (refDigest ref)
+        Left _ -> cmdOut $ "store-failed"
+
 cmdLoad :: Command
 cmdLoad = do
     st <- asks tiStorage
@@ -357,6 +391,40 @@
         cmdOut $ "load-line " <> T.unpack (decodeUtf8 $ BL.toStrict line)
     cmdOut "load-done"
 
+cmdLoadType :: Command
+cmdLoadType = do
+    st <- asks tiStorage
+    [ tref ] <- asks tiParams
+    liftIO (readRef st $ encodeUtf8 tref) >>= \case
+        Just ref -> do
+            let obj = load @Object ref
+            let otype = case obj of
+                    Blob {} -> "blob"
+                    Rec {} -> "rec"
+                    OnDemand {} -> "ondemand"
+                    ZeroObject {} -> "zero"
+                    UnknownObject utype _ -> "unknown " <> decodeUtf8 utype
+            cmdOut $ "load-type " <> T.unpack otype
+        Nothing -> do
+            cmdOut $ "load-type-failed"
+
+cmdLoadDeferred :: Command
+cmdLoadDeferred = do
+    st <- asks tiStorage
+    [ tidx ] <- asks tiParams
+    Just RunningServer {..} <- gets tsServer
+    deferred <- (!! read (T.unpack tidx)) <$> liftIO (readMVar rsDeferredObjects)
+    out <- asks tiOutput
+    liftIO $ void $ forkIO $ deferredWait deferred >>= \case
+        DeferredLoaded sobj -> do
+            void $ copyRef st $ storedRef sobj
+            header : _ <- return $ BL.lines $ serializeObject $ fromStored sobj
+            outLine out $ T.unpack $ T.unwords [ "load-deferred-done", tidx, decodeUtf8 $ BL.toStrict header ]
+        DeferredInvalid -> do
+            outLine out $ T.unpack $ T.unwords [ "load-deferred-invalid", tidx ]
+        DeferredFailed -> do
+            outLine out $ T.unpack $ T.unwords [ "load-deferred-failed", tidx ]
+
 cmdStoredGeneration :: Command
 cmdStoredGeneration = do
     st <- asks tiStorage
@@ -536,6 +604,7 @@
 
     h <- getOrLoadHead
     rsPeers <- liftIO $ newMVar (1, [])
+    rsDeferredObjects <- liftIO $ newMVar []
     services <- forM serviceNames $ \case
         ( "attach", _ ) -> return $ someServiceAttr $ pairingAttributes (Proxy @AttachService) out rsPeers "attach"
         ( "chatroom", _ ) -> return $ someService @ChatroomService Proxy
@@ -544,6 +613,7 @@
             { discoveryProvideTunnel = \_ _ -> "tunnel" `elem` params
             }
         ( "dm", _ ) -> return $ someServiceAttr $ directMessageAttributes out
+        ( "invite", _ ) -> return $ someServiceAttr $ inviteAttributes out
         ( "sync", _ ) -> return $ someService @SyncService Proxy
         ( "test", _ ) -> return $ someServiceAttr $ (defaultServiceAttributes Proxy)
             { testMessageReceived = \obj otype len sref -> do
@@ -563,6 +633,10 @@
                                 StreamClosed seqNum -> do
                                     outLine out $ unwords [ "test-stream-closed-from", show pidx, show num, show seqNum ]
                         go
+            , testOnDemandReceived = \size deferred -> do
+                liftIO $ do
+                    idx <- modifyMVar rsDeferredObjects (\ds -> return ( ds ++ [ deferred ], length ds ))
+                    outLine out $ unwords [ "test-ondemand-received", show idx, show size, show $ deferredRef deferred ]
             }
         ( sname, _ ) -> throwOtherError $ "unknown service `" <> T.unpack sname <> "'"
 
@@ -869,8 +943,9 @@
     threads <- dmThreadList . lookupSharedValue . lsShared . headObject <$> getHead
     case find (sameIdentity peer . msgPeer) threads of
         Just thread -> do
-            forM_ (reverse $ dmThreadToList thread) $ \DirectMessage {..} -> cmdOut $ "dm-list-item"
+            forM_ (reverse $ dmThreadToListUnread thread) $ \( DirectMessage {..}, new ) -> cmdOut $ "dm-list-item"
                 <> " from " <> (maybe "<unnamed>" T.unpack $ idName msgFrom)
+                <> " new " <> (if new then "yes" else "no")
                 <> " text " <> (T.unpack msgText)
         Nothing -> return ()
     cmdOut "dm-list-done"
@@ -887,6 +962,23 @@
     Just to <- contactIdentity <$> getContact cid
     dmList to
 
+cmdDmListIdentity :: Command
+cmdDmListIdentity = do
+    st <- asks tiStorage
+    [ tid ] <- asks tiParams
+    Just ref <- liftIO $ readRef st $ encodeUtf8 tid
+    Just pid <- return $ validateExtendedIdentity $ wrappedLoad ref
+    dmList pid
+
+cmdDmMarkSeen :: Command
+cmdDmMarkSeen = do
+    st <- asks tiStorage
+    [ tid ] <- asks tiParams
+    Just ref <- liftIO $ readRef st $ encodeUtf8 tid
+    Just pid <- return $ validateExtendedIdentity $ wrappedLoad ref
+    dmMarkAsSeen pid
+    cmdOut $ unwords [ "dm-mark-seen-done", T.unpack tid ]
+
 cmdChatroomCreate :: Command
 cmdChatroomCreate = do
     [name] <- asks tiParams
@@ -1015,3 +1107,17 @@
     via <- getPeer tvia
     Just target <- return $ readRefDigest $ encodeUtf8 ttarget
     liftIO $ discoverySetupTunnel via target
+
+cmdInviteContactCreate :: Command
+cmdInviteContactCreate = do
+    [ name ] <- asks tiParams
+    Just token <- inviteToken <$> createSingleContactInvite name
+    cmdOut $ unwords [ "invite-contact-create-done", showInviteToken token ]
+
+cmdInviteAccept :: Command
+cmdInviteAccept = do
+    [ tokenText, idref ] <- asks tiParams
+    Just token <- return $ parseInviteToken tokenText
+    Just from <- return $ readRefDigest $ encodeUtf8 idref
+    acceptInvite from token
+    cmdOut $ unwords [ "invite-accept-done", showInviteToken token ]
diff --git a/main/Test/Service.hs b/main/Test/Service.hs
--- a/main/Test/Service.hs
+++ b/main/Test/Service.hs
@@ -9,9 +9,12 @@
 import Control.Monad.Reader
 
 import Data.ByteString.Lazy.Char8 qualified as BL
+import Data.Word
 
+import Erebos.Identity
 import Erebos.Network
 import Erebos.Object
+import Erebos.Object.Deferred
 import Erebos.Service
 import Erebos.Service.Stream
 import Erebos.Storable
@@ -21,6 +24,7 @@
 data TestMessageAttributes = TestMessageAttributes
     { testMessageReceived :: Object -> String -> String -> String -> ServiceHandler TestMessage ()
     , testStreamsReceived :: [ StreamReader ] -> ServiceHandler TestMessage ()
+    , testOnDemandReceived :: Word64 -> Deferred Object -> ServiceHandler TestMessage ()
     }
 
 instance Storable TestMessage where
@@ -34,6 +38,7 @@
     defaultServiceAttributes _ = TestMessageAttributes
         { testMessageReceived = \_ _ _ _ -> return ()
         , testStreamsReceived = \_ -> return ()
+        , testOnDemandReceived = \_ _ -> return ()
         }
 
     serviceHandler smsg = do
@@ -49,6 +54,14 @@
         when (not $ null streams) $ do
             cb <- asks $ testStreamsReceived . svcAttributes
             cb streams
+
+        case obj of
+            OnDemand size dgst -> do
+                cb <- asks $ testOnDemandReceived . svcAttributes
+                server <- asks svcServer
+                pid <- asks svcPeerIdentity
+                cb size =<< liftIO (deferLoadWithServer dgst (DeferredExactSize size) server [ refDigest $ storedRef $ idData pid ])
+            _ -> return ()
 
 
 openTestStreams :: Int -> ServiceHandler TestMessage [ StreamWriter ]
diff --git a/main/WebSocket.hs b/main/WebSocket.hs
--- a/main/WebSocket.hs
+++ b/main/WebSocket.hs
@@ -30,7 +30,9 @@
     sendBytesToAddress (WebSocketAddress _ conn) msg = do
         WS.sendDataMessage conn $ WS.Binary $ BL.fromStrict msg
     connectionToAddressClosed (WebSocketAddress _ conn) = do
-        WS.sendClose conn BL.empty
+        WS.sendClose conn BL.empty `catch` \e -> if
+            | Just WS.ConnectionClosed <- fromException e -> return ()
+            | otherwise -> throwIO e
 
 startWebsocketServer :: Server -> String -> Int -> (String -> IO ()) -> IO ()
 startWebsocketServer server addr port logd = do
@@ -40,7 +42,15 @@
             u <- newUnique
             let paddr = WebSocketAddress u conn
             void $ serverPeerCustom server paddr
-            handle (\(e :: SomeException) -> logd $ "WebSocket thread exception: " ++ show e) $ do
+
+            let handler e
+                    | Just WS.CloseRequest {} <- fromException e = do
+                        dropPeerAddress server $ CustomPeerAddress paddr
+                    | Just WS.ConnectionClosed <- fromException e = do
+                        dropPeerAddress server $ CustomPeerAddress paddr
+                    | otherwise = do
+                        logd $ "WebSocket thread exception: " ++ show e
+            handle handler $ do
                 WS.withPingThread conn 30 (return ()) $ do
                     forever $ do
                         WS.receiveDataMessage conn >>= \case
diff --git a/src/Erebos/Chatroom.hs b/src/Erebos/Chatroom.hs
--- a/src/Erebos/Chatroom.hs
+++ b/src/Erebos/Chatroom.hs
@@ -50,6 +50,7 @@
 import Data.Text (Text)
 import Data.Time
 
+import Erebos.Conversation.Class
 import Erebos.Identity
 import Erebos.PubKey
 import Erebos.Service
@@ -59,6 +60,17 @@
 import Erebos.Storage.Head
 import Erebos.Storage.Merge
 import Erebos.Util
+
+
+instance ConversationType ChatroomState ChatMessage where
+    convMessageFrom = cmsgFrom
+    convMessageTime = cmsgTime
+    convMessageText = cmsgText
+
+    convReference = refDigest . storedRef . head . filterAncestors . concatMap storedRoots . roomStateData
+
+    convMessageListSince mbSince cstate =
+        map (, False) $ threadToListSince (maybe [] roomStateMessageData mbSince) (roomStateMessageData cstate)
 
 
 data ChatroomData = ChatroomData
diff --git a/src/Erebos/Contact.hs b/src/Erebos/Contact.hs
--- a/src/Erebos/Contact.hs
+++ b/src/Erebos/Contact.hs
@@ -4,6 +4,8 @@
     contactCustomName,
     contactName,
 
+    ContactData(..),
+
     contactSetName,
 
     ContactService,
diff --git a/src/Erebos/Conversation.hs b/src/Erebos/Conversation.hs
--- a/src/Erebos/Conversation.hs
+++ b/src/Erebos/Conversation.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 module Erebos.Conversation (
     Message,
     messageFrom,
@@ -5,6 +7,7 @@
     messageText,
     messageUnread,
     formatMessage,
+    formatMessageFT,
 
     Conversation,
     isSameConversation,
@@ -14,7 +17,9 @@
     isChatroomStateConversation,
     reloadConversation,
     lookupConversations,
+    lookupConversationByRef,
 
+    conversationReference,
     conversationName,
     conversationPeer,
     conversationHistory,
@@ -33,43 +38,52 @@
 import Data.Time.LocalTime
 
 import Erebos.Chatroom
+import Erebos.Conversation.Class
 import Erebos.DirectMessage
 import Erebos.Identity
 import Erebos.State
 import Erebos.Storable
+import Erebos.TextFormat
+import Erebos.TextFormat.Types
 
 
-data Message = DirectMessageMessage DirectMessage Bool
-             | ChatroomMessage ChatMessage Bool
+data Message = forall conv msg. ConversationType conv msg => Message msg Bool
 
+withMessage :: (forall conv msg. ConversationType conv msg => msg -> a) -> Message -> a
+withMessage f (Message msg _) = f msg
+
 messageFrom :: Message -> ComposedIdentity
-messageFrom (DirectMessageMessage msg _) = msgFrom msg
-messageFrom (ChatroomMessage msg _) = cmsgFrom msg
+messageFrom = withMessage convMessageFrom
 
 messageTime :: Message -> ZonedTime
-messageTime (DirectMessageMessage msg _) = msgTime msg
-messageTime (ChatroomMessage msg _) = cmsgTime msg
+messageTime = withMessage convMessageTime
 
 messageText :: Message -> Maybe Text
-messageText (DirectMessageMessage msg _) = Just $ msgText msg
-messageText (ChatroomMessage msg _) = cmsgText msg
+messageText = withMessage convMessageText
 
 messageUnread :: Message -> Bool
-messageUnread (DirectMessageMessage _ unread) = unread
-messageUnread (ChatroomMessage _ unread) = unread
+messageUnread (Message _ unread) = unread
 
 formatMessage :: TimeZone -> Message -> String
-formatMessage tzone msg = concat
-    [ formatTime defaultTimeLocale "[%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ messageTime msg
-    , maybe "<unnamed>" T.unpack $ idName $ messageFrom msg
-    , maybe "" ((": "<>) . T.unpack) $ messageText msg
-    ]
+formatMessage tzone = T.unpack . renderPlainText . formatMessageFT tzone
 
+formatMessageFT :: TimeZone -> Message -> FormattedText
+formatMessageFT tzone msg =
+    (if messageUnread msg then FormattedText (CustomTextColor (Just BrightYellow) Nothing) else id) $ mconcat
+        [ PlainText $ T.pack $ formatTime defaultTimeLocale "[%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ messageTime msg
+        , maybe "<unnamed>" PlainText $ idName $ messageFrom msg
+        , maybe "" ((": " <>) . PlainText) $ messageText msg
+        ]
 
+
 data Conversation
     = DirectMessageConversation DirectMessageThread
     | ChatroomConversation ChatroomState
 
+withConversation :: (forall conv msg. ConversationType conv msg => conv -> a) -> Conversation -> a
+withConversation f (DirectMessageConversation conv) = f conv
+withConversation f (ChatroomConversation conv) = f conv
+
 isSameConversation :: Conversation -> Conversation -> Bool
 isSameConversation (DirectMessageConversation t) (DirectMessageConversation t')
     = sameIdentity (msgPeer t) (msgPeer t')
@@ -101,7 +115,13 @@
 lookupConversations :: MonadHead LocalState m => m [ Conversation ]
 lookupConversations = map DirectMessageConversation . dmThreadList . lookupSharedValue . lsShared . fromStored <$> getLocalHead
 
+lookupConversationByRef :: MonadHead LocalState m => RefDigest -> m (Maybe Conversation)
+lookupConversationByRef dgst = find ((dgst ==) . conversationReference) <$> lookupConversations
 
+
+conversationReference :: Conversation -> RefDigest
+conversationReference = withConversation convReference
+
 conversationName :: Conversation -> Text
 conversationName (DirectMessageConversation thread) = fromMaybe (T.pack "<unnamed>") $ idName $ msgPeer thread
 conversationName (ChatroomConversation rstate) = fromMaybe (T.pack "<unnamed>") $ roomName =<< roomStateRoom rstate
@@ -111,8 +131,7 @@
 conversationPeer (ChatroomConversation _) = Nothing
 
 conversationHistory :: Conversation -> [ Message ]
-conversationHistory (DirectMessageConversation thread) = map (\msg -> DirectMessageMessage msg False) $ dmThreadToList thread
-conversationHistory (ChatroomConversation rstate) = map (\msg -> ChatroomMessage msg False) $ roomStateMessages rstate
+conversationHistory = withConversation $ map (uncurry Message) . convMessageListSince Nothing
 
 
 sendMessage :: (MonadHead LocalState m, MonadError e m, FromErebosError e) => Conversation -> Text -> m ()
diff --git a/src/Erebos/Conversation/Class.hs b/src/Erebos/Conversation/Class.hs
new file mode 100644
--- /dev/null
+++ b/src/Erebos/Conversation/Class.hs
@@ -0,0 +1,20 @@
+module Erebos.Conversation.Class (
+    ConversationType(..),
+    RefDigest,
+) where
+
+import Data.Text (Text)
+import Data.Time.LocalTime
+import Data.Typeable
+
+import Erebos.Identity
+import Erebos.Object
+
+
+class (Typeable conv, Typeable msg) => ConversationType conv msg | conv -> msg, msg -> conv where
+    convMessageFrom :: msg -> ComposedIdentity
+    convMessageTime :: msg -> ZonedTime
+    convMessageText :: msg -> Maybe Text
+
+    convReference :: conv -> RefDigest
+    convMessageListSince :: Maybe conv -> conv -> [ ( msg, Bool ) ]
diff --git a/src/Erebos/DirectMessage.hs b/src/Erebos/DirectMessage.hs
--- a/src/Erebos/DirectMessage.hs
+++ b/src/Erebos/DirectMessage.hs
@@ -1,6 +1,7 @@
 module Erebos.DirectMessage (
     DirectMessage(..),
     sendDirectMessage,
+    dmMarkAsSeen,
     updateDirectMessagePeer,
     createOrUpdateDirectMessagePeer,
 
@@ -11,7 +12,7 @@
     dmThreadList,
 
     DirectMessageThread(..),
-    dmThreadToList, dmThreadToListSince,
+    dmThreadToList, dmThreadToListSince, dmThreadToListUnread, dmThreadToListSinceUnread,
     dmThreadView,
 
     watchDirectMessageThreads,
@@ -25,6 +26,7 @@
 
 import Data.List
 import Data.Ord
+import Data.Proxy
 import Data.Set (Set)
 import Data.Set qualified as S
 import Data.Text (Text)
@@ -32,6 +34,7 @@
 import Data.Time.Format
 import Data.Time.LocalTime
 
+import Erebos.Conversation.Class
 import Erebos.Discovery
 import Erebos.Identity
 import Erebos.Network
@@ -42,6 +45,18 @@
 import Erebos.Storage.Head
 import Erebos.Storage.Merge
 
+
+instance ConversationType DirectMessageThread DirectMessage where
+    convMessageFrom = msgFrom
+    convMessageTime = msgTime
+    convMessageText = Just . msgText
+
+    convReference = refDigest . storedRef . head . idDataF . msgPeer
+
+    convMessageListSince mbSince thread =
+        threadToListHelper (msgSeen thread) (maybe S.empty (S.fromAscList . msgHead) mbSince) (msgHead thread)
+
+
 data DirectMessage = DirectMessage
     { msgFrom :: ComposedIdentity
     , msgPrev :: [ Stored DirectMessage ]
@@ -71,12 +86,21 @@
     { dmOwnerMismatch = svcPrint "Owner mismatch"
     }
 
+data DirectMessageGlobalState = DirectMessageGlobalState
+    { dmgsLastState :: Maybe [ Stored MessageState ]
+    }
+
 instance Service DirectMessage where
     serviceID _ = mkServiceID "c702076c-4928-4415-8b6b-3e839eafcb0d"
 
     type ServiceAttributes DirectMessage = DirectMessageAttributes
     defaultServiceAttributes _ = defaultDirectMessageAttributes
 
+    type ServiceGlobalState DirectMessage = DirectMessageGlobalState
+    emptyServiceGlobalState _ = DirectMessageGlobalState
+        { dmgsLastState = Nothing
+        }
+
     serviceHandler smsg = do
         let msg = fromStored smsg
         powner <- asks $ finalOwner . svcPeerIdentity
@@ -194,6 +218,23 @@
             }
         return $ DirectMessageThreads [ next ] (dmThreadView [ next ])
 
+dmMarkAsSeen
+    :: (Foldable f, Applicative f, MonadHead LocalState m)
+    => Identity f -> m ()
+dmMarkAsSeen pid = do
+    updateLocalState_ $ updateSharedState_ $ \(DirectMessageThreads prev _) -> do
+        let powner = finalOwner pid
+            received = findMsgProperty powner msReceived prev
+        next <- mstore MessageState
+            { msPrev = prev
+            , msPeer = powner
+            , msReady = []
+            , msSent = []
+            , msReceived = []
+            , msSeen = received
+            }
+        return $ DirectMessageThreads [ next ] (dmThreadView [ next ])
+
 updateDirectMessagePeer
     :: (Foldable f, Applicative f, MonadHead LocalState m)
     => Identity f -> m ()
@@ -262,8 +303,12 @@
                 return unchanged
 
 findMissingPeers :: Server -> DirectMessageThreads -> ExceptT ErebosError IO ()
-findMissingPeers server threads = do
-    forM_ (dmThreadList threads) $ \thread -> do
+findMissingPeers server (DirectMessageThreads states threads) = do
+    prev <- modifyServiceGlobalState server (Proxy @DirectMessage) $ \gs ->
+        ( gs { dmgsLastState = Just states }, dmgsLastState gs )
+    let diffPeers = map (msPeer . fromStored) . storedDifference states <$> prev
+
+    forM_ (takeWhile (\t -> maybe True (any (sameIdentity $ msgPeer t)) diffPeers) threads) $ \thread -> do
         when (msgHead thread /= msgReceived thread) $ do
             mapM_ (discoverySearch server) $ map (refDigest . storedRef) $ idDataF $ msgPeer thread
 
@@ -277,15 +322,21 @@
     }
 
 dmThreadToList :: DirectMessageThread -> [ DirectMessage ]
-dmThreadToList thread = threadToListHelper S.empty $ msgHead thread
+dmThreadToList thread = map fst $ threadToListHelper (msgSeen thread) S.empty $ msgHead thread
 
 dmThreadToListSince :: DirectMessageThread -> DirectMessageThread -> [ DirectMessage ]
-dmThreadToListSince since thread = threadToListHelper (S.fromAscList $ msgHead since) (msgHead thread)
+dmThreadToListSince since thread = map fst $ threadToListHelper (msgSeen thread) (S.fromAscList $ msgHead since) (msgHead thread)
 
-threadToListHelper :: Set (Stored DirectMessage) -> [ Stored DirectMessage ] -> [ DirectMessage ]
-threadToListHelper seen msgs
-    | msg : msgs' <- filter (`S.notMember` seen) $ reverse $ sortBy (comparing cmpView) msgs =
-        fromStored msg : threadToListHelper (S.insert msg seen) (msgs' ++ msgPrev (fromStored msg))
+dmThreadToListUnread :: DirectMessageThread -> [ ( DirectMessage, Bool ) ]
+dmThreadToListUnread thread = threadToListHelper (msgSeen thread) S.empty $ msgHead thread
+
+dmThreadToListSinceUnread :: DirectMessageThread -> DirectMessageThread -> [ ( DirectMessage, Bool ) ]
+dmThreadToListSinceUnread since thread = threadToListHelper (msgSeen thread) (S.fromAscList $ msgHead since) (msgHead thread)
+
+threadToListHelper :: [ Stored DirectMessage ] -> Set (Stored DirectMessage) -> [ Stored DirectMessage ] -> [ ( DirectMessage, Bool ) ]
+threadToListHelper seen used msgs
+    | msg : msgs' <- filter (`S.notMember` used) $ reverse $ sortBy (comparing cmpView) msgs =
+        ( fromStored msg, not $ any (msg `precedesOrEquals`) seen ) : threadToListHelper seen (S.insert msg used) (msgs' ++ msgPrev (fromStored msg))
     | otherwise = []
   where
     cmpView msg = (zonedTimeToUTC $ msgTime $ fromStored msg, msg)
diff --git a/src/Erebos/Discovery.hs b/src/Erebos/Discovery.hs
--- a/src/Erebos/Discovery.hs
+++ b/src/Erebos/Discovery.hs
@@ -67,6 +67,7 @@
     , discoveryTurnPort :: Maybe Word16
     , discoveryTurnServer :: Maybe Text
     , discoveryProvideTunnel :: Peer -> PeerAddress -> Bool
+    , discoveryDebugLog :: Bool
     }
 
 defaultDiscoveryAttributes :: DiscoveryAttributes
@@ -76,6 +77,7 @@
     , discoveryTurnPort = Nothing
     , discoveryTurnServer = Nothing
     , discoveryProvideTunnel = \_ _ -> False
+    , discoveryDebugLog = False
     }
 
 data DiscoveryConnection = DiscoveryConnection
@@ -248,6 +250,13 @@
             peer <- asks svcPeer
             paddrs <- getPeerAddresses peer
 
+            debugLog $ unwords
+                [ "new peer"
+                , show [ refDigest $ storedRef $ idData pid, refDigest $ storedRef $ idExtData pid ]
+                , show $ map (refDigest . storedRef) $ idDataF $ finalOwner pid
+                , show paddrs
+                ]
+
             let insertHelper new old | dpPriority new > dpPriority old = new
                                      | otherwise                       = old
 
@@ -288,6 +297,7 @@
                 }
 
         DiscoverySearch edgst -> do
+            pid <- asks svcPeerIdentity
             dpeer <- M.lookup (either refDigest id edgst) . dgsPeers <$> svcGetGlobal
             peer <- asks svcPeer
             paddr <- asks svcPeerAddress
@@ -295,7 +305,11 @@
             let offerTunnel
                     | discoveryProvideTunnel attrs peer paddr = (++ [ DiscoveryTunnel ])
                     | otherwise                               = id
-            replyPacket $ DiscoveryResult edgst $ maybe [] (offerTunnel . dpAddress) dpeer
+            let results = maybe [] (offerTunnel . dpAddress) dpeer
+            replyPacket $ DiscoveryResult edgst results
+            debugLog $ "search by " <> show (refDigest $ storedRef $ idData pid) <>
+                " for " <> show (either refDigest id edgst) <>
+                " result [" <> T.unpack (T.intercalate "," $ map toText results) <> "]"
 
         DiscoveryResult _ [] -> do
             -- not found
@@ -323,6 +337,7 @@
 #ifdef ENABLE_ICE_SUPPORT
                         getIceConfig >>= \case
                             Just config -> do
+                                printOp <- asks svcPrintOp
                                 void $ liftIO $ forkIO $ do
                                     ice <- iceCreateSession config PjIceSessRoleControlling $ \ice -> do
                                         rinfo <- iceRemoteInfo ice
@@ -338,7 +353,7 @@
                                             DiscoveryConnectionRequest (emptyConnection (Left $ storedRef $ idData self) edgst') { dconnIceInfo = Just rinfo }
                                         case res of
                                             Right _ -> return ()
-                                            Left err -> putStrLn $ "Discovery: failed to send connection request: " ++ err
+                                            Left err -> printOp $ "Discovery: failed to send connection request: " ++ err
 
                                     runAsService $ do
                                         let upd dp = dp { dpIceSession = Just ice }
@@ -391,12 +406,13 @@
                     peer <- asks svcPeer
                     getIceConfig >>= \case
                         Just config -> do
+                            printOp <- asks svcPrintOp
                             liftIO $ void $ iceCreateSession config PjIceSessRoleControlled $ \ice -> do
                                 rinfo <- iceRemoteInfo ice
                                 res <- runExceptT $ sendToPeer peer $ DiscoveryConnectionResponse rconn { dconnIceInfo = Just rinfo }
                                 case res of
                                     Right _ -> iceConnect ice prinfo $ void $ serverPeerIce server ice
-                                    Left err -> putStrLn $ "Discovery: failed to send connection response: " ++ err
+                                    Left err -> printOp $ "Discovery: failed to send connection response: " ++ err
                         Nothing -> do
                             return ()
 #endif
@@ -419,6 +435,8 @@
                                         replyPacket $ DiscoveryConnectionResponse rconn
                                     | fromSource : _ <- streams -> do
                                         void $ liftIO $ forkIO $ runPeerService @DiscoveryService dpeer $ do
+                                            debugLog $ "setting up tunnel from " <> show (either refDigest id $ dconnSource conn) <>
+                                                " to " <> show (either refDigest id $ dconnTarget conn)
                                             toTarget <- openStream
                                             svcModify $ \s -> s { dpsRelayedTunnelRequests =
                                                 ( either refDigest id $ dconnSource conn, ( fromSource, toTarget )) : dpsRelayedTunnelRequests s }
@@ -535,6 +553,19 @@
         forM_ searchingFor $ \dgst -> do
             sendToPeer peer $ DiscoverySearch (Right dgst)
 
+    serviceUpdatedPeer = do
+        pid <- asks svcPeerIdentity
+        peer <- asks svcPeer
+        isPeerDropped peer >>= \case
+            True -> do
+                peers <- dgsPeers <$> svcGetGlobal
+                let peers' = M.filter ((Just peer /=) . dpPeer) peers
+                svcModifyGlobal $ \s -> s { dgsPeers = peers' }
+                debugLog $ "dropped peer " <> show [ refDigest $ storedRef $ idData pid, refDigest $ storedRef $ idExtData pid ] <>
+                    ", map size " <> show (M.size peers) <> " -> " <> show (M.size peers')
+            False -> do
+                debugLog $ "updated peer " <> show [ refDigest $ storedRef $ idData pid, refDigest $ storedRef $ idExtData pid ]
+
 #ifdef ENABLE_ICE_SUPPORT
     serviceStopServer _ _ _ pstates = do
         forM_ pstates $ \( _, DiscoveryPeerState {..} ) -> do
@@ -542,6 +573,13 @@
 #endif
 
 
+debugLog :: String -> ServiceHandler DiscoveryService ()
+debugLog str = do
+    asks (discoveryDebugLog . svcAttributes) >>= \case
+        True -> svcPrint $ "discovery: " <> str
+        False -> return ()
+
+
 identityDigests :: Foldable f => Identity f -> [ RefDigest ]
 identityDigests pid = map (refDigest . storedRef) $ idDataF =<< unfoldOwners pid
 
@@ -566,20 +604,34 @@
 #endif
 
 
-discoverySearch :: (MonadIO m, MonadError e m, FromErebosError e) => Server -> RefDigest -> m ()
+-- | Start search for an identity identified by given ref using the discovery
+-- service.
+discoverySearch
+    :: forall m e. (MonadIO m, MonadError e m, FromErebosError e)
+    => Server -- ^ `Server' object to run the discovery
+    -> RefDigest -- ^ Reference identifying the intended peer
+    -> m ()
 discoverySearch server dgst = do
-    peers <- liftIO $ getCurrentPeerList server
-    match <- forM peers $ \peer -> do
-        getPeerIdentity peer >>= \case
-            PeerIdentityFull pid -> do
-                return $ dgst `elem` identityDigests pid
-            _ -> return False
-    when (not $ or match) $ do
-        modifyServiceGlobalState server (Proxy @DiscoveryService) $ \s -> (, ()) s
-            { dgsSearchingFor = S.insert dgst $ dgsSearchingFor s
-            }
-        forM_ peers $ \peer -> do
-            sendToPeer peer $ DiscoverySearch $ Right dgst
+    flip catchError (\e -> case toErebosError e of
+            Just (UnhandledService svc) | svc == serviceID (Proxy @DiscoveryService) -> return ()
+            _ -> throwError e) $ do
+        peers <- liftIO $ getCurrentPeerList server
+        match <- forM peers $ \peer -> do
+            getPeerIdentity peer >>= \case
+                PeerIdentityFull pid -> do
+                    return $ dgst `elem` identityDigests pid
+                _ -> return False
+        when (not $ or match) $ do
+            alreadySearching <- modifyServiceGlobalState server (Proxy @DiscoveryService) $ \s ->
+                let alreadySearching = S.member dgst $ dgsSearchingFor s
+                 in ( if alreadySearching then s else s
+                         { dgsSearchingFor =  S.insert dgst $ dgsSearchingFor s
+                         }
+                    , alreadySearching
+                    )
+            when (not alreadySearching) $ do
+                forM_ peers $ \peer -> do
+                    sendToPeer peer $ DiscoverySearch $ Right dgst
 
 
 data TunnelAddress = TunnelAddress
@@ -630,7 +682,7 @@
             receivedFromCustomAddress server taddr stpData
             receiveFromTunnel server taddr
         StreamClosed {} -> do
-            return ()
+            dropPeerAddress server $ CustomPeerAddress taddr
 
 
 discoverySetupTunnel :: Peer -> RefDigest -> IO ()
diff --git a/src/Erebos/Error.hs b/src/Erebos/Error.hs
--- a/src/Erebos/Error.hs
+++ b/src/Erebos/Error.hs
@@ -3,19 +3,24 @@
     showErebosError,
 
     FromErebosError(..),
+    throwErebosError,
     throwOtherError,
 ) where
 
 import Control.Monad.Except
 
+import {-# SOURCE #-} Erebos.Network.Protocol
 
+
 data ErebosError
     = ManyErrors [ ErebosError ]
     | OtherError String
+    | UnhandledService ServiceID
 
 showErebosError :: ErebosError -> String
 showErebosError (ManyErrors errs) = unlines $ map showErebosError errs
 showErebosError (OtherError str) = str
+showErebosError (UnhandledService svc) = "unhandled service ‘" ++ show svc ++ "’"
 
 instance Semigroup ErebosError where
     ManyErrors [] <> b = b
@@ -23,7 +28,7 @@
     ManyErrors a <> ManyErrors b = ManyErrors (a ++ b)
     ManyErrors a <> b = ManyErrors (a ++ [ b ])
     a <> ManyErrors b = ManyErrors (a : b)
-    a@OtherError {} <> b@OtherError {} = ManyErrors [ a, b ]
+    a <> b = ManyErrors [ a, b ]
 
 instance Monoid ErebosError where
     mempty = ManyErrors []
@@ -31,9 +36,14 @@
 
 class FromErebosError e where
     fromErebosError :: ErebosError -> e
+    toErebosError :: e -> Maybe ErebosError
 
 instance FromErebosError ErebosError where
     fromErebosError = id
+    toErebosError = Just
 
+throwErebosError :: (MonadError e m, FromErebosError e) => ErebosError -> m a
+throwErebosError = throwError . fromErebosError
+
 throwOtherError :: (MonadError e m, FromErebosError e) => String -> m a
-throwOtherError = throwError . fromErebosError . OtherError
+throwOtherError = throwErebosError . OtherError
diff --git a/src/Erebos/Identity.hs b/src/Erebos/Identity.hs
--- a/src/Erebos/Identity.hs
+++ b/src/Erebos/Identity.hs
@@ -391,13 +391,13 @@
     roots idt = uniq $ sort $ concatMap storedRoots $ toList $ idDataF idt
 
 
-unfoldOwners :: (Foldable m) => Identity m -> [ComposedIdentity]
+unfoldOwners :: Foldable m => Identity m -> [ComposedIdentity]
 unfoldOwners = unfoldr (fmap (\i -> (i, idOwner i))) . Just . toComposedIdentity
 
-finalOwner :: (Foldable m, Applicative m) => Identity m -> ComposedIdentity
+finalOwner :: Foldable m => Identity m -> ComposedIdentity
 finalOwner = last . unfoldOwners
 
-displayIdentity :: (Foldable m, Applicative m) => Identity m -> Text
+displayIdentity :: Foldable m => Identity m -> Text
 displayIdentity identity = T.concat
     [ T.intercalate (T.pack " / ") $ map (fromMaybe (T.pack "<unnamed>") . idName) owners
     ]
diff --git a/src/Erebos/Invite.hs b/src/Erebos/Invite.hs
new file mode 100644
--- /dev/null
+++ b/src/Erebos/Invite.hs
@@ -0,0 +1,385 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Erebos.Invite (
+    Invite(..),
+    InviteData(..),
+    AcceptedInvite(..),
+    AcceptedInviteData(..),
+    AcceptedInviteStatus(..),
+    InviteToken, showInviteToken, textInviteToken, parseInviteToken,
+    InviteService,
+    InviteServiceAttributes(..),
+
+    createSingleContactInvite,
+    acceptInvite,
+) where
+
+import Control.Arrow
+import Control.Monad
+import Control.Monad.Except
+import Control.Monad.IO.Class
+import Control.Monad.Reader
+
+import Crypto.Random
+
+import Data.ByteArray (ByteArray, ByteArrayAccess)
+import Data.ByteString (ByteString)
+import Data.ByteString.Char8 qualified as BC
+import Data.Foldable
+import Data.Maybe
+import Data.Ord
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Text.Encoding
+import Data.Time.LocalTime
+
+import Erebos.Contact
+import Erebos.Discovery
+import Erebos.Identity
+import Erebos.Network
+import Erebos.Object
+import Erebos.PubKey
+import Erebos.Service
+import Erebos.Set
+import Erebos.State
+import Erebos.Storable
+import Erebos.Storage.Merge
+import Erebos.Util
+
+
+data Invite = Invite
+    { inviteData :: [ Stored InviteData ]
+    , inviteToken :: Maybe InviteToken
+    , inviteCreated :: Maybe ZonedTime
+    , inviteAccepted :: [ ( Stored (Signed ExtendedIdentityData), Maybe ZonedTime ) ]
+    , inviteContact :: Maybe Text
+    }
+
+data InviteData = InviteData
+    { invdPrev :: [ Stored InviteData ]
+    , invdTime :: Maybe ZonedTime
+    , invdToken :: Maybe InviteToken
+    , invdAccepted :: Maybe (Stored (Signed ExtendedIdentityData))
+    , invdContact :: Maybe Text
+    }
+
+instance Storable InviteData where
+    store' x = storeRec $ do
+        mapM_ (storeRef "PREV") $ invdPrev x
+        mapM_ (storeDate "time") $ invdTime x
+        mapM_ (storeBinary "token") $ invdToken x
+        mapM_ (storeRef "accepted") $ invdAccepted x
+        mapM_ (storeText "contact") $ invdContact x
+
+    load' = loadRec $ InviteData
+        <$> loadRefs "PREV"
+        <*> loadMbDate "time"
+        <*> loadMbBinary "token"
+        <*> loadMbRef "accepted"
+        <*> loadMbText "contact"
+
+
+newtype InviteToken = InviteToken ByteString
+    deriving (Eq, Ord, Semigroup, Monoid, ByteArray, ByteArrayAccess)
+
+showInviteToken :: InviteToken -> String
+showInviteToken (InviteToken token) = BC.unpack (showHex token)
+
+textInviteToken :: InviteToken -> Text
+textInviteToken (InviteToken token) = decodeUtf8 (showHex token)
+
+parseInviteToken :: Text -> Maybe InviteToken
+parseInviteToken text = InviteToken <$> (readHex $ encodeUtf8 text)
+
+
+instance Mergeable Invite where
+    type Component Invite = InviteData
+
+    mergeSorted invdata = Invite
+        { inviteData = invdata
+        , inviteToken = findPropertyFirst invdToken invdata
+        , inviteCreated = join $ findPropertyFirst (\invd -> (const $ invdTime invd) <$> invdTime invd) invdata
+        , inviteAccepted = findProperty (\invd -> ( , invdTime invd ) <$> invdAccepted invd) invdata
+        , inviteContact = findPropertyFirst invdContact invdata
+        }
+
+    toComponents = inviteData
+
+instance SharedType (Set Invite) where
+    sharedTypeID _ = mkSharedTypeID "78da787a-9380-432e-a51d-532a30d27b3d"
+
+
+data AcceptedInvite = AcceptedInvite
+    { acceptedInviteData :: [ Stored AcceptedInviteData ]
+    , acceptedInviteToken :: Maybe InviteToken
+    , acceptedInviteFrom :: Maybe RefDigest
+    , acceptedInviteStatus :: AcceptedInviteStatus
+    }
+
+data AcceptedInviteData = AcceptedInviteData
+    { aidPrev :: [ Stored AcceptedInviteData ]
+    , aidToken :: Maybe InviteToken
+    , aidFrom :: Maybe RefDigest
+    , aidConfirmed :: Bool
+    , aidRejected :: Bool
+    }
+
+data AcceptedInviteStatus
+    = AcceptedInvitePending
+    | AcceptedInviteRejected
+    | AcceptedInviteConfirmed
+
+instance Storable AcceptedInviteData where
+    store' AcceptedInviteData {..} = storeRec $ do
+        mapM_ (storeRef "PREV") aidPrev
+        mapM_ (storeBinary "token") aidToken
+        mapM_ (storeRawWeak "from") aidFrom
+        when aidConfirmed $ storeEmpty "confirmed"
+        when aidRejected $ storeEmpty "rejected"
+
+    load' = loadRec $ do
+        aidPrev <- loadRefs "PREV"
+        aidToken <- loadMbBinary "token"
+        aidFrom <- loadMbRawWeak "from"
+        aidConfirmed <- isJust <$> loadMbEmpty "confirmed"
+        aidRejected <- isJust <$> loadMbEmpty "rejected"
+        return AcceptedInviteData {..}
+
+instance Mergeable AcceptedInvite where
+    type Component AcceptedInvite = AcceptedInviteData
+
+    mergeSorted aidata = AcceptedInvite
+        { acceptedInviteData = aidata
+        , acceptedInviteToken = findPropertyFirst aidToken aidata
+        , acceptedInviteFrom = findPropertyFirst aidFrom aidata
+        , acceptedInviteStatus = fromMaybe AcceptedInvitePending $ flip findPropertyFirst aidata $ \case
+            AcceptedInviteData {..}
+                | aidConfirmed -> Just AcceptedInviteConfirmed
+                | aidRejected -> Just AcceptedInviteRejected
+                | isJust aidToken -> Just AcceptedInvitePending
+                | otherwise -> Nothing
+        }
+    toComponents = acceptedInviteData
+
+instance SharedType (Set AcceptedInvite) where
+    sharedTypeID _ = mkSharedTypeID "b1ebf228-4892-476b-ba04-0c26320139b1"
+
+
+createSingleContactInvite :: MonadHead LocalState m => Text -> m Invite
+createSingleContactInvite name = do
+    time <- liftIO getZonedTime
+    token <- liftIO $ getRandomBytes 32
+    invite <- mergeSorted @Invite . (: []) <$> mstore InviteData
+        { invdPrev = []
+        , invdTime = Just time
+        , invdToken = Just token
+        , invdAccepted = Nothing
+        , invdContact = Just name
+        }
+    updateLocalState_ $ updateSharedState_ $ \invites -> do
+        storeSetAdd invite invites
+    return invite
+
+-- | Accept an invite received outside of the Erebos protocol. The acceptance
+-- is recorded in the shared state and will be confirmed with the issuer when a
+-- connection with their device is established.
+acceptInvite
+    :: MonadHead LocalState m
+    => RefDigest -- ^ Reference to the identity that issued the invite
+    -> InviteToken -- ^ Invite token
+    -> m ()
+acceptInvite from token = do
+    prev <- find ((Just token ==) . acceptedInviteToken)
+        . fromSetBy (comparing acceptedInviteToken) . lookupSharedValue . lsShared . fromStored
+        <$> getLocalHead
+    accepted <- mergeSorted @AcceptedInvite . (: []) <$> mstore AcceptedInviteData
+        { aidPrev = maybe [] acceptedInviteData prev
+        , aidToken = Just token
+        , aidFrom = Just from
+        , aidConfirmed = False
+        , aidRejected = False
+        }
+    updateLocalState_ $ updateSharedState_ $ storeSetAdd accepted
+
+
+data InviteService
+    = AcceptInvite InviteToken
+    | InvalidInvite InviteToken
+    | ContactInvite InviteToken (Maybe Text)
+    | UnknownInvitePacket
+
+data InviteServiceAttributes = InviteServiceAttributes
+    { inviteHookAccepted :: Invite -> ServiceHandler InviteService ()
+    , inviteHookReplyContact :: InviteToken -> Maybe Text -> ServiceHandler InviteService ()
+    , inviteHookReplyInvalid :: InviteToken -> ServiceHandler InviteService ()
+    }
+
+defaultInviteServiceAttributes :: InviteServiceAttributes
+defaultInviteServiceAttributes = InviteServiceAttributes
+    { inviteHookAccepted = \Invite {..} -> do
+        pid <- asks $ svcPeerIdentity
+        svcPrint $ T.unpack $ "Invite" <> maybe "" ((" for “" <>) . (<> "”")) inviteContact <> " accepted by " <> displayIdentity pid
+            <> " (token: " <> maybe "??" textInviteToken inviteToken <> ")"
+    , inviteHookReplyContact = \token mbName -> do
+        pid <- asks $ svcPeerIdentity
+        svcPrint $ T.unpack $ "Invite confirmed by " <> displayIdentity pid
+            <> (maybe "" (" with name " <>) mbName)
+            <> " (token: " <> textInviteToken token <> ")"
+    , inviteHookReplyInvalid = \token -> do
+        pid <- asks $ svcPeerIdentity
+        svcPrint $ T.unpack $ "Invite rejected as invalid by " <> displayIdentity pid
+            <> " (token: " <> textInviteToken token <> ")"
+    }
+
+instance Storable InviteService where
+    store' x = storeRec $ case x of
+        AcceptInvite token -> storeBinary "accept" token
+        InvalidInvite token -> storeBinary "invalid" token
+        ContactInvite token mbName -> do
+            storeBinary "valid" token
+            maybe (storeEmpty "contact") (storeText "contact") mbName
+        UnknownInvitePacket -> return ()
+
+    load' = loadRec $ msum
+        [ AcceptInvite <$> loadBinary "accept"
+        , InvalidInvite <$> loadBinary "invalid"
+        , ContactInvite <$> loadBinary "valid" <*> msum
+            [ return Nothing <* loadEmpty "contact"
+            , Just <$> loadText "contact"
+            ]
+        , return UnknownInvitePacket
+        ]
+
+instance Service InviteService where
+    serviceID _ = mkServiceID "70bff715-6856-43a0-8c58-007a06a26eb1"
+
+    type ServiceState InviteService = [ InviteToken ] -- accepted invites, waiting for reply
+    emptyServiceState _ = []
+
+    type ServiceAttributes InviteService = InviteServiceAttributes
+    defaultServiceAttributes _ = defaultInviteServiceAttributes
+
+    serviceHandler = fromStored >>> \case
+        AcceptInvite token -> do
+            invites <- fromSetBy (comparing inviteToken) . lookupSharedValue . lsShared . fromStored <$> getLocalHead
+            case find ((Just token ==) . inviteToken) invites of
+                Just invite
+                    | Just name <- inviteContact invite
+                    , [] <- inviteAccepted invite
+                    -> do
+                        asks (inviteHookAccepted . svcAttributes) >>= ($ invite)
+                        time <- liftIO getZonedTime
+                        identity <- asks svcPeerIdentity
+                        cdata <- mstore ContactData
+                            { cdPrev = []
+                            , cdIdentity = idExtDataF $ finalOwner identity
+                            , cdName = Just name
+                            }
+                        invdata <- mstore InviteData
+                            { invdPrev = inviteData invite
+                            , invdTime = Just time
+                            , invdToken = Nothing
+                            , invdAccepted = Just (idExtData identity)
+                            , invdContact = Nothing
+                            }
+                        updateLocalState_ $ updateSharedState_ $ storeSetAdd (mergeSorted @Contact [ cdata ])
+                        updateLocalState_ $ updateSharedState_ $ storeSetAdd (mergeSorted @Invite [ invdata ])
+                        replyPacket $ ContactInvite token Nothing
+
+                    | otherwise -> do
+                        replyPacket $ InvalidInvite token
+
+                Nothing -> do
+                    replyPacket $ InvalidInvite token
+
+        InvalidInvite token -> do
+            asks (inviteHookReplyInvalid . svcAttributes) >>= ($ token)
+            svcModify $ filter (/= token)
+
+            accepted <- fromSetBy (comparing acceptedInviteToken) . lookupSharedValue . lsShared . fromStored <$> getLocalHead
+            case find ((Just token ==) . acceptedInviteToken) accepted of
+                Just invite -> do
+                    aidata <- mstore AcceptedInviteData
+                        { aidPrev = acceptedInviteData invite
+                        , aidToken = Nothing
+                        , aidFrom = Nothing
+                        , aidConfirmed = False
+                        , aidRejected = True
+                        }
+                    updateLocalState_ $ updateSharedState_ $ storeSetAdd (mergeSorted @AcceptedInvite [ aidata ])
+                Nothing -> return ()
+
+        ContactInvite token mbName -> do
+            asks (inviteHookReplyContact . svcAttributes) >>= ($ mbName) . ($ token)
+            waitingTokens <- svcGet
+            if token `elem` waitingTokens
+              then do
+                svcSet $ filter (/= token) waitingTokens
+
+                accepted <- fromSetBy (comparing acceptedInviteToken) . lookupSharedValue . lsShared . fromStored <$> getLocalHead
+                case find ((Just token ==) . acceptedInviteToken) accepted of
+                    Just invite -> do
+                        aidata <- mstore AcceptedInviteData
+                            { aidPrev = acceptedInviteData invite
+                            , aidToken = Nothing
+                            , aidFrom = Nothing
+                            , aidConfirmed = True
+                            , aidRejected = False
+                            }
+                        updateLocalState_ $ updateSharedState_ $ storeSetAdd (mergeSorted @AcceptedInvite [ aidata ])
+                    Nothing -> return ()
+
+                identity <- asks svcPeerIdentity
+                cdata <- mstore ContactData
+                    { cdPrev = []
+                    , cdIdentity = idExtDataF $ finalOwner identity
+                    , cdName = Nothing
+                    }
+                updateLocalState_ $ updateSharedState_ $ storeSetAdd (mergeSorted @Contact [ cdata ])
+              else do
+                svcPrint $ "Received unexpected invite response for " <> BC.unpack (showHex token)
+
+        UnknownInvitePacket -> do
+            svcPrint $ "Received unknown invite packet"
+
+    serviceNewPeer = do
+        invites <- fromSetBy (comparing acceptedInviteToken) . lookupSharedValue . lsShared . fromStored <$> getLocalHead
+        peerDigests <- asks $ identityOwnerDigests . svcPeerIdentity
+        forM_ invites $ \case
+            AcceptedInvite
+                { acceptedInviteToken = Just token
+                , acceptedInviteFrom = Just from
+                , acceptedInviteStatus = AcceptedInvitePending
+                } | from `elem` peerDigests -> do
+                    svcModify (token :)
+                    replyPacket $ AcceptInvite token
+            _ -> return ()
+
+    serviceStorageWatchers _ = (:[]) $
+        GlobalStorageWatcher (lookupSharedValue . lsShared . fromStored) sendAcceptedInvites
+
+
+sendAcceptedInvites :: Server -> Set AcceptedInvite -> ExceptT ErebosError IO ()
+sendAcceptedInvites server aiset = do
+    forM_ (fromSetBy (comparing acceptedInviteToken) aiset) $ \case
+        AcceptedInvite
+            { acceptedInviteToken = Just token
+            , acceptedInviteFrom = Just from
+            , acceptedInviteStatus = AcceptedInvitePending
+            } -> do
+                let matchPeer peer = do
+                        getPeerIdentity peer >>= \case
+                            PeerIdentityFull pid -> do
+                                return $ from `elem` identityOwnerDigests pid
+                            _ -> return False
+
+                liftIO (findPeer server matchPeer) >>= \case
+                    Just peer -> runPeerService @InviteService peer $ do
+                        svcModify (token :)
+                        replyPacket $ AcceptInvite token
+                    Nothing -> do
+                        discoverySearch server from
+        _ -> return ()
+
+identityOwnerDigests :: Foldable f => Identity f -> [ RefDigest ]
+identityOwnerDigests pid = map (refDigest . storedRef) $ concatMap toList $ toList $ generations $ idExtDataF $ finalOwner pid
diff --git a/src/Erebos/Network.hs b/src/Erebos/Network.hs
--- a/src/Erebos/Network.hs
+++ b/src/Erebos/Network.hs
@@ -19,13 +19,14 @@
     serverPeer,
     serverPeerCustom,
     findPeer,
-    dropPeer,
+    dropPeer, dropPeerAddress,
     isPeerDropped,
     sendToPeer, sendManyToPeer,
     sendToPeerStored, sendManyToPeerStored,
     sendToPeerWith,
     runPeerService,
     modifyServiceGlobalState,
+    requestDataFromPeer, DataRequestResult(..),
 
     discoveryPort,
 ) where
@@ -232,21 +233,27 @@
 newWaitingRef :: RefDigest -> (Ref -> WaitingRefCallback) -> PacketHandler WaitingRef
 newWaitingRef dgst act = do
     peer@Peer {..} <- gets phPeer
-    wref <- WaitingRef peerStorage_ (partialRefFromDigest peerInStorage dgst) act <$> liftSTM (newTVar (Left []))
+    let cb (DataRequestFulfilled ref) = act ref
+        cb _                          = return ()
+    wref <- WaitingRef peerStorage_ (partialRefFromDigest peerInStorage dgst) maxBound cb <$> liftSTM (newTVar (Left []))
     modifyTMVarP peerWaitingRefs (wref:)
     liftSTM $ writeTQueue (serverDataResponse $ peerServer peer) (peer, Nothing)
     return wref
 
 
-forkServerThread :: Server -> IO () -> IO ()
-forkServerThread server act = do
+forkServerThread :: Server -> String -> IO () -> IO ()
+forkServerThread server label act = do
     modifyMVar_ (serverThreads server) $ \ts -> do
         t <- forkIO $ do
             t <- myThreadId
-            act
+            catchAndLogError act
             modifyMVar_ (serverThreads server) $ return . filter (/=t)
         return (t:ts)
+  where
+    catchAndLogError = handle $ \(e :: SomeException) ->
+        atomically $ writeTQueue (serverErrorLog server) $ "server " <> label <> ": " <> show e
 
+
 startServer :: ServerOptions -> Head LocalState -> (String -> IO ()) -> [SomeService] -> IO Server
 startServer serverOptions serverOrigHead logd' serverServices = do
     let serverStorage = headStorage serverOrigHead
@@ -266,20 +273,20 @@
     chanSvc <- newTQueueIO
 
     let logd = writeTQueue serverErrorLog
-    forkServerThread server $ forever $ do
+    forkServerThread server "logger" $ forever $ do
         logd' . (serverErrorPrefix serverOptions <>) =<< atomically (readTQueue serverErrorLog)
 
     logt <- if
         | serverTestLog serverOptions -> do
             serverTestLog <- newTQueueIO
-            forkServerThread server $ forever $ do
+            forkServerThread server "test-logger" $ forever $ do
                 logd' =<< atomically (readTQueue serverTestLog)
             return $ writeTQueue serverTestLog
         | otherwise -> do
             return $ \_ -> return ()
 
-    forkServerThread server $ dataResponseWorker server
-    forkServerThread server $ forever $ do
+    forkServerThread server "data-response-worker" $ dataResponseWorker server
+    forkServerThread server "io-action-worker" $ forever $ do
         either (atomically . logd . showErebosError) return =<< runExceptT =<<
             atomically (readTQueue serverIOActions)
 
@@ -293,7 +300,7 @@
             return sock
 
         loop sock = do
-            when (serverLocalDiscovery serverOptions) $ forkServerThread server $ do
+            when (serverLocalDiscovery serverOptions) $ forkServerThread server "discovery" $ do
                 announceAddreses <- fmap concat $ sequence $
                     [ map (SockAddrInet6 discoveryPort 0 discoveryMulticastGroup) <$> joinMulticast sock
                     , getBroadcastAddresses discoveryPort
@@ -339,18 +346,22 @@
                             atomically $ writeTQueue serverIOActions $ do
                                 act server x
 
-            forkServerThread server $ forever $ do
+            forkServerThread server "receiver" $ forever $ do
                 (msg, saddr) <- S.recvFrom sock 4096
                 writeFlowIO serverRawPath (DatagramAddress saddr, msg)
 
-            forkServerThread server $ forever $ do
-                (paddr, msg) <- readFlowIO serverRawPath
-                handle (\(e :: SomeException) -> atomically . logd $ "failed to send packet to " ++ show paddr ++ ": " ++ show e) $ do
+            forkServerThread server "sender" $ forever $ do
+                ( paddr, msg ) <- readFlowIO serverRawPath
+                let logAndDropAddress :: SomeException -> IO ()
+                    logAndDropAddress e = do
+                        atomically . logd $ "failed to send packet to " ++ show paddr ++ ": " ++ show e
+                        dropPeerAddress server paddr
+                handle logAndDropAddress $ do
                     case paddr of
                         CustomPeerAddress addr -> sendBytesToAddress addr msg
                         DatagramAddress addr -> void $ S.sendTo sock msg addr
 
-            forkServerThread server $ forever $ do
+            forkServerThread server "control-handler" $ forever $ do
                 readFlowIO serverControlFlow >>= \case
                     NewConnection conn mbpid -> do
                         let paddr = connAddress conn
@@ -361,7 +372,7 @@
                                     peer <- mkPeer server paddr
                                     return (M.insert paddr peer pvalue, peer)
 
-                        forkServerThread server $ do
+                        forkServerThread server "peer-handler" $ do
                             atomically $ do
                                 readTVar (peerState peer) >>= \case
                                     PeerInit packets -> do
@@ -395,10 +406,9 @@
                                     Nothing -> do
                                         case paddr of
                                             DatagramAddress _ -> return ()
-                                            CustomPeerAddress caddr -> connectionToAddressClosed caddr
-
+                                            CustomPeerAddress caddr -> connectionToAddressClosed caddr `catch`
+                                                \(e :: SomeException) -> atomically $ logd $ "connectionToAddressClosed on " <> show paddr <> " failed: " <> show e
                                         dropPeer peer
-                                        atomically $ writeTChan serverChanPeer peer
                             peerLoop
 
                     ReceivedAnnounce addr _ -> do
@@ -406,7 +416,7 @@
 
             erebosNetworkProtocol (headLocalIdentity serverOrigHead) logd logt protocolRawPath protocolControlFlow
 
-    forkServerThread server $ withSocketsDo $ do
+    forkServerThread server "main-loop" $ withSocketsDo $ do
         let hints = defaultHints
               { addrFlags = [AI_PASSIVE]
               , addrFamily = AF_INET6
@@ -415,7 +425,7 @@
         addr:_ <- getAddrInfo (Just hints) Nothing (Just $ show $ serverPort serverOptions)
         bracket (open addr) close loop
 
-    forkServerThread server $ forever $ do
+    forkServerThread server "service-handler" $ forever $ do
         ( peer, paddr, svc, ref, streams ) <- atomically $ readTQueue chanSvc
         case find ((svc ==) . someServiceID) serverServices of
             Just service@(SomeService (_ :: Proxy s) attr) -> runPeerServiceOn (Just ( service, attr )) streams paddr peer (serviceHandler $ wrappedLoad @s ref)
@@ -450,8 +460,8 @@
             Left ds -> case maybe id (filter . (/=) . refDigest) npref $ ds of
                 [] -> copyRef (wrefStorage wr) (wrefPartial wr) >>= \case
                           Right ref -> do
-                              atomically (writeTVar tvar $ Right ref)
-                              forkServerThread server $ runExceptT (wrefAction wr ref) >>= \case
+                              atomically (writeTVar tvar $ Right $ DataRequestFulfilled ref)
+                              forkServerThread server "request-fulfilled" $ runExceptT (wrefAction wr $ DataRequestFulfilled ref) >>= \case
                                   Left err -> atomically $ writeTQueue (serverErrorLog server) (showErebosError err)
                                   Right () -> return ()
 
@@ -548,7 +558,7 @@
         _                  -> throwError "can't open stream without established connection"
     (hdr, writer, handler) <- liftEither =<< liftSTM (connAddWriteStream conn)
 
-    liftSTM $ writeTQueue (serverIOActions peerServer_) (liftIO $ forkServerThread peerServer_ handler)
+    liftSTM $ writeTQueue (serverIOActions peerServer_) (liftIO $ forkServerThread peerServer_ "stream-writer" handler)
     addHeader hdr
     return writer
 
@@ -882,14 +892,27 @@
 
 dropPeer :: MonadIO m => Peer -> m ()
 dropPeer peer = liftIO $ do
-    modifyMVar_ (serverPeers $ peerServer peer) $ \pvalue -> do
-        atomically $ do
-            readTVar (peerState peer) >>= \case
-                PeerConnected conn -> connClose conn
-                _ -> return()
-            writeTVar (peerState peer) PeerDropped
-        return $ M.delete (peerAddress peer) pvalue
+    modifyMVar_ (serverPeers $ peerServer peer) $ dropPeerInner peer
 
+dropPeerAddress :: MonadIO m => Server -> PeerAddress -> m ()
+dropPeerAddress server paddr = liftIO $ do
+    modifyMVar_ (serverPeers server) $ \pvalue -> do
+        case find ((paddr ==) . peerAddress) pvalue of
+            Just peer -> dropPeerInner peer pvalue
+            Nothing -> return pvalue
+
+dropPeerInner :: Peer -> Map PeerAddress Peer -> IO (Map PeerAddress Peer)
+dropPeerInner peer pvalue = do
+    atomically $ do
+        readTVar (peerState peer) >>= \case
+            PeerConnected conn -> do
+                connClose conn
+                writeTChan (serverChanPeer $ peerServer peer) peer
+                notifyServicesOfPeer False peer
+            _ -> return ()
+        writeTVar (peerState peer) PeerDropped
+    return $ M.delete (peerAddress peer) pvalue
+
 isPeerDropped :: MonadIO m => Peer -> m Bool
 isPeerDropped peer = liftIO $ atomically $ readTVar (peerState peer) >>= \case
     PeerDropped -> return True
@@ -926,7 +949,7 @@
                         (hdr, writer, handler) <- liftEither =<< lift (connAddWriteStream conn)
 
                         lift $ writeTQueue (serverIOActions (peerServer peer)) $ do
-                            liftIO $ forkServerThread (peerServer peer) handler
+                            liftIO $ forkServerThread (peerServer peer) "service-stream-writer" handler
                         return [ ( hdr, cb writer ) ]
                     _ -> return []
         liftIO $ sequence_ $ map snd streamHeaders
@@ -949,7 +972,7 @@
     case res of
         Right () -> return ()
         Left err -> liftIO $ atomically $ writeTQueue (serverErrorLog $ peerServer peer) $
-            "failed to send packet to " <> show (peerAddress peer) <> ": " <> err
+            "failed to prepare packet to " <> show (peerAddress peer) <> ": " <> err
 
 sendToPeerS' :: SecurityRequirement -> Peer -> [TransportHeaderItem] -> TransportPacket Ref -> STM ()
 sendToPeerS' secure Peer {..} ackedBy packet = do
@@ -1060,7 +1083,15 @@
                 putTMVar (serverServiceStates server) global'
                 return res
         Nothing -> do
-            throwOtherError $ "unhandled service '" ++ show (toUUID svc) ++ "'"
+            throwErebosError $ UnhandledService svc
+
+
+requestDataFromPeer :: MonadIO m => Peer -> RefDigest -> Word64 -> (DataRequestResult -> ExceptT ErebosError IO ()) -> m ()
+requestDataFromPeer peer@Peer {..} dgst bound callback = do
+    liftIO $ atomically $ do
+        wref <- WaitingRef peerStorage_ (partialRefFromDigest peerInStorage dgst) bound callback <$> newTVar (Left [])
+        putTMVar peerWaitingRefs . (wref :) =<< takeTMVar peerWaitingRefs
+        writeTQueue (serverDataResponse peerServer_) ( peer, Nothing )
 
 
 foreign import ccall unsafe "Network/ifaddrs.h erebos_join_multicast" cJoinMulticast :: CInt -> Ptr CSize -> IO (Ptr Word32)
diff --git a/src/Erebos/Network/Protocol.hs b/src/Erebos/Network/Protocol.hs
--- a/src/Erebos/Network/Protocol.hs
+++ b/src/Erebos/Network/Protocol.hs
@@ -7,6 +7,7 @@
     SecurityRequirement(..),
 
     WaitingRef(..),
+    DataRequestResult(..),
     WaitingRefCallback,
     wrDigest,
 
@@ -111,8 +112,11 @@
     deriving (Eq, Show)
 
 newtype ServiceID = ServiceID UUID
-    deriving (Eq, Ord, Show, StorableUUID)
+    deriving (Eq, Ord, StorableUUID)
 
+instance Show ServiceID where
+    show = show . toUUID
+
 newtype Cookie = Cookie ByteString
     deriving (Eq, Show)
 
@@ -277,6 +281,8 @@
             writeTVar cChannel ChannelClosed
             writeTVar gConnections . filter (/=conn) =<< readTVar gConnections
             writeFlow cDataInternal Nothing
+            streams <- readTVar cInStreams
+            forM_ streams $ \( _, s ) -> writeFlow (sFlowIn s) (StreamClosed 0)
 
 connAddWriteStream :: Connection addr -> STM (Either String (TransportHeaderItem, RawStreamWriter, IO ()))
 connAddWriteStream conn@Connection {..} = do
@@ -461,9 +467,15 @@
 data WaitingRef = WaitingRef
     { wrefStorage :: Storage
     , wrefPartial :: PartialRef
-    , wrefAction :: Ref -> WaitingRefCallback
-    , wrefStatus :: TVar (Either [RefDigest] Ref)
+    , wrefBound :: Word64
+    , wrefAction :: DataRequestResult -> WaitingRefCallback
+    , wrefStatus :: TVar (Either [ RefDigest ] DataRequestResult)
     }
+
+data DataRequestResult
+    = DataRequestFulfilled Ref
+    | DataRequestRejected
+    | DataRequestBrokenBound
 
 type WaitingRefCallback = ExceptT ErebosError IO ()
 
diff --git a/src/Erebos/Network/Protocol.hs-boot b/src/Erebos/Network/Protocol.hs-boot
new file mode 100644
--- /dev/null
+++ b/src/Erebos/Network/Protocol.hs-boot
@@ -0,0 +1,6 @@
+module Erebos.Network.Protocol where
+
+import Erebos.UUID (UUID)
+
+newtype ServiceID = ServiceID UUID
+instance Show ServiceID
diff --git a/src/Erebos/Object.hs b/src/Erebos/Object.hs
--- a/src/Erebos/Object.hs
+++ b/src/Erebos/Object.hs
@@ -18,6 +18,44 @@
     readRefDigest, showRefDigest,
     refDigestFromByteString, hashToRefDigest,
     copyRef, partialRef, partialRefFromDigest,
+
+    componentSize,
+    partialComponentSize,
 ) where
 
+import Data.ByteString.Lazy qualified as BL
+import Data.Maybe
+import Data.Set qualified as S
+import Data.Word
+
 import Erebos.Object.Internal
+
+
+componentSize :: Ref -> Word64
+componentSize ref = go S.empty [ ref ]
+  where
+    go seen (r : rs)
+        | refDigest r `S.member` seen = go seen rs
+        | otherwise = objectSize r + go (S.insert (refDigest r) seen) (referredFrom r ++ rs)
+    go _ [] = 0
+
+    objectSize = fromIntegral . BL.length . lazyLoadBytes
+    referredFrom r = case load r of
+        Rec items -> mapMaybe ((\case RecRef r' -> Just r'; _ -> Nothing) . snd) items
+        _ -> []
+
+partialComponentSize :: PartialRef -> IO Word64
+partialComponentSize ref = go S.empty [ ref ]
+  where
+    go seen (r : rs)
+        | refDigest r `S.member` seen = go seen rs
+        | otherwise = do
+            size <- objectSize r
+            referred <- referredFrom r
+            (size +) <$> go (S.insert (refDigest r) seen) (referred ++ rs)
+    go _ [] = return 0
+
+    objectSize r = either (const 0) (fromIntegral . BL.length) <$> ioLoadBytes r
+    referredFrom r = ioLoadObject r >>= return . \case
+        Right (Rec items) -> mapMaybe ((\case RecRef r' -> Just r'; _ -> Nothing) . snd) items
+        _ -> []
diff --git a/src/Erebos/Object/Deferred.hs b/src/Erebos/Object/Deferred.hs
new file mode 100644
--- /dev/null
+++ b/src/Erebos/Object/Deferred.hs
@@ -0,0 +1,108 @@
+module Erebos.Object.Deferred (
+    Deferred,
+    DeferredSize(..),
+    DeferredResult(..),
+
+    deferredRef,
+    deferredLoad,
+    deferredWait,
+    deferredCheck,
+
+    deferLoadWithServer,
+) where
+
+import Control.Concurrent.MVar
+import Control.Monad.IO.Class
+
+import Data.Word
+
+import Erebos.Identity
+import Erebos.Network
+import Erebos.Object
+import Erebos.Storable
+
+
+-- | Deffered value, which can be loaded on request. Holds a reference (digest)
+-- to an object and information about suitable network peers, from which the
+-- data can be requested.
+data Deferred a = Deferred
+    { deferredRef_ :: RefDigest
+    , deferredSize :: DeferredSize
+    , deferredServer :: Server
+    , deferredPeers :: [ RefDigest ]
+    , deferredStatus :: MVar (Maybe (MVar (DeferredResult a)))
+    }
+
+-- | Size constraint for the deferred object.
+data DeferredSize
+    = DeferredExactSize Word64 -- ^ Component size of the referred data must be exactly the given value.
+    | DeferredMaximumSize Word64 -- ^ Component size of the referred data must not exceed the given value.
+
+-- | Result of the deferred load request.
+data DeferredResult a
+    = DeferredLoaded (Stored a) -- ^ Deferred object was sucessfully loaded.
+    | DeferredInvalid -- ^ Deferred object was (partially) loaded, but failed to meet the size constraint or was an invalid object.
+    | DeferredFailed -- ^ Failure to load the object, e.g. no suitable peer was found.
+
+-- | Get the digest of the deferred object.
+deferredRef :: Deferred a -> RefDigest
+deferredRef = deferredRef_
+
+-- | Request the deferred object to be loaded. Does nothing if that was already
+-- requested before. The result can be received using `deferredWait` or
+-- `deferredCheck` functions.
+deferredLoad :: (Storable a, MonadIO m) => Deferred a -> m ()
+deferredLoad Deferred {..} = liftIO $ do
+    modifyMVar_ deferredStatus $ \case
+        Nothing -> do
+            mvar <- newEmptyMVar
+            let matchPeer peer =
+                    getPeerIdentity peer >>= \case
+                        PeerIdentityFull pid -> do
+                            return $ any (`elem` identityDigests pid) deferredPeers
+                        _ -> return False
+
+            liftIO (findPeer deferredServer matchPeer) >>= \case
+                Just peer -> do
+                    let bound = case deferredSize of
+                            DeferredExactSize s -> s
+                            DeferredMaximumSize s -> s
+
+                        checkSize ref = case deferredSize of
+                            DeferredExactSize s -> componentSize ref == s
+                            DeferredMaximumSize s -> componentSize ref <= s
+
+                    requestDataFromPeer peer deferredRef_ bound $ liftIO . \case
+                        DataRequestFulfilled ref
+                            | checkSize ref -> putMVar mvar $ DeferredLoaded $ wrappedLoad ref
+                            | otherwise -> putMVar mvar DeferredInvalid
+                        DataRequestRejected -> putMVar mvar DeferredFailed
+                        DataRequestBrokenBound -> putMVar mvar DeferredInvalid
+
+                Nothing -> putMVar mvar DeferredFailed
+            return $ Just mvar
+        cur@Just {} -> return cur
+
+-- | Wait for a `Deferred` value to be loaded and return the result. Requests
+-- the value to be loaded if that was not already done.
+deferredWait :: (Storable a, MonadIO m) => Deferred a -> m (DeferredResult a)
+deferredWait d@Deferred {..} = liftIO $ readMVar deferredStatus >>= \case
+    Nothing -> deferredLoad d >> deferredWait d
+    Just mvar -> readMVar mvar
+
+-- | Check if a `Deferred` value has already been loaded and return it in
+-- `Just` if so, otherwise return `Nothing`. Requests the value to be loaded if
+-- that was not already done.
+deferredCheck :: (Storable a, MonadIO m) => Deferred a -> m (Maybe (DeferredResult a))
+deferredCheck d@Deferred {..} = liftIO $ readMVar deferredStatus >>= \case
+    Nothing -> deferredLoad d >> deferredCheck d
+    Just mvar -> tryReadMVar mvar
+
+deferLoadWithServer :: (Storable a, MonadIO m) => RefDigest -> DeferredSize -> Server -> [ RefDigest ] -> m (Deferred a)
+deferLoadWithServer deferredRef_ deferredSize deferredServer deferredPeers = do
+    deferredStatus <- liftIO $ newMVar Nothing
+    return Deferred {..}
+
+
+identityDigests :: Foldable f => Identity f -> [ RefDigest ]
+identityDigests pid = map (refDigest . storedRef) $ idDataF =<< unfoldOwners pid
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
@@ -47,6 +47,8 @@
 ) where
 
 import Control.Applicative
+import Control.DeepSeq
+import Control.Exception
 import Control.Monad
 import Control.Monad.Except
 import Control.Monad.Reader
@@ -55,26 +57,27 @@
 import Crypto.Hash
 
 import Data.Bifunctor
+import Data.ByteArray qualified as BA
 import Data.ByteString (ByteString)
-import qualified Data.ByteArray as BA
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Char8 as BC
-import qualified Data.ByteString.Lazy as BL
-import qualified Data.ByteString.Lazy.Char8 as BLC
+import Data.ByteString qualified as B
+import Data.ByteString.Char8 qualified as BC
+import Data.ByteString.Lazy qualified as BL
+import Data.ByteString.Lazy.Char8 qualified as BLC
 import Data.Char
 import Data.Function
 import Data.Maybe
 import Data.Ratio
 import Data.Set (Set)
-import qualified Data.Set as S
+import Data.Set qualified as S
 import Data.Text (Text)
-import qualified Data.Text as T
+import Data.Text qualified as T
 import Data.Text.Encoding
 import Data.Text.Encoding.Error
 import Data.Time.Calendar
 import Data.Time.Clock
 import Data.Time.Format
 import Data.Time.LocalTime
+import Data.Word
 
 import System.IO.Unsafe
 
@@ -129,6 +132,7 @@
 copyObject' :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> Object' c -> IO (c (Object' c'))
 copyObject' _ (Blob bs) = return $ return $ Blob bs
 copyObject' st (Rec rs) = fmap Rec . sequence <$> mapM (\( n, item ) -> fmap ( n, ) <$> copyRecItem' st item) rs
+copyObject' _ (OnDemand size dgst) = return $ return $ OnDemand size dgst
 copyObject' _ ZeroObject = return $ return ZeroObject
 copyObject' _ (UnknownObject otype content) = return $ return $ UnknownObject otype content
 
@@ -150,7 +154,8 @@
 
 data Object' c
     = Blob ByteString
-    | Rec [(ByteString, RecItem' c)]
+    | Rec [ ( ByteString, RecItem' c ) ]
+    | OnDemand Word64 RefDigest
     | ZeroObject
     | UnknownObject ByteString ByteString
     deriving (Show)
@@ -176,8 +181,12 @@
 serializeObject :: Object' c -> BL.ByteString
 serializeObject = \case
     Blob cnt -> BL.fromChunks [BC.pack "blob ", BC.pack (show $ B.length cnt), BC.singleton '\n', cnt]
-    Rec rec -> let cnt = BL.fromChunks $ concatMap (uncurry serializeRecItem) rec
-                in BL.fromChunks [BC.pack "rec ", BC.pack (show $ BL.length cnt), BC.singleton '\n'] `BL.append` cnt
+    Rec rec ->
+        let cnt = BL.fromChunks $ concatMap (uncurry serializeRecItem) rec
+         in BL.fromChunks [ BC.pack "rec ", BC.pack (show $ BL.length cnt), BC.singleton '\n' ] `BL.append` cnt
+    OnDemand size dgst ->
+        let cnt = BC.unlines [ BC.pack (show size), showRefDigest dgst ]
+         in BL.fromChunks [ BC.pack "ondemand ", BC.pack (show $ B.length cnt), BC.singleton '\n', cnt ]
     ZeroObject -> BL.empty
     UnknownObject otype cnt -> BL.fromChunks [ otype, BC.singleton ' ', BC.pack (show $ B.length cnt), BC.singleton '\n', cnt ]
 
@@ -194,6 +203,12 @@
 storeRawBytes :: PartialStorage -> BL.ByteString -> IO PartialRef
 storeRawBytes = unsafeStoreRawBytes
 
+unsafeStoreRawBytes :: Storage' c -> BL.ByteString -> IO (Ref' c)
+unsafeStoreRawBytes st@Storage {..} raw = do
+    dgst <- evaluate $ force $ hashToRefDigest raw
+    backendStoreBytes stBackend dgst raw
+    return $ Ref st dgst
+
 serializeRecItem :: ByteString -> RecItem' c -> [ByteString]
 serializeRecItem name (RecEmpty) = [name, BC.pack ":e", BC.singleton ' ', BC.singleton '\n']
 serializeRecItem name (RecInt x) = [name, BC.pack ":i", BC.singleton ' ', BC.pack (show x), BC.singleton '\n']
@@ -236,47 +251,73 @@
         (line, rest) | Just (otype, len) <- splitObjPrefix line -> do
             let (content, next) = first BL.toStrict $ BL.splitAt (fromIntegral len) $ BL.drop 1 rest
             guard $ B.length content == len
-            (,next) <$> case otype of
-                 _ | otype == BC.pack "blob" -> return $ Blob content
-                   | otype == BC.pack "rec" -> maybe (throwOtherError $ "malformed record item ")
-                                                   (return . Rec) $ sequence $ map parseRecLine $ mergeCont [] $ BC.lines content
-                   | otherwise -> return $ UnknownObject otype content
+            (, next) <$> if
+                | otype == BC.pack "blob"
+                    -> return $ Blob content
+                | otype == BC.pack "rec"
+                , Just ritems <- parseRecordBody st content
+                    -> return $ Rec ritems
+                | otype == BC.pack "ondemand"
+                , Just ondemand <- parseOnDemand st content
+                    -> return ondemand
+                | otherwise
+                    -> return $ UnknownObject otype content
         _ -> throwOtherError $ "malformed object"
-    where splitObjPrefix line = do
-              [otype, tlen] <- return $ BLC.words line
-              (len, rest) <- BLC.readInt tlen
-              guard $ BL.null rest
-              return (BL.toStrict otype, len)
+  where
+    splitObjPrefix line = do
+        [ otype, tlen ] <- return $ BLC.words line
+        ( len, rest ) <- BLC.readInt tlen
+        guard $ BL.null rest
+        return ( BL.toStrict otype, len )
 
-          mergeCont cs (a:b:rest) | Just ('\t', b') <- BC.uncons b = mergeCont (b':BC.pack "\n":cs) (a:rest)
-          mergeCont cs (a:rest) = B.concat (a : reverse cs) : mergeCont [] rest
-          mergeCont _ [] = []
+parseRecordBody :: Storage' c -> ByteString -> Maybe [ ( ByteString, RecItem' c ) ]
+parseRecordBody _ body | B.null body = Just []
+parseRecordBody st body = do
+    colon <- BC.elemIndex ':' body
+    space <- BC.elemIndex ' ' $ B.drop (colon + 1) body
+    let name = B.take colon body
+        itype = B.take space $ B.drop (colon + 1) body
+    ( content, remainingBody ) <- parseTabEscapedLines $ B.drop (space + colon + 2) body
 
-          parseRecLine line = do
-              colon <- BC.elemIndex ':' line
-              space <- BC.elemIndex ' ' line
-              guard $ colon < space
-              let name = B.take colon line
-                  itype = B.take (space-colon-1) $ B.drop (colon+1) line
-                  content = B.drop (space+1) line
+    let val = fromMaybe (RecUnknown itype content) $
+            case BC.unpack itype of
+                "e" -> do guard $ B.null content
+                          return RecEmpty
+                "i" -> do ( num, rest ) <- BC.readInteger content
+                          guard $ B.null rest
+                          return $ RecInt num
+                "n" -> RecNum <$> parseRatio content
+                "t" -> return $ RecText $ decodeUtf8With lenientDecode content
+                "b" -> RecBinary <$> readHex content
+                "d" -> RecDate <$> parseTimeM False defaultTimeLocale "%s %z" (BC.unpack content)
+                "u" -> RecUUID <$> U.fromASCIIBytes content
+                "r" -> RecRef . Ref st <$> readRefDigest content
+                "w" -> RecWeak <$> readRefDigest content
+                _   -> Nothing
+    (( name, val ) :) <$> parseRecordBody st remainingBody
 
-              let val = fromMaybe (RecUnknown itype content) $
-                      case BC.unpack itype of
-                          "e" -> do guard $ B.null content
-                                    return RecEmpty
-                          "i" -> do (num, rest) <- BC.readInteger content
-                                    guard $ B.null rest
-                                    return $ RecInt num
-                          "n" -> RecNum <$> parseRatio content
-                          "t" -> return $ RecText $ decodeUtf8With lenientDecode content
-                          "b" -> RecBinary <$> readHex content
-                          "d" -> RecDate <$> parseTimeM False defaultTimeLocale "%s %z" (BC.unpack content)
-                          "u" -> RecUUID <$> U.fromASCIIBytes content
-                          "r" -> RecRef . Ref st <$> readRefDigest content
-                          "w" -> RecWeak <$> readRefDigest content
-                          _   -> Nothing
-              return (name, val)
+-- Split given ByteString on the first newline not preceded by tab; replace
+-- "\t\n" in the first part with "\n".
+parseTabEscapedLines :: ByteString -> Maybe ( ByteString, ByteString )
+parseTabEscapedLines = parseLines []
+  where
+    parseLines linesReversed cur = do
+        newline <- BC.elemIndex '\n' cur
+        case ( BC.length cur > newline + 1, BC.index cur (newline + 1) ) of
+            ( True, '\t' ) -> parseLines (B.take (newline + 1) cur : linesReversed) (B.drop (newline + 2) cur)
+            _              -> Just ( BC.concat $ reverse $ B.take newline cur : linesReversed, B.drop (newline + 1) cur )
 
+parseOnDemand :: Storage' c -> ByteString -> Maybe (Object' c)
+parseOnDemand _ body = do
+    newline1 <- BC.elemIndex '\n' body
+    newline2 <- BC.elemIndex '\n' $ B.drop (newline1 + 1) body
+    guard (newline1 + newline2 + 2 == B.length body)
+    ( size, sizeRest ) <- BC.readInt (B.take newline1 body)
+    guard (B.null sizeRest)
+    dgst <- readRefDigest $ B.take newline2 $ B.drop (newline1 + 1) body
+    return $ OnDemand (fromIntegral size) dgst
+
+
 deserializeObject :: PartialStorage -> BL.ByteString -> Except ErebosError (PartialObject, BL.ByteString)
 deserializeObject = unsafeDeserializeObject
 
@@ -332,10 +373,12 @@
 class Storable a => ZeroStorable a where
     fromZero :: Storage -> a
 
-data Store = StoreBlob ByteString
-           | StoreRec (forall c. StorageCompleteness c => Storage' c -> [IO [(ByteString, RecItem' c)]])
-           | StoreZero
-           | StoreUnknown ByteString ByteString
+data Store
+    = StoreBlob ByteString
+    | StoreRec (forall c. StorageCompleteness c => Storage' c -> [IO [(ByteString, RecItem' c)]])
+    | StoreOnDemand Word64 RefDigest
+    | StoreZero
+    | StoreUnknown ByteString ByteString
 
 evalStore :: StorageCompleteness c => Storage' c -> Store -> IO (Ref' c)
 evalStore st = unsafeStoreObject st <=< evalStoreObject st
@@ -343,6 +386,7 @@
 evalStoreObject :: StorageCompleteness c => Storage' c -> Store -> IO (Object' c)
 evalStoreObject _ (StoreBlob x) = return $ Blob x
 evalStoreObject s (StoreRec f) = Rec . concat <$> sequence (f s)
+evalStoreObject _ (StoreOnDemand size dgst) = return $ OnDemand size dgst
 evalStoreObject _ StoreZero = return ZeroObject
 evalStoreObject _ (StoreUnknown otype content) = return $ UnknownObject otype content
 
@@ -379,6 +423,7 @@
     store' (Rec xs) = StoreRec $ \st -> return $ do
         Rec xs' <- copyObject st (Rec xs)
         return xs'
+    store' (OnDemand size dgst) = StoreOnDemand size dgst
     store' ZeroObject = StoreZero
     store' (UnknownObject otype content) = StoreUnknown otype content
 
diff --git a/src/Erebos/Storable.hs b/src/Erebos/Storable.hs
--- a/src/Erebos/Storable.hs
+++ b/src/Erebos/Storable.hs
@@ -11,6 +11,7 @@
 module Erebos.Storable (
     Storable(..), ZeroStorable(..),
     StorableText(..), StorableDate(..), StorableUUID(..),
+    StorageCompleteness(..),
 
     Store, StoreRec,
     storeBlob, storeRec, storeZero,
@@ -30,7 +31,7 @@
     loadZRef,
 
     Stored,
-    fromStored, storedRef,
+    fromStored, storedRef, refDigest,
     wrappedStore, wrappedLoad,
     copyStored,
     unsafeMapStored,
diff --git a/src/Erebos/Storage/Backend.hs b/src/Erebos/Storage/Backend.hs
--- a/src/Erebos/Storage/Backend.hs
+++ b/src/Erebos/Storage/Backend.hs
@@ -9,12 +9,17 @@
     Complete, Partial,
     Storage, PartialStorage,
     newStorage,
+    withStorageBackend,
 
+    refDigestBytes,
+
     WatchID, startWatchID, nextWatchID,
 ) where
 
 import Control.Concurrent.MVar
 
+import Data.ByteArray qualified as BA
+import Data.ByteString (ByteString)
 import Data.HashTable.IO qualified as HT
 
 import Erebos.Object.Internal
@@ -26,3 +31,10 @@
     stRefGeneration <- newMVar =<< HT.new
     stRefRoots <- newMVar =<< HT.new
     return Storage {..}
+
+withStorageBackend :: Storage' c -> (forall bck. (StorageBackend bck, BackendCompleteness bck ~ c) => bck -> IO a) -> IO a
+withStorageBackend Storage {..} f = f stBackend
+
+
+refDigestBytes :: RefDigest -> ByteString
+refDigestBytes = BA.convert
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
@@ -15,7 +15,6 @@
     StorageBackend(..),
     Complete, Partial,
 
-    unsafeStoreRawBytes,
     ioLoadBytesFromStorage,
 
     Generation(..),
@@ -26,7 +25,6 @@
 import Control.Arrow
 import Control.Concurrent
 import Control.DeepSeq
-import Control.Exception
 import Control.Monad.Identity
 
 import Crypto.Hash
@@ -274,12 +272,6 @@
     type LoadResult Partial a = Either RefDigest a
     returnLoadResult = id
     ioLoadBytes (Ref st dgst) = maybe (Left dgst) Right <$> ioLoadBytesFromStorage st dgst
-
-unsafeStoreRawBytes :: Storage' c -> BL.ByteString -> IO (Ref' c)
-unsafeStoreRawBytes st@Storage {..} raw = do
-    dgst <- evaluate $ force $ hashToRefDigest raw
-    backendStoreBytes stBackend dgst raw
-    return $ Ref st dgst
 
 ioLoadBytesFromStorage :: Storage' c -> RefDigest -> IO (Maybe BL.ByteString)
 ioLoadBytesFromStorage Storage {..} dgst =
diff --git a/src/Erebos/TextFormat.hs b/src/Erebos/TextFormat.hs
new file mode 100644
--- /dev/null
+++ b/src/Erebos/TextFormat.hs
@@ -0,0 +1,79 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Erebos.TextFormat (
+    FormattedText,
+    plainText,
+
+    TextStyle,
+    withStyle, noStyle,
+
+    Color(..),
+    setForegroundColor, setBackgroundColor,
+
+    endWithNewline,
+
+    renderPlainText,
+    formattedTextLength,
+    formattedTextHeight,
+) where
+
+import Data.Text (Text)
+import Data.Text qualified as T
+
+import Erebos.TextFormat.Types
+
+
+plainText :: Text -> FormattedText
+plainText = PlainText
+
+
+withStyle :: TextStyle -> FormattedText -> FormattedText
+withStyle = FormattedText
+
+noStyle :: TextStyle
+noStyle = CustomTextColor Nothing Nothing
+
+setForegroundColor :: Color -> TextStyle -> TextStyle
+setForegroundColor color (CustomTextColor _ bg) = CustomTextColor (Just color) bg
+
+setBackgroundColor :: Color -> TextStyle -> TextStyle
+setBackgroundColor color (CustomTextColor fg _) = CustomTextColor fg (Just color)
+
+
+endWithNewline :: FormattedText -> FormattedText
+endWithNewline = EndWithNewline
+
+
+renderPlainText :: FormattedText -> Text
+renderPlainText = \case
+    PlainText text -> text
+    ConcatenatedText ftexts -> mconcat $ map renderPlainText ftexts
+    FormattedText _ ftext -> renderPlainText ftext
+    EndWithNewline ftext -> let res = renderPlainText ftext
+                             in case T.unsnoc res of
+                                    Just ( _, '\n') -> res
+                                    _               -> res <> "\n"
+
+formattedTextLength :: FormattedText -> Int
+formattedTextLength = \case
+    PlainText text -> T.length text
+    ConcatenatedText ftexts -> sum $ map formattedTextLength ftexts
+    FormattedText _ ftext -> formattedTextLength ftext
+    EndWithNewline ftext -> formattedTextLength ftext
+
+formattedTextHeight :: FormattedText -> Int
+formattedTextHeight = countLines . collectParts
+  where
+    collectParts = \case
+        PlainText text -> [ text ]
+        ConcatenatedText ftexts -> concatMap collectParts ftexts
+        FormattedText _ ftext -> collectParts ftext
+        EndWithNewline ftext -> collectParts ftext
+    countLines (t : ts)
+        | T.null t = countLines ts
+        | otherwise = 1 + countLines (dropLine (t : ts))
+    countLines [] = 0
+    dropLine (t : ts)
+        | Just ( '\n', t' ) <- T.uncons (T.dropWhile (/= '\n') t) = t' : ts
+        | otherwise = dropLine ts
+    dropLine [] = []
diff --git a/src/Erebos/TextFormat/Ansi.hs b/src/Erebos/TextFormat/Ansi.hs
new file mode 100644
--- /dev/null
+++ b/src/Erebos/TextFormat/Ansi.hs
@@ -0,0 +1,83 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Erebos.TextFormat.Ansi (
+    FormattedText,
+
+    AnsiText(..),
+    renderAnsiText,
+) where
+
+import Control.Applicative
+import Control.Monad.State
+import Control.Monad.Writer
+
+import Data.String
+import Data.Text (Text)
+import Data.Text qualified as T
+
+import Erebos.TextFormat.Types
+
+
+newtype AnsiText = AnsiText { fromAnsiText :: Text }
+    deriving (Eq, Ord, Semigroup, Monoid, IsString)
+
+
+data RenderState = RenderState
+    { rsEndedWithNewline :: Bool
+    }
+
+initialRenderState :: RenderState
+initialRenderState = RenderState
+    { rsEndedWithNewline = True
+    }
+
+renderAnsiText :: FormattedText -> AnsiText
+renderAnsiText ft = AnsiText $ T.concat $ execWriter $ flip evalStateT initialRenderState $ go ( Nothing, Nothing ) ft
+  where
+    go :: ( Maybe Color, Maybe Color ) -> FormattedText -> StateT RenderState (Writer [ Text ]) ()
+    go cur@( cfg, cbg ) = \case
+        PlainText text -> do
+            tell [ text ]
+            case T.unsnoc text of
+                Just ( _, c ) -> modify (\s -> s { rsEndedWithNewline = c == '\n' })
+                Nothing -> return ()
+        ConcatenatedText ftexts -> mconcat <$> mapM (go cur) ftexts
+        FormattedText (CustomTextColor fg bg) ftext -> do
+            tell [ ansiColor fg bg ]
+            go ( fg <|> cfg, bg <|> cbg ) ftext
+            tell [ ansiColor
+                (if fg /= cfg then cfg <|> Just DefaultColor else Nothing)
+                (if bg /= cbg then cbg <|> Just DefaultColor else Nothing)
+                ]
+        EndWithNewline ftext -> do
+            go cur ftext
+            gets rsEndedWithNewline >>= \case
+                True -> return ()
+                False -> tell [ "\n" ] >> modify (\s -> s { rsEndedWithNewline = True })
+
+
+ansiColor :: Maybe Color -> Maybe Color -> Text
+ansiColor Nothing Nothing = ""
+ansiColor (Just fg) Nothing = "\ESC[" <> T.pack (show (colorNum fg)) <> "m"
+ansiColor Nothing (Just bg) = "\ESC[" <> T.pack (show (colorNum bg + 10)) <> "m"
+ansiColor (Just fg) (Just bg) = "\ESC[" <> T.pack (show (colorNum fg)) <> ";" <> T.pack (show (colorNum bg + 10)) <> "m"
+
+colorNum :: Color -> Int
+colorNum = \case
+    DefaultColor -> 39
+    Black -> 30
+    Red -> 31
+    Green -> 32
+    Yellow -> 33
+    Blue -> 34
+    Magenta -> 35
+    Cyan -> 36
+    White -> 37
+    BrightBlack -> 90
+    BrightRed -> 91
+    BrightGreen -> 92
+    BrightYellow -> 93
+    BrightBlue -> 94
+    BrightMagenta -> 95
+    BrightCyan -> 96
+    BrightWhite -> 97
diff --git a/src/Erebos/TextFormat/Types.hs b/src/Erebos/TextFormat/Types.hs
new file mode 100644
--- /dev/null
+++ b/src/Erebos/TextFormat/Types.hs
@@ -0,0 +1,58 @@
+module Erebos.TextFormat.Types (
+    FormattedText(..),
+    TextStyle(..),
+    Color(..),
+) where
+
+import Data.String
+import Data.Text (Text)
+
+
+data FormattedText
+    = PlainText Text
+    | ConcatenatedText [ FormattedText ]
+    | FormattedText TextStyle FormattedText
+    | EndWithNewline FormattedText
+
+instance IsString FormattedText where
+    fromString = PlainText . fromString
+
+instance Semigroup FormattedText where
+    ConcatenatedText xs <> ConcatenatedText ys = ConcatenatedText (xs ++ ys)
+    x <> ConcatenatedText ys = ConcatenatedText (x : ys)
+    ConcatenatedText xs <> y = ConcatenatedText (xs ++ [ y ])
+    x <> y = ConcatenatedText [ x, y ]
+
+instance Monoid FormattedText where
+    mempty = ConcatenatedText []
+    mconcat [] = ConcatenatedText []
+    mconcat [ x ] = x
+    mconcat xs = ConcatenatedText $ concatMap flatten xs
+      where
+        flatten (ConcatenatedText ys) = ys
+        flatten y = [ y ]
+
+
+data TextStyle
+    = CustomTextColor (Maybe Color) (Maybe Color)
+
+
+data Color
+    = DefaultColor
+    | Black
+    | Red
+    | Green
+    | Yellow
+    | Blue
+    | Magenta
+    | Cyan
+    | White
+    | BrightBlack
+    | BrightRed
+    | BrightGreen
+    | BrightYellow
+    | BrightBlue
+    | BrightMagenta
+    | BrightCyan
+    | BrightWhite
+    deriving (Eq)