diff --git a/migrations/531_2023-06-15_follow_request.model b/migrations/531_2023-06-15_follow_request.model new file mode 100644 index 0000000..700b4f3 --- /dev/null +++ b/migrations/531_2023-06-15_follow_request.model @@ -0,0 +1,8 @@ +FollowRequest + actor ActorId + target FollowerSetId + public Bool + follow OutboxItemId + + UniqueFollowRequest actor target + UniqueFollowRequestFollow follow diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 1e5998e..e5cf13f 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -1838,6 +1838,19 @@ followC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re } } +-- Meaning: The human wants to invite someone A to a resource R +-- Behavior: +-- * Some basic sanity checks +-- * Parse the Invite +-- * Make sure not inviting myself +-- * Verify that a capability is specified +-- * If resource is local, verify it exists in DB +-- * Verify the target A and resource R are addressed in the Invite +-- * Insert Invite to my inbox +-- * Asynchrnously: +-- * Deliver a request to the resource +-- * Deliver a notification to the target +-- * Deliver a notification to my followers inviteC :: Entity Person -> Actor @@ -1853,11 +1866,11 @@ inviteC -> AP.Invite URIMode -> ExceptT Text Handler OutboxItemId inviteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips remoteRecips fwdHosts action invite = do - error "Temporarily disabled due to switch to new actor system" + error "Disabled for actor refactoring" {- -- Check input (resource, recipient) <- parseInvite (Left senderPersonID) invite - capID <- fromMaybeE maybeCap "No capability provided" + _capID <- fromMaybeE maybeCap "No capability provided" -- If resource is remote, HTTP GET it and its managing actor, and insert to -- our DB. If resource is local, find it in our DB. @@ -1866,7 +1879,7 @@ inviteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re (runDBExcept . flip getGrantResource "Grant context not found in DB") (\ u@(ObjURI h lu) -> do instanceID <- - lift $ runDB $ either entityKey id <$> insertBy' (Instance h) + lift $ withDB $ either entityKey id <$> insertBy' (Instance h) result <- ExceptT $ first (T.pack . show) <$> fetchRemoteResource instanceID h lu @@ -1888,7 +1901,7 @@ inviteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re lift $ runDB $ either entityKey id <$> insertBy' (Instance h) result <- ExceptT $ first (T.pack . displayException) <$> - fetchRemoteActor instanceID h lu + fetchRemoteActor' instanceID h lu case result of Left Nothing -> throwE "Recipient @id mismatch" Left (Just err) -> throwE $ T.pack $ displayException err @@ -1910,27 +1923,25 @@ inviteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re now <- liftIO getCurrentTime senderHash <- encodeKeyHashid senderPersonID + ? <- withDBExcept $ do + + + + + + + + + + + + + + (obiidInvite, deliverHttpInvite) <- runDBExcept $ do - -- If resource is local, verify the specified capability gives relevant - -- access to it. - case resourceDB of - Left r -> do - capability <- - case capID of - Left (actor, _, item) -> return (actor, item) - Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local topic" - verifyCapability capability (Left senderPersonID) (bmap entityKey r) - Right _ -> pure () - - -- Insert new Collab to DB + -- Insert the Invite activity to author's outbox inviteID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now - case resourceDB of - Left localResource -> - lift $ insertCollab localResource recipientDB inviteID - Right _ -> pure () - - -- Insert the Grant activity to author's outbox _luInvite <- lift $ updateOutboxItem (LocalActorPerson senderPersonID) inviteID action -- Deliver the Invite activity to local recipients, and schedule @@ -1986,6 +1997,22 @@ inviteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re -- Return instructions for HTTP delivery to remote recipients return (inviteID, deliverHttpInvite) + + + + + + -- Notify the resource + + + + + + + + + + -- Launch asynchronous HTTP delivery of the Grant activity lift $ do forkWorker "inviteC: async HTTP Grant delivery" deliverHttpInvite @@ -1995,20 +2022,20 @@ inviteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re where fetchRemoteResource instanceID host localURI = do - maybeActor <- runSiteDB $ runMaybeT $ do + maybeActor <- withDB $ runMaybeT $ do roid <- MaybeT $ getKeyBy $ UniqueRemoteObject instanceID localURI MaybeT $ getBy $ UniqueRemoteActor roid case maybeActor of Just actor -> return $ Right $ Left actor Nothing -> do - manager <- asksSite getHttpManager + manager <- asksEnv getHttpManager errorOrResource <- fetchResource manager host localURI case errorOrResource of Left maybeError -> return $ Left $ maybe ResultIdMismatch ResultGetError maybeError Right resource -> do case resource of - ResourceActor (AP.Actor local detail) -> runSiteDB $ do + ResourceActor (AP.Actor local detail) -> withDB $ do roid <- either entityKey id <$> insertBy' (RemoteObject instanceID localURI) let ra = RemoteActor { remoteActorIdent = roid @@ -2020,8 +2047,8 @@ inviteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re } Right . Left . either id id <$> insertByEntity' ra ResourceChild luId luManager -> do - roid <- runSiteDB $ either entityKey id <$> insertBy' (RemoteObject instanceID localURI) - result <- fetchRemoteActor instanceID host luManager + roid <- withDB $ either entityKey id <$> insertBy' (RemoteObject instanceID localURI) + result <- fetchRemoteActor' instanceID host luManager return $ case result of Left e -> Left $ ResultSomeException e @@ -2038,23 +2065,6 @@ inviteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re routes <- lookup p $ recipPeople localRecips guard $ routePerson routes - insertCollab resource recipient inviteID = do - collabID <- insert Collab - case resource of - GrantResourceRepo (Entity repoID _) -> - insert_ $ CollabTopicRepo collabID repoID - GrantResourceDeck (Entity deckID _) -> - insert_ $ CollabTopicDeck collabID deckID - GrantResourceLoom (Entity loomID _) -> - insert_ $ CollabTopicLoom collabID loomID - fulfillsID <- insert $ CollabFulfillsInvite collabID - insert_ $ CollabInviterLocal fulfillsID inviteID - case recipient of - Left (GrantRecipPerson (Entity personID _)) -> - insert_ $ CollabRecipLocal collabID personID - Right (remoteActorID, _) -> - insert_ $ CollabRecipRemote collabID remoteActorID - hashGrantRecip (GrantRecipPerson k) = GrantRecipPerson <$> encodeKeyHashid k -} diff --git a/src/Vervis/Access.hs b/src/Vervis/Access.hs index b04183c..ca1a757 100644 --- a/src/Vervis/Access.hs +++ b/src/Vervis/Access.hs @@ -77,6 +77,7 @@ module Vervis.Access , grantResourceLocalActor , verifyCapability + , verifyCapability' ) where @@ -89,6 +90,8 @@ import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader import Data.Barbie import Data.Bifunctor +import Data.Bitraversable +import Data.ByteString (ByteString) import Data.Maybe import Data.Text (Text) import Database.Persist @@ -99,6 +102,7 @@ import Yesod.Core.Handler import qualified Database.Esqueleto as E import Control.Concurrent.Actor +import Network.FedURI import Web.Actor.Persist (stageHashidsContext) import Yesod.Hashids import Yesod.MonadSite @@ -107,6 +111,7 @@ import Control.Monad.Trans.Except.Local import Data.Either.Local import Database.Persist.Local +import Vervis.Actor import Vervis.Foundation import Vervis.Model import Vervis.Model.Role @@ -383,3 +388,23 @@ verifyCapability (capActor, capItem) actor resource = do -- Since there are currently no roles, and grants allow only the "Admin" -- role that supports every operation, we don't need to check role access return () + +verifyCapability' + :: MonadIO m + => (LocalActorBy Key, OutboxItemId) + -> Either + (LocalActorBy Key, ActorId, OutboxItemId) + (RemoteAuthor, LocalURI, Maybe ByteString) + -> GrantResourceBy Key + -> ExceptT Text (ReaderT SqlBackend m) () +verifyCapability' cap actor resource = do + actorP <- processActor actor + verifyCapability cap actorP resource + where + processActor = bitraverse processLocal processRemote + where + processLocal (actorByKey, _, _) = + case actorByKey of + LocalActorPerson personID -> return personID + _ -> throwE "Non-person local actors can't get Grants at the moment" + processRemote (author, _, _) = pure $ remoteAuthorId author diff --git a/src/Vervis/Actor.hs b/src/Vervis/Actor.hs index 87f1b86..79c6851 100644 --- a/src/Vervis/Actor.hs +++ b/src/Vervis/Actor.hs @@ -55,11 +55,12 @@ module Vervis.Actor -- * AP system base types , RemoteAuthor (..) , ActivityBody (..) - , VerseRemote (..) + --, VerseRemote (..) + , Verse (..) -- * Behavior utility types - , Verse - , Event (..) + --, Verse + --, Event (..) , Env (..) , Act , ActE @@ -87,6 +88,7 @@ import Control.Monad.Trans.Maybe import Control.Monad.Trans.Except import Control.Monad.Trans.Reader import Data.Barbie +import Data.Bifunctor import Data.ByteString (ByteString) import Data.Foldable import Data.Function @@ -290,6 +292,27 @@ data ActivityBody = ActivityBody , actbActivity :: AP.Activity URIMode } +data Verse = Verse + { verseSource :: Either (LocalActorBy Key, ActorId, OutboxItemId) (RemoteAuthor, LocalURI, Maybe ByteString) + , verseBody :: ActivityBody + --, verseLocalRecips :: RecipientRoutes + } + +instance Message Verse where + summarize (Verse (Left (actor, _, itemID)) body) = + let typ = AP.activityType $ AP.activitySpecific $ actbActivity body + in T.concat [typ, " ", T.pack $ show actor, " ", T.pack $ show itemID] + summarize (Verse (Right (author, luAct, _)) body) = + let ObjURI h _ = remoteAuthorURI author + typ = AP.activityType $ AP.activitySpecific $ actbActivity body + in T.concat [typ, " ", renderObjURI $ ObjURI h luAct] + refer (Verse (Left (actor, _, itemID)) _body) = + T.concat [T.pack $ show actor, " ", T.pack $ show itemID] + refer (Verse (Right (author, luAct, _)) _body) = + let ObjURI h _ = remoteAuthorURI author + in renderObjURI $ ObjURI h luAct + +{- data VerseRemote = VerseRemote { verseAuthor :: RemoteAuthor , verseBody :: ActivityBody @@ -341,6 +364,14 @@ data Event | EventRemoteJoinLocalTopicFwdToFollower RemoteActivityId -- ^ A remote actor asked to Join a local topic, and the local topic is -- forwarding the Join to me because I'm following the topic + | EventTopicHandleLocalInvite PersonId OutboxItemId BL.ByteString ByteString FedURI (Either (GrantRecipBy Key) FedURI) + -- ^ I'm a resource and a local Person has published an invite-for-me. + -- Params: Sender person, Invite ID, Invite activity body, forwarding + -- signature header, capability URI, invite target. + | EventLocalInviteLocalTopicFwdToFollower OutboxItemId + -- ^ An authorized local actor sent an Invite-to-a-local-topic, and the + -- local topic is forwarding the Invite to me because I'm following the + -- topic | EventUnknown deriving Show @@ -356,6 +387,7 @@ instance Message Verse where refer (Right (VerseRemote author _body _fwd uri)) = let ObjURI h _ = remoteAuthorURI author in renderObjURI $ ObjURI h uri +-} type YesodRender y = Route y -> [(Text, Text)] -> Text @@ -470,22 +502,24 @@ data RemoteRecipient = RemoteRecipient -- This function reads the follower sets and remote recipient data from the -- PostgreSQL database. Don't use it inside a database transaction. sendToLocalActors - :: Event - -- ^ Event to send to local live actors + :: Either (LocalActorBy Key, ActorId, OutboxItemId) (RemoteAuthor, LocalURI) + -- ^ Author of the activity being sent + -> ActivityBody + -- ^ Activity to send -> Bool -- ^ Whether to deliver to collection only if owner actor is addressed -> Maybe (LocalActorBy Key) -- ^ An actor whose collections are excluded from requiring an owner, i.e. -- even if owner is required, this actor's collections will be delivered -- to, even if this actor isn't addressed. This is meant to be the - -- activity's author. + -- activity's sender. -> Maybe (LocalActorBy Key) -- ^ An actor whose inbox to exclude from delivery, even if this actor is -- listed in the recipient set. This is meant to be the activity's - -- author. + -- sender. -> RecipientRoutes -> Act [((InstanceId, Host), NonEmpty RemoteRecipient)] -sendToLocalActors event requireOwner mauthor maidAuthor recips = do +sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do -- Unhash actor and work item hashids people <- unhashKeys $ recipPeople recips @@ -608,7 +642,9 @@ sendToLocalActors event requireOwner mauthor maidAuthor recips = do in case maidAuthor of Nothing -> s Just a -> HS.delete a s - sendMany liveRecips $ Left event + authorAndId' = + second (\ (author, luAct) -> (author, luAct, Nothing)) authorAndId + sendMany liveRecips $ Verse authorAndId' body -- Return remote followers, to whom we need to deliver via HTTP return remoteFollowers diff --git a/src/Vervis/Actor/Common.hs b/src/Vervis/Actor/Common.hs index 616ea4d..9a5e94b 100644 --- a/src/Vervis/Actor/Common.hs +++ b/src/Vervis/Actor/Common.hs @@ -20,6 +20,7 @@ module Vervis.Actor.Common , topicAccept , topicReject , topicInvite + --, topicHandleLocalInvite , topicJoin ) where @@ -33,6 +34,7 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader +import Data.Bifoldable import Data.Bifunctor import Data.Bitraversable import Data.ByteString (ByteString) @@ -92,13 +94,10 @@ actorFollow -> (a -> Act [Aud URIMode]) -> UTCTime -> Key r - -> RemoteAuthor - -> ActivityBody - -> Maybe (RecipientRoutes, ByteString) - -> LocalURI + -> Verse -> AP.Follow URIMode -> ActE (Text, Act (), Next) -actorFollow parseFollowee grabActor unread getFollowee getSieve makeLocalActor makeAudience now recipID author body mfwd luFollow (AP.Follow uObject _ hide) = do +actorFollow parseFollowee grabActor unread getFollowee getSieve makeLocalActor makeAudience now recipID (Verse authorIdMsig body) (AP.Follow uObject _ hide) = do -- Check input followee <- nameExceptT "Follow object" $ do @@ -107,6 +106,7 @@ actorFollow parseFollowee grabActor unread getFollowee getSieve makeLocalActor m case routeOrRemote of Left route -> pure route Right _ -> throwE "Remote, so definitely not me/mine" + -- Verify the followee is me or a subobject of mine parseFollowee route verifyNothingE (AP.activityCapability $ actbActivity body) @@ -114,28 +114,37 @@ actorFollow parseFollowee grabActor unread getFollowee getSieve makeLocalActor m maybeFollow <- withDBExcept $ do - -- Find recipient actor in DB + -- Find me in DB recip <- lift $ getJust recipID let recipActorID = grabActor recip recipActor <- lift $ getJust recipActorID - -- Insert the Follow to actor's inbox - mractid <- lift $ insertToInbox now author body (actorInbox recipActor) luFollow unread - for mractid $ \ followID -> do + -- Insert the Follow to my inbox + maybeFollowDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) unread + for maybeFollowDB $ \ followDB -> do -- Find followee in DB followerSetID <- getFollowee recipActor followee - -- Verify not already following us - let followerID = remoteAuthorId author - maybeFollow <- - lift $ getBy $ UniqueRemoteFollow followerID followerSetID - verifyNothingE maybeFollow "You're already following this object" + -- Verify not already following me + case followDB of + Left (_, followerID, followID) -> do + maybeFollow <- lift $ getBy $ UniqueFollow followerID followerSetID + verifyNothingE maybeFollow "You're already following this object" + Right (author, _, followID) -> do + let followerID = remoteAuthorId author + maybeFollow <- lift $ getBy $ UniqueRemoteFollow followerID followerSetID + verifyNothingE maybeFollow "You're already following this object" -- Record the new follow in DB acceptID <- lift $ insertEmptyOutboxItem' (actorOutbox recipActor) now - lift $ insert_ $ RemoteFollow followerID followerSetID (not hide) followID acceptID + lift $ case followDB of + Left (_actorByKey, actorID, followID) -> + insert_ $ Follow actorID followerSetID (not hide) followID acceptID + Right (author, _luFollow, followID) -> do + let authorID = remoteAuthorId author + insert_ $ RemoteFollow authorID followerSetID (not hide) followID acceptID -- Prepare an Accept activity and insert to actor's outbox accept@(actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- @@ -143,20 +152,15 @@ actorFollow parseFollowee grabActor unread getFollowee getSieve makeLocalActor m _luAccept <- lift $ updateOutboxItem' (makeLocalActor recipID) acceptID actionAccept sieve <- lift $ getSieve followee - return (recipActorID, followID, acceptID, sieve, accept) + return (recipActorID, acceptID, sieve, accept) case maybeFollow of Nothing -> done "I already have this activity in my inbox" - Just (actorID, followID, acceptID, sieve, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> do - lift $ for_ mfwd $ \ (localRecips, sig) -> - forwardActivity - (actbBL body) localRecips sig actorID - (makeLocalActor recipID) sieve - (EventRemoteFollowLocalRecipFwdToFollower followID) + Just (actorID, acceptID, sieve, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> do + forwardActivity authorIdMsig body (makeLocalActor recipID) actorID sieve lift $ sendActivity (makeLocalActor recipID) actorID localRecipsAccept - remoteRecipsAccept fwdHostsAccept acceptID - EventAcceptRemoteFollow actionAccept + remoteRecipsAccept fwdHostsAccept acceptID actionAccept done "Recorded Follow and published Accept" where @@ -164,14 +168,8 @@ actorFollow parseFollowee grabActor unread getFollowee getSieve makeLocalActor m prepareAccept followee = do encodeRouteHome <- getEncodeRouteHome - ra <- getJust $ remoteAuthorId author - - let ObjURI hAuthor luAuthor = remoteAuthorURI author - - audSender = - AudRemote hAuthor - [luAuthor] - (maybeToList $ remoteActorFollowers ra) + audSender <- makeAudSenderWithFollowers authorIdMsig + uFollow <- lift $ getActivityURI authorIdMsig audsRecip <- lift $ makeAudience followee @@ -185,7 +183,7 @@ actorFollow parseFollowee grabActor unread getFollowee getSieve makeLocalActor m , AP.actionAudience = AP.Audience recips [] [] [] [] [] , AP.actionFulfills = [] , AP.actionSpecific = AP.AcceptActivity AP.Accept - { AP.acceptObject = ObjURI hAuthor luFollow + { AP.acceptObject = uFollow , AP.acceptResult = Nothing } } @@ -198,13 +196,10 @@ topicAccept -> (forall f. f topic -> GrantResourceBy f) -> UTCTime -> Key topic - -> RemoteAuthor - -> ActivityBody - -> Maybe (RecipientRoutes, ByteString) - -> LocalURI + -> Verse -> AP.Accept URIMode -> ActE (Text, Act (), Next) -topicAccept topicActor topicResource now recipKey author body mfwd luAccept accept = do +topicAccept topicActor topicResource now recipKey (Verse authorIdMsig body) accept = do -- Check input acceptee <- parseAccept accept @@ -219,7 +214,7 @@ topicAccept topicActor topicResource now recipKey author body mfwd luAccept acce maybeNew <- withDBExcept $ do - -- Grab recipient deck from DB + -- Grab me from DB (recipActorID, recipActor) <- lift $ do recip <- getJust recipKey let actorID = topicActor recip @@ -263,9 +258,13 @@ topicAccept topicActor topicResource now recipKey author body mfwd luAccept acce (getBy $ UniqueCollabRecipRemote collabID) "Found Collab with no recip" "Found Collab with multiple recips" - case recip of - Right (Entity crrid crr) - | collabRecipRemoteActor crr == remoteAuthorId author -> return (fulfillsID, crrid) + case (recip, authorIdMsig) of + (Left (Entity crlid crl), Left (LocalActorPerson personID, _, _)) + | collabRecipLocalPerson crl == personID -> + return (fulfillsID, Left crlid) + (Right (Entity crrid crr), Right (author, _, _)) + | collabRecipRemoteActor crr == remoteAuthorId author -> + return (fulfillsID, Right crrid) _ -> throwE "Accepting an Invite whose recipient is someone else" -- If accepting a Join, verify accepter has permission @@ -275,9 +274,9 @@ topicAccept topicActor topicResource now recipKey author body mfwd luAccept acce case capID of Left (capActor, _, capItem) -> return (capActor, capItem) Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local resource" - verifyCapability + verifyCapability' capability - (Right $ remoteAuthorId author) + authorIdMsig (topicResource recipKey) return fulfillsID @@ -285,27 +284,33 @@ topicAccept topicActor topicResource now recipKey author body mfwd luAccept acce maybeEnabled <- lift $ getBy $ UniqueCollabEnable collabID verifyNothingE maybeEnabled "I already sent a Grant for this Invite/Join" - mractid <- lift $ insertToInbox now author body (actorInbox recipActor) luAccept False - for mractid $ \ acceptID -> do + maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False + for maybeAcceptDB $ \ acceptDB -> do -- Record the Accept on the Collab - case idsForAccept of - Left (fulfillsID, recipID) -> do - maybeAccept <- lift $ insertUnique $ CollabRecipRemoteAccept recipID fulfillsID acceptID - unless (isNothing maybeAccept) $ do - lift $ delete acceptID + case (idsForAccept, acceptDB) of + (Left (fulfillsID, Left recipID), Left (_, _, acceptID)) -> do + maybeAccept <- lift $ insertUnique $ CollabRecipLocalAccept recipID fulfillsID acceptID + unless (isNothing maybeAccept) $ throwE "This Invite already has an Accept by recip" - Right fulfillsID -> do - maybeAccept <- lift $ insertUnique $ CollabApproverRemote fulfillsID (remoteAuthorId author) acceptID - unless (isNothing maybeAccept) $ do - lift $ delete acceptID + (Left (fulfillsID, Right recipID), Right (_, _, acceptID)) -> do + maybeAccept <- lift $ insertUnique $ CollabRecipRemoteAccept recipID fulfillsID acceptID + unless (isJust maybeAccept) $ + throwE "This Invite already has an Accept by recip" + (Right fulfillsID, Left (_, _, acceptID)) -> do + maybeAccept <- lift $ insertUnique $ CollabApproverLocal fulfillsID acceptID + unless (isJust maybeAccept) $ throwE "This Join already has an Accept" + (Right fulfillsID, Right (author, _, acceptID)) -> do + maybeAccept <- lift $ insertUnique $ CollabApproverRemote fulfillsID (remoteAuthorId author) acceptID + unless (isJust maybeAccept) $ + throwE "This Join already has an Accept" + _ -> error "topicAccept impossible" -- Prepare forwarding of Accept to my followers let recipByID = grantResourceLocalActor $ topicResource recipKey recipByHash <- hashLocalActor recipByID let sieve = makeRecipientSet [] [localActorFollowers recipByHash] - isInvite = isLeft collab grantInfo <- do @@ -315,29 +320,23 @@ topicAccept topicActor topicResource now recipKey author body mfwd luAccept acce -- Prepare a Grant activity and insert to my outbox let inviterOrJoiner = either snd snd collab + isInvite = isLeft collab grant@(actionGrant, _, _, _) <- lift $ prepareGrant isInvite inviterOrJoiner let recipByKey = grantResourceLocalActor $ topicResource recipKey _luGrant <- lift $ updateOutboxItem' recipByKey grantID actionGrant return (grantID, grant) - return (recipActorID, isInvite, acceptID, sieve, grantInfo) + return (recipActorID, sieve, grantInfo) case maybeNew of Nothing -> done "I already have this activity in my inbox" - Just (recipActorID, isInvite, acceptID, sieve, (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant))) -> do + Just (recipActorID, sieve, (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant))) -> do let recipByID = grantResourceLocalActor $ topicResource recipKey - lift $ for_ mfwd $ \ (localRecips, sig) -> do - forwardActivity - (actbBL body) localRecips sig recipActorID recipByID sieve - (if isInvite - then EventRemoteAcceptInviteLocalResourceFwdToFollower acceptID - else EventRemoteApproveJoinLocalResourceFwdToFollower acceptID - ) + forwardActivity authorIdMsig body recipByID recipActorID sieve lift $ sendActivity recipByID recipActorID localRecipsGrant - remoteRecipsGrant fwdHostsGrant grantID - (EventGrantAfterRemoteAccept grantID) actionGrant + remoteRecipsGrant fwdHostsGrant grantID actionGrant done "Forwarded the Accept and published a Grant" where @@ -371,12 +370,15 @@ topicAccept topicActor topicResource now recipKey author body mfwd luAccept acce encodeRouteHome <- getEncodeRouteHome encodeRouteLocal <- getEncodeRouteLocal - accepter <- getJust $ remoteAuthorId author + audAccepter <- makeAudSenderWithFollowers authorIdMsig + audApprover <- lift $ makeAudSenderOnly authorIdMsig recipHash <- encodeKeyHashid recipKey let topicByHash = grantResourceLocalActor $ topicResource recipHash senderHash <- bitraverse hashLocalActor pure sender + uAccepter <- lift $ getActorURI authorIdMsig + let audience = if isInvite then @@ -385,9 +387,6 @@ topicAccept topicActor topicResource now recipKey author body mfwd luAccept acce Left actor -> AudLocal [actor] [] Right (ObjURI h lu, _followers) -> AudRemote h [lu] [] - audAccepter = - let ObjURI h lu = remoteAuthorURI author - in AudRemote h [lu] (maybeToList $ remoteActorFollowers accepter) audTopic = AudLocal [] [localActorFollowers topicByHash] in [audInviter, audAccepter, audTopic] else @@ -396,9 +395,6 @@ topicAccept topicActor topicResource now recipKey author body mfwd luAccept acce Left actor -> AudLocal [actor] [localActorFollowers actor] Right (ObjURI h lu, followers) -> AudRemote h [lu] (maybeToList followers) - audApprover = - let ObjURI h lu = remoteAuthorURI author - in AudRemote h [lu] [] audTopic = AudLocal [] [localActorFollowers topicByHash] in [audJoiner, audApprover, audTopic] @@ -417,7 +413,7 @@ topicAccept topicActor topicResource now recipKey author body mfwd luAccept acce encodeRouteLocal $ renderLocalActor topicByHash , AP.grantTarget = if isInvite - then remoteAuthorURI author + then uAccepter else case senderHash of Left actor -> encodeRouteHome $ renderLocalActor actor @@ -438,13 +434,10 @@ topicReject -> (forall f. f topic -> GrantResourceBy f) -> UTCTime -> Key topic - -> RemoteAuthor - -> ActivityBody - -> Maybe (RecipientRoutes, ByteString) - -> LocalURI + -> Verse -> AP.Reject URIMode -> ActE (Text, Act (), Next) -topicReject topicActor topicResource now recipKey author body mfwd luReject reject = do +topicReject topicActor topicResource now recipKey (Verse authorIdMsig body) reject = do -- Check input rejectee <- parseReject reject @@ -459,7 +452,7 @@ topicReject topicActor topicResource now recipKey author body mfwd luReject reje maybeNew <- withDBExcept $ do - -- Grab recipient deck from DB + -- Grab me from DB (recipActorID, recipActor) <- lift $ do recip <- getJust recipKey let actorID = topicActor recip @@ -503,9 +496,13 @@ topicReject topicActor topicResource now recipKey author body mfwd luReject reje (getBy $ UniqueCollabRecipRemote collabID) "Found Collab with no recip" "Found Collab with multiple recips" - case recip of - Right (Entity crrid crr) - | collabRecipRemoteActor crr == remoteAuthorId author -> return (fulfillsID, crrid, deleteInviter) + case (recip, authorIdMsig) of + (Left (Entity crlid crl), Left (LocalActorPerson personID, _, _)) + | collabRecipLocalPerson crl == personID -> + return (fulfillsID, Left crlid, deleteInviter) + (Right (Entity crrid crr), Right (author, _, _)) + | collabRecipRemoteActor crr == remoteAuthorId author -> + return (fulfillsID, Right crrid, deleteInviter) _ -> throwE "Rejecting an Invite whose recipient is someone else" -- If rejecting a Join, verify accepter has permission @@ -515,9 +512,9 @@ topicReject topicActor topicResource now recipKey author body mfwd luReject reje case capID of Left (capActor, _, capItem) -> return (capActor, capItem) Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local resource" - verifyCapability + verifyCapability' capability - (Right $ remoteAuthorId author) + authorIdMsig (topicResource recipKey) return (fulfillsID, deleteRecipJoin, deleteRecip) @@ -527,7 +524,11 @@ topicReject topicActor topicResource now recipKey author body mfwd luReject reje -- Verify the Collab isn't already accepted/approved case idsForReject of - Left (_fulfillsID, recipID, _) -> do + Left (_fulfillsID, Left recipID, _) -> do + mval <- + lift $ getBy $ UniqueCollabRecipLocalAcceptCollab recipID + verifyNothingE mval "Invite is already accepted" + Left (_fulfillsID, Right recipID, _) -> do mval <- lift $ getBy $ UniqueCollabRecipRemoteAcceptCollab recipID verifyNothingE mval "Invite is already accepted" @@ -537,13 +538,13 @@ topicReject topicActor topicResource now recipKey author body mfwd luReject reje unless (isNothing mval1 && isNothing mval2) $ throwE "Join is already approved" - mractid <- lift $ insertToInbox now author body (actorInbox recipActor) luReject False - for mractid $ \ rejectID -> do + maybeRejectDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False + for maybeRejectDB $ \ rejectDB -> do -- Delete the whole Collab record case idsForReject of Left (fulfillsID, recipID, deleteInviter) -> lift $ do - delete recipID + bitraverse_ delete delete recipID deleteTopic deleteInviter delete fulfillsID @@ -558,36 +559,29 @@ topicReject topicActor topicResource now recipKey author body mfwd luReject reje let recipByID = grantResourceLocalActor $ topicResource recipKey recipByHash <- hashLocalActor recipByID let sieve = makeRecipientSet [] [localActorFollowers recipByHash] - isInvite = isLeft collab newRejectInfo <- do -- Prepare a Reject activity and insert to my outbox newRejectID <- lift $ insertEmptyOutboxItem' (actorOutbox recipActor) now let inviterOrJoiner = either (view _2) (view _2) collab + isInvite = isLeft collab newReject@(actionReject, _, _, _) <- lift $ prepareReject isInvite inviterOrJoiner let recipByKey = grantResourceLocalActor $ topicResource recipKey _luNewReject <- lift $ updateOutboxItem' recipByKey newRejectID actionReject return (newRejectID, newReject) - return (recipActorID, isInvite, rejectID, sieve, newRejectInfo) + return (recipActorID, sieve, newRejectInfo) case maybeNew of Nothing -> done "I already have this activity in my inbox" - Just (recipActorID, isInvite, rejectID, sieve, (newRejectID, (action, localRecips, remoteRecips, fwdHosts))) -> do + Just (recipActorID, sieve, (newRejectID, (action, localRecips, remoteRecips, fwdHosts))) -> do let recipByID = grantResourceLocalActor $ topicResource recipKey - lift $ for_ mfwd $ \ (localRecips, sig) -> do - forwardActivity - (actbBL body) localRecips sig recipActorID recipByID sieve - (if isInvite - then EventRemoteRejectInviteLocalResourceFwdToFollower rejectID - else EventRemoteForbidJoinLocalResourceFwdToFollower rejectID - ) + forwardActivity authorIdMsig body recipByID recipActorID sieve lift $ sendActivity recipByID recipActorID localRecips - remoteRecips fwdHosts newRejectID - (EventRejectAfterRemoteReject newRejectID) action + remoteRecips fwdHosts newRejectID action done "Forwarded the Reject and published my own Reject" where @@ -623,12 +617,15 @@ topicReject topicActor topicResource now recipKey author body mfwd luReject reje encodeRouteHome <- getEncodeRouteHome encodeRouteLocal <- getEncodeRouteLocal - rejecter <- getJust $ remoteAuthorId author + audRejecter <- makeAudSenderWithFollowers authorIdMsig + audForbidder <- lift $ makeAudSenderOnly authorIdMsig recipHash <- encodeKeyHashid recipKey let topicByHash = grantResourceLocalActor $ topicResource recipHash senderHash <- bitraverse hashLocalActor pure sender + uReject <- lift $ getActivityURI authorIdMsig + let audience = if isInvite then @@ -637,9 +634,6 @@ topicReject topicActor topicResource now recipKey author body mfwd luReject reje Left actor -> AudLocal [actor] [] Right (ObjURI h lu, _followers) -> AudRemote h [lu] [] - audRejecter = - let ObjURI h lu = remoteAuthorURI author - in AudRemote h [lu] (maybeToList $ remoteActorFollowers rejecter) audTopic = AudLocal [] [localActorFollowers topicByHash] in [audInviter, audRejecter, audTopic] else @@ -648,9 +642,6 @@ topicReject topicActor topicResource now recipKey author body mfwd luReject reje Left actor -> AudLocal [actor] [localActorFollowers actor] Right (ObjURI h lu, followers) -> AudRemote h [lu] (maybeToList followers) - audForbidder = - let ObjURI h lu = remoteAuthorURI author - in AudRemote h [lu] [] audTopic = AudLocal [] [localActorFollowers topicByHash] in [audJoiner, audForbidder, audTopic] @@ -662,10 +653,7 @@ topicReject topicActor topicResource now recipKey author body mfwd luReject reje { AP.actionCapability = Nothing , AP.actionSummary = Nothing , AP.actionAudience = AP.Audience recips [] [] [] [] [] - , AP.actionFulfills = - [ let ObjURI h _ = remoteAuthorURI author - in ObjURI h luReject - ] + , AP.actionFulfills = [uReject] , AP.actionSpecific = AP.RejectActivity AP.Reject { AP.rejectObject = AP.rejectObject reject } @@ -684,13 +672,10 @@ topicInvite -> (CollabId -> Key topic -> ct) -> UTCTime -> Key topic - -> RemoteAuthor - -> ActivityBody - -> Maybe (RecipientRoutes, ByteString) - -> LocalURI + -> Verse -> AP.Invite URIMode -> ActE (Text, Act (), Next) -topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor now topicKey author body mfwd luInvite invite = do +topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor now topicKey (Verse authorIdMsig body) invite = do -- Check capability capability <- do @@ -713,8 +698,8 @@ topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor -- Check invite targetByKey <- do - (resource, recipient) <- - parseInvite (Right $ remoteAuthorURI author) invite + let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig + (resource, recipient) <- parseInvite author invite unless (Left (topicResource topicKey) == resource) $ throwE "Invite topic isn't me" return recipient @@ -747,17 +732,14 @@ topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor maybeNew <- withDBExcept $ do - -- Grab topic from DB + -- Grab me from DB (topicActorID, topicActor) <- lift $ do recip <- getJust topicKey let actorID = grabActor recip (actorID,) <$> getJust actorID -- Verify the specified capability gives relevant access - verifyCapability - capability - (Right $ remoteAuthorId author) - (topicResource topicKey) + verifyCapability' capability authorIdMsig (topicResource topicKey) -- Verify that target doesn't already have a Collab for me existingCollabIDs <- @@ -785,11 +767,11 @@ topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor [_] -> throwE "I already have a Collab for the target" _ -> error "Multiple collabs found for target" - mractid <- lift $ insertToInbox now author body (actorInbox topicActor) luInvite False - lift $ for mractid $ \ inviteID -> do + maybeInviteDB <- lift $ insertToInbox now authorIdMsig body (actorInbox topicActor) False + lift $ for maybeInviteDB $ \ inviteDB -> do -- Insert Collab record to DB - insertCollab targetDB inviteID + insertCollab targetDB inviteDB -- Prepare forwarding Invite to my followers sieve <- do @@ -797,26 +779,27 @@ topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor let topicByHash = grantResourceLocalActor $ topicResource topicHash return $ makeRecipientSet [] [localActorFollowers topicByHash] - return (topicActorID, inviteID, sieve) + return (topicActorID, sieve) case maybeNew of Nothing -> done "I already have this activity in my inbox" - Just (topicActorID, inviteID, sieve) -> do + Just (topicActorID, sieve) -> do let topicByID = grantResourceLocalActor $ topicResource topicKey - lift $ for_ mfwd $ \ (localRecips, sig) -> do - forwardActivity - (actbBL body) localRecips sig topicActorID topicByID sieve - (EventRemoteInviteLocalTopicFwdToFollower inviteID) + forwardActivity authorIdMsig body topicByID topicActorID sieve done "Recorded and forwarded the Invite" where - insertCollab recipient inviteID = do + insertCollab recipient inviteDB = do collabID <- insert Collab fulfillsID <- insert $ CollabFulfillsInvite collabID insert_ $ collabTopicCtor collabID topicKey - let authorID = remoteAuthorId author - insert_ $ CollabInviterRemote fulfillsID authorID inviteID + case inviteDB of + Left (_, _, inviteID) -> + insert_ $ CollabInviterLocal fulfillsID inviteID + Right (author, _, inviteID) -> do + let authorID = remoteAuthorId author + insert_ $ CollabInviterRemote fulfillsID authorID inviteID case recipient of Left (GrantRecipPerson (Entity personID _)) -> insert_ $ CollabRecipLocal collabID personID @@ -834,13 +817,10 @@ topicJoin -> (CollabId -> Key topic -> ct) -> UTCTime -> Key topic - -> RemoteAuthor - -> ActivityBody - -> Maybe (RecipientRoutes, ByteString) - -> LocalURI + -> Verse -> AP.Join URIMode -> ActE (Text, Act (), Next) -topicJoin grabActor topicResource topicField topicCollabField collabTopicCtor now topicKey author body mfwd luJoin join = do +topicJoin grabActor topicResource topicField topicCollabField collabTopicCtor now topicKey (Verse authorIdMsig body) join = do -- Check input resource <- parseJoin join @@ -849,58 +829,81 @@ topicJoin grabActor topicResource topicField topicCollabField collabTopicCtor no maybeNew <- withDBExcept $ do - -- Grab topic from DB + -- Grab me from DB (topicActorID, topicActor) <- lift $ do recip <- getJust topicKey let actorID = grabActor recip (actorID,) <$> getJust actorID -- Verify that target doesn't already have a Collab for me - existingCollabIDs <- lift $ do - let targetID = remoteAuthorId author - E.select $ E.from $ \ (topic `E.InnerJoin` recipr) -> do - E.on $ - topic E.^. topicCollabField E.==. - recipr E.^. CollabRecipRemoteCollab - E.where_ $ - topic E.^. topicField E.==. E.val topicKey E.&&. - recipr E.^. CollabRecipRemoteActor E.==. E.val targetID - return $ recipr E.^. CollabRecipRemoteCollab + existingCollabIDs <- lift $ + case authorIdMsig of + Left (LocalActorPerson personID, _, _) -> + E.select $ E.from $ \ (topic `E.InnerJoin` recipl) -> do + E.on $ + topic E.^. topicCollabField E.==. + recipl E.^. CollabRecipLocalCollab + E.where_ $ + topic E.^. topicField E.==. E.val topicKey E.&&. + recipl E.^. CollabRecipLocalPerson E.==. E.val personID + return $ recipl E.^. CollabRecipLocalCollab + Left (_, _, _) -> pure [] + Right (author, _, _) -> do + let targetID = remoteAuthorId author + E.select $ E.from $ \ (topic `E.InnerJoin` recipr) -> do + E.on $ + topic E.^. topicCollabField E.==. + recipr E.^. CollabRecipRemoteCollab + E.where_ $ + topic E.^. topicField E.==. E.val topicKey E.&&. + recipr E.^. CollabRecipRemoteActor E.==. E.val targetID + return $ recipr E.^. CollabRecipRemoteCollab case existingCollabIDs of [] -> pure () [_] -> throwE "I already have a Collab for the target" _ -> error "Multiple collabs found for target" - mractid <- lift $ insertToInbox now author body (actorInbox topicActor) luJoin False - lift $ for mractid $ \ joinID -> do + maybeJoinDB <- lift $ insertToInbox now authorIdMsig body (actorInbox topicActor) False + for maybeJoinDB $ \ joinDB -> do -- Insert Collab record to DB - insertCollab joinID + joinDB' <- + bitraverse + (\ (authorByKey, _, joinID) -> + case authorByKey of + LocalActorPerson personID -> pure (personID, joinID) + _ -> throwE "Non-person local actors can't get Grants currently" + ) + pure + joinDB + lift $ insertCollab joinDB' -- Prepare forwarding Join to my followers - sieve <- do + sieve <- lift $ do topicHash <- encodeKeyHashid topicKey let topicByHash = grantResourceLocalActor $ topicResource topicHash return $ makeRecipientSet [] [localActorFollowers topicByHash] - return (topicActorID, joinID, sieve) + return (topicActorID, sieve) case maybeNew of Nothing -> done "I already have this activity in my inbox" - Just (topicActorID, joinID, sieve) -> do + Just (topicActorID, sieve) -> do let topicByID = grantResourceLocalActor $ topicResource topicKey - lift $ for_ mfwd $ \ (localRecips, sig) -> do - forwardActivity - (actbBL body) localRecips sig topicActorID topicByID sieve - (EventRemoteJoinLocalTopicFwdToFollower joinID) + forwardActivity authorIdMsig body topicByID topicActorID sieve done "Recorded and forwarded the Join" where - insertCollab joinID = do + insertCollab joinDB = do collabID <- insert Collab fulfillsID <- insert $ CollabFulfillsJoin collabID insert_ $ collabTopicCtor collabID topicKey - let authorID = remoteAuthorId author - recipID <- insert $ CollabRecipRemote collabID authorID - insert_ $ CollabRecipRemoteJoin recipID fulfillsID joinID + case joinDB of + Left (personID, joinID) -> do + recipID <- insert $ CollabRecipLocal collabID personID + insert_ $ CollabRecipLocalJoin recipID fulfillsID joinID + Right (author, _, joinID) -> do + let authorID = remoteAuthorId author + recipID <- insert $ CollabRecipRemote collabID authorID + insert_ $ CollabRecipRemoteJoin recipID fulfillsID joinID diff --git a/src/Vervis/Actor/Deck.hs b/src/Vervis/Actor/Deck.hs index 1643acf..107e545 100644 --- a/src/Vervis/Actor/Deck.hs +++ b/src/Vervis/Actor/Deck.hs @@ -82,13 +82,10 @@ import Vervis.Ticket deckFollow :: UTCTime -> DeckId - -> RemoteAuthor - -> ActivityBody - -> Maybe (RecipientRoutes, ByteString) - -> LocalURI + -> Verse -> AP.Follow URIMode -> ActE (Text, Act (), Next) -deckFollow now recipDeckID author body mfwd luFollow follow = do +deckFollow now recipDeckID verse follow = do recipDeckHash <- encodeKeyHashid recipDeckID actorFollow (\case @@ -111,13 +108,13 @@ deckFollow now recipDeckID author body mfwd luFollow follow = do (\ _ -> pure $ makeRecipientSet [] []) LocalActorDeck (\ _ -> pure []) - now recipDeckID author body mfwd luFollow follow + now recipDeckID verse follow ------------------------------------------------------------------------------ -- Access ------------------------------------------------------------------------------ --- Meaning: A remote actor accepted something +-- Meaning: An actor accepted something -- Behavior: -- * If it's on an Invite where I'm the resource: -- * Verify the Accept is by the Invite target @@ -135,15 +132,12 @@ deckFollow now recipDeckID author body mfwd luFollow follow = do deckAccept :: UTCTime -> DeckId - -> RemoteAuthor - -> ActivityBody - -> Maybe (RecipientRoutes, ByteString) - -> LocalURI + -> Verse -> AP.Accept URIMode -> ActE (Text, Act (), Next) deckAccept = topicAccept deckActor GrantResourceDeck --- Meaning: A remote actor rejected something +-- Meaning: An actor rejected something -- Behavior: -- * If it's on an Invite where I'm the resource: -- * Verify the Reject is by the Invite target @@ -163,15 +157,12 @@ deckAccept = topicAccept deckActor GrantResourceDeck deckReject :: UTCTime -> DeckId - -> RemoteAuthor - -> ActivityBody - -> Maybe (RecipientRoutes, ByteString) - -> LocalURI + -> Verse -> AP.Reject URIMode -> ActE (Text, Act (), Next) deckReject = topicReject deckActor GrantResourceDeck --- Meaning: A remote actor A invited someone B to a resource +-- Meaning: An actor A invited actor B to a resource -- Behavior: -- * Verify the resource is me -- * Verify A isn't inviting themselves @@ -182,10 +173,7 @@ deckReject = topicReject deckActor GrantResourceDeck deckInvite :: UTCTime -> DeckId - -> RemoteAuthor - -> ActivityBody - -> Maybe (RecipientRoutes, ByteString) - -> LocalURI + -> Verse -> AP.Invite URIMode -> ActE (Text, Act (), Next) deckInvite = @@ -193,7 +181,7 @@ deckInvite = deckActor GrantResourceDeck CollabTopicDeckDeck CollabTopicDeckCollab CollabTopicDeck --- Meaning: A remote actor A asked to join a resource +-- Meaning: An actor A asked to join a resource -- Behavior: -- * Verify the resource is me -- * Verify A doesn't already have an invite/join/grant for me @@ -202,10 +190,7 @@ deckInvite = deckJoin :: UTCTime -> DeckId - -> RemoteAuthor - -> ActivityBody - -> Maybe (RecipientRoutes, ByteString) - -> LocalURI + -> Verse -> AP.Join URIMode -> ActE (Text, Act (), Next) deckJoin = @@ -217,7 +202,7 @@ deckJoin = -- Ambiguous: Following/Resolving ------------------------------------------------------------------------------ --- Meaning: A remote actor is undoing some previous action +-- Meaning: An actor is undoing some previous action -- Behavior: -- * If they're undoing their Following of me, or a ticket of mine: -- * Record it in my DB @@ -231,13 +216,10 @@ deckJoin = deckUndo :: UTCTime -> DeckId - -> RemoteAuthor - -> ActivityBody - -> Maybe (RecipientRoutes, ByteString) - -> LocalURI + -> Verse -> AP.Undo URIMode -> ActE (Text, Act (), Next) -deckUndo now recipDeckID author body mfwd luUndo (AP.Undo uObject) = do +deckUndo now recipDeckID (Verse authorIdMsig body) (AP.Undo uObject) = do -- Check input undone <- @@ -255,14 +237,14 @@ deckUndo now recipDeckID author body mfwd luUndo (AP.Undo uObject) = do maybeNew <- withDBExcept $ do - -- Grab recipient deck from DB + -- Grab me from DB (deckRecip, actorRecip) <- lift $ do p <- getJust recipDeckID (p,) <$> getJust (deckActor p) - -- Insert the Undo to deck's inbox - mractid <- lift $ insertToInbox now author body (actorInbox actorRecip) luUndo False - for mractid $ \ undoID -> do + -- Insert the Undo to my inbox + mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False + for mractid $ \ _undoDB -> do maybeUndo <- runMaybeT $ do @@ -271,7 +253,7 @@ deckUndo now recipDeckID author body mfwd luUndo (AP.Undo uObject) = do let followers = actorFollowers actorRecip asum - [ tryUnfollow followers undoneDB + [ tryUnfollow followers undoneDB authorIdMsig , tryUnresolve maybeCapability undoneDB ] @@ -285,28 +267,43 @@ deckUndo now recipDeckID author body mfwd luUndo (AP.Undo uObject) = do accept@(actionAccept, _, _, _) <- lift $ lift $ prepareAccept audience _luAccept <- lift $ updateOutboxItem' (LocalActorDeck recipDeckID) acceptID actionAccept - return (deckActor deckRecip, undoID, sieve, acceptID, accept) + return (deckActor deckRecip, sieve, acceptID, accept) case maybeNew of Nothing -> done "I already have this activity in my inbox" - Just (actorID, undoID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> do - lift $ for_ mfwd $ \ (localRecips, sig) -> do - forwardActivity - (actbBL body) localRecips sig actorID - (LocalActorDeck recipDeckID) sieve - (EventRemoteUnresolveLocalResourceFwdToFollower undoID) + Just (actorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> do + forwardActivity + authorIdMsig body (LocalActorDeck recipDeckID) actorID sieve lift $ sendActivity (LocalActorDeck recipDeckID) actorID localRecipsAccept - remoteRecipsAccept fwdHostsAccept acceptID - EventAcceptRemoteFollow actionAccept + remoteRecipsAccept fwdHostsAccept acceptID actionAccept done "Undid the Follow/Resolve, forwarded the Undo and published \ \Accept" where - tryUnfollow _ (Left _) = mzero - tryUnfollow deckFollowersID (Right remoteActivityID) = do + verifyTargetTicket followerSetID = do + ticketID <- + MaybeT $ lift $ getKeyBy $ UniqueTicketFollowers followerSetID + TicketDeck _ d <- + MaybeT $ lift $ getValBy $ UniqueTicketDeck ticketID + guard $ d == recipDeckID + + tryUnfollow deckFollowersID (Left (_actorByKey, _actorE, outboxItemID)) (Left (_, actorID, _)) = do + Entity followID follow <- + MaybeT $ lift $ getBy $ UniqueFollowFollow outboxItemID + let followerID = followActor follow + followerSetID = followTarget follow + verifyTargetMe followerSetID <|> verifyTargetTicket followerSetID + unless (followerID == actorID) $ + lift $ throwE "You're trying to Undo someone else's Follow" + lift $ lift $ delete followID + audSenderOnly <- lift $ lift $ lift $ makeAudSenderOnly authorIdMsig + return (makeRecipientSet [] [], [audSenderOnly]) + where + verifyTargetMe followerSetID = guard $ followerSetID == deckFollowersID + tryUnfollow deckFollowersID (Right remoteActivityID) (Right (author, _, _)) = do Entity remoteFollowID remoteFollow <- MaybeT $ lift $ getBy $ UniqueRemoteFollowFollow remoteActivityID let followerID = remoteFollowActor remoteFollow @@ -315,17 +312,11 @@ deckUndo now recipDeckID author body mfwd luUndo (AP.Undo uObject) = do unless (followerID == remoteAuthorId author) $ lift $ throwE "You're trying to Undo someone else's Follow" lift $ lift $ delete remoteFollowID - let ObjURI hAuthor luAuthor = remoteAuthorURI author - audSenderOnly = AudRemote hAuthor [luAuthor] [] + audSenderOnly <- lift $ lift $ lift $ makeAudSenderOnly authorIdMsig return (makeRecipientSet [] [], [audSenderOnly]) where verifyTargetMe followerSetID = guard $ followerSetID == deckFollowersID - verifyTargetTicket followerSetID = do - ticketID <- - MaybeT $ lift $ getKeyBy $ UniqueTicketFollowers followerSetID - TicketDeck _ d <- - MaybeT $ lift $ getValBy $ UniqueTicketDeck ticketID - guard $ d == recipDeckID + tryUnfollow _ _ _ = mzero tryUnresolve maybeCapability undone = do (deleteFromDB, ticketID) <- findTicket undone @@ -343,22 +334,16 @@ deckUndo now recipDeckID author body mfwd luUndo (AP.Undo uObject) = do Left c -> pure c Right _ -> throwE "Capability is a remote URI, i.e. not authored by me" lift $ - verifyCapability + verifyCapability' capability - (Right $ remoteAuthorId author) + authorIdMsig (GrantResourceDeck recipDeckID) lift $ lift deleteFromDB recipDeckHash <- encodeKeyHashid recipDeckID taskHash <- encodeKeyHashid taskID - audSender <- lift $ do - ra <- lift $ getJust $ remoteAuthorId author - let ObjURI hAuthor luAuthor = remoteAuthorURI author - return $ - AudRemote hAuthor - [luAuthor] - (maybeToList $ remoteActorFollowers ra) + audSender <- lift $ lift $ makeAudSenderWithFollowers authorIdMsig return ( makeRecipientSet [] @@ -399,8 +384,8 @@ deckUndo now recipDeckID author body mfwd luUndo (AP.Undo uObject) = do prepareAccept audience = do encodeRouteHome <- getEncodeRouteHome - let ObjURI hAuthor _ = remoteAuthorURI author - (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + uUndo <- getActivityURI authorIdMsig + let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = collectAudience audience recips = map encodeRouteHome audLocal ++ audRemote @@ -410,7 +395,7 @@ deckUndo now recipDeckID author body mfwd luUndo (AP.Undo uObject) = do , AP.actionAudience = AP.Audience recips [] [] [] [] [] , AP.actionFulfills = [] , AP.actionSpecific = AP.AcceptActivity AP.Accept - { AP.acceptObject = ObjURI hAuthor luUndo + { AP.acceptObject = uUndo , AP.acceptResult = Nothing } } @@ -421,27 +406,15 @@ deckUndo now recipDeckID author body mfwd luUndo (AP.Undo uObject) = do -- Main behavior function ------------------------------------------------------------------------------ -deckBehavior - :: UTCTime -> DeckId -> Verse -> ExceptT Text Act (Text, Act (), Next) -deckBehavior _now _deckID (Left event) = - case event of - EventRemoteFwdLocalActivity _ _ -> - throwE "Got a forwarded local activity, I don't need those" - _ -> throwE $ "Unsupported event for Deck: " <> T.pack (show event) -deckBehavior now deckID (Right (VerseRemote author body mfwd luActivity)) = +deckBehavior :: UTCTime -> DeckId -> Verse -> ActE (Text, Act (), Next) +deckBehavior now deckID verse@(Verse _authorIdMsig body) = case AP.activitySpecific $ actbActivity body of - AP.AcceptActivity accept -> - deckAccept now deckID author body mfwd luActivity accept - AP.FollowActivity follow -> - deckFollow now deckID author body mfwd luActivity follow - AP.InviteActivity invite -> - deckInvite now deckID author body mfwd luActivity invite - AP.JoinActivity join -> - deckJoin now deckID author body mfwd luActivity join - AP.RejectActivity reject -> - deckReject now deckID author body mfwd luActivity reject - AP.UndoActivity undo -> - deckUndo now deckID author body mfwd luActivity undo + AP.AcceptActivity accept -> deckAccept now deckID verse accept + AP.FollowActivity follow -> deckFollow now deckID verse follow + AP.InviteActivity invite -> deckInvite now deckID verse invite + AP.JoinActivity join -> deckJoin now deckID verse join + AP.RejectActivity reject -> deckReject now deckID verse reject + AP.UndoActivity undo -> deckUndo now deckID verse undo _ -> throwE "Unsupported activity type for Deck" instance VervisActor Deck where diff --git a/src/Vervis/Actor/Group.hs b/src/Vervis/Actor/Group.hs index 475b8ea..f2c4a14 100644 --- a/src/Vervis/Actor/Group.hs +++ b/src/Vervis/Actor/Group.hs @@ -52,14 +52,8 @@ import Vervis.Model import Vervis.Persist.Discussion import Vervis.Ticket -groupBehavior - :: UTCTime -> GroupId -> Verse -> ExceptT Text Act (Text, Act (), Next) -groupBehavior now groupID (Left event) = - case event of - EventRemoteFwdLocalActivity _ _ -> - throwE "Got a forwarded local activity, I don't need those" - _ -> throwE $ "Unsupported event for Group: " <> T.pack (show event) -groupBehavior now groupID (Right (VerseRemote author body mfwd luActivity)) = +groupBehavior :: UTCTime -> GroupId -> Verse -> ActE (Text, Act (), Next) +groupBehavior now groupID _verse@(Verse _authorIdMsig body) = case AP.activitySpecific $ actbActivity body of _ -> throwE "Unsupported activity type for Group" diff --git a/src/Vervis/Actor/Loom.hs b/src/Vervis/Actor/Loom.hs index cb8decc..41c7a14 100644 --- a/src/Vervis/Actor/Loom.hs +++ b/src/Vervis/Actor/Loom.hs @@ -52,14 +52,8 @@ import Vervis.Model import Vervis.Persist.Discussion import Vervis.Ticket -loomBehavior - :: UTCTime -> LoomId -> Verse -> ExceptT Text Act (Text, Act (), Next) -loomBehavior now loomID (Left event) = - case event of - EventRemoteFwdLocalActivity _ _ -> - throwE "Got a forwarded local activity, I don't need those" - _ -> throwE $ "Unsupported event for Loom: " <> T.pack (show event) -loomBehavior now loomID (Right (VerseRemote author body mfwd luActivity)) = +loomBehavior :: UTCTime -> LoomId -> Verse -> ActE (Text, Act (), Next) +loomBehavior now loomID _verse@(Verse _authorIdMsig body) = case AP.activitySpecific $ actbActivity body of _ -> throwE "Unsupported activity type for Loom" diff --git a/src/Vervis/Actor/Person.hs b/src/Vervis/Actor/Person.hs index c162ff2..28b1713 100644 --- a/src/Vervis/Actor/Person.hs +++ b/src/Vervis/Actor/Person.hs @@ -36,6 +36,7 @@ import Data.Time.Clock import Data.Traversable import Database.Persist import Database.Persist.Sql +import Optics.Core import Yesod.Persist.Core import qualified Data.Text as T @@ -60,6 +61,7 @@ import Vervis.Cloth import Vervis.Data.Actor import Vervis.Data.Collab import Vervis.Data.Discussion +import Vervis.Data.Follow import Vervis.FedURI import Vervis.Federation.Util import Vervis.Foundation @@ -68,6 +70,7 @@ import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectA import Vervis.Persist.Actor import Vervis.Persist.Collab import Vervis.Persist.Discussion +import Vervis.Persist.Follow import Vervis.Ticket ------------------------------------------------------------------------------ @@ -82,13 +85,10 @@ import Vervis.Ticket personFollow :: UTCTime -> PersonId - -> RemoteAuthor - -> ActivityBody - -> Maybe (RecipientRoutes, ByteString) - -> LocalURI + -> Verse -> AP.Follow URIMode -> ActE (Text, Act (), Next) -personFollow now recipPersonID author body mfwd luFollow follow = do +personFollow now recipPersonID verse follow = do recipPersonHash <- encodeKeyHashid recipPersonID actorFollow (\case @@ -103,9 +103,9 @@ personFollow now recipPersonID author body mfwd luFollow follow = do (\ () -> pure $ makeRecipientSet [] []) LocalActorPerson (\ () -> pure []) - now recipPersonID author body mfwd luFollow follow + now recipPersonID verse follow --- Meaning: A remote actor is undoing some previous action +-- Meaning: Someone is undoing some previous action -- Behavior: -- * Insert to my inbox -- * If they're undoing their Following of me: @@ -114,13 +114,10 @@ personFollow now recipPersonID author body mfwd luFollow follow = do personUndo :: UTCTime -> PersonId - -> RemoteAuthor - -> ActivityBody - -> Maybe (RecipientRoutes, ByteString) - -> LocalURI + -> Verse -> AP.Undo URIMode -> ActE (Text, Act (), Next) -personUndo now recipPersonID author body _mfwd luUndo (AP.Undo uObject) = do +personUndo now recipPersonID (Verse authorIdMsig body) (AP.Undo uObject) = do -- Check input undone <- @@ -129,14 +126,14 @@ personUndo now recipPersonID author body _mfwd luUndo (AP.Undo uObject) = do maybeUndo <- withDBExcept $ do - -- Grab recipient person from DB + -- Grab me from DB (personRecip, actorRecip) <- lift $ do p <- getJust recipPersonID (p,) <$> getJust (personActor p) -- Insert the Undo to person's inbox - mractid <- lift $ insertToInbox now author body (actorInbox actorRecip) luUndo False - for mractid $ \ undoID -> do + maybeUndoDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False + for maybeUndoDB $ \ undoDB -> do maybeUndo <- runMaybeT $ do @@ -144,7 +141,7 @@ personUndo now recipPersonID author body _mfwd luUndo (AP.Undo uObject) = do undoneDB <- MaybeT $ getActivity undone let followers = actorFollowers actorRecip - tryUnfollow followers undoneDB + tryUnfollow followers undoneDB undoDB for maybeUndo $ \ () -> do @@ -161,14 +158,12 @@ personUndo now recipPersonID author body _mfwd luUndo (AP.Undo uObject) = do Just (Just (actorID, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept))) -> do lift $ sendActivity (LocalActorPerson recipPersonID) actorID localRecipsAccept - remoteRecipsAccept fwdHostsAccept acceptID - EventAcceptRemoteFollow actionAccept + remoteRecipsAccept fwdHostsAccept acceptID actionAccept done "Undid the Follow and published Accept" where - tryUnfollow _ (Left _) = mzero - tryUnfollow personFollowersID (Right remoteActivityID) = do + tryUnfollow personFollowersID (Right remoteActivityID) (Right (author, _, _)) = do Entity remoteFollowID remoteFollow <- MaybeT $ lift $ getBy $ UniqueRemoteFollowFollow remoteActivityID let followerID = remoteFollowActor remoteFollow @@ -177,13 +172,23 @@ personUndo now recipPersonID author body _mfwd luUndo (AP.Undo uObject) = do unless (followerID == remoteAuthorId author) $ lift $ throwE "You're trying to Undo someone else's Follow" lift $ lift $ delete remoteFollowID + tryUnfollow personFollowersID (Left (_, _, outboxItemID)) (Left (_, actorID, _)) = do + Entity followID follow <- + MaybeT $ lift $ getBy $ UniqueFollowFollow outboxItemID + let followerID = followActor follow + followerSetID = followTarget follow + guard $ followerSetID == personFollowersID + unless (followerID == actorID) $ + lift $ throwE "You're trying to Undo someone else's Follow" + lift $ lift $ delete followID + tryUnfollow _ _ _ = mzero prepareAccept = do encodeRouteHome <- getEncodeRouteHome - let ObjURI hAuthor luAuthor = remoteAuthorURI author - audSender = AudRemote hAuthor [luAuthor] [] - (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + audSender <- makeAudSenderOnly authorIdMsig + uUndo <- getActivityURI authorIdMsig + let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = collectAudience [audSender] recips = map encodeRouteHome audLocal ++ audRemote @@ -193,47 +198,44 @@ personUndo now recipPersonID author body _mfwd luUndo (AP.Undo uObject) = do , AP.actionAudience = AP.Audience recips [] [] [] [] [] , AP.actionFulfills = [] , AP.actionSpecific = AP.AcceptActivity AP.Accept - { AP.acceptObject = ObjURI hAuthor luUndo + { AP.acceptObject = uUndo , AP.acceptResult = Nothing } } return (action, recipientSet, remoteActors, fwdHosts) --- Meaning: A remote actor accepted something +-- Meaning: An actor accepted something -- Behavior: -- * Insert to my inbox -- * If it's a Follow I sent to them, add to my following list in DB personAccept :: UTCTime -> PersonId - -> RemoteAuthor - -> ActivityBody - -> Maybe (RecipientRoutes, ByteString) - -> LocalURI + -> Verse -> AP.Accept URIMode -> ActE (Text, Act (), Next) -personAccept now recipPersonID author body _mfwd luAccept accept = do +personAccept now recipPersonID (Verse authorIdMsig body) accept = do -- Check input acceptee <- parseAccept accept - maybeAccept <- withDBExcept $ do + maybeNew <- withDBExcept $ do - -- Grab recipient person from DB + -- Grab me from DB (personRecip, actorRecip) <- lift $ do p <- getJust recipPersonID (p,) <$> getJust (personActor p) - mractid <- lift $ insertToInbox now author body (actorInbox actorRecip) luAccept True - for mractid $ \ acceptID -> runMaybeT $ do + maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True + for maybeAcceptDB $ \ acceptDB -> runMaybeT $ do -- Find the accepted activity in our DB accepteeDB <- MaybeT $ getActivity acceptee - tryFollow (personActor personRecip) accepteeDB acceptID + tryFollow (personActor personRecip) accepteeDB acceptDB - case maybeAccept of + case maybeNew of Nothing -> done "I already have this activity in my inbox" Just Nothing -> done "Not my Follow; Just inserted to my inbox" Just (Just ()) -> @@ -241,7 +243,7 @@ personAccept now recipPersonID author body _mfwd luAccept accept = do where - tryFollow actorID (Left (_, _, outboxItemID)) acceptID = do + tryFollow actorID (Left (_, _, outboxItemID)) (Right (author, _, acceptID)) = do Entity key val <- MaybeT $ lift $ getBy $ UniqueFollowRemoteRequestActivity outboxItemID @@ -261,42 +263,55 @@ personAccept now recipPersonID author body _mfwd luAccept accept = do , followRemoteFollow = outboxItemID , followRemoteAccept = acceptID } + tryFollow actorID (Left (_, _, outboxItemID)) (Left (authorByKey, _, acceptID)) = do + Entity key val <- + MaybeT $ lift $ getBy $ UniqueFollowRequestFollow outboxItemID + guard $ followRequestActor val == actorID + targetByKey <- + lift $ lift $ followeeActor <$> getFollowee' (followRequestTarget val) + unless (authorByKey == targetByKey) $ + lift $ throwE "You're Accepting a Follow I sent to someone else" + lift $ lift $ delete key + lift $ lift $ insert_ Follow + { followActor = actorID + , followTarget = followRequestTarget val + , followPublic = followRequestPublic val + , followFollow = outboxItemID + , followAccept = acceptID + } tryFollow _ (Right _) _ = mzero --- Meaning: A remote actor rejected something +-- Meaning: An actor rejected something -- Behavior: -- * Insert to my inbox -- * If it's a Follow I sent to them, remove record from my DB personReject :: UTCTime -> PersonId - -> RemoteAuthor - -> ActivityBody - -> Maybe (RecipientRoutes, ByteString) - -> LocalURI + -> Verse -> AP.Reject URIMode -> ActE (Text, Act (), Next) -personReject now recipPersonID author body _mfwd luReject reject = do +personReject now recipPersonID (Verse authorIdMsig body) reject = do -- Check input rejectee <- parseReject reject - maybeReject <- withDBExcept $ do + maybeNew <- withDBExcept $ do - -- Grab recipient person from DB + -- Grab me from DB (personRecip, actorRecip) <- lift $ do p <- getJust recipPersonID (p,) <$> getJust (personActor p) - mractid <- lift $ insertToInbox now author body (actorInbox actorRecip) luReject True - for mractid $ \ rejectID -> runMaybeT $ do + maybeRejectDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True + for maybeRejectDB $ \ _rejectDB -> runMaybeT $ do -- Find the rejected activity in our DB rejecteeDB <- MaybeT $ getActivity rejectee - tryFollow rejecteeDB + tryFollow (personActor personRecip) rejecteeDB authorIdMsig - case maybeReject of + case maybeNew of Nothing -> done "I already have this activity in my inbox" Just Nothing -> done "Not my Follow; Just inserted to my inbox" Just (Just ()) -> @@ -304,7 +319,7 @@ personReject now recipPersonID author body _mfwd luReject reject = do where - tryFollow (Left (_, _, outboxItemID)) = do + tryFollow _actorID (Left (_, _, outboxItemID)) (Right (author, _, _)) = do Entity key val <- MaybeT $ lift $ getBy $ UniqueFollowRemoteRequestActivity outboxItemID @@ -316,7 +331,16 @@ personReject now recipPersonID author body _mfwd luReject reject = do unless (remoteAuthorURI author == uRecip) $ lift $ throwE "You're Rejecting a Follow I sent to someone else" lift $ lift $ delete key - tryFollow (Right _) = mzero + tryFollow actorID (Left (_, _, outboxItemID)) (Left (authorByKey, _, _)) = do + Entity key val <- + MaybeT $ lift $ getBy $ UniqueFollowRequestFollow outboxItemID + guard $ followRequestActor val == actorID + targetByKey <- + lift $ lift $ followeeActor <$> getFollowee' (followRequestTarget val) + unless (authorByKey == targetByKey) $ + lift $ throwE "You're Rejecting a Follow I sent to someone else" + lift $ lift $ delete key + tryFollow _ (Right _) _ = mzero ------------------------------------------------------------------------------ -- Commenting @@ -327,18 +351,16 @@ personReject now recipPersonID author body _mfwd luReject reject = do personCreateNote :: UTCTime -> PersonId - -> RemoteAuthor - -> ActivityBody - -> Maybe (RecipientRoutes, ByteString) - -> LocalURI + -> Verse -> AP.Note URIMode -> ActE (Text, Act (), Next) -personCreateNote now recipPersonID author body mfwd luCreate note = do +personCreateNote now recipPersonID (Verse authorIdMsig body) note = do -- Check input (luNote, published, Comment maybeParent topic source content) <- do (luId, luAuthor, published, comment) <- parseRemoteComment note - unless (luAuthor == objUriLocal (remoteAuthorURI author)) $ + uCreateAuthor <- lift $ getActorURI authorIdMsig + unless (luAuthor == objUriLocal uCreateAuthor) $ throwE "Create author != note author" return (luId, published, comment) @@ -352,7 +374,7 @@ personCreateNote now recipPersonID author body mfwd luCreate note = do Right uContext -> do checkContextParent uContext maybeParent - lift $ insertToInbox now author body (actorInbox recipActor) luCreate True + lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) True Left (CommentTopicTicket deckID taskID) -> do (_, _, Entity _ ticket, _, _) <- do @@ -360,7 +382,7 @@ personCreateNote now recipPersonID author body mfwd luCreate note = do fromMaybeE mticket "Context: No such deck-ticket" let did = ticketDiscuss ticket _ <- traverse (getMessageParent did) maybeParent - lift $ insertToInbox now author body (actorInbox recipActor) luCreate True + lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) True Left (CommentTopicCloth loomID clothID) -> do (_, _, Entity _ ticket, _, _, _) <- do @@ -368,7 +390,7 @@ personCreateNote now recipPersonID author body mfwd luCreate note = do fromMaybeE mticket "Context: No such loom-cloth" let did = ticketDiscuss ticket _ <- traverse (getMessageParent did) maybeParent - lift $ insertToInbox now author body (actorInbox recipActor) luCreate True + lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) True done $ case mractid of @@ -409,344 +431,165 @@ personCreateNote now recipPersonID author body mfwd luCreate note = do personInvite :: UTCTime -> PersonId - -> RemoteAuthor - -> ActivityBody - -> Maybe (RecipientRoutes, ByteString) - -> LocalURI + -> Verse -> AP.Invite URIMode -> ActE (Text, Act (), Next) -personInvite now recipPersonID author body mfwd luInvite invite = do +personInvite now recipPersonID (Verse authorIdMsig body) invite = do -- Check input recipient <- do - (_resource, target) <- - parseInvite (Right $ remoteAuthorURI author) invite + let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig + (_resource, target) <- parseInvite author invite return target - maybeInvite <- withDBExcept $ do + maybeNew <- withDBExcept $ do - -- Grab recipient person from DB + -- Grab me from DB (personRecip, actorRecip) <- lift $ do p <- getJust recipPersonID (p,) <$> getJust (personActor p) - mractid <- lift $ insertToInbox now author body (actorInbox actorRecip) luInvite True - for mractid $ \ inviteID -> - return (personActor personRecip, inviteID) + maybeInviteDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True + for maybeInviteDB $ \ _inviteDB -> + return $ personActor personRecip - case maybeInvite of + case maybeNew of Nothing -> done "I already have this activity in my inbox" - Just (actorID, inviteID) -> do + Just actorID -> do let targetIsRecip = case recipient of Left (GrantRecipPerson p) -> p == recipPersonID _ -> False if not targetIsRecip then done "I'm not the target; Inserted to inbox" - else case mfwd of - Nothing -> - done - "I'm the target; Inserted to inbox; \ - \Forwarding not approved" - Just (localRecips, sig) -> do - recipHash <- encodeKeyHashid recipPersonID - let sieve = - makeRecipientSet - [] - [LocalStagePersonFollowers recipHash] - lift $ forwardActivity - (actbBL body) localRecips sig - actorID - (LocalActorPerson recipPersonID) sieve - (EventRemoteInviteLocalRecipFwdToFollower inviteID) - done - "I'm the target; Inserted to inbox; \ - \Forwarded to followers if addressed" + else do + recipHash <- encodeKeyHashid recipPersonID + let sieve = + makeRecipientSet + [] + [LocalStagePersonFollowers recipHash] + forwardActivity + authorIdMsig body (LocalActorPerson recipPersonID) + actorID sieve + done + "I'm the target; Inserted to inbox; \ + \Forwarded to followers if addressed" -- Meaning: Someone asked to join a resource -- Behavior: Insert to my inbox personJoin :: UTCTime -> PersonId - -> RemoteAuthor - -> ActivityBody - -> Maybe (RecipientRoutes, ByteString) - -> LocalURI + -> Verse -> AP.Join URIMode -> ActE (Text, Act (), Next) -personJoin now recipPersonID author body mfwd luJoin join = do +personJoin now recipPersonID (Verse authorIdMsig body) join = do -- Check input _resource <- parseJoin join maybeJoinID <- lift $ withDB $ do - -- Grab recipient person from DB + -- Grab me from DB (_personRecip, actorRecip) <- do p <- getJust recipPersonID (p,) <$> getJust (personActor p) - insertToInbox now author body (actorInbox actorRecip) luJoin True + insertToInbox now authorIdMsig body (actorInbox actorRecip) True case maybeJoinID of Nothing -> done "I already have this activity in my inbox" Just _joinID -> done "Inserted to my inbox" --- Meaning: A remote actor published a Grant +-- Meaning: An actor published a Grant -- Behavior: -- * Insert to my inbox personGrant :: UTCTime -> PersonId - -> RemoteAuthor - -> ActivityBody - -> Maybe (RecipientRoutes, ByteString) - -> LocalURI + -> Verse -> AP.Grant URIMode -> ActE (Text, Act (), Next) -personGrant now recipPersonID author body mfwd luGrant grant = do +personGrant now recipPersonID (Verse authorIdMsig body) grant = do -- Check input - (_remoteResource, recipient) <- do - let u@(ObjURI h _) = remoteAuthorURI author + target <- do + h <- lift $ objUriAuthority <$> getActorURI authorIdMsig (resource, recip, _mresult, _mstart, _mend) <- parseGrant h grant - resourceURI <- - case resource of - Right r -> return (u, r) - _ -> error "Remote Grant but parseGrant identified local resource" - when (recip == Right u) $ - throwE "Grant sender and target are the same remote actor" - return (resourceURI, recip) + case (recip, authorIdMsig) of + (Left (GrantRecipPerson p), Left (LocalActorPerson p', _, _)) + | p == p' -> + throwE "Grant sender and target are the same local Person" + (Right uRecip, Right (author, _, _)) + | uRecip == remoteAuthorURI author -> + throwE "Grant sender and target are the same remote actor" + _ -> pure () + return recip maybeGrant <- withDBExcept $ do - -- Grab recipient person from DB + -- Grab me from DB (personRecip, actorRecip) <- lift $ do p <- getJust recipPersonID (p,) <$> getJust (personActor p) - mractid <- lift $ insertToInbox now author body (actorInbox actorRecip) luGrant True - for mractid $ \ grantID -> - return (personActor personRecip, grantID) + mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True + for mractid $ \ _grantDB -> return $ personActor personRecip case maybeGrant of Nothing -> done "I already have this activity in my inbox" - Just (_actorID, _grantID) -> do + Just _actorID -> do let targetIsRecip = - case recipient of + case target of Left (GrantRecipPerson p) -> p == recipPersonID _ -> False if not targetIsRecip then done "I'm not the target; Inserted to inbox" else done "I'm the target; Inserted to inbox" --- Meaning: A remote actor has revoked some previously published Grants +-- Meaning: An actor has revoked some previously published Grants -- Behavior: Insert to my inbox personRevoke :: UTCTime -> PersonId - -> RemoteAuthor - -> ActivityBody - -> Maybe (RecipientRoutes, ByteString) - -> LocalURI + -> Verse -> AP.Revoke URIMode -> ActE (Text, Act (), Next) -personRevoke now recipPersonID author body _mfwd luRevoke (AP.Revoke _lus) = do +personRevoke now recipPersonID (Verse authorIdMsig body) (AP.Revoke _lus) = do maybeRevoke <- lift $ withDB $ do - -- Grab recipient person from DB + -- Grab me from DB (_personRecip, actorRecip) <- do p <- getJust recipPersonID (p,) <$> getJust (personActor p) - insertToInbox now author body (actorInbox actorRecip) luRevoke True + insertToInbox now authorIdMsig body (actorInbox actorRecip) True case maybeRevoke of Nothing -> done "I already have this activity in my inbox" - Just _revokeID -> done "Inserted to my inbox" + Just _revokeDB -> done "Inserted to my inbox" ------------------------------------------------------------------------------ -- Main behavior function ------------------------------------------------------------------------------ -insertActivityToInbox - :: MonadIO m - => UTCTime -> ActorId -> OutboxItemId -> ReaderT SqlBackend m Bool -insertActivityToInbox now recipActorID outboxItemID = do - inboxID <- actorInbox <$> getJust recipActorID - inboxItemID <- insert $ InboxItem True now - maybeItem <- insertUnique $ InboxItemLocal inboxID outboxItemID inboxItemID - case maybeItem of - Nothing -> do - delete inboxItemID - return False - Just _ -> return True - personBehavior :: UTCTime -> PersonId -> Verse -> ActE (Text, Act (), Next) -personBehavior now personID (Left event) = - case event of - -- Meaning: Someone X received an Invite and forwarded it to me because - -- I'm a follower of X - -- Behavior: Insert to my inbox - EventRemoteInviteLocalRecipFwdToFollower inviteID -> do - lift $ withDB $ do - (_personRecip, actorRecip) <- do - p <- getJust personID - (p,) <$> getJust (personActor p) - let inboxID = actorInbox actorRecip - itemID <- insert $ InboxItem True now - insert_ $ InboxItemRemote inboxID inviteID itemID - done "Inserted Invite to inbox" - -- Meaning: A remote actor has forwarded to me a local activity - -- Behavior: Insert it to my inbox - EventRemoteFwdLocalActivity authorByKey outboxItemID -> withDBExcept $ do - recipPerson <- lift $ getJust personID - verifyLocalActivityExistsInDB authorByKey outboxItemID - if LocalActorPerson personID == authorByKey - then done "Received activity authored by self, ignoring" - else do - inserted <- lift $ insertActivityToInbox now (personActor recipPerson) outboxItemID - done $ - if inserted - then "Activity inserted to my inbox" - else "Activity already exists in my inbox, ignoring" - -- Meaning: A deck/loom received an Undo{Resolve} and forwarded it to - -- me because I'm a follower of the deck/loom or the ticket - -- Behavior: Insert to my inbox - EventRemoteUnresolveLocalResourceFwdToFollower undoID -> do - lift $ withDB $ do - (_personRecip, actorRecip) <- do - p <- getJust personID - (p,) <$> getJust (personActor p) - let inboxID = actorInbox actorRecip - itemID <- insert $ InboxItem True now - insert_ $ InboxItemRemote inboxID undoID itemID - done "Inserted Undo{Resolve} to inbox" - -- Meaning: A remote actor accepted an Invite on a local resource, I'm - -- being forwarded as a follower of the resource - -- - -- Behavior: Insert the Accept to my inbox - EventRemoteAcceptInviteLocalResourceFwdToFollower acceptID -> do - lift $ withDB $ do - (_personRecip, actorRecip) <- do - p <- getJust personID - (p,) <$> getJust (personActor p) - let inboxID = actorInbox actorRecip - itemID <- insert $ InboxItem True now - insert_ $ InboxItemRemote inboxID acceptID itemID - done "Inserted Accept{Invite} to inbox" - -- Meaning: A remote actor approved a Join on a local resource, I'm - -- being forwarded as a follower of the resource - -- - -- Behavior: Insert the Accept to my inbox - EventRemoteApproveJoinLocalResourceFwdToFollower acceptID -> do - lift $ withDB $ do - (_personRecip, actorRecip) <- do - p <- getJust personID - (p,) <$> getJust (personActor p) - let inboxID = actorInbox actorRecip - itemID <- insert $ InboxItem True now - insert_ $ InboxItemRemote inboxID acceptID itemID - done "Inserted Accept{Join} to inbox" - -- Meaning: Local resource sent a Grant, I'm the - -- inviter/approver/target/follower - -- - -- Behavior: Insert the Grant to my inbox - EventGrantAfterRemoteAccept grantID -> do - _ <- lift $ withDB $ do - (personRecip, _actorRecip) <- do - p <- getJust personID - (p,) <$> getJust (personActor p) - insertActivityToInbox now (personActor personRecip) grantID - done "Inserted Grant to my inbox" - -- Meaning: A remote actor rejected an Invite on a local resource, I'm - -- being forwarded as a follower of the resource - -- - -- Behavior: Insert the Accept to my inbox - EventRemoteRejectInviteLocalResourceFwdToFollower rejectID -> do - lift $ withDB $ do - (_personRecip, actorRecip) <- do - p <- getJust personID - (p,) <$> getJust (personActor p) - let inboxID = actorInbox actorRecip - itemID <- insert $ InboxItem True now - insert_ $ InboxItemRemote inboxID rejectID itemID - done "Inserted Reject{Invite} to inbox" - -- Meaning: A remote actor disapproved a Join on a local resource, I'm - -- being forwarded as a follower of the resource - -- - -- Behavior: Insert the Reject to my inbox - EventRemoteForbidJoinLocalResourceFwdToFollower rejectID -> do - lift $ withDB $ do - (_personRecip, actorRecip) <- do - p <- getJust personID - (p,) <$> getJust (personActor p) - let inboxID = actorInbox actorRecip - itemID <- insert $ InboxItem True now - insert_ $ InboxItemRemote inboxID rejectID itemID - done "Inserted Reject{Join} to inbox" - -- Meaning: Local resource sent a Reject on Invite/Join, I'm the - -- inviter/disapprover/target/follower - -- - -- Behavior: Insert the Reject to my inbox - EventRejectAfterRemoteReject rejectID -> do - _ <- lift $ withDB $ do - (personRecip, _actorRecip) <- do - p <- getJust personID - (p,) <$> getJust (personActor p) - insertActivityToInbox now (personActor personRecip) rejectID - done "Inserted Reject to my inbox" - -- Meaning: An authorized remote actor sent an Invite on a local - -- resource, I'm being forwarded as a follower of the resource - -- - -- Behavior: Insert the Invite to my inbox - EventRemoteInviteLocalTopicFwdToFollower inviteID -> do - lift $ withDB $ do - (_personRecip, actorRecip) <- do - p <- getJust personID - (p,) <$> getJust (personActor p) - let inboxID = actorInbox actorRecip - itemID <- insert $ InboxItem True now - insert_ $ InboxItemRemote inboxID inviteID itemID - done "Inserted Invite to inbox" - -- Meaning: A remote actor sent a Join on a local resource, I'm being - -- forwarded as a follower of the resource - -- - -- Behavior: Insert the Join to my inbox - EventRemoteJoinLocalTopicFwdToFollower joinID -> do - lift $ withDB $ do - (_personRecip, actorRecip) <- do - p <- getJust personID - (p,) <$> getJust (personActor p) - let inboxID = actorInbox actorRecip - itemID <- insert $ InboxItem True now - insert_ $ InboxItemRemote inboxID joinID itemID - done "Inserted Invite to inbox" - _ -> throwE $ "Unsupported event for Person: " <> T.pack (show event) -personBehavior now personID (Right (VerseRemote author body mfwd luActivity)) = +personBehavior now personID verse@(Verse _authorIdMsig body) = case AP.activitySpecific $ actbActivity body of - AP.AcceptActivity accept -> - personAccept now personID author body mfwd luActivity accept + AP.AcceptActivity accept -> personAccept now personID verse accept AP.CreateActivity (AP.Create obj mtarget) -> case obj of AP.CreateNote _ note -> - personCreateNote now personID author body mfwd luActivity note + personCreateNote now personID verse note _ -> throwE "Unsupported create object type for people" - AP.FollowActivity follow -> - personFollow now personID author body mfwd luActivity follow - AP.GrantActivity grant -> - personGrant now personID author body mfwd luActivity grant - AP.InviteActivity invite -> - personInvite now personID author body mfwd luActivity invite - AP.JoinActivity join -> - personJoin now personID author body mfwd luActivity join - AP.RejectActivity reject -> - personReject now personID author body mfwd luActivity reject - AP.RevokeActivity revoke -> - personRevoke now personID author body mfwd luActivity revoke - AP.UndoActivity undo -> - personUndo now personID author body mfwd luActivity undo + AP.FollowActivity follow -> personFollow now personID verse follow + AP.GrantActivity grant -> personGrant now personID verse grant + AP.InviteActivity invite -> personInvite now personID verse invite + AP.JoinActivity join -> personJoin now personID verse join + AP.RejectActivity reject -> personReject now personID verse reject + AP.RevokeActivity revoke -> personRevoke now personID verse revoke + AP.UndoActivity undo -> personUndo now personID verse undo _ -> throwE "Unsupported activity type for Person" instance VervisActor Person where diff --git a/src/Vervis/Actor/Repo.hs b/src/Vervis/Actor/Repo.hs index 313ec9c..44c32a0 100644 --- a/src/Vervis/Actor/Repo.hs +++ b/src/Vervis/Actor/Repo.hs @@ -52,14 +52,8 @@ import Vervis.Model import Vervis.Persist.Discussion import Vervis.Ticket -repoBehavior - :: UTCTime -> RepoId -> Verse -> ExceptT Text Act (Text, Act (), Next) -repoBehavior now repoID (Left event) = - case event of - EventRemoteFwdLocalActivity _ _ -> - throwE "Got a forwarded local activity, I don't need those" - _ -> throwE $ "Unsupported event for Repo: " <> T.pack (show event) -repoBehavior now repoID (Right (VerseRemote author body mfwd luActivity)) = +repoBehavior :: UTCTime -> RepoId -> Verse -> ActE (Text, Act (), Next) +repoBehavior now repoID _verse@(Verse _authorIdMsig body) = case AP.activitySpecific $ actbActivity body of _ -> throwE "Unsupported activity type for Repo" diff --git a/src/Vervis/Actor2.hs b/src/Vervis/Actor2.hs index 488c1c9..ce0f2e0 100644 --- a/src/Vervis/Actor2.hs +++ b/src/Vervis/Actor2.hs @@ -23,6 +23,11 @@ module Vervis.Actor2 ( -- * Sending messages to actors sendActivity , forwardActivity + -- * Preparing a new activity + , makeAudSenderOnly + , makeAudSenderWithFollowers + , getActivityURI + , getActorURI ) where @@ -31,10 +36,13 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Except import Data.Barbie +import Data.Bifunctor import Data.ByteString (ByteString) import Data.Either +import Data.Foldable import Data.Hashable import Data.List.NonEmpty (NonEmpty) +import Data.Maybe import Data.Text (Text) import Data.Time.Clock import Data.Traversable @@ -58,23 +66,16 @@ import Web.Actor.Persist import qualified Web.ActivityPub as AP +import Control.Monad.Trans.Except.Local + import Vervis.Actor import Vervis.Data.Actor import Vervis.FedURI import Vervis.Foundation import Vervis.Model hiding (Actor, Message) -import Vervis.Recipient (renderLocalActor, localRecipSieve') +import Vervis.Recipient (renderLocalActor, localRecipSieve', localActorFollowers, Aud (..), ParsedAudience (..), parseAudience') import Vervis.Settings -instance StageWebRoute Env where - type StageRoute Env = Route App - askUrlRenderParams = do - Env _ _ _ _ _ render _ _ <- askEnv - case cast render of - Nothing -> error "Env site isn't App" - Just r -> pure r - pageParamName _ = "page" - askLatestInstanceKey :: Act (Maybe (Route App, ActorKey)) askLatestInstanceKey = do maybeTVar <- asksEnv envActorKeys @@ -173,15 +174,28 @@ sendActivity -- ^ Instances for which the sender is approving to forward this activity -> OutboxItemId -- ^ DB ID of the item in the author's outbox - -> Event - -- ^ Event to send to local live actors -> AP.Action URIMode -- ^ Activity to send to remote actors -> Act () -sendActivity senderByKey senderActorID localRecips remoteRecips fwdHosts itemID event action = do - moreRemoteRecips <- +sendActivity senderByKey senderActorID localRecips remoteRecips fwdHosts itemID action = do + moreRemoteRecips <- do let justSender = Just senderByKey - in sendToLocalActors event True justSender justSender localRecips + author = (senderByKey, senderActorID, itemID) + encodeRouteLocal <- getEncodeRouteLocal + itemHash <- encodeKeyHashid itemID + senderByHash <- hashLocalActor senderByKey + hLocal <- asksEnv stageInstanceHost + let act = + let luId = encodeRouteLocal $ activityRoute senderByHash itemHash + luActor = encodeRouteLocal $ renderLocalActor senderByHash + in AP.makeActivity luId luActor action + bodyBL = A.encode $ AP.Doc hLocal act + bodyO <- + case A.eitherDecode' bodyBL of + Left s -> error $ "Parsing encoded activity failed: " ++ s + Right o -> return o + let body = ActivityBody bodyBL bodyO act + sendToLocalActors (Left author) body True justSender justSender localRecips envelope <- do senderByHash <- hashLocalActor senderByKey prepareSendH senderActorID senderByHash itemID action @@ -210,20 +224,20 @@ prepareForwardIK :: (Route App, ActorKey) -> LocalActorBy KeyHashid -> BL.ByteString - -> ByteString + -> Maybe ByteString -> Act (AP.Errand URIMode) -prepareForwardIK (keyR, akey) fwderByHash body proof = do +prepareForwardIK (keyR, akey) fwderByHash body mproof = do let sign = actorKeySign akey fwderR = renderLocalActor fwderByHash - prepareToForward keyR sign True fwderR body proof + prepareToForward keyR sign True fwderR body mproof prepareForwardAK :: ActorId -> LocalActorBy KeyHashid -> BL.ByteString - -> ByteString + -> Maybe ByteString -> ActDB (AP.Errand URIMode) -prepareForwardAK actorID fwderByHash body proof = do +prepareForwardAK actorID fwderByHash body mproof = do Entity keyID key <- do mk <- getBy $ UniqueSigKey actorID case mk of @@ -233,31 +247,31 @@ prepareForwardAK actorID fwderByHash body proof = do let keyR = stampRoute fwderByHash keyHash sign = actorKeySign $ sigKeyMaterial key fwderR = renderLocalActor fwderByHash - prepareToForward keyR sign False fwderR body proof + prepareToForward keyR sign False fwderR body mproof prepareForwardP :: ActorId -> LocalActorBy KeyHashid -> BL.ByteString - -> ByteString + -> Maybe ByteString -> ActDB (AP.Errand URIMode) -prepareForwardP actorID fwderByHash body proof = do +prepareForwardP actorID fwderByHash body mproof = do maybeKey <- lift askLatestInstanceKey case maybeKey of - Nothing -> prepareForwardAK actorID fwderByHash body proof - Just key -> lift $ prepareForwardIK key fwderByHash body proof + Nothing -> prepareForwardAK actorID fwderByHash body mproof + Just key -> lift $ prepareForwardIK key fwderByHash body mproof prepareForwardH :: ActorId -> LocalActorBy KeyHashid -> BL.ByteString - -> ByteString + -> Maybe ByteString -> Act (AP.Errand URIMode) -prepareForwardH actorID fwderByHash body proof = do +prepareForwardH actorID fwderByHash body mproof = do maybeKey <- askLatestInstanceKey case maybeKey of - Nothing -> withDB $ prepareForwardAK actorID fwderByHash body proof - Just key -> prepareForwardIK key fwderByHash body proof + Nothing -> withDB $ prepareForwardAK actorID fwderByHash body mproof + Just key -> prepareForwardIK key fwderByHash body mproof -- | Given a list of local recipients, which may include actors and -- collections, @@ -269,26 +283,92 @@ prepareForwardH actorID fwderByHash body proof = do -- -- This function reads remote recipient data and the sender's signing key from -- the PostgreSQL database. Don't use it inside a database transaction. +-- +-- For a remote author, no forwarding is done if a signature isn't provided. forwardActivity - :: BL.ByteString - -> RecipientRoutes - -> ByteString - -> ActorId + :: Either (LocalActorBy Key, ActorId, OutboxItemId) (RemoteAuthor, LocalURI, Maybe ByteString) + -> ActivityBody -> LocalActorBy Key + -> ActorId -> RecipientRoutes - -> Event - -> Act () -forwardActivity body localRecips sig fwderActorID fwderByKey sieve event = do - remoteRecips <- - let localRecipsFinal = localRecipSieve' sieve False False localRecips - justSender = Just fwderByKey - in sendToLocalActors event False justSender justSender localRecipsFinal - errand <- do - fwderByHash <- hashLocalActor fwderByKey - prepareForwardH fwderActorID fwderByHash body sig - let remoteRecipsList = - concatMap - (\ ((_, h), rrs) -> NE.toList $ NE.map (ObjURI h . remoteRecipientId) rrs) - remoteRecips - dt <- asksEnv stageDeliveryTheater - liftIO $ sendHttp dt (MethodForwardRemote errand) remoteRecipsList + -> ActE () +forwardActivity sourceMaybeForward body fwderByKey fwderActorID sieve = do + let maybeForward = + case sourceMaybeForward of + Left l -> Just $ Left l + Right (author, luAct, msig) -> + Right . (author,luAct,) <$> msig + for_ maybeForward $ \ source -> do + localRecips <- do + mrecips <- parseAudience' $ AP.activityAudience $ actbActivity body + paudLocalRecips <$> fromMaybeE mrecips "Activity with no recipients" + remoteRecips <- + let localRecipsFinal = localRecipSieve' sieve False False localRecips + justSender = Just fwderByKey + authorAndId = + second (\ (author, luAct, _sig) -> (author, luAct)) source + in lift $ sendToLocalActors authorAndId body False justSender justSender localRecipsFinal + errand <- lift $ do + fwderByHash <- hashLocalActor fwderByKey + let msig = + case source of + Left _ -> Nothing + Right (_, _, b) -> Just b + prepareForwardH fwderActorID fwderByHash (actbBL body) msig + let remoteRecipsList = + concatMap + (\ ((_, h), rrs) -> NE.toList $ NE.map (ObjURI h . remoteRecipientId) rrs) + remoteRecips + dt <- lift $ asksEnv stageDeliveryTheater + lift $ liftIO $ sendHttp dt (MethodForwardRemote errand) remoteRecipsList + +makeAudSenderOnly + :: Either + (LocalActorBy Key, ActorId, OutboxItemId) + (RemoteAuthor, LocalURI, Maybe ByteString) + -> Act (Aud URIMode) +makeAudSenderOnly (Left (actorByKey, _, _)) = do + actorByHash <- hashLocalActor actorByKey + return $ AudLocal [actorByHash] [] +makeAudSenderOnly (Right (author, _, _)) = do + let ObjURI hAuthor luAuthor = remoteAuthorURI author + pure $ AudRemote hAuthor [luAuthor] [] + +makeAudSenderWithFollowers + :: Either + (LocalActorBy Key, ActorId, OutboxItemId) + (RemoteAuthor, LocalURI, Maybe ByteString) + -> ActDB (Aud URIMode) +makeAudSenderWithFollowers (Left (actorByKey, _, _)) = do + actorByHash <- hashLocalActor actorByKey + return $ AudLocal [actorByHash] [localActorFollowers actorByHash] +makeAudSenderWithFollowers (Right (author, _, _)) = do + let ObjURI hAuthor luAuthor = remoteAuthorURI author + ra <- getJust $ remoteAuthorId author + return $ + AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra) + +getActivityURI + :: Either + (LocalActorBy Key, ActorId, OutboxItemId) + (RemoteAuthor, LocalURI, Maybe ByteString) + -> Act FedURI +getActivityURI (Left (actorByKey, _, outboxItemID)) = do + encodeRouteHome <- getEncodeRouteHome + actorByHash <- hashLocalActor actorByKey + outboxItemHash <- encodeKeyHashid outboxItemID + return $ encodeRouteHome $ activityRoute actorByHash outboxItemHash +getActivityURI (Right (author, luAct, _)) = do + let ObjURI hAuthor _ = remoteAuthorURI author + pure $ ObjURI hAuthor luAct + +getActorURI + :: Either + (LocalActorBy Key, ActorId, OutboxItemId) + (RemoteAuthor, LocalURI, Maybe ByteString) + -> Act FedURI +getActorURI (Left (actorByKey, _, _)) = do + encodeRouteHome <- getEncodeRouteHome + actorByHash <- hashLocalActor actorByKey + return $ encodeRouteHome $ renderLocalActor actorByHash +getActorURI (Right (author, _, _)) = pure $ remoteAuthorURI author diff --git a/src/Vervis/Data/Collab.hs b/src/Vervis/Data/Collab.hs index 0c071fb..0209753 100644 --- a/src/Vervis/Data/Collab.hs +++ b/src/Vervis/Data/Collab.hs @@ -120,7 +120,7 @@ parseTopic u = do parseInvite :: StageRoute Env ~ Route App - => Either PersonId FedURI + => Either (LocalActorBy Key) FedURI -> AP.Invite URIMode -> ActE ( Either (GrantResourceBy Key) FedURI @@ -144,7 +144,7 @@ parseInvite sender (AP.Invite instrument object target) = do recipHash "Contains invalid hashid" case recipKey of - GrantRecipPerson p | Left p == sender -> + GrantRecipPerson p | Left (LocalActorPerson p) == sender -> throwE "Invite local sender and recipient are the same Person" _ -> return recipKey ) diff --git a/src/Vervis/Federation/Auth.hs b/src/Vervis/Federation/Auth.hs index 7f09678..be46837 100644 --- a/src/Vervis/Federation/Auth.hs +++ b/src/Vervis/Federation/Auth.hs @@ -404,12 +404,12 @@ verifyForwardedSig hAuthor luAuthor (Verification malgo keyid input signature) = else ActivityAuthRemote <$> verifyActorSig' malgo input signature hKey luKey (Just luAuthor) authenticateActivity - :: UTCTime - -- -> ExceptT Text Handler (Either PersonId ActivityDetail, BL.ByteString, Object, Activity) - -> ExceptT Text Handler (ActivityAuthentication, ActivityBody) + :: UTCTime -> ExceptT Text Handler (ActivityAuthentication, ActivityBody) authenticateActivity now = do (ra, wv, body) <- do verifyContentTypeAP_E + + -- Compute input for HTTP Signature verification proof <- withExceptT (T.pack . displayException) $ ExceptT $ do timeLimit <- getsYesod $ appHttpSigTimeLimit . appSettings let requires = [hRequestTarget, hHost, hDigest] @@ -419,6 +419,7 @@ authenticateActivity now = do toSeconds = toTimeUnit in fromIntegral $ toSeconds timeLimit prepareToVerifyHttpSig requires wants seconds now + (remoteAuthor, body) <- withExceptT T.pack $ (,) <$> verifyActorSig proof @@ -429,21 +430,13 @@ authenticateActivity now = do Right wv -> return wv return (remoteAuthor, wvdoc, body) let WithValue raw (Doc hActivity activity) = wv - uSender = remoteAuthorURI ra - ObjURI hSender luSender = uSender + uSender@(ObjURI hSender luSender) = remoteAuthorURI ra + luAuthor = activityActor activity auth <- - if hSender == hActivity - then do - unless (activityActor activity == luSender) $ - throwE $ T.concat - [ "Activity's actor <" - , renderObjURI $ - ObjURI hActivity $ activityActor activity - , "> != Signature key's actor <", renderObjURI uSender - , ">" - ] - return $ ActivityAuthRemote ra - else do + case (hSender == hActivity, luSender == luAuthor) of + (False, _) -> do + -- Sender and author are on different hosts, therefore require + -- a valid forwarded signature that approves the forwarding ma <- checkForward uSender hActivity (activityActor activity) case ma of Nothing -> throwE $ T.concat @@ -452,6 +445,28 @@ authenticateActivity now = do , renderAuthority hSender, ">" ] Just a -> return a + (True, False) -> do + -- Sender and author are different actors on the same host, + -- therefore we approve the forwarding without a signature + hl <- hostIsLocalOld hActivity + if hl + then ActivityAuthLocal <$> do + route <- parseLocalURI luAuthor + parseLocalActorE route + else ActivityAuthRemote <$> do + let uAuthor = ObjURI hActivity luAuthor + instanceID = remoteAuthorInstance ra + remoteActorID <- do + result <- ExceptT $ first (T.pack . displayException) <$> fetchRemoteActor instanceID hActivity luAuthor + case result of + Left Nothing -> throwE "Author @id mismatch" + Left (Just err) -> throwE $ T.pack $ displayException err + Right Nothing -> throwE "Author isn't an actor" + Right (Just actor) -> return $ entityKey actor + return $ RemoteAuthor uAuthor instanceID remoteActorID + (True, True) -> + -- Sender and author are the same actor + pure $ ActivityAuthRemote ra -- Verify FEP-8b32 jcs-eddsa-2022 VC data integrity proof for_ (AP.activityProof activity) $ \ proof -> do diff --git a/src/Vervis/Federation/Discussion.hs b/src/Vervis/Federation/Discussion.hs index ce31868..bc4551c 100644 --- a/src/Vervis/Federation/Discussion.hs +++ b/src/Vervis/Federation/Discussion.hs @@ -176,7 +176,8 @@ personCreateNoteF -> AP.Note URIMode -> ExceptT Text Handler Text personCreateNoteF now recipPersonHash author body mfwd luCreate note = do - + error "personCreateNoteF disabled for refactoring" +{- -- Check input recipPersonID <- decodeKeyHashid404 recipPersonHash (luNote, published, Comment maybeParent topic source content) <- do @@ -240,6 +241,7 @@ personCreateNoteF now recipPersonHash author body mfwd luCreate note = do did <- fromMaybeE mdid "Remote parent known, but no context RemoteDiscussion" unless (messageRoot m == did) $ throwE "Remote parent belongs to a different discussion" +-} deckCreateNoteF :: UTCTime @@ -251,7 +253,8 @@ deckCreateNoteF -> AP.Note URIMode -> ExceptT Text Handler Text deckCreateNoteF now recipDeckHash author body mfwd luCreate note = do - + error "deckCreateNoteF disabled for refactoring" +{- recipDeckID <- decodeKeyHashid404 recipDeckHash (luNote, published, Comment maybeParent topic source content) <- do (luId, luAuthor, published, comment) <- parseRemoteCommentOld note @@ -309,6 +312,7 @@ deckCreateNoteF now recipDeckHash author body mfwd luCreate note = do Right forwardHttp -> do forkWorker "projectCreateNoteF inbox-forwarding" forwardHttp return "Stored to inbox, cached comment, and did inbox forwarding" +-} loomCreateNoteF :: UTCTime @@ -320,7 +324,8 @@ loomCreateNoteF -> AP.Note URIMode -> ExceptT Text Handler Text loomCreateNoteF now recipLoomHash author body mfwd luCreate note = do - + error "loomCreateNoteF disabled for refactoring" +{- recipLoomID <- decodeKeyHashid404 recipLoomHash (luNote, published, Comment maybeParent topic source content) <- do (luId, luAuthor, published, comment) <- parseRemoteCommentOld note @@ -378,3 +383,4 @@ loomCreateNoteF now recipLoomHash author body mfwd luCreate note = do Right forwardHttp -> do forkWorker "projectCreateNoteF inbox-forwarding" forwardHttp return "Stored to inbox, cached comment, and did inbox forwarding" +-} diff --git a/src/Vervis/Federation/Offer.hs b/src/Vervis/Federation/Offer.hs index db07f51..1ed7838 100644 --- a/src/Vervis/Federation/Offer.hs +++ b/src/Vervis/Federation/Offer.hs @@ -500,7 +500,8 @@ loomUndoF -> AP.Undo URIMode -> ExceptT Text Handler Text loomUndoF now recipLoomHash author body mfwd luUndo (AP.Undo uObject) = do - + error "loomUndoF disabled for refactoring" +{- -- Check input recipLoomID <- decodeKeyHashid404 recipLoomHash undone <- @@ -700,6 +701,7 @@ loomUndoF now recipLoomHash author body mfwd luUndo (AP.Undo uObject) = do } return (action, recipientSet, remoteActors, fwdHosts) +-} repoUndoF :: UTCTime @@ -711,7 +713,8 @@ repoUndoF -> AP.Undo URIMode -> ExceptT Text Handler Text repoUndoF now recipRepoHash author body mfwd luUndo (AP.Undo uObject) = do - + error "repoUndoF disabled for refactoring" +{- -- Check input recipRepoID <- decodeKeyHashid404 recipRepoHash undone <- @@ -839,3 +842,4 @@ repoUndoF now recipRepoHash author body mfwd luUndo (AP.Undo uObject) = do } return (action, recipientSet, remoteActors, fwdHosts) +-} diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index 59a1c5b..b174baf 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/src/Vervis/Federation/Ticket.hs @@ -335,7 +335,8 @@ deckOfferTicketF -> FedURI -> ExceptT Text Handler Text deckOfferTicketF now recipDeckHash author body mfwd luOffer ticket uTarget = do - + error "deckOfferTicketF disabled for refactoring" +{- -- Check input recipDeckID <- decodeKeyHashid404 recipDeckHash (title, desc, source) <- do @@ -474,6 +475,7 @@ deckOfferTicketF now recipDeckHash author body mfwd luOffer ticket uTarget = do } return (action, recipientSet, remoteActors, fwdHosts) +-} activityAlreadyInInbox hAct luAct inboxID = fmap isJust . runMaybeT $ do instanceID <- MaybeT $ getKeyBy $ UniqueInstance hAct @@ -492,7 +494,8 @@ loomOfferTicketF -> FedURI -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) loomOfferTicketF now recipLoomHash author body mfwd luOffer ticket uTarget = do - + error "loomOfferTicketF disabled for refactoring" +{- -- Check input recipLoomID <- decodeKeyHashid404 recipLoomHash (title, desc, source, originTipOrBundle, targetRepoID, maybeTargetBranch) <- do @@ -808,6 +811,7 @@ loomOfferTicketF now recipLoomHash author body mfwd luOffer ticket uTarget = do } return (action, recipientSet, remoteActors, fwdHosts) +-} repoOfferTicketF :: UTCTime @@ -1130,7 +1134,8 @@ loomApplyF -> AP.Apply URIMode -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) loomApplyF now recipLoomHash author body mfwd luApply apply = (,Nothing) <$> do - + error "loomApplyF disabled for refactoring" +{- -- Check input recipLoomID <- decodeKeyHashid404 recipLoomHash (repoID, maybeBranch, clothID, bundleID) <- do @@ -1295,6 +1300,7 @@ loomApplyF now recipLoomHash author body mfwd luApply apply = (,Nothing) <$> do } return (action, recipientSet, remoteActors, fwdHosts) +-} personOfferDepF :: UTCTime @@ -1899,7 +1905,8 @@ trackerResolveF -> AP.Resolve URIMode -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) trackerResolveF maybeWorkItem grabActor getWorkItem makeResource trackerFollowers itemFollowers makeLocalActor now recipHash author body mfwd luResolve (AP.Resolve uObject) = (,Nothing) <$> do - + error "trackerResolveF disabled for refactoring" +{- -- Check input recipID <- decodeKeyHashid404 recipHash wiID <- nameExceptT "Resolve object" $ do @@ -2053,6 +2060,7 @@ trackerResolveF maybeWorkItem grabActor getWorkItem makeResource trackerFollower } return (action, recipientSet, remoteActors, fwdHosts) +-} deckResolveF :: UTCTime diff --git a/src/Vervis/Federation/Util.hs b/src/Vervis/Federation/Util.hs index 4871f2f..f18cae5 100644 --- a/src/Vervis/Federation/Util.hs +++ b/src/Vervis/Federation/Util.hs @@ -15,12 +15,12 @@ module Vervis.Federation.Util ( insertToInbox - , insertToInbox' ) where import Control.Monad.IO.Class import Control.Monad.Trans.Reader +import Data.ByteString (ByteString) import Data.Either import Data.Time.Clock import Database.Persist @@ -36,30 +36,32 @@ import Vervis.Federation.Auth import Vervis.Foundation import Vervis.Model --- | Insert a remote activity delivered to us into our inbox. Return its +-- | Insert an activity delivered to us into our inbox. Return its -- database ID if the activity wasn't already in our inbox. insertToInbox - :: MonadIO m - => UTCTime - -> RemoteAuthor + :: UTCTime + -> Either + (LocalActorBy Key, ActorId, OutboxItemId) + (RemoteAuthor, LocalURI, Maybe ByteString) -> ActivityBody -> InboxId - -> LocalURI -> Bool - -> ReaderT SqlBackend m (Maybe RemoteActivityId) -insertToInbox now author body ibid luAct unread = - fmap fst <$> insertToInbox' now author body ibid luAct unread - -insertToInbox' - :: MonadIO m - => UTCTime - -> RemoteAuthor - -> ActivityBody - -> InboxId - -> LocalURI - -> Bool - -> ReaderT SqlBackend m (Maybe (RemoteActivityId, InboxItemId)) -insertToInbox' now author body ibid luAct unread = do + -> ActDB + (Maybe + (Either + (LocalActorBy Key, ActorId, OutboxItemId) + (RemoteAuthor, LocalURI, RemoteActivityId) + ) + ) +insertToInbox now (Left a@(_, _, outboxItemID)) body inboxID unread = do + inboxItemID <- insert $ InboxItem unread now + maybeItem <- insertUnique $ InboxItemLocal inboxID outboxItemID inboxItemID + case maybeItem of + Nothing -> do + delete inboxItemID + return Nothing + Just _ -> return $ Just $ Left a +insertToInbox now (Right (author, luAct, _)) body inboxID unread = do let iidAuthor = remoteAuthorInstance author roid <- either entityKey id <$> insertBy' (RemoteObject iidAuthor luAct) @@ -69,9 +71,9 @@ insertToInbox' now author body ibid luAct unread = do , remoteActivityReceived = now } ibiid <- insert $ InboxItem unread now - mibrid <- insertUnique $ InboxItemRemote ibid ractid ibiid + mibrid <- insertUnique $ InboxItemRemote inboxID ractid ibiid case mibrid of Nothing -> do delete ibiid return Nothing - Just _ -> return $ Just (ractid, ibiid) + Just _ -> return $ Just $ Right (author, luAct, ractid) diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 156624c..e54b266 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -2936,6 +2936,8 @@ changes hLocal ctx = , removeField "Ticket" "status" -- 530 , addEntities model_530_join + -- 531 + , addEntities model_531_follow_request ] migrateDB diff --git a/src/Vervis/Migration/Entities.hs b/src/Vervis/Migration/Entities.hs index fdd78e0..7be9247 100644 --- a/src/Vervis/Migration/Entities.hs +++ b/src/Vervis/Migration/Entities.hs @@ -1,6 +1,7 @@ {- This file is part of Vervis. - - - Written in 2018, 2019, 2020, 2022 by fr33domlover . + - Written in 2018, 2019, 2020, 2022, 2023 + - by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -60,6 +61,7 @@ module Vervis.Migration.Entities , model_497_sigkey , model_508_invite , model_530_join + , model_531_follow_request ) where @@ -235,3 +237,6 @@ model_508_invite = $(schema "508_2022-10-19_invite") model_530_join :: [Entity SqlBackend] model_530_join = $(schema "530_2022-11-01_join") + +model_531_follow_request :: [Entity SqlBackend] +model_531_follow_request = $(schema "531_2023-06-15_follow_request") diff --git a/src/Vervis/Recipient.hs b/src/Vervis/Recipient.hs index 0d3b58e..0610403 100644 --- a/src/Vervis/Recipient.hs +++ b/src/Vervis/Recipient.hs @@ -85,6 +85,7 @@ module Vervis.Recipient , ParsedAudience (..) , concatRecipients , parseAudience + , parseAudience' -- * Creating a recipient set, supporting both local and remote recips , Aud (..) @@ -93,6 +94,7 @@ module Vervis.Recipient where import Control.Applicative +import Control.Concurrent.Actor import Control.Monad import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe @@ -108,6 +110,7 @@ import Data.Semigroup import Data.Text (Text) import Data.These import Data.Traversable +import Data.Typeable import Database.Persist import Database.Persist.Sql import GHC.Generics @@ -127,6 +130,7 @@ import Yesod.Hashids import Yesod.MonadSite import qualified Web.ActivityPub as AP +import qualified Web.Actor as WA import Data.List.Local import Data.List.NonEmpty.Local @@ -143,6 +147,15 @@ import Vervis.FedURI import Vervis.Foundation import Vervis.Model +instance WA.StageWebRoute Env where + type StageRoute Env = Route App + askUrlRenderParams = do + Env _ _ _ _ _ render _ _ <- askEnv + case cast render of + Nothing -> error "Env site isn't App" + Just r -> pure r + pageParamName _ = "page" + ------------------------------------------------------------------------------- -- Actor and collection-of-actors types -- @@ -785,6 +798,48 @@ parseRecipients recips = do Nothing -> Left route Just recip -> Right recip +parseRecipients' + :: WA.StageRoute Env ~ Route App + => NonEmpty FedURI -> ActE (RecipientRoutes, [FedURI]) +parseRecipients' recips = do + hLocal <- asksEnv WA.stageInstanceHost + let (locals, remotes) = splitRecipients hLocal recips + (lusInvalid, routesInvalid, localsSet) = parseLocalRecipients locals + unless (null lusInvalid) $ + throwE $ + "Local recipients are invalid routes: " <> + T.pack (show $ map (renderObjURI . ObjURI hLocal) lusInvalid) + unless (null routesInvalid) $ do + renderUrl <- WA.askUrlRender + throwE $ + "Local recipients are non-recipient routes: " <> + T.pack (show $ map renderUrl routesInvalid) + return (localsSet, remotes) + where + splitRecipients :: Host -> NonEmpty FedURI -> ([LocalURI], [FedURI]) + splitRecipients home recips = + let (local, remote) = NE.partition ((== home) . objUriAuthority) recips + in (map objUriLocal local, remote) + + parseLocalRecipients + :: [LocalURI] -> ([LocalURI], [Route App], RecipientRoutes) + parseLocalRecipients lus = + let (lusInvalid, routes) = partitionEithers $ map parseRoute lus + (routesInvalid, recips) = partitionEithers $ map parseRecip routes + (actors, stages) = partitionEithers recips + grouped = + map recipientFromActor actors ++ map recipientFromStage stages + in (lusInvalid, routesInvalid, groupLocalRecipients grouped) + where + parseRoute lu = + case decodeRouteLocal lu of + Nothing -> Left lu + Just route -> Right route + parseRecip route = + case parseLocalRecipient route of + Nothing -> Left route + Just recip -> Right recip + parseAudience :: (MonadSite m, SiteEnv m ~ App) => AP.Audience URIMode @@ -811,6 +866,31 @@ parseAudience audience = do groupByHost :: [FedURI] -> [(Host, NonEmpty LocalURI)] groupByHost = groupAllExtract objUriAuthority objUriLocal +parseAudience' + :: WA.StageRoute Env ~ Route App + => AP.Audience URIMode -> ActE (Maybe (ParsedAudience URIMode)) +parseAudience' audience = do + let recips = concatRecipients audience + for (nonEmpty recips) $ \ recipsNE -> do + (localsSet, remotes) <- parseRecipients' recipsNE + let remotesGrouped = + groupByHost $ remotes \\ AP.audienceNonActors audience + hosts = map fst remotesGrouped + return ParsedAudience + { paudLocalRecips = localsSet + , paudRemoteActors = remotesGrouped + , paudBlinded = + audience { AP.audienceBto = [], AP.audienceBcc = [] } + , paudFwdHosts = + let nonActorHosts = + LO.nubSort $ + map objUriAuthority $ AP.audienceNonActors audience + in LO.isect hosts nonActorHosts + } + where + groupByHost :: [FedURI] -> [(Host, NonEmpty LocalURI)] + groupByHost = groupAllExtract objUriAuthority objUriLocal + data Aud u = AudLocal [LocalActor] [LocalStage] | AudRemote (Authority u) [LocalURI] [LocalURI] diff --git a/src/Vervis/Web/Actor.hs b/src/Vervis/Web/Actor.hs index 531f2ab..4de1d6c 100644 --- a/src/Vervis/Web/Actor.hs +++ b/src/Vervis/Web/Actor.hs @@ -95,7 +95,7 @@ import Yesod.Persist.Local import qualified Data.Aeson.Encode.Pretty.ToEncoding as P import qualified Web.ActivityPub as AP -import Vervis.Actor (RemoteAuthor (..), ActivityBody (..), VerseRemote (..), Event (..)) +import Vervis.Actor (RemoteAuthor (..), ActivityBody (..), Verse (..)) import Vervis.ActivityPub import Vervis.API import Vervis.Data.Actor @@ -106,6 +106,7 @@ import Vervis.Foundation import Vervis.Model hiding (Ticket) import Vervis.Model.Ident import Vervis.Paginate +import Vervis.Persist.Actor import Vervis.Recipient import Vervis.Settings import Vervis.Ticket @@ -236,26 +237,27 @@ postInbox recipByKey = do now <- liftIO getCurrentTime result <- runExceptT $ do (auth, body) <- authenticateActivity now - verse <- + authorIdMsig <- case auth of ActivityAuthLocal authorByKey -> Left <$> do outboxItemID <- parseAuthenticatedLocalActivityURI authorByKey (AP.activityId $ actbActivity body) - return $ EventRemoteFwdLocalActivity authorByKey outboxItemID + actorID <- do + ment <- lift $ runDB $ getLocalActorEntity authorByKey + case ment of + Nothing -> throwE "Author not found in DB" + Just ent -> return $ localActorID ent + return (authorByKey, actorID, outboxItemID) ActivityAuthRemote author -> Right <$> do luActivity <- fromMaybeE (AP.activityId $ actbActivity body) "Activity without 'id'" - localRecips <- do - mrecips <- parseAudience $ AP.activityAudience $ actbActivity body - paudLocalRecips <$> fromMaybeE mrecips "Activity with no recipients" recipByHash <- hashLocalActor recipByKey msig <- checkForwarding recipByHash - let mfwd = (localRecips,) <$> msig - return $ VerseRemote author body mfwd luActivity + return (author, luActivity, msig) theater <- getsYesod appTheater - r <- liftIO $ callIO theater recipByKey verse + r <- liftIO $ callIO theater recipByKey $ Verse authorIdMsig body case r of Nothing -> notFound Just (Left e) -> throwE e diff --git a/src/Vervis/Web/Delivery.hs b/src/Vervis/Web/Delivery.hs index 8eaef88..38f363a 100644 --- a/src/Vervis/Web/Delivery.hs +++ b/src/Vervis/Web/Delivery.hs @@ -83,7 +83,7 @@ import Data.Maybe.Local import Data.Tuple.Local import Database.Persist.Local -import Vervis.Actor (Event) +--import Vervis.Actor import Vervis.ActivityPub import Vervis.Data.Actor import Vervis.FedURI diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 47f5634..080b61f 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -106,6 +106,7 @@ module Web.ActivityPub , hForwardedSignature , Envelope () , Errand () + , encodeForwardingSigHeader , sending , retrying , deliver @@ -2223,7 +2224,7 @@ httpPostAP manager headers keyid sign uSender value = data ForwardMode u = SendNoForward | SendAllowForward LocalURI - | ForwardBy (ObjURI u) ByteString + | ForwardBy (ObjURI u) (Maybe ByteString) data Envelope u = Envelope { envelopeKey :: RefURI u @@ -2238,9 +2239,30 @@ data Errand u = Errand , errandHolder :: Bool , errandFwder :: LocalURI , errandBody :: BL.ByteString - , errandProof :: ByteString + , errandProof :: Maybe ByteString } +-- | Produce a 'hForwardingSignature' header value for use when forwarding a +-- local activity, i.e. an activity of another local actor. +encodeForwardingSigHeader + :: UriMode u + => UTCTime + -> RefURI u + -> (ByteString -> S.Signature) + -> BL.ByteString + -> ObjURI u + -> Either S.HttpSigGenError ByteString +encodeForwardingSigHeader now ruKey sign body uRecipActor = + let digest = formatHttpBodyDigest SHA256 "SHA-256" $ hashlazy body + fwder = encodeUtf8 $ renderObjURI uRecipActor + req = + consHeader hActivityPubForwarder fwder $ + consHeader hDigest digest defaultRequest + keyid = S.KeyId $ TE.encodeUtf8 $ renderRefURI ruKey + in signRequestBytes (hDigest :| [hActivityPubForwarder]) Nothing keyid sign now req + where + consHeader n b r = r { requestHeaders = (n, b) : requestHeaders r } + -- | Like 'httpPostAP', except it takes the object as a raw lazy -- 'BL.ByteString'. It's your responsibility to make sure it's valid JSON. httpPostAPBytes @@ -2276,9 +2298,9 @@ httpPostAPBytes manager headers ruKey@(RefURI hKey _) sign mluHolder body fwd uI except $ first APPostErrorSig $ signRequestInto hForwardingSignature (hDigest :| [hActivityPubForwarder]) Nothing keyid sign now $ consHeader hActivityPubForwarder (encodeUtf8 $ renderObjURI $ ObjURI hInbox luRecip) req'' - ForwardBy uSender sig -> + ForwardBy uSender msig -> return $ - consHeader hForwardedSignature sig $ + maybe id (consHeader hForwardedSignature) msig $ consHeader hActivityPubForwarder (encodeUtf8 $ renderObjURI uSender) req'' tryExceptT APPostErrorHTTP $ httpNoBody req''' manager @@ -2331,16 +2353,16 @@ forwarding -> Bool -> ObjURI u -> BL.ByteString - -> ByteString + -> Maybe ByteString -> Errand u -forwarding lruKey sign holder (ObjURI hFwder luFwder) body sig = +forwarding lruKey sign holder (ObjURI hFwder luFwder) body msig = Errand { errandKey = RefURI hFwder lruKey , errandSign = sign , errandHolder = holder , errandFwder = luFwder , errandBody = body - , errandProof = sig + , errandProof = msig } deliver @@ -2369,7 +2391,7 @@ forward -> Errand u -> ObjURI u -> m (Either APPostError (Response ())) -forward manager headers (Errand ruKey@(RefURI hKey _) sign holder luFwder body sig) uInbox = +forward manager headers (Errand ruKey@(RefURI hKey _) sign holder luFwder body msig) uInbox = httpPostAPBytes manager headers @@ -2377,7 +2399,7 @@ forward manager headers (Errand ruKey@(RefURI hKey _) sign holder luFwder body s sign (guard holder >> Just luFwder) body - (ForwardBy (ObjURI hKey luFwder) sig) + (ForwardBy (ObjURI hKey luFwder) msig) uInbox -- | Result of GETing the keyId URI and processing the JSON document. diff --git a/src/Web/Actor.hs b/src/Web/Actor.hs index ad020ed..7ef3afd 100644 --- a/src/Web/Actor.hs +++ b/src/Web/Actor.hs @@ -193,11 +193,11 @@ prepareToForward -> Bool -> StageRoute s -> BL.ByteString - -> ByteString + -> Maybe ByteString -> m (AP.Errand u) -prepareToForward keyR sign holder fwderR body sig = do +prepareToForward keyR sign holder fwderR body msig = do encodeRouteLocal <- getEncodeRouteLocal encodeRouteHome <- getEncodeRouteHome let lruKey = LocalRefURI $ Left $ encodeRouteLocal keyR uFwder = encodeRouteHome fwderR - return $ AP.forwarding lruKey sign holder uFwder body sig + return $ AP.forwarding lruKey sign holder uFwder body msig diff --git a/src/Yesod/ActivityPub.hs b/src/Yesod/ActivityPub.hs index 5ec6179..ecda9b7 100644 --- a/src/Yesod/ActivityPub.hs +++ b/src/Yesod/ActivityPub.hs @@ -163,6 +163,7 @@ deliverActivityThrow envelope mluFwd uInbox = do Left e -> liftIO $ throwIO e Right response -> return response +{- prepareToForward :: (MonadSite m, SiteEnv m ~ site, SiteFedURI site, SiteFedURIMode site ~ u) => Route site @@ -178,6 +179,7 @@ prepareToForward keyR sign holder fwderR body sig = do let lruKey = LocalRefURI $ Left $ encodeRouteLocal keyR uFwder = encodeRouteHome fwderR return $ AP.forwarding lruKey sign holder uFwder body sig +-} forwardActivity :: ( MonadSite m, SiteEnv m ~ site diff --git a/th/models b/th/models index a1e5e80..980e5e0 100644 --- a/th/models +++ b/th/models @@ -228,11 +228,14 @@ FollowRemote UniqueFollowRemoteFollow follow UniqueFollowRemoteAccept accept ---FollowRequest --- person PersonId --- target FollowerSetId --- --- UniqueFollowRequest person target +FollowRequest + actor ActorId + target FollowerSetId + public Bool + follow OutboxItemId + + UniqueFollowRequest actor target + UniqueFollowRequestFollow follow Follow actor ActorId