From c45dcd68255404da844f9b2c4b35c85d48da6866 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Sat, 17 Jan 2026 16:33:11 +0100 Subject: Accept invites via shared state --- main/Main.hs | 3 +- main/Test.hs | 8 ++-- src/Erebos/Invite.hs | 128 ++++++++++++++++++++++++++++++++++++++++++++------- test/invite.et | 67 +++++++++++++++++++++++++-- 4 files changed, 181 insertions(+), 25 deletions(-) diff --git a/main/Main.hs b/main/Main.hs index 227451f..ec8c98a 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -992,8 +992,7 @@ cmdInviteAccept = do , Just from <- readRefDigest $ T.encodeUtf8 $ "blake2#" <> tfrom , Just token <- parseInviteToken tinv -> do - server <- asks ciServer - acceptInvite server from token + acceptInvite from token _ -> throwOtherError "invalit invite URL" cmdConversations :: Command diff --git a/main/Test.hs b/main/Test.hs index 7fdf5fc..5b6509a 100644 --- a/main/Test.hs +++ b/main/Test.hs @@ -239,9 +239,9 @@ inviteAttributes out = (defaultServiceAttributes Proxy) pid <- asks svcPeerIdentity afterCommit $ outLine out $ "invite-accepted " <> maybe "" showInviteToken inviteToken <> " " <> (BC.unpack $ showRef $ storedRef $ idExtData pid) , inviteHookReplyContact = \token _ -> do - afterCommit $ outLine out $ "invite-accept-done " <> showInviteToken token <> " contact" + afterCommit $ outLine out $ "invite-reply " <> showInviteToken token <> " contact" , inviteHookReplyInvalid = \token -> do - afterCommit $ outLine out $ "invite-accept-done " <> showInviteToken token <> " invalid" + afterCommit $ outLine out $ "invite-reply " <> showInviteToken token <> " invalid" } dmThreadWatcher :: ComposedIdentity -> Output -> DirectMessageThread -> DirectMessageThread -> IO () @@ -1091,5 +1091,5 @@ cmdInviteAccept = do [ tokenText, idref ] <- asks tiParams Just token <- return $ parseInviteToken tokenText Just from <- return $ readRefDigest $ encodeUtf8 idref - Just RunningServer {..} <- gets tsServer - acceptInvite rsServer from token + acceptInvite from token + cmdOut $ unwords [ "invite-accept-done", showInviteToken token ] diff --git a/src/Erebos/Invite.hs b/src/Erebos/Invite.hs index d815625..70ccffb 100644 --- a/src/Erebos/Invite.hs +++ b/src/Erebos/Invite.hs @@ -3,6 +3,8 @@ module Erebos.Invite ( Invite(..), InviteData(..), + AcceptedInvite(..), + AcceptedInviteData(..), InviteToken, showInviteToken, textInviteToken, parseInviteToken, InviteService, InviteServiceAttributes(..), @@ -23,6 +25,7 @@ import Data.ByteArray (ByteArray, ByteArrayAccess) import Data.ByteString (ByteString) import Data.ByteString.Char8 qualified as BC import Data.Foldable +import Data.Maybe import Data.Ord import Data.Text (Text) import Data.Text qualified as T @@ -98,6 +101,54 @@ instance SharedType (Set Invite) where sharedTypeID _ = mkSharedTypeID "78da787a-9380-432e-a51d-532a30d27b3d" +data AcceptedInvite = AcceptedInvite + { acceptedInviteData :: [ Stored AcceptedInviteData ] + , acceptedInviteToken :: Maybe InviteToken + , acceptedInviteFrom :: Maybe RefDigest + , acceptedInviteConfirmed :: Bool + , acceptedInviteRejected :: Bool + } + +data AcceptedInviteData = AcceptedInviteData + { aidPrev :: [ Stored AcceptedInviteData ] + , aidToken :: Maybe InviteToken + , aidFrom :: Maybe RefDigest + , aidConfirmed :: Bool + , aidRejected :: Bool + } + +instance Storable AcceptedInviteData where + store' AcceptedInviteData {..} = storeRec $ do + mapM_ (storeRef "PREV") aidPrev + mapM_ (storeBinary "token") aidToken + mapM_ (storeRawWeak "from") aidFrom + when aidConfirmed $ storeEmpty "confirmed" + when aidRejected $ storeEmpty "rejected" + + load' = loadRec $ do + aidPrev <- loadRefs "PREV" + aidToken <- loadMbBinary "token" + aidFrom <- loadMbRawWeak "from" + aidConfirmed <- isJust <$> loadMbEmpty "confirmed" + aidRejected <- isJust <$> loadMbEmpty "rejected" + return AcceptedInviteData {..} + +instance Mergeable AcceptedInvite where + type Component AcceptedInvite = AcceptedInviteData + + mergeSorted aidata = AcceptedInvite + { acceptedInviteData = aidata + , acceptedInviteToken = findPropertyFirst aidToken aidata + , acceptedInviteFrom = findPropertyFirst aidFrom aidata + , acceptedInviteConfirmed = not $ null $ findProperty (\aid -> if aidConfirmed aid then Just () else Nothing) aidata + , acceptedInviteRejected = not $ null $ findProperty (\aid -> if aidRejected aid then Just () else Nothing) aidata + } + toComponents = acceptedInviteData + +instance SharedType (Set AcceptedInvite) where + sharedTypeID _ = mkSharedTypeID "b1ebf228-4892-476b-ba04-0c26320139b1" + + createSingleContactInvite :: MonadHead LocalState m => Text -> m Invite createSingleContactInvite name = do token <- liftIO $ getRandomBytes 32 @@ -111,22 +162,23 @@ createSingleContactInvite name = 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 -> InviteToken -> 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" +-- | Accept an invite received outside of the Erebos protocol. The acceptance +-- is recorded in the shared state and will be confirmed with the issuer when a +-- connection with their device is established. +acceptInvite + :: MonadHead LocalState m + => RefDigest -- ^ Reference to the identity that issued the invite + -> InviteToken -- ^ Invite token + -> m () +acceptInvite from token = do + accepted <- mergeSorted @AcceptedInvite . (: []) <$> mstore AcceptedInviteData + { aidPrev = [] + , aidToken = Just token + , aidFrom = Just from + , aidConfirmed = False + , aidRejected = False + } + updateLocalState_ $ updateSharedState_ $ storeSetAdd accepted data InviteService @@ -239,3 +291,47 @@ instance Service InviteService where UnknownInvitePacket -> do svcPrint $ "Received unknown invite packet" + + serviceNewPeer = do + invites <- fromSetBy (comparing acceptedInviteToken) . lookupSharedValue . lsShared . fromStored <$> getLocalHead + peerDigests <- asks $ identityOwnerDigests . svcPeerIdentity + forM_ invites $ \case + AcceptedInvite + { acceptedInviteToken = Just token + , acceptedInviteFrom = Just from + , acceptedInviteConfirmed = False + , acceptedInviteRejected = False + } | from `elem` peerDigests -> do + svcModify (token :) + replyPacket $ AcceptInvite token + _ -> return () + + serviceStorageWatchers _ = (:[]) $ + GlobalStorageWatcher (lookupSharedValue . lsShared . fromStored) sendAcceptedInvites + + +sendAcceptedInvites :: Server -> Set AcceptedInvite -> ExceptT ErebosError IO () +sendAcceptedInvites server aiset = do + forM_ (fromSetBy (comparing acceptedInviteToken) aiset) $ \case + AcceptedInvite + { acceptedInviteToken = Just token + , acceptedInviteFrom = Just from + , acceptedInviteConfirmed = False + , acceptedInviteRejected = False + } -> 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 + return () + _ -> return () + +identityOwnerDigests :: Foldable f => Identity f -> [ RefDigest ] +identityOwnerDigests pid = map (refDigest . storedRef) $ concatMap toList $ toList $ generations $ idExtDataF $ finalOwner pid diff --git a/test/invite.et b/test/invite.et index c7a8054..23047be 100644 --- a/test/invite.et +++ b/test/invite.et @@ -34,7 +34,8 @@ test InviteContact: with p2: send "invite-accept 00 $p1obase" - expect /invite-accept-done 00 invalid/ + expect /invite-accept-done 00/ + expect /invite-reply 00 invalid/ send "contact-list" expect: @@ -43,7 +44,8 @@ test InviteContact: with p2: send "invite-accept $token $p1obase" - expect /invite-accept-done $token contact/ + expect /invite-accept-done $token/ + expect /invite-reply $token contact/ send "contact-list" expect: @@ -53,7 +55,8 @@ test InviteContact: with p2: send "invite-accept $token $p1obase" - expect /invite-accept-done $token invalid/ + expect /invite-accept-done $token/ + expect /invite-reply $token invalid/ send "contact-list" expect: @@ -69,3 +72,61 @@ test InviteContact: /contact-list-item [a-z0-9#]+ Contact2 Owner2/ /contact-list-(.*)/ capture done guard (done == "done") + + +test InviteContactDelayed: + let services = "contact,invite" + + subnet s1 + subnet s2 + + spawn as p1 on s1 + spawn as p2 on s2 + + 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 + + send "invite-contact-create Contact2" to p1 + expect from p1 /invite-contact-create-done ([^ ]+)/ capture token + + with p2: + send "invite-accept $token $p1obase" + expect /invite-accept-done $token/ + + send to p2 "peer-add ${p1.node.ip}" + + 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/ + + with p2: + expect /invite-reply $token contact/ + + send "contact-list" + expect: + /contact-list-item [a-z0-9#]+ .*/ + /contact-list-(.*)/ capture done + guard (done == "done") + + with p1: + expect /invite-accepted $token $refpat/ + + send "contact-list" + expect: + /contact-list-item [a-z0-9#]+ Contact2 .*/ + /contact-list-(.*)/ capture done + guard (done == "done") -- cgit v1.2.3