diff --git a/migrations/592_2024-04-18_permit_extend.model b/migrations/592_2024-04-18_permit_extend.model new file mode 100644 index 0000000..b43f807 --- /dev/null +++ b/migrations/592_2024-04-18_permit_extend.model @@ -0,0 +1,2 @@ +PermitTopicExtend + permit PermitPersonSendDelegatorId diff --git a/migrations/593_2024-04-18_permit_extend.model b/migrations/593_2024-04-18_permit_extend.model new file mode 100644 index 0000000..31a6884 --- /dev/null +++ b/migrations/593_2024-04-18_permit_extend.model @@ -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 diff --git a/migrations/601_2024-04-18_permit_extend_resource.model b/migrations/601_2024-04-18_permit_extend_resource.model new file mode 100644 index 0000000..381b971 --- /dev/null +++ b/migrations/601_2024-04-18_permit_extend_resource.model @@ -0,0 +1,11 @@ +PermitTopicExtendResourceLocal + permit PermitTopicExtendId + actor ActorId + + UniquePermitTopicExtendResourceLocal permit + +PermitTopicExtendResourceRemote + permit PermitTopicExtendId + actor RemoteActorId + + UniquePermitTopicExtendResourceRemote permit diff --git a/src/Vervis/Actor/Person.hs b/src/Vervis/Actor/Person.hs index b36c7d0..3b61b65 100644 --- a/src/Vervis/Actor/Person.hs +++ b/src/Vervis/Actor/Person.hs @@ -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 diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs index 0b98260..61bb729 100644 --- a/src/Vervis/Handler/Client.hs +++ b/src/Vervis/Handler/Client.hs @@ -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 diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 3ae904a..b4c733b 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -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 diff --git a/src/Vervis/Migration/Entities.hs b/src/Vervis/Migration/Entities.hs index 7f95ab1..9a3acc6 100644 --- a/src/Vervis/Migration/Entities.hs +++ b/src/Vervis/Migration/Entities.hs @@ -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") diff --git a/src/Vervis/Migration/Model2024.hs b/src/Vervis/Migration/Model2024.hs index e25afba..7f564f0 100644 --- a/src/Vervis/Migration/Model2024.hs +++ b/src/Vervis/Migration/Model2024.hs @@ -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") diff --git a/th/models b/th/models index 66794fa..5b303ef 100644 --- a/th/models +++ b/th/models @@ -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 ------------------------------------------------------------------------------