diff --git a/src/Vervis/Actor/Person.hs b/src/Vervis/Actor/Person.hs index 9daba29..db8c47e 100644 --- a/src/Vervis/Actor/Person.hs +++ b/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 - --h <- lift $ objUriAuthority <$> getActorURI authorIdMsig - (_role, resource, recip, _mresult, _mstart, _mend, _usage, _mdeleg) <- + maybeMine <- do + -- Verify the capability URI, if provided, is one of: + -- * 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 - for mractid $ \ _grantDB -> return $ personActor personRecip + maybePermit <- + 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 - let targetIsRecip = - case target of - Left (GrantRecipPerson' p) -> p == recipPersonID - _ -> False - if not targetIsRecip - then done "I'm not the target; Inserted to inbox" - else done "I'm the target; Inserted to inbox" + Just Nothing -> done "Inserted Grant to my inbox" + Just (Just (Left (recipActorID, sieve, maybeDeleg))) -> do + let recipByID = LocalActorPerson recipPersonID + forwardActivity authorIdMsig body recipByID recipActorID sieve + lift $ for_ maybeDeleg $ \ (delegID, (actionDeleg, localRecipsDeleg, remoteRecipsDeleg, fwdHostsDeleg)) -> + sendActivity + recipByID recipActorID localRecipsDeleg + 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