DB: Remove StemIdent* tables, use Komponent instead

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

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
+componentInvite
-    :: forall topic ct si.
+    :: forall topic.
-       ( PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic
+       (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
-       , PersistRecordBackend si SqlBackend
+    => (topic -> KomponentId)
-       )
-    => (topic -> ResourceId)
     -> (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
+    insertStem komponentID projectDB inviteDB = do
-        stemID <- insert $ Stem AP.RoleAdmin
+        stemID <- insert $ Stem AP.RoleAdmin komponentID
-        insert_ $ stemIdentCtor stemID topicKey
         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

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
+    insertStem komponentID projectDB addDB acceptID = do
-        stemID <- insert $ Stem AP.RoleAdmin
+        stemID <- insert $ Stem AP.RoleAdmin komponentID
-        insert_ $ StemIdentDeck stemID deckID
         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:

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_ $ stem E.^. StemHolder E.==. E.val (deckKomponent deck)
-                E.where_ $ ident E.^. StemIdentDeckDeck E.==. E.val deckID
                 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
+            Stem _ kompID <- MaybeT $ get stemID
-            StemIdentDeck _ d <- MaybeT $ getValBy $ UniqueStemIdentDeck stemID
+            guard $ kompID == deckKomponent deck
-            guard $ deckID == d
 
             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
+            Stem _ kompID <- MaybeT $ get stemID
-            StemIdentDeck _ d <- MaybeT $ getValBy $ UniqueStemIdentDeck stemID
+            guard $ kompID == deckKomponent deck
-            guard $ deckID == d
             acceptID <- MaybeT $ getKeyBy $ UniqueStemComponentAccept stemID
             _ <- MaybeT $ getBy $ UniqueStemDelegateLocal acceptID
 

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

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

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
+    Stem _ komponentID <- getJust stemID
-    maybeDeck <- getValBy $ UniqueStemIdentDeck stemID
+    getLocalComponent komponentID
-    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"
 
 getStemProject
     :: MonadIO m
@@ -622,11 +614,11 @@ getDestAdd destID = do
     getActivityIdent add
 
 checkExistingStems
-    :: ComponentBy Key -> Either (Entity Project) RemoteActorId -> ActDBE ()
+    :: KomponentId -> Either (Entity Project) RemoteActorId -> ActDBE ()
-checkExistingStems componentByID projectDB = do
+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.select $ E.from $ \ (stem `E.InnerJoin` project) -> do
-            E.on $ project E.^. StemProjectLocalStem E.==. ident E.^. stemField
+            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.select $ E.from $ \ (stem `E.InnerJoin` project) -> do
-            E.on $ project E.^. StemProjectRemoteStem E.==. ident E.^. stemField
+            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 = getExistingStems' komponentID projectDB
-        getExistingStems' repoID StemIdentRepoStem StemIdentRepoRepo projectDB
-    getExistingStems (ComponentDeck deckID) =
-        getExistingStems' deckID StemIdentDeckStem StemIdentDeckDeck projectDB
-    getExistingStems (ComponentLoom loomID) =
-        getExistingStems' loomID StemIdentLoomStem StemIdentLoomLoom projectDB
 
     tryStemEnabled (Left localID) =
         const () <$> MaybeT (getBy $ UniqueStemProjectGrantLocalProject localID)

th/models

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