S2S: Component: Implement Add-based version of inviteComponent

src/Vervis/Actor/Common.hs

@@ -1891,9 +1891,8 @@ componentGrant grabResource topicComponent now recipKey (Verse authorIdMsig body
 
 -- Meaning: An actor is adding some object to some target
 -- Behavior:
---  * If the object is me:
+--  * If target is my context (i.e. parents) collection:
---      * Verify that the object is me
+--      * Verify the object is a project
---      * Verify the target is some project's components collection URI
 --      * Verify the Add is authorized
 --      * For all the Stem records I have for this project:
 --          * Verify I'm not yet a member of the project
@@ -1911,6 +1910,19 @@ componentGrant grabResource topicComponent now recipKey (Verse authorIdMsig body
 --              * Author's followers
 --              * Project's followers
 --              * My followers
+--
+--  * If the object is me:
+--      * Verify the target is some project's components collection URI
+--      * For each Stem record I have for this project:
+--          * Verify it's not enabled yet, i.e. I'm not already a component
+--            of this project
+--          * Verify it's not in them-Invite-Accept state, already got the
+--            project's Accept and waiting for my approval
+--          * Verify it's not in us-Add-Accept state, has my approval and
+--            waiting for the project's side
+--      * Create a Stem record in DB
+--      * Insert the Add to my inbox
+--      * Forward the Add to my followers
 componentAdd
     :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
     => (topic -> KomponentId)
@@ -1922,183 +1934,293 @@ componentAdd
     -> ActE (Text, Act (), Next)
 componentAdd grabKomponent toComponent now meID (Verse authorIdMsig body) add = do
 
-    let meComponent = toComponent meID
+    let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
-        meResource = componentResource meComponent
+    (object, target, role) <- parseAdd author add
-        meActor = resourceToActor meResource
+    unless (role == AP.RoleAdmin) $
-
+        throwE "Add role isn't admin"
-    -- Check capability
+    case (target, object) of
-    capability <- do
+        (Left at, _)
-
+            | addTargetComponentProjects at == Just (toComponent meID) -> 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 "Add 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 input
-    projectComps <- do
-        let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
-        (component, projectComps, role) <- parseAdd author add
-        unless (component == Left meActor) $
-            throwE "Add object isn't me"
-        unless (role == AP.RoleAdmin) $
-            throwE "Add role isn't admin"
-        case projectComps of
-            Left (ATProjectComponents j) -> return $ Left j
-            Right u -> return $ Right u
-            _ -> throwE "I'm being added somewhere invalid"
-
-    -- If project is local, find it in our DB
-    -- If project is remote, HTTP GET it 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.
-    projectDB <-
-        bitraverse
-            (withDBExcept . flip getEntityE "Project not found in DB")
-            (\ u@(ObjURI h luComps) -> do
-                manager <- asksEnv envHttpManager
-                collection <-
-                    ExceptT $ first T.pack <$>
-                        AP.fetchAPID
-                            manager
-                            (AP.collectionId :: AP.Collection FedURI URIMode -> LocalURI)
-                            h
-                            luComps
-                luProject <- fromMaybeE (AP.collectionContext collection) "Collection has no context"
                 project <-
-                    ExceptT $ first T.pack <$>
+                    bitraverse
-                        AP.fetchAPID manager (AP.actorId . AP.actorLocal . AP.projectActor) h luProject
+                        (\case
-                unless (AP.projectComponents project == luComps) $
+                            LocalActorProject j -> pure j
-                    throwE "The collection isn't the project's components collection"
+                            _ -> throwE "Adding me to a local non-project"
-
+                        )
-                instanceID <-
+                        pure
-                    lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
+                        object
-                result <-
+                addProjectActive role project
-                    ExceptT $ first (T.pack . displayException) <$>
+        (_, Left la)
-                        fetchRemoteActor' instanceID h luProject
+            | resourceToActor (componentResource $ toComponent meID) == la -> do
-                case result of
+                case target of
-                    Left Nothing -> throwE "Target @id mismatch"
+                    Left (ATProjectComponents j) ->
-                    Left (Just err) -> throwE $ T.pack $ displayException err
+                        addProjectPassive role $ Left j
-                    Right Nothing -> throwE "Target isn't an actor"
+                    Right (ObjURI h luColl) -> do
-                    Right (Just actor) -> do
+                        -- NOTE this is HTTP GET done synchronously in the activity
-                        unless (remoteActorType (entityVal actor) == AP.ActorTypeProject) $
+                        -- handler
-                            throwE "Remote project type isn't Project"
+                        manager <- asksEnv envHttpManager
-                        return $ entityKey actor
+                        c <- AP.fetchAPID_T manager (AP.collectionId :: AP.Collection FedURI URIMode -> LocalURI) h luColl
-            )
+                        lu <- fromMaybeE (AP.collectionContext c) "No context"
-            projectComps
+                        j <- AP.fetchAPID_T manager (AP.actorId . AP.actorLocal . AP.projectActor) h lu
-
+                        if luColl == AP.projectComponents j
-    meHash <- encodeKeyHashid meID
+                            then addProjectPassive role $ Right $ ObjURI h lu
-    let meComponentHash = toComponent meHash
+                            else throwE "Non-components collection"
-        meResourceHash = componentResource meComponentHash
+                    _ -> throwE "I'm being added somewhere irrelevant"
-        meActorHash = resourceToActor meResourceHash
+        _ -> throwE "This Add isn't for me"
-
-    maybeNew <- withDBExcept $ do
-
-        -- Grab me from DB
-        komponentID <- lift $ grabKomponent <$> getJust meID
-        Komponent resourceID <- lift $ getJust komponentID
-        Resource meActorID <- lift $ getJust resourceID
-        actor <- lift $ getJust meActorID
-
-        -- Find existing Stem records I have for this project
-        -- Make sure none are enabled / in Add-Accept mode / in Invite-Accept
-        -- mode
-        checkExistingStems komponentID projectDB
-
-        -- Verify the specified capability gives relevant access
-        verifyCapability' capability authorIdMsig meResource AP.RoleAdmin
-
-        -- Insert the Add to my inbox
-        mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actor) False
-        lift $ for mractid $ \ (inboxItemID, addDB) -> do
-
-            -- Create a Stem record in DB
-            acceptID <- insertEmptyOutboxItem' (actorOutbox actor) now
-            insertStem komponentID projectDB addDB acceptID
-
-            -- Prepare forwarding Add to my followers
-            let sieve = makeRecipientSet [] [localActorFollowers meActorHash]
-
-            -- Prepare an Accept activity and insert to my outbox
-            accept@(actionAccept, _, _, _) <- prepareAccept projectDB
-            _luAccept <- updateOutboxItem' meActor acceptID actionAccept
-
-            return (meActorID, sieve, acceptID, accept, inboxItemID)
-
-    case maybeNew of
-        Nothing -> done "I already have this activity in my inbox"
-        Just (actorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept), inboxItemID) -> do
-            forwardActivity authorIdMsig body meActor actorID sieve
-            lift $ sendActivity
-                meActor actorID localRecipsAccept
-                remoteRecipsAccept fwdHostsAccept acceptID actionAccept
-            doneDB inboxItemID "Recorded and forwarded the Add, sent an Accept"
 
     where
 
-    insertStem komponentID projectDB addDB acceptID = do
+    addProjectActive role project = do
-        stemID <- insert $ Stem AP.RoleAdmin komponentID
-        case projectDB of
-            Left (Entity projectID _) ->
-                insert_ $ StemProjectLocal stemID projectID
-            Right remoteActorID ->
-                insert_ $ StemProjectRemote stemID remoteActorID
-        insert_ $ StemOriginAdd stemID
-        case addDB of
-            Left (_, _, addID) ->
-                insert_ $ StemComponentGestureLocal stemID addID
-            Right (author, _, addID) ->
-                insert_ $ StemComponentGestureRemote stemID (remoteAuthorId author) addID
-        insert_ $ StemComponentAccept stemID acceptID
 
-    prepareAccept projectDB = do
+        let meComponent = toComponent meID
-        encodeRouteHome <- getEncodeRouteHome
+            meResource = componentResource meComponent
+            meActor = resourceToActor meResource
 
-        audAdder <- makeAudSenderWithFollowers authorIdMsig
+        -- Check capability
-        audProject <-
+        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 "Add 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 input
+        unless (role == AP.RoleAdmin) $ throwE "Add role isn't admin"
+
+        -- If project is local, find it in our DB
+        -- If project is remote, HTTP GET it 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.
+        projectDB <-
+            bitraverse
+                (withDBExcept . flip getEntityE "Project not found in DB")
+                (\ u@(ObjURI h luProject) -> do
+                    manager <- asksEnv envHttpManager
+                    project <-
+                        ExceptT $ first T.pack <$>
+                            AP.fetchAPID manager (AP.actorId . AP.actorLocal . AP.projectActor) h luProject
+                    instanceID <-
+                        lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
+                    result <-
+                        ExceptT $ first (T.pack . displayException) <$>
+                            fetchRemoteActor' instanceID h luProject
+                    case result of
+                        Left Nothing -> throwE "Target @id mismatch"
+                        Left (Just err) -> throwE $ T.pack $ displayException err
+                        Right Nothing -> throwE "Target isn't an actor"
+                        Right (Just actor) -> do
+                            unless (remoteActorType (entityVal actor) == AP.ActorTypeProject) $
+                                throwE "Remote project type isn't Project"
+                            return $ entityKey actor
+                )
+                project
+
+        meHash <- encodeKeyHashid meID
+        let meComponentHash = toComponent meHash
+            meResourceHash = componentResource meComponentHash
+            meActorHash = resourceToActor meResourceHash
+
+        maybeNew <- withDBExcept $ do
+
+            -- Grab me from DB
+            komponentID <- lift $ grabKomponent <$> getJust meID
+            Komponent resourceID <- lift $ getJust komponentID
+            Resource meActorID <- lift $ getJust resourceID
+            actor <- lift $ getJust meActorID
+
+            -- Find existing Stem records I have for this project
+            -- Make sure none are enabled / in Add-Accept mode / in Invite-Accept
+            -- mode
+            checkExistingStems komponentID projectDB
+
+            -- Verify the specified capability gives relevant access
+            verifyCapability' capability authorIdMsig meResource AP.RoleAdmin
+
+            -- Insert the Add to my inbox
+            mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actor) False
+            lift $ for mractid $ \ (inboxItemID, addDB) -> do
+
+                -- Create a Stem record in DB
+                acceptID <- insertEmptyOutboxItem' (actorOutbox actor) now
+                insertStem komponentID projectDB addDB acceptID
+
+                -- Prepare forwarding Add to my followers
+                let sieve = makeRecipientSet [] [localActorFollowers meActorHash]
+
+                -- Prepare an Accept activity and insert to my outbox
+                accept@(actionAccept, _, _, _) <- prepareAccept projectDB
+                _luAccept <- updateOutboxItem' meActor acceptID actionAccept
+
+                return (meActorID, sieve, acceptID, accept, inboxItemID)
+
+        case maybeNew of
+            Nothing -> done "I already have this activity in my inbox"
+            Just (actorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept), inboxItemID) -> do
+                forwardActivity authorIdMsig body meActor actorID sieve
+                lift $ sendActivity
+                    meActor actorID localRecipsAccept
+                    remoteRecipsAccept fwdHostsAccept acceptID actionAccept
+                doneDB inboxItemID "[Add-project-active] Recorded and forwarded the Add, sent an Accept"
+
+        where
+
+        insertStem komponentID projectDB addDB acceptID = do
+            stemID <- insert $ Stem AP.RoleAdmin komponentID
             case projectDB of
-                Left (Entity j _) -> do
+                Left (Entity projectID _) ->
-                    jh <- encodeKeyHashid j
+                    insert_ $ StemProjectLocal stemID projectID
-                    return $
+                Right remoteActorID ->
-                        AudLocal
+                    insert_ $ StemProjectRemote stemID remoteActorID
-                            [LocalActorProject jh]
+            insert_ $ StemOriginAdd stemID
-                            [LocalStageProjectFollowers jh]
+            case addDB of
-                Right remoteActorID -> do
+                Left (_, _, addID) ->
-                    ra <- getJust remoteActorID
+                    insert_ $ StemComponentGestureLocal stemID addID
-                    ObjURI h lu <- getRemoteActorURI ra
+                Right (author, _, addID) ->
-                    return $ AudRemote h [lu] (maybeToList $ remoteActorFollowers ra)
+                    insert_ $ StemComponentGestureRemote stemID (remoteAuthorId author) addID
-        audComponent <-
+            insert_ $ StemComponentAccept stemID acceptID
-            AudLocal [] . pure . localActorFollowers <$>
-                hashLocalActor (resourceToActor $ componentResource $ toComponent meID)
-        uAdd <- lift $ getActivityURI authorIdMsig
 
-        let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+        prepareAccept projectDB = do
-                collectAudience [audAdder, audProject, audComponent]
+            encodeRouteHome <- getEncodeRouteHome
 
-            recips = map encodeRouteHome audLocal ++ audRemote
+            audAdder <- makeAudSenderWithFollowers authorIdMsig
-            action = AP.Action
+            audProject <-
-                { AP.actionCapability = Nothing
+                case projectDB of
-                , AP.actionSummary    = Nothing
+                    Left (Entity j _) -> do
-                , AP.actionAudience   = AP.Audience recips [] [] [] [] []
+                        jh <- encodeKeyHashid j
-                , AP.actionFulfills   = [uAdd]
+                        return $
-                , AP.actionSpecific   = AP.AcceptActivity AP.Accept
+                            AudLocal
-                    { AP.acceptObject   = uAdd
+                                [LocalActorProject jh]
-                    , AP.acceptResult   = Nothing
+                                [LocalStageProjectFollowers jh]
+                    Right remoteActorID -> do
+                        ra <- getJust remoteActorID
+                        ObjURI h lu <- getRemoteActorURI ra
+                        return $ AudRemote h [lu] (maybeToList $ remoteActorFollowers ra)
+            audComponent <-
+                AudLocal [] . pure . localActorFollowers <$>
+                    hashLocalActor (resourceToActor $ componentResource $ toComponent meID)
+            uAdd <- lift $ getActivityURI authorIdMsig
+
+            let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+                    collectAudience [audAdder, audProject, audComponent]
+
+                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)
+            return (action, recipientSet, remoteActors, fwdHosts)
+
+    addProjectPassive role project = do
+
+        let meComponent = toComponent meID
+            meResource = componentResource meComponent
+            meActor = resourceToActor meResource
+
+        -- Check input
+        unless (role == AP.RoleAdmin) $ throwE "Add role isn't admin"
+
+        -- If project is local, find it in our DB
+        -- If project is remote, HTTP GET it 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.
+        projectDB <-
+            bitraverse
+                (withDBExcept . flip getEntityE "Project not found in DB")
+                (\ u@(ObjURI h luProject) -> do
+                    manager <- asksEnv envHttpManager
+                    project <-
+                        ExceptT $ first T.pack <$>
+                            AP.fetchAPID manager (AP.actorId . AP.actorLocal . AP.projectActor) h luProject
+                    instanceID <-
+                        lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
+                    result <-
+                        ExceptT $ first (T.pack . displayException) <$>
+                            fetchRemoteActor' instanceID h luProject
+                    case result of
+                        Left Nothing -> throwE "Target @id mismatch"
+                        Left (Just err) -> throwE $ T.pack $ displayException err
+                        Right Nothing -> throwE "Target isn't an actor"
+                        Right (Just actor) -> do
+                            unless (remoteActorType (entityVal actor) == AP.ActorTypeProject) $
+                                throwE "Remote project type isn't Project"
+                            return $ entityKey actor
+                )
+                project
+
+        meHash <- encodeKeyHashid meID
+        let meComponentHash = toComponent meHash
+            meResourceHash = componentResource meComponentHash
+            meActorHash = resourceToActor meResourceHash
+
+        maybeNew <- withDBExcept $ do
+
+            -- Grab me from DB
+            komponentID <- lift $ grabKomponent <$> getJust meID
+            Komponent resourceID <- lift $ getJust komponentID
+            Resource meActorID <- lift $ getJust resourceID
+            actor <- lift $ getJust meActorID
+
+            -- Find existing Stem records I have for this project
+            -- Make sure none are enabled / in Add-Accept mode / in Invite-Accept
+            -- mode
+            checkExistingStems komponentID projectDB
+
+            -- Insert the Add to my inbox
+            mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actor) False
+            lift $ for mractid $ \ (inboxItemID, addDB) -> do
+
+                -- Create a Stem record in DB
+                insertStem komponentID projectDB addDB
+
+                -- Prepare forwarding Add to my followers
+                let sieve = makeRecipientSet [] [localActorFollowers meActorHash]
+
+                return (meActorID, sieve, inboxItemID)
+
+        case maybeNew of
+            Nothing -> done "I already have this activity in my inbox"
+            Just (actorID, sieve, inboxItemID) -> do
+                forwardActivity authorIdMsig body meActor actorID sieve
+                doneDB inboxItemID "[Add-parent-passive] Recorded and forwarded the Add"
+
+        where
+
+        insertStem komponentID projectDB addDB = do
+            stemID <- insert $ Stem AP.RoleAdmin komponentID
+            case projectDB of
+                Left (Entity projectID _) ->
+                    insert_ $ StemProjectLocal stemID projectID
+                Right remoteActorID ->
+                    insert_ $ StemProjectRemote stemID remoteActorID
+            originID <- insert $ StemOriginInvite stemID
+            case addDB of
+                Left (_, _, addID) ->
+                    insert_ $ StemProjectGestureLocal originID addID
+                Right (author, _, addID) ->
+                    insert_ $ StemProjectGestureRemote originID (remoteAuthorId author) addID

src/Vervis/Data/Collab.hs

@@ -31,6 +31,7 @@ module Vervis.Data.Collab
     , parseRemove
     , AddTarget (..)
     , addTargetResource
+    , addTargetComponentProjects
     , parseAdd
 
     , ComponentBy (..)
@@ -421,6 +422,9 @@ data AddTarget
     | ATProjectChildren ProjectId
     | ATGroupParents GroupId
     | ATGroupChildren GroupId
+    | ATRepoProjects RepoId
+    | ATDeckProjects DeckId
+    | ATLoomProjects LoomId
     deriving Eq
 
 addTargetResource :: AddTarget -> LocalResourceBy Key
@@ -430,6 +434,15 @@ addTargetResource = \case
     ATProjectChildren j -> LocalResourceProject j
     ATGroupParents g -> LocalResourceGroup g
     ATGroupChildren g -> LocalResourceGroup g
+    ATRepoProjects r -> LocalResourceRepo r
+    ATDeckProjects d -> LocalResourceDeck d
+    ATLoomProjects l -> LocalResourceLoom l
+
+addTargetComponentProjects = \case
+    ATRepoProjects r -> Just $ ComponentRepo r
+    ATDeckProjects d -> Just $ ComponentDeck d
+    ATLoomProjects l -> Just $ ComponentLoom l
+    _ -> Nothing
 
 parseAdd
     :: StageRoute Env ~ Route App
@@ -478,6 +491,15 @@ parseAdd sender (AP.Add object target role _context) = do
                 GroupChildrenR g ->
                     ATGroupChildren <$>
                     WAP.decodeKeyHashidE g "Inavlid team children hashid"
+                RepoProjectsR r ->
+                    ATRepoProjects <$>
+                    WAP.decodeKeyHashidE r "Inavlid repo projects hashid"
+                DeckProjectsR d ->
+                    ATDeckProjects <$>
+                    WAP.decodeKeyHashidE d "Inavlid deck projects hashid"
+                LoomProjectsR l ->
+                    ATLoomProjects <$>
+                    WAP.decodeKeyHashidE l "Inavlid loom projects hashid"
                 _ -> throwE "Not an Add target collection route"
             )
             pure

src/Vervis/Foundation.hs

@@ -930,6 +930,7 @@ instance YesodBreadcrumbs App where
         RepoStampR r k -> ("Stamp #" <> keyHashidText k, Just $ RepoR r)
 
         RepoCollabsR r -> ("Collaborators", Just $ RepoR r)
+        RepoProjectsR r -> ("Projects", Just $ RepoR r)
 
         DeckR d             -> ("Ticket Tracker =" <> keyHashidText d, Just HomeR)
         DeckInboxR d        -> ("Inbox", Just $ DeckR d)
@@ -993,6 +994,7 @@ instance YesodBreadcrumbs App where
         LoomStampR l k -> ("Stamp #" <> keyHashidText k, Just $ LoomR l)
 
         LoomCollabsR l -> ("Collaborators", Just $ LoomR l)
+        LoomProjectsR l -> ("Projects", Just $ LoomR l)
 
         ClothR l c            -> ("#" <> keyHashidText c, Just $ LoomClothsR l)
         ClothDiscussionR l c  -> ("Discussion", Just $ ClothR l c)

src/Vervis/Handler/Deck.hs

@@ -594,87 +594,10 @@ getDeckProjectsR deckHash = do
     (deck, actor, stems, drafts) <- runDB $ do
         deck <- get404 deckID
         actor <- getJust $ deckActor deck
-        stems <-
+        stems <- getStems $ deckKomponent deck
-            E.select $ E.from $ \ (stem `E.InnerJoin` accept `E.InnerJoin` deleg `E.InnerJoin` grant) -> do
+        drafts <- getStemDrafts $ deckKomponent deck
-                E.on $ deleg E.^. StemDelegateLocalGrant E.==. grant E.^. OutboxItemId
+        return (deck, actor, stems, drafts)
-                E.on $ accept E.^. StemComponentAcceptId E.==. deleg E.^. StemDelegateLocalStem
-                E.on $ stem E.^. StemId E.==. accept E.^. StemComponentAcceptStem
-                E.where_ $ stem E.^. StemHolder E.==. E.val (deckKomponent deck)
-                return
-                    ( stem
-                    , grant E.^. OutboxItemPublished
-                    )
-        stems' <- for stems $ \ (Entity stemID stem, E.Value time) -> do
-            j <- getStemProject stemID
-            projectView <-
-                bitraverse
-                    (\ projectID -> do
-                        actorID <- projectActor <$> getJust projectID
-                        actor <- getJust actorID
-                        return (projectID, actor)
-                    )
-                    getRemoteActorData
-                    j
-            return (projectView, stemRole stem, time, stemID)
-        drafts <-
-            E.select $ E.from $ \ (stem `E.LeftOuterJoin` accept `E.LeftOuterJoin` deleg) -> do
-                E.on $ accept E.?. StemComponentAcceptId E.==. deleg E.?. StemDelegateLocalStem
-                E.on $ E.just (stem E.^. StemId) E.==. accept E.?. StemComponentAcceptStem
-                E.where_ $
-                    stem E.^. StemHolder E.==. E.val (deckKomponent deck) E.&&.
-                    E.isNothing (deleg E.?. StemDelegateLocalId)
-                return stem
-        drafts' <- for drafts $ \ (Entity stemID (Stem role _)) -> do
-            (project, accept) <- do
-                project <- getStemProject stemID
-                accept <- isJust <$> getBy (UniqueStemComponentAccept stemID)
-                (,accept) <$> bitraverse
-                    (\ j -> do
-                        resourceID <- projectResource <$> getJust j
-                        Resource actorID <- getJust resourceID
-                        actor <- getJust actorID
-                        return (j, actor)
-                    )
-                    getRemoteActorData
-                    project
-            ((inviter, time), us) <- do
-                usOrThem <-
-                    requireEitherAlt
-                        (getKeyBy $ UniqueStemOriginAdd stemID)
-                        (getKeyBy $ UniqueStemOriginInvite stemID)
-                        "Neither us nor them"
-                        "Both us and them"
-                (addOrActor, us) <-
-                    case usOrThem of
-                        Left _usID -> (,True) <$>
-                            requireEitherAlt
-                                (fmap stemComponentGestureLocalActivity <$> getValBy (UniqueStemComponentGestureLocal stemID))
-                                (fmap (stemComponentGestureRemoteActor &&& stemComponentGestureRemoteActivity) <$> getValBy (UniqueStemComponentGestureRemote stemID))
-                                "Neither local not remote"
-                                "Both local and remote"
-                        Right themID -> (,False) <$>
-                            requireEitherAlt
-                                (fmap stemProjectGestureLocalInvite <$> getValBy (UniqueStemProjectGestureLocal themID))
-                                (fmap (stemProjectGestureRemoteActor &&& stemProjectGestureRemoteInvite) <$> getValBy (UniqueStemProjectGestureRemote themID))
-                                "Neither local not remote"
-                                "Both local and remote"
-                (,us) <$> case addOrActor of
-                    Left addID -> do
-                        OutboxItem outboxID _ time <- getJust addID
-                        Entity actorID actor <- getByJust $ UniqueActorOutbox outboxID
-                        (,time) . Left . (,actor) <$> getLocalActor actorID
-                    Right (actorID, addID) -> do
-                        RemoteActivity _ _ time <- getJust addID
-                        (,time) . Right <$> getRemoteActorData actorID
-            return (inviter, us, project, accept, time, role, stemID)
-        return (deck, actor, stems', drafts')
     defaultLayout $(widgetFile "deck/projects")
-    where
-    getRemoteActorData actorID = do
-        actor <- getJust actorID
-        object <- getJust $ remoteActorIdent actor
-        inztance <- getJust $ remoteObjectInstance object
-        return (inztance, object, actor)
 
 addProjectForm = renderDivs $
     areq fedUriField "(URI) Project" Nothing

src/Vervis/Handler/Loom.hs

@@ -33,6 +33,7 @@ module Vervis.Handler.Loom
     , getLoomStampR
 
     , getLoomCollabsR
+    , getLoomProjectsR
     )
 where
 
@@ -54,6 +55,7 @@ import Yesod.Core
 import Yesod.Core.Handler (redirect, setMessage, lookupPostParam, notFound)
 import Yesod.Form.Functions (runFormPost, runFormGet)
 import Yesod.Form.Types (FormResult (..))
+import Yesod.Form
 import Yesod.Persist.Core (runDB, get404, getBy404)
 
 import qualified Data.ByteString.Lazy as BL
@@ -88,11 +90,13 @@ import Vervis.Form.Tracker
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Paginate
+import Vervis.Persist.Actor
 import Vervis.Persist.Collab
 import Vervis.Recipient
 import Vervis.Settings
 import Vervis.Ticket
 import Vervis.TicketFilter
+import Vervis.Time
 import Vervis.Web.Actor
 import Vervis.Widget.Person
 import Vervis.Widget.Ticket
@@ -138,6 +142,8 @@ getLoomR loomHash = do
                 }
             , AP.patchTrackerCollaborators =
                 encodeRouteLocal $ LoomCollabsR loomHash
+            , AP.patchTrackerProjects =
+                encodeRouteLocal $ LoomProjectsR loomHash
             }
 
     provideHtmlAndAP loomAP $ redirect $ LoomClothsR loomHash
@@ -358,3 +364,23 @@ getLoomStampR = servePerActorKey loomActor LocalActorLoom
 
 getLoomCollabsR :: KeyHashid Loom -> Handler TypedContent
 getLoomCollabsR loomHash = error "TODO getLoomCollabsR"
+
+getLoomProjectsR :: KeyHashid Loom -> Handler Html
+getLoomProjectsR loomHash = do
+    loomID <- decodeKeyHashid404 loomHash
+    mp <- maybeAuthId
+    haveAdmin <- fmap isJust $ runDB $ runMaybeT $ do
+        personID <- MaybeT $ pure mp
+        loom <- lift $ get404 loomID
+        MaybeT $ getCapability personID (Left $ loomResource loom) AP.RoleAdmin
+    ((_, widgetAP), enctypeAP) <- runFormPost addProjectForm
+    (loom, actor, stems, drafts) <- runDB $ do
+        loom <- get404 loomID
+        actor <- getJust $ loomActor loom
+        stems <- getStems $ loomKomponent loom
+        drafts <- getStemDrafts $ loomKomponent loom
+        return (loom, actor, stems, drafts)
+    defaultLayout $(widgetFile "loom/projects")
+
+addProjectForm = renderDivs $
+    areq fedUriField "(URI) Project" Nothing

src/Vervis/Handler/Repo.hs

@@ -50,6 +50,7 @@ module Vervis.Handler.Repo
     , getRepoStampR
 
     , getRepoCollabsR
+    , getRepoProjectsR
 
 
 
@@ -124,6 +125,7 @@ import Yesod.Core.Content
 import Yesod.Core.Handler
 import Yesod.Form.Functions (runFormPost)
 import Yesod.Form.Types (FormResult (..))
+import Yesod.Form
 import Yesod.Persist.Core
 
 import qualified Data.ByteString as B
@@ -168,6 +170,7 @@ import Vervis.API
 import Vervis.Federation.Auth
 import Vervis.Federation.Offer
 import Vervis.FedURI
+import Vervis.Field.Person
 import Vervis.Form.Repo
 import Vervis.Foundation
 import Vervis.Path
@@ -175,15 +178,18 @@ import Vervis.Model
 import Vervis.Model.Ident
 import Vervis.Paginate
 import Vervis.Persist.Actor
+import Vervis.Persist.Collab
 import Vervis.Readme
 import Vervis.Recipient
 import Vervis.Settings
 import Vervis.SourceTree
 import Vervis.Style
+import Vervis.Time
 import Vervis.Web.Actor
 import Vervis.Web.Darcs
 import Vervis.Web.Delivery
 import Vervis.Web.Git
+import Vervis.Widget.Tracker
 
 import qualified Vervis.Client as C
 import qualified Vervis.Formatting as F
@@ -233,6 +239,7 @@ getRepoR repoHash = do
                 encodeRouteLocal . LoomR . hashLoom <$> repoLoom repo
             , AP.repoClone = encodeRouteLocal (RepoR repoHash) :| []
             , AP.repoCollaborators = encodeRouteLocal $ RepoCollabsR repoHash
+            , AP.repoProjects = encodeRouteLocal $ RepoProjectsR repoHash
             }
 
         next =
@@ -781,6 +788,27 @@ getRepoStampR = servePerActorKey repoActor LocalActorRepo
 getRepoCollabsR :: KeyHashid Repo -> Handler TypedContent
 getRepoCollabsR repoHash = error "TODO getRepoCollabsR"
 
+addProjectForm = renderDivs $
+    areq fedUriField "(URI) Project" Nothing
+
+getRepoProjectsR :: KeyHashid Repo -> Handler Html
+getRepoProjectsR repoHash = do
+    repoID <- decodeKeyHashid404 repoHash
+    mp <- maybeAuthId
+    haveAdmin <- fmap isJust $ runDB $ runMaybeT $ do
+        personID <- MaybeT $ pure mp
+        repo <- lift $ get404 repoID
+        MaybeT $ getCapability personID (Left $ repoResource repo) AP.RoleAdmin
+    ((_, widgetAP), enctypeAP) <- runFormPost addProjectForm
+    (repo, actor, stems, drafts) <- runDB $ do
+        repo <- get404 repoID
+        actor <- getJust $ repoActor repo
+        stems <- getStems $ repoKomponent repo
+        drafts <- getStemDrafts $ repoKomponent repo
+        return (repo, actor, stems, drafts)
+    hashLoom <- getEncodeKeyHashid
+    defaultLayout $(widgetFile "repo/projects")
+
 
 
 

src/Vervis/Persist/Actor.hs

@@ -47,6 +47,7 @@ module Vervis.Persist.Actor
     , insertToInbox
     , adaptErrbox
     , getActivityIdent
+    , getRemoteActorData
     )
 where
 
@@ -450,3 +451,9 @@ getActivityIdent =
             act <- getJust actID
             getRemoteActivityURI act
         )
+
+getRemoteActorData actorID = do
+    actor <- getJust actorID
+    object <- getJust $ remoteActorIdent actor
+    inztance <- getJust $ remoteObjectInstance object
+    return (inztance, object, actor)

src/Vervis/Persist/Collab.hs

@@ -57,10 +57,14 @@ module Vervis.Persist.Collab
 
     , getPermitsForResource
     , getCapability
+
+    , getStems
+    , getStemDrafts
     )
 where
 
 import Control.Applicative
+import Control.Arrow ((&&&))
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Class
@@ -1269,3 +1273,80 @@ getCapability personID actor role = do
                 u <- getRemoteActivityURI grant
                 return $ Right u
     return $ maybeDirect' <|> maybeExt'
+
+getStems komponentID = do
+    stems <-
+        E.select $ E.from $ \ (stem `E.InnerJoin` accept `E.InnerJoin` deleg `E.InnerJoin` grant) -> do
+            E.on $ deleg E.^. StemDelegateLocalGrant E.==. grant E.^. OutboxItemId
+            E.on $ accept E.^. StemComponentAcceptId E.==. deleg E.^. StemDelegateLocalStem
+            E.on $ stem E.^. StemId E.==. accept E.^. StemComponentAcceptStem
+            E.where_ $ stem E.^. StemHolder E.==. E.val komponentID
+            return
+                ( stem
+                , grant E.^. OutboxItemPublished
+                )
+    for stems $ \ (Entity stemID stem, E.Value time) -> do
+        j <- getStemProject stemID
+        projectView <-
+            bitraverse
+                (\ projectID -> do
+                    actorID <- projectActor <$> getJust projectID
+                    actor <- getJust actorID
+                    return (projectID, actor)
+                )
+                getRemoteActorData
+                j
+        return (projectView, stemRole stem, time, stemID)
+
+getStemDrafts komponentID = do
+    drafts <-
+        E.select $ E.from $ \ (stem `E.LeftOuterJoin` accept `E.LeftOuterJoin` deleg) -> do
+            E.on $ accept E.?. StemComponentAcceptId E.==. deleg E.?. StemDelegateLocalStem
+            E.on $ E.just (stem E.^. StemId) E.==. accept E.?. StemComponentAcceptStem
+            E.where_ $
+                stem E.^. StemHolder E.==. E.val komponentID E.&&.
+                E.isNothing (deleg E.?. StemDelegateLocalId)
+            return stem
+    for drafts $ \ (Entity stemID (Stem role _)) -> do
+        (project, accept) <- do
+            project <- getStemProject stemID
+            accept <- isJust <$> getBy (UniqueStemComponentAccept stemID)
+            (,accept) <$> bitraverse
+                (\ j -> do
+                    resourceID <- projectResource <$> getJust j
+                    Resource actorID <- getJust resourceID
+                    actor <- getJust actorID
+                    return (j, actor)
+                )
+                getRemoteActorData
+                project
+        ((inviter, time), us) <- do
+            usOrThem <-
+                requireEitherAlt
+                    (getKeyBy $ UniqueStemOriginAdd stemID)
+                    (getKeyBy $ UniqueStemOriginInvite stemID)
+                    "Neither us nor them"
+                    "Both us and them"
+            (addOrActor, us) <-
+                case usOrThem of
+                    Left _usID -> (,True) <$>
+                        requireEitherAlt
+                            (fmap stemComponentGestureLocalActivity <$> getValBy (UniqueStemComponentGestureLocal stemID))
+                            (fmap (stemComponentGestureRemoteActor &&& stemComponentGestureRemoteActivity) <$> getValBy (UniqueStemComponentGestureRemote stemID))
+                            "Neither local not remote"
+                            "Both local and remote"
+                    Right themID -> (,False) <$>
+                        requireEitherAlt
+                            (fmap stemProjectGestureLocalInvite <$> getValBy (UniqueStemProjectGestureLocal themID))
+                            (fmap (stemProjectGestureRemoteActor &&& stemProjectGestureRemoteInvite) <$> getValBy (UniqueStemProjectGestureRemote themID))
+                            "Neither local not remote"
+                            "Both local and remote"
+            (,us) <$> case addOrActor of
+                Left addID -> do
+                    OutboxItem outboxID _ time <- getJust addID
+                    Entity actorID actor <- getByJust $ UniqueActorOutbox outboxID
+                    (,time) . Left . (,actor) <$> getLocalActor actorID
+                Right (actorID, addID) -> do
+                    RemoteActivity _ _ time <- getJust addID
+                    (,time) . Right <$> getRemoteActorData actorID
+        return (inviter, us, project, accept, time, role, stemID)

src/Web/ActivityPub.hs

@@ -651,6 +651,7 @@ data Repo u = Repo
     , repoLoom  :: Maybe LocalURI
     , repoClone :: NonEmpty LocalURI
     , repoCollaborators :: LocalURI
+    , repoProjects :: LocalURI
     }
 
 instance ActivityPub Repo where
@@ -666,13 +667,15 @@ instance ActivityPub Repo where
                 <*> withAuthorityMaybeO h (o .:? "sendPatchesTo")
                 <*> (traverse (withAuthorityO h . pure) =<< o .:*+ "cloneUri")
                 <*> withAuthorityO h (o .: "collaborators")
-    toSeries h (Repo actor team vcs loom clone collabs)
+                <*> withAuthorityO h (o .: "context")
+    toSeries h (Repo actor team vcs loom clone collabs projects)
         =  toSeries h actor
         <> "team"                 .= (ObjURI h <$> team)
         <> "versionControlSystem" .= vcs
         <> "sendPatchesTo"        .=? (ObjURI h <$> loom)
         <> "cloneUri"             .=*+ (ObjURI h <$> clone)
         <> "collaborators"        .= ObjURI h collabs
+        <> "context"              .= ObjURI h projects
 
 data TicketTracker u = TicketTracker
     { ticketTrackerActor :: Actor u
@@ -701,6 +704,7 @@ instance ActivityPub TicketTracker where
 data PatchTracker u = PatchTracker
     { patchTrackerActor :: Actor u
     , patchTrackerCollaborators :: LocalURI
+    , patchTrackerProjects :: LocalURI
     }
 
 instance ActivityPub PatchTracker where
@@ -712,9 +716,11 @@ instance ActivityPub PatchTracker where
         fmap (h,) $
             PatchTracker a
                 <$> withAuthorityO h (o .: "collaborators")
-    toSeries h (PatchTracker actor collabs)
+                <*> withAuthorityO h (o .: "context")
+    toSeries h (PatchTracker actor collabs projects)
         =  toSeries h actor
-        <> "collaborators"  .= ObjURI h collabs
+        <> "collaborators" .= ObjURI h collabs
+        <> "context"       .= ObjURI h projects
 
 data CollectionType = CollectionTypeUnordered | CollectionTypeOrdered
 

templates/loom/projects.hamlet

@@ -0,0 +1,70 @@
+$# This file is part of Vervis.
+$#
+$# Written in 2016, 2019, 2022, 2023, 2024
+$# by fr33domlover <fr33domlover@riseup.net>.
+$#
+$# ♡ Copying is an act of love. Please copy, reuse and share.
+$#
+$# The author(s) have dedicated all copyright and related and neighboring
+$# rights to this software to the public domain worldwide. This software is
+$# distributed without any warranty.
+$#
+$# You should have received a copy of the CC0 Public Domain Dedication along
+$# with this software. If not, see
+$# <http://creativecommons.org/publicdomain/zero/1.0/>.
+
+^{loomNavW (Entity loomID loom) actor}
+
+<h2>Projects
+
+<table>
+  <tr>
+    <th>Role
+    <th>Project
+    <th>Since
+    $if haveAdmin
+      <th>Remove
+  $forall (project, role, since, stemID) <- stems
+    <tr>
+      <td>#{show role}
+      <td>^{projectLinkFedW project}
+      <td>#{showDate since}
+$#      $if haveAdmin
+$#        <td>^{buttonW POST "Remove" (LoomRemoveProjectR loomHash stemID)}
+
+$#$if haveAdmin
+$#  <p>Add loom to a project:
+$#  <form method=POST action=@{LoomAddProjectR loomHash} enctype=#{enctypeAP}>
+$#    ^{widgetAP}
+$#    <input type="submit">
+
+<h2>Invites
+
+<table>
+  <tr>
+    <th>Inviter
+    <th>Via
+    <th>Invited project
+    <th>I accepted?
+    <th>Role
+    <th>Time
+    $if haveAdmin
+      <th>Approve
+  $forall (inviter, us, project, accept, time, role, stemID) <- drafts
+    <tr>
+      <td>^{actorLinkFedW inviter}
+      <td>
+        $if us
+          Us
+        $else
+          Them
+      <td>^{projectLinkFedW project}
+      <td>
+        $if accept
+          [x]
+        $else
+          [_]
+      <td>#{show role}
+      <td>#{showDate time}
+$#      $if haveAdmin && (not accept && not us)
+$#        <td>^{buttonW POST "Approve" (LoomApproveProjectR loomHash stemID)}

templates/loom/widget/nav.hamlet

@@ -33,6 +33,9 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
   <span>
     <a href=@{LoomCollabsR loomHash}>
       [🤝 Collaborators]
+  <span>
+    <a href=@{LoomProjectsR loomHash}>
+      [🏗 Projects]
   <span>
     <a href=@{LoomClothsR loomHash}>
       [🥂 Merge Requests]

templates/repo/projects.hamlet

@@ -0,0 +1,100 @@
+$# This file is part of Vervis.
+$#
+$# Written in 2016, 2019, 2022, 2023, 2024
+$# by fr33domlover <fr33domlover@riseup.net>.
+$#
+$# ♡ Copying is an act of love. Please copy, reuse and share.
+$#
+$# The author(s) have dedicated all copyright and related and neighboring
+$# rights to this software to the public domain worldwide. This software is
+$# distributed without any warranty.
+$#
+$# You should have received a copy of the CC0 Public Domain Dedication along
+$# with this software. If not, see
+$# <http://creativecommons.org/publicdomain/zero/1.0/>.
+
+<div>
+  <span>
+    [[ 🗃
+    <a href=@{RepoR repoHash}>
+      ^#{keyHashidText repoHash} #{actorName actor}
+    ]] ::
+  <span>
+    <a href=@{RepoInboxR repoHash}>
+      [📥 Inbox]
+  <span>
+    <a href=@{RepoOutboxR repoHash}>
+      [📤 Outbox]
+  <span>
+    <a href=@{RepoErrboxR repoHash}>
+      [💥 Errbox]
+  <span>
+    <a href=@{RepoFollowersR repoHash}>
+      [🐤 Followers]
+  <span>
+    <a href=@{RepoCollabsR repoHash}>
+      [🤝 Collaborators]
+  <span>
+    <a href=@{RepoProjectsR repoHash}>
+      [🏗 Projects]
+  <span>
+    <a href=@{RepoCommitsR repoHash}>
+      [🛠 Commits]
+  $maybe loomID <- repoLoom repo
+    <span>
+      <a href=@{LoomClothsR $ hashLoom loomID}>
+        [🧩 Merge Requests]
+
+<h2>Projects
+
+<table>
+  <tr>
+    <th>Role
+    <th>Project
+    <th>Since
+    $if haveAdmin
+      <th>Remove
+  $forall (project, role, since, stemID) <- stems
+    <tr>
+      <td>#{show role}
+      <td>^{projectLinkFedW project}
+      <td>#{showDate since}
+$#      $if haveAdmin
+$#        <td>^{buttonW POST "Remove" (RepoRemoveProjectR repoHash stemID)}
+
+$#$if haveAdmin
+$#  <p>Add repo to a project:
+$#  <form method=POST action=@{RepoAddProjectR repoHash} enctype=#{enctypeAP}>
+$#    ^{widgetAP}
+$#    <input type="submit">
+
+<h2>Invites
+
+<table>
+  <tr>
+    <th>Inviter
+    <th>Via
+    <th>Invited project
+    <th>I accepted?
+    <th>Role
+    <th>Time
+    $if haveAdmin
+      <th>Approve
+  $forall (inviter, us, project, accept, time, role, stemID) <- drafts
+    <tr>
+      <td>^{actorLinkFedW inviter}
+      <td>
+        $if us
+          Us
+        $else
+          Them
+      <td>^{projectLinkFedW project}
+      <td>
+        $if accept
+          [x]
+        $else
+          [_]
+      <td>#{show role}
+      <td>#{showDate time}
+$#      $if haveAdmin && (not accept && not us)
+$#        <td>^{buttonW POST "Approve" (RepoApproveProjectR repoHash stemID)}

templates/repo/source-darcs.hamlet

@@ -51,6 +51,9 @@ $# ^{personNavW user}
   <span>
     <a href=@{RepoCollabsR repo}>
       [🤝 Collaborators]
+  <span>
+    <a href=@{RepoProjectsR repo}>
+      [🏗 Projects]
   <span>
     <a href=@{RepoCommitsR repo}>
       [🛠 Changes]

templates/repo/source-git.hamlet

@@ -51,6 +51,9 @@ $# ^{personNavW user}
   <span>
     <a href=@{RepoCollabsR repo}>
       [🤝 Collaborators]
+  <span>
+    <a href=@{RepoProjectsR repo}>
+      [🏗 Projects]
   <span>
     <a href=@{RepoCommitsR repo}>
       [🛠 Commits]

th/routes

@@ -221,6 +221,7 @@
 /repos/#RepoKeyHashid/stamps/#SigKeyKeyHashid     RepoStampR         GET
 
 /repos/#RepoKeyHashid/collabs                     RepoCollabsR       GET
+/repos/#RepoKeyHashid/projects                    RepoProjectsR      GET
 
 ---- Deck --------------------------------------------------------------------
 
@@ -305,6 +306,7 @@
 /looms/#LoomKeyHashid/stamps/#SigKeyKeyHashid     LoomStampR      GET
 
 /looms/#LoomKeyHashid/collabs                     LoomCollabsR    GET
+/looms/#LoomKeyHashid/projects                    LoomProjectsR   GET
 
 ---- Cloth -------------------------------------------------------------------