S2S: Group: Accept: Implement resource mode

src/Vervis/Actor/Group.hs

@@ -944,6 +944,41 @@ groupAdd now groupID (Verse authorIdMsig body) add = do
 --        delegation Grant I got from B
 --          * To: The parent/collaborator/team to whom I'd sent the Grant
 --          * CC: -
+--
+--  * Give me a new resource active   EffortOriginUs
+--      * Verify we haven't yet seen resource's Accept
+--      * Insert the Accept to my inbox
+--      * If sender is the resource, record the Accept into the Effort record
+--          * Prepare to send degelator-Grant
+--          * Otherwise nothing to do
+--      * Forward the Accept to my followers
+--      * Possibly send a Grant:
+--              * If sender is the resource
+--              * delegator-Grant
+--              * To: Resource
+--              * CC:
+--                  - Resource's followers
+--                  - My followers
+--
+--  * Give me a new resource passive  EffortOriginThem
+--      * Option 1: We haven't seen resource's Accept yet
+--          * Verify sender is the resource
+--      * Option 2: We saw it, but not my collaborator's Accept
+--          * Verify the Accept is authorized
+--      * Otherwise respond with error, no Accept is needed
+--      * Insert the Accept to my inbox
+--      * Option 1: Record resource's Accept in Effort record
+--      * Option 2: Record my collaborator's Accept
+--          * Prepare to send delegator-Grant
+--      * Forward the Accept to my followers
+--      * Possibly send a Grant:
+--          * In option 2
+--          * delegator-Grant
+--          * To: Resource
+--          * CC:
+--              - Resource's followers
+--              - My followers
+--              - The Accept sender (my collaborator)
 groupAccept
     :: UTCTime
     -> GroupId
@@ -972,8 +1007,10 @@ groupAccept now groupID (Verse authorIdMsig body) accept = do
         let adapt = maybe (Right Nothing) (either Left (Right . Just))
         maybeCollab <-
             ExceptT $ fmap adapt $ runMaybeT $
-                runExceptT (Left <$> tryInviteCollab accepteeDB) <|>
+                runExceptT (Left . Left <$> tryInviteCollab accepteeDB) <|>
-                runExceptT (Left <$> tryJoinCollab accepteeDB) <|>
+                runExceptT (Left . Left <$> tryJoinCollab accepteeDB) <|>
+                runExceptT (Left . Right <$> tryAddResourceActive accepteeDB) <|>
+                runExceptT (Left . Right <$> tryAddResourcePassive accepteeDB) <|>
                 runExceptT (Right . Left <$> tryAddChildActive accepteeDB) <|>
                 runExceptT (Right . Left <$> tryAddChildPassive accepteeDB) <|>
                 runExceptT (Right . Left <$> tryAddParentActive accepteeDB) <|>
@@ -984,7 +1021,8 @@ groupAccept now groupID (Verse authorIdMsig body) accept = do
             "Accepted activity isn't an Invite/Join/Add/Remove I'm aware of"
 
     case collabOrComp_or_child of
-        Left collab -> addCollab collab
+        Left (Left collab) -> addCollab collab
+        Left (Right resource) -> addResource resource
         Right (Left cp) -> addChildParent cp
         Right (Right parent) -> removeParent parent
 
@@ -1174,6 +1212,41 @@ groupAccept now groupID (Verse authorIdMsig body) accept = do
             lift $ MaybeT $ getValBy $ UniqueInboxItemRemote inboxID remoteActivityID
         tryRemoveParent' i
 
+    verifyEffortHolder :: EffortId -> MaybeT ActDB ()
+    verifyEffortHolder effortID = do
+        Effort _ g <- lift $ getJust effortID
+        guard $ g == groupID
+
+    tryAddResourceActive' usID = do
+        EffortOriginUs effortID <- lift . lift $ getJust usID
+        lift $ verifyEffortHolder effortID
+        topic <- lift . lift $ getEffortTopic effortID
+        return (effortID, topic, Left ())
+
+    tryAddResourceActive (Left (_actorByKey, _actorEntity, itemID)) = do
+        EffortUsGestureLocal usID _ <-
+            lift $ MaybeT $ getValBy $ UniqueEffortUsGestureLocalAdd itemID
+        tryAddResourceActive' usID
+    tryAddResourceActive (Right remoteActivityID) = do
+        EffortUsGestureRemote usID _ _ <-
+            lift $ MaybeT $ getValBy $ UniqueEffortUsGestureRemoteAdd remoteActivityID
+        tryAddResourceActive' usID
+
+    tryAddResourcePassive' themID = do
+        EffortOriginThem effortID <- lift . lift $ getJust themID
+        lift $ verifyEffortHolder effortID
+        topic <- lift . lift $ getEffortTopic effortID
+        return (effortID, topic, Right ())
+
+    tryAddResourcePassive (Left (_actorByKey, _actorEntity, itemID)) = do
+        EffortThemGestureLocal themID _ <-
+            lift $ MaybeT $ getValBy $ UniqueEffortThemGestureLocalAdd itemID
+        tryAddResourcePassive' themID
+    tryAddResourcePassive (Right remoteActivityID) = do
+        EffortThemGestureRemote themID _ _ <-
+            lift $ MaybeT $ getValBy $ UniqueEffortThemGestureRemoteAdd remoteActivityID
+        tryAddResourcePassive' themID
+
     componentIsAuthor ident =
         let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig
         in  author == bimap (resourceToActor . componentResource . snd) snd ident
@@ -1183,6 +1256,11 @@ groupAccept now groupID (Verse authorIdMsig body) accept = do
         let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig
         in  author == bimap (LocalActorGroup . snd) snd ident
 
+    theyIsAuthor' :: Either (a, LocalResourceBy Key) (b, RemoteActorId) -> Bool
+    theyIsAuthor' ident =
+        let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig
+        in  author == bimap (resourceToActor . snd) snd ident
+
     addCollab (collabID, fulfills, inviterOrJoiner) = do
 
         collab <-
@@ -1915,6 +1993,212 @@ groupAccept now groupID (Verse authorIdMsig body) accept = do
 
             return (action, recipientSet, remoteActors, fwdHosts)
 
+    addResource (effortID, topic', mode) = do
+
+        topic <-
+            lift $ traverseOf _Left (traverseOf _2 $ withDB . getLocalResource) topic'
+        mode' <-
+            bitraverse
+
+                -- Resource-active mode
+                -- Verify we haven't yet seen resource's Accept
+                (\ () -> do
+                    maybeResourceAccept <-
+                        lift $ withDB $
+                        case bimap fst fst topic of
+                            Left localID -> (() <$) <$> getBy (UniqueEffortThemAcceptLocal localID)
+                            Right remoteID -> (() <$) <$> getBy (UniqueEffortThemAcceptRemote remoteID)
+                    verifyNothingE maybeResourceAccept "I already saw resource's Accept"
+                )
+
+                -- Resource-passive mode
+                -- Option 1: We haven't seen resource's Accept yet
+                --   * Verify sender is the resource
+                -- Option 2: We saw it, but not my collaborator's Accept
+                --   * Verify the Accept is authorized
+                -- Otherwise respond with error, no Accept is needed
+                (\ () -> do
+                    (maybeResourceAccept, maybeGrant) <-
+                        lift $ withDB $ liftA2 (,)
+                            (case bimap fst fst topic of
+                                Left localID -> (() <$) <$> getBy (UniqueEffortThemAcceptLocal localID)
+                                Right remoteID -> (() <$) <$> getBy (UniqueEffortThemAcceptRemote remoteID)
+                            )
+                            (getBy $ UniqueEffortUsSendDelegator effortID)
+                    case (isJust maybeResourceAccept, isJust maybeGrant) of
+                        (False, True) -> error "Impossible/bug, didn't see resource's Accept but sent a Grant"
+                        (False, False) -> do
+                            unless (theyIsAuthor' topic) $
+                                throwE "The Accept I'm waiting for is from my new resource"
+                            return $ Left ()
+                        (True, False) -> do
+                            let muCap = AP.activityCapability $ actbActivity body
+                            uCap <- fromMaybeE muCap "No capability provided"
+                            verifyCapability''
+                                uCap
+                                authorIdMsig
+                                (LocalResourceGroup groupID)
+                                AP.RoleAdmin
+                            return $ Right ()
+                        (True, True) -> throwE "Resource already enabled, not needing any further Accept"
+                )
+
+                mode
+
+        maybeNew <- withDBExcept $ do
+
+            -- Grab me from DB
+            (recipActorID, recipActor) <- lift $ do
+                recip <- getJust groupID
+                let actorID = groupActor recip
+                (actorID,) <$> getJust actorID
+
+            maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False
+            for maybeAcceptDB $ \ (inboxItemID, acceptDB) -> do
+
+                idsForGrant <-
+                    lift $
+                    bitraverse
+
+                        -- Resource-active mode
+                        -- If sender is resource, record the Accept into the
+                        -- Effort record & prepare to send degelator-Grant
+                        -- Othrerwise do nothing
+                        (\ () ->
+                            if theyIsAuthor' topic
+                                then Just <$> do
+                                    case (topic, acceptDB) of
+                                        (Left (localID, _), Left (_, _, acceptID)) ->
+                                            insert_ $ EffortThemAcceptLocal localID acceptID
+                                        (Right (remoteID, _), Right (_, _, acceptID)) ->
+                                            insert_ $ EffortThemAcceptRemote remoteID acceptID
+                                        _ -> error "groupAccept impossible iv"
+                                    grantID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
+                                    insert_ $ EffortUsSendDelegator effortID grantID
+                                    return grantID
+                                else pure Nothing
+                        )
+
+                        -- Resource-passive mode
+                        (\case
+
+                            -- Getting an Accept from the resource
+                            -- Record resource's Accept in Effort record
+                            Left () -> do
+                                case (topic, acceptDB) of
+                                    (Left (localID, _), Left (_, _, acceptID)) ->
+                                        insert_ $ EffortThemAcceptLocal localID acceptID
+                                    (Right (remoteID, _), Right (_, _, acceptID)) ->
+                                        insert_ $ EffortThemAcceptRemote remoteID acceptID
+                                    _ -> error "groupAccept impossible v"
+                                return Nothing
+
+                            -- Getting an Accept from my collaborator
+                            -- Record my collaborator's Accept
+                            -- Prepare to send delegator-Grant
+                            Right () -> Just <$> do
+                                {-
+                                case (topic, acceptDB) of
+                                    (Left (localID, _), Left (_, _, acceptID)) ->
+                                        insert_ $ ? localID acceptID
+                                    (Right (remoteID, _), Right (_, _, acceptID)) ->
+                                        insert_ $ ? remoteID acceptID
+                                    _ -> error "groupAccept impossible iv"
+                                -}
+                                grantID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
+                                insert_ $ EffortUsSendDelegator effortID grantID
+                                return grantID
+                        )
+
+                        mode'
+
+                -- Prepare forwarding of Accept to my followers
+                let recipByID = LocalActorGroup groupID
+                recipByHash <- hashLocalActor recipByID
+                let sieve = makeRecipientSet [] [localActorFollowers recipByHash]
+
+                maybeAct <-
+                    case idsForGrant of
+                        Left mg -> for mg $ \ grantID -> lift $ do
+                            grant@(actionGrant, _, _, _) <-
+                                prepareEffortDelegGrant (bimap snd snd topic) False
+                            let recipByKey = LocalActorGroup groupID
+                            _luGrant <- updateOutboxItem' recipByKey grantID actionGrant
+                            return (grantID, grant)
+
+                        Right mg -> for mg $ \ grantID -> lift $ do
+                            grant@(actionGrant, _, _, _) <-
+                                prepareEffortDelegGrant (bimap snd snd topic) True
+                            let recipByKey = LocalActorGroup groupID
+                            _luGrant <- updateOutboxItem' recipByKey grantID actionGrant
+                            return (grantID, grant)
+
+                return (recipActorID, sieve, maybeAct, inboxItemID)
+
+        case maybeNew of
+            Nothing -> done "I already have this activity in my inbox"
+            Just (recipActorID, sieve, maybeGrant, inboxItemID) -> do
+                let recipByID = LocalActorGroup groupID
+                forwardActivity authorIdMsig body recipByID recipActorID sieve
+                lift $ for_ maybeGrant $ \ (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant)) ->
+                    sendActivity
+                        recipByID recipActorID localRecipsGrant
+                        remoteRecipsGrant fwdHostsGrant grantID actionGrant
+                doneDB inboxItemID "[Resource] Forwarded the Accept and maybe published a Grant/Accept"
+
+        where
+
+        prepareEffortDelegGrant ident includeAuthor = do
+            encodeRouteHome <- getEncodeRouteHome
+            encodeRouteLocal <- getEncodeRouteLocal
+
+            (uResource, audResource) <-
+                case ident of
+                    Left lr -> do
+                        la <- resourceToActor <$> hashLocalResource lr
+                        return
+                            ( encodeRouteHome $ renderLocalActor la
+                            , AudLocal [la] [localActorFollowers la]
+                            )
+                    Right raID -> do
+                        ra <- getJust raID
+                        u@(ObjURI h lu) <- getRemoteActorURI ra
+                        return
+                            ( u
+                            , AudRemote h [lu] (maybeToList $ remoteActorFollowers ra)
+                            )
+            audAuthor <- lift $ makeAudSenderOnly authorIdMsig
+            groupHash <- encodeKeyHashid groupID
+            let audGroup = AudLocal [] [LocalStageGroupFollowers groupHash]
+
+                audience =
+                    if includeAuthor
+                        then [audResource, audGroup, audAuthor]
+                        else [audResource, audGroup]
+
+                (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   = encodeRouteHome $ GroupR groupHash
+                        , AP.grantTarget    = uResource
+                        , AP.grantResult    = Nothing
+                        , AP.grantStart     = Just now
+                        , AP.grantEnd       = Nothing
+                        , AP.grantAllows    = AP.Invoke
+                        , AP.grantDelegates = Nothing
+                        }
+                    }
+
+            return (action, recipientSet, remoteActors, fwdHosts)
+
 -- Meaning: Someone has created a group with my ID URI
 -- Behavior:
 --     * Verify I'm in a just-been-created state