From 6de8ce6b2585040954288d7da496ec18b1da725b Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Wed, 15 May 2024 13:51:09 +0300 Subject: [PATCH] Vocab, UI: Component: Specify and serve teams collection --- src/Vervis/Foundation.hs | 6 ++++ src/Vervis/Handler/Deck.hs | 12 +++++++ src/Vervis/Handler/Loom.hs | 13 ++++++++ src/Vervis/Handler/Repo.hs | 12 +++++++ src/Vervis/Migration.hs | 6 ++++ src/Vervis/Persist/Collab.hs | 62 ++++++++++++++++++++++++++++++++++++ src/Vervis/Web/Collab.hs | 36 +++++++++++++++++++++ src/Web/ActivityPub.hs | 19 ++++++++--- th/models | 15 ++------- th/routes | 6 ++++ 10 files changed, 170 insertions(+), 17 deletions(-) diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 877bf4b..f492b34 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -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) diff --git a/src/Vervis/Handler/Deck.hs b/src/Vervis/Handler/Deck.hs index 2c6ed5b..95bf9de 100644 --- a/src/Vervis/Handler/Deck.hs +++ b/src/Vervis/Handler/Deck.hs @@ -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 diff --git a/src/Vervis/Handler/Loom.hs b/src/Vervis/Handler/Loom.hs index 231d2df..c4129b9 100644 --- a/src/Vervis/Handler/Loom.hs +++ b/src/Vervis/Handler/Loom.hs @@ -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 diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs index 92c94e5..e9c4d76 100644 --- a/src/Vervis/Handler/Repo.hs +++ b/src/Vervis/Handler/Repo.hs @@ -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 + diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index aeb2ef7..92af99b 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -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 diff --git a/src/Vervis/Persist/Collab.hs b/src/Vervis/Persist/Collab.hs index 4fb4699..5c5897c 100644 --- a/src/Vervis/Persist/Collab.hs +++ b/src/Vervis/Persist/Collab.hs @@ -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 + ) diff --git a/src/Vervis/Web/Collab.hs b/src/Vervis/Web/Collab.hs index 07f583a..fa3de9f 100644 --- a/src/Vervis/Web/Collab.hs +++ b/src/Vervis/Web/Collab.hs @@ -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 diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 32634d1..786d080 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -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) diff --git a/th/models b/th/models index cde58f1..9567311 100644 --- a/th/models +++ b/th/models @@ -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 -------------------------------- diff --git a/th/routes b/th/routes index dd050c9..d601080 100644 --- a/th/routes +++ b/th/routes @@ -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