{-# LANGUAGE QuasiQuotes #-}

-- | There are many invariants we expect to hold in our sqlite database and on codebase
-- objects which we can't maintain using database checks. This module performs checks for some
-- of these invariants, which can be useful to run after performing potentially dangerous
-- operations like migrations.
module Unison.Codebase.IntegrityCheck
  ( integrityCheckFullCodebase,
    integrityCheckAllBranches,
    integrityCheckAllCausals,
    prettyPrintIntegrityErrors,
    IntegrityResult (..),
  )
where

import Control.Lens
import Data.List.NonEmpty qualified as NEList
import Data.Set qualified as Set
import Data.Set.NonEmpty (NESet)
import Data.Set.NonEmpty qualified as NESet
import Data.Text.Lazy qualified as TL
import Data.Text.Lazy.IO qualified as TL
import Data.Void
import Text.Pretty.Simple
import U.Codebase.HashTags (BranchHash (..))
import U.Codebase.Sqlite.Branch.Full qualified as DBBranch
import U.Codebase.Sqlite.DbId qualified as DB
import U.Codebase.Sqlite.Operations qualified as Ops
import U.Codebase.Sqlite.Queries qualified as Q
import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2.DbHelpers qualified as Helpers
import Unison.Debug qualified as Debug
import Unison.Hash (Hash)
import Unison.Hash qualified as Hash
import Unison.Prelude
import Unison.Sqlite qualified as Sqlite
import Unison.Util.Monoid (foldMapM)
import Unison.Util.Pretty qualified as P
import Prelude hiding (log)

debugLog :: TL.Text -> Sqlite.Transaction ()
debugLog :: Text -> Transaction ()
debugLog Text
msg = DebugFlag -> Transaction () -> Transaction ()
forall (m :: * -> *). Monad m => DebugFlag -> m () -> m ()
Debug.whenDebug DebugFlag
Debug.Integrity (Transaction () -> Transaction ())
-> Transaction () -> Transaction ()
forall a b. (a -> b) -> a -> b
$ Text -> Transaction ()
logInfo Text
msg

logInfo :: TL.Text -> Sqlite.Transaction ()
logInfo :: Text -> Transaction ()
logInfo Text
msg = IO () -> Transaction ()
forall a. HasCallStack => IO a -> Transaction a
Sqlite.unsafeIO (IO () -> Transaction ()) -> IO () -> Transaction ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
TL.putStrLn Text
msg

logError :: TL.Text -> Sqlite.Transaction ()
logError :: Text -> Transaction ()
logError Text
msg = Text -> Transaction ()
logInfo (Text -> Transaction ()) -> Text -> Transaction ()
forall a b. (a -> b) -> a -> b
$ Text
"  ⚠️   " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg

data IntegrityError
  = DetectedObjectsWithoutCorrespondingHashObjects (NESet DB.ObjectId)
  | -- (causal hash, branch hash)
    DetectedCausalsWithoutCorrespondingBranchObjects (NESet (Hash, Hash))
  | DetectedCausalsWithCausalHashAsBranchHash (NESet Hash)
  | DetectedBranchErrors BranchHash (NESet BranchError)
  deriving stock (Int -> IntegrityError -> ShowS
[IntegrityError] -> ShowS
IntegrityError -> String
(Int -> IntegrityError -> ShowS)
-> (IntegrityError -> String)
-> ([IntegrityError] -> ShowS)
-> Show IntegrityError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IntegrityError -> ShowS
showsPrec :: Int -> IntegrityError -> ShowS
$cshow :: IntegrityError -> String
show :: IntegrityError -> String
$cshowList :: [IntegrityError] -> ShowS
showList :: [IntegrityError] -> ShowS
Show, IntegrityError -> IntegrityError -> Bool
(IntegrityError -> IntegrityError -> Bool)
-> (IntegrityError -> IntegrityError -> Bool) -> Eq IntegrityError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IntegrityError -> IntegrityError -> Bool
== :: IntegrityError -> IntegrityError -> Bool
$c/= :: IntegrityError -> IntegrityError -> Bool
/= :: IntegrityError -> IntegrityError -> Bool
Eq, Eq IntegrityError
Eq IntegrityError =>
(IntegrityError -> IntegrityError -> Ordering)
-> (IntegrityError -> IntegrityError -> Bool)
-> (IntegrityError -> IntegrityError -> Bool)
-> (IntegrityError -> IntegrityError -> Bool)
-> (IntegrityError -> IntegrityError -> Bool)
-> (IntegrityError -> IntegrityError -> IntegrityError)
-> (IntegrityError -> IntegrityError -> IntegrityError)
-> Ord IntegrityError
IntegrityError -> IntegrityError -> Bool
IntegrityError -> IntegrityError -> Ordering
IntegrityError -> IntegrityError -> IntegrityError
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: IntegrityError -> IntegrityError -> Ordering
compare :: IntegrityError -> IntegrityError -> Ordering
$c< :: IntegrityError -> IntegrityError -> Bool
< :: IntegrityError -> IntegrityError -> Bool
$c<= :: IntegrityError -> IntegrityError -> Bool
<= :: IntegrityError -> IntegrityError -> Bool
$c> :: IntegrityError -> IntegrityError -> Bool
> :: IntegrityError -> IntegrityError -> Bool
$c>= :: IntegrityError -> IntegrityError -> Bool
>= :: IntegrityError -> IntegrityError -> Bool
$cmax :: IntegrityError -> IntegrityError -> IntegrityError
max :: IntegrityError -> IntegrityError -> IntegrityError
$cmin :: IntegrityError -> IntegrityError -> IntegrityError
min :: IntegrityError -> IntegrityError -> IntegrityError
Ord)

data BranchError
  = IncorrectHashForBranch BranchHash BranchHash
  | MismatchedObjectForChild Hash DB.BranchObjectId DB.BranchObjectId
  | MissingObjectForChildCausal Hash
  | MissingObject DB.BranchObjectId
  | MissingCausalForChild Hash
  | ChildCausalHashObjectIdMismatch Hash DB.BranchObjectId
  deriving stock (Int -> BranchError -> ShowS
[BranchError] -> ShowS
BranchError -> String
(Int -> BranchError -> ShowS)
-> (BranchError -> String)
-> ([BranchError] -> ShowS)
-> Show BranchError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BranchError -> ShowS
showsPrec :: Int -> BranchError -> ShowS
$cshow :: BranchError -> String
show :: BranchError -> String
$cshowList :: [BranchError] -> ShowS
showList :: [BranchError] -> ShowS
Show, BranchError -> BranchError -> Bool
(BranchError -> BranchError -> Bool)
-> (BranchError -> BranchError -> Bool) -> Eq BranchError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BranchError -> BranchError -> Bool
== :: BranchError -> BranchError -> Bool
$c/= :: BranchError -> BranchError -> Bool
/= :: BranchError -> BranchError -> Bool
Eq, Eq BranchError
Eq BranchError =>
(BranchError -> BranchError -> Ordering)
-> (BranchError -> BranchError -> Bool)
-> (BranchError -> BranchError -> Bool)
-> (BranchError -> BranchError -> Bool)
-> (BranchError -> BranchError -> Bool)
-> (BranchError -> BranchError -> BranchError)
-> (BranchError -> BranchError -> BranchError)
-> Ord BranchError
BranchError -> BranchError -> Bool
BranchError -> BranchError -> Ordering
BranchError -> BranchError -> BranchError
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: BranchError -> BranchError -> Ordering
compare :: BranchError -> BranchError -> Ordering
$c< :: BranchError -> BranchError -> Bool
< :: BranchError -> BranchError -> Bool
$c<= :: BranchError -> BranchError -> Bool
<= :: BranchError -> BranchError -> Bool
$c> :: BranchError -> BranchError -> Bool
> :: BranchError -> BranchError -> Bool
$c>= :: BranchError -> BranchError -> Bool
>= :: BranchError -> BranchError -> Bool
$cmax :: BranchError -> BranchError -> BranchError
max :: BranchError -> BranchError -> BranchError
$cmin :: BranchError -> BranchError -> BranchError
min :: BranchError -> BranchError -> BranchError
Ord)

data IntegrityResult = IntegrityErrorDetected (NESet IntegrityError) | NoIntegrityErrors
  deriving stock (Int -> IntegrityResult -> ShowS
[IntegrityResult] -> ShowS
IntegrityResult -> String
(Int -> IntegrityResult -> ShowS)
-> (IntegrityResult -> String)
-> ([IntegrityResult] -> ShowS)
-> Show IntegrityResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IntegrityResult -> ShowS
showsPrec :: Int -> IntegrityResult -> ShowS
$cshow :: IntegrityResult -> String
show :: IntegrityResult -> String
$cshowList :: [IntegrityResult] -> ShowS
showList :: [IntegrityResult] -> ShowS
Show, IntegrityResult -> IntegrityResult -> Bool
(IntegrityResult -> IntegrityResult -> Bool)
-> (IntegrityResult -> IntegrityResult -> Bool)
-> Eq IntegrityResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IntegrityResult -> IntegrityResult -> Bool
== :: IntegrityResult -> IntegrityResult -> Bool
$c/= :: IntegrityResult -> IntegrityResult -> Bool
/= :: IntegrityResult -> IntegrityResult -> Bool
Eq, Eq IntegrityResult
Eq IntegrityResult =>
(IntegrityResult -> IntegrityResult -> Ordering)
-> (IntegrityResult -> IntegrityResult -> Bool)
-> (IntegrityResult -> IntegrityResult -> Bool)
-> (IntegrityResult -> IntegrityResult -> Bool)
-> (IntegrityResult -> IntegrityResult -> Bool)
-> (IntegrityResult -> IntegrityResult -> IntegrityResult)
-> (IntegrityResult -> IntegrityResult -> IntegrityResult)
-> Ord IntegrityResult
IntegrityResult -> IntegrityResult -> Bool
IntegrityResult -> IntegrityResult -> Ordering
IntegrityResult -> IntegrityResult -> IntegrityResult
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: IntegrityResult -> IntegrityResult -> Ordering
compare :: IntegrityResult -> IntegrityResult -> Ordering
$c< :: IntegrityResult -> IntegrityResult -> Bool
< :: IntegrityResult -> IntegrityResult -> Bool
$c<= :: IntegrityResult -> IntegrityResult -> Bool
<= :: IntegrityResult -> IntegrityResult -> Bool
$c> :: IntegrityResult -> IntegrityResult -> Bool
> :: IntegrityResult -> IntegrityResult -> Bool
$c>= :: IntegrityResult -> IntegrityResult -> Bool
>= :: IntegrityResult -> IntegrityResult -> Bool
$cmax :: IntegrityResult -> IntegrityResult -> IntegrityResult
max :: IntegrityResult -> IntegrityResult -> IntegrityResult
$cmin :: IntegrityResult -> IntegrityResult -> IntegrityResult
min :: IntegrityResult -> IntegrityResult -> IntegrityResult
Ord)

instance Semigroup IntegrityResult where
  IntegrityErrorDetected NESet IntegrityError
errA <> :: IntegrityResult -> IntegrityResult -> IntegrityResult
<> IntegrityErrorDetected NESet IntegrityError
errB = NESet IntegrityError -> IntegrityResult
IntegrityErrorDetected (NESet IntegrityError
errA NESet IntegrityError
-> NESet IntegrityError -> NESet IntegrityError
forall a. Semigroup a => a -> a -> a
<> NESet IntegrityError
errB)
  IntegrityResult
NoIntegrityErrors <> IntegrityErrorDetected NESet IntegrityError
err = NESet IntegrityError -> IntegrityResult
IntegrityErrorDetected NESet IntegrityError
err
  IntegrityErrorDetected NESet IntegrityError
err <> IntegrityResult
NoIntegrityErrors = NESet IntegrityError -> IntegrityResult
IntegrityErrorDetected NESet IntegrityError
err
  IntegrityResult
NoIntegrityErrors <> IntegrityResult
NoIntegrityErrors = IntegrityResult
NoIntegrityErrors

instance Monoid IntegrityResult where
  mempty :: IntegrityResult
mempty = IntegrityResult
NoIntegrityErrors

integrityCheckAllHashObjects :: Sqlite.Transaction IntegrityResult
integrityCheckAllHashObjects :: Transaction IntegrityResult
integrityCheckAllHashObjects = do
  forall a. (FromField a, HasCallStack) => Sql -> Transaction [a]
Sqlite.queryListCol @DB.ObjectId Sql
objectsWithoutHashObjectsSQL Transaction [ObjectId]
-> ([ObjectId] -> Transaction IntegrityResult)
-> Transaction IntegrityResult
forall a b. Transaction a -> (a -> Transaction b) -> Transaction b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    (ObjectId
o : [ObjectId]
os) -> do
      let badObjects :: NESet ObjectId
badObjects = NonEmpty ObjectId -> NESet ObjectId
forall a. Ord a => NonEmpty a -> NESet a
NESet.fromList (ObjectId
o ObjectId -> [ObjectId] -> NonEmpty ObjectId
forall a. a -> [a] -> NonEmpty a
NEList.:| [ObjectId]
os)
      IntegrityResult -> Transaction IntegrityResult
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IntegrityResult -> Transaction IntegrityResult)
-> IntegrityResult -> Transaction IntegrityResult
forall a b. (a -> b) -> a -> b
$ NESet IntegrityError -> IntegrityResult
IntegrityErrorDetected (IntegrityError -> NESet IntegrityError
forall a. a -> NESet a
NESet.singleton (IntegrityError -> NESet IntegrityError)
-> IntegrityError -> NESet IntegrityError
forall a b. (a -> b) -> a -> b
$ NESet ObjectId -> IntegrityError
DetectedObjectsWithoutCorrespondingHashObjects NESet ObjectId
badObjects)
    [] -> do
      IntegrityResult -> Transaction IntegrityResult
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure IntegrityResult
NoIntegrityErrors
  where
    objectsWithoutHashObjectsSQL :: Sql
objectsWithoutHashObjectsSQL =
      [Sqlite.sql|
        SELECT o.id
        FROM object AS o
        WHERE NOT EXISTS (
          SELECT 1
          FROM hash_object as ho
          WHERE ho.object_id = o.id
        )
      |]

-- | Performs a bevy of checks on causals.
integrityCheckAllCausals :: Sqlite.Transaction IntegrityResult
integrityCheckAllCausals :: Transaction IntegrityResult
integrityCheckAllCausals = do
  IntegrityResult
branchObjIntegrity <-
    forall a. (FromRow a, HasCallStack) => Sql -> Transaction [a]
Sqlite.queryListRow @(DB.CausalHashId, DB.BranchHashId) Sql
causalsWithMissingBranchObjects Transaction [(CausalHashId, BranchHashId)]
-> ([(CausalHashId, BranchHashId)] -> Transaction IntegrityResult)
-> Transaction IntegrityResult
forall a b. Transaction a -> (a -> Transaction b) -> Transaction b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      [] -> IntegrityResult -> Transaction IntegrityResult
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure IntegrityResult
NoIntegrityErrors
      ((CausalHashId, BranchHashId)
c : [(CausalHashId, BranchHashId)]
cs) -> do
        NonEmpty (Hash, Hash)
badCausals <- NonEmpty (CausalHashId, BranchHashId)
-> ((CausalHashId, BranchHashId) -> Transaction (Hash, Hash))
-> Transaction (NonEmpty (Hash, Hash))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for ((CausalHashId, BranchHashId)
c (CausalHashId, BranchHashId)
-> [(CausalHashId, BranchHashId)]
-> NonEmpty (CausalHashId, BranchHashId)
forall a. a -> [a] -> NonEmpty a
NEList.:| [(CausalHashId, BranchHashId)]
cs) (((CausalHashId, BranchHashId) -> Transaction (Hash, Hash))
 -> Transaction (NonEmpty (Hash, Hash)))
-> ((CausalHashId, BranchHashId) -> Transaction (Hash, Hash))
-> Transaction (NonEmpty (Hash, Hash))
forall a b. (a -> b) -> a -> b
$ \(CausalHashId
causalHashId, BranchHashId
branchHashId) -> do
          Hash
ch <- HashId -> Transaction Hash
Q.expectHash (CausalHashId -> HashId
DB.unCausalHashId CausalHashId
causalHashId)
          Hash
bh <- HashId -> Transaction Hash
Q.expectHash (BranchHashId -> HashId
DB.unBranchHashId BranchHashId
branchHashId)
          pure (Hash
ch, Hash
bh)
        Text -> Transaction ()
logError (Text -> Transaction ()) -> Text -> Transaction ()
forall a b. (a -> b) -> a -> b
$ Text
"Detected " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
pShow (NonEmpty (Hash, Hash) -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty (Hash, Hash)
badCausals) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" causals with missing branch objects."
        Text -> Transaction ()
debugLog (Text -> Transaction ())
-> (NonEmpty (Hash, Hash) -> Text)
-> NonEmpty (Hash, Hash)
-> Transaction ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Hash, Hash) -> Text
forall a. Show a => a -> Text
pShow (NonEmpty (Hash, Hash) -> Transaction ())
-> NonEmpty (Hash, Hash) -> Transaction ()
forall a b. (a -> b) -> a -> b
$ NonEmpty (Hash, Hash)
badCausals
        pure $ NESet IntegrityError -> IntegrityResult
IntegrityErrorDetected (IntegrityError -> NESet IntegrityError
forall a. a -> NESet a
NESet.singleton (IntegrityError -> NESet IntegrityError)
-> IntegrityError -> NESet IntegrityError
forall a b. (a -> b) -> a -> b
$ NESet (Hash, Hash) -> IntegrityError
DetectedCausalsWithoutCorrespondingBranchObjects (NESet (Hash, Hash) -> IntegrityError)
-> NESet (Hash, Hash) -> IntegrityError
forall a b. (a -> b) -> a -> b
$ NonEmpty (Hash, Hash) -> NESet (Hash, Hash)
forall a. Ord a => NonEmpty a -> NESet a
NESet.fromList NonEmpty (Hash, Hash)
badCausals)

  IntegrityResult
differingBranchHashIntegrity <-
    forall a. (FromField a, HasCallStack) => Sql -> Transaction [a]
Sqlite.queryListCol @DB.HashId Sql
causalsWithMatchingValueHashAndSelfHash Transaction [HashId]
-> ([HashId] -> Transaction IntegrityResult)
-> Transaction IntegrityResult
forall a b. Transaction a -> (a -> Transaction b) -> Transaction b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      [] -> IntegrityResult -> Transaction IntegrityResult
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure IntegrityResult
NoIntegrityErrors
      (HashId
c : [HashId]
cs) -> do
        NonEmpty Hash
badCausalHashes <- NonEmpty HashId
-> (HashId -> Transaction Hash) -> Transaction (NonEmpty Hash)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (HashId
c HashId -> [HashId] -> NonEmpty HashId
forall a. a -> [a] -> NonEmpty a
NEList.:| [HashId]
cs) HashId -> Transaction Hash
Q.expectHash
        pure (NESet IntegrityError -> IntegrityResult
IntegrityErrorDetected (IntegrityError -> NESet IntegrityError
forall a. a -> NESet a
NESet.singleton (IntegrityError -> NESet IntegrityError)
-> IntegrityError -> NESet IntegrityError
forall a b. (a -> b) -> a -> b
$ NESet Hash -> IntegrityError
DetectedCausalsWithCausalHashAsBranchHash (NESet Hash -> IntegrityError) -> NESet Hash -> IntegrityError
forall a b. (a -> b) -> a -> b
$ NonEmpty Hash -> NESet Hash
forall a. Ord a => NonEmpty a -> NESet a
NESet.fromList NonEmpty Hash
badCausalHashes))
  pure (IntegrityResult
branchObjIntegrity IntegrityResult -> IntegrityResult -> IntegrityResult
forall a. Semigroup a => a -> a -> a
<> IntegrityResult
differingBranchHashIntegrity)
  where
    causalsWithMissingBranchObjects :: Sqlite.Sql
    causalsWithMissingBranchObjects :: Sql
causalsWithMissingBranchObjects =
      [Sqlite.sql|
        SELECT c.self_hash_id, c.value_hash_id
          FROM causal c
          WHERE NOT EXISTS (SELECT 1 from object o WHERE o.primary_hash_id = c.value_hash_id);
      |]
    causalsWithMatchingValueHashAndSelfHash :: Sqlite.Sql
    causalsWithMatchingValueHashAndSelfHash :: Sql
causalsWithMatchingValueHashAndSelfHash =
      [Sqlite.sql|
        SELECT self_hash_id
          FROM causal
          WHERE self_hash_id = value_hash_id
      |]

-- | Performs a bevy of checks on branch objects and their relation to causals.
integrityCheckAllBranches :: Sqlite.Transaction IntegrityResult
integrityCheckAllBranches :: Transaction IntegrityResult
integrityCheckAllBranches = do
  [BranchObjectId]
branchObjIds <- Sql -> Transaction [BranchObjectId]
forall a. (FromField a, HasCallStack) => Sql -> Transaction [a]
Sqlite.queryListCol Sql
allBranchObjectIdsSql
  ((BranchObjectId -> Transaction IntegrityResult)
 -> [BranchObjectId] -> Transaction IntegrityResult)
-> [BranchObjectId]
-> (BranchObjectId -> Transaction IntegrityResult)
-> Transaction IntegrityResult
forall a b c. (a -> b -> c) -> b -> a -> c
flip (BranchObjectId -> Transaction IntegrityResult)
-> [BranchObjectId] -> Transaction IntegrityResult
forall (m :: * -> *) (f :: * -> *) b a.
(Monad m, Foldable f, Monoid b) =>
(a -> m b) -> f a -> m b
foldMapM [BranchObjectId]
branchObjIds BranchObjectId -> Transaction IntegrityResult
integrityCheckBranch
  where
    allBranchObjectIdsSql :: Sqlite.Sql
    allBranchObjectIdsSql :: Sql
allBranchObjectIdsSql =
      [Sqlite.sql|
        SELECT id FROM object WHERE type_id = 2;
      |]

    doesCausalExistForCausalHashId :: DB.CausalHashId -> Sqlite.Transaction Bool
    doesCausalExistForCausalHashId :: CausalHashId -> Transaction Bool
doesCausalExistForCausalHashId CausalHashId
hashId =
      Sql -> Transaction Bool
forall a. (FromField a, HasCallStack) => Sql -> Transaction a
Sqlite.queryOneCol
        [Sqlite.sql|
          SELECT EXISTS (SELECT 1 FROM causal WHERE self_hash_id = :hashId)
        |]

    integrityCheckBranch :: DB.BranchObjectId -> Sqlite.Transaction IntegrityResult
    integrityCheckBranch :: BranchObjectId -> Transaction IntegrityResult
integrityCheckBranch BranchObjectId
objId = do
      DbBranch
dbBranch <- BranchObjectId -> Transaction DbBranch
Ops.expectDbBranch BranchObjectId
objId
      BranchHash
expectedBranchHash <- DbBranch -> Transaction BranchHash
Helpers.dbBranchHash DbBranch
dbBranch
      BranchHash
actualBranchHash <- Hash -> BranchHash
BranchHash (Hash -> BranchHash) -> Transaction Hash -> Transaction BranchHash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ObjectId -> Transaction Hash
Q.expectPrimaryHashByObjectId (BranchObjectId -> ObjectId
DB.unBranchObjectId BranchObjectId
objId)
      Set BranchError
branchHashCheck <- BranchHash -> BranchHash -> Transaction (Set BranchError)
assertExpectedBranchHash BranchHash
expectedBranchHash BranchHash
actualBranchHash
      Set BranchError
branchChildChecks <- (((BranchObjectId, CausalHashId) -> Transaction (Set BranchError))
 -> [(BranchObjectId, CausalHashId)]
 -> Transaction (Set BranchError))
-> [(BranchObjectId, CausalHashId)]
-> ((BranchObjectId, CausalHashId)
    -> Transaction (Set BranchError))
-> Transaction (Set BranchError)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((BranchObjectId, CausalHashId) -> Transaction (Set BranchError))
-> [(BranchObjectId, CausalHashId)]
-> Transaction (Set BranchError)
forall (m :: * -> *) (f :: * -> *) b a.
(Monad m, Foldable f, Monoid b) =>
(a -> m b) -> f a -> m b
foldMapM (Getting
  (Endo [(BranchObjectId, CausalHashId)])
  DbBranch
  (BranchObjectId, CausalHashId)
-> DbBranch -> [(BranchObjectId, CausalHashId)]
forall a s. Getting (Endo [a]) s a -> s -> [a]
toListOf Getting
  (Endo [(BranchObjectId, CausalHashId)])
  DbBranch
  (BranchObjectId, CausalHashId)
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_ DbBranch
dbBranch) (((BranchObjectId, CausalHashId) -> Transaction (Set BranchError))
 -> Transaction (Set BranchError))
-> ((BranchObjectId, CausalHashId)
    -> Transaction (Set BranchError))
-> Transaction (Set BranchError)
forall a b. (a -> b) -> a -> b
$ \(BranchObjectId
childObjId, CausalHashId
childCausalHashId) -> do
        let checks :: [Transaction (Set BranchError)]
checks =
              [ BranchObjectId -> Transaction (Set BranchError)
assertBranchObjExists BranchObjectId
childObjId,
                CausalHashId -> Transaction (Set BranchError)
assertCausalExists CausalHashId
childCausalHashId,
                CausalHashId -> BranchObjectId -> Transaction (Set BranchError)
assertCausalValueMatchesObject CausalHashId
childCausalHashId BranchObjectId
childObjId
              ]
        ([Set BranchError] -> Set BranchError
forall a. Monoid a => [a] -> a
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([Set BranchError] -> Set BranchError)
-> Transaction [Set BranchError] -> Transaction (Set BranchError)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Transaction (Set BranchError)] -> Transaction [Set BranchError]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => [f a] -> f [a]
sequenceA [Transaction (Set BranchError)]
checks)
      case Set BranchError -> Maybe (NESet BranchError)
forall a. Set a -> Maybe (NESet a)
NESet.nonEmptySet (Set BranchError
branchHashCheck Set BranchError -> Set BranchError -> Set BranchError
forall a. Semigroup a => a -> a -> a
<> Set BranchError
branchChildChecks) of
        Maybe (NESet BranchError)
Nothing -> IntegrityResult -> Transaction IntegrityResult
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure IntegrityResult
NoIntegrityErrors
        Just NESet BranchError
errs -> IntegrityResult -> Transaction IntegrityResult
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IntegrityResult -> Transaction IntegrityResult)
-> (IntegrityError -> IntegrityResult)
-> IntegrityError
-> Transaction IntegrityResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NESet IntegrityError -> IntegrityResult
IntegrityErrorDetected (NESet IntegrityError -> IntegrityResult)
-> (IntegrityError -> NESet IntegrityError)
-> IntegrityError
-> IntegrityResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntegrityError -> NESet IntegrityError
forall a. a -> NESet a
NESet.singleton (IntegrityError -> Transaction IntegrityResult)
-> IntegrityError -> Transaction IntegrityResult
forall a b. (a -> b) -> a -> b
$ BranchHash -> NESet BranchError -> IntegrityError
DetectedBranchErrors BranchHash
actualBranchHash NESet BranchError
errs
      where
        assertExpectedBranchHash :: BranchHash -> BranchHash -> Sqlite.Transaction (Set BranchError)
        assertExpectedBranchHash :: BranchHash -> BranchHash -> Transaction (Set BranchError)
assertExpectedBranchHash BranchHash
expectedBranchHash BranchHash
actualBranchHash = do
          if (BranchHash
expectedBranchHash BranchHash -> BranchHash -> Bool
forall a. Eq a => a -> a -> Bool
/= BranchHash
actualBranchHash)
            then do
              Text -> Transaction ()
logError (Text -> Transaction ()) -> Text -> Transaction ()
forall a b. (a -> b) -> a -> b
$ Text
"Expected hash for namespace doesn't match actual hash for namespace: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (BranchHash, BranchHash) -> Text
forall a. Show a => a -> Text
pShow (BranchHash
expectedBranchHash, BranchHash
actualBranchHash)
              pure (BranchError -> Set BranchError
forall a. a -> Set a
Set.singleton (BranchError -> Set BranchError) -> BranchError -> Set BranchError
forall a b. (a -> b) -> a -> b
$ BranchHash -> BranchHash -> BranchError
IncorrectHashForBranch BranchHash
expectedBranchHash BranchHash
actualBranchHash)
            else do
              Set BranchError -> Transaction (Set BranchError)
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Set BranchError
forall a. Monoid a => a
mempty

        assertBranchObjExists :: DB.BranchObjectId -> Sqlite.Transaction (Set BranchError)
        assertBranchObjExists :: BranchObjectId -> Transaction (Set BranchError)
assertBranchObjExists BranchObjectId
branchObjId = do
          forall e a.
SqliteExceptionReason e =>
ObjectId -> (ByteString -> Either e a) -> Transaction (Maybe a)
Q.loadNamespaceObject @Void (BranchObjectId -> ObjectId
DB.unBranchObjectId BranchObjectId
branchObjId) (Either Void () -> ByteString -> Either Void ()
forall a b. a -> b -> a
const (Either Void () -> ByteString -> Either Void ())
-> Either Void () -> ByteString -> Either Void ()
forall a b. (a -> b) -> a -> b
$ () -> Either Void ()
forall a b. b -> Either a b
Right ()) Transaction (Maybe ())
-> (Maybe () -> Transaction (Set BranchError))
-> Transaction (Set BranchError)
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 ()
_ -> Set BranchError -> Transaction (Set BranchError)
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Set BranchError
forall a. Monoid a => a
mempty
            Maybe ()
Nothing -> do
              Text -> Transaction ()
logError (Text -> Transaction ()) -> Text -> Transaction ()
forall a b. (a -> b) -> a -> b
$ Text
"Expected namespace object for object ID: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BranchObjectId -> Text
forall a. Show a => a -> Text
pShow BranchObjectId
branchObjId
              pure (BranchError -> Set BranchError
forall a. a -> Set a
Set.singleton (BranchError -> Set BranchError) -> BranchError -> Set BranchError
forall a b. (a -> b) -> a -> b
$ BranchObjectId -> BranchError
MissingObject BranchObjectId
branchObjId)
        assertCausalExists :: DB.CausalHashId -> Sqlite.Transaction (Set BranchError)
        assertCausalExists :: CausalHashId -> Transaction (Set BranchError)
assertCausalExists CausalHashId
causalHashId = do
          CausalHashId -> Transaction Bool
doesCausalExistForCausalHashId CausalHashId
causalHashId Transaction Bool
-> (Bool -> Transaction (Set BranchError))
-> Transaction (Set BranchError)
forall a b. Transaction a -> (a -> Transaction b) -> Transaction b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Bool
True -> Set BranchError -> Transaction (Set BranchError)
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Set BranchError
forall a. Monoid a => a
mempty
            Bool
False -> do
              Hash
ch <- HashId -> Transaction Hash
Q.expectHash (CausalHashId -> HashId
DB.unCausalHashId CausalHashId
causalHashId)
              Text -> Transaction ()
logError (Text -> Transaction ()) -> Text -> Transaction ()
forall a b. (a -> b) -> a -> b
$ Text
"Expected causal for causal hash ID, but none was found: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CausalHashId -> Text
forall a. Show a => a -> Text
pShow CausalHashId
causalHashId
              pure (BranchError -> Set BranchError
forall a. a -> Set a
Set.singleton (BranchError -> Set BranchError) -> BranchError -> Set BranchError
forall a b. (a -> b) -> a -> b
$ Hash -> BranchError
MissingCausalForChild Hash
ch)
        assertCausalValueMatchesObject ::
          DB.CausalHashId ->
          DB.BranchObjectId ->
          Sqlite.Transaction (Set BranchError)
        assertCausalValueMatchesObject :: CausalHashId -> BranchObjectId -> Transaction (Set BranchError)
assertCausalValueMatchesObject CausalHashId
causalHashId BranchObjectId
branchObjId = do
          -- Assert the object for the causal hash ID matches the given object Id.
          CausalHashId -> Transaction (Maybe BranchObjectId)
Q.loadBranchObjectIdByCausalHashId CausalHashId
causalHashId Transaction (Maybe BranchObjectId)
-> (Maybe BranchObjectId -> Transaction (Set BranchError))
-> Transaction (Set BranchError)
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 BranchObjectId
Nothing -> do
              Hash
ch <- HashId -> Transaction Hash
Q.expectHash (CausalHashId -> HashId
DB.unCausalHashId CausalHashId
causalHashId)
              Text -> Transaction ()
logError (Text -> Transaction ()) -> Text -> Transaction ()
forall a b. (a -> b) -> a -> b
$ Text
"Expected branch object for causal hash ID: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CausalHashId -> Text
forall a. Show a => a -> Text
pShow CausalHashId
causalHashId
              pure (BranchError -> Set BranchError
forall a. a -> Set a
Set.singleton (BranchError -> Set BranchError) -> BranchError -> Set BranchError
forall a b. (a -> b) -> a -> b
$ Hash -> BranchError
MissingObjectForChildCausal Hash
ch)
            Just BranchObjectId
foundBranchId
              | BranchObjectId
foundBranchId BranchObjectId -> BranchObjectId -> Bool
forall a. Eq a => a -> a -> Bool
/= BranchObjectId
branchObjId -> do
                  Text -> Transaction ()
logError (Text -> Transaction ()) -> Text -> Transaction ()
forall a b. (a -> b) -> a -> b
$ Text
"Expected child branch object to match canonical object ID for causal hash's namespace: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (CausalHashId, BranchObjectId, BranchObjectId) -> Text
forall a. Show a => a -> Text
pShow (CausalHashId
causalHashId, BranchObjectId
foundBranchId, BranchObjectId
branchObjId)
                  Hash
ch <- HashId -> Transaction Hash
Q.expectHash (CausalHashId -> HashId
DB.unCausalHashId CausalHashId
causalHashId)
                  pure (BranchError -> Set BranchError
forall a. a -> Set a
Set.singleton (BranchError -> Set BranchError) -> BranchError -> Set BranchError
forall a b. (a -> b) -> a -> b
$ Hash -> BranchObjectId -> BranchObjectId -> BranchError
MismatchedObjectForChild Hash
ch BranchObjectId
branchObjId BranchObjectId
foundBranchId)
              | Bool
otherwise -> Set BranchError -> Transaction (Set BranchError)
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Set BranchError
forall a. Monoid a => a
mempty

prettyPrintIntegrityErrors :: (Foldable f) => f IntegrityError -> P.Pretty P.ColorText
prettyPrintIntegrityErrors :: forall (f :: * -> *).
Foldable f =>
f IntegrityError -> Pretty ColorText
prettyPrintIntegrityErrors f IntegrityError
xs
  | f IntegrityError -> Bool
forall a. f a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null f IntegrityError
xs = Pretty ColorText
forall a. Monoid a => a
mempty
  | Bool
otherwise =
      f IntegrityError
xs
        f IntegrityError
-> (f IntegrityError -> [IntegrityError]) -> [IntegrityError]
forall a b. a -> (a -> b) -> b
& f IntegrityError -> [IntegrityError]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
        [IntegrityError]
-> ([IntegrityError] -> [Pretty ColorText]) -> [Pretty ColorText]
forall a b. a -> (a -> b) -> b
& (IntegrityError -> Pretty ColorText)
-> [IntegrityError] -> [Pretty ColorText]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
          ( \case
              DetectedObjectsWithoutCorrespondingHashObjects NESet ObjectId
objs ->
                Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
P.hang
                  Pretty ColorText
"Detected objects without any corresponding hash_object. Object IDs:"
                  (NonEmpty (Pretty ColorText) -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.commas (ObjectId -> Pretty ColorText
prettyObjectId (ObjectId -> Pretty ColorText)
-> NonEmpty ObjectId -> NonEmpty (Pretty ColorText)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NESet ObjectId -> NonEmpty ObjectId
forall a. NESet a -> NonEmpty a
NESet.toList NESet ObjectId
objs))
              DetectedCausalsWithoutCorrespondingBranchObjects NESet (Hash, Hash)
hashes ->
                Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
P.hang
                  Pretty ColorText
"Detected causals without a corresponding branch object:\n"
                  ( Pretty ColorText
-> Pretty ColorText
-> [(Pretty ColorText, Pretty ColorText)]
-> Pretty ColorText
P.column2Header
                      Pretty ColorText
"Causal Hash"
                      Pretty ColorText
"Branch Hash"
                      (NESet (Hash, Hash) -> [(Hash, Hash)]
forall a. NESet a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NESet (Hash, Hash)
hashes [(Hash, Hash)]
-> ((Hash, Hash) -> (Pretty ColorText, Pretty ColorText))
-> [(Pretty ColorText, Pretty ColorText)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Hash -> Pretty ColorText)
-> (Hash -> Pretty ColorText)
-> (Hash, Hash)
-> (Pretty ColorText, Pretty ColorText)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Hash -> Pretty ColorText
prettyHash Hash -> Pretty ColorText
prettyHash)
                  )
              DetectedCausalsWithCausalHashAsBranchHash NESet Hash
ns ->
                Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
P.hang
                  Pretty ColorText
"Detected causals with the same causal hash as branch hash:"
                  ([Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.commas (Hash -> Pretty ColorText
prettyHash (Hash -> Pretty ColorText) -> [Hash] -> [Pretty ColorText]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NESet Hash -> [Hash]
forall a. NESet a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NESet Hash
ns))
              DetectedBranchErrors BranchHash
bh NESet BranchError
errs ->
                Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
P.hang
                  (Pretty ColorText
"Detected errors in branch: " Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Hash -> Pretty ColorText
prettyHash (BranchHash -> Hash
unBranchHash BranchHash
bh))
                  ([Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines ([Pretty ColorText] -> Pretty ColorText)
-> (NESet BranchError -> [Pretty ColorText])
-> NESet BranchError
-> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pretty ColorText -> Pretty ColorText)
-> [Pretty ColorText] -> [Pretty ColorText]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
"\n") ([Pretty ColorText] -> [Pretty ColorText])
-> (NESet BranchError -> [Pretty ColorText])
-> NESet BranchError
-> [Pretty ColorText]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BranchError -> Pretty ColorText)
-> [BranchError] -> [Pretty ColorText]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BranchError -> Pretty ColorText
prettyBranchError ([BranchError] -> [Pretty ColorText])
-> (NESet BranchError -> [BranchError])
-> NESet BranchError
-> [Pretty ColorText]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NESet BranchError -> [BranchError]
forall a. NESet a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NESet BranchError -> Pretty ColorText)
-> NESet BranchError -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$ NESet BranchError
errs)
          )
        [Pretty ColorText]
-> ([Pretty ColorText] -> [Pretty ColorText]) -> [Pretty ColorText]
forall a b. a -> (a -> b) -> b
& (Pretty ColorText -> Pretty ColorText)
-> [Pretty ColorText] -> [Pretty ColorText]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
"\n")
        [Pretty ColorText]
-> ([Pretty ColorText] -> Pretty ColorText) -> Pretty ColorText
forall a b. a -> (a -> b) -> b
& [Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines
        Pretty ColorText
-> (Pretty ColorText -> Pretty ColorText) -> Pretty ColorText
forall a b. a -> (a -> b) -> b
& Pretty ColorText -> Pretty ColorText
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.warnCallout
  where
    prettyHash :: Hash -> P.Pretty P.ColorText
    prettyHash :: Hash -> Pretty ColorText
prettyHash Hash
h = Pretty ColorText -> Pretty ColorText
P.blue (Pretty ColorText -> Pretty ColorText)
-> (Text -> Pretty ColorText) -> Text -> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Pretty ColorText
forall s. IsString s => Text -> Pretty s
P.text (Text -> Pretty ColorText) -> Text -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$ (Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Hash -> Text
Hash.toBase32HexText Hash
h)
    prettyBranchObjectId :: DB.BranchObjectId -> P.Pretty P.ColorText
    prettyBranchObjectId :: BranchObjectId -> Pretty ColorText
prettyBranchObjectId = ObjectId -> Pretty ColorText
prettyObjectId (ObjectId -> Pretty ColorText)
-> (BranchObjectId -> ObjectId)
-> BranchObjectId
-> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BranchObjectId -> ObjectId
DB.unBranchObjectId
    prettyObjectId :: DB.ObjectId -> P.Pretty P.ColorText
    prettyObjectId :: ObjectId -> Pretty ColorText
prettyObjectId (DB.ObjectId Word64
n) = Pretty ColorText -> Pretty ColorText
P.green (Word64 -> Pretty ColorText
forall a s. (Show a, IsString s) => a -> Pretty s
P.shown Word64
n)
    prettyBranchError :: BranchError -> P.Pretty P.ColorText
    prettyBranchError :: BranchError -> Pretty ColorText
prettyBranchError =
      Pretty ColorText -> Pretty ColorText
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap (Pretty ColorText -> Pretty ColorText)
-> (BranchError -> Pretty ColorText)
-> BranchError
-> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
        IncorrectHashForBranch BranchHash
expected BranchHash
actual -> Pretty ColorText
"The Branch hash for this branch is incorrect. Expected Hash: " Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Hash -> Pretty ColorText
prettyHash (BranchHash -> Hash
unBranchHash BranchHash
expected) Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
", Actual Hash: " Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Hash -> Pretty ColorText
prettyHash (BranchHash -> Hash
unBranchHash BranchHash
actual)
        MismatchedObjectForChild Hash
ha BranchObjectId
obj1 BranchObjectId
obj2 ->
          Pretty ColorText
"The child with causal hash: " Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Hash -> Pretty ColorText
prettyHash Hash
ha Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
" is mapped to object ID " Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> BranchObjectId -> Pretty ColorText
prettyBranchObjectId BranchObjectId
obj1 Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
" but should map to " Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> BranchObjectId -> Pretty ColorText
prettyBranchObjectId BranchObjectId
obj2 Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
"."
        MissingObjectForChildCausal Hash
ha ->
          Pretty ColorText
"There's no corresponding branch object for the causal hash: " Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Hash -> Pretty ColorText
prettyHash Hash
ha
        MissingObject BranchObjectId
objId -> Pretty ColorText
"Expected an object for the child reference to object id: " Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> BranchObjectId -> Pretty ColorText
prettyBranchObjectId BranchObjectId
objId
        MissingCausalForChild Hash
ch -> Pretty ColorText
"Expected a causal to exist for hash: " Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Hash -> Pretty ColorText
prettyHash Hash
ch
        ChildCausalHashObjectIdMismatch Hash
ch BranchObjectId
objId ->
          Pretty ColorText
"Expected the object ID reference " Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Hash -> Pretty ColorText
prettyHash Hash
ch Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
" to match the provided object ID: " Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> BranchObjectId -> Pretty ColorText
prettyBranchObjectId BranchObjectId
objId

-- | Performs all available integrity checks.
integrityCheckFullCodebase :: Sqlite.Transaction IntegrityResult
integrityCheckFullCodebase :: Transaction IntegrityResult
integrityCheckFullCodebase = do
  ([IntegrityResult] -> IntegrityResult)
-> Transaction [IntegrityResult] -> Transaction IntegrityResult
forall a b. (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [IntegrityResult] -> IntegrityResult
forall a. Monoid a => [a] -> a
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Transaction [IntegrityResult] -> Transaction IntegrityResult)
-> ([Transaction IntegrityResult] -> Transaction [IntegrityResult])
-> [Transaction IntegrityResult]
-> Transaction IntegrityResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Transaction IntegrityResult] -> Transaction [IntegrityResult]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => [f a] -> f [a]
sequenceA ([Transaction IntegrityResult] -> Transaction IntegrityResult)
-> [Transaction IntegrityResult] -> Transaction IntegrityResult
forall a b. (a -> b) -> a -> b
$
    [ Transaction IntegrityResult
integrityCheckAllHashObjects,
      Transaction IntegrityResult
integrityCheckAllBranches,
      Transaction IntegrityResult
integrityCheckAllCausals
    ]