Merge pull request #5684 from unisonweb/25-04-03-merge-db

bugfix: track merge branch parents in database to fix nameless dependency bug

Author: aryairani

codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs

@@ -134,6 +134,14 @@ module U.Codebase.Sqlite.Queries
     expectProjectBranchHead,
     setMostRecentBranch,
     loadMostRecentBranch,
+    loadProjectBranchParent,
+    loadMergeBranchParents,
+    insertMergeBranchLocal,
+    insertMergeBranchRemote,
+    insertMergeBranchLooseCode,
+    loadNamespaceUniqueTypeGuids,
+    existsAnyNamespaceUniqueTypeGuidForNamespace,
+    insertNamespaceUniqueTypeGuid,
 
     -- ** remote projects
     loadRemoteProject,
@@ -257,6 +265,7 @@ module U.Codebase.Sqlite.Queries
     addProjectBranchReflogTable,
     addProjectBranchCausalHashIdColumn,
     addProjectBranchLastAccessedColumn,
+    addMergeBranchTables,
 
     -- ** schema version
     currentSchemaVersion,
@@ -303,11 +312,13 @@ import Control.Monad.Writer qualified as Writer
 import Data.Aeson qualified as Aeson
 import Data.Aeson.Text qualified as Aeson
 import Data.Bitraversable (bitraverse)
+import Data.ByteString.Lazy (LazyByteString)
 import Data.Bytes.Put (runPutS)
 import Data.Foldable qualified as Foldable
 import Data.List qualified as List
 import Data.List.Extra qualified as List
 import Data.List.NonEmpty (NonEmpty)
+import Data.List.NonEmpty qualified as List.NonEmpty
 import Data.List.NonEmpty qualified as Nel
 import Data.List.NonEmpty qualified as NonEmpty
 import Data.Map qualified as Map
@@ -401,6 +412,8 @@ import Unison.Hash qualified as Hash
 import Unison.Hash32 (Hash32)
 import Unison.Hash32 qualified as Hash32
 import Unison.Hash32.Orphans.Sqlite ()
+import Unison.Name (Name)
+import Unison.Name qualified as Name
 import Unison.NameSegment.Internal (NameSegment (NameSegment))
 import Unison.NameSegment.Internal qualified as NameSegment
 import Unison.Prelude
@@ -421,7 +434,7 @@ type TextPathSegments = [Text]
 -- * main squeeze
 
 currentSchemaVersion :: SchemaVersion
-currentSchemaVersion = 18
+currentSchemaVersion = 19
 
 runCreateSql :: Transaction ()
 runCreateSql =
@@ -491,6 +504,10 @@ addProjectBranchLastAccessedColumn :: Transaction ()
 addProjectBranchLastAccessedColumn =
   executeStatements $(embedProjectStringFile "sql/015-add-project-branch-last-accessed.sql")
 
+addMergeBranchTables :: Transaction ()
+addMergeBranchTables =
+  executeStatements $(embedProjectStringFile "sql/016-add-merge-branch-tables.sql")
+
 schemaVersion :: Transaction SchemaVersion
 schemaVersion =
   queryOneCol
@@ -4328,6 +4345,192 @@ loadMostRecentBranch projectId =
         project_id = :projectId
     |]
 
+loadProjectBranchParent :: ProjectId -> ProjectBranchId -> Transaction (Maybe ProjectBranchId)
+loadProjectBranchParent projectId projectBranchId =
+  queryMaybeCol
+    [sql|
+      SELECT parent_branch_id
+      FROM project_branch_parent
+      WHERE project_id = :projectId
+        AND branch_id = :projectBranchId
+    |]
+
+loadMergeBranchParents ::
+  ProjectId ->
+  ProjectBranchId ->
+  Transaction
+    ( Maybe
+        ( Maybe ProjectBranchId,
+          CausalHashId,
+          Maybe ProjectBranchId,
+          CausalHashId
+        )
+    )
+loadMergeBranchParents projectId branchId =
+  queryMaybeRow
+    [sql|
+      SELECT local_source_branch_id, source_causal_hash_id, target_branch_id, target_causal_hash_id
+      FROM merge_branch
+      WHERE project_id = :projectId
+        AND branch_id = :branchId
+    |]
+
+insertMergeBranchLocal ::
+  ProjectId ->
+  ProjectBranchId ->
+  (ProjectBranchId, CausalHashId) ->
+  (ProjectBranchId, CausalHashId) ->
+  Transaction ()
+insertMergeBranchLocal
+  projectId
+  mergeBranchId
+  (sourceBranchId, sourceCausalHashId)
+  (targetBranchId, targetCausalHashId) =
+    execute
+      [sql|
+        INSERT INTO merge_branch (
+          project_id,
+          branch_id,
+          local_source_project_id,
+          local_source_branch_id,
+          source_causal_hash_id,
+          target_project_id,
+          target_branch_id,
+          target_causal_hash_id
+        )
+        VALUES (
+          :projectId,
+          :mergeBranchId,
+          :projectId,
+          :sourceBranchId,
+          :sourceCausalHashId,
+          :projectId,
+          :targetBranchId,
+          :targetCausalHashId
+        )
+      |]
+
+insertMergeBranchRemote ::
+  ProjectId ->
+  ProjectBranchId ->
+  (RemoteProjectId, RemoteProjectBranchId, URI, CausalHashId) ->
+  (ProjectBranchId, CausalHashId) ->
+  Transaction ()
+insertMergeBranchRemote
+  projectId
+  mergeBranchId
+  (sourceProjectId, sourceBranchId, sourceHost, sourceCausalHashId)
+  (targetBranchId, targetCausalHashId) =
+    execute
+      [sql|
+        INSERT INTO merge_branch (
+          project_id,
+          branch_id,
+          remote_source_project_id,
+          remote_source_branch_id,
+          remote_source_host,
+          source_causal_hash_id,
+          target_project_id,
+          target_branch_id,
+          target_causal_hash_id
+        )
+        VALUES (
+          :projectId,
+          :mergeBranchId,
+          :sourceProjectId,
+          :sourceBranchId,
+          :sourceHost,
+          :sourceCausalHashId,
+          :projectId,
+          :targetBranchId,
+          :targetCausalHashId
+        )
+      |]
+
+insertMergeBranchLooseCode ::
+  ProjectId ->
+  ProjectBranchId ->
+  CausalHashId ->
+  (ProjectBranchId, CausalHashId) ->
+  Transaction ()
+insertMergeBranchLooseCode
+  projectId
+  mergeBranchId
+  sourceCausalHashId
+  (targetBranchId, targetCausalHashId) =
+    execute
+      [sql|
+        INSERT INTO merge_branch (
+          project_id,
+          branch_id,
+          source_causal_hash_id,
+          target_project_id,
+          target_branch_id,
+          target_causal_hash_id
+        )
+        VALUES (
+          :projectId,
+          :mergeBranchId,
+          :sourceCausalHashId,
+          :projectId,
+          :targetBranchId,
+          :targetCausalHashId
+        )
+      |]
+
+loadNamespaceUniqueTypeGuids :: BranchHashId -> Transaction (Map Name Text)
+loadNamespaceUniqueTypeGuids namespaceHashId = do
+  rows <-
+    queryListRow
+      [sql|
+        SELECT type_name, type_guid
+        FROM namespace_unique_type_guid
+        WHERE namespace_hash_id = :namespaceHashId
+      |]
+
+  let f :: ByteString -> Name
+      f bytes =
+        case Aeson.decodeStrict @[Text] bytes of
+          Just (segment : segments) ->
+            Name.fromSegments (NameSegment segment NonEmpty.:| map NameSegment segments)
+          _ ->
+            error $
+              reportBug
+                "E955495"
+                ( "busted name in namespace_unique_type_guid (namespace hash id = "
+                    ++ show namespaceHashId
+                    ++ ")"
+                )
+
+  pure (Map.fromList (over (Lens.mapped . Lens._1) f rows))
+
+existsAnyNamespaceUniqueTypeGuidForNamespace :: BranchHashId -> Transaction Bool
+existsAnyNamespaceUniqueTypeGuidForNamespace namespaceHashId =
+  queryOneCol
+    [sql|
+      SELECT EXISTS (
+        SELECT 1
+        FROM namespace_unique_type_guid
+        WHERE namespace_hash_id = :namespaceHashId
+      )
+    |]
+
+insertNamespaceUniqueTypeGuid :: BranchHashId -> Name -> Text -> Transaction ()
+insertNamespaceUniqueTypeGuid namespaceHashId typeName typeGuid =
+  execute
+    [sql|
+      INSERT INTO namespace_unique_type_guid (namespace_hash_id, type_name, type_guid)
+      VALUES (:namespaceHashId, :typeNameJson, :typeGuid)
+    |]
+  where
+    typeNameJson :: LazyByteString
+    typeNameJson =
+      typeName
+        & Name.segments
+        & List.NonEmpty.toList
+        & map NameSegment.toUnescapedText
+        & Aeson.encode
+
 -- | Searches for all names within the given name lookup which contain the provided list of segments
 -- in order.
 -- Search is case insensitive.

codebase2/codebase-sqlite/sql/016-add-merge-branch-tables.sql

@@ -0,0 +1,40 @@
+create table merge_branch (
+  project_id uuid not null,
+  branch_id uuid not null,
+  local_source_project_id uuid,
+  local_source_branch_id uuid,
+  remote_source_project_id uuid,
+  remote_source_branch_id uuid,
+  remote_source_host text,
+  source_causal_hash_id integer not null references hash (id) on delete cascade,
+  target_project_id uuid,
+  target_branch_id uuid,
+  target_causal_hash_id integer not null references hash (id) on delete cascade,
+  primary key (project_id, branch_id),
+  foreign key (project_id, branch_id)
+    references project_branch (project_id, branch_id)
+    on delete cascade,
+  foreign key (local_source_project_id, local_source_branch_id)
+    references project_branch (project_id, branch_id)
+    on delete set null,
+  foreign key (remote_source_project_id, remote_source_branch_id, remote_source_host)
+    references remote_project_branch (project_id, branch_id, host)
+    on delete set null,
+  foreign key (target_project_id, target_branch_id)
+    references project_branch (project_id, branch_id)
+    on delete set null,
+  check (
+    local_source_branch_id is null or
+    remote_source_branch_id is null
+  ),
+  check (
+    (project_id = local_source_project_id or local_source_project_id is null) and
+    (project_id = target_project_id or target_project_id is null)
+  )
+);
+
+create table namespace_unique_type_guid (
+  namespace_hash_id integer not null references hash (id) on delete cascade,
+  type_name jsonb not null,
+  type_guid text not null
+);

codebase2/codebase-sqlite/unison-codebase-sqlite.cabal

@@ -1,6 +1,6 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.37.0.
+-- This file has been generated from package.yaml by hpack version 0.36.0.
 --
 -- see: https://github.com/sol/hpack
 
@@ -25,6 +25,7 @@ extra-source-files:
     sql/013-add-project-branch-reflog-table.sql
     sql/014-add-project-branch-causal-hash-id.sql
     sql/015-add-project-branch-last-accessed.sql
+    sql/016-add-merge-branch-tables.sql
     sql/create.sql
 
 source-repository head

parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs

@@ -85,7 +85,8 @@ migrations regionVar getDeclType termBuffer declBuffer rootCodebasePath =
       sqlMigration 15 Q.addSquashResultTableIfNotExists,
       sqlMigration 16 Q.cdToProjectRoot,
       (17 {- This migration takes a raw sqlite connection -}, \conn -> migrateSchema16To17 conn),
-      sqlMigration 18 Q.addProjectBranchLastAccessedColumn
+      sqlMigration 18 Q.addProjectBranchLastAccessedColumn,
+      sqlMigration 19 Q.addMergeBranchTables
     ]
   where
     runT :: Sqlite.Transaction () -> Sqlite.Connection -> IO ()

parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs

@@ -98,6 +98,7 @@ createSchema = do
   Q.addProjectBranchReflogTable
   Q.addProjectBranchCausalHashIdColumn
   Q.addProjectBranchLastAccessedColumn
+  Q.addMergeBranchTables
   (_, emptyCausalHashId) <- emptyCausalHash
   (_, ProjectBranch {projectId, branchId}) <- insertProjectAndBranch scratchProjectName scratchBranchName emptyCausalHashId
   Q.setCurrentProjectPath projectId branchId []

unison-cli/src/Unison/Cli/MergeTypes.hs

@@ -7,13 +7,16 @@ module Unison.Cli.MergeTypes
   )
 where
 
+import U.Codebase.Sqlite.Project (Project)
+import U.Codebase.Sqlite.ProjectBranch (ProjectBranch)
+import Unison.Cli.Share.Projects.Types (RemoteProjectBranch)
 import Unison.Codebase.Editor.RemoteRepo (ReadShareLooseCode)
 import Unison.Project (ProjectAndBranch, ProjectBranchName, ProjectName)
 
 -- | What are we merging in?
 data MergeSource
-  = MergeSource'LocalProjectBranch !(ProjectAndBranch ProjectName ProjectBranchName)
-  | MergeSource'RemoteProjectBranch !(ProjectAndBranch ProjectName ProjectBranchName)
+  = MergeSource'LocalProjectBranch !(ProjectAndBranch Project ProjectBranch)
+  | MergeSource'RemoteProjectBranch !RemoteProjectBranch
   | MergeSource'RemoteLooseCode !ReadShareLooseCode
 
 type MergeTarget =

unison-cli/src/Unison/Cli/Pretty.hs

@@ -205,8 +205,10 @@ prettyHash32 = prettyBase32Hex# . Hash32.toBase32Hex
 
 prettyMergeSource :: MergeSource -> Pretty
 prettyMergeSource = \case
-  MergeSource'LocalProjectBranch branch -> prettyProjectAndBranchName branch
-  MergeSource'RemoteProjectBranch branch -> "remote " <> prettyProjectAndBranchName branch
+  MergeSource'LocalProjectBranch branch ->
+    prettyProjectAndBranchName (ProjectAndBranch branch.project.name branch.branch.name)
+  MergeSource'RemoteProjectBranch branch ->
+    "remote " <> prettyProjectAndBranchName (ProjectAndBranch branch.projectName branch.branchName)
   MergeSource'RemoteLooseCode info -> prettyReadRemoteNamespace (ReadShare'LooseCode info)
 
 prettyMergeSourceOrTarget :: MergeSourceOrTarget -> Pretty