forge/Vervis
1
0
Fork 0
Code Pull requests Activity

C2S: grantC: Insert Collab records for Grants with remote topics too

Browse source
This commit is contained in:
fr33domlover 2022-08-28 13:51:43 +00:00
parent 06c520f6aa
commit d741d0e918
4 changed files with 285 additions and 122 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

319
src/Vervis/API.hs
View file

@ -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) =

64
src/Vervis/Access.hs
View file

@ -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 ()

21
src/Web/ActivityPub.hs
View file

@ -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

3
th/models
View file

@ -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