summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Erebos/Contact.hs2
-rw-r--r--src/Erebos/Identity.hs6
-rw-r--r--src/Erebos/Invite.hs213
3 files changed, 218 insertions, 3 deletions
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"
generated by cgit v1.2.3 (git 2.25.1) at 2025-11-07 14:29:24 +0000