diff --git a/unison-share-api/package.yaml b/unison-share-api/package.yaml index 77bf436d8a..954e80f9ce 100644 --- a/unison-share-api/package.yaml +++ b/unison-share-api/package.yaml @@ -14,6 +14,7 @@ dependencies: - async - base - binary + - bytes - bytestring - containers - directory @@ -42,6 +43,7 @@ dependencies: - transformers - unison-codebase - unison-codebase-sqlite + - unison-codebase-sqlite-hashing-v2 - unison-core - unison-core1 - unison-hash diff --git a/unison-share-api/src/Unison/Sync/HashValidation.hs b/unison-share-api/src/Unison/Sync/HashValidation.hs new file mode 100644 index 0000000000..607213767c --- /dev/null +++ b/unison-share-api/src/Unison/Sync/HashValidation.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DuplicateRecordFields #-} + +-- | Module for validating hashes of entities received/sent via sync. +module Unison.Sync.HashValidation + ( HashValidationError (..), + validateEntityHash, + ) +where + +import Control.Exception +import Data.ByteString qualified as BS +import Data.Bytes.Get (runGetS) +import U.Codebase.HashTags +import U.Codebase.Sqlite.Branch.Format qualified as BranchFormat +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.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.Prelude +import Unison.Sync.Common qualified as Share +import Unison.Sync.Types qualified as Share + +data HashValidationError + = MismatchedNamespaceHash (Hash {- expected hash -}) (Hash {- actual hash -}) + | MismatchedTermHash (Hash {- expected hash -}) (Hash {- actual hash -}) + | NamespaceDiffsAreUnsupported + | InvalidByteEncoding Text + deriving stock (Show, Eq, Ord) + deriving anyclass (Exception) + +data UnexpectedHashMismatch = UnexpectedHashMismatch + { providedHash :: ComponentHash, + actualHash :: ComponentHash + } + deriving stock (Show) + +-- | Note: We currently only validate Namespace hashes. +-- We should add more validation as more entities are shared. +validateEntityHash :: Hash32 -> Share.Entity Text Hash32 Hash32 -> Maybe HashValidationError +validateEntityHash expectedHash32 entity = do + case Share.entityToTempEntity id entity of + Entity.TC (TermFormat.SyncTerm localComp) -> do + validateTerm expectedHash localComp + Entity.N (BranchFormat.SyncDiff {}) -> do + (Just NamespaceDiffsAreUnsupported) + Entity.N (BranchFormat.SyncFull localIds (BranchFormat.LocalBranchBytes bytes)) -> do + validateBranchFull expectedHash localIds bytes + _ -> Nothing + where + expectedHash :: Hash + expectedHash = Hash32.toHash expectedHash32 + +validateBranchFull :: + Hash -> + BranchFormat.BranchLocalIds' Text Hash32 Hash32 (Hash32, Hash32) -> + BS.ByteString -> + (Maybe HashValidationError) +validateBranchFull expectedHash localIds bytes = do + case runGetS Serialization.getLocalBranch bytes of + Left e -> Just $ InvalidByteEncoding ("Failed to decode local branch bytes: " <> tShow e) + Right localBranch -> do + let localIds' = + 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 = + HH.hashBranchFormatFull v2HashHandle localIds' localBranch + if actualHash == BranchHash expectedHash + then Nothing + else Just $ MismatchedNamespaceHash expectedHash (unBranchHash actualHash) + +validateTerm :: Hash -> (TermFormat.SyncLocallyIndexedComponent' Text Hash32) -> (Maybe HashValidationError) +validateTerm expectedHash syncLocalComp@(TermFormat.SyncLocallyIndexedComponent comps) = do + case Decode.unsyncTermComponent syncLocalComp of + Left _ -> Just (InvalidByteEncoding $ "Failed to decode term component bytes" <> tShow comps) + Right localComp -> do + case HH.verifyTermFormatHash v2HashHandle (ComponentHash expectedHash) (TermFormat.Term localComp) of + Nothing -> Nothing + Just (HH.HashMismatch {expectedHash, actualHash}) -> Just $ MismatchedTermHash expectedHash actualHash diff --git a/unison-share-api/unison-share-api.cabal b/unison-share-api/unison-share-api.cabal index 19a0827673..ee5ed900d9 100644 --- a/unison-share-api/unison-share-api.cabal +++ b/unison-share-api/unison-share-api.cabal @@ -45,6 +45,7 @@ library Unison.Server.Types Unison.Sync.API Unison.Sync.Common + Unison.Sync.HashValidation Unison.Sync.Types Unison.Util.Find hs-source-dirs: @@ -86,6 +87,7 @@ library , async , base , binary + , bytes , bytestring , containers , directory @@ -114,6 +116,7 @@ library , transformers , unison-codebase , unison-codebase-sqlite + , unison-codebase-sqlite-hashing-v2 , unison-core , unison-core1 , unison-hash