From 497c11fd3636f3befd1e8dce4cd9dff8b3c63844 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Sat, 18 Oct 2025 22:45:29 +0200 Subject: Invite service and shared state Changelog: New service and shared state for invites --- erebos.cabal | 1 + main/Test.hs | 51 ++++++++++++ src/Erebos/Contact.hs | 2 + src/Erebos/Identity.hs | 6 +- src/Erebos/Invite.hs | 213 +++++++++++++++++++++++++++++++++++++++++++++++++ test/invite.et | 73 +++++++++++++++++ 6 files changed, 343 insertions(+), 3 deletions(-) create mode 100644 src/Erebos/Invite.hs create mode 100644 test/invite.et diff --git a/erebos.cabal b/erebos.cabal index c3080ed..4aabb73 100644 --- a/erebos.cabal +++ b/erebos.cabal @@ -107,6 +107,7 @@ library Erebos.Discovery Erebos.Error Erebos.Identity + Erebos.Invite Erebos.Network Erebos.Object Erebos.Pairing diff --git a/main/Test.hs b/main/Test.hs index 42e9c94..17dc228 100644 --- a/main/Test.hs +++ b/main/Test.hs @@ -15,10 +15,12 @@ import Control.Monad.State import Crypto.Random import Data.Bool +import Data.ByteString (ByteString) 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.Char import Data.Foldable import Data.Ord import Data.Text (Text) @@ -39,6 +41,7 @@ import Erebos.Contact import Erebos.DirectMessage import Erebos.Discovery import Erebos.Identity +import Erebos.Invite import Erebos.Network import Erebos.Object import Erebos.Pairing @@ -128,6 +131,26 @@ getHead = do modify $ \s -> s { tsHead = Just h } return h +showHex :: ByteString -> ByteString +showHex = B.concat . map showHexByte . B.unpack + where showHexChar x | x < 10 = x + o '0' + | otherwise = x + o 'a' - 10 + showHexByte x = B.pack [ showHexChar (x `div` 16), showHexChar (x `mod` 16) ] + o = fromIntegral . ord + +readHex :: ByteString -> Maybe ByteString +readHex = return . B.concat <=< readHex' + where readHex' bs | B.null bs = Just [] + readHex' bs = do (bx, bs') <- B.uncons bs + (by, bs'') <- B.uncons bs' + x <- hexDigit bx + y <- hexDigit by + (B.singleton (x * 16 + y) :) <$> readHex' bs'' + hexDigit x | x >= o '0' && x <= o '9' = Just $ x - o '0' + | x >= o 'a' && x <= o 'z' = Just $ x - o 'a' + 10 + | otherwise = Nothing + o = fromIntegral . ord + type Output = MVar () @@ -232,6 +255,17 @@ discoveryAttributes = (defaultServiceAttributes Proxy) { discoveryProvideTunnel = \_ _ -> False } +inviteAttributes :: Output -> InviteServiceAttributes +inviteAttributes out = (defaultServiceAttributes Proxy) + { inviteHookAccepted = \token -> do + pid <- asks svcPeerIdentity + afterCommit $ outLine out $ "invite-accepted " <> BC.unpack (showHex token) <> " " <> (BC.unpack $ showRef $ storedRef $ idExtData pid) + , inviteHookReplyContact = \token _ -> do + afterCommit $ outLine out $ "invite-accept-done " <> BC.unpack (showHex token) <> " contact" + , inviteHookReplyInvalid = \token -> do + afterCommit $ outLine out $ "invite-accept-done " <> BC.unpack (showHex token) <> " invalid" + } + dmThreadWatcher :: ComposedIdentity -> Output -> DirectMessageThread -> DirectMessageThread -> IO () dmThreadWatcher self out prev cur = do forM_ (reverse $ dmThreadToListSince prev cur) $ \msg -> do @@ -327,6 +361,8 @@ commands = , ( "chatroom-message-send", cmdChatroomMessageSend ) , ( "discovery-connect", cmdDiscoveryConnect ) , ( "discovery-tunnel", cmdDiscoveryTunnel ) + , ( "invite-contact-create", cmdInviteContactCreate ) + , ( "invite-accept", cmdInviteAccept ) ] cmdStore :: Command @@ -572,6 +608,7 @@ cmdStartServer = do { discoveryProvideTunnel = \_ _ -> "tunnel" `elem` params } ( "dm", _ ) -> return $ someServiceAttr $ directMessageAttributes out + ( "invite", _ ) -> return $ someServiceAttr $ inviteAttributes out ( "sync", _ ) -> return $ someService @SyncService Proxy ( "test", _ ) -> return $ someServiceAttr $ (defaultServiceAttributes Proxy) { testMessageReceived = \obj otype len sref -> do @@ -1043,3 +1080,17 @@ cmdDiscoveryTunnel = do via <- getPeer tvia Just target <- return $ readRefDigest $ encodeUtf8 ttarget liftIO $ discoverySetupTunnel via target + +cmdInviteContactCreate :: Command +cmdInviteContactCreate = do + [ name ] <- asks tiParams + Just token <- inviteToken <$> createSingleContactInvite name + cmdOut $ unwords [ "invite-contact-create-done", BC.unpack (showHex token) ] + +cmdInviteAccept :: Command +cmdInviteAccept = do + [ tokenText, idref ] <- asks tiParams + Just token <- return $ readHex $ encodeUtf8 tokenText + Just from <- return $ readRefDigest $ encodeUtf8 idref + Just RunningServer {..} <- gets tsServer + acceptInvite rsServer from token diff --git a/src/Erebos/Contact.hs b/src/Erebos/Contact.hs index b081ddb..78a504a 100644 --- a/src/Erebos/Contact.hs +++ b/src/Erebos/Contact.hs @@ -4,6 +4,8 @@ module Erebos.Contact ( contactCustomName, contactName, + ContactData(..), + contactSetName, ContactService, diff --git a/src/Erebos/Identity.hs b/src/Erebos/Identity.hs index bd5acb3..491df6e 100644 --- a/src/Erebos/Identity.hs +++ b/src/Erebos/Identity.hs @@ -391,13 +391,13 @@ sameIdentity x y = intersectsSorted (roots x) (roots y) roots idt = uniq $ sort $ concatMap storedRoots $ toList $ idDataF idt -unfoldOwners :: (Foldable m) => Identity m -> [ComposedIdentity] +unfoldOwners :: Foldable m => Identity m -> [ComposedIdentity] unfoldOwners = unfoldr (fmap (\i -> (i, idOwner i))) . Just . toComposedIdentity -finalOwner :: (Foldable m, Applicative m) => Identity m -> ComposedIdentity +finalOwner :: Foldable m => Identity m -> ComposedIdentity finalOwner = last . unfoldOwners -displayIdentity :: (Foldable m, Applicative m) => Identity m -> Text +displayIdentity :: Foldable m => Identity m -> Text displayIdentity identity = T.concat [ T.intercalate (T.pack " / ") $ map (fromMaybe (T.pack "") . idName) owners ] diff --git a/src/Erebos/Invite.hs b/src/Erebos/Invite.hs new file mode 100644 index 0000000..f860fbc --- /dev/null +++ b/src/Erebos/Invite.hs @@ -0,0 +1,213 @@ +module Erebos.Invite ( + Invite(..), + InviteData(..), + InviteService, + InviteServiceAttributes(..), + + createSingleContactInvite, + acceptInvite, +) where + +import Control.Arrow +import Control.Monad +import Control.Monad.Except +import Control.Monad.IO.Class +import Control.Monad.Reader + +import Crypto.Random + +import Data.ByteString (ByteString) +import Data.ByteString.Char8 qualified as BC +import Data.Foldable +import Data.Ord +import Data.Text (Text) + +import Erebos.Contact +import Erebos.Identity +import Erebos.Network +import Erebos.Object +import Erebos.PubKey +import Erebos.Service +import Erebos.Set +import Erebos.State +import Erebos.Storable +import Erebos.Storage.Merge +import Erebos.Util + + +data Invite = Invite + { inviteData :: [ Stored InviteData ] + , inviteToken :: Maybe ByteString + , inviteAccepted :: [ Stored (Signed ExtendedIdentityData) ] + , inviteContact :: Maybe Text + } + +data InviteData = InviteData + { invdPrev :: [ Stored InviteData ] + , invdToken :: Maybe ByteString + , invdAccepted :: Maybe (Stored (Signed ExtendedIdentityData)) + , invdContact :: Maybe Text + } + +instance Storable InviteData where + store' x = storeRec $ do + mapM_ (storeRef "PREV") $ invdPrev x + mapM_ (storeBinary "token") $ invdToken x + mapM_ (storeRef "accepted") $ invdAccepted x + mapM_ (storeText "contact") $ invdContact x + + load' = loadRec $ InviteData + <$> loadRefs "PREV" + <*> loadMbBinary "token" + <*> loadMbRef "accepted" + <*> loadMbText "contact" + + +instance Mergeable Invite where + type Component Invite = InviteData + + mergeSorted invdata = Invite + { inviteData = invdata + , inviteToken = findPropertyFirst invdToken invdata + , inviteAccepted = findProperty invdAccepted invdata + , inviteContact = findPropertyFirst invdContact invdata + } + + toComponents = inviteData + +instance SharedType (Set Invite) where + sharedTypeID _ = mkSharedTypeID "78da787a-9380-432e-a51d-532a30d27b3d" + + +createSingleContactInvite :: MonadHead LocalState m => Text -> m Invite +createSingleContactInvite name = do + token <- liftIO $ getRandomBytes 32 + invite <- mergeSorted @Invite . (: []) <$> mstore InviteData + { invdPrev = [] + , invdToken = Just token + , invdAccepted = Nothing + , invdContact = Just name + } + updateLocalState_ $ updateSharedState_ $ \invites -> do + storeSetAdd invite invites + return invite + +identityOwnerDigests :: Foldable f => Identity f -> [ RefDigest ] +identityOwnerDigests pid = map (refDigest . storedRef) $ concatMap toList $ toList $ generations $ idExtDataF $ finalOwner pid + +acceptInvite :: (MonadIO m, MonadError e m, FromErebosError e) => Server -> RefDigest -> ByteString -> m () +acceptInvite server from token = do + let matchPeer peer = do + getPeerIdentity peer >>= \case + PeerIdentityFull pid -> do + return $ from `elem` identityOwnerDigests pid + _ -> return False + liftIO (findPeer server matchPeer) >>= \case + Just peer -> runPeerService @InviteService peer $ do + svcModify (token :) + replyPacket $ AcceptInvite token + Nothing -> do + throwOtherError "peer not found" + + +data InviteService + = AcceptInvite ByteString + | InvalidInvite ByteString + | ContactInvite ByteString (Maybe Text) + | UnknownInvitePacket + +data InviteServiceAttributes = InviteServiceAttributes + { inviteHookAccepted :: ByteString -> ServiceHandler InviteService () + , inviteHookReplyContact :: ByteString -> Maybe Text -> ServiceHandler InviteService () + , inviteHookReplyInvalid :: ByteString -> ServiceHandler InviteService () + } + +defaultInviteServiceAttributes :: InviteServiceAttributes +defaultInviteServiceAttributes = InviteServiceAttributes + { inviteHookAccepted = \_ -> return () + , inviteHookReplyContact = \_ _ -> return () + , inviteHookReplyInvalid = \_ -> return () + } + +instance Storable InviteService where + store' x = storeRec $ case x of + AcceptInvite token -> storeBinary "accept" token + InvalidInvite token -> storeBinary "invalid" token + ContactInvite token mbName -> do + storeBinary "valid" token + maybe (storeEmpty "contact") (storeText "contact") mbName + UnknownInvitePacket -> return () + + load' = loadRec $ msum + [ AcceptInvite <$> loadBinary "accept" + , InvalidInvite <$> loadBinary "invalid" + , ContactInvite <$> loadBinary "valid" <*> msum + [ return Nothing <* loadEmpty "contact" + , Just <$> loadText "contact" + ] + , return UnknownInvitePacket + ] + +instance Service InviteService where + serviceID _ = mkServiceID "70bff715-6856-43a0-8c58-007a06a26eb1" + + type ServiceState InviteService = [ ByteString ] -- accepted invites, waiting for reply + emptyServiceState _ = [] + + type ServiceAttributes InviteService = InviteServiceAttributes + defaultServiceAttributes _ = defaultInviteServiceAttributes + + serviceHandler = fromStored >>> \case + AcceptInvite token -> do + asks (inviteHookAccepted . svcAttributes) >>= ($ token) + invites <- fromSetBy (comparing inviteToken) . lookupSharedValue . lsShared . fromStored <$> getLocalHead + case find ((Just token ==) . inviteToken) invites of + Just invite + | Just name <- inviteContact invite + , [] <- inviteAccepted invite + -> do + identity <- asks svcPeerIdentity + cdata <- mstore ContactData + { cdPrev = [] + , cdIdentity = idExtDataF $ finalOwner identity + , cdName = Just name + } + invdata <- mstore InviteData + { invdPrev = inviteData invite + , invdToken = Nothing + , invdAccepted = Just (idExtData identity) + , invdContact = Nothing + } + updateLocalState_ $ updateSharedState_ $ storeSetAdd (mergeSorted @Contact [ cdata ]) + updateLocalState_ $ updateSharedState_ $ storeSetAdd (mergeSorted @Invite [ invdata ]) + replyPacket $ ContactInvite token Nothing + + | otherwise -> do + replyPacket $ InvalidInvite token + + Nothing -> do + replyPacket $ InvalidInvite token + + InvalidInvite token -> do + asks (inviteHookReplyInvalid . svcAttributes) >>= ($ token) + svcModify $ filter (/= token) + svcPrint $ "Invite " <> BC.unpack (showHex token) <> " rejected as invalid" + + ContactInvite token mbName -> do + asks (inviteHookReplyContact . svcAttributes) >>= ($ mbName) . ($ token) + waitingTokens <- svcGet + if token `elem` waitingTokens + then do + svcSet $ filter (/= token) waitingTokens + identity <- asks svcPeerIdentity + cdata <- mstore ContactData + { cdPrev = [] + , cdIdentity = idExtDataF $ finalOwner identity + , cdName = Nothing + } + updateLocalState_ $ updateSharedState_ $ storeSetAdd (mergeSorted @Contact [ cdata ]) + else do + svcPrint $ "Received unexpected invite response for " <> BC.unpack (showHex token) + + UnknownInvitePacket -> do + svcPrint $ "Received unknown invite packet" diff --git a/test/invite.et b/test/invite.et new file mode 100644 index 0000000..bf1a45a --- /dev/null +++ b/test/invite.et @@ -0,0 +1,73 @@ +module invite + +import common + +test InviteContact: + let services = "contact,invite" + + spawn as p1 + spawn as p2 + + send "create-identity Device1 Owner1" to p1 + expect /create-identity-done ref ($refpat)/ from p1 capture p1id + send "identity-info $p1id" to p1 + expect /identity-info ref $p1id base ($refpat) owner ($refpat).*/ from p1 capture p1base, p1owner + send "identity-info $p1owner" to p1 + expect /identity-info ref $p1owner base ($refpat).*/ from p1 capture p1obase + + send "create-identity Device2 Owner2" to p2 + expect /create-identity-done ref ($refpat)/ from p2 capture p2id + + send "start-server services $services" to p1 + send "start-server services $services" to p2 + + expect from p1: + /peer ([0-9]+) addr ${p2.node.ip} 29665/ capture peer1_2 + /peer $peer1_2 id Device2 Owner2/ + + expect from p2: + /peer ([0-9]+) addr ${p1.node.ip} 29665/ capture peer2_1 + /peer $peer2_1 id Device1 Owner1/ + + send "invite-contact-create Contact2" to p1 + expect from p1 /invite-contact-create-done ([^ ]+)/ capture token + + with p2: + send "invite-accept 00 $p1obase" + expect /invite-accept-done 00 invalid/ + + send "contact-list" + expect: + /contact-list-(.*)/ capture done + guard (done == "done") + + with p2: + send "invite-accept $token $p1obase" + expect /invite-accept-done $token contact/ + + send "contact-list" + expect: + /contact-list-item [a-z0-9#]+ Owner1 Owner1/ + /contact-list-(.*)/ capture done + guard (done == "done") + + with p2: + send "invite-accept $token $p1obase" + expect /invite-accept-done $token invalid/ + + send "contact-list" + expect: + /contact-list-item [a-z0-9#]+ Owner1 Owner1/ + /contact-list-(.*)/ capture done + guard (done == "done") + + with p1: + expect /invite-accepted 00 $p2id/ + expect /invite-accepted $token $p2id/ + expect /invite-accepted $token $p2id/ + + send "contact-list" + expect: + /contact-list-item [a-z0-9#]+ Contact2 Owner2/ + /contact-list-(.*)/ capture done + guard (done == "done") -- cgit v1.2.3