forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Vocab, UI: Component: Specify and serve teams collection

Browse source
This commit is contained in:
Pere Lev 2024-05-15 13:51:09 +03:00
parent 46cb13e5b0
commit 6de8ce6b25
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D
10 changed files with 170 additions and 17 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
src/Vervis/Foundation.hs
View file

@ -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)

12
src/Vervis/Handler/Deck.hs
View file

@ -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

13
src/Vervis/Handler/Loom.hs
View file

@ -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

12
src/Vervis/Handler/Repo.hs
View file

@ -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

6
src/Vervis/Migration.hs
View file

@ -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

62
src/Vervis/Persist/Collab.hs
View file

@ -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
)

36
src/Vervis/Web/Collab.hs
View file

@ -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

19
src/Web/ActivityPub.hs
View file

@ -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)

15
th/models
View file

@ -1860,19 +1860,8 @@ EffortRemove
------------------------------------------------------------------------------
Squad
role Role
SquadHolderProject
squad SquadId
project ProjectId
UniqueSquadHolderProject squad
SquadHolderComponent
squad SquadId
component KomponentId
UniqueSquadHolderComponent squad
role Role
holder ResourceId
---------------------------------- Squad topic --------------------------------

6
th/routes
View file

@ -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