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