C2S: Implement ticket tracker creation

* Publish a Create activity and respond with a Grant activity
* postProjectsR reuses that code
* No automatic following at the moment
* Workflow and role specified in new project form are ignored for now
* Can't create tracker under a group yet, just under the user

config/models

@@ -287,8 +287,10 @@ Project
     wiki       RepoId        Maybe
     collabUser RoleId        Maybe
     collabAnon RoleId        Maybe
+    create     OutboxItemId
 
     UniqueProjectActor  actor
+    UniqueProjectCreate create
     UniqueProject ident sharer
 
 Repo
@@ -645,3 +647,10 @@ CollabRecipRemote
     actor  RemoteActorId
 
     UniqueCollabRecipRemote collab
+
+-------------------------------- Collab reason -------------------------------
+
+CollabFulfillsLocalTopicCreation
+    collab CollabId
+
+    UniqueCollabFulfillsLocalTopicCreation collab

migrations/2022_07_24_collab_fulfills.model

@@ -0,0 +1,4 @@
+CollabFulfillsLocalTopicCreation
+    collab CollabId
+
+    UniqueCollabFulfillsLocalTopicCreation collab

migrations/2022_07_24_project_create.model

@@ -0,0 +1,52 @@
+Outbox
+
+OutboxItem
+    outbox    OutboxId
+    activity  PersistJSONObject
+    published UTCTime
+
+Project
+    actor      Int64
+    ident      Text
+    sharer     SharerId
+    name       Text          Maybe
+    desc       Text          Maybe
+    workflow   Int64
+    nextTicket Int
+    wiki       Int64         Maybe
+    collabUser Int64         Maybe
+    collabAnon Int64         Maybe
+    create     OutboxItemId
+
+    UniqueProjectActor  actor
+    UniqueProjectCreate create
+    UniqueProject ident sharer
+
+Sharer
+    ident   Text
+    name    Text     Maybe
+    created UTCTime
+
+    UniqueSharer ident
+
+Person
+    ident               SharerId
+    login               Text
+    passphraseHash      ByteString
+    email               Text
+    verified            Bool
+    verifiedKey         Text
+    verifiedKeyCreated  UTCTime
+    resetPassKey        Text
+    resetPassKeyCreated UTCTime
+    about               Text
+    inbox               Int64
+    outbox              OutboxId
+    followers           Int64
+
+    UniquePersonIdent ident
+    UniquePersonLogin login
+    UniquePersonEmail email
+    UniquePersonInbox inbox
+    UniquePersonOutbox outbox
+    UniquePersonFollowers followers

migrations/2022_07_25_collab_fulfills_mig.model

@@ -0,0 +1,88 @@
+Collab
+
+CollabTopicLocalRepo
+    collab CollabId
+    repo   RepoId
+
+    UniqueCollabTopicLocalRepo collab
+
+CollabTopicLocalProject
+    collab  CollabId
+    project ProjectId
+
+    UniqueCollabTopicLocalProject collab
+
+CollabRecipLocal
+    collab CollabId
+    person PersonId
+
+    UniqueCollabRecipLocal collab
+
+CollabFulfillsLocalTopicCreation
+    collab CollabId
+
+    UniqueCollabFulfillsLocalTopicCreation collab
+
+Sharer
+    ident   ShrIdent
+    name    Text     Maybe
+    created UTCTime
+
+    UniqueSharer ident
+
+Person
+    ident               SharerId
+    login               Text
+    passphraseHash      ByteString
+    email               Text
+    verified            Bool
+    verifiedKey         Text
+    verifiedKeyCreated  UTCTime
+    resetPassKey        Text
+    resetPassKeyCreated UTCTime
+    about               Text
+    inbox               Int64
+    outbox              Int64
+    followers           Int64
+
+    UniquePersonIdent ident
+    UniquePersonLogin login
+    UniquePersonEmail email
+    UniquePersonInbox inbox
+    UniquePersonOutbox outbox
+    UniquePersonFollowers followers
+
+Project
+    actor      Int64
+    ident      Text
+    sharer     SharerId
+    name       Text          Maybe
+    desc       Text          Maybe
+    workflow   Int64
+    nextTicket Int
+    wiki       RepoId        Maybe
+    collabUser Int64         Maybe
+    collabAnon Int64         Maybe
+    create     Int64
+
+    UniqueProjectActor  actor
+    UniqueProjectCreate create
+    UniqueProject ident sharer
+
+Repo
+    ident      Text
+    sharer     SharerId
+    vcs        Text
+    project    ProjectId            Maybe
+    desc       Text                 Maybe
+    mainBranch Text
+    collabUser Int64                Maybe
+    collabAnon Int64                Maybe
+    inbox      Int64
+    outbox     Int64
+    followers  Int64
+
+    UniqueRepo ident sharer
+    UniqueRepoInbox inbox
+    UniqueRepoOutbox outbox
+    UniqueRepoFollowers followers

src/Vervis/API.hs

@@ -19,6 +19,7 @@ module Vervis.API
     , noteC
     , createNoteC
     , createTicketC
+    , createTicketTrackerC
     , followC
     , offerTicketC
     , offerDepC
@@ -87,7 +88,7 @@ import Crypto.PublicVerifKey
 import Database.Persist.JSON
 import Network.FedURI
 import Network.HTTP.Digest
-import Web.ActivityPub hiding (Patch, Ticket, Follow, Repo (..), ActorLocal (..))
+import Web.ActivityPub hiding (Patch, Ticket, Follow, Repo (..), ActorLocal (..), ActorDetail (..), Actor (..))
 import Yesod.ActivityPub
 import Yesod.Auth.Unverified
 import Yesod.FedURI
@@ -116,6 +117,7 @@ import Vervis.Git
 import Vervis.Model
 import Vervis.Model.Ident
 import Vervis.Model.Role
+import Vervis.Model.Workflow
 import Development.PatchMediaType
 import Vervis.Model.Ticket
 import Vervis.RemoteActorStore
@@ -1729,6 +1731,191 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
         update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc accept]
         return accept
 
+createTicketTrackerC
+    :: Entity Person
+    -> Sharer
+    -> Maybe TextHtml
+    -> Audience URIMode
+    -> AP.ActorDetail
+    -> Maybe FedURI
+    -> ExceptT Text Handler OutboxItemId
+createTicketTrackerC (Entity pidUser personUser) sharerUser summary audience tracker muTarget = do
+
+    -- Check input
+    (name, msummary) <- parseTracker tracker
+    let shrUser = sharerIdent sharerUser
+    now <- liftIO getCurrentTime
+    verifyNothingE muTarget "'target' not supported in Create TicketTracker"
+    ParsedAudience localRecips remoteRecips blinded fwdHosts <- do
+        mrecips <- parseAudience audience
+        fromMaybeE mrecips "Create TicketTracker with no recipients"
+    checkFederation remoteRecips
+    (obiid, deliverHttpCreate, deliverHttpGrant) <- runDBExcept $ do
+
+        -- Insert new project to DB
+        obiidCreate <- lift $ insertEmptyOutboxItem (personOutbox personUser) now
+        wid <- findWorkflow $ personIdent personUser
+        (jid, prj, obidDeck, ibidDeck) <- lift $ insertDeck now name msummary obiidCreate wid
+
+        -- Insert the Create activity to author's outbox
+        docCreate <- lift $ insertCreateToOutbox shrUser now blinded name msummary obiidCreate prj
+
+        -- Deliver the Create activity to local recipients, and schedule
+        -- delivery for unavailable remote recipients
+        remoteRecipsHttpCreate <- do
+            let sieve = makeRecipientSet
+                    []
+                    [LocalPersonCollectionSharerFollowers shrUser]
+            moreRemoteRecips <-
+                lift $ deliverLocal' True (LocalActorSharer shrUser) (personInbox personUser) obiidCreate $
+                    localRecipSieve sieve False localRecips
+            checkFederation moreRemoteRecips
+            lift $ deliverRemoteDB'' fwdHosts obiidCreate remoteRecips moreRemoteRecips
+
+        -- Insert collaboration access for project's creator
+        obiidGrant <- lift $ insertEmptyOutboxItem obidDeck now
+        lift $ insertCollab jid obiidGrant
+
+        -- Insert a Grant activity to project's outbox
+        let grantRecipActors = [LocalActorSharer shrUser]
+            grantRecipCollections = [LocalPersonCollectionSharerFollowers shrUser]
+        docGrant <-
+            lift $ insertGrantToOutbox shrUser prj obiidCreate obiidGrant grantRecipActors grantRecipCollections
+
+        -- Deliver the Grant activity to local recipients, and schedule
+        -- delivery for unavailable remote recipients
+        remoteRecipsHttpGrant <- do
+            remoteRecips <-
+                lift $ deliverLocal' True (LocalActorProject shrUser prj) ibidDeck obiidGrant $
+                    makeRecipientSet grantRecipActors grantRecipCollections
+            checkFederation remoteRecips
+            lift $ deliverRemoteDB'' [] obiidGrant [] remoteRecips
+
+        -- Return instructions for HTTP delivery to remote recipients
+        return
+            ( obiidCreate
+            , deliverRemoteHttp' fwdHosts obiidCreate docCreate remoteRecipsHttpCreate
+            , deliverRemoteHttp' []       obiidGrant  docGrant  remoteRecipsHttpGrant
+            )
+
+    -- Launch asynchronous HTTP delivery of Create and Grant
+    lift $ do
+        forkWorker "createTicketTrackerC: async HTTP Create delivery" deliverHttpCreate
+        forkWorker "createTicketTrackerC: async HTTP Grant delivery" deliverHttpGrant
+
+    return obiid
+    where
+    parseTracker (AP.ActorDetail typ muser mname msummary) = do
+        unless (typ == AP.ActorTypeTicketTracker) $
+            error "createTicketTrackerC: Create object isn't a TicketTracker"
+        verifyNothingE muser "TicketTracker can't have a username"
+        name <- fromMaybeE mname "TicketTracker doesn't specify name"
+        return (name, msummary)
+
+    findWorkflow sid = do
+        mw <-
+            lift $
+                selectFirst
+                    ([WorkflowSharer ==. sid] ||. [WorkflowScope !=. WSSharer])
+                    [Asc WorkflowId]
+        entityKey <$> fromMaybeE mw "Can't find a suitable workflow"
+
+    insertDeck now name msummary obiidCreate wid = do
+        ibid <- insert Inbox
+        obid <- insert Outbox
+        fsid <- insert FollowerSet
+        aid <- insert Actor
+            { actorName      = name
+            , actorDesc      = fromMaybe "" msummary
+            , actorCreatedAt = now
+            , actorInbox     = ibid
+            , actorOutbox    = obid
+            , actorFollowers = fsid
+            }
+        let ident = text2prj $ "actor_id_" <> T.pack (show $ fromSqlKey aid)
+        jid <- insert Project
+            { projectActor      = aid
+            , projectIdent      = ident
+            , projectSharer     = personIdent personUser
+            , projectName       = Just name
+            , projectDesc       = msummary
+            , projectWorkflow   = wid
+            , projectNextTicket = 1
+            , projectWiki       = Nothing
+            , projectCollabAnon = Nothing
+            , projectCollabUser = Nothing
+            , projectCreate     = obiidCreate
+            }
+        return (jid, ident, obid, ibid)
+
+    insertCreateToOutbox shrUser now blinded name msummary obiidCreate prj = do
+        encodeRouteLocal <- getEncodeRouteLocal
+        hLocal <- asksSite siteInstanceHost
+        obikhid <- encodeKeyHashid obiidCreate
+        let ttdetail = AP.ActorDetail
+                { AP.actorType     = AP.ActorTypeTicketTracker
+                , AP.actorUsername = Nothing
+                , AP.actorName     = Just name
+                , AP.actorSummary  = msummary
+                }
+            ttlocal = AP.ActorLocal
+                { AP.actorId         = encodeRouteLocal $ ProjectR shrUser prj
+                , AP.actorInbox      = encodeRouteLocal $ ProjectInboxR shrUser prj
+                , AP.actorOutbox     = Nothing
+                , AP.actorFollowers  = Nothing
+                , AP.actorFollowing  = Nothing
+                , AP.actorPublicKeys = []
+                , AP.actorSshKeys    = []
+                }
+            create = Doc hLocal Activity
+                { activityId         = Just $ encodeRouteLocal $ SharerOutboxItemR shrUser obikhid
+                , activityActor      = encodeRouteLocal $ SharerR shrUser
+                , activityCapability = Nothing
+                , activitySummary    = summary
+                , activityAudience   = blinded
+                , activitySpecific   = CreateActivity Create
+                    { createObject   = CreateTicketTracker ttdetail (Just (hLocal, ttlocal))
+                    , createTarget = Nothing
+                    }
+                }
+        update obiidCreate [OutboxItemActivity =. persistJSONObjectFromDoc create]
+        return create
+
+    insertCollab jid obiidGrant = do
+        cid <- insert Collab
+        insert_ $ CollabTopicLocalProject cid jid
+        insert_ $ CollabSenderLocal cid obiidGrant
+        insert_ $ CollabRecipLocal cid pidUser
+        insert_ $ CollabFulfillsLocalTopicCreation cid
+
+    insertGrantToOutbox shrUser prj obiidCreate obiidGrant actors collections = do
+        encodeRouteLocal <- getEncodeRouteLocal
+        encodeRouteHome <- getEncodeRouteHome
+        hLocal <- asksSite siteInstanceHost
+        obikhidCreate <- encodeKeyHashid obiidCreate
+        obikhidGrant <- encodeKeyHashid obiidGrant
+        let recips =
+                map encodeRouteHome $
+                        map renderLocalActor actors ++
+                        map renderLocalPersonCollection collections
+            grant = Doc hLocal Activity
+                { activityId       =
+                    Just $ encodeRouteLocal $
+                        ProjectOutboxItemR shrUser prj obikhidGrant
+                , activityActor    = encodeRouteLocal $ ProjectR shrUser prj
+                , activityCapability = Nothing
+                , activitySummary  = Nothing
+                , activityAudience = Audience recips [] [] [] [] []
+                , activitySpecific = GrantActivity Grant
+                    { grantObject   = Left RoleAdmin
+                    , grantContext  = encodeRouteHome $ ProjectR shrUser prj
+                    , grantTarget   = encodeRouteHome $ SharerR shrUser
+                    , grantFulfills = Just $ encodeRouteHome $ SharerOutboxItemR shrUser obikhidCreate
+                    }
+                }
+        update obiidGrant [OutboxItemActivity =. persistJSONObjectFromDoc grant]
+        return grant
+
 data Followee
     = FolloweeSharer ShrIdent
     | FolloweeSharerTicket ShrIdent (KeyHashid TicketAuthorLocal)

src/Vervis/Client.hs

@@ -31,6 +31,7 @@ module Vervis.Client
     , unresolve
     , createMR
     , offerMR
+    , createDeck
     )
 where
 
@@ -683,3 +684,28 @@ offerMR shrAuthor title desc uContext muBranch typ diff = runExceptT $ do
                 )
             }
     return (Nothing, Audience recips [] [] [] [] [], ticket)
+
+createDeck
+    :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
+    => ShrIdent
+    -> Text
+    -> Maybe Text
+    -> m (Maybe TextHtml, Audience URIMode, AP.ActorDetail, Maybe FedURI)
+createDeck shrAuthor name mdesc = do
+    encodeRouteHome <- getEncodeRouteHome
+
+    let audAuthor =
+            AudLocal [] [LocalPersonCollectionSharerFollowers shrAuthor]
+
+        (_, _, _, audLocal, audRemote) = collectAudience [audAuthor]
+
+        recips = map encodeRouteHome audLocal ++ audRemote
+
+        detail = AP.ActorDetail
+            { AP.actorType     = AP.ActorTypeTicketTracker
+            , AP.actorUsername = Nothing
+            , AP.actorName     = Just name
+            , AP.actorSummary  = mdesc
+            }
+
+    return (Nothing, Audience recips [] [] [] [] [], detail, Nothing)

src/Vervis/Form/Project.hs

@@ -42,8 +42,7 @@ import Development.PatchMediaType
 import Vervis.Model.Workflow
 
 data NewProject = NewProject
-    { npIdent :: PrjIdent
+    { npName  :: Text
-    , npName  :: Maybe Text
     , npDesc  :: Maybe Text
     , npWflow :: WorkflowId
     , npRole  :: Maybe RoleId
@@ -51,8 +50,7 @@ data NewProject = NewProject
 
 newProjectAForm :: SharerId -> AForm Handler NewProject
 newProjectAForm sid = NewProject
-    <$> areq (newProjectIdentField sid) "Identifier*" Nothing
+    <$> areq textField                  "Name*"       Nothing
-    <*> aopt textField                  "Name"        Nothing
     <*> aopt textField                  "Description" Nothing
     <*> areq selectWorkflow             "Workflow*"   Nothing
     <*> aopt selectRole                 "Custom role" Nothing
@@ -123,6 +121,7 @@ editProjectAForm sid (Entity jid project) = Project
     <*> aopt selectWiki "Wiki"       (Just $ projectWiki project)
     <*> aopt selectRole "User role"  (Just $ projectCollabUser project)
     <*> aopt selectRole "Guest role" (Just $ projectCollabAnon project)
+    <*> pure                         (projectCreate project)
     where
     selectWiki =
         selectField $

src/Vervis/Handler/Project.hs

@@ -32,6 +32,8 @@ module Vervis.Handler.Project
     )
 where
 
+import Control.Monad
+import Control.Monad.Trans.Except
 import Data.Foldable
 import Data.Maybe (fromMaybe)
 import Data.Text (Text)
@@ -40,7 +42,7 @@ import Data.Traversable
 import Database.Persist
 import Database.Esqueleto hiding (delete, (%), (==.))
 import Text.Blaze.Html (Html)
-import Yesod.Auth (requireAuthId)
+import Yesod.Auth (requireAuth)
 import Yesod.Core
 import Yesod.Core.Handler (redirect, setMessage, lookupPostParam, notFound)
 import Yesod.Form.Functions (runFormPost)
@@ -58,11 +60,13 @@ import Yesod.MonadSite
 
 import qualified Web.ActivityPub as AP
 
+import Control.Monad.Trans.Except.Local
 import Data.Either.Local
 import Database.Persist.Local
 import Yesod.Persist.Local
 
 import Vervis.API
+import Vervis.Client
 import Vervis.Federation
 import Vervis.Form.Project
 import Vervis.Foundation
@@ -86,58 +90,31 @@ getProjectsR ident = do
 
 postProjectsR :: ShrIdent -> Handler Html
 postProjectsR shr = do
-    Entity sid _ <- runDB $ getBy404 $ UniqueSharer shr
+    ep@(Entity _ p) <- requireAuth
+    Entity sid s <- runDB $ do
+        _ <- getBy404 $ UniqueSharer shr
+        getJustEntity $ personIdent p
+    unless (sharerIdent s == shr) $
+        invalidArgs ["Trying to create project under someone/something else"]
     ((result, widget), enctype) <- runFormPost $ newProjectForm sid
+    eprj <- runExceptT $ do
+        NewProject name mdesc _ _ <-
             case result of
-        FormSuccess np -> do
+                FormSuccess np -> return np
-            now <- liftIO getCurrentTime
+                FormMissing -> throwE "Field(s) missing"
-            host <- asksSite siteInstanceHost
+                FormFailure _l -> throwE "Project creation failed, see below"
-            pid <- requireAuthId
+        (msummary, audience, detail, mtarget) <- lift $ createDeck shr name mdesc
-            runDB $ do
+        obiidCreate <- createTicketTrackerC ep s msummary audience detail mtarget
-                ibid <- insert Inbox
+        runDBExcept $ do
-                obid <- insert Outbox
+            mj <- lift $ getValBy $ UniqueProjectCreate obiidCreate
-                fsid <- insert FollowerSet
+            projectIdent <$> fromMaybeE mj "New project not found"
-                aid <- insert Actor
+    case eprj of
-                    { actorName      = fromMaybe "" $ npName np
+        Left e -> do
-                    , actorDesc      = fromMaybe "" $ npDesc np
+            setMessage $ toHtml e
-                    , actorCreatedAt = now
-                    , actorInbox     = ibid
-                    , actorOutbox    = obid
-                    , actorFollowers = fsid
-                    }
-                let project = Project
-                        { projectActor      = aid
-                        , projectIdent      = npIdent np
-                        , projectSharer     = sid
-                        , projectName       = npName np
-                        , projectDesc       = npDesc np
-                        , projectWorkflow   = npWflow np
-                        , projectNextTicket = 1
-                        , projectWiki       = Nothing
-                        , projectCollabAnon = Nothing
-                        , projectCollabUser = Nothing
-                        }
-                jid <- insert project
-
-                obiid <-
-                    insert $
-                        OutboxItem
-                            obid
-                            (persistJSONObjectFromDoc $ Doc host emptyActivity)
-                            now
-                cid <- insert Collab
-                for_ (npRole np) $ \ rlid -> insert_ $ CollabRoleLocal cid rlid
-                insert_ $ CollabTopicLocalProject cid jid
-                insert_ $ CollabSenderLocal cid obiid
-                insert_ $ CollabRecipLocal cid pid
-            setMessage "Project added."
-            redirect $ ProjectR shr (npIdent np)
-        FormMissing -> do
-            setMessage "Field(s) missing"
-            defaultLayout $(widgetFile "project/new")
-        FormFailure _l -> do
-            setMessage "Project creation failed, see below"
             defaultLayout $(widgetFile "project/new")
+        Right prj -> do
+            setMessage "Project created!"
+            redirect $ ProjectR shr prj
 
 getProjectNewR :: ShrIdent -> Handler Html
 getProjectNewR shr = do

src/Vervis/Migration.hs

@@ -1874,6 +1874,53 @@ changes hLocal ctx =
     , removeField "Project" "outbox"
       -- 296
     , removeField "Project" "followers"
+      -- 297
+    , addFieldRefRequired''
+        "Project"
+        (do obid <- insert Outbox297
+            let doc = persistJSONObjectFromDoc $ Doc hLocal emptyActivity
+            insertEntity $ OutboxItem297 obid doc defaultTime
+        )
+        (Just $ \ (Entity obiidTemp obiTemp) -> do
+            js <- selectList ([] :: [Filter Project297]) []
+            for_ js $ \ (Entity jid j) -> do
+                mp <- getValBy $ UniquePersonIdent297 $ project297Sharer j
+                p <-
+                    case mp of
+                        Nothing -> error "Project sharer isn't a Person"
+                        Just person -> return person
+                let doc = persistJSONObjectFromDoc $ Doc hLocal emptyActivity
+                obiid <-
+                    insert $ OutboxItem297 (person297Outbox p) doc defaultTime
+                update jid [Project297Create =. obiid]
+
+            delete obiidTemp
+            delete $ outboxItem297Outbox obiTemp
+        )
+        "create"
+        "OutboxItem"
+      -- 298
+    , addUnique "Project" $ Unique "UniqueProjectCreate" ["create"]
+      -- 299
+    , addEntities model_2022_07_24
+      -- 300
+    , unchecked $ lift $ do
+        ctsJ <- selectList ([] :: [Filter CollabTopicLocalProject300]) []
+        for_ ctsJ $ \ (Entity _ (CollabTopicLocalProject300 cid jid)) -> do
+            j <- getJust jid
+            mcr <- getValBy $ UniqueCollabRecipLocal300 cid
+            for_ mcr $ \ (CollabRecipLocal300 _ pid) -> do
+                p <- getJust pid
+                when (project300Sharer j == person300Ident p) $
+                    insert_ $ CollabFulfillsLocalTopicCreation300 cid
+        ctsR <- selectList ([] :: [Filter CollabTopicLocalRepo300]) []
+        for_ ctsR $ \ (Entity _ (CollabTopicLocalRepo300 cid rid)) -> do
+            r <- getJust rid
+            mcr <- getValBy $ UniqueCollabRecipLocal300 cid
+            for_ mcr $ \ (CollabRecipLocal300 _ pid) -> do
+                p <- getJust pid
+                when (repo300Sharer r == person300Ident p) $
+                    insert_ $ CollabFulfillsLocalTopicCreation300 cid
     ]
 
 migrateDB

src/Vervis/Migration/Model.hs

@@ -266,6 +266,21 @@ module Vervis.Migration.Model
     , FollowerSet289Generic (..)
     , Actor289Generic (..)
     , Project289Generic (..)
+    , Outbox297Generic (..)
+    , OutboxItem297Generic (..)
+    , Project297
+    , Project297Generic (..)
+    , Person297Generic (..)
+    , model_2022_07_24
+    , CollabTopicLocalProject300
+    , CollabTopicLocalProject300Generic (..)
+    , CollabTopicLocalRepo300
+    , CollabTopicLocalRepo300Generic (..)
+    , CollabRecipLocal300Generic (..)
+    , Person300Generic (..)
+    , Project300Generic (..)
+    , Repo300Generic (..)
+    , CollabFulfillsLocalTopicCreation300Generic (..)
     )
 where
 
@@ -514,3 +529,12 @@ model_2022_07_17 = $(schema "2022_07_17_actor")
 
 makeEntitiesMigration "289"
     $(modelFile "migrations/2022_07_17_project_actor.model")
+
+makeEntitiesMigration "297"
+    $(modelFile "migrations/2022_07_24_project_create.model")
+
+model_2022_07_24 :: [Entity SqlBackend]
+model_2022_07_24 = $(schema "2022_07_24_collab_fulfills")
+
+makeEntitiesMigration "300"
+    $(modelFile "migrations/2022_07_25_collab_fulfills_mig.model")

src/Web/ActivityPub.hs

@@ -59,6 +59,7 @@ module Web.ActivityPub
     , Hash (..)
     , Commit (..)
     , Branch (..)
+    , Role (..)
 
       -- * Activity
     , Accept (..)
@@ -68,6 +69,7 @@ module Web.ActivityPub
     , CreateObject (..)
     , Create (..)
     , Follow (..)
+    , Grant (..)
     , OfferObject (..)
     , Offer (..)
     , Push (..)
@@ -1328,6 +1330,20 @@ instance ActivityPub Branch where
         <> "ref"     .= ref
         <> "context" .= ObjURI authority repo
 
+data Role = RoleAdmin deriving Eq
+
+instance FromJSON Role where
+    parseJSON = withText "Role" parse
+        where
+        parse "https://forgefed.org/ns#admin" = pure RoleAdmin
+        parse t = fail $ "Unknown role: " ++ T.unpack t
+
+instance ToJSON Role where
+    toJSON = error "toJSON Role"
+    toEncoding r =
+        toEncoding $ case r of
+            RoleAdmin -> "https://forgefed.org/ns#admin" :: Text
+
 data Accept u = Accept
     { acceptObject :: ObjURI u
     , acceptResult :: Maybe LocalURI
@@ -1457,6 +1473,28 @@ encodeFollow (Follow obj mcontext hide)
     <> "context" .=? mcontext
     <> "hide"    .=  hide
 
+data Grant u = Grant
+    { grantObject   :: Either Role (ObjURI u)
+    , grantContext  :: ObjURI u
+    , grantTarget   :: ObjURI u
+    , grantFulfills :: Maybe (ObjURI u)
+    }
+
+parseGrant :: UriMode u => Object -> Parser (Grant u)
+parseGrant o =
+    Grant
+        <$> o .: "object"
+        <*> o .: "context"
+        <*> o .: "target"
+        <*> o .:? "fulfills"
+
+encodeGrant :: UriMode u => Grant u -> Series
+encodeGrant (Grant obj context target mfulfills)
+    =  "object"  .= obj
+    <> "context" .= context
+    <> "target"  .= target
+    <> "fulfills" .=? mfulfills
+
 data OfferObject u = OfferTicket (Ticket u) | OfferDep (TicketDependency u)
 
 instance ActivityPub OfferObject where
@@ -1568,6 +1606,7 @@ data SpecificActivity u
     | ApplyActivity   (Apply u)
     | CreateActivity  (Create u)
     | FollowActivity  (Follow u)
+    | GrantActivity   (Grant u)
     | OfferActivity   (Offer u)
     | PushActivity    (Push u)
     | RejectActivity  (Reject u)
@@ -1602,6 +1641,7 @@ instance ActivityPub Activity where
                         "Apply"   -> ApplyActivity   <$> parseApply o
                         "Create"  -> CreateActivity  <$> parseCreate o a actor
                         "Follow"  -> FollowActivity  <$> parseFollow o
+                        "Grant"   -> GrantActivity   <$> parseGrant o
                         "Offer"   -> OfferActivity   <$> parseOffer o a actor
                         "Push"    -> PushActivity    <$> parsePush a o
                         "Reject"  -> RejectActivity  <$> parseReject o
@@ -1625,6 +1665,7 @@ instance ActivityPub Activity where
         activityType (ApplyActivity _)   = "Apply"
         activityType (CreateActivity _)  = "Create"
         activityType (FollowActivity _)  = "Follow"
+        activityType (GrantActivity _)   = "Grant"
         activityType (OfferActivity _)   = "Offer"
         activityType (PushActivity _)    = "Push"
         activityType (RejectActivity _)  = "Reject"
@@ -1635,6 +1676,7 @@ instance ActivityPub Activity where
         encodeSpecific _ _ (ApplyActivity a)   = encodeApply a
         encodeSpecific _ _ (CreateActivity a)  = encodeCreate a
         encodeSpecific _ _ (FollowActivity a)  = encodeFollow a
+        encodeSpecific _ _ (GrantActivity a)   = encodeGrant a
         encodeSpecific h u (OfferActivity a)   = encodeOffer h u a
         encodeSpecific h _ (PushActivity a)    = encodePush h a
         encodeSpecific _ _ (RejectActivity a)  = encodeReject a

templates/project/new.hamlet

@@ -1,6 +1,6 @@
 $# This file is part of Vervis.
 $#
-$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+$# Written in 2016, 2022 by fr33domlover <fr33domlover@riseup.net>.
 $#
 $# ♡ Copying is an act of love. Please copy, reuse and share.
 $#
@@ -12,6 +12,10 @@ $# 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/>.
 
+<p>
+  NOTE: Your workflow and role choices will be ignored. They're temporarily
+  not in use while these features are being federated.
+
 <form method=POST action=@{ProjectsR shr} enctype=#{enctype}>
   ^{widget}
   <div class="submit">