erebos 0.1.6 → 0.1.7

raw patch · 13 files changed

+300/−73 lines, 13 filesdep +cryptondep −cryptonitePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: crypton

Dependencies removed: cryptonite

API changes (from Hackage documentation)

Files

• CHANGELOG.md +9/−0
• README.md +5/−0
• erebos.cabal +3/−3
• main/Main.hs +21/−2
• main/Test.hs +62/−10
• main/Test/Service.hs +5/−4
• src/Erebos/Chatroom.hs +32/−7
• src/Erebos/ICE/pjproject.c +4/−2
• src/Erebos/Identity.hs +7/−1
• src/Erebos/Network/Protocol.hs +77/−6
• src/Erebos/Network/ifaddrs.c +4/−2
• src/Erebos/State.hs +17/−10
• src/Erebos/Storage.hs +54/−26

@@ -1,7 +1,16 @@ # Revision history for erebos +## 0.1.7 -- 2024-10-30++* Chatroom-specific identity+* Secure cookie for connection initialization+* Support multiple public peers+* Handle unknown object and record item types+* Keep unknown items in local state+ ## 0.1.6 -- 2024-08-12 +* Chatroom members list and join/leave commands * Fix sending multiple data responses in a stream * Added `--storage`/`--memory-storage` command-line options * Compatibility with GHC up to 9.10

@@ -128,6 +128,11 @@ `/join`   : Join chatroom without sending text message. +`/join-as <name>`  +: Join chatroom using a new identity with a name `<name>`. This new identity is+  unrelated to the main one, and will be used for any future messages sent to+  this chatroom.+ `/leave`   : Leave the chatroom. User will no longer be listed as a member and erebos tool   will no longer collect message of this chatroom.

@@ -1,7 +1,7 @@ Cabal-Version:       3.0  Name:                erebos-Version:             0.1.6+Version:             0.1.7 Synopsis:            Decentralized messaging and synchronization Description:     Library and simple CLI interface implementing the Erebos identity@@ -143,7 +143,7 @@         bytestring >=0.10 && <0.13,         clock >=0.8 && < 0.9,         containers >= 0.6 && <0.8,-        cryptonite >=0.25 && <0.31,+        crypton ^>= { 1.0 },         deepseq >= 1.4 && <1.6,         directory >= 1.3 && <1.4,         filepath >=1.4 && <1.6,@@ -187,7 +187,7 @@      build-depends:         bytestring,-        cryptonite,+        crypton,         directory,         erebos,         haskeline >=0.7 && <0.9,

@@ -502,6 +502,7 @@     , ("ice-send", cmdIceSend) #endif     , ("join", cmdJoin)+    , ("join-as", cmdJoinAs)     , ("leave", cmdLeave)     , ("members", cmdMembers)     , ("select", cmdSelectContext)@@ -540,9 +541,20 @@ cmdPeerAddPublic :: Command cmdPeerAddPublic = do     server <- asks ciServer-    addr:_ <- liftIO $ getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just "discovery1.erebosprotocol.net") (Just (show discoveryPort))-    void $ liftIO $ serverPeer server (addrAddress addr)+    liftIO $ mapM_ (serverPeer server . addrAddress) =<< gather 'a'+  where+    gather c+        | c <= 'z' = do+            let hints = Just $ defaultHints { addrSocketType = Datagram }+                hostname = Just $ c : ".discovery.erebosprotocol.net"+                service = Just $ show discoveryPort+            handle (\(_ :: IOException) -> return []) (getAddrInfo hints hostname service) >>= \case+                addr : _ -> (addr :) <$> gather (succ c)+                [] -> return [] +        | otherwise = do+            return []+ cmdPeerDrop :: Command cmdPeerDrop = do     dropPeer =<< getSelectedPeer@@ -558,6 +570,13 @@  cmdJoin :: Command cmdJoin = joinChatroom =<< getSelectedChatroom++cmdJoinAs :: Command+cmdJoinAs = do+    name <- asks ciLine+    st <- getStorage+    identity <- liftIO $ createIdentity st (Just $ T.pack name) Nothing+    joinChatroomAs identity =<< getSelectedChatroom  cmdLeave :: Command cmdLeave = leaveChatroom =<< getSelectedChatroom

@@ -16,6 +16,7 @@ import Data.ByteString qualified as B import Data.ByteString.Char8 qualified as BC import Data.ByteString.Lazy qualified as BL+import Data.ByteString.Lazy.Char8 qualified as BL import Data.Foldable import Data.Ord import Data.Text (Text)@@ -244,6 +245,7 @@ commands :: [(Text, Command)] commands = map (T.pack *** id)     [ ("store", cmdStore)+    , ("load", cmdLoad)     , ("stored-generation", cmdStoredGeneration)     , ("stored-roots", cmdStoredRoots)     , ("stored-set-add", cmdStoredSetAdd)@@ -259,6 +261,9 @@     , ("peer-drop", cmdPeerDrop)     , ("peer-list", cmdPeerList)     , ("test-message-send", cmdTestMessageSend)+    , ("local-state-get", cmdLocalStateGet)+    , ("local-state-replace", cmdLocalStateReplace)+    , ("local-state-wait", cmdLocalStateWait)     , ("shared-state-get", cmdSharedStateGet)     , ("shared-state-wait", cmdSharedStateWait)     , ("watch-local-identity", cmdWatchLocalIdentity)@@ -285,6 +290,7 @@     , ("chatroom-unsubscribe", cmdChatroomUnsubscribe)     , ("chatroom-members", cmdChatroomMembers)     , ("chatroom-join", cmdChatroomJoin)+    , ("chatroom-join-as", cmdChatroomJoinAs)     , ("chatroom-leave", cmdChatroomLeave)     , ("chatroom-message-send", cmdChatroomMessageSend)     ]@@ -299,6 +305,18 @@     ref <- liftIO $ unsafeStoreRawBytes st $ BL.fromChunks [encodeUtf8 otype, BC.singleton ' ', BC.pack (show $ B.length cnt), BC.singleton '\n', cnt]     cmdOut $ "store-done " ++ show (refDigest ref) +cmdLoad :: Command+cmdLoad = do+    st <- asks tiStorage+    [ tref ] <- asks tiParams+    Just ref <- liftIO $ readRef st $ encodeUtf8 tref+    let obj = load @Object ref+    header : content <- return $ BL.lines $ serializeObject obj+    cmdOut $ "load-type " <> T.unpack (decodeUtf8 $ BL.toStrict header)+    forM_ content $ \line -> do+        cmdOut $ "load-line " <> T.unpack (decodeUtf8 $ BL.toStrict line)+    cmdOut "load-done"+ cmdStoredGeneration :: Command cmdStoredGeneration = do     st <- asks tiStorage@@ -422,6 +440,7 @@         storeHead st $ LocalState             { lsIdentity = idExtData identity             , lsShared = shared+            , lsOther = []             }     initTestHead h @@ -438,8 +457,10 @@         , someService @SyncService Proxy         , someService @ChatroomService Proxy         , someServiceAttr $ (defaultServiceAttributes Proxy)-            { testMessageReceived = \otype len sref ->-                liftIO $ outLine out $ unwords ["test-message-received", otype, len, sref]+            { testMessageReceived = \obj otype len sref -> do+                liftIO $ do+                    void $ store (headStorage h) obj+                    outLine out $ unwords ["test-message-received", otype, len, sref]             }         ] @@ -511,29 +532,52 @@     sendManyToPeer peer $ map (TestMessage . wrappedLoad) refs     cmdOut "test-message-send done" -cmdSharedStateGet :: Command-cmdSharedStateGet = do+cmdLocalStateGet :: Command+cmdLocalStateGet = do     h <- getHead-    cmdOut $ unwords $ "shared-state-get" : map (show . refDigest . storedRef) (lsShared $ headObject h)+    cmdOut $ unwords $ "local-state-get" : map (show . refDigest . storedRef) [ headStoredObject h ] -cmdSharedStateWait :: Command-cmdSharedStateWait = do+cmdLocalStateReplace :: Command+cmdLocalStateReplace = do     st <- asks tiStorage+    [ told, tnew ] <- asks tiParams+    Just rold <- liftIO $ readRef st $ encodeUtf8 told+    Just rnew <- liftIO $ readRef st $ encodeUtf8 tnew+    ok <- updateLocalHead @LocalState $ \ls -> do+        if storedRef ls == rold+          then return ( wrappedLoad rnew, True )+          else return ( ls, False )+    cmdOut $ if ok then "local-state-replace-done" else "local-state-replace-failed"++localStateWaitHelper :: Storable a => String -> (Head LocalState -> [ Stored a ]) -> Command+localStateWaitHelper label sel = do+    st <- asks tiStorage     out <- asks tiOutput     h <- getOrLoadHead     trefs <- asks tiParams      liftIO $ do         mvar <- newEmptyMVar-        w <- watchHeadWith h (lsShared . headObject) $ \cur -> do+        w <- watchHeadWith h sel $ \cur -> do             mbobjs <- mapM (readRef st . encodeUtf8) trefs             case map wrappedLoad <$> sequence mbobjs of                 Just objs | filterAncestors (cur ++ objs) == cur -> do-                    outLine out $ unwords $ "shared-state-wait" : map T.unpack trefs+                    outLine out $ unwords $ label : map T.unpack trefs                     void $ forkIO $ unwatchHead =<< takeMVar mvar                 _ -> return ()         putMVar mvar w +cmdLocalStateWait :: Command+cmdLocalStateWait = localStateWaitHelper "local-state-wait" ((: []) . headStoredObject)++cmdSharedStateGet :: Command+cmdSharedStateGet = do+    h <- getHead+    cmdOut $ unwords $ "shared-state-get" : map (show . refDigest . storedRef) (lsShared $ headObject h)++cmdSharedStateWait :: Command+cmdSharedStateWait = localStateWaitHelper "shared-state-wait" (lsShared . headObject)+ cmdWatchLocalIdentity :: Command cmdWatchLocalIdentity = do     h <- getOrLoadHead@@ -714,7 +758,7 @@ cmdChatroomWatchLocal :: Command cmdChatroomWatchLocal = do     [] <- asks tiParams-    h <- getHead+    h <- getOrLoadHead     out <- asks tiOutput     void $ watchChatrooms h $ \_ -> \case         Nothing -> return ()@@ -771,6 +815,14 @@     [ cid ] <- asks tiParams     joinChatroomByStateData =<< getChatroomStateData cid     cmdOut "chatroom-join-done"++cmdChatroomJoinAs :: Command+cmdChatroomJoinAs = do+    [ cid, name ] <- asks tiParams+    st <- asks tiStorage+    identity <- liftIO $ createIdentity st (Just name) Nothing+    joinChatroomAsByStateData identity =<< getChatroomStateData cid+    cmdOut $ unwords [ "chatroom-join-as-done", T.unpack cid ]  cmdChatroomLeave :: Command cmdChatroomLeave = do

@@ -14,7 +14,7 @@ data TestMessage = TestMessage (Stored Object)  data TestMessageAttributes = TestMessageAttributes-    { testMessageReceived :: String -> String -> String -> ServiceHandler TestMessage ()+    { testMessageReceived :: Object -> String -> String -> String -> ServiceHandler TestMessage ()     }  instance Storable TestMessage where@@ -25,12 +25,13 @@     serviceID _ = mkServiceID "cb46b92c-9203-4694-8370-8742d8ac9dc8"      type ServiceAttributes TestMessage = TestMessageAttributes-    defaultServiceAttributes _ = TestMessageAttributes (\_ _ _ -> return ())+    defaultServiceAttributes _ = TestMessageAttributes (\_ _ _ _ -> return ())      serviceHandler smsg = do         let TestMessage sobj = fromStored smsg-        case map BL.unpack $ BL.words $ BL.takeWhile (/='\n') $ serializeObject $ fromStored sobj of+            obj = fromStored sobj+        case map BL.unpack $ BL.words $ BL.takeWhile (/='\n') $ serializeObject obj of             [otype, len] -> do                 cb <- asks $ testMessageReceived . svcAttributes-                cb otype len (show $ refDigest $ storedRef sobj)+                cb obj otype len (show $ refDigest $ storedRef sobj)             _ -> return ()

@@ -13,6 +13,7 @@     chatroomSetSubscribe,     chatroomMembers,     joinChatroom, joinChatroomByStateData,+    joinChatroomAs, joinChatroomAsByStateData,     leaveChatroom, leaveChatroomByStateData,     getMessagesSinceState, @@ -185,15 +186,18 @@ sendChatroomMessageByStateData     :: (MonadStorage m, MonadHead LocalState m, MonadError String m)     => Stored ChatroomStateData -> Text -> m ()-sendChatroomMessageByStateData lookupData msg = sendRawChatroomMessageByStateData lookupData Nothing (Just msg) False+sendChatroomMessageByStateData lookupData msg = sendRawChatroomMessageByStateData lookupData Nothing Nothing (Just msg) False  sendRawChatroomMessageByStateData     :: (MonadStorage m, MonadHead LocalState m, MonadError String m)-    => Stored ChatroomStateData -> Maybe (Stored (Signed ChatMessageData)) -> Maybe Text -> Bool -> m ()-sendRawChatroomMessageByStateData lookupData mdReplyTo mdText mdLeave = void $ findAndUpdateChatroomState $ \cstate -> do+    => Stored ChatroomStateData -> Maybe UnifiedIdentity -> Maybe (Stored (Signed ChatMessageData)) -> Maybe Text -> Bool -> m ()+sendRawChatroomMessageByStateData lookupData mbIdentity mdReplyTo mdText mdLeave = void $ findAndUpdateChatroomState $ \cstate -> do     guard $ any (lookupData `precedesOrEquals`) $ roomStateData cstate     Just $ do-        mdFrom <- finalOwner . localIdentity . fromStored <$> getLocalHead+        mdFrom <- finalOwner <$> if+            | Just identity <- mbIdentity -> return identity+            | Just identity <- roomStateIdentity cstate -> return identity+            | otherwise -> localIdentity . fromStored <$> getLocalHead         secret <- loadKey $ idKeyMessage mdFrom         mdTime <- liftIO getZonedTime         let mdPrev = roomStateMessageData cstate@@ -205,7 +209,8 @@         mergeSorted . (:[]) <$> mstore ChatroomStateData             { rsdPrev = roomStateData cstate             , rsdRoom = []-            , rsdSubscribe = Just True+            , rsdSubscribe = Just (not mdLeave)+            , rsdIdentity = mbIdentity             , rsdMessages = [ mdata ]             } @@ -214,6 +219,7 @@     { rsdPrev :: [Stored ChatroomStateData]     , rsdRoom :: [Stored (Signed ChatroomData)]     , rsdSubscribe :: Maybe Bool+    , rsdIdentity :: Maybe UnifiedIdentity     , rsdMessages :: [Stored (Signed ChatMessageData)]     } @@ -222,6 +228,7 @@     , roomStateRoom :: Maybe Chatroom     , roomStateMessageData :: [Stored (Signed ChatMessageData)]     , roomStateSubscribe :: Bool+    , roomStateIdentity :: Maybe UnifiedIdentity     , roomStateMessages :: [ChatMessage]     } @@ -230,12 +237,14 @@         forM_ rsdPrev $ storeRef "PREV"         forM_ rsdRoom $ storeRef "room"         forM_ rsdSubscribe $ storeInt "subscribe" . bool @Int 0 1+        forM_ rsdIdentity $ storeRef "id" . idExtData         forM_ rsdMessages $ storeRef "msg"      load' = loadRec $ do         rsdPrev <- loadRefs "PREV"         rsdRoom <- loadRefs "room"         rsdSubscribe <- fmap ((/=) @Int 0) <$> loadMbInt "subscribe"+        rsdIdentity <- loadMbUnifiedIdentity "id"         rsdMessages <- loadRefs "msg"         return ChatroomStateData {..} @@ -249,6 +258,7 @@                 ChatroomStateData {..} | null rsdMessages -> Nothing                                        | otherwise        -> Just rsdMessages             roomStateSubscribe = fromMaybe False $ findPropertyFirst rsdSubscribe roomStateData+            roomStateIdentity = findPropertyFirst rsdIdentity roomStateData             roomStateMessages = threadToListSince [] $ concatMap (rsdMessages . fromStored) roomStateData          in ChatroomState {..} @@ -266,6 +276,7 @@         { rsdPrev = []         , rsdRoom = [ rdata ]         , rsdSubscribe = Just True+        , rsdIdentity = Nothing         , rsdMessages = []         } @@ -313,6 +324,7 @@             { rsdPrev = roomStateData cstate             , rsdRoom = [ rdata ]             , rsdSubscribe = Just True+            , rsdIdentity = Nothing             , rsdMessages = []             } @@ -343,6 +355,7 @@             { rsdPrev = roomStateData cstate             , rsdRoom = []             , rsdSubscribe = Just subscribe+            , rsdIdentity = Nothing             , rsdMessages = []             } @@ -364,8 +377,18 @@ joinChatroomByStateData     :: (MonadStorage m, MonadHead LocalState m, MonadError String m)     => Stored ChatroomStateData -> m ()-joinChatroomByStateData lookupData = sendRawChatroomMessageByStateData lookupData Nothing Nothing False+joinChatroomByStateData lookupData = sendRawChatroomMessageByStateData lookupData Nothing Nothing Nothing False +joinChatroomAs+    :: (MonadStorage m, MonadHead LocalState m, MonadError String m)+    => UnifiedIdentity -> ChatroomState -> m ()+joinChatroomAs identity rstate = joinChatroomAsByStateData identity (head $ roomStateData rstate)++joinChatroomAsByStateData+    :: (MonadStorage m, MonadHead LocalState m, MonadError String m)+    => UnifiedIdentity -> Stored ChatroomStateData -> m ()+joinChatroomAsByStateData identity lookupData = sendRawChatroomMessageByStateData lookupData (Just identity) Nothing Nothing False+ leaveChatroom     :: (MonadStorage m, MonadHead LocalState m, MonadError String m)     => ChatroomState -> m ()@@ -374,7 +397,7 @@ leaveChatroomByStateData     :: (MonadStorage m, MonadHead LocalState m, MonadError String m)     => Stored ChatroomStateData -> m ()-leaveChatroomByStateData lookupData = sendRawChatroomMessageByStateData lookupData Nothing Nothing True+leaveChatroomByStateData lookupData = sendRawChatroomMessageByStateData lookupData Nothing Nothing Nothing True  getMessagesSinceState :: ChatroomState -> ChatroomState -> [ChatMessage] getMessagesSinceState cur old = threadToListSince (roomStateMessageData old) (roomStateMessageData cur)@@ -498,6 +521,7 @@                                 { rsdPrev = prev                                 , rsdRoom = room                                 , rsdSubscribe = Nothing+                                , rsdIdentity = Nothing                                 , rsdMessages = []                                 }                             storeSetAddComponent sdata set@@ -542,6 +566,7 @@                                     { rsdPrev = prevData                                     , rsdRoom = []                                     , rsdSubscribe = Nothing+                                    , rsdIdentity = Nothing                                     , rsdMessages = messages                                     }                                 storeSetAddComponent sdata set

@@ -172,7 +172,7 @@  	pj_ice_strans * res; -	struct user_data * udata = malloc(sizeof(struct user_data));+	struct user_data * udata = calloc( 1, sizeof( struct user_data )); 	udata->role = role; 	udata->sptr = sptr; 	udata->cb_init = cb;@@ -213,7 +213,9 @@ 	pj_str_t local_ufrag, local_pwd; 	pj_status_t status; -	pj_ice_strans_get_ufrag_pwd(strans, &local_ufrag, &local_pwd, NULL, NULL);+	status = pj_ice_strans_get_ufrag_pwd( strans, &local_ufrag, &local_pwd, NULL, NULL );+	if( status != PJ_SUCCESS )+		return -status;  	n = snprintf(ufrag, maxlen, "%.*s", (int) local_ufrag.slen, local_ufrag.ptr); 	if (n < 0 || n == maxlen)

@@ -13,7 +13,7 @@     createIdentity,     validateIdentity, validateIdentityF, validateIdentityFE,     validateExtendedIdentity, validateExtendedIdentityF, validateExtendedIdentityFE,-    loadIdentity, loadUnifiedIdentity,+    loadIdentity, loadMbIdentity, loadUnifiedIdentity, loadMbUnifiedIdentity,      mergeIdentity, toUnifiedIdentity, toComposedIdentity,     updateIdentity, updateOwners,@@ -282,8 +282,14 @@ loadIdentity :: String -> LoadRec ComposedIdentity loadIdentity name = maybe (throwError "identity validation failed") return . validateExtendedIdentityF =<< loadRefs name +loadMbIdentity :: String -> LoadRec (Maybe ComposedIdentity)+loadMbIdentity name = return . validateExtendedIdentityF =<< loadRefs name+ loadUnifiedIdentity :: String -> LoadRec UnifiedIdentity loadUnifiedIdentity name = maybe (throwError "identity validation failed") return . validateExtendedIdentity =<< loadRef name++loadMbUnifiedIdentity :: String -> LoadRec (Maybe UnifiedIdentity)+loadMbUnifiedIdentity name = return . (validateExtendedIdentity =<<) =<< loadMbRef name   gatherPrevious :: Set (Stored (Signed ExtendedIdentityData)) -> [Stored (Signed ExtendedIdentityData)] -> Set (Stored (Signed ExtendedIdentityData))

@@ -40,7 +40,17 @@ import Control.Monad.Except import Control.Monad.Trans +import Crypto.Cipher.ChaChaPoly1305 qualified as C+import Crypto.MAC.Poly1305 qualified as C (Auth(..), authTag)+import Crypto.Error+import Crypto.Random++import Data.Binary+import Data.Binary.Get+import Data.Binary.Put import Data.Bits+import Data.ByteArray (Bytes, ScrubbedBytes)+import Data.ByteArray qualified as BA import Data.ByteString (ByteString) import Data.ByteString qualified as B import Data.ByteString.Char8 qualified as BC@@ -51,7 +61,6 @@ import Data.Text (Text) import Data.Text qualified as T import Data.Void-import Data.Word  import System.Clock @@ -104,6 +113,35 @@                          | EncryptedOnly     deriving (Eq, Ord) +data ParsedCookie = ParsedCookie+    { cookieNonce :: C.Nonce+    , cookieValidity :: Word32+    , cookieContent :: ByteString+    , cookieMac :: C.Auth+    }++instance Eq ParsedCookie where+    (==) = (==) `on` (\c -> ( BA.convert (cookieNonce c) :: ByteString, cookieValidity c, cookieContent c, cookieMac c ))++instance Show ParsedCookie where+    show ParsedCookie {..} = show (nonce, cookieValidity, cookieContent, mac)+      where C.Auth mac = cookieMac+            nonce = BA.convert cookieNonce :: ByteString++instance Binary ParsedCookie where+    put ParsedCookie {..} = do+        putByteString $ BA.convert cookieNonce+        putWord32be cookieValidity+        putByteString $ BA.convert cookieMac+        putByteString cookieContent++    get = do+        Just cookieNonce <- maybeCryptoError . C.nonce12 <$> getByteString 12+        cookieValidity <- getWord32be+        Just cookieMac <- maybeCryptoError . C.authTag <$> getByteString 16+        cookieContent <- BL.toStrict <$> getRemainingLazyByteString+        return ParsedCookie {..}+ isHeaderItemAcknowledged :: TransportHeaderItem -> Bool isHeaderItemAcknowledged = \case     Acknowledged {} -> False@@ -168,9 +206,12 @@     , gNextUp :: TMVar (Connection addr, (Bool, TransportPacket PartialObject))     , gLog :: String -> STM ()     , gStorage :: PartialStorage+    , gStartTime :: TimeSpec     , gNowVar :: TVar TimeSpec     , gNextTimeout :: TVar TimeSpec     , gInitConfig :: Ref+    , gCookieKey :: ScrubbedBytes+    , gCookieStartTime :: Word32     }  data Connection addr = Connection@@ -444,11 +485,14 @@     mStorage <- memoryStorage     gStorage <- derivePartialStorage mStorage -    startTime <- getTime Monotonic-    gNowVar <- newTVarIO startTime-    gNextTimeout <- newTVarIO startTime+    gStartTime <- getTime Monotonic+    gNowVar <- newTVarIO gStartTime+    gNextTimeout <- newTVarIO gStartTime     gInitConfig <- store mStorage $ (Rec [] :: Object) +    gCookieKey <- getRandomBytes 32+    gCookieStartTime <- runGet getWord32host . BL.pack . BA.unpack @ScrubbedBytes <$> getRandomBytes 4+     let gs = GlobalState {..}      let signalTimeouts = forever $ do@@ -702,11 +746,38 @@         _ -> return Nothing  createCookie :: GlobalState addr -> addr -> IO Cookie-createCookie GlobalState {} addr = return (Cookie $ BC.pack $ show addr)+createCookie GlobalState {..} addr = do+    (nonceBytes :: Bytes) <- getRandomBytes 12+    validUntil <- (fromNanoSecs (60 * 10^(9 :: Int)) +) <$> getTime Monotonic+    let validSecondsFromStart = fromIntegral $ toNanoSecs (validUntil - gStartTime) `div` (10^(9 :: Int))+        cookieValidity = validSecondsFromStart - gCookieStartTime+        plainContent = BC.pack (show addr)+    throwCryptoErrorIO $ do+        cookieNonce <- C.nonce12 nonceBytes+        st1 <- C.initialize gCookieKey cookieNonce+        let st2 = C.finalizeAAD $ C.appendAAD (BL.toStrict $ runPut $ putWord32be cookieValidity) st1+            (cookieContent, st3) = C.encrypt plainContent st2+            cookieMac = C.finalize st3+        return $ Cookie $ BL.toStrict $ encode $ ParsedCookie {..}  verifyCookie :: GlobalState addr -> addr -> Cookie -> IO Bool-verifyCookie GlobalState {} addr (Cookie cookie) = return $ show addr == BC.unpack cookie+verifyCookie GlobalState {..} addr (Cookie cookie) = do+    ctime <- getTime Monotonic+    return $ fromMaybe False $ do+        ( _, _, ParsedCookie {..} ) <- either (const Nothing) Just $ decodeOrFail $ BL.fromStrict cookie+        maybeCryptoError $ do+            st1 <- C.initialize gCookieKey cookieNonce+            let st2 = C.finalizeAAD $ C.appendAAD (BL.toStrict $ runPut $ putWord32be cookieValidity) st1+                (plainContent, st3) = C.decrypt cookieContent st2+                mac = C.finalize st3 +                validSecondsFromStart = fromIntegral $ cookieValidity + gCookieStartTime+                validUntil = gStartTime + fromNanoSecs (validSecondsFromStart * (10^(9 :: Int)))+            return $ and+                [ mac == cookieMac+                , ctime <= validUntil+                , show addr == BC.unpack plainContent+                ]  reservePacket :: Connection addr -> STM ReservedToSend reservePacket conn@Connection {..} = do

@@ -36,8 +36,10 @@ 		return 0;  	for (struct ifaddrs * ifa = addrs; ifa; ifa = ifa->ifa_next) {-		if (ifa->ifa_addr && ifa->ifa_addr->sa_family == AF_INET6 &&-				!(ifa->ifa_flags & IFF_LOOPBACK)) {+		if( ifa->ifa_addr && ifa->ifa_addr->sa_family == AF_INET6 &&+				! (ifa->ifa_flags & IFF_LOOPBACK) &&+				(ifa->ifa_flags & IFF_MULTICAST) &&+				! IN6_IS_ADDR_LINKLOCAL( & ((struct sockaddr_in6 *) ifa->ifa_addr)->sin6_addr ) ){ 			int idx = if_nametoindex(ifa->ifa_name);  			bool seen = false;

@@ -22,13 +22,15 @@ import Control.Monad.Except import Control.Monad.Reader +import Data.ByteString (ByteString)+import Data.ByteString.Char8 qualified as BC import Data.Foldable import Data.Maybe-import qualified Data.Text as T-import qualified Data.Text.IO as T+import Data.Text qualified as T+import Data.Text.IO qualified as T import Data.Typeable import Data.UUID (UUID)-import qualified Data.UUID as U+import Data.UUID qualified as U  import System.IO @@ -40,6 +42,7 @@ data LocalState = LocalState     { lsIdentity :: Stored (Signed ExtendedIdentityData)     , lsShared :: [Stored SharedState]+    , lsOther :: [ ( ByteString, RecItem ) ]     }  data SharedState = SharedState@@ -58,13 +61,16 @@     sharedTypeID :: proxy a -> SharedTypeID  instance Storable LocalState where-    store' st = storeRec $ do-        storeRef "id" $ lsIdentity st-        mapM_ (storeRef "shared") $ lsShared st+    store' LocalState {..} = storeRec $ do+        storeRef "id" lsIdentity+        mapM_ (storeRef "shared") lsShared+        storeRecItems lsOther -    load' = loadRec $ LocalState-        <$> loadRef "id"-        <*> loadRefs "shared"+    load' = loadRec $ do+        lsIdentity <- loadRef "id"+        lsShared <- loadRefs "shared"+        lsOther <- filter ((`notElem` [ BC.pack "id", BC.pack "shared" ]) . fst) <$> loadRecItems+        return LocalState {..}  instance HeadType LocalState where     headTypeID _ = mkHeadTypeID "1d7491a9-7bcb-4eaa-8f13-c8c4c4087e4e"@@ -123,7 +129,8 @@             }         storeHead st $ LocalState             { lsIdentity = idExtData identity-            , lsShared = [shared]+            , lsShared = [ shared ]+            , lsOther = []             }  localIdentity :: LocalState -> UnifiedIdentity

@@ -38,6 +38,7 @@     storeEmpty, storeInt, storeNum, storeText, storeBinary, storeDate, storeUUID, storeRef, storeRawRef,     storeMbEmpty, storeMbInt, storeMbNum, storeMbText, storeMbBinary, storeMbDate, storeMbUUID, storeMbRef, storeMbRawRef,     storeZRef,+    storeRecItems,      Load, LoadRec,     evalLoad,@@ -121,25 +122,32 @@ openStorage path = modifyIOError annotate $ do     let versionFileName = "erebos-storage"     let versionPath = path </> versionFileName-    let writeVersionFile = writeFile versionPath $ storageVersion <> "\n"+    let writeVersionFile = writeFileOnce versionPath $ BLC.pack $ 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"+    maybeVersion <- handleJust (guard . isDoesNotExistError) (const $ return Nothing) $+        Just <$> readFile versionPath+    version <- case maybeVersion of+        Just versionContent -> do+            return $ takeWhile (/= '\n') versionContent -                    | "objects" `notElem` files || "heads" `notElem` files -> do-                        fail "directory is neither empty, nor an existing erebos storage"+        Nothing -> do+            files <- handleJust (guard . isDoesNotExistError) (const $ return []) $+                listDirectory path+            when (not $ or+                    [ null files+                    , versionFileName `elem` files+                    , (versionFileName ++ ".lock") `elem` files+                    , "objects" `elem` files && "heads" `elem` files+                    ]) $ do+                fail "directory is neither empty, nor an existing erebos storage" -                _ -> writeVersionFile-        False -> do             createDirectoryIfMissing True $ path             writeVersionFile+            takeWhile (/= '\n') <$> readFile versionPath +    when (version /= storageVersion) $ do+        fail $ "unsupported storage version " <> version+     createDirectoryIfMissing True $ path </> "objects"     createDirectoryIfMissing True $ path </> "heads"     watchers <- newMVar (Nothing, [], WatchList 1 [])@@ -210,24 +218,30 @@                       mbobj <- sequence $ copyObject' st <$> mbobj'                       sequence $ unsafeStoreObject st <$> join mbobj +copyRecItem' :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> RecItem' c -> IO (c (RecItem' c'))+copyRecItem' st = \case+    RecEmpty -> return $ return $ RecEmpty+    RecInt x -> return $ return $ RecInt x+    RecNum x -> return $ return $ RecNum x+    RecText x -> return $ return $ RecText x+    RecBinary x -> return $ return $ RecBinary x+    RecDate x -> return $ return $ RecDate x+    RecUUID x -> return $ return $ RecUUID x+    RecRef x -> fmap RecRef <$> copyRef' st x+    RecUnknown t x -> return $ return $ RecUnknown t x+ copyObject' :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> Object' c -> IO (c (Object' c')) copyObject' _ (Blob bs) = return $ return $ Blob bs-copyObject' st (Rec rs) = fmap Rec . sequence <$> mapM copyItem rs-    where copyItem :: (ByteString, RecItem' c) -> IO (c (ByteString, RecItem' c'))-          copyItem (n, item) = fmap (n,) <$> case item of-              RecEmpty -> return $ return $ RecEmpty-              RecInt x -> return $ return $ RecInt x-              RecNum x -> return $ return $ RecNum x-              RecText x -> return $ return $ RecText x-              RecBinary x -> return $ return $ RecBinary x-              RecDate x -> return $ return $ RecDate x-              RecUUID x -> return $ return $ RecUUID x-              RecRef x -> fmap RecRef <$> copyRef' st x+copyObject' st (Rec rs) = fmap Rec . sequence <$> mapM (\( n, item ) -> fmap ( n, ) <$> copyRecItem' st item) rs copyObject' _ ZeroObject = return $ return ZeroObject+copyObject' _ (UnknownObject otype content) = return $ return $ UnknownObject otype content  copyRef :: forall c c' m. (StorageCompleteness c, StorageCompleteness c', MonadIO m) => Storage' c' -> Ref' c -> m (LoadResult c (Ref' c')) copyRef st ref' = liftIO $ returnLoadResult <$> copyRef' st ref' +copyRecItem :: forall c c' m. (StorageCompleteness c, StorageCompleteness c', MonadIO m) => Storage' c' -> RecItem' c -> m (LoadResult c (RecItem' c'))+copyRecItem st item' = liftIO $ returnLoadResult <$> copyRecItem' st item'+ copyObject :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> Object' c -> IO (LoadResult c (Object' c')) copyObject st obj' = returnLoadResult <$> copyObject' st obj' @@ -242,6 +256,7 @@     = Blob ByteString     | Rec [(ByteString, RecItem' c)]     | ZeroObject+    | UnknownObject ByteString ByteString     deriving (Show)  type Object = Object' Complete@@ -256,6 +271,7 @@     | RecDate ZonedTime     | RecUUID UUID     | RecRef (Ref' c)+    | RecUnknown ByteString ByteString     deriving (Show)  type RecItem = RecItem' Complete@@ -266,6 +282,7 @@     Rec rec -> let cnt = BL.fromChunks $ concatMap (uncurry serializeRecItem) rec                 in BL.fromChunks [BC.pack "rec ", BC.pack (show $ BL.length cnt), BC.singleton '\n'] `BL.append` cnt     ZeroObject -> BL.empty+    UnknownObject otype cnt -> BL.fromChunks [ otype, BC.singleton ' ', BC.pack (show $ B.length cnt), BC.singleton '\n', cnt ]  -- |Serializes and stores object data without ony dependencies, so is safe only -- if all the referenced objects are already stored or reference is partial.@@ -292,6 +309,7 @@ serializeRecItem name (RecDate x) = [name, BC.pack ":d", BC.singleton ' ', BC.pack (formatTime defaultTimeLocale "%s %z" x), BC.singleton '\n'] serializeRecItem name (RecUUID x) = [name, BC.pack ":u", BC.singleton ' ', U.toASCIIBytes x, BC.singleton '\n'] serializeRecItem name (RecRef x) = [name, BC.pack ":r ", showRef x, BC.singleton '\n']+serializeRecItem name (RecUnknown t x) = [ name, BC.singleton ':', t, BC.singleton ' ', x, BC.singleton '\n' ]  lazyLoadObject :: forall c. StorageCompleteness c => Ref' c -> LoadResult c (Object' c) lazyLoadObject = returnLoadResult . unsafePerformIO . ioLoadObject@@ -324,7 +342,7 @@                  _ | otype == BC.pack "blob" -> return $ Blob content                    | otype == BC.pack "rec" -> maybe (throwError $ "Malformed record item ")                                                    (return . Rec) $ sequence $ map parseRecLine $ mergeCont [] $ BC.lines content-                   | otherwise -> throwError $ "Unknown object type"+                   | otherwise -> return $ UnknownObject otype content         _ -> throwError $ "Malformed object"     where splitObjPrefix line = do               [otype, tlen] <- return $ BLC.words line@@ -344,7 +362,8 @@                   itype = B.take (space-colon-1) $ B.drop (colon+1) line                   content = B.drop (space+1) line -              val <- case BC.unpack itype of+              let val = fromMaybe (RecUnknown itype content) $+                      case BC.unpack itype of                           "e" -> do guard $ B.null content                                     return RecEmpty                           "i" -> do (num, rest) <- BC.readInteger content@@ -605,6 +624,7 @@ data Store = StoreBlob ByteString            | StoreRec (forall c. StorageCompleteness c => Storage' c -> [IO [(ByteString, RecItem' c)]])            | StoreZero+           | StoreUnknown ByteString ByteString  evalStore :: StorageCompleteness c => Storage' c -> Store -> IO (Ref' c) evalStore st = unsafeStoreObject st <=< evalStoreObject st@@ -613,6 +633,7 @@ evalStoreObject _ (StoreBlob x) = return $ Blob x evalStoreObject s (StoreRec f) = Rec . concat <$> sequence (f s) evalStoreObject _ StoreZero = return ZeroObject+evalStoreObject _ (StoreUnknown otype content) = return $ UnknownObject otype content  newtype StoreRecM c a = StoreRecM (ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) a)     deriving (Functor, Applicative, Monad)@@ -647,6 +668,7 @@         Rec xs' <- copyObject st (Rec xs)         return xs'     store' ZeroObject = StoreZero+    store' (UnknownObject otype content) = StoreUnknown otype content      load' = loadCurrentObject @@ -790,6 +812,12 @@         return $ if isZeroRef ref then []                                   else [(BC.pack name, RecRef ref)] +storeRecItems :: StorageCompleteness c => [ ( ByteString, RecItem ) ] -> StoreRec c+storeRecItems items = StoreRecM $ do+    st <- ask+    tell $ flip map items $ \( name, value ) -> do+        value' <- copyRecItem st value+        return [ ( name, value' ) ]  loadBlob :: (ByteString -> a) -> Load a loadBlob f = loadCurrentObject >>= \case