S2S: Component: Implement Add-based version of inviteComponent

2024-05-11 22:25:50 +03:00 · 2024-05-11 22:25:50 +03:00 · f864274ff0
commit f864274ff0
parent 38ce72996c
15 changed files with 653 additions and 255 deletions
--- a/src/Vervis/Actor/Common.hs
+++ b/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:
--      * Verify that the object is me
--      * Verify the target is some project's components collection URI
+--  * If target is my context (i.e. parents) collection:
+--      * Verify the object is a project
 --      * 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,6 +1934,44 @@ componentAdd
    -> ActE (Text, Act (), Next)
 componentAdd grabKomponent toComponent now meID (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 at, _)
+            | addTargetComponentProjects at == Just (toComponent meID) -> do
+                project <-
+                    bitraverse
+                        (\case
+                            LocalActorProject j -> pure j
+                            _ -> throwE "Adding me to a local non-project"
+                        )
+                        pure
+                        object
+                addProjectActive role project
+        (_, Left la)
+            | resourceToActor (componentResource $ toComponent meID) == la -> do
+                case target of
+                    Left (ATProjectComponents j) ->
+                        addProjectPassive role $ 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"
+                        j <- AP.fetchAPID_T manager (AP.actorId . AP.actorLocal . AP.projectActor) h lu
+                        if luColl == AP.projectComponents j
+                            then addProjectPassive role $ Right $ ObjURI h lu
+                            else throwE "Non-components collection"
+                    _ -> throwE "I'm being added somewhere irrelevant"
+        _ -> throwE "This Add isn't for me"
+
+    where
+
+    addProjectActive role project = do
+
        let meComponent = toComponent meID
            meResource = componentResource meComponent
            meActor = resourceToActor meResource
@ -1946,17 +1996,7 @@ componentAdd grabKomponent toComponent now meID (Verse authorIdMsig body) add =
                _ -> 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"
+        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
@ -1969,22 +2009,11 @@ componentAdd grabKomponent toComponent now meID (Verse authorIdMsig body) add =
        projectDB <-
            bitraverse
                (withDBExcept . flip getEntityE "Project not found in DB")
-            (\ u@(ObjURI h luComps) -> do
+                (\ u@(ObjURI h luProject) -> 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 <$>
                            AP.fetchAPID manager (AP.actorId . AP.actorLocal . AP.projectActor) h luProject
-                unless (AP.projectComponents project == luComps) $
-                    throwE "The collection isn't the project's components collection"
-
                    instanceID <-
                        lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
                    result <-
@ -1999,7 +2028,7 @@ componentAdd grabKomponent toComponent now meID (Verse authorIdMsig body) add =
                                throwE "Remote project type isn't Project"
                            return $ entityKey actor
                )
-            projectComps
+                project

        meHash <- encodeKeyHashid meID
        let meComponentHash = toComponent meHash
@ -2046,7 +2075,7 @@ componentAdd grabKomponent toComponent now meID (Verse authorIdMsig body) add =
                lift $ sendActivity
                    meActor actorID localRecipsAccept
                    remoteRecipsAccept fwdHostsAccept acceptID actionAccept
-            doneDB inboxItemID "Recorded and forwarded the Add, sent an Accept"
+                doneDB inboxItemID "[Add-project-active] Recorded and forwarded the Add, sent an Accept"

        where

@ -2102,3 +2131,96 @@ componentAdd grabKomponent toComponent now meID (Verse authorIdMsig body) add =
                    }

            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
--- a/src/Vervis/Data/Collab.hs
+++ b/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
--- a/src/Vervis/Foundation.hs
+++ b/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)
--- a/src/Vervis/Handler/Deck.hs
+++ b/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 <-
-            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 (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')
+        stems <- getStems $ deckKomponent deck
+        drafts <- getStemDrafts $ deckKomponent deck
+        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
--- a/src/Vervis/Handler/Loom.hs
+++ b/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
--- a/src/Vervis/Handler/Repo.hs
+++ b/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")
+



--- a/src/Vervis/Persist/Actor.hs
+++ b/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)
--- a/src/Vervis/Persist/Collab.hs
+++ b/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)
--- a/src/Web/ActivityPub.hs
+++ b/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
+        <> "context"       .= ObjURI h projects

 data CollectionType = CollectionTypeUnordered | CollectionTypeOrdered

--- a/templates/loom/projects.hamlet
+++ b/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)}
--- a/templates/loom/widget/nav.hamlet
+++ b/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]
--- a/templates/repo/projects.hamlet
+++ b/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)}
--- a/templates/repo/source-darcs.hamlet
+++ b/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]
--- a/templates/repo/source-git.hamlet
+++ b/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]
--- a/th/routes
+++ b/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 -------------------------------------------------------------------