erebos 0.1.4 → 0.1.5

raw patch · 14 files changed

+758/−172 lines, 14 filesdep +Win32dep +fsnotifydep −hinotifydep ~unixdep ~uuidPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: Win32, fsnotify

Dependencies removed: hinotify

Dependency ranges changed: unix, uuid

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• README.md +64/−34
• erebos.cabal +14/−4
• main/Main.hs +161/−7
• main/Test.hs +81/−3
• src/Erebos/Chatroom.hs +163/−22
• src/Erebos/Conversation.hs +33/−3
• src/Erebos/Network.hs +10/−6
• src/Erebos/Network/Protocol.hs +51/−15
• src/Erebos/Network/ifaddrs.c +50/−0
• src/Erebos/Storage.hs +78/−53
• src/Erebos/Storage/Internal.hs +14/−25
• src/unix/Erebos/Storage/Platform.hs +20/−0
• src/windows/Erebos/Storage/Platform.hs +13/−0

@@ -1,5 +1,11 @@ # Revision history for erebos +## 0.1.5 -- 2024-07-16++* Public chatrooms for multiple participants+* Send keep-alive packets on idle connection+* Windows support+ ## 0.1.4 -- 2024-06-11  * Added `/conversations` command to list and select conversations

@@ -60,7 +60,8 @@ [1] PEER UPD discovery1.erebosprotocol.net [37.221.243.57 29665] ``` -Select the peer and send it a message, the public server just responds with automatic echo message:+Select the peer and send it a message, the public server just responds with+automatic echo message: ``` > /1 discovery1.erebosprotocol.net> hello@@ -68,31 +69,58 @@ [18:55] discovery1.erebosprotocol.net: Echo: hello ``` +List chatrooms known to the peers:+```+> /chatrooms+[1] Test chatroom+[2] Second test chatroom+```++Enter a chatroom and send a message there:+```+> /1+Test chatroom> Hi+Test chatroom [19:03] Some Name: Hi+```+ ### Messaging  `/peers`  -List peers with direct network connection. Peers are discovered automatically-on local network or can be manually added.+: List peers with direct network connection. Peers are discovered automatically+  on local network or can be manually added.  `/contacts`  -List known contacts (see below).+: List known contacts (see below).  `/conversations`  -List started conversations with contacts or other peers.+: List started conversations with contacts or other peers.  `/<number>`  -Select conversation, contact or peer `<number>` based on the last-`/conversations`, `/contacts` or `/peers` output list.+: Select conversation, contact or peer `<number>` based on the last+  `/conversations`, `/contacts` or `/peers` output list.  `<message>`  -Send `<message>` to selected conversation.+: Send `<message>` to selected conversation.  `/history`  -Show message history of the selected conversation.+: Show message history of the selected conversation.  `/details`  -Show information about the selected conversations, contact or peer.+: Show information about the selected conversations, contact or peer. +### Chatrooms++Currently only public unmoderated chatrooms are supported, which means that any+network peer is allowed to read and post to the chatroom. Individual messages+are signed, so message author can not be forged.++`/chatrooms`  +: List known chatrooms.++`/chatroom-create-public [<name>]`  +: Create public unmoderated chatroom. Room name can be passed as command+  argument or entered interactively.+ ### Add contacts  To ensure the identity of the contact and prevent man-in-the-middle attack,@@ -101,21 +129,22 @@ new contact, list peers using `/peers` command and select one with `/<number>`.  `/contacts`  -List already added contacts.+: List already added contacts.  `/contact-add`  -Add selected peer as contact. Six-digit verification code will be computed-based on peer keys, which will be displayed on both devices and needs to be-checked that both numbers are same. After that it needs to be confirmed using-`/contact-accept` to finish the process.+: Add selected peer as contact. Six-digit verification code will be computed+  based on peer keys, which will be displayed on both devices and needs to be+  checked that both numbers are same. After that it needs to be confirmed using+  `/contact-accept` to finish the process.  `/contact-accept`  -Confirm that displayed verification codes are same on both devices and add the-selected peer as contact. The side, which did not initiate the contact adding-process, needs to select the corresponding peer with `/<number>` command first.+: Confirm that displayed verification codes are same on both devices and add+  the selected peer as contact. The side, which did not initiate the contact+  adding process, needs to select the corresponding peer with `/<number>`+  command first.  `/contact-reject`  -Reject contact request or verification code of selected peer.+: Reject contact request or verification code of selected peer.  ### Attach other devices @@ -134,37 +163,38 @@ target device with `/<number>`.  `/attach`  -Attach current device to the selected peer. After the process completes the-owner of the selected peer will become owner of this device as well. Six-digit-verification code will be displayed on both devices and the user needs to check-that both are the same before confirmation using the `/attach-accept` command.+: Attach current device to the selected peer. After the process completes the+  owner of the selected peer will become owner of this device as well.+  Six-digit verification code will be displayed on both devices and the user+  needs to check that both are the same before confirmation using the+  `/attach-accept` command.  `/attach-accept`  -Confirm that displayed verification codes are same on both devices and complete-the attachment process (or wait for the confirmation on the peer device). The-side, which did not initiate the attachment process, needs to select the-corresponding peer with `/<number>` command first.+: Confirm that displayed verification codes are same on both devices and+  complete the attachment process (or wait for the confirmation on the peer+  device). The side, which did not initiate the attachment process, needs to+  select the corresponding peer with `/<number>` command first.  `/attach-reject`  -Reject device attachment request or verification code of selected peer.+: Reject device attachment request or verification code of selected peer.  ### Other  `/peer-add <host> [<port>]`  -Manually add network peer with given hostname or IP address.+: Manually add network peer with given hostname or IP address.  `/peer-add-public`  -Add known public network peer(s).+: Add known public network peer(s).  `/peer-drop`  -Drop the currently selected peer. Afterwards, the connection can be-re-established by either side.+: Drop the currently selected peer. Afterwards, the connection can be+  re-established by either side.  `/update-identity`  -Interactively update current identity information+: Interactively update current identity information  `/quit`  -Quit the erebos tool.+: Quit the erebos tool.   Storage

@@ -1,7 +1,7 @@-Cabal-Version:       2.2+Cabal-Version:       3.0  Name:                erebos-Version:             0.1.4+Version:             0.1.5 Synopsis:            Decentralized messaging and synchronization Description:     Library and simple CLI interface implementing the Erebos identity@@ -117,6 +117,7 @@     other-modules:         Erebos.Flow         Erebos.Storage.List+        Erebos.Storage.Platform         Erebos.Util      c-sources:@@ -147,9 +148,9 @@         deepseq >= 1.4 && <1.6,         directory >= 1.3 && <1.4,         filepath >=1.4 && <1.6,+        fsnotify ^>= { 0.4 },         hashable >=1.3 && <1.5,         hashtables >=1.2 && <1.4,-        hinotify >=0.4 && <0.5,         iproute >=1.7.12 && <1.8,         memory >=0.14 && <0.19,         mtl >=2.2 && <2.4,@@ -157,10 +158,18 @@         stm >=2.5 && <2.6,         text >= 1.2 && <2.2,         time >= 1.8 && <1.14,-        unix >=2.7 && <2.9,         uuid >=1.3 && <1.4,         zlib >=0.6 && <0.8 +    if os(windows)+        hs-source-dirs: src/windows+        build-depends:+            Win32 ^>= { 2.14 },+    else+        hs-source-dirs: src/unix+        build-depends:+            unix ^>= { 2.7, 2.8 },+ executable erebos     import: common     default-language:    Haskell2010@@ -190,3 +199,4 @@         text,         time,         transformers >= 0.5 && <0.7,+        uuid,

@@ -24,6 +24,7 @@ import Data.Text qualified as T import Data.Text.Encoding qualified as T import Data.Text.IO qualified as T+import Data.Time.Format import Data.Time.LocalTime import Data.Typeable @@ -37,6 +38,7 @@  import Erebos.Attach import Erebos.Contact+import Erebos.Chatroom import Erebos.Conversation #ifdef ENABLE_ICE_SUPPORT import Erebos.Discovery@@ -59,6 +61,7 @@ data Options = Options     { optServer :: ServerOptions     , optServices :: [ServiceOption]+    , optChatroomAutoSubscribe :: Maybe Int     , optDmBotEcho :: Maybe Text     , optShowHelp :: Bool     , optShowVersion :: Bool@@ -75,6 +78,7 @@ defaultOptions = Options     { optServer = defaultServerOptions     , optServices = availableServices+    , optChatroomAutoSubscribe = Nothing     , optDmBotEcho = Nothing     , optShowHelp = False     , optShowVersion = False@@ -86,6 +90,8 @@         True "attach (to) other devices"     , ServiceOption "sync" (someService @SyncService Proxy)         True "synchronization with attached devices"+    , ServiceOption "chatroom" (someService @ChatroomService Proxy)+        True "chatrooms with multiple participants"     , ServiceOption "contact" (someService @ContactService Proxy)         True "create contacts with network peers"     , ServiceOption "dm" (someService @DirectMessage Proxy)@@ -104,6 +110,9 @@     , Option ['s'] ["silent"]         (NoArg (so $ \opts -> opts { serverLocalDiscovery = False }))         "do not send announce packets for local discovery"+    , Option [] ["chatroom-auto-subscribe"]+        (ReqArg (\count -> \opts -> opts { optChatroomAutoSubscribe = Just (read count) }) "<count>")+        "automatically subscribe for up to <count> chatrooms"     , Option [] ["dm-bot-echo"]         (ReqArg (\prefix -> \opts -> opts { optDmBotEcho = Just (T.pack prefix) }) "<prefix>")         "automatically reply to direct messages with the same text prefixed with <prefix>"@@ -235,6 +244,7 @@                             PeerIdentityRef wref _ -> "<" ++ BC.unpack (showRefDigest $ wrDigest wref) ++ ">"                             PeerIdentityUnknown _  -> "<unknown>"                         SelectedContact contact -> return $ T.unpack $ contactName contact+                        SelectedChatroom rstate -> return $ T.unpack $ fromMaybe (T.pack "<unnamed>") $ roomName =<< roomStateRoom rstate                         SelectedConversation conv -> return $ T.unpack $ conversationName conv                     return $ pname ++ "> "                 Right prompt -> return prompt@@ -281,13 +291,20 @@                         Right reply -> extPrintLn $ formatDirectMessage tzone $ fromStored reply                         Left err -> extPrintLn $ "Failed to send dm echo: " <> err +    peers <- liftIO $ newMVar []+    contextOptions <- liftIO $ newMVar []+    chatroomSetVar <- liftIO $ newEmptyMVar++    let autoSubscribe = optChatroomAutoSubscribe opts+        chatroomList = fromSetBy (comparing roomStateData) . lookupSharedValue . lsShared . headObject $ erebosHead+    watched <- if isJust autoSubscribe || any roomStateSubscribe chatroomList+        then fmap Just $ liftIO $ watchChatroomsForCli extPrintLn erebosHead chatroomSetVar contextOptions autoSubscribe+        else return Nothing+     server <- liftIO $ do         startServer (optServer opts) erebosHead extPrintLn $             map soptService $ filter soptEnabled $ optServices opts -    peers <- liftIO $ newMVar []-    contextOptions <- liftIO $ newMVar []-     void $ liftIO $ forkIO $ void $ forever $ do         peer <- getNextPeerChange server         peerIdentity peer >>= \case@@ -320,11 +337,14 @@                 { ciServer = server                 , ciLine = line                 , ciPrint = extPrintLn+                , ciOptions = opts                 , ciPeers = liftIO $ modifyMVar peers $ \ps -> do                     ps' <- filterM (fmap not . isPeerDropped . fst) ps                     return (ps', ps')                 , ciContextOptions = liftIO $ readMVar contextOptions                 , ciSetContextOptions = \ctxs -> liftIO $ modifyMVar_ contextOptions $ const $ return ctxs+                , ciContextOptionsVar = contextOptions+                , ciChatroomSetVar = chatroomSetVar                 }             case res of                 Right cstate'@@ -343,6 +363,7 @@         , csIceSessions = [] #endif         , csIcePeer = Nothing+        , csWatchChatrooms = watched         , csQuit = False         } @@ -351,9 +372,12 @@     { ciServer :: Server     , ciLine :: String     , ciPrint :: String -> IO ()+    , ciOptions :: Options     , ciPeers :: CommandM [(Peer, String)]     , ciContextOptions :: CommandM [CommandContext]     , ciSetContextOptions :: [CommandContext] -> Command+    , ciContextOptionsVar :: MVar [ CommandContext ]+    , ciChatroomSetVar :: MVar (Set ChatroomState)     }  data CommandState = CommandState@@ -363,12 +387,14 @@     , csIceSessions :: [IceSession] #endif     , csIcePeer :: Maybe Peer+    , csWatchChatrooms :: Maybe WatchedHead     , csQuit :: Bool     }  data CommandContext = NoContext                     | SelectedPeer Peer                     | SelectedContact Contact+                    | SelectedChatroom ChatroomState                     | SelectedConversation Conversation  newtype CommandM a = CommandM (ReaderT CommandInput (StateT CommandState (ExceptT String IO)) a)@@ -410,6 +436,10 @@     SelectedContact contact -> case contactIdentity contact of         Just cid -> directMessageConversation cid         Nothing -> throwError "contact without erebos identity"+    SelectedChatroom rstate ->+        chatroomConversation rstate >>= \case+            Just conv -> return conv+            Nothing -> throwError "invalid chatroom"     SelectedConversation conv -> reloadConversation conv     _ -> throwError "no contact, peer or conversation selected" @@ -425,6 +455,8 @@     , ("attach", cmdAttach)     , ("attach-accept", cmdAttachAccept)     , ("attach-reject", cmdAttachReject)+    , ("chatrooms", cmdChatrooms)+    , ("chatroom-create-public", cmdChatroomCreatePublic)     , ("contacts", cmdContacts)     , ("contact-add", cmdContactAdd)     , ("contact-accept", cmdContactAccept)@@ -496,16 +528,24 @@ cmdSelectContext = do     n <- read <$> asks ciLine     join (asks ciContextOptions) >>= \ctxs -> if-        | n > 0, (ctx : _) <- drop (n - 1) ctxs -> modify $ \s -> s { csContext = ctx }+        | n > 0, (ctx : _) <- drop (n - 1) ctxs -> do+            modify $ \s -> s { csContext = ctx }+            case ctx of+                SelectedChatroom rstate -> do+                    when (not (roomStateSubscribe rstate)) $ do+                        chatroomSetSubscribe (head $ roomStateData rstate) True+                _ -> return ()         | otherwise -> throwError "invalid index"  cmdSend :: Command cmdSend = void $ do     text <- asks ciLine     conv <- getSelectedConversation-    msg <- sendMessage conv $ T.pack text-    tzone <- liftIO $ getCurrentTimeZone-    liftIO $ putStrLn $ formatMessage tzone msg+    sendMessage conv (T.pack text) >>= \case+        Just msg -> do+            tzone <- liftIO $ getCurrentTimeZone+            liftIO $ putStrLn $ formatMessage tzone msg+        Nothing -> return ()  cmdHistory :: Command cmdHistory = void $ do@@ -530,6 +570,110 @@ cmdAttachReject :: Command cmdAttachReject = attachReject =<< getSelectedPeer +watchChatroomsForCli :: (String -> IO ()) -> Head LocalState -> MVar (Set ChatroomState) -> MVar [ CommandContext ] -> Maybe Int -> IO WatchedHead+watchChatroomsForCli eprint h chatroomSetVar contextVar autoSubscribe = do+    subscribedNumVar <- newEmptyMVar++    let ctxUpdate updateType (idx :: Int) rstate = \case+            SelectedChatroom rstate' : rest+                | currentRoots <- filterAncestors (concatMap storedRoots $ roomStateData rstate)+                , any ((`intersectsSorted` currentRoots) . storedRoots) $ roomStateData rstate'+                -> do+                    eprint $ "[" <> 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+                    return [ SelectedChatroom rstate ]+          where+            name = maybe "<unnamed>" T.unpack $ roomName =<< roomStateRoom rstate++    watchChatrooms h $ \set -> \case+        Nothing -> do+            let chatroomList = fromSetBy (comparing roomStateData) set+                (subscribed, notSubscribed) = partition roomStateSubscribe chatroomList+                subscribedNum = length subscribed++            putMVar chatroomSetVar set+            putMVar subscribedNumVar subscribedNum++            case autoSubscribe of+                Nothing -> return ()+                Just num -> do+                    forM_ (take (num - subscribedNum) notSubscribed) $ \rstate -> do+                        (runExceptT $ flip runReaderT h $ chatroomSetSubscribe (head $ roomStateData rstate) True) >>= \case+                             Right () -> return ()+                             Left err -> eprint err++        Just diff -> do+            modifyMVar_ chatroomSetVar $ return . const set+            forM_ diff $ \case+                AddedChatroom rstate -> do+                    modifyMVar_ contextVar $ ctxUpdate "NEW" 1 rstate+                    modifyMVar_ subscribedNumVar $ return . if roomStateSubscribe rstate then (+ 1) else id++                RemovedChatroom rstate -> do+                    modifyMVar_ contextVar $ ctxUpdate "DEL" 1 rstate+                    modifyMVar_ subscribedNumVar $ return . if roomStateSubscribe rstate then subtract 1 else id++                UpdatedChatroom oldroom rstate -> do+                    when (any ((\rsd -> not (null (rsdRoom rsd))) . fromStored) (roomStateData rstate)) $ do+                        modifyMVar_ contextVar $ ctxUpdate "UPD" 1 rstate+                    when (any (not . null . rsdMessages . fromStored) (roomStateData rstate)) $ do+                        tzone <- getCurrentTimeZone+                        forM_ (reverse $ getMessagesSinceState rstate oldroom) $ \msg -> do+                            eprint $ concat $+                                [ maybe "<unnamed>" T.unpack $ roomName =<< cmsgRoom msg+                                , formatTime defaultTimeLocale " [%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ cmsgTime msg+                                , maybe "<unnamed>" T.unpack $ idName $ cmsgFrom msg+                                , ": "+                                , maybe "<no message>" T.unpack $ cmsgText msg+                                ]+                    modifyMVar_ subscribedNumVar $ return+                        . (if roomStateSubscribe rstate then (+ 1) else id)+                        . (if roomStateSubscribe oldroom then subtract 1 else id)++ensureWatchedChatrooms :: Command+ensureWatchedChatrooms = do+    gets csWatchChatrooms >>= \case+        Nothing -> do+            eprint <- asks ciPrint+            h <- gets csHead+            chatroomSetVar <- asks ciChatroomSetVar+            contextVar <- asks ciContextOptionsVar+            autoSubscribe <- asks $ optChatroomAutoSubscribe . ciOptions+            watched <- liftIO $ watchChatroomsForCli eprint h chatroomSetVar contextVar autoSubscribe+            modify $ \s -> s { csWatchChatrooms = Just watched }+        Just _ -> return ()++cmdChatrooms :: Command+cmdChatrooms = do+    ensureWatchedChatrooms+    chatroomSetVar <- asks ciChatroomSetVar+    chatroomList <- fromSetBy (comparing roomStateData) <$> liftIO (readMVar chatroomSetVar)+    set <- asks ciSetContextOptions+    set $ map SelectedChatroom chatroomList+    forM_ (zip [1..] chatroomList) $ \(i :: Int, rstate) -> do+        liftIO $ putStrLn $ "[" ++ show i ++ "] " ++ maybe "<unnamed>" T.unpack (roomName =<< roomStateRoom rstate)++cmdChatroomCreatePublic :: Command+cmdChatroomCreatePublic = do+    name <- asks ciLine >>= \case+        line | not (null line) -> return $ T.pack line+        _ -> liftIO $ do+            T.putStr $ T.pack "Name: "+            hFlush stdout+            T.getLine++    ensureWatchedChatrooms+    void $ createChatroom+        (if T.null name then Nothing else Just name)+        Nothing++ cmdContacts :: Command cmdContacts = do     args <- words <$> asks ciLine@@ -586,6 +730,9 @@         SelectedContact contact -> do             printContactDetails contact +        SelectedChatroom rstate -> do+            liftIO $ putStrLn $ "Chatroom: " <> (T.unpack $ fromMaybe (T.pack "<unnamed>") $ roomName =<< roomStateRoom rstate)+         SelectedConversation conv -> do             case conversationPeer conv of                 Just pid -> printContactOrIdentityDetails pid@@ -703,3 +850,10 @@  cmdQuit :: Command cmdQuit = modify $ \s -> s { csQuit = True }+++intersectsSorted :: Ord a => [a] -> [a] -> Bool+intersectsSorted (x:xs) (y:ys) | x < y     = intersectsSorted xs (y:ys)+                               | x > y     = intersectsSorted (x:xs) ys+                               | otherwise = True+intersectsSorted _ _ = False

@@ -12,6 +12,7 @@  import Crypto.Random +import Data.Bool import Data.ByteString qualified as B import Data.ByteString.Char8 qualified as BC import Data.ByteString.Lazy qualified as BL@@ -22,6 +23,7 @@ import Data.Text.Encoding import Data.Text.IO qualified as T import Data.Typeable+import Data.UUID qualified as U  import Network.Socket @@ -50,6 +52,8 @@ data TestState = TestState     { tsHead :: Maybe (Head LocalState)     , tsServer :: Maybe RunningServer+    , tsWatchedHeads :: [ ( Int, WatchedHead ) ]+    , tsWatchedHeadNext :: Int     , tsWatchedLocalIdentity :: Maybe WatchedHead     , tsWatchedSharedIdentity :: Maybe WatchedHead     }@@ -64,6 +68,8 @@ initTestState = TestState     { tsHead = Nothing     , tsServer = Nothing+    , tsWatchedHeads = []+    , tsWatchedHeadNext = 1     , tsWatchedLocalIdentity = Nothing     , tsWatchedSharedIdentity = Nothing     }@@ -242,6 +248,10 @@     , ("stored-roots", cmdStoredRoots)     , ("stored-set-add", cmdStoredSetAdd)     , ("stored-set-list", cmdStoredSetList)+    , ("head-create", cmdHeadCreate)+    , ("head-replace", cmdHeadReplace)+    , ("head-watch", cmdHeadWatch)+    , ("head-unwatch", cmdHeadUnwatch)     , ("create-identity", cmdCreateIdentity)     , ("start-server", cmdStartServer)     , ("stop-server", cmdStopServer)@@ -271,6 +281,8 @@     , ("chatroom-list-local", cmdChatroomListLocal)     , ("chatroom-watch-local", cmdChatroomWatchLocal)     , ("chatroom-set-name", cmdChatroomSetName)+    , ("chatroom-subscribe", cmdChatroomSubscribe)+    , ("chatroom-unsubscribe", cmdChatroomUnsubscribe)     , ("chatroom-message-send", cmdChatroomMessageSend)     ] @@ -318,6 +330,58 @@         cmdOut $ "stored-set-item" ++ concatMap ((' ':) . show . refDigest . storedRef) item     cmdOut $ "stored-set-done" +cmdHeadCreate :: Command+cmdHeadCreate = do+    [ ttid, tref ] <- asks tiParams+    st <- asks tiStorage+    Just tid <- return $ fromUUID <$> U.fromText ttid+    Just ref <- liftIO $ readRef st (encodeUtf8 tref)++    h <- storeHeadRaw st tid ref+    cmdOut $ unwords $ [ "head-create-done", show (toUUID tid), show (toUUID h) ]++cmdHeadReplace :: Command+cmdHeadReplace = do+    [ ttid, thid, told, tnew ] <- asks tiParams+    st <- asks tiStorage+    Just tid <- return $ fmap fromUUID $ U.fromText ttid+    Just hid <- return $ fmap fromUUID $ U.fromText thid+    Just old <- liftIO $ readRef st (encodeUtf8 told)+    Just new <- liftIO $ readRef st (encodeUtf8 tnew)++    replaceHeadRaw st tid hid old new >>= cmdOut . unwords . \case+        Left Nothing  -> [ "head-replace-fail", T.unpack ttid, T.unpack thid, T.unpack told, T.unpack tnew ]+        Left (Just r) -> [ "head-replace-fail", T.unpack ttid, T.unpack thid, T.unpack told, T.unpack tnew, show (refDigest r) ]+        Right _       -> [ "head-replace-done", T.unpack ttid, T.unpack thid, T.unpack told, T.unpack tnew ]++cmdHeadWatch :: Command+cmdHeadWatch = do+    [ ttid, thid ] <- asks tiParams+    st <- asks tiStorage+    Just tid <- return $ fmap fromUUID $ U.fromText ttid+    Just hid <- return $ fmap fromUUID $ U.fromText thid++    out <- asks tiOutput+    wid <- gets tsWatchedHeadNext++    watched <- liftIO $ watchHeadRaw st tid hid id $ \r -> do+        outLine out $ unwords [ "head-watch-cb", show wid, show $ refDigest r ]++    modify $ \s -> s+        { tsWatchedHeads = ( wid, watched ) : tsWatchedHeads s+        , tsWatchedHeadNext = wid + 1+        }++    cmdOut $ unwords $ [ "head-watch-done", T.unpack ttid, T.unpack thid, show wid ]++cmdHeadUnwatch :: Command+cmdHeadUnwatch = do+    [ twid ] <- asks tiParams+    let wid = read (T.unpack twid)+    Just watched <- lookup wid <$> gets tsWatchedHeads+    liftIO $ unwatchHead watched+    cmdOut $ unwords [ "head-unwatch-done", show wid ]+ initTestHead :: Head LocalState -> Command initTestHead h = do     _ <- liftIO . watchReceivedMessages h . dmReceivedWatcher =<< asks tiOutput@@ -655,17 +719,18 @@             AddedChatroom room -> outLine out $ unwords $ "chatroom-watched-added" : chatroomInfo room             RemovedChatroom room -> outLine out $ unwords $ "chatroom-watched-removed" : chatroomInfo room             UpdatedChatroom oldroom room -> do-                when (any (not . null . rsdRoom . fromStored) (roomStateData room)) $ do+                when (any ((\rsd -> not (null (rsdRoom rsd)) || not (null (rsdSubscribe rsd))) . fromStored) (roomStateData room)) $ do                     outLine out $ unwords $ concat                         [ [ "chatroom-watched-updated" ], chatroomInfo room                         , [ "old" ], map (show . refDigest . storedRef) (roomStateData oldroom)                         , [ "new" ], map (show . refDigest . storedRef) (roomStateData room)                         ]                 when (any (not . null . rsdMessages . fromStored) (roomStateData room)) $ do-                    forM_ (getMessagesSinceState room oldroom) $ \msg -> do+                    forM_ (reverse $ getMessagesSinceState room oldroom) $ \msg -> do                         outLine out $ unwords $ concat                             [ [ "chatroom-message-new" ]                             , [ show . refDigest . storedRef . head . filterAncestors . concatMap storedRoots . toComponents $ room ]+                            , [ "room", maybe "<unnamed>" T.unpack $ roomName =<< cmsgRoom msg ]                             , [ "from", maybe "<unnamed>" T.unpack $ idName $ cmsgFrom msg ]                             , maybe [] (("text":) . (:[]) . T.unpack) $ cmsgText msg                             ]@@ -674,10 +739,23 @@ chatroomInfo room =     [ show . refDigest . storedRef . head . filterAncestors . concatMap storedRoots . toComponents $ room     , maybe "<unnamed>" T.unpack $ roomName =<< roomStateRoom room+    , "sub " <> bool "false" "true" (roomStateSubscribe room)     ] +cmdChatroomSubscribe :: Command+cmdChatroomSubscribe = do+    [ cid ] <- asks tiParams+    to <- getChatroomStateData cid+    void $ chatroomSetSubscribe to True++cmdChatroomUnsubscribe :: Command+cmdChatroomUnsubscribe = do+    [ cid ] <- asks tiParams+    to <- getChatroomStateData cid+    void $ chatroomSetSubscribe to False+ cmdChatroomMessageSend :: Command cmdChatroomMessageSend = do     [cid, msg] <- asks tiParams     to <- getChatroomStateData cid-    void $ chatroomMessageByStateData to msg+    void $ sendChatroomMessageByStateData to msg

@@ -10,14 +10,18 @@     listChatrooms,     findChatroomByRoomData,     findChatroomByStateData,+    chatroomSetSubscribe,     getMessagesSinceState,      ChatroomSetChange(..),     watchChatrooms, -    ChatMessage, cmsgFrom, cmsgReplyTo, cmsgTime, cmsgText, cmsgLeave,+    ChatMessage,+    cmsgFrom, cmsgReplyTo, cmsgTime, cmsgText, cmsgLeave,+    cmsgRoom, cmsgRoomData,     ChatMessageData(..),-    chatroomMessageByStateData,+    sendChatroomMessage,+    sendChatroomMessageByStateData,      ChatroomService(..), ) where@@ -27,6 +31,8 @@ import Control.Monad.Except import Control.Monad.IO.Class +import Data.Bool+import Data.Either import Data.IORef import Data.List import Data.Maybe@@ -109,6 +115,11 @@     { cmsgData :: Stored (Signed ChatMessageData)     } +validateSingleMessage :: Stored (Signed ChatMessageData) -> Maybe ChatMessage+validateSingleMessage sdata = do+    guard $ fromStored sdata `isSignedBy` idKeyMessage (mdFrom (fromSigned sdata))+    return $ ChatMessage sdata+ cmsgFrom :: ChatMessage -> ComposedIdentity cmsgFrom = mdFrom . fromSigned . cmsgData @@ -124,6 +135,12 @@ cmsgLeave :: ChatMessage -> Bool cmsgLeave = mdLeave . fromSigned . cmsgData +cmsgRoom :: ChatMessage -> Maybe Chatroom+cmsgRoom = either (const Nothing) Just . runExcept . validateChatroom . cmsgRoomData++cmsgRoomData :: ChatMessage -> [ Stored (Signed ChatroomData) ]+cmsgRoomData = concat . findProperty ((\case [] -> Nothing; xs -> Just xs) . mdRoom . fromStored . signedData) . (: []) . cmsgData+ instance Storable ChatMessageData where     store' ChatMessageData {..} = storeRec $ do         mapM_ (storeRef "SPREV") mdPrev@@ -144,23 +161,26 @@         mdLeave <- isJust <$> loadMbEmpty "leave"         return ChatMessageData {..} -threadToList :: [Stored (Signed ChatMessageData)] -> [ChatMessage]-threadToList thread = helper S.empty $ thread+threadToListSince :: [ Stored (Signed ChatMessageData) ] -> [ Stored (Signed ChatMessageData) ] -> [ ChatMessage ]+threadToListSince since thread = helper (S.fromList since) thread   where     helper :: S.Set (Stored (Signed ChatMessageData)) -> [Stored (Signed ChatMessageData)] -> [ChatMessage]     helper seen msgs         | msg : msgs' <- filter (`S.notMember` seen) $ reverse $ sortBy (comparing cmpView) msgs =-            messageFromData msg : helper (S.insert msg seen) (msgs' ++ mdPrev (fromSigned msg))+            maybe id (:) (validateSingleMessage msg) $+               helper (S.insert msg seen) (msgs' ++ mdPrev (fromSigned msg))         | otherwise = []     cmpView msg = (zonedTimeToUTC $ mdTime $ fromSigned msg, msg) -    messageFromData :: Stored (Signed ChatMessageData) -> ChatMessage-    messageFromData sdata = ChatMessage { cmsgData = sdata }+sendChatroomMessage+    :: (MonadStorage m, MonadHead LocalState m, MonadError String m)+    => ChatroomState -> Text -> m ()+sendChatroomMessage rstate msg = sendChatroomMessageByStateData (head $ roomStateData rstate) msg -chatroomMessageByStateData+sendChatroomMessageByStateData     :: (MonadStorage m, MonadHead LocalState m, MonadError String m)     => Stored ChatroomStateData -> Text -> m ()-chatroomMessageByStateData lookupData msg = void $ findAndUpdateChatroomState $ \cstate -> do+sendChatroomMessageByStateData lookupData msg = void $ findAndUpdateChatroomState $ \cstate -> do     guard $ any (lookupData `precedesOrEquals`) $ roomStateData cstate     Just $ do         self <- finalOwner . localIdentity . fromStored <$> getLocalHead@@ -168,7 +188,9 @@         time <- liftIO getZonedTime         mdata <- mstore =<< sign secret =<< mstore ChatMessageData             { mdPrev = roomStateMessageData cstate-            , mdRoom = []+            , mdRoom = if null (roomStateMessageData cstate)+                          then maybe [] roomData (roomStateRoom cstate)+                          else []             , mdFrom = self             , mdReplyTo = Nothing             , mdTime = time@@ -178,6 +200,7 @@         mergeSorted . (:[]) <$> mstore ChatroomStateData             { rsdPrev = roomStateData cstate             , rsdRoom = []+            , rsdSubscribe = Just True             , rsdMessages = [ mdata ]             } @@ -185,6 +208,7 @@ data ChatroomStateData = ChatroomStateData     { rsdPrev :: [Stored ChatroomStateData]     , rsdRoom :: [Stored (Signed ChatroomData)]+    , rsdSubscribe :: Maybe Bool     , rsdMessages :: [Stored (Signed ChatMessageData)]     } @@ -192,6 +216,7 @@     { roomStateData :: [Stored ChatroomStateData]     , roomStateRoom :: Maybe Chatroom     , roomStateMessageData :: [Stored (Signed ChatMessageData)]+    , roomStateSubscribe :: Bool     , roomStateMessages :: [ChatMessage]     } @@ -199,11 +224,13 @@     store' ChatroomStateData {..} = storeRec $ do         forM_ rsdPrev $ storeRef "PREV"         forM_ rsdRoom $ storeRef "room"+        forM_ rsdSubscribe $ storeInt "subscribe" . bool @Int 0 1         forM_ rsdMessages $ storeRef "msg"      load' = loadRec $ do         rsdPrev <- loadRefs "PREV"         rsdRoom <- loadRefs "room"+        rsdSubscribe <- fmap ((/=) @Int 0) <$> loadMbInt "subscribe"         rsdMessages <- loadRefs "msg"         return ChatroomStateData {..} @@ -216,7 +243,8 @@             roomStateMessageData = filterAncestors $ concat $ flip findProperty roomStateData $ \case                 ChatroomStateData {..} | null rsdMessages -> Nothing                                        | otherwise        -> Just rsdMessages-            roomStateMessages = threadToList $ concatMap (rsdMessages . fromStored) roomStateData+            roomStateSubscribe = fromMaybe False $ findPropertyFirst rsdSubscribe roomStateData+            roomStateMessages = threadToListSince [] $ concatMap (rsdMessages . fromStored) roomStateData          in ChatroomState {..}      toComponents = roomStateData@@ -232,6 +260,7 @@     cstate <- mergeSorted . (:[]) <$> mstore ChatroomStateData         { rsdPrev = []         , rsdRoom = [ rdata ]+        , rsdSubscribe = Just True         , rsdMessages = []         } @@ -278,6 +307,7 @@         mergeSorted . (:[]) <$> mstore ChatroomStateData             { rsdPrev = roomStateData cstate             , rsdRoom = [ rdata ]+            , rsdSubscribe = Just True             , rsdMessages = []             } @@ -298,11 +328,21 @@ findChatroomByStateData :: MonadHead LocalState m => Stored ChatroomStateData -> m (Maybe ChatroomState) findChatroomByStateData cdata = findChatroom $ any (cdata `precedesOrEquals`) . roomStateData +chatroomSetSubscribe+    :: (MonadStorage m, MonadHead LocalState m, MonadError String m)+    => Stored ChatroomStateData -> Bool -> m ()+chatroomSetSubscribe lookupData subscribe = void $ findAndUpdateChatroomState $ \cstate -> do+    guard $ any (lookupData `precedesOrEquals`) $ roomStateData cstate+    Just $ do+        mergeSorted . (:[]) <$> mstore ChatroomStateData+            { rsdPrev = roomStateData cstate+            , rsdRoom = []+            , rsdSubscribe = Just subscribe+            , rsdMessages = []+            }+ getMessagesSinceState :: ChatroomState -> ChatroomState -> [ChatMessage]-getMessagesSinceState cur old = takeWhile notOld (roomStateMessages cur)-  where-    notOld msg = cmsgData msg `notElem` roomStateMessageData old-    -- TODO: parallel message threads+getMessagesSinceState cur old = threadToListSince (roomStateMessageData old) (roomStateMessageData cur)   data ChatroomSetChange = AddedChatroom ChatroomState@@ -342,13 +382,18 @@ data ChatroomService = ChatroomService     { chatRoomQuery :: Bool     , chatRoomInfo :: [Stored (Signed ChatroomData)]+    , chatRoomSubscribe :: [Stored (Signed ChatroomData)]+    , chatRoomUnsubscribe :: [Stored (Signed ChatroomData)]     , chatRoomMessage :: [Stored (Signed ChatMessageData)]     }+    deriving (Eq)  emptyPacket :: ChatroomService emptyPacket = ChatroomService     { chatRoomQuery = False     , chatRoomInfo = []+    , chatRoomSubscribe = []+    , chatRoomUnsubscribe = []     , chatRoomMessage = []     } @@ -356,17 +401,22 @@     store' ChatroomService {..} = storeRec $ do         when  chatRoomQuery $ storeEmpty "room-query"         forM_ chatRoomInfo $ storeRef "room-info"+        forM_ chatRoomSubscribe $ storeRef "room-subscribe"+        forM_ chatRoomUnsubscribe $ storeRef "room-unsubscribe"         forM_ chatRoomMessage $ storeRef "room-message"      load' = loadRec $ do         chatRoomQuery <- isJust <$> loadMbEmpty "room-query"         chatRoomInfo <- loadRefs "room-info"+        chatRoomSubscribe <- loadRefs "room-subscribe"+        chatRoomUnsubscribe <- loadRefs "room-unsubscribe"         chatRoomMessage <- loadRefs "room-message"         return ChatroomService {..}  data PeerState = PeerState     { psSendRoomUpdates :: Bool     , psLastList :: [(Stored ChatroomStateData, ChatroomState)]+    , psSubscribedTo :: [ Stored (Signed ChatroomData) ] -- least root for each room     }  instance Service ChatroomService where@@ -376,12 +426,18 @@     emptyServiceState _ = PeerState         { psSendRoomUpdates = False         , psLastList = []+        , psSubscribedTo = []         }      serviceHandler spacket = do         let ChatroomService {..} = fromStored spacket++        previouslyUpdated <- psSendRoomUpdates <$> svcGet         svcModify $ \s -> s { psSendRoomUpdates = True } +        when (not previouslyUpdated) $ do+            syncChatroomsToPeer . lookupSharedValue . lsShared . fromStored =<< getLocalHead+         when chatRoomQuery $ do             rooms <- listChatrooms             replyPacket emptyPacket@@ -394,10 +450,10 @@                     upd set (roomInfo :: Stored (Signed ChatroomData)) = do                         let currentRoots = storedRoots roomInfo                             isCurrentRoom = any ((`intersectsSorted` currentRoots) . storedRoots) .-                                concatMap (rsdRoom . fromStored) . roomStateData+                                maybe [] roomData . roomStateRoom                          let prev = concatMap roomStateData $ filter isCurrentRoom rooms-                            prevRoom = concatMap (rsdRoom . fromStored) prev+                            prevRoom = filterAncestors $ concat $ findProperty ((\case [] -> Nothing; xs -> Just xs) . rsdRoom) prev                             room = filterAncestors $ (roomInfo : ) prevRoom                          -- update local state only if we got roomInfo not present there@@ -406,12 +462,58 @@                             sdata <- mstore ChatroomStateData                                 { rsdPrev = prev                                 , rsdRoom = room+                                , rsdSubscribe = Nothing                                 , rsdMessages = []                                 }                             storeSetAddComponent sdata set                           else return set                 foldM upd roomSet chatRoomInfo +        forM_ chatRoomSubscribe $ \subscribeData -> do+            mbRoomState <- findChatroomByRoomData subscribeData+            forM_ mbRoomState $ \roomState ->+                forM (roomStateRoom roomState) $ \room -> do+                    let leastRoot = head . filterAncestors . concatMap storedRoots . roomData $ room+                    svcModify $ \ps -> ps { psSubscribedTo = leastRoot : psSubscribedTo ps }+                    replyPacket emptyPacket+                        { chatRoomMessage = roomStateMessageData roomState+                        }++        forM_ chatRoomUnsubscribe $ \unsubscribeData -> do+            mbRoomState <- findChatroomByRoomData unsubscribeData+            forM_ (mbRoomState >>= roomStateRoom) $ \room -> do+                let leastRoot = head . filterAncestors . concatMap storedRoots . roomData $ room+                svcModify $ \ps -> ps { psSubscribedTo = filter (/= leastRoot) (psSubscribedTo ps) }++        when (not (null chatRoomMessage)) $ do+            updateLocalHead_ $ updateSharedState_ $ \roomSet -> do+                let rooms = fromSetBy (comparing $ roomName <=< roomStateRoom) roomSet+                    upd set (msgData :: Stored (Signed ChatMessageData))+                        | Just msg <- validateSingleMessage msgData = do+                            let roomInfo = cmsgRoomData msg+                                currentRoots = filterAncestors $ concatMap storedRoots roomInfo+                                isCurrentRoom = any ((`intersectsSorted` currentRoots) . storedRoots) .+                                    maybe [] roomData . roomStateRoom++                            let prevData = concatMap roomStateData $ filter isCurrentRoom rooms+                                prev = mergeSorted prevData+                                prevMessages = roomStateMessageData prev+                                messages = filterAncestors $ msgData : prevMessages++                            -- update local state only if subscribed and we got some new messages+                            if roomStateSubscribe prev && messages /= prevMessages+                              then do+                                sdata <- mstore ChatroomStateData+                                    { rsdPrev = prevData+                                    , rsdRoom = []+                                    , rsdSubscribe = Nothing+                                    , rsdMessages = messages+                                    }+                                storeSetAddComponent sdata set+                              else return set+                        | otherwise = return set+                foldM upd roomSet chatRoomMessage+     serviceNewPeer = do         replyPacket emptyPacket { chatRoomQuery = True } @@ -423,11 +525,50 @@     ps@PeerState {..} <- svcGet     when psSendRoomUpdates $ do         let curList = chatroomSetToList set-        updates <- fmap (concat . catMaybes) $-            forM (makeChatroomDiff psLastList curList) $ return . \case+            diff = makeChatroomDiff psLastList curList++        roomUpdates <- fmap (concat . catMaybes) $+            forM diff $ return . \case                 AddedChatroom room -> roomData <$> roomStateRoom room                 RemovedChatroom {} -> Nothing-                UpdatedChatroom _ room -> roomData <$> roomStateRoom room-        when (not $ null updates) $ do-            replyPacket $ emptyPacket { chatRoomInfo = updates }+                UpdatedChatroom oldroom room+                    | roomStateData oldroom /= roomStateData room -> roomData <$> roomStateRoom room+                    | otherwise -> Nothing++        (subscribe, unsubscribe) <- fmap (partitionEithers . concat . catMaybes) $+            forM diff $ return . \case+                AddedChatroom room+                    | roomStateSubscribe room+                    -> map Left . roomData <$> roomStateRoom room+                RemovedChatroom oldroom+                    | roomStateSubscribe oldroom+                    -> map Right . roomData <$> roomStateRoom oldroom+                UpdatedChatroom oldroom room+                    | roomStateSubscribe oldroom /= roomStateSubscribe room+                    -> map (if roomStateSubscribe room then Left else Right) . roomData <$> roomStateRoom room+                _ -> Nothing++        messages <- fmap concat $ do+            let leastRootFor = head . filterAncestors . concatMap storedRoots . roomData+            forM diff $ return . \case+                AddedChatroom rstate+                    | Just room <- roomStateRoom rstate+                    , leastRootFor room `elem` psSubscribedTo+                    -> roomStateMessageData rstate+                UpdatedChatroom oldstate rstate+                    | Just room <- roomStateRoom rstate+                    , leastRootFor room `elem` psSubscribedTo+                    , roomStateMessageData oldstate /= roomStateMessageData rstate+                    -> roomStateMessageData rstate+                _ -> []++        let packet = emptyPacket+                { chatRoomInfo = roomUpdates+                , chatRoomSubscribe = subscribe+                , chatRoomUnsubscribe = unsubscribe+                , chatRoomMessage = messages+                }++        when (packet /= emptyPacket) $ do+            replyPacket packet         svcSet $ ps { psLastList = curList }

@@ -1,12 +1,15 @@ module Erebos.Conversation (     Message,     messageFrom,+    messageTime,     messageText,     messageUnread,     formatMessage,      Conversation,     directMessageConversation,+    chatroomConversation,+    chatroomConversationByStateData,     reloadConversation,     lookupConversations, @@ -23,30 +26,45 @@ import Data.Maybe import Data.Text (Text) import Data.Text qualified as T+import Data.Time.Format import Data.Time.LocalTime  import Erebos.Identity+import Erebos.Chatroom import Erebos.Message hiding (formatMessage) import Erebos.State import Erebos.Storage   data Message = DirectMessageMessage DirectMessage Bool+             | ChatroomMessage ChatMessage Bool  messageFrom :: Message -> ComposedIdentity messageFrom (DirectMessageMessage msg _) = msgFrom msg+messageFrom (ChatroomMessage msg _) = cmsgFrom msg +messageTime :: Message -> ZonedTime+messageTime (DirectMessageMessage msg _) = msgTime msg+messageTime (ChatroomMessage msg _) = cmsgTime msg+ messageText :: Message -> Maybe Text messageText (DirectMessageMessage msg _) = Just $ msgText msg+messageText (ChatroomMessage msg _) = cmsgText msg  messageUnread :: Message -> Bool messageUnread (DirectMessageMessage _ unread) = unread+messageUnread (ChatroomMessage _ unread) = unread  formatMessage :: TimeZone -> Message -> String-formatMessage tzone (DirectMessageMessage msg _) = formatDirectMessage tzone msg+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+    ]   data Conversation = DirectMessageConversation DirectMessageThread+                  | ChatroomConversation ChatroomState  directMessageConversation :: MonadHead LocalState m => ComposedIdentity -> m Conversation directMessageConversation peer = do@@ -54,8 +72,16 @@         Just thread -> return $ DirectMessageConversation thread         Nothing -> return $ DirectMessageConversation $ DirectMessageThread peer [] [] [] +chatroomConversation :: MonadHead LocalState m => ChatroomState -> m (Maybe Conversation)+chatroomConversation rstate = chatroomConversationByStateData (head $ roomStateData rstate)++chatroomConversationByStateData :: MonadHead LocalState m => Stored ChatroomStateData -> m (Maybe Conversation)+chatroomConversationByStateData sdata = fmap ChatroomConversation <$> findChatroomByStateData sdata+ reloadConversation :: MonadHead LocalState m => Conversation -> m Conversation reloadConversation (DirectMessageConversation thread) = directMessageConversation (msgPeer thread)+reloadConversation cur@(ChatroomConversation rstate) =+    fromMaybe cur <$> chatroomConversation rstate  lookupConversations :: MonadHead LocalState m => m [Conversation] lookupConversations = map DirectMessageConversation . toThreadList . lookupSharedValue . lsShared . fromStored <$> getLocalHead@@ -63,13 +89,17 @@  conversationName :: Conversation -> Text conversationName (DirectMessageConversation thread) = fromMaybe (T.pack "<unnamed>") $ idName $ msgPeer thread+conversationName (ChatroomConversation rstate) = fromMaybe (T.pack "<unnamed>") $ roomName =<< roomStateRoom rstate  conversationPeer :: Conversation -> Maybe ComposedIdentity conversationPeer (DirectMessageConversation thread) = Just $ msgPeer thread+conversationPeer (ChatroomConversation _) = Nothing  conversationHistory :: Conversation -> [Message] conversationHistory (DirectMessageConversation thread) = map (\msg -> DirectMessageMessage msg False) $ threadToList thread+conversationHistory (ChatroomConversation rstate) = map (\msg -> ChatroomMessage msg False) $ roomStateMessages rstate  -sendMessage :: (MonadHead LocalState m, MonadError String m) => Conversation -> Text -> m Message-sendMessage (DirectMessageConversation thread) text = DirectMessageMessage <$> (fromStored <$> sendDirectMessage (msgPeer thread) text) <*> pure False+sendMessage :: (MonadHead LocalState m, MonadError String m) => Conversation -> Text -> m (Maybe Message)+sendMessage (DirectMessageConversation thread) text = fmap Just $ DirectMessageMessage <$> (fromStored <$> sendDirectMessage (msgPeer thread) text) <*> pure False+sendMessage (ChatroomConversation rstate) text = sendChatroomMessage rstate text >> return Nothing

@@ -301,10 +301,11 @@              forkServerThread server $ forever $ do                 (paddr, msg) <- readFlowIO serverRawPath-                case paddr of-                    DatagramAddress addr -> void $ S.sendTo sock msg addr+                handle (\(e :: IOException) -> atomically . logd $ "failed to send packet to " ++ show paddr ++ ": " ++ show e) $ do+                    case paddr of+                        DatagramAddress addr -> void $ S.sendTo sock msg addr #ifdef ENABLE_ICE_SUPPORT-                    PeerIceSession ice   -> iceSend ice msg+                        PeerIceSession ice   -> iceSend ice msg #endif              forkServerThread server $ forever $ do@@ -922,6 +923,9 @@             w <- peekElemOff ptr i             if w == 0 then return []                       else (SockAddrInet port w:) <$> parse (i + 1)-    addrs <- parse 0-    cFree ptr-    return addrs+    if ptr == nullPtr+      then return []+      else do+        addrs <- parse 0+        cFree ptr+        return addrs

@@ -68,7 +68,10 @@ protocolVersions :: [Text] protocolVersions = [protocolVersion] +keepAliveInternal :: TimeSpec+keepAliveInternal = fromNanoSecs $ 30 * 10^(9 :: Int) + data TransportPacket a = TransportPacket TransportHeader [a]  data TransportHeader = TransportHeader [TransportHeaderItem]@@ -186,6 +189,7 @@     , cReservedPackets :: TVar Int     , cSentPackets :: TVar [SentPacket]     , cToAcknowledge :: TVar [Integer]+    , cNextKeepAlive :: TVar (Maybe TimeSpec)     , cInStreams :: TVar [(Word8, Stream)]     , cOutStreams :: TVar [(Word8, Stream)]     }@@ -440,7 +444,7 @@     mStorage <- memoryStorage     gStorage <- derivePartialStorage mStorage -    startTime <- getTime MonotonicRaw+    startTime <- getTime Monotonic     gNowVar <- newTVarIO startTime     gNextTimeout <- newTVarIO startTime     gInitConfig <- store mStorage $ (Rec [] :: Object)@@ -448,7 +452,7 @@     let gs = GlobalState {..}      let signalTimeouts = forever $ do-            now <- getTime MonotonicRaw+            now <- getTime Monotonic             next <- atomically $ do                 writeTVar gNowVar now                 readTVar gNextTimeout@@ -487,6 +491,7 @@     cReservedPackets <- newTVar 0     cSentPackets <- newTVar []     cToAcknowledge <- newTVar []+    cNextKeepAlive <- newTVar Nothing     cInStreams <- newTVar []     cOutStreams <- newTVar []     let conn = Connection {..}@@ -548,6 +553,7 @@                  Nothing -> throwError "empty packet" +        now <- getTime Monotonic         runExceptT parse >>= \case             Right (Left (secure, objs, mbcounter))                 | hobj:content <- objs@@ -562,6 +568,7 @@                             case mbup of                                 Just up -> putTMVar gNextUp (conn, (secure, up))                                 Nothing -> return ()+                            updateKeepAlive conn now                             processAcknowledgements gs conn items                         ioAfter                     Nothing -> return ()@@ -571,8 +578,9 @@                       gLog $ show objs              Right (Right (snum, seq8, content, counter))-                | Just Connection {..} <- mbconn+                | Just conn@Connection {..} <- mbconn                 -> atomically $ do+                    updateKeepAlive conn now                     (lookup snum <$> readTVar cInStreams) >>= \case                         Nothing ->                             gLog $ "unexpected stream number " ++ show snum@@ -713,9 +721,9 @@     return $ ReservedToSend Nothing (return ()) (atomically $ connClose conn)  resendBytes :: Connection addr -> Maybe ReservedToSend -> SentPacket -> IO ()-resendBytes Connection {..} reserved sp = do+resendBytes conn@Connection {..} reserved sp = do     let GlobalState {..} = cGlobalState-    now <- getTime MonotonicRaw+    now <- getTime Monotonic     atomically $ do         when (isJust reserved) $ do             modifyTVar' cReservedPackets (subtract 1)@@ -726,6 +734,7 @@                 , spRetryCount = spRetryCount sp + 1                 }         writeFlow gDataFlow (cAddress, spData sp)+        updateKeepAlive conn now  sendBytes :: Connection addr -> Maybe ReservedToSend -> ByteString -> IO () sendBytes conn reserved bs = resendBytes conn reserved@@ -738,6 +747,12 @@         , spData = bs         } +updateKeepAlive :: Connection addr -> TimeSpec -> STM ()+updateKeepAlive Connection {..} now = do+    let next = now + keepAliveInternal+    writeTVar cNextKeepAlive $ Just next++ processOutgoing :: forall addr. GlobalState addr -> STM (IO ()) processOutgoing gs@GlobalState {..} = do @@ -777,11 +792,12 @@                 let onAck = sequence_ $ map (streamAccepted conn) $                         catMaybes (map (\case StreamOpen n -> Just n; _ -> Nothing) hitems) -                let mkPlain extraHeaders =-                        let header = TransportHeader $ map AcknowledgedSingle acknowledge ++ extraHeaders ++ hitems-                         in BL.concat $-                            (serializeObject $ transportToObject gStorage header)-                            : map lazyLoadBytes content+                let mkPlain extraHeaders+                        | combinedHeaderItems@(_:_) <- map AcknowledgedSingle acknowledge ++ extraHeaders ++ hitems =+                             BL.concat $+                                (serializeObject $ transportToObject gStorage $ TransportHeader combinedHeaderItems)+                                : map lazyLoadBytes content+                        | otherwise = BL.empty                  let usePlaintext = do                         plain <- mkPlain <$> generateCookieHeaders conn channel@@ -811,6 +827,13 @@                         sendBytes conn mbReserved' bs                     Nothing -> return () +    let waitUntil :: TimeSpec -> TimeSpec -> STM ()+        waitUntil now till = do+            nextTimeout <- readTVar gNextTimeout+            if nextTimeout <= now || till < nextTimeout+               then writeTVar gNextTimeout till+               else retry+     let retransmitPacket :: Connection addr -> STM (IO ())         retransmitPacket conn@Connection {..} = do             now <- readTVar gNowVar@@ -819,11 +842,8 @@                 _         -> retry             let nextTry = spTime sp + fromNanoSecs 1000000000             if | now < nextTry -> do-                    nextTimeout <- readTVar gNextTimeout-                    if nextTimeout <= now || nextTry < nextTimeout-                       then do writeTVar gNextTimeout nextTry-                               return $ return ()-                       else retry+                    waitUntil now nextTry+                    return $ return ()                | spRetryCount sp < 2 -> do                     reserved <- reservePacket conn                     writeTVar cSentPackets rest@@ -863,11 +883,27 @@                 writeTVar gIdentity (nid, cur : past)                 return $ return () +    let sendKeepAlive :: Connection addr -> STM (IO ())+        sendKeepAlive Connection {..} = do+            readTVar cNextKeepAlive >>= \case+                Nothing -> retry+                Just next -> do+                    now <- readTVar gNowVar+                    if next <= now+                      then do+                        identity <- fst <$> readTVar gIdentity+                        let header = TransportHeader [ AnnounceSelf $ refDigest $ storedRef $ idData identity ]+                        writeTQueue cSecureOutQueue (EncryptedOnly, TransportPacket header [], [])+                      else do+                        waitUntil now next+                    return $ return ()+     conns <- readTVar gConnections     msum $ concat $         [ map retransmitPacket conns         , map sendNextPacket conns         , [ handleControlRequests ]+        , map sendKeepAlive conns         ]  processAcknowledgements :: GlobalState addr -> Connection addr -> [TransportHeaderItem] -> STM (IO ())

@@ -1,5 +1,7 @@ #include "ifaddrs.h" +#ifndef _WIN32+ #include <arpa/inet.h> #include <ifaddrs.h> #include <net/if.h>@@ -39,3 +41,51 @@ 	ret[count] = 0; 	return ret; }++#else // _WIN32++#include <winsock2.h>+#include <ws2tcpip.h>++#pragma comment(lib, "ws2_32.lib")++uint32_t * broadcast_addresses(void)+{+	uint32_t * ret = NULL;+	SOCKET wsock = INVALID_SOCKET;++	struct WSAData wsaData;+	if (WSAStartup(MAKEWORD(2, 2), &wsaData) != 0)+		return NULL;++	wsock = WSASocket(AF_INET, SOCK_DGRAM, IPPROTO_UDP, NULL, 0, 0);+	if (wsock == INVALID_SOCKET)+		goto cleanup;++	INTERFACE_INFO InterfaceList[32];+	unsigned long nBytesReturned;++	if (WSAIoctl(wsock, SIO_GET_INTERFACE_LIST, 0, 0,+				InterfaceList, sizeof(InterfaceList),+				&nBytesReturned, 0, 0) == SOCKET_ERROR)+		goto cleanup;++	int numInterfaces = nBytesReturned / sizeof(INTERFACE_INFO);++	size_t capacity = 16, count = 0;+	ret = malloc(sizeof(uint32_t) * capacity);++	for (int i = 0; i < numInterfaces && count < capacity - 1; i++)+		if (InterfaceList[i].iiFlags & IFF_BROADCAST)+			ret[count++] = InterfaceList[i].iiBroadcastAddress.AddressIn.sin_addr.s_addr;++	ret[count] = 0;+cleanup:+	if (wsock != INVALID_SOCKET)+		closesocket(wsock);+	WSACleanup();++	return ret;+}++#endif

@@ -21,9 +21,11 @@     headId, headStorage, headRef, headObject, headStoredObject,     loadHeads, loadHead, reloadHead,     storeHead, replaceHead, updateHead, updateHead_,+    loadHeadRaw, storeHeadRaw, replaceHeadRaw,      WatchedHead,     watchHead, watchHeadWith, unwatchHead,+    watchHeadRaw,      MonadStorage(..), @@ -62,7 +64,6 @@ ) where  import Control.Applicative-import Control.Arrow import Control.Concurrent import Control.Exception import Control.Monad@@ -72,6 +73,7 @@  import Crypto.Hash +import Data.Bifunctor import Data.ByteString (ByteString) import qualified Data.ByteArray as BA import qualified Data.ByteString as B@@ -101,8 +103,8 @@ import qualified Data.UUID.V4 as U  import System.Directory+import System.FSNotify import System.FilePath-import System.INotify import System.IO.Error import System.IO.Unsafe @@ -117,25 +119,30 @@  openStorage :: FilePath -> IO Storage openStorage path = modifyIOError annotate $ do-    let versionPath = path </> "erebos-storage"-    doesFileExist versionPath >>= \case-        True -> readFile versionPath >>= \case-            content | (ver:_) <- lines content, ver == storageVersion -> return ()-                    | otherwise -> fail "unsupported storage version"+    let versionFileName = "erebos-storage"+    let versionPath = path </> versionFileName+    let writeVersionFile = writeFile versionPath $ storageVersion <> "\n"++    doesDirectoryExist path >>= \case+        True -> do+            listDirectory path >>= \case+                files@(_:_)+                    | versionFileName `elem` files -> do+                        readFile versionPath >>= \case+                            content | (ver:_) <- lines content, ver == storageVersion -> return ()+                                    | otherwise -> fail "unsupported storage version"++                    | "objects" `notElem` files || "heads" `notElem` files -> do+                        fail "directory is neither empty, nor an existing erebos storage"++                _ -> writeVersionFile         False -> do-            doesDirectoryExist path >>= \case-                True -> do-                    listDirectory path >>= \case-                        contents@(_:_) | "objects" `notElem` contents || "heads" `notElem` contents-                            -> fail "directory is neither empty, nor an existing erebos storage"-                        _ -> return ()-                False -> do-                    createDirectoryIfMissing True $ path-            writeFile versionPath $ storageVersion <> "\n"+            createDirectoryIfMissing True $ path+            writeVersionFile      createDirectoryIfMissing True $ path </> "objects"     createDirectoryIfMissing True $ path </> "heads"-    watchers <- newMVar ([], WatchList 1 [])+    watchers <- newMVar (Nothing, [], WatchList 1 [])     refgen <- newMVar =<< HT.new     refroots <- newMVar =<< HT.new     return $ Storage@@ -431,57 +438,70 @@     catMaybes . map toHead <$> readMVar theads  loadHead :: forall a m. (HeadType a, MonadIO m) => Storage -> HeadID -> m (Maybe (Head a))-loadHead s@(Storage { stBacking = StorageDir { dirPath = spath }}) hid = liftIO $ do+loadHead st hid = fmap (Head hid . wrappedLoad) <$> loadHeadRaw st (headTypeID @a Proxy) hid++loadHeadRaw :: forall m. MonadIO m => Storage -> HeadTypeID -> HeadID -> m (Maybe Ref)+loadHeadRaw s@(Storage { stBacking = StorageDir { dirPath = spath }}) tid hid = liftIO $ do     handleJust (guard . isDoesNotExistError) (const $ return Nothing) $ do-        (h:_) <- BC.lines <$> B.readFile (headPath spath (headTypeID @a Proxy) hid)+        (h:_) <- BC.lines <$> B.readFile (headPath spath tid hid)         Just ref <- readRef s h-        return $ Just $ Head hid $ wrappedLoad ref-loadHead Storage { stBacking = StorageMemory { memHeads = theads } } hid = liftIO $ do-    fmap (Head hid . wrappedLoad) . lookup (headTypeID @a Proxy, hid) <$> readMVar theads+        return $ Just ref+loadHeadRaw Storage { stBacking = StorageMemory { memHeads = theads } } tid hid = liftIO $ do+    lookup (tid, hid) <$> readMVar theads  reloadHead :: (HeadType a, MonadIO m) => Head a -> m (Maybe (Head a)) reloadHead (Head hid (Stored (Ref st _) _)) = loadHead st hid  storeHead :: forall a m. MonadIO m => HeadType a => Storage -> a -> m (Head a)-storeHead st obj = liftIO $ do+storeHead st obj = do     let tid = headTypeID @a Proxy-    hid <- HeadID <$> U.nextRandom     stored <- wrappedStore st obj+    hid <- storeHeadRaw st tid (storedRef stored)+    return $ Head hid stored++storeHeadRaw :: forall m. MonadIO m => Storage -> HeadTypeID -> Ref -> m HeadID+storeHeadRaw st tid ref = liftIO $ do+    hid <- HeadID <$> U.nextRandom     case stBacking st of          StorageDir { dirPath = spath } -> do              Right () <- writeFileChecked (headPath spath tid hid) Nothing $-                 showRef (storedRef stored) `B.append` BC.singleton '\n'+                 showRef ref `B.append` BC.singleton '\n'              return ()          StorageMemory { memHeads = theads } -> do-             modifyMVar_ theads $ return . (((tid, hid), storedRef stored) :)-    return $ Head hid stored+             modifyMVar_ theads $ return . (((tid, hid), ref) :)+    return hid  replaceHead :: forall a m. (HeadType a, MonadIO m) => Head a -> Stored a -> m (Either (Maybe (Head a)) (Head a)) replaceHead prev@(Head hid pobj) stored' = liftIO $ do     let st = headStorage prev         tid = headTypeID @a Proxy     stored <- copyStored st stored'+    bimap (fmap $ Head hid . wrappedLoad) (const $ Head hid stored) <$>+        replaceHeadRaw st tid hid (storedRef pobj) (storedRef stored)++replaceHeadRaw :: forall m. MonadIO m => Storage -> HeadTypeID -> HeadID -> Ref -> Ref -> m (Either (Maybe Ref) Ref)+replaceHeadRaw st tid hid prev new = liftIO $ do     case stBacking st of          StorageDir { dirPath = spath } -> do              let filename = headPath spath tid hid                  showRefL r = showRef r `B.append` BC.singleton '\n' -             writeFileChecked filename (Just $ showRefL $ headRef prev) (showRefL $ storedRef stored) >>= \case+             writeFileChecked filename (Just $ showRefL prev) (showRefL new) >>= \case                  Left Nothing -> return $ Left Nothing                  Left (Just bs) -> do Just oref <- readRef st $ BC.takeWhile (/='\n') bs-                                      return $ Left $ Just $ Head hid $ wrappedLoad oref-                 Right () -> return $ Right $ Head hid stored+                                      return $ Left $ Just oref+                 Right () -> return $ Right new           StorageMemory { memHeads = theads, memWatchers = twatch } -> do              res <- modifyMVar theads $ \hs -> do                  ws <- map wlFun . filter ((==(tid, hid)) . wlHead) . wlList <$> readMVar twatch                  return $ case partition ((==(tid, hid)) . fst) hs of                      ([] , _  ) -> (hs, Left Nothing)-                     ((_, r):_, hs') | r == storedRef pobj -> (((tid, hid), storedRef stored) : hs',-                                                                  Right (Head hid stored, ws))-                                     | otherwise -> (hs, Left $ Just $ Head hid $ wrappedLoad r)+                     ((_, r):_, hs') | r == prev -> (((tid, hid), new) : hs',+                                                                  Right (new, ws))+                                     | otherwise -> (hs, Left $ Just r)              case res of-                  Right (h, ws) -> mapM_ ($ headRef h) ws >> return (Right h)+                  Right (r, ws) -> mapM_ ($ r) ws >> return (Right r)                   Left x -> return $ Left x  updateHead :: (HeadType a, MonadIO m) => Head a -> (Stored a -> m (Stored a, b)) -> m (Maybe (Head a), b)@@ -502,41 +522,46 @@ watchHead h = watchHeadWith h id  watchHeadWith :: forall a b. (HeadType a, Eq b) => Head a -> (Head a -> b) -> (b -> IO ()) -> IO WatchedHead-watchHeadWith oh@(Head hid (Stored (Ref st _) _)) sel cb = do+watchHeadWith (Head hid (Stored (Ref st _) _)) sel cb = do+    watchHeadRaw st (headTypeID @a Proxy) hid (sel . Head hid . wrappedLoad) cb++watchHeadRaw :: forall b. Eq b => Storage -> HeadTypeID -> HeadID -> (Ref -> b) -> (b -> IO ()) -> IO WatchedHead+watchHeadRaw st tid hid sel cb = do     memo <- newEmptyMVar-    let tid = headTypeID @a Proxy-        addWatcher wl = (wl', WatchedHead st (wlNext wl) memo)+    let addWatcher wl = (wl', WatchedHead st (wlNext wl) memo)             where wl' = wl { wlNext = wlNext wl + 1                            , wlList = WatchListItem                                { wlID = wlNext wl                                , wlHead = (tid, hid)                                , wlFun = \r -> do-                                   let x = sel $ Head hid $ wrappedLoad r+                                   let x = sel r                                    modifyMVar_ memo $ \prev -> do-                                       when (x /= prev) $ cb x-                                       return x+                                       when (Just x /= prev) $ cb x+                                       return $ Just x                                } : wlList wl                            }      watched <- case stBacking st of-         StorageDir { dirPath = spath, dirWatchers = mvar } -> modifyMVar mvar $ \(ilist, wl) -> do-             ilist' <- case lookup tid ilist of-                 Just _ -> return ilist-                 Nothing -> do-                     inotify <- initINotify-                     void $ addWatch inotify [Move] (BC.pack $ headTypePath spath tid) $ \case-                         MovedIn { filePath = fpath } | Just ihid <- HeadID <$> U.fromASCIIBytes fpath -> do-                             loadHead @a st ihid >>= \case-                                 Just h -> mapM_ ($ headRef h) . map wlFun . filter ((== (tid, ihid)) . wlHead) . wlList . snd =<< readMVar mvar+         StorageDir { dirPath = spath, dirWatchers = mvar } -> modifyMVar mvar $ \(mbmanager, ilist, wl) -> do+             manager <- maybe startManager return mbmanager+             ilist' <- case tid `elem` ilist of+                 True -> return ilist+                 False -> do+                     void $ watchDir manager (headTypePath spath tid) (const True) $ \case+                         Added { eventPath = fpath } | Just ihid <- HeadID <$> U.fromString (takeFileName fpath) -> do+                             loadHeadRaw st tid ihid >>= \case+                                 Just ref -> do+                                     (_, _, iwl) <- readMVar mvar+                                     mapM_ ($ ref) . map wlFun . filter ((== (tid, ihid)) . wlHead) . wlList $ iwl                                  Nothing -> return ()                          _ -> return ()-                     return $ (tid, inotify) : ilist-             return $ first (ilist',) $ addWatcher wl+                     return $ tid : ilist+             return $ first ( Just manager, ilist', ) $ addWatcher wl           StorageMemory { memWatchers = mvar } -> modifyMVar mvar $ return . addWatcher -    cur <- sel . maybe oh id <$> reloadHead oh-    cb cur+    cur <- fmap sel <$> loadHeadRaw st tid hid+    maybe (return ()) cb cur     putMVar memo cur      return watched

@@ -1,5 +1,3 @@-{-# LANGUAGE CPP #-}- module Erebos.Storage.Internal where  import Codec.Compression.Zlib@@ -33,15 +31,15 @@ import Foreign.Storable (peek)  import System.Directory+import System.FSNotify (WatchManager) import System.FilePath-import System.INotify (INotify) import System.IO import System.IO.Error import System.IO.Unsafe (unsafePerformIO)-import System.Posix.Files-import System.Posix.IO +import Erebos.Storage.Platform + data Storage' c = Storage     { stBacking :: StorageBacking c     , stParent :: Maybe (Storage' Identity)@@ -62,7 +60,7 @@  data StorageBacking c          = StorageDir { dirPath :: FilePath-                      , dirWatchers :: MVar ([(HeadTypeID, INotify)], WatchList c)+                      , dirWatchers :: MVar ( Maybe WatchManager, [ HeadTypeID ], WatchList c )                       }          | StorageMemory { memHeads :: MVar [((HeadTypeID, HeadID), Ref' c)]                          , memObjs :: MVar (Map RefDigest BL.ByteString)@@ -230,16 +228,7 @@ openLockFile :: FilePath -> IO Handle openLockFile path = do     createDirectoryIfMissing True (takeDirectory path)-    fd <- retry 10 $-#if MIN_VERSION_unix(2,8,0)-        openFd path WriteOnly defaultFileFlags-            { creat = Just $ unionFileModes ownerReadMode ownerWriteMode-            , exclusive = True-            }-#else-        openFd path WriteOnly (Just $ unionFileModes ownerReadMode ownerWriteMode) (defaultFileFlags { exclusive = True })-#endif-    fdToHandle fd+    retry 10 $ createFileExclusive path   where     retry :: Int -> IO a -> IO a     retry 0 act = act@@ -249,34 +238,34 @@ writeFileOnce :: FilePath -> BL.ByteString -> IO () writeFileOnce file content = bracket (openLockFile locked)     hClose $ \h -> do-        fileExist file >>= \case-            True  -> removeLink locked+        doesFileExist file >>= \case+            True  -> removeFile locked             False -> do BL.hPut h content                         hFlush h-                        rename locked file+                        renameFile locked file     where locked = file ++ ".lock"  writeFileChecked :: FilePath -> Maybe ByteString -> ByteString -> IO (Either (Maybe ByteString) ()) writeFileChecked file prev content = bracket (openLockFile locked)     hClose $ \h -> do-        (prev,) <$> fileExist file >>= \case+        (prev,) <$> doesFileExist file >>= \case             (Nothing, True) -> do                 current <- B.readFile file-                removeLink locked+                removeFile locked                 return $ Left $ Just current             (Nothing, False) -> do B.hPut h content                                    hFlush h-                                   rename locked file+                                   renameFile locked file                                    return $ Right ()             (Just expected, True) -> do                 current <- B.readFile file                 if current == expected then do B.hPut h content                                                hFlush h-                                               rename locked file+                                               renameFile locked file                                                return $ return ()-                                       else do removeLink locked+                                       else do removeFile locked                                                return $ Left $ Just current             (Just _, False) -> do-                removeLink locked+                removeFile locked                 return $ Left Nothing     where locked = file ++ ".lock"

@@ -0,0 +1,20 @@+{-# LANGUAGE CPP #-}++module Erebos.Storage.Platform (+    createFileExclusive,+) where++import System.IO+import System.Posix.Files+import System.Posix.IO++createFileExclusive :: FilePath -> IO Handle+createFileExclusive path = fdToHandle =<< do+#if MIN_VERSION_unix(2,8,0)+    openFd path WriteOnly defaultFileFlags+        { creat = Just $ unionFileModes ownerReadMode ownerWriteMode+        , exclusive = True+        }+#else+    openFd path WriteOnly (Just $ unionFileModes ownerReadMode ownerWriteMode) (defaultFileFlags { exclusive = True })+#endif

@@ -0,0 +1,13 @@+module Erebos.Storage.Platform (+    createFileExclusive,+) where++import Data.Bits++import System.IO+import System.Win32.File+import System.Win32.Types++createFileExclusive :: FilePath -> IO Handle+createFileExclusive path = do+    hANDLEToHandle =<< createFile path gENERIC_WRITE (fILE_SHARE_READ .|. fILE_SHARE_DELETE) Nothing cREATE_NEW fILE_ATTRIBUTE_NORMAL Nothing