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
This commit is contained in:
parent
3cda2205c5
commit
b3cd7ca28f
12 changed files with 517 additions and 58 deletions
|
@ -287,8 +287,10 @@ Project
|
||||||
wiki RepoId Maybe
|
wiki RepoId Maybe
|
||||||
collabUser RoleId Maybe
|
collabUser RoleId Maybe
|
||||||
collabAnon RoleId Maybe
|
collabAnon RoleId Maybe
|
||||||
|
create OutboxItemId
|
||||||
|
|
||||||
UniqueProjectActor actor
|
UniqueProjectActor actor
|
||||||
|
UniqueProjectCreate create
|
||||||
UniqueProject ident sharer
|
UniqueProject ident sharer
|
||||||
|
|
||||||
Repo
|
Repo
|
||||||
|
@ -645,3 +647,10 @@ CollabRecipRemote
|
||||||
actor RemoteActorId
|
actor RemoteActorId
|
||||||
|
|
||||||
UniqueCollabRecipRemote collab
|
UniqueCollabRecipRemote collab
|
||||||
|
|
||||||
|
-------------------------------- Collab reason -------------------------------
|
||||||
|
|
||||||
|
CollabFulfillsLocalTopicCreation
|
||||||
|
collab CollabId
|
||||||
|
|
||||||
|
UniqueCollabFulfillsLocalTopicCreation collab
|
||||||
|
|
4
migrations/2022_07_24_collab_fulfills.model
Normal file
4
migrations/2022_07_24_collab_fulfills.model
Normal file
|
@ -0,0 +1,4 @@
|
||||||
|
CollabFulfillsLocalTopicCreation
|
||||||
|
collab CollabId
|
||||||
|
|
||||||
|
UniqueCollabFulfillsLocalTopicCreation collab
|
52
migrations/2022_07_24_project_create.model
Normal file
52
migrations/2022_07_24_project_create.model
Normal file
|
@ -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
|
88
migrations/2022_07_25_collab_fulfills_mig.model
Normal file
88
migrations/2022_07_25_collab_fulfills_mig.model
Normal file
|
@ -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
|
|
@ -19,6 +19,7 @@ module Vervis.API
|
||||||
, noteC
|
, noteC
|
||||||
, createNoteC
|
, createNoteC
|
||||||
, createTicketC
|
, createTicketC
|
||||||
|
, createTicketTrackerC
|
||||||
, followC
|
, followC
|
||||||
, offerTicketC
|
, offerTicketC
|
||||||
, offerDepC
|
, offerDepC
|
||||||
|
@ -87,7 +88,7 @@ import Crypto.PublicVerifKey
|
||||||
import Database.Persist.JSON
|
import Database.Persist.JSON
|
||||||
import Network.FedURI
|
import Network.FedURI
|
||||||
import Network.HTTP.Digest
|
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.ActivityPub
|
||||||
import Yesod.Auth.Unverified
|
import Yesod.Auth.Unverified
|
||||||
import Yesod.FedURI
|
import Yesod.FedURI
|
||||||
|
@ -116,6 +117,7 @@ import Vervis.Git
|
||||||
import Vervis.Model
|
import Vervis.Model
|
||||||
import Vervis.Model.Ident
|
import Vervis.Model.Ident
|
||||||
import Vervis.Model.Role
|
import Vervis.Model.Role
|
||||||
|
import Vervis.Model.Workflow
|
||||||
import Development.PatchMediaType
|
import Development.PatchMediaType
|
||||||
import Vervis.Model.Ticket
|
import Vervis.Model.Ticket
|
||||||
import Vervis.RemoteActorStore
|
import Vervis.RemoteActorStore
|
||||||
|
@ -1729,6 +1731,191 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
|
||||||
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc accept]
|
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc accept]
|
||||||
return 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
|
data Followee
|
||||||
= FolloweeSharer ShrIdent
|
= FolloweeSharer ShrIdent
|
||||||
| FolloweeSharerTicket ShrIdent (KeyHashid TicketAuthorLocal)
|
| FolloweeSharerTicket ShrIdent (KeyHashid TicketAuthorLocal)
|
||||||
|
|
|
@ -31,6 +31,7 @@ module Vervis.Client
|
||||||
, unresolve
|
, unresolve
|
||||||
, createMR
|
, createMR
|
||||||
, offerMR
|
, offerMR
|
||||||
|
, createDeck
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -683,3 +684,28 @@ offerMR shrAuthor title desc uContext muBranch typ diff = runExceptT $ do
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
return (Nothing, Audience recips [] [] [] [] [], ticket)
|
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)
|
||||||
|
|
|
@ -42,8 +42,7 @@ import Development.PatchMediaType
|
||||||
import Vervis.Model.Workflow
|
import Vervis.Model.Workflow
|
||||||
|
|
||||||
data NewProject = NewProject
|
data NewProject = NewProject
|
||||||
{ npIdent :: PrjIdent
|
{ npName :: Text
|
||||||
, npName :: Maybe Text
|
|
||||||
, npDesc :: Maybe Text
|
, npDesc :: Maybe Text
|
||||||
, npWflow :: WorkflowId
|
, npWflow :: WorkflowId
|
||||||
, npRole :: Maybe RoleId
|
, npRole :: Maybe RoleId
|
||||||
|
@ -51,8 +50,7 @@ data NewProject = NewProject
|
||||||
|
|
||||||
newProjectAForm :: SharerId -> AForm Handler NewProject
|
newProjectAForm :: SharerId -> AForm Handler NewProject
|
||||||
newProjectAForm sid = NewProject
|
newProjectAForm sid = NewProject
|
||||||
<$> areq (newProjectIdentField sid) "Identifier*" Nothing
|
<$> areq textField "Name*" Nothing
|
||||||
<*> aopt textField "Name" Nothing
|
|
||||||
<*> aopt textField "Description" Nothing
|
<*> aopt textField "Description" Nothing
|
||||||
<*> areq selectWorkflow "Workflow*" Nothing
|
<*> areq selectWorkflow "Workflow*" Nothing
|
||||||
<*> aopt selectRole "Custom role" Nothing
|
<*> aopt selectRole "Custom role" Nothing
|
||||||
|
@ -123,6 +121,7 @@ editProjectAForm sid (Entity jid project) = Project
|
||||||
<*> aopt selectWiki "Wiki" (Just $ projectWiki project)
|
<*> aopt selectWiki "Wiki" (Just $ projectWiki project)
|
||||||
<*> aopt selectRole "User role" (Just $ projectCollabUser project)
|
<*> aopt selectRole "User role" (Just $ projectCollabUser project)
|
||||||
<*> aopt selectRole "Guest role" (Just $ projectCollabAnon project)
|
<*> aopt selectRole "Guest role" (Just $ projectCollabAnon project)
|
||||||
|
<*> pure (projectCreate project)
|
||||||
where
|
where
|
||||||
selectWiki =
|
selectWiki =
|
||||||
selectField $
|
selectField $
|
||||||
|
|
|
@ -32,6 +32,8 @@ module Vervis.Handler.Project
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
import Control.Monad
|
||||||
|
import Control.Monad.Trans.Except
|
||||||
import Data.Foldable
|
import Data.Foldable
|
||||||
import Data.Maybe (fromMaybe)
|
import Data.Maybe (fromMaybe)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
|
@ -40,7 +42,7 @@ import Data.Traversable
|
||||||
import Database.Persist
|
import Database.Persist
|
||||||
import Database.Esqueleto hiding (delete, (%), (==.))
|
import Database.Esqueleto hiding (delete, (%), (==.))
|
||||||
import Text.Blaze.Html (Html)
|
import Text.Blaze.Html (Html)
|
||||||
import Yesod.Auth (requireAuthId)
|
import Yesod.Auth (requireAuth)
|
||||||
import Yesod.Core
|
import Yesod.Core
|
||||||
import Yesod.Core.Handler (redirect, setMessage, lookupPostParam, notFound)
|
import Yesod.Core.Handler (redirect, setMessage, lookupPostParam, notFound)
|
||||||
import Yesod.Form.Functions (runFormPost)
|
import Yesod.Form.Functions (runFormPost)
|
||||||
|
@ -58,11 +60,13 @@ import Yesod.MonadSite
|
||||||
|
|
||||||
import qualified Web.ActivityPub as AP
|
import qualified Web.ActivityPub as AP
|
||||||
|
|
||||||
|
import Control.Monad.Trans.Except.Local
|
||||||
import Data.Either.Local
|
import Data.Either.Local
|
||||||
import Database.Persist.Local
|
import Database.Persist.Local
|
||||||
import Yesod.Persist.Local
|
import Yesod.Persist.Local
|
||||||
|
|
||||||
import Vervis.API
|
import Vervis.API
|
||||||
|
import Vervis.Client
|
||||||
import Vervis.Federation
|
import Vervis.Federation
|
||||||
import Vervis.Form.Project
|
import Vervis.Form.Project
|
||||||
import Vervis.Foundation
|
import Vervis.Foundation
|
||||||
|
@ -86,58 +90,31 @@ getProjectsR ident = do
|
||||||
|
|
||||||
postProjectsR :: ShrIdent -> Handler Html
|
postProjectsR :: ShrIdent -> Handler Html
|
||||||
postProjectsR shr = do
|
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
|
((result, widget), enctype) <- runFormPost $ newProjectForm sid
|
||||||
|
eprj <- runExceptT $ do
|
||||||
|
NewProject name mdesc _ _ <-
|
||||||
case result of
|
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")
|
defaultLayout $(widgetFile "project/new")
|
||||||
|
Right prj -> do
|
||||||
|
setMessage "Project created!"
|
||||||
|
redirect $ ProjectR shr prj
|
||||||
|
|
||||||
getProjectNewR :: ShrIdent -> Handler Html
|
getProjectNewR :: ShrIdent -> Handler Html
|
||||||
getProjectNewR shr = do
|
getProjectNewR shr = do
|
||||||
|
|
|
@ -1874,6 +1874,53 @@ changes hLocal ctx =
|
||||||
, removeField "Project" "outbox"
|
, removeField "Project" "outbox"
|
||||||
-- 296
|
-- 296
|
||||||
, removeField "Project" "followers"
|
, 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
|
migrateDB
|
||||||
|
|
|
@ -266,6 +266,21 @@ module Vervis.Migration.Model
|
||||||
, FollowerSet289Generic (..)
|
, FollowerSet289Generic (..)
|
||||||
, Actor289Generic (..)
|
, Actor289Generic (..)
|
||||||
, Project289Generic (..)
|
, Project289Generic (..)
|
||||||
|
, Outbox297Generic (..)
|
||||||
|
, OutboxItem297Generic (..)
|
||||||
|
, Project297
|
||||||
|
, Project297Generic (..)
|
||||||
|
, Person297Generic (..)
|
||||||
|
, model_2022_07_24
|
||||||
|
, CollabTopicLocalProject300
|
||||||
|
, CollabTopicLocalProject300Generic (..)
|
||||||
|
, CollabTopicLocalRepo300
|
||||||
|
, CollabTopicLocalRepo300Generic (..)
|
||||||
|
, CollabRecipLocal300Generic (..)
|
||||||
|
, Person300Generic (..)
|
||||||
|
, Project300Generic (..)
|
||||||
|
, Repo300Generic (..)
|
||||||
|
, CollabFulfillsLocalTopicCreation300Generic (..)
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -514,3 +529,12 @@ model_2022_07_17 = $(schema "2022_07_17_actor")
|
||||||
|
|
||||||
makeEntitiesMigration "289"
|
makeEntitiesMigration "289"
|
||||||
$(modelFile "migrations/2022_07_17_project_actor.model")
|
$(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")
|
||||||
|
|
|
@ -59,6 +59,7 @@ module Web.ActivityPub
|
||||||
, Hash (..)
|
, Hash (..)
|
||||||
, Commit (..)
|
, Commit (..)
|
||||||
, Branch (..)
|
, Branch (..)
|
||||||
|
, Role (..)
|
||||||
|
|
||||||
-- * Activity
|
-- * Activity
|
||||||
, Accept (..)
|
, Accept (..)
|
||||||
|
@ -68,6 +69,7 @@ module Web.ActivityPub
|
||||||
, CreateObject (..)
|
, CreateObject (..)
|
||||||
, Create (..)
|
, Create (..)
|
||||||
, Follow (..)
|
, Follow (..)
|
||||||
|
, Grant (..)
|
||||||
, OfferObject (..)
|
, OfferObject (..)
|
||||||
, Offer (..)
|
, Offer (..)
|
||||||
, Push (..)
|
, Push (..)
|
||||||
|
@ -1328,6 +1330,20 @@ instance ActivityPub Branch where
|
||||||
<> "ref" .= ref
|
<> "ref" .= ref
|
||||||
<> "context" .= ObjURI authority repo
|
<> "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
|
data Accept u = Accept
|
||||||
{ acceptObject :: ObjURI u
|
{ acceptObject :: ObjURI u
|
||||||
, acceptResult :: Maybe LocalURI
|
, acceptResult :: Maybe LocalURI
|
||||||
|
@ -1457,6 +1473,28 @@ encodeFollow (Follow obj mcontext hide)
|
||||||
<> "context" .=? mcontext
|
<> "context" .=? mcontext
|
||||||
<> "hide" .= hide
|
<> "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)
|
data OfferObject u = OfferTicket (Ticket u) | OfferDep (TicketDependency u)
|
||||||
|
|
||||||
instance ActivityPub OfferObject where
|
instance ActivityPub OfferObject where
|
||||||
|
@ -1568,6 +1606,7 @@ data SpecificActivity u
|
||||||
| ApplyActivity (Apply u)
|
| ApplyActivity (Apply u)
|
||||||
| CreateActivity (Create u)
|
| CreateActivity (Create u)
|
||||||
| FollowActivity (Follow u)
|
| FollowActivity (Follow u)
|
||||||
|
| GrantActivity (Grant u)
|
||||||
| OfferActivity (Offer u)
|
| OfferActivity (Offer u)
|
||||||
| PushActivity (Push u)
|
| PushActivity (Push u)
|
||||||
| RejectActivity (Reject u)
|
| RejectActivity (Reject u)
|
||||||
|
@ -1602,6 +1641,7 @@ instance ActivityPub Activity where
|
||||||
"Apply" -> ApplyActivity <$> parseApply o
|
"Apply" -> ApplyActivity <$> parseApply o
|
||||||
"Create" -> CreateActivity <$> parseCreate o a actor
|
"Create" -> CreateActivity <$> parseCreate o a actor
|
||||||
"Follow" -> FollowActivity <$> parseFollow o
|
"Follow" -> FollowActivity <$> parseFollow o
|
||||||
|
"Grant" -> GrantActivity <$> parseGrant o
|
||||||
"Offer" -> OfferActivity <$> parseOffer o a actor
|
"Offer" -> OfferActivity <$> parseOffer o a actor
|
||||||
"Push" -> PushActivity <$> parsePush a o
|
"Push" -> PushActivity <$> parsePush a o
|
||||||
"Reject" -> RejectActivity <$> parseReject o
|
"Reject" -> RejectActivity <$> parseReject o
|
||||||
|
@ -1625,6 +1665,7 @@ instance ActivityPub Activity where
|
||||||
activityType (ApplyActivity _) = "Apply"
|
activityType (ApplyActivity _) = "Apply"
|
||||||
activityType (CreateActivity _) = "Create"
|
activityType (CreateActivity _) = "Create"
|
||||||
activityType (FollowActivity _) = "Follow"
|
activityType (FollowActivity _) = "Follow"
|
||||||
|
activityType (GrantActivity _) = "Grant"
|
||||||
activityType (OfferActivity _) = "Offer"
|
activityType (OfferActivity _) = "Offer"
|
||||||
activityType (PushActivity _) = "Push"
|
activityType (PushActivity _) = "Push"
|
||||||
activityType (RejectActivity _) = "Reject"
|
activityType (RejectActivity _) = "Reject"
|
||||||
|
@ -1635,6 +1676,7 @@ instance ActivityPub Activity where
|
||||||
encodeSpecific _ _ (ApplyActivity a) = encodeApply a
|
encodeSpecific _ _ (ApplyActivity a) = encodeApply a
|
||||||
encodeSpecific _ _ (CreateActivity a) = encodeCreate a
|
encodeSpecific _ _ (CreateActivity a) = encodeCreate a
|
||||||
encodeSpecific _ _ (FollowActivity a) = encodeFollow a
|
encodeSpecific _ _ (FollowActivity a) = encodeFollow a
|
||||||
|
encodeSpecific _ _ (GrantActivity a) = encodeGrant a
|
||||||
encodeSpecific h u (OfferActivity a) = encodeOffer h u a
|
encodeSpecific h u (OfferActivity a) = encodeOffer h u a
|
||||||
encodeSpecific h _ (PushActivity a) = encodePush h a
|
encodeSpecific h _ (PushActivity a) = encodePush h a
|
||||||
encodeSpecific _ _ (RejectActivity a) = encodeReject a
|
encodeSpecific _ _ (RejectActivity a) = encodeReject a
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
$# This file is part of Vervis.
|
$# 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.
|
$# ♡ 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
|
$# with this software. If not, see
|
||||||
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
|
$# <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}>
|
<form method=POST action=@{ProjectsR shr} enctype=#{enctype}>
|
||||||
^{widget}
|
^{widget}
|
||||||
<div class="submit">
|
<div class="submit">
|
||||||
|
|
Loading…
Reference in a new issue