Merge pull request #164 from unisoncomputing/cp/reject-ambiguous-element-orderings

Reject ambiguous element orderings

Author: ChrisPenner

.github/workflows/ci.yaml

@@ -330,7 +330,7 @@ jobs:
 
           # Install ucm
           mkdir ucm
-          curl -L https://github.com/unisonweb/unison/releases/download/release%2F0.5.47/ucm-linux-x64.tar.gz | tar -xz -C ucm
+          curl -L https://github.com/unisonweb/unison/releases/download/release%2F1.0.0/ucm-linux-x64.tar.gz | tar -xz -C ucm
           export PATH=$PWD/ucm:$PATH
 
           # Start share and it's dependencies in the background

Makefile

@@ -4,9 +4,8 @@ SHARE_PROJECT_ROOT := $(dir $(abspath $(lastword $(MAKEFILE_LIST))))
 export SHARE_PROJECT_ROOT
 UNAME := $(shell uname)
 STACK_FLAGS := "--fast"
-dist_dir := $(shell stack path | awk '/^dist-dir/{print $$2}')
 exe_name := share-api
-exe := $(dist_dir)/build/$(exe_name)/$(exe_name)
+exe := $(shell stack exec -- which $(exe_name))
 target_dir := docker/tmp
 installed_share := $(target_dir)/$(exe_name)
 unison := $(shell command -v unison)
@@ -27,10 +26,9 @@ endif
 $(target_dir):
 	mkdir $@
 
-$(exe): $(shell find . unison -type f -name '*.hs') $(shell find . unison -type f -name '*.yaml')
-	@echo $(exe)
-	@echo $@
-	stack build $(STACK_FLAGS)
+$(exe): $(shell fd '' . unison --type file -e hs 2>/dev/null || find . unison -type f -name '*.hs') $(shell fd '' . unison --type file -e yaml 2>/dev/null || find . unison -type f -name '*.yaml')
+	@echo Building $(exe_name)
+	stack build $(STACK_FLAGS) $(exe_name)
 
 $(installed_share): $(exe) $(target_dir)
 	cp $(exe) $(installed_share)

share-api/src/Share/Web/UCM/Sync/Impl.hs

@@ -52,6 +52,7 @@ import Share.Web.Errors
 import Share.Web.UCM.Sync.HashJWT qualified as HashJWT
 import Share.Web.UCM.Sync.Types (EntityBunch (..), RepoInfoKind (..), entityKind)
 import U.Codebase.Causal qualified as Causal
+import U.Codebase.Sqlite.HashHandle qualified as HH
 import U.Codebase.Sqlite.Orphans ()
 import Unison.Codebase.Path qualified as Path
 import Unison.Hash32 (Hash32)
@@ -259,11 +260,11 @@ insertEntitiesToCodebase codebase entities = do
     mayErrs <- PG.transactionUnsafeIO $ batchValidateEntities maxParallelismPerUploadRequest isComponentHashMismatchAllowedIO isCausalHashMismatchAllowedIO unsavedEntities
     case mayErrs of
       Nothing -> pure ()
-      Just (err :| _errs) -> throwError err
-    -- case err of
-    --   Right e -> throwError e
-    --   Left () ->
-    --     throwError $ Sync.InvalidByteEncoding (Hash32.fromHash hash) Sync.TermComponentType "Incomplete element ordering in term components"
+      Just (err :| _errs) ->
+        case err of
+          Right e -> throwError e
+          Left (HH.IncompleteElementOrderingError (ComponentHash hash)) ->
+            throwError $ Sync.InvalidByteEncoding (Hash32.fromHash hash) Sync.TermComponentType "Incomplete element ordering in term components"
     SyncQ.saveTempEntities codebase unsavedEntities
     let hashesNowInTemp = Set.fromList (fst <$> Foldable.toList unsavedEntities) <> (Set.fromList . Foldable.toList $ hashesAlreadyInTemp)
     pure hashesNowInTemp
@@ -397,7 +398,7 @@ batchValidateEntities ::
   (ComponentHash -> ComponentHash -> IO Bool) ->
   (CausalHash -> CausalHash -> IO Bool) ->
   f (Hash32, Sync.Entity Text Hash32 Hash32) ->
-  IO (Maybe (NonEmpty Sync.EntityValidationError))
+  IO (Maybe (NonEmpty (Either HH.HashingFailure Sync.EntityValidationError)))
 batchValidateEntities maxParallelism checkIfComponentHashMismatchIsAllowed checkIfCausalHashMismatchIsAllowed entities = do
   errs <- UnliftIO.pooledForConcurrentlyN maxParallelism entities \(hash, entity) ->
     validateEntity checkIfComponentHashMismatchIsAllowed checkIfCausalHashMismatchIsAllowed hash entity
@@ -409,16 +410,16 @@ validateEntity ::
   (CausalHash -> CausalHash -> m Bool) ->
   Hash32 ->
   Share.Entity Text Hash32 Hash32 ->
-  m (Maybe Sync.EntityValidationError)
+  m (Maybe (Either HH.HashingFailure Sync.EntityValidationError))
 validateEntity checkIfComponentHashMismatchIsAllowed checkIfCausalHashMismatchIsAllowed hash entity = do
   case (Sync.validateEntity hash entity) of
-    Just (err@(Sync.EntityHashMismatch Sync.TermComponentType (Sync.HashMismatchForEntity {supplied = expectedHash, computed = actualHash}))) ->
+    Just (Right (err@(Sync.EntityHashMismatch Sync.TermComponentType (Sync.HashMismatchForEntity {supplied = expectedHash, computed = actualHash})))) ->
       checkIfComponentHashMismatchIsAllowed (ComponentHash . Hash32.toHash $ expectedHash) (ComponentHash . Hash32.toHash $ actualHash) >>= \case
-        False -> pure (Just err)
+        False -> pure (Just $ Right err)
         True -> pure Nothing
-    Just (err@(Sync.EntityHashMismatch Sync.CausalType (Sync.HashMismatchForEntity {supplied = expectedHash, computed = actualHash}))) ->
+    Just (Right (err@(Sync.EntityHashMismatch Sync.CausalType (Sync.HashMismatchForEntity {supplied = expectedHash, computed = actualHash})))) ->
       checkIfCausalHashMismatchIsAllowed (CausalHash . Hash32.toHash $ expectedHash) (CausalHash . Hash32.toHash $ actualHash) >>= \case
-        False -> pure (Just err)
+        False -> pure (Just $ Right err)
         True -> pure Nothing
     Just err ->
       -- This shouldn't happen unless the ucm client is buggy or malicious

share-task-runner/src/Share/Tasks/AmbiguousComponentCheck.hs

@@ -8,6 +8,7 @@ import Share.Postgres.Cursors qualified as PG
 import Share.Prelude
 import Share.Utils.Logging (Loggable (..))
 import Share.Utils.Logging qualified as Logging
+import U.Codebase.Sqlite.HashHandle qualified as HH
 import U.Codebase.Sqlite.TempEntity
 import Unison.Hash32
 import Unison.Sync.EntityValidation qualified as EV
@@ -17,7 +18,7 @@ import Unison.Util.Servant.CBOR qualified as CBOR
 
 data AmbiguousComponentCheckError
   = TaskAmbiguousComponentCheckError Hash32
-  | TaskEntityValidationError Hash32 (Sync.EntityValidationError)
+  | TaskEntityValidationError Hash32 (Either HH.HashingFailure Sync.EntityValidationError)
   | TaskEntityDecodingError Hash32 CBOR.DeserialiseFailure
   deriving (Show, Eq)
 

transcripts/run-transcripts.zsh

@@ -12,7 +12,9 @@ done;
 
 source "$(realpath "$(dirname "$0")")/transcript_helpers.sh"
 
-# Base directory containing all transcripts
+echo "UCM Version: $(transcript_ucm --version)"
+
+# Base directory containing share-api transcripts
 transcripts_location="transcripts/share-apis"
 
 # Find all directories within transcripts_location

transcripts/share-apis/branch-browse/branch-find.json

@@ -136,6 +136,7 @@
               {
                 "annotation": {
                   "contents": "#r7hq9rqc3hebqailf77f656vbgice0716c6f0j7bj06muhj5ac1pq103gdh5974f14fcbmvp44fai5in1ajp5j3ejckfp6bffd3fpoo",
+                  "fqn": "Remote",
                   "tag": "TypeReference"
                 },
                 "segment": "Remote"

transcripts/share-apis/code-browse/codebase-definition-by-hash-constructor.json

@@ -44,6 +44,7 @@
             {
               "annotation": {
                 "contents": "#6kbe32g06nqg93cqub6ohqc4ql4o49ntgnunifds0t75qre6lacnbsr3evn8bkivj68ecbvmhkbak4dbg4fqertcpgb396rmo34tnh0#d0",
+                "fqn": "names.Thing.This",
                 "tag": "TermReference"
               },
               "segment": "This"
@@ -57,6 +58,7 @@
             {
               "annotation": {
                 "contents": "#6kbe32g06nqg93cqub6ohqc4ql4o49ntgnunifds0t75qre6lacnbsr3evn8bkivj68ecbvmhkbak4dbg4fqertcpgb396rmo34tnh0#d1",
+                "fqn": "names.Thing.That",
                 "tag": "TermReference"
               },
               "segment": "That"

transcripts/share-apis/code-browse/codebase-definition-by-hash-term.json

@@ -9,6 +9,7 @@
           {
             "annotation": {
               "contents": "##Nat",
+              "fqn": "builtin.Nat",
               "tag": "TypeReference"
             },
             "segment": "Nat"
@@ -36,6 +37,7 @@
             {
               "annotation": {
                 "contents": "##Nat",
+                "fqn": "builtin.Nat",
                 "tag": "TypeReference"
               },
               "segment": "Nat"

transcripts/share-apis/code-browse/codebase-definition-by-name-encoded.json

@@ -49,6 +49,7 @@
           {
             "annotation": {
               "contents": "##Nat",
+              "fqn": "builtin.Nat",
               "tag": "TypeReference"
             },
             "segment": "Nat"
@@ -128,6 +129,7 @@
             {
               "annotation": {
                 "contents": "##Nat",
+                "fqn": "builtin.Nat",
                 "tag": "TypeReference"
               },
               "segment": "Nat"

transcripts/share-apis/code-browse/codebase-definition-by-name-should-minimally-suffix-again.json

@@ -9,6 +9,7 @@
           {
             "annotation": {
               "contents": "##Nat",
+              "fqn": "builtin.Nat",
               "tag": "TypeReference"
             },
             "segment": "Nat"
@@ -36,6 +37,7 @@
             {
               "annotation": {
                 "contents": "##Nat",
+                "fqn": "builtin.Nat",
                 "tag": "TypeReference"
               },
               "segment": "Nat"