Accept invites via shared state

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 "<missing-token>" 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")