erebos 0.2.3 → 0.2.4

raw patch · 10 files changed

+255/−69 lines, 10 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• erebos.cabal +3/−1
• main/Main.hs +38/−24
• main/Test.hs +71/−4
• main/Test/State.hs +24/−0
• src/Erebos/Discovery.hs +67/−27
• src/Erebos/Network.hs +20/−6
• src/Erebos/Network/Address.hs +10/−0
• src/Erebos/State.hs +4/−1
• src/Erebos/Storage/Graph.hs +11/−6

@@ -1,5 +1,12 @@ # Revision history for erebos +## 0.2.4 -- 2026-10-15++* Added `--command` command-line option to run initial commands after starting the server.+* Discovery is now working also on localhost without the need for external interface.+* Fixed tunnel offer for peers without inet addresses.+* Fixed status indicator for new messages not being updated in some situations.+ ## 0.2.3 -- 2026-08-19  * Discovery service handles situation when search target joins later.

@@ -1,7 +1,7 @@ Cabal-Version:       3.0  Name:                erebos-Version:             0.2.3+Version:             0.2.4 Synopsis:            Decentralized messaging and synchronization Description:     Library and simple CLI interface implementing the Erebos identity@@ -53,6 +53,7 @@      default-extensions:         DefaultSignatures+        DataKinds         ExistentialQuantification         FlexibleContexts         FlexibleInstances@@ -205,6 +206,7 @@         Terminal         Test         Test.Service+        Test.State         Version         Version.Git         WebSocket

@@ -64,9 +64,10 @@  data Options = Options     { optServer :: ServerOptions-    , optServices :: [ServiceOption]+    , optServices :: [ ServiceOption ]     , optStorage :: StorageOption     , optCreateIdentity :: Maybe ( Maybe Text, [ Maybe Text ] )+    , optCommands :: [ Text ]     , optChatroomAutoSubscribe :: Maybe Int     , optDmBotEcho :: Maybe Text     , optWebSocketServer :: Maybe Int@@ -93,6 +94,7 @@     , optServices = availableServices     , optStorage = DefaultStorage     , optCreateIdentity = Nothing+    , optCommands = []     , optChatroomAutoSubscribe = Nothing     , optDmBotEcho = Nothing     , optWebSocketServer = Nothing@@ -147,6 +149,9 @@                  in maybe (Just ( Nothing, [ ownerName ] )) (Just . second (ownerName :)) (optCreateIdentity opts)             }) "<name>")         "create owner for a new device identity"+    , Option [ 'c' ] [ "command" ]+        (ReqArg (\value -> \opts -> return opts { optCommands = optCommands opts ++ [ T.pack value ] }) "<command>")+        "run given <command> after starting the server"     , Option [] [ "chatroom-auto-subscribe" ]         (ReqArg (\count -> \opts -> return opts { optChatroomAutoSubscribe = Just (read count) }) "<count>")         "automatically subscribe for up to <count> chatrooms"@@ -396,21 +401,20 @@                     | tui       -> KeepPrompt mzero                     | otherwise -> KeepPrompt $ liftIO $ forever $ threadDelay 100000000 -        getInputCommandTui cstate = do-            let parseCommand cmdline =-                    case dropWhile isSpace <$> span (\c -> isAlphaNum c || c == '-') cmdline of-                        ( scmd, args )-                            | not (null scmd) && all isDigit scmd-                            -> ( cmdSelectContext, scmd )+        parseCommand cmdline =+            case dropWhile isSpace <$> span (\c -> isAlphaNum c || c == '-') cmdline of+                ( scmd, args )+                    | not (null scmd) && all isDigit scmd+                    -> ( cmdSelectContext, scmd ) -                            | otherwise-                            -> ( fromMaybe (cmdUnknown scmd) $ lookup scmd commands, args )+                    | otherwise+                    -> ( fromMaybe (cmdUnknown scmd) $ lookup scmd commands, args ) -            ( CommandM cmd, line ) <- getInputLinesTui cstate >>= return . \case+        getInputCommandTui cstate = do+            getInputLinesTui cstate >>= return . \case                 '/' : input     -> parseCommand input                 input | not tui -> parseCommand input                 input           -> ( cmdSend, input )-            return ( cmd, line )      let getInputCommand = getInputCommandTui . Left @@ -449,7 +453,7 @@                  case optDmBotEcho opts of                     Just prefix-                        | not (msgFrom msg `sameIdentity` self)+                        | new && not (msgFrom msg `sameIdentity` self)                         -> do                             void $ forkIO $ do                                 res <- runExceptT $ flip runReaderT erebosHead $ sendDirectMessage (msgFrom msg) (prefix <> msgText msg)@@ -515,9 +519,8 @@                     cur -> return cur             _ -> return () -    let process :: CommandState -> MaybeT IO CommandState-        process cstate = do-            (cmd, line) <- getInputCommand cstate+    let process :: CommandState -> ( Command, String ) -> MaybeT IO CommandState+        process cstate ( CommandM cmd, line ) = do             h <- liftIO (reloadHead $ csHead cstate) >>= \case                 Just h  -> return h                 Nothing -> do lift $ extPrintLn "current head deleted"@@ -548,9 +551,12 @@                     lift $ extPrintLn $ withStyle (setForegroundColor BrightRed noStyle) $ plainText $ T.pack $ "Error: " ++ showErebosError err                     return cstate -    let loop (Just cstate) = runMaybeT (process cstate) >>= loop-        loop Nothing = return ()-    loop $ Just $ CommandState+    let loop [] (Just cstate) = do+            loop [] =<< runMaybeT (process cstate =<< getInputCommand cstate)+        loop (c : cs) (Just cstate) = do+            loop cs =<< runMaybeT (process cstate $ parseCommand $ T.unpack c)+        loop _ Nothing = return ()+    loop (optCommands opts) $ Just $ CommandState         { csHead = erebosHead         , csContext = NoContext         , csWatchChatrooms = watched@@ -770,17 +776,25 @@     forM_ (zip [1..] peers) $ \(i :: Int, (_, name)) -> do         printSelectOption i $ plainText name +peerAddressFromText :: (MonadIO m, MonadError ErebosError m) => Text -> m SockAddr+peerAddressFromText taddr = do+    ( hostname, port ) <- case words (T.unpack taddr) of+        hostname : p : _ -> return ( hostname, p )+        [ single ]+            | all isDigit single -> return ( "localhost", single )+            | otherwise -> return ( single, show discoveryPort )+        [] -> throwOtherError "missing peer address"+    liftIO (getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just hostname) (Just port)) >>= \case+        addr : _ -> return (addrAddress addr)+        [] -> throwOtherError "address not found"+ cmdPeerAdd :: Command cmdPeerAdd = void $ do     server <- asks ciServer-    (hostname, port) <- (words <$> asks ciLine) >>= \case-        hostname:p:_ -> return (hostname, p)-        [hostname] -> return (hostname, show discoveryPort)-        [] -> throwOtherError "missing peer address"-    addr:_ <- liftIO $ getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just hostname) (Just port)+    addr <- peerAddressFromText . T.pack =<< asks ciLine     contextOptsVar <- asks ciContextOptionsVar     liftIO $ modifyMVar_ contextOptsVar $ return . first (const $ Just WatchPeers)-    liftIO $ serverPeer server (addrAddress addr)+    liftIO $ serverPeer server addr  cmdPeerAddPublic :: Command cmdPeerAddPublic = do

@@ -19,6 +19,7 @@ import Data.ByteString.Char8 qualified as BC import Data.ByteString.Lazy qualified as BL import Data.ByteString.Lazy.Char8 qualified as BL+import Data.Char import Data.Foldable import Data.Ord import Data.Text (Text)@@ -28,6 +29,8 @@ import Data.Typeable import Data.UUID.Types qualified as U +import GHC.TypeLits+ import Network.Socket  import System.IO@@ -57,6 +60,7 @@ import Erebos.Sync  import Test.Service+import Test.State   data TestState = TestState@@ -238,6 +242,20 @@     { discoveryProvideTunnel = \_ _ -> False     } +discoveryTracer :: Output -> Peer -> PeerAddress -> Stored DiscoveryService -> IO ()+discoveryTracer out _ paddr spacket = case fromStored spacket of+    DiscoverySearch dgst -> do+        outLine out $ "discovery-packet " <> show paddr <> " search " <> show (either refDigest id dgst)+    DiscoveryResult dgst results via -> do+        outLine out $ "discovery-packet " <> show paddr <> " result " <> show (either refDigest id dgst)+        forM_ results $ \addr -> do+            outLine out $ "discovery-packet-result result " <> T.unpack (toText addr)+        forM_ via $ \DiscoveryVia {..} -> do+            forM_ viaAddress $ \addr -> do+                outLine out $ "discovery-packet-result via " <> show viaIdentity <> " addr " <> T.unpack (toText addr)+        outLine out $ "discovery-packet-result done"+    _ -> return ()+ inviteAttributes :: Output -> InviteServiceAttributes inviteAttributes out = (defaultServiceAttributes Proxy)     { inviteHookAccepted = \Invite {..} -> do@@ -320,6 +338,7 @@     , ( "peer-add", cmdPeerAdd )     , ( "peer-drop", cmdPeerDrop )     , ( "peer-list", cmdPeerList )+    , ( "peer-get-by-addr", cmdPeerGetByAddr )     , ( "test-message-send", cmdTestMessageSend )     , ( "test-stream-open", cmdTestStreamOpen )     , ( "test-stream-close", cmdTestStreamClose )@@ -329,6 +348,8 @@     , ( "local-state-wait", cmdLocalStateWait )     , ( "shared-state-get", cmdSharedStateGet )     , ( "shared-state-wait", cmdSharedStateWait )+    , ( "shared-state-val-get", cmdSharedStateValGet )+    , ( "shared-state-val-set", cmdSharedStateValSet )     , ( "watch-local-identity", cmdWatchLocalIdentity )     , ( "watch-shared-identity", cmdWatchSharedIdentity )     , ( "update-local-identity", cmdUpdateLocalIdentity )@@ -600,7 +621,11 @@             , lsOther = []             }     initTestHead h-    cmdOut $ unwords [ "create-identity-done", "ref", show $ refDigest $ storedRef $ lsIdentity $ headObject h ]+    cmdOut $ unwords+        [ "create-identity-done"+        , "ref", show $ refDigest $ storedRef $ eiddStoredBase $ lsIdentity $ headObject h+        , "extref", show $ refDigest $ storedRef $ lsIdentity $ headObject h+        ]  cmdIdentityInfo :: Command cmdIdentityInfo = do@@ -644,7 +669,11 @@         ( "chatroom", _ ) -> return $ someService @ChatroomService Proxy         ( "contact", _ ) -> return $ someServiceAttr $ pairingAttributes (Proxy @ContactService) out rsPeers "contact"         ( "discovery", params ) -> return $ someServiceAttr $ discoveryAttributes-            { discoveryProvideTunnel = \_ _ -> "tunnel" `elem` params+            { discoveryProvideTunnel+                = \_ paddr -> or+                    [ "tunnel" `elem` params+                    , ("tunnel-" <> T.pack (takeWhile (not . isSpace) $ show paddr)) `elem` params+                    ]             }         ( "dm", _ ) -> return $ someServiceAttr $ directMessageAttributes out         ( "invite", _ ) -> return $ someServiceAttr $ inviteAttributes out@@ -674,9 +703,17 @@             }         ( sname, _ ) -> throwOtherError $ "unknown service `" <> T.unpack sname <> "'" +    serviceTracers <- forM (map fst $ filter (("trace" `elem`) . snd) serviceNames) $ \case+        "discovery" -> return $ servicePacketTracer $ discoveryTracer out+        sname -> throwOtherError $ "tracer not implemented for ‘" <> T.unpack sname <> "’"++    let serverOptions' = serverOptions+            { serverServicePacketTracers = serviceTracers+            }+     let logPrint str = do BC.hPutStrLn stdout (BC.pack str)                           hFlush stdout-    rsServer <- liftIO $ startServer serverOptions h logPrint services+    rsServer <- liftIO $ startServer serverOptions' h logPrint services      rsPeerThread <- liftIO $ forkIO $ void $ forever $ do         peer <- getNextPeerChange rsServer@@ -705,6 +742,7 @@         modifyMVar_ rsPeers update      modify $ \s -> s { tsServer = Just RunningServer {..} }+    cmdOut "start-server-done"  cmdStopServer :: Command cmdStopServer = do@@ -748,7 +786,17 @@             ]     cmdOut "peer-list-done" +cmdPeerGetByAddr :: Command+cmdPeerGetByAddr = do+    Just RunningServer {..} <- gets tsServer+    addr <- T.unwords <$> asks tiParams+    ( _, peers ) <- liftIO $ readMVar rsPeers+    forM_ peers $ \tpeer -> do+        paddr <- getPeerAddress $ tpPeer tpeer+        when (T.pack (show paddr) == addr) $ do+            cmdOut $ "peer-get-by-addr " <> show (tpIndex tpeer) + cmdTestMessageSend :: Command cmdTestMessageSend = do     spidx : trefs <- asks tiParams@@ -838,6 +886,25 @@ cmdSharedStateWait :: Command cmdSharedStateWait = localStateWaitHelper "shared-state-wait" (lsShared . headObject) +cmdSharedStateValGet :: Command+cmdSharedStateValGet = do+    [ stid ] <- asks tiParams+    h <- getOrLoadHead+    case someSymbolVal $ T.unpack stid of+        SomeSymbol (_ :: Proxy tid) -> do+            let value = lookupSharedValueH @(CustomSharedState tid) h+            cmdOut $ unwords $ "shared-state-val-get" : T.unpack stid : map (BC.unpack . showRef . storedRef) (customStateComponents value)++cmdSharedStateValSet :: Command+cmdSharedStateValSet = do+    stid : trefs <- asks tiParams+    st <- asks tiStorage+    Just refs <- liftIO $ fmap sequence $ mapM (readRef st . encodeUtf8) trefs+    case someSymbolVal $ T.unpack stid of+        SomeSymbol (_ :: Proxy tid) -> do+            updateLocalState_ $ updateSharedState_ $ \_ -> do+                return $ CustomSharedState @tid $ map wrappedLoad refs+ cmdWatchLocalIdentity :: Command cmdWatchLocalIdentity = do     h <- getOrLoadHead@@ -845,7 +912,7 @@      out <- asks tiOutput     w <- liftIO $ watchHeadWith h headLocalIdentity $ \idt -> do-        outLine out $ unwords $ "local-identity" : map (maybe "<unnamed>" T.unpack . idName) (unfoldOwners idt)+        outLine out $ unwords $ "local-identity" : show (refDigest $ storedRef $ idExtData idt) : map (maybe "<unnamed>" T.unpack . idName) (unfoldOwners idt)     modify $ \s -> s { tsWatchedLocalIdentity = Just w }  cmdWatchSharedIdentity :: Command

@@ -0,0 +1,24 @@+module Test.State (+    CustomSharedState(..),+) where++import Data.Proxy++import GHC.TypeLits++import Erebos.Object+import Erebos.State+import Erebos.Storage.Merge+++data CustomSharedState (tid :: Symbol) = CustomSharedState+    { customStateComponents :: StoredTips Object+    }++instance Mergeable (CustomSharedState tid) where+    type Component (CustomSharedState tid) = Object+    toComponents = customStateComponents+    mergeSorted = CustomSharedState++instance KnownSymbol tid => SharedType (CustomSharedState tid) where+    sharedTypeID _ = mkSharedTypeID (symbolVal @tid Proxy)

@@ -3,6 +3,7 @@  module Erebos.Discovery (     DiscoveryService(..),+    DiscoveryAddress, DiscoveryVia(..),     DiscoveryAttributes(..),     DiscoveryConnection(..), @@ -59,7 +60,8 @@     | DiscoveryConnectionResponse DiscoveryConnection  data DiscoveryAddress-    = DiscoveryIP InetAddress PortNumber+    = DiscoveryLocalhost PortNumber+    | DiscoveryIP InetAddress PortNumber     | DiscoveryICE     | DiscoveryTunnel     | DiscoveryOther Text@@ -184,6 +186,7 @@  instance StorableText DiscoveryAddress where     toText = \case+        DiscoveryLocalhost port -> T.unwords [ "localhost", T.pack $ show port ]         DiscoveryIP addr port -> T.unwords [ T.pack $ show addr, T.pack $ show port ]         DiscoveryICE -> "ICE"         DiscoveryTunnel -> "tunnel"@@ -191,6 +194,11 @@      fromText str = return $ if         | [ addrStr, portStr ] <- T.words str+        , addrStr == "localhost"+        , Just port <- readMaybe $ T.unpack portStr+        -> DiscoveryLocalhost port++        | [ addrStr, portStr ] <- T.words str         , Just addr <- readMaybe $ T.unpack addrStr         , Just port <- readMaybe $ T.unpack portStr         -> DiscoveryIP addr port@@ -218,6 +226,7 @@     { dpPriority :: Int     , dpPeer :: Maybe Peer     , dpAddress :: [ DiscoveryAddress ]+    , dpLocalhost :: Maybe PortNumber     , dpIceSession :: Maybe IceSession     } @@ -226,20 +235,21 @@     { dpPriority = 0     , dpPeer = Nothing     , dpAddress = []+    , dpLocalhost = Nothing     , dpIceSession = Nothing     }  viaFromPeer :: DiscoveryAttributes -> Peer -> DiscoveryPeer -> IO (Maybe DiscoveryVia) viaFromPeer attrs peer DiscoveryPeer {..}     | Just dpeer <- dpPeer-    , _ : _ <- dpAddress     = do         getPeerIdentity dpeer >>= \case             PeerIdentityFull pid -> do                 offerTunnel <- offerTunnelBetween attrs peer dpeer                 let viaAddress = (if offerTunnel then (++ [ DiscoveryTunnel ]) else id) dpAddress                 let viaIdentity = refDigest $ storedRef $ idData pid-                return $ Just DiscoveryVia {..}+                return $ if null viaAddress then Nothing+                                            else Just DiscoveryVia {..}             _ -> return Nothing     | otherwise     = return Nothing@@ -313,24 +323,28 @@             peer <- asks svcPeer             paddrs <- getPeerAddresses peer +            let matchedAddrs = flip filter addrs $ \case+                    DiscoveryICE -> True+                    DiscoveryIP ipaddr port ->+                        DatagramAddress (inetToSockAddr ( ipaddr, port )) `elem` paddrs+                    _ -> False+                localhostPort = getLocalhostPortFromPeerAddresses paddrs+             debugLog $ unwords                 [ "new peer"                 , show [ refDigest $ storedRef $ idData pid, refDigest $ storedRef $ idExtData pid ]                 , show $ map (refDigest . storedRef) $ idDataF $ finalOwner pid                 , show paddrs+                , show (map toText matchedAddrs)+                , show localhostPort                 ] -            let matchedAddrs = flip filter addrs $ \case-                    DiscoveryICE -> True-                    DiscoveryIP ipaddr port ->-                        DatagramAddress (inetToSockAddr ( ipaddr, port )) `elem` paddrs-                    _ -> False-             forM_ (idDataF =<< unfoldOwners pid) $ \sdata -> do                 let dp = DiscoveryPeer                         { dpPriority = fromMaybe 0 priority                         , dpPeer = Just peer                         , dpAddress = matchedAddrs+                        , dpLocalhost = localhostPort                         , dpIceSession = Nothing                         }                     rv = ResultValue@@ -359,10 +373,19 @@                             st <- getStorage                             forM_ dgsts $ \dgst -> do                                 when (dgst `M.member` peerSearchingFor) $ do-                                    offerTunnel <- offerTunnelBetween attrs peer sp >>= return . \case-                                        True  -> (++ [ DiscoveryTunnel ])-                                        False -> id-                                    let discoveryAddrs = offerTunnel matchedAddrs+                                    discoveryAddrs <- concat <$> sequence+                                        [ case localhostPort of+                                              Just port -> getPeerAddresses sp >>= \case+                                                  spaddrs+                                                      | isJust $ getLocalhostPortFromPeerAddresses spaddrs+                                                      -> return [ DiscoveryLocalhost port ]+                                                  _ -> return []+                                              _ -> return []+                                        , return matchedAddrs+                                        , offerTunnelBetween attrs peer sp >>= return . \case+                                            True  -> [ DiscoveryTunnel ]+                                            False -> []+                                        ]                                     let ( results, via )                                             | dgst == (refDigest $ storedRef $ idData pid)                                             = ( discoveryAddrs, [] )@@ -402,6 +425,7 @@             let dgst = either refDigest id edgst             peer <- asks svcPeer             pid <- asks svcPeerIdentity+            paddrs <- getPeerAddresses peer             (M.lookup dgst . dgsPeers <$> svcGetGlobal) >>= \case                 Just rv                   | direct <- (\p -> Just p <* guard (p /= peer)) =<< dpPeer =<< rvDirect rv@@ -411,14 +435,19 @@                   , isJust direct || not (null rvia)                   -> do                     attrs <- asks svcAttributes-                    offerTunnel <- case direct of-                        Just dpeer -> offerTunnelBetween attrs peer dpeer >>= return . \case-                            True  -> (++ [ DiscoveryTunnel ])-                            False -> id-                        Nothing -> return id-                    let results-                            | isJust direct = offerTunnel $ maybe [] dpAddress $ rvDirect rv-                            | otherwise = []+                    results <- if+                        | isJust direct -> concat <$> sequence+                            [ case ( dpLocalhost =<< rvDirect rv, getLocalhostPortFromPeerAddresses paddrs ) of+                                ( Just port, Just _ ) -> return [ DiscoveryLocalhost port ]+                                _ -> return []+                            , return $ maybe [] dpAddress $ rvDirect rv+                            , case direct of+                                Just dpeer -> offerTunnelBetween attrs peer dpeer >>= return . \case+                                    True  -> [ DiscoveryTunnel ]+                                    False -> []+                                Nothing -> return []+                            ]+                        | otherwise -> return []                     via <- liftIO $ fmap catMaybes $ mapM (viaFromPeer attrs peer) rvia                     replyPacket $ DiscoveryResult edgst results via                     debugLog $ "search by " <> show (refDigest $ storedRef $ idData pid) <>@@ -463,6 +492,14 @@             let runAsService = runPeerService @DiscoveryService @IO discoveryPeer              let tryAddresses = \case+                    DiscoveryLocalhost port : _ -> do+                        void $ liftIO $ forkIO $ do+                            let saddr = makeLocalhostAddress port+                            peer <- serverPeer server saddr+                            runAsService $ do+                                let upd rv = rv { rvDirect = Just $ (fromMaybe emptyPeer $ rvDirect rv) { dpPeer = Just peer } }+                                svcModifyGlobal $ \s -> s { dgsPeers = M.alter (Just . upd . fromMaybe mempty) dgst $ dgsPeers s }+                     DiscoveryIP ipaddr port : _ -> do                         void $ liftIO $ forkIO $ do                             let saddr = inetToSockAddr ( ipaddr, port )@@ -785,16 +822,16 @@             Just (UnhandledService svc) | svc == serviceID (Proxy @DiscoveryService) -> return ()             _ -> throwError e) $ do         peers <- liftIO $ getCurrentPeerList server-        match <- forM peers $ \peer -> do+        peersFull <- fmap catMaybes $ forM peers $ \peer -> do             getPeerIdentity peer >>= \case-                PeerIdentityFull pid -> do-                    return $ dgst `elem` identityDigests pid-                _ -> return False-        when (not $ or match) $ do+                PeerIdentityFull pid -> return $ Just ( peer, pid )+                _ -> return Nothing+        let match = any ((dgst `elem`) . identityDigests . snd) peersFull+        when (not match) $ do             _ <- modifyServiceGlobalState server (Proxy @DiscoveryService) $ \s ->                 ( s { dgsSearchingFor =  S.insert dgst $ dgsSearchingFor s }, () )             now <- liftIO $ getTime Monotonic-            forM_ peers $ \peer -> do+            forM_ peersFull $ \( peer, _ ) -> do                 runPeerService peer $ do                     weAskedFor <- dpsWeAskedFor <$> svcGet                     when (not $ M.member dgst weAskedFor) $ do@@ -882,3 +919,6 @@             (emptyConnection (Right self) (Right target))             { dconnTunnel = True             }++getLocalhostPortFromPeerAddresses :: [ PeerAddress ] -> Maybe PortNumber+getLocalhostPortFromPeerAddresses = msum . map (\case DatagramAddress a -> getLocalhostPort a; _ -> Nothing)

@@ -7,6 +7,7 @@     getNextPeerChangeChan,     getServerAddresses,     ServerOptions(..), serverIdentity, defaultServerOptions,+    ServicePacketTracer, servicePacketTracer,      Peer, peerServer, peerStorage,     PeerAddress(..), getPeerAddress, getPeerAddresses,@@ -131,6 +132,7 @@     , serverLocalDiscovery :: Bool     , serverErrorPrefix :: String     , serverTestLog :: Bool+    , serverServicePacketTracers :: [ ServicePacketTracer ]     }  defaultServerOptions :: ServerOptions@@ -140,9 +142,15 @@     , serverLocalDiscovery = True     , serverErrorPrefix = ""     , serverTestLog = False+    , serverServicePacketTracers = []     } +data ServicePacketTracer = forall s. Service s => ServicePacketTracer (Peer -> PeerAddress -> Stored s -> IO ()) +servicePacketTracer :: forall s. Service s => (Peer -> PeerAddress -> Stored s -> IO ()) -> ServicePacketTracer+servicePacketTracer = ServicePacketTracer++ data Peer = Peer     { peerAddress :: PeerAddress     , peerServer_ :: Server@@ -441,16 +449,16 @@              erebosNetworkProtocol (headLocalIdentity serverOrigHead) logd logt protocolRawPath protocolControlFlow -    forkServerThread server "main-loop" $ withSocketsDo $ do+    withSocketsDo $ do         let hints = defaultHints-              { addrFlags = [AI_PASSIVE]+              { addrFlags = [ AI_PASSIVE ]               , addrFamily = AF_INET6               , addrSocketType = Datagram               }         addr:_ <- getAddrInfo (Just hints) Nothing (Just $ show $ serverPort serverOptions)         let open = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)             closeAndNotify sock = close sock >> putMVar serverSocketClosed ()-        bracket open closeAndNotify $ \sock -> do+        bracketOnError open closeAndNotify $ \sock -> do             withFdSocket sock setCloseOnExecIfNeeded             setSocketOption sock Broadcast 1             bind sock (addrAddress addr) `catchIOError` \e -> if@@ -462,12 +470,18 @@                       bind sock (SockAddrInet6 0 f h s)                 | otherwise -> ioError e             putMVar serverSocket sock-            loop sock+            forkServerThread server "main-loop" $ do+                loop sock `finally` closeAndNotify sock      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)+            Just service@(SomeService (_ :: Proxy s) attr) -> do+                let packet = wrappedLoad @s ref+                forM_ (serverServicePacketTracers serverOptions) $ \case+                    ServicePacketTracer t | Just (t' :: Peer -> PeerAddress -> Stored s -> IO ()) <- cast t -> t' peer paddr packet+                    _ -> return ()+                runPeerServiceOn (Just ( service, attr )) streams paddr peer (serviceHandler packet)             _ -> atomically $ logd $ "unhandled service '" ++ show (toUUID svc) ++ "'"      return server@@ -1102,7 +1116,7 @@                                             putTMVar (serverServiceStates server) $ M.insert svc (SomeServiceGlobalState proxy gs') global                                         return h'                 _ -> do-                    atomically $ logd $ "can't run service handler on peer with incomplete identity " ++ show paddr+                    atomically $ logd $ "can't run service " <> show (toUUID svc) <> " handler on peer with incomplete identity " ++ show paddr          _ -> atomically $ do             logd $ "unhandled service '" ++ show (toUUID svc) ++ "'"

@@ -2,6 +2,8 @@     InetAddress(..),     inetFromSockAddr,     inetToSockAddr,+    makeLocalhostAddress,+    getLocalhostPort,      SockAddr, PortNumber, ) where@@ -63,3 +65,11 @@  inetToSockAddr :: ( InetAddress, PortNumber ) -> SockAddr inetToSockAddr = IP.toSockAddr . first fromInetAddress+++makeLocalhostAddress :: PortNumber -> SockAddr+makeLocalhostAddress port = SockAddrInet6 port 0 ( 0, 0, 0, 1 ) 0++getLocalhostPort :: SockAddr -> Maybe PortNumber+getLocalhostPort (SockAddrInet6 port _ ( 0, 0, 0, 1 ) _) = Just port+getLocalhostPort _                                       = Nothing

@@ -126,7 +126,10 @@     updateLocalHead f = do         h <- ask         snd <$> updateHead' h (\h' -> local (const h') (f $ headStoredObject h'))-    getLocalHeadCache _ = asks headCache++    getLocalHeadCache _ = do+        h <- ask+        snd <$> updateHead' h (\h' -> return ( headStoredObject h', headCache h' ))   newtype LocalHeadT h m a = LocalHeadT { runLocalHeadT_ :: Storage -> ( Stored h, HeadCacheType h ) -> m ( a, ( Stored h, HeadCacheType h ) ) }

@@ -127,12 +127,17 @@ filterAncestors :: Storable a => [ Stored a ] -> StoredTips a filterAncestors [ x ] = [ x ] filterAncestors xs = let xs' = uniq $ sort xs-                      in helper xs' xs'-    where helper remains walk = case generationMax walk of-                                     Just x -> let px = previous x-                                                   remains' = filter (\r -> all (/=r) px) remains-                                                in helper remains' $ uniq $ sort (px ++ filter (/=x) walk)-                                     Nothing -> remains+                      in sort $ helper xs' xs'+  where+    helper [] _ = []+    helper remains walk =+        case generationMax walk of+            Just x ->+                let px = previous x+                    youngerThenX r = Just GT == compareGeneration (storedGeneration r) (storedGeneration x)+                    ( returned, remains' ) = partition youngerThenX $ filter (\r -> all (/= r) px) remains+                 in returned ++ helper remains' (uniq $ sort (px ++ filter (/= x) walk))+            Nothing -> remains  commonAncestors :: Storable a => [ Stored a ] -> [ Stored a ] -> StoredTips a commonAncestors [] _ = []