From f93f67a098c11d638f926552c16c4da038000292 Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Sat, 18 May 2024 13:16:20 +0300 Subject: [PATCH] UI, Vocab: Group: Serve accessible resources collection --- src/Vervis/Foundation.hs | 2 + src/Vervis/Handler/Group.hs | 43 ++++++++++++++++++++ src/Vervis/Migration.hs | 10 +++++ src/Vervis/Persist/Collab.hs | 79 ++++++++++++++++++++++++++++++++++++ src/Web/ActivityPub.hs | 5 ++- templates/group/nav.hamlet | 3 ++ th/models | 13 +----- th/routes | 2 + 8 files changed, 144 insertions(+), 13 deletions(-) diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 51f6b4b..8f40380 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -905,6 +905,8 @@ instance YesodBreadcrumbs App where GroupApproveChildR _ _ -> ("", Nothing) GroupApproveParentR _ _ -> ("", Nothing) + GroupEffortsR g -> ("Accessible Resources", Just $ GroupR g) + RepoR r -> ("Repo ^" <> keyHashidText r, Just HomeR) RepoInboxR r -> ("Inbox", Just $ RepoR r) RepoOutboxR r -> ("Outbox", Just $ RepoR r) diff --git a/src/Vervis/Handler/Group.hs b/src/Vervis/Handler/Group.hs index aafe89d..52c8a5f 100644 --- a/src/Vervis/Handler/Group.hs +++ b/src/Vervis/Handler/Group.hs @@ -45,6 +45,8 @@ module Vervis.Handler.Group , postGroupApproveChildR , postGroupApproveParentR + , getGroupEffortsR + @@ -216,6 +218,7 @@ getGroupR groupHash = do , AP.teamChildren = encodeRouteLocal $ GroupChildrenR groupHash , AP.teamParents = encodeRouteLocal $ GroupParentsR groupHash , AP.teamMembers = encodeRouteLocal $ GroupMembersR groupHash + , AP.teamResources = encodeRouteLocal $ GroupEffortsR groupHash } provideHtmlAndAP groupAP $(widgetFile "group/one") @@ -935,6 +938,46 @@ postGroupApproveChildR groupHash destID = do setMessage "Accept sent" redirect $ GroupChildrenR groupHash +getGroupEffortsR :: KeyHashid Group -> Handler TypedContent +getGroupEffortsR groupHash = do + groupID <- decodeKeyHashid404 groupHash + (group, actor, efforts) <- runDB $ do + group <- get404 groupID + actor <- getJust $ groupActor group + efforts <- getTeamResources groupID + return (group, actor, efforts) + h <- asksSite siteInstanceHost + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + hashActor <- getHashLocalActor + let meR = GroupR groupHash + makeItem (role, time, resource, _) = AP.Relationship + { AP.relationshipId = Nothing + , AP.relationshipExtraTypes = [] + , AP.relationshipSubject = + case resource of + Left (la, _) -> + encodeRouteHome $ renderLocalActor $ hashActor la + Right (i, ro, _) -> + ObjURI (instanceHost i) (remoteObjectIdent ro) + , AP.relationshipProperty = Left AP.RelHasRecCollab + , AP.relationshipObject = encodeRouteHome meR + , AP.relationshipAttributedTo = encodeRouteLocal meR + , AP.relationshipPublished = Just time + , AP.relationshipUpdated = Nothing + , AP.relationshipInstrument = Just role + } + effortsAP = AP.Collection + { AP.collectionId = encodeRouteLocal $ GroupEffortsR groupHash + , AP.collectionType = CollectionTypeUnordered + , AP.collectionTotalItems = Just $ length efforts + , AP.collectionCurrent = Nothing + , AP.collectionFirst = Nothing + , AP.collectionLast = Nothing + , AP.collectionItems = map (Doc h . makeItem) efforts + , AP.collectionContext = Just $ encodeRouteLocal meR + } + provideHtmlAndAP effortsAP $ redirectToPrettyJSON (GroupEffortsR groupHash) diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 92af99b..b1045be 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -3819,6 +3819,16 @@ changes hLocal ctx = , removeEntity "SquadHolderProject" -- 642 , removeEntity "SquadHolderComponent" + -- 643 + , addFieldRefRequiredEmpty "Effort" "topic" "Resource" + -- 644 + , removeEntity "EffortTopicProject" + -- 645 + , removeEntity "EffortTopicComponent" + -- 646 + , addFieldRefRequiredEmpty "EffortTopicLocal" "topic" "Resource" + -- 647 + , removeField "Effort" "topic" ] migrateDB diff --git a/src/Vervis/Persist/Collab.hs b/src/Vervis/Persist/Collab.hs index a426c7b..e61b366 100644 --- a/src/Vervis/Persist/Collab.hs +++ b/src/Vervis/Persist/Collab.hs @@ -66,6 +66,8 @@ module Vervis.Persist.Collab , getSquadAdd , getSquadTeam + + , getTeamResources ) where @@ -1681,3 +1683,80 @@ getSquadTeam squadID = (getBy $ UniqueSquadTopicRemote squadID) "Found Squad without topic" "Found Squad with both local and remote topic" + +getTeamResources + :: MonadIO m + => GroupId + -> ReaderT SqlBackend m + [ ( AP.Role + , UTCTime + , Either (LocalActorBy Key, Actor) (Instance, RemoteObject, RemoteActor) + , EffortId + ) + ] +getTeamResources groupID = + fmap (sortOn $ view _2) $ liftA2 (++) + (map (\ (E.Value role, E.Value time, resource, Entity _ actor, E.Value effortID) -> + (role, time, Left (resource, actor), effortID) + ) + <$> (do ls <- getLocals + for ls $ \ (role, time, E.Value r, E.Value d, E.Value l, E.Value j, actor, effort) -> do + resource <- + exactlyOneJust + [ LocalActorRepo <$> r + , LocalActorDeck <$> d + , LocalActorLoom <$> l + , LocalActorProject <$> j + ] + "EffortTopicLocal: Specific actor not found" + "EffortTopicLocal: Multiple specific actors not found" + return (role, time, resource, actor, effort) + ) + ) + (map (\ (E.Value role, E.Value time, Entity _ i, Entity _ ro, Entity _ ra, E.Value effortID) -> + (role, time, Right (i, ro, ra), effortID) + ) + <$> getRemotes + ) + where + getLocals = + E.select $ E.from $ \ (effort `E.InnerJoin` topic `E.InnerJoin` resource `E.InnerJoin` actor `E.InnerJoin` deleg `E.InnerJoin` grant `E.LeftOuterJoin` repo `E.LeftOuterJoin` deck `E.LeftOuterJoin` loom `E.LeftOuterJoin` project) -> do + E.on $ E.just (resource E.^. ResourceId) E.==. project E.?. ProjectResource + E.on $ E.just (resource E.^. ResourceId) E.==. loom E.?. LoomResource + E.on $ E.just (resource E.^. ResourceId) E.==. deck E.?. DeckResource + E.on $ E.just (resource E.^. ResourceId) E.==. repo E.?. RepoResource + E.on $ deleg E.^. EffortUsSendDelegatorGrant E.==. grant E.^. OutboxItemId + E.on $ effort E.^. EffortId E.==. deleg E.^. EffortUsSendDelegatorEffort + E.on $ resource E.^. ResourceActor E.==. actor E.^. ActorId + E.on $ topic E.^. EffortTopicLocalTopic E.==. resource E.^. ResourceId + E.on $ effort E.^. EffortId E.==. topic E.^. EffortTopicLocalEffort + E.where_ $ effort E.^. EffortHolder E.==. E.val groupID + E.orderBy [E.asc $ deleg E.^. EffortUsSendDelegatorId] + return + ( effort E.^. EffortRole + , grant E.^. OutboxItemPublished + , repo E.?. RepoId + , deck E.?. DeckId + , loom E.?. LoomId + , project E.?. ProjectId + , actor + , effort E.^. EffortId + ) + getRemotes = + E.select $ E.from $ \ (effort `E.InnerJoin` topic `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.^. EffortTopicRemoteTopic E.==. ra E.^. RemoteActorId + E.on $ deleg E.^. EffortUsSendDelegatorGrant E.==. grant E.^. OutboxItemId + E.on $ effort E.^. EffortId E.==. deleg E.^. EffortUsSendDelegatorEffort + E.on $ effort E.^. EffortId E.==. topic E.^. EffortTopicRemoteEffort + E.where_ $ effort E.^. EffortHolder E.==. E.val groupID + E.orderBy [E.asc $ deleg E.^. EffortUsSendDelegatorId] + return + ( effort E.^. EffortRole + , grant E.^. OutboxItemPublished + , i + , ro + , ra + , effort E.^. EffortId + ) diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 0b81775..f391e5c 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -951,6 +951,7 @@ data Team u = Team , teamChildren :: LocalURI , teamParents :: LocalURI , teamMembers :: LocalURI + , teamResources :: LocalURI } instance ActivityPub Team where @@ -964,11 +965,13 @@ instance ActivityPub Team where <$> withAuthorityO h (o .: "subteams") <*> withAuthorityO h (o .: "context") <*> withAuthorityO h (o .: "members") - toSeries h (Team actor children parents members) + <*> withAuthorityO h (o .: "teamResources") + toSeries h (Team actor children parents members resources) = toSeries h actor <> "subteams" .= ObjURI h children <> "context" .= ObjURI h parents <> "members" .= ObjURI h members + <> "teamResources" .= ObjURI h resources data Audience u = Audience { audienceTo :: [ObjURI u] diff --git a/templates/group/nav.hamlet b/templates/group/nav.hamlet index 0d0acd9..1e7c7e3 100644 --- a/templates/group/nav.hamlet +++ b/templates/group/nav.hamlet @@ -33,6 +33,9 @@ $# . [🤝 Members] + + + [💼 Projects] [🐛 Children] diff --git a/th/models b/th/models index 9567311..cb1163d 100644 --- a/th/models +++ b/th/models @@ -1659,21 +1659,10 @@ Effort EffortTopicLocal effort EffortId + topic ResourceId UniqueEffortTopicLocal effort -EffortTopicProject - topic EffortTopicLocalId - project ProjectId - - UniqueEffortTopicProject topic - -EffortTopicComponent - topic EffortTopicLocalId - component KomponentId - - UniqueEffortTopicComponent topic - EffortTopicRemote effort EffortId topic RemoteActorId diff --git a/th/routes b/th/routes index 009affe..3e71d4e 100644 --- a/th/routes +++ b/th/routes @@ -198,6 +198,8 @@ /groups/#GroupKeyHashid/child/approve/#DestId GroupApproveChildR POST /groups/#GroupKeyHashid/parent/approve/#SourceId GroupApproveParentR POST +/groups/#GroupKeyHashid/efforts GroupEffortsR GET + ---- Repo -------------------------------------------------------------------- /repos/#RepoKeyHashid RepoR GET