reexport Data.Tuple.Only, move entityExists, update Sync error types

codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs

@@ -132,6 +132,7 @@ module U.Codebase.Sqlite.Queries
     garbageCollectWatchesWithoutObjects,
 
     -- * sync temp entities
+    entityExists,
     expectEntity,
     getMissingDependentsForTempEntity,
     getMissingDependencyJwtsForTempEntity,
@@ -151,6 +152,7 @@ module U.Codebase.Sqlite.Queries
 where
 
 import qualified Control.Lens as Lens
+import Control.Monad.Extra ((||^))
 import Data.Bitraversable (bitraverse)
 import Data.Bytes.Put (runPutS)
 import qualified Data.Foldable as Foldable
@@ -161,7 +163,6 @@ import qualified Data.Set as Set
 import Data.Set.NonEmpty (NESet)
 import qualified Data.Set.NonEmpty as NESet
 import Data.String.Here.Uninterpolated (here, hereFile)
-import Data.Tuple.Only (Only (..))
 import qualified Data.Vector as Vector
 import U.Codebase.HashTags (BranchHash (..), CausalHash (..), PatchHash (..))
 import U.Codebase.Reference (Reference' (..))
@@ -1412,6 +1413,15 @@ ancestorSql =
 
 -- * share sync / temp entities
 
+-- | Does this entity already exist in the database, i.e. in the `object` or `causal` table?
+entityExists :: Base32Hex -> Transaction Bool
+entityExists b32 = do
+  -- first get hashId if exists
+  loadHashId b32 >>= \case
+    Nothing -> pure False
+    -- then check if is causal hash or if object exists for hash id
+    Just hashId -> isCausalHash hashId ||^ isObjectHash hashId
+
 getMissingDependencyJwtsForTempEntity :: Base32Hex -> Transaction (Maybe (NESet Text))
 getMissingDependencyJwtsForTempEntity h = do
   jwts <-

codebase2/codebase-sqlite/U/Codebase/Sqlite/Reference.hs

@@ -4,14 +4,13 @@
 
 module U.Codebase.Sqlite.Reference where
 
-import Data.Tuple.Only (Only (..))
 import U.Codebase.Reference (Id' (Id), Reference' (ReferenceBuiltin, ReferenceDerived))
 import U.Codebase.Sqlite.DbId (HashId, ObjectId, TextId)
 import U.Codebase.Sqlite.LocalIds (LocalDefnId, LocalHashId, LocalTextId)
 import U.Codebase.Sqlite.Orphans ()
 import U.Util.Base32Hex
 import Unison.Prelude
-import Unison.Sqlite (FromField, FromRow (fromRow), RowParser, SQLData (SQLNull), ToField, ToRow (toRow), field)
+import Unison.Sqlite (FromField, FromRow (fromRow), Only (..), RowParser, SQLData (SQLNull), ToField, ToRow (toRow), field)
 
 type Reference = Reference' TextId ObjectId
 

codebase2/codebase-sqlite/U/Codebase/Sqlite/Referent.hs

@@ -6,13 +6,12 @@
 module U.Codebase.Sqlite.Referent where
 
 import Control.Applicative (liftA3)
-import Data.Tuple.Only (Only (..))
 import qualified U.Codebase.Reference as Reference
 import U.Codebase.Referent (Id', Referent')
 import qualified U.Codebase.Referent as Referent
 import U.Codebase.Sqlite.DbId (ObjectId)
 import qualified U.Codebase.Sqlite.Reference as Sqlite
-import Unison.Sqlite (FromRow (..), SQLData (..), ToField (toField), ToRow (..), field)
+import Unison.Sqlite (FromRow (..), Only (..), SQLData (..), ToField (toField), ToRow (..), field)
 
 type Referent = Referent' Sqlite.Reference Sqlite.Reference
 

lib/unison-sqlite/src/Unison/Sqlite.hs

@@ -104,6 +104,7 @@ module Unison.Sqlite
     (Sqlite.Simple.:.) (..),
     Sqlite.Simple.FromField (fromField),
     Sqlite.Simple.FromRow (fromRow),
+    Sqlite.Simple.Only(..),
     Sqlite.Simple.RowParser,
     Sqlite.Simple.SQLData (..),
     Sqlite.Simple.ToField (toField),

unison-cli/src/Unison/Share/Sync.hs

@@ -26,7 +26,6 @@ module Unison.Share.Sync
 where
 
 import qualified Control.Lens as Lens
-import Control.Monad.Extra ((||^))
 import Control.Monad.Trans.Reader (ReaderT, runReaderT)
 import qualified Control.Monad.Trans.Reader as Reader
 import qualified Data.Foldable as Foldable (find)
@@ -454,22 +453,13 @@ data EntityLocation
   | -- | Nowhere
     EntityNotStored
 
--- | Does this entity already exist in the database, i.e. in the `object` or `causal` table?
-entityExists :: Share.Hash -> Sqlite.Transaction Bool
-entityExists (Share.Hash b32) = do
-  -- first get hashId if exists
-  Q.loadHashId b32 >>= \case
-    Nothing -> pure False
-    -- then check if is causal hash or if object exists for hash id
-    Just hashId -> Q.isCausalHash hashId ||^ Q.isObjectHash hashId
-
 -- | Where is an entity stored?
 entityLocation :: Share.Hash -> Sqlite.Transaction EntityLocation
-entityLocation hash =
-  entityExists hash >>= \case
+entityLocation (Share.Hash b32) =
+  Q.entityExists b32 >>= \case
     True -> pure EntityInMainStorage
     False ->
-      Q.getMissingDependencyJwtsForTempEntity (Share.toBase32Hex hash) <&> \case
+      Q.getMissingDependencyJwtsForTempEntity b32 <&> \case
         Nothing -> EntityNotStored
         Just missingDependencies -> EntityInTempStorage (NESet.map Share.HashJWT missingDependencies)
 
@@ -525,7 +515,7 @@ upsertEntitySomewhere hash entity =
       -- otherwise add it to main storage.
       missingDependencies0 <-
         Set.filterM
-          (entityExists . Share.decodedHashJWTHash)
+          (Q.entityExists . Share.toBase32Hex . Share.decodedHashJWTHash)
           (Set.map Share.decodeHashJWT (Share.entityDependencies entity))
       case NESet.nonEmptySet missingDependencies0 of
         Nothing -> insertEntity hash entity

unison-share-api/src/Unison/Sync/Types.hs

@@ -640,6 +640,10 @@ data UploadEntitiesResponse
   = UploadEntitiesSuccess
   | UploadEntitiesNeedDependencies (NeedDependencies Hash)
   | UploadEntitiesNoWritePermission RepoName
+  | UploadEntitiesHashMismatchForEntity HashMismatchForEntity
+  deriving stock (Show, Eq, Ord)
+
+data HashMismatchForEntity = HashMismatchForEntity {supplied :: Hash, computed :: Hash}
   deriving stock (Show, Eq, Ord)
 
 instance ToJSON UploadEntitiesResponse where
@@ -647,16 +651,23 @@ instance ToJSON UploadEntitiesResponse where
     UploadEntitiesSuccess -> jsonUnion "success" (Object mempty)
     UploadEntitiesNeedDependencies nd -> jsonUnion "need_dependencies" nd
     UploadEntitiesNoWritePermission repoName -> jsonUnion "no_write_permission" repoName
+    UploadEntitiesHashMismatchForEntity mismatch -> jsonUnion "hash_mismatch_for_entity" mismatch
 
 instance FromJSON UploadEntitiesResponse where
-  parseJSON v =
-    v & Aeson.withObject "UploadEntitiesResponse" \obj ->
+  parseJSON = Aeson.withObject "UploadEntitiesResponse" \obj ->
     obj .: "type" >>= Aeson.withText "type" \case
       "success" -> pure UploadEntitiesSuccess
       "need_dependencies" -> UploadEntitiesNeedDependencies <$> obj .: "payload"
       "no_write_permission" -> UploadEntitiesNoWritePermission <$> obj .: "payload"
+      "hash_mismatch_for_entity" -> UploadEntitiesHashMismatchForEntity <$> obj .: "payload"
       t -> failText $ "Unexpected UploadEntitiesResponse type: " <> t
 
+instance ToJSON HashMismatchForEntity where
+  toJSON (HashMismatchForEntity supplied computed) = object ["supplied" .= supplied, "computed" .= computed]
+
+instance FromJSON HashMismatchForEntity where
+  parseJSON = Aeson.withObject "HashMismatchForEntity" \obj -> HashMismatchForEntity <$> obj .: "supplied" <*> obj .: "computed"
+
 ------------------------------------------------------------------------------------------------------------------------
 -- Fast-forward path
 
@@ -684,8 +695,10 @@ instance FromJSON UploadEntitiesResponse where
 -- Note that if the client wants to begin a history at a new path on the server, it would use the "update path" endpoint
 -- instead.
 data FastForwardPathRequest = FastForwardPathRequest
-  { -- TODO non-empty
-    hashes :: [Hash],
+  { -- expected_hash :: Hash,
+
+    -- | The sequence of causals to fast-forward, starting from the oldest new causal to the newest new causal
+    hashes :: NonEmpty Hash,
     -- | The path to fast-forward.
     path :: Path
   }
@@ -713,6 +726,11 @@ data FastForwardPathResponse
     FastForwardPathNotFastForward HashJWT
   | -- | There was no history at this path; the client should use the "update path" endpoint instead.
     FastForwardPathNoHistory
+  | -- | This wasn't a fast-forward. You said the first hash was a parent of the second hash, but I disagree.
+    FastForwardPathInvalidParentage InvalidParentage
+  deriving stock (Show)
+
+data InvalidParentage = InvalidParentage {parent :: Hash, child :: Hash}
   deriving stock (Show)
 
 instance ToJSON FastForwardPathResponse where
@@ -722,6 +740,7 @@ instance ToJSON FastForwardPathResponse where
     FastForwardPathNoWritePermission path -> jsonUnion "no_write_permission" path
     FastForwardPathNotFastForward hashJwt -> jsonUnion "not_fast_forward" hashJwt
     FastForwardPathNoHistory -> jsonUnion "no_history" (Object mempty)
+    FastForwardPathInvalidParentage invalidParentage -> jsonUnion "invalid_parentage" invalidParentage
 
 instance FromJSON FastForwardPathResponse where
   parseJSON =
@@ -732,8 +751,16 @@ instance FromJSON FastForwardPathResponse where
         "no_write_permission" -> FastForwardPathNoWritePermission <$> o .: "payload"
         "not_fast_forward" -> FastForwardPathNotFastForward <$> o .: "payload"
         "no_history" -> pure FastForwardPathNoHistory
+        "invalid_parentage" -> FastForwardPathInvalidParentage <$> o .: "payload"
         t -> failText $ "Unexpected FastForwardPathResponse type: " <> t
 
+instance ToJSON InvalidParentage where
+  toJSON (InvalidParentage parent child) = object ["parent" .= parent, "child" .= child]
+
+instance FromJSON InvalidParentage where
+  parseJSON =
+    Aeson.withObject "InvalidParentage" \o -> InvalidParentage <$> o .: "parent" <*> o .: "child"
+
 ------------------------------------------------------------------------------------------------------------------------
 -- Update path