UI, Vocab: Group: Serve accessible resources collection

This commit is contained in:
Pere Lev 2024-05-18 13:16:20 +03:00
parent 0ee94afd9e
commit f93f67a098
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D
8 changed files with 144 additions and 13 deletions

View file

@ -905,6 +905,8 @@ instance YesodBreadcrumbs App where
GroupApproveChildR _ _ -> ("", Nothing) GroupApproveChildR _ _ -> ("", Nothing)
GroupApproveParentR _ _ -> ("", Nothing) GroupApproveParentR _ _ -> ("", Nothing)
GroupEffortsR g -> ("Accessible Resources", Just $ GroupR g)
RepoR r -> ("Repo ^" <> keyHashidText r, Just HomeR) RepoR r -> ("Repo ^" <> keyHashidText r, Just HomeR)
RepoInboxR r -> ("Inbox", Just $ RepoR r) RepoInboxR r -> ("Inbox", Just $ RepoR r)
RepoOutboxR r -> ("Outbox", Just $ RepoR r) RepoOutboxR r -> ("Outbox", Just $ RepoR r)

View file

@ -45,6 +45,8 @@ module Vervis.Handler.Group
, postGroupApproveChildR , postGroupApproveChildR
, postGroupApproveParentR , postGroupApproveParentR
, getGroupEffortsR
@ -216,6 +218,7 @@ getGroupR groupHash = do
, AP.teamChildren = encodeRouteLocal $ GroupChildrenR groupHash , AP.teamChildren = encodeRouteLocal $ GroupChildrenR groupHash
, AP.teamParents = encodeRouteLocal $ GroupParentsR groupHash , AP.teamParents = encodeRouteLocal $ GroupParentsR groupHash
, AP.teamMembers = encodeRouteLocal $ GroupMembersR groupHash , AP.teamMembers = encodeRouteLocal $ GroupMembersR groupHash
, AP.teamResources = encodeRouteLocal $ GroupEffortsR groupHash
} }
provideHtmlAndAP groupAP $(widgetFile "group/one") provideHtmlAndAP groupAP $(widgetFile "group/one")
@ -935,6 +938,46 @@ postGroupApproveChildR groupHash destID = do
setMessage "Accept sent" setMessage "Accept sent"
redirect $ GroupChildrenR groupHash 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)

View file

@ -3819,6 +3819,16 @@ changes hLocal ctx =
, removeEntity "SquadHolderProject" , removeEntity "SquadHolderProject"
-- 642 -- 642
, removeEntity "SquadHolderComponent" , removeEntity "SquadHolderComponent"
-- 643
, addFieldRefRequiredEmpty "Effort" "topic" "Resource"
-- 644
, removeEntity "EffortTopicProject"
-- 645
, removeEntity "EffortTopicComponent"
-- 646
, addFieldRefRequiredEmpty "EffortTopicLocal" "topic" "Resource"
-- 647
, removeField "Effort" "topic"
] ]
migrateDB migrateDB

View file

@ -66,6 +66,8 @@ module Vervis.Persist.Collab
, getSquadAdd , getSquadAdd
, getSquadTeam , getSquadTeam
, getTeamResources
) )
where where
@ -1681,3 +1683,80 @@ getSquadTeam squadID =
(getBy $ UniqueSquadTopicRemote squadID) (getBy $ UniqueSquadTopicRemote squadID)
"Found Squad without topic" "Found Squad without topic"
"Found Squad with both local and remote 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
)

View file

@ -951,6 +951,7 @@ data Team u = Team
, teamChildren :: LocalURI , teamChildren :: LocalURI
, teamParents :: LocalURI , teamParents :: LocalURI
, teamMembers :: LocalURI , teamMembers :: LocalURI
, teamResources :: LocalURI
} }
instance ActivityPub Team where instance ActivityPub Team where
@ -964,11 +965,13 @@ instance ActivityPub Team where
<$> withAuthorityO h (o .: "subteams") <$> withAuthorityO h (o .: "subteams")
<*> withAuthorityO h (o .: "context") <*> withAuthorityO h (o .: "context")
<*> withAuthorityO h (o .: "members") <*> 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 = toSeries h actor
<> "subteams" .= ObjURI h children <> "subteams" .= ObjURI h children
<> "context" .= ObjURI h parents <> "context" .= ObjURI h parents
<> "members" .= ObjURI h members <> "members" .= ObjURI h members
<> "teamResources" .= ObjURI h resources
data Audience u = Audience data Audience u = Audience
{ audienceTo :: [ObjURI u] { audienceTo :: [ObjURI u]

View file

@ -33,6 +33,9 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<span> <span>
<a href=@{GroupMembersR groupHash}> <a href=@{GroupMembersR groupHash}>
[🤝 Members] [🤝 Members]
<span>
<a href=@{GroupEffortsR groupHash}>
[💼 Projects]
<span> <span>
<a href=@{GroupChildrenR groupHash}> <a href=@{GroupChildrenR groupHash}>
[🐛 Children] [🐛 Children]

View file

@ -1659,21 +1659,10 @@ Effort
EffortTopicLocal EffortTopicLocal
effort EffortId effort EffortId
topic ResourceId
UniqueEffortTopicLocal effort UniqueEffortTopicLocal effort
EffortTopicProject
topic EffortTopicLocalId
project ProjectId
UniqueEffortTopicProject topic
EffortTopicComponent
topic EffortTopicLocalId
component KomponentId
UniqueEffortTopicComponent topic
EffortTopicRemote EffortTopicRemote
effort EffortId effort EffortId
topic RemoteActorId topic RemoteActorId

View file

@ -198,6 +198,8 @@
/groups/#GroupKeyHashid/child/approve/#DestId GroupApproveChildR POST /groups/#GroupKeyHashid/child/approve/#DestId GroupApproveChildR POST
/groups/#GroupKeyHashid/parent/approve/#SourceId GroupApproveParentR POST /groups/#GroupKeyHashid/parent/approve/#SourceId GroupApproveParentR POST
/groups/#GroupKeyHashid/efforts GroupEffortsR GET
---- Repo -------------------------------------------------------------------- ---- Repo --------------------------------------------------------------------
/repos/#RepoKeyHashid RepoR GET /repos/#RepoKeyHashid RepoR GET