{-# LANGUAGE DataKinds #-}
{-# LANGUAGE QuasiQuotes #-}

module Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema3To4 (migrateSchema3To4) where

import Control.Lens
import Control.Monad.Except
import Control.Monad.State
import Data.Generics.Product
import Data.Map qualified as Map
import Data.Semigroup
import Data.Set.Lens (setOf)
import U.Codebase.Sqlite.Branch.Format qualified as S.BranchFormat
import U.Codebase.Sqlite.Branch.Full qualified as DBBranch
import U.Codebase.Sqlite.DbId qualified as DB
import U.Codebase.Sqlite.LocalizeObject qualified as S.LocalizeObject
import U.Codebase.Sqlite.Operations qualified as Ops
import U.Codebase.Sqlite.Queries qualified as Q
import U.Codebase.Sqlite.Serialization qualified as S
import U.Codebase.Sync qualified as Sync
import U.Util.Serialization qualified as S
import Unison.Codebase.SqliteCodebase.Migrations.Helpers (abortMigration)
import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2.DbHelpers qualified as Helpers
import Unison.Debug qualified as Debug
import Unison.Prelude
import Unison.Sqlite qualified as Sqlite
import Prelude hiding (log)

data MigrationState = MigrationState
  { -- A mapping from a causal hash to the _corrected_ and _canonicalized_ branch hash and
    -- object.
    MigrationState -> Map CausalHashId (BranchHashId, BranchObjectId)
_canonicalBranchForCausalHashId :: Map DB.CausalHashId (DB.BranchHashId, DB.BranchObjectId),
    -- A mapping of branch hashes which were found to be correct and don't need to be
    -- re-hashed/re-canonicalized, it allows us to skip some redundant work.
    MigrationState -> Map BranchHashId BranchObjectId
_validBranchHashIds :: Map DB.BranchHashId DB.BranchObjectId,
    MigrationState -> Int
_numMigrated :: Int
  }
  deriving ((forall x. MigrationState -> Rep MigrationState x)
-> (forall x. Rep MigrationState x -> MigrationState)
-> Generic MigrationState
forall x. Rep MigrationState x -> MigrationState
forall x. MigrationState -> Rep MigrationState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. MigrationState -> Rep MigrationState x
from :: forall x. MigrationState -> Rep MigrationState x
$cto :: forall x. Rep MigrationState x -> MigrationState
to :: forall x. Rep MigrationState x -> MigrationState
Generic)

canonicalBranchForCausalHashId :: Lens' MigrationState (Map DB.CausalHashId (DB.BranchHashId, DB.BranchObjectId))
canonicalBranchForCausalHashId :: Lens'
  MigrationState (Map CausalHashId (BranchHashId, BranchObjectId))
canonicalBranchForCausalHashId =
  forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"_canonicalBranchForCausalHashId"

validBranchHashIds :: Lens' MigrationState (Map DB.BranchHashId DB.BranchObjectId)
validBranchHashIds :: Lens' MigrationState (Map BranchHashId BranchObjectId)
validBranchHashIds =
  forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"_validBranchHashIds"

numMigrated :: Lens' MigrationState Int
numMigrated :: Lens' MigrationState Int
numMigrated =
  forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"_numMigrated"

-- | There was a bug in previous versions of UCM which incorrectly used causal hashes as branch hashes.
-- This remained undetected because there was never a need for this hash to be verifiable,
-- and the hashes were still unique because the namespace hash was PART of the causal hash.
-- It did however result in many identical branches being stored multiple times under
-- different `primary_hash_id`s.
--
-- However, with the advent of Share and Sync, we now need to correctly verify these namespace
-- hashes.
--
-- This migration fixes the issue by re-hashing namespace objects where the value_hash_id of a
-- causal matches the self_hash_id.
-- Luckily this doesn't change any causal hashes.
--
-- However, due to the possibility of multiple identical objects stored under different
-- `primary_hash_id`s, we may now have multiple objects with the same `primary_hash_id`, which
-- our DB schema doesn't allow.
--
-- To address this, we keep exactly one 'canonical' object for each hash, then remap all
-- references to old objects into this canonical object instead. Unfortunately this requires
-- mapping over every branch object and traversing the child references.
--
-- It was also discovered that some developers had many branches which referenced objects
-- which weren't in their codebase. We're not yet sure how this happened, but it's unlikely
-- to be the case for most end users, and it turned out that these references were in causals
-- and branches which were unreachable from the root namespace. As a fix, this migration also
-- tracks every causal and branch which is reachable from the root namespace and deletes all
-- causals and namespaces which are unreachable. Note that this may orphan some definitions,
-- patches, etc. which were previously referenced in an 'unreachable' branch, but they were
-- already floating around in an unreachable state.
migrateSchema3To4 :: Sqlite.Transaction ()
migrateSchema3To4 :: Transaction ()
migrateSchema3To4 = do
  SchemaVersion -> Transaction ()
Q.expectSchemaVersion SchemaVersion
3
  CausalHashId
rootCausalHashId <- Transaction CausalHashId
expectNamespaceRoot
  Int
totalCausals <- Transaction Int
causalCount
  MigrationState
migrationState <- (StateT MigrationState Transaction ()
 -> MigrationState -> Transaction MigrationState)
-> MigrationState
-> StateT MigrationState Transaction ()
-> Transaction MigrationState
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT MigrationState Transaction ()
-> MigrationState -> Transaction MigrationState
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (Map CausalHashId (BranchHashId, BranchObjectId)
-> Map BranchHashId BranchObjectId -> Int -> MigrationState
MigrationState Map CausalHashId (BranchHashId, BranchObjectId)
forall a. Monoid a => a
mempty Map BranchHashId BranchObjectId
forall a. Monoid a => a
mempty Int
0) (StateT MigrationState Transaction ()
 -> Transaction MigrationState)
-> StateT MigrationState Transaction ()
-> Transaction MigrationState
forall a b. (a -> b) -> a -> b
$ Sync (StateT MigrationState Transaction) CausalHashId
-> Progress (StateT MigrationState Transaction) CausalHashId
-> [CausalHashId]
-> StateT MigrationState Transaction ()
forall (m :: * -> *) h.
(Monad m, Show h) =>
Sync m h -> Progress m h -> [h] -> m ()
Sync.sync Sync (StateT MigrationState Transaction) CausalHashId
migrationSync (Int -> Progress (StateT MigrationState Transaction) CausalHashId
migrationProgress Int
totalCausals) [CausalHashId
rootCausalHashId]
  let MigrationState {$sel:_canonicalBranchForCausalHashId:MigrationState :: MigrationState -> Map CausalHashId (BranchHashId, BranchObjectId)
_canonicalBranchForCausalHashId = Map CausalHashId (BranchHashId, BranchObjectId)
mapping} = MigrationState
migrationState
  let reachableCausalHashes :: Set CausalHashId
reachableCausalHashes = Map CausalHashId (BranchHashId, BranchObjectId) -> Set CausalHashId
forall k a. Map k a -> Set k
Map.keysSet Map CausalHashId (BranchHashId, BranchObjectId)
mapping
  let reachableBranchObjIds :: Set BranchObjectId
reachableBranchObjIds = Getting
  (Set BranchObjectId)
  (Map CausalHashId (BranchHashId, BranchObjectId))
  BranchObjectId
-> Map CausalHashId (BranchHashId, BranchObjectId)
-> Set BranchObjectId
forall a s. Getting (Set a) s a -> s -> Set a
setOf (((BranchHashId, BranchObjectId)
 -> Const (Set BranchObjectId) (BranchHashId, BranchObjectId))
-> Map CausalHashId (BranchHashId, BranchObjectId)
-> Const
     (Set BranchObjectId)
     (Map CausalHashId (BranchHashId, BranchObjectId))
forall (f :: * -> *) a b.
Traversable f =>
IndexedTraversal Int (f a) (f b) a b
IndexedTraversal
  Int
  (Map CausalHashId (BranchHashId, BranchObjectId))
  (Map CausalHashId (BranchHashId, BranchObjectId))
  (BranchHashId, BranchObjectId)
  (BranchHashId, BranchObjectId)
traversed (((BranchHashId, BranchObjectId)
  -> Const (Set BranchObjectId) (BranchHashId, BranchObjectId))
 -> Map CausalHashId (BranchHashId, BranchObjectId)
 -> Const
      (Set BranchObjectId)
      (Map CausalHashId (BranchHashId, BranchObjectId)))
-> ((BranchObjectId -> Const (Set BranchObjectId) BranchObjectId)
    -> (BranchHashId, BranchObjectId)
    -> Const (Set BranchObjectId) (BranchHashId, BranchObjectId))
-> Getting
     (Set BranchObjectId)
     (Map CausalHashId (BranchHashId, BranchObjectId))
     BranchObjectId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BranchObjectId -> Const (Set BranchObjectId) BranchObjectId)
-> (BranchHashId, BranchObjectId)
-> Const (Set BranchObjectId) (BranchHashId, BranchObjectId)
forall s t a b. Field2 s t a b => Lens s t a b
Lens
  (BranchHashId, BranchObjectId)
  (BranchHashId, BranchObjectId)
  BranchObjectId
  BranchObjectId
_2) Map CausalHashId (BranchHashId, BranchObjectId)
mapping
  String -> Transaction ()
log (String -> Transaction ()) -> String -> Transaction ()
forall a b. (a -> b) -> a -> b
$ String
"🛠  Cleaning up unreachable branches and causals..."
  Set CausalHashId -> Set BranchObjectId -> Transaction ()
dropUnreachableCausalsAndBranches Set CausalHashId
reachableCausalHashes Set BranchObjectId
reachableBranchObjIds
  SchemaVersion -> Transaction ()
Q.setSchemaVersion SchemaVersion
4
  where
    causalCount :: Sqlite.Transaction Int
    causalCount :: Transaction Int
causalCount = do
      Sql -> Transaction Int
forall a. (FromField a, HasCallStack) => Sql -> Transaction a
Sqlite.queryOneCol
        [Sqlite.sql|
          SELECT count(*) FROM causal;
        |]

expectNamespaceRoot :: Sqlite.Transaction DB.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
  |]

migrationProgress :: Int -> Sync.Progress (StateT MigrationState Sqlite.Transaction) DB.CausalHashId
migrationProgress :: Int -> Progress (StateT MigrationState Transaction) CausalHashId
migrationProgress Int
totalCausals =
  Sync.Progress {CausalHashId -> StateT MigrationState Transaction ()
forall {t :: (* -> *) -> * -> *} {a}.
(MonadTrans t, Show a) =>
a -> t Transaction ()
need :: forall {t :: (* -> *) -> * -> *} {a}.
(MonadTrans t, Show a) =>
a -> t Transaction ()
need :: CausalHashId -> StateT MigrationState Transaction ()
Sync.need, CausalHashId -> StateT MigrationState Transaction ()
done :: CausalHashId -> StateT MigrationState Transaction ()
done :: CausalHashId -> StateT MigrationState Transaction ()
Sync.done, CausalHashId -> StateT MigrationState Transaction ()
forall {t :: (* -> *) -> * -> *} {a}.
(MonadTrans t, Show a) =>
a -> t Transaction ()
error :: forall {t :: (* -> *) -> * -> *} {a}.
(MonadTrans t, Show a) =>
a -> t Transaction ()
error :: CausalHashId -> StateT MigrationState Transaction ()
Sync.error, StateT MigrationState Transaction ()
allDone :: StateT MigrationState Transaction ()
allDone :: StateT MigrationState Transaction ()
Sync.allDone}
  where
    need :: a -> t Transaction ()
need a
e = Transaction () -> t Transaction ()
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Transaction () -> t Transaction ())
-> Transaction () -> t Transaction ()
forall a b. (a -> b) -> a -> b
$ String -> Transaction ()
debugLog (String -> Transaction ()) -> String -> Transaction ()
forall a b. (a -> b) -> a -> b
$ String
"Need " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
e
    done :: CausalHashId -> StateT MigrationState Transaction ()
done CausalHashId
_ =
      do
        Int
numDone <- (Int -> (Int, Int)) -> MigrationState -> (Int, MigrationState)
Lens' MigrationState Int
numMigrated ((Int -> (Int, Int)) -> MigrationState -> (Int, MigrationState))
-> Int -> StateT MigrationState Transaction Int
forall s (m :: * -> *) a.
(MonadState s m, Num a) =>
LensLike' ((,) a) s a -> a -> m a
<+= Int
1
        Transaction () -> StateT MigrationState Transaction ()
forall (m :: * -> *) a. Monad m => m a -> StateT MigrationState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Transaction () -> StateT MigrationState Transaction ())
-> Transaction () -> StateT MigrationState Transaction ()
forall a b. (a -> b) -> a -> b
$ IO () -> Transaction ()
forall a. HasCallStack => IO a -> Transaction a
Sqlite.unsafeIO (IO () -> Transaction ()) -> IO () -> Transaction ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"\r🏗  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
numDone String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" / ~" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
totalCausals String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" entities migrated. 🚧"
    error :: a -> t Transaction ()
error a
e = Transaction () -> t Transaction ()
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Transaction () -> t Transaction ())
-> (String -> Transaction ()) -> String -> t Transaction ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Transaction ()
log (String -> t Transaction ()) -> String -> t Transaction ()
forall a b. (a -> b) -> a -> b
$ String
"Error " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
e
    allDone :: StateT MigrationState Transaction ()
allDone = do
      -- In some corrupted codebases we don't necessarily process every causal, or there may
      -- be unreachable causals. We'll show the final number here just so everything looks
      -- good to users. It's okay since we'll process the other branches and clean them up in
      -- a batch step.
      Transaction () -> StateT MigrationState Transaction ()
forall (m :: * -> *) a. Monad m => m a -> StateT MigrationState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Transaction () -> StateT MigrationState Transaction ())
-> Transaction () -> StateT MigrationState Transaction ()
forall a b. (a -> b) -> a -> b
$ IO () -> Transaction ()
forall a. HasCallStack => IO a -> Transaction a
Sqlite.unsafeIO (IO () -> Transaction ()) -> IO () -> Transaction ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"\r🏗  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
totalCausals String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" / ~" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
totalCausals String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" entities migrated. 🚧"
      Transaction () -> StateT MigrationState Transaction ()
forall (m :: * -> *) a. Monad m => m a -> StateT MigrationState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Transaction () -> StateT MigrationState Transaction ())
-> (String -> Transaction ())
-> String
-> StateT MigrationState Transaction ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> Transaction ()
forall a. HasCallStack => IO a -> Transaction a
Sqlite.unsafeIO (IO () -> Transaction ())
-> (String -> IO ()) -> String -> Transaction ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn (String -> StateT MigrationState Transaction ())
-> String -> StateT MigrationState Transaction ()
forall a b. (a -> b) -> a -> b
$ String
"Finished."

migrationSync :: Sync.Sync (StateT MigrationState Sqlite.Transaction) DB.CausalHashId
migrationSync :: Sync (StateT MigrationState Transaction) CausalHashId
migrationSync =
  (CausalHashId
 -> StateT MigrationState Transaction (TrySyncResult CausalHashId))
-> Sync (StateT MigrationState Transaction) CausalHashId
forall (m :: * -> *) entity.
(entity -> m (TrySyncResult entity)) -> Sync m entity
Sync.Sync \CausalHashId
e -> do
    (ExceptT
  (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
-> StateT
     MigrationState Transaction (Either (TrySyncResult CausalHashId) ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT
   (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
 -> StateT
      MigrationState
      Transaction
      (Either (TrySyncResult CausalHashId) ()))
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
-> StateT
     MigrationState Transaction (Either (TrySyncResult CausalHashId) ())
forall a b. (a -> b) -> a -> b
$ CausalHashId
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
migrateCausal CausalHashId
e) StateT
  MigrationState Transaction (Either (TrySyncResult CausalHashId) ())
-> (Either (TrySyncResult CausalHashId) ()
    -> StateT MigrationState Transaction (TrySyncResult CausalHashId))
-> StateT MigrationState Transaction (TrySyncResult CausalHashId)
forall a b.
StateT MigrationState Transaction a
-> (a -> StateT MigrationState Transaction b)
-> StateT MigrationState Transaction b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left TrySyncResult CausalHashId
syncResult -> TrySyncResult CausalHashId
-> StateT MigrationState Transaction (TrySyncResult CausalHashId)
forall a. a -> StateT MigrationState Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TrySyncResult CausalHashId
syncResult
      Right ()
_ -> TrySyncResult CausalHashId
-> StateT MigrationState Transaction (TrySyncResult CausalHashId)
forall a. a -> StateT MigrationState Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TrySyncResult CausalHashId
forall entity. TrySyncResult entity
Sync.Done

liftT :: Sqlite.Transaction a -> ExceptT (Sync.TrySyncResult DB.CausalHashId) (StateT MigrationState Sqlite.Transaction) a
liftT :: forall a.
Transaction a
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) a
liftT = StateT MigrationState Transaction a
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) a
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (TrySyncResult CausalHashId) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT MigrationState Transaction a
 -> ExceptT
      (TrySyncResult CausalHashId) (StateT MigrationState Transaction) a)
-> (Transaction a -> StateT MigrationState Transaction a)
-> Transaction a
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transaction a -> StateT MigrationState Transaction a
forall (m :: * -> *) a. Monad m => m a -> StateT MigrationState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

dropUnreachableCausalsAndBranches :: Set DB.CausalHashId -> Set DB.BranchObjectId -> Sqlite.Transaction ()
dropUnreachableCausalsAndBranches :: Set CausalHashId -> Set BranchObjectId -> Transaction ()
dropUnreachableCausalsAndBranches Set CausalHashId
reachableCausals Set BranchObjectId
reachableBranchObjs = do
  Transaction ()
createReachabilityTables
  (CausalHashId -> Transaction ())
-> Set CausalHashId -> Transaction ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ CausalHashId -> Transaction ()
forall {a}. ToField a => a -> Transaction ()
insertReachableCausalSql Set CausalHashId
reachableCausals
  (BranchObjectId -> Transaction ())
-> Set BranchObjectId -> Transaction ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ BranchObjectId -> Transaction ()
forall {a}. ToField a => a -> Transaction ()
insertReachableBranchObjectSql Set BranchObjectId
reachableBranchObjs
  Transaction ()
deleteUnreachableHashObjects
  Transaction ()
deleteUnreachableBranchObjects
  Transaction ()
deleteUnreachableCausalParents
  Transaction ()
deleteUnreachableCausals
  where
    deleteUnreachableHashObjects :: Transaction ()
deleteUnreachableHashObjects =
      HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
Sqlite.execute
        [Sqlite.sql|
        DELETE FROM hash_object AS ho
          WHERE
            NOT EXISTS (SELECT 1 FROM reachable_branch_objects AS ro WHERE ho.object_id = ro.object_id)
            -- Ensure hash objects we're deleting are for branch objects.
            AND EXISTS (SELECT 1 FROM object AS o WHERE o.id = ho.object_id AND type_id = 2)
      |]
    deleteUnreachableBranchObjects :: Transaction ()
deleteUnreachableBranchObjects =
      HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
Sqlite.execute
        [Sqlite.sql|
        DELETE FROM object AS o
          WHERE
            o.type_id = 2 -- Filter for only branches
            AND NOT EXISTS (SELECT 1 FROM reachable_branch_objects AS ro WHERE o.id = ro.object_id)
      |]
    deleteUnreachableCausals :: Transaction ()
deleteUnreachableCausals =
      HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
Sqlite.execute
        [Sqlite.sql|
        DELETE FROM causal AS c
          WHERE NOT EXISTS (SELECT 1 FROM reachable_causals AS rc WHERE c.self_hash_id = rc.self_hash_id)
      |]
    deleteUnreachableCausalParents :: Transaction ()
deleteUnreachableCausalParents =
      HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
Sqlite.execute
        [Sqlite.sql|
        DELETE FROM causal_parent AS cp
          WHERE
            -- We only need to check the children, because if it's impossible for a parent to be
            -- unreachable if the child is reachable. A.k.a. reachable(child) =implies> reachable(parent)
            NOT EXISTS (SELECT 1 FROM reachable_causals AS rc WHERE cp.causal_id = rc.self_hash_id)
      |]
    insertReachableCausalSql :: a -> Transaction ()
insertReachableCausalSql a
h =
      HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
Sqlite.execute
        [Sqlite.sql|
          INSERT INTO reachable_causals (self_hash_id) VALUES (:h)
            ON CONFLICT DO NOTHING
        |]
    insertReachableBranchObjectSql :: a -> Transaction ()
insertReachableBranchObjectSql a
o =
      HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
Sqlite.execute
        [Sqlite.sql|
          INSERT INTO reachable_branch_objects (object_id) VALUES (:o)
            ON CONFLICT DO NOTHING
        |]
    createReachabilityTables :: Transaction ()
createReachabilityTables = do
      HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
Sqlite.execute
        [Sqlite.sql|
           CREATE TEMP TABLE IF NOT EXISTS reachable_branch_objects (
            object_id INTEGER PRIMARY KEY NOT NULL
           )
          |]
      HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
Sqlite.execute
        [Sqlite.sql|
           CREATE TEMP TABLE IF NOT EXISTS reachable_causals (
            self_hash_id INTEGER PRIMARY KEY NOT NULL
           )
          |]

migrateCausal :: DB.CausalHashId -> ExceptT (Sync.TrySyncResult DB.CausalHashId) (StateT MigrationState Sqlite.Transaction) ()
migrateCausal :: CausalHashId
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
migrateCausal CausalHashId
causalHashId = do
  Getting
  (First (BranchHashId, BranchObjectId))
  MigrationState
  (BranchHashId, BranchObjectId)
-> ExceptT
     (TrySyncResult CausalHashId)
     (StateT MigrationState Transaction)
     (Maybe (BranchHashId, BranchObjectId))
forall s (m :: * -> *) a.
MonadState s m =>
Getting (First a) s a -> m (Maybe a)
preuse ((Map CausalHashId (BranchHashId, BranchObjectId)
 -> Const
      (First (BranchHashId, BranchObjectId))
      (Map CausalHashId (BranchHashId, BranchObjectId)))
-> MigrationState
-> Const (First (BranchHashId, BranchObjectId)) MigrationState
Lens'
  MigrationState (Map CausalHashId (BranchHashId, BranchObjectId))
canonicalBranchForCausalHashId ((Map CausalHashId (BranchHashId, BranchObjectId)
  -> Const
       (First (BranchHashId, BranchObjectId))
       (Map CausalHashId (BranchHashId, BranchObjectId)))
 -> MigrationState
 -> Const (First (BranchHashId, BranchObjectId)) MigrationState)
-> (((BranchHashId, BranchObjectId)
     -> Const
          (First (BranchHashId, BranchObjectId))
          (BranchHashId, BranchObjectId))
    -> Map CausalHashId (BranchHashId, BranchObjectId)
    -> Const
         (First (BranchHashId, BranchObjectId))
         (Map CausalHashId (BranchHashId, BranchObjectId)))
-> Getting
     (First (BranchHashId, BranchObjectId))
     MigrationState
     (BranchHashId, BranchObjectId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map CausalHashId (BranchHashId, BranchObjectId))
-> Traversal'
     (Map CausalHashId (BranchHashId, BranchObjectId))
     (IxValue (Map CausalHashId (BranchHashId, BranchObjectId)))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Index (Map CausalHashId (BranchHashId, BranchObjectId))
CausalHashId
causalHashId) ExceptT
  (TrySyncResult CausalHashId)
  (StateT MigrationState Transaction)
  (Maybe (BranchHashId, BranchObjectId))
-> (Maybe (BranchHashId, BranchObjectId)
    -> ExceptT
         (TrySyncResult CausalHashId)
         (StateT MigrationState Transaction)
         ())
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall a b.
ExceptT
  (TrySyncResult CausalHashId) (StateT MigrationState Transaction) a
-> (a
    -> ExceptT
         (TrySyncResult CausalHashId) (StateT MigrationState Transaction) b)
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just (BranchHashId, BranchObjectId)
_ -> TrySyncResult CausalHashId
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall a.
TrySyncResult CausalHashId
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError TrySyncResult CausalHashId
forall entity. TrySyncResult entity
Sync.PreviouslyDone
    Maybe (BranchHashId, BranchObjectId)
Nothing -> do
      [CausalHashId]
causalParents <- Transaction [CausalHashId]
-> ExceptT
     (TrySyncResult CausalHashId)
     (StateT MigrationState Transaction)
     [CausalHashId]
forall a.
Transaction a
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) a
liftT (Transaction [CausalHashId]
 -> ExceptT
      (TrySyncResult CausalHashId)
      (StateT MigrationState Transaction)
      [CausalHashId])
-> Transaction [CausalHashId]
-> ExceptT
     (TrySyncResult CausalHashId)
     (StateT MigrationState Transaction)
     [CausalHashId]
forall a b. (a -> b) -> a -> b
$ CausalHashId -> Transaction [CausalHashId]
Q.loadCausalParents CausalHashId
causalHashId
      [CausalHashId]
unmigratedParents <- ((CausalHashId
  -> ExceptT
       (TrySyncResult CausalHashId)
       (StateT MigrationState Transaction)
       Bool)
 -> [CausalHashId]
 -> ExceptT
      (TrySyncResult CausalHashId)
      (StateT MigrationState Transaction)
      [CausalHashId])
-> [CausalHashId]
-> (CausalHashId
    -> ExceptT
         (TrySyncResult CausalHashId)
         (StateT MigrationState Transaction)
         Bool)
-> ExceptT
     (TrySyncResult CausalHashId)
     (StateT MigrationState Transaction)
     [CausalHashId]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (CausalHashId
 -> ExceptT
      (TrySyncResult CausalHashId)
      (StateT MigrationState Transaction)
      Bool)
-> [CausalHashId]
-> ExceptT
     (TrySyncResult CausalHashId)
     (StateT MigrationState Transaction)
     [CausalHashId]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM [CausalHashId]
causalParents ((CausalHashId
  -> ExceptT
       (TrySyncResult CausalHashId)
       (StateT MigrationState Transaction)
       Bool)
 -> ExceptT
      (TrySyncResult CausalHashId)
      (StateT MigrationState Transaction)
      [CausalHashId])
-> (CausalHashId
    -> ExceptT
         (TrySyncResult CausalHashId)
         (StateT MigrationState Transaction)
         Bool)
-> ExceptT
     (TrySyncResult CausalHashId)
     (StateT MigrationState Transaction)
     [CausalHashId]
forall a b. (a -> b) -> a -> b
$ \CausalHashId
parentHashId -> (LensLike'
  (Const Bool)
  MigrationState
  (Map CausalHashId (BranchHashId, BranchObjectId))
-> (Map CausalHashId (BranchHashId, BranchObjectId) -> Bool)
-> ExceptT
     (TrySyncResult CausalHashId)
     (StateT MigrationState Transaction)
     Bool
forall s (m :: * -> *) r a.
MonadState s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
uses LensLike'
  (Const Bool)
  MigrationState
  (Map CausalHashId (BranchHashId, BranchObjectId))
Lens'
  MigrationState (Map CausalHashId (BranchHashId, BranchObjectId))
canonicalBranchForCausalHashId (CausalHashId
-> Map CausalHashId (BranchHashId, BranchObjectId) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.notMember CausalHashId
parentHashId))
      Bool
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool)
-> ([CausalHashId] -> Bool) -> [CausalHashId] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CausalHashId] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([CausalHashId] -> Bool) -> [CausalHashId] -> Bool
forall a b. (a -> b) -> a -> b
$ [CausalHashId]
unmigratedParents) (ExceptT
   (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
 -> ExceptT
      (TrySyncResult CausalHashId)
      (StateT MigrationState Transaction)
      ())
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall a b. (a -> b) -> a -> b
$ TrySyncResult CausalHashId
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall a.
TrySyncResult CausalHashId
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ([CausalHashId] -> TrySyncResult CausalHashId
forall entity. [entity] -> TrySyncResult entity
Sync.Missing [CausalHashId]
unmigratedParents)
      BranchHashId
valueHashId <- Transaction BranchHashId
-> ExceptT
     (TrySyncResult CausalHashId)
     (StateT MigrationState Transaction)
     BranchHashId
forall a.
Transaction a
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) a
liftT (Transaction BranchHashId
 -> ExceptT
      (TrySyncResult CausalHashId)
      (StateT MigrationState Transaction)
      BranchHashId)
-> Transaction BranchHashId
-> ExceptT
     (TrySyncResult CausalHashId)
     (StateT MigrationState Transaction)
     BranchHashId
forall a b. (a -> b) -> a -> b
$ CausalHashId -> Transaction BranchHashId
Q.expectCausalValueHashId CausalHashId
causalHashId
      Getting (First BranchObjectId) MigrationState BranchObjectId
-> ExceptT
     (TrySyncResult CausalHashId)
     (StateT MigrationState Transaction)
     (Maybe BranchObjectId)
forall s (m :: * -> *) a.
MonadState s m =>
Getting (First a) s a -> m (Maybe a)
preuse ((Map BranchHashId BranchObjectId
 -> Const (First BranchObjectId) (Map BranchHashId BranchObjectId))
-> MigrationState -> Const (First BranchObjectId) MigrationState
Lens' MigrationState (Map BranchHashId BranchObjectId)
validBranchHashIds ((Map BranchHashId BranchObjectId
  -> Const (First BranchObjectId) (Map BranchHashId BranchObjectId))
 -> MigrationState -> Const (First BranchObjectId) MigrationState)
-> ((BranchObjectId -> Const (First BranchObjectId) BranchObjectId)
    -> Map BranchHashId BranchObjectId
    -> Const (First BranchObjectId) (Map BranchHashId BranchObjectId))
-> Getting (First BranchObjectId) MigrationState BranchObjectId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map BranchHashId BranchObjectId)
-> Traversal'
     (Map BranchHashId BranchObjectId)
     (IxValue (Map BranchHashId BranchObjectId))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Index (Map BranchHashId BranchObjectId)
BranchHashId
valueHashId) ExceptT
  (TrySyncResult CausalHashId)
  (StateT MigrationState Transaction)
  (Maybe BranchObjectId)
-> (Maybe BranchObjectId
    -> ExceptT
         (TrySyncResult CausalHashId)
         (StateT MigrationState Transaction)
         ())
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall a b.
ExceptT
  (TrySyncResult CausalHashId) (StateT MigrationState Transaction) a
-> (a
    -> ExceptT
         (TrySyncResult CausalHashId) (StateT MigrationState Transaction) b)
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe BranchObjectId
Nothing -> ()
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall a.
a
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just BranchObjectId
objId -> do
          (Map CausalHashId (BranchHashId, BranchObjectId)
 -> Identity (Map CausalHashId (BranchHashId, BranchObjectId)))
-> MigrationState -> Identity MigrationState
Lens'
  MigrationState (Map CausalHashId (BranchHashId, BranchObjectId))
canonicalBranchForCausalHashId ((Map CausalHashId (BranchHashId, BranchObjectId)
  -> Identity (Map CausalHashId (BranchHashId, BranchObjectId)))
 -> MigrationState -> Identity MigrationState)
-> ((Maybe (BranchHashId, BranchObjectId)
     -> Identity (Maybe (BranchHashId, BranchObjectId)))
    -> Map CausalHashId (BranchHashId, BranchObjectId)
    -> Identity (Map CausalHashId (BranchHashId, BranchObjectId)))
-> (Maybe (BranchHashId, BranchObjectId)
    -> Identity (Maybe (BranchHashId, BranchObjectId)))
-> MigrationState
-> Identity MigrationState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map CausalHashId (BranchHashId, BranchObjectId))
-> Lens'
     (Map CausalHashId (BranchHashId, BranchObjectId))
     (Maybe (IxValue (Map CausalHashId (BranchHashId, BranchObjectId))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map CausalHashId (BranchHashId, BranchObjectId))
CausalHashId
causalHashId ((Maybe (BranchHashId, BranchObjectId)
  -> Identity (Maybe (BranchHashId, BranchObjectId)))
 -> MigrationState -> Identity MigrationState)
-> (BranchHashId, BranchObjectId)
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a (Maybe b) -> b -> m ()
?= (BranchHashId
valueHashId, BranchObjectId
objId)
          TrySyncResult CausalHashId
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall a.
TrySyncResult CausalHashId
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError TrySyncResult CausalHashId
forall entity. TrySyncResult entity
Sync.Done
      Transaction (Maybe BranchObjectId)
-> ExceptT
     (TrySyncResult CausalHashId)
     (StateT MigrationState Transaction)
     (Maybe BranchObjectId)
forall a.
Transaction a
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) a
liftT (CausalHashId -> Transaction (Maybe BranchObjectId)
Q.loadBranchObjectIdByCausalHashId CausalHashId
causalHashId) ExceptT
  (TrySyncResult CausalHashId)
  (StateT MigrationState Transaction)
  (Maybe BranchObjectId)
-> (Maybe BranchObjectId
    -> ExceptT
         (TrySyncResult CausalHashId)
         (StateT MigrationState Transaction)
         ())
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall a b.
ExceptT
  (TrySyncResult CausalHashId) (StateT MigrationState Transaction) a
-> (a
    -> ExceptT
         (TrySyncResult CausalHashId) (StateT MigrationState Transaction) b)
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe BranchObjectId
Nothing -> do
          Transaction ()
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall a.
Transaction a
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) a
liftT (Transaction ()
 -> ExceptT
      (TrySyncResult CausalHashId)
      (StateT MigrationState Transaction)
      ())
-> (String -> Transaction ())
-> String
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Transaction ()
forall a. String -> Transaction a
abortMigration (String
 -> ExceptT
      (TrySyncResult CausalHashId)
      (StateT MigrationState Transaction)
      ())
-> String
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall a b. (a -> b) -> a -> b
$ String
"Missing object for child branch of causal: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> CausalHashId -> String
forall a. Show a => a -> String
show CausalHashId
causalHashId
        Just BranchObjectId
branchObjId -> do
          CausalHashId
-> BranchHashId
-> BranchObjectId
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
rehashAndCanonicalizeNamespace CausalHashId
causalHashId BranchHashId
valueHashId BranchObjectId
branchObjId

rehashAndCanonicalizeNamespace :: DB.CausalHashId -> DB.BranchHashId -> DB.BranchObjectId -> ExceptT (Sync.TrySyncResult DB.CausalHashId) (StateT MigrationState Sqlite.Transaction) ()
rehashAndCanonicalizeNamespace :: CausalHashId
-> BranchHashId
-> BranchObjectId
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
rehashAndCanonicalizeNamespace CausalHashId
causalHashId BranchHashId
possiblyIncorrectNamespaceHashId BranchObjectId
objId = do
  DbBranch
dbBranch <- Transaction DbBranch
-> ExceptT
     (TrySyncResult CausalHashId)
     (StateT MigrationState Transaction)
     DbBranch
forall a.
Transaction a
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) a
liftT (Transaction DbBranch
 -> ExceptT
      (TrySyncResult CausalHashId)
      (StateT MigrationState Transaction)
      DbBranch)
-> Transaction DbBranch
-> ExceptT
     (TrySyncResult CausalHashId)
     (StateT MigrationState Transaction)
     DbBranch
forall a b. (a -> b) -> a -> b
$ BranchObjectId -> Transaction DbBranch
Ops.expectDbBranch BranchObjectId
objId
  Map CausalHashId (BranchHashId, BranchObjectId)
canonicalBranchForCausalMap <- Getting
  (Map CausalHashId (BranchHashId, BranchObjectId))
  MigrationState
  (Map CausalHashId (BranchHashId, BranchObjectId))
-> ExceptT
     (TrySyncResult CausalHashId)
     (StateT MigrationState Transaction)
     (Map CausalHashId (BranchHashId, BranchObjectId))
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting
  (Map CausalHashId (BranchHashId, BranchObjectId))
  MigrationState
  (Map CausalHashId (BranchHashId, BranchObjectId))
Lens'
  MigrationState (Map CausalHashId (BranchHashId, BranchObjectId))
canonicalBranchForCausalHashId
  -- remap all of the object ID's of the child branches to the correct and canonical objects,
  -- get a list of any unmigrated children, and also track whether any re-mappings actually
  -- occurred, so we don't do extra work when nothing changed.
  let (([CausalHashId]
unmigratedChildren, Any Bool
changes), DbBranch
remappedBranch) =
        DbBranch
dbBranch
          DbBranch
-> (DbBranch -> (([CausalHashId], Any), DbBranch))
-> (([CausalHashId], Any), DbBranch)
forall a b. a -> (a -> b) -> b
& ((BranchObjectId, CausalHashId)
 -> (([CausalHashId], Any), (BranchObjectId, CausalHashId)))
-> DbBranch -> (([CausalHashId], Any), DbBranch)
forall t h p c c' (f :: * -> *).
Applicative f =>
(c -> f c') -> Branch' t h p c -> f (Branch' t h p c')
DBBranch.childrenHashes_ (((BranchObjectId, CausalHashId)
  -> (([CausalHashId], Any), (BranchObjectId, CausalHashId)))
 -> DbBranch -> (([CausalHashId], Any), DbBranch))
-> ((BranchObjectId, CausalHashId)
    -> (([CausalHashId], Any), (BranchObjectId, CausalHashId)))
-> DbBranch
-> (([CausalHashId], Any), DbBranch)
forall {k} (f :: k -> *) s (t :: k) a (b :: k).
LensLike f s t a b -> LensLike f s t a b
%%~ \(ids :: (BranchObjectId, CausalHashId)
ids@(BranchObjectId
childBranchObjId, CausalHashId
childCausalHashId)) -> do
            case CausalHashId
-> Map CausalHashId (BranchHashId, BranchObjectId)
-> Maybe (BranchHashId, BranchObjectId)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CausalHashId
childCausalHashId Map CausalHashId (BranchHashId, BranchObjectId)
canonicalBranchForCausalMap of
              Maybe (BranchHashId, BranchObjectId)
Nothing -> (([CausalHashId
childCausalHashId], Bool -> Any
Any Bool
False), (BranchObjectId, CausalHashId)
ids)
              Just (BranchHashId
_, BranchObjectId
canonicalObjId) ->
                let changed :: Bool
changed = BranchObjectId
canonicalObjId BranchObjectId -> BranchObjectId -> Bool
forall a. Eq a => a -> a -> Bool
/= BranchObjectId
childBranchObjId
                 in (([], Bool -> Any
Any Bool
changed), (BranchObjectId
canonicalObjId, CausalHashId
childCausalHashId))
  Bool
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool)
-> ([CausalHashId] -> Bool) -> [CausalHashId] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CausalHashId] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([CausalHashId] -> Bool) -> [CausalHashId] -> Bool
forall a b. (a -> b) -> a -> b
$ [CausalHashId]
unmigratedChildren) (ExceptT
   (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
 -> ExceptT
      (TrySyncResult CausalHashId)
      (StateT MigrationState Transaction)
      ())
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall a b. (a -> b) -> a -> b
$ TrySyncResult CausalHashId
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall a.
TrySyncResult CausalHashId
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ([CausalHashId] -> TrySyncResult CausalHashId
forall entity. [entity] -> TrySyncResult entity
Sync.Missing [CausalHashId]
unmigratedChildren)
  Bool
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
changes (ExceptT
   (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
 -> ExceptT
      (TrySyncResult CausalHashId)
      (StateT MigrationState Transaction)
      ())
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall a b. (a -> b) -> a -> b
$ do
    Transaction ()
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall a.
Transaction a
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) a
liftT (Transaction ()
 -> ExceptT
      (TrySyncResult CausalHashId)
      (StateT MigrationState Transaction)
      ())
-> Transaction ()
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall a b. (a -> b) -> a -> b
$ BranchObjectId -> DbBranch -> Transaction ()
replaceBranch BranchObjectId
objId DbBranch
remappedBranch
  BranchHash
correctNamespaceHash <- Transaction BranchHash
-> ExceptT
     (TrySyncResult CausalHashId)
     (StateT MigrationState Transaction)
     BranchHash
forall a.
Transaction a
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) a
liftT (Transaction BranchHash
 -> ExceptT
      (TrySyncResult CausalHashId)
      (StateT MigrationState Transaction)
      BranchHash)
-> Transaction BranchHash
-> ExceptT
     (TrySyncResult CausalHashId)
     (StateT MigrationState Transaction)
     BranchHash
forall a b. (a -> b) -> a -> b
$ DbBranch -> Transaction BranchHash
Helpers.dbBranchHash DbBranch
remappedBranch
  Transaction ()
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall a.
Transaction a
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) a
liftT (Transaction ()
 -> ExceptT
      (TrySyncResult CausalHashId)
      (StateT MigrationState Transaction)
      ())
-> (String -> Transaction ())
-> String
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Transaction ()
debugLog (String
 -> ExceptT
      (TrySyncResult CausalHashId)
      (StateT MigrationState Transaction)
      ())
-> String
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall a b. (a -> b) -> a -> b
$ String
"Correct namespace hash: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> BranchHash -> String
forall a. Show a => a -> String
show BranchHash
correctNamespaceHash
  BranchHashId
correctNamespaceHashId <- Transaction BranchHashId
-> ExceptT
     (TrySyncResult CausalHashId)
     (StateT MigrationState Transaction)
     BranchHashId
forall a.
Transaction a
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) a
liftT (Transaction BranchHashId
 -> ExceptT
      (TrySyncResult CausalHashId)
      (StateT MigrationState Transaction)
      BranchHashId)
-> Transaction BranchHashId
-> ExceptT
     (TrySyncResult CausalHashId)
     (StateT MigrationState Transaction)
     BranchHashId
forall a b. (a -> b) -> a -> b
$ BranchHash -> Transaction BranchHashId
Q.saveBranchHash BranchHash
correctNamespaceHash

  Bool
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BranchHashId
correctNamespaceHashId BranchHashId -> BranchHashId -> Bool
forall a. Eq a => a -> a -> Bool
== BranchHashId
possiblyIncorrectNamespaceHashId) (ExceptT
   (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
 -> ExceptT
      (TrySyncResult CausalHashId)
      (StateT MigrationState Transaction)
      ())
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall a b. (a -> b) -> a -> b
$ do
    -- If the existing hash for this namespace was already correct, we don't need to
    -- canonicalize the branch or worry about deleting/updating bad objects.
    -- We just record the mapping and move on.
    (Map CausalHashId (BranchHashId, BranchObjectId)
 -> Identity (Map CausalHashId (BranchHashId, BranchObjectId)))
-> MigrationState -> Identity MigrationState
Lens'
  MigrationState (Map CausalHashId (BranchHashId, BranchObjectId))
canonicalBranchForCausalHashId ((Map CausalHashId (BranchHashId, BranchObjectId)
  -> Identity (Map CausalHashId (BranchHashId, BranchObjectId)))
 -> MigrationState -> Identity MigrationState)
-> ((Maybe (BranchHashId, BranchObjectId)
     -> Identity (Maybe (BranchHashId, BranchObjectId)))
    -> Map CausalHashId (BranchHashId, BranchObjectId)
    -> Identity (Map CausalHashId (BranchHashId, BranchObjectId)))
-> (Maybe (BranchHashId, BranchObjectId)
    -> Identity (Maybe (BranchHashId, BranchObjectId)))
-> MigrationState
-> Identity MigrationState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map CausalHashId (BranchHashId, BranchObjectId))
-> Lens'
     (Map CausalHashId (BranchHashId, BranchObjectId))
     (Maybe (IxValue (Map CausalHashId (BranchHashId, BranchObjectId))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map CausalHashId (BranchHashId, BranchObjectId))
CausalHashId
causalHashId ((Maybe (BranchHashId, BranchObjectId)
  -> Identity (Maybe (BranchHashId, BranchObjectId)))
 -> MigrationState -> Identity MigrationState)
-> (BranchHashId, BranchObjectId)
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a (Maybe b) -> b -> m ()
?= (BranchHashId
correctNamespaceHashId, BranchObjectId
objId)
    (Map BranchHashId BranchObjectId
 -> Identity (Map BranchHashId BranchObjectId))
-> MigrationState -> Identity MigrationState
Lens' MigrationState (Map BranchHashId BranchObjectId)
validBranchHashIds ((Map BranchHashId BranchObjectId
  -> Identity (Map BranchHashId BranchObjectId))
 -> MigrationState -> Identity MigrationState)
-> ((Maybe BranchObjectId -> Identity (Maybe BranchObjectId))
    -> Map BranchHashId BranchObjectId
    -> Identity (Map BranchHashId BranchObjectId))
-> (Maybe BranchObjectId -> Identity (Maybe BranchObjectId))
-> MigrationState
-> Identity MigrationState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map BranchHashId BranchObjectId)
-> Lens'
     (Map BranchHashId BranchObjectId)
     (Maybe (IxValue (Map BranchHashId BranchObjectId)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map BranchHashId BranchObjectId)
BranchHashId
possiblyIncorrectNamespaceHashId ((Maybe BranchObjectId -> Identity (Maybe BranchObjectId))
 -> MigrationState -> Identity MigrationState)
-> BranchObjectId
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a (Maybe b) -> b -> m ()
?= BranchObjectId
objId
    TrySyncResult CausalHashId
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall a.
TrySyncResult CausalHashId
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError TrySyncResult CausalHashId
forall entity. TrySyncResult entity
Sync.Done

  -- Update the value_hash_id on the causal to the correct hash for the branch
  Transaction ()
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall a.
Transaction a
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) a
liftT (Transaction ()
 -> ExceptT
      (TrySyncResult CausalHashId)
      (StateT MigrationState Transaction)
      ())
-> Transaction ()
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall a b. (a -> b) -> a -> b
$ BranchHashId -> BranchHashId -> Transaction ()
updateCausalValueHash BranchHashId
correctNamespaceHashId BranchHashId
possiblyIncorrectNamespaceHashId
  -- It's possible that an object already exists for this new hash
  Maybe BranchObjectId
mayCanonical <- BranchHashId
-> ExceptT
     (TrySyncResult CausalHashId)
     (StateT MigrationState Transaction)
     (Maybe BranchObjectId)
getCanonicalObjectForHash BranchHashId
correctNamespaceHashId
  Transaction ()
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall a.
Transaction a
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) a
liftT (Transaction ()
 -> ExceptT
      (TrySyncResult CausalHashId)
      (StateT MigrationState Transaction)
      ())
-> (String -> Transaction ())
-> String
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Transaction ()
debugLog (String
 -> ExceptT
      (TrySyncResult CausalHashId)
      (StateT MigrationState Transaction)
      ())
-> String
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall a b. (a -> b) -> a -> b
$ String
"(objId, Canonical object ID):" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (BranchObjectId, Maybe BranchObjectId) -> String
forall a. Show a => a -> String
show (BranchObjectId
objId, Maybe BranchObjectId
mayCanonical)
  Transaction ()
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall a.
Transaction a
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) a
liftT (Transaction ()
 -> ExceptT
      (TrySyncResult CausalHashId)
      (StateT MigrationState Transaction)
      ())
-> (String -> Transaction ())
-> String
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Transaction ()
debugLog (String
 -> ExceptT
      (TrySyncResult CausalHashId)
      (StateT MigrationState Transaction)
      ())
-> String
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall a b. (a -> b) -> a -> b
$ String
"Updating causal value hash (from, to)" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (BranchHashId, BranchHashId) -> String
forall a. Show a => a -> String
show (BranchHashId
possiblyIncorrectNamespaceHashId, BranchHashId
correctNamespaceHashId)
  BranchObjectId
canonicalObjId <- case Maybe BranchObjectId
mayCanonical of
    -- If there's an existing canonical object, record the mapping from this object id to
    -- that one.
    Just BranchObjectId
canonicalObjectId
      | BranchObjectId
canonicalObjectId BranchObjectId -> BranchObjectId -> Bool
forall a. Eq a => a -> a -> Bool
/= BranchObjectId
objId -> do
          -- Found an existing but different object with this hash, so the current object is a duplicate and
          -- needs to be deleted.
          Transaction ()
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall a.
Transaction a
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) a
liftT (Transaction ()
 -> ExceptT
      (TrySyncResult CausalHashId)
      (StateT MigrationState Transaction)
      ())
-> (String -> Transaction ())
-> String
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Transaction ()
debugLog (String
 -> ExceptT
      (TrySyncResult CausalHashId)
      (StateT MigrationState Transaction)
      ())
-> String
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall a b. (a -> b) -> a -> b
$ String
"Mapping objID: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> BranchObjectId -> String
forall a. Show a => a -> String
show BranchObjectId
objId String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" to canonical: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> BranchObjectId -> String
forall a. Show a => a -> String
show BranchObjectId
canonicalObjectId
          Transaction ()
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall a.
Transaction a
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) a
liftT (Transaction ()
 -> ExceptT
      (TrySyncResult CausalHashId)
      (StateT MigrationState Transaction)
      ())
-> (String -> Transaction ())
-> String
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Transaction ()
debugLog (String
 -> ExceptT
      (TrySyncResult CausalHashId)
      (StateT MigrationState Transaction)
      ())
-> String
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall a b. (a -> b) -> a -> b
$ String
"Unilaterally deleting: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> BranchObjectId -> String
forall a. Show a => a -> String
show BranchObjectId
objId
          -- Remove possible foreign-key references before deleting the objects themselves
          Transaction ()
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall a.
Transaction a
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) a
liftT (Transaction ()
 -> ExceptT
      (TrySyncResult CausalHashId)
      (StateT MigrationState Transaction)
      ())
-> Transaction ()
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall a b. (a -> b) -> a -> b
$ BranchObjectId -> Transaction ()
forall {a}. ToField a => a -> Transaction ()
deleteHashObjectsByObjectId BranchObjectId
objId
          Transaction ()
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall a.
Transaction a
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) a
liftT (Transaction ()
 -> ExceptT
      (TrySyncResult CausalHashId)
      (StateT MigrationState Transaction)
      ())
-> Transaction ()
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall a b. (a -> b) -> a -> b
$ BranchObjectId -> Transaction ()
forall {a}. ToField a => a -> Transaction ()
deleteObjectById BranchObjectId
objId
          pure BranchObjectId
canonicalObjectId
      | Bool
otherwise -> do
          -- This should be impossible.
          String
-> ExceptT
     (TrySyncResult CausalHashId)
     (StateT MigrationState Transaction)
     BranchObjectId
forall a. HasCallStack => String -> a
error (String
 -> ExceptT
      (TrySyncResult CausalHashId)
      (StateT MigrationState Transaction)
      BranchObjectId)
-> String
-> ExceptT
     (TrySyncResult CausalHashId)
     (StateT MigrationState Transaction)
     BranchObjectId
forall a b. (a -> b) -> a -> b
$ String
"We proved that the new hash is different from the existing one, but somehow found the same object for each hash. Please report this as a bug." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (BranchObjectId, BranchObjectId) -> String
forall a. Show a => a -> String
show (BranchObjectId
objId, BranchObjectId
canonicalObjectId)
    Maybe BranchObjectId
Nothing -> do
      -- There's no existing canonical object, this object BECOMES the canonical one by
      -- reassigning its primary hash.
      Transaction ()
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall a.
Transaction a
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) a
liftT (Transaction ()
 -> ExceptT
      (TrySyncResult CausalHashId)
      (StateT MigrationState Transaction)
      ())
-> (String -> Transaction ())
-> String
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Transaction ()
debugLog (String
 -> ExceptT
      (TrySyncResult CausalHashId)
      (StateT MigrationState Transaction)
      ())
-> String
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall a b. (a -> b) -> a -> b
$ String
"Updating in place: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> BranchObjectId -> String
forall a. Show a => a -> String
show BranchObjectId
objId
      Transaction ()
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall a.
Transaction a
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) a
liftT (Transaction ()
 -> ExceptT
      (TrySyncResult CausalHashId)
      (StateT MigrationState Transaction)
      ())
-> Transaction ()
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall a b. (a -> b) -> a -> b
$ BranchObjectId -> Transaction ()
forall {a}. ToField a => a -> Transaction ()
deleteHashObjectsByObjectId BranchObjectId
objId
      Transaction ()
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall a.
Transaction a
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) a
liftT (Transaction ()
 -> ExceptT
      (TrySyncResult CausalHashId)
      (StateT MigrationState Transaction)
      ())
-> Transaction ()
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall a b. (a -> b) -> a -> b
$ BranchHashId -> BranchObjectId -> Transaction ()
forall {a} {a}. (ToField a, ToField a) => a -> a -> Transaction ()
updateHashIdForObject BranchHashId
correctNamespaceHashId BranchObjectId
objId
      Transaction ()
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall a.
Transaction a
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) a
liftT (Transaction ()
 -> ExceptT
      (TrySyncResult CausalHashId)
      (StateT MigrationState Transaction)
      ())
-> Transaction ()
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall a b. (a -> b) -> a -> b
$ HashId -> ObjectId -> HashVersion -> Transaction ()
Q.saveHashObject (BranchHashId -> HashId
DB.unBranchHashId BranchHashId
correctNamespaceHashId) (BranchObjectId -> ObjectId
DB.unBranchObjectId BranchObjectId
objId) HashVersion
2
      pure BranchObjectId
objId
  -- Save the canonical branch info for the causal for use in remappings.
  (Map CausalHashId (BranchHashId, BranchObjectId)
 -> Identity (Map CausalHashId (BranchHashId, BranchObjectId)))
-> MigrationState -> Identity MigrationState
Lens'
  MigrationState (Map CausalHashId (BranchHashId, BranchObjectId))
canonicalBranchForCausalHashId ((Map CausalHashId (BranchHashId, BranchObjectId)
  -> Identity (Map CausalHashId (BranchHashId, BranchObjectId)))
 -> MigrationState -> Identity MigrationState)
-> ((Maybe (BranchHashId, BranchObjectId)
     -> Identity (Maybe (BranchHashId, BranchObjectId)))
    -> Map CausalHashId (BranchHashId, BranchObjectId)
    -> Identity (Map CausalHashId (BranchHashId, BranchObjectId)))
-> (Maybe (BranchHashId, BranchObjectId)
    -> Identity (Maybe (BranchHashId, BranchObjectId)))
-> MigrationState
-> Identity MigrationState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map CausalHashId (BranchHashId, BranchObjectId))
-> Lens'
     (Map CausalHashId (BranchHashId, BranchObjectId))
     (Maybe (IxValue (Map CausalHashId (BranchHashId, BranchObjectId))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map CausalHashId (BranchHashId, BranchObjectId))
CausalHashId
causalHashId ((Maybe (BranchHashId, BranchObjectId)
  -> Identity (Maybe (BranchHashId, BranchObjectId)))
 -> MigrationState -> Identity MigrationState)
-> (BranchHashId, BranchObjectId)
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a (Maybe b) -> b -> m ()
?= (BranchHashId
correctNamespaceHashId, BranchObjectId
canonicalObjId)
  where
    updateCausalValueHash :: DB.BranchHashId -> DB.BranchHashId -> Sqlite.Transaction ()
    updateCausalValueHash :: BranchHashId -> BranchHashId -> Transaction ()
updateCausalValueHash BranchHashId
correctNamespaceHashId BranchHashId
possiblyIncorrectNamespaceHashId =
      HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
Sqlite.execute
        [Sqlite.sql|
          UPDATE causal
            SET value_hash_id = :correctNamespaceHashId
            WHERE value_hash_id = :possiblyIncorrectNamespaceHashId
        |]

    getCanonicalObjectForHash ::
      DB.BranchHashId ->
      ExceptT
        (Sync.TrySyncResult DB.CausalHashId)
        (StateT MigrationState Sqlite.Transaction)
        (Maybe DB.BranchObjectId)
    getCanonicalObjectForHash :: BranchHashId
-> ExceptT
     (TrySyncResult CausalHashId)
     (StateT MigrationState Transaction)
     (Maybe BranchObjectId)
getCanonicalObjectForHash BranchHashId
namespaceHashId =
      Transaction (Maybe BranchObjectId)
-> ExceptT
     (TrySyncResult CausalHashId)
     (StateT MigrationState Transaction)
     (Maybe BranchObjectId)
forall a.
Transaction a
-> ExceptT
     (TrySyncResult CausalHashId) (StateT MigrationState Transaction) a
liftT (Transaction (Maybe BranchObjectId)
 -> ExceptT
      (TrySyncResult CausalHashId)
      (StateT MigrationState Transaction)
      (Maybe BranchObjectId))
-> Transaction (Maybe BranchObjectId)
-> ExceptT
     (TrySyncResult CausalHashId)
     (StateT MigrationState Transaction)
     (Maybe BranchObjectId)
forall a b. (a -> b) -> a -> b
$
        Sql -> Transaction (Maybe BranchObjectId)
forall a.
(FromField a, HasCallStack) =>
Sql -> Transaction (Maybe a)
Sqlite.queryMaybeCol
          [Sqlite.sql|
            SELECT id
              FROM object
              WHERE primary_hash_id = :namespaceHashId
          |]

    updateHashIdForObject :: a -> a -> Transaction ()
updateHashIdForObject a
hashId a
objId =
      HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
Sqlite.execute
        [Sqlite.sql|
          UPDATE object
            SET primary_hash_id = :hashId
            WHERE id = :objId
        |]

    -- Replace the bytes payload of a given branch in-place.
    -- This does NOT update the hash of the object.
    replaceBranch :: DB.BranchObjectId -> DBBranch.DbBranch -> Sqlite.Transaction ()
    replaceBranch :: BranchObjectId -> DbBranch -> Transaction ()
replaceBranch BranchObjectId
objId DbBranch
branch = do
      let (BranchLocalIds
localBranchIds, LocalBranch
localBranch) = DbBranch -> (BranchLocalIds, LocalBranch)
S.LocalizeObject.localizeBranch DbBranch
branch
      let bytes :: ByteString
bytes = Put
  (BranchFormat'
     TextId
     ObjectId
     PatchObjectId
     (BranchObjectId, CausalHashId)
     BranchObjectId)
-> BranchFormat'
     TextId
     ObjectId
     PatchObjectId
     (BranchObjectId, CausalHashId)
     BranchObjectId
-> ByteString
forall a. Put a -> a -> ByteString
S.putBytes BranchFormat'
  TextId
  ObjectId
  PatchObjectId
  (BranchObjectId, CausalHashId)
  BranchObjectId
-> m ()
Put
  (BranchFormat'
     TextId
     ObjectId
     PatchObjectId
     (BranchObjectId, CausalHashId)
     BranchObjectId)
S.putBranchFormat (BranchFormat'
   TextId
   ObjectId
   PatchObjectId
   (BranchObjectId, CausalHashId)
   BranchObjectId
 -> ByteString)
-> BranchFormat'
     TextId
     ObjectId
     PatchObjectId
     (BranchObjectId, CausalHashId)
     BranchObjectId
-> ByteString
forall a b. (a -> b) -> a -> b
$ BranchLocalIds
-> LocalBranch
-> BranchFormat'
     TextId
     ObjectId
     PatchObjectId
     (BranchObjectId, CausalHashId)
     BranchObjectId
forall text defRef patchRef childRef branchRef.
BranchLocalIds' text defRef patchRef childRef
-> LocalBranch
-> BranchFormat' text defRef patchRef childRef branchRef
S.BranchFormat.Full BranchLocalIds
localBranchIds LocalBranch
localBranch
      HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
Sqlite.execute
        [Sqlite.sql|
          UPDATE object
          SET bytes = :bytes
          WHERE id = :objId
        |]

    deleteHashObjectsByObjectId :: a -> Transaction ()
deleteHashObjectsByObjectId a
objId =
      HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
Sqlite.execute
        [Sqlite.sql|
          DELETE FROM hash_object
            WHERE object_id = :objId
        |]

    deleteObjectById :: a -> Transaction ()
deleteObjectById a
objId =
      HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
Sqlite.execute
        [Sqlite.sql|
          DELETE FROM object
            WHERE id = :objId
        |]

log :: String -> Sqlite.Transaction ()
log :: String -> Transaction ()
log = IO () -> Transaction ()
forall a. HasCallStack => IO a -> Transaction a
Sqlite.unsafeIO (IO () -> Transaction ())
-> (String -> IO ()) -> String -> Transaction ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn

debugLog :: String -> Sqlite.Transaction ()
debugLog :: String -> Transaction ()
debugLog = DebugFlag -> Transaction () -> Transaction ()
forall (m :: * -> *). Monad m => DebugFlag -> m () -> m ()
Debug.whenDebug DebugFlag
Debug.Migration (Transaction () -> Transaction ())
-> (String -> Transaction ()) -> String -> Transaction ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> Transaction ()
forall a. HasCallStack => IO a -> Transaction a
Sqlite.unsafeIO (IO () -> Transaction ())
-> (String -> IO ()) -> String -> Transaction ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn