{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}

module Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema16To17 (migrateSchema16To17) where

import Control.Lens
import Data.Aeson qualified as Aeson
import Data.Map qualified as Map
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text
import Data.UUID (UUID)
import Data.UUID qualified as UUID
import U.Codebase.Branch.Type qualified as V2Branch
import U.Codebase.Causal qualified as V2Causal
import U.Codebase.Sqlite.DbId (CausalHashId, ProjectBranchId (..), ProjectId (..))
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
import U.Codebase.Sqlite.Queries qualified as Q
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Branch qualified as Branch
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.SqliteCodebase.Branch.Cache qualified as BranchCache
import Unison.Codebase.SqliteCodebase.Operations qualified as CodebaseOps
import Unison.Codebase.SqliteCodebase.Operations qualified as Ops
import Unison.Core.Project (ProjectBranchName (UnsafeProjectBranchName), ProjectName (UnsafeProjectName))
import Unison.Debug qualified as Debug
import Unison.NameSegment (NameSegment)
import Unison.NameSegment.Internal (NameSegment (NameSegment))
import Unison.NameSegment.Internal qualified as NameSegment
import Unison.Prelude
import Unison.Sqlite qualified as Sqlite
import Unison.Sqlite.Connection qualified as Connection
import Unison.Syntax.NameSegment qualified as NameSegment
import UnliftIO qualified
import UnliftIO qualified as UnsafeIO

-- | This migration converts the codebase from having all projects in a single codebase root to having separate causal
-- roots for each project branch.
-- It:
--
-- * Adds the new project reflog table
-- * Adds the project-branch head as a causal-hash-id column on the project-branch table, and populates it from all the projects in the project root.
-- * Makes a new legacy project from the existing root branch (minus .__projects)
-- * Adds a new scratch/main project
-- * Adds a currentProjectPath table to replace the most-recent-path functionality.
--
-- It requires a Connection argument rather than working inside a Transaction because it needs to temporarily disable
-- foreign key checking, and the foreign_key pragma cannot be set within a transaction.
migrateSchema16To17 :: Sqlite.Connection -> IO ()
migrateSchema16To17 :: Connection -> IO ()
migrateSchema16To17 Connection
conn = Transaction () -> IO ()
forall r. Transaction r -> IO r
withDisabledForeignKeys (Transaction () -> IO ()) -> Transaction () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  SchemaVersion -> Transaction ()
Q.expectSchemaVersion SchemaVersion
16
  Transaction ()
Q.addProjectBranchReflogTable
  DebugFlag -> [Char] -> Transaction ()
forall (m :: * -> *). Monad m => DebugFlag -> [Char] -> m ()
Debug.debugLogM DebugFlag
Debug.Migration [Char]
"Adding causal hashes to project branches table."
  Transaction ()
addCausalHashesToProjectBranches
  DebugFlag -> [Char] -> Transaction ()
forall (m :: * -> *). Monad m => DebugFlag -> [Char] -> m ()
Debug.debugLogM DebugFlag
Debug.Migration [Char]
"Making legacy project from loose code."
  Transaction ()
makeLegacyProjectFromLooseCode
  DebugFlag -> [Char] -> Transaction ()
forall (m :: * -> *). Monad m => DebugFlag -> [Char] -> m ()
Debug.debugLogM DebugFlag
Debug.Migration [Char]
"Adding scratch project"
  ProjectBranch
scratchMain <-
    ProjectName
-> ProjectBranchName -> Transaction (Maybe ProjectBranch)
Q.loadProjectBranchByNames ProjectName
scratchProjectName ProjectBranchName
scratchBranchName Transaction (Maybe ProjectBranch)
-> (Maybe ProjectBranch -> Transaction ProjectBranch)
-> Transaction ProjectBranch
forall a b. Transaction a -> (a -> Transaction b) -> Transaction b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just ProjectBranch
pb -> ProjectBranch -> Transaction ProjectBranch
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProjectBranch
pb
      Maybe ProjectBranch
Nothing -> do
        (CausalHash
_, CausalHashId
emptyCausalHashId) <- Transaction (CausalHash, CausalHashId)
Codebase.emptyCausalHash
        (Project
_proj, ProjectBranch
pb) <- ProjectName
-> ProjectBranchName
-> CausalHashId
-> Transaction (Project, ProjectBranch)
Ops.insertProjectAndBranch ProjectName
scratchProjectName ProjectBranchName
scratchBranchName CausalHashId
emptyCausalHashId
        ProjectBranch -> Transaction ProjectBranch
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProjectBranch
pb

  -- Try to set the recent project branch to what it was, default back to scratch if it doesn't exist or the user is in
  -- loose code.
  Maybe (ProjectId, ProjectBranchId)
mayRecentProjectBranch <- MaybeT Transaction (ProjectId, ProjectBranchId)
-> Transaction (Maybe (ProjectId, ProjectBranchId))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT Transaction (ProjectId, ProjectBranchId)
 -> Transaction (Maybe (ProjectId, ProjectBranchId)))
-> MaybeT Transaction (ProjectId, ProjectBranchId)
-> Transaction (Maybe (ProjectId, ProjectBranchId))
forall a b. (a -> b) -> a -> b
$ do
    (ProjectId
projectId, ProjectBranchId
branchId) <- Transaction (Maybe (ProjectId, ProjectBranchId))
-> MaybeT Transaction (ProjectId, ProjectBranchId)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT Transaction (Maybe (ProjectId, ProjectBranchId))
getMostRecentProjectBranchIds
    -- Make sure the project-branch still exists.
    ProjectBranch
_projBranch <- Transaction (Maybe ProjectBranch)
-> MaybeT Transaction ProjectBranch
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Transaction (Maybe ProjectBranch)
 -> MaybeT Transaction ProjectBranch)
-> Transaction (Maybe ProjectBranch)
-> MaybeT Transaction ProjectBranch
forall a b. (a -> b) -> a -> b
$ ProjectId -> ProjectBranchId -> Transaction (Maybe ProjectBranch)
Q.loadProjectBranch ProjectId
projectId ProjectBranchId
branchId
    pure (ProjectId
projectId, ProjectBranchId
branchId)

  DebugFlag -> [Char] -> Transaction ()
forall (m :: * -> *). Monad m => DebugFlag -> [Char] -> m ()
Debug.debugLogM DebugFlag
Debug.Migration [Char]
"Adding current project path table"
  Transaction ()
Q.addCurrentProjectPathTable
  DebugFlag -> [Char] -> Transaction ()
forall (m :: * -> *). Monad m => DebugFlag -> [Char] -> m ()
Debug.debugLogM DebugFlag
Debug.Migration [Char]
"Setting current project path to scratch project"

  case Maybe (ProjectId, ProjectBranchId)
mayRecentProjectBranch of
    Just (ProjectId
projectId, ProjectBranchId
branchId) ->
      ProjectId -> ProjectBranchId -> [NameSegment] -> Transaction ()
Q.setCurrentProjectPath ProjectId
projectId ProjectBranchId
branchId []
    Maybe (ProjectId, ProjectBranchId)
Nothing -> ProjectId -> ProjectBranchId -> [NameSegment] -> Transaction ()
Q.setCurrentProjectPath ProjectBranch
scratchMain.projectId ProjectBranch
scratchMain.branchId []
  DebugFlag -> [Char] -> Transaction ()
forall (m :: * -> *). Monad m => DebugFlag -> [Char] -> m ()
Debug.debugLogM DebugFlag
Debug.Migration [Char]
"Done migrating to version 17"
  SchemaVersion -> Transaction ()
Q.setSchemaVersion SchemaVersion
17
  where
    scratchProjectName :: ProjectName
scratchProjectName = Text -> ProjectName
UnsafeProjectName Text
"scratch"
    scratchBranchName :: ProjectBranchName
scratchBranchName = Text -> ProjectBranchName
UnsafeProjectBranchName Text
"main"
    withDisabledForeignKeys :: Sqlite.Transaction r -> IO r
    withDisabledForeignKeys :: forall r. Transaction r -> IO r
withDisabledForeignKeys Transaction r
m = do
      let disable :: IO ()
disable = HasCallStack => Connection -> Sql -> IO ()
Connection -> Sql -> IO ()
Connection.execute Connection
conn [Sqlite.sql| PRAGMA foreign_keys=OFF |]
      let enable :: IO ()
enable = HasCallStack => Connection -> Sql -> IO ()
Connection -> Sql -> IO ()
Connection.execute Connection
conn [Sqlite.sql| PRAGMA foreign_keys=ON |]
      let action :: IO r
action = Connection -> ((forall r. Transaction r -> IO r) -> IO r) -> IO r
forall (m :: * -> *) a.
(HasCallStack, MonadUnliftIO m) =>
Connection -> ((forall x. Transaction x -> m x) -> m a) -> m a
Sqlite.runWriteTransaction Connection
conn \forall r. Transaction r -> IO r
run -> Transaction r -> IO r
forall r. Transaction r -> IO r
run (Transaction r -> IO r) -> Transaction r -> IO r
forall a b. (a -> b) -> a -> b
$ Transaction r
m
      IO () -> (() -> IO ()) -> (() -> IO r) -> IO r
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
UnsafeIO.bracket IO ()
disable (IO () -> () -> IO ()
forall a b. a -> b -> a
const IO ()
enable) (IO r -> () -> IO r
forall a b. a -> b -> a
const IO r
action)

data ForeignKeyFailureException
  = ForeignKeyFailureException
      -- We leave the data as raw as possible to ensure we can display it properly rather than get decoding errors while
      -- trying to display some other error.
      [[Sqlite.SQLData]]
  | MissingRootBranch
  deriving stock (Int -> ForeignKeyFailureException -> ShowS
[ForeignKeyFailureException] -> ShowS
ForeignKeyFailureException -> [Char]
(Int -> ForeignKeyFailureException -> ShowS)
-> (ForeignKeyFailureException -> [Char])
-> ([ForeignKeyFailureException] -> ShowS)
-> Show ForeignKeyFailureException
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ForeignKeyFailureException -> ShowS
showsPrec :: Int -> ForeignKeyFailureException -> ShowS
$cshow :: ForeignKeyFailureException -> [Char]
show :: ForeignKeyFailureException -> [Char]
$cshowList :: [ForeignKeyFailureException] -> ShowS
showList :: [ForeignKeyFailureException] -> ShowS
Show)
  deriving anyclass (Show ForeignKeyFailureException
Typeable ForeignKeyFailureException
(Typeable ForeignKeyFailureException,
 Show ForeignKeyFailureException) =>
(ForeignKeyFailureException -> SomeException)
-> (SomeException -> Maybe ForeignKeyFailureException)
-> (ForeignKeyFailureException -> [Char])
-> Exception ForeignKeyFailureException
SomeException -> Maybe ForeignKeyFailureException
ForeignKeyFailureException -> [Char]
ForeignKeyFailureException -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> [Char]) -> Exception e
$ctoException :: ForeignKeyFailureException -> SomeException
toException :: ForeignKeyFailureException -> SomeException
$cfromException :: SomeException -> Maybe ForeignKeyFailureException
fromException :: SomeException -> Maybe ForeignKeyFailureException
$cdisplayException :: ForeignKeyFailureException -> [Char]
displayException :: ForeignKeyFailureException -> [Char]
Exception)

addCausalHashesToProjectBranches :: Sqlite.Transaction ()
addCausalHashesToProjectBranches :: Transaction ()
addCausalHashesToProjectBranches = do
  DebugFlag -> [Char] -> Transaction ()
forall (m :: * -> *). Monad m => DebugFlag -> [Char] -> m ()
Debug.debugLogM DebugFlag
Debug.Migration [Char]
"Creating new_project_branch"
  -- Create the new version of the project_branch table with the causal_hash_id column.
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
Sqlite.execute
    [Sqlite.sql|
CREATE TABLE new_project_branch (
  project_id uuid NOT NULL REFERENCES project (id),
  branch_id uuid NOT NULL,
  name text NOT NULL,
  causal_hash_id integer NOT NULL REFERENCES causal(self_hash_id),

  primary key (project_id, branch_id),

  unique (project_id, name)
)
without rowid;
|]
  CausalHashId
rootCausalHashId <- Transaction CausalHashId
expectNamespaceRoot
  CausalHash
rootCh <- CausalHashId -> Transaction CausalHash
Q.expectCausalHash CausalHashId
rootCausalHashId
  Branch Transaction
projectsRoot <- CausalHash -> Path -> Transaction (CausalBranch Transaction)
Codebase.getShallowCausalAtPathFromRootHash CausalHash
rootCh (NameSegment -> Path
Path.singleton (NameSegment -> Path) -> NameSegment -> Path
forall a b. (a -> b) -> a -> b
$ NameSegment
projectsNameSegment) Transaction (CausalBranch Transaction)
-> (CausalBranch Transaction -> Transaction (Branch Transaction))
-> Transaction (Branch Transaction)
forall a b. Transaction a -> (a -> Transaction b) -> Transaction b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CausalBranch Transaction -> Transaction (Branch Transaction)
forall (m :: * -> *) hc he pe e. Causal m hc he pe e -> m e
V2Causal.value
  Map NameSegment (CausalBranch Transaction)
-> (NameSegment -> CausalBranch Transaction -> Transaction ())
-> Transaction ()
forall i (t :: * -> *) (f :: * -> *) a b.
(FoldableWithIndex i t, Applicative f) =>
t a -> (i -> a -> f b) -> f ()
ifor_ (Branch Transaction -> Map NameSegment (CausalBranch Transaction)
forall (m :: * -> *). Branch m -> Map NameSegment (CausalBranch m)
V2Branch.children Branch Transaction
projectsRoot) \NameSegment
projectIdNS CausalBranch Transaction
projectsCausal -> do
    ProjectId
projectId <- case NameSegment
projectIdNS of
      UUIDNameSegment UUID
projectIdUUID -> ProjectId -> Transaction ProjectId
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProjectId -> Transaction ProjectId)
-> ProjectId -> Transaction ProjectId
forall a b. (a -> b) -> a -> b
$ UUID -> ProjectId
ProjectId UUID
projectIdUUID
      NameSegment
_ -> [Char] -> Transaction ProjectId
forall a. HasCallStack => [Char] -> a
error ([Char] -> Transaction ProjectId)
-> [Char] -> Transaction ProjectId
forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid Project Id NameSegment:" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> NameSegment -> [Char]
forall a. Show a => a -> [Char]
show NameSegment
projectIdNS
    DebugFlag -> [Char] -> ProjectId -> Transaction ()
forall a (m :: * -> *).
(Show a, Monad m) =>
DebugFlag -> [Char] -> a -> m ()
Debug.debugM DebugFlag
Debug.Migration [Char]
"Migrating project" ProjectId
projectId
    Branch Transaction
projectsBranch <- CausalBranch Transaction -> Transaction (Branch Transaction)
forall (m :: * -> *) hc he pe e. Causal m hc he pe e -> m e
V2Causal.value CausalBranch Transaction
projectsCausal
    case (NameSegment
-> Map NameSegment (CausalBranch Transaction)
-> Maybe (CausalBranch Transaction)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NameSegment
branchesNameSegment (Map NameSegment (CausalBranch Transaction)
 -> Maybe (CausalBranch Transaction))
-> Map NameSegment (CausalBranch Transaction)
-> Maybe (CausalBranch Transaction)
forall a b. (a -> b) -> a -> b
$ Branch Transaction -> Map NameSegment (CausalBranch Transaction)
forall (m :: * -> *). Branch m -> Map NameSegment (CausalBranch m)
V2Branch.children Branch Transaction
projectsBranch) of
      Maybe (CausalBranch Transaction)
Nothing -> () -> Transaction ()
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just CausalBranch Transaction
branchesCausal -> do
        Branch Transaction
branchesBranch <- CausalBranch Transaction -> Transaction (Branch Transaction)
forall (m :: * -> *) hc he pe e. Causal m hc he pe e -> m e
V2Causal.value CausalBranch Transaction
branchesCausal
        Map NameSegment (CausalBranch Transaction)
-> (NameSegment -> CausalBranch Transaction -> Transaction ())
-> Transaction ()
forall i (t :: * -> *) (f :: * -> *) a b.
(FoldableWithIndex i t, Applicative f) =>
t a -> (i -> a -> f b) -> f ()
ifor_ (Branch Transaction -> Map NameSegment (CausalBranch Transaction)
forall (m :: * -> *). Branch m -> Map NameSegment (CausalBranch m)
V2Branch.children Branch Transaction
branchesBranch) \NameSegment
branchIdNS CausalBranch Transaction
projectBranchCausal -> Transaction (Maybe ()) -> Transaction ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Transaction (Maybe ()) -> Transaction ())
-> (MaybeT Transaction () -> Transaction (Maybe ()))
-> MaybeT Transaction ()
-> Transaction ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MaybeT Transaction () -> Transaction (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT Transaction () -> Transaction ())
-> MaybeT Transaction () -> Transaction ()
forall a b. (a -> b) -> a -> b
$ do
          ProjectBranchId
projectBranchId <- case NameSegment
branchIdNS of
            UUIDNameSegment UUID
branchIdUUID -> ProjectBranchId -> MaybeT Transaction ProjectBranchId
forall a. a -> MaybeT Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProjectBranchId -> MaybeT Transaction ProjectBranchId)
-> ProjectBranchId -> MaybeT Transaction ProjectBranchId
forall a b. (a -> b) -> a -> b
$ UUID -> ProjectBranchId
ProjectBranchId UUID
branchIdUUID
            NameSegment
_ -> [Char] -> MaybeT Transaction ProjectBranchId
forall a. HasCallStack => [Char] -> a
error ([Char] -> MaybeT Transaction ProjectBranchId)
-> [Char] -> MaybeT Transaction ProjectBranchId
forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid Branch Id NameSegment:" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> NameSegment -> [Char]
forall a. Show a => a -> [Char]
show NameSegment
branchIdNS
          DebugFlag -> [Char] -> ProjectBranchId -> MaybeT Transaction ()
forall a (m :: * -> *).
(Show a, Monad m) =>
DebugFlag -> [Char] -> a -> m ()
Debug.debugM DebugFlag
Debug.Migration [Char]
"Migrating project branch" ProjectBranchId
projectBranchId
          let branchCausalHash :: CausalHash
branchCausalHash = CausalBranch Transaction -> CausalHash
forall (m :: * -> *) hc he pe e. Causal m hc he pe e -> hc
V2Causal.causalHash CausalBranch Transaction
projectBranchCausal
          CausalHashId
causalHashId <- Transaction CausalHashId -> MaybeT Transaction CausalHashId
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Transaction CausalHashId -> MaybeT Transaction CausalHashId)
-> Transaction CausalHashId -> MaybeT Transaction CausalHashId
forall a b. (a -> b) -> a -> b
$ CausalHash -> Transaction CausalHashId
Q.expectCausalHashIdByCausalHash CausalHash
branchCausalHash
          ProjectBranchName
branchName <-
            Transaction (Maybe ProjectBranchName)
-> MaybeT Transaction ProjectBranchName
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Transaction (Maybe ProjectBranchName)
 -> MaybeT Transaction ProjectBranchName)
-> Transaction (Maybe ProjectBranchName)
-> MaybeT Transaction ProjectBranchName
forall a b. (a -> b) -> a -> b
$
              forall a.
(FromField a, HasCallStack) =>
Sql -> Transaction (Maybe a)
Sqlite.queryMaybeCol @ProjectBranchName
                [Sqlite.sql|
                  SELECT project_branch.name
                  FROM project_branch
                  WHERE
                    project_branch.project_id = :projectId
                    AND project_branch.branch_id = :projectBranchId
                |]
          -- Insert the full project branch with HEAD into the new table
          Transaction () -> MaybeT Transaction ()
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Transaction () -> MaybeT Transaction ())
-> Transaction () -> MaybeT Transaction ()
forall a b. (a -> b) -> a -> b
$
            HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
Sqlite.execute
              [Sqlite.sql|
              INSERT INTO new_project_branch (project_id, branch_id, name, causal_hash_id)
                VALUES (:projectId, :projectBranchId, :branchName, :causalHashId)
            |]

  DebugFlag -> [Char] -> Transaction ()
forall (m :: * -> *). Monad m => DebugFlag -> [Char] -> m ()
Debug.debugLogM DebugFlag
Debug.Migration [Char]
"Deleting orphaned project branch data"
  -- Delete any project branch data that don't have a matching branch in the current root.
  -- This is to make sure any old or invalid project branches get cleared out and won't cause problems when we rewrite
  -- foreign key references.
  -- We have to do this manually since we had to disable foreign key checks to add the new column.
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
Sqlite.execute
    [Sqlite.sql| DELETE FROM project_branch_parent AS pbp
      WHERE NOT EXISTS(SELECT 1 FROM new_project_branch npb WHERE npb.project_id = pbp.project_id AND npb.branch_id = pbp.branch_id)
    |]
  DebugFlag -> [Char] -> Transaction ()
forall (m :: * -> *). Monad m => DebugFlag -> [Char] -> m ()
Debug.debugLogM DebugFlag
Debug.Migration [Char]
"Deleting orphaned remote mapping data"
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
Sqlite.execute
    [Sqlite.sql| DELETE FROM project_branch_remote_mapping AS pbrp
      WHERE NOT EXISTS(SELECT 1 FROM new_project_branch npb WHERE npb.project_id = pbrp.local_project_id AND npb.branch_id = pbrp.local_branch_id)
    |]
  -- Delete any project branch rows that don't have a matching branch in the current root.
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
Sqlite.execute
    [Sqlite.sql|
    DELETE FROM most_recent_branch AS mrb
      WHERE NOT EXISTS(SELECT 1 FROM new_project_branch npb WHERE npb.project_id = mrb.project_id AND npb.branch_id = mrb.branch_id)
    |]

  DebugFlag -> [Char] -> Transaction ()
forall (m :: * -> *). Monad m => DebugFlag -> [Char] -> m ()
Debug.debugLogM DebugFlag
Debug.Migration [Char]
"Swapping old and new project branch tables"
  -- Drop the old project_branch table and rename the new one to take its place.
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
Sqlite.execute [Sqlite.sql| DROP TABLE project_branch |]
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
Sqlite.execute [Sqlite.sql| ALTER TABLE new_project_branch RENAME TO project_branch |]
  DebugFlag -> [Char] -> Transaction ()
forall (m :: * -> *). Monad m => DebugFlag -> [Char] -> m ()
Debug.debugLogM DebugFlag
Debug.Migration [Char]
"Checking foreign keys"
  [[SQLData]]
foreignKeyErrs <- Sql -> Transaction [[SQLData]]
forall a. (FromRow a, HasCallStack) => Sql -> Transaction [a]
Sqlite.queryListRow [Sqlite.sql| PRAGMA foreign_key_check |]
  Bool -> Transaction () -> Transaction ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> ([[SQLData]] -> Bool) -> [[SQLData]] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[SQLData]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([[SQLData]] -> Bool) -> [[SQLData]] -> Bool
forall a b. (a -> b) -> a -> b
$ [[SQLData]]
foreignKeyErrs) (Transaction () -> Transaction ())
-> (ForeignKeyFailureException -> Transaction ())
-> ForeignKeyFailureException
-> Transaction ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> Transaction ()
forall a. HasCallStack => IO a -> Transaction a
Sqlite.unsafeIO (IO () -> Transaction ())
-> (ForeignKeyFailureException -> IO ())
-> ForeignKeyFailureException
-> Transaction ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForeignKeyFailureException -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
UnliftIO.throwIO (ForeignKeyFailureException -> Transaction ())
-> ForeignKeyFailureException -> Transaction ()
forall a b. (a -> b) -> a -> b
$ [[SQLData]] -> ForeignKeyFailureException
ForeignKeyFailureException [[SQLData]]
foreignKeyErrs

makeLegacyProjectFromLooseCode :: Sqlite.Transaction ()
makeLegacyProjectFromLooseCode :: Transaction ()
makeLegacyProjectFromLooseCode = do
  CausalHashId
rootChId <-
    forall a. (FromField a, HasCallStack) => Sql -> Transaction a
Sqlite.queryOneCol @CausalHashId
      [Sqlite.sql|
    SELECT causal_id
    FROM namespace_root
  |]
  CausalHash
rootCh <- CausalHashId -> Transaction CausalHash
Q.expectCausalHash CausalHashId
rootChId
  BranchCache Transaction
branchCache <- IO (BranchCache Transaction)
-> Transaction (BranchCache Transaction)
forall a. HasCallStack => IO a -> Transaction a
Sqlite.unsafeIO IO (BranchCache Transaction)
forall (m :: * -> *). MonadIO m => m (BranchCache Transaction)
BranchCache.newBranchCache
  Reference -> Transaction ConstructorType
getDeclType <- IO (Reference -> Transaction ConstructorType)
-> Transaction (Reference -> Transaction ConstructorType)
forall a. HasCallStack => IO a -> Transaction a
Sqlite.unsafeIO (IO (Reference -> Transaction ConstructorType)
 -> Transaction (Reference -> Transaction ConstructorType))
-> IO (Reference -> Transaction ConstructorType)
-> Transaction (Reference -> Transaction ConstructorType)
forall a b. (a -> b) -> a -> b
$ Word
-> (Reference -> Transaction ConstructorType)
-> IO (Reference -> Transaction ConstructorType)
forall a (m :: * -> *) b.
(Ord a, MonadIO m) =>
Word -> (a -> Transaction b) -> m (a -> Transaction b)
CodebaseOps.makeCachedTransaction Word
2048 Reference -> Transaction ConstructorType
CodebaseOps.getDeclType
  Branch Transaction
rootBranch <-
    BranchCache Transaction
-> (Reference -> Transaction ConstructorType)
-> CausalHash
-> Transaction (Maybe (Branch Transaction))
CodebaseOps.getBranchForHash BranchCache Transaction
branchCache Reference -> Transaction ConstructorType
getDeclType CausalHash
rootCh Transaction (Maybe (Branch Transaction))
-> Transaction (Branch Transaction)
-> Transaction (Branch Transaction)
forall (m :: * -> *) a. Monad m => m (Maybe a) -> m a -> m a
`whenNothingM` do
      IO (Branch Transaction) -> Transaction (Branch Transaction)
forall a. HasCallStack => IO a -> Transaction a
Sqlite.unsafeIO (IO (Branch Transaction) -> Transaction (Branch Transaction))
-> (ForeignKeyFailureException -> IO (Branch Transaction))
-> ForeignKeyFailureException
-> Transaction (Branch Transaction)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForeignKeyFailureException -> IO (Branch Transaction)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
UnliftIO.throwIO (ForeignKeyFailureException -> Transaction (Branch Transaction))
-> ForeignKeyFailureException -> Transaction (Branch Transaction)
forall a b. (a -> b) -> a -> b
$ ForeignKeyFailureException
MissingRootBranch
  -- Remove the hidden projects root if one existed.
  let rootWithoutProjects :: Branch Transaction
rootWithoutProjects = Branch Transaction
rootBranch Branch Transaction
-> (Branch Transaction -> Branch Transaction) -> Branch Transaction
forall a b. a -> (a -> b) -> b
& ASetter
  (Branch Transaction)
  (Branch Transaction)
  (Map NameSegment (Branch Transaction))
  (Map NameSegment (Branch Transaction))
-> (Map NameSegment (Branch Transaction)
    -> Map NameSegment (Branch Transaction))
-> Branch Transaction
-> Branch Transaction
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((Branch0 Transaction -> Identity (Branch0 Transaction))
-> Branch Transaction -> Identity (Branch Transaction)
forall (m :: * -> *) (f :: * -> *).
Functor f =>
(Branch0 m -> f (Branch0 m)) -> Branch m -> f (Branch m)
Branch.head_ ((Branch0 Transaction -> Identity (Branch0 Transaction))
 -> Branch Transaction -> Identity (Branch Transaction))
-> ((Map NameSegment (Branch Transaction)
     -> Identity (Map NameSegment (Branch Transaction)))
    -> Branch0 Transaction -> Identity (Branch0 Transaction))
-> ASetter
     (Branch Transaction)
     (Branch Transaction)
     (Map NameSegment (Branch Transaction))
     (Map NameSegment (Branch Transaction))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map NameSegment (Branch Transaction)
 -> Identity (Map NameSegment (Branch Transaction)))
-> Branch0 Transaction -> Identity (Branch0 Transaction)
forall (m :: * -> *) (f :: * -> *).
Functor f =>
(Map NameSegment (Branch m) -> f (Map NameSegment (Branch m)))
-> Branch0 m -> f (Branch0 m)
Branch.children) (NameSegment
-> Map NameSegment (Branch Transaction)
-> Map NameSegment (Branch Transaction)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete NameSegment
projectsNameSegment)
  Branch Transaction -> Transaction ()
CodebaseOps.putBranch Branch Transaction
rootWithoutProjects
  let legacyBranchRootHash :: CausalHash
legacyBranchRootHash = Branch Transaction -> CausalHash
forall (m :: * -> *). Branch m -> CausalHash
Branch.headHash Branch Transaction
rootWithoutProjects
  CausalHashId
legacyBranchRootHashId <- CausalHash -> Transaction CausalHashId
Q.expectCausalHashIdByCausalHash CausalHash
legacyBranchRootHash

  let findLegacyName :: Maybe Int -> Sqlite.Transaction ProjectName
      findLegacyName :: Maybe Int -> Transaction ProjectName
findLegacyName Maybe Int
mayN = do
        let tryProjName :: ProjectName
tryProjName = case Maybe Int
mayN of
              Maybe Int
Nothing -> Text -> ProjectName
UnsafeProjectName Text
"legacy"
              Just Int
n -> Text -> ProjectName
UnsafeProjectName (Text -> ProjectName) -> Text -> ProjectName
forall a b. (a -> b) -> a -> b
$ Text
"legacy" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
Text.pack (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n)
        ProjectName
-> ProjectBranchName -> Transaction (Maybe ProjectBranch)
Q.loadProjectBranchByNames ProjectName
tryProjName ProjectBranchName
legacyBranchName Transaction (Maybe ProjectBranch)
-> (Maybe ProjectBranch -> Transaction ProjectName)
-> Transaction ProjectName
forall a b. Transaction a -> (a -> Transaction b) -> Transaction b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Maybe ProjectBranch
Nothing -> ProjectName -> Transaction ProjectName
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProjectName
tryProjName
          Just ProjectBranch
_ -> Maybe Int -> Transaction ProjectName
findLegacyName (Maybe Int -> Transaction ProjectName)
-> (Int -> Maybe Int) -> Int -> Transaction ProjectName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Transaction ProjectName) -> Int -> Transaction ProjectName
forall a b. (a -> b) -> a -> b
$ Int -> (Int -> Int) -> Maybe Int -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
1 Int -> Int
forall a. Enum a => a -> a
succ Maybe Int
mayN
  ProjectName
legacyProjName <- Maybe Int -> Transaction ProjectName
findLegacyName Maybe Int
forall a. Maybe a
Nothing
  Transaction (Project, ProjectBranch) -> Transaction ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Transaction (Project, ProjectBranch) -> Transaction ())
-> Transaction (Project, ProjectBranch) -> Transaction ()
forall a b. (a -> b) -> a -> b
$ ProjectName
-> ProjectBranchName
-> CausalHashId
-> Transaction (Project, ProjectBranch)
Ops.insertProjectAndBranch ProjectName
legacyProjName ProjectBranchName
legacyBranchName CausalHashId
legacyBranchRootHashId
  pure ()
  where
    legacyBranchName :: ProjectBranchName
legacyBranchName = Text -> ProjectBranchName
UnsafeProjectBranchName Text
"main"

expectNamespaceRoot :: Sqlite.Transaction CausalHashId
expectNamespaceRoot :: Transaction CausalHashId
expectNamespaceRoot =
  Sql -> Transaction CausalHashId
forall a. (FromField a, HasCallStack) => Sql -> Transaction a
Sqlite.queryOneCol Sql
loadNamespaceRootSql

loadNamespaceRootSql :: Sqlite.Sql
loadNamespaceRootSql :: Sql
loadNamespaceRootSql =
  [Sqlite.sql|
    SELECT causal_id
    FROM namespace_root
  |]

pattern UUIDNameSegment :: UUID -> NameSegment
pattern $mUUIDNameSegment :: forall {r}. NameSegment -> (UUID -> r) -> ((# #) -> r) -> r
$bUUIDNameSegment :: UUID -> NameSegment
UUIDNameSegment uuid <-
  ( NameSegment.toUnescapedText ->
      (Text.uncons -> Just ('_', UUID.fromText . Text.map (\Char
c -> if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' then Char
'-' else Char
c) -> Just uuid))
    )
  where
    UUIDNameSegment UUID
uuid =
      Text -> NameSegment
NameSegment (Char -> Text -> Text
Text.cons Char
'_' ((Char -> Char) -> Text -> Text
Text.map (\Char
c -> if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-' then Char
'_' else Char
c) (UUID -> Text
UUID.toText UUID
uuid)))

projectsNameSegment :: NameSegment
projectsNameSegment :: NameSegment
projectsNameSegment = Text -> NameSegment
NameSegment.unsafeParseText Text
"__projects"

branchesNameSegment :: NameSegment
branchesNameSegment :: NameSegment
branchesNameSegment = Text -> NameSegment
NameSegment.unsafeParseText Text
"branches"

expectMostRecentNamespace :: Sqlite.Transaction [NameSegment]
expectMostRecentNamespace :: Transaction [NameSegment]
expectMostRecentNamespace =
  Sql
-> (Text -> Either JsonParseFailure [NameSegment])
-> Transaction [NameSegment]
forall a e r.
(FromField a, SqliteExceptionReason e, HasCallStack) =>
Sql -> (a -> Either e r) -> Transaction r
Sqlite.queryOneColCheck
    [Sqlite.sql|
      SELECT namespace
      FROM most_recent_namespace
    |]
    Text -> Either JsonParseFailure [NameSegment]
check
  where
    check :: Text -> Either Q.JsonParseFailure [NameSegment]
    check :: Text -> Either JsonParseFailure [NameSegment]
check Text
bytes =
      case ByteString -> Either [Char] [Text]
forall a. FromJSON a => ByteString -> Either [Char] a
Aeson.eitherDecodeStrict (Text -> ByteString
Text.encodeUtf8 Text
bytes) of
        Left [Char]
failure -> JsonParseFailure -> Either JsonParseFailure [NameSegment]
forall a b. a -> Either a b
Left (Q.JsonParseFailure {Text
bytes :: Text
$sel:bytes:JsonParseFailure :: Text
bytes, $sel:failure:JsonParseFailure :: Text
failure = [Char] -> Text
Text.pack [Char]
failure})
        Right [Text]
namespace -> [NameSegment] -> Either JsonParseFailure [NameSegment]
forall a b. b -> Either a b
Right ((Text -> NameSegment) -> [Text] -> [NameSegment]
forall a b. (a -> b) -> [a] -> [b]
map Text -> NameSegment
NameSegment [Text]
namespace)

getMostRecentProjectBranchIds :: Sqlite.Transaction (Maybe (ProjectId, ProjectBranchId))
getMostRecentProjectBranchIds :: Transaction (Maybe (ProjectId, ProjectBranchId))
getMostRecentProjectBranchIds = do
  [NameSegment]
nameSegments <- Transaction [NameSegment]
expectMostRecentNamespace
  case [NameSegment]
nameSegments of
    (NameSegment
proj : UUIDNameSegment UUID
projectId : NameSegment
branches : UUIDNameSegment UUID
branchId : [NameSegment]
_)
      | NameSegment
proj NameSegment -> NameSegment -> Bool
forall a. Eq a => a -> a -> Bool
== NameSegment
projectsNameSegment Bool -> Bool -> Bool
&& NameSegment
branches NameSegment -> NameSegment -> Bool
forall a. Eq a => a -> a -> Bool
== NameSegment
branchesNameSegment ->
          Maybe (ProjectId, ProjectBranchId)
-> Transaction (Maybe (ProjectId, ProjectBranchId))
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (ProjectId, ProjectBranchId)
 -> Transaction (Maybe (ProjectId, ProjectBranchId)))
-> ((ProjectId, ProjectBranchId)
    -> Maybe (ProjectId, ProjectBranchId))
-> (ProjectId, ProjectBranchId)
-> Transaction (Maybe (ProjectId, ProjectBranchId))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProjectId, ProjectBranchId) -> Maybe (ProjectId, ProjectBranchId)
forall a. a -> Maybe a
Just ((ProjectId, ProjectBranchId)
 -> Transaction (Maybe (ProjectId, ProjectBranchId)))
-> (ProjectId, ProjectBranchId)
-> Transaction (Maybe (ProjectId, ProjectBranchId))
forall a b. (a -> b) -> a -> b
$ (UUID -> ProjectId
ProjectId UUID
projectId, UUID -> ProjectBranchId
ProjectBranchId UUID
branchId)
    [NameSegment]
_ -> Maybe (ProjectId, ProjectBranchId)
-> Transaction (Maybe (ProjectId, ProjectBranchId))
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ProjectId, ProjectBranchId)
forall a. Maybe a
Nothing