From 5bf5384be4c782f672866fbaa48f8f93177d3f2c Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 8 Nov 2023 12:46:00 -0800 Subject: [PATCH] Rig up error messaging for failed entity validation --- .../src/Unison/CommandLine/OutputMessages.hs | 33 +++++++++++++ unison-cli/src/Unison/Share/Sync.hs | 14 +++++- ...{HashValidation.hs => EntityValidation.hs} | 48 ++++++++----------- unison-share-api/src/Unison/Sync/Types.hs | 35 ++++++++++++++ unison-share-api/unison-share-api.cabal | 2 +- 5 files changed, 102 insertions(+), 30 deletions(-) rename unison-share-api/src/Unison/Sync/{HashValidation.hs => EntityValidation.hs} (68%) diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index d47281a4ec..fe87de2101 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -2210,6 +2210,7 @@ prettyDownloadEntitiesError = \case Share.DownloadEntitiesInvalidRepoInfo err repoInfo -> invalidRepoInfo err repoInfo Share.DownloadEntitiesUserNotFound userHandle -> shareUserNotFound (Share.RepoInfo userHandle) Share.DownloadEntitiesProjectNotFound project -> shareProjectNotFound project + Share.DownloadEntitiesEntityValidationFailure err -> prettyEntityValidationError err prettyFastForwardPathError :: Share.Path -> Share.FastForwardPathError -> Pretty prettyFastForwardPathError path = \case @@ -2307,6 +2308,38 @@ prettyTransportError = \case responseRequestId = fmap Text.decodeUtf8 . List.lookup "X-RequestId" . Foldable.toList @Seq . Servant.responseHeaders +prettyEntityValidationError :: Share.EntityValidationError -> Pretty +prettyEntityValidationError = \case + Share.EntityHashMismatch typ (Share.HashMismatchForEntity {supplied, computed}) -> + P.lines + [ P.wrap $ "The hash associated with the given " <> prettyEntityType typ <> " entity is incorrect.", + "", + P.wrap $ "The associated hash is: " <> prettyHash32 supplied, + P.wrap $ "The computed hash is: " <> prettyHash32 computed + ] + Share.UnsupportedEntityType hash typ -> + P.lines + [ P.wrap $ "The entity with hash " <> prettyHash32 hash <> " of type " <> prettyEntityType typ <> " is not supported by your version of ucm.", + P.wrap $ "Try upgrading to the latest version of ucm." + ] + Share.InvalidByteEncoding hash typ err -> + P.lines + [ P.wrap $ "Failed to decode a " <> prettyEntityType typ <> " entity with the hash " <> prettyHash32 hash <> ".", + "Please create an issue and report this to the Unison team", + "", + P.wrap $ "The error was: " <> P.text err + ] + +prettyEntityType :: Share.EntityType -> Pretty +prettyEntityType = \case + Share.TermComponentType -> "term component" + Share.DeclComponentType -> "type component" + Share.PatchType -> "patch" + Share.PatchDiffType -> "patch diff" + Share.NamespaceType -> "namespace" + Share.NamespaceDiffType -> "namespace diff" + Share.CausalType -> "causal" + invalidRepoInfo :: Text -> Share.RepoInfo -> Pretty invalidRepoInfo err repoInfo = P.lines diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 9115b360df..016f9c7760 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -21,6 +21,7 @@ module Unison.Share.Sync where import Control.Concurrent.STM +import Control.Lens import Control.Monad.Except import Control.Monad.Reader (ask) import Control.Monad.Trans.Reader (ReaderT, runReaderT) @@ -62,6 +63,7 @@ import Unison.Share.Sync.Types import Unison.Sqlite qualified as Sqlite import Unison.Sync.API qualified as Share (API) import Unison.Sync.Common (causalHashToHash32, entityToTempEntity, expectEntity, hash32ToCausalHash) +import Unison.Sync.EntityValidation qualified as EV import Unison.Sync.Types qualified as Share import Unison.Util.Monoid (foldMapM) @@ -428,6 +430,9 @@ downloadEntities unisonShareUrl repoInfo hashJwt downloadedCallback = do Left err -> failed (TransportError err) Right (Share.DownloadEntitiesFailure err) -> failed (SyncError err) Right (Share.DownloadEntitiesSuccess entities) -> pure entities + case validateEntities entities of + Left err -> failed . SyncError . Share.DownloadEntitiesEntityValidationFailure $ err + Right () -> pure () tempEntities <- Cli.runTransaction (insertEntities entities) liftIO (downloadedCallback 1) pure (NESet.nonEmptySet tempEntities) @@ -446,12 +451,19 @@ downloadEntities unisonShareUrl repoInfo hashJwt downloadedCallback = do tempEntities liftIO doCompleteTempEntities & onLeftM \err -> failed err - -- Since we may have just inserted and then deleted many temp entities, we attempt to recover some disk space by -- vacuuming after each pull. If the vacuum fails due to another open transaction on this connection, that's ok, -- we'll try vacuuming again next pull. _success <- liftIO (Codebase.withConnection codebase Sqlite.vacuum) pure (Right ()) + where + validateEntities :: NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT) -> Either Share.EntityValidationError () + validateEntities entities = + ifor_ (NEMap.toMap entities) \hash entity -> do + let entityWithHashes = entity & Share.entityHashes_ %~ Share.hashJWTHash + case EV.validateEntity hash entityWithHashes of + Nothing -> pure () + Just err -> Left err type WorkerCount = TVar Int diff --git a/unison-share-api/src/Unison/Sync/HashValidation.hs b/unison-share-api/src/Unison/Sync/EntityValidation.hs similarity index 68% rename from unison-share-api/src/Unison/Sync/HashValidation.hs rename to unison-share-api/src/Unison/Sync/EntityValidation.hs index 607213767c..5f0b1b480d 100644 --- a/unison-share-api/src/Unison/Sync/HashValidation.hs +++ b/unison-share-api/src/Unison/Sync/EntityValidation.hs @@ -2,15 +2,14 @@ {-# LANGUAGE DuplicateRecordFields #-} -- | Module for validating hashes of entities received/sent via sync. -module Unison.Sync.HashValidation - ( HashValidationError (..), - validateEntityHash, +module Unison.Sync.EntityValidation + ( validateEntity, ) where -import Control.Exception import Data.ByteString qualified as BS import Data.Bytes.Get (runGetS) +import Data.Text qualified as Text import U.Codebase.HashTags import U.Codebase.Sqlite.Branch.Format qualified as BranchFormat import U.Codebase.Sqlite.Decode qualified as Decode @@ -27,29 +26,15 @@ 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 +validateEntity :: Hash32 -> Share.Entity Text Hash32 Hash32 -> Maybe Share.EntityValidationError +validateEntity 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) + (Just $ Share.UnsupportedEntityType expectedHash32 Share.NamespaceDiffType) Entity.N (BranchFormat.SyncFull localIds (BranchFormat.LocalBranchBytes bytes)) -> do validateBranchFull expectedHash localIds bytes _ -> Nothing @@ -61,10 +46,10 @@ validateBranchFull :: Hash -> BranchFormat.BranchLocalIds' Text Hash32 Hash32 (Hash32, Hash32) -> BS.ByteString -> - (Maybe HashValidationError) + (Maybe Share.EntityValidationError) validateBranchFull expectedHash localIds bytes = do case runGetS Serialization.getLocalBranch bytes of - Left e -> Just $ InvalidByteEncoding ("Failed to decode local branch bytes: " <> tShow e) + Left e -> Just $ Share.InvalidByteEncoding (Hash32.fromHash expectedHash) Share.NamespaceType (Text.pack e) Right localBranch -> do let localIds' = localIds @@ -78,13 +63,20 @@ validateBranchFull expectedHash localIds bytes = do HH.hashBranchFormatFull v2HashHandle localIds' localBranch if actualHash == BranchHash expectedHash then Nothing - else Just $ MismatchedNamespaceHash expectedHash (unBranchHash actualHash) + else Just $ Share.EntityHashMismatch Share.NamespaceType (mismatch expectedHash (unBranchHash actualHash)) -validateTerm :: Hash -> (TermFormat.SyncLocallyIndexedComponent' Text Hash32) -> (Maybe HashValidationError) -validateTerm expectedHash syncLocalComp@(TermFormat.SyncLocallyIndexedComponent comps) = do +validateTerm :: Hash -> (TermFormat.SyncLocallyIndexedComponent' Text Hash32) -> (Maybe Share.EntityValidationError) +validateTerm expectedHash syncLocalComp = do case Decode.unsyncTermComponent syncLocalComp of - Left _ -> Just (InvalidByteEncoding $ "Failed to decode term component bytes" <> tShow comps) + Left decodeErr -> Just (Share.InvalidByteEncoding (Hash32.fromHash expectedHash) Share.TermComponentType (tShow decodeErr)) Right localComp -> do case HH.verifyTermFormatHash v2HashHandle (ComponentHash expectedHash) (TermFormat.Term localComp) of Nothing -> Nothing - Just (HH.HashMismatch {expectedHash, actualHash}) -> Just $ MismatchedTermHash expectedHash actualHash + Just (HH.HashMismatch {expectedHash, actualHash}) -> Just . Share.EntityHashMismatch Share.TermComponentType $ mismatch expectedHash actualHash + +mismatch :: Hash -> Hash -> Share.HashMismatchForEntity +mismatch supplied computed = + Share.HashMismatchForEntity + { supplied = Hash32.fromHash supplied, + computed = Hash32.fromHash computed + } diff --git a/unison-share-api/src/Unison/Sync/Types.hs b/unison-share-api/src/Unison/Sync/Types.hs index 98bff1866b..a44194d0a0 100644 --- a/unison-share-api/src/Unison/Sync/Types.hs +++ b/unison-share-api/src/Unison/Sync/Types.hs @@ -62,6 +62,7 @@ module Unison.Sync.Types HashMismatchForEntity (..), InvalidParentage (..), NeedDependencies (..), + EntityValidationError (..), ) where @@ -591,6 +592,7 @@ data DownloadEntitiesError DownloadEntitiesUserNotFound Text | -- | project shorthand DownloadEntitiesProjectNotFound Text + | DownloadEntitiesEntityValidationFailure EntityValidationError deriving stock (Eq, Show) instance ToJSON DownloadEntitiesResponse where @@ -600,6 +602,7 @@ instance ToJSON DownloadEntitiesResponse where DownloadEntitiesFailure (DownloadEntitiesInvalidRepoInfo msg repoInfo) -> jsonUnion "invalid_repo_info" (msg, repoInfo) DownloadEntitiesFailure (DownloadEntitiesUserNotFound userHandle) -> jsonUnion "user_not_found" userHandle DownloadEntitiesFailure (DownloadEntitiesProjectNotFound projectShorthand) -> jsonUnion "project_not_found" projectShorthand + DownloadEntitiesFailure (DownloadEntitiesEntityValidationFailure err) -> jsonUnion "entity_validation_failure" err instance FromJSON DownloadEntitiesResponse where parseJSON = Aeson.withObject "DownloadEntitiesResponse" \obj -> @@ -611,6 +614,38 @@ instance FromJSON DownloadEntitiesResponse where "project_not_found" -> DownloadEntitiesFailure . DownloadEntitiesProjectNotFound <$> obj .: "payload" t -> failText $ "Unexpected DownloadEntitiesResponse type: " <> t +-- | The ways in which validating an entity may fail. +data EntityValidationError + = EntityHashMismatch EntityType HashMismatchForEntity + | UnsupportedEntityType Hash32 EntityType + | InvalidByteEncoding Hash32 EntityType Text {- decoding err msg -} + deriving stock (Show, Eq, Ord) + deriving anyclass (Exception) + +instance ToJSON EntityValidationError where + toJSON = \case + EntityHashMismatch typ mismatch -> jsonUnion "mismatched_hash" (object ["type" .= typ, "mismatch" .= mismatch]) + UnsupportedEntityType hash typ -> jsonUnion "unsupported_entity_type" (object ["hash" .= hash, "type" .= typ]) + InvalidByteEncoding hash typ errMsg -> jsonUnion "invalid_byte_encoding" (object ["hash" .= hash, "type" .= typ, "error" .= errMsg]) + +instance FromJSON EntityValidationError where + parseJSON = Aeson.withObject "EntityValidationError" \obj -> + obj .: "type" >>= Aeson.withText "type" \case + "mismatched_hash" -> do + typ <- obj .: "payload" >>= (.: "type") + mismatch <- obj .: "payload" >>= (.: "mismatch") + pure (EntityHashMismatch typ mismatch) + "unsupported_entity_type" -> do + hash <- obj .: "payload" >>= (.: "hash") + typ <- obj .: "payload" >>= (.: "type") + pure (UnsupportedEntityType hash typ) + "invalid_byte_encoding" -> do + hash <- obj .: "payload" >>= (.: "hash") + typ <- obj .: "payload" >>= (.: "type") + errMsg <- obj .: "payload" >>= (.: "error") + pure (InvalidByteEncoding hash typ errMsg) + t -> failText $ "Unexpected EntityValidationError type: " <> t + ------------------------------------------------------------------------------------------------------------------------ -- Upload entities diff --git a/unison-share-api/unison-share-api.cabal b/unison-share-api/unison-share-api.cabal index ee5ed900d9..c88b3b0698 100644 --- a/unison-share-api/unison-share-api.cabal +++ b/unison-share-api/unison-share-api.cabal @@ -45,7 +45,7 @@ library Unison.Server.Types Unison.Sync.API Unison.Sync.Common - Unison.Sync.HashValidation + Unison.Sync.EntityValidation Unison.Sync.Types Unison.Util.Find hs-source-dirs: