From d741d0e9189b6b3460f733e73384988731f9ea02 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Sun, 28 Aug 2022 13:51:43 +0000 Subject: [PATCH] C2S: grantC: Insert Collab records for Grants with remote topics too --- src/Vervis/API.hs | 319 ++++++++++++++++++++++++++--------------- src/Vervis/Access.hs | 64 +++++++++ src/Web/ActivityPub.hs | 21 +++ th/models | 3 - 4 files changed, 285 insertions(+), 122 deletions(-) diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 987a63b..a10ea6b 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -45,6 +45,7 @@ import Crypto.Hash import Data.Aeson import Data.Barbie import Data.Bifunctor +import Data.Bifoldable import Data.Bitraversable import Data.ByteString (ByteString) import Data.Either @@ -1472,6 +1473,13 @@ followC (Entity pidSender personSender) summary audience follow@(AP.Follow uObje data GrantRecipBy f = GrantRecipPerson (f Person) deriving (Generic, FunctorB, TraversableB, ConstraintsB) +data Result + = ResultSomeException SomeException + | ResultIdMismatch + | ResultGetError APGetError + | ResultNotActor + deriving Show + grantC :: Entity Person -> Actor @@ -1483,14 +1491,12 @@ grantC grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do -- Check input - (resourceK, recipientK) <- parseGrant grant - let input = adaptGrant resourceK recipientK + (resource, recipient) <- parseGrant grant ParsedAudience localRecips remoteRecips blinded fwdHosts <- do mrecips <- parseAudience audience - recips <- fromMaybeE mrecips "Create TicketTracker with no recipients" + recips <- fromMaybeE mrecips "Grant with no recipients" checkFederation $ paudRemoteActors recips return recips - verifyRecipients input localRecips remoteRecips -- Verify the capability URI is one of: -- * Outbox item URI of a local actor, i.e. a local activity @@ -1498,44 +1504,70 @@ grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do uCap <- fromMaybeE muCap "No capability provided" capID <- parseActivityURI "Grant capability" uCap + -- 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. + resourceDB <- + bitraverse + (runDBExcept . flip getGrantResource "Grant context not found in DB") + (\ u@(ObjURI h lu) -> do + instanceID <- + lift $ runDB $ either entityKey id <$> insertBy' (Instance h) + result <- + ExceptT $ first (T.pack . show) <$> + fetchRemoteResource instanceID h lu + case result of + Left (Entity actorID actor) -> + return (remoteActorIdent actor, actorID, u) + Right (objectID, luManager, (Entity actorID _)) -> + return (objectID, actorID, ObjURI h luManager) + ) + resource + -- If recipient is remote, HTTP GET it, make sure it's an actor, and insert - -- it to our DB - inputHttp <- for input $ \ (resource, recipient) -> - fmap (resource,) $ bifor recipient pure $ \ (ObjURI h lu) -> do - instanceID <- - lift $ runDB $ either entityKey id <$> insertBy' (Instance h) - result <- - ExceptT $ first (T.pack . displayException) <$> - fetchRemoteActor instanceID h lu - case result of - Left Nothing -> throwE "Recipient @id mismatch" - Left (Just err) -> throwE $ T.pack $ displayException err - Right Nothing -> throwE "Recipient isn't an actor" - Right (Just actor) -> return $ entityKey actor + -- it to our DB. If recipient is local, find it in our DB. + recipientDB <- + bitraverse + (runDBExcept . flip getGrantRecip "Grant recipient not found in DB") + (\ u@(ObjURI h lu) -> do + instanceID <- + lift $ runDB $ either entityKey id <$> insertBy' (Instance h) + result <- + ExceptT $ first (T.pack . displayException) <$> + fetchRemoteActor instanceID h lu + case result of + Left Nothing -> throwE "Recipient @id mismatch" + Left (Just err) -> throwE $ T.pack $ displayException err + Right Nothing -> throwE "Recipient isn't an actor" + Right (Just actor) -> return (entityKey actor, u) + ) + recipient + + -- Verify that resource and recipient are addressed by the Grant + bitraverse_ + (verifyResourceAddressed localRecips . bmap entityKey) + (\ (_, _, u) -> verifyRemoteAddressed remoteRecips u) + resourceDB + bitraverse_ + (verifyRecipientAddressed localRecips . bmap entityKey) + (verifyRemoteAddressed remoteRecips . snd) + recipientDB now <- liftIO getCurrentTime senderHash <- encodeKeyHashid pidUser (obiidGrant, deliverHttpGrant) <- runDBExcept $ do - -- Find resource (if local) and recipient (if local) in DB - inputDB <- - for inputHttp $ bitraverse - (flip getGrantResource "Grant context not found in DB") - (bitraverse - (flip getGrantRecip "Grant recipient not found in DB") - pure - ) - - -- If resource is loca, verify the specified capability gives relevant - -- access - for_ inputDB $ \ (resource, _) -> - verifyCapability capID pidUser (bmap entityKey resource) + -- If resource is local, verify the specified capability gives relevant + -- access. If resource is remote, check the specified capability as + -- much as we can, letting the remote resource say the final word. + bitraverse_ + (verifyCapability capID pidUser . bmap entityKey) + (verifyCapabilityRemote capID pidUser . (\ (o, _, _) -> o)) + resourceDB -- Insert new Collab to DB grantID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now - for_ inputDB $ \ (resource, recipient) -> - lift $ insertCollab resource recipient grantID + lift $ insertCollab resourceDB recipientDB grantID -- Insert the Grant activity to author's outbox docGrant <- lift $ insertGrantToOutbox senderHash now uCap blinded grantID @@ -1543,48 +1575,52 @@ grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do -- Deliver the Grant activity to local recipients, and schedule -- delivery for unavailable remote recipients remoteRecipsHttpGrant <- do - resourceH <- bitraverse hashGrantResource pure resourceK - recipientH <- bitraverse hashGrantRecip pure recipientK - let actors = catMaybes - [ case resourceH of + resourceHash <- bitraverse hashGrantResource pure resource + recipientHash <- bitraverse hashGrantRecip pure recipient + let sieveActors = catMaybes + [ case resourceHash of Left (GrantResourceRepo r) -> Just $ LocalActorRepo r Left (GrantResourceDeck d) -> Just $ LocalActorDeck d Left (GrantResourceLoom l) -> Just $ LocalActorLoom l Right _ -> Nothing - , case recipientH of + , case recipientHash of Left (GrantRecipPerson p) -> Just $ LocalActorPerson p Right _ -> Nothing ] - stages = catMaybes + sieveStages = catMaybes [ Just $ LocalStagePersonFollowers senderHash - , case resourceH of + , case resourceHash of Left (GrantResourceRepo r) -> Just $ LocalStageRepoFollowers r Left (GrantResourceDeck d) -> Just $ LocalStageDeckFollowers d Left (GrantResourceLoom l) -> Just $ LocalStageLoomFollowers l Right _ -> Nothing - , case recipientH of + , case recipientHash of Left (GrantRecipPerson p) -> Just $ LocalStagePersonFollowers p Right _ -> Nothing ] - sieve = makeRecipientSet actors stages + sieve = makeRecipientSet sieveActors sieveStages moreRemoteRecips <- lift $ deliverLocal' True (LocalActorPerson senderHash) (personActor personUser) grantID $ localRecipSieve sieve False localRecips checkFederation moreRemoteRecips lift $ deliverRemoteDB'' fwdHosts grantID remoteRecips moreRemoteRecips - -- For local resource/recipient, verify they've received the Grant - for_ inputDB $ \ (resource, recipient) -> do - let resourceActorID = - case resource of - GrantResourceRepo (Entity _ r) -> repoActor r - GrantResourceDeck (Entity _ d) -> deckActor d - GrantResourceLoom (Entity _ l) -> loomActor l - verifyActorHasItem resourceActorID grantID "Local topic didn't receive the Grant" - case recipient of - Left (GrantRecipPerson (Entity _ p)) -> - verifyActorHasItem (personActor p) grantID "Local recipient didn't receive the Grant" - Right _ -> return () + -- If resource is local, verify it has received the Grant + case resourceDB of + Left localResource -> do + let resourceActorID = + case localResource of + GrantResourceRepo (Entity _ r) -> repoActor r + GrantResourceDeck (Entity _ d) -> deckActor d + GrantResourceLoom (Entity _ l) -> loomActor l + verifyActorHasItem resourceActorID grantID "Local topic didn't receive the Grant" + Right _ -> pure () + + -- If recipient is local, verify it has received the grant + case recipientDB of + Left (GrantRecipPerson (Entity _ p)) -> + verifyActorHasItem (personActor p) grantID "Local recipient didn't receive the Grant" + Right _ -> pure () -- Return instructions for HTTP delivery to remote recipients return @@ -1600,6 +1636,42 @@ grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do where + parseGrantResource (RepoR r) = Just $ GrantResourceRepo r + parseGrantResource (DeckR d) = Just $ GrantResourceDeck d + parseGrantResource (LoomR l) = Just $ GrantResourceLoom l + parseGrantResource _ = Nothing + + unhashGrantResourcePure ctx = f + where + f (GrantResourceRepo r) = + GrantResourceRepo <$> decodeKeyHashidPure ctx r + f (GrantResourceDeck d) = + GrantResourceDeck <$> decodeKeyHashidPure ctx d + f (GrantResourceLoom l) = + GrantResourceLoom <$> decodeKeyHashidPure ctx l + + unhashGrantResource resource = do + ctx <- asksSite siteHashidsContext + return $ unhashGrantResourcePure ctx resource + + unhashGrantResourceE resource e = + ExceptT $ maybe (Left e) Right <$> unhashGrantResource resource + + parseGrantRecip (PersonR p) = Just $ GrantRecipPerson p + parseGrantRecip _ = Nothing + + unhashGrantRecipPure ctx = f + where + f (GrantRecipPerson p) = + GrantRecipPerson <$> decodeKeyHashidPure ctx p + + unhashGrantRecip resource = do + ctx <- asksSite siteHashidsContext + return $ unhashGrantRecipPure ctx resource + + unhashGrantRecipE resource e = + ExceptT $ maybe (Left e) Right <$> unhashGrantRecip resource + parseGrant :: Grant URIMode -> ExceptT Text Handler @@ -1630,24 +1702,6 @@ grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do resourceHash "Grant resource contains invalid hashid" else pure $ Right u - where - parseGrantResource (RepoR r) = Just $ GrantResourceRepo r - parseGrantResource (DeckR d) = Just $ GrantResourceDeck d - parseGrantResource (LoomR l) = Just $ GrantResourceLoom l - parseGrantResource _ = Nothing - unhashGrantResourcePure ctx = f - where - f (GrantResourceRepo r) = - GrantResourceRepo <$> decodeKeyHashidPure ctx r - f (GrantResourceDeck d) = - GrantResourceDeck <$> decodeKeyHashidPure ctx d - f (GrantResourceLoom l) = - GrantResourceLoom <$> decodeKeyHashidPure ctx l - unhashGrantResource resource = do - ctx <- asksSite siteHashidsContext - return $ unhashGrantResourcePure ctx resource - unhashGrantResourceE resource e = - ExceptT $ maybe (Left e) Right <$> unhashGrantResource resource parseTarget u@(ObjURI h lu) = do hl <- hostIsLocal h if hl @@ -1669,48 +1723,42 @@ grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do throwE "Grant sender and recipient are the same Person" _ -> return recipKey else pure $ Right u - where - parseGrantRecip (PersonR p) = Just $ GrantRecipPerson p - parseGrantRecip _ = Nothing - unhashGrantRecipPure ctx = f - where - f (GrantRecipPerson p) = - GrantRecipPerson <$> decodeKeyHashidPure ctx p - unhashGrantRecip resource = do - ctx <- asksSite siteHashidsContext - return $ unhashGrantRecipPure ctx resource - unhashGrantRecipE resource e = - ExceptT $ maybe (Left e) Right <$> unhashGrantRecip resource - adaptGrant - :: Either (GrantResourceBy Key) FedURI - -> Either (GrantRecipBy Key) FedURI - -> Maybe (GrantResourceBy Key, Either (GrantRecipBy Key) FedURI) - adaptGrant (Right _) _ = Nothing - adaptGrant (Left resource) recip = Just (resource, recip) - - verifyRecipients input localRecips remoteRecips = - for_ input $ \ (resourceK, recipientK) -> do - resourceH <- hashGrantResource resourceK - recipientH <- bitraverse hashGrantRecip pure recipientK - fromMaybeE (verifyResource resourceH) "Local resource not addressed" - fromMaybeE (verifyRecip recipientH) "Recipient not addressed" - where - verifyResource (GrantResourceRepo r) = do - routes <- lookup r $ recipRepos localRecips - guard $ routeRepo routes - verifyResource (GrantResourceDeck d) = do - routes <- lookup d $ recipDecks localRecips - guard $ routeDeck $ familyDeck routes - verifyResource (GrantResourceLoom l) = do - routes <- lookup l $ recipLooms localRecips - guard $ routeLoom $ familyLoom routes - verifyRecip (Left (GrantRecipPerson p)) = do - routes <- lookup p $ recipPeople localRecips - guard $ routePerson routes - verifyRecip (Right (ObjURI h lu)) = do - lus <- lookup h remoteRecips - guard $ lu `elem` lus + fetchRemoteResource instanceID host localURI = do + maybeActor <- runSiteDB $ 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 + 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 + roid <- either entityKey id <$> insertBy' (RemoteObject instanceID localURI) + let ra = RemoteActor + { remoteActorIdent = roid + , remoteActorName = + AP.actorName detail <|> AP.actorUsername detail + , remoteActorInbox = AP.actorInbox local + , remoteActorFollowers = AP.actorFollowers local + , remoteActorErrorSince = Nothing + } + 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 + return $ + case result of + Left e -> Left $ ResultSomeException e + Right (Left Nothing) -> Left ResultIdMismatch + Right (Left (Just e)) -> Left $ ResultGetError e + Right (Right Nothing) -> Left ResultNotActor + Right (Right (Just actor)) -> Right $ Right (roid, luManager, actor) getGrantResource (GrantResourceRepo k) e = GrantResourceRepo <$> getEntityE k e @@ -1721,20 +1769,53 @@ grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do getGrantRecip (GrantRecipPerson k) e = GrantRecipPerson <$> getEntityE k e + verifyResourceAddressed localRecips resource = do + resourceHash <- hashGrantResource resource + fromMaybeE (verify resourceHash) "Local resource not addressed" + where + verify (GrantResourceRepo r) = do + routes <- lookup r $ recipRepos localRecips + guard $ routeRepo routes + verify (GrantResourceDeck d) = do + routes <- lookup d $ recipDecks localRecips + guard $ routeDeck $ familyDeck routes + verify (GrantResourceLoom l) = do + routes <- lookup l $ recipLooms localRecips + guard $ routeLoom $ familyLoom routes + + verifyRecipientAddressed localRecips recipient = do + recipientHash <- hashGrantRecip recipient + fromMaybeE (verify recipientHash) "Recipient not addressed" + where + verify (GrantRecipPerson p) = do + routes <- lookup p $ recipPeople localRecips + guard $ routePerson routes + + verifyRemoteAddressed remoteRecips u = + fromMaybeE (verify u) "Given remote entity not addressed" + where + verify (ObjURI h lu) = do + lus <- lookup h remoteRecips + guard $ lu `elem` lus + insertCollab resource recipient grantID = do collabID <- insert Collab case resource of - GrantResourceRepo (Entity repoID _) -> - insert_ $ CollabTopicLocalRepo collabID repoID - GrantResourceDeck (Entity deckID _) -> - insert_ $ CollabTopicLocalDeck collabID deckID - GrantResourceLoom (Entity loomID _) -> - insert_ $ CollabTopicLocalLoom collabID loomID + Left local -> + case local of + GrantResourceRepo (Entity repoID _) -> + insert_ $ CollabTopicLocalRepo collabID repoID + GrantResourceDeck (Entity deckID _) -> + insert_ $ CollabTopicLocalDeck collabID deckID + GrantResourceLoom (Entity loomID _) -> + insert_ $ CollabTopicLocalLoom collabID loomID + Right (remoteID, _, _) -> + insert_ $ CollabTopicRemote collabID remoteID Nothing insert_ $ CollabSenderLocal collabID grantID case recipient of Left (GrantRecipPerson (Entity personID _)) -> insert_ $ CollabRecipLocal collabID personID - Right remoteActorID -> + Right (remoteActorID, _) -> insert_ $ CollabRecipRemote collabID remoteActorID hashGrantResource (GrantResourceRepo k) = diff --git a/src/Vervis/Access.hs b/src/Vervis/Access.hs index 8fc55a8..521b73c 100644 --- a/src/Vervis/Access.hs +++ b/src/Vervis/Access.hs @@ -64,6 +64,7 @@ module Vervis.Access , checkProjectAccess , GrantResourceBy (..) , verifyCapability + , verifyCapabilityRemote ) where @@ -313,3 +314,66 @@ verifyCapability capability personID 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 () + +verifyCapabilityRemote + :: Either (LocalActorBy KeyHashid, OutboxItemId) FedURI + -> PersonId + -> RemoteObjectId + -> ExceptT Text (ReaderT SqlBackend Handler) () +verifyCapabilityRemote capability personID resourceID = do + -- Find the activity itself by URI in the DB + grant <- do + mact <- getActivity capability + fromMaybeE mact "Capability activity not known to me" + + -- Find the Collab record for that activity + cid <- + case grant of + Left (_actor, obiid) -> do + mcsl <- lift $ getValBy $ UniqueCollabSenderLocalActivity obiid + collabSenderLocalCollab <$> + fromMaybeE mcsl "Capability is a local activity but no matching capability" + Right ractid -> do + mcsr <- lift $ getValBy $ UniqueCollabSenderRemoteActivity ractid + collabSenderRemoteCollab <$> + fromMaybeE mcsr "Capability is a known remote activity but no matching capability" + + -- Find the recipient of that Collab + recipID <- do + mcrl <- lift $ getValBy $ UniqueCollabRecipLocal cid + crl <- fromMaybeE mcrl "No local recip for capability" + mcrr <- lift $ getBy $ UniqueCollabRecipRemote cid + for_ mcrr $ \ _ -> error "Both local & remote recip for capability!" + return $ collabRecipLocalPerson crl + + -- Verify the recipient is the expected one + unless (recipID == personID) $ + throwE "Collab recipient is some other Person" + + -- Verify the topic isn't local + maybeRepo <- lift $ fmap (const ()) <$> getValBy (UniqueCollabTopicLocalRepo cid) + maybeDeck <- lift $ fmap (const ()) <$> getValBy (UniqueCollabTopicLocalDeck cid) + maybeLoom <- lift $ fmap (const ()) <$> getValBy (UniqueCollabTopicLocalLoom cid) + case length $ catMaybes [maybeRepo, maybeDeck, maybeLoom] of + 0 -> return () + 1 -> throwE "Collab is for some other, local topic" + _ -> error "Collab with multiple topics" + + -- Find the remote topic, on which this Collab gives access + topicID <- do + maybeRemote <- lift $ getValBy $ UniqueCollabTopicRemote cid + case maybeRemote of + Nothing -> error "Collab without topic" + Just remote -> return $ collabTopicRemoteTopic remote + + -- Verify the topic matches the resource specified + unless (topicID == resourceID) $ + throwE "Capability topic is some other remote resource" + + -- Verify that the resource has accepted the grant, making it valid + maybeAccept <- lift $ getBy $ UniqueCollabTopicAcceptCollab cid + _ <- fromMaybeE maybeAccept "Collab not approved by the resource" + + -- 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 () diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index b2bc6f9..2f3a649 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -42,6 +42,7 @@ module Web.ActivityPub , CollectionPageType (..) , CollectionPage (..) , Recipient (..) + , Resource (..) -- * Content objects , Note (..) @@ -99,6 +100,7 @@ module Web.ActivityPub , fetchAPID , fetchAPID' , fetchRecipient + , fetchResource , keyListedByActor , fetchUnknownKey , fetchKnownPersonalKey @@ -622,6 +624,19 @@ instance ActivityPub Recipient where toSeries h (RecipientActor a) = toSeries h a toSeries h (RecipientCollection c) = toSeries h c +data Resource u = ResourceActor (Actor u) | ResourceChild LocalURI LocalURI + +instance ActivityPub Resource where + jsonldContext _ = [as2Context, secContext, forgeContext] + parseObject o = + second ResourceActor <$> parseObject o <|> do + ObjURI h luId <- o .: "id" <|> o .: "@id" + (h,) . ResourceChild luId <$> withAuthorityO h (o .: "managedBy") + toSeries h (ResourceActor a) = toSeries h a + toSeries h (ResourceChild luId luManager) + = "id" .= ObjURI h luId + <> "managedBy" .= ObjURI h luManager + data Audience u = Audience { audienceTo :: [ObjURI u] , audienceBto :: [ObjURI u] @@ -1901,6 +1916,12 @@ fetchRecipient m = fetchAPID' m getId getId (RecipientActor a) = actorId $ actorLocal a getId (RecipientCollection c) = collectionId c +fetchResource :: (MonadIO m, UriMode u) => Manager -> Authority u -> LocalURI -> m (Either (Maybe APGetError) (Resource u)) +fetchResource m = fetchAPID' m getId + where + getId (ResourceActor a) = actorId $ actorLocal a + getId (ResourceChild luId _) = luId + fetchAPID :: (MonadIO m, UriMode u, ActivityPub a) => Manager -> (a u -> LocalURI) -> Authority u -> LocalURI -> m (Either String (a u)) fetchAPID m getId h lu = first showError <$> fetchAPID' m getId h lu where diff --git a/th/models b/th/models index 0e9493a..497de7c 100644 --- a/th/models +++ b/th/models @@ -620,9 +620,6 @@ CollabTopicAccept UniqueCollabTopicAcceptCollab collab UniqueCollabTopicAcceptAccept accept --- Do we need this for S2S? Or is this just for the Client, to decide which --- Grant URI to use as the 'capability'? If latter, look into removing this --- table... CollabTopicRemote collab CollabId topic RemoteObjectId