From 4b6e95b2e89ab90ce35f10e5eb0049517cd78b1c Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Tue, 30 Apr 2024 00:32:30 +0300 Subject: [PATCH] DB: Remove StemIdent* tables, use Komponent instead --- migrations/634_2024-04-29_stem_holder.model | 91 +++++++++++++++++++++ src/Vervis/Actor/Common.hs | 29 +++---- src/Vervis/Actor/Deck.hs | 11 ++- src/Vervis/Handler/Deck.hs | 22 ++--- src/Vervis/Migration.hs | 51 ++++++++++++ src/Vervis/Migration/Model2024.hs | 3 + src/Vervis/Persist/Collab.hs | 41 ++++------ th/models | 23 +----- 8 files changed, 188 insertions(+), 83 deletions(-) create mode 100644 migrations/634_2024-04-29_stem_holder.model diff --git a/migrations/634_2024-04-29_stem_holder.model b/migrations/634_2024-04-29_stem_holder.model new file mode 100644 index 0000000..51229b7 --- /dev/null +++ b/migrations/634_2024-04-29_stem_holder.model @@ -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 diff --git a/src/Vervis/Actor/Common.hs b/src/Vervis/Actor/Common.hs index c568051..bbcf890 100644 --- a/src/Vervis/Actor/Common.hs +++ b/src/Vervis/Actor/Common.hs @@ -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 diff --git a/src/Vervis/Actor/Deck.hs b/src/Vervis/Actor/Deck.hs index af3358e..c59913b 100644 --- a/src/Vervis/Actor/Deck.hs +++ b/src/Vervis/Actor/Deck.hs @@ -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: diff --git a/src/Vervis/Handler/Deck.hs b/src/Vervis/Handler/Deck.hs index d534afe..fff2952 100644 --- a/src/Vervis/Handler/Deck.hs +++ b/src/Vervis/Handler/Deck.hs @@ -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 diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index c9090a3..b537ab7 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -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 diff --git a/src/Vervis/Migration/Model2024.hs b/src/Vervis/Migration/Model2024.hs index 7fb1598..e9757e6 100644 --- a/src/Vervis/Migration/Model2024.hs +++ b/src/Vervis/Migration/Model2024.hs @@ -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") diff --git a/src/Vervis/Persist/Collab.hs b/src/Vervis/Persist/Collab.hs index 0f33ebc..d03d329 100644 --- a/src/Vervis/Persist/Collab.hs +++ b/src/Vervis/Persist/Collab.hs @@ -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) diff --git a/th/models b/th/models index c0db222..29c3f88 100644 --- a/th/models +++ b/th/models @@ -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 --------------------------------