From acdce58fc614397bb5a9370b130cd53b73f06711 Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Sat, 20 Apr 2024 03:52:34 +0300 Subject: [PATCH] DB: Add a Resource table, and use it in all local Actors except Person --- migrations/603_2024-04-20_resource.model | 4 + migrations/604_2024-04-20_resource.model | 84 +++++++++++++ src/Vervis/API.hs | 4 + src/Vervis/Actor.hs | 111 ++++++++++++++++- src/Vervis/Actor/Person/Client.hs | 6 + src/Vervis/Data/Actor.hs | 43 +++++++ src/Vervis/Migration.hs | 148 +++++++++++++++++++++++ src/Vervis/Migration/Entities.hs | 4 + src/Vervis/Migration/Model2024.hs | 3 + src/Vervis/Persist/Actor.hs | 50 ++++++++ src/Vervis/Recipient.hs | 75 +++++++++++- th/models | 23 +++- 12 files changed, 547 insertions(+), 8 deletions(-) create mode 100644 migrations/603_2024-04-20_resource.model create mode 100644 migrations/604_2024-04-20_resource.model diff --git a/migrations/603_2024-04-20_resource.model b/migrations/603_2024-04-20_resource.model new file mode 100644 index 0000000..ef1b211 --- /dev/null +++ b/migrations/603_2024-04-20_resource.model @@ -0,0 +1,4 @@ +Resource + actor ActorId + + UniqueResource actor diff --git a/migrations/604_2024-04-20_resource.model b/migrations/604_2024-04-20_resource.model new file mode 100644 index 0000000..abd0cc2 --- /dev/null +++ b/migrations/604_2024-04-20_resource.model @@ -0,0 +1,84 @@ +OutboxItem +Workflow +PermitTopicExtend + +Inbox + +Outbox + +FollowerSet + +Actor + name Text + desc Text + createdAt UTCTime + inbox InboxId + outbox OutboxId + followers FollowerSetId + justCreatedBy ActorId Maybe + + UniqueActorInbox inbox + UniqueActorOutbox outbox + UniqueActorFollowers followers + +Resource + actor ActorId + + UniqueResource actor + +Group + actor ActorId + resource ResourceId + create OutboxItemId + + UniqueGroupActor actor + UniqueGroupCreate create + +Project + actor ActorId + resource ResourceId + create OutboxItemId + + UniqueProjectActor actor + UniqueProjectCreate create + +Deck + actor ActorId + resource ResourceId + workflow WorkflowId + nextTicket Int + wiki RepoId Maybe + create OutboxItemId + + UniqueDeckActor actor + UniqueDeckCreate create + +Loom + nextTicket Int + actor ActorId + resource ResourceId + repo RepoId + create OutboxItemId + + UniqueLoomActor actor + UniqueLoomRepo repo + UniqueLoomCreate create + +Repo + vcs VersionControlSystem + project DeckId Maybe + mainBranch Text + actor ActorId + resource ResourceId + create OutboxItemId + loom LoomId Maybe + + UniqueRepoActor actor + UniqueRepoCreate create + +PermitTopicExtendResourceLocal + permit PermitTopicExtendId + actor ActorId + resource ResourceId + + UniquePermitTopicExtendResourceLocal permit diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 1b0aa48..1e26066 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -1131,9 +1131,11 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips insertLoom now name msummary obiidCreate repoID = do actor@(Entity actorID _) <- insertActor now name (fromMaybe "" msummary) (Just $ personActor personUser) + resourceID <- insert $ Resource actorID loomID <- insert Loom { loomNextTicket = 1 , loomActor = actorID + , loomResource = resourceID , loomRepo = repoID , loomCreate = obiidCreate } @@ -1367,11 +1369,13 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r insertRepo now name msummary createID = do actor@(Entity actorID _) <- insertActor now name (fromMaybe "" msummary) (Just $ personActor personUser) + resourceID <- insert $ Resource actorID repoID <- insert Repo { repoVcs = vcs , repoProject = Nothing , repoMainBranch = "main" , repoActor = actorID + , repoResource = resourceID , repoCreate = createID , repoLoom = Nothing } diff --git a/src/Vervis/Actor.hs b/src/Vervis/Actor.hs index 22b1f72..423f95d 100644 --- a/src/Vervis/Actor.hs +++ b/src/Vervis/Actor.hs @@ -1,6 +1,7 @@ {- This file is part of Vervis. - - - Written in 2019, 2020, 2022, 2023 by fr33domlover . + - Written in 2019, 2020, 2022, 2023, 2024 + - by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -24,7 +25,10 @@ module Vervis.Actor ( -- * Local actors LocalActorBy (..) + , LocalResourceBy (..) , LocalActor + , actorToResource + , resourceToActor -- * Converting between KeyHashid, Key, Identity and Entity -- @@ -40,6 +44,17 @@ module Vervis.Actor , unhashLocalActorE , unhashLocalActor404 + , hashLocalResourcePure + , getHashLocalResource + , hashLocalResource + + , unhashLocalResourcePure + , unhashLocalResource + , unhashLocalResourceF + , unhashLocalResourceM + , unhashLocalResourceE + , unhashLocalResource404 + -- * Local recipient set , TicketRoutes (..) , ClothRoutes (..) @@ -147,6 +162,14 @@ data LocalActorBy f | LocalActorProject (f Project) deriving (Generic, FunctorB, ConstraintsB) +data LocalResourceBy f + = LocalResourceGroup (f Group) + | LocalResourceRepo (f Repo) + | LocalResourceDeck (f Deck) + | LocalResourceLoom (f Loom) + | LocalResourceProject (f Project) + deriving (Generic, FunctorB, ConstraintsB) + deriving instance AllBF Eq f LocalActorBy => Eq (LocalActorBy f) deriving instance AllBF Ord f LocalActorBy => Ord (LocalActorBy f) deriving instance AllBF Hashable f LocalActorBy => Hashable (LocalActorBy f) @@ -154,6 +177,21 @@ deriving instance AllBF Show f LocalActorBy => Show (LocalActorBy f) type LocalActor = LocalActorBy KeyHashid +actorToResource = \case + LocalActorPerson _ -> Nothing + LocalActorGroup g -> Just $ LocalResourceGroup g + LocalActorRepo r -> Just $ LocalResourceRepo r + LocalActorDeck d -> Just $ LocalResourceDeck d + LocalActorLoom l -> Just $ LocalResourceLoom l + LocalActorProject j -> Just $ LocalResourceProject j + +resourceToActor = \case + LocalResourceGroup g -> LocalActorGroup g + LocalResourceRepo r -> LocalActorRepo r + LocalResourceDeck d -> LocalActorDeck d + LocalResourceLoom l -> LocalActorLoom l + LocalResourceProject j -> LocalActorProject j + hashLocalActorPure :: HashidsContext -> LocalActorBy Key -> LocalActorBy KeyHashid hashLocalActorPure ctx = f @@ -227,6 +265,77 @@ unhashLocalActor404 actor = maybe notFound return =<< unhashLocalActor actor ctx <- asksSite siteHashidsContext return $ unhashLocalActorPure ctx byHash +hashLocalResourcePure + :: HashidsContext -> LocalResourceBy Key -> LocalResourceBy KeyHashid +hashLocalResourcePure ctx = f + where + f (LocalResourceGroup g) = LocalResourceGroup $ encodeKeyHashidPure ctx g + f (LocalResourceRepo r) = LocalResourceRepo $ encodeKeyHashidPure ctx r + f (LocalResourceDeck d) = LocalResourceDeck $ encodeKeyHashidPure ctx d + f (LocalResourceLoom l) = LocalResourceLoom $ encodeKeyHashidPure ctx l + f (LocalResourceProject j) = LocalResourceProject $ encodeKeyHashidPure ctx j + +getHashLocalResource + :: (MonadActor m, StageHashids (ActorEnv m)) + => m (LocalResourceBy Key -> LocalResourceBy KeyHashid) +getHashLocalResource = do + ctx <- asksEnv stageHashidsContext + return $ hashLocalResourcePure ctx + +hashLocalResource + :: (MonadActor m, StageHashids (ActorEnv m)) + => LocalResourceBy Key -> m (LocalResourceBy KeyHashid) +hashLocalResource actor = do + hash <- getHashLocalResource + return $ hash actor + +unhashLocalResourcePure + :: HashidsContext -> LocalResourceBy KeyHashid -> Maybe (LocalResourceBy Key) +unhashLocalResourcePure ctx = f + where + f (LocalResourceGroup g) = LocalResourceGroup <$> decodeKeyHashidPure ctx g + f (LocalResourceRepo r) = LocalResourceRepo <$> decodeKeyHashidPure ctx r + f (LocalResourceDeck d) = LocalResourceDeck <$> decodeKeyHashidPure ctx d + f (LocalResourceLoom l) = LocalResourceLoom <$> decodeKeyHashidPure ctx l + f (LocalResourceProject j) = LocalResourceProject <$> decodeKeyHashidPure ctx j + +unhashLocalResource + :: (MonadActor m, StageHashids (ActorEnv m)) + => LocalResourceBy KeyHashid -> m (Maybe (LocalResourceBy Key)) +unhashLocalResource actor = do + ctx <- asksEnv stageHashidsContext + return $ unhashLocalResourcePure ctx actor + +unhashLocalResourceF + :: (F.MonadFail m, MonadActor m, StageHashids (ActorEnv m)) + => LocalResourceBy KeyHashid -> String -> m (LocalResourceBy Key) +unhashLocalResourceF actor e = maybe (F.fail e) return =<< unhashLocalResource actor + +unhashLocalResourceM + :: (MonadActor m, StageHashids (ActorEnv m)) + => LocalResourceBy KeyHashid -> MaybeT m (LocalResourceBy Key) +unhashLocalResourceM = MaybeT . unhashLocalResource + +unhashLocalResourceE + :: (MonadActor m, StageHashids (ActorEnv m)) + => LocalResourceBy KeyHashid -> e -> ExceptT e m (LocalResourceBy Key) +unhashLocalResourceE actor e = + ExceptT $ maybe (Left e) Right <$> unhashLocalResource actor + +unhashLocalResource404 + :: ( MonadSite m + , MonadHandler m + , HandlerSite m ~ SiteEnv m + , YesodHashids (HandlerSite m) + ) + => LocalResourceBy KeyHashid + -> m (LocalResourceBy Key) +unhashLocalResource404 actor = maybe notFound return =<< unhashLocalResource actor + where + unhashLocalResource byHash = do + ctx <- asksSite siteHashidsContext + return $ unhashLocalResourcePure ctx byHash + data TicketRoutes = TicketRoutes { routeTicketFollowers :: Bool } diff --git a/src/Vervis/Actor/Person/Client.hs b/src/Vervis/Actor/Person/Client.hs index f0da743..e109892 100644 --- a/src/Vervis/Actor/Person/Client.hs +++ b/src/Vervis/Actor/Person/Client.hs @@ -473,8 +473,10 @@ clientCreateDeck now personMeID (ClientMsg maybeCap localRecips remoteRecips fwd , actorFollowers = fsid , actorJustCreatedBy = Just actorMeID } + rid <- insert $ Resource aid did <- insert Deck { deckActor = aid + , deckResource = rid , deckWorkflow = wid , deckNextTicket = 1 , deckWiki = Nothing @@ -641,8 +643,10 @@ clientCreateProject now personMeID (ClientMsg maybeCap localRecips remoteRecips , actorFollowers = fsid , actorJustCreatedBy = Just actorMeID } + rid <- insert $ Resource aid did <- insert Project { projectActor = aid + , projectResource = rid , projectCreate = obiidCreate } return (did, fsid) @@ -806,8 +810,10 @@ clientCreateTeam now personMeID (ClientMsg maybeCap localRecips remoteRecips fwd , actorFollowers = fsid , actorJustCreatedBy = Just actorMeID } + rid <- insert $ Resource aid gid <- insert Group { groupActor = aid + , groupResource = rid , groupCreate = obiidCreate } return (gid, fsid) diff --git a/src/Vervis/Data/Actor.hs b/src/Vervis/Data/Actor.hs index 8d7586e..9aa0832 100644 --- a/src/Vervis/Data/Actor.hs +++ b/src/Vervis/Data/Actor.hs @@ -22,12 +22,17 @@ module Vervis.Data.Actor , stampRoute , parseStampRoute , localActorID + , localResourceID , parseLocalURI , parseFedURIOld , parseLocalActorE , parseLocalActorE' + , parseLocalResourceE + , parseLocalResourceE' , parseActorURI , parseActorURI' + , parseResourceURI + , parseResourceURI' ) where @@ -175,6 +180,13 @@ localActorID (LocalActorDeck (Entity _ d)) = deckActor d localActorID (LocalActorLoom (Entity _ l)) = loomActor l localActorID (LocalActorProject (Entity _ r)) = projectActor r +localResourceID :: LocalResourceBy Entity -> ResourceId +localResourceID (LocalResourceGroup (Entity _ g)) = groupResource g +localResourceID (LocalResourceRepo (Entity _ r)) = repoResource r +localResourceID (LocalResourceDeck (Entity _ d)) = deckResource d +localResourceID (LocalResourceLoom (Entity _ l)) = loomResource l +localResourceID (LocalResourceProject (Entity _ r)) = projectResource r + parseFedURIOld :: ( MonadSite m , SiteEnv m ~ site @@ -201,6 +213,18 @@ parseLocalActorE' route = do actorByHash <- fromMaybeE (parseLocalActor route) "Not an actor route" VA.unhashLocalActorE actorByHash "Invalid actor keyhashid" +parseLocalResourceE + :: (MonadSite m, YesodHashids (SiteEnv m)) + => Route App -> ExceptT Text m (LocalResourceBy Key) +parseLocalResourceE route = do + actorByHash <- fromMaybeE (parseLocalResource route) "Not a resource route" + unhashLocalResourceE actorByHash "Invalid resource keyhashid" + +parseLocalResourceE' :: Route App -> VA.ActE (LocalResourceBy Key) +parseLocalResourceE' route = do + actorByHash <- fromMaybeE (parseLocalResource route) "Not a resource route" + VA.unhashLocalResourceE actorByHash "Invalid resource keyhashid" + parseActorURI :: (MonadSite m, SiteEnv m ~ App) => FedURI @@ -219,3 +243,22 @@ parseActorURI' u = do parseLocalActorE' pure routeOrRemote + +parseResourceURI + :: (MonadSite m, SiteEnv m ~ App) + => FedURI + -> ExceptT Text m (Either (LocalResourceBy Key) FedURI) +parseResourceURI u = do + routeOrRemote <- parseFedURIOld u + bitraverse + parseLocalResourceE + pure + routeOrRemote + +parseResourceURI' :: FedURI -> VA.ActE (Either (LocalResourceBy Key) FedURI) +parseResourceURI' u = do + routeOrRemote <- parseFedURI u + bitraverse + parseLocalResourceE' + pure + routeOrRemote diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index b4c733b..dcb02de 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -3341,6 +3341,154 @@ changes hLocal ctx = , addEntities model_601_permit_extend_resource -- 602 , addFieldPrimRequired "PermitTopicExtend" ("RoleAdmin" :: String) "role" + -- 603 + , addEntities model_603_resource + -- 604 + , addFieldRefRequired'' + "Repo" + (do inboxID <- insert Inbox604 + outboxID <- insert Outbox604 + followerSetID <- insert FollowerSet604 + actorID <- insert $ Actor604 "" "" defaultTime inboxID outboxID followerSetID Nothing + insertEntity $ Resource604 actorID + ) + (Just $ \ (Entity tempResourceID (Resource604 tempActorID)) -> do + l <- selectList [] [] + for_ l $ \ (Entity k (Repo604 _ _ _ actorID _ _ _)) -> do + resourceID <- insert $ Resource604 actorID + update k [Repo604Resource =. resourceID] + + Actor604 _ _ _ inboxID outboxID followerSetID _ <- getJust tempActorID + delete tempResourceID + delete tempActorID + delete inboxID + delete outboxID + delete followerSetID + ) + "resource" + "Resource" + -- 605 + , addFieldRefRequired'' + "Deck" + (do inboxID <- insert Inbox604 + outboxID <- insert Outbox604 + followerSetID <- insert FollowerSet604 + actorID <- insert $ Actor604 "" "" defaultTime inboxID outboxID followerSetID Nothing + insertEntity $ Resource604 actorID + ) + (Just $ \ (Entity tempResourceID (Resource604 tempActorID)) -> do + l <- selectList [] [] + for_ l $ \ (Entity k (Deck604 actorID _ _ _ _ _)) -> do + resourceID <- insert $ Resource604 actorID + update k [Deck604Resource =. resourceID] + + Actor604 _ _ _ inboxID outboxID followerSetID _ <- getJust tempActorID + delete tempResourceID + delete tempActorID + delete inboxID + delete outboxID + delete followerSetID + ) + "resource" + "Resource" + -- 606 + , addFieldRefRequired'' + "Loom" + (do inboxID <- insert Inbox604 + outboxID <- insert Outbox604 + followerSetID <- insert FollowerSet604 + actorID <- insert $ Actor604 "" "" defaultTime inboxID outboxID followerSetID Nothing + insertEntity $ Resource604 actorID + ) + (Just $ \ (Entity tempResourceID (Resource604 tempActorID)) -> do + l <- selectList [] [] + for_ l $ \ (Entity k (Loom604 _ actorID _ _ _)) -> do + resourceID <- insert $ Resource604 actorID + update k [Loom604Resource =. resourceID] + + Actor604 _ _ _ inboxID outboxID followerSetID _ <- getJust tempActorID + delete tempResourceID + delete tempActorID + delete inboxID + delete outboxID + delete followerSetID + ) + "resource" + "Resource" + -- 607 + , addFieldRefRequired'' + "Project" + (do inboxID <- insert Inbox604 + outboxID <- insert Outbox604 + followerSetID <- insert FollowerSet604 + actorID <- insert $ Actor604 "" "" defaultTime inboxID outboxID followerSetID Nothing + insertEntity $ Resource604 actorID + ) + (Just $ \ (Entity tempResourceID (Resource604 tempActorID)) -> do + l <- selectList [] [] + for_ l $ \ (Entity k (Project604 actorID _ _)) -> do + resourceID <- insert $ Resource604 actorID + update k [Project604Resource =. resourceID] + + Actor604 _ _ _ inboxID outboxID followerSetID _ <- getJust tempActorID + delete tempResourceID + delete tempActorID + delete inboxID + delete outboxID + delete followerSetID + ) + "resource" + "Resource" + -- 608 + , addFieldRefRequired'' + "Group" + (do inboxID <- insert Inbox604 + outboxID <- insert Outbox604 + followerSetID <- insert FollowerSet604 + actorID <- insert $ Actor604 "" "" defaultTime inboxID outboxID followerSetID Nothing + insertEntity $ Resource604 actorID + ) + (Just $ \ (Entity tempResourceID (Resource604 tempActorID)) -> do + l <- selectList [] [] + for_ l $ \ (Entity k (Group604 actorID _ _)) -> do + resourceID <- insert $ Resource604 actorID + update k [Group604Resource =. resourceID] + + Actor604 _ _ _ inboxID outboxID followerSetID _ <- getJust tempActorID + delete tempResourceID + delete tempActorID + delete inboxID + delete outboxID + delete followerSetID + ) + "resource" + "Resource" + -- 609 + {- + , addFieldRefRequired'' + "PermitTopicExtendResourceLocal" + (do inboxID <- insert Inbox604 + outboxID <- insert Outbox604 + followerSetID <- insert FollowerSet604 + actorID <- insert $ Actor604 "" "" defaultTime inboxID outboxID followerSetID Nothing + insertEntity $ Resource604 actorID + ) + (Just $ \ (Entity tempResourceID (Resource604 tempActorID)) -> do + l <- selectList [] [] + for_ l $ \ (Entity k (PermitTopicExtendResourceLocal604 _ actorID _)) -> do + resourceID <- getKeyByJust $ UniqueResource604 actorID + update k [PermitTopicExtendResourceLocal604Resource =. resourceID] + + Actor604 _ _ _ inboxID outboxID followerSetID _ <- getJust tempActorID + delete tempResourceID + delete tempActorID + delete inboxID + delete outboxID + delete followerSetID + ) + "resource" + "Resource" + -} ] migrateDB diff --git a/src/Vervis/Migration/Entities.hs b/src/Vervis/Migration/Entities.hs index 9a3acc6..3b5f203 100644 --- a/src/Vervis/Migration/Entities.hs +++ b/src/Vervis/Migration/Entities.hs @@ -74,6 +74,7 @@ module Vervis.Migration.Entities , model_591_component_gather , model_592_permit_extend , model_601_permit_extend_resource + , model_603_resource ) where @@ -289,3 +290,6 @@ 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") + +model_603_resource :: [Entity SqlBackend] +model_603_resource = $(schema "603_2024-04-20_resource") diff --git a/src/Vervis/Migration/Model2024.hs b/src/Vervis/Migration/Model2024.hs index 7f564f0..8cc944d 100644 --- a/src/Vervis/Migration/Model2024.hs +++ b/src/Vervis/Migration/Model2024.hs @@ -60,3 +60,6 @@ makeEntitiesMigration "584" makeEntitiesMigration "593" $(modelFile "migrations/593_2024-04-18_permit_extend.model") + +makeEntitiesMigration "604" + $(modelFile "migrations/604_2024-04-20_resource.model") diff --git a/src/Vervis/Persist/Actor.hs b/src/Vervis/Persist/Actor.hs index 390d1f9..b01de1b 100644 --- a/src/Vervis/Persist/Actor.hs +++ b/src/Vervis/Persist/Actor.hs @@ -15,10 +15,15 @@ module Vervis.Persist.Actor ( getLocalActor + , getLocalResource , getLocalActorEnt + --, getLocalResourceEnt , getLocalActorEntity , getLocalActorEntityE , getLocalActorEntity404 + , getLocalResourceEntity + , getLocalResourceEntityE + , getLocalResourceEntity404 , verifyLocalActivityExistsInDB , getRemoteObjectURI , getRemoteActorURI @@ -68,6 +73,7 @@ import qualified Web.Actor as WA import qualified Web.Actor.Persist as WAP import Control.Monad.Trans.Except.Local +import Data.Maybe.Local import Database.Persist.Local import Vervis.Data.Actor @@ -83,6 +89,10 @@ getLocalActor :: MonadIO m => ActorId -> ReaderT SqlBackend m (LocalActorBy Key) getLocalActor = fmap (bmap entityKey) . getLocalActorEnt +getLocalResource + :: MonadIO m => ResourceId -> ReaderT SqlBackend m (LocalResourceBy Key) +getLocalResource = fmap (bmap entityKey) . getLocalResourceEnt + getLocalActorEnt :: MonadIO m => ActorId -> ReaderT SqlBackend m (LocalActorBy Entity) getLocalActorEnt actorID = do @@ -103,6 +113,23 @@ getLocalActorEnt actorID = do (Nothing, Nothing, Nothing, Nothing, Nothing, Just j) -> LocalActorProject j _ -> error "Multi-usage of an ActorId" +getLocalResourceEnt + :: MonadIO m => ResourceId -> ReaderT SqlBackend m (LocalResourceBy Entity) +getLocalResourceEnt resourceID = do + Resource actorID <- getJust resourceID + options <- + sequence + [ fmap LocalResourceRepo <$> getBy (UniqueRepoActor actorID) + , fmap LocalResourceDeck <$> getBy (UniqueDeckActor actorID) + , fmap LocalResourceLoom <$> getBy (UniqueLoomActor actorID) + , fmap LocalResourceProject <$> getBy (UniqueProjectActor actorID) + , fmap LocalResourceGroup <$> getBy (UniqueGroupActor actorID) + ] + exactlyOneJust + options + "Found Resource without specific actor" + "Found Resource with multiple actors" + getLocalActorEntity :: MonadIO m => LocalActorBy Key @@ -128,6 +155,29 @@ getLocalActorEntityE a e = do getLocalActorEntity404 = maybe notFound return <=< getLocalActorEntity +getLocalResourceEntity + :: MonadIO m + => LocalResourceBy Key + -> ReaderT SqlBackend m (Maybe (LocalResourceBy Entity)) +getLocalResourceEntity (LocalResourceGroup g) = + fmap (LocalResourceGroup . Entity g) <$> get g +getLocalResourceEntity (LocalResourceRepo r) = + fmap (LocalResourceRepo . Entity r) <$> get r +getLocalResourceEntity (LocalResourceDeck d) = + fmap (LocalResourceDeck . Entity d) <$> get d +getLocalResourceEntity (LocalResourceLoom l) = + fmap (LocalResourceLoom . Entity l) <$> get l +getLocalResourceEntity (LocalResourceProject r) = + fmap (LocalResourceProject . Entity r) <$> get r + +getLocalResourceEntityE a e = do + m <- lift $ getLocalResourceEntity a + case m of + Nothing -> throwE e + Just a' -> return a' + +getLocalResourceEntity404 = maybe notFound return <=< getLocalResourceEntity + verifyLocalActivityExistsInDB :: MonadIO m => LocalActorBy Key diff --git a/src/Vervis/Recipient.hs b/src/Vervis/Recipient.hs index fa88bc5..0372e70 100644 --- a/src/Vervis/Recipient.hs +++ b/src/Vervis/Recipient.hs @@ -1,6 +1,7 @@ {- This file is part of Vervis. - - - Written in 2019, 2020, 2022, 2023 by fr33domlover . + - Written in 2019, 2020, 2022, 2023, 2024 + - by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -22,9 +23,12 @@ module Vervis.Recipient ( -- * Local actors LocalActorBy (..) + , LocalResourceBy (..) , LocalActor , parseLocalActor , renderLocalActor + , parseLocalResource + , renderLocalResource -- * Local collections of (local and remote) actors , LocalStageBy (..) @@ -46,6 +50,17 @@ module Vervis.Recipient , unhashLocalActorE , unhashLocalActor404 + , hashLocalResourcePure + , getHashLocalResource + , hashLocalResource + + , unhashLocalResourcePure + , unhashLocalResource + , unhashLocalResourceF + , unhashLocalResourceM + , unhashLocalResourceE + , unhashLocalResource404 + , hashLocalStagePure , getHashLocalStage , hashLocalStage @@ -143,6 +158,12 @@ import Vervis.Actor hiding , unhashLocalActorF , unhashLocalActorM , unhashLocalActorE + , getHashLocalResource + , hashLocalResource + , unhashLocalResource + , unhashLocalResourceF + , unhashLocalResourceM + , unhashLocalResourceE ) import Vervis.FedURI import Vervis.Foundation @@ -204,6 +225,21 @@ renderLocalActor (LocalActorDeck dkhid) = DeckR dkhid renderLocalActor (LocalActorLoom lkhid) = LoomR lkhid renderLocalActor (LocalActorProject jkhid) = ProjectR jkhid +parseLocalResource :: Route App -> Maybe (LocalResourceBy KeyHashid) +parseLocalResource (GroupR gkhid) = Just $ LocalResourceGroup gkhid +parseLocalResource (RepoR rkhid) = Just $ LocalResourceRepo rkhid +parseLocalResource (DeckR dkhid) = Just $ LocalResourceDeck dkhid +parseLocalResource (LoomR lkhid) = Just $ LocalResourceLoom lkhid +parseLocalResource (ProjectR jkhid) = Just $ LocalResourceProject jkhid +parseLocalResource _ = Nothing + +renderLocalResource :: LocalResourceBy KeyHashid -> Route App +renderLocalResource (LocalResourceGroup gkhid) = GroupR gkhid +renderLocalResource (LocalResourceRepo rkhid) = RepoR rkhid +renderLocalResource (LocalResourceDeck dkhid) = DeckR dkhid +renderLocalResource (LocalResourceLoom lkhid) = LoomR lkhid +renderLocalResource (LocalResourceProject jkhid) = ProjectR jkhid + data LocalStageBy f = LocalStagePersonFollowers (f Person) @@ -315,6 +351,43 @@ unhashLocalActorE unhashLocalActorE actor e = ExceptT $ maybe (Left e) Right <$> unhashLocalActor actor +getHashLocalResource + :: (MonadSite m, YesodHashids (SiteEnv m)) + => m (LocalResourceBy Key -> LocalResourceBy KeyHashid) +getHashLocalResource = do + ctx <- asksSite siteHashidsContext + return $ hashLocalResourcePure ctx + +hashLocalResource + :: (MonadSite m, YesodHashids (SiteEnv m)) + => LocalResourceBy Key -> m (LocalResourceBy KeyHashid) +hashLocalResource actor = do + hash <- getHashLocalResource + return $ hash actor + +unhashLocalResource + :: (MonadSite m, YesodHashids (SiteEnv m)) + => LocalResourceBy KeyHashid -> m (Maybe (LocalResourceBy Key)) +unhashLocalResource actor = do + ctx <- asksSite siteHashidsContext + return $ unhashLocalResourcePure ctx actor + +unhashLocalResourceF + :: (F.MonadFail m, MonadSite m, YesodHashids (SiteEnv m)) + => LocalResourceBy KeyHashid -> String -> m (LocalResourceBy Key) +unhashLocalResourceF actor e = maybe (F.fail e) return =<< unhashLocalResource actor + +unhashLocalResourceM + :: (MonadSite m, YesodHashids (SiteEnv m)) + => LocalResourceBy KeyHashid -> MaybeT m (LocalResourceBy Key) +unhashLocalResourceM = MaybeT . unhashLocalResource + +unhashLocalResourceE + :: (MonadSite m, YesodHashids (SiteEnv m)) + => LocalResourceBy KeyHashid -> e -> ExceptT e m (LocalResourceBy Key) +unhashLocalResourceE actor e = + ExceptT $ maybe (Left e) Right <$> unhashLocalResource actor + hashLocalStagePure :: HashidsContext -> LocalStageBy Key -> LocalStageBy KeyHashid hashLocalStagePure ctx = f diff --git a/th/models b/th/models index 5b303ef..e4780c7 100644 --- a/th/models +++ b/th/models @@ -149,6 +149,11 @@ Person UniquePersonEmail email UniquePersonActor actor +Resource + actor ActorId + + UniqueResource actor + -- ========================================================================= -- -- Delivery -- ========================================================================= -- @@ -270,8 +275,9 @@ SshKey UniqueSshKey person ident Group - actor ActorId - create OutboxItemId + actor ActorId + resource ResourceId + create OutboxItemId UniqueGroupActor actor UniqueGroupCreate create @@ -289,14 +295,16 @@ GroupMember ------------------------------------------------------------------------------- Project - actor ActorId - create OutboxItemId + actor ActorId + resource ResourceId + create OutboxItemId UniqueProjectActor actor UniqueProjectCreate create Deck actor ActorId + resource ResourceId workflow WorkflowId nextTicket Int wiki RepoId Maybe @@ -308,6 +316,7 @@ Deck Loom nextTicket Int actor ActorId + resource ResourceId repo RepoId create OutboxItemId @@ -320,6 +329,7 @@ Repo project DeckId Maybe mainBranch Text actor ActorId + resource ResourceId create OutboxItemId loom LoomId Maybe @@ -936,8 +946,9 @@ PermitTopicExtendRemote UniquePermitTopicExtendRemoteGrant grant PermitTopicExtendResourceLocal - permit PermitTopicExtendId - actor ActorId + permit PermitTopicExtendId + actor ActorId + --resource ResourceId UniquePermitTopicExtendResourceLocal permit