Invite service and shared state

Changelog: New service and shared state for invites

6 files changed, 343 insertions, 3 deletions

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 "<unnamed>") . 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")