S2S: Project Grant handler

src/Vervis/API.hs

@@ -397,7 +397,7 @@ acceptC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re
                 , actionFulfills   = [AP.acceptObject accept]
                 , actionSpecific   = GrantActivity Grant
                     { grantObject  = RoleAdmin
-                    , grantContext = encodeRouteLocal $ renderLocalActor topicHash
+                    , grantContext = encodeRouteHome $ renderLocalActor topicHash
                     , grantTarget  = encodeRouteHome $ PersonR recipHash
                     , grantResult  = Nothing
                     , grantStart   = Nothing
@@ -1196,7 +1196,7 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips
                 [encodeRouteHome $ PersonOutboxItemR adminHash obikhidCreate]
             , actionSpecific = GrantActivity Grant
                 { grantObject   = AP.RXRole RoleAdmin
-                , grantContext  = encodeRouteLocal $ LoomR loomHash
+                , grantContext  = encodeRouteHome $ LoomR loomHash
                 , grantTarget   = encodeRouteHome $ PersonR adminHash
                 , grantResult  = Nothing
                 , grantStart   = Nothing
@@ -1432,7 +1432,7 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r
                 [encodeRouteHome $ PersonOutboxItemR adminHash obikhidCreate]
             , actionSpecific   = GrantActivity Grant
                 { grantObject    = AP.RXRole RoleAdmin
-                , grantContext   = encodeRouteLocal $ RepoR repoHash
+                , grantContext   = encodeRouteHome $ RepoR repoHash
                 , grantTarget    = encodeRouteHome $ PersonR adminHash
                 , grantResult    = Nothing
                 , grantStart   = Nothing

src/Vervis/Actor/Common.hs

@@ -415,7 +415,7 @@ topicAccept topicActor topicResource now recipKey (Verse authorIdMsig body) acce
                 , AP.actionSpecific   = AP.GrantActivity AP.Grant
                     { AP.grantObject    = AP.RXRole role
                     , AP.grantContext   =
-                        encodeRouteLocal $ renderLocalActor topicByHash
+                        encodeRouteHome $ renderLocalActor topicByHash
                     , AP.grantTarget    =
                         if isInvite
                             then uAccepter
@@ -1296,7 +1296,7 @@ topicCreateMe topicActor topicResource collabTopicFieldTopic collabTopicCtor now
                 , AP.actionSpecific   = AP.GrantActivity AP.Grant
                     { AP.grantObject    = AP.RXRole AP.RoleAdmin
                     , AP.grantContext   =
-                        encodeRouteLocal $ renderLocalActor topicByHash
+                        encodeRouteHome $ renderLocalActor topicByHash
                     , AP.grantTarget    = uCreator
                     , AP.grantResult    = Nothing
                     , AP.grantStart     = Just now

src/Vervis/Actor/Project.hs

@@ -537,7 +537,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
                 , AP.actionSpecific   = AP.GrantActivity AP.Grant
                     { AP.grantObject    = AP.RXRole role
                     , AP.grantContext   =
-                        encodeRouteLocal $ renderLocalActor topicByHash
+                        encodeRouteHome $ renderLocalActor topicByHash
                     , AP.grantTarget    =
                         if isInvite
                             then uAccepter
@@ -594,7 +594,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
                 , AP.actionFulfills   = [AP.acceptObject accept]
                 , AP.actionSpecific   = AP.GrantActivity AP.Grant
                     { AP.grantObject    = AP.RXDelegator
-                    , AP.grantContext   = encodeRouteLocal $ ProjectR projectHash
+                    , AP.grantContext   = encodeRouteHome $ ProjectR projectHash
                     , AP.grantTarget    = uComponent
                     , AP.grantResult    = Nothing
                     , AP.grantStart     = Just now
@@ -877,6 +877,257 @@ projectFollow now recipProjectID verse follow = do
         (\ _ -> pure [])
         now recipProjectID verse follow
 
+-- Meaning: An actor is granting access-to-some-resource to another actor
+-- Behavior:
+--      * Verify that:
+--          * The sender is a component of mine, C
+--          * The Grant's context is C
+--          * The Grant's target is me
+--          * The Grant's usage is gatherAndConvey
+--          * The Grant doesn't specify 'delegates'
+--          * The activity is authorized via a valid delegator-Grant I had sent
+--            to C
+--      * Verify the Grant's role is the same one specified in the Invite/Add
+--        that added the Component
+--      * Verify I don't yet have a delegation from C
+--      * Insert the Grant to my inbox
+--      * Record the delegation in the Component record in DB
+--      * Forward the Grant to my followers
+--      * For each person (non-team) collaborator of mine, prepare and send a
+--        Grant, and store it in the Componet record in DB:
+--          * Role: The lower among (1) admin (2) the collaborator's role in me
+--          * Resource: C
+--          * Target: The collaborator
+--          * Delegates: The Grant I just got from C
+--          * Result: ProjectCollabLiveR for this collaborator
+--          * Usage: invoke
+projectGrant
+    :: UTCTime
+    -> ProjectId
+    -> Verse
+    -> AP.Grant URIMode
+    -> ActE (Text, Act (), Next)
+projectGrant now projectID (Verse authorIdMsig body) grant = do
+
+    -- Check capability
+    capability <- do
+
+        -- Verify that a capability is provided
+        uCap <- do
+            let muCap = AP.activityCapability $ actbActivity body
+            fromMaybeE muCap "No capability provided"
+
+        -- Verify the capability URI is one of:
+        --   * Outbox item URI of a local actor, i.e. a local activity
+        --   * A remote URI
+        cap <- nameExceptT "Invite capability" $ parseActivityURI' uCap
+
+        -- Verify the capability is local
+        case cap of
+            Left (actorByKey, _, outboxItemID) ->
+                return (actorByKey, outboxItemID)
+            _ -> throwE "Capability is remote i.e. definitely not by me"
+
+    -- Check grant
+    (role, component) <- checkDelegationStart grant
+
+    maybeNew <- withDBExcept $ do
+
+        -- Grab me from DB
+        (recipActorID, recipActor) <- lift $ do
+            recip <- getJust projectID
+            let actorID = projectActor recip
+            (actorID,) <$> getJust actorID
+
+        -- Find the Component record from the capability
+        Entity enableID (ComponentEnable componentID _) <- do
+            unless (fst capability == LocalActorProject projectID) $
+                throwE "Capability isn't mine"
+            m <- lift $ getBy $ UniqueComponentEnableGrant $ snd capability
+            fromMaybeE m "I don't have a Component with this capability"
+        Component j role' <- lift $ getJust componentID
+        unless (j == projectID) $
+            throwE "Found a Component for this delegator-Grant but it's not mine"
+        unless (role' == role) $
+            throwE "Grant role isn't the same as in the Invite/Add"
+        ident <- lift $ getComponentIdent componentID
+        identForCheck <-
+            lift $
+            bitraverse
+                (pure . snd)
+                (\ (_, raID) -> getRemoteActorURI =<< getJust raID)
+                ident
+        unless (identForCheck == component) $
+            throwE "Capability's component and Grant author aren't the same actor"
+
+        -- Verify I don't yet have a delegation from the component
+        maybeDeleg <-
+            lift $ case bimap fst fst ident of
+                Left localID -> (() <$) <$> getBy (UniqueComponentDelegateLocal localID)
+                Right remoteID -> (() <$) <$> getBy (UniqueComponentDelegateRemote remoteID)
+        verifyNothingE maybeDeleg "I already have a delegation-start Grant from this component"
+
+        maybeGrantDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False
+        for maybeGrantDB $ \ grantDB -> do
+
+            -- Record the delegation in DB
+            lift $ case (grantDB, bimap fst fst ident) of
+                (Left (_, _, grantID), Left localID) -> insert_ $ ComponentDelegateLocal localID grantID
+                (Right (_, _, grantID), Right remoteID) -> insert_ $ ComponentDelegateRemote remoteID grantID
+                _ -> error "projectGrant impossible"
+
+            -- Prepare forwarding of Accept to my followers
+            projectHash <- encodeKeyHashid projectID
+            let sieve = makeRecipientSet [] [LocalStageProjectFollowers projectHash]
+
+            -- For each Collab in me, prepare a delegation-extension Grant
+            localCollabs <-
+                lift $
+                E.select $ E.from $ \ (topic `E.InnerJoin` collab `E.InnerJoin` enable `E.InnerJoin` recipL) -> do
+                    E.on $ enable E.^. CollabEnableCollab E.==. recipL E.^. CollabRecipLocalCollab
+                    E.on $ topic E.^. CollabTopicProjectCollab E.==. enable E.^. CollabEnableCollab
+                    E.on $ topic E.^. CollabTopicProjectCollab E.==. collab E.^. CollabId
+                    E.where_ $ topic E.^. CollabTopicProjectProject E.==. E.val projectID
+                    return
+                        ( collab E.^. CollabRole
+                        , recipL E.^. CollabRecipLocalId
+                        , recipL E.^. CollabRecipLocalPerson
+                        , enable E.^. CollabEnableId
+                        )
+            localExtensions <- lift $ for localCollabs $ \ (E.Value role', E.Value recipID, E.Value personID, E.Value enableID') -> do
+                extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
+                insert_ $ ComponentFurtherLocal enableID recipID extID
+                ext@(actionExt, _, _, _) <-
+                    prepareExtensionGrant identForCheck (Left personID) (min role role') enableID'
+                let recipByKey = LocalActorProject projectID
+                _luExt <- updateOutboxItem' recipByKey extID actionExt
+                return (extID, ext)
+
+            remoteCollabs <-
+                lift $
+                E.select $ E.from $ \ (topic `E.InnerJoin` collab `E.InnerJoin` enable `E.InnerJoin` recipR) -> do
+                    E.on $ enable E.^. CollabEnableCollab E.==. recipR E.^. CollabRecipRemoteCollab
+                    E.on $ topic E.^. CollabTopicProjectCollab E.==. enable E.^. CollabEnableCollab
+                    E.on $ topic E.^. CollabTopicProjectCollab E.==. collab E.^. CollabId
+                    E.where_ $ topic E.^. CollabTopicProjectProject E.==. E.val projectID
+                    return
+                        ( collab E.^. CollabRole
+                        , recipR E.^. CollabRecipRemoteId
+                        , recipR E.^. CollabRecipRemoteActor
+                        , enable E.^. CollabEnableId
+                        )
+            remoteExtensions <- lift $ for remoteCollabs $ \ (E.Value role', E.Value recipID, E.Value raID, E.Value enableID') -> do
+                extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
+                insert_ $ ComponentFurtherRemote enableID recipID extID
+                ext@(actionExt, _, _, _) <-
+                    prepareExtensionGrant identForCheck (Right raID) (min role role') enableID'
+                let recipByKey = LocalActorProject projectID
+                _luExt <- updateOutboxItem' recipByKey extID actionExt
+                return (extID, ext)
+
+            return (recipActorID, sieve, localExtensions, remoteExtensions)
+
+    case maybeNew of
+        Nothing -> done "I already have this activity in my inbox"
+        Just (recipActorID, sieve, localExts, remoteExts) -> do
+            let recipByID = LocalActorProject projectID
+            forwardActivity authorIdMsig body recipByID recipActorID sieve
+            lift $ for_ (localExts ++ remoteExts) $
+                \ (extID, (actionExt, localRecipsExt, remoteRecipsExt, fwdHostsExt)) ->
+                    sendActivity
+                        recipByID recipActorID localRecipsExt
+                        remoteRecipsExt fwdHostsExt extID actionExt
+            done "Forwarded the Grant and published delegation extensions"
+
+    where
+
+    checkDelegationStart g = do
+        (role, resource, recipient, _mresult, mstart, mend, usage, mdeleg) <-
+            parseGrant' g
+        role' <-
+            case role of
+                AP.RXRole r -> pure r
+                AP.RXDelegator -> throwE "Role is delegator"
+        component <-
+            fromMaybeE
+                (bitraverse resourceToComponent Just resource)
+                "Resource is a local project, therefore not a component of mine"
+        case (component, authorIdMsig) of
+            (Left c, Left (a, _, _)) | componentActor c == a -> pure ()
+            (Right u, Right (ra, _, _)) | remoteAuthorURI ra == u -> pure ()
+            _ -> throwE "Author and context aren't the same actor"
+        case recipient of
+            Left (GrantRecipProject' j) | j == projectID -> pure ()
+            _ -> throwE "Target isn't me"
+        for_ mstart $ \ start ->
+            unless (start < now) $ throwE "Start time is in the future"
+        for_ mend $ \ _ ->
+            throwE "End time is specified"
+        unless (usage == AP.GatherAndConvey) $
+            throwE "Usage isn't GatherAndConvey"
+        for_ mdeleg $ \ _ ->
+            throwE "'delegates' is specified"
+        return (role', component)
+
+    prepareExtensionGrant component collab role enableID = do
+        encodeRouteHome <- getEncodeRouteHome
+        encodeRouteLocal <- getEncodeRouteLocal
+
+        projectHash <- encodeKeyHashid projectID
+        uStart <- lift $ getActivityURI authorIdMsig
+
+        (uCollab, audCollab) <-
+            case collab of
+                Left personID -> do
+                    personHash <- encodeKeyHashid personID
+                    return
+                        ( encodeRouteHome $ PersonR personHash
+                        , AudLocal [LocalActorPerson personHash] []
+                        )
+                Right raID -> do
+                    ra <- getJust raID
+                    u@(ObjURI h lu) <- getRemoteActorURI ra
+                    return (u, AudRemote h [lu] [])
+
+        uComponent <-
+            case component of
+                Left c -> do
+                    a <- componentActor <$> hashComponent c
+                    return $ encodeRouteHome $ renderLocalActor a
+                Right u -> pure u
+
+        enableHash <- encodeKeyHashid enableID
+
+        let audience = [audCollab]
+
+            (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   = [uStart]
+                , AP.actionSpecific   = AP.GrantActivity AP.Grant
+                    { AP.grantObject    = AP.RXRole role
+                    , AP.grantContext   = uComponent
+                    , AP.grantTarget    = uCollab
+                    , AP.grantResult    =
+                        Just
+                            (encodeRouteLocal $
+                                ProjectCollabLiveR projectHash enableHash
+                            , Nothing
+                            )
+                    , AP.grantStart     = Just now
+                    , AP.grantEnd       = Nothing
+                    , AP.grantAllows    = AP.Invoke
+                    , AP.grantDelegates = Just uStart
+                    }
+                }
+
+        return (action, recipientSet, remoteActors, fwdHosts)
+
 -- Meaning: An actor A invited actor B to a resource
 -- Behavior:
 --      * Verify the resource is my collabs or components list
@@ -1341,6 +1592,7 @@ projectBehavior now projectID (Left verse@(Verse _authorIdMsig body)) =
         AP.AddActivity add       -> projectAdd now projectID verse add
         AP.CreateActivity create -> projectCreate now projectID verse create
         AP.FollowActivity follow -> projectFollow now projectID verse follow
+        AP.GrantActivity grant   -> projectGrant now projectID verse grant
         AP.InviteActivity invite -> projectInvite now projectID verse invite
         AP.JoinActivity join     -> projectJoin now projectID verse join
         AP.RejectActivity reject -> projectReject now projectID verse reject

src/Vervis/Data/Collab.hs

@@ -25,6 +25,7 @@ module Vervis.Data.Collab
     , parseInvite
     , parseJoin
     , parseGrant
+    , parseGrant'
     , parseAccept
     , parseReject
     , parseRemove
@@ -49,6 +50,10 @@ module Vervis.Data.Collab
     , ComponentBy (..)
     , hashComponent
     , componentActor
+    , resourceToComponent
+
+    , GrantRecipBy' (..)
+    , hashGrantRecip'
     )
 where
 
@@ -60,6 +65,7 @@ import Data.Bifunctor
 import Data.Bitraversable
 import Data.Functor.Identity
 import Data.Text (Text)
+import Data.Traversable
 import Database.Persist
 import Database.Persist.Types
 import GHC.Generics
@@ -279,7 +285,8 @@ parseGrant h (AP.Grant object context target mresult mstart mend allows deleg) =
         <*> pure mstart
         <*> pure mend
     where
-    parseContext lu = do
+    parseContext (ObjURI h' lu) = do
+        unless (h == h') $ throwE "Context and author aren't of same host"
         hl <- hostIsLocal h
         if hl
             then Left <$> do
@@ -312,6 +319,66 @@ parseGrant h (AP.Grant object context target mresult mstart mend allows deleg) =
                     "Grant target contains invalid hashid"
             else pure $ Right u
 
+parseGrant'
+    :: AP.Grant URIMode
+    -> ActE
+        ( AP.RoleExt
+        , Either (GrantResourceBy Key) FedURI
+        , Either (GrantRecipBy' Key) FedURI
+        , Maybe (LocalURI, Maybe Int)
+        , Maybe UTCTime
+        , Maybe UTCTime
+        , AP.Usage
+        , Maybe (Either (LocalActorBy Key, OutboxItemId) FedURI)
+        )
+parseGrant' (AP.Grant object context target mresult mstart mend allows deleg) =
+    (,,,,,,,)
+        <$> verifyRole object
+        <*> parseContext context
+        <*> parseTarget target
+        <*> pure
+                (fmap
+                    (\ (lu, md) -> (lu, (\ (AP.Duration i) -> i) <$> md))
+                    mresult
+                )
+        <*> pure mstart
+        <*> pure mend
+        <*> pure allows
+        <*> for deleg (fmap (first (\ (actor, _, item) -> (actor, item))) . parseActivityURI')
+    where
+    parseContext u@(ObjURI h lu) = do
+        hl <- hostIsLocal h
+        if hl
+            then Left <$> do
+                route <-
+                    fromMaybeE
+                        (decodeRouteLocal lu)
+                        "Grant context isn't a valid route"
+                resourceHash <-
+                    fromMaybeE
+                        (parseGrantResource route)
+                        "Grant context isn't a shared resource route"
+                unhashGrantResourceE'
+                    resourceHash
+                    "Grant resource contains invalid hashid"
+            else pure $ Right u
+    parseTarget u@(ObjURI h lu) = do
+        hl <- hostIsLocal h
+        if hl
+            then Left <$> do
+                route <-
+                    fromMaybeE
+                        (decodeRouteLocal lu)
+                        "Grant target isn't a valid route"
+                recipHash <-
+                    fromMaybeE
+                        (parseGrantRecip' route)
+                        "Grant target isn't a grant recipient route"
+                unhashGrantRecipE'
+                    recipHash
+                    "Grant target contains invalid hashid"
+            else pure $ Right u
+
 parseAccept (AP.Accept object mresult) = do
     --verifyNothingE mresult "Accept must not contain 'result'"
     first (\ (actor, _, item) -> (actor, item)) <$>
@@ -503,3 +570,39 @@ unhashComponentE c e = ExceptT $ maybe (Left e) Right <$> unhashComponent c
 componentActor (ComponentRepo r) = LocalActorRepo r
 componentActor (ComponentDeck d) = LocalActorDeck d
 componentActor (ComponentLoom l) = LocalActorLoom l
+
+resourceToComponent = \case
+    GrantResourceRepo k -> Just $ ComponentRepo k
+    GrantResourceDeck k -> Just $ ComponentDeck k
+    GrantResourceLoom k -> Just $ ComponentLoom k
+    GrantResourceProject _ -> Nothing
+
+data GrantRecipBy' f
+    = GrantRecipPerson' (f Person)
+    | GrantRecipProject' (f Project)
+    deriving (Generic, FunctorB, TraversableB, ConstraintsB)
+
+deriving instance AllBF Eq f GrantRecipBy' => Eq (GrantRecipBy' f)
+
+parseGrantRecip' (PersonR p)  = Just $ GrantRecipPerson' p
+parseGrantRecip' (ProjectR j) = Just $ GrantRecipProject' j
+parseGrantRecip' _            = Nothing
+
+hashGrantRecip' (GrantRecipPerson' k) =
+    GrantRecipPerson' <$> WAP.encodeKeyHashid k
+hashGrantRecip' (GrantRecipProject' k) =
+    GrantRecipProject' <$> WAP.encodeKeyHashid k
+
+unhashGrantRecipPure' ctx = f
+    where
+    f (GrantRecipPerson' p) =
+        GrantRecipPerson' <$> decodeKeyHashidPure ctx p
+    f (GrantRecipProject' p) =
+        GrantRecipProject' <$> decodeKeyHashidPure ctx p
+
+unhashGrantRecip' resource = do
+    ctx <- asksEnv WAP.stageHashidsContext
+    return $ unhashGrantRecipPure' ctx resource
+
+unhashGrantRecipE' resource e =
+    ExceptT $ maybe (Left e) Right <$> unhashGrantRecip' resource

src/Web/ActivityPub.hs

@@ -1868,7 +1868,7 @@ encodeFollow (Follow obj mcontext hide)
 
 data Grant u = Grant
     { grantObject   :: RoleExt
-    , grantContext  :: LocalURI
+    , grantContext  :: ObjURI u
     , grantTarget   :: ObjURI u
     , grantResult   :: Maybe (LocalURI, Maybe Duration)
     , grantStart    :: Maybe UTCTime
@@ -1881,7 +1881,7 @@ parseGrant :: UriMode u => Authority u -> Object -> Parser (Grant u)
 parseGrant h o =
     Grant
         <$> o .: "object"
-        <*> withAuthorityO h (o .: "context")
+        <*> o .: "context"
         <*> o .: "target"
         <*> (do mres <- o .:+? "result"
                 for mres $ \case
@@ -1897,7 +1897,7 @@ parseGrant h o =
 encodeGrant :: UriMode u => Authority u -> Grant u -> Series
 encodeGrant h (Grant obj context target mresult mstart mend allows mdelegates)
     =  "object"  .= obj
-    <> "context" .= ObjURI h context
+    <> "context" .= context
     <> "target"  .= target
     <> (case mresult of
         Nothing -> mempty