UI, AP: Display project and team children and parents
This commit is contained in:
Pere Lev
parent
1f06d689f5
commit
802df6b15b
11 changed files with 584 additions and 18 deletions
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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|
|
||||
<a href=@{ProjectR h}>
|
||||
\$#{keyHashidText h} #{actorName actor}
|
||||
|]
|
||||
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)
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
28
templates/group/children.hamlet
Normal file
28
templates/group/children.hamlet
Normal file
|
|
@ -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}
|
||||
28
templates/group/parents.hamlet
Normal file
28
templates/group/parents.hamlet
Normal file
|
|
@ -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}
|
||||
28
templates/project/children.hamlet
Normal file
28
templates/project/children.hamlet
Normal file
|
|
@ -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}
|
||||
28
templates/project/parents.hamlet
Normal file
28
templates/project/parents.hamlet
Normal file
|
|
@ -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}
|
||||
|
|
@ -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
|
||||
|
|
|
|||
10
th/routes
10
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
|
||||
|
|
|
|||
Loading…
Reference in a new issue