S2S: Group: Implement Add handler based on Project

src/Vervis/Actor/Group.hs

@@ -77,6 +77,526 @@ import Vervis.Persist.Actor
 import Vervis.Persist.Collab
 import Vervis.Persist.Discussion
 import Vervis.Ticket
+import Vervis.Web.Collab
+
+-- Meaning: An actor is adding some object to some target
+-- Behavior:
+--      * If the target is my children list:
+--        * Verify the object is a project, find in DB/HTTP
+--        * Verify the Add is authorized
+--        * Verify it's not already an active child of mine
+--        * Verify it's not already an active parent of mine
+--        * Verify it's not already in an Origin-Us process where I saw the Add
+--          and sent my Accept
+--        * Verify it's not already in an Origin-Them process, where I saw the
+--          Add and the potential child's Accept
+--        * Insert the Add to my inbox
+--        * Create a Dest record in DB
+--        * Forward the Add to my followers
+--        * Publish an Accept to:
+--          * The object project + followers
+--          * Add sender + followers
+--          * My followers
+--        * Record my Accept in the Dest record
+--
+--      * If the target is my parents list:
+--        * Verify the object is a project, find in DB/HTTP
+--        * Verify the Add is authorized
+--        * Verify it's not already an active parent of mine
+--        * Verify it's not already an active child of mine
+--        * Verify it's not already in an Origin-Us process where I saw the Add
+--          and sent my Accept
+--        * Verify it's not already in an Origin-Them process, where I saw the
+--          Add and the potential parent's Accept
+--        * Insert the Add to my inbox
+--        * Create a Source record in DB
+--        * Forward the Add to my followers
+--        * Publish an Accept to:
+--          * The object project + followers
+--          * Add sender + followers
+--          * My followers
+--        * Record my Accept in the Source record
+--
+--      * If I'm the object, being added to someone's parents/children list:
+--        * Verify the target is a project, find in DB/HTTP
+--        * Verify it's not already an active parent of mine
+--        * Verify it's not already an active child of mine
+--        * Verify it's not already in an Origin-Us process where I saw the Add
+--          and sent my Accept
+--        * Verify it's not already in an Origin-Them process, where I saw the
+--          Add and the potential parent/child's Accept
+--        * Insert the Add to my inbox
+--        * Create a Source/Dest record in DB
+--        * Forward the Add to my followers
+--
+--      * Otherwise, error
+groupAdd
+    :: UTCTime
+    -> GroupId
+    -> Verse
+    -> AP.Add URIMode
+    -> ActE (Text, Act (), Next)
+groupAdd now groupID (Verse authorIdMsig body) add = do
+
+    let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
+    (object, target, role) <- parseAdd author add
+    unless (role == AP.RoleAdmin) $
+        throwE "Add role isn't admin"
+    case (target, object) of
+        (Left (ATGroupChildren j), _) | j == groupID ->
+            addChildActive object
+        (Left (ATGroupParents j), _) | j == groupID ->
+            addParentActive object
+        (_, Left (LocalActorGroup j)) | j == groupID ->
+            case target of
+                Left (ATGroupParents j) | j /= groupID ->
+                    addChildPassive $ Left j
+                Left (ATGroupChildren j) | j /= groupID ->
+                    addParentPassive $ Left j
+                Right (ObjURI h luColl) -> do
+                    -- NOTE this is HTTP GET done synchronously in the activity
+                    -- handler
+                    manager <- asksEnv envHttpManager
+                    c <- AP.fetchAPID_T manager (AP.collectionId :: AP.Collection FedURI URIMode -> LocalURI) h luColl
+                    lu <- fromMaybeE (AP.collectionContext c) "No context"
+                    rwc <- AP.fetchRWC_T manager h lu
+                    AP.Actor l d <-
+                        case AP.rwcResource rwc of
+                            AP.ResourceActor a -> pure a
+                            AP.ResourceChild _ _ -> throwE "Add.target remote ResourceChild"
+                    let typ = AP.actorType d
+                    if typ == AP.ActorTypeTeam && Just luColl == AP.rwcSubteams rwc
+                        then addParentPassive $ Right $ ObjURI h lu
+                    else if typ == AP.ActorTypeTeam && Just luColl == AP.rwcParentsOrProjects rwc
+                        then addChildPassive $ Right $ ObjURI h lu
+                    else throwE "Weird collection situation"
+                _ -> throwE "I'm being added somewhere irrelevant"
+        _ -> throwE "This Add isn't for me"
+
+    where
+
+    prepareAccept childDB = do
+        encodeRouteHome <- getEncodeRouteHome
+
+        audAdder <- makeAudSenderWithFollowers authorIdMsig
+        audChild <-
+            case childDB of
+                Left (Entity j _) -> do
+                    jh <- encodeKeyHashid j
+                    return $ AudLocal [LocalActorGroup jh] []
+                Right (ObjURI h lu, Entity _ ra) ->
+                    return $ AudRemote h [lu] (maybeToList $ remoteActorFollowers ra)
+        audMe <-
+            AudLocal [] . pure . LocalStageGroupFollowers <$>
+                encodeKeyHashid groupID
+        uAdd <- lift $ getActivityURI authorIdMsig
+
+        let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+                collectAudience [audAdder, audChild, audMe]
+
+            recips = map encodeRouteHome audLocal ++ audRemote
+            action = AP.Action
+                { AP.actionCapability = Nothing
+                , AP.actionSummary    = Nothing
+                , AP.actionAudience   = AP.Audience recips [] [] [] [] []
+                , AP.actionFulfills   = [uAdd]
+                , AP.actionSpecific   = AP.AcceptActivity AP.Accept
+                    { AP.acceptObject   = uAdd
+                    , AP.acceptResult   = Nothing
+                    }
+                }
+
+        return (action, recipientSet, remoteActors, fwdHosts)
+
+    addParentActive parent = do
+
+        -- If parent is local, find it in our DB
+        -- If parent is remote, HTTP GET it, verify it's an actor of Group
+        -- type, and store in our DB (if it's already there, no need for HTTP)
+        --
+        -- NOTE: This is a blocking HTTP GET done right here in the handler,
+        -- which is NOT a good idea. Ideally, it would be done async, and the
+        -- handler result would be sent later in a separate (e.g. Accept) activity.
+        -- But for the PoC level, the current situation will hopefully do.
+        parentDB <-
+            bitraverse
+                (\case
+                    LocalActorGroup j -> withDBExcept $ getEntityE j "Parent not found in DB"
+                    _ -> throwE "Local proposed parent of non-group type"
+                )
+                (\ u@(ObjURI h lu) -> do
+                    instanceID <-
+                        lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
+                    result <-
+                        ExceptT $ first (T.pack . displayException) <$>
+                            fetchRemoteActor' instanceID h lu
+                    case result of
+                        Left Nothing -> throwE "Parent @id mismatch"
+                        Left (Just err) -> throwE $ T.pack $ displayException err
+                        Right Nothing -> throwE "Parent isn't an actor"
+                        Right (Just actor) -> do
+                            case remoteActorType $ entityVal actor of
+                                AP.ActorTypeTeam -> pure ()
+                                _ -> throwE "Remote parent type isn't Group"
+                            return (u, actor)
+                )
+                parent
+        let parentDB' = second (entityKey . snd) parentDB
+
+        -- Verify that a capability is provided
+        uCap <- do
+            let muCap = AP.activityCapability $ actbActivity body
+            fromMaybeE muCap "No capability provided"
+
+        -- Verify the sender is authorized by me to add a parent
+        verifyCapability''
+            uCap
+            authorIdMsig
+            (LocalResourceGroup groupID)
+            AP.RoleAdmin
+
+        maybeNew <- withDBExcept $ do
+
+            -- Grab me from DB
+            (group, actorRecip) <- lift $ do
+                p <- getJust groupID
+                (p,) <$> getJust (groupActor p)
+
+            -- Verify the object isn't a child of mine
+            verifyNoEnabledGroupChildren groupID parentDB'
+
+            -- Verify the object isn't already a parent of mine, and that no
+            -- Source record is already in Add-Accept state
+            verifyNoStartedGroupParents groupID parentDB'
+
+            -- Insert the Add to my inbox
+            mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
+            lift $ for mractid $ \ (inboxItemID, addDB) -> do
+
+                -- Create a Source record in DB
+                acceptID <- insertEmptyOutboxItem' (actorOutbox actorRecip) now
+                insertSource parentDB' addDB acceptID
+
+                -- Prepare forwarding the Add to my followers
+                sieve <- do
+                    groupHash <- encodeKeyHashid groupID
+                    return $ makeRecipientSet [] [LocalStageGroupFollowers groupHash]
+
+                -- Prepare an Accept activity and insert to my outbox
+                accept@(actionAccept, _, _, _) <- prepareAccept parentDB
+                _luAccept <- updateOutboxItem' (LocalActorGroup groupID) acceptID actionAccept
+
+                return (groupActor group, sieve, acceptID, accept, inboxItemID)
+
+        case maybeNew of
+            Nothing -> done "I already have this activity in my inbox"
+            Just (groupActorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept), inboxItemID) -> do
+                forwardActivity
+                    authorIdMsig body (LocalActorGroup groupID) groupActorID sieve
+                lift $ sendActivity
+                    (LocalActorGroup groupID) groupActorID localRecipsAccept
+                    remoteRecipsAccept fwdHostsAccept acceptID actionAccept
+                doneDB inboxItemID "Recorded a parent-group-in-progress, forwarded the Add, sent an Accept"
+
+        where
+
+        insertSource topicDB addDB acceptID = do
+            sourceID <- insert $ Source AP.RoleAdmin
+            holderID <- insert $ SourceHolderGroup sourceID groupID
+            case topicDB of
+                Left (Entity j _) -> do
+                    localID <- insert $ SourceTopicLocal sourceID
+                    insert_ $ SourceTopicGroup holderID localID j
+                Right a ->
+                    insert_ $ SourceTopicRemote sourceID a
+            usID <- insert $ SourceOriginUs sourceID
+            case addDB of
+                Left (_, _, addID) ->
+                    insert_ $ SourceUsGestureLocal usID addID
+                Right (author, _, addID) ->
+                    insert_ $ SourceUsGestureRemote usID (remoteAuthorId author) addID
+
+            insert_ $ SourceUsAccept usID acceptID
+
+    addChildActive child = do
+
+        -- If child is local, find it in our DB
+        -- If child is remote, HTTP GET it, verify it's an actor of Group
+        -- type, and store in our DB (if it's already there, no need for HTTP)
+        --
+        -- NOTE: This is a blocking HTTP GET done right here in the handler,
+        -- which is NOT a good idea. Ideally, it would be done async, and the
+        -- handler result would be sent later in a separate (e.g. Accept) activity.
+        -- But for the PoC level, the current situation will hopefully do.
+        childDB <-
+            bitraverse
+                (\case
+                    LocalActorGroup j -> withDBExcept $ getEntityE j "Child not found in DB"
+                    _ -> throwE "Local proposed child of non-group type"
+                )
+                (\ u@(ObjURI h lu) -> do
+                    instanceID <-
+                        lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
+                    result <-
+                        ExceptT $ first (T.pack . displayException) <$>
+                            fetchRemoteActor' instanceID h lu
+                    case result of
+                        Left Nothing -> throwE "Child @id mismatch"
+                        Left (Just err) -> throwE $ T.pack $ displayException err
+                        Right Nothing -> throwE "Child isn't an actor"
+                        Right (Just actor) -> do
+                            case remoteActorType $ entityVal actor of
+                                AP.ActorTypeTeam -> pure ()
+                                _ -> throwE "Remote child type isn't Group"
+                            return (u, actor)
+                )
+                child
+        let childDB' = second (entityKey . snd) childDB
+
+        -- Verify that a capability is provided
+        uCap <- do
+            let muCap = AP.activityCapability $ actbActivity body
+            fromMaybeE muCap "No capability provided"
+
+        -- Verify the sender is authorized by me to add a child
+        verifyCapability''
+            uCap
+            authorIdMsig
+            (LocalResourceGroup groupID)
+            AP.RoleTriage
+
+        maybeNew <- withDBExcept $ do
+
+            -- Grab me from DB
+            (group, actorRecip) <- lift $ do
+                p <- getJust groupID
+                (p,) <$> getJust (groupActor p)
+
+            -- Verify the object isn't a parent of mine
+            verifyNoEnabledGroupParents groupID childDB'
+
+            -- Verify the object isn't already a child of mine, and that no
+            -- Dest record is already in Add-Accept state
+            verifyNoStartedGroupChildren groupID childDB'
+
+            -- Insert the Add to my inbox
+            mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
+            lift $ for mractid $ \ (inboxItemID, addDB) -> do
+
+                -- Create a Dest record in DB
+                acceptID <- insertEmptyOutboxItem' (actorOutbox actorRecip) now
+                insertDest childDB' addDB acceptID
+
+                -- Prepare forwarding the Add to my followers
+                sieve <- do
+                    groupHash <- encodeKeyHashid groupID
+                    return $ makeRecipientSet [] [LocalStageGroupFollowers groupHash]
+
+                -- Prepare an Accept activity and insert to my outbox
+                accept@(actionAccept, _, _, _) <- prepareAccept childDB
+                _luAccept <- updateOutboxItem' (LocalActorGroup groupID) acceptID actionAccept
+
+                return (groupActor group, sieve, acceptID, accept, inboxItemID)
+
+        case maybeNew of
+            Nothing -> done "I already have this activity in my inbox"
+            Just (groupActorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept), inboxItemID) -> do
+                forwardActivity
+                    authorIdMsig body (LocalActorGroup groupID) groupActorID sieve
+                lift $ sendActivity
+                    (LocalActorGroup groupID) groupActorID localRecipsAccept
+                    remoteRecipsAccept fwdHostsAccept acceptID actionAccept
+                doneDB inboxItemID "Recorded a child-group-in-progress, forwarded the Add, sent an Accept"
+
+        where
+
+        insertDest topicDB addDB acceptID = do
+            destID <- insert $ Dest AP.RoleAdmin
+            holderID <- insert $ DestHolderGroup destID groupID
+            case topicDB of
+                Left (Entity j _) -> do
+                    localID <- insert $ DestTopicLocal destID
+                    insert_ $ DestTopicGroup holderID localID j
+                Right a ->
+                    insert_ $ DestTopicRemote destID a
+            insert_ $ DestOriginUs destID
+            case addDB of
+                Left (_, _, addID) ->
+                    insert_ $ DestUsGestureLocal destID addID
+                Right (author, _, addID) ->
+                    insert_ $ DestUsGestureRemote destID (remoteAuthorId author) addID
+
+            insert_ $ DestUsAccept destID acceptID
+
+    addParentPassive parent = do
+
+        -- If parent is local, find it in our DB
+        -- If parent is remote, HTTP GET it, verify it's an actor of Group
+        -- type, and store in our DB (if it's already there, no need for HTTP)
+        --
+        -- NOTE: This is a blocking HTTP GET done right here in the handler,
+        -- which is NOT a good idea. Ideally, it would be done async, and the
+        -- handler result would be sent later in a separate (e.g. Accept) activity.
+        -- But for the PoC level, the current situation will hopefully do.
+        parentDB <-
+            bitraverse
+                (\ j -> withDBExcept $ getEntityE j "Parent not found in DB")
+                (\ u@(ObjURI h lu) -> do
+                    instanceID <-
+                        lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
+                    result <-
+                        ExceptT $ first (T.pack . displayException) <$>
+                            fetchRemoteActor' instanceID h lu
+                    case result of
+                        Left Nothing -> throwE "Parent @id mismatch"
+                        Left (Just err) -> throwE $ T.pack $ displayException err
+                        Right Nothing -> throwE "Parent isn't an actor"
+                        Right (Just actor) -> do
+                            case remoteActorType $ entityVal actor of
+                                AP.ActorTypeTeam -> pure ()
+                                _ -> throwE "Remote parent type isn't Group"
+                            return (u, actor)
+                )
+                parent
+        let parentDB' = second (entityKey . snd) parentDB
+
+        maybeNew <- withDBExcept $ do
+
+            -- Grab me from DB
+            (group, actorRecip) <- lift $ do
+                p <- getJust groupID
+                (p,) <$> getJust (groupActor p)
+
+            -- Verify the target isn't a child of mine
+            verifyNoEnabledGroupChildren groupID parentDB'
+
+            -- Verify the target isn't already a parent of mine, and that no
+            -- Source record is already in Add-Accept state
+            verifyNoStartedGroupParents groupID parentDB'
+
+            -- Insert the Add to my inbox
+            mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
+            lift $ for mractid $ \ (inboxItemID, addDB) -> do
+
+                -- Create a Source record in DB
+                insertSource parentDB' addDB
+
+                -- Prepare forwarding the Add to my followers
+                sieve <- do
+                    groupHash <- encodeKeyHashid groupID
+                    return $ makeRecipientSet [] [LocalStageGroupFollowers groupHash]
+
+                return (groupActor group, sieve, inboxItemID)
+
+        case maybeNew of
+            Nothing -> done "I already have this activity in my inbox"
+            Just (groupActorID, sieve, inboxItemID) -> do
+                forwardActivity
+                    authorIdMsig body (LocalActorGroup groupID) groupActorID sieve
+                doneDB inboxItemID "Recorded a parent-group-in-progress, forwarded the Add"
+
+        where
+
+        insertSource topicDB addDB = do
+            sourceID <- insert $ Source AP.RoleAdmin
+            holderID <- insert $ SourceHolderGroup sourceID groupID
+            case topicDB of
+                Left (Entity j _) -> do
+                    localID <- insert $ SourceTopicLocal sourceID
+                    insert_ $ SourceTopicGroup holderID localID j
+                Right a ->
+                    insert_ $ SourceTopicRemote sourceID a
+            themID <- insert $ SourceOriginThem sourceID
+            case addDB of
+                Left (_, _, addID) ->
+                    insert_ $ SourceThemGestureLocal themID addID
+                Right (author, _, addID) ->
+                    insert_ $ SourceThemGestureRemote themID (remoteAuthorId author) addID
+
+    addChildPassive child = do
+
+        -- If child is local, find it in our DB
+        -- If child is remote, HTTP GET it, verify it's an actor of Group
+        -- type, and store in our DB (if it's already there, no need for HTTP)
+        --
+        -- NOTE: This is a blocking HTTP GET done right here in the handler,
+        -- which is NOT a good idea. Ideally, it would be done async, and the
+        -- handler result would be sent later in a separate (e.g. Accept) activity.
+        -- But for the PoC level, the current situation will hopefully do.
+        childDB <-
+            bitraverse
+                (\ j -> withDBExcept $ getEntityE j "Child not found in DB")
+                (\ u@(ObjURI h lu) -> do
+                    instanceID <-
+                        lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
+                    result <-
+                        ExceptT $ first (T.pack . displayException) <$>
+                            fetchRemoteActor' instanceID h lu
+                    case result of
+                        Left Nothing -> throwE "Child @id mismatch"
+                        Left (Just err) -> throwE $ T.pack $ displayException err
+                        Right Nothing -> throwE "Child isn't an actor"
+                        Right (Just actor) -> do
+                            case remoteActorType $ entityVal actor of
+                                AP.ActorTypeTeam -> pure ()
+                                _ -> throwE "Remote child type isn't Group"
+                            return (u, actor)
+                )
+                child
+        let childDB' = second (entityKey . snd) childDB
+
+        maybeNew <- withDBExcept $ do
+
+            -- Grab me from DB
+            (group, actorRecip) <- lift $ do
+                p <- getJust groupID
+                (p,) <$> getJust (groupActor p)
+
+            -- Verify the object isn't a parent of mine
+            verifyNoEnabledGroupParents groupID childDB'
+
+            -- Verify the object isn't already a child of mine, and that no
+            -- Dest record is already in Add-Accept state
+            verifyNoStartedGroupChildren groupID childDB'
+
+            -- Insert the Add to my inbox
+            mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
+            lift $ for mractid $ \ (inboxItemID, addDB) -> do
+
+                -- Create a Dest record in DB
+                insertDest childDB' addDB
+
+                -- Prepare forwarding the Add to my followers
+                sieve <- do
+                    groupHash <- encodeKeyHashid groupID
+                    return $ makeRecipientSet [] [LocalStageGroupFollowers groupHash]
+
+                return (groupActor group, sieve, inboxItemID)
+
+        case maybeNew of
+            Nothing -> done "I already have this activity in my inbox"
+            Just (groupActorID, sieve, inboxItemID) -> do
+                forwardActivity
+                    authorIdMsig body (LocalActorGroup groupID) groupActorID sieve
+                doneDB inboxItemID "Recorded a child-group-in-progress, forwarded the Add"
+
+        where
+
+        insertDest topicDB addDB = do
+            destID <- insert $ Dest AP.RoleAdmin
+            holderID <- insert $ DestHolderGroup destID groupID
+            case topicDB of
+                Left (Entity j _) -> do
+                    localID <- insert $ DestTopicLocal destID
+                    insert_ $ DestTopicGroup holderID localID j
+                Right a ->
+                    insert_ $ DestTopicRemote destID a
+            themID <- insert $ DestOriginThem destID
+            case addDB of
+                Left (_, _, addID) ->
+                    insert_ $ DestThemGestureLocal themID addID
+                Right (author, _, addID) ->
+                    insert_ $ DestThemGestureRemote themID (remoteAuthorId author) addID
 
 -- Meaning: An actor accepted something
 -- Behavior:
@@ -965,6 +1485,7 @@ groupBehavior :: UTCTime -> GroupId -> VerseExt -> ActE (Text, Act (), Next)
 groupBehavior now groupID (Left verse@(Verse _authorIdMsig body)) =
     case AP.activitySpecific $ actbActivity body of
         AP.AcceptActivity accept -> groupAccept now groupID verse accept
+        AP.AddActivity add       -> groupAdd now groupID verse add
         AP.CreateActivity create -> groupCreate now groupID verse create
         AP.FollowActivity follow -> groupFollow now groupID verse follow
         AP.GrantActivity grant   -> groupGrant now groupID verse grant