Vocab, UI: Component: Specify and serve teams collection
This commit is contained in:
parent
46cb13e5b0
commit
6de8ce6b25
10 changed files with 170 additions and 17 deletions
|
@ -940,6 +940,8 @@ instance YesodBreadcrumbs App where
|
|||
RepoCollabsR r -> ("Collaborators", Just $ RepoR r)
|
||||
RepoProjectsR r -> ("Projects", Just $ RepoR r)
|
||||
|
||||
RepoTeamsR r -> ("Teams", Just $ RepoR r)
|
||||
|
||||
DeckR d -> ("Ticket Tracker =" <> keyHashidText d, Just HomeR)
|
||||
DeckInboxR d -> ("Inbox", Just $ DeckR d)
|
||||
DeckOutboxR d -> ("Outbox", Just $ DeckR d)
|
||||
|
@ -969,6 +971,8 @@ instance YesodBreadcrumbs App where
|
|||
DeckRemoveProjectR d c -> ("", Nothing)
|
||||
DeckAddProjectR d -> ("", Nothing)
|
||||
|
||||
DeckTeamsR d -> ("Teams", Just $ DeckR d)
|
||||
|
||||
TicketR d t -> ("#" <> keyHashidText t, Just $ DeckTicketsR d)
|
||||
TicketDiscussionR d t -> ("Discussion", Just $ TicketR d t)
|
||||
TicketEventsR d t -> ("Events", Just $ TicketR d t)
|
||||
|
@ -1004,6 +1008,8 @@ instance YesodBreadcrumbs App where
|
|||
LoomCollabsR l -> ("Collaborators", Just $ LoomR l)
|
||||
LoomProjectsR l -> ("Projects", Just $ LoomR l)
|
||||
|
||||
LoomTeamsR l -> ("Teams", Just $ LoomR l)
|
||||
|
||||
ClothR l c -> ("#" <> keyHashidText c, Just $ LoomClothsR l)
|
||||
ClothDiscussionR l c -> ("Discussion", Just $ ClothR l c)
|
||||
ClothEventsR l c -> ("Events", Just $ ClothR l c)
|
||||
|
|
|
@ -47,6 +47,7 @@ module Vervis.Handler.Deck
|
|||
, postDeckApproveProjectR
|
||||
, postDeckRemoveProjectR
|
||||
|
||||
, getDeckTeamsR
|
||||
|
||||
|
||||
|
||||
|
@ -135,6 +136,7 @@ import Vervis.Ticket
|
|||
import Vervis.TicketFilter
|
||||
import Vervis.Time
|
||||
import Vervis.Web.Actor
|
||||
import Vervis.Web.Collab
|
||||
import Vervis.Widget
|
||||
import Vervis.Widget.Person
|
||||
import Vervis.Widget.Ticket
|
||||
|
@ -185,6 +187,8 @@ getDeckR deckHash = do
|
|||
encodeRouteLocal $ DeckCollabsR deckHash
|
||||
, AP.ticketTrackerProjects =
|
||||
encodeRouteLocal $ DeckProjectsR deckHash
|
||||
, AP.ticketTrackerTeams =
|
||||
encodeRouteLocal $ DeckTeamsR deckHash
|
||||
}
|
||||
|
||||
provideHtmlAndAP deckAP $ redirect $ DeckTicketsR deckHash
|
||||
|
@ -735,6 +739,14 @@ postDeckRemoveProjectR deckHash stemID = do
|
|||
setMessage "Remove sent"
|
||||
redirect $ DeckProjectsR deckHash
|
||||
|
||||
getDeckTeamsR :: KeyHashid Deck -> Handler TypedContent
|
||||
getDeckTeamsR deckHash = do
|
||||
deckID <- decodeKeyHashid404 deckHash
|
||||
resourceID <- runDB $ do
|
||||
komponentID <- deckKomponent <$> get404 deckID
|
||||
komponentResource <$> getJust komponentID
|
||||
serveTeamsCollection (DeckR deckHash) (DeckTeamsR deckHash) resourceID
|
||||
|
||||
{-
|
||||
getProjectsR :: ShrIdent -> Handler Html
|
||||
getProjectsR ident = do
|
||||
|
|
|
@ -34,6 +34,8 @@ module Vervis.Handler.Loom
|
|||
|
||||
, getLoomCollabsR
|
||||
, getLoomProjectsR
|
||||
|
||||
, getLoomTeamsR
|
||||
)
|
||||
where
|
||||
|
||||
|
@ -98,6 +100,7 @@ import Vervis.Ticket
|
|||
import Vervis.TicketFilter
|
||||
import Vervis.Time
|
||||
import Vervis.Web.Actor
|
||||
import Vervis.Web.Collab
|
||||
import Vervis.Widget.Person
|
||||
import Vervis.Widget.Ticket
|
||||
import Vervis.Widget.Tracker
|
||||
|
@ -144,6 +147,8 @@ getLoomR loomHash = do
|
|||
encodeRouteLocal $ LoomCollabsR loomHash
|
||||
, AP.patchTrackerProjects =
|
||||
encodeRouteLocal $ LoomProjectsR loomHash
|
||||
, AP.patchTrackerTeams =
|
||||
encodeRouteLocal $ LoomTeamsR loomHash
|
||||
}
|
||||
|
||||
provideHtmlAndAP loomAP $ redirect $ LoomClothsR loomHash
|
||||
|
@ -384,3 +389,11 @@ getLoomProjectsR loomHash = do
|
|||
|
||||
addProjectForm = renderDivs $
|
||||
areq fedUriField "(URI) Project" Nothing
|
||||
|
||||
getLoomTeamsR :: KeyHashid Loom -> Handler TypedContent
|
||||
getLoomTeamsR loomHash = do
|
||||
loomID <- decodeKeyHashid404 loomHash
|
||||
resourceID <- runDB $ do
|
||||
komponentID <- loomKomponent <$> get404 loomID
|
||||
komponentResource <$> getJust komponentID
|
||||
serveTeamsCollection (LoomR loomHash) (LoomTeamsR loomHash) resourceID
|
||||
|
|
|
@ -52,6 +52,8 @@ module Vervis.Handler.Repo
|
|||
, getRepoCollabsR
|
||||
, getRepoProjectsR
|
||||
|
||||
, getRepoTeamsR
|
||||
|
||||
|
||||
|
||||
|
||||
|
@ -186,6 +188,7 @@ import Vervis.SourceTree
|
|||
import Vervis.Style
|
||||
import Vervis.Time
|
||||
import Vervis.Web.Actor
|
||||
import Vervis.Web.Collab
|
||||
import Vervis.Web.Darcs
|
||||
import Vervis.Web.Delivery
|
||||
import Vervis.Web.Git
|
||||
|
@ -240,6 +243,7 @@ getRepoR repoHash = do
|
|||
, AP.repoClone = encodeRouteLocal (RepoR repoHash) :| []
|
||||
, AP.repoCollaborators = encodeRouteLocal $ RepoCollabsR repoHash
|
||||
, AP.repoProjects = encodeRouteLocal $ RepoProjectsR repoHash
|
||||
, AP.repoTeams = encodeRouteLocal $ RepoTeamsR repoHash
|
||||
}
|
||||
|
||||
next =
|
||||
|
@ -809,6 +813,14 @@ getRepoProjectsR repoHash = do
|
|||
hashLoom <- getEncodeKeyHashid
|
||||
defaultLayout $(widgetFile "repo/projects")
|
||||
|
||||
getRepoTeamsR :: KeyHashid Repo -> Handler TypedContent
|
||||
getRepoTeamsR repoHash = do
|
||||
repoID <- decodeKeyHashid404 repoHash
|
||||
resourceID <- runDB $ do
|
||||
komponentID <- repoKomponent <$> get404 repoID
|
||||
komponentResource <$> getJust komponentID
|
||||
serveTeamsCollection (RepoR repoHash) (RepoTeamsR repoHash) resourceID
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
|
@ -3813,6 +3813,12 @@ changes hLocal ctx =
|
|||
, addEntities model_638_effort_squad
|
||||
-- 639
|
||||
, addEntities model_639_component_convey
|
||||
-- 640
|
||||
, addFieldRefRequiredEmpty "Squad" "holder" "Resource"
|
||||
-- 641
|
||||
, removeEntity "SquadHolderProject"
|
||||
-- 642
|
||||
, removeEntity "SquadHolderComponent"
|
||||
]
|
||||
|
||||
migrateDB
|
||||
|
|
|
@ -60,6 +60,8 @@ module Vervis.Persist.Collab
|
|||
|
||||
, getStems
|
||||
, getStemDrafts
|
||||
|
||||
, getResourceTeams
|
||||
)
|
||||
where
|
||||
|
||||
|
@ -1350,3 +1352,63 @@ getStemDrafts komponentID = do
|
|||
RemoteActivity _ _ time <- getJust addID
|
||||
(,time) . Right <$> getRemoteActorData actorID
|
||||
return (inviter, us, project, accept, time, role, stemID)
|
||||
|
||||
getResourceTeams
|
||||
:: MonadIO m
|
||||
=> ResourceId
|
||||
-> ReaderT SqlBackend m
|
||||
[ ( AP.Role
|
||||
, UTCTime
|
||||
, Either (GroupId, Actor) (Instance, RemoteObject, RemoteActor)
|
||||
, SquadId
|
||||
)
|
||||
]
|
||||
getResourceTeams resourceID =
|
||||
fmap (sortOn $ view _2) $ liftA2 (++)
|
||||
(map (\ (E.Value role, E.Value time, E.Value groupID, Entity _ actor, E.Value squadID) ->
|
||||
(role, time, Left (groupID, actor), squadID)
|
||||
)
|
||||
<$> getLocals
|
||||
)
|
||||
(map (\ (E.Value role, E.Value time, Entity _ i, Entity _ ro, Entity _ ra, E.Value squadID) ->
|
||||
(role, time, Right (i, ro, ra), squadID)
|
||||
)
|
||||
<$> getRemotes
|
||||
)
|
||||
where
|
||||
getLocals =
|
||||
E.select $ E.from $ \ (squad `E.InnerJoin` topic `E.InnerJoin` group `E.InnerJoin` actor `E.InnerJoin` accept `E.InnerJoin` deleg `E.InnerJoin` grant) -> do
|
||||
E.on $ deleg E.^. SquadThemSendDelegatorLocalGrant E.==. grant E.^. OutboxItemId
|
||||
E.on $ accept E.^. SquadUsAcceptId E.==. deleg E.^. SquadThemSendDelegatorLocalSquad
|
||||
E.on $ squad E.^. SquadId E.==. accept E.^. SquadUsAcceptSquad
|
||||
E.on $ group E.^. GroupActor E.==. actor E.^. ActorId
|
||||
E.on $ topic E.^. SquadTopicLocalGroup E.==. group E.^. GroupId
|
||||
E.on $ squad E.^. SquadId E.==. topic E.^. SquadTopicLocalSquad
|
||||
E.where_ $ squad E.^. SquadHolder E.==. E.val resourceID
|
||||
E.orderBy [E.asc $ grant E.^. OutboxItemPublished]
|
||||
return
|
||||
( squad E.^. SquadRole
|
||||
, grant E.^. OutboxItemPublished
|
||||
, topic E.^. SquadTopicLocalGroup
|
||||
, actor
|
||||
, squad E.^. SquadId
|
||||
)
|
||||
getRemotes =
|
||||
E.select $ E.from $ \ (squad `E.InnerJoin` topic `E.InnerJoin` accept `E.InnerJoin` deleg `E.InnerJoin` grant `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i) -> do
|
||||
E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId
|
||||
E.on $ ra E.^. RemoteActorIdent E.==. ro E.^. RemoteObjectId
|
||||
E.on $ topic E.^. SquadTopicRemoteTopic E.==. ra E.^. RemoteActorId
|
||||
E.on $ deleg E.^. SquadThemSendDelegatorRemoteGrant E.==. grant E.^. RemoteActivityId
|
||||
E.on $ accept E.^. SquadUsAcceptId E.==. deleg E.^. SquadThemSendDelegatorRemoteSquad
|
||||
E.on $ squad E.^. SquadId E.==. accept E.^. SquadUsAcceptSquad
|
||||
E.on $ squad E.^. SquadId E.==. topic E.^. SquadTopicRemoteSquad
|
||||
E.where_ $ squad E.^. SquadHolder E.==. E.val resourceID
|
||||
E.orderBy [E.asc $ grant E.^. RemoteActivityReceived]
|
||||
return
|
||||
( squad E.^. SquadRole
|
||||
, grant E.^. RemoteActivityReceived
|
||||
, i
|
||||
, ro
|
||||
, ra
|
||||
, squad E.^. SquadId
|
||||
)
|
||||
|
|
|
@ -16,6 +16,7 @@
|
|||
module Vervis.Web.Collab
|
||||
( verifyCapability''
|
||||
, checkCapabilityBeforeExtending
|
||||
, serveTeamsCollection
|
||||
)
|
||||
where
|
||||
|
||||
|
@ -63,6 +64,7 @@ import Yesod.Hashids
|
|||
import Yesod.MonadSite
|
||||
|
||||
import qualified Web.ActivityPub as AP
|
||||
import qualified Yesod.FedURI as YF
|
||||
|
||||
import Control.Monad.Trans.Except.Local
|
||||
import Data.Either.Local
|
||||
|
@ -517,3 +519,37 @@ checkCapabilityBeforeExtending uCap extender = do
|
|||
AP.grantAllows grant == AP.Distribute &&
|
||||
targetIsTeam &&
|
||||
(AP.grantAllows h == AP.Distribute || AP.grantAllows h == AP.Invoke)
|
||||
|
||||
serveTeamsCollection meR hereR resourceID = do
|
||||
teams <- runDB $ getResourceTeams resourceID
|
||||
h <- asksSite siteInstanceHost
|
||||
encodeRouteLocal <- YF.getEncodeRouteLocal
|
||||
encodeRouteHome <- YF.getEncodeRouteHome
|
||||
hashGroup <- getEncodeKeyHashid
|
||||
let makeItem (role, time, team, _) = AP.Relationship
|
||||
{ AP.relationshipId = Nothing
|
||||
, AP.relationshipExtraTypes = []
|
||||
, AP.relationshipSubject = encodeRouteHome meR
|
||||
, AP.relationshipProperty = Left AP.RelHasRecCollab
|
||||
, AP.relationshipObject =
|
||||
case team of
|
||||
Left (groupID, _) ->
|
||||
encodeRouteHome $ GroupR $ hashGroup groupID
|
||||
Right (i, ro, _) ->
|
||||
ObjURI (instanceHost i) (remoteObjectIdent ro)
|
||||
, AP.relationshipAttributedTo = encodeRouteLocal meR
|
||||
, AP.relationshipPublished = Just time
|
||||
, AP.relationshipUpdated = Nothing
|
||||
, AP.relationshipInstrument = Just role
|
||||
}
|
||||
teamsAP = AP.Collection
|
||||
{ AP.collectionId = encodeRouteLocal hereR
|
||||
, AP.collectionType = CollectionTypeUnordered
|
||||
, AP.collectionTotalItems = Just $ length teams
|
||||
, AP.collectionCurrent = Nothing
|
||||
, AP.collectionFirst = Nothing
|
||||
, AP.collectionLast = Nothing
|
||||
, AP.collectionItems = map (Doc h . makeItem) teams
|
||||
, AP.collectionContext = Just $ encodeRouteLocal meR
|
||||
}
|
||||
provideHtmlAndAP teamsAP $ redirectToPrettyJSON hereR
|
||||
|
|
|
@ -660,6 +660,7 @@ data Repo u = Repo
|
|||
, repoClone :: NonEmpty LocalURI
|
||||
, repoCollaborators :: LocalURI
|
||||
, repoProjects :: LocalURI
|
||||
, repoTeams :: LocalURI
|
||||
}
|
||||
|
||||
instance ActivityPub Repo where
|
||||
|
@ -676,7 +677,8 @@ instance ActivityPub Repo where
|
|||
<*> (traverse (withAuthorityO h . pure) =<< o .:*+ "cloneUri")
|
||||
<*> withAuthorityO h (o .: "collaborators")
|
||||
<*> withAuthorityO h (o .: "context")
|
||||
toSeries h (Repo actor team vcs loom clone collabs projects)
|
||||
<*> withAuthorityO h (o .: "teams")
|
||||
toSeries h (Repo actor team vcs loom clone collabs projects teams)
|
||||
= toSeries h actor
|
||||
<> "team" .= (ObjURI h <$> team)
|
||||
<> "versionControlSystem" .= vcs
|
||||
|
@ -684,12 +686,14 @@ instance ActivityPub Repo where
|
|||
<> "cloneUri" .=*+ (ObjURI h <$> clone)
|
||||
<> "collaborators" .= ObjURI h collabs
|
||||
<> "context" .= ObjURI h projects
|
||||
<> "teams" .= ObjURI h teams
|
||||
|
||||
data TicketTracker u = TicketTracker
|
||||
{ ticketTrackerActor :: Actor u
|
||||
, ticketTrackerTeam :: Maybe LocalURI
|
||||
, ticketTrackerCollaborators :: LocalURI
|
||||
, ticketTrackerProjects :: LocalURI
|
||||
, ticketTrackerTeams :: LocalURI
|
||||
}
|
||||
|
||||
instance ActivityPub TicketTracker where
|
||||
|
@ -703,16 +707,19 @@ instance ActivityPub TicketTracker where
|
|||
<$> withAuthorityMaybeO h (o .:|? "team")
|
||||
<*> withAuthorityO h (o .: "collaborators")
|
||||
<*> withAuthorityO h (o .: "context")
|
||||
toSeries h (TicketTracker actor team collabs projects)
|
||||
<*> withAuthorityO h (o .: "teams")
|
||||
toSeries h (TicketTracker actor team collabs projects teams)
|
||||
= toSeries h actor
|
||||
<> "team" .= (ObjURI h <$> team)
|
||||
<> "collaborators" .= ObjURI h collabs
|
||||
<> "context" .= ObjURI h projects
|
||||
<> "teams" .= ObjURI h teams
|
||||
|
||||
data PatchTracker u = PatchTracker
|
||||
{ patchTrackerActor :: Actor u
|
||||
, patchTrackerCollaborators :: LocalURI
|
||||
, patchTrackerProjects :: LocalURI
|
||||
, patchTrackerTeams :: LocalURI
|
||||
}
|
||||
|
||||
instance ActivityPub PatchTracker where
|
||||
|
@ -725,10 +732,12 @@ instance ActivityPub PatchTracker where
|
|||
PatchTracker a
|
||||
<$> withAuthorityO h (o .: "collaborators")
|
||||
<*> withAuthorityO h (o .: "context")
|
||||
toSeries h (PatchTracker actor collabs projects)
|
||||
<*> withAuthorityO h (o .: "teams")
|
||||
toSeries h (PatchTracker actor collabs projects teams)
|
||||
= toSeries h actor
|
||||
<> "collaborators" .= ObjURI h collabs
|
||||
<> "context" .= ObjURI h projects
|
||||
<> "teams" .= ObjURI h teams
|
||||
|
||||
data CollectionType = CollectionTypeUnordered | CollectionTypeOrdered
|
||||
|
||||
|
@ -1119,7 +1128,7 @@ instance ActivityPub Note where
|
|||
<> "mediaType" .= ("text/html" :: Text)
|
||||
|
||||
data RelationshipProperty =
|
||||
RelDependsOn | RelHasCollab | RelHasMember | RelHasChild | RelHasParent
|
||||
RelDependsOn | RelHasCollab | RelHasMember | RelHasChild | RelHasParent | RelHasRecCollab
|
||||
deriving Eq
|
||||
|
||||
instance FromJSON RelationshipProperty where
|
||||
|
@ -1131,6 +1140,7 @@ instance FromJSON RelationshipProperty where
|
|||
| t == "hasMember" = pure RelHasMember
|
||||
| t == "hasChild" = pure RelHasChild
|
||||
| t == "hasParent" = pure RelHasParent
|
||||
| t == "hasRecursiveCollaborator" = pure RelHasRecCollab
|
||||
| otherwise = fail $ "Unrecognized relationship: " ++ T.unpack t
|
||||
|
||||
instance ToJSON RelationshipProperty where
|
||||
|
@ -1142,6 +1152,7 @@ instance ToJSON RelationshipProperty where
|
|||
RelHasMember -> "hasMember"
|
||||
RelHasChild -> "hasChild"
|
||||
RelHasParent -> "hasParent"
|
||||
RelHasRecCollab -> "hasRecursiveCollaborator"
|
||||
|
||||
data Relationship u = Relationship
|
||||
{ relationshipId :: Maybe (ObjURI u)
|
||||
|
|
13
th/models
13
th/models
|
@ -1861,18 +1861,7 @@ EffortRemove
|
|||
|
||||
Squad
|
||||
role Role
|
||||
|
||||
SquadHolderProject
|
||||
squad SquadId
|
||||
project ProjectId
|
||||
|
||||
UniqueSquadHolderProject squad
|
||||
|
||||
SquadHolderComponent
|
||||
squad SquadId
|
||||
component KomponentId
|
||||
|
||||
UniqueSquadHolderComponent squad
|
||||
holder ResourceId
|
||||
|
||||
---------------------------------- Squad topic --------------------------------
|
||||
|
||||
|
|
|
@ -234,6 +234,8 @@
|
|||
/repos/#RepoKeyHashid/collabs RepoCollabsR GET
|
||||
/repos/#RepoKeyHashid/projects RepoProjectsR GET
|
||||
|
||||
/repos/#RepoKeyHashid/teams RepoTeamsR GET
|
||||
|
||||
---- Deck --------------------------------------------------------------------
|
||||
|
||||
/decks/#DeckKeyHashid DeckR GET
|
||||
|
@ -266,6 +268,8 @@
|
|||
/decks/#DeckKeyHashid/project/approve/#StemId DeckApproveProjectR POST
|
||||
/decks/#DeckKeyHashid/project/remove/#StemId DeckRemoveProjectR POST
|
||||
|
||||
/decks/#DeckKeyHashid/teams DeckTeamsR GET
|
||||
|
||||
---- Ticket ------------------------------------------------------------------
|
||||
|
||||
/decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid TicketR GET
|
||||
|
@ -319,6 +323,8 @@
|
|||
/looms/#LoomKeyHashid/collabs LoomCollabsR GET
|
||||
/looms/#LoomKeyHashid/projects LoomProjectsR GET
|
||||
|
||||
/looms/#LoomKeyHashid/teams LoomTeamsR GET
|
||||
|
||||
---- Cloth -------------------------------------------------------------------
|
||||
|
||||
/looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid ClothR GET
|
||||
|
|
Loading…
Reference in a new issue