forge/Vervis
1
0
Fork 0
Code Pull requests Activity

DB: Remove StemIdent* tables, use Komponent instead

Browse source
This commit is contained in:
Pere Lev 2024-04-30 00:32:30 +03:00
parent 5d594ca738
commit 4b6e95b2e8
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D
8 changed files with 188 additions and 83 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

91
migrations/634_2024-04-29_stem_holder.model Normal file
View file

@ -0,0 +1,91 @@
Workflow
OutboxItem
Outbox
Inbox
FollowerSet
Actor
name Text
desc Text
createdAt UTCTime
inbox InboxId
outbox OutboxId
followers FollowerSetId
justCreatedBy ActorId Maybe
errbox InboxId
UniqueActorInbox inbox
UniqueActorOutbox outbox
UniqueActorFollowers followers
Resource
actor ActorId
UniqueResource actor
Komponent
resource ResourceId
UniqueKomponent resource
Deck
actor ActorId
resource ResourceId
komponent KomponentId
workflow WorkflowId
nextTicket Int
wiki RepoId Maybe
create OutboxItemId
UniqueDeckActor actor
UniqueDeckCreate create
Loom
nextTicket Int
actor ActorId
resource ResourceId
komponent KomponentId
repo RepoId
create OutboxItemId
UniqueLoomActor actor
UniqueLoomRepo repo
UniqueLoomCreate create
Repo
vcs VersionControlSystem
project DeckId Maybe
mainBranch Text
actor ActorId
resource ResourceId
komponent KomponentId
create OutboxItemId
loom LoomId Maybe
UniqueRepoActor actor
UniqueRepoCreate create
Stem
role Role
holder KomponentId
StemIdentRepo
stem StemId
repo RepoId
UniqueStemIdentRepo stem
StemIdentDeck
stem StemId
deck DeckId
UniqueStemIdentDeck stem
StemIdentLoom
stem StemId
loom LoomId
UniqueStemIdentLoom stem

29
src/Vervis/Actor/Common.hs
View file

@ -21,7 +21,7 @@ module Vervis.Actor.Common
( actorFollow
, topicAccept
, topicReject
, topicInvite
, componentInvite
, topicRemove
, topicJoin
, topicCreateMe
@ -944,20 +944,17 @@ topicReject grabResource topicResource now recipKey (Verse authorIdMsig body) re
-- * Create a Stem record in DB
-- * Insert the Invite to my inbox
-- * Forward the Invite to my followers
topicInvite
:: forall topic ct si.
( PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic
, PersistRecordBackend si SqlBackend
)
=> (topic -> ResourceId)
componentInvite
:: forall topic.
(PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
=> (topic -> KomponentId)
-> (forall f. f topic -> ComponentBy f)
-> (StemId -> Key topic -> si)
-> UTCTime
-> Key topic
-> Verse
-> AP.Invite URIMode
-> ActE (Text, Act (), Next)
topicInvite grabResource topicComponent stemIdentCtor now topicKey (Verse authorIdMsig body) invite = do
componentInvite grabKomponent topicComponent now topicKey (Verse authorIdMsig body) invite = do
-- Check invite
recipOrProject <- do
@ -1088,7 +1085,8 @@ topicInvite grabResource topicComponent stemIdentCtor now topicKey (Verse author
maybeNew <- withDBExcept $ do
-- Grab me from DB
resourceID <- lift $ grabResource <$> getJust topicKey
komponentID <- lift $ grabKomponent <$> getJust topicKey
Komponent resourceID <- lift $ getJust komponentID
Resource topicActorID <- lift $ getJust resourceID
topicActor <- lift $ getJust topicActorID
@ -1130,7 +1128,7 @@ topicInvite grabResource topicComponent stemIdentCtor now topicKey (Verse author
-- Find existing Stem records I have for this project
-- Make sure none are enabled / in Add-Accept mode / in Invite-Accept
-- mode
checkExistingStems (topicComponent topicKey) projectDB
checkExistingStems komponentID projectDB
maybeInviteDB <- lift $ insertToInbox now authorIdMsig body (actorInbox topicActor) False
lift $ for maybeInviteDB $ \ (inboxItemID, inviteDB) -> do
@ -1154,7 +1152,7 @@ topicInvite grabResource topicComponent stemIdentCtor now topicKey (Verse author
_luAccept <- updateOutboxItem' topicByKey acceptID actionAccept
return (acceptID, accept)
Right projectDB -> do
insertStem projectDB inviteDB
insertStem komponentID projectDB inviteDB
return Nothing
return (topicActorID, sieve, maybeAccept, inboxItemID)
@ -1190,9 +1188,8 @@ topicInvite grabResource topicComponent stemIdentCtor now topicKey (Verse author
Right remoteActorID ->
insert_ $ CollabRecipRemote collabID remoteActorID
insertStem projectDB inviteDB = do
stemID <- insert $ Stem AP.RoleAdmin
insert_ $ stemIdentCtor stemID topicKey
insertStem komponentID projectDB inviteDB = do
stemID <- insert $ Stem AP.RoleAdmin komponentID
case projectDB of
Left (Entity projectID _) ->
insert_ $ StemProjectLocal stemID projectID
@ -1778,7 +1775,7 @@ componentGrant grabResource topicComponent now recipKey (Verse authorIdMsig body
-- Prepare a Grant activity and insert to my outbox
chain <- do
Stem role <- getJust stemID
Stem role _ <- getJust stemID
chain@(actionChain, _, _, _) <- prepareChain role
let recipByKey = resourceToActor $ topicResource recipKey
_luChain <- updateOutboxItem' recipByKey chainID actionChain

11
src/Vervis/Actor/Deck.hs
View file

@ -192,7 +192,7 @@ deckAdd now deckID (Verse authorIdMsig body) add = do
-- Find existing Stem records I have for this project
-- Make sure none are enabled / in Add-Accept mode / in Invite-Accept
-- mode
checkExistingStems (ComponentDeck deckID) projectDB
checkExistingStems (deckKomponent deck) projectDB
-- Verify the specified capability gives relevant access
verifyCapability'
@ -204,7 +204,7 @@ deckAdd now deckID (Verse authorIdMsig body) add = do
-- Create a Stem record in DB
acceptID <- insertEmptyOutboxItem' (actorOutbox actor) now
insertStem projectDB addDB acceptID
insertStem (deckKomponent deck) projectDB addDB acceptID
-- Prepare forwarding Add to my followers
sieve <- do
@ -229,9 +229,8 @@ deckAdd now deckID (Verse authorIdMsig body) add = do
where
insertStem projectDB addDB acceptID = do
stemID <- insert $ Stem AP.RoleAdmin
insert_ $ StemIdentDeck stemID deckID
insertStem komponentID projectDB addDB acceptID = do
stemID <- insert $ Stem AP.RoleAdmin komponentID
case projectDB of
Left (Entity projectID _) ->
insert_ $ StemProjectLocal stemID projectID
@ -801,7 +800,7 @@ deckInvite
-> Verse
-> AP.Invite URIMode
-> ActE (Text, Act (), Next)
deckInvite = topicInvite deckResource ComponentDeck StemIdentDeck
deckInvite = componentInvite deckKomponent ComponentDeck
-- Meaning: An actor A is removing actor B from a resource
-- Behavior:

22
src/Vervis/Handler/Deck.hs
View file

@ -595,12 +595,11 @@ getDeckProjectsR deckHash = do
deck <- get404 deckID
actor <- getJust $ deckActor deck
stems <-
E.select $ E.from $ \ (ident `E.InnerJoin` stem `E.InnerJoin` accept `E.InnerJoin` deleg `E.InnerJoin` grant) -> do
E.select $ E.from $ \ (stem `E.InnerJoin` accept `E.InnerJoin` deleg `E.InnerJoin` grant) -> do
E.on $ deleg E.^. StemDelegateLocalGrant E.==. grant E.^. OutboxItemId
E.on $ accept E.^. StemComponentAcceptId E.==. deleg E.^. StemDelegateLocalStem
E.on $ stem E.^. StemId E.==. accept E.^. StemComponentAcceptStem
E.on $ ident E.^. StemIdentDeckStem E.==. stem E.^. StemId
E.where_ $ ident E.^. StemIdentDeckDeck E.==. E.val deckID
E.where_ $ stem E.^. StemHolder E.==. E.val (deckKomponent deck)
return
( stem
, grant E.^. OutboxItemPublished
@ -618,15 +617,14 @@ getDeckProjectsR deckHash = do
j
return (projectView, stemRole stem, time, stemID)
drafts <-
E.select $ E.from $ \ (ident `E.InnerJoin` stem `E.LeftOuterJoin` accept `E.LeftOuterJoin` deleg) -> do
E.select $ E.from $ \ (stem `E.LeftOuterJoin` accept `E.LeftOuterJoin` deleg) -> do
E.on $ accept E.?. StemComponentAcceptId E.==. deleg E.?. StemDelegateLocalStem
E.on $ E.just (stem E.^. StemId) E.==. accept E.?. StemComponentAcceptStem
E.on $ ident E.^. StemIdentDeckStem E.==. stem E.^. StemId
E.where_ $
ident E.^. StemIdentDeckDeck E.==. E.val deckID E.&&.
stem E.^. StemHolder E.==. E.val (deckKomponent deck) E.&&.
E.isNothing (deleg E.?. StemDelegateLocalId)
return stem
drafts' <- for drafts $ \ (Entity stemID (Stem role)) -> do
drafts' <- for drafts $ \ (Entity stemID (Stem role _)) -> do
(project, accept) <- do
project <- getStemProject stemID
accept <- isJust <$> getBy (UniqueStemComponentAccept stemID)
@ -736,9 +734,8 @@ postDeckApproveProjectR deckHash stemID = do
result <- runExceptT $ do
mpidOrU <- lift $ runDB $ runMaybeT $ do
deck <- MaybeT $ get deckID
_ <- MaybeT $ get stemID
StemIdentDeck _ d <- MaybeT $ getValBy $ UniqueStemIdentDeck stemID
guard $ deckID == d
Stem _ kompID <- MaybeT $ get stemID
guard $ kompID == deckKomponent deck
uAdd <- lift $ do
add <- getStemAdd stemID
@ -787,9 +784,8 @@ postDeckRemoveProjectR deckHash stemID = do
result <- runExceptT $ do
mpidOrU <- lift $ runDB $ runMaybeT $ do
deck <- MaybeT $ get deckID
_ <- MaybeT $ get stemID
StemIdentDeck _ d <- MaybeT $ getValBy $ UniqueStemIdentDeck stemID
guard $ deckID == d
Stem _ kompID <- MaybeT $ get stemID
guard $ kompID == deckKomponent deck
acceptID <- MaybeT $ getKeyBy $ UniqueStemComponentAccept stemID
_ <- MaybeT $ getBy $ UniqueStemDelegateLocal acceptID

51
src/Vervis/Migration.hs
View file

@ -3758,6 +3758,57 @@ changes hLocal ctx =
, removeEntity "ComponentLocalLoom"
-- 633
, removeEntity "ComponentLocalRepo"
-- 634
, addFieldRefRequired''
"Stem"
(do inboxID <- insert Inbox634
errboxID <- insert Inbox634
outboxID <- insert Outbox634
followerSetID <- insert FollowerSet634
actorID <- insert $ Actor634 "" "" defaultTime inboxID outboxID followerSetID Nothing errboxID
resourceID <- insert $ Resource634 actorID
insertEntity $ Komponent634 resourceID
)
(Just $ \ (Entity tempKomponentID (Komponent634 tempResourceID)) -> do
l <- selectKeysList [] []
for_ l $ \ k -> do
komponentID <- do
options <-
sequence
[ do
ma <- fmap stemIdentRepo634Repo <$> getValBy (UniqueStemIdentRepo634 k)
for ma $ fmap repo634Komponent . getJust
, do
ma <- fmap stemIdentDeck634Deck <$> getValBy (UniqueStemIdentDeck634 k)
for ma $ fmap deck634Komponent . getJust
, do
ma <- fmap stemIdentLoom634Loom <$> getValBy (UniqueStemIdentLoom634 k)
for ma $ fmap loom634Komponent . getJust
]
exactlyOneJust
options
"Found Stem without ident"
"Found Stem with multiple idents"
update k [Stem634Holder =. komponentID]
Resource634 tempActorID <- getJust tempResourceID
Actor634 _ _ _ inboxID outboxID followerSetID _ errboxID <- getJust tempActorID
delete tempKomponentID
delete tempResourceID
delete tempActorID
delete inboxID
delete errboxID
delete outboxID
delete followerSetID
)
"holder"
"Komponent"
-- 635
, removeEntity "StemIdentRepo"
-- 636
, removeEntity "StemIdentDeck"
-- 637
, removeEntity "StemIdentLoom"
]
migrateDB

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

@ -75,3 +75,6 @@ makeEntitiesMigration "627"
makeEntitiesMigration "630"
$(modelFile "migrations/630_2024-04-29_component_komponent.model")
makeEntitiesMigration "634"
$(modelFile "migrations/634_2024-04-29_stem_holder.model")

41
src/Vervis/Persist/Collab.hs
View file

@ -147,16 +147,8 @@ getPermitTopic permitID = do
getStemIdent :: MonadIO m => StemId -> ReaderT SqlBackend m (ComponentBy Key)
getStemIdent stemID = do
maybeRepo <- getValBy $ UniqueStemIdentRepo stemID
maybeDeck <- getValBy $ UniqueStemIdentDeck stemID
maybeLoom <- getValBy $ UniqueStemIdentLoom stemID
return $
case (maybeRepo, maybeDeck, maybeLoom) of
(Nothing, Nothing, Nothing) -> error "Found Stem without ident"
(Just r, Nothing, Nothing) -> ComponentRepo $ stemIdentRepoRepo r
(Nothing, Just d, Nothing) -> ComponentDeck $ stemIdentDeckDeck d
(Nothing, Nothing, Just l) -> ComponentLoom $ stemIdentLoomLoom l
_ -> error "Found Stem with multiple idents"
Stem _ komponentID <- getJust stemID
getLocalComponent komponentID
getStemProject
:: MonadIO m
@ -622,11 +614,11 @@ getDestAdd destID = do
getActivityIdent add
checkExistingStems
:: ComponentBy Key -> Either (Entity Project) RemoteActorId -> ActDBE ()
checkExistingStems componentByID projectDB = do
:: KomponentId -> Either (Entity Project) RemoteActorId -> ActDBE ()
checkExistingStems komponentID projectDB = do
-- Find existing Stem records I have for this project
stemIDs <- lift $ getExistingStems componentByID
stemIDs <- lift getExistingStems
-- Grab all the enabled ones, make sure none are enabled, and even if
-- any are enabled, make sure there's at most one (otherwise it's a
@ -655,35 +647,30 @@ checkExistingStems componentByID projectDB = do
where
getExistingStems' compID stemField compField (Left (Entity projectID _)) =
getExistingStems' kompID (Left (Entity projectID _)) =
fmap (map $ bimap E.unValue (Left . E.unValue)) $
E.select $ E.from $ \ (project `E.InnerJoin` ident) -> do
E.on $ project E.^. StemProjectLocalStem E.==. ident E.^. stemField
E.select $ E.from $ \ (stem `E.InnerJoin` project) -> do
E.on $ stem E.^. StemId E.==. project E.^. StemProjectLocalStem
E.where_ $
project E.^. StemProjectLocalProject E.==. E.val projectID E.&&.
ident E.^. compField E.==. E.val compID
stem E.^. StemHolder E.==. E.val kompID
return
( project E.^. StemProjectLocalStem
, project E.^. StemProjectLocalId
)
getExistingStems' compID stemField compField (Right remoteActorID) =
getExistingStems' kompID (Right remoteActorID) =
fmap (map $ bimap E.unValue (Right . E.unValue)) $
E.select $ E.from $ \ (project `E.InnerJoin` ident) -> do
E.on $ project E.^. StemProjectRemoteStem E.==. ident E.^. stemField
E.select $ E.from $ \ (stem `E.InnerJoin` project) -> do
E.on $ stem E.^. StemId E.==. project E.^. StemProjectRemoteStem
E.where_ $
project E.^. StemProjectRemoteProject E.==. E.val remoteActorID E.&&.
ident E.^. compField E.==. E.val compID
stem E.^. StemHolder E.==. E.val kompID
return
( project E.^. StemProjectRemoteStem
, project E.^. StemProjectRemoteId
)
getExistingStems (ComponentRepo repoID) =
getExistingStems' repoID StemIdentRepoStem StemIdentRepoRepo projectDB
getExistingStems (ComponentDeck deckID) =
getExistingStems' deckID StemIdentDeckStem StemIdentDeckDeck projectDB
getExistingStems (ComponentLoom loomID) =
getExistingStems' loomID StemIdentLoomStem StemIdentLoomLoom projectDB
getExistingStems = getExistingStems' komponentID projectDB
tryStemEnabled (Left localID) =
const () <$> MaybeT (getBy $ UniqueStemProjectGrantLocalProject localID)

23
th/models
View file

@ -1078,27 +1078,8 @@ ComponentGather
------------------------------------------------------------------------------
Stem
role Role
-------------------------------- Stem identity -------------------------------
StemIdentRepo
stem StemId
repo RepoId
UniqueStemIdentRepo stem
StemIdentDeck
stem StemId
deck DeckId
UniqueStemIdentDeck stem
StemIdentLoom
stem StemId
loom LoomId
UniqueStemIdentLoom stem
role Role
holder KomponentId
-------------------------------- Stem project --------------------------------