diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs index b688b8909..4a37c108e 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs @@ -163,6 +163,7 @@ import U.Codebase.WatchKind (WatchKind) import qualified U.Core.ABT as ABT import qualified U.Util.Base32Hex as Base32Hex import qualified U.Util.Hash as H +import qualified U.Util.Hash32 as Hash32 import qualified U.Util.Lens as Lens import qualified U.Util.Serialization as S import qualified U.Util.Term as TermUtil @@ -186,7 +187,7 @@ newtype NeedTypeForBuiltinMetadata objectExistsForHash :: H.Hash -> Transaction Bool objectExistsForHash h = isJust <$> runMaybeT do - id <- MaybeT . Q.loadHashId . H.toBase32Hex $ h + id <- MaybeT . Q.loadHashId . Hash32.fromHash $ h MaybeT $ Q.loadObjectIdForAnyHashId id expectValueHashByCausalHashId :: Db.CausalHashId -> Transaction BranchHash diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 2f6571eca..067b3c0d9 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -200,9 +200,11 @@ import qualified U.Codebase.Sqlite.TempEntityType as TempEntityType import qualified U.Codebase.Sqlite.Term.Format as TermFormat import U.Codebase.WatchKind (WatchKind) import qualified U.Util.Alternative as Alternative -import U.Util.Base32Hex (Base32Hex (..)) import U.Util.Hash (Hash) import qualified U.Util.Hash as Hash +import U.Util.Hash32 (Hash32) +import qualified U.Util.Hash32 as Hash32 +import U.Util.Hash32.Orphans.Sqlite () import Unison.Prelude import Unison.Sqlite @@ -259,28 +261,28 @@ countCausals = queryOneCol_ [here| SELECT COUNT(*) FROM causal |] countWatches :: Transaction Int countWatches = queryOneCol_ [here| SELECT COUNT(*) FROM watch |] -saveHash :: Base32Hex -> Transaction HashId -saveHash base32 = execute sql (Only base32) >> expectHashId base32 +saveHash :: Hash32 -> Transaction HashId +saveHash hash = execute sql (Only hash) >> expectHashId hash where sql = [here| INSERT INTO hash (base32) VALUES (?) ON CONFLICT DO NOTHING |] saveHashHash :: Hash -> Transaction HashId -saveHashHash = saveHash . Hash.toBase32Hex +saveHashHash = saveHash . Hash32.fromHash -loadHashId :: Base32Hex -> Transaction (Maybe HashId) -loadHashId base32 = queryMaybeCol loadHashIdSql (Only base32) +loadHashId :: Hash32 -> Transaction (Maybe HashId) +loadHashId hash = queryMaybeCol loadHashIdSql (Only hash) -expectHashId :: Base32Hex -> Transaction HashId -expectHashId base32 = queryOneCol loadHashIdSql (Only base32) +expectHashId :: Hash32 -> Transaction HashId +expectHashId hash = queryOneCol loadHashIdSql (Only hash) loadHashIdSql :: Sql loadHashIdSql = [here| SELECT id FROM hash WHERE base32 = ? |] loadHashIdByHash :: Hash -> Transaction (Maybe HashId) -loadHashIdByHash = loadHashId . Hash.toBase32Hex +loadHashIdByHash = loadHashId . Hash32.fromHash saveCausalHash :: CausalHash -> Transaction CausalHashId saveCausalHash = fmap CausalHashId . saveHashHash . unCausalHash @@ -311,12 +313,12 @@ expectCausalByCausalHash ch = do pure (hId, bhId) expectHashIdByHash :: Hash -> Transaction HashId -expectHashIdByHash = expectHashId . Hash.toBase32Hex +expectHashIdByHash = expectHashId . Hash32.fromHash expectHash :: HashId -> Transaction Hash -expectHash h = Hash.fromBase32Hex <$> expectHash32 h +expectHash h = Hash32.toHash <$> expectHash32 h -expectHash32 :: HashId -> Transaction Base32Hex +expectHash32 :: HashId -> Transaction Hash32 expectHash32 h = queryOneCol sql (Only h) where sql = [here| SELECT base32 FROM hash WHERE id = ? |] @@ -485,22 +487,22 @@ loadObjectIdForPrimaryHash h = expectObjectIdForPrimaryHash :: Hash -> Transaction ObjectId expectObjectIdForPrimaryHash = - expectObjectIdForHash32 . Hash.toBase32Hex + expectObjectIdForHash32 . Hash32.fromHash -expectObjectIdForHash32 :: Base32Hex -> Transaction ObjectId +expectObjectIdForHash32 :: Hash32 -> Transaction ObjectId expectObjectIdForHash32 hash = do hashId <- expectHashId hash expectObjectIdForPrimaryHashId hashId -expectBranchObjectIdForHash32 :: Base32Hex -> Transaction BranchObjectId +expectBranchObjectIdForHash32 :: Hash32 -> Transaction BranchObjectId expectBranchObjectIdForHash32 = fmap BranchObjectId . expectObjectIdForHash32 -expectPatchObjectIdForHash32 :: Base32Hex -> Transaction PatchObjectId +expectPatchObjectIdForHash32 :: Hash32 -> Transaction PatchObjectId expectPatchObjectIdForHash32 = fmap PatchObjectId . expectObjectIdForHash32 -expectBranchHashIdForHash32 :: Base32Hex -> Transaction BranchHashId +expectBranchHashIdForHash32 :: Hash32 -> Transaction BranchHashId expectBranchHashIdForHash32 = queryOneCol sql . Only where sql = @@ -512,7 +514,7 @@ expectBranchHashIdForHash32 = queryOneCol sql . Only AND hash.base32 = ? |] -expectCausalHashIdForHash32 :: Base32Hex -> Transaction CausalHashId +expectCausalHashIdForHash32 :: Hash32 -> Transaction CausalHashId expectCausalHashIdForHash32 = queryOneCol sql . Only where sql = @@ -556,9 +558,9 @@ isObjectHash h = -- | All objects have corresponding hashes. expectPrimaryHashByObjectId :: ObjectId -> Transaction Hash expectPrimaryHashByObjectId = - fmap Hash.fromBase32Hex . expectPrimaryHash32ByObjectId + fmap Hash32.toHash . expectPrimaryHash32ByObjectId -expectPrimaryHash32ByObjectId :: ObjectId -> Transaction Base32Hex +expectPrimaryHash32ByObjectId :: ObjectId -> Transaction Hash32 expectPrimaryHash32ByObjectId oId = queryOneCol sql (Only oId) where sql = [here| SELECT hash.base32 @@ -625,11 +627,11 @@ flushCausalDependents chId = do -- 2. Delete #foo from temp_entity (if it's there) -- 3. For each like #bar and #baz with no more rows in temp_entity_missing_dependency, -- insert_entity them. -tryMoveTempEntityDependents :: Base32Hex -> Transaction () -tryMoveTempEntityDependents dependencyBase32 = do - dependents <- getMissingDependentsForTempEntity dependencyBase32 - execute deleteMissingDependency (Only dependencyBase32) - deleteTempEntity dependencyBase32 +tryMoveTempEntityDependents :: Hash32 -> Transaction () +tryMoveTempEntityDependents dependency = do + dependents <- getMissingDependentsForTempEntity dependency + execute deleteMissingDependency (Only dependency) + deleteTempEntity dependency traverse_ flushIfReadyToFlush dependents where deleteMissingDependency :: Sql @@ -638,14 +640,14 @@ tryMoveTempEntityDependents dependencyBase32 = do WHERE dependency = ? |] - flushIfReadyToFlush :: Base32Hex -> Transaction () + flushIfReadyToFlush :: Hash32 -> Transaction () flushIfReadyToFlush dependent = do readyToFlush dependent >>= \case True -> moveTempEntityToMain dependent False -> pure () - readyToFlush :: Base32Hex -> Transaction Bool - readyToFlush b32 = queryOneCol [here| + readyToFlush :: Hash32 -> Transaction Bool + readyToFlush hash = queryOneCol [here| SELECT EXISTS ( SELECT 1 FROM temp_entity @@ -655,7 +657,7 @@ tryMoveTempEntityDependents dependencyBase32 = do FROM temp_entity_missing_dependency WHERE dependent = ? ) - |] (b32, b32) + |] (hash, hash) expectCausal :: CausalHashId -> Transaction Causal.SyncCausalFormat expectCausal hashId = do @@ -680,7 +682,7 @@ expectCausal hashId = do pure Causal.SyncCausalFormat {parents, valueHash} -- | Read an entity out of main storage. -expectEntity :: Base32Hex -> Transaction SyncEntity +expectEntity :: Hash32 -> Transaction SyncEntity expectEntity hash = do hashId <- expectHashId hash -- We don't know if this is an object or a causal, so just try one, then the other. @@ -694,18 +696,18 @@ expectEntity hash = do Namespace -> Entity.N <$> decodeSyncNamespaceFormat bytes Patch -> Entity.P <$> decodeSyncPatchFormat bytes -moveTempEntityToMain :: Base32Hex -> Transaction () -moveTempEntityToMain b32 = do - t <- expectTempEntity b32 - deleteTempEntity b32 - r <- tempToSyncEntity t - _ <- saveSyncEntity b32 r +moveTempEntityToMain :: Hash32 -> Transaction () +moveTempEntityToMain hash = do + entity <- expectTempEntity hash + deleteTempEntity hash + entity' <- tempToSyncEntity entity + _ <- saveSyncEntity hash entity' pure () -- | Read an entity out of temp storage. -expectTempEntity :: Base32Hex -> Transaction TempEntity -expectTempEntity b32 = do - queryOneRowCheck sql (Only b32) \(blob, typeId) -> +expectTempEntity :: Hash32 -> Transaction TempEntity +expectTempEntity hash = do + queryOneRowCheck sql (Only hash) \(blob, typeId) -> case typeId of TempEntityType.TermComponentType -> Entity.TC <$> decodeTempTermFormat blob TempEntityType.DeclComponentType -> Entity.DC <$> decodeTempDeclFormat blob @@ -851,9 +853,9 @@ syncToTempEntity = \case TermFormat.SyncTerm . TermFormat.SyncLocallyIndexedComponent <$> Lens.traverseOf (traverse . Lens._1) (bitraverse expectText expectPrimaryHash32ByObjectId) terms -saveSyncEntity :: Base32Hex -> SyncEntity -> Transaction (Either CausalHashId ObjectId) -saveSyncEntity b32Hex entity = do - hashId <- saveHash b32Hex +saveSyncEntity :: Hash32 -> SyncEntity -> Transaction (Either CausalHashId ObjectId) +saveSyncEntity hash entity = do + hashId <- saveHash hash case entity of Entity.TC stf -> do let bytes = runPutS (Serialization.recomposeTermFormat stf) @@ -932,7 +934,7 @@ loadCausalParents h = queryListCol sql (Only h) where sql = [here| |] -- | Like 'loadCausalParents', but the input and outputs are hashes, not hash ids. -loadCausalParentsByHash :: Base32Hex -> Transaction [Base32Hex] +loadCausalParentsByHash :: Hash32 -> Transaction [Hash32] loadCausalParentsByHash hash = queryListCol [here| @@ -1440,7 +1442,7 @@ 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 :: Hash32 -> Transaction Bool entityExists hash = do -- first get hashId if exists loadHashId hash >>= \case @@ -1448,7 +1450,7 @@ entityExists hash = do -- 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 :: Hash32 -> Transaction (Maybe (NESet Text)) getMissingDependencyJwtsForTempEntity h = do jwts <- queryListCol @@ -1459,7 +1461,7 @@ getMissingDependencyJwtsForTempEntity h = do (Only h) pure (NESet.nonEmptySet (Set.fromList jwts)) -getMissingDependentsForTempEntity :: Base32Hex -> Transaction [Base32Hex] +getMissingDependentsForTempEntity :: Hash32 -> Transaction [Hash32] getMissingDependentsForTempEntity h = queryListCol [here| @@ -1474,7 +1476,7 @@ getMissingDependentsForTempEntity h = -- Preconditions: -- 1. The entity does not already exist in "main" storage (`object` / `causal`) -- 2. The entity does not already exist in `temp_entity`. -insertTempEntity :: Base32Hex -> TempEntity -> NESet (Base32Hex, Text) -> Transaction () +insertTempEntity :: Hash32 -> TempEntity -> NESet (Hash32, Text) -> Transaction () insertTempEntity entityHash entity missingDependencies = do execute [here| @@ -1499,7 +1501,7 @@ insertTempEntity entityHash entity missingDependencies = do Entity.entityType entity -- | Delete a row from the `temp_entity` table, if it exists. -deleteTempEntity :: Base32Hex -> Transaction () +deleteTempEntity :: Hash32 -> Transaction () deleteTempEntity hash = execute [here| diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs index c93b495f0..688091356 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs @@ -14,12 +14,9 @@ import Data.Bytes.Get (MonadGet, getByteString, getWord8, runGetS) import Data.Bytes.Put (MonadPut, putByteString, putWord8) import Data.Bytes.Serial (SerialEndian (serializeBE), deserialize, deserializeBE, serialize) import Data.Bytes.VarInt (VarInt (VarInt), unVarInt) -import Data.Int (Int64) import Data.List (elemIndex) import qualified Data.Set as Set import Data.Vector (Vector) -import Data.Word (Word64) -import Debug.Trace (trace) import qualified U.Codebase.Decl as Decl import U.Codebase.Kind (Kind) import qualified U.Codebase.Kind as Kind @@ -46,10 +43,12 @@ import qualified U.Codebase.Sqlite.Term.Format as TermFormat import qualified U.Codebase.Term as Term import qualified U.Codebase.Type as Type import qualified U.Core.ABT as ABT -import U.Util.Base32Hex (Base32Hex) import qualified U.Util.Base32Hex as Base32Hex +import U.Util.Hash32 (Hash32) +import qualified U.Util.Hash32 as Hash32 import qualified U.Util.Monoid as Monoid import U.Util.Serialization hiding (debug) +import Unison.Prelude import Prelude hiding (getChar, putChar) debug :: Bool @@ -749,31 +748,31 @@ putTempEntity = \case Entity.C gdc -> putSyncCausal gdc where - putBase32Hex = putText . Base32Hex.toText + putHash32 = putText . Hash32.toText putPatchLocalIds PatchFormat.LocalIds {patchTextLookup, patchHashLookup, patchDefnLookup} = do putFoldable putText patchTextLookup - putFoldable putBase32Hex patchHashLookup - putFoldable putBase32Hex patchDefnLookup + putFoldable putHash32 patchHashLookup + putFoldable putHash32 patchDefnLookup putNamespaceLocalIds BranchFormat.LocalIds {branchTextLookup, branchDefnLookup, branchPatchLookup, branchChildLookup} = do putFoldable putText branchTextLookup - putFoldable putBase32Hex branchDefnLookup - putFoldable putBase32Hex branchPatchLookup - putFoldable (putPair putBase32Hex putBase32Hex) branchChildLookup + putFoldable putHash32 branchDefnLookup + putFoldable putHash32 branchPatchLookup + putFoldable (putPair putHash32 putHash32) branchChildLookup putSyncCausal Causal.SyncCausalFormat {valueHash, parents} = do - putBase32Hex valueHash - putFoldable putBase32Hex parents + putHash32 valueHash + putFoldable putHash32 parents putSyncFullPatch lids bytes = do putPatchLocalIds lids putFramedByteString bytes putSyncDiffPatch parent lids bytes = do - putBase32Hex parent + putHash32 parent putPatchLocalIds lids putFramedByteString bytes putSyncFullNamespace lids bytes = do putNamespaceLocalIds lids putFramedByteString bytes putSyncDiffNamespace parent lids bytes = do - putBase32Hex parent + putHash32 parent putNamespaceLocalIds lids putFramedByteString bytes putSyncTerm (TermFormat.SyncLocallyIndexedComponent vec) = @@ -781,15 +780,15 @@ putTempEntity = \case -- when deserializing, because we don't think we need to (and it adds a -- little overhead.) flip putFoldable vec \(localIds, bytes) -> do - putLocalIdsWith putText putBase32Hex localIds + putLocalIdsWith putText putHash32 localIds putFramedByteString bytes putSyncDecl (DeclFormat.SyncLocallyIndexedComponent vec) = flip putFoldable vec \(localIds, bytes) -> do - putLocalIdsWith putText putBase32Hex localIds + putLocalIdsWith putText putHash32 localIds putFramedByteString bytes -getBase32Hex :: MonadGet m => m Base32Hex -getBase32Hex = Base32Hex.UnsafeFromText <$> getText +getHash32 :: MonadGet m => m Hash32 +getHash32 = Hash32.UnsafeFromBase32Hex . Base32Hex.UnsafeFromText <$> getText getTempTermFormat :: MonadGet m => m TempEntity.TempTermFormat getTempTermFormat = @@ -798,7 +797,7 @@ getTempTermFormat = TermFormat.SyncTerm . TermFormat.SyncLocallyIndexedComponent <$> getVector ( getPair - (getLocalIdsWith getText getBase32Hex) + (getLocalIdsWith getText getHash32) getFramedByteString ) tag -> unknownTag "getTempTermFormat" tag @@ -810,7 +809,7 @@ getTempDeclFormat = DeclFormat.SyncDecl . DeclFormat.SyncLocallyIndexedComponent <$> getVector ( getPair - (getLocalIdsWith getText getBase32Hex) + (getLocalIdsWith getText getHash32) getFramedByteString ) tag -> unknownTag "getTempDeclFormat" tag @@ -819,34 +818,34 @@ getTempPatchFormat :: MonadGet m => m TempEntity.TempPatchFormat getTempPatchFormat = getWord8 >>= \case 0 -> PatchFormat.SyncFull <$> getPatchLocalIds <*> getFramedByteString - 1 -> PatchFormat.SyncDiff <$> getBase32Hex <*> getPatchLocalIds <*> getFramedByteString + 1 -> PatchFormat.SyncDiff <$> getHash32 <*> getPatchLocalIds <*> getFramedByteString tag -> unknownTag "getTempPatchFormat" tag where getPatchLocalIds = PatchFormat.LocalIds <$> getVector getText - <*> getVector getBase32Hex - <*> getVector getBase32Hex + <*> getVector getHash32 + <*> getVector getHash32 getTempNamespaceFormat :: MonadGet m => m TempEntity.TempNamespaceFormat getTempNamespaceFormat = getWord8 >>= \case 0 -> BranchFormat.SyncFull <$> getBranchLocalIds <*> getFramedByteString - 1 -> BranchFormat.SyncDiff <$> getBase32Hex <*> getBranchLocalIds <*> getFramedByteString + 1 -> BranchFormat.SyncDiff <$> getHash32 <*> getBranchLocalIds <*> getFramedByteString tag -> unknownTag "getTempNamespaceFormat" tag where getBranchLocalIds = BranchFormat.LocalIds <$> getVector getText - <*> getVector getBase32Hex - <*> getVector getBase32Hex - <*> getVector (getPair getBase32Hex getBase32Hex) + <*> getVector getHash32 + <*> getVector getHash32 + <*> getVector (getPair getHash32 getHash32) getTempCausalFormat :: MonadGet m => m TempEntity.TempCausalFormat getTempCausalFormat = Causal.SyncCausalFormat - <$> getBase32Hex - <*> getVector getBase32Hex + <$> getHash32 + <*> getVector getHash32 getSymbol :: MonadGet m => m Symbol getSymbol = Symbol <$> getVarInt <*> getText diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs index aff0e5df8..be966233b 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs @@ -7,7 +7,7 @@ import qualified U.Codebase.Sqlite.Entity as Entity import U.Codebase.Sqlite.LocalIds (LocalIds') import qualified U.Codebase.Sqlite.Patch.Format as Patch import qualified U.Codebase.Sqlite.Term.Format as Term -import U.Util.Base32Hex (Base32Hex) +import U.Util.Hash32 (Hash32) import Unison.Prelude -- | @@ -18,20 +18,20 @@ import Unison.Prelude -- | P TempPatchFormat -- | C TempCausalFormat type TempEntity = - Entity.SyncEntity' Text Base32Hex Base32Hex Base32Hex Base32Hex Base32Hex Base32Hex + Entity.SyncEntity' Text Hash32 Hash32 Hash32 Hash32 Hash32 Hash32 -type TempLocalIds = LocalIds' Text Base32Hex +type TempLocalIds = LocalIds' Text Hash32 -type TempTermFormat = Term.SyncTermFormat' Text Base32Hex +type TempTermFormat = Term.SyncTermFormat' Text Hash32 -type TempDeclFormat = Decl.SyncDeclFormat' Text Base32Hex +type TempDeclFormat = Decl.SyncDeclFormat' Text Hash32 -type TempPatchFormat = Patch.SyncPatchFormat' Base32Hex Text Base32Hex Base32Hex +type TempPatchFormat = Patch.SyncPatchFormat' Hash32 Text Hash32 Hash32 -type TempPatchLocalIds = Patch.PatchLocalIds' Text Base32Hex Base32Hex +type TempPatchLocalIds = Patch.PatchLocalIds' Text Hash32 Hash32 -type TempNamespaceFormat = Namespace.SyncBranchFormat' Base32Hex Text Base32Hex Base32Hex (Base32Hex, Base32Hex) +type TempNamespaceFormat = Namespace.SyncBranchFormat' Hash32 Text Hash32 Hash32 (Hash32, Hash32) -type TempNamespaceLocalIds = Namespace.BranchLocalIds' Text Base32Hex Base32Hex (Base32Hex, Base32Hex) +type TempNamespaceLocalIds = Namespace.BranchLocalIds' Text Hash32 Hash32 (Hash32, Hash32) -type TempCausalFormat = Causal.SyncCausalFormat' Base32Hex Base32Hex +type TempCausalFormat = Causal.SyncCausalFormat' Hash32 Hash32 diff --git a/codebase2/codebase-sqlite/package.yaml b/codebase2/codebase-sqlite/package.yaml index fa1481fd0..f0331c219 100644 --- a/codebase2/codebase-sqlite/package.yaml +++ b/codebase2/codebase-sqlite/package.yaml @@ -33,6 +33,7 @@ dependencies: - unison-sqlite - unison-util - unison-util-base32hex + - unison-util-base32hex-orphans-sqlite - unison-util-serialization - unison-util-term - unliftio diff --git a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal index 5dd57b42b..3f827edf0 100644 --- a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal +++ b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal @@ -106,6 +106,7 @@ library , unison-sqlite , unison-util , unison-util-base32hex + , unison-util-base32hex-orphans-sqlite , unison-util-serialization , unison-util-term , unliftio diff --git a/hie.yaml b/hie.yaml index 7c6ac739a..91cc9aeba 100644 --- a/hie.yaml +++ b/hie.yaml @@ -42,6 +42,9 @@ cradle: - path: "lib/unison-util-base32hex/src" component: "unison-util-base32hex:lib" + - path: "lib/unison-util-base32hex-orphans-aeson/src" + component: "unison-util-base32hex-orphans-aeson:lib" + - path: "lib/unison-util-relation/src" component: "unison-util-relation:lib" diff --git a/lib/unison-util-base32hex-orphans-aeson/package.yaml b/lib/unison-util-base32hex-orphans-aeson/package.yaml new file mode 100644 index 000000000..da2b27afc --- /dev/null +++ b/lib/unison-util-base32hex-orphans-aeson/package.yaml @@ -0,0 +1,44 @@ +name: unison-util-base32hex-orphans-aeson +github: unisonweb/unison +copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors + +library: + when: + - condition: false + other-modules: Paths_unison_util_base32hex_orphans_aeson + source-dirs: src + +dependencies: + - aeson + - base + - text + - unison-util-base32hex + +ghc-options: + -Wall + -fno-warn-orphans + +default-extensions: + - ApplicativeDo + - BangPatterns + - BlockArguments + - DeriveFunctor + - DeriveGeneric + - DeriveTraversable + - DerivingStrategies + - DerivingVia + - DoAndIfThenElse + - FlexibleContexts + - FlexibleInstances + - GeneralizedNewtypeDeriving + - LambdaCase + - MultiParamTypeClasses + - NamedFieldPuns + - OverloadedStrings + - PatternSynonyms + - RankNTypes + - ScopedTypeVariables + - StandaloneDeriving + - TupleSections + - TypeApplications + - ViewPatterns diff --git a/lib/unison-util-base32hex-orphans-aeson/src/U/Util/Hash32/Orphans/Aeson.hs b/lib/unison-util-base32hex-orphans-aeson/src/U/Util/Hash32/Orphans/Aeson.hs new file mode 100644 index 000000000..10ce032d1 --- /dev/null +++ b/lib/unison-util-base32hex-orphans-aeson/src/U/Util/Hash32/Orphans/Aeson.hs @@ -0,0 +1,14 @@ +module U.Util.Hash32.Orphans.Aeson () where + +import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey) +import Data.Text (Text) +import U.Util.Base32Hex (Base32Hex (..)) +import U.Util.Hash32 (Hash32 (..)) + +deriving via Text instance FromJSON Hash32 + +deriving via Text instance FromJSONKey Hash32 + +deriving via Text instance ToJSON Hash32 + +deriving via Text instance ToJSONKey Hash32 diff --git a/lib/unison-util-base32hex-orphans-aeson/unison-util-base32hex-orphans-aeson.cabal b/lib/unison-util-base32hex-orphans-aeson/unison-util-base32hex-orphans-aeson.cabal new file mode 100644 index 000000000..b77f6d5be --- /dev/null +++ b/lib/unison-util-base32hex-orphans-aeson/unison-util-base32hex-orphans-aeson.cabal @@ -0,0 +1,53 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.4. +-- +-- see: https://github.com/sol/hpack + +name: unison-util-base32hex-orphans-aeson +version: 0.0.0 +homepage: https://github.com/unisonweb/unison#readme +bug-reports: https://github.com/unisonweb/unison/issues +copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors +build-type: Simple + +source-repository head + type: git + location: https://github.com/unisonweb/unison + +library + exposed-modules: + U.Util.Hash32.Orphans.Aeson + hs-source-dirs: + src + default-extensions: + ApplicativeDo + BangPatterns + BlockArguments + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingStrategies + DerivingVia + DoAndIfThenElse + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + LambdaCase + MultiParamTypeClasses + NamedFieldPuns + OverloadedStrings + PatternSynonyms + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + ViewPatterns + ghc-options: -Wall -fno-warn-orphans + build-depends: + aeson + , base + , text + , unison-util-base32hex + default-language: Haskell2010 diff --git a/lib/unison-util-base32hex-orphans-sqlite/package.yaml b/lib/unison-util-base32hex-orphans-sqlite/package.yaml new file mode 100644 index 000000000..7ed1fbaa8 --- /dev/null +++ b/lib/unison-util-base32hex-orphans-sqlite/package.yaml @@ -0,0 +1,44 @@ +name: unison-util-base32hex-orphans-sqlite +github: unisonweb/unison +copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors + +library: + when: + - condition: false + other-modules: Paths_unison_util_base32hex_orphans_sqlite + source-dirs: src + +dependencies: + - base + - sqlite-simple + - text + - unison-util-base32hex + +ghc-options: + -Wall + -fno-warn-orphans + +default-extensions: + - ApplicativeDo + - BangPatterns + - BlockArguments + - DeriveFunctor + - DeriveGeneric + - DeriveTraversable + - DerivingStrategies + - DerivingVia + - DoAndIfThenElse + - FlexibleContexts + - FlexibleInstances + - GeneralizedNewtypeDeriving + - LambdaCase + - MultiParamTypeClasses + - NamedFieldPuns + - OverloadedStrings + - PatternSynonyms + - RankNTypes + - ScopedTypeVariables + - StandaloneDeriving + - TupleSections + - TypeApplications + - ViewPatterns diff --git a/lib/unison-util-base32hex-orphans-sqlite/src/U/Util/Hash32/Orphans/Sqlite.hs b/lib/unison-util-base32hex-orphans-sqlite/src/U/Util/Hash32/Orphans/Sqlite.hs new file mode 100644 index 000000000..2b5aaaa79 --- /dev/null +++ b/lib/unison-util-base32hex-orphans-sqlite/src/U/Util/Hash32/Orphans/Sqlite.hs @@ -0,0 +1,11 @@ +module U.Util.Hash32.Orphans.Sqlite () where + +import Data.Text (Text) +import Database.SQLite.Simple.FromField (FromField) +import Database.SQLite.Simple.ToField (ToField) +import U.Util.Base32Hex (Base32Hex (..)) +import U.Util.Hash32 (Hash32 (..)) + +deriving via Text instance ToField Hash32 + +deriving via Text instance FromField Hash32 diff --git a/lib/unison-util-base32hex-orphans-sqlite/unison-util-base32hex-orphans-sqlite.cabal b/lib/unison-util-base32hex-orphans-sqlite/unison-util-base32hex-orphans-sqlite.cabal new file mode 100644 index 000000000..f78c9eca9 --- /dev/null +++ b/lib/unison-util-base32hex-orphans-sqlite/unison-util-base32hex-orphans-sqlite.cabal @@ -0,0 +1,53 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.4. +-- +-- see: https://github.com/sol/hpack + +name: unison-util-base32hex-orphans-sqlite +version: 0.0.0 +homepage: https://github.com/unisonweb/unison#readme +bug-reports: https://github.com/unisonweb/unison/issues +copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors +build-type: Simple + +source-repository head + type: git + location: https://github.com/unisonweb/unison + +library + exposed-modules: + U.Util.Hash32.Orphans.Sqlite + hs-source-dirs: + src + default-extensions: + ApplicativeDo + BangPatterns + BlockArguments + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingStrategies + DerivingVia + DoAndIfThenElse + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + LambdaCase + MultiParamTypeClasses + NamedFieldPuns + OverloadedStrings + PatternSynonyms + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + ViewPatterns + ghc-options: -Wall -fno-warn-orphans + build-depends: + base + , sqlite-simple + , text + , unison-util-base32hex + default-language: Haskell2010 diff --git a/lib/unison-util-base32hex/src/U/Util/Hash32.hs b/lib/unison-util-base32hex/src/U/Util/Hash32.hs index bc1f6ab29..39f4205e0 100644 --- a/lib/unison-util-base32hex/src/U/Util/Hash32.hs +++ b/lib/unison-util-base32hex/src/U/Util/Hash32.hs @@ -1,40 +1,55 @@ -- | A 512-bit hash, internally represented as base32hex. module U.Util.Hash32 ( -- * Hash32 type - Hash32, + Hash32 (..), -- * Conversions - -- ** Base32Hex - fromBase32Hex, - toBase32Hex, - -- ** The other Hash :) fromHash, toHash, + + -- ** Base32Hex + unsafeFromBase32Hex, + toBase32Hex, + + -- ** Text + toText, ) where -import U.Util.Base32Hex (Base32Hex) +import U.Util.Base32Hex (Base32Hex (..)) import U.Util.Hash (Hash) import qualified U.Util.Hash as Hash import Unison.Prelude -- | A 512-bit hash, internally represented as base32hex. -newtype Hash32 = Hash32 Base32Hex - -fromBase32Hex :: Base32Hex -> Hash32 -fromBase32Hex = - Hash32 - -toBase32Hex :: Hash32 -> Base32Hex -toBase32Hex = - coerce +-- +-- Some orphan instances provided in: +-- +-- * @unison-util-base32hex-orphans-aeson@ +-- * @unison-util-base32hex-orphans-sqlite@ +newtype Hash32 = UnsafeFromBase32Hex Base32Hex + deriving (Eq, Ord, Show) via (Text) fromHash :: Hash -> Hash32 fromHash = - fromBase32Hex . Hash.toBase32Hex + unsafeFromBase32Hex . Hash.toBase32Hex toHash :: Hash32 -> Hash toHash = Hash.fromBase32Hex . toBase32Hex + +-- | Convert base32hex to a hash32 (asserting that it is a 512-bit hash). +unsafeFromBase32Hex :: Base32Hex -> Hash32 +unsafeFromBase32Hex = + coerce + +-- | Convert a hash32 to base32hex. +toBase32Hex :: Hash32 -> Base32Hex +toBase32Hex = + coerce + +toText :: Hash32 -> Text +toText = + coerce diff --git a/stack.yaml b/stack.yaml index 313e93b8d..adbe564c4 100644 --- a/stack.yaml +++ b/stack.yaml @@ -25,6 +25,8 @@ packages: - lib/unison-prelude - lib/unison-sqlite - lib/unison-util-base32hex +- lib/unison-util-base32hex-orphans-aeson +- lib/unison-util-base32hex-orphans-sqlite - lib/unison-util-relation - lib/unison-pretty-printer diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index f02961efa..36c8ed4eb 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -32,6 +32,8 @@ import U.Codebase.Sqlite.DbId (SchemaVersion (SchemaVersion)) import U.Util.Base32Hex (Base32Hex) import qualified U.Util.Base32Hex as Base32Hex import qualified U.Util.Hash as Hash +import U.Util.Hash32 (Hash32) +import qualified U.Util.Hash32 as Hash32 import qualified U.Util.Monoid as Monoid import qualified Unison.ABT as ABT import qualified Unison.Auth.Types as Auth @@ -129,7 +131,6 @@ import qualified Unison.Share.Sync as Share import qualified Unison.ShortHash as SH import qualified Unison.ShortHash as ShortHash import qualified Unison.Sync.Types as Share -import qualified Unison.Sync.Types as Share.Hash (toBase32Hex) import Unison.Term (Term) import qualified Unison.Term as Term import qualified Unison.TermPrinter as TermPrinter @@ -637,8 +638,8 @@ notifyUser dir o = case o of CachedTests 0 _ -> pure . P.callout "😶" $ "No tests to run." CachedTests n n' | n == n' -> - pure $ - P.lines [cache, "", displayTestResults True ppe oks fails] + pure $ + P.lines [cache, "", displayTestResults True ppe oks fails] CachedTests _n m -> pure $ if m == 0 @@ -647,6 +648,7 @@ notifyUser dir o = case o of P.indentN 2 $ P.lines ["", cache, "", displayTestResults False ppe oks fails, "", "✅ "] where + NewlyComputed -> do clearCurrentLine pure $ @@ -1601,7 +1603,7 @@ notifyUser dir o = case o of P.fatalCallout ( P.lines [ "The server detected an error in the history being pushed, please report this as a bug in ucm.", - "The history in question is the hash: " <> prettyShareHash child <> " with the ancestor: " <> prettyShareHash parent + "The history in question is the hash: " <> prettyHash32 child <> " with the ancestor: " <> prettyHash32 parent ] ) Share.FastForwardPushErrorNotFastForward sharePath -> @@ -1643,7 +1645,7 @@ notifyUser dir o = case o of ), P.text "", P.text "The hashes it expected are:\n" - <> P.indentN 2 (P.lines (map prettyShareHash (toList hashes))) + <> P.indentN 2 (P.lines (map prettyHash32 (toList hashes))) ] handleGetCausalHashByPathError = \case Share.GetCausalHashByPathErrorNoReadPermission sharePath -> noReadPermission sharePath @@ -1736,8 +1738,8 @@ prettyBase32Hex# b = P.group $ "#" <> prettyBase32Hex b prettyHash :: IsString s => Hash.Hash -> P.Pretty s prettyHash = prettyBase32Hex# . Hash.toBase32Hex -prettyShareHash :: IsString s => Share.Hash -> P.Pretty s -prettyShareHash = prettyBase32Hex# . Share.Hash.toBase32Hex +prettyHash32 :: IsString s => Hash32 -> P.Pretty s +prettyHash32 = prettyBase32Hex# . Hash32.toBase32Hex formatMissingStuff :: (Show tm, Show typ) => @@ -2269,7 +2271,7 @@ showDiffNamespace :: (Pretty, NumberedArgs) showDiffNamespace _ _ _ _ diffOutput | OBD.isEmpty diffOutput = - ("The namespaces are identical.", mempty) + ("The namespaces are identical.", mempty) showDiffNamespace sn ppe oldPath newPath OBD.BranchDiffOutput {..} = (P.sepNonEmpty "\n\n" p, toList args) where diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index a203634a3..f35b23a5a 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -41,16 +41,15 @@ import qualified Data.Set.NonEmpty as NESet import qualified Servant.API as Servant ((:<|>) (..)) import Servant.Client (BaseUrl) import qualified Servant.Client as Servant (ClientEnv, ClientM, client, hoistClient, mkClientEnv, runClientM) -import U.Codebase.HashTags (CausalHash (..)) +import U.Codebase.HashTags (CausalHash) import qualified U.Codebase.Sqlite.Queries as Q -import U.Util.Base32Hex (Base32Hex) -import qualified U.Util.Hash as Hash +import U.Util.Hash32 (Hash32) import Unison.Auth.HTTPClient (AuthorizedHttpClient) import qualified Unison.Auth.HTTPClient as Auth import Unison.Prelude import qualified Unison.Sqlite as Sqlite import qualified Unison.Sync.API as Share (api) -import Unison.Sync.Common +import Unison.Sync.Common (causalHashToHash32, entityToTempEntity, expectEntity, hash32ToCausalHash) import qualified Unison.Sync.Types as Share import Unison.Util.Monoid (foldMapM) import qualified Unison.Util.Set as Set @@ -62,7 +61,7 @@ import qualified Unison.Util.Set as Set data CheckAndSetPushError = CheckAndSetPushErrorHashMismatch Share.HashMismatch | CheckAndSetPushErrorNoWritePermission Share.Path - | CheckAndSetPushErrorServerMissingDependencies (NESet Share.Hash) + | CheckAndSetPushErrorServerMissingDependencies (NESet Hash32) -- | Push a causal to Unison Share. -- FIXME reword this @@ -77,7 +76,7 @@ checkAndSetPush :: Share.Path -> -- | The hash that we expect this repo+path to be at on Unison Share. If not, we'll get back a hash mismatch error. -- This prevents accidentally pushing over data that we didn't know was there. - Maybe Share.Hash -> + Maybe Hash32 -> -- | The hash of our local causal to push. CausalHash -> IO (Either CheckAndSetPushError ()) @@ -114,7 +113,7 @@ checkAndSetPush httpClient unisonShareUrl conn path expectedHash causalHash = do Share.UpdatePathRequest { path, expectedHash, - newHash = causalHashToShareHash causalHash + newHash = causalHashToHash32 causalHash } -- | An error occurred while fast-forward pushing code to Unison Share. @@ -123,9 +122,9 @@ data FastForwardPushError | FastForwardPushErrorNoReadPermission Share.Path | FastForwardPushErrorNotFastForward Share.Path | FastForwardPushErrorNoWritePermission Share.Path - | FastForwardPushErrorServerMissingDependencies (NESet Share.Hash) - | -- Parent Child - FastForwardPushInvalidParentage Share.Hash Share.Hash + | FastForwardPushErrorServerMissingDependencies (NESet Hash32) + | -- Parent Child + FastForwardPushInvalidParentage Hash32 Hash32 -- | Push a causal to Unison Share. -- FIXME reword this @@ -161,7 +160,7 @@ fastForwardPush httpClient unisonShareUrl conn path localHeadHash = Share.FastForwardPathRequest { expectedHash = remoteHeadHash, hashes = - causalHashToShareHash <$> List.NonEmpty.fromList (localInnerHashes ++ [localHeadHash]), + causalHashToHash32 <$> List.NonEmpty.fromList (localInnerHashes ++ [localHeadHash]), path } doFastForwardPath <&> \case @@ -185,14 +184,14 @@ fastForwardPush httpClient unisonShareUrl conn path localHeadHash = unisonShareUrl conn (Share.pathRepoName path) - (NESet.singleton (causalHashToShareHash headHash)) + (NESet.singleton (causalHashToHash32 headHash)) -- Return a list from oldest to newst of the ancestors between (excluding) the latest local and the current remote -- hash. -- note: seems like we /should/ cut this short, with another command to go longer? :grimace: - fancyBfs :: CausalHash -> Share.Hash -> Sqlite.Transaction (Maybe [CausalHash]) + fancyBfs :: CausalHash -> Hash32 -> Sqlite.Transaction (Maybe [CausalHash]) fancyBfs h0 h1 = - tweak <$> dagbfs (== Share.toBase32Hex h1) Q.loadCausalParentsByHash (Hash.toBase32Hex (unCausalHash h0)) + tweak <$> dagbfs (== h1) Q.loadCausalParentsByHash (causalHashToHash32 h0) where -- Drop 1 (under a Maybe, and twddling hash types): -- @@ -202,9 +201,9 @@ fastForwardPush httpClient unisonShareUrl conn path localHeadHash = -- -- The drop 1 is because dagbfs returns the goal at the head of the returned list, but we know what the goal is -- already (the remote head hash). - tweak :: Maybe [Base32Hex] -> Maybe [CausalHash] + tweak :: Maybe [Hash32] -> Maybe [CausalHash] tweak = - fmap (map (CausalHash . Hash.fromBase32Hex) . drop 1) + fmap (map hash32ToCausalHash . drop 1) data Step a = DeadEnd @@ -333,7 +332,7 @@ pull httpClient unisonShareUrl conn repoPath = do Just EntityInMainStorage -> pure () Just (EntityInTempStorage missingDependencies) -> doDownload missingDependencies Nothing -> doDownload (NESet.singleton hashJwt) - pure (Right (CausalHash (Hash.fromBase32Hex (Share.toBase32Hex hash)))) + pure (Right (hash32ToCausalHash hash)) where doDownload :: NESet Share.HashJWT -> IO () doDownload = @@ -388,7 +387,7 @@ downloadEntities httpClient unisonShareUrl conn repoName = whenJust (NESet.nonEmptySet missingDependencies0) loop - doDownload :: NESet Share.HashJWT -> IO (NEMap Share.Hash (Share.Entity Text Share.Hash Share.HashJWT)) + doDownload :: NESet Share.HashJWT -> IO (NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT)) doDownload hashes = do Share.DownloadEntitiesSuccess entities <- httpDownloadEntities @@ -410,12 +409,12 @@ uploadEntities :: BaseUrl -> Sqlite.Connection -> Share.RepoName -> - NESet Share.Hash -> + NESet Hash32 -> IO Bool uploadEntities httpClient unisonShareUrl conn repoName = loop where - loop :: NESet Share.Hash -> IO Bool + loop :: NESet Hash32 -> IO Bool loop (NESet.toAscList -> hashes) = do -- Get each entity that the server is missing out of the database. entities <- Sqlite.runTransaction conn (traverse expectEntity hashes) @@ -449,8 +448,8 @@ data EntityLocation EntityInTempStorage (NESet Share.HashJWT) -- | Where is an entity stored? -entityLocation :: Share.Hash -> Sqlite.Transaction (Maybe EntityLocation) -entityLocation (Share.Hash hash) = +entityLocation :: Hash32 -> Sqlite.Transaction (Maybe EntityLocation) +entityLocation hash = Q.entityExists hash >>= \case True -> pure (Just EntityInMainStorage) False -> @@ -487,8 +486,8 @@ elaborateHashes = -- 2. In main storage if we already have all of its dependencies in main storage. -- 3. In temp storage otherwise. upsertEntitySomewhere :: - Share.Hash -> - Share.Entity Text Share.Hash Share.HashJWT -> + Hash32 -> + Share.Entity Text Hash32 Share.HashJWT -> Sqlite.Transaction EntityLocation upsertEntitySomewhere hash entity = entityLocation hash >>= \case @@ -496,7 +495,7 @@ upsertEntitySomewhere hash entity = Nothing -> do missingDependencies0 <- Set.filterM - (fmap not . Q.entityExists . Share.toBase32Hex . Share.hashJWTHash) + (fmap not . Q.entityExists . Share.hashJWTHash) (Share.entityDependencies entity) case NESet.nonEmptySet missingDependencies0 of Nothing -> do @@ -507,26 +506,26 @@ upsertEntitySomewhere hash entity = pure (EntityInTempStorage missingDependencies) -- | Insert an entity that doesn't have any missing dependencies. -insertEntity :: Share.Hash -> Share.Entity Text Share.Hash Share.HashJWT -> Sqlite.Transaction () +insertEntity :: Hash32 -> Share.Entity Text Hash32 Share.HashJWT -> Sqlite.Transaction () insertEntity hash entity = do - syncEntity <- Q.tempToSyncEntity (entityToTempEntity (Share.toBase32Hex . Share.hashJWTHash) entity) - _id <- Q.saveSyncEntity (Share.toBase32Hex hash) syncEntity + syncEntity <- Q.tempToSyncEntity (entityToTempEntity Share.hashJWTHash entity) + _id <- Q.saveSyncEntity hash syncEntity pure () -- | Insert an entity and its missing dependencies. insertTempEntity :: - Share.Hash -> - Share.Entity Text Share.Hash Share.HashJWT -> + Hash32 -> + Share.Entity Text Hash32 Share.HashJWT -> NESet Share.HashJWT -> Sqlite.Transaction () insertTempEntity hash entity missingDependencies = Q.insertTempEntity - (Share.toBase32Hex hash) - (entityToTempEntity (Share.toBase32Hex . Share.hashJWTHash) entity) + hash + (entityToTempEntity Share.hashJWTHash entity) ( NESet.map ( \hashJwt -> let Share.DecodedHashJWT {claims = Share.HashJWTClaims {hash}} = Share.decodeHashJWT hashJwt - in (Share.toBase32Hex hash, Share.unHashJWT hashJwt) + in (hash, Share.unHashJWT hashJwt) ) missingDependencies ) diff --git a/unison-share-api/package.yaml b/unison-share-api/package.yaml index 78b7b2f19..779210a01 100644 --- a/unison-share-api/package.yaml +++ b/unison-share-api/package.yaml @@ -47,6 +47,7 @@ dependencies: - unison-pretty-printer - unison-util - unison-util-base32hex + - unison-util-base32hex-orphans-aeson - unison-util-relation - unison-sqlite - unliftio diff --git a/unison-share-api/src/Unison/Sync/Common.hs b/unison-share-api/src/Unison/Sync/Common.hs index af7fb4f37..8bad96a97 100644 --- a/unison-share-api/src/Unison/Sync/Common.hs +++ b/unison-share-api/src/Unison/Sync/Common.hs @@ -3,7 +3,8 @@ module Unison.Sync.Common ( expectEntity, -- * Type conversions - causalHashToShareHash, + causalHashToHash32, + hash32ToCausalHash, entityToTempEntity, tempEntityToEntity, ) @@ -11,7 +12,6 @@ where import qualified Control.Lens as Lens import qualified Data.Set as Set -import Data.Vector (Vector) import qualified Data.Vector as Vector import U.Codebase.HashTags (CausalHash (..)) import qualified U.Codebase.Sqlite.Branch.Format as NamespaceFormat @@ -25,27 +25,33 @@ import U.Codebase.Sqlite.TempEntity (TempEntity) import qualified U.Codebase.Sqlite.TempEntity as Sqlite import qualified U.Codebase.Sqlite.TempEntity as TempEntity import qualified U.Codebase.Sqlite.Term.Format as TermFormat -import U.Util.Base32Hex (Base32Hex) -import qualified U.Util.Hash as Hash +import U.Util.Hash32 (Hash32) +import qualified U.Util.Hash32 as Hash32 import Unison.Prelude import qualified Unison.Sqlite as Sqlite import qualified Unison.Sync.Types as Share -- | Read an entity out of the database that we know is in main storage. -expectEntity :: Share.Hash -> Sqlite.Transaction (Share.Entity Text Share.Hash Share.Hash) +expectEntity :: Hash32 -> Sqlite.Transaction (Share.Entity Text Hash32 Hash32) expectEntity hash = do - syncEntity <- Q.expectEntity (Share.toBase32Hex hash) + syncEntity <- Q.expectEntity hash tempEntity <- Q.syncToTempEntity syncEntity pure (tempEntityToEntity tempEntity) -causalHashToShareHash :: CausalHash -> Share.Hash -causalHashToShareHash = - Share.Hash . Hash.toBase32Hex . unCausalHash +-- FIXME this isn't the right module for this conversion +causalHashToHash32 :: CausalHash -> Hash32 +causalHashToHash32 = + Hash32.fromHash . unCausalHash + +-- FIXME this isn't the right module for this conversion +hash32ToCausalHash :: Hash32 -> CausalHash +hash32ToCausalHash = + CausalHash . Hash32.toHash -- | Convert an entity that came over the wire from Unison Share into an equivalent type that we can store in the -- `temp_entity` table. -entityToTempEntity :: forall hash. (hash -> Base32Hex) -> Share.Entity Text Share.Hash hash -> TempEntity -entityToTempEntity toBase32Hex = \case +entityToTempEntity :: forall hash. (hash -> Hash32) -> Share.Entity Text Hash32 hash -> TempEntity +entityToTempEntity toHash32 = \case Share.TC (Share.TermComponent terms) -> terms & Vector.fromList @@ -65,7 +71,7 @@ entityToTempEntity toBase32Hex = \case Share.PD Share.PatchDiff {parent, textLookup, oldHashLookup, newHashLookup, bytes} -> Entity.P ( PatchFormat.SyncDiff - (toBase32Hex parent) + (toHash32 parent) (mungePatchLocalIds textLookup oldHashLookup newHashLookup) bytes ) @@ -74,22 +80,22 @@ entityToTempEntity toBase32Hex = \case Share.ND Share.NamespaceDiff {parent, textLookup, defnLookup, patchLookup, childLookup, bytes} -> Entity.N ( NamespaceFormat.SyncDiff - (toBase32Hex parent) + (toHash32 parent) (mungeNamespaceLocalIds textLookup defnLookup patchLookup childLookup) bytes ) Share.C Share.Causal {namespaceHash, parents} -> Entity.C Causal.SyncCausalFormat - { valueHash = toBase32Hex namespaceHash, - parents = Vector.fromList (map toBase32Hex (Set.toList parents)) + { valueHash = toHash32 namespaceHash, + parents = Vector.fromList (map toHash32 (Set.toList parents)) } where mungeLocalIds :: Share.LocalIds Text hash -> TempEntity.TempLocalIds mungeLocalIds Share.LocalIds {texts, hashes} = LocalIds { textLookup = Vector.fromList texts, - defnLookup = Vector.map toBase32Hex (Vector.fromList hashes) + defnLookup = Vector.map toHash32 (Vector.fromList hashes) } mungeNamespaceLocalIds :: @@ -101,20 +107,20 @@ entityToTempEntity toBase32Hex = \case mungeNamespaceLocalIds textLookup defnLookup patchLookup childLookup = NamespaceFormat.LocalIds { branchTextLookup = Vector.fromList textLookup, - branchDefnLookup = Vector.fromList (map toBase32Hex defnLookup), - branchPatchLookup = Vector.fromList (map toBase32Hex patchLookup), - branchChildLookup = Vector.fromList (map (\(x, y) -> (toBase32Hex x, toBase32Hex y)) childLookup) + branchDefnLookup = Vector.fromList (map toHash32 defnLookup), + branchPatchLookup = Vector.fromList (map toHash32 patchLookup), + branchChildLookup = Vector.fromList (map (\(x, y) -> (toHash32 x, toHash32 y)) childLookup) } - mungePatchLocalIds :: [Text] -> [Share.Hash] -> [hash] -> TempEntity.TempPatchLocalIds + mungePatchLocalIds :: [Text] -> [Hash32] -> [hash] -> TempEntity.TempPatchLocalIds mungePatchLocalIds textLookup oldHashLookup newHashLookup = PatchFormat.LocalIds { patchTextLookup = Vector.fromList textLookup, - patchHashLookup = Vector.fromList (coerce @[Share.Hash] @[Base32Hex] oldHashLookup), - patchDefnLookup = Vector.fromList (map toBase32Hex newHashLookup) + patchHashLookup = Vector.fromList oldHashLookup, + patchDefnLookup = Vector.fromList (map toHash32 newHashLookup) } -tempEntityToEntity :: Sqlite.TempEntity -> Share.Entity Text Share.Hash Share.Hash +tempEntityToEntity :: Sqlite.TempEntity -> Share.Entity Text Hash32 Hash32 tempEntityToEntity = \case Entity.TC (TermFormat.SyncTerm (TermFormat.SyncLocallyIndexedComponent terms)) -> terms @@ -134,17 +140,17 @@ tempEntityToEntity = \case Share.P Share.Patch { textLookup = Vector.toList patchTextLookup, - oldHashLookup = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) patchHashLookup), - newHashLookup = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) patchDefnLookup), + oldHashLookup = Vector.toList patchHashLookup, + newHashLookup = Vector.toList patchDefnLookup, bytes } PatchFormat.SyncDiff parent PatchFormat.LocalIds {patchTextLookup, patchHashLookup, patchDefnLookup} bytes -> Share.PD Share.PatchDiff - { parent = Share.Hash parent, + { parent, textLookup = Vector.toList patchTextLookup, - oldHashLookup = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) patchHashLookup), - newHashLookup = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) patchDefnLookup), + oldHashLookup = Vector.toList patchHashLookup, + newHashLookup = Vector.toList patchDefnLookup, bytes } Entity.N format -> @@ -160,11 +166,9 @@ tempEntityToEntity = \case Share.N Share.Namespace { textLookup = Vector.toList branchTextLookup, - defnLookup = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) branchDefnLookup), - patchLookup = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) branchPatchLookup), - childLookup = - Vector.toList - (coerce @(Vector (Base32Hex, Base32Hex)) @(Vector (Share.Hash, Share.Hash)) branchChildLookup), + defnLookup = Vector.toList branchDefnLookup, + patchLookup = Vector.toList branchPatchLookup, + childLookup = Vector.toList branchChildLookup, bytes } NamespaceFormat.SyncDiff @@ -178,25 +182,23 @@ tempEntityToEntity = \case bytes -> Share.ND Share.NamespaceDiff - { parent = Share.Hash parent, + { parent, textLookup = Vector.toList branchTextLookup, - defnLookup = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) branchDefnLookup), - patchLookup = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) branchPatchLookup), - childLookup = - Vector.toList - (coerce @(Vector (Base32Hex, Base32Hex)) @(Vector (Share.Hash, Share.Hash)) branchChildLookup), + defnLookup = Vector.toList branchDefnLookup, + patchLookup = Vector.toList branchPatchLookup, + childLookup = Vector.toList branchChildLookup, bytes } Entity.C Causal.SyncCausalFormat {valueHash, parents} -> Share.C Share.Causal - { namespaceHash = Share.Hash valueHash, - parents = Set.fromList (coerce @[Base32Hex] @[Share.Hash] (Vector.toList parents)) + { namespaceHash = valueHash, + parents = Set.fromList (Vector.toList parents) } where - mungeLocalIds :: LocalIds' Text Base32Hex -> Share.LocalIds Text Share.Hash + mungeLocalIds :: LocalIds' Text Hash32 -> Share.LocalIds Text Hash32 mungeLocalIds LocalIds {textLookup, defnLookup} = Share.LocalIds { texts = Vector.toList textLookup, - hashes = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) defnLookup) + hashes = Vector.toList defnLookup } diff --git a/unison-share-api/src/Unison/Sync/Types.hs b/unison-share-api/src/Unison/Sync/Types.hs index a5a636695..6e842cc77 100644 --- a/unison-share-api/src/Unison/Sync/Types.hs +++ b/unison-share-api/src/Unison/Sync/Types.hs @@ -12,7 +12,6 @@ module Unison.Sync.Types pathCodebasePath, -- ** Hash types - Hash (..), HashJWT (..), hashJWTHash, HashJWTClaims (..), @@ -89,7 +88,8 @@ import Data.Set.NonEmpty (NESet) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Servant.Auth.JWT -import U.Util.Base32Hex (Base32Hex (..)) +import U.Util.Hash32 (Hash32) +import U.Util.Hash32.Orphans.Aeson () import Unison.Prelude import qualified Unison.Util.Set as Set import qualified Web.JWT as JWT @@ -140,21 +140,18 @@ instance FromJSON Path where ------------------------------------------------------------------------------------------------------------------------ -- Hash types -newtype Hash = Hash {toBase32Hex :: Base32Hex} - deriving (Show, Eq, Ord, ToJSON, FromJSON, ToJSONKey, FromJSONKey) via (Text) - newtype HashJWT = HashJWT {unHashJWT :: Text} deriving newtype (Show, Eq, Ord, ToJSON, FromJSON) -- | Grab the hash out of a hash JWT. -- -- This decodes the whole JWT, then throws away the claims; use it if you really only need the hash! -hashJWTHash :: HashJWT -> Hash +hashJWTHash :: HashJWT -> Hash32 hashJWTHash = decodedHashJWTHash . decodeHashJWT data HashJWTClaims = HashJWTClaims - { hash :: Hash + { hash :: Hash32 -- Currently unused -- entityType :: EntityType } @@ -216,7 +213,7 @@ decodeHashJWTClaims (HashJWT text) = Aeson.Success claims -> claims -- | Grab the hash out of a decoded hash JWT. -decodedHashJWTHash :: DecodedHashJWT -> Hash +decodedHashJWTHash :: DecodedHashJWT -> Hash32 decodedHashJWTHash DecodedHashJWT {claims = HashJWTClaims {hash}} = hash @@ -661,7 +658,7 @@ instance FromJSON DownloadEntitiesRequest where pure DownloadEntitiesRequest {..} data DownloadEntitiesResponse - = DownloadEntitiesSuccess (NEMap Hash (Entity Text Hash HashJWT)) + = DownloadEntitiesSuccess (NEMap Hash32 (Entity Text Hash32 HashJWT)) | DownloadEntitiesNoReadPermission RepoName -- data DownloadEntities = DownloadEntities @@ -696,7 +693,7 @@ instance FromJSON DownloadEntitiesResponse where data UploadEntitiesRequest = UploadEntitiesRequest { repoName :: RepoName, - entities :: NEMap Hash (Entity Text Hash Hash) + entities :: NEMap Hash32 (Entity Text Hash32 Hash32) } deriving stock (Show, Eq, Ord) @@ -715,12 +712,12 @@ instance FromJSON UploadEntitiesRequest where data UploadEntitiesResponse = UploadEntitiesSuccess - | UploadEntitiesNeedDependencies (NeedDependencies Hash) + | UploadEntitiesNeedDependencies (NeedDependencies Hash32) | UploadEntitiesNoWritePermission RepoName | UploadEntitiesHashMismatchForEntity HashMismatchForEntity deriving stock (Show, Eq, Ord) -data HashMismatchForEntity = HashMismatchForEntity {supplied :: Hash, computed :: Hash} +data HashMismatchForEntity = HashMismatchForEntity {supplied :: Hash32, computed :: Hash32} deriving stock (Show, Eq, Ord) instance ToJSON UploadEntitiesResponse where @@ -775,9 +772,9 @@ instance FromJSON HashMismatchForEntity where -- instead. data FastForwardPathRequest = FastForwardPathRequest { -- | The causal that the client believes exists at `path` - expectedHash :: Hash, + expectedHash :: Hash32, -- | The sequence of causals to fast-forward with, starting from the oldest new causal to the newest new causal - hashes :: NonEmpty Hash, + hashes :: NonEmpty Hash32, -- | The path to fast-forward path :: Path } @@ -801,7 +798,7 @@ instance FromJSON FastForwardPathRequest where data FastForwardPathResponse = FastForwardPathSuccess - | FastForwardPathMissingDependencies (NeedDependencies Hash) + | FastForwardPathMissingDependencies (NeedDependencies Hash32) | FastForwardPathNoWritePermission Path | -- | This wasn't a fast-forward. Here's a JWT to download the causal head, if you want it. FastForwardPathNotFastForward HashJWT @@ -811,7 +808,7 @@ data FastForwardPathResponse FastForwardPathInvalidParentage InvalidParentage deriving stock (Show) -data InvalidParentage = InvalidParentage {parent :: Hash, child :: Hash} +data InvalidParentage = InvalidParentage {parent :: Hash32, child :: Hash32} deriving stock (Show) instance ToJSON FastForwardPathResponse where @@ -847,8 +844,8 @@ instance FromJSON InvalidParentage where data UpdatePathRequest = UpdatePathRequest { path :: Path, - expectedHash :: Maybe Hash, -- Nothing requires empty history at destination - newHash :: Hash + expectedHash :: Maybe Hash32, -- Nothing requires empty history at destination + newHash :: Hash32 } deriving stock (Show, Eq, Ord) @@ -870,7 +867,7 @@ instance FromJSON UpdatePathRequest where data UpdatePathResponse = UpdatePathSuccess | UpdatePathHashMismatch HashMismatch - | UpdatePathMissingDependencies (NeedDependencies Hash) + | UpdatePathMissingDependencies (NeedDependencies Hash32) | UpdatePathNoWritePermission Path deriving stock (Show, Eq, Ord) @@ -893,8 +890,8 @@ instance FromJSON UpdatePathResponse where data HashMismatch = HashMismatch { path :: Path, - expectedHash :: Maybe Hash, - actualHash :: Maybe Hash + expectedHash :: Maybe Hash32, + actualHash :: Maybe Hash32 } deriving stock (Show, Eq, Ord) diff --git a/unison-share-api/unison-share-api.cabal b/unison-share-api/unison-share-api.cabal index 71a9fa24e..a9e3e75d7 100644 --- a/unison-share-api/unison-share-api.cabal +++ b/unison-share-api/unison-share-api.cabal @@ -105,6 +105,7 @@ library , unison-sqlite , unison-util , unison-util-base32hex + , unison-util-base32hex-orphans-aeson , unison-util-relation , unliftio , unordered-containers