diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -128,6 +128,11 @@ `/join` : Join chatroom without sending text message. +`/join-as ` +: Join chatroom using a new identity with a 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. diff --git a/erebos.cabal b/erebos.cabal --- a/erebos.cabal +++ b/erebos.cabal @@ -1,7 +1,7 @@ Cabal-Version: 3.0 Name: erebos -Version: 0.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, diff --git a/main/Main.hs b/main/Main.hs --- a/main/Main.hs +++ b/main/Main.hs @@ -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 diff --git a/main/Test.hs b/main/Test.hs --- a/main/Test.hs +++ b/main/Test.hs @@ -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 diff --git a/main/Test/Service.hs b/main/Test/Service.hs --- a/main/Test/Service.hs +++ b/main/Test/Service.hs @@ -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 () diff --git a/src/Erebos/Chatroom.hs b/src/Erebos/Chatroom.hs --- a/src/Erebos/Chatroom.hs +++ b/src/Erebos/Chatroom.hs @@ -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 diff --git a/src/Erebos/ICE/pjproject.c b/src/Erebos/ICE/pjproject.c --- a/src/Erebos/ICE/pjproject.c +++ b/src/Erebos/ICE/pjproject.c @@ -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) diff --git a/src/Erebos/Identity.hs b/src/Erebos/Identity.hs --- a/src/Erebos/Identity.hs +++ b/src/Erebos/Identity.hs @@ -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)) diff --git a/src/Erebos/Network/Protocol.hs b/src/Erebos/Network/Protocol.hs --- a/src/Erebos/Network/Protocol.hs +++ b/src/Erebos/Network/Protocol.hs @@ -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 diff --git a/src/Erebos/Network/ifaddrs.c b/src/Erebos/Network/ifaddrs.c --- a/src/Erebos/Network/ifaddrs.c +++ b/src/Erebos/Network/ifaddrs.c @@ -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; diff --git a/src/Erebos/State.hs b/src/Erebos/State.hs --- a/src/Erebos/State.hs +++ b/src/Erebos/State.hs @@ -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 diff --git a/src/Erebos/Storage.hs b/src/Erebos/Storage.hs --- a/src/Erebos/Storage.hs +++ b/src/Erebos/Storage.hs @@ -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