forge/Vervis
1
0
Fork 0
Code Pull requests Activity

S2S: Person: Grant: Record role and resource in Permit record

Browse source
This commit is contained in:
Pere Lev 2024-04-19 02:30:33 +03:00
parent 1f36657084
commit ab08e593ef
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D
9 changed files with 252 additions and 23 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
migrations/592_2024-04-18_permit_extend.model Normal file
View file

@ -0,0 +1,2 @@
PermitTopicExtend
permit PermitPersonSendDelegatorId

48
migrations/593_2024-04-18_permit_extend.model Normal file
View file

@ -0,0 +1,48 @@
Person
PermitTopicEnableLocal
PermitTopicEnableRemote
RemoteActivity
Outbox
OutboxItem
outbox OutboxId
activity PersistJSONObject
published UTCTime
Permit
person PersonId
role Role
PermitPersonGesture
permit PermitId
activity OutboxItemId
UniquePermitPersonGesture permit
UniquePermitPersonGestureActivity activity
PermitPersonSendDelegator
permit PermitPersonGestureId
grant OutboxItemId
UniquePermitPersonSendDelegator permit
UniquePermitPersonSendDelegatorGrant grant
PermitTopicExtend
permit PermitPersonSendDelegatorId
PermitTopicExtendLocal
permit PermitPersonSendDelegatorId
permitNew PermitTopicExtendId
topic PermitTopicEnableLocalId
grant OutboxItemId
UniquePermitTopicExtendLocalGrant grant
PermitTopicExtendRemote
permit PermitPersonSendDelegatorId
permitNew PermitTopicExtendId
topic PermitTopicEnableRemoteId
grant RemoteActivityId
UniquePermitTopicExtendRemoteGrant grant

11
migrations/601_2024-04-18_permit_extend_resource.model Normal file
View file

@ -0,0 +1,11 @@
PermitTopicExtendResourceLocal
permit PermitTopicExtendId
actor ActorId
UniquePermitTopicExtendResourceLocal permit
PermitTopicExtendResourceRemote
permit PermitTopicExtendId
actor RemoteActorId
UniquePermitTopicExtendResourceRemote permit

84
src/Vervis/Actor/Person.hs
View file

@ -20,6 +20,7 @@ module Vervis.Actor.Person
where
import Control.Applicative
import Control.Exception.Base
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Logger.CallStack
@ -71,11 +72,12 @@ import Vervis.FedURI
import Vervis.Federation.Util
import Vervis.Foundation
import Vervis.Model
import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience)
import Vervis.Persist.Actor
import Vervis.Persist.Collab
import Vervis.Persist.Discussion
import Vervis.Persist.Follow
import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience)
import Vervis.RemoteActorStore
import Vervis.Ticket
-- Meaning: Someone is offering a ticket or dependency to a tracker
@ -888,7 +890,35 @@ personGrant now recipPersonID (Verse authorIdMsig body) grant = do
case cap of
Left (LocalActorPerson p, itemID) | p == recipPersonID -> pure itemID
_ -> lift $ throwE "Extending access to me using a delegator-Grant capability that isn't mine"
return $ Right delegatorID
return $ Right (resource, role, delegatorID)
-- For extension-Grant, get the resource by DB/HTTP, and check role
maybeMine' <-
for maybeMine $ traverseOf _Right $ \ (resource, roleExt, delegatorID) -> do
role <-
case roleExt of
AP.RXRole r -> pure r
AP.RXDelegator -> throwE "I've been delegated a Grant with role being delegate"
resourceDB <- bitraverse
(\ la ->
withDBExcept $ localActorID <$>
getLocalActorEntityE la "Extension-Grant resource not found in DB"
)
(\ (ObjURI h lu) -> do
manager <- asksEnv envHttpManager
instanceID <-
lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
result <-
ExceptT $ first (T.pack . displayException) <$>
fetchRemoteActor' instanceID h lu
case result of
Left Nothing -> throwE "Resource @id mismatch"
Left (Just err) -> throwE $ T.pack $ displayException err
Right Nothing -> throwE "Resource isn't an actor"
Right (Just actor) -> return $ entityKey actor
)
resource
return (resourceDB, role, delegatorID)
maybeNew <- withDBExcept $ do
@ -898,7 +928,7 @@ personGrant now recipPersonID (Verse authorIdMsig body) grant = do
(p,) <$> getJust (personActor p)
maybePermit <-
for maybeMine $
for maybeMine' $
bitraverse
(\ (role, fulfills) -> do
@ -940,7 +970,7 @@ personGrant now recipPersonID (Verse authorIdMsig body) grant = do
return (gestureID, bimap fst fst topic)
)
(\ delegatorID -> do
(\ (resourceDB, role, delegatorID) -> do
Entity sendID (PermitPersonSendDelegator gestureID _) <- do
mp <- lift $ getBy $ UniquePermitPersonSendDelegatorGrant delegatorID
fromMaybeE mp "Extension-Grant.capability: I don't have such a delegator-Grant, can't find a PermitPersonSendDelegator record"
@ -953,7 +983,7 @@ personGrant now recipPersonID (Verse authorIdMsig body) grant = do
(Right raID, Right ra) | raID == remoteAuthorId ra -> pure ()
_ -> throwE "Grant sender isn't the Permit topic"
return (sendID, bimap fst fst topic)
return (resourceDB, role, sendID, bimap fst fst topic)
)
mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True
@ -1005,23 +1035,30 @@ personGrant now recipPersonID (Verse authorIdMsig body) grant = do
return (personActor personRecip, sieve, maybeDeleg)
)
(\ (sendID, topic) ->
case (topic, grantDB) of
(\ (resourceDB, role, sendID, topic) -> do
extendID <- case (topic, grantDB) of
(Left localID, Left (_, _, extID)) -> lift $ do
enableID <- do
me <- getKeyBy $ UniquePermitTopicEnableLocalTopic localID
case me of
Just e -> pure e
Nothing -> error "Impossible, Permit has the delegator-Grant but no (local) Enable"
insert_ $ PermitTopicExtendLocal sendID enableID extID
extendID <- insert $ PermitTopicExtend sendID role
insert_ $ PermitTopicExtendLocal extendID enableID extID
return extendID
(Right remoteID, Right (_, _, extID)) -> lift $ do
enableID <- do
me <- getKeyBy $ UniquePermitTopicEnableRemoteTopic remoteID
case me of
Just e -> pure e
Nothing -> error "Impossible, Permit has the delegator-Grant but no (remote) Enable"
insert_ $ PermitTopicExtendRemote sendID enableID extID
extendID <- insert $ PermitTopicExtend sendID role
insert_ $ PermitTopicExtendRemote extendID enableID extID
return extendID
_ -> error "personGrant impossible 2"
lift $ case resourceDB of
Left actorID -> insert_ $ PermitTopicExtendResourceLocal extendID actorID
Right actorID -> insert_ $ PermitTopicExtendResourceRemote extendID actorID
)
case maybeNew of
@ -1170,10 +1207,11 @@ personRevoke now recipPersonID (Verse authorIdMsig body) (AP.Revoke lus) = do
(\ extend -> do
-- Verify the Permit is mine
sendID <-
extendID <-
lift . lift $ case extend of
Left k -> permitTopicExtendLocalPermit <$> getJust k
Right k -> permitTopicExtendRemotePermit <$> getJust k
PermitTopicExtend sendID _ <- lift . lift $ getJust extendID
PermitPersonSendDelegator gestureID _ <- lift . lift $ getJust sendID
PermitPersonGesture permitID _ <- lift . lift $ getJust gestureID
Permit p _ <- lift . lift $ getJust permitID
@ -1188,7 +1226,7 @@ personRevoke now recipPersonID (Verse authorIdMsig body) (AP.Revoke lus) = do
_ -> throwE "Revoke sender isn't the Permit topic"
-- Return data for PermitTopicExtend* deletion
return extend
return (extendID, extend)
)
found
@ -1199,10 +1237,18 @@ personRevoke now recipPersonID (Verse authorIdMsig body) (AP.Revoke lus) = do
bitraverse_
(\ (permitID, gestureID, topicAndEnable) -> do
case topicAndEnable of
Left (_, enableID) ->
deleteWhere [PermitTopicExtendLocalTopic ==. enableID]
Right (_, enableID) ->
deleteWhere [PermitTopicExtendRemoteTopic ==. enableID]
Left (_, enableID) -> do
extends <- selectList [PermitTopicExtendLocalTopic ==. enableID] []
let extendIDs = map (permitTopicExtendLocalPermit . entityVal) extends
extendLocalIDs = map entityKey extends
deleteWhere [PermitTopicExtendLocalId <-. extendLocalIDs]
deleteWhere [PermitTopicExtendId <-. extendIDs]
Right (_, enableID) -> do
extends <- selectList [PermitTopicExtendRemoteTopic ==. enableID] []
let extendIDs = map (permitTopicExtendRemotePermit . entityVal) extends
extendRemoteIDs = map entityKey extends
deleteWhere [PermitTopicExtendRemoteId <-. extendRemoteIDs]
deleteWhere [PermitTopicExtendId <-. extendIDs]
deleteBy $ UniquePermitPersonSendDelegator gestureID
case topicAndEnable of
Left (topicID, enableID) -> do
@ -1230,9 +1276,11 @@ personRevoke now recipPersonID (Verse authorIdMsig body) (AP.Revoke lus) = do
Right (topicID, _) -> delete topicID
delete permitID
)
(\case
Left k -> delete k
Right k -> delete k
(\ (extendID, extend) -> do
case extend of
Left k -> delete k
Right k -> delete k
delete extendID
)
case maybeNew of

8
src/Vervis/Handler/Client.hs
View file

@ -200,9 +200,10 @@ getHomeR = do
Just sendID -> do
topicHash <- VR.hashLocalActor topic
hashItem <- getEncodeKeyHashid
extIDs <-
extIDs <- do
extendIDs <- selectKeysList [PermitTopicExtendPermit ==. sendID] []
map (permitTopicExtendLocalGrant . entityVal) <$>
selectList [PermitTopicExtendLocalPermit ==. sendID] [Asc PermitTopicExtendLocalId]
selectList [PermitTopicExtendLocalPermit <-. extendIDs] [Asc PermitTopicExtendLocalId]
for extIDs $ \ extID -> do
info <- getExtInfo $ Left extID
return
@ -237,7 +238,8 @@ getHomeR = do
case delegator of
Nothing -> pure []
Just sendID -> do
es <- selectList [PermitTopicExtendRemotePermit ==. sendID] [Asc PermitTopicExtendRemoteId]
extendIDs <- selectKeysList [PermitTopicExtendPermit ==. sendID] []
es <- selectList [PermitTopicExtendRemotePermit <-. extendIDs] [Asc PermitTopicExtendRemoteId]
for es $ \ (Entity _ (PermitTopicExtendRemote _ _ extID)) -> do
ext <- getJust extID
u <- getRemoteActivityURI ext

88
src/Vervis/Migration.hs
View file

@ -3253,6 +3253,94 @@ changes hLocal ctx =
, removeEntity "ComponentGatherRemote"
-- 591
, addEntities model_591_component_gather
-- 592
, addEntities model_592_permit_extend
-- 593
, addFieldRefRequired''
"PermitTopicExtendLocal"
(do permitID <- do
personID <- do
mp <- selectFirst [] [Asc Person593Id]
entityKey <$> maybe (error "No people") return mp
insert $ Permit593 personID RoleVisit
itemID <- do
outboxID <- insert Outbox593
let doc = persistJSONObjectFromDoc $ Doc hLocal emptyActivity
insert $ OutboxItem593 outboxID doc defaultTime
gestureID <- insert $ PermitPersonGesture593 permitID itemID
sendID <- insert $ PermitPersonSendDelegator593 gestureID itemID
insertEntity $ PermitTopicExtend593 sendID
)
(Just $ \ (Entity tempExtendID (PermitTopicExtend593 tempSendID)) -> do
l <- selectList [] []
for_ l $ \ (Entity k (PermitTopicExtendLocal593 sendID _ _ _)) -> do
extendID <- insert $ PermitTopicExtend593 sendID
update k [PermitTopicExtendLocal593PermitNew =. extendID]
PermitPersonSendDelegator593 gestureID itemID <- getJust tempSendID
PermitPersonGesture593 permitID _ <- getJust gestureID
OutboxItem593 outboxID _ _ <- getJust itemID
delete tempExtendID
delete tempSendID
delete gestureID
delete itemID
delete outboxID
delete permitID
)
"permitNew"
"PermitTopicExtend"
-- 594
, addFieldRefRequired''
"PermitTopicExtendRemote"
(do let doc = persistJSONObjectFromDoc $ Doc hLocal emptyActivity
permitID <- do
personID <- do
mp <- selectFirst [] [Asc Person593Id]
entityKey <$> maybe (error "No people") return mp
insert $ Permit593 personID RoleVisit
itemID <- do
outboxID <- insert Outbox593
insert $ OutboxItem593 outboxID doc defaultTime
gestureID <- insert $ PermitPersonGesture593 permitID itemID
sendID <- insert $ PermitPersonSendDelegator593 gestureID itemID
insertEntity $ PermitTopicExtend593 sendID
)
(Just $ \ (Entity tempExtendID (PermitTopicExtend593 tempSendID)) -> do
l <- selectList [] []
for_ l $ \ (Entity k (PermitTopicExtendRemote593 sendID _ _ _)) -> do
extendID <- insert $ PermitTopicExtend593 sendID
update k [PermitTopicExtendRemote593PermitNew =. extendID]
PermitPersonSendDelegator593 gestureID itemID <- getJust tempSendID
PermitPersonGesture593 permitID _ <- getJust gestureID
OutboxItem593 outboxID _ _ <- getJust itemID
delete tempExtendID
delete tempSendID
delete gestureID
delete itemID
delete outboxID
delete permitID
)
"permitNew"
"PermitTopicExtend"
-- 595
, removeField "PermitTopicExtendLocal" "permit"
-- 596
, removeField "PermitTopicExtendRemote" "permit"
-- 597
, renameField "PermitTopicExtendLocal" "permitNew" "permit"
-- 598
, renameField "PermitTopicExtendRemote" "permitNew" "permit"
-- 599
, addUnique' "PermitTopicExtendLocal" "" ["permit"]
-- 600
, addUnique' "PermitTopicExtendRemote" "" ["permit"]
-- 601
, addEntities model_601_permit_extend_resource
-- 602
, addFieldPrimRequired "PermitTopicExtend" ("RoleAdmin" :: String) "role"
]
migrateDB

9
src/Vervis/Migration/Entities.hs
View file

@ -72,6 +72,8 @@ module Vervis.Migration.Entities
, model_578_source_remove
, model_583_dest_start
, model_591_component_gather
, model_592_permit_extend
, model_601_permit_extend_resource
)
where
@ -280,3 +282,10 @@ model_583_dest_start = $(schema "583_2024-04-13_dest_start")
model_591_component_gather :: [Entity SqlBackend]
model_591_component_gather = $(schema "591_2024-04-14_component_gather")
model_592_permit_extend :: [Entity SqlBackend]
model_592_permit_extend = $(schema "592_2024-04-18_permit_extend")
model_601_permit_extend_resource :: [Entity SqlBackend]
model_601_permit_extend_resource =
$(schema "601_2024-04-18_permit_extend_resource")

3
src/Vervis/Migration/Model2024.hs
View file

@ -57,3 +57,6 @@ import Web.ActivityPub
makeEntitiesMigration "584"
$(modelFile "migrations/584_2024-04-14_delete_gather.model")
makeEntitiesMigration "593"
$(modelFile "migrations/593_2024-04-18_permit_extend.model")

22
th/models
View file

@ -915,20 +915,38 @@ PermitPersonSendDelegator
-- Witnesses extension-Grants that the topic has sent, extending chains from
-- its components/subprojects or projects/superteams
PermitTopicExtendLocal
PermitTopicExtend
permit PermitPersonSendDelegatorId
role Role
PermitTopicExtendLocal
permit PermitTopicExtendId
topic PermitTopicEnableLocalId
grant OutboxItemId
UniquePermitTopicExtendLocal permit
UniquePermitTopicExtendLocalGrant grant
PermitTopicExtendRemote
permit PermitPersonSendDelegatorId
permit PermitTopicExtendId
topic PermitTopicEnableRemoteId
grant RemoteActivityId
UniquePermitTopicExtendRemote permit
UniquePermitTopicExtendRemoteGrant grant
PermitTopicExtendResourceLocal
permit PermitTopicExtendId
actor ActorId
UniquePermitTopicExtendResourceLocal permit
PermitTopicExtendResourceRemote
permit PermitTopicExtendId
actor RemoteActorId
UniquePermitTopicExtendResourceRemote permit
------------------------------------------------------------------------------
-- Components, from project perspective
------------------------------------------------------------------------------