{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}

-- | Module for validating hashes of entities received/sent via sync.
module Unison.Sync.EntityValidation
  ( validateEntity,
  )
where

import Data.ByteString qualified as BS
import Data.Bytes.Get (runGetS)
import Data.Set qualified as Set
import Data.Text qualified as Text
import U.Codebase.HashTags
import U.Codebase.Sqlite.Branch.Format qualified as BranchFormat
import U.Codebase.Sqlite.Causal qualified as CausalFormat
import U.Codebase.Sqlite.Decl.Format qualified as DeclFormat
import U.Codebase.Sqlite.Decode qualified as Decode
import U.Codebase.Sqlite.Entity qualified as Entity
import U.Codebase.Sqlite.HashHandle qualified as HH
import U.Codebase.Sqlite.Orphans ()
import U.Codebase.Sqlite.Patch.Format qualified as PatchFormat
import U.Codebase.Sqlite.Serialization qualified as Serialization
import U.Codebase.Sqlite.Term.Format qualified as TermFormat
import U.Codebase.Sqlite.V2.HashHandle (v2HashHandle)
import Unison.Hash (Hash)
import Unison.Hash32 (Hash32)
import Unison.Hash32 qualified as Hash32
import Unison.Hashing.V2 qualified as H
import Unison.Prelude
import Unison.Sync.Common qualified as Share
import Unison.Sync.Types qualified as Share

-- | Note: We currently only validate Namespace hashes.
-- We should add more validation as more entities are shared.
validateEntity :: Hash32 -> Share.Entity Text Hash32 Hash32 -> Maybe Share.EntityValidationError
validateEntity :: Hash32 -> Entity Text Hash32 Hash32 -> Maybe EntityValidationError
validateEntity Hash32
expectedHash32 Entity Text Hash32 Hash32
entity = do
  case (Hash32 -> Hash32) -> Entity Text Hash32 Hash32 -> TempEntity
forall hash.
(hash -> Hash32) -> Entity Text Hash32 hash -> TempEntity
Share.entityToTempEntity Hash32 -> Hash32
forall a. a -> a
id Entity Text Hash32 Hash32
entity of
    Entity.TC (TermFormat.SyncTerm SyncLocallyIndexedComponent' Text Hash32
localComp) -> do
      Hash
-> SyncLocallyIndexedComponent' Text Hash32
-> Maybe EntityValidationError
validateTerm Hash
expectedHash SyncLocallyIndexedComponent' Text Hash32
localComp
    Entity.DC (DeclFormat.SyncDecl SyncLocallyIndexedComponent' Text Hash32
localComp) -> do
      Hash
-> SyncLocallyIndexedComponent' Text Hash32
-> Maybe EntityValidationError
validateDecl Hash
expectedHash SyncLocallyIndexedComponent' Text Hash32
localComp
    Entity.N (BranchFormat.SyncDiff {}) -> do
      EntityValidationError -> Maybe EntityValidationError
forall a. a -> Maybe a
Just (EntityValidationError -> Maybe EntityValidationError)
-> EntityValidationError -> Maybe EntityValidationError
forall a b. (a -> b) -> a -> b
$ Hash32 -> EntityType -> EntityValidationError
Share.UnsupportedEntityType Hash32
expectedHash32 EntityType
Share.NamespaceDiffType
    Entity.N (BranchFormat.SyncFull BranchLocalIds' Text Hash32 Hash32 (Hash32, Hash32)
localIds (BranchFormat.LocalBranchBytes ByteString
bytes)) -> do
      Hash
-> BranchLocalIds' Text Hash32 Hash32 (Hash32, Hash32)
-> ByteString
-> Maybe EntityValidationError
validateBranchFull Hash
expectedHash BranchLocalIds' Text Hash32 Hash32 (Hash32, Hash32)
localIds ByteString
bytes
    Entity.C CausalFormat.SyncCausalFormat {Hash32
valueHash :: Hash32
$sel:valueHash:SyncCausalFormat :: forall causalHash valueHash.
SyncCausalFormat' causalHash valueHash -> valueHash
valueHash, Vector Hash32
parents :: Vector Hash32
$sel:parents:SyncCausalFormat :: forall causalHash valueHash.
SyncCausalFormat' causalHash valueHash -> Vector causalHash
parents} -> do
      Hash32 -> Hash32 -> [Hash32] -> Maybe EntityValidationError
validateCausal Hash32
expectedHash32 Hash32
valueHash (Vector Hash32 -> [Hash32]
forall a. Vector a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Vector Hash32
parents)
    Entity.P (PatchFormat.SyncDiff {}) -> do
      EntityValidationError -> Maybe EntityValidationError
forall a. a -> Maybe a
Just (EntityValidationError -> Maybe EntityValidationError)
-> EntityValidationError -> Maybe EntityValidationError
forall a b. (a -> b) -> a -> b
$ Hash32 -> EntityType -> EntityValidationError
Share.UnsupportedEntityType Hash32
expectedHash32 EntityType
Share.PatchDiffType
    Entity.P (PatchFormat.SyncFull PatchLocalIds' Text Hash32 Hash32
localIds ByteString
bytes) -> do
      Hash32
-> PatchLocalIds' Text Hash32 Hash32
-> ByteString
-> Maybe EntityValidationError
validatePatchFull Hash32
expectedHash32 PatchLocalIds' Text Hash32 Hash32
localIds ByteString
bytes
  where
    expectedHash :: Hash
    expectedHash :: Hash
expectedHash = Hash32 -> Hash
Hash32.toHash Hash32
expectedHash32

validatePatchFull :: Hash32 -> PatchFormat.PatchLocalIds' Text Hash32 Hash32 -> BS.ByteString -> Maybe Share.EntityValidationError
validatePatchFull :: Hash32
-> PatchLocalIds' Text Hash32 Hash32
-> ByteString
-> Maybe EntityValidationError
validatePatchFull Hash32
expectedHash32 PatchLocalIds' Text Hash32 Hash32
localIds ByteString
bytes = do
  let expectedHash :: Hash
expectedHash = Hash32 -> Hash
Hash32.toHash Hash32
expectedHash32
  case Get LocalPatch -> ByteString -> Either String LocalPatch
forall a. Get a -> ByteString -> Either String a
runGetS Get LocalPatch
forall (m :: * -> *). MonadGet m => m LocalPatch
Serialization.getLocalPatch ByteString
bytes of
    Left String
e -> EntityValidationError -> Maybe EntityValidationError
forall a. a -> Maybe a
Just (EntityValidationError -> Maybe EntityValidationError)
-> EntityValidationError -> Maybe EntityValidationError
forall a b. (a -> b) -> a -> b
$ Hash32 -> EntityType -> Text -> EntityValidationError
Share.InvalidByteEncoding Hash32
expectedHash32 EntityType
Share.PatchType (String -> Text
Text.pack String
e)
    Right LocalPatch
localPatch -> do
      let localIds' :: PatchLocalIds' Text ComponentHash ComponentHash
localIds' =
            PatchLocalIds' Text Hash32 Hash32
localIds
              { PatchFormat.patchTextLookup = PatchFormat.patchTextLookup localIds,
                PatchFormat.patchHashLookup = ComponentHash . Hash32.toHash <$> PatchFormat.patchHashLookup localIds,
                PatchFormat.patchDefnLookup = ComponentHash . Hash32.toHash <$> PatchFormat.patchDefnLookup localIds
              }
      let actualHash :: PatchHash
actualHash =
            HashHandle
-> PatchLocalIds' Text ComponentHash ComponentHash
-> LocalPatch
-> PatchHash
HH.hashPatchFormatFull HashHandle
v2HashHandle PatchLocalIds' Text ComponentHash ComponentHash
localIds' LocalPatch
localPatch
      if PatchHash
actualHash PatchHash -> PatchHash -> Bool
forall a. Eq a => a -> a -> Bool
== Hash -> PatchHash
PatchHash Hash
expectedHash
        then Maybe EntityValidationError
forall a. Maybe a
Nothing
        else EntityValidationError -> Maybe EntityValidationError
forall a. a -> Maybe a
Just (EntityValidationError -> Maybe EntityValidationError)
-> EntityValidationError -> Maybe EntityValidationError
forall a b. (a -> b) -> a -> b
$ EntityType -> HashMismatchForEntity -> EntityValidationError
Share.EntityHashMismatch EntityType
Share.PatchType (Hash -> Hash -> HashMismatchForEntity
mismatch Hash
expectedHash (PatchHash -> Hash
unPatchHash PatchHash
actualHash))

validateBranchFull ::
  Hash ->
  BranchFormat.BranchLocalIds' Text Hash32 Hash32 (Hash32, Hash32) ->
  BS.ByteString ->
  (Maybe Share.EntityValidationError)
validateBranchFull :: Hash
-> BranchLocalIds' Text Hash32 Hash32 (Hash32, Hash32)
-> ByteString
-> Maybe EntityValidationError
validateBranchFull Hash
expectedHash BranchLocalIds' Text Hash32 Hash32 (Hash32, Hash32)
localIds ByteString
bytes = do
  case Get LocalBranch -> ByteString -> Either String LocalBranch
forall a. Get a -> ByteString -> Either String a
runGetS Get LocalBranch
forall (m :: * -> *). MonadGet m => m LocalBranch
Serialization.getLocalBranch ByteString
bytes of
    Left String
e -> EntityValidationError -> Maybe EntityValidationError
forall a. a -> Maybe a
Just (EntityValidationError -> Maybe EntityValidationError)
-> EntityValidationError -> Maybe EntityValidationError
forall a b. (a -> b) -> a -> b
$ Hash32 -> EntityType -> Text -> EntityValidationError
Share.InvalidByteEncoding (Hash -> Hash32
Hash32.fromHash Hash
expectedHash) EntityType
Share.NamespaceType (String -> Text
Text.pack String
e)
    Right LocalBranch
localBranch -> do
      let localIds' :: BranchLocalIds'
  Text ComponentHash PatchHash (BranchHash, CausalHash)
localIds' =
            BranchLocalIds' Text Hash32 Hash32 (Hash32, Hash32)
localIds
              { BranchFormat.branchDefnLookup = ComponentHash . Hash32.toHash <$> BranchFormat.branchDefnLookup localIds,
                BranchFormat.branchPatchLookup = PatchHash . Hash32.toHash <$> BranchFormat.branchPatchLookup localIds,
                BranchFormat.branchChildLookup =
                  BranchFormat.branchChildLookup localIds
                    <&> bimap (BranchHash . Hash32.toHash) (CausalHash . Hash32.toHash)
              }
      let actualHash :: BranchHash
actualHash =
            HashHandle
-> BranchLocalIds'
     Text ComponentHash PatchHash (BranchHash, CausalHash)
-> LocalBranch
-> BranchHash
HH.hashBranchFormatFull HashHandle
v2HashHandle BranchLocalIds'
  Text ComponentHash PatchHash (BranchHash, CausalHash)
localIds' LocalBranch
localBranch
      if BranchHash
actualHash BranchHash -> BranchHash -> Bool
forall a. Eq a => a -> a -> Bool
== Hash -> BranchHash
BranchHash Hash
expectedHash
        then Maybe EntityValidationError
forall a. Maybe a
Nothing
        else EntityValidationError -> Maybe EntityValidationError
forall a. a -> Maybe a
Just (EntityValidationError -> Maybe EntityValidationError)
-> EntityValidationError -> Maybe EntityValidationError
forall a b. (a -> b) -> a -> b
$ EntityType -> HashMismatchForEntity -> EntityValidationError
Share.EntityHashMismatch EntityType
Share.NamespaceType (Hash -> Hash -> HashMismatchForEntity
mismatch Hash
expectedHash (BranchHash -> Hash
unBranchHash BranchHash
actualHash))

validateTerm :: Hash -> (TermFormat.SyncLocallyIndexedComponent' Text Hash32) -> (Maybe Share.EntityValidationError)
validateTerm :: Hash
-> SyncLocallyIndexedComponent' Text Hash32
-> Maybe EntityValidationError
validateTerm Hash
expectedHash SyncLocallyIndexedComponent' Text Hash32
syncLocalComp = do
  case SyncLocallyIndexedComponent' Text Hash32
-> Either DecodeError (LocallyIndexedComponent' Text Hash32)
forall t d.
HasCallStack =>
SyncLocallyIndexedComponent' t d
-> Either DecodeError (LocallyIndexedComponent' t d)
Decode.unsyncTermComponent SyncLocallyIndexedComponent' Text Hash32
syncLocalComp of
    Left DecodeError
decodeErr -> EntityValidationError -> Maybe EntityValidationError
forall a. a -> Maybe a
Just (Hash32 -> EntityType -> Text -> EntityValidationError
Share.InvalidByteEncoding (Hash -> Hash32
Hash32.fromHash Hash
expectedHash) EntityType
Share.TermComponentType (DecodeError -> Text
forall a. Show a => a -> Text
tShow DecodeError
decodeErr))
    Right LocallyIndexedComponent' Text Hash32
localComp -> do
      case HashHandle -> ComponentHash -> HashTermFormat -> Maybe HashMismatch
HH.verifyTermFormatHash HashHandle
v2HashHandle (Hash -> ComponentHash
ComponentHash Hash
expectedHash) (LocallyIndexedComponent' Text Hash32 -> HashTermFormat
forall t d. LocallyIndexedComponent' t d -> TermFormat' t d
TermFormat.Term LocallyIndexedComponent' Text Hash32
localComp) of
        Maybe HashMismatch
Nothing -> Maybe EntityValidationError
forall a. Maybe a
Nothing
        Just (HH.HashMismatch {Hash
expectedHash :: Hash
$sel:expectedHash:HashMismatch :: HashMismatch -> Hash
expectedHash, Hash
actualHash :: Hash
$sel:actualHash:HashMismatch :: HashMismatch -> Hash
actualHash}) -> EntityValidationError -> Maybe EntityValidationError
forall a. a -> Maybe a
Just (EntityValidationError -> Maybe EntityValidationError)
-> (HashMismatchForEntity -> EntityValidationError)
-> HashMismatchForEntity
-> Maybe EntityValidationError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityType -> HashMismatchForEntity -> EntityValidationError
Share.EntityHashMismatch EntityType
Share.TermComponentType (HashMismatchForEntity -> Maybe EntityValidationError)
-> HashMismatchForEntity -> Maybe EntityValidationError
forall a b. (a -> b) -> a -> b
$ Hash -> Hash -> HashMismatchForEntity
mismatch Hash
expectedHash Hash
actualHash

validateDecl :: Hash -> (DeclFormat.SyncLocallyIndexedComponent' Text Hash32) -> (Maybe Share.EntityValidationError)
validateDecl :: Hash
-> SyncLocallyIndexedComponent' Text Hash32
-> Maybe EntityValidationError
validateDecl Hash
expectedHash SyncLocallyIndexedComponent' Text Hash32
syncLocalComp = do
  case SyncLocallyIndexedComponent' Text Hash32
-> Either DecodeError (LocallyIndexedComponent' Text Hash32)
forall t d.
SyncLocallyIndexedComponent' t d
-> Either DecodeError (LocallyIndexedComponent' t d)
Decode.unsyncDeclComponent SyncLocallyIndexedComponent' Text Hash32
syncLocalComp of
    Left DecodeError
decodeErr -> EntityValidationError -> Maybe EntityValidationError
forall a. a -> Maybe a
Just (Hash32 -> EntityType -> Text -> EntityValidationError
Share.InvalidByteEncoding (Hash -> Hash32
Hash32.fromHash Hash
expectedHash) EntityType
Share.DeclComponentType (DecodeError -> Text
forall a. Show a => a -> Text
tShow DecodeError
decodeErr))
    Right LocallyIndexedComponent' Text Hash32
localComp -> do
      case HashHandle
-> ComponentHash -> HashDeclFormat -> Maybe DeclHashingError
HH.verifyDeclFormatHash HashHandle
v2HashHandle (Hash -> ComponentHash
ComponentHash Hash
expectedHash) (LocallyIndexedComponent' Text Hash32 -> HashDeclFormat
forall text defn.
LocallyIndexedComponent' text defn -> DeclFormat' text defn
DeclFormat.Decl LocallyIndexedComponent' Text Hash32
localComp) of
        Maybe DeclHashingError
Nothing -> Maybe EntityValidationError
forall a. Maybe a
Nothing
        Just (HH.DeclHashMismatch (HH.HashMismatch {Hash
$sel:expectedHash:HashMismatch :: HashMismatch -> Hash
expectedHash :: Hash
expectedHash, Hash
$sel:actualHash:HashMismatch :: HashMismatch -> Hash
actualHash :: Hash
actualHash})) -> EntityValidationError -> Maybe EntityValidationError
forall a. a -> Maybe a
Just (EntityValidationError -> Maybe EntityValidationError)
-> (HashMismatchForEntity -> EntityValidationError)
-> HashMismatchForEntity
-> Maybe EntityValidationError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityType -> HashMismatchForEntity -> EntityValidationError
Share.EntityHashMismatch EntityType
Share.DeclComponentType (HashMismatchForEntity -> Maybe EntityValidationError)
-> HashMismatchForEntity -> Maybe EntityValidationError
forall a b. (a -> b) -> a -> b
$ Hash -> Hash -> HashMismatchForEntity
mismatch Hash
expectedHash Hash
actualHash
        Just DeclHashingError
HH.DeclHashResolutionFailure -> EntityValidationError -> Maybe EntityValidationError
forall a. a -> Maybe a
Just (EntityValidationError -> Maybe EntityValidationError)
-> EntityValidationError -> Maybe EntityValidationError
forall a b. (a -> b) -> a -> b
$ Hash32 -> EntityValidationError
Share.HashResolutionFailure (Hash -> Hash32
Hash32.fromHash Hash
expectedHash)

validateCausal :: Hash32 -> Hash32 -> [Hash32] -> Maybe Share.EntityValidationError
validateCausal :: Hash32 -> Hash32 -> [Hash32] -> Maybe EntityValidationError
validateCausal Hash32
expectedHash32 Hash32
valueHash32 [Hash32]
parentHashes32 = do
  let expectedHash :: Hash
expectedHash = Hash32 -> Hash
Hash32.toHash Hash32
expectedHash32
  let branchHash :: Hash
branchHash = Hash32 -> Hash
Hash32.toHash Hash32
valueHash32
  let parents :: Set Hash
parents = [Hash] -> Set Hash
forall a. Ord a => [a] -> Set a
Set.fromList (Hash32 -> Hash
Hash32.toHash (Hash32 -> Hash) -> [Hash32] -> [Hash]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Hash32]
parentHashes32)
  let actualHash :: Hash
actualHash = Causal -> Hash
forall a. ContentAddressable a => a -> Hash
H.contentHash (H.Causal {Hash
branchHash :: Hash
branchHash :: Hash
branchHash, Set Hash
parents :: Set Hash
parents :: Set Hash
parents})
  if Hash
actualHash Hash -> Hash -> Bool
forall a. Eq a => a -> a -> Bool
== Hash
expectedHash
    then Maybe EntityValidationError
forall a. Maybe a
Nothing
    else EntityValidationError -> Maybe EntityValidationError
forall a. a -> Maybe a
Just (EntityValidationError -> Maybe EntityValidationError)
-> EntityValidationError -> Maybe EntityValidationError
forall a b. (a -> b) -> a -> b
$ EntityType -> HashMismatchForEntity -> EntityValidationError
Share.EntityHashMismatch EntityType
Share.CausalType (Hash -> Hash -> HashMismatchForEntity
mismatch Hash
expectedHash Hash
actualHash)

mismatch :: Hash -> Hash -> Share.HashMismatchForEntity
mismatch :: Hash -> Hash -> HashMismatchForEntity
mismatch Hash
supplied Hash
computed =
  Share.HashMismatchForEntity
    { $sel:supplied:HashMismatchForEntity :: Hash32
supplied = Hash -> Hash32
Hash32.fromHash Hash
supplied,
      $sel:computed:HashMismatchForEntity :: Hash32
computed = Hash -> Hash32
Hash32.fromHash Hash
computed
    }