summaryrefslogtreecommitdiff
path: root/src/Erebos/Invite.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Erebos/Invite.hs')
-rw-r--r--src/Erebos/Invite.hs385
1 files changed, 385 insertions, 0 deletions
diff --git a/src/Erebos/Invite.hs b/src/Erebos/Invite.hs
new file mode 100644
index 0000000..c6e037d
--- /dev/null
+++ b/src/Erebos/Invite.hs
@@ -0,0 +1,385 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Erebos.Invite (
+ Invite(..),
+ InviteData(..),
+ AcceptedInvite(..),
+ AcceptedInviteData(..),
+ AcceptedInviteStatus(..),
+ InviteToken, showInviteToken, textInviteToken, parseInviteToken,
+ 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.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
+import Data.Text.Encoding
+import Data.Time.LocalTime
+
+import Erebos.Contact
+import Erebos.Discovery
+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 InviteToken
+ , inviteCreated :: Maybe ZonedTime
+ , inviteAccepted :: [ ( Stored (Signed ExtendedIdentityData), Maybe ZonedTime ) ]
+ , inviteContact :: Maybe Text
+ }
+
+data InviteData = InviteData
+ { invdPrev :: [ Stored InviteData ]
+ , invdTime :: Maybe ZonedTime
+ , invdToken :: Maybe InviteToken
+ , invdAccepted :: Maybe (Stored (Signed ExtendedIdentityData))
+ , invdContact :: Maybe Text
+ }
+
+instance Storable InviteData where
+ store' x = storeRec $ do
+ mapM_ (storeRef "PREV") $ invdPrev x
+ mapM_ (storeDate "time") $ invdTime x
+ mapM_ (storeBinary "token") $ invdToken x
+ mapM_ (storeRef "accepted") $ invdAccepted x
+ mapM_ (storeText "contact") $ invdContact x
+
+ load' = loadRec $ InviteData
+ <$> loadRefs "PREV"
+ <*> loadMbDate "time"
+ <*> loadMbBinary "token"
+ <*> loadMbRef "accepted"
+ <*> loadMbText "contact"
+
+
+newtype InviteToken = InviteToken ByteString
+ deriving (Eq, Ord, Semigroup, Monoid, ByteArray, ByteArrayAccess)
+
+showInviteToken :: InviteToken -> String
+showInviteToken (InviteToken token) = BC.unpack (showHex token)
+
+textInviteToken :: InviteToken -> Text
+textInviteToken (InviteToken token) = decodeUtf8 (showHex token)
+
+parseInviteToken :: Text -> Maybe InviteToken
+parseInviteToken text = InviteToken <$> (readHex $ encodeUtf8 text)
+
+
+instance Mergeable Invite where
+ type Component Invite = InviteData
+
+ mergeSorted invdata = Invite
+ { inviteData = invdata
+ , inviteToken = findPropertyFirst invdToken invdata
+ , inviteCreated = join $ findPropertyFirst (\invd -> (const $ invdTime invd) <$> invdTime invd) invdata
+ , inviteAccepted = findProperty (\invd -> ( , invdTime invd ) <$> invdAccepted invd) invdata
+ , inviteContact = findPropertyFirst invdContact invdata
+ }
+
+ toComponents = inviteData
+
+instance SharedType (Set Invite) where
+ sharedTypeID _ = mkSharedTypeID "78da787a-9380-432e-a51d-532a30d27b3d"
+
+
+data AcceptedInvite = AcceptedInvite
+ { acceptedInviteData :: [ Stored AcceptedInviteData ]
+ , acceptedInviteToken :: Maybe InviteToken
+ , acceptedInviteFrom :: Maybe RefDigest
+ , acceptedInviteStatus :: AcceptedInviteStatus
+ }
+
+data AcceptedInviteData = AcceptedInviteData
+ { aidPrev :: [ Stored AcceptedInviteData ]
+ , aidToken :: Maybe InviteToken
+ , aidFrom :: Maybe RefDigest
+ , aidConfirmed :: Bool
+ , aidRejected :: Bool
+ }
+
+data AcceptedInviteStatus
+ = AcceptedInvitePending
+ | AcceptedInviteRejected
+ | AcceptedInviteConfirmed
+
+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
+ , acceptedInviteStatus = fromMaybe AcceptedInvitePending $ flip findPropertyFirst aidata $ \case
+ AcceptedInviteData {..}
+ | aidConfirmed -> Just AcceptedInviteConfirmed
+ | aidRejected -> Just AcceptedInviteRejected
+ | isJust aidToken -> Just AcceptedInvitePending
+ | otherwise -> Nothing
+ }
+ toComponents = acceptedInviteData
+
+instance SharedType (Set AcceptedInvite) where
+ sharedTypeID _ = mkSharedTypeID "b1ebf228-4892-476b-ba04-0c26320139b1"
+
+
+createSingleContactInvite :: MonadHead LocalState m => Text -> m Invite
+createSingleContactInvite name = do
+ time <- liftIO getZonedTime
+ token <- liftIO $ getRandomBytes 32
+ invite <- mergeSorted @Invite . (: []) <$> mstore InviteData
+ { invdPrev = []
+ , invdTime = Just time
+ , invdToken = Just token
+ , invdAccepted = Nothing
+ , invdContact = Just name
+ }
+ updateLocalState_ $ updateSharedState_ $ \invites -> do
+ storeSetAdd invite invites
+ return invite
+
+-- | 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
+ prev <- find ((Just token ==) . acceptedInviteToken)
+ . fromSetBy (comparing acceptedInviteToken) . lookupSharedValue . lsShared . fromStored
+ <$> getLocalHead
+ accepted <- mergeSorted @AcceptedInvite . (: []) <$> mstore AcceptedInviteData
+ { aidPrev = maybe [] acceptedInviteData prev
+ , aidToken = Just token
+ , aidFrom = Just from
+ , aidConfirmed = False
+ , aidRejected = False
+ }
+ updateLocalState_ $ updateSharedState_ $ storeSetAdd accepted
+
+
+data InviteService
+ = AcceptInvite InviteToken
+ | InvalidInvite InviteToken
+ | ContactInvite InviteToken (Maybe Text)
+ | UnknownInvitePacket
+
+data InviteServiceAttributes = InviteServiceAttributes
+ { inviteHookAccepted :: Invite -> ServiceHandler InviteService ()
+ , inviteHookReplyContact :: InviteToken -> Maybe Text -> ServiceHandler InviteService ()
+ , inviteHookReplyInvalid :: InviteToken -> ServiceHandler InviteService ()
+ }
+
+defaultInviteServiceAttributes :: InviteServiceAttributes
+defaultInviteServiceAttributes = InviteServiceAttributes
+ { inviteHookAccepted = \Invite {..} -> do
+ pid <- asks $ svcPeerIdentity
+ svcPrint $ T.unpack $ "Invite" <> maybe "" ((" for “" <>) . (<> "”")) inviteContact <> " accepted by " <> displayIdentity pid
+ <> " (token: " <> maybe "??" textInviteToken inviteToken <> ")"
+ , inviteHookReplyContact = \token mbName -> do
+ pid <- asks $ svcPeerIdentity
+ svcPrint $ T.unpack $ "Invite confirmed by " <> displayIdentity pid
+ <> (maybe "" (" with name " <>) mbName)
+ <> " (token: " <> textInviteToken token <> ")"
+ , inviteHookReplyInvalid = \token -> do
+ pid <- asks $ svcPeerIdentity
+ svcPrint $ T.unpack $ "Invite rejected as invalid by " <> displayIdentity pid
+ <> " (token: " <> textInviteToken token <> ")"
+ }
+
+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 = [ InviteToken ] -- accepted invites, waiting for reply
+ emptyServiceState _ = []
+
+ type ServiceAttributes InviteService = InviteServiceAttributes
+ defaultServiceAttributes _ = defaultInviteServiceAttributes
+
+ serviceHandler = fromStored >>> \case
+ AcceptInvite token -> do
+ invites <- fromSetBy (comparing inviteToken) . lookupSharedValue . lsShared . fromStored <$> getLocalHead
+ case find ((Just token ==) . inviteToken) invites of
+ Just invite
+ | Just name <- inviteContact invite
+ , [] <- inviteAccepted invite
+ -> do
+ asks (inviteHookAccepted . svcAttributes) >>= ($ invite)
+ time <- liftIO getZonedTime
+ identity <- asks svcPeerIdentity
+ cdata <- mstore ContactData
+ { cdPrev = []
+ , cdIdentity = idExtDataF $ finalOwner identity
+ , cdName = Just name
+ }
+ invdata <- mstore InviteData
+ { invdPrev = inviteData invite
+ , invdTime = Just time
+ , 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)
+
+ accepted <- fromSetBy (comparing acceptedInviteToken) . lookupSharedValue . lsShared . fromStored <$> getLocalHead
+ case find ((Just token ==) . acceptedInviteToken) accepted of
+ Just invite -> do
+ aidata <- mstore AcceptedInviteData
+ { aidPrev = acceptedInviteData invite
+ , aidToken = Nothing
+ , aidFrom = Nothing
+ , aidConfirmed = False
+ , aidRejected = True
+ }
+ updateLocalState_ $ updateSharedState_ $ storeSetAdd (mergeSorted @AcceptedInvite [ aidata ])
+ Nothing -> return ()
+
+ ContactInvite token mbName -> do
+ asks (inviteHookReplyContact . svcAttributes) >>= ($ mbName) . ($ token)
+ waitingTokens <- svcGet
+ if token `elem` waitingTokens
+ then do
+ svcSet $ filter (/= token) waitingTokens
+
+ accepted <- fromSetBy (comparing acceptedInviteToken) . lookupSharedValue . lsShared . fromStored <$> getLocalHead
+ case find ((Just token ==) . acceptedInviteToken) accepted of
+ Just invite -> do
+ aidata <- mstore AcceptedInviteData
+ { aidPrev = acceptedInviteData invite
+ , aidToken = Nothing
+ , aidFrom = Nothing
+ , aidConfirmed = True
+ , aidRejected = False
+ }
+ updateLocalState_ $ updateSharedState_ $ storeSetAdd (mergeSorted @AcceptedInvite [ aidata ])
+ Nothing -> return ()
+
+ 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"
+
+ serviceNewPeer = do
+ invites <- fromSetBy (comparing acceptedInviteToken) . lookupSharedValue . lsShared . fromStored <$> getLocalHead
+ peerDigests <- asks $ identityOwnerDigests . svcPeerIdentity
+ forM_ invites $ \case
+ AcceptedInvite
+ { acceptedInviteToken = Just token
+ , acceptedInviteFrom = Just from
+ , acceptedInviteStatus = AcceptedInvitePending
+ } | 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
+ , acceptedInviteStatus = AcceptedInvitePending
+ } -> 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
+ discoverySearch server from
+ _ -> return ()
+
+identityOwnerDigests :: Foldable f => Identity f -> [ RefDigest ]
+identityOwnerDigests pid = map (refDigest . storedRef) $ concatMap toList $ toList $ generations $ idExtDataF $ finalOwner pid
generated by cgit v1.2.3 (git 2.25.1) at 2026-03-16 22:20:51 +0000