forge/Vervis
1
0
Fork 0
Code Pull requests Activity

DB: Add a Resource table, and use it in all local Actors except Person

Browse source
This commit is contained in:
Pere Lev 2024-04-20 03:52:34 +03:00
parent fc9d56dd34
commit acdce58fc6
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D
12 changed files with 547 additions and 8 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
migrations/603_2024-04-20_resource.model Normal file
View file

@ -0,0 +1,4 @@
Resource
actor ActorId
UniqueResource actor

84
migrations/604_2024-04-20_resource.model Normal file
View file

@ -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

4
src/Vervis/API.hs
View file

@ -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
}

111
src/Vervis/Actor.hs
View file

@ -1,6 +1,7 @@
{- This file is part of Vervis.
-
- Written in 2019, 2020, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
- Written in 2019, 2020, 2022, 2023, 2024
- by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ 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
}

6
src/Vervis/Actor/Person/Client.hs
View file

@ -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)

43
src/Vervis/Data/Actor.hs
View file

@ -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

148
src/Vervis/Migration.hs
View file

@ -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

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

@ -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")

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

@ -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")

50
src/Vervis/Persist/Actor.hs
View file

@ -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

75
src/Vervis/Recipient.hs
View file

@ -1,6 +1,7 @@
{- This file is part of Vervis.
-
- Written in 2019, 2020, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
- Written in 2019, 2020, 2022, 2023, 2024
- by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ 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

23
th/models
View file

@ -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