UI, AP: Display project and team children and parents

src/Vervis/Foundation.hs

@@ -161,6 +161,8 @@ type ProjectKeyHashid           = KeyHashid Project
 type CollabEnableKeyHashid      = KeyHashid CollabEnable
 type StemKeyHashid              = KeyHashid Stem
 type PermitFulfillsInviteKeyHashid = KeyHashid PermitFulfillsInvite
+type DestThemSendDelegatorLocalKeyHashid = KeyHashid DestThemSendDelegatorLocal
+type DestThemSendDelegatorRemoteKeyHashid = KeyHashid DestThemSendDelegatorRemote
 
 -- This is where we define all of the routes in our application. For a full
 -- explanation of the syntax, please see:
@@ -890,6 +892,11 @@ instance YesodBreadcrumbs App where
         GroupInviteR g   -> ("Invite", Just $ GroupR g)
         GroupRemoveR _ _ -> ("", Nothing)
 
+        GroupChildrenR j -> ("Child teams", Just $ GroupR j)
+        GroupChildLocalLiveR j d -> ("Local " <> keyHashidText d, Just $ GroupChildrenR j)
+        GroupChildRemoteLiveR j d -> ("Remote " <> keyHashidText d, Just $ GroupChildrenR j)
+        GroupParentsR j -> ("Parent teams", Just $ GroupR j)
+
         RepoR r             -> ("Repo ^" <> keyHashidText r, Just HomeR)
         RepoInboxR r        -> ("Inbox", Just $ RepoR r)
         RepoOutboxR r       -> ("Outbox", Just $ RepoR r)
@@ -1025,3 +1032,8 @@ instance YesodBreadcrumbs App where
         ProjectCollabLiveR j c -> (keyHashidText c, Just $ ProjectCollabsR j)
 
         ProjectInviteCompR d  -> ("Invite", Just $ ProjectComponentsR d)
+
+        ProjectChildrenR j -> ("Child projects", Just $ ProjectR j)
+        ProjectParentsR j -> ("Parent projects", Just $ ProjectR j)
+        ProjectParentLocalLiveR j d -> ("Local " <> keyHashidText d, Just $ ProjectParentsR j)
+        ProjectParentRemoteLiveR j d -> ("Remote " <> keyHashidText d, Just $ ProjectParentsR j)

src/Vervis/Handler/Group.hs

@@ -32,6 +32,10 @@ module Vervis.Handler.Group
     , postGroupInviteR
     , postGroupRemoveR
 
+    , getGroupChildrenR
+    , getGroupChildLocalLiveR
+    , getGroupChildRemoteLiveR
+    , getGroupParentsR
 
 
 
@@ -58,12 +62,14 @@ import Data.Bitraversable
 import Data.ByteString (ByteString)
 import Data.Default.Class
 import Data.Foldable
+import Data.List
 import Data.Maybe (fromMaybe)
 import Data.Text (Text)
 import Data.Time.Clock
 import Data.Traversable
 import Database.Persist
 import Network.HTTP.Types.Method
+import Optics.Core
 import Text.Blaze.Html (Html)
 import Yesod.Auth (requireAuth)
 import Yesod.Core
@@ -383,6 +389,217 @@ postGroupRemoveR groupHash ctID = do
             setMessage "Remove sent"
     redirect $ GroupMembersR groupHash
 
+getGroupChildrenR :: KeyHashid Group -> Handler TypedContent
+getGroupChildrenR groupHash = do
+    groupID <- decodeKeyHashid404 groupHash
+    (actor, group, children) <- runDB $ do
+        group <- get404 groupID
+        actor <- getJust $ groupActor group
+        children <- getChildren groupID
+        return (actor, group, children)
+    encodeRouteLocal <- getEncodeRouteLocal
+    encodeRouteHome <- getEncodeRouteHome
+    hashGroup <- getEncodeKeyHashid
+    h <- asksSite siteInstanceHost
+    let makeId (Left (childID, _)) =
+            encodeRouteHome $ GroupR $ hashGroup childID
+        makeId (Right (i, ro, _)) =
+            ObjURI (instanceHost i) (remoteObjectIdent ro)
+        makeItem (role, time, i) = AP.Relationship
+            { AP.relationshipId           = Nothing
+            , AP.relationshipExtraTypes   = []
+            , AP.relationshipSubject      = encodeRouteHome $ GroupR groupHash
+            , AP.relationshipProperty     = Left AP.RelHasChild
+            , AP.relationshipObject       = makeId i
+            , AP.relationshipAttributedTo = encodeRouteLocal $ GroupR groupHash
+            , AP.relationshipPublished    = Just time
+            , AP.relationshipUpdated      = Nothing
+            , AP.relationshipInstrument   = Just role
+            }
+        childrenAP = Collection
+            { collectionId         = encodeRouteLocal $ GroupChildrenR groupHash
+            , collectionType       = CollectionTypeUnordered
+            , collectionTotalItems = Just $ length children
+            , collectionCurrent    = Nothing
+            , collectionFirst      = Nothing
+            , collectionLast       = Nothing
+            , collectionItems      = map (Doc h . makeItem) children
+            , collectionContext    =
+                Just $ encodeRouteLocal $ GroupR groupHash
+            }
+    provideHtmlAndAP childrenAP $ getHtml groupID group actor children
+
+    where
+
+    getChildren groupID = fmap (sortOn $ view _2) $ liftA2 (++)
+        (map (\ (E.Value role, E.Value time, E.Value child, Entity _ actor) ->
+                (role, time, Left (child, actor))
+             )
+            <$> getLocals groupID
+        )
+        (map (\ (E.Value role, E.Value time, Entity _ i, Entity _ ro, Entity _ ra) ->
+                (role, time, Right (i, ro, ra))
+             )
+            <$> getRemotes groupID
+        )
+
+    getLocals groupID =
+        E.select $ E.from $ \ (dest `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` group `E.InnerJoin` actor `E.InnerJoin` accept `E.InnerJoin` deleg `E.InnerJoin` grant) -> do
+            E.on $ deleg E.^. DestThemSendDelegatorLocalGrant E.==. grant E.^. OutboxItemId
+            E.on $ accept E.^. DestUsAcceptId E.==. deleg E.^. DestThemSendDelegatorLocalDest
+            E.on $ dest E.^. DestId E.==. accept E.^. DestUsAcceptDest
+            E.on $ group E.^. GroupActor E.==. actor E.^. ActorId
+            E.on $ topic E.^. DestTopicGroupChild E.==. group E.^. GroupId
+            E.on $ holder E.^. DestHolderGroupId E.==. topic E.^. DestTopicGroupHolder
+            E.on $ dest E.^. DestId E.==. holder E.^. DestHolderGroupDest
+            E.where_ $ holder E.^. DestHolderGroupGroup E.==. E.val groupID
+            E.orderBy [E.asc $ grant E.^. OutboxItemPublished]
+            return
+                ( dest E.^. DestRole
+                , grant E.^. OutboxItemPublished
+                , topic E.^. DestTopicGroupChild
+                , actor
+                )
+
+    getRemotes groupID =
+        E.select $ E.from $ \ (dest `E.InnerJoin` holder `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.^. DestTopicRemoteTopic E.==. ra E.^. RemoteActorId
+            E.on $ deleg E.^. DestThemSendDelegatorRemoteGrant E.==. grant E.^. RemoteActivityId
+            E.on $ accept E.^. DestUsAcceptId E.==. deleg E.^. DestThemSendDelegatorRemoteDest
+            E.on $ dest E.^. DestId E.==. accept E.^. DestUsAcceptDest
+            E.on $ dest E.^. DestId E.==. topic E.^. DestTopicRemoteDest
+            E.on $ dest E.^. DestId E.==. holder E.^. DestHolderGroupDest
+            E.where_ $ holder E.^. DestHolderGroupGroup E.==. E.val groupID
+            E.orderBy [E.asc $ grant E.^. RemoteActivityReceived]
+            return
+                ( dest E.^. DestRole
+                , grant E.^. RemoteActivityReceived
+                , i
+                , ro
+                , ra
+                )
+
+    getHtml groupID group actor children = do
+        $(widgetFile "group/children")
+
+getGroupChildLocalLiveR :: KeyHashid Group -> KeyHashid DestThemSendDelegatorLocal -> Handler ()
+getGroupChildLocalLiveR groupHash delegHash = do
+    groupID <- decodeKeyHashid404 groupHash
+    delegID <- decodeKeyHashid404 delegHash
+    runDB $ do
+        _ <- get404 groupID
+        DestThemSendDelegatorLocal _ localID _ <- get404 delegID
+        DestTopicLocal destID <- getJust localID
+        Entity _ (DestHolderGroup _ g) <-
+            getBy404 $ UniqueDestHolderGroup destID
+        unless (g == groupID) notFound
+
+getGroupChildRemoteLiveR :: KeyHashid Group -> KeyHashid DestThemSendDelegatorRemote -> Handler ()
+getGroupChildRemoteLiveR groupHash delegHash = do
+    groupID <- decodeKeyHashid404 groupHash
+    delegID <- decodeKeyHashid404 delegHash
+    runDB $ do
+        _ <- get404 groupID
+        DestThemSendDelegatorRemote _ remoteID _ <- get404 delegID
+        DestTopicRemote destID _ <- getJust remoteID
+        Entity _ (DestHolderGroup _ g) <-
+            getBy404 $ UniqueDestHolderGroup destID
+        unless (g == groupID) notFound
+
+getGroupParentsR :: KeyHashid Group -> Handler TypedContent
+getGroupParentsR groupHash = do
+    groupID <- decodeKeyHashid404 groupHash
+    (actor, group, parents) <- runDB $ do
+        group <- get404 groupID
+        actor <- getJust $ groupActor group
+        parents <- getParents groupID
+        return (actor, group, parents)
+    encodeRouteHome <- getEncodeRouteHome
+    encodeRouteLocal <- getEncodeRouteLocal
+    hashGroup <- getEncodeKeyHashid
+    h <- asksSite siteInstanceHost
+    let makeId (Left (parentID, _)) =
+            encodeRouteHome $ GroupR $ hashGroup parentID
+        makeId (Right (i, ro, _)) =
+            ObjURI (instanceHost i) (remoteObjectIdent ro)
+        makeItem (role, time, i) = AP.Relationship
+            { AP.relationshipId           = Nothing
+            , AP.relationshipExtraTypes   = []
+            , AP.relationshipSubject      = encodeRouteHome $ GroupR groupHash
+            , AP.relationshipProperty     = Left AP.RelHasParent
+            , AP.relationshipObject       = makeId i
+            , AP.relationshipAttributedTo = encodeRouteLocal $ GroupR groupHash
+            , AP.relationshipPublished    = Just time
+            , AP.relationshipUpdated      = Nothing
+            , AP.relationshipInstrument   = Just role
+            }
+        parentsAP = Collection
+            { collectionId         = encodeRouteLocal $ GroupParentsR groupHash
+            , collectionType       = CollectionTypeUnordered
+            , collectionTotalItems = Just $ length parents
+            , collectionCurrent    = Nothing
+            , collectionFirst      = Nothing
+            , collectionLast       = Nothing
+            , collectionItems      = map (Doc h . makeItem) parents
+            , collectionContext    =
+                Just $ encodeRouteLocal $ GroupR groupHash
+            }
+    provideHtmlAndAP parentsAP $ getHtml groupID group actor parents
+
+    where
+
+    getParents groupID = fmap (sortOn $ view _2) $ liftA2 (++)
+        (map (\ (E.Value role, E.Value time, E.Value parent, Entity _ actor) ->
+                (role, time, Left (parent, actor))
+             )
+            <$> getLocals groupID
+        )
+        (map (\ (E.Value role, E.Value time, Entity _ i, Entity _ ro, Entity _ ra) ->
+                (role, time, Right (i, ro, ra))
+             )
+            <$> getRemotes groupID
+        )
+
+    getLocals groupID =
+        E.select $ E.from $ \ (source `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` group `E.InnerJoin` actor `E.InnerJoin` deleg `E.InnerJoin` grant) -> do
+            E.on $ deleg E.^. SourceUsSendDelegatorGrant E.==. grant E.^. OutboxItemId
+            E.on $ source E.^. SourceId E.==. deleg E.^. SourceUsSendDelegatorSource
+            E.on $ group E.^. GroupActor E.==. actor E.^. ActorId
+            E.on $ topic E.^. SourceTopicGroupParent E.==. group E.^. GroupId
+            E.on $ holder E.^. SourceHolderGroupId E.==. topic E.^. SourceTopicGroupHolder
+            E.on $ source E.^. SourceId E.==. holder E.^. SourceHolderGroupSource
+            E.where_ $ holder E.^. SourceHolderGroupGroup E.==. E.val groupID
+            E.orderBy [E.asc $ deleg E.^. SourceUsSendDelegatorId]
+            return
+                ( source E.^. SourceRole
+                , grant E.^. OutboxItemPublished
+                , topic E.^. SourceTopicGroupParent
+                , actor
+                )
+
+    getRemotes groupID =
+        E.select $ E.from $ \ (source `E.InnerJoin` holder `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.^. SourceTopicRemoteTopic E.==. ra E.^. RemoteActorId
+            E.on $ deleg E.^. SourceUsSendDelegatorGrant E.==. grant E.^. OutboxItemId
+            E.on $ source E.^. SourceId E.==. deleg E.^. SourceUsSendDelegatorSource
+            E.on $ source E.^. SourceId E.==. topic E.^. SourceTopicRemoteSource
+            E.on $ source E.^. SourceId E.==. holder E.^. SourceHolderGroupSource
+            E.where_ $ holder E.^. SourceHolderGroupGroup E.==. E.val groupID
+            E.orderBy [E.asc $ deleg E.^. SourceUsSendDelegatorId]
+            return
+                ( source E.^. SourceRole
+                , grant E.^. OutboxItemPublished
+                , i
+                , ro
+                , ra
+                )
+
+    getHtml groupID group actor parents = do
+        $(widgetFile "group/parents")
 
 
 

src/Vervis/Handler/Project.hs

@@ -38,6 +38,11 @@ module Vervis.Handler.Project
 
     , getProjectInviteCompR
     , postProjectInviteCompR
+
+    , getProjectChildrenR
+    , getProjectParentsR
+    , getProjectParentLocalLiveR
+    , getProjectParentRemoteLiveR
     )
 where
 
@@ -51,12 +56,14 @@ import Data.Bitraversable
 import Data.ByteString (ByteString)
 import Data.Default.Class
 import Data.Foldable
+import Data.List
 import Data.Maybe (fromMaybe)
 import Data.Text (Text)
 import Data.Time.Clock
 import Data.Traversable
 import Database.Persist
 import Network.HTTP.Types.Method
+import Optics.Core
 import Text.Blaze.Html (Html)
 import Yesod.Auth (requireAuth)
 import Yesod.Core
@@ -563,3 +570,215 @@ postProjectInviteCompR projectHash = do
         Right inviteID -> do
             setMessage "Invite sent"
             redirect $ ProjectComponentsR projectHash
+
+getProjectChildrenR :: KeyHashid Project -> Handler TypedContent
+getProjectChildrenR projectHash = do
+    projectID <- decodeKeyHashid404 projectHash
+    (actor, project, children) <- runDB $ do
+        project <- get404 projectID
+        actor <- getJust $ projectActor project
+        children <- getChildren projectID
+        return (actor, project, children)
+    encodeRouteHome <- getEncodeRouteHome
+    encodeRouteLocal <- getEncodeRouteLocal
+    hashProject <- getEncodeKeyHashid
+    h <- asksSite siteInstanceHost
+    let makeId (Left (childID, _)) =
+            encodeRouteHome $ ProjectR $ hashProject childID
+        makeId (Right (i, ro, _)) =
+            ObjURI (instanceHost i) (remoteObjectIdent ro)
+        makeItem (role, time, i) = AP.Relationship
+            { AP.relationshipId           = Nothing
+            , AP.relationshipExtraTypes   = []
+            , AP.relationshipSubject      = encodeRouteHome $ ProjectR projectHash
+            , AP.relationshipProperty     = Left AP.RelHasChild
+            , AP.relationshipObject       = makeId i
+            , AP.relationshipAttributedTo = encodeRouteLocal $ ProjectR projectHash
+            , AP.relationshipPublished    = Just time
+            , AP.relationshipUpdated      = Nothing
+            , AP.relationshipInstrument   = Just role
+            }
+        childrenAP = Collection
+            { collectionId         = encodeRouteLocal $ ProjectChildrenR projectHash
+            , collectionType       = CollectionTypeUnordered
+            , collectionTotalItems = Just $ length children
+            , collectionCurrent    = Nothing
+            , collectionFirst      = Nothing
+            , collectionLast       = Nothing
+            , collectionItems      = map (Doc h . makeItem) children
+            , collectionContext    =
+                Just $ encodeRouteLocal $ ProjectR projectHash
+            }
+    provideHtmlAndAP childrenAP $ getHtml projectID project actor children
+
+    where
+
+    getChildren projectID = fmap (sortOn $ view _2) $ liftA2 (++)
+        (map (\ (E.Value role, E.Value time, E.Value child, Entity _ actor) ->
+                (role, time, Left (child, actor))
+             )
+            <$> getLocals projectID
+        )
+        (map (\ (E.Value role, E.Value time, Entity _ i, Entity _ ro, Entity _ ra) ->
+                (role, time, Right (i, ro, ra))
+             )
+            <$> getRemotes projectID
+        )
+
+    getLocals projectID =
+        E.select $ E.from $ \ (source `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` project `E.InnerJoin` actor `E.InnerJoin` deleg `E.InnerJoin` grant) -> do
+            E.on $ deleg E.^. SourceUsSendDelegatorGrant E.==. grant E.^. OutboxItemId
+            E.on $ source E.^. SourceId E.==. deleg E.^. SourceUsSendDelegatorSource
+            E.on $ project E.^. ProjectActor E.==. actor E.^. ActorId
+            E.on $ topic E.^. SourceTopicProjectChild E.==. project E.^. ProjectId
+            E.on $ holder E.^. SourceHolderProjectId E.==. topic E.^. SourceTopicProjectHolder
+            E.on $ source E.^. SourceId E.==. holder E.^. SourceHolderProjectSource
+            E.where_ $ holder E.^. SourceHolderProjectProject E.==. E.val projectID
+            E.orderBy [E.asc $ deleg E.^. SourceUsSendDelegatorId]
+            return
+                ( source E.^. SourceRole
+                , grant E.^. OutboxItemPublished
+                , topic E.^. SourceTopicProjectChild
+                , actor
+                )
+
+    getRemotes projectID =
+        E.select $ E.from $ \ (source `E.InnerJoin` holder `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.^. SourceTopicRemoteTopic E.==. ra E.^. RemoteActorId
+            E.on $ deleg E.^. SourceUsSendDelegatorGrant E.==. grant E.^. OutboxItemId
+            E.on $ source E.^. SourceId E.==. deleg E.^. SourceUsSendDelegatorSource
+            E.on $ source E.^. SourceId E.==. topic E.^. SourceTopicRemoteSource
+            E.on $ source E.^. SourceId E.==. holder E.^. SourceHolderProjectSource
+            E.where_ $ holder E.^. SourceHolderProjectProject E.==. E.val projectID
+            E.orderBy [E.asc $ deleg E.^. SourceUsSendDelegatorId]
+            return
+                ( source E.^. SourceRole
+                , grant E.^. OutboxItemPublished
+                , i
+                , ro
+                , ra
+                )
+
+    getHtml projectID project actor children = do
+        $(widgetFile "project/children")
+
+getProjectParentsR :: KeyHashid Project -> Handler TypedContent
+getProjectParentsR projectHash = do
+    projectID <- decodeKeyHashid404 projectHash
+    (actor, project, parents) <- runDB $ do
+        project <- get404 projectID
+        actor <- getJust $ projectActor project
+        parents <- getParents projectID
+        return (actor, project, parents)
+    encodeRouteHome <- getEncodeRouteHome
+    encodeRouteLocal <- getEncodeRouteLocal
+    hashProject <- getEncodeKeyHashid
+    h <- asksSite siteInstanceHost
+    let makeId (Left (parentID, _)) =
+            encodeRouteHome $ ProjectR $ hashProject parentID
+        makeId (Right (i, ro, _)) =
+            ObjURI (instanceHost i) (remoteObjectIdent ro)
+        makeItem (role, time, i) = AP.Relationship
+            { AP.relationshipId           = Nothing
+            , AP.relationshipExtraTypes   = []
+            , AP.relationshipSubject      = encodeRouteHome $ ProjectR projectHash
+            , AP.relationshipProperty     = Left AP.RelHasParent
+            , AP.relationshipObject       = makeId i
+            , AP.relationshipAttributedTo = encodeRouteLocal $ ProjectR projectHash
+            , AP.relationshipPublished    = Just time
+            , AP.relationshipUpdated      = Nothing
+            , AP.relationshipInstrument   = Just role
+            }
+        parentsAP = Collection
+            { collectionId         = encodeRouteLocal $ ProjectParentsR projectHash
+            , collectionType       = CollectionTypeUnordered
+            , collectionTotalItems = Just $ length parents
+            , collectionCurrent    = Nothing
+            , collectionFirst      = Nothing
+            , collectionLast       = Nothing
+            , collectionItems      = map (Doc h . makeItem) parents
+            , collectionContext    =
+                Just $ encodeRouteLocal $ ProjectR projectHash
+            }
+    provideHtmlAndAP parentsAP $ getHtml projectID project actor parents
+
+    where
+
+    getParents projectID = fmap (sortOn $ view _2) $ liftA2 (++)
+        (map (\ (E.Value role, E.Value time, E.Value parent, Entity _ actor) ->
+                (role, time, Left (parent, actor))
+             )
+            <$> getLocals projectID
+        )
+        (map (\ (E.Value role, E.Value time, Entity _ i, Entity _ ro, Entity _ ra) ->
+                (role, time, Right (i, ro, ra))
+             )
+            <$> getRemotes projectID
+        )
+
+    getLocals projectID =
+        E.select $ E.from $ \ (dest `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` project `E.InnerJoin` actor `E.InnerJoin` accept `E.InnerJoin` deleg `E.InnerJoin` grant) -> do
+            E.on $ deleg E.^. DestThemSendDelegatorLocalGrant E.==. grant E.^. OutboxItemId
+            E.on $ accept E.^. DestUsAcceptId E.==. deleg E.^. DestThemSendDelegatorLocalDest
+            E.on $ dest E.^. DestId E.==. accept E.^. DestUsAcceptDest
+            E.on $ project E.^. ProjectActor E.==. actor E.^. ActorId
+            E.on $ topic E.^. DestTopicProjectParent E.==. project E.^. ProjectId
+            E.on $ holder E.^. DestHolderProjectId E.==. topic E.^. DestTopicProjectHolder
+            E.on $ dest E.^. DestId E.==. holder E.^. DestHolderProjectDest
+            E.where_ $ holder E.^. DestHolderProjectProject E.==. E.val projectID
+            E.orderBy [E.asc $ grant E.^. OutboxItemPublished]
+            return
+                ( dest E.^. DestRole
+                , grant E.^. OutboxItemPublished
+                , topic E.^. DestTopicProjectParent
+                , actor
+                )
+
+    getRemotes projectID =
+        E.select $ E.from $ \ (dest `E.InnerJoin` holder `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.^. DestTopicRemoteTopic E.==. ra E.^. RemoteActorId
+            E.on $ deleg E.^. DestThemSendDelegatorRemoteGrant E.==. grant E.^. RemoteActivityId
+            E.on $ accept E.^. DestUsAcceptId E.==. deleg E.^. DestThemSendDelegatorRemoteDest
+            E.on $ dest E.^. DestId E.==. accept E.^. DestUsAcceptDest
+            E.on $ dest E.^. DestId E.==. topic E.^. DestTopicRemoteDest
+            E.on $ dest E.^. DestId E.==. holder E.^. DestHolderProjectDest
+            E.where_ $ holder E.^. DestHolderProjectProject E.==. E.val projectID
+            E.orderBy [E.asc $ grant E.^. RemoteActivityReceived]
+            return
+                ( dest E.^. DestRole
+                , grant E.^. RemoteActivityReceived
+                , i
+                , ro
+                , ra
+                )
+
+    getHtml projectID project actor parents = do
+        $(widgetFile "project/parents")
+
+getProjectParentLocalLiveR :: KeyHashid Project -> KeyHashid DestThemSendDelegatorLocal -> Handler ()
+getProjectParentLocalLiveR projectHash delegHash = do
+    projectID <- decodeKeyHashid404 projectHash
+    delegID <- decodeKeyHashid404 delegHash
+    runDB $ do
+        _ <- get404 projectID
+        DestThemSendDelegatorLocal _ localID _ <- get404 delegID
+        DestTopicLocal destID <- getJust localID
+        Entity _ (DestHolderProject _ j) <-
+            getBy404 $ UniqueDestHolderProject destID
+        unless (j == projectID) notFound
+
+getProjectParentRemoteLiveR :: KeyHashid Project -> KeyHashid DestThemSendDelegatorRemote -> Handler ()
+getProjectParentRemoteLiveR projectHash delegHash = do
+    projectID <- decodeKeyHashid404 projectHash
+    delegID <- decodeKeyHashid404 delegHash
+    runDB $ do
+        _ <- get404 projectID
+        DestThemSendDelegatorRemote _ remoteID _ <- get404 delegID
+        DestTopicRemote destID _ <- getJust remoteID
+        Entity _ (DestHolderProject _ j) <-
+            getBy404 $ UniqueDestHolderProject destID
+        unless (j == projectID) notFound

src/Vervis/Widget/Tracker.hs

@@ -19,11 +19,13 @@ module Vervis.Widget.Tracker
     , projectNavW
     , componentLinkFedW
     , projectLinkFedW
+    , groupLinkFedW
     , actorLinkFedW
     , groupNavW
     )
 where
 
+import Data.Bifunctor
 import Database.Persist
 import Database.Persist.Types
 import Yesod.Core.Widget
@@ -101,22 +103,12 @@ componentLinkFedW (Right (inztance, object, actor)) =
 projectLinkFedW
     :: Either (ProjectId, Actor) (Instance, RemoteObject, RemoteActor)
     -> Widget
-projectLinkFedW (Left (j, actor)) = do
+projectLinkFedW = actorLinkFedW . bimap (first LocalActorProject) id
-    h <- encodeKeyHashid j
+
-    [whamlet|
+groupLinkFedW
-        <a href=@{ProjectR h}>
+    :: Either (GroupId, Actor) (Instance, RemoteObject, RemoteActor)
-          \$#{keyHashidText h} #{actorName actor}
+    -> Widget
-    |]
+groupLinkFedW = actorLinkFedW . bimap (first LocalActorGroup) id
-projectLinkFedW (Right (inztance, object, actor)) =
-    [whamlet|
-        <a href="#{renderObjURI uActor}">
-          $maybe name <- remoteActorName actor
-            #{name}
-          $nothing
-            #{renderAuthority $ instanceHost inztance}#{localUriPath $ remoteObjectIdent object}
-    |]
-    where
-    uActor = ObjURI (instanceHost inztance) (remoteObjectIdent object)
 
 actorLinkW :: LocalActorBy Key -> Actor -> Widget
 actorLinkW (LocalActorPerson k) actor = do

src/Web/ActivityPub.hs

@@ -1120,7 +1120,7 @@ instance ActivityPub Note where
         <> "mediaType"    .=  ("text/html" :: Text)
 
 data RelationshipProperty =
-    RelDependsOn | RelHasCollab | RelHasMember
+    RelDependsOn | RelHasCollab | RelHasMember | RelHasChild | RelHasParent
     deriving Eq
 
 instance FromJSON RelationshipProperty where
@@ -1130,6 +1130,8 @@ instance FromJSON RelationshipProperty where
             | t == "dependsOn" = pure RelDependsOn
             | t == "hasCollaborator" = pure RelHasCollab
             | t == "hasMember" = pure RelHasMember
+            | t == "hasChild" = pure RelHasChild
+            | t == "hasParent" = pure RelHasParent
             | otherwise = fail $ "Unrecognized relationship: " ++ T.unpack t
 
 instance ToJSON RelationshipProperty where
@@ -1139,6 +1141,8 @@ instance ToJSON RelationshipProperty where
             RelDependsOn -> "dependsOn" :: Text
             RelHasCollab -> "hasCollaborator"
             RelHasMember -> "hasMember"
+            RelHasChild -> "hasChild"
+            RelHasParent -> "hasParent"
 
 data Relationship u = Relationship
     { relationshipId           :: Maybe (ObjURI u)

templates/group/children.hamlet

@@ -0,0 +1,28 @@
+$# This file is part of Vervis.
+$#
+$# Written in 2016, 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
+$#
+$# ♡ Copying is an act of love. Please copy, reuse and share.
+$#
+$# The author(s) have dedicated all copyright and related and neighboring
+$# rights to this software to the public domain worldwide. This software is
+$# distributed without any warranty.
+$#
+$# You should have received a copy of the CC0 Public Domain Dedication along
+$# with this software. If not, see
+$# <http://creativecommons.org/publicdomain/zero/1.0/>.
+
+^{groupNavW (Entity groupID group) actor}
+
+<h2>Children
+
+<table>
+  <tr>
+    <th>Role
+    <th>Since
+    <th>Child
+  $forall (role, since, child) <- children
+    <tr>
+      <td>#{show role}
+      <td>#{showDate since}
+      <td>^{groupLinkFedW child}

templates/group/parents.hamlet

@@ -0,0 +1,28 @@
+$# This file is part of Vervis.
+$#
+$# Written in 2016, 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
+$#
+$# ♡ Copying is an act of love. Please copy, reuse and share.
+$#
+$# The author(s) have dedicated all copyright and related and neighboring
+$# rights to this software to the public domain worldwide. This software is
+$# distributed without any warranty.
+$#
+$# You should have received a copy of the CC0 Public Domain Dedication along
+$# with this software. If not, see
+$# <http://creativecommons.org/publicdomain/zero/1.0/>.
+
+^{groupNavW (Entity groupID group) actor}
+
+<h2>Parents
+
+<table>
+  <tr>
+    <th>Role
+    <th>Since
+    <th>Child
+  $forall (role, since, parent) <- parents
+    <tr>
+      <td>#{show role}
+      <td>#{showDate since}
+      <td>^{groupLinkFedW parent}

templates/project/children.hamlet

@@ -0,0 +1,28 @@
+$# This file is part of Vervis.
+$#
+$# Written in 2016, 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
+$#
+$# ♡ Copying is an act of love. Please copy, reuse and share.
+$#
+$# The author(s) have dedicated all copyright and related and neighboring
+$# rights to this software to the public domain worldwide. This software is
+$# distributed without any warranty.
+$#
+$# You should have received a copy of the CC0 Public Domain Dedication along
+$# with this software. If not, see
+$# <http://creativecommons.org/publicdomain/zero/1.0/>.
+
+^{projectNavW (Entity projectID project) actor}
+
+<h2>Children
+
+<table>
+  <tr>
+    <th>Role
+    <th>Since
+    <th>Child
+  $forall (role, since, child) <- children
+    <tr>
+      <td>#{show role}
+      <td>#{showDate since}
+      <td>^{projectLinkFedW child}

templates/project/parents.hamlet

@@ -0,0 +1,28 @@
+$# This file is part of Vervis.
+$#
+$# Written in 2016, 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
+$#
+$# ♡ Copying is an act of love. Please copy, reuse and share.
+$#
+$# The author(s) have dedicated all copyright and related and neighboring
+$# rights to this software to the public domain worldwide. This software is
+$# distributed without any warranty.
+$#
+$# You should have received a copy of the CC0 Public Domain Dedication along
+$# with this software. If not, see
+$# <http://creativecommons.org/publicdomain/zero/1.0/>.
+
+^{projectNavW (Entity projectID project) actor}
+
+<h2>Parents
+
+<table>
+  <tr>
+    <th>Role
+    <th>Since
+    <th>Child
+  $forall (role, since, parent) <- parents
+    <tr>
+      <td>#{show role}
+      <td>#{showDate since}
+      <td>^{projectLinkFedW parent}

th/models

@@ -1405,7 +1405,7 @@ SourceThemAcceptRemote
 -------------------------------- Source enable -------------------------------
 
 -- Witnesses that, seeing their approval and our collaborator's gesture, I've
--- sent then a delegator-Grant and now officially considering them a source of
+-- sent them a delegator-Grant and now officially considering them a source of
 -- us
 SourceUsSendDelegator
     source SourceId

th/routes

@@ -174,6 +174,11 @@
 /groups/#GroupKeyHashid/invite                          GroupInviteR     GET POST
 /groups/#GroupKeyHashid/remove/#CollabTopicGroupId      GroupRemoveR     POST
 
+/groups/#GroupKeyHashid/children GroupChildrenR GET
+/groups/#GroupKeyHashid/children/local/#DestThemSendDelegatorLocalKeyHashid/live GroupChildLocalLiveR GET
+/groups/#GroupKeyHashid/children/remote/#DestThemSendDelegatorRemoteKeyHashid/live GroupChildRemoteLiveR GET
+/groups/#GroupKeyHashid/parents  GroupParentsR  GET
+
 ---- Repo --------------------------------------------------------------------
 
 /repos/#RepoKeyHashid                             RepoR              GET
@@ -343,3 +348,8 @@
 /projects/#ProjectKeyHashid/collabs/#CollabEnableKeyHashid/live ProjectCollabLiveR    GET
 
 /projects/#ProjectKeyHashid/invite-component             ProjectInviteCompR     GET POST
+
+/projects/#ProjectKeyHashid/children ProjectChildrenR GET
+/projects/#ProjectKeyHashid/parents  ProjectParentsR  GET
+/projects/#ProjectKeyHashid/parents/local/#DestThemSendDelegatorLocalKeyHashid/live ProjectParentLocalLiveR GET
+/projects/#ProjectKeyHashid/parents/remote/#DestThemSendDelegatorRemoteKeyHashid/live ProjectParentRemoteLiveR GET