UI: Component, Project: Display teams, invites and action buttons
This commit is contained in:
Pere Lev
parent
97dee05af8
commit
0ee94afd9e
13 changed files with 384 additions and 23 deletions
|
|
@ -31,6 +31,7 @@ module Vervis.Form.Tracker
|
|||
, GroupInvite (..)
|
||||
, groupInviteForm
|
||||
, inviteForm
|
||||
, addTeamForm
|
||||
--, NewProjectCollab (..)
|
||||
--, newProjectCollabForm
|
||||
--, editProjectForm
|
||||
|
|
@ -225,6 +226,13 @@ inviteForm = renderDivs $ (,)
|
|||
selectRole :: Field Handler AP.Role
|
||||
selectRole = selectField optionsEnum
|
||||
|
||||
addTeamForm = renderDivs $ (,)
|
||||
<$> areq fedUriField "Team URI*" Nothing
|
||||
<*> areq selectRole "Role*" Nothing
|
||||
where
|
||||
selectRole :: Field Handler AP.Role
|
||||
selectRole = selectField optionsEnum
|
||||
|
||||
{-
|
||||
editProjectAForm :: SharerId -> Entity Project -> AForm Handler Project
|
||||
editProjectAForm sid (Entity jid project) = Project
|
||||
|
|
|
|||
|
|
@ -1076,6 +1076,11 @@ instance YesodBreadcrumbs App where
|
|||
ProjectApproveChildR _ _ -> ("", Nothing)
|
||||
ProjectApproveParentR _ _ -> ("", Nothing)
|
||||
|
||||
ProjectTeamsR j -> ("Teams", Just $ ProjectR j)
|
||||
ProjectAddTeamR _ -> ("", Nothing)
|
||||
ProjectApproveTeamR _ _ -> ("", Nothing)
|
||||
ProjectRemoveTeamR _ _ -> ("", Nothing)
|
||||
|
||||
PersonErrboxR p -> ("Errbox", Just $ PersonR p)
|
||||
GroupErrboxR g -> ("Errbox", Just $ GroupR g)
|
||||
ProjectErrboxR j -> ("Errbox", Just $ ProjectR j)
|
||||
|
|
|
|||
|
|
@ -434,6 +434,12 @@ getDeckCollabsR deckHash = do
|
|||
(DeckCollabsR deckHash)
|
||||
(DeckRemoveR deckHash)
|
||||
(DeckInviteR deckHash)
|
||||
(Just
|
||||
( DeckRemoveTeamR deckHash
|
||||
, DeckAddTeamR deckHash
|
||||
, DeckApproveTeamR deckHash
|
||||
)
|
||||
)
|
||||
(deckNavW (Entity deckID deck) actor)
|
||||
|
||||
postDeckInviteR :: KeyHashid Deck -> Handler Html
|
||||
|
|
@ -609,13 +615,10 @@ getDeckTeamsR deckHash = do
|
|||
komponentResource <$> getJust komponentID
|
||||
serveTeamsCollection (DeckR deckHash) (DeckTeamsR deckHash) resourceID
|
||||
|
||||
addTeamForm = renderDivs $
|
||||
areq fedUriField "(URI) Team" Nothing
|
||||
|
||||
postDeckAddTeamR :: KeyHashid Deck -> Handler ()
|
||||
postDeckAddTeamR deckHash = do
|
||||
deckID <- decodeKeyHashid404 deckHash
|
||||
uTeam <-
|
||||
(uTeam, role) <-
|
||||
runFormPostRedirect (DeckCollabsR deckHash) addTeamForm
|
||||
|
||||
personEntity@(Entity personID person) <- requireAuth
|
||||
|
|
@ -625,7 +628,7 @@ postDeckAddTeamR deckHash = do
|
|||
let uCollection = encodeRouteHome $ DeckTeamsR deckHash
|
||||
|
||||
result <- runExceptT $ do
|
||||
(maybeSummary, audience, add) <- C.add personID uTeam uCollection AP.RoleAdmin
|
||||
(maybeSummary, audience, add) <- C.add personID uTeam uCollection role
|
||||
cap <- do
|
||||
maybeItem <- lift $ runDB $ do
|
||||
resourceID <- deckResource <$> get404 deckID
|
||||
|
|
|
|||
|
|
@ -262,6 +262,7 @@ getGroupMembersR groupHash = do
|
|||
(GroupMembersR groupHash)
|
||||
(GroupRemoveR groupHash)
|
||||
(GroupInviteR groupHash)
|
||||
Nothing
|
||||
(groupNavW (Entity groupID group) actor)
|
||||
|
||||
postGroupInviteR :: KeyHashid Group -> Handler Html
|
||||
|
|
|
|||
|
|
@ -383,6 +383,12 @@ getLoomCollabsR loomHash = do
|
|||
(LoomCollabsR loomHash)
|
||||
(LoomRemoveR loomHash)
|
||||
(LoomInviteR loomHash)
|
||||
(Just
|
||||
( LoomRemoveTeamR loomHash
|
||||
, LoomAddTeamR loomHash
|
||||
, LoomApproveTeamR loomHash
|
||||
)
|
||||
)
|
||||
(loomNavW (Entity loomID loom) actor)
|
||||
|
||||
postLoomInviteR :: KeyHashid Loom -> Handler Html
|
||||
|
|
@ -425,13 +431,10 @@ getLoomTeamsR loomHash = do
|
|||
komponentResource <$> getJust komponentID
|
||||
serveTeamsCollection (LoomR loomHash) (LoomTeamsR loomHash) resourceID
|
||||
|
||||
addTeamForm = renderDivs $
|
||||
areq fedUriField "(URI) Team" Nothing
|
||||
|
||||
postLoomAddTeamR :: KeyHashid Loom -> Handler ()
|
||||
postLoomAddTeamR loomHash = do
|
||||
loomID <- decodeKeyHashid404 loomHash
|
||||
uTeam <-
|
||||
(uTeam, role) <-
|
||||
runFormPostRedirect (LoomCollabsR loomHash) addTeamForm
|
||||
|
||||
personEntity@(Entity personID person) <- requireAuth
|
||||
|
|
@ -441,7 +444,7 @@ postLoomAddTeamR loomHash = do
|
|||
let uCollection = encodeRouteHome $ LoomTeamsR loomHash
|
||||
|
||||
result <- runExceptT $ do
|
||||
(maybeSummary, audience, add) <- C.add personID uTeam uCollection AP.RoleAdmin
|
||||
(maybeSummary, audience, add) <- C.add personID uTeam uCollection role
|
||||
cap <- do
|
||||
maybeItem <- lift $ runDB $ do
|
||||
resourceID <- loomResource <$> get404 loomID
|
||||
|
|
|
|||
|
|
@ -53,6 +53,11 @@ module Vervis.Handler.Project
|
|||
, postProjectApproveComponentR
|
||||
, postProjectApproveChildR
|
||||
, postProjectApproveParentR
|
||||
|
||||
, getProjectTeamsR
|
||||
, postProjectAddTeamR
|
||||
, postProjectApproveTeamR
|
||||
, postProjectRemoveTeamR
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -185,6 +190,8 @@ getProjectR projectHash = do
|
|||
encodeRouteLocal $ ProjectComponentsR projectHash
|
||||
, AP.projectCollaborators =
|
||||
encodeRouteLocal $ ProjectCollabsR projectHash
|
||||
, AP.projectTeams =
|
||||
encodeRouteLocal $ ProjectTeamsR projectHash
|
||||
}
|
||||
provideHtmlAndAP projectAP $(widgetFile "project/one")
|
||||
where
|
||||
|
|
@ -262,6 +269,12 @@ getProjectCollabsR projectHash = do
|
|||
(ProjectCollabsR projectHash)
|
||||
(ProjectRemoveR projectHash)
|
||||
(ProjectInviteR projectHash)
|
||||
(Just
|
||||
( ProjectRemoveTeamR projectHash
|
||||
, ProjectAddTeamR projectHash
|
||||
, ProjectApproveTeamR projectHash
|
||||
)
|
||||
)
|
||||
(projectNavW (Entity projectID project) actor)
|
||||
|
||||
postProjectInviteR :: KeyHashid Project -> Handler Html
|
||||
|
|
@ -1219,3 +1232,142 @@ postProjectApproveParentR projectHash destID = do
|
|||
Right removeID ->
|
||||
setMessage "Accept sent"
|
||||
redirect $ ProjectParentsR projectHash
|
||||
|
||||
getProjectTeamsR :: KeyHashid Project -> Handler TypedContent
|
||||
getProjectTeamsR projectHash = do
|
||||
projectID <- decodeKeyHashid404 projectHash
|
||||
resourceID <- runDB $ projectResource <$> getJust projectID
|
||||
serveTeamsCollection (ProjectR projectHash) (ProjectTeamsR projectHash) resourceID
|
||||
|
||||
postProjectAddTeamR :: KeyHashid Project -> Handler ()
|
||||
postProjectAddTeamR projectHash = do
|
||||
projectID <- decodeKeyHashid404 projectHash
|
||||
(uTeam, role) <-
|
||||
runFormPostRedirect (ProjectCollabsR projectHash) addTeamForm
|
||||
|
||||
personEntity@(Entity personID person) <- requireAuth
|
||||
personHash <- encodeKeyHashid personID
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
let uCollection = encodeRouteHome $ ProjectTeamsR projectHash
|
||||
|
||||
result <- runExceptT $ do
|
||||
(maybeSummary, audience, add) <- C.add personID uTeam uCollection role
|
||||
cap <- do
|
||||
maybeItem <- lift $ runDB $ do
|
||||
resourceID <- projectResource <$> get404 projectID
|
||||
getCapability personID (Left resourceID) AP.RoleAdmin
|
||||
fromMaybeE maybeItem "You need to be have Admin access to the Project to add teams"
|
||||
uCap <- lift $ renderActivityURI cap
|
||||
(localRecips, remoteRecips, fwdHosts, action) <-
|
||||
C.makeServerInput (Just uCap) maybeSummary audience $ AP.AddActivity add
|
||||
let cap' = first (\ (la, i) -> (la, error "lah", i)) cap
|
||||
handleViaActor
|
||||
personID (Just cap') localRecips remoteRecips fwdHosts action
|
||||
|
||||
case result of
|
||||
Left e -> setMessage $ toHtml e
|
||||
Right inviteID -> setMessage "Add sent"
|
||||
redirect $ ProjectCollabsR projectHash
|
||||
|
||||
postProjectApproveTeamR :: KeyHashid Project -> SquadId -> Handler Html
|
||||
postProjectApproveTeamR projectHash squadID = do
|
||||
projectID <- decodeKeyHashid404 projectHash
|
||||
|
||||
personEntity@(Entity personID person) <- requireAuth
|
||||
personHash <- encodeKeyHashid personID
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
result <- runExceptT $ do
|
||||
mpidOrU <- lift $ runDB $ runMaybeT $ do
|
||||
project <- MaybeT $ get projectID
|
||||
Squad _ resourceID <- MaybeT $ get squadID
|
||||
guard $ resourceID == projectResource project
|
||||
|
||||
uAdd <- lift $ do
|
||||
add <- getSquadAdd squadID
|
||||
renderActivityURI add
|
||||
|
||||
topic <- lift $ bimap snd snd <$> getSquadTeam squadID
|
||||
lift $
|
||||
(projectResource project,uAdd,) <$>
|
||||
bitraverse
|
||||
pure
|
||||
(getRemoteActorURI <=< getJust)
|
||||
topic
|
||||
(resourceID, uAdd, pidOrU) <- maybe notFound pure mpidOrU
|
||||
(maybeSummary, audience, accept) <- do
|
||||
uTeam <-
|
||||
case pidOrU of
|
||||
Left g -> encodeRouteHome . GroupR <$> encodeKeyHashid g
|
||||
Right u -> pure u
|
||||
let uProject = encodeRouteHome $ ProjectR projectHash
|
||||
C.acceptParentChild personID uAdd uTeam uProject
|
||||
cap <- do
|
||||
maybeItem <- lift $ runDB $ getCapability personID (Left resourceID) AP.RoleAdmin
|
||||
fromMaybeE maybeItem "You need to be have Admin access to the Project to approve teams"
|
||||
uCap <- lift $ renderActivityURI cap
|
||||
(localRecips, remoteRecips, fwdHosts, action) <-
|
||||
C.makeServerInput (Just uCap) maybeSummary audience $ AP.AcceptActivity accept
|
||||
let cap' = first (\ (la, i) -> (la, error "lah", i)) cap
|
||||
handleViaActor
|
||||
personID (Just cap') localRecips remoteRecips fwdHosts action
|
||||
|
||||
case result of
|
||||
Left e -> do
|
||||
setMessage $ toHtml e
|
||||
Right removeID ->
|
||||
setMessage "Accept sent"
|
||||
redirect $ ProjectCollabsR projectHash
|
||||
|
||||
postProjectRemoveTeamR :: KeyHashid Project -> SquadId -> Handler Html
|
||||
postProjectRemoveTeamR projectHash squadID = do
|
||||
projectID <- decodeKeyHashid404 projectHash
|
||||
|
||||
personEntity@(Entity personID person) <- requireAuth
|
||||
personHash <- encodeKeyHashid personID
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
result <- runExceptT $ do
|
||||
mpidOrU <- lift $ runDB $ runMaybeT $ do
|
||||
project <- MaybeT $ get projectID
|
||||
Squad _ resourceID <- MaybeT $ get squadID
|
||||
guard $ resourceID == projectResource project
|
||||
acceptID <- MaybeT $ getKeyBy $ UniqueSquadUsAccept squadID
|
||||
_ <- MaybeT $ getBy $ UniqueSquadUsStart acceptID
|
||||
|
||||
uAdd <- lift $ do
|
||||
add <- getSquadAdd squadID
|
||||
renderActivityURI add
|
||||
|
||||
topic <- lift $ bimap snd snd <$> getSquadTeam squadID
|
||||
lift $
|
||||
(projectResource project,uAdd,) <$>
|
||||
bitraverse
|
||||
pure
|
||||
(getRemoteActorURI <=< getJust)
|
||||
topic
|
||||
(resourceID, uAdd, pidOrU) <- maybe notFound pure mpidOrU
|
||||
(maybeSummary, audience, remove) <- do
|
||||
uTeam <-
|
||||
case pidOrU of
|
||||
Left g -> encodeRouteHome . GroupR <$> encodeKeyHashid g
|
||||
Right u -> pure u
|
||||
let uCollection = encodeRouteHome $ ProjectTeamsR projectHash
|
||||
C.remove personID uTeam uCollection
|
||||
cap <- do
|
||||
maybeItem <- lift $ runDB $ getCapability personID (Left resourceID) AP.RoleAdmin
|
||||
fromMaybeE maybeItem "You need to be have Admin access to the Project to remove teams"
|
||||
uCap <- lift $ renderActivityURI cap
|
||||
(localRecips, remoteRecips, fwdHosts, action) <-
|
||||
C.makeServerInput (Just uCap) maybeSummary audience $ AP.RemoveActivity remove
|
||||
let cap' = first (\ (la, i) -> (la, error "lah", i)) cap
|
||||
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
|
||||
|
|
|
|||
|
|
@ -180,6 +180,7 @@ import Vervis.Federation.Offer
|
|||
import Vervis.FedURI
|
||||
import Vervis.Field.Person
|
||||
import Vervis.Form.Repo
|
||||
import Vervis.Form.Tracker
|
||||
import Vervis.Foundation
|
||||
import Vervis.Path
|
||||
import Vervis.Model
|
||||
|
|
@ -805,6 +806,12 @@ getRepoCollabsR repoHash = do
|
|||
(RepoCollabsR repoHash)
|
||||
(RepoRemoveR repoHash)
|
||||
(RepoInviteR repoHash)
|
||||
(Just
|
||||
( RepoRemoveTeamR repoHash
|
||||
, RepoAddTeamR repoHash
|
||||
, RepoApproveTeamR repoHash
|
||||
)
|
||||
)
|
||||
(repoNavW (Entity repoID repo) actor)
|
||||
|
||||
postRepoInviteR :: KeyHashid Repo -> Handler Html
|
||||
|
|
@ -848,13 +855,10 @@ getRepoTeamsR repoHash = do
|
|||
komponentResource <$> getJust komponentID
|
||||
serveTeamsCollection (RepoR repoHash) (RepoTeamsR repoHash) resourceID
|
||||
|
||||
addTeamForm = renderDivs $
|
||||
areq fedUriField "(URI) Team" Nothing
|
||||
|
||||
postRepoAddTeamR :: KeyHashid Repo -> Handler ()
|
||||
postRepoAddTeamR repoHash = do
|
||||
repoID <- decodeKeyHashid404 repoHash
|
||||
uTeam <-
|
||||
(uTeam, role) <-
|
||||
runFormPostRedirect (RepoCollabsR repoHash) addTeamForm
|
||||
|
||||
personEntity@(Entity personID person) <- requireAuth
|
||||
|
|
@ -864,7 +868,7 @@ postRepoAddTeamR repoHash = do
|
|||
let uCollection = encodeRouteHome $ RepoTeamsR repoHash
|
||||
|
||||
result <- runExceptT $ do
|
||||
(maybeSummary, audience, add) <- C.add personID uTeam uCollection AP.RoleAdmin
|
||||
(maybeSummary, audience, add) <- C.add personID uTeam uCollection role
|
||||
cap <- do
|
||||
maybeItem <- lift $ runDB $ do
|
||||
resourceID <- repoResource <$> get404 repoID
|
||||
|
|
|
|||
|
|
@ -62,6 +62,7 @@ module Vervis.Persist.Collab
|
|||
, getStemDrafts
|
||||
|
||||
, getResourceTeams
|
||||
, getResourceTeamDrafts
|
||||
|
||||
, getSquadAdd
|
||||
, getSquadTeam
|
||||
|
|
@ -1404,6 +1405,16 @@ getCapability personID actor role = do
|
|||
return $ Right u
|
||||
return $ maybeDirect' <|> maybeExt'
|
||||
|
||||
getStems
|
||||
:: MonadIO m
|
||||
=> KomponentId
|
||||
-> ReaderT SqlBackend m
|
||||
[ ( Either (ProjectId, Actor) (Instance, RemoteObject, RemoteActor)
|
||||
, AP.Role
|
||||
, UTCTime
|
||||
, StemId
|
||||
)
|
||||
]
|
||||
getStems komponentID = do
|
||||
stems <-
|
||||
E.select $ E.from $ \ (stem `E.InnerJoin` accept `E.InnerJoin` deleg `E.InnerJoin` grant) -> do
|
||||
|
|
@ -1428,6 +1439,19 @@ getStems komponentID = do
|
|||
j
|
||||
return (projectView, stemRole stem, time, stemID)
|
||||
|
||||
getStemDrafts
|
||||
:: MonadIO m
|
||||
=> KomponentId
|
||||
-> ReaderT SqlBackend m
|
||||
[ ( Either (LocalActorBy Key, Actor) (Instance, RemoteObject, RemoteActor)
|
||||
, Bool
|
||||
, Either (ProjectId, Actor) (Instance, RemoteObject, RemoteActor)
|
||||
, Bool
|
||||
, UTCTime
|
||||
, AP.Role
|
||||
, StemId
|
||||
)
|
||||
]
|
||||
getStemDrafts komponentID = do
|
||||
drafts <-
|
||||
E.select $ E.from $ \ (stem `E.LeftOuterJoin` accept `E.LeftOuterJoin` deleg) -> do
|
||||
|
|
@ -1541,6 +1565,73 @@ getResourceTeams resourceID =
|
|||
, squad E.^. SquadId
|
||||
)
|
||||
|
||||
getResourceTeamDrafts
|
||||
:: MonadIO m
|
||||
=> ResourceId
|
||||
-> ReaderT SqlBackend m
|
||||
[ ( Either (LocalActorBy Key, Actor) (Instance, RemoteObject, RemoteActor)
|
||||
, Bool
|
||||
, Either (GroupId, Actor) (Instance, RemoteObject, RemoteActor)
|
||||
, Bool
|
||||
, UTCTime
|
||||
, AP.Role
|
||||
, SquadId
|
||||
)
|
||||
]
|
||||
getResourceTeamDrafts resourceID = do
|
||||
squads <- E.select $ E.from $ \ (squad `E.LeftOuterJoin` accept `E.LeftOuterJoin` delegl `E.LeftOuterJoin` delegr) -> do
|
||||
E.on $ accept E.?. SquadUsAcceptId E.==. delegr E.?. SquadThemSendDelegatorRemoteSquad
|
||||
E.on $ accept E.?. SquadUsAcceptId E.==. delegl E.?. SquadThemSendDelegatorLocalSquad
|
||||
E.on $ E.just (squad E.^. SquadId) E.==. accept E.?. SquadUsAcceptSquad
|
||||
E.where_ $
|
||||
squad E.^. SquadHolder E.==. E.val resourceID E.&&.
|
||||
E.isNothing (delegl E.?. SquadThemSendDelegatorLocalId) E.&&.
|
||||
E.isNothing (delegr E.?. SquadThemSendDelegatorRemoteId)
|
||||
E.orderBy [E.asc $ squad E.^. SquadId]
|
||||
return squad
|
||||
for squads $ \ (Entity squadID (Squad role _)) -> do
|
||||
team <- do
|
||||
topic <- getSquadTeam squadID
|
||||
bitraverse
|
||||
(\ (_, gID) -> do
|
||||
g <- getJust gID
|
||||
actor <- getJust $ groupActor g
|
||||
return (gID, actor)
|
||||
)
|
||||
(\ (_, actorID) -> getRemoteActorData actorID)
|
||||
topic
|
||||
accept <- isJust <$> getBy (UniqueSquadUsAccept squadID)
|
||||
((inviter, time), us) <- do
|
||||
usOrThem <-
|
||||
requireEitherAlt
|
||||
(getKeyBy $ UniqueSquadOriginUs squadID)
|
||||
(getKeyBy $ UniqueSquadOriginThem squadID)
|
||||
"Neither us nor them"
|
||||
"Both us and them"
|
||||
(addOrActor, us) <-
|
||||
case usOrThem of
|
||||
Left _usID -> (,True) <$>
|
||||
requireEitherAlt
|
||||
(fmap squadUsGestureLocalActivity <$> getValBy (UniqueSquadUsGestureLocal squadID))
|
||||
(fmap (squadUsGestureRemoteActor &&& squadUsGestureRemoteActivity) <$> getValBy (UniqueSquadUsGestureRemote squadID))
|
||||
"Neither local not remote"
|
||||
"Both local and remote"
|
||||
Right themID -> (,False) <$>
|
||||
requireEitherAlt
|
||||
(fmap squadThemGestureLocalAdd <$> getValBy (UniqueSquadThemGestureLocal themID))
|
||||
(fmap (squadThemGestureRemoteActor &&& squadThemGestureRemoteAdd) <$> getValBy (UniqueSquadThemGestureRemote themID))
|
||||
"Neither local not remote"
|
||||
"Both local and remote"
|
||||
(,us) <$> case addOrActor of
|
||||
Left addID -> do
|
||||
OutboxItem outboxID _ time <- getJust addID
|
||||
Entity actorID actor <- getByJust $ UniqueActorOutbox outboxID
|
||||
(,time) . Left . (,actor) <$> getLocalActor actorID
|
||||
Right (actorID, addID) -> do
|
||||
RemoteActivity _ _ time <- getJust addID
|
||||
(,time) . Right <$> getRemoteActorData actorID
|
||||
return (inviter, us, team, accept, time, role, squadID)
|
||||
|
||||
getSquadAdd
|
||||
:: MonadIO m
|
||||
=> SquadId
|
||||
|
|
|
|||
|
|
@ -133,9 +133,14 @@ serveCollabs
|
|||
-> Route App
|
||||
-> (CollabId -> Route App)
|
||||
-> Route App
|
||||
-> Maybe
|
||||
( SquadId -> Route App
|
||||
, Route App
|
||||
, SquadId -> Route App
|
||||
)
|
||||
-> Widget
|
||||
-> Handler TypedContent
|
||||
serveCollabs rel resourceID meR hereR removeR inviteR navW = do
|
||||
serveCollabs rel resourceID meR hereR removeR inviteR maybeTeams navW = do
|
||||
collabs <- runDB $ getCollabs resourceID
|
||||
h <- asksSite siteInstanceHost
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
|
|
@ -174,13 +179,16 @@ serveCollabs rel resourceID meR hereR removeR inviteR navW = do
|
|||
haveAdmin <- fmap isJust $ handlerToWidget $ runDB $ runMaybeT $ do
|
||||
personID <- MaybeT $ pure mp
|
||||
MaybeT $ getCapability personID (Left resourceID) AP.RoleAdmin
|
||||
(invites, joins) <- handlerToWidget $ runDB $ do
|
||||
invites <- getCollabInvites resourceID
|
||||
joins <- getCollabJoins resourceID
|
||||
return (invites, joins)
|
||||
(invites, joins, teamsAndDrafts) <- handlerToWidget $ runDB $ (,,)
|
||||
<$> getCollabInvites resourceID
|
||||
<*> getCollabJoins resourceID
|
||||
<*> (for maybeTeams $ \ r -> (r,,)
|
||||
<$> getResourceTeams resourceID
|
||||
<*> getResourceTeamDrafts resourceID
|
||||
)
|
||||
[whamlet|
|
||||
^{navW}
|
||||
^{collabsW haveAdmin collabs invites joins removeR inviteR}
|
||||
^{collabsW haveAdmin collabs invites joins teamsAndDrafts removeR inviteR}
|
||||
|]
|
||||
|
||||
serveInviteCollab :: ResourceId -> Route App -> Handler Html
|
||||
|
|
|
|||
|
|
@ -245,9 +245,31 @@ collabsW
|
|||
, CollabId
|
||||
)
|
||||
]
|
||||
-> Maybe
|
||||
( ( SquadId -> Route App
|
||||
, Route App
|
||||
, SquadId -> Route App
|
||||
)
|
||||
, [ ( AP.Role
|
||||
, UTCTime
|
||||
, Either (GroupId, Actor) (Instance, RemoteObject, RemoteActor)
|
||||
, SquadId
|
||||
)
|
||||
]
|
||||
, [ ( Either (LocalActorBy Key, Actor) (Instance, RemoteObject, RemoteActor)
|
||||
, Bool
|
||||
, Either (GroupId, Actor) (Instance, RemoteObject, RemoteActor)
|
||||
, Bool
|
||||
, UTCTime
|
||||
, AP.Role
|
||||
, SquadId
|
||||
)
|
||||
]
|
||||
)
|
||||
-> (CollabId -> Route App)
|
||||
-> Route App
|
||||
-> Widget
|
||||
collabsW haveAdmin collabs invites joins removeR inviteR = do
|
||||
collabsW haveAdmin collabs invites joins teamsAndDrafts removeR inviteR = do
|
||||
((_, widgetIC), enctypeIC) <- handlerToWidget $ runFormPost inviteForm
|
||||
((_, widgetAT), enctypeAT) <- handlerToWidget $ runFormPost addTeamForm
|
||||
$(widgetFile "widget/collabs")
|
||||
|
|
|
|||
|
|
@ -920,6 +920,7 @@ data Project u = Project
|
|||
, projectParents :: LocalURI
|
||||
, projectComponents :: LocalURI
|
||||
, projectCollaborators :: LocalURI
|
||||
, projectTeams :: LocalURI
|
||||
}
|
||||
|
||||
instance ActivityPub Project where
|
||||
|
|
@ -935,13 +936,15 @@ instance ActivityPub Project where
|
|||
<*> withAuthorityO h (o .: "context")
|
||||
<*> withAuthorityO h (o .: "components")
|
||||
<*> withAuthorityO h (o .: "collaborators")
|
||||
toSeries h (Project actor tracker children parents components collabs)
|
||||
<*> withAuthorityO h (o .: "teams")
|
||||
toSeries h (Project actor tracker children parents components collabs teams)
|
||||
= toSeries h actor
|
||||
<> "ticketsTrackedBy" .=? tracker
|
||||
<> "subprojects" .= ObjURI h children
|
||||
<> "context" .= ObjURI h parents
|
||||
<> "components" .= ObjURI h components
|
||||
<> "collaborators" .= ObjURI h collabs
|
||||
<> "teams" .= ObjURI h teams
|
||||
|
||||
data Team u = Team
|
||||
{ teamActor :: Actor u
|
||||
|
|
|
|||
|
|
@ -13,6 +13,30 @@ $# 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/>.
|
||||
|
||||
$maybe ((removeTeamR, addTeamR, _approveTeamR), teams, _drafts) <- teamsAndDrafts
|
||||
<h2>Teams
|
||||
|
||||
<table>
|
||||
<tr>
|
||||
<th>Role
|
||||
<th>Since
|
||||
<th>Team
|
||||
$if haveAdmin
|
||||
<th>Remove
|
||||
$forall (role, since, team, squadID) <- teams
|
||||
<tr>
|
||||
<td>#{show role}
|
||||
<td>#{showDate since}
|
||||
<td>^{groupLinkFedW team}
|
||||
$if haveAdmin
|
||||
<td>^{buttonW POST "Remove" (removeTeamR squadID)}
|
||||
|
||||
$if haveAdmin
|
||||
<p>Add a team:
|
||||
<form method=POST action=@{addTeamR} enctype=#{enctypeAT}>
|
||||
^{widgetAT}
|
||||
<input type=submit>
|
||||
|
||||
<h2>Collaborators
|
||||
|
||||
<table>
|
||||
|
|
@ -36,6 +60,38 @@ $if haveAdmin
|
|||
^{widgetIC}
|
||||
<input type=submit>
|
||||
|
||||
$maybe ((_removeTeamR, _addTeamR, approveTeamR), _teams, drafts) <- teamsAndDrafts
|
||||
<h2>Team Invites
|
||||
|
||||
<table>
|
||||
<tr>
|
||||
<th>Inviter
|
||||
<th>Via
|
||||
<th>Invited team
|
||||
<th>I accepted?
|
||||
<th>Role
|
||||
<th>Time
|
||||
$if haveAdmin
|
||||
<th>Approve
|
||||
$forall (inviter, us, team, accept, time, role, squadID) <- drafts
|
||||
<tr>
|
||||
<td>^{actorLinkFedW inviter}
|
||||
<td>
|
||||
$if us
|
||||
Us
|
||||
$else
|
||||
Them
|
||||
<td>^{groupLinkFedW team}
|
||||
<td>
|
||||
$if accept
|
||||
[x]
|
||||
$else
|
||||
[_]
|
||||
<td>#{show role}
|
||||
<td>#{showDate time}
|
||||
$if haveAdmin && (not accept && not us)
|
||||
<td>^{buttonW POST "Approve" (approveTeamR squadID)}
|
||||
|
||||
<h2>Invites
|
||||
|
||||
<table>
|
||||
|
|
|
|||
|
|
@ -407,3 +407,8 @@
|
|||
/projects/#ProjectKeyHashid/component/approve/#ComponentId ProjectApproveComponentR POST
|
||||
/projects/#ProjectKeyHashid/child/approve/#SourceId ProjectApproveChildR POST
|
||||
/projects/#ProjectKeyHashid/parent/approve/#DestId ProjectApproveParentR POST
|
||||
|
||||
/projects/#ProjectKeyHashid/teams ProjectTeamsR GET
|
||||
/projects/#ProjectKeyHashid/add-team ProjectAddTeamR POST
|
||||
/projects/#ProjectKeyHashid/approve-team/#SquadId ProjectApproveTeamR POST
|
||||
/projects/#ProjectKeyHashid/remove-team/#SquadId ProjectRemoveTeamR POST
|
||||
|
|
|
|||
Loading…
Reference in a new issue