forge/Vervis
1
0
Fork 0
Code Pull requests Activity

S2S: Update Project-Accept handler to handle Components

Browse source
This commit is contained in:
Pere Lev 2023-07-12 16:50:29 +03:00
parent aec2235fdc
commit a083b0d866
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D
6 changed files with 333 additions and 76 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
src/Vervis/API.hs
View file

@ -1195,7 +1195,7 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips
, actionFulfills =
[encodeRouteHome $ PersonOutboxItemR adminHash obikhidCreate]
, actionSpecific = GrantActivity Grant
{ grantObject = RoleAdmin
{ grantObject = AP.RXRole RoleAdmin
, grantContext = encodeRouteLocal $ LoomR loomHash
, grantTarget = encodeRouteHome $ PersonR adminHash
, grantResult = Nothing
@ -1431,7 +1431,7 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r
, actionFulfills =
[encodeRouteHome $ PersonOutboxItemR adminHash obikhidCreate]
, actionSpecific = GrantActivity Grant
{ grantObject = RoleAdmin
{ grantObject = AP.RXRole RoleAdmin
, grantContext = encodeRouteLocal $ RepoR repoHash
, grantTarget = encodeRouteHome $ PersonR adminHash
, grantResult = Nothing

4
src/Vervis/Actor/Common.hs
View file

@ -413,7 +413,7 @@ topicAccept topicActor topicResource now recipKey (Verse authorIdMsig body) acce
, AP.actionAudience = AP.Audience recips [] [] [] [] []
, AP.actionFulfills = [AP.acceptObject accept]
, AP.actionSpecific = AP.GrantActivity AP.Grant
{ AP.grantObject = role
{ AP.grantObject = AP.RXRole role
, AP.grantContext =
encodeRouteLocal $ renderLocalActor topicByHash
, AP.grantTarget =
@ -1294,7 +1294,7 @@ topicCreateMe topicActor topicResource collabTopicFieldTopic collabTopicCtor now
, AP.actionAudience = AP.Audience recips [] [] [] [] []
, AP.actionFulfills = [uCreate]
, AP.actionSpecific = AP.GrantActivity AP.Grant
{ AP.grantObject = AP.RoleAdmin
{ AP.grantObject = AP.RXRole AP.RoleAdmin
, AP.grantContext =
encodeRouteLocal $ renderLocalActor topicByHash
, AP.grantTarget = uCreator

284
src/Vervis/Actor/Project.hs
View file

@ -28,6 +28,7 @@ import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import Data.Barbie
import Data.Bifoldable
import Data.Bifunctor
import Data.Bitraversable
import Data.ByteString (ByteString)
@ -91,7 +92,7 @@ import Vervis.Ticket
-- * Verify I haven't seen a component-Accept on this Add
-- * Otherwise, i.e. sender isn't the component:
-- * Verify I've seen the component-Accept for this Add
-- * Verify the Accept is authorized
-- * Verify the new Accept is authorized
-- * If it's none of these, respond with error
--
-- * In collab mode, verify the Collab isn't enabled yet
@ -123,14 +124,14 @@ import Vervis.Ticket
-- * CC: Accept sender, Join sender's followers, my followers
-- * For Invite-component mode:
-- * Only if sender is the component
-- * delegator-Grant with a result URI
-- * delegator-Grant
-- * To: Component
-- * CC:
-- - Component's followers
-- - My followers
-- * For Add-component mode:
-- * Only if sender isn't the component
-- * delegator-Grant with a result URI
-- * delegator-Grant
-- * To: Component
-- * CC:
-- - Component's followers
@ -169,17 +170,24 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
fromMaybeE a "Can't find acceptee in DB"
-- See if the accepted activity is an Invite or Join where my collabs
-- URI is the resource, grabbing the Collab record from our DB
(collabID, fulfills, inviterOrJoiner) <- do
-- URI is the resource, grabbing the Collab record from our DB,
-- Or if the accepted activity is an Invite or Add where my components
-- URI is the resource, grabbing the Component record from our DB
collabOrComp <- do
let adapt = maybe (Right Nothing) (either Left (Right . Just))
maybeCollab <-
ExceptT $ fmap adapt $ runMaybeT $
runExceptT (tryInviteCollab accepteeDB) <|>
runExceptT (tryJoinCollab accepteeDB)
fromMaybeE maybeCollab "Accepted activity isn't an Invite or Join I'm aware of"
runExceptT (Left <$> tryInviteCollab accepteeDB) <|>
runExceptT (Left <$> tryJoinCollab accepteeDB) <|>
runExceptT (Right <$> tryInviteComp accepteeDB) <|>
runExceptT (Right <$> tryAddComp accepteeDB)
fromMaybeE
maybeCollab
"Accepted activity isn't an Invite/Join/Add I'm aware of"
idsForAccept <-
bitraverse
idsForAccept <- bitraverse
(\ (collabID, fulfills, inviterOrJoiner) -> (collabID,inviterOrJoiner,) <$> bitraverse
-- If accepting an Invite, find the Collab recipient and verify
-- it's the sender of the Accept
@ -217,16 +225,74 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
)
fulfills
)
-- Verify the Collab isn't already validated
(\ (componentID, ident, inviteOrAdd) -> (componentID, ident,) <$> bitraverse
-- If accepting an Invite-component, there's nothing to check
-- at this point
pure
-- If accepting an Add-component:
-- * If the sender is the component, verify I haven't seen
-- a component-Accept on this Add
-- * Otherwise, verify I've seen the component-Accept for
-- this Add and that the new Accept is authorized
(\ () -> do
maybeComponentAccept <-
lift $
case bimap fst fst ident of
Left localID -> (() <$) <$> getBy (UniqueComponentAcceptLocal localID)
Right remoteID -> (() <$) <$> getBy (UniqueComponentAcceptRemote remoteID)
if componentIsAuthor ident
then
verifyNothingE
maybeComponentAccept
"I've already seen a ComponentAccept* on \
\that Add"
else do
fromMaybeE
maybeComponentAccept
"I haven't yet seen the Component's Accept on \
\the Add"
capID <- fromMaybeE maybeCap "No capability provided"
capability <-
case capID of
Left (capActor, _, capItem) -> return (capActor, capItem)
Right _ -> throwE "Capability is a remote URI, i.e. not authored by me"
verifyCapability'
capability
authorIdMsig
(GrantResourceProject projectID)
AP.RoleAdmin
)
inviteOrAdd
)
collabOrComp
-- In collab mode, verify the Collab isn't already validated
-- In component mode, verify the Component isn't already validated
bitraverse_
(\ (collabID, _, _) -> do
maybeEnabled <- lift $ getBy $ UniqueCollabEnable collabID
verifyNothingE maybeEnabled "I already sent a Grant for this Invite/Join"
)
(\ (componentID, _, _) -> do
maybeEnabled <- lift $ getBy $ UniqueComponentEnable componentID
verifyNothingE maybeEnabled "I already sent a delegator-Grant for this Invite/Add"
)
collabOrComp
maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False
for maybeAcceptDB $ \ acceptDB -> do
-- Record the Accept on the Collab
case (idsForAccept, acceptDB) of
idsForGrant <- case idsForAccept of
-- In collab mode, record the Accept and enable the Collab
Left (collabID, inviterOrJoiner, collab) -> Left <$> do
case (collab, acceptDB) of
(Left (fulfillsID, Left recipID), Left (_, _, acceptID)) -> do
maybeAccept <- lift $ insertUnique $ CollabRecipLocalAccept recipID fulfillsID acceptID
unless (isNothing maybeAccept) $
@ -243,39 +309,92 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
maybeAccept <- lift $ insertUnique $ CollabApproverRemote fulfillsID (remoteAuthorId author) acceptID
unless (isJust maybeAccept) $
throwE "This Join already has an Accept"
_ -> error "topicAccept impossible"
_ -> error "projectAccept impossible"
grantID <- lift $ insertEmptyOutboxItem' (actorOutbox recipActor) now
lift $ insert_ $ CollabEnable collabID grantID
return (collabID, inviterOrJoiner, collab, grantID)
-- In Invite-component mode, only if the Accept author is the
-- component, record the Accept and enable the Component
Right (componentID, ident, Left ()) -> fmap Right $
lift $ if componentIsAuthor ident
then Just <$> do
case (ident, acceptDB) of
(Left (localID, _), Left (_, _, acceptID)) ->
insert_ $ ComponentAcceptLocal localID acceptID
(Right (remoteID, _), Right (_, _, acceptID)) ->
insert_ $ ComponentAcceptRemote remoteID acceptID
_ -> error "personAccept impossible ii"
grantID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
enableID <- insert $ ComponentEnable componentID grantID
return (componentID, ident, grantID, enableID, False)
else pure Nothing
-- In Add-component mode:
-- * If the sender is the component, record the Accept
-- * Otherwise, record the Accept and enable the Component
Right (componentID, ident, Right ()) -> fmap Right $
lift $ if componentIsAuthor ident
then do
case (ident, acceptDB) of
(Left (localID, _), Left (_, _, acceptID)) ->
insert_ $ ComponentAcceptLocal localID acceptID
(Right (remoteID, _), Right (_, _, acceptID)) ->
insert_ $ ComponentAcceptRemote remoteID acceptID
_ -> error "personAccept impossible iii"
return Nothing
else Just <$> do
case acceptDB of
Left (_, _, acceptID) ->
insert_ $ ComponentProjectGestureLocal componentID acceptID
Right (author, _, acceptID) ->
insert_ $ ComponentProjectGestureRemote componentID (remoteAuthorId author) acceptID
grantID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
enableID <- insert $ ComponentEnable componentID grantID
return (componentID, ident, grantID, enableID, True)
-- Prepare forwarding of Accept to my followers
let recipByID = grantResourceLocalActor $ GrantResourceProject projectID
recipByHash <- hashLocalActor recipByID
let sieve = makeRecipientSet [] [localActorFollowers recipByHash]
grantInfo <- do
maybeGrant <-
case idsForGrant of
-- Enable the Collab in our DB
grantID <- lift $ insertEmptyOutboxItem' (actorOutbox recipActor) now
lift $ insert_ $ CollabEnable collabID grantID
-- Prepare a Grant activity and insert to my outbox
let isInvite = isLeft fulfills
-- In collab mode, prepare a regular Grant
Left (collabID, inviterOrJoiner, collab, grantID) -> lift $ do
let isInvite = isLeft collab
grant@(actionGrant, _, _, _) <- do
Collab role <- lift $ getJust collabID
lift $ prepareGrant isInvite inviterOrJoiner role
let recipByKey = grantResourceLocalActor $ GrantResourceProject projectID
_luGrant <- lift $ updateOutboxItem' recipByKey grantID actionGrant
Collab role <- getJust collabID
prepareCollabGrant isInvite inviterOrJoiner role
let recipByKey = LocalActorProject projectID
_luGrant <- updateOutboxItem' recipByKey grantID actionGrant
return $ Just (grantID, grant)
-- In Invite-component mode, only if the Accept author is
-- the component, prepare a delegator-Grant
--
-- In Add-component mode, only if the Accept author isn't
-- the component, prepare a delegator-Grant
Right comp -> for comp $ \ (_componentID, ident, grantID, enableID, includeAuthor) -> lift $ do
grant@(actionGrant, _, _, _) <-
prepareDelegGrant (bimap snd snd ident) enableID includeAuthor
let recipByKey = LocalActorProject projectID
_luGrant <- updateOutboxItem' recipByKey grantID actionGrant
return (grantID, grant)
return (recipActorID, sieve, grantInfo)
return (recipActorID, sieve, maybeGrant)
case maybeNew of
Nothing -> done "I already have this activity in my inbox"
Just (recipActorID, sieve, (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant))) -> do
let recipByID = grantResourceLocalActor $ GrantResourceProject projectID
Just (recipActorID, sieve, maybeGrant) -> do
let recipByID = LocalActorProject projectID
forwardActivity authorIdMsig body recipByID recipActorID sieve
lift $ sendActivity
lift $ for_ maybeGrant $ \ (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant)) ->
sendActivity
recipByID recipActorID localRecipsGrant
remoteRecipsGrant fwdHostsGrant grantID actionGrant
done "Forwarded the Accept and published a Grant"
done "Forwarded the Accept and maybe published a Grant"
where
@ -331,16 +450,50 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
(,remoteActorFollowers actor) <$> getRemoteActorURI actor
return (collabID, Right fulfillsID, Right joiner)
{-
tryInviteComp (Left (actorByKey, _actorEntity, itemID)) = do
ComponentOriginInvite
ComponentProjectGestureLocal
tryInviteCollab (Right remoteActivityID) = do
ComponentOriginInvite
ComponentProjectGestureRemote
-}
verifyCompTopic :: ComponentId -> ActDBE ()
verifyCompTopic componentID = do
Component j _ <- lift $ getJust componentID
unless (j == projectID) $
throwE "Accept object is an Invite/Add for some other project"
prepareGrant isInvite sender role = do
tryInviteComp (Left (actorByKey, _actorEntity, itemID)) = do
ComponentProjectGestureLocal componentID _ <-
lift $ MaybeT $ getValBy $
UniqueComponentProjectGestureLocalActivity itemID
_ <- lift $ MaybeT $ getBy $ UniqueComponentOriginInvite componentID
ExceptT $ lift $ runExceptT $ verifyCompTopic componentID
ident <- lift $ lift $ getComponentIdent componentID
return (componentID, ident, Left ())
tryInviteComp (Right remoteActivityID) = do
ComponentProjectGestureRemote componentID _ _ <-
lift $ MaybeT $ getValBy $
UniqueComponentProjectGestureRemoteActivity remoteActivityID
_ <- lift $ MaybeT $ getBy $ UniqueComponentOriginInvite componentID
ExceptT $ lift $ runExceptT $ verifyCompTopic componentID
ident <- lift $ lift $ getComponentIdent componentID
return (componentID, ident, Left ())
tryAddComp (Left (actorByKey, _actorEntity, itemID)) = do
ComponentGestureLocal originID _ <-
lift $ MaybeT $ getValBy $ UniqueComponentGestureLocalAdd itemID
ComponentOriginAdd componentID <- lift $ lift $ getJust originID
ExceptT $ lift $ runExceptT $ verifyCompTopic componentID
ident <- lift $ lift $ getComponentIdent componentID
return (componentID, ident, Right ())
tryAddComp (Right remoteActivityID) = do
ComponentGestureRemote originID _ _ <-
lift $ MaybeT $ getValBy $
UniqueComponentGestureRemoteAdd remoteActivityID
ComponentOriginAdd componentID <- lift $ lift $ getJust originID
ExceptT $ lift $ runExceptT $ verifyCompTopic componentID
ident <- lift $ lift $ getComponentIdent componentID
return (componentID, ident, Right ())
componentIsAuthor ident =
let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig
in author == bimap (componentActor . snd) snd ident
prepareCollabGrant isInvite sender role = do
encodeRouteHome <- getEncodeRouteHome
encodeRouteLocal <- getEncodeRouteLocal
@ -382,7 +535,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
, AP.actionAudience = AP.Audience recips [] [] [] [] []
, AP.actionFulfills = [AP.acceptObject accept]
, AP.actionSpecific = AP.GrantActivity AP.Grant
{ AP.grantObject = role
{ AP.grantObject = AP.RXRole role
, AP.grantContext =
encodeRouteLocal $ renderLocalActor topicByHash
, AP.grantTarget =
@ -402,6 +555,57 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
return (action, recipientSet, remoteActors, fwdHosts)
prepareDelegGrant ident _enableID includeAuthor = do
encodeRouteHome <- getEncodeRouteHome
encodeRouteLocal <- getEncodeRouteLocal
(uComponent, audComponent) <-
case ident of
Left c -> do
a <- componentActor <$> hashComponent c
return
( encodeRouteHome $ renderLocalActor a
, AudLocal [a] [localActorFollowers a]
)
Right raID -> do
ra <- getJust raID
u@(ObjURI h lu) <- getRemoteActorURI ra
return
( u
, AudRemote h [lu] (maybeToList $ remoteActorFollowers ra)
)
audAuthor <- lift $ makeAudSenderOnly authorIdMsig
projectHash <- encodeKeyHashid projectID
let audProject = AudLocal [] [LocalStageProjectFollowers projectHash]
audience =
if includeAuthor
then [audComponent, audProject, audAuthor]
else [audComponent, audProject]
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
collectAudience audience
recips = map encodeRouteHome audLocal ++ audRemote
action = AP.Action
{ AP.actionCapability = Nothing
, AP.actionSummary = Nothing
, AP.actionAudience = AP.Audience recips [] [] [] [] []
, AP.actionFulfills = [AP.acceptObject accept]
, AP.actionSpecific = AP.GrantActivity AP.Grant
{ AP.grantObject = AP.RXDelegator
, AP.grantContext = encodeRouteLocal $ ProjectR projectHash
, AP.grantTarget = uComponent
, AP.grantResult = Nothing
, AP.grantStart = Just now
, AP.grantEnd = Nothing
, AP.grantAllows = AP.Invoke
, AP.grantDelegates = Nothing
}
}
return (action, recipientSet, remoteActors, fwdHosts)
checkExistingComponents
:: ProjectId -> Either (ComponentBy Entity) RemoteActorId -> ActDBE ()
checkExistingComponents projectID componentDB = do

2
src/Vervis/Data/Collab.hs
View file

@ -253,7 +253,7 @@ parseGrant
:: Host
-> AP.Grant URIMode
-> ActE
( AP.Role
( AP.RoleExt
, Either (GrantResourceBy Key) LocalURI
, Either (GrantRecipBy Key) FedURI
, Maybe (LocalURI, Maybe Int)

37
src/Vervis/Persist/Collab.hs
View file

@ -26,6 +26,8 @@ module Vervis.Persist.Collab
, verifyCapability'
, getGrant
, getComponentIdent
)
where
@ -356,3 +358,38 @@ getGrant topicCollabField topicActorField resourceID personID = do
[] -> return Nothing
[E.Value i] -> return $ Just i
_ -> error $ "Multiple grants for a Person in resource#" ++ show resourceID
getComponentIdent
:: MonadIO m
=> ComponentId
-> ReaderT SqlBackend m
(Either
(ComponentLocalId, ComponentBy Key)
(ComponentRemoteId, RemoteActorId)
)
getComponentIdent componentID = do
ident <-
requireEitherAlt
(getKeyBy $ UniqueComponentLocal componentID)
(getBy $ UniqueComponentRemote componentID)
"Found Component without ident"
"Found Component with both local and remote ident"
bitraverse
(\ localID -> do
maybeRepo <- getValBy $ UniqueComponentLocalRepo localID
maybeDeck <- getValBy $ UniqueComponentLocalDeck localID
maybeLoom <- getValBy $ UniqueComponentLocalLoom localID
fmap (localID,) $ return $
case (maybeRepo, maybeDeck, maybeLoom) of
(Nothing, Nothing, Nothing) ->
error "Found ComponentLocal without ident"
(Just r, Nothing, Nothing) ->
ComponentRepo $ componentLocalRepoRepo r
(Nothing, Just d, Nothing) ->
ComponentDeck $ componentLocalDeckDeck d
(Nothing, Nothing, Just l) ->
ComponentLoom $ componentLocalLoomLoom l
_ -> error "Found ComponentLocal with multiple idents"
)
(\ (Entity k v) -> pure (k, componentRemoteActor v))
ident

36
src/Web/ActivityPub.hs
View file

@ -67,6 +67,7 @@ module Web.ActivityPub
, Commit (..)
, Branch (..)
, Role (..)
, RoleExt (..)
, Duration (..)
, Usage (..)
@ -1623,16 +1624,16 @@ data Role
= RoleVisit | RoleReport | RoleTriage | RoleWrite | RoleMaintain | RoleAdmin
deriving (Show, Read, Eq, Ord, Enum, Bounded)
parseRole "visit" = pure RoleVisit
parseRole "report" = pure RoleReport
parseRole "triage" = pure RoleTriage
parseRole "write" = pure RoleWrite
parseRole "maintain" = pure RoleMaintain
parseRole "admin" = pure RoleAdmin
parseRole t = fail $ "Unknown role: " ++ T.unpack t
instance FromJSON Role where
parseJSON = withText "Role" parse
where
parse "visit" = pure RoleVisit
parse "report" = pure RoleReport
parse "triage" = pure RoleTriage
parse "write" = pure RoleWrite
parse "maintain" = pure RoleMaintain
parse "admin" = pure RoleAdmin
parse t = fail $ "Unknown role: " ++ T.unpack t
parseJSON = withText "Role" parseRole
instance ToJSON Role where
toJSON = error "toJSON Role"
@ -1645,6 +1646,21 @@ instance ToJSON Role where
RoleMaintain -> "maintain"
RoleAdmin -> "admin"
data RoleExt = RXRole Role | RXDelegator deriving (Show, Read, Eq)
instance FromJSON RoleExt where
parseJSON = withText "RoleExt" parse
where
parse "delegator" = pure RXDelegator
parse t = RXRole <$> parseRole t
instance ToJSON RoleExt where
toJSON = error "toJSON RoleExt"
toEncoding r =
case r of
RXRole role -> toEncoding role
RXDelegator -> toEncoding ("delegator" :: Text)
data Duration = Duration Int
instance FromJSON Duration where
@ -1851,7 +1867,7 @@ encodeFollow (Follow obj mcontext hide)
<> "hide" .= hide
data Grant u = Grant
{ grantObject :: Role
{ grantObject :: RoleExt
, grantContext :: LocalURI
, grantTarget :: ObjURI u
, grantResult :: Maybe (LocalURI, Maybe Duration)