From 973636bcfe10c6f9539bb4d73014279212ad5e0d Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 15 Aug 2024 15:37:01 -0700 Subject: [PATCH 01/44] Use separate PPE for each of LCA/Alice/Bob when computing synhashes. --- unison-merge/src/Unison/Merge/Diff.hs | 37 +++++---------------- unison-merge/src/Unison/Merge/Mergeblob1.hs | 24 ++++++++++++- 2 files changed, 31 insertions(+), 30 deletions(-) diff --git a/unison-merge/src/Unison/Merge/Diff.hs b/unison-merge/src/Unison/Merge/Diff.hs index 39be392c28..6e5786ea34 100644 --- a/unison-merge/src/Unison/Merge/Diff.hs +++ b/unison-merge/src/Unison/Merge/Diff.hs @@ -5,7 +5,6 @@ where import Data.Map.Strict qualified as Map import Data.Semialign (alignWith) -import Data.Set qualified as Set import Data.These (These (..)) import U.Codebase.Reference (TypeReference) import Unison.ConstructorReference (GConstructorReference (..)) @@ -14,20 +13,18 @@ import Unison.DataDeclaration qualified as DataDeclaration import Unison.DeclNameLookup (DeclNameLookup) import Unison.DeclNameLookup qualified as DeclNameLookup import Unison.Hash (Hash (Hash)) -import Unison.HashQualifiedPrime qualified as HQ' import Unison.Merge.DiffOp (DiffOp (..)) import Unison.Merge.PartialDeclNameLookup (PartialDeclNameLookup (..)) import Unison.Merge.Synhash qualified as Synhash import Unison.Merge.Synhashed (Synhashed (..)) import Unison.Merge.ThreeWay (ThreeWay (..)) -import Unison.Merge.ThreeWay qualified as ThreeWay import Unison.Merge.TwoWay (TwoWay (..)) import Unison.Merge.Updated (Updated (..)) import Unison.Name (Name) import Unison.Parser.Ann (Ann) import Unison.Prelude hiding (catMaybes) import Unison.PrettyPrintEnv (PrettyPrintEnv (..)) -import Unison.PrettyPrintEnv qualified as Ppe +import Unison.PrettyPrintEnvDecl qualified as PPED import Unison.Reference (Reference' (..), TermReference, TermReferenceId, TypeReferenceId) import Unison.Referent (Referent) import Unison.Referent qualified as Referent @@ -50,21 +47,16 @@ nameBasedNamespaceDiff :: (HasCallStack) => TwoWay DeclNameLookup -> PartialDeclNameLookup -> + ThreeWay PPED.PrettyPrintEnvDecl -> ThreeWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) -> Defns (Map TermReferenceId (Term Symbol Ann)) (Map TypeReferenceId (Decl Symbol Ann)) -> TwoWay (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference) -nameBasedNamespaceDiff declNameLookups lcaDeclNameLookup defns hydratedDefns = - let lcaHashes = synhashLcaDefns ppe lcaDeclNameLookup defns.lca hydratedDefns - hashes = synhashDefns ppe hydratedDefns <$> declNameLookups <*> ThreeWay.forgetLca defns - in diffHashedNamespaceDefns lcaHashes <$> hashes - where - ppe :: PrettyPrintEnv - ppe = - -- The order between Alice and Bob isn't important here for syntactic hashing; not sure right now if it matters - -- that the LCA is added last - deepNamespaceDefinitionsToPpe defns.alice - `Ppe.addFallback` deepNamespaceDefinitionsToPpe defns.bob - `Ppe.addFallback` deepNamespaceDefinitionsToPpe defns.lca +nameBasedNamespaceDiff declNameLookups lcaDeclNameLookup ppeds defns hydratedDefns = + let ThreeWay {lca = lcaPPE, alice = alicePPE, bob = bobPPE} = PPED.unsuffixifiedPPE <$> ppeds + lcaHashes = synhashLcaDefns lcaPPE lcaDeclNameLookup defns.lca hydratedDefns + aliceHashes = synhashDefns alicePPE hydratedDefns declNameLookups.alice defns.alice + bobHashes = synhashDefns bobPPE hydratedDefns declNameLookups.bob defns.bob + in diffHashedNamespaceDefns lcaHashes <$> TwoWay {alice = aliceHashes, bob = bobHashes} diffHashedNamespaceDefns :: DefnsF2 (Map Name) Synhashed term typ -> @@ -183,19 +175,6 @@ synhashDefnsWith hashTerm hashType = do hashType1 name typ = Synhashed (hashType name typ) typ ------------------------------------------------------------------------------------------------------------------------- --- Pretty-print env helpers - -deepNamespaceDefinitionsToPpe :: Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name) -> PrettyPrintEnv -deepNamespaceDefinitionsToPpe Defns {terms, types} = - PrettyPrintEnv (arbitraryName terms) (arbitraryName types) - where - arbitraryName :: (Ord ref) => BiMultimap ref Name -> ref -> [(HQ'.HashQualified Name, HQ'.HashQualified Name)] - arbitraryName names ref = - BiMultimap.lookupDom ref names - & Set.lookupMin - & maybe [] \name -> [(HQ'.NameOnly name, HQ'.NameOnly name)] - ------------------------------------------------------------------------------------------------------------------------ -- Looking up terms and decls that we expect to be there diff --git a/unison-merge/src/Unison/Merge/Mergeblob1.hs b/unison-merge/src/Unison/Merge/Mergeblob1.hs index 83cfd58b16..c0daa655cb 100644 --- a/unison-merge/src/Unison/Merge/Mergeblob1.hs +++ b/unison-merge/src/Unison/Merge/Mergeblob1.hs @@ -1,14 +1,17 @@ module Unison.Merge.Mergeblob1 ( Mergeblob1 (..), + hydratedDefnDependencies, makeMergeblob1, ) where +import Control.Lens import Data.List qualified as List import Data.Map.Strict qualified as Map import Unison.DataDeclaration (Decl) import Unison.DataDeclaration qualified as DataDeclaration import Unison.DeclNameLookup (DeclNameLookup) +import Unison.LabeledDependency qualified as LD import Unison.Merge.CombineDiffs (CombinedDiffOp, combineDiffs) import Unison.Merge.DeclCoherencyCheck (IncoherentDeclReason, checkDeclCoherency, lenientCheckDeclCoherency) import Unison.Merge.Diff (nameBasedNamespaceDiff) @@ -27,11 +30,14 @@ import Unison.Name (Name) import Unison.NameSegment (NameSegment) import Unison.Parser.Ann (Ann) import Unison.Prelude +import Unison.PrettyPrintEnvDecl qualified as PPED import Unison.Reference (TermReference, TermReferenceId, TypeReference, TypeReferenceId) import Unison.Referent (Referent) import Unison.Symbol (Symbol) import Unison.Term (Term) +import Unison.Term qualified as Term import Unison.Type (Type) +import Unison.Type qualified as Type import Unison.Util.BiMultimap (BiMultimap) import Unison.Util.Defns (Defns (..), DefnsF, DefnsF2, DefnsF3) @@ -54,10 +60,25 @@ data Mergeblob1 libdep = Mergeblob1 unconflicts :: DefnsF Unconflicts Referent TypeReference } +hydratedDefnDependencies :: + ThreeWay + ( DefnsF + (Map Name) + (TermReferenceId, (Term Symbol Ann, Type Symbol Ann)) + (TypeReferenceId, Decl Symbol Ann) + ) -> + ThreeWay (Set LD.LabeledDependency) +hydratedDefnDependencies hydratedDefns = + hydratedDefns + <&> \Defns {terms, types} -> + (terms & foldOf (folded . _2 . beside (to Term.labeledDependencies) (to Type.labeledDependencies))) + <> (types & foldOf (folded . _2 . to DataDeclaration.labeledDeclTypeDependencies)) + makeMergeblob1 :: forall libdep. (Eq libdep) => Mergeblob0 libdep -> + ThreeWay PPED.PrettyPrintEnvDecl {- Pretty print env containing names for everything in 'hydratedDefnDependencies' -} -> ThreeWay ( DefnsF (Map Name) @@ -65,7 +86,7 @@ makeMergeblob1 :: (TypeReferenceId, Decl Symbol Ann) ) -> Either (EitherWay IncoherentDeclReason) (Mergeblob1 libdep) -makeMergeblob1 blob hydratedDefns = do +makeMergeblob1 blob ppeds hydratedDefns = do -- Make one big constructor count lookup for all type decls let numConstructors = Map.empty @@ -97,6 +118,7 @@ makeMergeblob1 blob hydratedDefns = do nameBasedNamespaceDiff declNameLookups lcaDeclNameLookup + ppeds blob.defns Defns { terms = From 9df178db255a845f6a6663ec089537761e751bb4 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 15 Aug 2024 16:02:01 -0700 Subject: [PATCH 02/44] Build and pass in the appropriate merge PPED for alice/bob/lca --- .../Unison/Codebase/Editor/HandleInput/Merge2.hs | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs index d8166ae03a..13af6839fc 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs @@ -38,6 +38,7 @@ import Unison.Cli.MergeTypes (MergeSource (..), MergeSourceAndTarget (..), Merge import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Cli.MonadUtils qualified as Cli +import Unison.Cli.PrettyPrintUtils qualified as Cli import Unison.Cli.ProjectUtils qualified as ProjectUtils import Unison.Cli.UpdateUtils ( getNamespaceDependentsOf3, @@ -72,8 +73,10 @@ import Unison.Merge.ThreeWay qualified as ThreeWay import Unison.Name (Name) import Unison.NameSegment (NameSegment) import Unison.NameSegment qualified as NameSegment +import Unison.Names (Names) import Unison.Parser.Ann (Ann) import Unison.Prelude +import Unison.PrettyPrintEnvDecl qualified as PPED import Unison.Project ( ProjectAndBranch (..), ProjectBranchName, @@ -228,6 +231,16 @@ doMerge info = do Cli.runTransactionWithRollback2 (\rollback -> Right <$> action (rollback . Left)) & onLeftM (done . Output.ConflictedDefn "merge") + names3 :: Merge.ThreeWay Names <- do + let causalHashes = Merge.TwoOrThreeWay {alice = info.alice.causalHash, bob = info.bob.causalHash, lca = info.lca.causalHash} + branches <- for causalHashes \ch -> do + liftIO (Codebase.getBranchForHash env.codebase ch) >>= \case + Nothing -> done (Output.CouldntLoadBranch ch) + Just b -> pure b + let names = fmap (Branch.toNames . Branch.head) branches + pure Merge.ThreeWay {alice = names.alice, bob = names.bob, lca = fromMaybe mempty names.lca} + ppeds3 :: Merge.ThreeWay PPED.PrettyPrintEnvDecl <- for names3 Cli.prettyPrintEnvDeclFromNames + libdeps3 <- Cli.runTransaction (loadLibdeps branches) let blob0 = Merge.makeMergeblob0 nametrees3 libdeps3 @@ -252,7 +265,7 @@ doMerge info = do ) blob1 <- - Merge.makeMergeblob1 blob0 hydratedDefns & onLeft \case + Merge.makeMergeblob1 blob0 ppeds3 hydratedDefns & onLeft \case Merge.Alice reason -> done (Output.IncoherentDeclDuringMerge mergeTarget reason) Merge.Bob reason -> done (Output.IncoherentDeclDuringMerge mergeSource reason) From be313bc5dd6f9fb15b90bbd953889be2d1f000f6 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 19 Aug 2024 12:32:51 -0700 Subject: [PATCH 03/44] Add eitherToThese to prelude --- lib/unison-prelude/src/Unison/Prelude.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/lib/unison-prelude/src/Unison/Prelude.hs b/lib/unison-prelude/src/Unison/Prelude.hs index 374f4a1812..ef48bc2556 100644 --- a/lib/unison-prelude/src/Unison/Prelude.hs +++ b/lib/unison-prelude/src/Unison/Prelude.hs @@ -25,6 +25,7 @@ module Unison.Prelude whenJustM, eitherToMaybe, maybeToEither, + eitherToThese, altSum, altMap, hoistMaybe, @@ -82,6 +83,7 @@ import Data.Text as X (Text) import Data.Text qualified as Text import Data.Text.Encoding as X (decodeUtf8, encodeUtf8) import Data.Text.IO qualified as Text +import Data.These (These (..)) import Data.Traversable as X (for) import Data.Typeable as X (Typeable) import Data.Void as X (Void) @@ -205,6 +207,9 @@ throwEitherM = throwEitherMWith id throwEitherMWith :: forall e e' m a. (MonadIO m, Exception e') => (e -> e') -> m (Either e a) -> m a throwEitherMWith f action = throwExceptT . withExceptT f $ (ExceptT action) +eitherToThese :: Either a b -> These a b +eitherToThese = either This That + tShow :: (Show a) => a -> Text tShow = Text.pack . show From 0daa48971fbffc3fce07f408e935a968529237ca Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 19 Aug 2024 12:32:51 -0700 Subject: [PATCH 04/44] Split off propagated updates when computing diff --- .../Codebase/Editor/HandleInput/Merge2.hs | 5 +- unison-merge/src/Unison/Merge/Diff.hs | 60 +++++++++++++------ unison-merge/src/Unison/Merge/Mergeblob1.hs | 21 ++++--- unison-merge/src/Unison/Merge/Mergeblob2.hs | 2 +- 4 files changed, 57 insertions(+), 31 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs index 13af6839fc..0c97e4b363 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs @@ -38,7 +38,6 @@ import Unison.Cli.MergeTypes (MergeSource (..), MergeSourceAndTarget (..), Merge import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Cli.MonadUtils qualified as Cli -import Unison.Cli.PrettyPrintUtils qualified as Cli import Unison.Cli.ProjectUtils qualified as ProjectUtils import Unison.Cli.UpdateUtils ( getNamespaceDependentsOf3, @@ -76,7 +75,6 @@ import Unison.NameSegment qualified as NameSegment import Unison.Names (Names) import Unison.Parser.Ann (Ann) import Unison.Prelude -import Unison.PrettyPrintEnvDecl qualified as PPED import Unison.Project ( ProjectAndBranch (..), ProjectBranchName, @@ -239,7 +237,6 @@ doMerge info = do Just b -> pure b let names = fmap (Branch.toNames . Branch.head) branches pure Merge.ThreeWay {alice = names.alice, bob = names.bob, lca = fromMaybe mempty names.lca} - ppeds3 :: Merge.ThreeWay PPED.PrettyPrintEnvDecl <- for names3 Cli.prettyPrintEnvDeclFromNames libdeps3 <- Cli.runTransaction (loadLibdeps branches) @@ -265,7 +262,7 @@ doMerge info = do ) blob1 <- - Merge.makeMergeblob1 blob0 ppeds3 hydratedDefns & onLeft \case + Merge.makeMergeblob1 blob0 names3 hydratedDefns & onLeft \case Merge.Alice reason -> done (Output.IncoherentDeclDuringMerge mergeTarget reason) Merge.Bob reason -> done (Output.IncoherentDeclDuringMerge mergeSource reason) diff --git a/unison-merge/src/Unison/Merge/Diff.hs b/unison-merge/src/Unison/Merge/Diff.hs index 6e5786ea34..39a0254723 100644 --- a/unison-merge/src/Unison/Merge/Diff.hs +++ b/unison-merge/src/Unison/Merge/Diff.hs @@ -3,9 +3,11 @@ module Unison.Merge.Diff ) where +import Data.Either.Combinators (mapRight) import Data.Map.Strict qualified as Map -import Data.Semialign (alignWith) +import Data.Semialign (Unalign (..), alignWith) import Data.These (These (..)) +import Data.Zip qualified as Zip import U.Codebase.Reference (TypeReference) import Unison.ConstructorReference (GConstructorReference (..)) import Unison.DataDeclaration (Decl) @@ -14,16 +16,20 @@ import Unison.DeclNameLookup (DeclNameLookup) import Unison.DeclNameLookup qualified as DeclNameLookup import Unison.Hash (Hash (Hash)) import Unison.Merge.DiffOp (DiffOp (..)) +import Unison.Merge.HumanDiffOp (HumanDiffOp) import Unison.Merge.PartialDeclNameLookup (PartialDeclNameLookup (..)) import Unison.Merge.Synhash qualified as Synhash import Unison.Merge.Synhashed (Synhashed (..)) +import Unison.Merge.Synhashed qualified as Synhashed import Unison.Merge.ThreeWay (ThreeWay (..)) import Unison.Merge.TwoWay (TwoWay (..)) import Unison.Merge.Updated (Updated (..)) import Unison.Name (Name) +import Unison.Names (Names) import Unison.Parser.Ann (Ann) import Unison.Prelude hiding (catMaybes) import Unison.PrettyPrintEnv (PrettyPrintEnv (..)) +import Unison.PrettyPrintEnv qualified as PPE import Unison.PrettyPrintEnvDecl qualified as PPED import Unison.Reference (Reference' (..), TermReference, TermReferenceId, TypeReferenceId) import Unison.Referent (Referent) @@ -50,32 +56,50 @@ nameBasedNamespaceDiff :: ThreeWay PPED.PrettyPrintEnvDecl -> ThreeWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) -> Defns (Map TermReferenceId (Term Symbol Ann)) (Map TypeReferenceId (Decl Symbol Ann)) -> - TwoWay (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference) + ( -- Core diffs, i.e. adds, deletes, and updates which have different synhashes. + TwoWay (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference), + -- Propagated updates, i.e. updates which have the same synhash but different Unison hashes. + TwoWay (DefnsF2 (Map Name) Updated Referent TypeReference) + ) nameBasedNamespaceDiff declNameLookups lcaDeclNameLookup ppeds defns hydratedDefns = - let ThreeWay {lca = lcaPPE, alice = alicePPE, bob = bobPPE} = PPED.unsuffixifiedPPE <$> ppeds - lcaHashes = synhashLcaDefns lcaPPE lcaDeclNameLookup defns.lca hydratedDefns - aliceHashes = synhashDefns alicePPE hydratedDefns declNameLookups.alice defns.alice - bobHashes = synhashDefns bobPPE hydratedDefns declNameLookups.bob defns.bob - in diffHashedNamespaceDefns lcaHashes <$> TwoWay {alice = aliceHashes, bob = bobHashes} + let lcaHashes = synhashLcaDefns synhashPPE lcaDeclNameLookup defns.lca hydratedDefns + aliceHashes = synhashDefns synhashPPE hydratedDefns declNameLookups.alice defns.alice + bobHashes = synhashDefns synhashPPE hydratedDefns declNameLookups.bob defns.bob + in (diffHashedNamespaceDefns lcaHashes <$> TwoWay {alice = aliceHashes, bob = bobHashes}) + & Zip.unzip + where + synhashPPE :: PPE.PrettyPrintEnv + synhashPPE = + let ThreeWay {lca = lcaPPE, alice = alicePPE, bob = bobPPE} = PPED.unsuffixifiedPPE <$> ppeds + in alicePPE `PPE.addFallback` bobPPE `PPE.addFallback` lcaPPE diffHashedNamespaceDefns :: DefnsF2 (Map Name) Synhashed term typ -> DefnsF2 (Map Name) Synhashed term typ -> - DefnsF3 (Map Name) DiffOp Synhashed term typ -diffHashedNamespaceDefns = - zipDefnsWith f f + ( -- Core diffs, i.e. adds, deletes, and updates which have different synhashes. + DefnsF3 (Map Name) DiffOp Synhashed term typ, + -- Propagated updates, i.e. updates which have the same synhash but different Unison hashes. + DefnsF2 (Map Name) Updated term typ + ) +diffHashedNamespaceDefns d1 d2 = + zipDefnsWith f f d1 d2 + & splitPropagated where - f :: Map Name (Synhashed ref) -> Map Name (Synhashed ref) -> Map Name (DiffOp (Synhashed ref)) - f old new = - Map.mapMaybe id (alignWith g old new) + f :: Map Name (Synhashed ref) -> Map Name (Synhashed ref) -> (Map Name (DiffOp (Synhashed ref)), Map Name (Updated ref)) + f old new = unalign (eitherToThese . mapRight (fmap Synhashed.value) <$> alignWith g old new) - g :: (Eq x) => These x x -> Maybe (DiffOp x) + g :: (Eq x) => These x x -> Either (DiffOp x) (Updated x) g = \case - This old -> Just (DiffOp'Delete old) - That new -> Just (DiffOp'Add new) + This old -> Left (DiffOp'Delete old) + That new -> Left (DiffOp'Add new) These old new - | old == new -> Nothing - | otherwise -> Just (DiffOp'Update Updated {old, new}) + | old == new -> Right (Updated {old, new}) + | otherwise -> Left (DiffOp'Update Updated {old, new}) + splitPropagated :: + Defns (Map Name (DiffOp (Synhashed term)), Map Name (Updated term)) (Map Name (DiffOp (Synhashed typ)), Map Name (Updated typ)) -> + (DefnsF3 (Map Name) DiffOp Synhashed term typ, DefnsF2 (Map Name) Updated term typ) + splitPropagated Defns {terms, types} = + (Defns {terms = fst terms, types = fst types}, Defns {terms = snd terms, types = snd types}) ------------------------------------------------------------------------------------------------------------------------ -- Syntactic hashing diff --git a/unison-merge/src/Unison/Merge/Mergeblob1.hs b/unison-merge/src/Unison/Merge/Mergeblob1.hs index c0daa655cb..5aeabc693d 100644 --- a/unison-merge/src/Unison/Merge/Mergeblob1.hs +++ b/unison-merge/src/Unison/Merge/Mergeblob1.hs @@ -28,9 +28,12 @@ import Unison.Merge.TwoWay (TwoWay (..)) import Unison.Merge.Unconflicts (Unconflicts) import Unison.Name (Name) import Unison.NameSegment (NameSegment) +import Unison.Names (Names) import Unison.Parser.Ann (Ann) import Unison.Prelude +import Unison.PrettyPrintEnv.Names qualified as PPE import Unison.PrettyPrintEnvDecl qualified as PPED +import Unison.PrettyPrintEnvDecl.Names qualified as PPED import Unison.Reference (TermReference, TermReferenceId, TypeReference, TypeReferenceId) import Unison.Referent (Referent) import Unison.Symbol (Symbol) @@ -46,7 +49,7 @@ data Mergeblob1 libdep = Mergeblob1 declNameLookups :: TwoWay DeclNameLookup, defns :: ThreeWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)), diff :: DefnsF2 (Map Name) CombinedDiffOp Referent TypeReference, - diffs :: TwoWay (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference), + diffsFromLCA :: TwoWay (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference), hydratedDefns :: ThreeWay ( DefnsF @@ -78,7 +81,7 @@ makeMergeblob1 :: forall libdep. (Eq libdep) => Mergeblob0 libdep -> - ThreeWay PPED.PrettyPrintEnvDecl {- Pretty print env containing names for everything in 'hydratedDefnDependencies' -} -> + ThreeWay Names {- Names for _at least_ every reference in 'hydratedDefnDependencies' -} -> ThreeWay ( DefnsF (Map Name) @@ -86,7 +89,9 @@ makeMergeblob1 :: (TypeReferenceId, Decl Symbol Ann) ) -> Either (EitherWay IncoherentDeclReason) (Mergeblob1 libdep) -makeMergeblob1 blob ppeds hydratedDefns = do +makeMergeblob1 blob names3 hydratedDefns = do + let ppeds3 :: ThreeWay PPED.PrettyPrintEnvDecl + ppeds3 = names3 <&> \names -> (PPED.makePPED (PPE.namer names) (PPE.suffixifyByHash names)) -- Make one big constructor count lookup for all type decls let numConstructors = Map.empty @@ -114,11 +119,11 @@ makeMergeblob1 blob ppeds hydratedDefns = do lenientCheckDeclCoherency blob.nametrees.lca numConstructors -- Diff LCA->Alice and LCA->Bob - let diffs = + let (diffsFromLCA, propagatedUpdates) = nameBasedNamespaceDiff declNameLookups lcaDeclNameLookup - ppeds + ppeds3 blob.defns Defns { terms = @@ -132,8 +137,8 @@ makeMergeblob1 blob ppeds hydratedDefns = do } -- Combine the LCA->Alice and LCA->Bob diffs together - let diff = - combineDiffs diffs + let diff = combineDiffs diffsFromLCA + -- Partition the combined diff into the conflicted things and the unconflicted things let (conflicts, unconflicts) = @@ -154,7 +159,7 @@ makeMergeblob1 blob ppeds hydratedDefns = do declNameLookups, defns = blob.defns, diff, - diffs, + diffsFromLCA, hydratedDefns, lcaDeclNameLookup, libdeps, diff --git a/unison-merge/src/Unison/Merge/Mergeblob2.hs b/unison-merge/src/Unison/Merge/Mergeblob2.hs index fc76660bbe..6c4d98090f 100644 --- a/unison-merge/src/Unison/Merge/Mergeblob2.hs +++ b/unison-merge/src/Unison/Merge/Mergeblob2.hs @@ -62,7 +62,7 @@ data Mergeblob2Error makeMergeblob2 :: Mergeblob1 libdep -> Either Mergeblob2Error (Mergeblob2 libdep) makeMergeblob2 blob = do -- Bail early if it looks like we can't proceed with the merge, because Alice or Bob has one or more conflicted alias - for_ ((,) <$> TwoWay Alice Bob <*> blob.diffs) \(who, diff) -> + for_ ((,) <$> TwoWay Alice Bob <*> blob.diffsFromLCA) \(who, diff) -> whenJust (findConflictedAlias blob.defns.lca diff) $ Left . Mergeblob2Error'ConflictedAlias . who From 01fff50b75e3c459926d0568408956b55396e408 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 19 Aug 2024 12:32:51 -0700 Subject: [PATCH 05/44] Add Human Diff machinery --- unison-merge/src/Unison/Merge/Diff.hs | 10 +++++++ unison-merge/src/Unison/Merge/HumanDiffOp.hs | 29 ++++++++++++++++++++ unison-merge/src/Unison/Merge/Mergeblob1.hs | 4 +++ unison-merge/unison-merge.cabal | 1 + 4 files changed, 44 insertions(+) create mode 100644 unison-merge/src/Unison/Merge/HumanDiffOp.hs diff --git a/unison-merge/src/Unison/Merge/Diff.hs b/unison-merge/src/Unison/Merge/Diff.hs index 39a0254723..d0ccc5e3cc 100644 --- a/unison-merge/src/Unison/Merge/Diff.hs +++ b/unison-merge/src/Unison/Merge/Diff.hs @@ -1,5 +1,6 @@ module Unison.Merge.Diff ( nameBasedNamespaceDiff, + humanizeDiffs, ) where @@ -101,6 +102,15 @@ diffHashedNamespaceDefns d1 d2 = splitPropagated Defns {terms, types} = (Defns {terms = fst terms, types = fst types}, Defns {terms = snd terms, types = snd types}) +-- | Post-process a diff to identify relationships humans might care about, +-- such as whether a given addition could be interpreted as an alias of an existing definition, +-- or whether an add and deletion could be a rename. +humanizeDiffs :: + ThreeWay Names -> + TwoWay (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference) -> + TwoWay (DefnsF2 (Map Name) HumanDiffOp Referent TypeReference) +humanizeDiffs names3 diffs = _ + ------------------------------------------------------------------------------------------------------------------------ -- Syntactic hashing diff --git a/unison-merge/src/Unison/Merge/HumanDiffOp.hs b/unison-merge/src/Unison/Merge/HumanDiffOp.hs new file mode 100644 index 0000000000..a6518852bc --- /dev/null +++ b/unison-merge/src/Unison/Merge/HumanDiffOp.hs @@ -0,0 +1,29 @@ +module Unison.Merge.HumanDiffOp + ( HumanDiffOp (..), + ) +where + +import Data.Set (Set) +import Data.Set.NonEmpty (NESet) +import Unison.Merge.Updated (Updated) +import Unison.Name (Name) + +-- | A diff operation is one of: +-- +-- * An add (where nothing was) +-- * A delete (of the thing that was) +-- * An update (from old to new) +-- * A propagated update (from old to new) +-- * An alias of some definition(s) on the other side +-- * A rename from some definition(s) on the other side +data HumanDiffOp ref + = HumanDiffOp'Add !ref + | HumanDiffOp'Delete !ref + | HumanDiffOp'Update !(Updated ref) + | HumanDiffOp'PropagatedUpdate !(Updated ref) + | HumanDiffOp'AliasOf !ref !(NESet Name {- existing names -}) + | -- The definition at this location was renamed from the given set of names to the current place + HumanDiffOp'RenamedFrom !ref !(NESet Name) + | -- The definition at this location was renamed to the given set of names from the current place + HumanDiffOp'RenamedTo !ref !(NESet Name) + deriving stock (Show) diff --git a/unison-merge/src/Unison/Merge/Mergeblob1.hs b/unison-merge/src/Unison/Merge/Mergeblob1.hs index 5aeabc693d..4b69b79990 100644 --- a/unison-merge/src/Unison/Merge/Mergeblob1.hs +++ b/unison-merge/src/Unison/Merge/Mergeblob1.hs @@ -17,6 +17,7 @@ import Unison.Merge.DeclCoherencyCheck (IncoherentDeclReason, checkDeclCoherency import Unison.Merge.Diff (nameBasedNamespaceDiff) import Unison.Merge.DiffOp (DiffOp) import Unison.Merge.EitherWay (EitherWay (..)) +import Unison.Merge.HumanDiffOp (HumanDiffOp) import Unison.Merge.Libdeps (LibdepDiffOp, applyLibdepsDiff, diffLibdeps, getTwoFreshLibdepNames) import Unison.Merge.Mergeblob0 (Mergeblob0 (..)) import Unison.Merge.PartialDeclNameLookup (PartialDeclNameLookup) @@ -50,6 +51,7 @@ data Mergeblob1 libdep = Mergeblob1 defns :: ThreeWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)), diff :: DefnsF2 (Map Name) CombinedDiffOp Referent TypeReference, diffsFromLCA :: TwoWay (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference), + humanDiffsFromLCA :: TwoWay (DefnsF2 (Map Name) HumanDiffOp Referent TypeReference), hydratedDefns :: ThreeWay ( DefnsF @@ -139,6 +141,7 @@ makeMergeblob1 blob names3 hydratedDefns = do -- Combine the LCA->Alice and LCA->Bob diffs together let diff = combineDiffs diffsFromLCA + let humanDiffsFromLCA = humanizeDiffs names3 diffsFromLCA propagatedUpdates -- Partition the combined diff into the conflicted things and the unconflicted things let (conflicts, unconflicts) = @@ -160,6 +163,7 @@ makeMergeblob1 blob names3 hydratedDefns = do defns = blob.defns, diff, diffsFromLCA, + humanDiffsFromLCA, hydratedDefns, lcaDeclNameLookup, libdeps, diff --git a/unison-merge/unison-merge.cabal b/unison-merge/unison-merge.cabal index 01f9170c4c..20fa1b3a4c 100644 --- a/unison-merge/unison-merge.cabal +++ b/unison-merge/unison-merge.cabal @@ -25,6 +25,7 @@ library Unison.Merge.EitherWay Unison.Merge.EitherWayI Unison.Merge.FindConflictedAlias + Unison.Merge.HumanDiffOp Unison.Merge.Libdeps Unison.Merge.Mergeblob0 Unison.Merge.Mergeblob1 From bba872243c1cfd24d204baf6f024eea682278c39 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 19 Aug 2024 13:25:55 -0700 Subject: [PATCH 06/44] Wire up a working humanized diff. --- .../Codebase/Editor/HandleInput/Merge2.hs | 2 +- unison-core/src/Unison/Util/Defns.hs | 12 +++ unison-merge/src/Unison/Merge/Diff.hs | 76 ++++++++++++++++++- unison-merge/src/Unison/Merge/HumanDiffOp.hs | 1 - unison-merge/src/Unison/Merge/Mergeblob1.hs | 2 +- 5 files changed, 87 insertions(+), 6 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs index 0c97e4b363..1a533734e8 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs @@ -266,7 +266,7 @@ doMerge info = do Merge.Alice reason -> done (Output.IncoherentDeclDuringMerge mergeTarget reason) Merge.Bob reason -> done (Output.IncoherentDeclDuringMerge mergeSource reason) - liftIO (debugFunctions.debugDiffs blob1.diffs) + liftIO (debugFunctions.debugDiffs blob1.diffsFromLCA) liftIO (debugFunctions.debugCombinedDiff blob1.diff) diff --git a/unison-core/src/Unison/Util/Defns.hs b/unison-core/src/Unison/Util/Defns.hs index e61c5ba7bb..5f56166d01 100644 --- a/unison-core/src/Unison/Util/Defns.hs +++ b/unison-core/src/Unison/Util/Defns.hs @@ -13,6 +13,7 @@ module Unison.Util.Defns zipDefns, zipDefnsWith, zipDefnsWith3, + zipDefnsWith4, ) where @@ -99,3 +100,14 @@ zipDefnsWith3 :: Defns tm4 ty4 zipDefnsWith3 f g (Defns terms1 types1) (Defns terms2 types2) (Defns terms3 types3) = Defns (f terms1 terms2 terms3) (g types1 types2 types3) + +zipDefnsWith4 :: + (tm1 -> tm2 -> tm3 -> tm4 -> tm5) -> + (ty1 -> ty2 -> ty3 -> ty4 -> ty5) -> + Defns tm1 ty1 -> + Defns tm2 ty2 -> + Defns tm3 ty3 -> + Defns tm4 ty4 -> + Defns tm5 ty5 +zipDefnsWith4 f g (Defns terms1 types1) (Defns terms2 types2) (Defns terms3 types3) (Defns terms4 types4) = + Defns (f terms1 terms2 terms3 terms4) (g types1 types2 types3 types4) diff --git a/unison-merge/src/Unison/Merge/Diff.hs b/unison-merge/src/Unison/Merge/Diff.hs index d0ccc5e3cc..b4d6730d85 100644 --- a/unison-merge/src/Unison/Merge/Diff.hs +++ b/unison-merge/src/Unison/Merge/Diff.hs @@ -5,8 +5,12 @@ module Unison.Merge.Diff where import Data.Either.Combinators (mapRight) +import Data.List.NonEmpty qualified as NEL +import Data.List.NonEmpty qualified as NEList import Data.Map.Strict qualified as Map import Data.Semialign (Unalign (..), alignWith) +import Data.Set qualified as Set +import Data.Set.NonEmpty qualified as NESet import Data.These (These (..)) import Data.Zip qualified as Zip import U.Codebase.Reference (TypeReference) @@ -17,16 +21,18 @@ import Unison.DeclNameLookup (DeclNameLookup) import Unison.DeclNameLookup qualified as DeclNameLookup import Unison.Hash (Hash (Hash)) import Unison.Merge.DiffOp (DiffOp (..)) -import Unison.Merge.HumanDiffOp (HumanDiffOp) +import Unison.Merge.HumanDiffOp (HumanDiffOp (..)) import Unison.Merge.PartialDeclNameLookup (PartialDeclNameLookup (..)) import Unison.Merge.Synhash qualified as Synhash import Unison.Merge.Synhashed (Synhashed (..)) import Unison.Merge.Synhashed qualified as Synhashed import Unison.Merge.ThreeWay (ThreeWay (..)) +import Unison.Merge.ThreeWay qualified as ThreeWay import Unison.Merge.TwoWay (TwoWay (..)) import Unison.Merge.Updated (Updated (..)) import Unison.Name (Name) import Unison.Names (Names) +import Unison.Names qualified as Names import Unison.Parser.Ann (Ann) import Unison.Prelude hiding (catMaybes) import Unison.PrettyPrintEnv (PrettyPrintEnv (..)) @@ -40,7 +46,10 @@ import Unison.Syntax.Name qualified as Name import Unison.Term (Term) import Unison.Util.BiMultimap (BiMultimap) import Unison.Util.BiMultimap qualified as BiMultimap -import Unison.Util.Defns (Defns (..), DefnsF2, DefnsF3, zipDefnsWith) +import Unison.Util.Defns (Defns (..), DefnsF, DefnsF2, DefnsF3, zipDefnsWith) +import Unison.Util.Defns qualified as Defns +import Unison.Util.Relation (Relation) +import Unison.Util.Relation qualified as Rel -- | @nameBasedNamespaceDiff db declNameLookups defns@ returns Alice's and Bob's name-based namespace diffs, each in the -- form: @@ -108,8 +117,69 @@ diffHashedNamespaceDefns d1 d2 = humanizeDiffs :: ThreeWay Names -> TwoWay (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference) -> + TwoWay (DefnsF2 (Map Name) Updated Referent TypeReference) -> TwoWay (DefnsF2 (Map Name) HumanDiffOp Referent TypeReference) -humanizeDiffs names3 diffs = _ +humanizeDiffs names3 diffs propagatedUpdates = + zipWithF3 + nameRelations + diffs + propagatedUpdates + \relation diffOps propagatedUpdates -> Defns.zipDefnsWith4 computeHumanDiffOp computeHumanDiffOp lcaRelation relation diffOps propagatedUpdates + where + zipWithF3 :: (Zip.Zip f) => f a -> f b -> f c -> (a -> b -> c -> d) -> f d + zipWithF3 a b c f = Zip.zipWith (\(x, y) z -> f x y z) (Zip.zip a b) c + namesToRelations :: Names -> (DefnsF (Relation Name) Referent TypeReference) + namesToRelations names = Defns {terms = Names.terms names, types = Names.types names} + lcaRelation :: DefnsF (Relation Name) Referent TypeReference + lcaRelation = namesToRelations names3.lca + nameRelations :: TwoWay (DefnsF (Relation Name) Referent TypeReference) + nameRelations = namesToRelations <$> ThreeWay.forgetLca names3 + + computeHumanDiffOp :: + forall ref. + (Show ref, Ord ref) => + Relation Name ref -> + Relation Name ref -> + Map Name (DiffOp (Synhashed ref)) -> + Map Name (Updated ref) -> + Map Name (HumanDiffOp ref) + computeHumanDiffOp oldRelation newRelation diffs propagatedUpdates = alignWith go diffs propagatedUpdates + where + go :: These (DiffOp (Synhashed ref)) (Updated ref) -> (HumanDiffOp ref) + go = \case + This diff -> humanizeDiffOp (Synhashed.value <$> diff) + That updated -> (HumanDiffOp'PropagatedUpdate updated) + These diff updated -> error (reportBug "E488729" ("The impossible happened, an update in merge was detected as both a propagated AND core update " ++ show diff ++ " and " ++ show updated)) + + humanizeDiffOp :: DiffOp ref -> HumanDiffOp ref + humanizeDiffOp = \case + DiffOp'Add ref -> + -- This name is newly added. We need to check if it's a new definition, an alias, or a rename. + case Set.toList (Rel.lookupRan ref oldRelation) of + -- No old names for this ref, so it's a new addition not an alias + [] -> HumanDiffOp'Add ref + -- There are old names for this ref, but not old refs for this name, so it's + -- either a new alias or a rename. + -- + -- If at least one old name for this ref no longer exists, we treat it like a + -- rename. + (n : ns) -> do + let existingNames = NESet.fromList (n NEList.:| ns) + case NESet.nonEmptySet (Rel.lookupRan ref newRelation) of + Nothing -> error (reportBug "E458329" ("Expected to find at least one name for ref in new namespace, since we found the ref by the name.")) + Just allNewNames -> + case NESet.nonEmptySet (NESet.difference existingNames allNewNames) of + -- If all the old names still exist in the new namespace, it's a new alias. + Nothing -> HumanDiffOp'AliasOf ref existingNames + -- Otherwise, treat it as a rename. + Just namesWhichDisappeared -> + HumanDiffOp'RenamedFrom ref namesWhichDisappeared + DiffOp'Delete ref -> + case NEL.nonEmpty $ Set.toList (Rel.lookupRan ref newRelation) of + -- No names for this ref, it was removed. + Nothing -> HumanDiffOp'Delete ref + Just newNames -> HumanDiffOp'RenamedTo ref (NESet.fromList newNames) + DiffOp'Update Updated {old, new} -> HumanDiffOp'Update Updated {old, new} ------------------------------------------------------------------------------------------------------------------------ -- Syntactic hashing diff --git a/unison-merge/src/Unison/Merge/HumanDiffOp.hs b/unison-merge/src/Unison/Merge/HumanDiffOp.hs index a6518852bc..1a4c5e4299 100644 --- a/unison-merge/src/Unison/Merge/HumanDiffOp.hs +++ b/unison-merge/src/Unison/Merge/HumanDiffOp.hs @@ -3,7 +3,6 @@ module Unison.Merge.HumanDiffOp ) where -import Data.Set (Set) import Data.Set.NonEmpty (NESet) import Unison.Merge.Updated (Updated) import Unison.Name (Name) diff --git a/unison-merge/src/Unison/Merge/Mergeblob1.hs b/unison-merge/src/Unison/Merge/Mergeblob1.hs index 4b69b79990..6e5477a84b 100644 --- a/unison-merge/src/Unison/Merge/Mergeblob1.hs +++ b/unison-merge/src/Unison/Merge/Mergeblob1.hs @@ -14,7 +14,7 @@ import Unison.DeclNameLookup (DeclNameLookup) import Unison.LabeledDependency qualified as LD import Unison.Merge.CombineDiffs (CombinedDiffOp, combineDiffs) import Unison.Merge.DeclCoherencyCheck (IncoherentDeclReason, checkDeclCoherency, lenientCheckDeclCoherency) -import Unison.Merge.Diff (nameBasedNamespaceDiff) +import Unison.Merge.Diff (humanizeDiffs, nameBasedNamespaceDiff) import Unison.Merge.DiffOp (DiffOp) import Unison.Merge.EitherWay (EitherWay (..)) import Unison.Merge.HumanDiffOp (HumanDiffOp) From de79fe82f6f020ab9ab39785cc75b29ddf76a258 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 19 Aug 2024 16:31:56 -0700 Subject: [PATCH 07/44] Fix up hydrated defns labeled dependencies --- unison-merge/src/Unison/Merge/Mergeblob1.hs | 30 +++++++++++---------- 1 file changed, 16 insertions(+), 14 deletions(-) diff --git a/unison-merge/src/Unison/Merge/Mergeblob1.hs b/unison-merge/src/Unison/Merge/Mergeblob1.hs index 6e5477a84b..5a0799f863 100644 --- a/unison-merge/src/Unison/Merge/Mergeblob1.hs +++ b/unison-merge/src/Unison/Merge/Mergeblob1.hs @@ -1,6 +1,6 @@ module Unison.Merge.Mergeblob1 ( Mergeblob1 (..), - hydratedDefnDependencies, + hydratedDefnsLabeledDependencies, makeMergeblob1, ) where @@ -8,8 +8,10 @@ where import Control.Lens import Data.List qualified as List import Data.Map.Strict qualified as Map +import Data.Set qualified as Set import Unison.DataDeclaration (Decl) import Unison.DataDeclaration qualified as DataDeclaration +import Unison.DataDeclaration.Dependencies qualified as Decl import Unison.DeclNameLookup (DeclNameLookup) import Unison.LabeledDependency qualified as LD import Unison.Merge.CombineDiffs (CombinedDiffOp, combineDiffs) @@ -36,6 +38,7 @@ import Unison.PrettyPrintEnv.Names qualified as PPE import Unison.PrettyPrintEnvDecl qualified as PPED import Unison.PrettyPrintEnvDecl.Names qualified as PPED import Unison.Reference (TermReference, TermReferenceId, TypeReference, TypeReferenceId) +import Unison.Reference qualified as Reference import Unison.Referent (Referent) import Unison.Symbol (Symbol) import Unison.Term (Term) @@ -65,19 +68,18 @@ data Mergeblob1 libdep = Mergeblob1 unconflicts :: DefnsF Unconflicts Referent TypeReference } -hydratedDefnDependencies :: - ThreeWay - ( DefnsF - (Map Name) - (TermReferenceId, (Term Symbol Ann, Type Symbol Ann)) - (TypeReferenceId, Decl Symbol Ann) - ) -> - ThreeWay (Set LD.LabeledDependency) -hydratedDefnDependencies hydratedDefns = - hydratedDefns - <&> \Defns {terms, types} -> - (terms & foldOf (folded . _2 . beside (to Term.labeledDependencies) (to Type.labeledDependencies))) - <> (types & foldOf (folded . _2 . to DataDeclaration.labeledDeclTypeDependencies)) +-- | Get a names object for all the hydrated definitions AND their direct dependencies +hydratedDefnsLabeledDependencies :: (DefnsF (Map Name) (TermReferenceId, (Term Symbol Ann, Type Symbol Ann)) (TypeReferenceId, Decl Symbol Ann)) -> Set LD.LabeledDependency +hydratedDefnsLabeledDependencies (Defns {terms, types}) = + let termDeps :: Set LD.LabeledDependency + termDeps = foldOf (folded . beside (to Reference.DerivedId . to LD.TermReference . to Set.singleton) (beside (to Term.labeledDependencies) (to Type.labeledDependencies))) terms + typeDeps :: Set LD.LabeledDependency + typeDeps = + types + & foldMap \(typeRefId, typeDecl) -> + let typeRef = Reference.DerivedId typeRefId + in Decl.labeledDeclDependenciesIncludingSelfAndFieldAccessors typeRef typeDecl + in termDeps <> typeDeps makeMergeblob1 :: forall libdep. From 020d9c6d1ceb42edc5448a4e4d87bbdecaa58d09 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 21 Aug 2024 12:02:38 -0700 Subject: [PATCH 08/44] Add semigroup/monoid to nametree --- unison-core/src/Unison/Util/Nametree.hs | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/unison-core/src/Unison/Util/Nametree.hs b/unison-core/src/Unison/Util/Nametree.hs index e87bdde344..50ae6d1510 100644 --- a/unison-core/src/Unison/Util/Nametree.hs +++ b/unison-core/src/Unison/Util/Nametree.hs @@ -3,6 +3,7 @@ module Unison.Util.Nametree Nametree (..), traverseNametreeWithName, unfoldNametree, + unionWith, -- ** Flattening and unflattening flattenNametree, @@ -33,6 +34,16 @@ data Nametree a = Nametree } deriving stock (Functor, Foldable, Traversable, Generic, Show) +unionWith :: (a -> a -> a) -> Nametree a -> Nametree a -> Nametree a +unionWith f (Nametree x xs) (Nametree y ys) = + Nametree (f x y) (Map.unionWith (unionWith f) xs ys) + +instance (Semigroup a) => Semigroup (Nametree a) where + (<>) = unionWith (<>) + +instance (Monoid a) => Monoid (Nametree a) where + mempty = Nametree mempty mempty + instance Semialign Nametree where alignWith :: (These a b -> c) -> Nametree a -> Nametree b -> Nametree c alignWith f (Nametree x xs) (Nametree y ys) = From 50715280a5e00b1044baa471eb8ff1d97c9decc2 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 21 Aug 2024 15:26:45 -0700 Subject: [PATCH 09/44] Add optics for Defns --- unison-core/src/Unison/Util/Defns.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/unison-core/src/Unison/Util/Defns.hs b/unison-core/src/Unison/Util/Defns.hs index 5f56166d01..dc87e7ebc8 100644 --- a/unison-core/src/Unison/Util/Defns.hs +++ b/unison-core/src/Unison/Util/Defns.hs @@ -4,6 +4,8 @@ module Unison.Util.Defns DefnsF2, DefnsF3, DefnsF4, + terms_, + types_, alignDefnsWith, defnsAreEmpty, hoistDefnsF, @@ -17,6 +19,7 @@ module Unison.Util.Defns ) where +import Control.Lens (Lens) import Data.Align (Semialign, alignWith) import Data.Bifoldable (Bifoldable, bifoldMap) import Data.Bitraversable (Bitraversable, bitraverse) @@ -44,6 +47,12 @@ instance Bitraversable Defns where bitraverse f g (Defns x y) = Defns <$> f x <*> g y +terms_ :: Lens (Defns terms types) (Defns terms' types) terms terms' +terms_ f (Defns x y) = (\x' -> Defns x' y) <$> f x + +types_ :: Lens (Defns terms types) (Defns terms types') types types' +types_ f (Defns x y) = (\y' -> Defns x y') <$> f y + -- | A common shape of definitions - terms and types are stored in the same structure. type DefnsF f terms types = Defns (f terms) (f types) From 821ec0416721d2cb6d7619639ff0c8e5d063b653 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 21 Aug 2024 16:42:03 -0700 Subject: [PATCH 10/44] Add Eq, Ord to Defn combinators --- unison-core/src/Unison/Util/Defn.hs | 21 +++++++++++++++++++++ unison-core/src/Unison/Util/Defns.hs | 2 +- 2 files changed, 22 insertions(+), 1 deletion(-) diff --git a/unison-core/src/Unison/Util/Defn.hs b/unison-core/src/Unison/Util/Defn.hs index d897491de4..26a0fdd222 100644 --- a/unison-core/src/Unison/Util/Defn.hs +++ b/unison-core/src/Unison/Util/Defn.hs @@ -3,7 +3,28 @@ module Unison.Util.Defn ) where +import Data.Bifoldable (Bifoldable (..)) +import Data.Bifunctor (Bifunctor (..)) +import Data.Bitraversable (Bitraversable (..)) +import GHC.Generics (Generic) + -- | A "definition" is either a term or a type. data Defn term typ = TermDefn term | TypeDefn typ + deriving stock (Generic, Functor, Foldable, Traversable, Show, Eq, Ord) + +instance Bifunctor Defn where + bimap f g = \case + TermDefn x -> TermDefn (f x) + TypeDefn y -> TypeDefn (g y) + +instance Bifoldable Defn where + bifoldMap f g = \case + TermDefn x -> f x + TypeDefn y -> g y + +instance Bitraversable Defn where + bitraverse f g = \case + TermDefn x -> TermDefn <$> f x + TypeDefn y -> TypeDefn <$> g y diff --git a/unison-core/src/Unison/Util/Defns.hs b/unison-core/src/Unison/Util/Defns.hs index dc87e7ebc8..5c4eb8d41e 100644 --- a/unison-core/src/Unison/Util/Defns.hs +++ b/unison-core/src/Unison/Util/Defns.hs @@ -32,7 +32,7 @@ data Defns terms types = Defns { terms :: terms, types :: types } - deriving stock (Generic, Functor, Show) + deriving stock (Generic, Functor, Show, Eq, Ord) deriving (Monoid, Semigroup) via GenericSemigroupMonoid (Defns terms types) instance Bifoldable Defns where From 375cb30b124e5b7dd5137c8c5c19238e7cf68d94 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 22 Aug 2024 09:48:33 -0700 Subject: [PATCH 11/44] Add for to Set Utils --- lib/unison-prelude/src/Unison/Util/Set.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/lib/unison-prelude/src/Unison/Util/Set.hs b/lib/unison-prelude/src/Unison/Util/Set.hs index 50d2cff56a..789708937b 100644 --- a/lib/unison-prelude/src/Unison/Util/Set.hs +++ b/lib/unison-prelude/src/Unison/Util/Set.hs @@ -4,6 +4,7 @@ module Unison.Util.Set mapMaybe, symmetricDifference, Unison.Util.Set.traverse, + Unison.Util.Set.for, flatMap, filterM, forMaybe, @@ -45,6 +46,9 @@ forMaybe xs f = traverse :: (Applicative f, Ord b) => (a -> f b) -> Set a -> f (Set b) traverse f = fmap Set.fromList . Prelude.traverse f . Set.toList +for :: (Ord b, Applicative f) => Set a -> (a -> f b) -> f (Set b) +for = flip Unison.Util.Set.traverse + flatMap :: (Ord b) => (a -> Set b) -> Set a -> Set b flatMap f = Set.unions . fmap f . Set.toList From 036793ee78b5ae91e5ccf32e82cd366ee14bdfeb Mon Sep 17 00:00:00 2001 From: Mitchell Dalvi Rosen Date: Tue, 3 Dec 2024 12:20:26 -0500 Subject: [PATCH 12/44] tweaks --- .../Codebase/Editor/HandleInput/Merge2.hs | 17 ++++++++++++----- unison-merge/src/Unison/Merge/Diff.hs | 9 +++------ 2 files changed, 15 insertions(+), 11 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs index 353c29763e..8dc383882e 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs @@ -238,8 +238,17 @@ doMerge info = do Cli.runTransactionWithRollback2 (\rollback -> Right <$> action (rollback . Left)) & onLeftM (done . Output.ConflictedDefn "merge") + libdeps3 <- Cli.runTransaction (loadLibdeps branches) + + let blob0 = Merge.makeMergeblob0 nametrees3 libdeps3 + names3 :: Merge.ThreeWay Names <- do - let causalHashes = Merge.TwoOrThreeWay {alice = info.alice.causalHash, bob = info.bob.causalHash, lca = info.lca.causalHash} + let causalHashes = + Merge.TwoOrThreeWay + { alice = info.alice.causalHash, + bob = info.bob.causalHash, + lca = info.lca.causalHash + } branches <- for causalHashes \ch -> do liftIO (Codebase.getBranchForHash env.codebase ch) >>= \case Nothing -> done (Output.CouldntLoadBranch ch) @@ -247,9 +256,7 @@ doMerge info = do let names = fmap (Branch.toNames . Branch.head) branches pure Merge.ThreeWay {alice = names.alice, bob = names.bob, lca = fromMaybe mempty names.lca} - libdeps3 <- Cli.runTransaction (loadLibdeps branches) - - let blob0 = Merge.makeMergeblob0 nametrees3 libdeps3 + respondRegion (Output.Literal "Loading definitions...") -- Hydrate hydratedDefns :: @@ -270,7 +277,7 @@ doMerge info = do in bimap f g <$> blob0.defns ) - respondRegion (Output.Literal "Computing diff between branches...") + respondRegion (Output.Literal "Computing diffs...") blob1 <- Merge.makeMergeblob1 blob0 names3 hydratedDefns & onLeft \case diff --git a/unison-merge/src/Unison/Merge/Diff.hs b/unison-merge/src/Unison/Merge/Diff.hs index b4d6730d85..0b6e4c8332 100644 --- a/unison-merge/src/Unison/Merge/Diff.hs +++ b/unison-merge/src/Unison/Merge/Diff.hs @@ -120,11 +120,8 @@ humanizeDiffs :: TwoWay (DefnsF2 (Map Name) Updated Referent TypeReference) -> TwoWay (DefnsF2 (Map Name) HumanDiffOp Referent TypeReference) humanizeDiffs names3 diffs propagatedUpdates = - zipWithF3 - nameRelations - diffs - propagatedUpdates - \relation diffOps propagatedUpdates -> Defns.zipDefnsWith4 computeHumanDiffOp computeHumanDiffOp lcaRelation relation diffOps propagatedUpdates + zipWithF3 nameRelations diffs propagatedUpdates \relation diffOps propagatedUpdates -> + Defns.zipDefnsWith4 computeHumanDiffOp computeHumanDiffOp lcaRelation relation diffOps propagatedUpdates where zipWithF3 :: (Zip.Zip f) => f a -> f b -> f c -> (a -> b -> c -> d) -> f d zipWithF3 a b c f = Zip.zipWith (\(x, y) z -> f x y z) (Zip.zip a b) c @@ -148,7 +145,7 @@ humanizeDiffs names3 diffs propagatedUpdates = go :: These (DiffOp (Synhashed ref)) (Updated ref) -> (HumanDiffOp ref) go = \case This diff -> humanizeDiffOp (Synhashed.value <$> diff) - That updated -> (HumanDiffOp'PropagatedUpdate updated) + That updated -> HumanDiffOp'PropagatedUpdate updated These diff updated -> error (reportBug "E488729" ("The impossible happened, an update in merge was detected as both a propagated AND core update " ++ show diff ++ " and " ++ show updated)) humanizeDiffOp :: DiffOp ref -> HumanDiffOp ref From f0dec756852f701cd9e7636afef489b3eef6f1e6 Mon Sep 17 00:00:00 2001 From: Mitchell Dalvi Rosen Date: Wed, 4 Dec 2024 10:19:02 -0500 Subject: [PATCH 13/44] re-run transcripts --- unison-src/transcripts/idempotent/fix-5326.md | 4 +- unison-src/transcripts/merge.output.md | 132 +++++++++++++----- 2 files changed, 102 insertions(+), 34 deletions(-) diff --git a/unison-src/transcripts/idempotent/fix-5326.md b/unison-src/transcripts/idempotent/fix-5326.md index 267648cb4c..5d06bcbcf9 100644 --- a/unison-src/transcripts/idempotent/fix-5326.md +++ b/unison-src/transcripts/idempotent/fix-5326.md @@ -193,7 +193,9 @@ scratch/main> merge /foo Loading branches... - Computing diff between branches... + Loading definitions... + + Computing diffs... Loading dependents of changes... diff --git a/unison-src/transcripts/merge.output.md b/unison-src/transcripts/merge.output.md index 288ec046e2..9975ca6df9 100644 --- a/unison-src/transcripts/merge.output.md +++ b/unison-src/transcripts/merge.output.md @@ -68,7 +68,9 @@ scratch/alice> merge /bob Loading branches... - Computing diff between branches... + Loading definitions... + + Computing diffs... Loading dependents of changes... @@ -137,7 +139,9 @@ scratch/alice> merge /bob Loading branches... - Computing diff between branches... + Loading definitions... + + Computing diffs... Loading dependents of changes... @@ -220,7 +224,9 @@ scratch/alice> merge /bob Loading branches... - Computing diff between branches... + Loading definitions... + + Computing diffs... Loading dependents of changes... @@ -325,7 +331,9 @@ scratch/alice> merge /bob Loading branches... - Computing diff between branches... + Loading definitions... + + Computing diffs... Loading dependents of changes... @@ -439,7 +447,9 @@ scratch/alice> merge /bob Loading branches... - Computing diff between branches... + Loading definitions... + + Computing diffs... Loading dependents of changes... @@ -524,7 +534,9 @@ scratch/alice> merge /bob Loading branches... - Computing diff between branches... + Loading definitions... + + Computing diffs... Loading dependents of changes... @@ -603,7 +615,9 @@ scratch/alice> merge bob Loading branches... - Computing diff between branches... + Loading definitions... + + Computing diffs... Loading dependents of changes... @@ -843,7 +857,9 @@ scratch/alice> merge /bob Loading branches... - Computing diff between branches... + Loading definitions... + + Computing diffs... Loading dependents of changes... @@ -934,7 +950,9 @@ scratch/alice> merge /bob Loading branches... - Computing diff between branches... + Loading definitions... + + Computing diffs... Loading dependents of changes... @@ -1036,7 +1054,9 @@ scratch/alice> merge /bob Loading branches... - Computing diff between branches... + Loading definitions... + + Computing diffs... Loading dependents of changes... @@ -1141,7 +1161,9 @@ scratch/alice> merge /bob Loading branches... - Computing diff between branches... + Loading definitions... + + Computing diffs... Loading dependents of changes... @@ -1224,7 +1246,9 @@ scratch/alice> merge /bob Loading branches... - Computing diff between branches... + Loading definitions... + + Computing diffs... Loading dependents of changes... @@ -1307,7 +1331,9 @@ scratch/alice> merge bob Loading branches... - Computing diff between branches... + Loading definitions... + + Computing diffs... Loading dependents of changes... @@ -1386,7 +1412,9 @@ scratch/alice> merge bob Loading branches... - Computing diff between branches... + Loading definitions... + + Computing diffs... Loading dependents of changes... @@ -1481,7 +1509,9 @@ scratch/alice> merge bob Loading branches... - Computing diff between branches... + Loading definitions... + + Computing diffs... Loading dependents of changes... @@ -1600,7 +1630,9 @@ scratch/alice> merge bob Loading branches... - Computing diff between branches... + Loading definitions... + + Computing diffs... Loading dependents of changes... @@ -1692,7 +1724,9 @@ scratch/alice> merge bob Loading branches... - Computing diff between branches... + Loading definitions... + + Computing diffs... Loading dependents of changes... @@ -1794,7 +1828,9 @@ scratch/alice> merge /bob Loading branches... - Computing diff between branches... + Loading definitions... + + Computing diffs... Loading dependents of changes... @@ -1967,7 +2003,9 @@ scratch/alice> merge /bob Loading branches... - Computing diff between branches... + Loading definitions... + + Computing diffs... Sorry, I wasn't able to perform the merge: @@ -2033,7 +2071,9 @@ scratch/alice> merge /bob Loading branches... - Computing diff between branches... + Loading definitions... + + Computing diffs... Sorry, I wasn't able to perform the merge: @@ -2098,7 +2138,9 @@ scratch/alice> merge /bob Loading branches... - Computing diff between branches... + Loading definitions... + + Computing diffs... Sorry, I wasn't able to perform the merge: @@ -2164,7 +2206,9 @@ scratch/alice> merge /bob Loading branches... - Computing diff between branches... + Loading definitions... + + Computing diffs... Sorry, I wasn't able to perform the merge: @@ -2231,7 +2275,9 @@ scratch/alice> merge /bob Loading branches... - Computing diff between branches... + Loading definitions... + + Computing diffs... On scratch/alice, the type A.inner.X is an alias of A. I'm not able to perform a merge when a type exists nested under an @@ -2288,7 +2334,9 @@ scratch/alice> merge bob Loading branches... - Computing diff between branches... + Loading definitions... + + Computing diffs... Sorry, I wasn't able to perform the merge, because I need all constructor names to be nested somewhere beneath the @@ -2494,7 +2542,9 @@ scratch/alice> merge /bob Loading branches... - Computing diff between branches... + Loading definitions... + + Computing diffs... Loading dependents of changes... @@ -2619,7 +2669,9 @@ scratch/alice> merge /bob Loading branches... - Computing diff between branches... + Loading definitions... + + Computing diffs... Loading dependents of changes... @@ -2728,7 +2780,9 @@ scratch/main> merge topic Loading branches... - Computing diff between branches... + Loading definitions... + + Computing diffs... Loading dependents of changes... @@ -2875,7 +2929,9 @@ scratch/alice> merge /bob Loading branches... - Computing diff between branches... + Loading definitions... + + Computing diffs... Loading dependents of changes... @@ -3047,7 +3103,9 @@ scratch/bob> merge /alice Loading branches... - Computing diff between branches... + Loading definitions... + + Computing diffs... Loading dependents of changes... @@ -3063,7 +3121,9 @@ scratch/carol> merge /bob Loading branches... - Computing diff between branches... + Loading definitions... + + Computing diffs... Loading dependents of changes... @@ -3217,7 +3277,9 @@ scratch/alice> merge /bob Loading branches... - Computing diff between branches... + Loading definitions... + + Computing diffs... Loading dependents of changes... @@ -3297,7 +3359,9 @@ scratch/alice> merge /bob Loading branches... - Computing diff between branches... + Loading definitions... + + Computing diffs... Loading dependents of changes... @@ -3496,7 +3560,9 @@ scratch/alice> merge /bob Loading branches... - Computing diff between branches... + Loading definitions... + + Computing diffs... Loading dependents of changes... From 0a7ef4fa3dda54dd0ecc53732b4d9271985db22d Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 17 Jan 2025 10:35:59 -0800 Subject: [PATCH 14/44] PR cleanup --- unison-cli/package.yaml | 1 - .../src/Unison/Codebase/Editor/Input.hs | 3 +- .../src/Unison/CommandLine/InputPatterns.hs | 6 +- unison-cli/src/Unison/Share/SyncV2.hs | 231 +++++++++--------- unison-cli/unison-cli.cabal | 1 - unison-share-api/src/Unison/SyncV2/Types.hs | 10 +- 6 files changed, 119 insertions(+), 133 deletions(-) diff --git a/unison-cli/package.yaml b/unison-cli/package.yaml index d3d48f2c8a..d81ba052f7 100644 --- a/unison-cli/package.yaml +++ b/unison-cli/package.yaml @@ -20,7 +20,6 @@ library: - condition: "!os(windows)" dependencies: unix dependencies: - - attoparsec - Diff - IntervalMap - ListLike diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index c496b5ba0d..e4015b64fe 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -128,7 +128,8 @@ data Input | PushRemoteBranchI PushRemoteBranchInput | SyncToFileI FilePath (ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName)) | SyncFromFileI FilePath UnresolvedProjectBranch - | SyncFromCodebaseI FilePath (ProjectAndBranch ProjectName ProjectBranchName) UnresolvedProjectBranch + | -- | Sync from a codebase project branch to this codebase's project branch + SyncFromCodebaseI FilePath (ProjectAndBranch ProjectName ProjectBranchName) UnresolvedProjectBranch | ResetI (BranchId2 {- namespace to reset it to -}) (Maybe UnresolvedProjectBranch {- ProjectBranch to reset -}) | -- | used in Welcome module to give directions to user -- diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 40a82c2241..0d0022da05 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -2205,11 +2205,13 @@ syncFromCodebase = args = [("codebase-location", Required, filePathArg), ("branch-to-sync", Required, projectAndBranchNamesArg suggestionsConfig), ("destination-branch", Optional, projectAndBranchNamesArg suggestionsConfig)], help = ( P.wrapColumn2 - [ (makeExample syncFromCodebase ["./codebase", "/feature", "/main"], "Sets the /feature branch to the contents of the codebase at ./codebase.") + [ ( makeExample syncFromCodebase ["./codebase", "srcProject/main", "destProject/main"], + "Imports srcProject/main from the specified codebase, then sets destProject/main to the imported branch." + ) ] ), parse = \case - [codebaseLocation, branchToSync, destinationBranch] -> Input.SyncFromCodebaseI <$> unsupportedStructuredArgument makeStandalone "a file name" codebaseLocation <*> handleBranchWithProject branchToSync <*> handleBranchWithOptionalProject destinationBranch + [codebaseLocation, srcBranch, destinationBranch] -> Input.SyncFromCodebaseI <$> unsupportedStructuredArgument makeStandalone "a file name" codebaseLocation <*> handleBranchWithProject srcBranch <*> handleBranchWithOptionalProject destinationBranch args -> wrongArgsLength "three arguments" args } where diff --git a/unison-cli/src/Unison/Share/SyncV2.hs b/unison-cli/src/Unison/Share/SyncV2.hs index bbce0d95e6..bcfccd85c3 100644 --- a/unison-cli/src/Unison/Share/SyncV2.hs +++ b/unison-cli/src/Unison/Share/SyncV2.hs @@ -16,11 +16,8 @@ import Control.Monad.Except import Control.Monad.Reader (ask) import Control.Monad.ST (ST, stToIO) import Control.Monad.State -import Data.Attoparsec.ByteString qualified as A -import Data.Attoparsec.ByteString.Char8 qualified as A8 import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as BL -import Data.Conduit.Attoparsec qualified as C import Data.Conduit.List qualified as C import Data.Conduit.Zlib qualified as C import Data.Graph qualified as Graph @@ -36,7 +33,6 @@ import U.Codebase.Sqlite.V2.HashHandle (v2HashHandle) import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Codebase qualified as Codebase -import Unison.Debug qualified as Debug import Unison.Hash32 (Hash32) import Unison.Prelude import Unison.Share.ExpectedHashMismatches (expectedCausalHashMismatches, expectedComponentHashMismatches) @@ -57,20 +53,76 @@ type Stream i o = ConduitT i o StreamM () type SyncErr = SyncError SyncV2.PullError +-- The base monad we use within the conduit pipeline. type StreamM = (ExceptT SyncErr (C.ResourceT IO)) +-- | The number of entities to process in a single transaction. +-- +-- SQLite transactions have some fixed overhead, so setting this too low can really slow things down, +-- but going too high here means we may be waiting on the network to get a full batch when we could be starting work. batchSize :: Int batchSize = 5000 ------------------------------------------------------------------------------------------------------------------------ --- Download entities +-- Main methods +------------------------------------------------------------------------------------------------------------------------ + +-- | Sync a given causal hash and its dependencies to a sync-file. +syncToFile :: + Codebase.Codebase IO v a -> + CausalHash -> + Maybe SyncV2.BranchRef -> + FilePath -> + IO (Either SyncErr ()) +syncToFile codebase rootHash mayBranchRef destFilePath = do + liftIO $ Codebase.withConnection codebase \conn -> do + C.runResourceT $ + withCodebaseEntityStream conn rootHash mayBranchRef \mayTotal stream -> do + withStreamProgressCallback (Just mayTotal) \countC -> runExceptT do + C.runConduit $ stream C..| countC C..| C.map (BL.toStrict . CBOR.serialise) C..| C.transPipe liftIO C.gzip C..| C.sinkFile destFilePath +syncFromFile :: + Bool -> + -- | Location of the sync-file + FilePath -> + Cli (Either (SyncError SyncV2.PullError) CausalHash) +syncFromFile shouldValidate syncFilePath = do + Cli.Env {codebase} <- ask + runExceptT do + mapExceptT liftIO $ Timing.time "File Sync" $ do + header <- mapExceptT C.runResourceT $ do + let stream = C.sourceFile syncFilePath C..| C.ungzip C..| decodeUnframedEntities + (header, rest) <- initializeStream stream + streamIntoCodebase shouldValidate codebase header rest + pure header + afterSyncChecks codebase (SyncV2.rootCausalHash header) + pure . hash32ToCausalHash $ SyncV2.rootCausalHash header + +syncFromCodebase :: + Bool -> + -- | The codebase to sync from. + Sqlite.Connection -> + (Codebase.Codebase IO v a) -> + -- | The hash to sync. + CausalHash -> + IO (Either (SyncError SyncV2.PullError) ()) +syncFromCodebase shouldValidate srcConn destCodebase causalHash = do + liftIO . C.runResourceT . runExceptT $ withCodebaseEntityStream srcConn causalHash Nothing \_total entityStream -> do + (header, rest) <- initializeStream entityStream + streamIntoCodebase shouldValidate destCodebase header rest + mapExceptT liftIO (afterSyncChecks destCodebase (causalHashToHash32 causalHash)) + +------------------------------------------------------------------------------------------------------------------------ +-- Helpers +------------------------------------------------------------------------------------------------------------------------ + +-- | Validate that the provided entities match their expected hashes, and if so, save them to the codebase. validateAndSave :: Bool -> (Codebase.Codebase IO v a) -> [(Hash32, TempEntity)] -> StreamM () validateAndSave shouldValidate codebase entities = do let validateEntities = runExceptT $ when shouldValidate (batchValidateEntities entities) - -- Validation is slow, run it in parallel with insertion, but don't commit the transaction until we're done - -- validation. + -- Validation is slow, so we run it in parallel with insertion (which can also be slow), + -- but we don't commit the transaction until we're done validation to avoid inserting invalid entities. ExceptT . liftIO $ IO.withAsync validateEntities \validationTask -> do Timing.time "Inserting entities" $ Codebase.runTransactionExceptT codebase do for_ entities \(hash, entity) -> do @@ -78,6 +130,25 @@ validateAndSave shouldValidate codebase entities = do lift (Sqlite.unsafeIO (IO.wait validationTask)) >>= \case Left err -> throwError err Right _ -> pure () + where + batchValidateEntities :: [(Hash32, TempEntity)] -> ExceptT SyncErr IO () + batchValidateEntities entities = do + mismatches <- fmap catMaybes $ liftIO $ IO.pooledForConcurrently entities \(hash, entity) -> do + IO.evaluate $ EV.validateTempEntity hash entity + for_ mismatches \case + err@(Share.EntityHashMismatch et (Share.HashMismatchForEntity {supplied, computed})) -> + let expectedMismatches = case et of + Share.TermComponentType -> expectedComponentHashMismatches + Share.DeclComponentType -> expectedComponentHashMismatches + Share.CausalType -> expectedCausalHashMismatches + _ -> mempty + in case Map.lookup supplied expectedMismatches of + Just expected + | expected == computed -> pure () + _ -> do + throwError . SyncError . SyncV2.PullError'DownloadEntities . SyncV2.DownloadEntitiesEntityValidationFailure $ err + err -> do + throwError . SyncError . SyncV2.PullError'DownloadEntities . SyncV2.DownloadEntitiesEntityValidationFailure $ err -- | Syncs a stream which could send entities in any order. syncUnsortedStream :: @@ -86,7 +157,6 @@ syncUnsortedStream :: Stream () SyncV2.EntityChunk -> StreamM () syncUnsortedStream shouldValidate codebase stream = do - Debug.debugLogM Debug.Temp $ "Syncing unsorted stream" allResults <- C.runConduit $ stream C..| C.sinkList allEntities <- ExceptT $ Timing.time "Unpacking chunks" $ liftIO $ Codebase.runTransactionExceptT codebase $ do unpackChunks allResults let sortedEntities = sortDependencyFirst allEntities @@ -99,13 +169,20 @@ syncSortedStream :: Stream () SyncV2.EntityChunk -> StreamM () syncSortedStream shouldValidate codebase stream = do - Debug.debugLogM Debug.Temp $ "Syncing sorted stream" let handler :: Stream [SyncV2.EntityChunk] o handler = C.mapM_C \chunkBatch -> do - entityBatch <- mapExceptT lift . ExceptT $ Codebase.runTransactionExceptT codebase do for chunkBatch unpackChunk - validateAndSave shouldValidate codebase (catMaybes entityBatch) + entityBatch <- mapExceptT lift . ExceptT $ Codebase.runTransactionExceptT codebase do unpackChunks chunkBatch + validateAndSave shouldValidate codebase entityBatch C.runConduit $ stream C..| C.chunksOf batchSize C..| handler +-- | Topologically sort entities based on their dependencies. +sortDependencyFirst :: [(Hash32, TempEntity)] -> [(Hash32, TempEntity)] +sortDependencyFirst entities = do + let adjList = entities <&> \(hash32, entity) -> ((hash32, entity), hash32, Set.toList $ Share.entityDependencies (tempEntityToEntity entity)) + (graph, vertexInfo, _vertexForKey) = Graph.graphFromEdges adjList + in Graph.reverseTopSort graph <&> \v -> (view _1 $ vertexInfo v) + +-- | Unpack a single entity chunk, returning the entity if it's not already in the codebase, Nothing otherwise. unpackChunk :: SyncV2.EntityChunk -> ExceptT SyncErr Sqlite.Transaction (Maybe (Hash32, TempEntity)) unpackChunk = \case SyncV2.EntityChunk {hash, entityCBOR = entityBytes} -> do @@ -126,25 +203,6 @@ unpackChunks xs = do for xs unpackChunk <&> catMaybes -batchValidateEntities :: [(Hash32, TempEntity)] -> ExceptT SyncErr IO () -batchValidateEntities entities = do - mismatches <- fmap catMaybes $ liftIO $ IO.pooledForConcurrently entities \(hash, entity) -> do - IO.evaluate $ EV.validateTempEntity hash entity - for_ mismatches \case - err@(Share.EntityHashMismatch et (Share.HashMismatchForEntity {supplied, computed})) -> - let expectedMismatches = case et of - Share.TermComponentType -> expectedComponentHashMismatches - Share.DeclComponentType -> expectedComponentHashMismatches - Share.CausalType -> expectedCausalHashMismatches - _ -> mempty - in case Map.lookup supplied expectedMismatches of - Just expected - | expected == computed -> pure () - _ -> do - throwError . SyncError . SyncV2.PullError'DownloadEntities . SyncV2.DownloadEntitiesEntityValidationFailure $ err - err -> do - throwError . SyncError . SyncV2.PullError'DownloadEntities . SyncV2.DownloadEntitiesEntityValidationFailure $ err - streamIntoCodebase :: Bool -> Codebase.Codebase IO v a -> SyncV2.StreamInitInfo -> Stream () SyncV2.EntityChunk -> StreamM () streamIntoCodebase shouldValidate codebase SyncV2.StreamInitInfo {version, entitySorting, numEntities = numEntities} stream = ExceptT do withStreamProgressCallback (fromIntegral <$> numEntities) \countC -> runExceptT do @@ -157,6 +215,7 @@ streamIntoCodebase shouldValidate codebase SyncV2.StreamInitInfo {version, entit SyncV2.DependenciesFirst -> syncSortedStream shouldValidate codebase stream' SyncV2.Unsorted -> syncUnsortedStream shouldValidate codebase stream' +-- | Verify that the hash we expected to import from the stream was successfully loaded into the codebase. afterSyncChecks :: Codebase.Codebase IO v a -> Hash32 -> ExceptT (SyncError SyncV2.PullError) IO () afterSyncChecks codebase hash = do lift (didCausalSuccessfullyImport codebase hash) >>= \case @@ -171,53 +230,15 @@ afterSyncChecks codebase hash = do let expectedHash = hash32ToCausalHash hash isJust <$> (Codebase.runTransaction codebase $ Q.loadCausalByCausalHash expectedHash) --- | Topologically sort entities based on their dependencies. -sortDependencyFirst :: [(Hash32, TempEntity)] -> [(Hash32, TempEntity)] -sortDependencyFirst entities = do - let adjList = entities <&> \(hash32, entity) -> ((hash32, entity), hash32, Set.toList $ Share.entityDependencies (tempEntityToEntity entity)) - (graph, vertexInfo, _vertexForKey) = Graph.graphFromEdges adjList - in Graph.reverseTopSort graph <&> \v -> (view _1 $ vertexInfo v) - -syncFromFile :: - Bool -> - -- | Location of the sync-file - FilePath -> - Cli (Either (SyncError SyncV2.PullError) CausalHash) -syncFromFile shouldValidate syncFilePath = do - Cli.Env {codebase} <- ask - runExceptT do - Debug.debugLogM Debug.Temp $ "Kicking off sync" - mapExceptT liftIO $ Timing.time "File Sync" $ do - header <- mapExceptT C.runResourceT $ do - let stream = C.sourceFile syncFilePath C..| C.ungzip C..| decodeUnframedEntities - (header, rest) <- initializeStream stream - streamIntoCodebase shouldValidate codebase header rest - pure header - afterSyncChecks codebase (SyncV2.rootCausalHash header) - pure . hash32ToCausalHash $ SyncV2.rootCausalHash header - -syncFromCodebase :: - Bool -> - -- | The codebase to sync from. - Sqlite.Connection -> - (Codebase.Codebase IO v a) -> - -- | The hash to sync. - CausalHash -> - IO (Either (SyncError SyncV2.PullError) ()) -syncFromCodebase shouldValidate srcConn destCodebase causalHash = do - liftIO . C.runResourceT . runExceptT $ withEntityStream srcConn causalHash Nothing \_total entityStream -> do - (header, rest) <- initializeStream entityStream - streamIntoCodebase shouldValidate destCodebase header rest - mapExceptT liftIO (afterSyncChecks destCodebase (causalHashToHash32 causalHash)) - -withEntityStream :: +-- | Load and stream entities for a given causal hash from a codebase. +withCodebaseEntityStream :: (MonadIO m) => Sqlite.Connection -> CausalHash -> Maybe SyncV2.BranchRef -> (Int -> Stream () SyncV2.DownloadEntitiesChunk -> m r) -> m r -withEntityStream conn rootHash mayBranchRef callback = do +withCodebaseEntityStream conn rootHash mayBranchRef callback = do entities <- liftIO $ withEntityLoadingCallback $ \counter -> do Sqlite.runTransaction conn (depsForCausal rootHash counter) liftIO $ Text.hPutStrLn IO.stderr $ "Finished loading entities, writing sync-file." @@ -244,54 +265,24 @@ withEntityStream conn rootHash mayBranchRef callback = do & (initialChunk :) let stream = C.yieldMany contents callback totalEntities stream - -syncToFile :: - Codebase.Codebase IO v a -> - CausalHash -> - Maybe SyncV2.BranchRef -> - FilePath -> - IO (Either SyncErr ()) -syncToFile codebase rootHash mayBranchRef destFilePath = do - liftIO $ Codebase.withConnection codebase \conn -> do - C.runResourceT $ - withEntityStream conn rootHash mayBranchRef \mayTotal stream -> do - withStreamProgressCallback (Just mayTotal) \countC -> runExceptT do - C.runConduit $ stream C..| countC C..| C.map (BL.toStrict . CBOR.serialise) C..| C.transPipe liftIO C.gzip C..| C.sinkFile destFilePath - --- | Collect all dependencies of a given causal hash. -depsForCausal :: CausalHash -> (Int -> IO ()) -> Sqlite.Transaction (Map Hash32 (Sync.Entity Text Hash32 Hash32)) -depsForCausal causalHash counter = do - flip execStateT mempty $ expandEntities (causalHashToHash32 causalHash) where - expandEntities :: Hash32 -> ((StateT (Map Hash32 (Sync.Entity Text Hash32 Hash32)) Sqlite.Transaction)) () - expandEntities hash32 = do - gets (Map.member hash32) >>= \case - True -> pure () - False -> do - entity <- lift $ Sync.expectEntity hash32 - modify (Map.insert hash32 entity) - lift . Sqlite.unsafeIO $ counter 1 - traverseOf_ Sync.entityHashes_ expandEntities entity - --- | Gets the framed chunks from a NetString framed stream. -_unNetString :: ConduitT ByteString ByteString StreamM () -_unNetString = do - bs <- C.sinkParser $ do - len <- A8.decimal - _ <- A8.char ':' - bs <- A.take len - _ <- A8.char ',' - pure bs - C.yield bs - -_decodeFramedEntity :: ByteString -> StreamM SyncV2.DownloadEntitiesChunk -_decodeFramedEntity bs = do - case CBOR.deserialiseOrFail (BL.fromStrict bs) of - Left err -> throwError . SyncError . SyncV2.PullError'Sync $ SyncV2.SyncErrorDeserializationFailure err - Right chunk -> pure chunk + -- Collect all dependencies of a given causal hash. + depsForCausal :: CausalHash -> (Int -> IO ()) -> Sqlite.Transaction (Map Hash32 (Sync.Entity Text Hash32 Hash32)) + depsForCausal causalHash counter = do + flip execStateT mempty $ expandEntities (causalHashToHash32 causalHash) + where + expandEntities :: Hash32 -> ((StateT (Map Hash32 (Sync.Entity Text Hash32 Hash32)) Sqlite.Transaction)) () + expandEntities hash32 = do + gets (Map.member hash32) >>= \case + True -> pure () + False -> do + entity <- lift $ Sync.expectEntity hash32 + modify (Map.insert hash32 entity) + lift . Sqlite.unsafeIO $ counter 1 + traverseOf_ Sync.entityHashes_ expandEntities entity -- Expects a stream of tightly-packed CBOR entities without any framing/separators. -decodeUnframedEntities :: ConduitT ByteString SyncV2.DownloadEntitiesChunk StreamM () +decodeUnframedEntities :: Stream ByteString SyncV2.DownloadEntitiesChunk decodeUnframedEntities = C.transPipe (mapExceptT (lift . stToIO)) $ do C.await >>= \case Nothing -> pure () @@ -338,11 +329,10 @@ decodeUnframedEntities = C.transPipe (mapExceptT (lift . stToIO)) $ do k <- newDecoder loop rem k --- | Peel the header off the stream and parse the remaining entity chunks. +-- | Peel the header off the stream and parse the remaining entity chunks into EntityChunks initializeStream :: Stream () SyncV2.DownloadEntitiesChunk -> StreamM (SyncV2.StreamInitInfo, Stream () SyncV2.EntityChunk) initializeStream stream = do (streamRemainder, init) <- stream C.$$+ C.headC - Debug.debugM Debug.Temp "Got initial chunk: " init case init of Nothing -> throwError . SyncError . SyncV2.PullError'Sync $ SyncV2.SyncErrorMissingInitialChunk Just chunk -> do @@ -351,7 +341,6 @@ initializeStream stream = do let entityStream = C.unsealConduitT streamRemainder C..| C.mapM parseEntity pure $ (info, entityStream) SyncV2.EntityC _ -> do - Debug.debugLogM Debug.Temp $ "Got unexpected entity chunk" throwError . SyncError . SyncV2.PullError'Sync $ SyncV2.SyncErrorMissingInitialChunk SyncV2.ErrorC (SyncV2.ErrorChunk err) -> throwError . SyncError . SyncV2.PullError'DownloadEntities $ err where @@ -361,6 +350,10 @@ initializeStream stream = do SyncV2.ErrorC (SyncV2.ErrorChunk err) -> throwError . SyncError $ SyncV2.PullError'DownloadEntities err SyncV2.InitialC {} -> throwError . SyncError $ SyncV2.PullError'Sync SyncV2.SyncErrorMisplacedInitialChunk +------------------------------------------------------------------------------------------------------------------------ +-- Progress Tracking +------------------------------------------------------------------------------------------------------------------------ + -- Provide the given action a callback that display to the terminal. withStreamProgressCallback :: (MonadIO m, MonadUnliftIO n) => Maybe Int -> (ConduitT i i m () -> n a) -> n a withStreamProgressCallback total action = do diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index f128d6ff8d..e1f51a7633 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -200,7 +200,6 @@ library , aeson-pretty , ansi-terminal , async - , attoparsec , base , bytestring , cmark diff --git a/unison-share-api/src/Unison/SyncV2/Types.hs b/unison-share-api/src/Unison/SyncV2/Types.hs index 2f4432ee74..80272de8ab 100644 --- a/unison-share-api/src/Unison/SyncV2/Types.hs +++ b/unison-share-api/src/Unison/SyncV2/Types.hs @@ -32,7 +32,6 @@ import Data.Word (Word16, Word64) import U.Codebase.HashTags (CausalHash) import U.Codebase.Sqlite.TempEntity (TempEntity) import Unison.Core.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName) -import Unison.Debug qualified as Debug import Unison.Hash32 (Hash32) import Unison.Prelude (From (..)) import Unison.Server.Orphans () @@ -186,7 +185,7 @@ optionalDecodeMapKey k m = Nothing -> pure Nothing Just bs -> Just <$> decodeUnknownCBORBytes bs --- | Serialised as a map to allow for future expansion +-- | Serialised as a map to be future compatible, allowing for future expansion. instance Serialise StreamInitInfo where encode (StreamInitInfo {version, entitySorting, numEntities, rootCausalHash, rootBranchRef}) = CBOR.encode @@ -199,18 +198,11 @@ instance Serialise StreamInitInfo where <> maybe [] (\br -> [("br", serialiseUnknownCBORBytes br)]) rootBranchRef ) decode = do - Debug.debugLogM Debug.Temp "Decoding StreamInitInfo" - Debug.debugLogM Debug.Temp "Decoding Map" m <- CBOR.decode - Debug.debugLogM Debug.Temp "Decoding Version" version <- decodeMapKey "v" m - Debug.debugLogM Debug.Temp "Decoding Entity Sorting" entitySorting <- decodeMapKey "es" m - Debug.debugLogM Debug.Temp "Decoding Number of Entities" numEntities <- (optionalDecodeMapKey "ne" m) - Debug.debugLogM Debug.Temp "Decoding Root Causal Hash" rootCausalHash <- decodeMapKey "rc" m - Debug.debugLogM Debug.Temp "Decoding Branch Ref" rootBranchRef <- optionalDecodeMapKey "br" m pure StreamInitInfo {version, entitySorting, numEntities, rootCausalHash, rootBranchRef} From 1df99747c0c9997603755b07803b8ec81cea4ce1 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 14 Jan 2025 15:43:02 -0800 Subject: [PATCH 15/44] SyncV2 with Share server --- .../U/Codebase/Sqlite/Queries.hs | 92 +++++++++++------- .../sql/001-temp-entity-tables.sql | 3 +- lib/unison-sqlite/package.yaml | 1 + .../src/Unison/Sqlite/Connection.hs | 62 +++++++++--- .../src/Unison/Sqlite/Connection/Internal.hs | 8 +- lib/unison-sqlite/unison-sqlite.cabal | 3 +- unison-cli/src/Unison/Cli/DownloadUtils.hs | 46 ++++++--- .../Codebase/Editor/HandleInput/InstallLib.hs | 2 +- .../Editor/HandleInput/ProjectClone.hs | 4 +- .../Editor/HandleInput/ProjectCreate.hs | 4 +- .../Codebase/Editor/HandleInput/Pull.hs | 1 + .../Codebase/Editor/HandleInput/SyncV2.hs | 30 ++++++ unison-cli/src/Unison/Share/Sync/Util.hs | 42 ++++++++ unison-cli/src/Unison/Share/SyncV2.hs | 95 +++++++++++++++++++ unison-cli/unison-cli.cabal | 1 + unison-share-api/src/Unison/SyncV2/API.hs | 29 ++++++ unison-share-api/unison-share-api.cabal | 1 + 17 files changed, 356 insertions(+), 68 deletions(-) create mode 100644 unison-cli/src/Unison/Share/Sync/Util.hs create mode 100644 unison-share-api/src/Unison/SyncV2/API.hs diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 033efb8655..936dd91cdf 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -228,6 +228,7 @@ module U.Codebase.Sqlite.Queries expectEntity, syncToTempEntity, insertTempEntity, + insertTempEntityV2, saveTempEntityInMain, expectTempEntity, deleteTempEntity, @@ -315,6 +316,7 @@ import Data.Map.NonEmpty qualified as NEMap import Data.Maybe qualified as Maybe import Data.Sequence qualified as Seq import Data.Set qualified as Set +import Data.Set.NonEmpty (NESet) import Data.Text qualified as Text import Data.Text.Encoding qualified as Text import Data.Text.Lazy qualified as Text.Lazy @@ -532,23 +534,18 @@ countWatches = queryOneCol [sql| SELECT COUNT(*) FROM watch |] saveHash :: Hash32 -> Transaction HashId saveHash hash = do - execute - [sql| - INSERT INTO hash (base32) VALUES (:hash) - ON CONFLICT DO NOTHING - |] - expectHashId hash + loadHashId hash >>= \case + Just h -> pure h + Nothing -> do + queryOneCol + [sql| + INSERT INTO hash (base32) VALUES (:hash) + RETURNING id + |] saveHashes :: Traversable f => f Hash32 -> Transaction (f HashId) saveHashes hashes = do - for_ hashes \hash -> - execute - [sql| - INSERT INTO hash (base32) - VALUES (:hash) - ON CONFLICT DO NOTHING - |] - traverse expectHashId hashes + for hashes saveHash saveHashHash :: Hash -> Transaction HashId saveHashHash = saveHash . Hash32.fromHash @@ -623,13 +620,15 @@ expectBranchHashForCausalHash ch = do saveText :: Text -> Transaction TextId saveText t = do - execute - [sql| - INSERT INTO text (text) - VALUES (:t) - ON CONFLICT DO NOTHING - |] - expectTextId t + loadTextId t >>= \case + Just h -> pure h + Nothing -> do + queryOneCol + [sql| + INSERT INTO text (text) + VALUES (:t) + RETURNING id + |] saveTexts :: Traversable f => f Text -> Transaction (f TextId) saveTexts = @@ -686,7 +685,7 @@ saveObject :: ObjectType -> ByteString -> Transaction ObjectId -saveObject hh h t blob = do +saveObject _hh h t blob = do execute [sql| INSERT INTO object (primary_hash_id, type_id, bytes) @@ -697,9 +696,9 @@ saveObject hh h t blob = do saveHashObject h oId 2 -- todo: remove this from here, and add it to other relevant places once there are v1 and v2 hashes rowsModified >>= \case 0 -> pure () - _ -> do - hash <- expectHash32 h - tryMoveTempEntityDependents hh hash + _ -> pure () + -- hash <- expectHash32 h + -- tryMoveTempEntityDependents hh hash pure oId expectObject :: SqliteExceptionReason e => ObjectId -> (ByteString -> Either e a) -> Transaction a @@ -957,7 +956,7 @@ saveCausal :: BranchHashId -> [CausalHashId] -> Transaction () -saveCausal hh self value parents = do +saveCausal _hh self value parents = do execute [sql| INSERT INTO causal (self_hash_id, value_hash_id) @@ -973,15 +972,15 @@ saveCausal hh self value parents = do INSERT INTO causal_parent (causal_id, parent_id) VALUES (:self, :parent) |] - flushCausalDependents hh self + -- flushCausalDependents hh self -flushCausalDependents :: +_flushCausalDependents :: HashHandle -> CausalHashId -> Transaction () -flushCausalDependents hh chId = do +_flushCausalDependents hh chId = do hash <- expectHash32 (unCausalHashId chId) - tryMoveTempEntityDependents hh hash + _tryMoveTempEntityDependents hh hash -- | `tryMoveTempEntityDependents #foo` does this: -- 0. Precondition: We just inserted object #foo. @@ -989,11 +988,11 @@ flushCausalDependents hh chId = do -- 2. Delete #foo as dependency from temp_entity_missing_dependency. e.g. (#bar, #foo), (#baz, #foo) -- 3. For each like #bar and #baz with no more rows in temp_entity_missing_dependency, -- insert_entity them. -tryMoveTempEntityDependents :: +_tryMoveTempEntityDependents :: HashHandle -> Hash32 -> Transaction () -tryMoveTempEntityDependents hh dependency = do +_tryMoveTempEntityDependents hh dependency = do dependents <- queryListCol [sql| @@ -2993,6 +2992,35 @@ insertTempEntity entityHash entity missingDependencies = do entityType = Entity.entityType entity +-- | Insert a new `temp_entity` row, and its associated 1+ `temp_entity_missing_dependency` rows. +-- +-- Preconditions: +-- 1. The entity does not already exist in "main" storage (`object` / `causal`) +-- 2. The entity does not already exist in `temp_entity`. +insertTempEntityV2 :: Hash32 -> TempEntity -> NESet Hash32 -> Transaction () +insertTempEntityV2 entityHash entity missingDependencies = do + execute + [sql| + INSERT INTO temp_entity (hash, blob, type_id) + VALUES (:entityHash, :entityBlob, :entityType) + ON CONFLICT DO NOTHING + |] + + for_ missingDependencies \depHash -> + execute + [sql| + INSERT INTO temp_entity_missing_dependency (dependent, dependency) + VALUES (:entityHash, :depHash) + |] + where + entityBlob :: ByteString + entityBlob = + runPutS (Serialization.putTempEntity entity) + + entityType :: TempEntityType + entityType = + Entity.entityType entity + -- | Delete a row from the `temp_entity` table, if it exists. deleteTempEntity :: Hash32 -> Transaction () deleteTempEntity hash = diff --git a/codebase2/codebase-sqlite/sql/001-temp-entity-tables.sql b/codebase2/codebase-sqlite/sql/001-temp-entity-tables.sql index 0ae13812b1..6651d4a6fe 100644 --- a/codebase2/codebase-sqlite/sql/001-temp-entity-tables.sql +++ b/codebase2/codebase-sqlite/sql/001-temp-entity-tables.sql @@ -56,7 +56,8 @@ create table if not exists temp_entity ( create table if not exists temp_entity_missing_dependency ( dependent text not null references temp_entity(hash), dependency text not null, - dependencyJwt text not null, + -- TODO: this is just for testing + dependencyJwt text null, unique (dependent, dependency) ); create index if not exists temp_entity_missing_dependency_ix_dependent on temp_entity_missing_dependency (dependent); diff --git a/lib/unison-sqlite/package.yaml b/lib/unison-sqlite/package.yaml index 84d0201eab..b90bd2aa57 100644 --- a/lib/unison-sqlite/package.yaml +++ b/lib/unison-sqlite/package.yaml @@ -9,6 +9,7 @@ library: dependencies: - base + - containers - direct-sqlite - megaparsec - pretty-simple diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs b/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs index 48167980db..726cac860e 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs @@ -58,6 +58,7 @@ module Unison.Sqlite.Connection ) where +import Data.Map qualified as Map import Database.SQLite.Simple qualified as Sqlite import Database.SQLite.Simple.FromField qualified as Sqlite import Database.SQLite3 qualified as Direct.Sqlite @@ -71,7 +72,10 @@ import Unison.Sqlite.Connection.Internal (Connection (..)) import Unison.Sqlite.Exception import Unison.Sqlite.Sql (Sql (..)) import Unison.Sqlite.Sql qualified as Sql +import UnliftIO (atomically) import UnliftIO.Exception +import UnliftIO.STM (readTVar) +import UnliftIO.STM qualified as STM -- | Perform an action with a connection to a SQLite database. -- @@ -103,19 +107,47 @@ openConnection name file = do Just "" -> file _ -> "file:" <> file <> "?mode=ro" conn0 <- Sqlite.open sqliteURI `catch` rethrowAsSqliteConnectException name file - let conn = Connection {conn = conn0, file, name} + statementCache <- STM.newTVarIO Map.empty + let conn = Connection {conn = conn0, file, name, statementCache} execute conn [Sql.sql| PRAGMA foreign_keys = ON |] execute conn [Sql.sql| PRAGMA busy_timeout = 60000 |] + execute conn [Sql.sql| PRAGMA synchronous = normal |] + execute conn [Sql.sql| PRAGMA journal_size_limit = 6144000 |] + execute conn [Sql.sql| PRAGMA cache_size = -64000 |] + execute conn [Sql.sql| PRAGMA temp_store = 2 |] + pure conn -- Close a connection opened with 'openConnection'. closeConnection :: Connection -> IO () -closeConnection (Connection _ _ conn) = +closeConnection conn@(Connection {conn = conn0}) = do -- FIXME if this throws an exception, it won't be under `SomeSqliteException` -- Possible fixes: -- 1. Add close exception to the hierarchy, e.g. `SqliteCloseException` -- 2. Always ignore exceptions thrown by `close` (Mitchell prefers this one) - Sqlite.close conn + closeAllStatements conn + Sqlite.close conn0 + +withStatement :: Connection -> Text -> (Sqlite.Statement -> IO a) -> IO a +withStatement conn sql action = do + bracket (prepareStatement conn sql) Sqlite.reset action + where + prepareStatement :: Connection -> Text -> IO Sqlite.Statement + prepareStatement Connection {conn, statementCache} sql = do + cached <- atomically $ do + cache <- STM.readTVar statementCache + pure $ Map.lookup sql cache + case cached of + Just stmt -> pure stmt + Nothing -> do + stmt <- Sqlite.openStatement conn (coerce @Text @Sqlite.Query sql) + atomically $ STM.modifyTVar statementCache (Map.insert sql stmt) + pure stmt + +closeAllStatements :: Connection -> IO () +closeAllStatements Connection {statementCache} = do + cache <- atomically $ readTVar statementCache + for_ cache Sqlite.closeStatement -- An internal type, for making prettier debug logs @@ -152,7 +184,7 @@ logQuery (Sql sql params) result = -- Without results execute :: (HasCallStack) => Connection -> Sql -> IO () -execute conn@(Connection _ _ conn0) sql@(Sql s params) = do +execute conn sql@(Sql s params) = do logQuery sql Nothing doExecute `catch` \(exception :: Sqlite.SQLError) -> throwSqliteQueryException @@ -163,16 +195,16 @@ execute conn@(Connection _ _ conn0) sql@(Sql s params) = do } where doExecute :: IO () - doExecute = - Sqlite.withStatement conn0 (coerce s) \(Sqlite.Statement statement) -> do - bindParameters statement params - void (Direct.Sqlite.step statement) + doExecute = do + withStatement conn s \statement -> do + bindParameters (coerce statement) params + void (Direct.Sqlite.step $ coerce statement) -- | Execute one or more semicolon-delimited statements. -- -- This function does not support parameters, and is mostly useful for executing DDL and migrations. executeStatements :: (HasCallStack) => Connection -> Text -> IO () -executeStatements conn@(Connection _ _ (Sqlite.Connection database _tempNameCounter)) sql = do +executeStatements conn@(Connection {conn = Sqlite.Connection database _tempNameCounter}) sql = do logQuery (Sql sql []) Nothing Direct.Sqlite.exec database sql `catch` \(exception :: Sqlite.SQLError) -> throwSqliteQueryException @@ -185,7 +217,7 @@ executeStatements conn@(Connection _ _ (Sqlite.Connection database _tempNameCoun -- With results, without checks queryStreamRow :: (HasCallStack, Sqlite.FromRow a) => Connection -> Sql -> (IO (Maybe a) -> IO r) -> IO r -queryStreamRow conn@(Connection _ _ conn0) sql@(Sql s params) callback = +queryStreamRow conn sql@(Sql s params) callback = run `catch` \(exception :: Sqlite.SQLError) -> throwSqliteQueryException SqliteQueryExceptionInfo @@ -194,8 +226,8 @@ queryStreamRow conn@(Connection _ _ conn0) sql@(Sql s params) callback = sql } where - run = - bracket (Sqlite.openStatement conn0 (coerce s)) Sqlite.closeStatement \statement -> do + run = do + withStatement conn s \statement -> do Sqlite.bind statement params callback (Sqlite.nextRow statement) @@ -213,7 +245,7 @@ queryStreamCol = queryStreamRow queryListRow :: forall a. (Sqlite.FromRow a, HasCallStack) => Connection -> Sql -> IO [a] -queryListRow conn@(Connection _ _ conn0) sql@(Sql s params) = do +queryListRow conn sql@(Sql s params) = do result <- doQuery `catch` \(exception :: Sqlite.SQLError) -> @@ -228,7 +260,7 @@ queryListRow conn@(Connection _ _ conn0) sql@(Sql s params) = do where doQuery :: IO [a] doQuery = - Sqlite.withStatement conn0 (coerce s) \statement -> do + withStatement conn (coerce s) \statement -> do bindParameters (coerce statement) params let loop :: [a] -> IO [a] loop rows = @@ -347,7 +379,7 @@ queryOneColCheck conn s check = -- Rows modified rowsModified :: Connection -> IO Int -rowsModified (Connection _ _ conn) = +rowsModified (Connection {conn}) = Sqlite.changes conn -- Vacuum diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Connection/Internal.hs b/lib/unison-sqlite/src/Unison/Sqlite/Connection/Internal.hs index 5f80151f94..579c37cfb9 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Connection/Internal.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Connection/Internal.hs @@ -3,15 +3,19 @@ module Unison.Sqlite.Connection.Internal ) where +import Data.Map (Map) +import Data.Text (Text) import Database.SQLite.Simple qualified as Sqlite +import UnliftIO.STM (TVar) -- | A /non-thread safe/ connection to a SQLite database. data Connection = Connection { name :: String, file :: FilePath, - conn :: Sqlite.Connection + conn :: Sqlite.Connection, + statementCache :: TVar (Map Text Sqlite.Statement) } instance Show Connection where - show (Connection name file _conn) = + show (Connection name file _conn _statementCache) = "Connection { name = " ++ show name ++ ", file = " ++ show file ++ " }" diff --git a/lib/unison-sqlite/unison-sqlite.cabal b/lib/unison-sqlite/unison-sqlite.cabal index 28ea0f7c4f..329a05c5d8 100644 --- a/lib/unison-sqlite/unison-sqlite.cabal +++ b/lib/unison-sqlite/unison-sqlite.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0. +-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack @@ -64,6 +64,7 @@ library ghc-options: -Wall build-depends: base + , containers , direct-sqlite , megaparsec , pretty-simple diff --git a/unison-cli/src/Unison/Cli/DownloadUtils.hs b/unison-cli/src/Unison/Cli/DownloadUtils.hs index 343ebfeeb5..fb53a84176 100644 --- a/unison-cli/src/Unison/Cli/DownloadUtils.hs +++ b/unison-cli/src/Unison/Cli/DownloadUtils.hs @@ -4,12 +4,14 @@ module Unison.Cli.DownloadUtils ( downloadProjectBranchFromShare, downloadLooseCodeFromShare, + SyncVersion (..), ) where import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TVar (modifyTVar', newTVarIO, readTVar, readTVarIO) import Data.List.NonEmpty (pattern (:|)) +import Data.Set qualified as Set import System.Console.Regions qualified as Console.Regions import U.Codebase.HashTags (CausalHash) import U.Codebase.Sqlite.Queries qualified as Queries @@ -28,20 +30,24 @@ import Unison.Share.API.Hash qualified as Share import Unison.Share.Codeserver qualified as Codeserver import Unison.Share.Sync qualified as Share import Unison.Share.Sync.Types qualified as Share +import Unison.Share.SyncV2 qualified as SyncV2 import Unison.Share.Types (codeserverBaseURL) import Unison.Sync.Common qualified as Sync.Common import Unison.Sync.Types qualified as Share +import Unison.SyncV2.Types qualified as SyncV2 + +data SyncVersion = SyncV1 | SyncV2 -- | Download a project/branch from Share. downloadProjectBranchFromShare :: (HasCallStack) => + SyncVersion -> Share.IncludeSquashedHead -> Share.RemoteProjectBranch -> Cli (Either Output.ShareError CausalHash) -downloadProjectBranchFromShare useSquashed branch = +downloadProjectBranchFromShare syncVersion useSquashed branch = Cli.labelE \done -> do let remoteProjectBranchName = branch.branchName - let repoInfo = Share.RepoInfo (into @Text (ProjectAndBranch branch.projectName remoteProjectBranchName)) causalHashJwt <- case (useSquashed, branch.squashedBranchHead) of (Share.IncludeSquashedHead, Nothing) -> done Output.ShareExpectedSquashedHead @@ -49,16 +55,32 @@ downloadProjectBranchFromShare useSquashed branch = (Share.NoSquashedHead, _) -> pure branch.branchHead exists <- Cli.runTransaction (Queries.causalExistsByHash32 (Share.hashJWTHash causalHashJwt)) when (not exists) do - (result, numDownloaded) <- - Cli.with withEntitiesDownloadedProgressCallback \(downloadedCallback, getNumDownloaded) -> do - result <- Share.downloadEntities Share.hardCodedBaseUrl repoInfo causalHashJwt downloadedCallback - numDownloaded <- liftIO getNumDownloaded - pure (result, numDownloaded) - result & onLeft \err0 -> do - done case err0 of - Share.SyncError err -> Output.ShareErrorDownloadEntities err - Share.TransportError err -> Output.ShareErrorTransport err - Cli.respond (Output.DownloadedEntities numDownloaded) + case syncVersion of + SyncV1 -> do + let repoInfo = Share.RepoInfo (into @Text (ProjectAndBranch branch.projectName remoteProjectBranchName)) + Cli.with withEntitiesDownloadedProgressCallback \(downloadedCallback, getNumDownloaded) -> do + result <- Share.downloadEntities Share.hardCodedBaseUrl repoInfo causalHashJwt downloadedCallback + numDownloaded <- liftIO getNumDownloaded + result & onLeft \err0 -> do + done case err0 of + Share.SyncError err -> Output.ShareErrorDownloadEntities err + Share.TransportError err -> Output.ShareErrorTransport err + Cli.respond (Output.DownloadedEntities numDownloaded) + SyncV2 -> do + -- Cli.with withEntitiesDownloadedProgressCallback \(downloadedCallback, getNumDownloaded) -> do + let branchRef = SyncV2.BranchRef (into @Text (ProjectAndBranch branch.projectName remoteProjectBranchName)) + -- TODO: Fill this in. + let knownHashes = Set.empty + let downloadedCallback = \_ -> pure () + let shouldValidate = not $ Codeserver.isCustomCodeserver Codeserver.defaultCodeserver + result <- SyncV2.syncFromCodeserver shouldValidate Share.hardCodedBaseUrl branchRef causalHashJwt knownHashes downloadedCallback + result & onLeft \err0 -> do + done case err0 of + Share.SyncError err -> + -- TODO: Fix this + error (show err) + -- Output.ShareErrorDownloadEntities err + Share.TransportError err -> Output.ShareErrorTransport err pure (Sync.Common.hash32ToCausalHash (Share.hashJWTHash causalHashJwt)) -- | Download loose code from Share. diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/InstallLib.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/InstallLib.hs index 52e70188c8..299f30ba47 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/InstallLib.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/InstallLib.hs @@ -60,7 +60,7 @@ handleInstallLib remind (ProjectAndBranch libdepProjectName unresolvedLibdepBran Cli.Env {codebase} <- ask causalHash <- - downloadProjectBranchFromShare Share.IncludeSquashedHead libdepProjectBranch + downloadProjectBranchFromShare SyncV1 Share.IncludeSquashedHead libdepProjectBranch & onLeftM (Cli.returnEarly . Output.ShareError) remoteBranchObject <- liftIO (Codebase.expectBranchForHash codebase causalHash) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectClone.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectClone.hs index 8a872d18b8..670a730b5e 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectClone.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectClone.hs @@ -13,7 +13,7 @@ import U.Codebase.Sqlite.Project qualified as Sqlite (Project (..)) import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite import U.Codebase.Sqlite.Queries qualified as Q import U.Codebase.Sqlite.Queries qualified as Queries -import Unison.Cli.DownloadUtils (downloadProjectBranchFromShare) +import Unison.Cli.DownloadUtils (SyncVersion (..), downloadProjectBranchFromShare) import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Cli.MonadUtils qualified as Cli (getCurrentProjectAndBranch) @@ -225,7 +225,7 @@ cloneInto localProjectBranch remoteProjectBranch = do let remoteProjectBranchNames = ProjectAndBranch remoteProjectName remoteBranchName branchHead <- - downloadProjectBranchFromShare Share.NoSquashedHead remoteProjectBranch + downloadProjectBranchFromShare SyncV1 Share.NoSquashedHead remoteProjectBranch & onLeftM (Cli.returnEarly . Output.ShareError) localProjectAndBranch <- diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectCreate.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectCreate.hs index e9f6e99e95..0096a91d8d 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectCreate.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectCreate.hs @@ -13,7 +13,7 @@ import U.Codebase.Sqlite.Project (Project (..)) import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) import U.Codebase.Sqlite.Queries (expectCausalHashIdByCausalHash) import U.Codebase.Sqlite.Queries qualified as Queries -import Unison.Cli.DownloadUtils (downloadProjectBranchFromShare) +import Unison.Cli.DownloadUtils (SyncVersion (..), downloadProjectBranchFromShare) import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Cli.Share.Projects qualified as Share @@ -108,7 +108,7 @@ projectCreate tryDownloadingBase maybeProjectName = do Share.GetProjectBranchResponseBranchNotFound -> done Nothing Share.GetProjectBranchResponseProjectNotFound -> done Nothing Share.GetProjectBranchResponseSuccess branch -> pure branch - downloadProjectBranchFromShare Share.NoSquashedHead baseLatestReleaseBranch + downloadProjectBranchFromShare SyncV1 Share.NoSquashedHead baseLatestReleaseBranch & onLeftM (Cli.returnEarly . Output.ShareError) Cli.Env {codebase} <- ask baseLatestReleaseBranchObject <- diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs index 3ff7012220..42aebf0299 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs @@ -59,6 +59,7 @@ handlePull unresolvedSourceAndTarget pullMode = do ReadShare'LooseCode repo -> downloadLooseCodeFromShare repo & onLeftM (Cli.returnEarly . Output.ShareError) ReadShare'ProjectBranch remoteBranch -> downloadProjectBranchFromShare + SyncV1 ( case pullMode of Input.PullWithHistory -> Share.NoSquashedHead Input.PullWithoutHistory -> Share.IncludeSquashedHead diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/SyncV2.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/SyncV2.hs index f34a64302a..3e3c7ba5ec 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/SyncV2.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/SyncV2.hs @@ -2,6 +2,7 @@ module Unison.Codebase.Editor.HandleInput.SyncV2 ( handleSyncToFile, handleSyncFromFile, handleSyncFromCodebase, + handleSyncFromCodeserver, ) where @@ -21,6 +22,7 @@ import Unison.Prelude import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName) import Unison.Share.SyncV2 qualified as SyncV2 import Unison.SyncV2.Types (BranchRef) +import Unison.Cli.DownloadUtils (SyncVersion, downloadProjectBranchFromShare) handleSyncToFile :: FilePath -> ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName) -> Cli () handleSyncToFile destSyncFile branchToSync = do @@ -69,3 +71,31 @@ handleSyncFromCodebase description srcCodebasePath srcBranch destBranch = do Cli.setProjectBranchRootToCausalHash (projectBranch ^. #branch) description causalHash Right (Right (Left syncErr)) -> do Cli.respond (Output.SyncPullError syncErr) + +handleSyncFromCodebase :: Text -> CodebasePath -> ProjectAndBranch ProjectName ProjectBranchName -> ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli () +handleSyncFromCodebase description srcCodebasePath srcBranch destBranch = do + Cli.Env {codebase} <- ask + pp <- Cli.getCurrentProjectPath + projectBranch <- Project.resolveProjectBranchInProject (pp ^. #project) (over #branch Just destBranch) + r <- liftIO $ Init.withOpenCodebase SqliteCodebase.init "sync-src" srcCodebasePath Init.DontLock (Init.MigrateAfterPrompt Init.Backup Init.Vacuum) \srcCodebase -> do + Codebase.withConnection srcCodebase \srcConn -> do + maySrcCausalHash <- Codebase.runTransaction srcCodebase $ do + let ProjectAndBranch srcProjName srcBranchName = srcBranch + runMaybeT do + project <- MaybeT (Q.loadProjectByName srcProjName) + branch <- MaybeT (Q.loadProjectBranchByName (project ^. #projectId) srcBranchName) + lift $ Project.getProjectBranchCausalHash branch + case maySrcCausalHash of + Nothing -> pure $ Left (error "Todo proper error") + Just srcCausalHash -> do + let shouldValidate = True + fmap (const srcCausalHash) <$> liftIO (SyncV2.syncFromCodebase shouldValidate srcConn codebase srcCausalHash) + + case r of + Left _err -> pure $ error "Todo proper error" + Right (Left syncErr) -> Cli.respond (Output.SyncPullError syncErr) + Right (Right causalHash) -> do + Cli.setProjectBranchRootToCausalHash (projectBranch ^. #branch) description causalHash + +handleSyncFromCodeserver :: SyncVersion -> Projects.IncludeSquashedHead -> Projects.RemoteProjectBranch -> Cli (Either Output.ShareError CausalHash) +handleSyncFromCodeserver = downloadProjectBranchFromShare diff --git a/unison-cli/src/Unison/Share/Sync/Util.hs b/unison-cli/src/Unison/Share/Sync/Util.hs new file mode 100644 index 0000000000..39eeb2cede --- /dev/null +++ b/unison-cli/src/Unison/Share/Sync/Util.hs @@ -0,0 +1,42 @@ +module Unison.Share.Sync.Util + ( BailT (..), + MonadBail (..), + runBailT, + mapBailT, + withError, + ) +where + +import Control.Monad.Reader (MonadReader (..), ReaderT (..), mapReaderT, withReaderT) +import Data.Data (Typeable) +import UnliftIO qualified as IO + +newtype Handler e = Handler {runHandler :: forall x. e -> IO x} + +newtype BailT e m a = BailT {unErrGroupT :: ReaderT (Handler e) m a} + deriving newtype (Functor, Applicative, Monad, IO.MonadUnliftIO, IO.MonadIO) + +newtype ExceptionWrapper e = ExceptionWrapper {unException :: e} + +instance Show (ExceptionWrapper e) where + show (ExceptionWrapper _) = "ExceptionWrapper<>" + +instance (Typeable e) => IO.Exception (ExceptionWrapper e) + +class MonadBail e m where + bail :: e -> m a + +mapBailT :: (Monad n) => (m a -> n b) -> BailT e m a -> BailT e n b +mapBailT f (BailT m) = BailT $ mapReaderT f $ m + +withError :: (Monad m) => (e' -> e) -> BailT e' m a -> BailT e m a +withError f (BailT m) = BailT $ withReaderT (\h -> Handler $ runHandler h . f) m + +instance (IO.MonadUnliftIO m, Typeable e) => MonadBail e (BailT e m) where + bail e = do + handler <- BailT ask + BailT $ IO.liftIO $ runHandler handler e + +runBailT :: (IO.MonadUnliftIO m, Typeable e) => BailT e m a -> (e -> m a) -> m a +runBailT (BailT m) handler = do + IO.handle (handler . unException) $ runReaderT m (Handler (IO.throwIO . ExceptionWrapper)) diff --git a/unison-cli/src/Unison/Share/SyncV2.hs b/unison-cli/src/Unison/Share/SyncV2.hs index bcfccd85c3..dd90bdac75 100644 --- a/unison-cli/src/Unison/Share/SyncV2.hs +++ b/unison-cli/src/Unison/Share/SyncV2.hs @@ -48,6 +48,12 @@ import Unison.SyncV2.Types qualified as SyncV2 import Unison.Util.Servant.CBOR qualified as CBOR import Unison.Util.Timing qualified as Timing import UnliftIO qualified as IO +import Unison.SyncV2.API (Routes (downloadEntitiesStream)) +import Unison.SyncV2.API qualified as SyncV2 +import Data.Attoparsec.ByteString qualified as A +import Data.Attoparsec.ByteString.Char8 qualified as A8 +import Data.Conduit.Attoparsec qualified as C + type Stream i o = ConduitT i o StreamM () @@ -281,6 +287,23 @@ withCodebaseEntityStream conn rootHash mayBranchRef callback = do lift . Sqlite.unsafeIO $ counter 1 traverseOf_ Sync.entityHashes_ expandEntities entity +-- | Gets the framed chunks from a NetString framed stream. +_unNetString :: ConduitT ByteString ByteString StreamM () +_unNetString = do + bs <- C.sinkParser $ do + len <- A8.decimal + _ <- A8.char ':' + bs <- A.take len + _ <- A8.char ',' + pure bs + C.yield bs + +_decodeFramedEntity :: ByteString -> StreamM SyncV2.DownloadEntitiesChunk +_decodeFramedEntity bs = do + case CBOR.deserialiseOrFail (BL.fromStrict bs) of + Left err -> throwError . SyncError . SyncV2.PullError'Sync $ SyncV2.SyncErrorDeserializationFailure err + Right chunk -> pure chunk + -- Expects a stream of tightly-packed CBOR entities without any framing/separators. decodeUnframedEntities :: Stream ByteString SyncV2.DownloadEntitiesChunk decodeUnframedEntities = C.transPipe (mapExceptT (lift . stToIO)) $ do @@ -329,6 +352,78 @@ decodeUnframedEntities = C.transPipe (mapExceptT (lift . stToIO)) $ do k <- newDecoder loop rem k +------------------------------------------------------------------------------------------------------------------------ +-- Servant stuff + +type SyncAPI = ("ucm" Servant.:> "v2" Servant.:> "sync" Servant.:> SyncV2.API) + +syncAPI :: Proxy SyncAPI +syncAPI = Proxy @SyncAPI + +downloadEntitiesStreamClientM :: SyncV2.DownloadEntitiesRequest -> Servant.ClientM (Servant.SourceT IO SyncV2.DownloadEntitiesChunk) +SyncV2.Routes + { downloadEntitiesStream = downloadEntitiesStreamClientM + } = Servant.client syncAPI + +-- -- | Helper for running clientM that returns a stream of entities. +-- -- You MUST consume the stream within the callback, it will be closed when the callback returns. +-- handleStream :: forall m o. (MonadUnliftIO m) => Servant.ClientEnv -> (o -> m ()) -> Servant.ClientM (Servant.SourceIO o) -> m (Either CodeserverTransportError ()) +-- handleStream clientEnv callback clientM = do +-- handleSourceT clientEnv (SourceT.foreach (throwError . StreamingError . Text.pack) callback) clientM + +-- | Helper for running clientM that returns a stream of entities. +-- You MUST consume the stream within the callback, it will be closed when the callback returns. +withConduit :: forall r. Servant.ClientEnv -> (Stream () SyncV2.DownloadEntitiesChunk -> StreamM r) -> Servant.ClientM (Servant.SourceIO SyncV2.DownloadEntitiesChunk) -> StreamM r +withConduit clientEnv callback clientM = do + Debug.debugLogM Debug.Temp $ "Running clientM" + ExceptT $ withRunInIO \runInIO -> do + Servant.withClientM clientM clientEnv $ \case + Left err -> pure . Left . TransportError $ (handleClientError clientEnv err) + Right sourceT -> do + Debug.debugLogM Debug.Temp $ "Converting sourceIO to conduit" + conduit <- liftIO $ Servant.fromSourceIO sourceT + (runInIO . runExceptT $ callback conduit) + +handleClientError :: Servant.ClientEnv -> Servant.ClientError -> CodeserverTransportError +handleClientError clientEnv err = + case err of + Servant.FailureResponse _req resp -> + case HTTP.statusCode $ Servant.responseStatusCode resp of + 401 -> Unauthenticated (Servant.baseUrl clientEnv) + -- The server should provide semantically relevant permission-denied messages + -- when possible, but this should catch any we miss. + 403 -> PermissionDenied (Text.Lazy.toStrict . Text.Lazy.decodeUtf8 $ Servant.responseBody resp) + 408 -> Timeout + 429 -> RateLimitExceeded + 504 -> Timeout + _ -> UnexpectedResponse resp + Servant.DecodeFailure msg resp -> DecodeFailure msg resp + Servant.UnsupportedContentType _ct resp -> UnexpectedResponse resp + Servant.InvalidContentTypeHeader resp -> UnexpectedResponse resp + Servant.ConnectionError _ -> UnreachableCodeserver (Servant.baseUrl clientEnv) + +httpStreamEntities :: + forall. + Auth.AuthenticatedHttpClient -> + Servant.BaseUrl -> + SyncV2.DownloadEntitiesRequest -> + (SyncV2.StreamInitInfo -> Stream () SyncV2.EntityChunk -> StreamM ()) -> + StreamM () +httpStreamEntities (Auth.AuthenticatedHttpClient httpClient) unisonShareUrl req callback = do + let clientEnv = + (Servant.mkClientEnv httpClient unisonShareUrl) + { Servant.makeClientRequest = \url request -> + -- Disable client-side timeouts + (Servant.defaultMakeClientRequest url request) + <&> \r -> + r + { Http.Client.responseTimeout = Http.Client.responseTimeoutNone + } + } + (downloadEntitiesStreamClientM req) & withConduit clientEnv \stream -> do + (init, entityStream) <- initializeStream stream + callback init entityStream + -- | Peel the header off the stream and parse the remaining entity chunks into EntityChunks initializeStream :: Stream () SyncV2.DownloadEntitiesChunk -> StreamM (SyncV2.StreamInitInfo, Stream () SyncV2.EntityChunk) initializeStream stream = do diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index e1f51a7633..795180729d 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -152,6 +152,7 @@ library Unison.Share.ExpectedHashMismatches Unison.Share.Sync Unison.Share.Sync.Types + Unison.Share.Sync.Util Unison.Share.SyncV2 Unison.Util.HTTP Unison.Version diff --git a/unison-share-api/src/Unison/SyncV2/API.hs b/unison-share-api/src/Unison/SyncV2/API.hs new file mode 100644 index 0000000000..71ea8693d3 --- /dev/null +++ b/unison-share-api/src/Unison/SyncV2/API.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE DataKinds #-} + +module Unison.SyncV2.API + ( API, + api, + Routes (..), + ) +where + +import Data.Proxy +import GHC.Generics (Generic) +import Servant.API +import Unison.SyncV2.Types +import Unison.Util.Servant.CBOR (CBOR) + +api :: Proxy API +api = Proxy + +type API = NamedRoutes Routes + +type DownloadEntitiesStream = + -- | The causal hash the client needs. The server should provide it and all of its dependencies + ReqBody '[CBOR, JSON] DownloadEntitiesRequest + :> StreamPost NetstringFraming CBOR (SourceIO DownloadEntitiesChunk) + +data Routes mode = Routes + { downloadEntitiesStream :: mode :- "entities" :> "download" :> DownloadEntitiesStream + } + deriving stock (Generic) diff --git a/unison-share-api/unison-share-api.cabal b/unison-share-api/unison-share-api.cabal index aaacbda4fd..a9447279da 100644 --- a/unison-share-api/unison-share-api.cabal +++ b/unison-share-api/unison-share-api.cabal @@ -48,6 +48,7 @@ library Unison.Sync.Common Unison.Sync.EntityValidation Unison.Sync.Types + Unison.SyncV2.API Unison.SyncV2.Types Unison.Util.Find Unison.Util.Servant.CBOR From 211a7139bd7bdbcf36c1bb951bd79536174a2544 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 22 Jan 2025 16:47:35 -0800 Subject: [PATCH 16/44] Revive syncFromCodeserver --- unison-cli/src/Unison/Share/SyncV2.hs | 42 +++++++++++++++++++++++++++ 1 file changed, 42 insertions(+) diff --git a/unison-cli/src/Unison/Share/SyncV2.hs b/unison-cli/src/Unison/Share/SyncV2.hs index dd90bdac75..8b45bf3f18 100644 --- a/unison-cli/src/Unison/Share/SyncV2.hs +++ b/unison-cli/src/Unison/Share/SyncV2.hs @@ -5,6 +5,7 @@ module Unison.Share.SyncV2 ( syncFromFile, syncToFile, syncFromCodebase, + syncFromCodeserver, ) where @@ -22,19 +23,30 @@ import Data.Conduit.List qualified as C import Data.Conduit.Zlib qualified as C import Data.Graph qualified as Graph import Data.Map qualified as Map +import Data.Proxy import Data.Set qualified as Set import Data.Text.IO qualified as Text +import Data.Text.Lazy qualified as Text.Lazy +import Data.Text.Lazy.Encoding qualified as Text.Lazy +import Network.HTTP.Client qualified as Http.Client +import Network.HTTP.Types qualified as HTTP +import Servant.API qualified as Servant +import Servant.Client.Streaming qualified as Servant import Servant.Conduit () +import Servant.Types.SourceT qualified as Servant import System.Console.Regions qualified as Console.Regions import U.Codebase.HashTags (CausalHash) import U.Codebase.Sqlite.Queries qualified as Q import U.Codebase.Sqlite.TempEntity (TempEntity) import U.Codebase.Sqlite.V2.HashHandle (v2HashHandle) +import Unison.Auth.HTTPClient qualified as Auth import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Codebase qualified as Codebase +import Unison.Debug qualified as Debug import Unison.Hash32 (Hash32) import Unison.Prelude +import Unison.Share.API.Hash qualified as Share import Unison.Share.ExpectedHashMismatches (expectedCausalHashMismatches, expectedComponentHashMismatches) import Unison.Share.Sync.Types import Unison.Sqlite qualified as Sqlite @@ -118,6 +130,36 @@ syncFromCodebase shouldValidate srcConn destCodebase causalHash = do streamIntoCodebase shouldValidate destCodebase header rest mapExceptT liftIO (afterSyncChecks destCodebase (causalHashToHash32 causalHash)) +syncFromCodeserver :: + Bool -> + -- | The Unison Share URL. + Servant.BaseUrl -> + -- | The branch to download from. + SyncV2.BranchRef -> + -- | The hash to download. + Share.HashJWT -> + Set Hash32 -> + -- | Callback that's given a number of entities we just downloaded. + (Int -> IO ()) -> + Cli (Either (SyncError SyncV2.PullError) ()) +syncFromCodeserver shouldValidate unisonShareUrl branchRef hashJwt knownHashes _downloadedCallback = do + Cli.Env {authHTTPClient, codebase} <- ask + runExceptT do + let hash = Share.hashJWTHash hashJwt + ExceptT $ do + (Cli.runTransaction (Q.entityLocation hash)) >>= \case + Just Q.EntityInMainStorage -> pure $ Right () + _ -> do + Debug.debugLogM Debug.Temp $ "Kicking off sync request" + Timing.time "Entity Download" $ do + liftIO . C.runResourceT . runExceptT $ httpStreamEntities + authHTTPClient + unisonShareUrl + SyncV2.DownloadEntitiesRequest {branchRef, causalHash = hashJwt, knownHashes} + \header stream -> do + streamIntoCodebase shouldValidate codebase header stream + mapExceptT liftIO (afterSyncChecks codebase hash) + ------------------------------------------------------------------------------------------------------------------------ -- Helpers ------------------------------------------------------------------------------------------------------------------------ From 691eaa9dff354f7c06e7926473d87f8db28d3ab4 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 23 Jan 2025 11:04:21 -0800 Subject: [PATCH 17/44] Add pull.v2 command --- unison-cli/package.yaml | 1 + unison-cli/src/Unison/Cli/DownloadUtils.hs | 3 +- .../src/Unison/Codebase/Editor/HandleInput.hs | 2 +- .../Codebase/Editor/HandleInput/Pull.hs | 6 ++-- .../Codebase/Editor/HandleInput/SyncV2.hs | 33 +++---------------- .../src/Unison/Codebase/Editor/Input.hs | 6 +++- .../src/Unison/CommandLine/InputPatterns.hs | 19 +++++++---- unison-cli/unison-cli.cabal | 1 + 8 files changed, 30 insertions(+), 41 deletions(-) diff --git a/unison-cli/package.yaml b/unison-cli/package.yaml index d81ba052f7..d3d48f2c8a 100644 --- a/unison-cli/package.yaml +++ b/unison-cli/package.yaml @@ -20,6 +20,7 @@ library: - condition: "!os(windows)" dependencies: unix dependencies: + - attoparsec - Diff - IntervalMap - ListLike diff --git a/unison-cli/src/Unison/Cli/DownloadUtils.hs b/unison-cli/src/Unison/Cli/DownloadUtils.hs index fb53a84176..0772eda44c 100644 --- a/unison-cli/src/Unison/Cli/DownloadUtils.hs +++ b/unison-cli/src/Unison/Cli/DownloadUtils.hs @@ -19,6 +19,7 @@ import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Cli.Share.Projects qualified as Share import Unison.Codebase.Editor.HandleInput.AuthLogin (ensureAuthenticatedWithCodeserver) +import Unison.Codebase.Editor.Input (SyncVersion (..)) import Unison.Codebase.Editor.Output qualified as Output import Unison.Codebase.Editor.RemoteRepo (ReadShareLooseCode, shareUserHandleToText) import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo @@ -36,8 +37,6 @@ import Unison.Sync.Common qualified as Sync.Common import Unison.Sync.Types qualified as Share import Unison.SyncV2.Types qualified as SyncV2 -data SyncVersion = SyncV1 | SyncV2 - -- | Download a project/branch from Share. downloadProjectBranchFromShare :: (HasCallStack) => diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index c0cc9a8dd6..726fa6eb9c 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -687,7 +687,7 @@ loop e = do _ <- Cli.updateAtM description pp \destb -> liftIO (Branch.merge'' (Codebase.lca codebase) Branch.RegularMerge srcb destb) Cli.respond Success - PullI sourceTarget pullMode -> handlePull sourceTarget pullMode + PullI syncVersion sourceTarget pullMode -> handlePull syncVersion sourceTarget pullMode PushRemoteBranchI pushRemoteBranchInput -> handlePushRemoteBranch pushRemoteBranchInput SyncToFileI syncFileDest projectBranchName -> SyncV2.handleSyncToFile syncFileDest projectBranchName SyncFromFileI syncFileSrc projectBranchName -> do diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs index 42aebf0299..e51ba1046a 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs @@ -46,8 +46,8 @@ import Unison.Prelude import Unison.Project (ProjectAndBranch (..), ProjectBranchNameOrLatestRelease (..), ProjectName) import Witch (unsafeFrom) -handlePull :: PullSourceTarget -> PullMode -> Cli () -handlePull unresolvedSourceAndTarget pullMode = do +handlePull :: SyncVersion -> PullSourceTarget -> PullMode -> Cli () +handlePull syncVersion unresolvedSourceAndTarget pullMode = do let includeSquashed = case pullMode of Input.PullWithHistory -> Share.NoSquashedHead Input.PullWithoutHistory -> Share.IncludeSquashedHead @@ -59,7 +59,7 @@ handlePull unresolvedSourceAndTarget pullMode = do ReadShare'LooseCode repo -> downloadLooseCodeFromShare repo & onLeftM (Cli.returnEarly . Output.ShareError) ReadShare'ProjectBranch remoteBranch -> downloadProjectBranchFromShare - SyncV1 + syncVersion ( case pullMode of Input.PullWithHistory -> Share.NoSquashedHead Input.PullWithoutHistory -> Share.IncludeSquashedHead diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/SyncV2.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/SyncV2.hs index 3e3c7ba5ec..015e5b7630 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/SyncV2.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/SyncV2.hs @@ -8,11 +8,14 @@ where import Control.Lens import Control.Monad.Reader (MonadReader (..)) +import U.Codebase.HashTags (CausalHash) import U.Codebase.Sqlite.Queries qualified as Q +import Unison.Cli.DownloadUtils (SyncVersion (..), downloadProjectBranchFromShare) import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Cli.MonadUtils qualified as Cli import Unison.Cli.ProjectUtils qualified as Project +import Unison.Cli.Share.Projects qualified as Projects import Unison.Codebase (CodebasePath) import Unison.Codebase qualified as Codebase import Unison.Codebase.Editor.Output qualified as Output @@ -22,7 +25,6 @@ import Unison.Prelude import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName) import Unison.Share.SyncV2 qualified as SyncV2 import Unison.SyncV2.Types (BranchRef) -import Unison.Cli.DownloadUtils (SyncVersion, downloadProjectBranchFromShare) handleSyncToFile :: FilePath -> ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName) -> Cli () handleSyncToFile destSyncFile branchToSync = do @@ -72,30 +74,5 @@ handleSyncFromCodebase description srcCodebasePath srcBranch destBranch = do Right (Right (Left syncErr)) -> do Cli.respond (Output.SyncPullError syncErr) -handleSyncFromCodebase :: Text -> CodebasePath -> ProjectAndBranch ProjectName ProjectBranchName -> ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli () -handleSyncFromCodebase description srcCodebasePath srcBranch destBranch = do - Cli.Env {codebase} <- ask - pp <- Cli.getCurrentProjectPath - projectBranch <- Project.resolveProjectBranchInProject (pp ^. #project) (over #branch Just destBranch) - r <- liftIO $ Init.withOpenCodebase SqliteCodebase.init "sync-src" srcCodebasePath Init.DontLock (Init.MigrateAfterPrompt Init.Backup Init.Vacuum) \srcCodebase -> do - Codebase.withConnection srcCodebase \srcConn -> do - maySrcCausalHash <- Codebase.runTransaction srcCodebase $ do - let ProjectAndBranch srcProjName srcBranchName = srcBranch - runMaybeT do - project <- MaybeT (Q.loadProjectByName srcProjName) - branch <- MaybeT (Q.loadProjectBranchByName (project ^. #projectId) srcBranchName) - lift $ Project.getProjectBranchCausalHash branch - case maySrcCausalHash of - Nothing -> pure $ Left (error "Todo proper error") - Just srcCausalHash -> do - let shouldValidate = True - fmap (const srcCausalHash) <$> liftIO (SyncV2.syncFromCodebase shouldValidate srcConn codebase srcCausalHash) - - case r of - Left _err -> pure $ error "Todo proper error" - Right (Left syncErr) -> Cli.respond (Output.SyncPullError syncErr) - Right (Right causalHash) -> do - Cli.setProjectBranchRootToCausalHash (projectBranch ^. #branch) description causalHash - -handleSyncFromCodeserver :: SyncVersion -> Projects.IncludeSquashedHead -> Projects.RemoteProjectBranch -> Cli (Either Output.ShareError CausalHash) -handleSyncFromCodeserver = downloadProjectBranchFromShare +handleSyncFromCodeserver :: Projects.IncludeSquashedHead -> Projects.RemoteProjectBranch -> Cli (Either Output.ShareError CausalHash) +handleSyncFromCodeserver = downloadProjectBranchFromShare SyncV2 diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index e4015b64fe..b8767076e8 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -27,6 +27,7 @@ module Unison.Codebase.Editor.Input IsGlobal, DeleteOutput (..), DeleteTarget (..), + SyncVersion (..), ) where @@ -55,6 +56,9 @@ data Event = UnisonFileChanged SourceName Source deriving stock (Show) +data SyncVersion = SyncV1 | SyncV2 + deriving (Eq, Show) + type Source = Text -- "id x = x\nconst a b = a" type SourceName = Text -- "foo.u" or "buffer 7" @@ -124,7 +128,7 @@ data Input MergeLocalBranchI BranchRelativePath (Maybe BranchRelativePath) Branch.MergeMode | PreviewMergeLocalBranchI BranchRelativePath (Maybe BranchRelativePath) | DiffNamespaceI BranchId2 BranchId2 -- old new - | PullI !PullSourceTarget !PullMode + | PullI !SyncVersion !PullSourceTarget !PullMode | PushRemoteBranchI PushRemoteBranchInput | SyncToFileI FilePath (ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName)) | SyncFromFileI FilePath UnresolvedProjectBranch diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 0d0022da05..ccf5f0fc23 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -92,6 +92,7 @@ module Unison.CommandLine.InputPatterns projectSwitch, projectsInputPattern, pull, + pullV2, pullWithoutHistory, push, pushCreate, @@ -1783,7 +1784,11 @@ reset = pull :: InputPattern pull = - pullImpl "pull" [] Input.PullWithHistory "" + pullImpl "pull" [] Input.PullWithHistory "" Input.SyncV1 + +pullV2 :: InputPattern +pullV2 = + pullImpl "pull.v2" [] Input.PullWithHistory "" Input.SyncV2 pullWithoutHistory :: InputPattern pullWithoutHistory = @@ -1792,9 +1797,10 @@ pullWithoutHistory = [] Input.PullWithoutHistory "without including the remote's history. This usually results in smaller codebase sizes." + Input.SyncV1 -pullImpl :: String -> [String] -> Input.PullMode -> P.Pretty CT.ColorText -> InputPattern -pullImpl name aliases pullMode addendum = do +pullImpl :: String -> [String] -> Input.PullMode -> P.Pretty CT.ColorText -> Input.SyncVersion -> InputPattern +pullImpl name aliases pullMode addendum syncVersion = do self where self = @@ -1838,10 +1844,10 @@ pullImpl name aliases pullMode addendum = do explainRemote Pull ], parse = \case - [] -> pure $ Input.PullI Input.PullSourceTarget0 pullMode + [] -> pure $ Input.PullI syncVersion Input.PullSourceTarget0 pullMode [sourceArg] -> do source <- handlePullSourceArg sourceArg - pure (Input.PullI (Input.PullSourceTarget1 source) pullMode) + pure (Input.PullI syncVersion (Input.PullSourceTarget1 source) pullMode) [sourceArg, targetArg] -> -- You used to be able to pull into a path, so this arg parser is a little complicated, because -- we want to provide helpful suggestions if you are doing a deprecated or invalid thing. @@ -1849,7 +1855,7 @@ pullImpl name aliases pullMode addendum = do handleMaybeProjectBranchArg targetArg, handlePath'Arg targetArg ) of - (Right source, Right target, _) -> Right (Input.PullI (Input.PullSourceTarget2 source target) pullMode) + (Right source, Right target, _) -> Right (Input.PullI syncVersion (Input.PullSourceTarget2 source target) pullMode) (Left err, _, _) -> Left err -- Parsing as a path didn't work either; just show the branch parse error (Right _, Left err, Left _) -> Left err @@ -3795,6 +3801,7 @@ validInputs = projectSwitch, projectsInputPattern, pull, + pullV2, pullWithoutHistory, push, pushCreate, diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index 795180729d..dbdc009a7a 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -201,6 +201,7 @@ library , aeson-pretty , ansi-terminal , async + , attoparsec , base , bytestring , cmark From b9f2c83093a67e10c5536a7f31b7023a228cc5de Mon Sep 17 00:00:00 2001 From: Mitchell Dalvi Rosen Date: Tue, 28 Jan 2025 10:39:38 -0500 Subject: [PATCH 18/44] derive Eq IncoherentDeclReason --- .../src/Unison/Merge/DeclCoherencyCheck.hs | 2 +- unison-merge/src/Unison/Merge/Diff.hs | 25 +++++++++++----- unison-merge/src/Unison/Merge/Mergeblob1.hs | 30 +++++++++++++------ 3 files changed, 40 insertions(+), 17 deletions(-) diff --git a/unison-merge/src/Unison/Merge/DeclCoherencyCheck.hs b/unison-merge/src/Unison/Merge/DeclCoherencyCheck.hs index 697e693d6b..97fe824740 100644 --- a/unison-merge/src/Unison/Merge/DeclCoherencyCheck.hs +++ b/unison-merge/src/Unison/Merge/DeclCoherencyCheck.hs @@ -132,7 +132,7 @@ data IncoherentDeclReason -- Foo.Bar#Foo IncoherentDeclReason'NestedDeclAlias !Name !Name -- shorter name, longer name | IncoherentDeclReason'StrayConstructor !TypeReferenceId !Name - deriving stock (Show) + deriving stock (Eq, Show) checkDeclCoherency :: (HasCallStack) => diff --git a/unison-merge/src/Unison/Merge/Diff.hs b/unison-merge/src/Unison/Merge/Diff.hs index 0b6e4c8332..37625c66c7 100644 --- a/unison-merge/src/Unison/Merge/Diff.hs +++ b/unison-merge/src/Unison/Merge/Diff.hs @@ -95,25 +95,33 @@ diffHashedNamespaceDefns d1 d2 = zipDefnsWith f f d1 d2 & splitPropagated where - f :: Map Name (Synhashed ref) -> Map Name (Synhashed ref) -> (Map Name (DiffOp (Synhashed ref)), Map Name (Updated ref)) - f old new = unalign (eitherToThese . mapRight (fmap Synhashed.value) <$> alignWith g old new) + f :: + Map Name (Synhashed ref) -> + Map Name (Synhashed ref) -> + (Map Name (DiffOp (Synhashed ref)), Map Name (Updated ref)) + f old new = + unalign (eitherToThese . mapRight (fmap Synhashed.value) <$> alignWith g old new) g :: (Eq x) => These x x -> Either (DiffOp x) (Updated x) g = \case This old -> Left (DiffOp'Delete old) That new -> Left (DiffOp'Add new) These old new - | old == new -> Right (Updated {old, new}) + | old == new -> Right Updated {old, new} | otherwise -> Left (DiffOp'Update Updated {old, new}) + splitPropagated :: - Defns (Map Name (DiffOp (Synhashed term)), Map Name (Updated term)) (Map Name (DiffOp (Synhashed typ)), Map Name (Updated typ)) -> + Defns + ( Map Name (DiffOp (Synhashed term)), + Map Name (Updated term) + ) + (Map Name (DiffOp (Synhashed typ)), Map Name (Updated typ)) -> (DefnsF3 (Map Name) DiffOp Synhashed term typ, DefnsF2 (Map Name) Updated term typ) splitPropagated Defns {terms, types} = (Defns {terms = fst terms, types = fst types}, Defns {terms = snd terms, types = snd types}) --- | Post-process a diff to identify relationships humans might care about, --- such as whether a given addition could be interpreted as an alias of an existing definition, --- or whether an add and deletion could be a rename. +-- | Post-process a diff to identify relationships humans might care about, such as whether a given addition could be +-- interpreted as an alias of an existing definition, or whether an add and deletion could be a rename. humanizeDiffs :: ThreeWay Names -> TwoWay (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference) -> @@ -125,10 +133,13 @@ humanizeDiffs names3 diffs propagatedUpdates = where zipWithF3 :: (Zip.Zip f) => f a -> f b -> f c -> (a -> b -> c -> d) -> f d zipWithF3 a b c f = Zip.zipWith (\(x, y) z -> f x y z) (Zip.zip a b) c + namesToRelations :: Names -> (DefnsF (Relation Name) Referent TypeReference) namesToRelations names = Defns {terms = Names.terms names, types = Names.types names} + lcaRelation :: DefnsF (Relation Name) Referent TypeReference lcaRelation = namesToRelations names3.lca + nameRelations :: TwoWay (DefnsF (Relation Name) Referent TypeReference) nameRelations = namesToRelations <$> ThreeWay.forgetLca names3 diff --git a/unison-merge/src/Unison/Merge/Mergeblob1.hs b/unison-merge/src/Unison/Merge/Mergeblob1.hs index c606cd94a4..085af71eb0 100644 --- a/unison-merge/src/Unison/Merge/Mergeblob1.hs +++ b/unison-merge/src/Unison/Merge/Mergeblob1.hs @@ -69,18 +69,30 @@ data Mergeblob1 libdep = Mergeblob1 unconflicts :: DefnsF Unconflicts Referent TypeReference } --- | Get a names object for all the hydrated definitions AND their direct dependencies -hydratedDefnsLabeledDependencies :: (DefnsF (Map Name) (TermReferenceId, (Term Symbol Ann, Type Symbol Ann)) (TypeReferenceId, Decl Symbol Ann)) -> Set LD.LabeledDependency -hydratedDefnsLabeledDependencies (Defns {terms, types}) = +-- | Get a names object for all the hydrated definitions AND their direct dependencies +hydratedDefnsLabeledDependencies :: + DefnsF + (Map Name) + (TermReferenceId, (Term Symbol Ann, Type Symbol Ann)) + (TypeReferenceId, Decl Symbol Ann) -> + Set LD.LabeledDependency +hydratedDefnsLabeledDependencies defns = let termDeps :: Set LD.LabeledDependency - termDeps = foldOf (folded . beside (to Reference.DerivedId . to LD.TermReference . to Set.singleton) (beside (to Term.labeledDependencies) (to Type.labeledDependencies))) terms + termDeps = + foldOf + ( folded + . beside + (to Reference.DerivedId . to LD.TermReference . to Set.singleton) + (beside (to Term.labeledDependencies) (to Type.labeledDependencies)) + ) + defns.terms + typeDeps :: Set LD.LabeledDependency typeDeps = - types + defns.types & foldMap \(typeRefId, typeDecl) -> - let typeRef = Reference.DerivedId typeRefId - in Decl.labeledDeclDependenciesIncludingSelfAndFieldAccessors typeRef typeDecl - in termDeps <> typeDeps + Decl.labeledDeclDependenciesIncludingSelfAndFieldAccessors (Reference.DerivedId typeRefId) typeDecl + in Set.union termDeps typeDeps makeMergeblob1 :: forall libdep. @@ -96,7 +108,7 @@ makeMergeblob1 :: Either (EitherWay IncoherentDeclReason) (Mergeblob1 libdep) makeMergeblob1 blob names3 hydratedDefns = do let ppeds3 :: ThreeWay PPED.PrettyPrintEnvDecl - ppeds3 = names3 <&> \names -> (PPED.makePPED (PPE.namer names) (PPE.suffixifyByHash names)) + ppeds3 = names3 <&> \names -> PPED.makePPED (PPE.namer names) (PPE.suffixifyByHash names) -- Make one big constructor count lookup for all type decls let numConstructors = Map.empty From f91dc103afc7a9c4f0361afcdd2adea35bdf40a5 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 24 Jan 2025 13:06:48 -0800 Subject: [PATCH 19/44] Remove debugging --- unison-cli/src/Unison/Share/SyncV2.hs | 15 +++++---------- 1 file changed, 5 insertions(+), 10 deletions(-) diff --git a/unison-cli/src/Unison/Share/SyncV2.hs b/unison-cli/src/Unison/Share/SyncV2.hs index 8b45bf3f18..af1da5d72b 100644 --- a/unison-cli/src/Unison/Share/SyncV2.hs +++ b/unison-cli/src/Unison/Share/SyncV2.hs @@ -17,8 +17,11 @@ import Control.Monad.Except import Control.Monad.Reader (ask) import Control.Monad.ST (ST, stToIO) import Control.Monad.State +import Data.Attoparsec.ByteString qualified as A +import Data.Attoparsec.ByteString.Char8 qualified as A8 import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as BL +import Data.Conduit.Attoparsec qualified as C import Data.Conduit.List qualified as C import Data.Conduit.Zlib qualified as C import Data.Graph qualified as Graph @@ -43,7 +46,6 @@ import Unison.Auth.HTTPClient qualified as Auth import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Codebase qualified as Codebase -import Unison.Debug qualified as Debug import Unison.Hash32 (Hash32) import Unison.Prelude import Unison.Share.API.Hash qualified as Share @@ -55,17 +57,13 @@ import Unison.Sync.Common qualified as Sync import Unison.Sync.EntityValidation qualified as EV import Unison.Sync.Types qualified as Share import Unison.Sync.Types qualified as Sync +import Unison.SyncV2.API (Routes (downloadEntitiesStream)) +import Unison.SyncV2.API qualified as SyncV2 import Unison.SyncV2.Types (CBORBytes) import Unison.SyncV2.Types qualified as SyncV2 import Unison.Util.Servant.CBOR qualified as CBOR import Unison.Util.Timing qualified as Timing import UnliftIO qualified as IO -import Unison.SyncV2.API (Routes (downloadEntitiesStream)) -import Unison.SyncV2.API qualified as SyncV2 -import Data.Attoparsec.ByteString qualified as A -import Data.Attoparsec.ByteString.Char8 qualified as A8 -import Data.Conduit.Attoparsec qualified as C - type Stream i o = ConduitT i o StreamM () @@ -150,7 +148,6 @@ syncFromCodeserver shouldValidate unisonShareUrl branchRef hashJwt knownHashes _ (Cli.runTransaction (Q.entityLocation hash)) >>= \case Just Q.EntityInMainStorage -> pure $ Right () _ -> do - Debug.debugLogM Debug.Temp $ "Kicking off sync request" Timing.time "Entity Download" $ do liftIO . C.runResourceT . runExceptT $ httpStreamEntities authHTTPClient @@ -417,12 +414,10 @@ SyncV2.Routes -- You MUST consume the stream within the callback, it will be closed when the callback returns. withConduit :: forall r. Servant.ClientEnv -> (Stream () SyncV2.DownloadEntitiesChunk -> StreamM r) -> Servant.ClientM (Servant.SourceIO SyncV2.DownloadEntitiesChunk) -> StreamM r withConduit clientEnv callback clientM = do - Debug.debugLogM Debug.Temp $ "Running clientM" ExceptT $ withRunInIO \runInIO -> do Servant.withClientM clientM clientEnv $ \case Left err -> pure . Left . TransportError $ (handleClientError clientEnv err) Right sourceT -> do - Debug.debugLogM Debug.Temp $ "Converting sourceIO to conduit" conduit <- liftIO $ Servant.fromSourceIO sourceT (runInIO . runExceptT $ callback conduit) From f075ba96d61e5961470440326200cd3c857b491a Mon Sep 17 00:00:00 2001 From: Mitchell Dalvi Rosen Date: Wed, 29 Jan 2025 14:55:40 -0500 Subject: [PATCH 20/44] add ThreeWay.toTwoOrThreeWay --- unison-merge/src/Unison/Merge/ThreeWay.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/unison-merge/src/Unison/Merge/ThreeWay.hs b/unison-merge/src/Unison/Merge/ThreeWay.hs index cc9d24c47d..a5fb93f3b3 100644 --- a/unison-merge/src/Unison/Merge/ThreeWay.hs +++ b/unison-merge/src/Unison/Merge/ThreeWay.hs @@ -1,11 +1,13 @@ module Unison.Merge.ThreeWay ( ThreeWay (..), forgetLca, + toTwoOrThreeWay, ) where import Data.Semialign (Semialign (alignWith), Unzip (unzipWith), Zip (zipWith)) import Data.These (These (..)) +import Unison.Merge.TwoOrThreeWay (TwoOrThreeWay (..)) import Unison.Merge.TwoWay (TwoWay (..)) import Unison.Prelude @@ -46,3 +48,7 @@ instance Zip ThreeWay where forgetLca :: ThreeWay a -> TwoWay a forgetLca ThreeWay {alice, bob} = TwoWay {alice, bob} + +toTwoOrThreeWay :: ThreeWay a -> TwoOrThreeWay a +toTwoOrThreeWay ThreeWay {alice, bob, lca} = + TwoOrThreeWay {alice, bob, lca = Just lca} From 1a429d93078481fe163165e3d16ee89135444e8a Mon Sep 17 00:00:00 2001 From: Mitchell Dalvi Rosen Date: Wed, 29 Jan 2025 15:15:49 -0500 Subject: [PATCH 21/44] add TwoOrThreeWay.toThreeWay --- .../src/Unison/Merge/Internal/Types.hs | 51 +++++++++++++++++++ unison-merge/src/Unison/Merge/ThreeWay.hs | 38 +------------- .../src/Unison/Merge/TwoOrThreeWay.hs | 11 ++-- unison-merge/unison-merge.cabal | 3 +- 4 files changed, 59 insertions(+), 44 deletions(-) create mode 100644 unison-merge/src/Unison/Merge/Internal/Types.hs diff --git a/unison-merge/src/Unison/Merge/Internal/Types.hs b/unison-merge/src/Unison/Merge/Internal/Types.hs new file mode 100644 index 0000000000..5d1a39e646 --- /dev/null +++ b/unison-merge/src/Unison/Merge/Internal/Types.hs @@ -0,0 +1,51 @@ +-- | Internal types module to house types that would require mutual recursion at the module level if defined separately +module Unison.Merge.Internal.Types + ( ThreeWay (..), + TwoOrThreeWay (..), + ) +where + +import Data.Semialign (Semialign (alignWith), Unzip (unzipWith), Zip (zipWith)) +import Data.These (These (..)) +import Unison.Prelude + +data ThreeWay a = ThreeWay + { lca :: !a, + alice :: !a, + bob :: !a + } + deriving stock (Foldable, Functor, Generic, Traversable) + +instance Applicative ThreeWay where + pure :: a -> ThreeWay a + pure x = + ThreeWay x x x + + (<*>) :: ThreeWay (a -> b) -> ThreeWay a -> ThreeWay b + ThreeWay f g h <*> ThreeWay x y z = + ThreeWay (f x) (g y) (h z) + +instance Semialign ThreeWay where + alignWith :: (These a b -> c) -> ThreeWay a -> ThreeWay b -> ThreeWay c + alignWith f (ThreeWay a b c) (ThreeWay x y z) = + ThreeWay (f (These a x)) (f (These b y)) (f (These c z)) + +instance Unzip ThreeWay where + unzipWith :: (c -> (a, b)) -> ThreeWay c -> (ThreeWay a, ThreeWay b) + unzipWith f (ThreeWay a b c) = + let (i, x) = f a + (j, y) = f b + (k, z) = f c + in (ThreeWay i j k, ThreeWay x y z) + +instance Zip ThreeWay where + zipWith :: (a -> b -> c) -> ThreeWay a -> ThreeWay b -> ThreeWay c + zipWith f (ThreeWay a b c) (ThreeWay x y z) = + ThreeWay (f a x) (f b y) (f c z) + +data TwoOrThreeWay a = TwoOrThreeWay + { lca :: Maybe a, + alice :: a, + bob :: a + } + deriving stock (Foldable, Functor, Generic, Traversable) diff --git a/unison-merge/src/Unison/Merge/ThreeWay.hs b/unison-merge/src/Unison/Merge/ThreeWay.hs index a5fb93f3b3..aa49f7b9d3 100644 --- a/unison-merge/src/Unison/Merge/ThreeWay.hs +++ b/unison-merge/src/Unison/Merge/ThreeWay.hs @@ -5,45 +5,9 @@ module Unison.Merge.ThreeWay ) where -import Data.Semialign (Semialign (alignWith), Unzip (unzipWith), Zip (zipWith)) -import Data.These (These (..)) +import Unison.Merge.Internal.Types (ThreeWay (..)) import Unison.Merge.TwoOrThreeWay (TwoOrThreeWay (..)) import Unison.Merge.TwoWay (TwoWay (..)) -import Unison.Prelude - -data ThreeWay a = ThreeWay - { lca :: !a, - alice :: !a, - bob :: !a - } - deriving stock (Foldable, Functor, Generic, Traversable) - -instance Applicative ThreeWay where - pure :: a -> ThreeWay a - pure x = - ThreeWay x x x - - (<*>) :: ThreeWay (a -> b) -> ThreeWay a -> ThreeWay b - ThreeWay f g h <*> ThreeWay x y z = - ThreeWay (f x) (g y) (h z) - -instance Semialign ThreeWay where - alignWith :: (These a b -> c) -> ThreeWay a -> ThreeWay b -> ThreeWay c - alignWith f (ThreeWay a b c) (ThreeWay x y z) = - ThreeWay (f (These a x)) (f (These b y)) (f (These c z)) - -instance Unzip ThreeWay where - unzipWith :: (c -> (a, b)) -> ThreeWay c -> (ThreeWay a, ThreeWay b) - unzipWith f (ThreeWay a b c) = - let (i, x) = f a - (j, y) = f b - (k, z) = f c - in (ThreeWay i j k, ThreeWay x y z) - -instance Zip ThreeWay where - zipWith :: (a -> b -> c) -> ThreeWay a -> ThreeWay b -> ThreeWay c - zipWith f (ThreeWay a b c) (ThreeWay x y z) = - ThreeWay (f a x) (f b y) (f c z) forgetLca :: ThreeWay a -> TwoWay a forgetLca ThreeWay {alice, bob} = diff --git a/unison-merge/src/Unison/Merge/TwoOrThreeWay.hs b/unison-merge/src/Unison/Merge/TwoOrThreeWay.hs index 556ff0fd2d..cec3725c11 100644 --- a/unison-merge/src/Unison/Merge/TwoOrThreeWay.hs +++ b/unison-merge/src/Unison/Merge/TwoOrThreeWay.hs @@ -1,13 +1,12 @@ module Unison.Merge.TwoOrThreeWay ( TwoOrThreeWay (..), + toThreeWay, ) where +import Unison.Merge.Internal.Types (ThreeWay (..), TwoOrThreeWay (..)) import Unison.Prelude -data TwoOrThreeWay a = TwoOrThreeWay - { lca :: Maybe a, - alice :: a, - bob :: a - } - deriving stock (Foldable, Functor, Generic, Traversable) +toThreeWay :: a -> TwoOrThreeWay a -> ThreeWay a +toThreeWay x TwoOrThreeWay {alice, bob, lca} = + ThreeWay {alice, bob, lca = fromMaybe x lca} diff --git a/unison-merge/unison-merge.cabal b/unison-merge/unison-merge.cabal index f4e1d4d6c6..91d98ef5f7 100644 --- a/unison-merge/unison-merge.cabal +++ b/unison-merge/unison-merge.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0. +-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack @@ -26,6 +26,7 @@ library Unison.Merge.EitherWayI Unison.Merge.FindConflictedAlias Unison.Merge.HumanDiffOp + Unison.Merge.Internal.Types Unison.Merge.Libdeps Unison.Merge.Mergeblob0 Unison.Merge.Mergeblob1 From c7fc1b9aea576e0af1724b0a3b0870d9a947fd69 Mon Sep 17 00:00:00 2001 From: Mitchell Dalvi Rosen Date: Wed, 29 Jan 2025 15:50:30 -0500 Subject: [PATCH 22/44] add instance Applicative TwoOrThreeWay --- unison-merge/src/Unison/Merge/Internal/Types.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/unison-merge/src/Unison/Merge/Internal/Types.hs b/unison-merge/src/Unison/Merge/Internal/Types.hs index 5d1a39e646..d1c29ebb01 100644 --- a/unison-merge/src/Unison/Merge/Internal/Types.hs +++ b/unison-merge/src/Unison/Merge/Internal/Types.hs @@ -49,3 +49,12 @@ data TwoOrThreeWay a = TwoOrThreeWay bob :: a } deriving stock (Foldable, Functor, Generic, Traversable) + +instance Applicative TwoOrThreeWay where + pure :: a -> TwoOrThreeWay a + pure x = + TwoOrThreeWay (Just x) x x + + (<*>) :: TwoOrThreeWay (a -> b) -> TwoOrThreeWay a -> TwoOrThreeWay b + TwoOrThreeWay f g h <*> TwoOrThreeWay x y z = + TwoOrThreeWay (f <*> x) (g y) (h z) From 9b944fdf57d3f938f528fd4b5f2b209ca9a8b5bb Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 29 Jan 2025 12:50:38 -0800 Subject: [PATCH 23/44] Switch to use Vectors --- unison-cli/src/Unison/Share/SyncV2.hs | 88 +++++++++++++++++---------- 1 file changed, 57 insertions(+), 31 deletions(-) diff --git a/unison-cli/src/Unison/Share/SyncV2.hs b/unison-cli/src/Unison/Share/SyncV2.hs index af1da5d72b..baa014564d 100644 --- a/unison-cli/src/Unison/Share/SyncV2.hs +++ b/unison-cli/src/Unison/Share/SyncV2.hs @@ -24,6 +24,7 @@ import Data.ByteString.Lazy qualified as BL import Data.Conduit.Attoparsec qualified as C import Data.Conduit.List qualified as C import Data.Conduit.Zlib qualified as C +import Data.Foldable qualified as Foldable import Data.Graph qualified as Graph import Data.Map qualified as Map import Data.Proxy @@ -31,6 +32,8 @@ import Data.Set qualified as Set import Data.Text.IO qualified as Text import Data.Text.Lazy qualified as Text.Lazy import Data.Text.Lazy.Encoding qualified as Text.Lazy +import Data.Vector (Vector) +import Data.Vector qualified as Vector import Network.HTTP.Client qualified as Http.Client import Network.HTTP.Types qualified as HTTP import Servant.API qualified as Servant @@ -162,7 +165,7 @@ syncFromCodeserver shouldValidate unisonShareUrl branchRef hashJwt knownHashes _ ------------------------------------------------------------------------------------------------------------------------ -- | Validate that the provided entities match their expected hashes, and if so, save them to the codebase. -validateAndSave :: Bool -> (Codebase.Codebase IO v a) -> [(Hash32, TempEntity)] -> StreamM () +validateAndSave :: Bool -> (Codebase.Codebase IO v a) -> Vector (Hash32, TempEntity) -> StreamM () validateAndSave shouldValidate codebase entities = do let validateEntities = runExceptT $ when shouldValidate (batchValidateEntities entities) @@ -175,25 +178,25 @@ validateAndSave shouldValidate codebase entities = do lift (Sqlite.unsafeIO (IO.wait validationTask)) >>= \case Left err -> throwError err Right _ -> pure () - where - batchValidateEntities :: [(Hash32, TempEntity)] -> ExceptT SyncErr IO () - batchValidateEntities entities = do - mismatches <- fmap catMaybes $ liftIO $ IO.pooledForConcurrently entities \(hash, entity) -> do - IO.evaluate $ EV.validateTempEntity hash entity - for_ mismatches \case - err@(Share.EntityHashMismatch et (Share.HashMismatchForEntity {supplied, computed})) -> - let expectedMismatches = case et of - Share.TermComponentType -> expectedComponentHashMismatches - Share.DeclComponentType -> expectedComponentHashMismatches - Share.CausalType -> expectedCausalHashMismatches - _ -> mempty - in case Map.lookup supplied expectedMismatches of - Just expected - | expected == computed -> pure () - _ -> do - throwError . SyncError . SyncV2.PullError'DownloadEntities . SyncV2.DownloadEntitiesEntityValidationFailure $ err - err -> do - throwError . SyncError . SyncV2.PullError'DownloadEntities . SyncV2.DownloadEntitiesEntityValidationFailure $ err + +batchValidateEntities :: Vector (Hash32, TempEntity) -> ExceptT SyncErr IO () +batchValidateEntities entities = do + mismatches <- fmap Vector.catMaybes $ liftIO $ IO.pooledForConcurrently entities \(hash, entity) -> do + IO.evaluate $ EV.validateTempEntity hash entity + for_ mismatches \case + err@(Share.EntityHashMismatch et (Share.HashMismatchForEntity {supplied, computed})) -> + let expectedMismatches = case et of + Share.TermComponentType -> expectedComponentHashMismatches + Share.DeclComponentType -> expectedComponentHashMismatches + Share.CausalType -> expectedCausalHashMismatches + _ -> mempty + in case Map.lookup supplied expectedMismatches of + Just expected + | expected == computed -> pure () + _ -> do + throwError . SyncError . SyncV2.PullError'DownloadEntities . SyncV2.DownloadEntitiesEntityValidationFailure $ err + err -> do + throwError . SyncError . SyncV2.PullError'DownloadEntities . SyncV2.DownloadEntitiesEntityValidationFailure $ err -- | Syncs a stream which could send entities in any order. syncUnsortedStream :: @@ -202,10 +205,17 @@ syncUnsortedStream :: Stream () SyncV2.EntityChunk -> StreamM () syncUnsortedStream shouldValidate codebase stream = do - allResults <- C.runConduit $ stream C..| C.sinkList - allEntities <- ExceptT $ Timing.time "Unpacking chunks" $ liftIO $ Codebase.runTransactionExceptT codebase $ do unpackChunks allResults + allEntities <- C.runConduit $ stream C..| C.chunksOf batchSize C..| unpackChunks codebase C..| validateBatch C..| C.concat C..| C.sinkVector @Vector let sortedEntities = sortDependencyFirst allEntities - validateAndSave shouldValidate codebase sortedEntities + liftIO $ withEntitySavingCallback (Just $ Vector.length allEntities) \countC -> do + Codebase.runTransaction codebase $ for_ sortedEntities \(hash, entity) -> do + r <- Q.saveTempEntityInMain v2HashHandle hash entity + Sqlite.unsafeIO $ countC 1 + pure r + where + validateBatch :: Stream (Vector (Hash32, TempEntity)) (Vector (Hash32, TempEntity)) + validateBatch = C.iterM \entities -> do + when shouldValidate (mapExceptT lift $ batchValidateEntities entities) -- | Syncs a stream which sends entities which are already sorted in dependency order. syncSortedStream :: @@ -214,17 +224,16 @@ syncSortedStream :: Stream () SyncV2.EntityChunk -> StreamM () syncSortedStream shouldValidate codebase stream = do - let handler :: Stream [SyncV2.EntityChunk] o - handler = C.mapM_C \chunkBatch -> do - entityBatch <- mapExceptT lift . ExceptT $ Codebase.runTransactionExceptT codebase do unpackChunks chunkBatch + let handler :: Stream (Vector (Hash32, TempEntity)) o + handler = C.mapM_C \entityBatch -> do validateAndSave shouldValidate codebase entityBatch - C.runConduit $ stream C..| C.chunksOf batchSize C..| handler + C.runConduit $ stream C..| C.chunksOf batchSize C..| unpackChunks codebase C..| handler -- | Topologically sort entities based on their dependencies. -sortDependencyFirst :: [(Hash32, TempEntity)] -> [(Hash32, TempEntity)] +sortDependencyFirst :: (Foldable f, Functor f) => f (Hash32, TempEntity) -> [(Hash32, TempEntity)] sortDependencyFirst entities = do let adjList = entities <&> \(hash32, entity) -> ((hash32, entity), hash32, Set.toList $ Share.entityDependencies (tempEntityToEntity entity)) - (graph, vertexInfo, _vertexForKey) = Graph.graphFromEdges adjList + (graph, vertexInfo, _vertexForKey) = Graph.graphFromEdges (Foldable.toList adjList) in Graph.reverseTopSort graph <&> \v -> (view _1 $ vertexInfo v) -- | Unpack a single entity chunk, returning the entity if it's not already in the codebase, Nothing otherwise. @@ -243,10 +252,11 @@ unpackChunk = \case Left err -> do throwError $ (SyncError . SyncV2.PullError'Sync $ SyncV2.SyncErrorDeserializationFailure err) Right entity -> pure entity -unpackChunks :: [SyncV2.EntityChunk] -> ExceptT SyncErr Sqlite.Transaction [(Hash32, TempEntity)] -unpackChunks xs = do +unpackChunks :: Codebase.Codebase IO v a -> Stream [SyncV2.EntityChunk] (Vector (Hash32, TempEntity)) +unpackChunks codebase = C.mapM \xs -> ExceptT . lift . Codebase.runTransactionExceptT codebase $ do for xs unpackChunk <&> catMaybes + <&> Vector.fromList streamIntoCodebase :: Bool -> Codebase.Codebase IO v a -> SyncV2.StreamInitInfo -> Stream () SyncV2.EntityChunk -> StreamM () streamIntoCodebase shouldValidate codebase SyncV2.StreamInitInfo {version, entitySorting, numEntities = numEntities} stream = ExceptT do @@ -504,6 +514,22 @@ withStreamProgressCallback total action = do liftIO $ IO.atomically (IO.modifyTVar' entitiesDownloadedVar (+ 1)) C.yield i +withEntitySavingCallback :: (MonadUnliftIO m) => Maybe Int -> ((Int -> m ()) -> m a) -> m a +withEntitySavingCallback total action = do + counterVar <- IO.newTVarIO (0 :: Int) + IO.withRunInIO \toIO -> do + Console.Regions.displayConsoleRegions do + Console.Regions.withConsoleRegion Console.Regions.Linear \region -> do + Console.Regions.setConsoleRegion region do + processed <- IO.readTVar counterVar + pure $ + "\n Saved " + <> tShow processed + <> maybe "" (\total -> " / " <> tShow total) total + <> " entities...\n\n" + toIO $ action $ \i -> do + liftIO $ IO.atomically (IO.modifyTVar' counterVar (+ i)) + withEntityLoadingCallback :: (MonadUnliftIO m) => ((Int -> m ()) -> m a) -> m a withEntityLoadingCallback action = do counterVar <- IO.newTVarIO (0 :: Int) From 4c31e90ecdf16b72bba15ec41eaeb74505287c9d Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 30 Jan 2025 10:16:32 -0800 Subject: [PATCH 24/44] Revert Queries module to trunk --- .../U/Codebase/Sqlite/Queries.hs | 92 +++++++------------ .../sql/001-temp-entity-tables.sql | 3 +- 2 files changed, 33 insertions(+), 62 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 1e3d1eef5a..043fd697c7 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -229,7 +229,6 @@ module U.Codebase.Sqlite.Queries expectEntity, syncToTempEntity, insertTempEntity, - insertTempEntityV2, saveTempEntityInMain, expectTempEntity, deleteTempEntity, @@ -318,7 +317,6 @@ import Data.Map.NonEmpty qualified as NEMap import Data.Maybe qualified as Maybe import Data.Sequence qualified as Seq import Data.Set qualified as Set -import Data.Set.NonEmpty (NESet) import Data.Text qualified as Text import Data.Text.Encoding qualified as Text import Data.Text.Lazy qualified as Text.Lazy @@ -540,18 +538,23 @@ countWatches = queryOneCol [sql| SELECT COUNT(*) FROM watch |] saveHash :: Hash32 -> Transaction HashId saveHash hash = do - loadHashId hash >>= \case - Just h -> pure h - Nothing -> do - queryOneCol - [sql| - INSERT INTO hash (base32) VALUES (:hash) - RETURNING id - |] + execute + [sql| + INSERT INTO hash (base32) VALUES (:hash) + ON CONFLICT DO NOTHING + |] + expectHashId hash saveHashes :: Traversable f => f Hash32 -> Transaction (f HashId) saveHashes hashes = do - for hashes saveHash + for_ hashes \hash -> + execute + [sql| + INSERT INTO hash (base32) + VALUES (:hash) + ON CONFLICT DO NOTHING + |] + traverse expectHashId hashes saveHashHash :: Hash -> Transaction HashId saveHashHash = saveHash . Hash32.fromHash @@ -626,15 +629,13 @@ expectBranchHashForCausalHash ch = do saveText :: Text -> Transaction TextId saveText t = do - loadTextId t >>= \case - Just h -> pure h - Nothing -> do - queryOneCol - [sql| - INSERT INTO text (text) - VALUES (:t) - RETURNING id - |] + execute + [sql| + INSERT INTO text (text) + VALUES (:t) + ON CONFLICT DO NOTHING + |] + expectTextId t saveTexts :: Traversable f => f Text -> Transaction (f TextId) saveTexts = @@ -691,7 +692,7 @@ saveObject :: ObjectType -> ByteString -> Transaction ObjectId -saveObject _hh h t blob = do +saveObject hh h t blob = do execute [sql| INSERT INTO object (primary_hash_id, type_id, bytes) @@ -702,9 +703,9 @@ saveObject _hh h t blob = do saveHashObject h oId 2 -- todo: remove this from here, and add it to other relevant places once there are v1 and v2 hashes rowsModified >>= \case 0 -> pure () - _ -> pure () - -- hash <- expectHash32 h - -- tryMoveTempEntityDependents hh hash + _ -> do + hash <- expectHash32 h + tryMoveTempEntityDependents hh hash pure oId expectObject :: SqliteExceptionReason e => ObjectId -> (ByteString -> Either e a) -> Transaction a @@ -962,7 +963,7 @@ saveCausal :: BranchHashId -> [CausalHashId] -> Transaction () -saveCausal _hh self value parents = do +saveCausal hh self value parents = do execute [sql| INSERT INTO causal (self_hash_id, value_hash_id) @@ -978,15 +979,15 @@ saveCausal _hh self value parents = do INSERT INTO causal_parent (causal_id, parent_id) VALUES (:self, :parent) |] - -- flushCausalDependents hh self + flushCausalDependents hh self -_flushCausalDependents :: +flushCausalDependents :: HashHandle -> CausalHashId -> Transaction () -_flushCausalDependents hh chId = do +flushCausalDependents hh chId = do hash <- expectHash32 (unCausalHashId chId) - _tryMoveTempEntityDependents hh hash + tryMoveTempEntityDependents hh hash -- | `tryMoveTempEntityDependents #foo` does this: -- 0. Precondition: We just inserted object #foo. @@ -994,11 +995,11 @@ _flushCausalDependents hh chId = do -- 2. Delete #foo as dependency from temp_entity_missing_dependency. e.g. (#bar, #foo), (#baz, #foo) -- 3. For each like #bar and #baz with no more rows in temp_entity_missing_dependency, -- insert_entity them. -_tryMoveTempEntityDependents :: +tryMoveTempEntityDependents :: HashHandle -> Hash32 -> Transaction () -_tryMoveTempEntityDependents hh dependency = do +tryMoveTempEntityDependents hh dependency = do dependents <- queryListCol [sql| @@ -2972,35 +2973,6 @@ insertTempEntity entityHash entity missingDependencies = do entityType = Entity.entityType entity --- | Insert a new `temp_entity` row, and its associated 1+ `temp_entity_missing_dependency` rows. --- --- Preconditions: --- 1. The entity does not already exist in "main" storage (`object` / `causal`) --- 2. The entity does not already exist in `temp_entity`. -insertTempEntityV2 :: Hash32 -> TempEntity -> NESet Hash32 -> Transaction () -insertTempEntityV2 entityHash entity missingDependencies = do - execute - [sql| - INSERT INTO temp_entity (hash, blob, type_id) - VALUES (:entityHash, :entityBlob, :entityType) - ON CONFLICT DO NOTHING - |] - - for_ missingDependencies \depHash -> - execute - [sql| - INSERT INTO temp_entity_missing_dependency (dependent, dependency) - VALUES (:entityHash, :depHash) - |] - where - entityBlob :: ByteString - entityBlob = - runPutS (Serialization.putTempEntity entity) - - entityType :: TempEntityType - entityType = - Entity.entityType entity - -- | Delete a row from the `temp_entity` table, if it exists. deleteTempEntity :: Hash32 -> Transaction () deleteTempEntity hash = diff --git a/codebase2/codebase-sqlite/sql/001-temp-entity-tables.sql b/codebase2/codebase-sqlite/sql/001-temp-entity-tables.sql index 6651d4a6fe..0ae13812b1 100644 --- a/codebase2/codebase-sqlite/sql/001-temp-entity-tables.sql +++ b/codebase2/codebase-sqlite/sql/001-temp-entity-tables.sql @@ -56,8 +56,7 @@ create table if not exists temp_entity ( create table if not exists temp_entity_missing_dependency ( dependent text not null references temp_entity(hash), dependency text not null, - -- TODO: this is just for testing - dependencyJwt text null, + dependencyJwt text not null, unique (dependent, dependency) ); create index if not exists temp_entity_missing_dependency_ix_dependent on temp_entity_missing_dependency (dependent); From f2b3422a7e5ee29d3ec36916d67a1d31f061dd89 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 30 Jan 2025 10:20:44 -0800 Subject: [PATCH 25/44] Remove unused BailT Monad --- lib/unison-sqlite/unison-sqlite.cabal | 1 - unison-cli/src/Unison/Share/Sync/Util.hs | 42 ------------------------ unison-cli/unison-cli.cabal | 1 - 3 files changed, 44 deletions(-) delete mode 100644 unison-cli/src/Unison/Share/Sync/Util.hs diff --git a/lib/unison-sqlite/unison-sqlite.cabal b/lib/unison-sqlite/unison-sqlite.cabal index 13a9eb27cd..3db0980a7c 100644 --- a/lib/unison-sqlite/unison-sqlite.cabal +++ b/lib/unison-sqlite/unison-sqlite.cabal @@ -65,7 +65,6 @@ library ghc-options: -Wall build-depends: base - , containers , direct-sqlite , megaparsec , pretty-simple diff --git a/unison-cli/src/Unison/Share/Sync/Util.hs b/unison-cli/src/Unison/Share/Sync/Util.hs deleted file mode 100644 index 39eeb2cede..0000000000 --- a/unison-cli/src/Unison/Share/Sync/Util.hs +++ /dev/null @@ -1,42 +0,0 @@ -module Unison.Share.Sync.Util - ( BailT (..), - MonadBail (..), - runBailT, - mapBailT, - withError, - ) -where - -import Control.Monad.Reader (MonadReader (..), ReaderT (..), mapReaderT, withReaderT) -import Data.Data (Typeable) -import UnliftIO qualified as IO - -newtype Handler e = Handler {runHandler :: forall x. e -> IO x} - -newtype BailT e m a = BailT {unErrGroupT :: ReaderT (Handler e) m a} - deriving newtype (Functor, Applicative, Monad, IO.MonadUnliftIO, IO.MonadIO) - -newtype ExceptionWrapper e = ExceptionWrapper {unException :: e} - -instance Show (ExceptionWrapper e) where - show (ExceptionWrapper _) = "ExceptionWrapper<>" - -instance (Typeable e) => IO.Exception (ExceptionWrapper e) - -class MonadBail e m where - bail :: e -> m a - -mapBailT :: (Monad n) => (m a -> n b) -> BailT e m a -> BailT e n b -mapBailT f (BailT m) = BailT $ mapReaderT f $ m - -withError :: (Monad m) => (e' -> e) -> BailT e' m a -> BailT e m a -withError f (BailT m) = BailT $ withReaderT (\h -> Handler $ runHandler h . f) m - -instance (IO.MonadUnliftIO m, Typeable e) => MonadBail e (BailT e m) where - bail e = do - handler <- BailT ask - BailT $ IO.liftIO $ runHandler handler e - -runBailT :: (IO.MonadUnliftIO m, Typeable e) => BailT e m a -> (e -> m a) -> m a -runBailT (BailT m) handler = do - IO.handle (handler . unException) $ runReaderT m (Handler (IO.throwIO . ExceptionWrapper)) diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index 543bc2d5c3..8a40ecd6e4 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -153,7 +153,6 @@ library Unison.Share.ExpectedHashMismatches Unison.Share.Sync Unison.Share.Sync.Types - Unison.Share.Sync.Util Unison.Share.SyncV2 Unison.Util.HTTP Unison.Version From dadd5e88d8d1c1a01e9fa485db7c2f062a5476cd Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 30 Jan 2025 10:26:07 -0800 Subject: [PATCH 26/44] Remove cruft --- unison-cli/src/Unison/Cli/DownloadUtils.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/unison-cli/src/Unison/Cli/DownloadUtils.hs b/unison-cli/src/Unison/Cli/DownloadUtils.hs index 0772eda44c..50e89dd354 100644 --- a/unison-cli/src/Unison/Cli/DownloadUtils.hs +++ b/unison-cli/src/Unison/Cli/DownloadUtils.hs @@ -66,7 +66,6 @@ downloadProjectBranchFromShare syncVersion useSquashed branch = Share.TransportError err -> Output.ShareErrorTransport err Cli.respond (Output.DownloadedEntities numDownloaded) SyncV2 -> do - -- Cli.with withEntitiesDownloadedProgressCallback \(downloadedCallback, getNumDownloaded) -> do let branchRef = SyncV2.BranchRef (into @Text (ProjectAndBranch branch.projectName remoteProjectBranchName)) -- TODO: Fill this in. let knownHashes = Set.empty From bdb2ecda0049539657acf5542e41cc90ab3285b4 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 30 Jan 2025 10:40:16 -0800 Subject: [PATCH 27/44] Reduce code duplication in progress counters --- lib/unison-sqlite/unison-sqlite.cabal | 1 + unison-cli/src/Unison/Share/SyncV2.hs | 112 ++++++++++++++------------ 2 files changed, 61 insertions(+), 52 deletions(-) diff --git a/lib/unison-sqlite/unison-sqlite.cabal b/lib/unison-sqlite/unison-sqlite.cabal index 3db0980a7c..13a9eb27cd 100644 --- a/lib/unison-sqlite/unison-sqlite.cabal +++ b/lib/unison-sqlite/unison-sqlite.cabal @@ -65,6 +65,7 @@ library ghc-options: -Wall build-depends: base + , containers , direct-sqlite , megaparsec , pretty-simple diff --git a/unison-cli/src/Unison/Share/SyncV2.hs b/unison-cli/src/Unison/Share/SyncV2.hs index baa014564d..37f0720723 100644 --- a/unison-cli/src/Unison/Share/SyncV2.hs +++ b/unison-cli/src/Unison/Share/SyncV2.hs @@ -89,8 +89,11 @@ batchSize = 5000 -- | Sync a given causal hash and its dependencies to a sync-file. syncToFile :: Codebase.Codebase IO v a -> + -- | Root hash to sync CausalHash -> + -- | Optional name of the branch begin synced Maybe SyncV2.BranchRef -> + -- | Location of the sync-file FilePath -> IO (Either SyncErr ()) syncToFile codebase rootHash mayBranchRef destFilePath = do @@ -98,9 +101,15 @@ syncToFile codebase rootHash mayBranchRef destFilePath = do C.runResourceT $ withCodebaseEntityStream conn rootHash mayBranchRef \mayTotal stream -> do withStreamProgressCallback (Just mayTotal) \countC -> runExceptT do - C.runConduit $ stream C..| countC C..| C.map (BL.toStrict . CBOR.serialise) C..| C.transPipe liftIO C.gzip C..| C.sinkFile destFilePath + C.runConduit $ + stream + C..| countC + C..| C.map (BL.toStrict . CBOR.serialise) + C..| C.transPipe liftIO C.gzip + C..| C.sinkFile destFilePath syncFromFile :: + -- | Whether to validate entities as they're imported. Bool -> -- | Location of the sync-file FilePath -> @@ -179,6 +188,7 @@ validateAndSave shouldValidate codebase entities = do Left err -> throwError err Right _ -> pure () +-- | Validate that a batch of entities matches the hashes they're keyed by, throwing an error if any of them fail validation. batchValidateEntities :: Vector (Hash32, TempEntity) -> ExceptT SyncErr IO () batchValidateEntities entities = do mismatches <- fmap Vector.catMaybes $ liftIO $ IO.pooledForConcurrently entities \(hash, entity) -> do @@ -205,7 +215,14 @@ syncUnsortedStream :: Stream () SyncV2.EntityChunk -> StreamM () syncUnsortedStream shouldValidate codebase stream = do - allEntities <- C.runConduit $ stream C..| C.chunksOf batchSize C..| unpackChunks codebase C..| validateBatch C..| C.concat C..| C.sinkVector @Vector + allEntities <- + C.runConduit $ + stream + C..| C.chunksOf batchSize + C..| unpackChunks codebase + C..| validateBatch + C..| C.concat + C..| C.sinkVector @Vector let sortedEntities = sortDependencyFirst allEntities liftIO $ withEntitySavingCallback (Just $ Vector.length allEntities) \countC -> do Codebase.runTransaction codebase $ for_ sortedEntities \(hash, entity) -> do @@ -218,6 +235,7 @@ syncUnsortedStream shouldValidate codebase stream = do when shouldValidate (mapExceptT lift $ batchValidateEntities entities) -- | Syncs a stream which sends entities which are already sorted in dependency order. +-- This allows us to stream them directly into the codebase as they're received. syncSortedStream :: Bool -> (Codebase.Codebase IO v a) -> @@ -227,9 +245,13 @@ syncSortedStream shouldValidate codebase stream = do let handler :: Stream (Vector (Hash32, TempEntity)) o handler = C.mapM_C \entityBatch -> do validateAndSave shouldValidate codebase entityBatch - C.runConduit $ stream C..| C.chunksOf batchSize C..| unpackChunks codebase C..| handler + C.runConduit $ + stream + C..| C.chunksOf batchSize + C..| unpackChunks codebase + C..| handler --- | Topologically sort entities based on their dependencies. +-- | Topologically sort entities based on their dependencies, returning a list in dependency-first order. sortDependencyFirst :: (Foldable f, Functor f) => f (Hash32, TempEntity) -> [(Hash32, TempEntity)] sortDependencyFirst entities = do let adjList = entities <&> \(hash32, entity) -> ((hash32, entity), hash32, Set.toList $ Share.entityDependencies (tempEntityToEntity entity)) @@ -258,9 +280,17 @@ unpackChunks codebase = C.mapM \xs -> ExceptT . lift . Codebase.runTransactionEx <&> catMaybes <&> Vector.fromList -streamIntoCodebase :: Bool -> Codebase.Codebase IO v a -> SyncV2.StreamInitInfo -> Stream () SyncV2.EntityChunk -> StreamM () +-- | Stream entities from one codebase into another. +streamIntoCodebase :: + -- | Whether to validate entities as they're imported. + Bool -> + Codebase.Codebase IO v a -> + SyncV2.StreamInitInfo -> + Stream () SyncV2.EntityChunk -> + StreamM () streamIntoCodebase shouldValidate codebase SyncV2.StreamInitInfo {version, entitySorting, numEntities = numEntities} stream = ExceptT do withStreamProgressCallback (fromIntegral <$> numEntities) \countC -> runExceptT do + -- Add a counter to the stream to track how many entities we've processed. let stream' = stream C..| countC case version of (SyncV2.Version 1) -> pure () @@ -270,7 +300,7 @@ streamIntoCodebase shouldValidate codebase SyncV2.StreamInitInfo {version, entit SyncV2.DependenciesFirst -> syncSortedStream shouldValidate codebase stream' SyncV2.Unsorted -> syncUnsortedStream shouldValidate codebase stream' --- | Verify that the hash we expected to import from the stream was successfully loaded into the codebase. +-- | A sanity-check to verify that the hash we expected to import from the stream was successfully loaded into the codebase. afterSyncChecks :: Codebase.Codebase IO v a -> Hash32 -> ExceptT (SyncError SyncV2.PullError) IO () afterSyncChecks codebase hash = do lift (didCausalSuccessfullyImport codebase hash) >>= \case @@ -285,12 +315,13 @@ afterSyncChecks codebase hash = do let expectedHash = hash32ToCausalHash hash isJust <$> (Codebase.runTransaction codebase $ Q.loadCausalByCausalHash expectedHash) --- | Load and stream entities for a given causal hash from a codebase. +-- | Load and stream entities for a given causal hash from a codebase into a stream. withCodebaseEntityStream :: (MonadIO m) => Sqlite.Connection -> CausalHash -> Maybe SyncV2.BranchRef -> + -- | Callback to call with the total count of entities and the stream. (Int -> Stream () SyncV2.DownloadEntitiesChunk -> m r) -> m r withCodebaseEntityStream conn rootHash mayBranchRef callback = do @@ -353,7 +384,7 @@ _decodeFramedEntity bs = do Left err -> throwError . SyncError . SyncV2.PullError'Sync $ SyncV2.SyncErrorDeserializationFailure err Right chunk -> pure chunk --- Expects a stream of tightly-packed CBOR entities without any framing/separators. +-- | Unpacks a stream of tightly-packed CBOR entities without any framing/separators. decodeUnframedEntities :: Stream ByteString SyncV2.DownloadEntitiesChunk decodeUnframedEntities = C.transPipe (mapExceptT (lift . stToIO)) $ do C.await >>= \case @@ -414,12 +445,6 @@ SyncV2.Routes { downloadEntitiesStream = downloadEntitiesStreamClientM } = Servant.client syncAPI --- -- | Helper for running clientM that returns a stream of entities. --- -- You MUST consume the stream within the callback, it will be closed when the callback returns. --- handleStream :: forall m o. (MonadUnliftIO m) => Servant.ClientEnv -> (o -> m ()) -> Servant.ClientM (Servant.SourceIO o) -> m (Either CodeserverTransportError ()) --- handleStream clientEnv callback clientM = do --- handleSourceT clientEnv (SourceT.foreach (throwError . StreamingError . Text.pack) callback) clientM - -- | Helper for running clientM that returns a stream of entities. -- You MUST consume the stream within the callback, it will be closed when the callback returns. withConduit :: forall r. Servant.ClientEnv -> (Stream () SyncV2.DownloadEntitiesChunk -> StreamM r) -> Servant.ClientM (Servant.SourceIO SyncV2.DownloadEntitiesChunk) -> StreamM r @@ -449,6 +474,7 @@ handleClientError clientEnv err = Servant.InvalidContentTypeHeader resp -> UnexpectedResponse resp Servant.ConnectionError _ -> UnreachableCodeserver (Servant.baseUrl clientEnv) +-- | Stream entities from the codeserver. httpStreamEntities :: forall. Auth.AuthenticatedHttpClient -> @@ -496,51 +522,33 @@ initializeStream stream = do -- Progress Tracking ------------------------------------------------------------------------------------------------------------------------ --- Provide the given action a callback that display to the terminal. -withStreamProgressCallback :: (MonadIO m, MonadUnliftIO n) => Maybe Int -> (ConduitT i i m () -> n a) -> n a -withStreamProgressCallback total action = do - entitiesDownloadedVar <- IO.newTVarIO (0 :: Int) - IO.withRunInIO \toIO -> do - Console.Regions.displayConsoleRegions do - Console.Regions.withConsoleRegion Console.Regions.Linear \region -> do - Console.Regions.setConsoleRegion region do - entitiesDownloaded <- IO.readTVar entitiesDownloadedVar - pure $ - "\n Processed " - <> tShow entitiesDownloaded - <> maybe "" (\total -> " / " <> tShow total) total - <> " entities...\n\n" - toIO $ action $ C.awaitForever \i -> do - liftIO $ IO.atomically (IO.modifyTVar' entitiesDownloadedVar (+ 1)) - C.yield i - -withEntitySavingCallback :: (MonadUnliftIO m) => Maybe Int -> ((Int -> m ()) -> m a) -> m a -withEntitySavingCallback total action = do +counterProgress :: (MonadIO m, MonadUnliftIO n) => (Int -> Text) -> ((Int -> m ()) -> n a) -> n a +counterProgress msgBuilder action = do counterVar <- IO.newTVarIO (0 :: Int) IO.withRunInIO \toIO -> do Console.Regions.displayConsoleRegions do Console.Regions.withConsoleRegion Console.Regions.Linear \region -> do Console.Regions.setConsoleRegion region do - processed <- IO.readTVar counterVar - pure $ - "\n Saved " - <> tShow processed - <> maybe "" (\total -> " / " <> tShow total) total - <> " entities...\n\n" + num <- IO.readTVar counterVar + pure $ msgBuilder num toIO $ action $ \i -> do liftIO $ IO.atomically (IO.modifyTVar' counterVar (+ i)) +-- | Track how many entities have been downloaded using a counter stream. +withStreamProgressCallback :: (MonadIO m, MonadUnliftIO n) => Maybe Int -> (ConduitT i i m () -> n a) -> n a +withStreamProgressCallback total action = do + let msg n = "\n Processed " <> tShow n <> maybe "" (\total -> " / " <> tShow total) total <> " entities...\n\n" + let action' f = action (C.iterM \_i -> f 1) + counterProgress msg action' + +-- | Track how many entities have been saved. +withEntitySavingCallback :: (MonadUnliftIO m) => Maybe Int -> ((Int -> m ()) -> m a) -> m a +withEntitySavingCallback total action = do + let msg n = "\n Saved " <> tShow n <> maybe "" (\total -> " / " <> tShow total) total <> " entities...\n\n" + counterProgress msg action + +-- | Track how many entities have been loaded. withEntityLoadingCallback :: (MonadUnliftIO m) => ((Int -> m ()) -> m a) -> m a withEntityLoadingCallback action = do - counterVar <- IO.newTVarIO (0 :: Int) - IO.withRunInIO \toIO -> do - Console.Regions.displayConsoleRegions do - Console.Regions.withConsoleRegion Console.Regions.Linear \region -> do - Console.Regions.setConsoleRegion region do - processed <- IO.readTVar counterVar - pure $ - "\n Loading " - <> tShow processed - <> " entities...\n\n" - toIO $ action $ \i -> do - liftIO $ IO.atomically (IO.modifyTVar' counterVar (+ i)) + let msg n = "\n Loading " <> tShow n <> " entities...\n\n" + counterProgress msg action From 55fd99bb712359afdab3d35bf56f266e4bd6f4f8 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 30 Jan 2025 11:22:27 -0800 Subject: [PATCH 28/44] Hide pull.v2 --- unison-cli/src/Unison/CommandLine/InputPatterns.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index f8ab98c53e..c17759e418 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -1792,7 +1792,9 @@ pull = pullV2 :: InputPattern pullV2 = - pullImpl "pull.v2" [] Input.PullWithHistory "" Input.SyncV2 + (pullImpl "pull.v2" [] Input.PullWithHistory "" Input.SyncV2) + {I.visibility = I.Hidden + } pullWithoutHistory :: InputPattern pullWithoutHistory = From 89c7a680daf393f36578b7401899b341f060f9bc Mon Sep 17 00:00:00 2001 From: Mitchell Dalvi Rosen Date: Mon, 3 Feb 2025 12:08:52 -0500 Subject: [PATCH 29/44] expose two-way libdeps diffs in mergeblob --- unison-merge/src/Unison/Merge/Libdeps.hs | 50 ++++++++++----------- unison-merge/src/Unison/Merge/Mergeblob1.hs | 16 +++---- 2 files changed, 33 insertions(+), 33 deletions(-) diff --git a/unison-merge/src/Unison/Merge/Libdeps.hs b/unison-merge/src/Unison/Merge/Libdeps.hs index ec0b9899d4..ff580a7b9b 100644 --- a/unison-merge/src/Unison/Merge/Libdeps.hs +++ b/unison-merge/src/Unison/Merge/Libdeps.hs @@ -2,6 +2,7 @@ module Unison.Merge.Libdeps ( LibdepDiffOp (..), diffLibdeps, + mergeLibdepsDiffs, applyLibdepsDiff, getTwoFreshLibdepNames, ) @@ -15,6 +16,7 @@ import Data.These (These (..)) import Unison.Merge.DiffOp (DiffOp (..)) import Unison.Merge.EitherWay qualified as EitherWay import Unison.Merge.ThreeWay (ThreeWay (..)) +import Unison.Merge.ThreeWay qualified as ThreeWay import Unison.Merge.TwoDiffOps (TwoDiffOps (..)) import Unison.Merge.TwoDiffOps qualified as TwoDiffOps import Unison.Merge.TwoWay (TwoWay (..)) @@ -33,45 +35,43 @@ data LibdepDiffOp a | AddBothLibdeps !a !a | DeleteLibdep --- | Perform a three-way diff on two collections of library dependencies. +-- | Perform two two-way diffs on two collections of library dependencies. This is only half of a three-way diff: use +-- 'mergeLibdepsDiffs' to complete it. diffLibdeps :: + forall k v. (Ord k, Eq v) => -- | Library dependencies. ThreeWay (Map k v) -> - -- | Library dependencies diff. - Map k (LibdepDiffOp v) + -- | Library dependencies diffs. + TwoWay (Map k (DiffOp v)) diffLibdeps libdeps = - mergeDiffs (twoWayDiff libdeps.lca libdeps.alice) (twoWayDiff libdeps.lca libdeps.bob) - --- `twoWayDiff old new` computes a diff between old thing `old` and new thing `new`. --- --- Values present in `old` but not `new` are tagged as "deleted"; similar for "added" and "updated". -twoWayDiff :: (Ord k, Eq v) => Map k v -> Map k v -> Map k (DiffOp v) -twoWayDiff = - Map.merge - (Map.mapMissing \_ -> DiffOp'Delete) - (Map.mapMissing \_ -> DiffOp'Add) - ( Map.zipWithMaybeMatched \_ old new -> - if old == new - then Nothing - else Just (DiffOp'Update Updated {old, new}) - ) + f <$> ThreeWay.forgetLca libdeps + where + f :: Map k v -> Map k (DiffOp v) + f = + Map.merge + (Map.mapMissing \_ -> DiffOp'Delete) + (Map.mapMissing \_ -> DiffOp'Add) + ( Map.zipWithMaybeMatched \_ old new -> + if old == new + then Nothing + else Just (DiffOp'Update Updated {old, new}) + ) + libdeps.lca -- Merge two library dependency diffs together: -- -- * Keep all adds/updates (allowing conflicts as necessary, which will be resolved later) -- * Ignore deletes that only one party makes (because the other party may expect the dep to still be there) -mergeDiffs :: +mergeLibdepsDiffs :: forall k v. (Ord k, Eq v) => - -- The LCA->Alice library dependencies diff. - Map k (DiffOp v) -> - -- The LCA->Bob library dependencies diff. - Map k (DiffOp v) -> + -- The LCA->Alice and LCA->Bob library dependencies diffs. + TwoWay (Map k (DiffOp v)) -> -- The merged library dependencies diff. Map k (LibdepDiffOp v) -mergeDiffs alice bob = - catMaybes (alignWith combineDiffOps alice bob) +mergeLibdepsDiffs diffs = + catMaybes (alignWith combineDiffOps diffs.alice diffs.bob) combineDiffOps :: (Eq a) => These (DiffOp a) (DiffOp a) -> Maybe (LibdepDiffOp a) combineDiffOps = diff --git a/unison-merge/src/Unison/Merge/Mergeblob1.hs b/unison-merge/src/Unison/Merge/Mergeblob1.hs index 085af71eb0..df86ed9f7d 100644 --- a/unison-merge/src/Unison/Merge/Mergeblob1.hs +++ b/unison-merge/src/Unison/Merge/Mergeblob1.hs @@ -20,7 +20,7 @@ import Unison.Merge.Diff (humanizeDiffs, nameBasedNamespaceDiff) import Unison.Merge.DiffOp (DiffOp) import Unison.Merge.EitherWay (EitherWay (..)) import Unison.Merge.HumanDiffOp (HumanDiffOp) -import Unison.Merge.Libdeps (LibdepDiffOp, applyLibdepsDiff, diffLibdeps, getTwoFreshLibdepNames) +import Unison.Merge.Libdeps (applyLibdepsDiff, diffLibdeps, getTwoFreshLibdepNames, mergeLibdepsDiffs) import Unison.Merge.Mergeblob0 (Mergeblob0 (..)) import Unison.Merge.PartialDeclNameLookup (PartialDeclNameLookup) import Unison.Merge.PartitionCombinedDiffs (partitionCombinedDiffs) @@ -63,9 +63,9 @@ data Mergeblob1 libdep = Mergeblob1 (TypeReferenceId, Decl Symbol Ann) ), lcaDeclNameLookup :: PartialDeclNameLookup, - libdeps :: Map NameSegment libdep, - libdepsDiff :: Map NameSegment (LibdepDiffOp libdep), lcaLibdeps :: Map NameSegment libdep, + libdeps :: Map NameSegment libdep, + libdepsDiffs :: TwoWay (Map NameSegment (DiffOp libdep)), unconflicts :: DefnsF Unconflicts Referent TypeReference } @@ -163,13 +163,13 @@ makeMergeblob1 blob names3 hydratedDefns = do partitionCombinedDiffs (ThreeWay.forgetLca blob.defns) declNameLookups diff -- Diff and merge libdeps - let libdepsDiff :: Map NameSegment (LibdepDiffOp libdep) - libdepsDiff = + let libdepsDiffs :: TwoWay (Map NameSegment (DiffOp libdep)) + libdepsDiffs = diffLibdeps blob.libdeps let libdeps :: Map NameSegment libdep libdeps = - applyLibdepsDiff getTwoFreshLibdepNames blob.libdeps libdepsDiff + applyLibdepsDiff getTwoFreshLibdepNames blob.libdeps (mergeLibdepsDiffs libdepsDiffs) pure Mergeblob1 @@ -181,8 +181,8 @@ makeMergeblob1 blob names3 hydratedDefns = do humanDiffsFromLCA, hydratedDefns, lcaDeclNameLookup, - libdeps, - libdepsDiff, lcaLibdeps = blob.libdeps.lca, + libdeps, + libdepsDiffs, unconflicts } From 0a202a318b36e75c835ff5073efd20d0040bf408 Mon Sep 17 00:00:00 2001 From: Mitchell Dalvi Rosen Date: Mon, 3 Feb 2025 18:57:02 -0500 Subject: [PATCH 30/44] derive Foldable, Traversable for DiffOp, Updated --- unison-merge/src/Unison/Merge/DiffOp.hs | 2 +- unison-merge/src/Unison/Merge/Updated.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/unison-merge/src/Unison/Merge/DiffOp.hs b/unison-merge/src/Unison/Merge/DiffOp.hs index db980f480b..9a17b3031f 100644 --- a/unison-merge/src/Unison/Merge/DiffOp.hs +++ b/unison-merge/src/Unison/Merge/DiffOp.hs @@ -14,4 +14,4 @@ data DiffOp a = DiffOp'Add !a | DiffOp'Delete !a | DiffOp'Update !(Updated a) - deriving stock (Functor, Show) + deriving stock (Foldable, Functor, Show, Traversable) diff --git a/unison-merge/src/Unison/Merge/Updated.hs b/unison-merge/src/Unison/Merge/Updated.hs index 00b64ed98b..6dd5fc41b8 100644 --- a/unison-merge/src/Unison/Merge/Updated.hs +++ b/unison-merge/src/Unison/Merge/Updated.hs @@ -10,4 +10,4 @@ data Updated a = Updated { old :: a, new :: a } - deriving stock (Functor, Generic, Show) + deriving stock (Foldable, Functor, Generic, Show, Traversable) From b87bbbbe9697d2fef4b1f7f5e61e1b5d54dff4de Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 31 Jan 2025 11:04:49 -0800 Subject: [PATCH 31/44] Switch to unframed entities --- unison-cli/src/Unison/Share/SyncV2.hs | 10 +++++++--- unison-share-api/src/Unison/SyncV2/API.hs | 2 +- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/unison-cli/src/Unison/Share/SyncV2.hs b/unison-cli/src/Unison/Share/SyncV2.hs index 37f0720723..8f9768a7e0 100644 --- a/unison-cli/src/Unison/Share/SyncV2.hs +++ b/unison-cli/src/Unison/Share/SyncV2.hs @@ -440,21 +440,25 @@ type SyncAPI = ("ucm" Servant.:> "v2" Servant.:> "sync" Servant.:> SyncV2.API) syncAPI :: Proxy SyncAPI syncAPI = Proxy @SyncAPI -downloadEntitiesStreamClientM :: SyncV2.DownloadEntitiesRequest -> Servant.ClientM (Servant.SourceT IO SyncV2.DownloadEntitiesChunk) +downloadEntitiesStreamClientM :: SyncV2.DownloadEntitiesRequest -> Servant.ClientM (Servant.SourceT IO (CBORBytes SyncV2.DownloadEntitiesChunk)) SyncV2.Routes { downloadEntitiesStream = downloadEntitiesStreamClientM } = Servant.client syncAPI -- | Helper for running clientM that returns a stream of entities. -- You MUST consume the stream within the callback, it will be closed when the callback returns. -withConduit :: forall r. Servant.ClientEnv -> (Stream () SyncV2.DownloadEntitiesChunk -> StreamM r) -> Servant.ClientM (Servant.SourceIO SyncV2.DownloadEntitiesChunk) -> StreamM r +withConduit :: forall r. Servant.ClientEnv -> (Stream () (SyncV2.DownloadEntitiesChunk) -> StreamM r) -> Servant.ClientM (Servant.SourceIO (CBORBytes SyncV2.DownloadEntitiesChunk)) -> StreamM r withConduit clientEnv callback clientM = do ExceptT $ withRunInIO \runInIO -> do Servant.withClientM clientM clientEnv $ \case Left err -> pure . Left . TransportError $ (handleClientError clientEnv err) Right sourceT -> do conduit <- liftIO $ Servant.fromSourceIO sourceT - (runInIO . runExceptT $ callback conduit) + (runInIO . runExceptT $ callback (conduit C..| unpackCBORBytesStream)) + +unpackCBORBytesStream :: Stream (CBORBytes SyncV2.DownloadEntitiesChunk) SyncV2.DownloadEntitiesChunk +unpackCBORBytesStream = + C.map (BL.toStrict . coerce @_ @BL.ByteString) C..| decodeUnframedEntities handleClientError :: Servant.ClientEnv -> Servant.ClientError -> CodeserverTransportError handleClientError clientEnv err = diff --git a/unison-share-api/src/Unison/SyncV2/API.hs b/unison-share-api/src/Unison/SyncV2/API.hs index 71ea8693d3..ae575c1885 100644 --- a/unison-share-api/src/Unison/SyncV2/API.hs +++ b/unison-share-api/src/Unison/SyncV2/API.hs @@ -21,7 +21,7 @@ type API = NamedRoutes Routes type DownloadEntitiesStream = -- | The causal hash the client needs. The server should provide it and all of its dependencies ReqBody '[CBOR, JSON] DownloadEntitiesRequest - :> StreamPost NetstringFraming CBOR (SourceIO DownloadEntitiesChunk) + :> StreamPost NoFraming CBOR (SourceIO (CBORBytes DownloadEntitiesChunk)) data Routes mode = Routes { downloadEntitiesStream :: mode :- "entities" :> "download" :> DownloadEntitiesStream From d71506318bd3d0e658533bb2bce8f4e8dd071b32 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 31 Jan 2025 12:32:08 -0800 Subject: [PATCH 32/44] Add dedicated CBORStream type --- unison-cli/src/Unison/Share/SyncV2.hs | 8 ++++---- unison-share-api/src/Unison/SyncV2/API.hs | 2 +- unison-share-api/src/Unison/SyncV2/Types.hs | 1 + unison-share-api/src/Unison/Util/Servant/CBOR.hs | 12 ++++++++++++ 4 files changed, 18 insertions(+), 5 deletions(-) diff --git a/unison-cli/src/Unison/Share/SyncV2.hs b/unison-cli/src/Unison/Share/SyncV2.hs index 8f9768a7e0..d4e64e9cce 100644 --- a/unison-cli/src/Unison/Share/SyncV2.hs +++ b/unison-cli/src/Unison/Share/SyncV2.hs @@ -62,7 +62,7 @@ import Unison.Sync.Types qualified as Share import Unison.Sync.Types qualified as Sync import Unison.SyncV2.API (Routes (downloadEntitiesStream)) import Unison.SyncV2.API qualified as SyncV2 -import Unison.SyncV2.Types (CBORBytes) +import Unison.SyncV2.Types (CBORBytes, CBORStream) import Unison.SyncV2.Types qualified as SyncV2 import Unison.Util.Servant.CBOR qualified as CBOR import Unison.Util.Timing qualified as Timing @@ -440,14 +440,14 @@ type SyncAPI = ("ucm" Servant.:> "v2" Servant.:> "sync" Servant.:> SyncV2.API) syncAPI :: Proxy SyncAPI syncAPI = Proxy @SyncAPI -downloadEntitiesStreamClientM :: SyncV2.DownloadEntitiesRequest -> Servant.ClientM (Servant.SourceT IO (CBORBytes SyncV2.DownloadEntitiesChunk)) +downloadEntitiesStreamClientM :: SyncV2.DownloadEntitiesRequest -> Servant.ClientM (Servant.SourceT IO (CBORStream SyncV2.DownloadEntitiesChunk)) SyncV2.Routes { downloadEntitiesStream = downloadEntitiesStreamClientM } = Servant.client syncAPI -- | Helper for running clientM that returns a stream of entities. -- You MUST consume the stream within the callback, it will be closed when the callback returns. -withConduit :: forall r. Servant.ClientEnv -> (Stream () (SyncV2.DownloadEntitiesChunk) -> StreamM r) -> Servant.ClientM (Servant.SourceIO (CBORBytes SyncV2.DownloadEntitiesChunk)) -> StreamM r +withConduit :: forall r. Servant.ClientEnv -> (Stream () (SyncV2.DownloadEntitiesChunk) -> StreamM r) -> Servant.ClientM (Servant.SourceIO (CBORStream SyncV2.DownloadEntitiesChunk)) -> StreamM r withConduit clientEnv callback clientM = do ExceptT $ withRunInIO \runInIO -> do Servant.withClientM clientM clientEnv $ \case @@ -456,7 +456,7 @@ withConduit clientEnv callback clientM = do conduit <- liftIO $ Servant.fromSourceIO sourceT (runInIO . runExceptT $ callback (conduit C..| unpackCBORBytesStream)) -unpackCBORBytesStream :: Stream (CBORBytes SyncV2.DownloadEntitiesChunk) SyncV2.DownloadEntitiesChunk +unpackCBORBytesStream :: Stream (CBORStream SyncV2.DownloadEntitiesChunk) SyncV2.DownloadEntitiesChunk unpackCBORBytesStream = C.map (BL.toStrict . coerce @_ @BL.ByteString) C..| decodeUnframedEntities diff --git a/unison-share-api/src/Unison/SyncV2/API.hs b/unison-share-api/src/Unison/SyncV2/API.hs index ae575c1885..4aec0e6b54 100644 --- a/unison-share-api/src/Unison/SyncV2/API.hs +++ b/unison-share-api/src/Unison/SyncV2/API.hs @@ -21,7 +21,7 @@ type API = NamedRoutes Routes type DownloadEntitiesStream = -- | The causal hash the client needs. The server should provide it and all of its dependencies ReqBody '[CBOR, JSON] DownloadEntitiesRequest - :> StreamPost NoFraming CBOR (SourceIO (CBORBytes DownloadEntitiesChunk)) + :> StreamPost NoFraming OctetStream (SourceIO (CBORStream DownloadEntitiesChunk)) data Routes mode = Routes { downloadEntitiesStream :: mode :- "entities" :> "download" :> DownloadEntitiesStream diff --git a/unison-share-api/src/Unison/SyncV2/Types.hs b/unison-share-api/src/Unison/SyncV2/Types.hs index 80272de8ab..c2935110d9 100644 --- a/unison-share-api/src/Unison/SyncV2/Types.hs +++ b/unison-share-api/src/Unison/SyncV2/Types.hs @@ -7,6 +7,7 @@ module Unison.SyncV2.Types SyncError (..), DownloadEntitiesError (..), CBORBytes (..), + CBORStream(..), EntityKind (..), serialiseCBORBytes, deserialiseOrFailCBORBytes, diff --git a/unison-share-api/src/Unison/Util/Servant/CBOR.hs b/unison-share-api/src/Unison/Util/Servant/CBOR.hs index 18fd94904c..580b1a7124 100644 --- a/unison-share-api/src/Unison/Util/Servant/CBOR.hs +++ b/unison-share-api/src/Unison/Util/Servant/CBOR.hs @@ -5,6 +5,7 @@ module Unison.Util.Servant.CBOR ( CBOR, UnknownCBORBytes, CBORBytes (..), + CBORStream (..), deserialiseOrFailCBORBytes, serialiseCBORBytes, decodeCBORBytes, @@ -86,3 +87,14 @@ serialiseUnknownCBORBytes = CBORBytes . CBOR.serialise data Unknown type UnknownCBORBytes = CBORBytes Unknown + +-- | Wrapper for a stream of CBOR data. Each chunk may not be a complete CBOR value, but the concatenation of all the chunks is a valid CBOR stream. +newtype CBORStream a = CBORStream BL.ByteString + deriving (Serialise) via (BL.ByteString) + deriving (Eq, Show, Ord) + +instance MimeRender OctetStream (CBORStream a) where + mimeRender Proxy (CBORStream bs) = bs + +instance MimeUnrender OctetStream (CBORStream a) where + mimeUnrender Proxy bs = Right (CBORStream bs) From 67f04ee74745723dccf98ba9d11b8bfa2e57ce51 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 4 Feb 2025 10:28:25 -0800 Subject: [PATCH 33/44] Make timestamps for last-accessed sub-second, (and set on creation) and fix transcript order --- .../U/Codebase/Sqlite/Queries.hs | 6 +- .../idempotent/api-list-projects-branches.md | 10 +-- .../api-list-projects-branches.output.md | 74 +++++++++++++++++++ 3 files changed, 81 insertions(+), 9 deletions(-) create mode 100644 unison-src/transcripts/idempotent/api-list-projects-branches.output.md diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 043fd697c7..3d94e12f2f 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -3839,8 +3839,8 @@ insertProjectBranch description causalHashId (ProjectBranch projectId branchId b execute [sql| - INSERT INTO project_branch (project_id, branch_id, name, causal_hash_id) - VALUES (:projectId, :branchId, :branchName, :causalHashId) + INSERT INTO project_branch (project_id, branch_id, name, causal_hash_id, last_accessed) + VALUES (:projectId, :branchId, :branchName, :causalHashId, strftime('%s', 'now', 'subsec')) |] whenJust maybeParentBranchId \parentBranchId -> execute @@ -4478,7 +4478,7 @@ setCurrentProjectPath projId branchId path = do execute [sql| UPDATE project_branch - SET last_accessed = strftime('%s', 'now') + SET last_accessed = strftime('%s', 'now', 'subsec') WHERE project_id = :projId AND branch_id = :branchId |] diff --git a/unison-src/transcripts/idempotent/api-list-projects-branches.md b/unison-src/transcripts/idempotent/api-list-projects-branches.md index 2f3bc28b22..0599cbf799 100644 --- a/unison-src/transcripts/idempotent/api-list-projects-branches.md +++ b/unison-src/transcripts/idempotent/api-list-projects-branches.md @@ -8,17 +8,15 @@ lump many of those together. Doing it this way ensures both the creation timesta the same direction so we don't end up with flaky non-deterministic tests. ``` ucm :hide -scratch/main> project.create-empty project-cherry +project-apple/main> project.create-empty project-cherry -scratch/main> project.create-empty project-banana - -scratch/main> project.create-empty project-apple +project-apple/main> project.create-empty project-banana project-apple/main> branch a-branch-cherry -project-apple/main> branch a-branch-banana +project-apple/a-branch-cherry> branch a-branch-banana -project-apple/main> branch a-branch-apple +project-apple/a-branch-banana> branch a-branch-apple ``` ``` api diff --git a/unison-src/transcripts/idempotent/api-list-projects-branches.output.md b/unison-src/transcripts/idempotent/api-list-projects-branches.output.md new file mode 100644 index 0000000000..0599cbf799 --- /dev/null +++ b/unison-src/transcripts/idempotent/api-list-projects-branches.output.md @@ -0,0 +1,74 @@ +# List Projects And Branches Test + +I create projects and branches in reverse alphabetical order, and starting with `z` +to place them after `main` alphabetically. +This is because the results from the listing endpoints is sorted by (timestamp, name); but +the default sqlite timestamp only has second-level precision and the transcript will sometimes +lump many of those together. Doing it this way ensures both the creation timestamp and name sort +the same direction so we don't end up with flaky non-deterministic tests. + +``` ucm :hide +project-apple/main> project.create-empty project-cherry + +project-apple/main> project.create-empty project-banana + +project-apple/main> branch a-branch-cherry + +project-apple/a-branch-cherry> branch a-branch-banana + +project-apple/a-branch-banana> branch a-branch-apple +``` + +``` api +-- Should list all projects +GET /api/projects + [ + { + "activeBranchRef": "a-branch-apple", + "projectName": "project-apple" + }, + { + "activeBranchRef": "main", + "projectName": "project-banana" + }, + { + "activeBranchRef": "main", + "projectName": "project-cherry" + }, + { + "activeBranchRef": "main", + "projectName": "scratch" + } + ] +-- Can query for some infix of the project name +GET /api/projects?query=bana + [ + { + "activeBranchRef": "main", + "projectName": "project-banana" + } + ] +-- Should list all branches +GET /api/projects/project-apple/branches + [ + { + "branchName": "a-branch-apple" + }, + { + "branchName": "a-branch-banana" + }, + { + "branchName": "a-branch-cherry" + }, + { + "branchName": "main" + } + ] +-- Can query for some infix of the project name +GET /api/projects/project-apple/branches?query=bana + [ + { + "branchName": "a-branch-banana" + } + ] +``` From df68cc62e917a6c46339db490b886420c475f432 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 4 Feb 2025 11:24:02 -0800 Subject: [PATCH 34/44] Clean up error reporting --- unison-cli/src/Unison/Cli/DownloadUtils.hs | 6 ++---- unison-cli/src/Unison/Codebase/Editor/Output.hs | 1 + unison-cli/src/Unison/CommandLine/OutputMessages.hs | 1 + 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/unison-cli/src/Unison/Cli/DownloadUtils.hs b/unison-cli/src/Unison/Cli/DownloadUtils.hs index 50e89dd354..5cae49f49c 100644 --- a/unison-cli/src/Unison/Cli/DownloadUtils.hs +++ b/unison-cli/src/Unison/Cli/DownloadUtils.hs @@ -74,10 +74,8 @@ downloadProjectBranchFromShare syncVersion useSquashed branch = result <- SyncV2.syncFromCodeserver shouldValidate Share.hardCodedBaseUrl branchRef causalHashJwt knownHashes downloadedCallback result & onLeft \err0 -> do done case err0 of - Share.SyncError err -> - -- TODO: Fix this - error (show err) - -- Output.ShareErrorDownloadEntities err + Share.SyncError pullErr -> + Output.ShareErrorPullV2 pullErr Share.TransportError err -> Output.ShareErrorTransport err pure (Sync.Common.hash32ToCausalHash (Share.hashJWTHash causalHashJwt)) diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index 2519967aed..b3a7f1cc60 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -475,6 +475,7 @@ data ShareError = ShareErrorDownloadEntities Share.DownloadEntitiesError | ShareErrorGetCausalHashByPath Sync.GetCausalHashByPathError | ShareErrorPull Sync.PullError + | ShareErrorPullV2 SyncV2.PullError | ShareErrorTransport Sync.CodeserverTransportError | ShareErrorUploadEntities Share.UploadEntitiesError | ShareExpectedSquashedHead diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 95dda95cf9..2d61f2b9ab 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -2291,6 +2291,7 @@ prettyShareError = ShareErrorDownloadEntities err -> prettyDownloadEntitiesError err ShareErrorGetCausalHashByPath err -> prettyGetCausalHashByPathError err ShareErrorPull err -> prettyPullError err + ShareErrorPullV2 err -> prettyPullV2Error err ShareErrorTransport err -> prettyTransportError err ShareErrorUploadEntities err -> prettyUploadEntitiesError err ShareExpectedSquashedHead -> "The server failed to provide a squashed branch head when requested. Please report this as a bug to the Unison team." From 18299ba656c858f0fbd2a8670c12300f2f7b0827 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 4 Feb 2025 11:54:43 -0800 Subject: [PATCH 35/44] Rename progress markers --- unison-cli/src/Unison/Share/SyncV2.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/unison-cli/src/Unison/Share/SyncV2.hs b/unison-cli/src/Unison/Share/SyncV2.hs index d4e64e9cce..ec65a4ca13 100644 --- a/unison-cli/src/Unison/Share/SyncV2.hs +++ b/unison-cli/src/Unison/Share/SyncV2.hs @@ -541,18 +541,18 @@ counterProgress msgBuilder action = do -- | Track how many entities have been downloaded using a counter stream. withStreamProgressCallback :: (MonadIO m, MonadUnliftIO n) => Maybe Int -> (ConduitT i i m () -> n a) -> n a withStreamProgressCallback total action = do - let msg n = "\n Processed " <> tShow n <> maybe "" (\total -> " / " <> tShow total) total <> " entities...\n\n" + let msg n = "\n 📦 Unpacked " <> tShow n <> maybe "" (\total -> " / " <> tShow total) total <> " entities...\n\n" let action' f = action (C.iterM \_i -> f 1) counterProgress msg action' -- | Track how many entities have been saved. withEntitySavingCallback :: (MonadUnliftIO m) => Maybe Int -> ((Int -> m ()) -> m a) -> m a withEntitySavingCallback total action = do - let msg n = "\n Saved " <> tShow n <> maybe "" (\total -> " / " <> tShow total) total <> " entities...\n\n" + let msg n = "\n 💾 Saved " <> tShow n <> maybe "" (\total -> " / " <> tShow total) total <> " new entities...\n\n" counterProgress msg action -- | Track how many entities have been loaded. withEntityLoadingCallback :: (MonadUnliftIO m) => ((Int -> m ()) -> m a) -> m a withEntityLoadingCallback action = do - let msg n = "\n Loading " <> tShow n <> " entities...\n\n" + let msg n = "\n 📦 Unpacked " <> tShow n <> " entities...\n\n" counterProgress msg action From 2c234cb9b286c4504fd534f897293e26b3e93f92 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 28 Jan 2025 15:27:46 -0800 Subject: [PATCH 36/44] Add API and implementation for negotiating which causals to sync --- unison-cli/src/Unison/Share/SyncV2.hs | 68 ++++++++++++++++++--- unison-share-api/src/Unison/SyncV2/API.hs | 8 ++- unison-share-api/src/Unison/SyncV2/Types.hs | 58 ++++++++++++++++++ 3 files changed, 126 insertions(+), 8 deletions(-) diff --git a/unison-cli/src/Unison/Share/SyncV2.hs b/unison-cli/src/Unison/Share/SyncV2.hs index ec65a4ca13..8f297d2bea 100644 --- a/unison-cli/src/Unison/Share/SyncV2.hs +++ b/unison-cli/src/Unison/Share/SyncV2.hs @@ -22,7 +22,8 @@ import Data.Attoparsec.ByteString.Char8 qualified as A8 import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as BL import Data.Conduit.Attoparsec qualified as C -import Data.Conduit.List qualified as C +import Data.Conduit.Combinators qualified as C +import Data.Conduit.List qualified as CL import Data.Conduit.Zlib qualified as C import Data.Foldable qualified as Foldable import Data.Graph qualified as Graph @@ -148,13 +149,13 @@ syncFromCodeserver :: SyncV2.BranchRef -> -- | The hash to download. Share.HashJWT -> - Set Hash32 -> -- | Callback that's given a number of entities we just downloaded. (Int -> IO ()) -> Cli (Either (SyncError SyncV2.PullError) ()) -syncFromCodeserver shouldValidate unisonShareUrl branchRef hashJwt knownHashes _downloadedCallback = do +syncFromCodeserver shouldValidate unisonShareUrl branchRef hashJwt _downloadedCallback = do Cli.Env {authHTTPClient, codebase} <- ask runExceptT do + knownHashes <- ExceptT $ negotiateKnownCausals unisonShareUrl branchRef hashJwt let hash = Share.hashJWTHash hashJwt ExceptT $ do (Cli.runTransaction (Q.entityLocation hash)) >>= \case @@ -247,7 +248,7 @@ syncSortedStream shouldValidate codebase stream = do validateAndSave shouldValidate codebase entityBatch C.runConduit $ stream - C..| C.chunksOf batchSize + C..| CL.chunksOf batchSize C..| unpackChunks codebase C..| handler @@ -441,13 +442,15 @@ syncAPI :: Proxy SyncAPI syncAPI = Proxy @SyncAPI downloadEntitiesStreamClientM :: SyncV2.DownloadEntitiesRequest -> Servant.ClientM (Servant.SourceT IO (CBORStream SyncV2.DownloadEntitiesChunk)) +causalDependenciesStreamClientM :: SyncV2.CausalDependenciesRequest -> Servant.ClientM (Servant.SourceT IO (CBORStream SyncV2.CausalDependenciesChunk)) SyncV2.Routes - { downloadEntitiesStream = downloadEntitiesStreamClientM + { downloadEntitiesStream = downloadEntitiesStreamClientM, + causalDependenciesStream = causalDependenciesStreamClientM } = Servant.client syncAPI -- | Helper for running clientM that returns a stream of entities. -- You MUST consume the stream within the callback, it will be closed when the callback returns. -withConduit :: forall r. Servant.ClientEnv -> (Stream () (SyncV2.DownloadEntitiesChunk) -> StreamM r) -> Servant.ClientM (Servant.SourceIO (CBORStream SyncV2.DownloadEntitiesChunk)) -> StreamM r +withConduit :: forall r chunk. Servant.ClientEnv -> (Stream () chunk -> StreamM r) -> Servant.ClientM (Servant.SourceIO (CBORStream chunk)) -> StreamM r withConduit clientEnv callback clientM = do ExceptT $ withRunInIO \runInIO -> do Servant.withClientM clientM clientEnv $ \case @@ -480,7 +483,6 @@ handleClientError clientEnv err = -- | Stream entities from the codeserver. httpStreamEntities :: - forall. Auth.AuthenticatedHttpClient -> Servant.BaseUrl -> SyncV2.DownloadEntitiesRequest -> @@ -522,6 +524,58 @@ initializeStream stream = do SyncV2.ErrorC (SyncV2.ErrorChunk err) -> throwError . SyncError $ SyncV2.PullError'DownloadEntities err SyncV2.InitialC {} -> throwError . SyncError $ SyncV2.PullError'Sync SyncV2.SyncErrorMisplacedInitialChunk +------------------------------------------------------------------------------------------------------------------------ +-- Causal Dependency negotiation +------------------------------------------------------------------------------------------------------------------------ + +httpStreamCausalDependencies :: + forall r. + Auth.AuthenticatedHttpClient -> + Servant.BaseUrl -> + SyncV2.CausalDependenciesRequest -> + (Stream () SyncV2.CausalDependenciesChunk -> StreamM r) -> + StreamM r +httpStreamCausalDependencies (Auth.AuthenticatedHttpClient httpClient) unisonShareUrl req callback = do + let clientEnv = + (Servant.mkClientEnv httpClient unisonShareUrl) + { Servant.makeClientRequest = \url request -> + -- Disable client-side timeouts + (Servant.defaultMakeClientRequest url request) + <&> \r -> + r + { Http.Client.responseTimeout = Http.Client.responseTimeoutNone + } + } + (causalDependenciesStreamClientM req) & withConduit clientEnv callback + +-- | Ask Share for the dependencies of a given hash jwt, +-- then filter them to get the set of causals which we have and don't need sent. +negotiateKnownCausals :: + -- | The Unison Share URL. + Servant.BaseUrl -> + -- | The branch to download from. + SyncV2.BranchRef -> + -- | The hash to download. + Share.HashJWT -> + Cli (Either (SyncError SyncV2.PullError) (Set Hash32)) +negotiateKnownCausals unisonShareUrl branchRef hashJwt = do + Cli.Env {authHTTPClient, codebase} <- ask + Timing.time "Causal Negotiation" $ do + liftIO . C.runResourceT . runExceptT $ httpStreamCausalDependencies + authHTTPClient + unisonShareUrl + SyncV2.CausalDependenciesRequest {branchRef, rootCausal = hashJwt} + \stream -> do + Set.fromList <$> C.runConduit (stream C..| C.map unpack C..| C.filterM (haveCausalHash codebase) C..| C.sinkList) + where + unpack :: SyncV2.CausalDependenciesChunk -> Hash32 + unpack = \case + SyncV2.HashC causalHash -> causalHash + haveCausalHash :: Codebase.Codebase IO v a -> Hash32 -> StreamM Bool + haveCausalHash codebase causalHash = do + liftIO $ Codebase.runTransaction codebase do + Q.causalExistsByHash32 causalHash + ------------------------------------------------------------------------------------------------------------------------ -- Progress Tracking ------------------------------------------------------------------------------------------------------------------------ diff --git a/unison-share-api/src/Unison/SyncV2/API.hs b/unison-share-api/src/Unison/SyncV2/API.hs index 4aec0e6b54..b4ed916475 100644 --- a/unison-share-api/src/Unison/SyncV2/API.hs +++ b/unison-share-api/src/Unison/SyncV2/API.hs @@ -23,7 +23,13 @@ type DownloadEntitiesStream = ReqBody '[CBOR, JSON] DownloadEntitiesRequest :> StreamPost NoFraming OctetStream (SourceIO (CBORStream DownloadEntitiesChunk)) +-- | Get the relevant dependencies of a causal, including the causal spine and the causal hashes of any library roots. +type CausalDependenciesStream = + ReqBody '[CBOR, JSON] CausalDependenciesRequest + :> StreamPost NetstringFraming CBOR (SourceIO CausalDependenciesChunk) + data Routes mode = Routes - { downloadEntitiesStream :: mode :- "entities" :> "download" :> DownloadEntitiesStream + { downloadEntitiesStream :: mode :- "entities" :> "download" :> DownloadEntitiesStream, + causalDependenciesStream :: mode :- "entities" :> "dependencies" :> CausalDependenciesStream } deriving stock (Generic) diff --git a/unison-share-api/src/Unison/SyncV2/Types.hs b/unison-share-api/src/Unison/SyncV2/Types.hs index c2935110d9..9868b9c441 100644 --- a/unison-share-api/src/Unison/SyncV2/Types.hs +++ b/unison-share-api/src/Unison/SyncV2/Types.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE RecordWildCards #-} + module Unison.SyncV2.Types ( DownloadEntitiesRequest (..), DownloadEntitiesChunk (..), @@ -6,6 +8,8 @@ module Unison.SyncV2.Types StreamInitInfo (..), SyncError (..), DownloadEntitiesError (..), + CausalDependenciesRequest (..), + CausalDependenciesChunk (..), CBORBytes (..), CBORStream(..), EntityKind (..), @@ -24,6 +28,7 @@ import Codec.Serialise qualified as CBOR import Codec.Serialise.Decoding qualified as CBOR import Control.Exception (Exception) import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.=)) +import Data.Aeson qualified as Aeson import Data.Map (Map) import Data.Map qualified as Map import Data.Set (Set) @@ -299,3 +304,56 @@ instance Serialise EntityKind where 3 -> pure TypeEntity 4 -> pure PatchEntity _ -> fail "invalid tag" + +------------------------------------------------------------------------------------------------------------------------ +-- Causal Dependencies + +data CausalDependenciesRequest = CausalDependenciesRequest + { branchRef :: BranchRef, + rootCausal :: HashJWT + } + deriving stock (Show, Eq, Ord) + +instance ToJSON CausalDependenciesRequest where + toJSON (CausalDependenciesRequest branchRef rootCausal) = + object + [ "branch_ref" .= branchRef, + "root_causal" .= rootCausal + ] + +instance FromJSON CausalDependenciesRequest where + parseJSON = Aeson.withObject "CausalDependenciesRequest" \obj -> do + branchRef <- obj .: "branch_ref" + rootCausal <- obj .: "root_causal" + pure CausalDependenciesRequest {..} + +instance Serialise CausalDependenciesRequest where + encode (CausalDependenciesRequest {branchRef, rootCausal}) = + encode branchRef <> encode rootCausal + decode = CausalDependenciesRequest <$> decode <*> decode + +-- | A chunk of the download entities response stream. +data CausalDependenciesChunk + = HashC Hash32 + deriving (Show, Eq, Ord) + +data CausalDependenciesChunkTag = HashChunkTag + deriving (Show, Eq, Ord) + +instance Serialise CausalDependenciesChunkTag where + encode = \case + HashChunkTag -> CBOR.encodeWord8 0 + decode = do + tag <- CBOR.decodeWord8 + case tag of + 0 -> pure HashChunkTag + _ -> fail "invalid tag" + +instance Serialise CausalDependenciesChunk where + encode = \case + (HashC ch) -> do + encode HashChunkTag <> CBOR.encode ch + decode = do + tag <- decode + case tag of + HashChunkTag -> HashC <$> CBOR.decode From 32aae20f59c09ff21aa2484b9440384bd8accc53 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 30 Jan 2025 11:43:54 -0800 Subject: [PATCH 37/44] Get building --- unison-cli/src/Unison/Cli/DownloadUtils.hs | 5 +---- unison-cli/src/Unison/Share/SyncV2.hs | 2 +- 2 files changed, 2 insertions(+), 5 deletions(-) diff --git a/unison-cli/src/Unison/Cli/DownloadUtils.hs b/unison-cli/src/Unison/Cli/DownloadUtils.hs index 5cae49f49c..68c21dc6a2 100644 --- a/unison-cli/src/Unison/Cli/DownloadUtils.hs +++ b/unison-cli/src/Unison/Cli/DownloadUtils.hs @@ -11,7 +11,6 @@ where import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TVar (modifyTVar', newTVarIO, readTVar, readTVarIO) import Data.List.NonEmpty (pattern (:|)) -import Data.Set qualified as Set import System.Console.Regions qualified as Console.Regions import U.Codebase.HashTags (CausalHash) import U.Codebase.Sqlite.Queries qualified as Queries @@ -67,11 +66,9 @@ downloadProjectBranchFromShare syncVersion useSquashed branch = Cli.respond (Output.DownloadedEntities numDownloaded) SyncV2 -> do let branchRef = SyncV2.BranchRef (into @Text (ProjectAndBranch branch.projectName remoteProjectBranchName)) - -- TODO: Fill this in. - let knownHashes = Set.empty let downloadedCallback = \_ -> pure () let shouldValidate = not $ Codeserver.isCustomCodeserver Codeserver.defaultCodeserver - result <- SyncV2.syncFromCodeserver shouldValidate Share.hardCodedBaseUrl branchRef causalHashJwt knownHashes downloadedCallback + result <- SyncV2.syncFromCodeserver shouldValidate Share.hardCodedBaseUrl branchRef causalHashJwt downloadedCallback result & onLeft \err0 -> do done case err0 of Share.SyncError pullErr -> diff --git a/unison-cli/src/Unison/Share/SyncV2.hs b/unison-cli/src/Unison/Share/SyncV2.hs index 8f297d2bea..5c6fdba7c7 100644 --- a/unison-cli/src/Unison/Share/SyncV2.hs +++ b/unison-cli/src/Unison/Share/SyncV2.hs @@ -219,7 +219,7 @@ syncUnsortedStream shouldValidate codebase stream = do allEntities <- C.runConduit $ stream - C..| C.chunksOf batchSize + C..| CL.chunksOf batchSize C..| unpackChunks codebase C..| validateBatch C..| C.concat From 3e7f26342cd9e9776a1c746d42c5b2d47591956c Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 31 Jan 2025 13:56:27 -0800 Subject: [PATCH 38/44] Switch causal dependency stream to CBORStream --- unison-cli/src/Unison/Share/SyncV2.hs | 12 +++--- unison-share-api/src/Unison/SyncV2/API.hs | 2 +- unison-share-api/src/Unison/SyncV2/Types.hs | 45 +++++++++++++++++---- 3 files changed, 44 insertions(+), 15 deletions(-) diff --git a/unison-cli/src/Unison/Share/SyncV2.hs b/unison-cli/src/Unison/Share/SyncV2.hs index 5c6fdba7c7..4eda9ac8d9 100644 --- a/unison-cli/src/Unison/Share/SyncV2.hs +++ b/unison-cli/src/Unison/Share/SyncV2.hs @@ -386,7 +386,7 @@ _decodeFramedEntity bs = do Right chunk -> pure chunk -- | Unpacks a stream of tightly-packed CBOR entities without any framing/separators. -decodeUnframedEntities :: Stream ByteString SyncV2.DownloadEntitiesChunk +decodeUnframedEntities :: forall a. (CBOR.Serialise a) => Stream ByteString a decodeUnframedEntities = C.transPipe (mapExceptT (lift . stToIO)) $ do C.await >>= \case Nothing -> pure () @@ -394,13 +394,13 @@ decodeUnframedEntities = C.transPipe (mapExceptT (lift . stToIO)) $ do d <- newDecoder loop bs d where - newDecoder :: ConduitT ByteString SyncV2.DownloadEntitiesChunk (ExceptT SyncErr (ST s)) (Maybe ByteString -> ST s (CBOR.IDecode s (SyncV2.DownloadEntitiesChunk))) + newDecoder :: ConduitT ByteString a (ExceptT SyncErr (ST s)) (Maybe ByteString -> ST s (CBOR.IDecode s a)) newDecoder = do (lift . lift) CBOR.deserialiseIncremental >>= \case CBOR.Done _ _ _ -> throwError . SyncError . SyncV2.PullError'Sync $ SyncV2.SyncErrorStreamFailure "Invalid initial decoder" CBOR.Fail _ _ err -> throwError . SyncError . SyncV2.PullError'Sync $ SyncV2.SyncErrorDeserializationFailure err CBOR.Partial k -> pure k - loop :: ByteString -> (Maybe ByteString -> ST s (CBOR.IDecode s (SyncV2.DownloadEntitiesChunk))) -> ConduitT ByteString SyncV2.DownloadEntitiesChunk (ExceptT SyncErr (ST s)) () + loop :: ByteString -> (Maybe ByteString -> ST s (CBOR.IDecode s a)) -> ConduitT ByteString a (ExceptT SyncErr (ST s)) () loop bs k = do (lift . lift) (k (Just bs)) >>= \case CBOR.Fail _ _ err -> throwError . SyncError . SyncV2.PullError'Sync $ SyncV2.SyncErrorDeserializationFailure err @@ -450,7 +450,7 @@ SyncV2.Routes -- | Helper for running clientM that returns a stream of entities. -- You MUST consume the stream within the callback, it will be closed when the callback returns. -withConduit :: forall r chunk. Servant.ClientEnv -> (Stream () chunk -> StreamM r) -> Servant.ClientM (Servant.SourceIO (CBORStream chunk)) -> StreamM r +withConduit :: forall r chunk. (CBOR.Serialise chunk) => Servant.ClientEnv -> (Stream () chunk -> StreamM r) -> Servant.ClientM (Servant.SourceIO (CBORStream chunk)) -> StreamM r withConduit clientEnv callback clientM = do ExceptT $ withRunInIO \runInIO -> do Servant.withClientM clientM clientEnv $ \case @@ -459,7 +459,7 @@ withConduit clientEnv callback clientM = do conduit <- liftIO $ Servant.fromSourceIO sourceT (runInIO . runExceptT $ callback (conduit C..| unpackCBORBytesStream)) -unpackCBORBytesStream :: Stream (CBORStream SyncV2.DownloadEntitiesChunk) SyncV2.DownloadEntitiesChunk +unpackCBORBytesStream :: (CBOR.Serialise a) => Stream (CBORStream a) a unpackCBORBytesStream = C.map (BL.toStrict . coerce @_ @BL.ByteString) C..| decodeUnframedEntities @@ -570,7 +570,7 @@ negotiateKnownCausals unisonShareUrl branchRef hashJwt = do where unpack :: SyncV2.CausalDependenciesChunk -> Hash32 unpack = \case - SyncV2.HashC causalHash -> causalHash + SyncV2.CausalHashDepC {causalHash} -> causalHash haveCausalHash :: Codebase.Codebase IO v a -> Hash32 -> StreamM Bool haveCausalHash codebase causalHash = do liftIO $ Codebase.runTransaction codebase do diff --git a/unison-share-api/src/Unison/SyncV2/API.hs b/unison-share-api/src/Unison/SyncV2/API.hs index b4ed916475..ef80d3d1cf 100644 --- a/unison-share-api/src/Unison/SyncV2/API.hs +++ b/unison-share-api/src/Unison/SyncV2/API.hs @@ -26,7 +26,7 @@ type DownloadEntitiesStream = -- | Get the relevant dependencies of a causal, including the causal spine and the causal hashes of any library roots. type CausalDependenciesStream = ReqBody '[CBOR, JSON] CausalDependenciesRequest - :> StreamPost NetstringFraming CBOR (SourceIO CausalDependenciesChunk) + :> StreamPost NoFraming OctetStream (SourceIO (CBORStream CausalDependenciesChunk)) data Routes mode = Routes { downloadEntitiesStream :: mode :- "entities" :> "download" :> DownloadEntitiesStream, diff --git a/unison-share-api/src/Unison/SyncV2/Types.hs b/unison-share-api/src/Unison/SyncV2/Types.hs index 9868b9c441..52f6c543b8 100644 --- a/unison-share-api/src/Unison/SyncV2/Types.hs +++ b/unison-share-api/src/Unison/SyncV2/Types.hs @@ -11,7 +11,7 @@ module Unison.SyncV2.Types CausalDependenciesRequest (..), CausalDependenciesChunk (..), CBORBytes (..), - CBORStream(..), + CBORStream (..), EntityKind (..), serialiseCBORBytes, deserialiseOrFailCBORBytes, @@ -332,28 +332,57 @@ instance Serialise CausalDependenciesRequest where encode branchRef <> encode rootCausal decode = CausalDependenciesRequest <$> decode <*> decode +data DependencyType + = -- This is a top-level history node of the root we're pulling. + CausalSpineDependency + | -- This is the causal root of a library dependency. + LibDependency + deriving (Show, Eq, Ord) + +instance Serialise DependencyType where + encode = \case + CausalSpineDependency -> CBOR.encodeWord8 0 + LibDependency -> CBOR.encodeWord8 1 + decode = do + tag <- CBOR.decodeWord8 + case tag of + 0 -> pure CausalSpineDependency + 1 -> pure LibDependency + _ -> fail "invalid tag" + +instance ToJSON DependencyType where + toJSON = \case + CausalSpineDependency -> "causal_spine" + LibDependency -> "lib" + +instance FromJSON DependencyType where + parseJSON = Aeson.withText "DependencyType" \case + "causal_spine" -> pure CausalSpineDependency + "lib" -> pure LibDependency + _ -> fail "invalid DependencyType" + -- | A chunk of the download entities response stream. data CausalDependenciesChunk - = HashC Hash32 + = CausalHashDepC {causalHash :: Hash32, dependencyType :: DependencyType} deriving (Show, Eq, Ord) -data CausalDependenciesChunkTag = HashChunkTag +data CausalDependenciesChunkTag = CausalHashDepChunkTag deriving (Show, Eq, Ord) instance Serialise CausalDependenciesChunkTag where encode = \case - HashChunkTag -> CBOR.encodeWord8 0 + CausalHashDepChunkTag -> CBOR.encodeWord8 0 decode = do tag <- CBOR.decodeWord8 case tag of - 0 -> pure HashChunkTag + 0 -> pure CausalHashDepChunkTag _ -> fail "invalid tag" instance Serialise CausalDependenciesChunk where encode = \case - (HashC ch) -> do - encode HashChunkTag <> CBOR.encode ch + (CausalHashDepC {causalHash, dependencyType}) -> do + encode CausalHashDepChunkTag <> CBOR.encode causalHash <> CBOR.encode dependencyType decode = do tag <- decode case tag of - HashChunkTag -> HashC <$> CBOR.decode + CausalHashDepChunkTag -> CausalHashDepC <$> CBOR.decode <*> CBOR.decode From 3e6720928859b73792d3872b3257ecb9c55d7f11 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 31 Jan 2025 16:14:22 -0800 Subject: [PATCH 39/44] Take dependencies till we know enough, then hang up. --- unison-cli/src/Unison/Share/SyncV2.hs | 30 ++++++++++++++++++--- unison-share-api/src/Unison/SyncV2/Types.hs | 1 + 2 files changed, 27 insertions(+), 4 deletions(-) diff --git a/unison-cli/src/Unison/Share/SyncV2.hs b/unison-cli/src/Unison/Share/SyncV2.hs index 4eda9ac8d9..de7bbbef01 100644 --- a/unison-cli/src/Unison/Share/SyncV2.hs +++ b/unison-cli/src/Unison/Share/SyncV2.hs @@ -63,7 +63,7 @@ import Unison.Sync.Types qualified as Share import Unison.Sync.Types qualified as Sync import Unison.SyncV2.API (Routes (downloadEntitiesStream)) import Unison.SyncV2.API qualified as SyncV2 -import Unison.SyncV2.Types (CBORBytes, CBORStream) +import Unison.SyncV2.Types (CBORBytes, CBORStream, DependencyType (..)) import Unison.SyncV2.Types qualified as SyncV2 import Unison.Util.Servant.CBOR qualified as CBOR import Unison.Util.Timing qualified as Timing @@ -566,11 +566,33 @@ negotiateKnownCausals unisonShareUrl branchRef hashJwt = do unisonShareUrl SyncV2.CausalDependenciesRequest {branchRef, rootCausal = hashJwt} \stream -> do - Set.fromList <$> C.runConduit (stream C..| C.map unpack C..| C.filterM (haveCausalHash codebase) C..| C.sinkList) + Set.fromList <$> C.runConduit (stream C..| C.map unpack C..| findKnownDeps codebase C..| C.sinkList) where - unpack :: SyncV2.CausalDependenciesChunk -> Hash32 + -- Go through the dependencies of the remote root from top-down, yielding all causal hashes that we already + -- have until we find one in the causal spine we already have, then yield that one and stop since we'll implicitly + -- have all of its dependencies. + findKnownDeps :: Codebase.Codebase IO v a -> Stream (Hash32, DependencyType) Hash32 + findKnownDeps codebase = do + C.await >>= \case + Just (hash, LibDependency) -> do + -- We yield all lib dependencies we have, it's possible we don't have any of the causal spine in common, but _do_ have + -- some of the libraries we can still save a lot of work. + whenM (lift $ haveCausalHash codebase hash) (C.yield hash) + -- We continue regardless. + findKnownDeps codebase + Just (hash, CausalSpineDependency) -> do + lift (haveCausalHash codebase hash) >>= \case + True -> do + -- If we find a causal hash we have in the spine, we don't need to look further, + -- we can pass it on, then hang up the stream. + C.yield hash + False -> do + -- Otherwise we keep looking, maybe we'll have one further in. + findKnownDeps codebase + Nothing -> pure () + unpack :: SyncV2.CausalDependenciesChunk -> (Hash32, DependencyType) unpack = \case - SyncV2.CausalHashDepC {causalHash} -> causalHash + SyncV2.CausalHashDepC {causalHash, dependencyType} -> (causalHash, dependencyType) haveCausalHash :: Codebase.Codebase IO v a -> Hash32 -> StreamM Bool haveCausalHash codebase causalHash = do liftIO $ Codebase.runTransaction codebase do diff --git a/unison-share-api/src/Unison/SyncV2/Types.hs b/unison-share-api/src/Unison/SyncV2/Types.hs index 52f6c543b8..0a716a5c37 100644 --- a/unison-share-api/src/Unison/SyncV2/Types.hs +++ b/unison-share-api/src/Unison/SyncV2/Types.hs @@ -10,6 +10,7 @@ module Unison.SyncV2.Types DownloadEntitiesError (..), CausalDependenciesRequest (..), CausalDependenciesChunk (..), + DependencyType (..), CBORBytes (..), CBORStream (..), EntityKind (..), From 51cf2b2b4c22acc5ba051282b84f4ecdbc6ed80b Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 3 Feb 2025 16:47:49 -0800 Subject: [PATCH 40/44] Clear temp entity tables before starting a syncv2 --- unison-cli/src/Unison/Share/SyncV2.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/unison-cli/src/Unison/Share/SyncV2.hs b/unison-cli/src/Unison/Share/SyncV2.hs index de7bbbef01..7ec0181ae4 100644 --- a/unison-cli/src/Unison/Share/SyncV2.hs +++ b/unison-cli/src/Unison/Share/SyncV2.hs @@ -117,6 +117,9 @@ syncFromFile :: Cli (Either (SyncError SyncV2.PullError) CausalHash) syncFromFile shouldValidate syncFilePath = do Cli.Env {codebase} <- ask + -- Every insert into SQLite checks the temp entity tables, but syncv2 doesn't actually use them, so it's faster + -- if we clear them out before starting a sync. + Cli.runTransaction Q.clearTempEntityTables runExceptT do mapExceptT liftIO $ Timing.time "File Sync" $ do header <- mapExceptT C.runResourceT $ do @@ -136,6 +139,9 @@ syncFromCodebase :: CausalHash -> IO (Either (SyncError SyncV2.PullError) ()) syncFromCodebase shouldValidate srcConn destCodebase causalHash = do + -- Every insert into SQLite checks the temp entity tables, but syncv2 doesn't actually use them, so it's faster + -- if we clear them out before starting a sync. + Sqlite.runTransaction srcConn Q.clearTempEntityTables liftIO . C.runResourceT . runExceptT $ withCodebaseEntityStream srcConn causalHash Nothing \_total entityStream -> do (header, rest) <- initializeStream entityStream streamIntoCodebase shouldValidate destCodebase header rest @@ -154,6 +160,9 @@ syncFromCodeserver :: Cli (Either (SyncError SyncV2.PullError) ()) syncFromCodeserver shouldValidate unisonShareUrl branchRef hashJwt _downloadedCallback = do Cli.Env {authHTTPClient, codebase} <- ask + -- Every insert into SQLite checks the temp entity tables, but syncv2 doesn't actually use them, so it's faster + -- if we clear them out before starting a sync. + Cli.runTransaction Q.clearTempEntityTables runExceptT do knownHashes <- ExceptT $ negotiateKnownCausals unisonShareUrl branchRef hashJwt let hash = Share.hashJWTHash hashJwt From 40af0b1aacf75fd45b110cf2dd24abf156dc224d Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 4 Feb 2025 20:56:12 -0800 Subject: [PATCH 41/44] Progress tick on negotiation --- unison-cli/src/Unison/Share/SyncV2.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/unison-cli/src/Unison/Share/SyncV2.hs b/unison-cli/src/Unison/Share/SyncV2.hs index 7ec0181ae4..d3b215c4a2 100644 --- a/unison-cli/src/Unison/Share/SyncV2.hs +++ b/unison-cli/src/Unison/Share/SyncV2.hs @@ -569,6 +569,7 @@ negotiateKnownCausals :: Cli (Either (SyncError SyncV2.PullError) (Set Hash32)) negotiateKnownCausals unisonShareUrl branchRef hashJwt = do Cli.Env {authHTTPClient, codebase} <- ask + liftIO $ Text.hPutStrLn IO.stderr $ " 🔎 Identifying missing entities..." Timing.time "Causal Negotiation" $ do liftIO . C.runResourceT . runExceptT $ httpStreamCausalDependencies authHTTPClient From 9516179a79dfa73d30d8a91220d43a098f4e70f5 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 5 Feb 2025 10:15:38 -0800 Subject: [PATCH 42/44] Set Sync version via env var --- docs/configuration.md | 13 ++++++++++-- unison-cli/src/Unison/Cli/DownloadUtils.hs | 17 ++++++++++++--- .../src/Unison/Codebase/Editor/HandleInput.hs | 2 +- .../Codebase/Editor/HandleInput/InstallLib.hs | 2 +- .../Editor/HandleInput/ProjectClone.hs | 4 ++-- .../Editor/HandleInput/ProjectCreate.hs | 4 ++-- .../Codebase/Editor/HandleInput/Pull.hs | 5 ++--- .../Codebase/Editor/HandleInput/SyncV2.hs | 4 ++-- .../src/Unison/Codebase/Editor/Input.hs | 6 +----- .../src/Unison/CommandLine/InputPatterns.hs | 21 ++++++------------- unison-cli/src/Unison/Share/SyncV2.hs | 2 +- 11 files changed, 43 insertions(+), 37 deletions(-) diff --git a/docs/configuration.md b/docs/configuration.md index 549f274a2a..87d38dca3a 100644 --- a/docs/configuration.md +++ b/docs/configuration.md @@ -10,6 +10,7 @@ * [`UNISON_SHARE_ACCESS_TOKEN`](#unison_share_access_token) * [`UNISON_READONLY`](#unison_readonly) * [`UNISON_ENTITY_VALIDATION`](#unison_entity_validation) + * [`UNISON_SYNC_VERSION`](#unison_sync_version) * [Local Codebase Server](#local-codebase-server) * [Codebase Configuration](#codebase-configuration) @@ -17,7 +18,7 @@ ### `UNISON_DEBUG` -Enable debugging output for various portions of the application. +Enable debugging output for various portions of the application. See `lib/unison-prelude/src/Unison/Debug.hs` for the full list of supported flags. E.g. @@ -62,7 +63,7 @@ Note for Windows users: Due to an outstanding issue with GHC's IO manager on Win Enabling the LSP on windows can cause UCM to hang on exit and may require the process to be killed by the operating system or via Ctrl-C. Note that this doesn't pose any risk of codebase corruption or cause any known issues, it's simply an annoyance. -If you accept this annoyance, you can enable the LSP server on Windows by exporting the `UNISON_LSP_ENABLED=true` environment variable. +If you accept this annoyance, you can enable the LSP server on Windows by exporting the `UNISON_LSP_ENABLED=true` environment variable. You can set this persistently in powershell using: @@ -117,6 +118,14 @@ Defaults to enabled. $ UNISON_ENTITY_VALIDATION="false" ucm ``` +### `UNISON_SYNC_VERSION` + +Allows enabling the experimental Sync Version 2 protocol when downloading code from Share. + +```sh +$ UNISON_ENTITY_VALIDATION="2" ucm +``` + ### `UNISON_PULL_WORKERS` Allows setting the number of workers to use when pulling from a codebase server. diff --git a/unison-cli/src/Unison/Cli/DownloadUtils.hs b/unison-cli/src/Unison/Cli/DownloadUtils.hs index 68c21dc6a2..936b2b3fba 100644 --- a/unison-cli/src/Unison/Cli/DownloadUtils.hs +++ b/unison-cli/src/Unison/Cli/DownloadUtils.hs @@ -12,13 +12,13 @@ import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TVar (modifyTVar', newTVarIO, readTVar, readTVarIO) import Data.List.NonEmpty (pattern (:|)) import System.Console.Regions qualified as Console.Regions +import System.IO.Unsafe (unsafePerformIO) import U.Codebase.HashTags (CausalHash) import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Cli.Share.Projects qualified as Share import Unison.Codebase.Editor.HandleInput.AuthLogin (ensureAuthenticatedWithCodeserver) -import Unison.Codebase.Editor.Input (SyncVersion (..)) import Unison.Codebase.Editor.Output qualified as Output import Unison.Codebase.Editor.RemoteRepo (ReadShareLooseCode, shareUserHandleToText) import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo @@ -35,15 +35,26 @@ import Unison.Share.Types (codeserverBaseURL) import Unison.Sync.Common qualified as Sync.Common import Unison.Sync.Types qualified as Share import Unison.SyncV2.Types qualified as SyncV2 +import UnliftIO.Environment qualified as UnliftIO + +data SyncVersion = SyncV1 | SyncV2 + deriving (Eq, Show) + +-- | The version of the sync protocol to use. +syncVersion :: SyncVersion +syncVersion = unsafePerformIO do + UnliftIO.lookupEnv "UNISON_SYNC_VERSION" + <&> \case + Just "2" -> SyncV2 + _ -> SyncV1 -- | Download a project/branch from Share. downloadProjectBranchFromShare :: (HasCallStack) => - SyncVersion -> Share.IncludeSquashedHead -> Share.RemoteProjectBranch -> Cli (Either Output.ShareError CausalHash) -downloadProjectBranchFromShare syncVersion useSquashed branch = +downloadProjectBranchFromShare useSquashed branch = Cli.labelE \done -> do let remoteProjectBranchName = branch.branchName causalHashJwt <- diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 6675a49843..3924afa1aa 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -667,7 +667,7 @@ loop e = do _ <- Cli.updateAtM description pp \destb -> liftIO (Branch.merge'' (Codebase.lca codebase) Branch.RegularMerge srcb destb) Cli.respond Success - PullI syncVersion sourceTarget pullMode -> handlePull syncVersion sourceTarget pullMode + PullI sourceTarget pullMode -> handlePull sourceTarget pullMode PushRemoteBranchI pushRemoteBranchInput -> handlePushRemoteBranch pushRemoteBranchInput SyncToFileI syncFileDest projectBranchName -> SyncV2.handleSyncToFile syncFileDest projectBranchName SyncFromFileI syncFileSrc projectBranchName -> do diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/InstallLib.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/InstallLib.hs index 299f30ba47..52e70188c8 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/InstallLib.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/InstallLib.hs @@ -60,7 +60,7 @@ handleInstallLib remind (ProjectAndBranch libdepProjectName unresolvedLibdepBran Cli.Env {codebase} <- ask causalHash <- - downloadProjectBranchFromShare SyncV1 Share.IncludeSquashedHead libdepProjectBranch + downloadProjectBranchFromShare Share.IncludeSquashedHead libdepProjectBranch & onLeftM (Cli.returnEarly . Output.ShareError) remoteBranchObject <- liftIO (Codebase.expectBranchForHash codebase causalHash) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectClone.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectClone.hs index 670a730b5e..8a872d18b8 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectClone.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectClone.hs @@ -13,7 +13,7 @@ import U.Codebase.Sqlite.Project qualified as Sqlite (Project (..)) import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite import U.Codebase.Sqlite.Queries qualified as Q import U.Codebase.Sqlite.Queries qualified as Queries -import Unison.Cli.DownloadUtils (SyncVersion (..), downloadProjectBranchFromShare) +import Unison.Cli.DownloadUtils (downloadProjectBranchFromShare) import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Cli.MonadUtils qualified as Cli (getCurrentProjectAndBranch) @@ -225,7 +225,7 @@ cloneInto localProjectBranch remoteProjectBranch = do let remoteProjectBranchNames = ProjectAndBranch remoteProjectName remoteBranchName branchHead <- - downloadProjectBranchFromShare SyncV1 Share.NoSquashedHead remoteProjectBranch + downloadProjectBranchFromShare Share.NoSquashedHead remoteProjectBranch & onLeftM (Cli.returnEarly . Output.ShareError) localProjectAndBranch <- diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectCreate.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectCreate.hs index 0096a91d8d..e9f6e99e95 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectCreate.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectCreate.hs @@ -13,7 +13,7 @@ import U.Codebase.Sqlite.Project (Project (..)) import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) import U.Codebase.Sqlite.Queries (expectCausalHashIdByCausalHash) import U.Codebase.Sqlite.Queries qualified as Queries -import Unison.Cli.DownloadUtils (SyncVersion (..), downloadProjectBranchFromShare) +import Unison.Cli.DownloadUtils (downloadProjectBranchFromShare) import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Cli.Share.Projects qualified as Share @@ -108,7 +108,7 @@ projectCreate tryDownloadingBase maybeProjectName = do Share.GetProjectBranchResponseBranchNotFound -> done Nothing Share.GetProjectBranchResponseProjectNotFound -> done Nothing Share.GetProjectBranchResponseSuccess branch -> pure branch - downloadProjectBranchFromShare SyncV1 Share.NoSquashedHead baseLatestReleaseBranch + downloadProjectBranchFromShare Share.NoSquashedHead baseLatestReleaseBranch & onLeftM (Cli.returnEarly . Output.ShareError) Cli.Env {codebase} <- ask baseLatestReleaseBranchObject <- diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs index e51ba1046a..3ff7012220 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs @@ -46,8 +46,8 @@ import Unison.Prelude import Unison.Project (ProjectAndBranch (..), ProjectBranchNameOrLatestRelease (..), ProjectName) import Witch (unsafeFrom) -handlePull :: SyncVersion -> PullSourceTarget -> PullMode -> Cli () -handlePull syncVersion unresolvedSourceAndTarget pullMode = do +handlePull :: PullSourceTarget -> PullMode -> Cli () +handlePull unresolvedSourceAndTarget pullMode = do let includeSquashed = case pullMode of Input.PullWithHistory -> Share.NoSquashedHead Input.PullWithoutHistory -> Share.IncludeSquashedHead @@ -59,7 +59,6 @@ handlePull syncVersion unresolvedSourceAndTarget pullMode = do ReadShare'LooseCode repo -> downloadLooseCodeFromShare repo & onLeftM (Cli.returnEarly . Output.ShareError) ReadShare'ProjectBranch remoteBranch -> downloadProjectBranchFromShare - syncVersion ( case pullMode of Input.PullWithHistory -> Share.NoSquashedHead Input.PullWithoutHistory -> Share.IncludeSquashedHead diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/SyncV2.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/SyncV2.hs index 015e5b7630..39af010bfe 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/SyncV2.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/SyncV2.hs @@ -10,7 +10,7 @@ import Control.Lens import Control.Monad.Reader (MonadReader (..)) import U.Codebase.HashTags (CausalHash) import U.Codebase.Sqlite.Queries qualified as Q -import Unison.Cli.DownloadUtils (SyncVersion (..), downloadProjectBranchFromShare) +import Unison.Cli.DownloadUtils (downloadProjectBranchFromShare) import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Cli.MonadUtils qualified as Cli @@ -75,4 +75,4 @@ handleSyncFromCodebase description srcCodebasePath srcBranch destBranch = do Cli.respond (Output.SyncPullError syncErr) handleSyncFromCodeserver :: Projects.IncludeSquashedHead -> Projects.RemoteProjectBranch -> Cli (Either Output.ShareError CausalHash) -handleSyncFromCodeserver = downloadProjectBranchFromShare SyncV2 +handleSyncFromCodeserver = downloadProjectBranchFromShare diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index b386cd98b2..75de97cd1a 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -31,7 +31,6 @@ module Unison.Codebase.Editor.Input -- * Type aliases ErrorMessageOrName, RawQuery, - SyncVersion (..), ) where @@ -60,9 +59,6 @@ data Event = UnisonFileChanged SourceName Source deriving stock (Show) -data SyncVersion = SyncV1 | SyncV2 - deriving (Eq, Show) - type Source = Text -- "id x = x\nconst a b = a" type SourceName = Text -- "foo.u" or "buffer 7" @@ -138,7 +134,7 @@ data Input MergeLocalBranchI BranchRelativePath (Maybe BranchRelativePath) Branch.MergeMode | PreviewMergeLocalBranchI BranchRelativePath (Maybe BranchRelativePath) | DiffNamespaceI BranchId2 BranchId2 -- old new - | PullI !SyncVersion !PullSourceTarget !PullMode + | PullI !PullSourceTarget !PullMode | PushRemoteBranchI PushRemoteBranchInput | SyncToFileI FilePath (ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName)) | SyncFromFileI FilePath UnresolvedProjectBranch diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index c17759e418..b003e374a2 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -92,7 +92,6 @@ module Unison.CommandLine.InputPatterns projectSwitch, projectsInputPattern, pull, - pullV2, pullWithoutHistory, push, pushCreate, @@ -1788,13 +1787,7 @@ reset = pull :: InputPattern pull = - pullImpl "pull" [] Input.PullWithHistory "" Input.SyncV1 - -pullV2 :: InputPattern -pullV2 = - (pullImpl "pull.v2" [] Input.PullWithHistory "" Input.SyncV2) - {I.visibility = I.Hidden - } + pullImpl "pull" [] Input.PullWithHistory "" pullWithoutHistory :: InputPattern pullWithoutHistory = @@ -1803,10 +1796,9 @@ pullWithoutHistory = [] Input.PullWithoutHistory "without including the remote's history. This usually results in smaller codebase sizes." - Input.SyncV1 -pullImpl :: String -> [String] -> Input.PullMode -> P.Pretty CT.ColorText -> Input.SyncVersion -> InputPattern -pullImpl name aliases pullMode addendum syncVersion = do +pullImpl :: String -> [String] -> Input.PullMode -> P.Pretty CT.ColorText -> InputPattern +pullImpl name aliases pullMode addendum = do self where self = @@ -1850,10 +1842,10 @@ pullImpl name aliases pullMode addendum syncVersion = do explainRemote Pull ], parse = \case - [] -> pure $ Input.PullI syncVersion Input.PullSourceTarget0 pullMode + [] -> pure $ Input.PullI Input.PullSourceTarget0 pullMode [sourceArg] -> do source <- handlePullSourceArg sourceArg - pure (Input.PullI syncVersion (Input.PullSourceTarget1 source) pullMode) + pure (Input.PullI (Input.PullSourceTarget1 source) pullMode) [sourceArg, targetArg] -> -- You used to be able to pull into a path, so this arg parser is a little complicated, because -- we want to provide helpful suggestions if you are doing a deprecated or invalid thing. @@ -1861,7 +1853,7 @@ pullImpl name aliases pullMode addendum syncVersion = do handleMaybeProjectBranchArg targetArg, handlePath'Arg targetArg ) of - (Right source, Right target, _) -> Right (Input.PullI syncVersion (Input.PullSourceTarget2 source target) pullMode) + (Right source, Right target, _) -> Right (Input.PullI (Input.PullSourceTarget2 source target) pullMode) (Left err, _, _) -> Left err -- Parsing as a path didn't work either; just show the branch parse error (Right _, Left err, Left _) -> Left err @@ -3821,7 +3813,6 @@ validInputs = projectSwitch, projectsInputPattern, pull, - pullV2, pullWithoutHistory, push, pushCreate, diff --git a/unison-cli/src/Unison/Share/SyncV2.hs b/unison-cli/src/Unison/Share/SyncV2.hs index d3b215c4a2..14870f208d 100644 --- a/unison-cli/src/Unison/Share/SyncV2.hs +++ b/unison-cli/src/Unison/Share/SyncV2.hs @@ -569,7 +569,7 @@ negotiateKnownCausals :: Cli (Either (SyncError SyncV2.PullError) (Set Hash32)) negotiateKnownCausals unisonShareUrl branchRef hashJwt = do Cli.Env {authHTTPClient, codebase} <- ask - liftIO $ Text.hPutStrLn IO.stderr $ " 🔎 Identifying missing entities..." + liftIO $ Text.hPutStrLn IO.stderr $ " 🔎 Identifying missing entities..." Timing.time "Causal Negotiation" $ do liftIO . C.runResourceT . runExceptT $ httpStreamCausalDependencies authHTTPClient From c8d360d184f275054ea7e10046470810e0a8c47d Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 5 Feb 2025 11:13:16 -0800 Subject: [PATCH 43/44] Update transcript output --- .../project-outputs/docs/configuration.output.md | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/unison-src/transcripts/project-outputs/docs/configuration.output.md b/unison-src/transcripts/project-outputs/docs/configuration.output.md index 0bf4d06de5..bcae1f8b5a 100644 --- a/unison-src/transcripts/project-outputs/docs/configuration.output.md +++ b/unison-src/transcripts/project-outputs/docs/configuration.output.md @@ -9,6 +9,7 @@ - [`UNISON_SHARE_ACCESS_TOKEN`](#unison_share_access_token) - [`UNISON_READONLY`](#unison_readonly) - [`UNISON_ENTITY_VALIDATION`](#unison_entity_validation) + - [`UNISON_SYNC_VERSION`](#unison_sync_version) - [Local Codebase Server](#local-codebase-server) - [Codebase Configuration](#codebase-configuration) @@ -116,6 +117,14 @@ Defaults to enabled. $ UNISON_ENTITY_VALIDATION="false" ucm ``` +### `UNISON_SYNC_VERSION` + +Allows enabling the experimental Sync Version 2 protocol when downloading code from Share. + +``` sh +$ UNISON_ENTITY_VALIDATION="2" ucm +``` + ### `UNISON_PULL_WORKERS` Allows setting the number of workers to use when pulling from a codebase server. From 3fc349f70291fefe85649ace49cd2b6aea5e319b Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Fri, 7 Feb 2025 14:25:09 -0500 Subject: [PATCH 44/44] Fix a problem with pre-evaluation in the sandboxed runtime Pre-evaluation tries to evaluate all top level values ahead of time. There are a few such values, though, that come from operations we have marked as sandboxed, like the standard handles. Documents and such would never actually use these handles, but they might be transitively referred to by the documents. Pre-evaluation was then eagerly evaluating the disallowed functions, even though the values aren't actually needed to calculate the document value. This commit just ignores sandboxing failures during pre-evaluation. They will cause there to be no stored result for the value, but as long as the document (or whatever else is being evaluated) doesn't _actually_ depend on the sandboxed value, it will evaluate fine. --- unison-runtime/src/Unison/Runtime/Machine.hs | 20 +++++++ unison-src/transcripts/idempotent/fix5506.md | 62 ++++++++++++++++++++ 2 files changed, 82 insertions(+) create mode 100644 unison-src/transcripts/idempotent/fix5506.md diff --git a/unison-runtime/src/Unison/Runtime/Machine.hs b/unison-runtime/src/Unison/Runtime/Machine.hs index 8976269e17..179310e5da 100644 --- a/unison-runtime/src/Unison/Runtime/Machine.hs +++ b/unison-runtime/src/Unison/Runtime/Machine.hs @@ -33,6 +33,7 @@ import Control.Lens import Data.Atomics qualified as Atomic import Data.Bits import Data.Functor.Classes (Eq1 (..), Ord1 (..)) +import Data.List qualified as List import Data.IORef (IORef) import Data.IORef qualified as IORef import Data.Map.Strict qualified as M @@ -2361,6 +2362,12 @@ preEvalTopLevelConstants cacheableCombs newCombs cc = do atomically $ do modifyTVar evaluatedCacheableCombsVar $ EC.mapInsert w (EC.mapSingleton 0 $ CachedVal w val) apply0 (Just hook) cc activeThreads w + `catch` \e -> + -- ignore sandboxing exceptions during pre-eval, in case they + -- don't matter for the final result. + if isSandboxingException e + then pure () + else throwIO e evaluatedCacheableCombs <- readTVarIO evaluatedCacheableCombsVar let allNew = evaluatedCacheableCombs <> newCombs @@ -2368,6 +2375,19 @@ preEvalTopLevelConstants cacheableCombs newCombs cc = do -- new cached versions. atomically $ modifyTVar (combs cc) (\existingCombs -> (resolveCombs (Just $ EC.mapDifference existingCombs allNew) allNew) <> existingCombs) +-- Checks if a runtime exception is due to sandboxing. +-- +-- This is used above during pre-evaluation, to ignore sandboxing +-- exceptions for top-level constant dependencies of docs and such, in +-- case the docs don't actually evaluate them. +isSandboxingException :: RuntimeExn -> Bool +isSandboxingException (PE _ (P.toPlainUnbroken -> msg)) = + List.isPrefixOf sdbx1 msg || List.isPrefixOf sdbx2 msg + where + sdbx1 = "attempted to use sandboxed operation" + sdbx2 = "Attempted to use disallowed builtin in sandboxed" +isSandboxingException _ = False + expandSandbox :: Map Reference (Set Reference) -> [(Reference, SuperGroup Symbol)] -> diff --git a/unison-src/transcripts/idempotent/fix5506.md b/unison-src/transcripts/idempotent/fix5506.md new file mode 100644 index 0000000000..3157d04ddd --- /dev/null +++ b/unison-src/transcripts/idempotent/fix5506.md @@ -0,0 +1,62 @@ +``` ucm :hide +scratch/main> builtins.mergeio +``` + +``` unison + +stdOut = stdHandle StdOut + +putText h t = match putBytes.impl h (Text.toUtf8 t) with + Left e -> raise e + _ -> () + +printLine t = + putText stdOut t + putText stdOut "\n" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + printLine : Text ->{IO, Exception} () + putText : Handle -> Text ->{IO, Exception} () + stdOut : Handle +``` + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. +``` + +``` unison + +hmmm = {{ I'll try {printLine}. That's a good trick. }} +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + hmmm : Doc2 +``` + +``` ucm +scratch/main> display hmmm + + I'll try printLine. That's a good trick. +```