From 802df6b15b43c61a01157ccc2772b83a23dc3543 Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Tue, 12 Dec 2023 23:21:06 +0200 Subject: [PATCH] UI, AP: Display project and team children and parents --- src/Vervis/Foundation.hs | 12 ++ src/Vervis/Handler/Group.hs | 217 +++++++++++++++++++++++++++++ src/Vervis/Handler/Project.hs | 219 ++++++++++++++++++++++++++++++ src/Vervis/Widget/Tracker.hs | 24 ++-- src/Web/ActivityPub.hs | 6 +- templates/group/children.hamlet | 28 ++++ templates/group/parents.hamlet | 28 ++++ templates/project/children.hamlet | 28 ++++ templates/project/parents.hamlet | 28 ++++ th/models | 2 +- th/routes | 10 ++ 11 files changed, 584 insertions(+), 18 deletions(-) create mode 100644 templates/group/children.hamlet create mode 100644 templates/group/parents.hamlet create mode 100644 templates/project/children.hamlet create mode 100644 templates/project/parents.hamlet diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 809aba7..f28de99 100644 --- a/src/Vervis/Foundation.hs +++ b/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) diff --git a/src/Vervis/Handler/Group.hs b/src/Vervis/Handler/Group.hs index d38d0aa..e7f58ed 100644 --- a/src/Vervis/Handler/Group.hs +++ b/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") diff --git a/src/Vervis/Handler/Project.hs b/src/Vervis/Handler/Project.hs index 9473a1d..d833d73 100644 --- a/src/Vervis/Handler/Project.hs +++ b/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 diff --git a/src/Vervis/Widget/Tracker.hs b/src/Vervis/Widget/Tracker.hs index 2ae7e59..e157ba0 100644 --- a/src/Vervis/Widget/Tracker.hs +++ b/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 - h <- encodeKeyHashid j - [whamlet| - - \$#{keyHashidText h} #{actorName actor} - |] -projectLinkFedW (Right (inztance, object, actor)) = - [whamlet| - - $maybe name <- remoteActorName actor - #{name} - $nothing - #{renderAuthority $ instanceHost inztance}#{localUriPath $ remoteObjectIdent object} - |] - where - uActor = ObjURI (instanceHost inztance) (remoteObjectIdent object) +projectLinkFedW = actorLinkFedW . bimap (first LocalActorProject) id + +groupLinkFedW + :: Either (GroupId, Actor) (Instance, RemoteObject, RemoteActor) + -> Widget +groupLinkFedW = actorLinkFedW . bimap (first LocalActorGroup) id actorLinkW :: LocalActorBy Key -> Actor -> Widget actorLinkW (LocalActorPerson k) actor = do diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index db3e34c..7e3f5fe 100644 --- a/src/Web/ActivityPub.hs +++ b/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) diff --git a/templates/group/children.hamlet b/templates/group/children.hamlet new file mode 100644 index 0000000..e726a8d --- /dev/null +++ b/templates/group/children.hamlet @@ -0,0 +1,28 @@ +$# This file is part of Vervis. +$# +$# Written in 2016, 2019, 2022, 2023 by fr33domlover . +$# +$# ♡ 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 +$# . + +^{groupNavW (Entity groupID group) actor} + +

Children + + + + +
Role + Since + Child + $forall (role, since, child) <- children +
#{show role} + #{showDate since} + ^{groupLinkFedW child} diff --git a/templates/group/parents.hamlet b/templates/group/parents.hamlet new file mode 100644 index 0000000..5258021 --- /dev/null +++ b/templates/group/parents.hamlet @@ -0,0 +1,28 @@ +$# This file is part of Vervis. +$# +$# Written in 2016, 2019, 2022, 2023 by fr33domlover . +$# +$# ♡ 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 +$# . + +^{groupNavW (Entity groupID group) actor} + +

Parents + + + + +
Role + Since + Child + $forall (role, since, parent) <- parents +
#{show role} + #{showDate since} + ^{groupLinkFedW parent} diff --git a/templates/project/children.hamlet b/templates/project/children.hamlet new file mode 100644 index 0000000..5a4a5d9 --- /dev/null +++ b/templates/project/children.hamlet @@ -0,0 +1,28 @@ +$# This file is part of Vervis. +$# +$# Written in 2016, 2019, 2022, 2023 by fr33domlover . +$# +$# ♡ 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 +$# . + +^{projectNavW (Entity projectID project) actor} + +

Children + + + + +
Role + Since + Child + $forall (role, since, child) <- children +
#{show role} + #{showDate since} + ^{projectLinkFedW child} diff --git a/templates/project/parents.hamlet b/templates/project/parents.hamlet new file mode 100644 index 0000000..02239b4 --- /dev/null +++ b/templates/project/parents.hamlet @@ -0,0 +1,28 @@ +$# This file is part of Vervis. +$# +$# Written in 2016, 2019, 2022, 2023 by fr33domlover . +$# +$# ♡ 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 +$# . + +^{projectNavW (Entity projectID project) actor} + +

Parents + + + + +
Role + Since + Child + $forall (role, since, parent) <- parents +
#{show role} + #{showDate since} + ^{projectLinkFedW parent} diff --git a/th/models b/th/models index 9b0fe99..ce21e56 100644 --- a/th/models +++ b/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 diff --git a/th/routes b/th/routes index c305a95..b6633a7 100644 --- a/th/routes +++ b/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