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

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

9
src/Vervis/Foundation.hs
View file

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

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

@ -1,6 +1,7 @@
{- 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.
-
@ -33,8 +34,7 @@ module Vervis.Handler.Group
, postGroupRemoveR
, getGroupChildrenR
, getGroupChildLocalLiveR
, getGroupChildRemoteLiveR
, getGroupChildLiveR
, getGroupParentsR
@ -484,26 +484,14 @@ getGroupChildrenR groupHash = do
getHtml groupID group actor children = do
$(widgetFile "group/children")
getGroupChildLocalLiveR :: KeyHashid Group -> KeyHashid DestThemSendDelegatorLocal -> Handler ()
getGroupChildLocalLiveR groupHash delegHash = do
getGroupChildLiveR :: KeyHashid Group -> KeyHashid DestUsStart -> Handler ()
getGroupChildLiveR groupHash startHash = do
groupID <- decodeKeyHashid404 groupHash
delegID <- decodeKeyHashid404 delegHash
startID <- decodeKeyHashid404 startHash
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
DestUsStart usAcceptID _ <- get404 startID
DestUsAccept destID _ <- getJust usAcceptID
Entity _ (DestHolderGroup _ g) <-
getBy404 $ UniqueDestHolderGroup destID
unless (g == groupID) notFound

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

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

6
th/routes
View file

@ -177,8 +177,7 @@
/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/children/#DestUsStartKeyHashid/live GroupChildLiveR GET
/groups/#GroupKeyHashid/parents GroupParentsR GET
---- Repo --------------------------------------------------------------------
@ -353,5 +352,4 @@
/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
/projects/#ProjectKeyHashid/parents/#DestUsStartKeyHashid/live ProjectParentLiveR GET