Project routes, handlers and creation UI

migrations/541_2023-06-26_project.model

@@ -4,3 +4,9 @@ Project
 
     UniqueProjectActor  actor
     UniqueProjectCreate create
+
+CollabTopicProject
+    collab  CollabId
+    project ProjectId
+
+    UniqueCollabTopicProject collab

src/Vervis/API.hs

@@ -173,6 +173,9 @@ verifyResourceAddressed localRecips resource = do
     verify (GrantResourceLoom l) = do
         routes <- lookup l $ recipLooms localRecips
         guard $ routeLoom $ familyLoom routes
+    verify (GrantResourceProject r) = do
+        routes <- lookup r $ recipProjects localRecips
+        guard $ routeProject routes
 
 verifyRemoteAddressed
     :: Monad m => [(Host, NonEmpty LocalURI)] -> FedURI -> ExceptT Text m ()
@@ -2054,6 +2057,7 @@ actorOutboxItem (LocalActorGroup _) = error "No outbox for Group yet"
 actorOutboxItem (LocalActorRepo r) = RepoOutboxItemR r
 actorOutboxItem (LocalActorDeck d) = DeckOutboxItemR d
 actorOutboxItem (LocalActorLoom l) = LoomOutboxItemR l
+actorOutboxItem (LocalActorProject l) = ProjectOutboxItemR l
 
 offerDepC
     :: Entity Person

src/Vervis/Actor.hs

@@ -48,6 +48,7 @@ module Vervis.Actor
     , RepoRoutes (..)
     , DeckRoutes (..)
     , LoomRoutes (..)
+    , ProjectRoutes (..)
     , DeckFamilyRoutes (..)
     , LoomFamilyRoutes (..)
     , RecipientRoutes (..)
@@ -133,11 +134,12 @@ import Vervis.RemoteActorStore.Types
 import Vervis.Settings
 
 data LocalActorBy f
-    = LocalActorPerson (f Person)
+    = LocalActorPerson  (f Person)
-    | LocalActorGroup  (f Group)
+    | LocalActorGroup   (f Group)
-    | LocalActorRepo   (f Repo)
+    | LocalActorRepo    (f Repo)
-    | LocalActorDeck   (f Deck)
+    | LocalActorDeck    (f Deck)
-    | LocalActorLoom   (f Loom)
+    | LocalActorLoom    (f Loom)
+    | LocalActorProject (f Project)
     deriving (Generic, FunctorB, ConstraintsB)
 
 deriving instance AllBF Eq f LocalActorBy => Eq (LocalActorBy f)
@@ -151,11 +153,12 @@ hashLocalActorPure
     :: HashidsContext -> LocalActorBy Key -> LocalActorBy KeyHashid
 hashLocalActorPure ctx = f
     where
-    f (LocalActorPerson p) = LocalActorPerson $ encodeKeyHashidPure ctx p
+    f (LocalActorPerson p)  = LocalActorPerson $ encodeKeyHashidPure ctx p
-    f (LocalActorGroup g)  = LocalActorGroup $ encodeKeyHashidPure ctx g
+    f (LocalActorGroup g)   = LocalActorGroup $ encodeKeyHashidPure ctx g
-    f (LocalActorRepo r)   = LocalActorRepo $ encodeKeyHashidPure ctx r
+    f (LocalActorRepo r)    = LocalActorRepo $ encodeKeyHashidPure ctx r
-    f (LocalActorDeck d)   = LocalActorDeck $ encodeKeyHashidPure ctx d
+    f (LocalActorDeck d)    = LocalActorDeck $ encodeKeyHashidPure ctx d
-    f (LocalActorLoom l)   = LocalActorLoom $ encodeKeyHashidPure ctx l
+    f (LocalActorLoom l)    = LocalActorLoom $ encodeKeyHashidPure ctx l
+    f (LocalActorProject j) = LocalActorProject $ encodeKeyHashidPure ctx j
 
 getHashLocalActor
     :: (MonadActor m, StageHashids (ActorEnv m))
@@ -175,11 +178,12 @@ unhashLocalActorPure
     :: HashidsContext -> LocalActorBy KeyHashid -> Maybe (LocalActorBy Key)
 unhashLocalActorPure ctx = f
     where
-    f (LocalActorPerson p) = LocalActorPerson <$> decodeKeyHashidPure ctx p
+    f (LocalActorPerson p)  = LocalActorPerson <$> decodeKeyHashidPure ctx p
-    f (LocalActorGroup g)  = LocalActorGroup <$> decodeKeyHashidPure ctx g
+    f (LocalActorGroup g)   = LocalActorGroup <$> decodeKeyHashidPure ctx g
-    f (LocalActorRepo r)   = LocalActorRepo <$> decodeKeyHashidPure ctx r
+    f (LocalActorRepo r)    = LocalActorRepo <$> decodeKeyHashidPure ctx r
-    f (LocalActorDeck d)   = LocalActorDeck <$> decodeKeyHashidPure ctx d
+    f (LocalActorDeck d)    = LocalActorDeck <$> decodeKeyHashidPure ctx d
-    f (LocalActorLoom l)   = LocalActorLoom <$> decodeKeyHashidPure ctx l
+    f (LocalActorLoom l)    = LocalActorLoom <$> decodeKeyHashidPure ctx l
+    f (LocalActorProject j) = LocalActorProject <$> decodeKeyHashidPure ctx j
 
 unhashLocalActor
     :: (MonadActor m, StageHashids (ActorEnv m))
@@ -258,6 +262,12 @@ data LoomRoutes = LoomRoutes
     }
     deriving Eq
 
+data ProjectRoutes = ProjectRoutes
+    { routeProject          :: Bool
+    , routeProjectFollowers :: Bool
+    }
+    deriving Eq
+
 data DeckFamilyRoutes = DeckFamilyRoutes
     { familyDeck    :: DeckRoutes
     , familyTickets :: [(KeyHashid TicketDeck, TicketRoutes)]
@@ -271,11 +281,12 @@ data LoomFamilyRoutes = LoomFamilyRoutes
     deriving Eq
 
 data RecipientRoutes = RecipientRoutes
-    { recipPeople :: [(KeyHashid Person, PersonRoutes)]
+    { recipPeople   :: [(KeyHashid Person , PersonRoutes)]
-    , recipGroups :: [(KeyHashid Group , GroupRoutes)]
+    , recipGroups   :: [(KeyHashid Group  , GroupRoutes)]
-    , recipRepos  :: [(KeyHashid Repo  , RepoRoutes)]
+    , recipRepos    :: [(KeyHashid Repo   , RepoRoutes)]
-    , recipDecks  :: [(KeyHashid Deck  , DeckFamilyRoutes)]
+    , recipDecks    :: [(KeyHashid Deck   , DeckFamilyRoutes)]
-    , recipLooms  :: [(KeyHashid Loom  , LoomFamilyRoutes)]
+    , recipLooms    :: [(KeyHashid Loom   , LoomFamilyRoutes)]
+    , recipProjects :: [(KeyHashid Project, ProjectRoutes)]
     }
     deriving Eq
 
@@ -346,7 +357,6 @@ data Env = forall y. (Typeable y, Yesod y) => Env
     , envHashidsContext  :: HashidsContext
     , envActorKeys       :: Maybe (TVar (ActorKey, ActorKey, Bool))
     , envDeliveryTheater :: DeliveryTheater URIMode
-    --, envYesodSite       :: y
     , envYesodRender     :: YesodRender y
     , envHttpManager     :: Manager
     , envFetch           :: ActorFetchShare
@@ -469,6 +479,7 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do
         looms <- unhashKeys $ recipLooms recips
         for looms $ \ (loomID, (LoomFamilyRoutes loom cloths)) ->
             (loomID,) . (loom,) <$> unhashKeys cloths
+    projects <- unhashKeys $ recipProjects recips
 
     -- Grab local actor sets whose stages are allowed for delivery
     let allowStages'
@@ -489,6 +500,8 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do
             filter (allowStages' fst routeDeck LocalActorDeck) decksAndTickets
         loomsAndClothsForStages =
             filter (allowStages' fst routeLoom LocalActorLoom) loomsAndCloths
+        projectsForStages =
+            filter (allowStages' id routeProject LocalActorProject) projects
 
     -- Grab local actors being addressed
     let localActorsForSelf = concat
@@ -497,6 +510,7 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do
             , [ LocalActorRepo key | (key, routes) <- repos, routeRepo routes ]
             , [ LocalActorDeck key | (key, (routes, _)) <- decksAndTickets, routeDeck routes ]
             , [ LocalActorLoom key | (key, (routes, _)) <- loomsAndCloths, routeLoom routes ]
+            , [ LocalActorProject key | (key, routes) <- projects, routeProject routes ]
             ]
 
     -- Grab local actors whose followers are going to be delivered to
@@ -510,6 +524,8 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do
             [ key | (key, (routes, _)) <- decksAndTicketsForStages, routeDeckFollowers routes ]
         loomIDsForFollowers =
             [ key | (key, (routes, _)) <- loomsAndClothsForStages, routeLoomFollowers routes ]
+        projectIDsForFollowers =
+            [ key | (key, routes) <- projectsForStages, routeProjectFollowers routes ]
 
     -- Grab tickets and cloths whose followers are going to be delivered to
     let ticketSetsForFollowers =
@@ -540,6 +556,7 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do
                 , selectActorIDs repoActor repoIDsForFollowers
                 , selectActorIDs deckActor deckIDsForFollowers
                 , selectActorIDs loomActor loomIDsForFollowers
+                , selectActorIDs projectActor projectIDsForFollowers
                 ]
             ticketIDs <-
                 concat <$>
@@ -561,11 +578,12 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do
 
         -- Get the local and remote followers of the follower sets from DB
         locals <- concat <$> sequenceA
-                [ selectFollowers LocalActorPerson PersonActor followerSetIDs
+                [ selectFollowers LocalActorPerson  PersonActor  followerSetIDs
-                , selectFollowers LocalActorGroup  GroupActor  followerSetIDs
+                , selectFollowers LocalActorGroup   GroupActor   followerSetIDs
-                , selectFollowers LocalActorRepo   RepoActor   followerSetIDs
+                , selectFollowers LocalActorRepo    RepoActor    followerSetIDs
-                , selectFollowers LocalActorDeck   DeckActor   followerSetIDs
+                , selectFollowers LocalActorDeck    DeckActor    followerSetIDs
-                , selectFollowers LocalActorLoom   LoomActor   followerSetIDs
+                , selectFollowers LocalActorLoom    LoomActor    followerSetIDs
+                , selectFollowers LocalActorProject ProjectActor followerSetIDs
                 ]
         remotes <- getRemoteFollowers followerSetIDs
         return (locals, remotes)

src/Vervis/Actor/Person/Client.hs

@@ -92,6 +92,9 @@ verifyResourceAddressed localRecips resource = do
     verify (GrantResourceLoom l) = do
         routes <- lookup l $ recipLooms localRecips
         guard $ routeLoom $ familyLoom routes
+    verify (GrantResourceProject r) = do
+        routes <- lookup r $ recipProjects localRecips
+        guard $ routeProject routes
 
 verifyRecipientAddressed localRecips recipient = do
     recipientHash <- hashGrantRecip recipient
@@ -384,6 +387,7 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
                         Left (GrantResourceRepo r) -> Just $ LocalActorRepo r
                         Left (GrantResourceDeck d) -> Just $ LocalActorDeck d
                         Left (GrantResourceLoom l) -> Just $ LocalActorLoom l
+                        Left (GrantResourceProject l) -> Just $ LocalActorProject l
                         Right _                    -> Nothing
                     , case recipientHash of
                         Left (GrantRecipPerson p) -> Just $ LocalActorPerson p
@@ -395,6 +399,7 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
                         Left (GrantResourceRepo r) -> Just $ LocalStageRepoFollowers r
                         Left (GrantResourceDeck d) -> Just $ LocalStageDeckFollowers d
                         Left (GrantResourceLoom l) -> Just $ LocalStageLoomFollowers l
+                        Left (GrantResourceProject l) -> Just $ LocalStageProjectFollowers l
                         Right _                    -> Nothing
                     , case recipientHash of
                         Left (GrantRecipPerson p) -> Just $ LocalStagePersonFollowers p
@@ -484,6 +489,7 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
                         Left (GrantResourceRepo r) -> Just $ LocalActorRepo r
                         Left (GrantResourceDeck d) -> Just $ LocalActorDeck d
                         Left (GrantResourceLoom l) -> Just $ LocalActorLoom l
+                        Left (GrantResourceProject l) -> Just $ LocalActorProject l
                         Right _                    -> Nothing
                     , case recipientHash of
                         Left (GrantRecipPerson p) -> Just $ LocalActorPerson p
@@ -495,6 +501,7 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
                         Left (GrantResourceRepo r) -> Just $ LocalStageRepoFollowers r
                         Left (GrantResourceDeck d) -> Just $ LocalStageDeckFollowers d
                         Left (GrantResourceLoom l) -> Just $ LocalStageLoomFollowers l
+                        Left (GrantResourceProject l) -> Just $ LocalStageProjectFollowers l
                         Right _                    -> Nothing
                     , case recipientHash of
                         Left (GrantRecipPerson p) -> Just $ LocalStagePersonFollowers p

src/Vervis/Actor/Project.hs

@@ -0,0 +1,62 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2023 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/>.
+ -}
+
+module Vervis.Actor.Project
+    (
+    )
+where
+
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.Logger.CallStack
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Except
+import Control.Monad.Trans.Maybe
+import Data.ByteString (ByteString)
+import Data.Foldable
+import Data.Text (Text)
+import Data.Time.Clock
+import Database.Persist
+import Yesod.Persist.Core
+
+import qualified Data.Text as T
+
+import Control.Concurrent.Actor
+import Network.FedURI
+import Yesod.MonadSite
+
+import qualified Web.ActivityPub as AP
+
+import Control.Monad.Trans.Except.Local
+import Database.Persist.Local
+
+import Vervis.Actor
+import Vervis.Cloth
+import Vervis.Data.Discussion
+import Vervis.FedURI
+import Vervis.Federation.Util
+import Vervis.Foundation
+import Vervis.Model
+import Vervis.Persist.Discussion
+import Vervis.Ticket
+
+projectBehavior :: UTCTime -> ProjectId -> VerseExt -> ActE (Text, Act (), Next)
+projectBehavior now projectID (Left _verse@(Verse _authorIdMsig body)) =
+    case AP.activitySpecific $ actbActivity body of
+        _ -> throwE "Unsupported activity type for Project"
+projectBehavior _ _ (Right _) = throwE "ClientMsgs aren't supported for Project"
+
+instance VervisActor Project where
+    actorBehavior = projectBehavior

src/Vervis/Application.hs

@@ -110,6 +110,7 @@ import Vervis.Actor.Deck
 import Vervis.Actor.Group
 import Vervis.Actor.Loom
 import Vervis.Actor.Person
+import Vervis.Actor.Project
 import Vervis.Actor.Repo
 import Vervis.Darcs
 import Vervis.Data.Actor
@@ -130,6 +131,7 @@ import Vervis.Handler.Group
 import Vervis.Handler.Key
 import Vervis.Handler.Loom
 import Vervis.Handler.Person
+import Vervis.Handler.Project
 import Vervis.Handler.Repo
 --import Vervis.Handler.Role
 --import Vervis.Handler.Sharer
@@ -349,6 +351,7 @@ makeFoundation appSettings = do
         , selectAll LocalActorRepo
         , selectAll LocalActorDeck
         , selectAll LocalActorLoom
+        , selectAll LocalActorProject
         ]
         where
         selectAll

src/Vervis/Client.hs

@@ -37,6 +37,7 @@ module Vervis.Client
     , createDeck
     , createLoom
     , createRepo
+    , createProject
     , invite
     , remove
     )
@@ -949,6 +950,27 @@ createRepo senderHash name desc = do
 
     return (Nothing, audience, detail)
 
+createProject
+    :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
+    => KeyHashid Person
+    -> Text
+    -> Text
+    -> m (Maybe HTML, [Aud URIMode], AP.ActorDetail)
+createProject senderHash name desc = do
+    let audAuthor =
+            AudLocal [] [LocalStagePersonFollowers senderHash]
+
+        audience = [audAuthor]
+
+        detail = AP.ActorDetail
+            { AP.actorType     = AP.ActorTypeProject
+            , AP.actorUsername = Nothing
+            , AP.actorName     = Just name
+            , AP.actorSummary  = Just desc
+            }
+
+    return (Nothing, audience, detail)
+
 invite
     :: PersonId
     -> FedURI
@@ -1012,6 +1034,8 @@ invite personID uRecipient uResource role = do
                     AudLocal [LocalActorDeck d] [LocalStageDeckFollowers d]
                 Left (GrantResourceLoom l) ->
                     AudLocal [LocalActorLoom l] [LocalStageLoomFollowers l]
+                Left (GrantResourceProject l) ->
+                    AudLocal [LocalActorProject l] [LocalStageProjectFollowers l]
                 Right (remoteActor, ObjURI h lu) ->
                     AudRemote h
                         [lu]
@@ -1093,6 +1117,8 @@ remove personID uRecipient uResource = do
                     AudLocal [LocalActorDeck d] [LocalStageDeckFollowers d]
                 Left (GrantResourceLoom l) ->
                     AudLocal [LocalActorLoom l] [LocalStageLoomFollowers l]
+                Left (GrantResourceProject l) ->
+                    AudLocal [LocalActorProject l] [LocalStageProjectFollowers l]
                 Right (remoteActor, ObjURI h lu) ->
                     AudRemote h
                         [lu]

src/Vervis/Data/Actor.hs

@@ -80,6 +80,7 @@ parseLocalActivityURI luAct = do
     parseOutboxItemRoute (RepoOutboxItemR r i)   = Just (LocalActorRepo r, i)
     parseOutboxItemRoute (DeckOutboxItemR d i)   = Just (LocalActorDeck d, i)
     parseOutboxItemRoute (LoomOutboxItemR l i)   = Just (LocalActorLoom l, i)
+    parseOutboxItemRoute (ProjectOutboxItemR r i)   = Just (LocalActorProject r, i)
     parseOutboxItemRoute _                       = Nothing
 
 parseLocalActivityURI'
@@ -141,6 +142,7 @@ activityRoute (LocalActorGroup g) = GroupOutboxItemR g
 activityRoute (LocalActorRepo r) = RepoOutboxItemR r
 activityRoute (LocalActorDeck d) = DeckOutboxItemR d
 activityRoute (LocalActorLoom l) = LoomOutboxItemR l
+activityRoute (LocalActorProject r) = ProjectOutboxItemR r
 
 stampRoute :: LocalActorBy KeyHashid -> KeyHashid SigKey -> Route App
 stampRoute (LocalActorPerson p) = PersonStampR p
@@ -148,6 +150,7 @@ stampRoute (LocalActorGroup g) = GroupStampR g
 stampRoute (LocalActorRepo r) = RepoStampR r
 stampRoute (LocalActorDeck d) = DeckStampR d
 stampRoute (LocalActorLoom l) = LoomStampR l
+stampRoute (LocalActorProject r) = ProjectStampR r
 
 parseStampRoute
     :: Route App -> Maybe (LocalActorBy KeyHashid, KeyHashid SigKey)
@@ -156,6 +159,7 @@ parseStampRoute (GroupStampR g i)  = Just (LocalActorGroup g, i)
 parseStampRoute (RepoStampR r i)   = Just (LocalActorRepo r, i)
 parseStampRoute (DeckStampR d i)   = Just (LocalActorDeck d, i)
 parseStampRoute (LoomStampR l i)   = Just (LocalActorLoom l, i)
+parseStampRoute (ProjectStampR r i)   = Just (LocalActorProject r, i)
 parseStampRoute _                       = Nothing
 
 localActorID :: LocalActorBy Entity -> ActorId
@@ -164,6 +168,7 @@ localActorID (LocalActorGroup (Entity _ g))  = groupActor g
 localActorID (LocalActorRepo (Entity _ r))   = repoActor r
 localActorID (LocalActorDeck (Entity _ d))   = deckActor d
 localActorID (LocalActorLoom (Entity _ l))   = loomActor l
+localActorID (LocalActorProject (Entity _ r))   = projectActor r
 
 parseFedURIOld
     :: ( MonadSite m

src/Vervis/Data/Collab.hs

@@ -85,6 +85,7 @@ import Vervis.Model
 parseGrantResource (RepoR r) = Just $ GrantResourceRepo r
 parseGrantResource (DeckR d) = Just $ GrantResourceDeck d
 parseGrantResource (LoomR l) = Just $ GrantResourceLoom l
+parseGrantResource (ProjectR l) = Just $ GrantResourceProject l
 parseGrantResource _         = Nothing
 
 data GrantRecipBy f = GrantRecipPerson (f Person)
@@ -230,11 +231,6 @@ parseGrant h (AP.Grant object context target mresult mstart mend allows deleg) =
                     resourceHash
                     "Grant resource contains invalid hashid"
             else pure $ Right lu
-        where
-        parseGrantResource (RepoR r) = Just $ GrantResourceRepo r
-        parseGrantResource (DeckR d) = Just $ GrantResourceDeck d
-        parseGrantResource (LoomR l) = Just $ GrantResourceLoom l
-        parseGrantResource _         = Nothing
     parseTarget u@(ObjURI h lu) = do
         hl <- hostIsLocal h
         if hl
@@ -277,11 +273,13 @@ grantResourceActorID :: GrantResourceBy Identity -> ActorId
 grantResourceActorID (GrantResourceRepo (Identity r)) = repoActor r
 grantResourceActorID (GrantResourceDeck (Identity d)) = deckActor d
 grantResourceActorID (GrantResourceLoom (Identity l)) = loomActor l
+grantResourceActorID (GrantResourceProject (Identity l)) = projectActor l
 
 data GrantResourceBy f
     = GrantResourceRepo (f Repo)
     | GrantResourceDeck (f Deck)
     | GrantResourceLoom (f Loom)
+    | GrantResourceProject (f Project)
     deriving (Generic, FunctorB, TraversableB, ConstraintsB)
 
 deriving instance AllBF Eq f GrantResourceBy => Eq (GrantResourceBy f)
@@ -294,6 +292,8 @@ unhashGrantResourcePure ctx = f
         GrantResourceDeck <$> decodeKeyHashidPure ctx d
     f (GrantResourceLoom l) =
         GrantResourceLoom <$> decodeKeyHashidPure ctx l
+    f (GrantResourceProject l) =
+        GrantResourceProject <$> decodeKeyHashidPure ctx l
 
 unhashGrantResource resource = do
     ctx <- asksSite siteHashidsContext
@@ -317,6 +317,8 @@ hashGrantResource (GrantResourceDeck k) =
     GrantResourceDeck <$> encodeKeyHashid k
 hashGrantResource (GrantResourceLoom k) =
     GrantResourceLoom <$> encodeKeyHashid k
+hashGrantResource (GrantResourceProject k) =
+    GrantResourceProject <$> encodeKeyHashid k
 
 hashGrantResource' (GrantResourceRepo k) =
     GrantResourceRepo <$> WAP.encodeKeyHashid k
@@ -324,6 +326,8 @@ hashGrantResource' (GrantResourceDeck k) =
     GrantResourceDeck <$> WAP.encodeKeyHashid k
 hashGrantResource' (GrantResourceLoom k) =
     GrantResourceLoom <$> WAP.encodeKeyHashid k
+hashGrantResource' (GrantResourceProject k) =
+    GrantResourceProject <$> WAP.encodeKeyHashid k
 
 getGrantResource (GrantResourceRepo k) e =
     GrantResourceRepo <$> getEntityE k e
@@ -331,6 +335,8 @@ getGrantResource (GrantResourceDeck k) e =
     GrantResourceDeck <$> getEntityE k e
 getGrantResource (GrantResourceLoom k) e =
     GrantResourceLoom <$> getEntityE k e
+getGrantResource (GrantResourceProject k) e =
+    GrantResourceProject <$> getEntityE k e
 
 getGrantResource404 = maybe notFound return <=< getGrantResourceEntity
     where
@@ -340,8 +346,11 @@ getGrantResource404 = maybe notFound return <=< getGrantResourceEntity
         fmap GrantResourceDeck <$> getEntity k
     getGrantResourceEntity (GrantResourceLoom k) =
         fmap GrantResourceLoom <$> getEntity k
+    getGrantResourceEntity (GrantResourceProject k) =
+        fmap GrantResourceProject <$> getEntity k
 
 grantResourceLocalActor :: GrantResourceBy f -> LocalActorBy f
 grantResourceLocalActor (GrantResourceRepo r) = LocalActorRepo r
 grantResourceLocalActor (GrantResourceDeck d) = LocalActorDeck d
 grantResourceLocalActor (GrantResourceLoom l) = LocalActorLoom l
+grantResourceLocalActor (GrantResourceProject l) = LocalActorProject l

src/Vervis/Data/Discussion.hs

@@ -222,3 +222,4 @@ messageRoute (LocalActorGroup g)  = GroupMessageR g
 messageRoute (LocalActorRepo r)   = RepoMessageR r
 messageRoute (LocalActorDeck d)   = DeckMessageR d
 messageRoute (LocalActorLoom l)   = LoomMessageR l
+messageRoute (LocalActorProject l)   = ProjectMessageR l

src/Vervis/Form/Tracker.hs

@@ -16,10 +16,14 @@
 module Vervis.Form.Tracker
     ( NewDeck (..)
     , newDeckForm
+    , NewProject (..)
+    , newProjectForm
     , NewLoom (..)
     , newLoomForm
     , DeckInvite (..)
     , deckInviteForm
+    , ProjectInvite (..)
+    , projectInviteForm
     --, NewProjectCollab (..)
     --, newProjectCollabForm
     --, editProjectForm
@@ -56,6 +60,16 @@ newDeckForm = renderDivs $ NewDeck
     <$> areq textField "Name*"       Nothing
     <*> areq textField "Description" Nothing
 
+data NewProject = NewProject
+    { npName  :: Text
+    , npDesc  :: Text
+    }
+
+newProjectForm :: Form NewProject
+newProjectForm = renderDivs $ NewProject
+    <$> areq textField "Name*"       Nothing
+    <*> areq textField "Description" Nothing
+
 data NewLoom = NewLoom
     { nlName  :: Text
     , nlDesc  :: Text
@@ -115,6 +129,38 @@ deckInviteForm deckID = renderDivs $ DeckInvite
             l
     selectRole = selectField optionsEnum
 
+data ProjectInvite = ProjectInvite
+    { jiPerson :: PersonId
+    , jiRole   :: AP.Role
+    }
+
+projectInviteForm :: ProjectId -> Form ProjectInvite
+projectInviteForm projectID = renderDivs $ ProjectInvite
+    <$> areq selectPerson "Person*" Nothing
+    <*> areq selectRole   "Role*"   Nothing
+    where
+    selectPerson = selectField $ do
+        l <- runDB $ E.select $
+            E.from $ \ (person `E.InnerJoin` actor `E.LeftOuterJoin` (recip `E.InnerJoin` topic)) -> do
+                E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicProjectCollab E.&&.
+                       topic E.^. CollabTopicProjectProject E.==. E.val projectID
+                E.on $ person E.^. PersonId E.==. recip E.^. CollabRecipLocalPerson
+                E.on $ person E.^. PersonActor E.==. actor E.^. ActorId
+                E.where_ $ E.isNothing $ E.just $ recip E.^. CollabRecipLocalId
+                return (person, actor)
+        optionsPairs $
+            map (\ (Entity pid p, Entity _ a) ->
+                    ( T.concat
+                        [ actorName a
+                        , " ~"
+                        , username2text $ personUsername p
+                        ]
+                    , pid
+                    )
+                )
+            l
+    selectRole = selectField optionsEnum
+
 {-
 editProjectAForm :: SharerId -> Entity Project -> AForm Handler Project
 editProjectAForm sid (Entity jid project) = Project

src/Vervis/Foundation.hs

@@ -157,6 +157,7 @@ type LoomKeyHashid              = KeyHashid Loom
 type TicketDeckKeyHashid        = KeyHashid TicketDeck
 type TicketLoomKeyHashid        = KeyHashid TicketLoom
 type SigKeyKeyHashid            = KeyHashid SigKey
+type ProjectKeyHashid           = KeyHashid Project
 
 -- This is where we define all of the routes in our application. For a full
 -- explanation of the syntax, please see:
@@ -982,3 +983,20 @@ instance YesodBreadcrumbs App where
         ClothReplyOnR l c _ -> ("Reply", Just $ ClothR l c)
 
         ClothDepR l c p -> (keyHashidText p, Just $ ClothDepsR l c)
+
+        ProjectR d             -> ("Project $" <> keyHashidText d, Just HomeR)
+        ProjectInboxR d        -> ("Inbox", Just $ ProjectR d)
+        ProjectOutboxR d       -> ("Outbox", Just $ ProjectR d)
+        ProjectOutboxItemR d i -> (keyHashidText i, Just $ ProjectOutboxR d)
+        ProjectFollowersR d    -> ("Followers", Just $ ProjectR d)
+
+        ProjectMessageR d m -> ("Message #" <> keyHashidText m, Just $ ProjectR d)
+
+        ProjectNewR        -> ("New Project", Just HomeR)
+
+        ProjectStampR d k -> ("Stamp #" <> keyHashidText k, Just $ ProjectR d)
+
+        ProjectCollabsR d -> ("Collaborators", Just $ ProjectR d)
+
+        ProjectInviteR d  -> ("Invite", Just $ ProjectR d)
+        ProjectRemoveR _ _ -> ("", Nothing)

src/Vervis/Handler/Client.hs

@@ -122,7 +122,7 @@ getHomeR = do
     where
     personalOverview :: Entity Person -> Handler Html
     personalOverview (Entity pid _person) = do
-        (repos, decks, looms) <- runDB $ (,,)
+        (repos, decks, looms, projects) <- runDB $ (,,,)
             <$> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` repo `E.InnerJoin` actor) -> do
                     E.on $ repo E.^. RepoActor E.==. actor E.^. ActorId
                     E.on $ topic E.^. CollabTopicRepoRepo E.==. repo E.^. RepoId
@@ -153,15 +153,26 @@ getHomeR = do
                     E.orderBy [E.asc $ loom E.^. LoomId]
                     return (loom, actor, collab)
                 )
+            <*> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` project `E.InnerJoin` actor) -> do
+                    E.on $ project E.^. ProjectActor E.==. actor E.^. ActorId
+                    E.on $ topic E.^. CollabTopicProjectProject E.==. project E.^. ProjectId
+                    E.on $ topic E.^. CollabTopicProjectCollab E.==. enable E.^. CollabEnableCollab
+                    E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicProjectCollab
+                    E.on $ recip E.^. CollabRecipLocalCollab E.==. collab E.^. CollabId
+                    E.where_ $ recip E.^. CollabRecipLocalPerson E.==. E.val pid
+                    E.orderBy [E.asc $ project E.^. ProjectId]
+                    return (project, actor, collab)
+                )
         hashRepo <- getEncodeKeyHashid
         hashDeck <- getEncodeKeyHashid
         hashLoom <- getEncodeKeyHashid
+        hashProject <- getEncodeKeyHashid
         defaultLayout $(widgetFile "personal-overview")
 
 getBrowseR :: Handler Html
 getBrowseR = do
-    (people, groups, repos, decks, looms) <- runDB $
+    (people, groups, repos, decks, looms, projects) <- runDB $
-        (,,,,)
+        (,,,,,)
             <$> (E.select $ E.from $ \ (person `E.InnerJoin` actor) -> do
                     E.on $ person E.^. PersonActor E.==. actor E.^. ActorId
                     E.orderBy [E.asc $ person E.^. PersonId]
@@ -187,6 +198,11 @@ getBrowseR = do
                     E.orderBy [E.asc $ loom E.^. LoomId]
                     return (loom, actor)
                 )
+            <*> (E.select $ E.from $ \ (project `E.InnerJoin` actor) -> do
+                    E.on $ project E.^. ProjectActor E.==. actor E.^. ActorId
+                    E.orderBy [E.asc $ project E.^. ProjectId]
+                    return (project, actor)
+                )
         {-
         now <- liftIO getCurrentTime
         repoRows <- forM repos $
@@ -209,6 +225,7 @@ getBrowseR = do
     hashRepo <- getEncodeKeyHashid
     hashDeck <- getEncodeKeyHashid
     hashLoom <- getEncodeKeyHashid
+    hashProject <- getEncodeKeyHashid
     defaultLayout $ do
         setTitle "Welcome to Vervis!"
         $(widgetFile "browse")

src/Vervis/Handler/Project.hs

@@ -0,0 +1,332 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016, 2019, 2022, 2023 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/>.
+ -}
+
+module Vervis.Handler.Project
+    ( getProjectR
+    , getProjectInboxR
+    , postProjectInboxR
+    , getProjectOutboxR
+    , getProjectOutboxItemR
+    , getProjectFollowersR
+
+    , getProjectMessageR
+
+    , getProjectNewR
+    , postProjectNewR
+
+    , getProjectStampR
+
+    , getProjectCollabsR
+    , getProjectInviteR
+    , postProjectInviteR
+    , postProjectRemoveR
+    )
+where
+
+import Control.Applicative
+import Control.Monad
+import Control.Monad.Trans.Except
+import Control.Monad.Trans.Maybe
+import Data.Aeson
+import Data.Bitraversable
+import Data.ByteString (ByteString)
+import Data.Default.Class
+import Data.Foldable
+import Data.Maybe (fromMaybe)
+import Data.Text (Text)
+import Data.Time.Clock
+import Data.Traversable
+import Database.Persist
+import Network.HTTP.Types.Method
+import Text.Blaze.Html (Html)
+import Yesod.Auth (requireAuth)
+import Yesod.Core
+import Yesod.Core.Handler (redirect, setMessage, lookupPostParam, notFound)
+import Yesod.Form.Functions (runFormPost, runFormGet)
+import Yesod.Form.Types (FormResult (..))
+import Yesod.Persist.Core (runDB, get404, getBy404)
+
+import qualified Data.ByteString.Lazy as BL
+import qualified Database.Esqueleto as E
+
+import Database.Persist.JSON
+import Development.PatchMediaType
+import Network.FedURI
+import Web.ActivityPub hiding (Project (..), Repo (..), Actor (..), ActorDetail (..), ActorLocal (..))
+import Yesod.ActivityPub
+import Yesod.FedURI
+import Yesod.Hashids
+import Yesod.MonadSite
+
+import qualified Web.ActivityPub as AP
+
+import Control.Monad.Trans.Except.Local
+import Data.Either.Local
+import Data.Paginate.Local
+import Database.Persist.Local
+import Yesod.Form.Local
+import Yesod.Persist.Local
+
+import Vervis.Access
+import Vervis.API
+import Vervis.Federation.Auth
+import Vervis.Federation.Collab
+import Vervis.Federation.Discussion
+import Vervis.Federation.Offer
+import Vervis.Federation.Ticket
+import Vervis.FedURI
+import Vervis.Form.Ticket
+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
+import Vervis.Widget.Person
+import Vervis.Widget.Ticket
+import Vervis.Widget.Tracker
+
+import qualified Vervis.Client as C
+
+getProjectR :: KeyHashid Project -> Handler TypedContent
+getProjectR projectHash = do
+    projectID <- decodeKeyHashid404 projectHash
+    (project, actor, sigKeyIDs) <- runDB $ do
+        d <- get404 projectID
+        let aid = projectActor d
+        a <- getJust aid
+        sigKeys <- selectKeysList [SigKeyActor ==. aid] [Asc SigKeyId]
+        return (d, a, sigKeys)
+
+    encodeRouteLocal <- getEncodeRouteLocal
+    hashSigKey <- getEncodeKeyHashid
+    perActor <- asksSite $ appPerActorKeys . appSettings
+    let projectAP = AP.Project
+            { AP.projectActor = AP.Actor
+                { AP.actorLocal = AP.ActorLocal
+                    { AP.actorId         = encodeRouteLocal $ ProjectR projectHash
+                    , AP.actorInbox      = encodeRouteLocal $ ProjectInboxR projectHash
+                    , AP.actorOutbox     =
+                        Just $ encodeRouteLocal $ ProjectOutboxR projectHash
+                    , AP.actorFollowers  =
+                        Just $ encodeRouteLocal $ ProjectFollowersR projectHash
+                    , AP.actorFollowing  = Nothing
+                    , AP.actorPublicKeys =
+                        map (Left . encodeRouteLocal) $
+                        if perActor
+                            then map (ProjectStampR projectHash . hashSigKey) sigKeyIDs
+                            else [ActorKey1R, ActorKey2R]
+                    , AP.actorSshKeys    = []
+                    }
+                , AP.actorDetail = AP.ActorDetail
+                    { AP.actorType       = AP.ActorTypeProject
+                    , AP.actorUsername   = Nothing
+                    , AP.actorName       = Just $ actorName actor
+                    , AP.actorSummary    = Just $ actorDesc actor
+                    }
+                }
+            , AP.projectTracker    = Nothing
+            , AP.projectChildren   = []
+            , AP.projectParents    = []
+            , AP.projectComponents = []
+            }
+    provideHtmlAndAP projectAP $ redirectToPrettyJSON here
+    where
+    here = ProjectR projectHash
+
+getProjectInboxR :: KeyHashid Project -> Handler TypedContent
+getProjectInboxR = getInbox ProjectInboxR projectActor
+
+postProjectInboxR :: KeyHashid Project -> Handler ()
+postProjectInboxR projectHash = do
+    projectID <- decodeKeyHashid404 projectHash
+    postInbox $ LocalActorProject projectID
+
+getProjectOutboxR :: KeyHashid Project -> Handler TypedContent
+getProjectOutboxR = getOutbox ProjectOutboxR ProjectOutboxItemR projectActor
+
+getProjectOutboxItemR
+    :: KeyHashid Project -> KeyHashid OutboxItem -> Handler TypedContent
+getProjectOutboxItemR = getOutboxItem ProjectOutboxItemR projectActor
+
+getProjectFollowersR :: KeyHashid Project -> Handler TypedContent
+getProjectFollowersR = getActorFollowersCollection ProjectFollowersR projectActor
+
+getProjectMessageR :: KeyHashid Project -> KeyHashid LocalMessage -> Handler Html
+getProjectMessageR _ _ = notFound
+
+getProjectNewR :: Handler Html
+getProjectNewR = do
+    ((_result, widget), enctype) <- runFormPost newProjectForm
+    defaultLayout $(widgetFile "project/new")
+
+postProjectNewR :: Handler Html
+postProjectNewR = do
+    NewProject name desc <- runFormPostRedirect ProjectNewR newProjectForm
+
+    personEntity@(Entity personID person) <- requireAuth
+    personHash <- encodeKeyHashid personID
+    (maybeSummary, audience, detail) <- C.createProject personHash name desc
+    (localRecips, remoteRecips, fwdHosts, action) <-
+        C.makeServerInput Nothing maybeSummary audience $ AP.CreateActivity $ AP.Create (AP.CreateProject detail Nothing) Nothing
+    result <-
+        runExceptT $
+        handleViaActor personID Nothing localRecips remoteRecips fwdHosts action
+
+    case result of
+        Left e -> do
+            setMessage $ toHtml e
+            redirect ProjectNewR
+        Right createID -> do
+            maybeProjectID <- runDB $ getKeyBy $ UniqueProjectCreate createID
+            case maybeProjectID of
+                Nothing -> error "Can't find the newly created project"
+                Just projectID -> do
+                    projectHash <- encodeKeyHashid projectID
+                    setMessage "New project created"
+                    redirect $ ProjectR projectHash
+
+getProjectStampR :: KeyHashid Project -> KeyHashid SigKey -> Handler TypedContent
+getProjectStampR = servePerActorKey projectActor LocalActorProject
+
+getProjectCollabsR :: KeyHashid Project -> Handler Html
+getProjectCollabsR projectHash = do
+    projectID <- decodeKeyHashid404 projectHash
+    (project, actor, collabs, invites, joins) <- runDB $ do
+        project <- get404 projectID
+        actor <- getJust $ projectActor project
+        collabs <- do
+            grants <-
+                getTopicGrants CollabTopicProjectCollab CollabTopicProjectProject projectID
+            for grants $ \ (role, actor, ct, time) ->
+                (,role,ct,time) <$> getPersonWidgetInfo actor
+        invites <- do
+            invites' <-
+                getTopicInvites CollabTopicProjectCollab CollabTopicProjectProject projectID
+            for invites' $ \ (inviter, recip, time, role) -> (,,,)
+                <$> (getPersonWidgetInfo =<< bitraverse grabPerson pure inviter)
+                <*> getPersonWidgetInfo recip
+                <*> pure time
+                <*> pure role
+        joins <- do
+            joins' <-
+                getTopicJoins CollabTopicProjectCollab CollabTopicProjectProject projectID
+            for joins' $ \ (recip, time, role) ->
+                (,time,role) <$> getPersonWidgetInfo recip
+        return (project, actor, collabs, invites, joins)
+    defaultLayout $(widgetFile "project/collab/list")
+    where
+    grabPerson actorID = do
+        actorByKey <- getLocalActor actorID
+        case actorByKey of
+            LocalActorPerson personID -> return personID
+            _ -> error "Surprise, local inviter actor isn't a Person"
+
+getProjectInviteR :: KeyHashid Project -> Handler Html
+getProjectInviteR projectHash = do
+    projectID <- decodeKeyHashid404 projectHash
+    ((_result, widget), enctype) <- runFormPost $ projectInviteForm projectID
+    defaultLayout $(widgetFile "project/collab/new")
+
+postProjectInviteR :: KeyHashid Project -> Handler Html
+postProjectInviteR projectHash = do
+    projectID <- decodeKeyHashid404 projectHash
+    ProjectInvite recipPersonID role <-
+        runFormPostRedirect (ProjectInviteR projectHash) $ projectInviteForm projectID
+
+    personEntity@(Entity personID person) <- requireAuth
+    personHash <- encodeKeyHashid personID
+    recipPersonHash <- encodeKeyHashid recipPersonID
+    encodeRouteHome <- getEncodeRouteHome
+
+    result <- runExceptT $ do
+        (maybeSummary, audience, invite) <- do
+            let uRecipient = encodeRouteHome $ PersonR recipPersonHash
+                uResource = encodeRouteHome $ ProjectR projectHash
+            C.invite personID uRecipient uResource role
+        grantID <- do
+            maybeItem <- lift $ runDB $ getGrant CollabTopicProjectCollab CollabTopicProjectProject projectID personID
+            fromMaybeE maybeItem "You need to be a collaborator in the Project to invite people"
+        grantHash <- encodeKeyHashid grantID
+        let uCap = encodeRouteHome $ ProjectOutboxItemR projectHash grantHash
+        (localRecips, remoteRecips, fwdHosts, action) <-
+            C.makeServerInput (Just uCap) maybeSummary audience $ AP.InviteActivity invite
+        let cap =
+                Left (LocalActorProject projectID, LocalActorProject projectHash, grantID)
+        handleViaActor
+            personID (Just cap) localRecips remoteRecips fwdHosts action
+
+    case result of
+        Left e -> do
+            setMessage $ toHtml e
+            redirect $ ProjectInviteR projectHash
+        Right inviteID -> do
+            setMessage "Invite sent"
+            redirect $ ProjectCollabsR projectHash
+
+postProjectRemoveR :: KeyHashid Project -> CollabTopicProjectId -> Handler Html
+postProjectRemoveR projectHash ctID = do
+    projectID <- decodeKeyHashid404 projectHash
+
+    personEntity@(Entity personID person) <- requireAuth
+    personHash <- encodeKeyHashid personID
+    encodeRouteHome <- getEncodeRouteHome
+
+    result <- runExceptT $ do
+        mpidOrU <- lift $ runDB $ runMaybeT $ do
+            CollabTopicProject collabID projectID' <- MaybeT $ get ctID
+            guard $ projectID' == projectID
+            _ <- MaybeT $ getBy $ UniqueCollabEnable collabID
+            member <-
+                Left <$> MaybeT (getValBy $ UniqueCollabRecipLocal collabID) <|>
+                Right <$> MaybeT (getValBy $ UniqueCollabRecipRemote collabID)
+            lift $
+                bitraverse
+                    (pure . collabRecipLocalPerson)
+                    (getRemoteActorURI <=< getJust . collabRecipRemoteActor)
+                    member
+        pidOrU <- maybe notFound pure mpidOrU
+        (maybeSummary, audience, remove) <- do
+            uRecipient <-
+                case pidOrU of
+                    Left pid -> encodeRouteHome . PersonR <$> encodeKeyHashid pid
+                    Right u -> pure u
+            let uResource = encodeRouteHome $ ProjectR projectHash
+            C.remove personID uRecipient uResource
+        grantID <- do
+            maybeItem <- lift $ runDB $ getGrant CollabTopicProjectCollab CollabTopicProjectProject projectID personID
+            fromMaybeE maybeItem "You need to be a collaborator in the Project to remove people"
+        grantHash <- encodeKeyHashid grantID
+        let uCap = encodeRouteHome $ ProjectOutboxItemR projectHash grantHash
+        (localRecips, remoteRecips, fwdHosts, action) <-
+            C.makeServerInput (Just uCap) maybeSummary audience $ AP.RemoveActivity remove
+        let cap =
+                Left (LocalActorProject projectID, LocalActorProject projectHash, grantID)
+        handleViaActor
+            personID (Just cap) localRecips remoteRecips fwdHosts action
+
+    case result of
+        Left e -> do
+            setMessage $ toHtml e
+        Right removeID ->
+            setMessage "Remove sent"
+    redirect $ ProjectCollabsR projectHash

src/Vervis/Model.hs

@@ -100,6 +100,10 @@ instance Hashable LoomId where
     hashWithSalt salt = hashWithSalt salt . fromSqlKey
     hash = hash . fromSqlKey
 
+instance Hashable ProjectId where
+    hashWithSalt salt = hashWithSalt salt . fromSqlKey
+    hash = hash . fromSqlKey
+
 {-
 instance PersistEntityGraph Ticket TicketDependency where
     sourceParam = ticketDependencyParent

src/Vervis/Persist/Actor.hs

@@ -81,14 +81,16 @@ getLocalActorEnt actorID = do
     mr <- getBy $ UniqueRepoActor actorID
     md <- getBy $ UniqueDeckActor actorID
     ml <- getBy $ UniqueLoomActor actorID
+    mj <- getBy $ UniqueProjectActor actorID
     return $
-        case (mp, mg, mr, md, ml) of
+        case (mp, mg, mr, md, ml, mj) of
-            (Nothing, Nothing, Nothing, Nothing, Nothing) -> error "Unused ActorId"
+            (Nothing, Nothing, Nothing, Nothing, Nothing, Nothing) -> error "Unused ActorId"
-            (Just p, Nothing, Nothing, Nothing, Nothing) -> LocalActorPerson p
+            (Just p, Nothing, Nothing, Nothing, Nothing, Nothing) -> LocalActorPerson p
-            (Nothing, Just g, Nothing, Nothing, Nothing) -> LocalActorGroup g
+            (Nothing, Just g, Nothing, Nothing, Nothing, Nothing) -> LocalActorGroup g
-            (Nothing, Nothing, Just r, Nothing, Nothing) -> LocalActorRepo r
+            (Nothing, Nothing, Just r, Nothing, Nothing, Nothing) -> LocalActorRepo r
-            (Nothing, Nothing, Nothing, Just d, Nothing) -> LocalActorDeck d
+            (Nothing, Nothing, Nothing, Just d, Nothing, Nothing) -> LocalActorDeck d
-            (Nothing, Nothing, Nothing, Nothing, Just l) -> LocalActorLoom l
+            (Nothing, Nothing, Nothing, Nothing, Just l, Nothing) -> LocalActorLoom l
+            (Nothing, Nothing, Nothing, Nothing, Nothing, Just j) -> LocalActorProject j
             _ -> error "Multi-usage of an ActorId"
 
 getLocalActorEntity
@@ -105,6 +107,8 @@ getLocalActorEntity (LocalActorDeck d) =
     fmap (LocalActorDeck . Entity d) <$> get d
 getLocalActorEntity (LocalActorLoom l) =
     fmap (LocalActorLoom . Entity l) <$> get l
+getLocalActorEntity (LocalActorProject r) =
+    fmap (LocalActorProject . Entity r) <$> get r
 
 verifyLocalActivityExistsInDB
     :: MonadIO m

src/Vervis/Persist/Collab.hs

@@ -63,15 +63,18 @@ getCollabTopic collabID = do
     maybeRepo <- getValBy $ UniqueCollabTopicRepo collabID
     maybeDeck <- getValBy $ UniqueCollabTopicDeck collabID
     maybeLoom <- getValBy $ UniqueCollabTopicLoom collabID
+    maybeProject <- getValBy $ UniqueCollabTopicProject collabID
     return $
-        case (maybeRepo, maybeDeck, maybeLoom) of
+        case (maybeRepo, maybeDeck, maybeLoom, maybeProject) of
-            (Nothing, Nothing, Nothing) -> error "Found Collab without topic"
+            (Nothing, Nothing, Nothing, Nothing) -> error "Found Collab without topic"
-            (Just r, Nothing, Nothing) ->
+            (Just r, Nothing, Nothing, Nothing) ->
                 GrantResourceRepo $ collabTopicRepoRepo r
-            (Nothing, Just d, Nothing) ->
+            (Nothing, Just d, Nothing, Nothing) ->
                 GrantResourceDeck $ collabTopicDeckDeck d
-            (Nothing, Nothing, Just l) ->
+            (Nothing, Nothing, Just l, Nothing) ->
                 GrantResourceLoom $ collabTopicLoomLoom l
+            (Nothing, Nothing, Nothing, Just l) ->
+                GrantResourceProject $ collabTopicProjectProject l
             _ -> error "Found Collab with multiple topics"
 
 getCollabTopic'
@@ -80,15 +83,18 @@ getCollabTopic' collabID = do
     maybeRepo <- getBy $ UniqueCollabTopicRepo collabID
     maybeDeck <- getBy $ UniqueCollabTopicDeck collabID
     maybeLoom <- getBy $ UniqueCollabTopicLoom collabID
+    maybeProject <- getBy $ UniqueCollabTopicProject collabID
     return $
-        case (maybeRepo, maybeDeck, maybeLoom) of
+        case (maybeRepo, maybeDeck, maybeLoom, maybeProject) of
-            (Nothing, Nothing, Nothing) -> error "Found Collab without topic"
+            (Nothing, Nothing, Nothing, Nothing) -> error "Found Collab without topic"
-            (Just (Entity k r), Nothing, Nothing) ->
+            (Just (Entity k r), Nothing, Nothing, Nothing) ->
                 (delete k, GrantResourceRepo $ collabTopicRepoRepo r)
-            (Nothing, Just (Entity k d), Nothing) ->
+            (Nothing, Just (Entity k d), Nothing, Nothing) ->
                 (delete k, GrantResourceDeck $ collabTopicDeckDeck d)
-            (Nothing, Nothing, Just (Entity k l)) ->
+            (Nothing, Nothing, Just (Entity k l), Nothing) ->
                 (delete k, GrantResourceLoom $ collabTopicLoomLoom l)
+            (Nothing, Nothing, Nothing, Just (Entity k l)) ->
+                (delete k, GrantResourceProject $ collabTopicProjectProject l)
             _ -> error "Found Collab with multiple topics"
 
 getGrantRecip (GrantRecipPerson k) e = GrantRecipPerson <$> getEntityE k e
@@ -284,19 +290,7 @@ verifyCapability (capActor, capItem) actor resource requiredRole = do
         throwE "Collab recipient is someone else"
 
     -- Find the local topic, on which this Collab gives access
-    topic <- lift $ do
+    topic <- lift $ getCollabTopic collabID
-        maybeRepo <- getValBy $ UniqueCollabTopicRepo collabID
-        maybeDeck <- getValBy $ UniqueCollabTopicDeck collabID
-        maybeLoom <- getValBy $ UniqueCollabTopicLoom collabID
-        case (maybeRepo, maybeDeck, maybeLoom) of
-            (Nothing, Nothing, Nothing) -> error "Collab without topic"
-            (Just r, Nothing, Nothing) ->
-                return $ GrantResourceRepo $ collabTopicRepoRepo r
-            (Nothing, Just d, Nothing) ->
-                return $ GrantResourceDeck $ collabTopicDeckDeck d
-            (Nothing, Nothing, Just l) ->
-                return $ GrantResourceLoom $ collabTopicLoomLoom l
-            _ -> error "Collab with multiple topics"
 
     -- Verify that topic is indeed the sender of the Grant
     unless (grantResourceLocalActor topic == capActor) $

src/Vervis/Persist/Discussion.hs

@@ -1,6 +1,7 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2019, 2020, 2022, 2023
+ - by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -92,6 +93,9 @@ getLocalAuthor lmid aid name = do
             LocalActorLoom loomID -> do
                 loomHash <- encodeKeyHashid loomID
                 return $ "+" <> keyHashidText loomHash
+            LocalActorProject projectID -> do
+                projectHash <- encodeKeyHashid projectID
+                return $ "$" <> keyHashidText projectHash
     return $ MessageTreeNodeLocal lmid authorByKey code name
 
 getAllMessages :: AppDB DiscussionId -> Handler [MessageTreeNode]

src/Vervis/Recipient.hs

@@ -69,6 +69,7 @@ module Vervis.Recipient
     , RepoRoutes (..)
     , DeckRoutes (..)
     , LoomRoutes (..)
+    , ProjectRoutes (..)
     , DeckFamilyRoutes (..)
     , LoomFamilyRoutes (..)
     , RecipientRoutes (..)
@@ -192,6 +193,7 @@ parseLocalActor (GroupR gkhid)  = Just $ LocalActorGroup gkhid
 parseLocalActor (RepoR rkhid)   = Just $ LocalActorRepo rkhid
 parseLocalActor (DeckR dkhid)   = Just $ LocalActorDeck dkhid
 parseLocalActor (LoomR lkhid)   = Just $ LocalActorLoom lkhid
+parseLocalActor (ProjectR jkhid)   = Just $ LocalActorProject jkhid
 parseLocalActor _               = Nothing
 
 renderLocalActor :: LocalActor -> Route App
@@ -200,6 +202,7 @@ renderLocalActor (LocalActorGroup gkhid)  = GroupR gkhid
 renderLocalActor (LocalActorRepo rkhid)   = RepoR rkhid
 renderLocalActor (LocalActorDeck dkhid)   = DeckR dkhid
 renderLocalActor (LocalActorLoom lkhid)   = LoomR lkhid
+renderLocalActor (LocalActorProject jkhid)   = ProjectR jkhid
 
 data LocalStageBy f
     = LocalStagePersonFollowers (f Person)
@@ -213,6 +216,8 @@ data LocalStageBy f
 
     | LocalStageLoomFollowers   (f Loom)
     | LocalStageClothFollowers  (f Loom) (f TicketLoom)
+
+    | LocalStageProjectFollowers   (f Project)
     deriving (Generic, FunctorB, ConstraintsB)
 
 deriving instance AllBF Eq f LocalStageBy => Eq (LocalStageBy f)
@@ -235,6 +240,8 @@ parseLocalStage (LoomFollowersR lkhid) =
     Just $ LocalStageLoomFollowers lkhid
 parseLocalStage (ClothFollowersR lkhid ltkhid) =
     Just $ LocalStageClothFollowers lkhid ltkhid
+parseLocalStage (ProjectFollowersR jkhid) =
+    Just $ LocalStageProjectFollowers jkhid
 parseLocalStage _ = Nothing
 
 renderLocalStage :: LocalStage -> Route App
@@ -252,6 +259,8 @@ renderLocalStage (LocalStageLoomFollowers lkhid) =
     LoomFollowersR lkhid
 renderLocalStage (LocalStageClothFollowers lkhid ltkhid) =
     ClothFollowersR lkhid ltkhid
+renderLocalStage (LocalStageProjectFollowers jkhid) =
+    ProjectFollowersR jkhid
 
 parseLocalRecipient :: Route App -> Maybe (Either LocalActor LocalStage)
 parseLocalRecipient r =
@@ -263,6 +272,7 @@ localActorFollowers (LocalActorGroup g)  = LocalStageGroupFollowers g
 localActorFollowers (LocalActorRepo r)   = LocalStageRepoFollowers r
 localActorFollowers (LocalActorDeck d)   = LocalStageDeckFollowers d
 localActorFollowers (LocalActorLoom l)   = LocalStageLoomFollowers l
+localActorFollowers (LocalActorProject j)   = LocalStageProjectFollowers j
 
 -------------------------------------------------------------------------------
 -- Converting between KeyHashid, Key, Identity and Entity
@@ -327,6 +337,8 @@ hashLocalStagePure ctx = f
         LocalStageClothFollowers
             (encodeKeyHashidPure ctx l)
             (encodeKeyHashidPure ctx c)
+    f (LocalStageProjectFollowers j) =
+        LocalStageProjectFollowers $ encodeKeyHashidPure ctx j
 
 getHashLocalStage
     :: (MonadSite m, YesodHashids (SiteEnv m))
@@ -364,6 +376,8 @@ unhashLocalStagePure ctx = f
         LocalStageClothFollowers
             <$> decodeKeyHashidPure ctx l
             <*> decodeKeyHashidPure ctx c
+    f (LocalStageProjectFollowers j) =
+        LocalStageProjectFollowers <$> decodeKeyHashidPure ctx j
 
 unhashLocalStage
     :: (MonadSite m, YesodHashids (SiteEnv m))
@@ -405,6 +419,7 @@ getLocalActorID (LocalActorGroup g)  = fmap groupActor <$> get g
 getLocalActorID (LocalActorRepo r)   = fmap repoActor <$> get r
 getLocalActorID (LocalActorDeck d)   = fmap deckActor <$> get d
 getLocalActorID (LocalActorLoom l)   = fmap loomActor <$> get l
+getLocalActorID (LocalActorProject j)   = fmap projectActor <$> get j
 
 -------------------------------------------------------------------------------
 -- Intermediate recipient types
@@ -428,6 +443,8 @@ data LeafDeck = LeafDeck | LeafDeckFollowers deriving (Eq, Ord)
 
 data LeafLoom = LeafLoom | LeafLoomFollowers deriving (Eq, Ord)
 
+data LeafProject = LeafProject | LeafProjectFollowers deriving (Eq, Ord)
+
 data PieceDeck
     = PieceDeck LeafDeck
     | PieceTicket (KeyHashid TicketDeck) LeafTicket
@@ -444,6 +461,7 @@ data LocalRecipient
     | RecipRepo   (KeyHashid Repo)   LeafRepo
     | RecipDeck   (KeyHashid Deck)   PieceDeck
     | RecipLoom   (KeyHashid Loom)   PieceLoom
+    | RecipProject   (KeyHashid Project)   LeafProject
     deriving (Eq, Ord)
 
 recipientFromActor :: LocalActor -> LocalRecipient
@@ -457,6 +475,8 @@ recipientFromActor (LocalActorDeck dkhid) =
     RecipDeck dkhid $ PieceDeck LeafDeck
 recipientFromActor (LocalActorLoom lkhid) =
     RecipLoom lkhid $ PieceLoom LeafLoom
+recipientFromActor (LocalActorProject jkhid) =
+    RecipProject jkhid LeafProject
 
 recipientFromStage :: LocalStage -> LocalRecipient
 recipientFromStage (LocalStagePersonFollowers pkhid) =
@@ -473,6 +493,8 @@ recipientFromStage (LocalStageLoomFollowers lkhid) =
     RecipLoom lkhid $ PieceLoom LeafLoomFollowers
 recipientFromStage (LocalStageClothFollowers lkhid ltkhid) =
     RecipLoom lkhid $ PieceCloth ltkhid LeafClothFollowers
+recipientFromStage (LocalStageProjectFollowers jkhid) =
+    RecipProject jkhid LeafProjectFollowers
 
 -------------------------------------------------------------------------------
 -- Recipient set types
@@ -493,19 +515,22 @@ groupLocalRecipients = organize . partitionByActor
            , [(KeyHashid Repo, LeafRepo)]
            , [(KeyHashid Deck, PieceDeck)]
            , [(KeyHashid Loom, PieceLoom)]
+           , [(KeyHashid Project, LeafProject)]
            )
-    partitionByActor = foldl' f ([], [], [], [], [])
+    partitionByActor = foldl' f ([], [], [], [], [], [])
         where
-        f (p, g, r, d, l) (RecipPerson pkhid pleaf) =
+        f (p, g, r, d, l, j) (RecipPerson pkhid pleaf) =
-            ((pkhid, pleaf) : p, g, r, d, l)
+            ((pkhid, pleaf) : p, g, r, d, l, j)
-        f (p, g, r, d, l) (RecipGroup gkhid gleaf) =
+        f (p, g, r, d, l, j) (RecipGroup gkhid gleaf) =
-            (p, (gkhid, gleaf) : g, r, d, l)
+            (p, (gkhid, gleaf) : g, r, d, l, j)
-        f (p, g, r, d, l) (RecipRepo rkhid rleaf) =
+        f (p, g, r, d, l, j) (RecipRepo rkhid rleaf) =
-            (p, g, (rkhid, rleaf) : r, d, l)
+            (p, g, (rkhid, rleaf) : r, d, l, j)
-        f (p, g, r, d, l) (RecipDeck dkhid dpiece) =
+        f (p, g, r, d, l, j) (RecipDeck dkhid dpiece) =
-            (p, g, r, (dkhid, dpiece) : d, l)
+            (p, g, r, (dkhid, dpiece) : d, l, j)
-        f (p, g, r, d, l) (RecipLoom lkhid lpiece) =
+        f (p, g, r, d, l, j) (RecipLoom lkhid lpiece) =
-            (p, g, r, d, (lkhid, lpiece) : l)
+            (p, g, r, d, (lkhid, lpiece) : l, j)
+        f (p, g, r, d, l, j) (RecipProject jkhid jleaf) =
+            (p, g, r, d, l, (jkhid, jleaf) : j)
 
     organize
         :: ( [(KeyHashid Person, LeafPerson)]
@@ -513,9 +538,10 @@ groupLocalRecipients = organize . partitionByActor
            , [(KeyHashid Repo, LeafRepo)]
            , [(KeyHashid Deck, PieceDeck)]
            , [(KeyHashid Loom, PieceLoom)]
+           , [(KeyHashid Project, LeafProject)]
            )
         -> RecipientRoutes
-    organize (p, g, r, d, l) = RecipientRoutes
+    organize (p, g, r, d, l, j) = RecipientRoutes
         { recipPeople =
             map (second $ foldr orLP $ PersonRoutes False False) $ groupByKeySort p
         , recipGroups =
@@ -544,6 +570,8 @@ groupLocalRecipients = organize . partitionByActor
                     . partitionEithers . NE.toList . NE.map pl2either
                 ) $
             groupByKeySort l
+        , recipProjects =
+            map (second $ foldr orLJ $ ProjectRoutes False False) $ groupByKeySort j
         }
         where
         groupByKey :: (Foldable f, Eq a) => f (a, b) -> [(a, NonEmpty b)]
@@ -585,6 +613,11 @@ groupLocalRecipients = organize . partitionByActor
         orLC _                  cr@(ClothRoutes True) = cr
         orLC LeafClothFollowers cr@(ClothRoutes _)    = cr { routeClothFollowers = True }
 
+        orLJ :: LeafProject -> ProjectRoutes -> ProjectRoutes
+        orLJ _                 rr@(ProjectRoutes True True) = rr
+        orLJ LeafProject          rr@(ProjectRoutes _    _)    = rr { routeProject = True }
+        orLJ LeafProjectFollowers rr@(ProjectRoutes _    _)    = rr { routeProjectFollowers = True }
+
         pd2either :: PieceDeck -> Either LeafDeck (KeyHashid TicketDeck, LeafTicket)
         pd2either (PieceDeck ld)          = Left ld
         pd2either (PieceTicket ltkhid lt) = Right (ltkhid, lt)
@@ -622,6 +655,7 @@ localRecipSieve' sieve allowPeople allowOthers routes = RecipientRoutes
     , recipRepos  = applySieve' applyRepo recipRepos
     , recipDecks  = applySieve' applyDeck recipDecks
     , recipLooms  = applySieve' applyLoom recipLooms
+    , recipProjects  = applySieve' applyProject recipProjects
     }
     where
     applySieve
@@ -725,6 +759,17 @@ localRecipSieve' sieve allowPeople allowOthers routes = RecipientRoutes
                     then Nothing
                     else Just (lkhid, LoomFamilyRoutes loom cloths)
 
+    applyProject _     (This _) = Nothing
+    applyProject rkhid (That r) =
+        if allowOthers && routeProject r
+            then Just (rkhid, ProjectRoutes True False)
+            else Nothing
+    applyProject rkhid (These (ProjectRoutes r' rf') (ProjectRoutes r rf)) =
+        let merged = ProjectRoutes (r && (r' || allowOthers)) (rf && rf')
+        in  if merged == ProjectRoutes False False
+                then Nothing
+                else Just (rkhid, merged)
+
 actorIsAddressed :: RecipientRoutes -> LocalActor -> Bool
 actorIsAddressed recips = isJust . verify
     where
@@ -743,6 +788,9 @@ actorIsAddressed recips = isJust . verify
     verify (LocalActorLoom l) = do
         routes <- lookup l $ recipLooms recips
         guard $ routeLoom $ familyLoom routes
+    verify (LocalActorProject j) = do
+        routes <- lookup j $ recipProjects recips
+        guard $ routeProject routes
 
 data ParsedAudience u = ParsedAudience
     { paudLocalRecips  :: RecipientRoutes

src/Vervis/Web/Actor.hs

@@ -378,6 +378,8 @@ getLocalActors actorIDs = do
                 selectKeysList [DeckActor <-. actorIDs] []
             , map LocalActorLoom <$>
                 selectKeysList [LoomActor <-. actorIDs] []
+            , map LocalActorProject <$>
+                selectKeysList [ProjectActor <-. actorIDs] []
             ]
     case compare (length localActors) (length actorIDs) of
         LT -> error "Found actor ID not used by any specific actor"

src/Vervis/Widget/Tracker.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -16,6 +16,7 @@
 module Vervis.Widget.Tracker
     ( deckNavW
     , loomNavW
+    , projectNavW
     )
 where
 
@@ -38,3 +39,8 @@ loomNavW (Entity loomID loom) actor = do
     loomHash <- encodeKeyHashid loomID
     hashRepo <- getEncodeKeyHashid
     $(widgetFile "loom/widget/nav")
+
+projectNavW :: Entity Project -> Actor -> Widget
+projectNavW (Entity projectID project) actor = do
+    projectHash <- encodeKeyHashid projectID
+    $(widgetFile "project/widget/nav")

src/Web/ActivityPub.hs

@@ -1715,6 +1715,7 @@ data CreateObject u
     | CreateTicketTracker ActorDetail (Maybe (Authority u, ActorLocal u))
     | CreateRepository ActorDetail VersionControlSystem (Maybe (Authority u, ActorLocal u))
     | CreatePatchTracker ActorDetail (NonEmpty (ObjURI u)) (Maybe (Authority u, ActorLocal u))
+    | CreateProject ActorDetail (Maybe (Authority u, ActorLocal u))
 
 parseCreateObject :: UriMode u => Object -> Parser (CreateObject u)
 parseCreateObject o
@@ -1737,6 +1738,11 @@ parseCreateObject o
             repos <- o .:*+ "tracksPatchesFor"
             ml <- parseActorLocal o
             return $ CreatePatchTracker d repos ml
+    <|> do  d <- parseActorDetail o
+            unless (actorType d == ActorTypeProject) $
+                fail "type isn't Project"
+            ml <- parseActorLocal o
+            return $ CreateProject d ml
 
 encodeCreateObject :: UriMode u => CreateObject u -> Series
 encodeCreateObject (CreateNote h note) = toSeries h note
@@ -1751,6 +1757,8 @@ encodeCreateObject (CreatePatchTracker d repos ml)
     =  encodeActorDetail d
     <> "tracksPatchesFor" .=*+ repos
     <> maybe mempty (uncurry encodeActorLocal) ml
+encodeCreateObject (CreateProject d ml) =
+    encodeActorDetail d <> maybe mempty (uncurry encodeActorLocal) ml
 
 data Create u = Create
     { createObject :: CreateObject u
@@ -1770,6 +1778,7 @@ parseCreate o a luActor = do
         CreateTicketTracker _ _ -> return ()
         CreateRepository _ _ _ -> return ()
         CreatePatchTracker _ _ _ -> return ()
+        CreateProject _ _ -> return ()
     Create obj <$> o .:? "target"
 
 encodeCreate :: UriMode u => Create u -> Series

templates/browse.hamlet

@@ -1,6 +1,7 @@
 $# This file is part of Vervis.
 $#
-$# Written in 2016, 2018, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
+$# Written in 2016, 2018, 2019, 2022, 2023
+$# by fr33domlover <fr33domlover@riseup.net>.
 $#
 $# ♡ Copying is an act of love. Please copy, reuse and share.
 $#
@@ -96,3 +97,12 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
     <li>
       <a href=@{LoomR $ hashLoom loomID}>
         +#{keyHashidText $ hashLoom loomID} #{actorName actor}
+
+<h2>Projects
+
+<ul>
+  $forall (Entity projectID _, Entity _ actor) <- projects
+    <li>
+      <a href=@{ProjectR $ hashProject projectID}>
+        $#{keyHashidText $ hashProject projectID} #{actorName actor}
+        $# #{abcde}

templates/personal-overview.hamlet

@@ -33,6 +33,9 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
   <li>
     <a href=@{LoomNewR}>
       Create a new patch tracker
+  <li>
+    <a href=@{ProjectNewR}>
+      Create a new project
   <li>
     <a href=@{PublishOfferMergeR}>
       Open a merge request
@@ -85,3 +88,14 @@ $#       Comment on a ticket or merge request
       ]
       <a href=@{LoomR $ hashLoom loomID}>
         +#{keyHashidText $ hashLoom loomID} #{actorName actor}
+
+<h2>Your projects
+
+<ul>
+  $forall (Entity projectID _, Entity _ actor, Entity _ (Collab role)) <- projects
+    <li>
+      [
+      #{show role}
+      ]
+      <a href=@{ProjectR $ hashProject projectID}>
+        $#{keyHashidText $ hashProject projectID} #{actorName actor}

templates/project/collab/list.hamlet

@@ -0,0 +1,59 @@
+$# This file is part of Vervis.
+$#
+$# Written in 2016, 2019, 2022, 2023 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/>.
+
+^{projectNavW (Entity projectID project) actor}
+
+<h2>Collaborators
+
+<table>
+  <tr>
+    <th>Role
+    <th>Collaborator
+    <th>Since
+  $forall (person, role, ctID, since) <- collabs
+    <tr>
+      <td>#{show role}
+      <td>^{personLinkFedW person}
+      <td>#{showDate since}
+      <td>^{buttonW POST "Remove" (ProjectRemoveR projectHash ctID)}
+
+<h2>Invites
+
+<table>
+  <tr>
+    <th>Inviter
+    <th>Invitee
+    <th>Role
+    <th>Time
+  $forall (inviter, invitee, time, role) <- invites
+    <tr>
+      <td>^{personLinkFedW inviter}
+      <td>^{personLinkFedW invitee}
+      <td>#{show role}
+      <td>#{showDate time}
+
+<a href=@{ProjectInviteR projectHash}>Invite…
+
+<h2>Joins
+
+<table>
+  <tr>
+    <th>Joiner
+    <th>Role
+    <th>Time
+  $forall (joiner, time, role) <- joins
+    <tr>
+      <td>^{personLinkFedW joiner}
+      <td>#{show role}
+      <td>#{showDate time}

templates/project/collab/new.hamlet

@@ -0,0 +1,18 @@
+$# This file is part of Vervis.
+$#
+$# Written in 2016, 2023 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/>.
+
+<form method=POST action=@{ProjectInviteR projectHash} enctype=#{enctype}>
+  ^{widget}
+  <div class="submit">
+    <input type="submit">

templates/project/new.hamlet

@@ -0,0 +1,18 @@
+$# This file is part of Vervis.
+$#
+$# Written in 2016, 2022 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/>.
+
+<form method=POST action=@{ProjectNewR} enctype=#{enctype}>
+  ^{widget}
+  <div class="submit">
+      <input type="submit">

templates/project/widget/nav.hamlet

@@ -0,0 +1,36 @@
+$# This file is part of Vervis.
+$#
+$# Written in 2019, 2022, 2023 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=@{ProjectR projectHash}>
+      $#{keyHashidText projectHash} #{actorName actor}
+    ]] ::
+  <span>
+    <a href=@{ProjectInboxR projectHash}>
+      [📥 Inbox]
+  <span>
+    <a href=@{ProjectOutboxR projectHash}>
+      [📤 Outbox]
+  <span>
+    <a href=@{ProjectFollowersR projectHash}>
+      [🐤 Followers]
+  <span>
+    <a href=@{ProjectCollabsR projectHash}>
+      [🤝 Collaborators]
+  <span>
+    [No wiki]
+  <span>
+    [✏ Edit]

th/models

@@ -647,13 +647,6 @@ CollabRecipRemoteJoin
 
 -------------------------------- Collab topic --------------------------------
 
--- Removed for now, until I figure out whether/how to federate custom roles
---CollabRoleLocal
---    collab CollabId
---    role   RoleId
---
---    UniqueCollabRoleLocal collab
-
 CollabTopicRepo
     collab CollabId
     repo   RepoId
@@ -672,6 +665,12 @@ CollabTopicLoom
 
     UniqueCollabTopicLoom collab
 
+CollabTopicProject
+    collab  CollabId
+    project ProjectId
+
+    UniqueCollabTopicProject collab
+
 CollabEnable
     collab CollabId
     grant  OutboxItemId

th/routes

@@ -304,3 +304,21 @@
 
 -- /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/new-dep                         ClothDepNewR    GET POST
 -- /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/deps/#TicketDepKeyHashid/delete ClothDepDeleteR POST
+
+---- Project -----------------------------------------------------------------
+
+/projects/#ProjectKeyHashid                              ProjectR           GET
+/projects/#ProjectKeyHashid/inbox                        ProjectInboxR      GET POST
+/projects/#ProjectKeyHashid/outbox                       ProjectOutboxR     GET
+/projects/#ProjectKeyHashid/outbox/#OutboxItemKeyHashid  ProjectOutboxItemR GET
+/projects/#ProjectKeyHashid/followers                    ProjectFollowersR  GET
+
+/projects/#ProjectKeyHashid/messages/#LocalMessageKeyHashid ProjectMessageR GET
+
+/new-project                                             ProjectNewR        GET POST
+
+/projects/#ProjectKeyHashid/stamps/#SigKeyKeyHashid      ProjectStampR      GET
+
+/projects/#ProjectKeyHashid/collabs                      ProjectCollabsR    GET
+/projects/#ProjectKeyHashid/invite                       ProjectInviteR     GET POST
+/projects/#ProjectKeyHashid/remove/#CollabTopicProjectId ProjectRemoveR     POST

vervis.cabal

@@ -149,6 +149,7 @@ library
                        Vervis.Actor.Loom
                        Vervis.Actor.Person
                        Vervis.Actor.Person.Client
+                       Vervis.Actor.Project
                        Vervis.Actor.Repo
                        Vervis.API
                        Vervis.Avatar
@@ -210,6 +211,7 @@ library
                        Vervis.Handler.Person
                        Vervis.Handler.Repo
                        --Vervis.Handler.Role
+                       Vervis.Handler.Project
                        --Vervis.Handler.Sharer
                        Vervis.Handler.Ticket
                        -- Vervis.Handler.Wiki