Rig up error messaging for failed entity validation

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

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

unison-share-api/src/Unison/Sync/HashValidation.hs → 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
+    }

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
 

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: