UI, Vocab: Group: Serve accessible resources collection
This commit is contained in:
Pere Lev
parent
0ee94afd9e
commit
f93f67a098
8 changed files with 144 additions and 13 deletions
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
)
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
|
|||
|
|
@ -33,6 +33,9 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
|
|||
<span>
|
||||
<a href=@{GroupMembersR groupHash}>
|
||||
[🤝 Members]
|
||||
<span>
|
||||
<a href=@{GroupEffortsR groupHash}>
|
||||
[💼 Projects]
|
||||
<span>
|
||||
<a href=@{GroupChildrenR groupHash}>
|
||||
[🐛 Children]
|
||||
|
|
|
|||
13
th/models
13
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue