S2S: Person: Implement response to direct-Grant and extension-Grant

src/Vervis/Actor/Person.hs

@@ -805,6 +805,21 @@ personJoin now recipPersonID (Verse authorIdMsig body) join = do
 -- Meaning: An actor published a Grant
 -- Behavior:
 --      * Insert to my inbox
+--
+--      * If it's a direct-Grant that fulfills a Permit I have:
+--          * Verify the Permit isn't already enabled
+--          * Verify the sender is the Permit topic
+--          * Verify the role is identical to what was requested
+--          * Update the Permit record, storing the direct-Grant
+--          * Forward the direct-Grant to my followers
+--          * If topic is a Project or a Team:
+--              * Send a delegator-Grant to the topic
+--              * Update the Permit record, storing the delegator-Grant
+--
+--      * If it's a extension-Grant whose capability is a delegator-Grant from
+--        a Permit I have:
+--          * Verify the sender is the Permit topic
+--          * Update the Permit record, storing the extension-Grant
 personGrant
     :: UTCTime
     -> PersonId
@@ -814,9 +829,18 @@ personGrant
 personGrant now recipPersonID (Verse authorIdMsig body) grant = do
 
     -- Check input
-    target <- do
+    maybeMine <- do
-        --h <- lift $ objUriAuthority <$> getActorURI authorIdMsig
+        -- Verify the capability URI, if provided, is one of:
-        (_role, resource, recip, _mresult, _mstart, _mend, _usage, _mdeleg) <-
+        --   * Outbox item URI of a local actor, i.e. a local activity
+        --   * A remote URI
+        maybeCapability <-
+            for (AP.activityCapability $ actbActivity body) $ \ uCap ->
+                nameExceptT "Grant.capability" $
+                    first (\ (actor, _, item) -> (actor, item)) <$>
+                        parseActivityURI' uCap
+
+        -- Basic sanity checks
+        (role, resource, recip, _mresult, mstart, mend, usage, mdeleg) <-
             parseGrant' grant
         case (recip, authorIdMsig) of
             (Left (GrantRecipPerson' p), Left (LocalActorPerson p', _, _))
@@ -826,28 +850,259 @@ personGrant now recipPersonID (Verse authorIdMsig body) grant = do
                 | uRecip == remoteAuthorURI author ->
                     throwE "Grant sender and target are the same remote actor"
             _ -> pure ()
-        return recip
+        let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
+        case mdeleg of
+            Nothing ->
+                unless (author == resource) $
+                    throwE "Not an extension but resource and actor differ"
+            Just _ ->
+                when (author == resource) $
+                    throwE "Extension but resource and actor are identical"
 
-    maybeGrant <- withDBExcept $ do
+        -- For a direct-Grant, use 'fulfills' to identify the Permit
+        -- For an extension-Grant, use 'capability' for that
+        runMaybeT $ do
+            guard $ usage == AP.Invoke
+            guard $ recip == Left (GrantRecipPerson' recipPersonID)
+            lift $ do
+                for_ mstart $ \ start ->
+                    unless (start <= now) $
+                        throwE "Got a Grant that hasn't started"
+                for_ mend $ \ _ -> throwE "Got a Grant with expiration"
+            if isNothing mdeleg
+                then do
+                    uFulfills <-
+                        case AP.activityFulfills $ actbActivity body of
+                            [] -> mzero
+                            [u] -> pure u
+                            _ -> lift $ throwE "Multiple fulfills"
+                    fulfills <-
+                        lift $
+                        first (\ (actor, _, item) -> (actor, item)) <$>
+                            parseActivityURI' uFulfills
+                    return $ Left (role, fulfills)
+                else do
+                    cap <- lift $ fromMaybeE maybeCapability "Extension-Grant doesn't specify a delegator-Grant capability"
+                    delegatorID <-
+                        case cap of
+                            Left (LocalActorPerson p, itemID) | p == recipPersonID -> pure itemID
+                            _ -> lift $ throwE "Extending access to me using a delegator-Grant capability that isn't mine"
+                    return $ Right delegatorID
+
+    maybeNew <- withDBExcept $ do
 
         -- Grab me from DB
         (personRecip, actorRecip) <- lift $ do
             p <- getJust recipPersonID
             (p,) <$> getJust (personActor p)
 
-        mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True
+        maybePermit <-
-        for mractid $ \ _grantDB -> return $ personActor personRecip
+            for maybeMine $
+                bitraverse
+                    (\ (role, fulfills) -> do
 
-    case maybeGrant of
+                        -- Find my Permit record, verify the roles match
+                        fulfillsDB <- do
+                            a <- getActivity fulfills
+                            fromMaybeE a "Can't find fulfills in DB"
+                        (permitID, maybeGestureID) <- do
+                            mp <- runMaybeT $ do
+                                x@(pt, mg) <-
+                                    tryInvite fulfillsDB <|>
+                                    tryJoin fulfillsDB <|>
+                                    tryCreate fulfillsDB
+                                Permit p role' <- lift . lift $ getJust pt
+                                guard $ p == recipPersonID
+                                lift $ unless (role == AP.RXRole role') $
+                                    throwE "Requested and granted roles differ"
+                                return x
+                            fromMaybeE mp "Can't find a PermitFulfills*"
+
+                        -- If Permit fulfills an Invite, verify I've approved
+                        -- it
+                        gestureID <- fromMaybeE maybeGestureID "I'm getting this Grant but I haven't yet approved the Invite"
+
+                        -- Verify the Permit isn't already enabled
+                        topic <- lift $ getPermitTopic permitID
+                        maybeTopicEnable <-
+                            lift $ case bimap fst fst topic of
+                                Left localID -> void <$> getBy (UniquePermitTopicEnableLocalTopic localID)
+                                Right remoteID -> void <$> getBy (UniquePermitTopicEnableRemoteTopic remoteID)
+                        unless (isNothing maybeTopicEnable) $
+                            throwE "I've already received the direct-Grant"
+
+                        -- Verify the Grant sender is the Permit topic
+                        case (bimap snd snd topic, bimap (view _1) (view _1) authorIdMsig) of
+                            (Left la, Left la') | la == la' -> pure ()
+                            (Right raID, Right ra) | raID == remoteAuthorId ra -> pure ()
+                            _ -> throwE "Grant sender isn't the Permit topic"
+
+                        return (gestureID, bimap fst fst topic)
+                    )
+                    (\ delegatorID -> do
+                        Entity sendID (PermitPersonSendDelegator gestureID _) <- do
+                            mp <- lift $ getBy $ UniquePermitPersonSendDelegatorGrant delegatorID
+                            fromMaybeE mp "Extension-Grant.capability: I don't have such a delegator-Grant, can't find a PermitPersonSendDelegator record"
+                        PermitPersonGesture permitID _ <- lift $ getJust gestureID
+
+                        -- Verify the Grant sender is the Permit topic
+                        topic <- lift $ getPermitTopic permitID
+                        case (bimap snd snd topic, bimap (view _1) (view _1) authorIdMsig) of
+                            (Left la, Left la') | la == la' -> pure ()
+                            (Right raID, Right ra) | raID == remoteAuthorId ra -> pure ()
+                            _ -> throwE "Grant sender isn't the Permit topic"
+
+                        return (sendID, bimap fst fst topic)
+                    )
+
+        mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True
+        for mractid $ \ grantDB -> do
+
+            for maybePermit $
+                bitraverse
+                    (\ (gestureID, topic) -> lift $ do
+
+                        -- Update the Permit record, storing the direct-Grant
+                        case (topic, grantDB) of
+                            (Left localID, Left (_, _, grantID)) ->
+                                insert_ $ PermitTopicEnableLocal gestureID localID grantID
+                            (Right remoteID, Right (_, _, grantID)) ->
+                                insert_ $ PermitTopicEnableRemote gestureID remoteID grantID
+                            _ -> error "personGrant impossible"
+
+                        -- Prepare forwarding direct-Grant to my followers
+                        recipPersonHash <- encodeKeyHashid recipPersonID
+                        let sieve = makeRecipientSet [] [LocalStagePersonFollowers recipPersonHash]
+
+                         -- Prepapre delegator-Grant and update Permit
+                        needDeleg <-
+                            case grantDB of
+                                Left (la, _, _) ->
+                                    pure $ case la of
+                                        LocalActorProject _ -> True
+                                        LocalActorGroup _ -> True
+                                        _ -> False
+                                Right (author, _, _) -> do
+                                    ra <- getJust $ remoteAuthorId author
+                                    pure $ case remoteActorType ra of
+                                        AP.ActorTypeProject -> True
+                                        AP.ActorTypeTeam -> True
+                                        _ -> False
+                        maybeDeleg <-
+                            if needDeleg
+                                then Just <$> do
+                                    delegID <- insertEmptyOutboxItem' (actorOutbox actorRecip) now
+                                    deleg@(actionDeleg, _, _, _) <- prepareDelegGrant
+                                    let recipByKey = LocalActorPerson recipPersonID
+                                    _luDeleg <- updateOutboxItem' recipByKey delegID actionDeleg
+
+                                    insert_ $ PermitPersonSendDelegator gestureID delegID
+
+                                    return (delegID, deleg)
+                                else
+                                    pure Nothing
+
+                        return (personActor personRecip, sieve, maybeDeleg)
+                    )
+                    (\ (sendID, topic) ->
+                        case (topic, grantDB) of
+                            (Left localID, Left (_, _, extID)) -> lift $ do
+                                enableID <- do
+                                    me <- getKeyBy $ UniquePermitTopicEnableLocalTopic localID
+                                    case me of
+                                        Just e -> pure e
+                                        Nothing -> error "Impossible, Permit has the delegator-Grant but no (local) Enable"
+                                insert_ $ PermitTopicExtendLocal sendID enableID extID
+                            (Right remoteID, Right (_, _, extID)) -> lift $ do
+                                enableID <- do
+                                    me <- getKeyBy $ UniquePermitTopicEnableRemoteTopic remoteID
+                                    case me of
+                                        Just e -> pure e
+                                        Nothing -> error "Impossible, Permit has the delegator-Grant but no (remote) Enable"
+                                insert_ $ PermitTopicExtendRemote sendID enableID extID
+                            _ -> error "personGrant impossible 2"
+                    )
+
+    case maybeNew of
         Nothing -> done "I already have this activity in my inbox"
-        Just _actorID -> do
+        Just Nothing -> done "Inserted Grant to my inbox"
-            let targetIsRecip =
+        Just (Just (Left (recipActorID, sieve, maybeDeleg))) -> do
-                    case target of
+            let recipByID = LocalActorPerson recipPersonID
-                        Left (GrantRecipPerson' p) -> p == recipPersonID
+            forwardActivity authorIdMsig body recipByID recipActorID sieve
-                        _ -> False
+            lift $ for_ maybeDeleg $ \ (delegID, (actionDeleg, localRecipsDeleg, remoteRecipsDeleg, fwdHostsDeleg)) ->
-            if not targetIsRecip
+                sendActivity
-                then done "I'm not the target; Inserted to inbox"
+                    recipByID recipActorID localRecipsDeleg
-                else done "I'm the target; Inserted to inbox"
+                    remoteRecipsDeleg fwdHostsDeleg delegID actionDeleg
+            done "Forwarded the direct-Grant, updated Permit, maybe published delegator-Grant"
+        Just (Just (Right ())) ->
+            done "Got an extension-Grant, updated Permit"
+
+    where
+
+    tryInvite fulfillsDB = do
+        fulfillsID <-
+            case fulfillsDB of
+                Left (_actorByKey, _actorEntity, itemID) -> do
+                    PermitTopicGestureLocal fulfillsID _ <-
+                        MaybeT $ lift $ getValBy $ UniquePermitTopicGestureLocalInvite itemID
+                    return fulfillsID
+                Right remoteActivityID -> do
+                    PermitTopicGestureRemote fulfillsID _ _ <-
+                        MaybeT $ lift $ getValBy $ UniquePermitTopicGestureRemoteInvite remoteActivityID
+                    return fulfillsID
+        PermitFulfillsInvite permitID <- lift . lift $ getJust fulfillsID
+        maybeGestureID <- lift . lift $ getKeyBy $ UniquePermitPersonGesture permitID
+        return (permitID, maybeGestureID)
+
+    tryJoin fulfillsDB = do
+        Entity gestureID (PermitPersonGesture permitID _) <-
+            case fulfillsDB of
+                Left (_actorByKey, _actorEntity, itemID) ->
+                    MaybeT $ lift $ getBy $ UniquePermitPersonGestureActivity itemID
+                Right _remoteActivityID -> mzero
+        _ <- MaybeT $ lift $ getBy $ UniquePermitFulfillsJoin permitID
+        return (permitID, Just gestureID)
+
+    tryCreate fulfillsDB = do
+        Entity gestureID (PermitPersonGesture permitID _) <-
+            case fulfillsDB of
+                Left (_actorByKey, _actorEntity, itemID) ->
+                    MaybeT $ lift $ getBy $ UniquePermitPersonGestureActivity itemID
+                Right _remoteActivityID -> mzero
+        _ <- MaybeT $ lift $ getBy $ UniquePermitFulfillsTopicCreation permitID
+        return (permitID, Just gestureID)
+
+    prepareDelegGrant = do
+        encodeRouteHome <- getEncodeRouteHome
+        encodeRouteLocal <- getEncodeRouteLocal
+
+        personHash <- encodeKeyHashid recipPersonID
+        audTopic <- lift $ makeAudSenderOnly authorIdMsig
+        uTopic <- lift $ getActorURI authorIdMsig
+        uDirectGrant <- lift $ getActivityURI authorIdMsig
+
+        let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+                collectAudience [audTopic]
+
+            recips = map encodeRouteHome audLocal ++ audRemote
+            action = AP.Action
+                { AP.actionCapability = Just uDirectGrant
+                , AP.actionSummary    = Nothing
+                , AP.actionAudience   = AP.Audience recips [] [] [] [] []
+                , AP.actionFulfills   = [uDirectGrant]
+                , AP.actionSpecific   = AP.GrantActivity AP.Grant
+                    { AP.grantObject    = AP.RXDelegator
+                    , AP.grantContext   = encodeRouteHome $ PersonR personHash
+                    , AP.grantTarget    = uTopic
+                    , AP.grantResult    = Nothing
+                    , AP.grantStart     = Just now
+                    , AP.grantEnd       = Nothing
+                    , AP.grantAllows    = AP.Invoke
+                    , AP.grantDelegates = Nothing
+                    }
+                }
+
+        return (action, recipientSet, remoteActors, fwdHosts)
 
 -- Meaning: An actor has revoked some previously published Grants
 -- Behavior: Insert to my inbox