Merge branch 'cp/pull-hash-validation' into cp/pull-hash-validation-t…

…ypes
unisonweb · Nov 9, 2023 · 07a53cc · 07a53cc
2 parents d4baadc + 1e415c4
commit 07a53cc
Show file tree

Hide file tree

Showing 2 changed files with 23 additions and 20 deletions.
diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs
@@ -22,6 +22,8 @@ where
 
 import Control.Concurrent.STM
 import Control.Lens
+import GHC.IO (unsafePerformIO)
+import System.Environment (lookupEnv)
 import Control.Monad.Except
 import Control.Monad.Reader (ask)
 import Control.Monad.Trans.Reader (ReaderT, runReaderT)
@@ -459,11 +461,26 @@ downloadEntities unisonShareUrl repoInfo hashJwt downloadedCallback = do
   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
+      when shouldValidateEntities $ do
+        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
+
+-- | Only validate entities if this flag is set.
+-- It defaults to disabled because there are terms in the wild that currently fail hash
+-- validation.
+validationEnvKey :: String
+validationEnvKey = "UNISON_ENTITY_VALIDATION"
+
+shouldValidateEntities :: Bool
+shouldValidateEntities = unsafePerformIO $ do
+  lookupEnv validationEnvKey <&> \case
+    Just "true" -> True
+    _ -> False
+{-# NOINLINE shouldValidateEntities #-}
+
 
 type WorkerCount =
   TVar Int

diff --git a/unison-share-api/src/Unison/Sync/EntityValidation.hs b/unison-share-api/src/Unison/Sync/EntityValidation.hs
@@ -11,8 +11,6 @@ import Data.ByteString qualified as BS
 import Data.Bytes.Get (runGetS)
 import Data.Set qualified as Set
 import Data.Text qualified as Text
-import GHC.IO (unsafePerformIO)
-import System.Environment (lookupEnv)
 import U.Codebase.HashTags
 import U.Codebase.Sqlite.Branch.Format qualified as BranchFormat
 import U.Codebase.Sqlite.Causal qualified as CausalFormat
@@ -32,21 +30,10 @@ import Unison.Prelude
 import Unison.Sync.Common qualified as Share
 import Unison.Sync.Types qualified as Share
 
-validationEnvKey :: String
-validationEnvKey = "UNISON_ENTITY_VALIDATION"
-
-shouldValidateEntities :: Bool
-shouldValidateEntities = unsafePerformIO $ do
-  lookupEnv validationEnvKey <&> \case
-    Just "true" -> True
-    _ -> False
-{-# NOINLINE shouldValidateEntities #-}
-
 -- | 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 expectedHash32 entity
-  | shouldValidateEntities = do
+validateEntity expectedHash32 entity = do
       case Share.entityToTempEntity id entity of
         Entity.TC (TermFormat.SyncTerm localComp) -> do
           validateTerm expectedHash localComp
@@ -59,7 +46,6 @@ validateEntity expectedHash32 entity
         Entity.C CausalFormat.SyncCausalFormat {valueHash, parents} -> do
           validateCausal expectedHash32 valueHash (toList parents)
         _ -> Nothing
-  | otherwise = Nothing
   where
     expectedHash :: Hash
     expectedHash = Hash32.toHash expectedHash32