forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Switch to DestUsStart in parent/child Live routes

Browse source 
This breaks the old Live routes, so existing chains will stop working
This commit is contained in:
Pere Lev 2024-04-14 13:52:35 +03:00
parent 8f6f5d61bf
commit 97b675130f
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D
5 changed files with 69 additions and 123 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

124
src/Vervis/Actor/Project.hs
View file

@ -2422,7 +2422,9 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
-- For each parent of mine, prepare a delegation-extension Grant -- For each parent of mine, prepare a delegation-extension Grant
localParents <- localParents <-
lift $ lift $
E.select $ E.from $ \ (dest `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` deleg) -> do E.select $ E.from $ \ (dest `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` deleg `E.InnerJoin` accept `E.InnerJoin` start) -> do
E.on $ accept E.^. DestUsAcceptId E.==. start E.^. DestUsStartDest
E.on $ dest E.^. DestId E.==. accept E.^. DestUsAcceptDest
E.on $ topic E.^. DestTopicProjectTopic E.==. deleg E.^. DestThemSendDelegatorLocalTopic E.on $ topic E.^. DestTopicProjectTopic E.==. deleg E.^. DestThemSendDelegatorLocalTopic
E.on $ holder E.^. DestHolderProjectId E.==. topic E.^. DestTopicProjectHolder E.on $ holder E.^. DestHolderProjectId E.==. topic E.^. DestTopicProjectHolder
E.on $ dest E.^. DestId E.==. holder E.^. DestHolderProjectDest E.on $ dest E.^. DestId E.==. holder E.^. DestHolderProjectDest
@ -2432,19 +2434,22 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
, topic E.^. DestTopicProjectParent , topic E.^. DestTopicProjectParent
, deleg E.^. DestThemSendDelegatorLocalId , deleg E.^. DestThemSendDelegatorLocalId
, deleg E.^. DestThemSendDelegatorLocalGrant , deleg E.^. DestThemSendDelegatorLocalGrant
, start E.^. DestUsStartId
) )
localExtensionsForParents <- lift $ for localParents $ \ (E.Value role', E.Value parentID, E.Value delegID, E.Value grantID) -> do localExtensionsForParents <- lift $ for localParents $ \ (E.Value role', E.Value parentID, E.Value _delegID, E.Value grantID, E.Value startID) -> do
extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
--insert_ $ ComponentFurtherLocal enableID delegID extID --insert_ $ ComponentFurtherLocal enableID delegID extID
ext@(actionExt, _, _, _) <- ext@(actionExt, _, _, _) <-
prepareExtensionGrantForParent identForCheck (Left (parentID, grantID)) (min role role') (Left delegID) prepareExtensionGrantForParent identForCheck (Left (parentID, grantID)) (min role role') startID
let recipByKey = LocalActorProject projectID let recipByKey = LocalActorProject projectID
_luExt <- updateOutboxItem' recipByKey extID actionExt _luExt <- updateOutboxItem' recipByKey extID actionExt
return (extID, ext) return (extID, ext)
remoteParents <- remoteParents <-
lift $ lift $
E.select $ E.from $ \ (dest `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` deleg) -> do E.select $ E.from $ \ (dest `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` deleg `E.InnerJoin` accept `E.InnerJoin` start) -> do
E.on $ accept E.^. DestUsAcceptId E.==. start E.^. DestUsStartDest
E.on $ dest E.^. DestId E.==. accept E.^. DestUsAcceptDest
E.on $ topic E.^. DestTopicRemoteId E.==. deleg E.^. DestThemSendDelegatorRemoteTopic E.on $ topic E.^. DestTopicRemoteId E.==. deleg E.^. DestThemSendDelegatorRemoteTopic
E.on $ dest E.^. DestId E.==. topic E.^. DestTopicRemoteDest E.on $ dest E.^. DestId E.==. topic E.^. DestTopicRemoteDest
E.on $ dest E.^. DestId E.==. holder E.^. DestHolderProjectDest E.on $ dest E.^. DestId E.==. holder E.^. DestHolderProjectDest
@ -2454,12 +2459,13 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
, topic E.^. DestTopicRemoteTopic , topic E.^. DestTopicRemoteTopic
, deleg E.^. DestThemSendDelegatorRemoteId , deleg E.^. DestThemSendDelegatorRemoteId
, deleg E.^. DestThemSendDelegatorRemoteGrant , deleg E.^. DestThemSendDelegatorRemoteGrant
, start E.^. DestUsStartId
) )
remoteExtensionsForParents <- lift $ for remoteParents $ \ (E.Value role', E.Value parentID, E.Value delegID, E.Value grantID) -> do remoteExtensionsForParents <- lift $ for remoteParents $ \ (E.Value role', E.Value parentID, E.Value _delegID, E.Value grantID, E.Value startID) -> do
extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
--insert_ $ ComponentFurtherRemote enableID delegID extID --insert_ $ ComponentFurtherRemote enableID delegID extID
ext@(actionExt, _, _, _) <- ext@(actionExt, _, _, _) <-
prepareExtensionGrantForParent identForCheck (Right (parentID, grantID)) (min role role') (Right delegID) prepareExtensionGrantForParent identForCheck (Right (parentID, grantID)) (min role role') startID
let recipByKey = LocalActorProject projectID let recipByKey = LocalActorProject projectID
_luExt <- updateOutboxItem' recipByKey extID actionExt _luExt <- updateOutboxItem' recipByKey extID actionExt
return (extID, ext) return (extID, ext)
@ -2550,7 +2556,7 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
return (action, recipientSet, remoteActors, fwdHosts) return (action, recipientSet, remoteActors, fwdHosts)
prepareExtensionGrantForParent component parent role deleg = do prepareExtensionGrantForParent component parent role startID = do
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
@ -2583,16 +2589,9 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
return $ encodeRouteHome $ renderLocalActor a return $ encodeRouteHome $ renderLocalActor a
Right u -> pure u Right u -> pure u
resultR <- resultR <- do
case deleg of startHash <- encodeKeyHashid startID
Left delegID -> do return $ ProjectParentLiveR projectHash startHash
delegHash <- encodeKeyHashid delegID
return $
ProjectParentLocalLiveR projectHash delegHash
Right delegID -> do
delegHash <- encodeKeyHashid delegID
return $
ProjectParentRemoteLiveR projectHash delegHash
let audience = [audParent] let audience = [audParent]
@ -3039,7 +3038,8 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
-- For each parent of mine, prepare a delegation-extension Grant -- For each parent of mine, prepare a delegation-extension Grant
localParents <- localParents <-
lift $ lift $
E.select $ E.from $ \ (dest `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` deleg `E.InnerJoin` accept) -> do E.select $ E.from $ \ (dest `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` deleg `E.InnerJoin` accept `E.InnerJoin` start) -> do
E.on $ accept E.^. DestUsAcceptId E.==. start E.^. DestUsStartDest
E.on $ dest E.^. DestId E.==. accept E.^. DestUsAcceptDest E.on $ dest E.^. DestId E.==. accept E.^. DestUsAcceptDest
E.on $ topic E.^. DestTopicProjectTopic E.==. deleg E.^. DestThemSendDelegatorLocalTopic E.on $ topic E.^. DestTopicProjectTopic E.==. deleg E.^. DestThemSendDelegatorLocalTopic
E.on $ holder E.^. DestHolderProjectId E.==. topic E.^. DestTopicProjectHolder E.on $ holder E.^. DestHolderProjectId E.==. topic E.^. DestTopicProjectHolder
@ -3051,8 +3051,9 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
, deleg E.^. DestThemSendDelegatorLocalId , deleg E.^. DestThemSendDelegatorLocalId
, deleg E.^. DestThemSendDelegatorLocalGrant , deleg E.^. DestThemSendDelegatorLocalGrant
, accept E.^. DestUsAcceptId , accept E.^. DestUsAcceptId
, start E.^. DestUsStartId
) )
localExtensionsForParents <- lift $ for localParents $ \ (E.Value role', E.Value parentID, E.Value delegID, E.Value grantID, E.Value acceptID) -> do localExtensionsForParents <- lift $ for localParents $ \ (E.Value role', E.Value parentID, E.Value delegID, E.Value grantID, E.Value acceptID, E.Value startID) -> do
extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
gatherID <- insert $ SourceUsGather sendID acceptID extID gatherID <- insert $ SourceUsGather sendID acceptID extID
case from of case from of
@ -3060,14 +3061,15 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
Right remoteID -> insert_ $ SourceUsGatherFromRemote gatherID remoteID Right remoteID -> insert_ $ SourceUsGatherFromRemote gatherID remoteID
insert_ $ SourceUsGatherToLocal gatherID delegID insert_ $ SourceUsGatherToLocal gatherID delegID
ext@(actionExt, _, _, _) <- ext@(actionExt, _, _, _) <-
prepareExtensionGrantForParent (Left (parentID, grantID)) (min role role') (Left delegID) prepareExtensionGrantForParent (Left (parentID, grantID)) (min role role') startID
let recipByKey = LocalActorProject projectID let recipByKey = LocalActorProject projectID
_luExt <- updateOutboxItem' recipByKey extID actionExt _luExt <- updateOutboxItem' recipByKey extID actionExt
return (extID, ext) return (extID, ext)
remoteParents <- remoteParents <-
lift $ lift $
E.select $ E.from $ \ (dest `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` deleg `E.InnerJoin` accept) -> do E.select $ E.from $ \ (dest `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` deleg `E.InnerJoin` accept `E.InnerJoin` start) -> do
E.on $ accept E.^. DestUsAcceptId E.==. start E.^. DestUsStartDest
E.on $ dest E.^. DestId E.==. accept E.^. DestUsAcceptDest E.on $ dest E.^. DestId E.==. accept E.^. DestUsAcceptDest
E.on $ topic E.^. DestTopicRemoteId E.==. deleg E.^. DestThemSendDelegatorRemoteTopic E.on $ topic E.^. DestTopicRemoteId E.==. deleg E.^. DestThemSendDelegatorRemoteTopic
E.on $ dest E.^. DestId E.==. topic E.^. DestTopicRemoteDest E.on $ dest E.^. DestId E.==. topic E.^. DestTopicRemoteDest
@ -3079,8 +3081,9 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
, deleg E.^. DestThemSendDelegatorRemoteId , deleg E.^. DestThemSendDelegatorRemoteId
, deleg E.^. DestThemSendDelegatorRemoteGrant , deleg E.^. DestThemSendDelegatorRemoteGrant
, accept E.^. DestUsAcceptId , accept E.^. DestUsAcceptId
, start E.^. DestUsStartId
) )
remoteExtensionsForParents <- lift $ for remoteParents $ \ (E.Value role', E.Value parentID, E.Value delegID, E.Value grantID, E.Value acceptID) -> do remoteExtensionsForParents <- lift $ for remoteParents $ \ (E.Value role', E.Value parentID, E.Value delegID, E.Value grantID, E.Value acceptID, E.Value startID) -> do
extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
gatherID <- insert $ SourceUsGather sendID acceptID extID gatherID <- insert $ SourceUsGather sendID acceptID extID
case from of case from of
@ -3088,7 +3091,7 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
Right remoteID -> insert_ $ SourceUsGatherFromRemote gatherID remoteID Right remoteID -> insert_ $ SourceUsGatherFromRemote gatherID remoteID
insert_ $ SourceUsGatherToRemote gatherID delegID insert_ $ SourceUsGatherToRemote gatherID delegID
ext@(actionExt, _, _, _) <- ext@(actionExt, _, _, _) <-
prepareExtensionGrantForParent (Right (parentID, grantID)) (min role role') (Right delegID) prepareExtensionGrantForParent (Right (parentID, grantID)) (min role role') startID
let recipByKey = LocalActorProject projectID let recipByKey = LocalActorProject projectID
_luExt <- updateOutboxItem' recipByKey extID actionExt _luExt <- updateOutboxItem' recipByKey extID actionExt
return (extID, ext) return (extID, ext)
@ -3170,7 +3173,7 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
return (action, recipientSet, remoteActors, fwdHosts) return (action, recipientSet, remoteActors, fwdHosts)
prepareExtensionGrantForParent parent role deleg = do prepareExtensionGrantForParent parent role startID = do
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
@ -3196,16 +3199,10 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
getRemoteActivityURI ract getRemoteActivityURI ract
return (u, AudRemote h [lu] [], uAct) return (u, AudRemote h [lu] [], uAct)
resultR <- resultR <- do
case deleg of startHash <- encodeKeyHashid startID
Left delegID -> do return $
delegHash <- encodeKeyHashid delegID ProjectParentLiveR projectHash startHash
return $
ProjectParentLocalLiveR projectHash delegHash
Right delegID -> do
delegHash <- encodeKeyHashid delegID
return $
ProjectParentRemoteLiveR projectHash delegHash
let audience = [audParent] let audience = [audParent]
@ -3328,14 +3325,14 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
fromMaybeE mk "I already have such a DestThemSendDelegatorRemote" fromMaybeE mk "I already have such a DestThemSendDelegatorRemote"
_ -> error "projectGrant.parent impossible" _ -> error "projectGrant.parent impossible"
-- Prepare a start-Grant
startID <- lift $ insertEmptyOutboxItem' (actorOutbox recipActor) now startID <- lift $ insertEmptyOutboxItem' (actorOutbox recipActor) now
start@(actionStart, _, _, _) <- lift $ prepareStartGrant role to destStartID <- lift $ insert $ DestUsStart acceptID startID
-- Prepare a start-Grant
start@(actionStart, _, _, _) <- lift $ prepareStartGrant role destStartID
let recipByKey = LocalActorProject projectID let recipByKey = LocalActorProject projectID
_luStart <- lift $ updateOutboxItem' recipByKey startID actionStart _luStart <- lift $ updateOutboxItem' recipByKey startID actionStart
lift $ insert_ $ DestUsStart acceptID startID
-- For each Component in me, prepare a delegation-extension Grant -- For each Component in me, prepare a delegation-extension Grant
localComponents <- localComponents <-
lift $ lift $
@ -3369,7 +3366,7 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
s <- encodeKeyHashid startID s <- encodeKeyHashid startID
return $ encodeRouteHome $ activityRoute (componentActor c) s return $ encodeRouteHome $ activityRoute (componentActor c) s
ext@(actionExt, _, _, _) <- ext@(actionExt, _, _, _) <-
prepareExtensionGrant componentIdent uStart (min role (componentRole component)) enableID to prepareExtensionGrant componentIdent uStart (min role (componentRole component)) enableID destStartID
let recipByKey = LocalActorProject projectID let recipByKey = LocalActorProject projectID
_luExt <- updateOutboxItem' recipByKey extID actionExt _luExt <- updateOutboxItem' recipByKey extID actionExt
return (extID, ext) return (extID, ext)
@ -3401,7 +3398,7 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
ra <- getJust startID ra <- getJust startID
getRemoteActivityURI ra getRemoteActivityURI ra
ext@(actionExt, _, _, _) <- ext@(actionExt, _, _, _) <-
prepareExtensionGrant componentIdent uStart (min role (componentRole component)) enableID to prepareExtensionGrant componentIdent uStart (min role (componentRole component)) enableID destStartID
let recipByKey = LocalActorProject projectID let recipByKey = LocalActorProject projectID
_luExt <- updateOutboxItem' recipByKey extID actionExt _luExt <- updateOutboxItem' recipByKey extID actionExt
return (extID, ext) return (extID, ext)
@ -3451,7 +3448,7 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
Nothing -> error "SourceThemDelegate grant has no 'id'" Nothing -> error "SourceThemDelegate grant has no 'id'"
Just lu -> pure $ ObjURI h lu Just lu -> pure $ ObjURI h lu
ext@(actionExt, _, _, _) <- ext@(actionExt, _, _, _) <-
prepareExtensionGrantFromChild uStart grant role to prepareExtensionGrantFromChild uStart grant role destStartID
let recipByKey = LocalActorProject projectID let recipByKey = LocalActorProject projectID
_luExt <- updateOutboxItem' recipByKey extID actionExt _luExt <- updateOutboxItem' recipByKey extID actionExt
return (extID, ext) return (extID, ext)
@ -3474,7 +3471,7 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
where where
prepareExtensionGrant component uStart role enableID deleg = do prepareExtensionGrant component uStart role enableID startID = do
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
@ -3493,16 +3490,9 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
audParent <- lift $ makeAudSenderOnly authorIdMsig audParent <- lift $ makeAudSenderOnly authorIdMsig
uParent <- lift $ getActorURI authorIdMsig uParent <- lift $ getActorURI authorIdMsig
resultR <- resultR <- do
case deleg of startHash <- encodeKeyHashid startID
Left delegID -> do return $ ProjectParentLiveR projectHash startHash
delegHash <- encodeKeyHashid delegID
return $
ProjectParentLocalLiveR projectHash delegHash
Right delegID -> do
delegHash <- encodeKeyHashid delegID
return $
ProjectParentRemoteLiveR projectHash delegHash
let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
collectAudience [audParent] collectAudience [audParent]
@ -3531,7 +3521,7 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
return (action, recipientSet, remoteActors, fwdHosts) return (action, recipientSet, remoteActors, fwdHosts)
prepareStartGrant role deleg = do prepareStartGrant role startID = do
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
@ -3542,16 +3532,9 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
audParent <- lift $ makeAudSenderOnly authorIdMsig audParent <- lift $ makeAudSenderOnly authorIdMsig
uParent <- lift $ getActorURI authorIdMsig uParent <- lift $ getActorURI authorIdMsig
resultR <- resultR <- do
case deleg of startHash <- encodeKeyHashid startID
Left delegID -> do return $ ProjectParentLiveR projectHash startHash
delegHash <- encodeKeyHashid delegID
return $
ProjectParentLocalLiveR projectHash delegHash
Right delegID -> do
delegHash <- encodeKeyHashid delegID
return $
ProjectParentRemoteLiveR projectHash delegHash
let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
collectAudience [audParent] collectAudience [audParent]
@ -3580,7 +3563,7 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
return (action, recipientSet, remoteActors, fwdHosts) return (action, recipientSet, remoteActors, fwdHosts)
prepareExtensionGrantFromChild uStart grant role to = do prepareExtensionGrantFromChild uStart grant role startID = do
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
@ -3594,16 +3577,9 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
audParent <- lift $ makeAudSenderOnly authorIdMsig audParent <- lift $ makeAudSenderOnly authorIdMsig
uParent <- lift $ getActorURI authorIdMsig uParent <- lift $ getActorURI authorIdMsig
resultR <- resultR <- do
case to of startHash <- encodeKeyHashid startID
Left delegID -> do return $ ProjectParentLiveR projectHash startHash
delegHash <- encodeKeyHashid delegID
return $
ProjectParentLocalLiveR projectHash delegHash
Right delegID -> do
delegHash <- encodeKeyHashid delegID
return $
ProjectParentRemoteLiveR projectHash delegHash
let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
collectAudience [audParent] collectAudience [audParent]

9
src/Vervis/Foundation.hs
View file

@ -161,8 +161,7 @@ type ProjectKeyHashid = KeyHashid Project
type CollabEnableKeyHashid = KeyHashid CollabEnable type CollabEnableKeyHashid = KeyHashid CollabEnable
type StemKeyHashid = KeyHashid Stem type StemKeyHashid = KeyHashid Stem
type PermitFulfillsInviteKeyHashid = KeyHashid PermitFulfillsInvite type PermitFulfillsInviteKeyHashid = KeyHashid PermitFulfillsInvite
type DestThemSendDelegatorLocalKeyHashid = KeyHashid DestThemSendDelegatorLocal type DestUsStartKeyHashid = KeyHashid DestUsStart
type DestThemSendDelegatorRemoteKeyHashid = KeyHashid DestThemSendDelegatorRemote
-- This is where we define all of the routes in our application. For a full -- This is where we define all of the routes in our application. For a full
-- explanation of the syntax, please see: -- explanation of the syntax, please see:
@ -896,8 +895,7 @@ instance YesodBreadcrumbs App where
GroupRemoveR _ _ -> ("", Nothing) GroupRemoveR _ _ -> ("", Nothing)
GroupChildrenR j -> ("Child teams", Just $ GroupR j) GroupChildrenR j -> ("Child teams", Just $ GroupR j)
GroupChildLocalLiveR j d -> ("Local " <> keyHashidText d, Just $ GroupChildrenR j) GroupChildLiveR j d -> (keyHashidText d, Just $ GroupChildrenR j)
GroupChildRemoteLiveR j d -> ("Remote " <> keyHashidText d, Just $ GroupChildrenR j)
GroupParentsR j -> ("Parent teams", Just $ GroupR j) GroupParentsR j -> ("Parent teams", Just $ GroupR j)
RepoR r -> ("Repo ^" <> keyHashidText r, Just HomeR) RepoR r -> ("Repo ^" <> keyHashidText r, Just HomeR)
@ -1038,5 +1036,4 @@ instance YesodBreadcrumbs App where
ProjectChildrenR j -> ("Child projects", Just $ ProjectR j) ProjectChildrenR j -> ("Child projects", Just $ ProjectR j)
ProjectParentsR j -> ("Parent projects", Just $ ProjectR j) ProjectParentsR j -> ("Parent projects", Just $ ProjectR j)
ProjectParentLocalLiveR j d -> ("Local " <> keyHashidText d, Just $ ProjectParentsR j) ProjectParentLiveR j d -> (keyHashidText d, Just $ ProjectParentsR j)
ProjectParentRemoteLiveR j d -> ("Remote " <> keyHashidText d, Just $ ProjectParentsR j)

28
src/Vervis/Handler/Group.hs
View file

@ -1,6 +1,7 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2016, 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>. - Written in 2016, 2019, 2022, 2023, 2024
- by fr33domlover <fr33domlover@riseup.net>.
- -
- ♡ Copying is an act of love. Please copy, reuse and share. - ♡ Copying is an act of love. Please copy, reuse and share.
- -
@ -33,8 +34,7 @@ module Vervis.Handler.Group
, postGroupRemoveR , postGroupRemoveR
, getGroupChildrenR , getGroupChildrenR
, getGroupChildLocalLiveR , getGroupChildLiveR
, getGroupChildRemoteLiveR
, getGroupParentsR , getGroupParentsR
@ -484,26 +484,14 @@ getGroupChildrenR groupHash = do
getHtml groupID group actor children = do getHtml groupID group actor children = do
$(widgetFile "group/children") $(widgetFile "group/children")
getGroupChildLocalLiveR :: KeyHashid Group -> KeyHashid DestThemSendDelegatorLocal -> Handler () getGroupChildLiveR :: KeyHashid Group -> KeyHashid DestUsStart -> Handler ()
getGroupChildLocalLiveR groupHash delegHash = do getGroupChildLiveR groupHash startHash = do
groupID <- decodeKeyHashid404 groupHash groupID <- decodeKeyHashid404 groupHash
delegID <- decodeKeyHashid404 delegHash startID <- decodeKeyHashid404 startHash
runDB $ do runDB $ do
_ <- get404 groupID _ <- get404 groupID
DestThemSendDelegatorLocal _ localID _ <- get404 delegID DestUsStart usAcceptID _ <- get404 startID
DestTopicLocal destID <- getJust localID DestUsAccept destID _ <- getJust usAcceptID
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) <- Entity _ (DestHolderGroup _ g) <-
getBy404 $ UniqueDestHolderGroup destID getBy404 $ UniqueDestHolderGroup destID
unless (g == groupID) notFound unless (g == groupID) notFound

25
src/Vervis/Handler/Project.hs
View file

@ -42,8 +42,7 @@ module Vervis.Handler.Project
, getProjectChildrenR , getProjectChildrenR
, getProjectParentsR , getProjectParentsR
, getProjectParentLocalLiveR , getProjectParentLiveR
, getProjectParentRemoteLiveR
) )
where where
@ -889,26 +888,14 @@ getProjectParentsR projectHash = do
inztance <- getJust $ remoteObjectInstance object inztance <- getJust $ remoteObjectInstance object
return (inztance, object, actor) return (inztance, object, actor)
getProjectParentLocalLiveR :: KeyHashid Project -> KeyHashid DestThemSendDelegatorLocal -> Handler () getProjectParentLiveR :: KeyHashid Project -> KeyHashid DestUsStart -> Handler ()
getProjectParentLocalLiveR projectHash delegHash = do getProjectParentLiveR projectHash startHash = do
projectID <- decodeKeyHashid404 projectHash projectID <- decodeKeyHashid404 projectHash
delegID <- decodeKeyHashid404 delegHash startID <- decodeKeyHashid404 startHash
runDB $ do runDB $ do
_ <- get404 projectID _ <- get404 projectID
DestThemSendDelegatorLocal _ localID _ <- get404 delegID DestUsStart usAcceptID _ <- get404 startID
DestTopicLocal destID <- getJust localID DestUsAccept destID _ <- getJust usAcceptID
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) <- Entity _ (DestHolderProject _ j) <-
getBy404 $ UniqueDestHolderProject destID getBy404 $ UniqueDestHolderProject destID
unless (j == projectID) notFound unless (j == projectID) notFound

6
th/routes
View file

@ -177,8 +177,7 @@
/groups/#GroupKeyHashid/remove/#CollabTopicGroupId GroupRemoveR POST /groups/#GroupKeyHashid/remove/#CollabTopicGroupId GroupRemoveR POST
/groups/#GroupKeyHashid/children GroupChildrenR GET /groups/#GroupKeyHashid/children GroupChildrenR GET
/groups/#GroupKeyHashid/children/local/#DestThemSendDelegatorLocalKeyHashid/live GroupChildLocalLiveR GET /groups/#GroupKeyHashid/children/#DestUsStartKeyHashid/live GroupChildLiveR GET
/groups/#GroupKeyHashid/children/remote/#DestThemSendDelegatorRemoteKeyHashid/live GroupChildRemoteLiveR GET
/groups/#GroupKeyHashid/parents GroupParentsR GET /groups/#GroupKeyHashid/parents GroupParentsR GET
---- Repo -------------------------------------------------------------------- ---- Repo --------------------------------------------------------------------
@ -353,5 +352,4 @@
/projects/#ProjectKeyHashid/children ProjectChildrenR GET /projects/#ProjectKeyHashid/children ProjectChildrenR GET
/projects/#ProjectKeyHashid/parents ProjectParentsR GET /projects/#ProjectKeyHashid/parents ProjectParentsR GET
/projects/#ProjectKeyHashid/parents/local/#DestThemSendDelegatorLocalKeyHashid/live ProjectParentLocalLiveR GET /projects/#ProjectKeyHashid/parents/#DestUsStartKeyHashid/live ProjectParentLiveR GET
/projects/#ProjectKeyHashid/parents/remote/#DestThemSendDelegatorRemoteKeyHashid/live ProjectParentRemoteLiveR GET