From 700af9cc7fb3b0ae08dac8b6d044fc242ec17faa Mon Sep 17 00:00:00 2001 From: AgentM Date: Sun, 7 Jan 2024 00:16:12 -0500 Subject: [PATCH 01/10] update to curryer-rpc 0.3.3 for streamly 0.10.0 support websocket server test fails, why? --- cabal.project | 3 ++- project-m36.cabal | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/cabal.project b/cabal.project index 4a134cb0..fc74f514 100644 --- a/cabal.project +++ b/cabal.project @@ -1,8 +1,9 @@ packages: project-m36.cabal + ../curryer package * split-sections: True -- allow fast-builder to build with GHC 9.2.2 (currently pegged at 9.0.1) -allow-newer: fast-builder:base, streamly-bytestring:bytestring +allow-newer: fast-builder:base diff --git a/project-m36.cabal b/project-m36.cabal index ed37dd52..451c7878 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -35,7 +35,7 @@ Flag haskell-scripting Default: True Library - Build-Depends: base>=4.16 && < 4.19, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, filepath, zlib, directory, temporary, stm, time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256, text-manipulate >= 0.2.0.1 && < 0.4, winery >= 1.4, curryer-rpc>=0.3.2, network, async, vector-instances, recursion-schemes, streamly == 0.9.0, convertible, fast-builder, scientific + Build-Depends: base>=4.16 && < 4.19, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, filepath, zlib, directory, temporary, stm, time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256, text-manipulate >= 0.2.0.1 && < 0.4, winery >= 1.4, curryer-rpc>=0.3.3, network, async, vector-instances, recursion-schemes, streamly >= 0.9.0, convertible, fast-builder, scientific if flag(haskell-scripting) Build-Depends: ghc >= 9.0 && < 9.5 CPP-Options: -DPM36_HASKELL_SCRIPTING From cdd3e2ed9dd1286894e5dfab7df1be9c7435c9fe Mon Sep 17 00:00:00 2001 From: AgentM Date: Sun, 7 Jan 2024 17:35:52 -0500 Subject: [PATCH 02/10] remove special curryer-rpc from cabal.project --- cabal.project | 1 - 1 file changed, 1 deletion(-) diff --git a/cabal.project b/cabal.project index fc74f514..6bf8b77e 100644 --- a/cabal.project +++ b/cabal.project @@ -1,6 +1,5 @@ packages: project-m36.cabal - ../curryer package * split-sections: True From 043f1483bddf3bb7b8dd572f82c396782cdb45c2 Mon Sep 17 00:00:00 2001 From: AgentM Date: Mon, 8 Jan 2024 00:48:15 -0500 Subject: [PATCH 03/10] update nix for streamly 0.10.10 --- release.nix | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/release.nix b/release.nix index 22fb1e8a..1bde5265 100644 --- a/release.nix +++ b/release.nix @@ -15,18 +15,18 @@ let overrides = self: super: { curryer-rpc = self.callHackageDirect { pkg = "curryer-rpc"; - ver = "0.3.2"; - sha256 = "sha256-QiKsaFcIzOrtCpgVrgArnj7Hd09JVjF67huam+0aZSc="; } {}; + ver = "0.3.3"; + sha256 = "sha256-IzUOtMOfsnDG9BBvXnlywIMAUntctX0jNPZxzOQnmHo="; } {}; streamly = self.callHackageDirect { pkg = "streamly"; - ver = "0.9.0"; - sha256 = "sha256-eOxVb8qQjZDo1+S7CStqYSExOg2QHWkMY+zlOYqwZak="; } {}; + ver = "0.10.0"; + sha256 = "sha256-QkqfJ7ta+Odfv5wYL+SvOpM6ZmVTDSPxDPDhjNRU2wE="; } {}; streamly-core = self.callHackageDirect { pkg = "streamly-core"; - ver = "0.1.0"; - sha256 = "sha256-hoSV6Q2+X5a7hFnJAArqNPjcMaCVyX9Vz4FcxeJ+jgI="; } {}; + ver = "0.2.0"; + sha256 = "sha256-fMo5dz/AY0CUZaP1lhXqjfsuGVO4GtAW3/q9W9N6D3Q="; } {}; lockfree-queue = self.callHackageDirect { pkg = "lockfree-queue"; From 19669db26a9c50cff002f9a083a4462d126be98d Mon Sep 17 00:00:00 2001 From: AgentM Date: Mon, 8 Jan 2024 01:07:04 -0500 Subject: [PATCH 04/10] update nix with streamly-bytestring 0.2.1 --- release.nix | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/release.nix b/release.nix index 1bde5265..a3baca49 100644 --- a/release.nix +++ b/release.nix @@ -27,6 +27,10 @@ let pkg = "streamly-core"; ver = "0.2.0"; sha256 = "sha256-fMo5dz/AY0CUZaP1lhXqjfsuGVO4GtAW3/q9W9N6D3Q="; } {}; + streamly-bytestring = self.callHackageDirect { + pkg = "streamly-bytestring"; + ver = "0.2.1"; + sha256 = "sha256-EcH6qq4nRjea3xQ66Zlqgjjg7lF/grkKJI0+tTO4B84="; } {}; lockfree-queue = self.callHackageDirect { pkg = "lockfree-queue"; From 4b0200a47fffd9691c7a9d604db4cbe378b90d27 Mon Sep 17 00:00:00 2001 From: AgentM Date: Mon, 8 Jan 2024 13:17:07 -0500 Subject: [PATCH 05/10] squelch hlint warning about lists in Atomable --- src/lib/ProjectM36/Atomable.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/lib/ProjectM36/Atomable.hs b/src/lib/ProjectM36/Atomable.hs index df696e16..4be5c421 100644 --- a/src/lib/ProjectM36/Atomable.hs +++ b/src/lib/ProjectM36/Atomable.hs @@ -158,7 +158,7 @@ instance Atomable a => Atomable [a] where instance Atomable a => Atomable (NE.NonEmpty a) where toAtom (x NE.:| []) = ConstructedAtom "NECons" (nonEmptyListAtomType (toAtomType (Proxy :: Proxy a))) [toAtom x] - toAtom (x NE.:| xs) = ConstructedAtom "NECons" (nonEmptyListAtomType (toAtomType (Proxy :: Proxy a))) (toAtom x : toAtom xs : []) + toAtom (x NE.:| xs) = ConstructedAtom "NECons" (nonEmptyListAtomType (toAtomType (Proxy :: Proxy a))) [toAtom x, toAtom xs] fromAtom (ConstructedAtom "NECons" _ [x]) = fromAtom x NE.:| [] fromAtom (ConstructedAtom "NECons" _ [x,y] ) = fromAtom x NE.:| fromAtom y fromAtom x = error "improper fromAtom (NonEmptyList a)" From d450f9c6001b5504c0c684b524f7924e4565e3bd Mon Sep 17 00:00:00 2001 From: AgentM Date: Fri, 12 Jan 2024 22:15:08 -0500 Subject: [PATCH 06/10] revert to streamly 0.9.0 to skip potentially buggy streamly 0.10.0 resulting in TCP stream corruption --- project-m36.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/project-m36.cabal b/project-m36.cabal index 451c7878..a7c85457 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -35,7 +35,7 @@ Flag haskell-scripting Default: True Library - Build-Depends: base>=4.16 && < 4.19, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, filepath, zlib, directory, temporary, stm, time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256, text-manipulate >= 0.2.0.1 && < 0.4, winery >= 1.4, curryer-rpc>=0.3.3, network, async, vector-instances, recursion-schemes, streamly >= 0.9.0, convertible, fast-builder, scientific + Build-Depends: base>=4.16 && < 4.19, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, filepath, zlib, directory, temporary, stm, time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256, text-manipulate >= 0.2.0.1 && < 0.4, winery >= 1.4, curryer-rpc>=0.3.4, network, async, vector-instances, recursion-schemes, streamly == 0.9.0, convertible, fast-builder, scientific if flag(haskell-scripting) Build-Depends: ghc >= 9.0 && < 9.5 CPP-Options: -DPM36_HASKELL_SCRIPTING From cc66a7588d0d7c4a8d3a9a0cb360700e395c8d44 Mon Sep 17 00:00:00 2001 From: AgentM Date: Fri, 12 Jan 2024 23:49:18 -0500 Subject: [PATCH 07/10] update version to 0.9.9 after reverting to streamly 0.9.0 --- Changelog.markdown | 3 ++- project-m36.cabal | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/Changelog.markdown b/Changelog.markdown index 527a97b6..aaca84ee 100644 --- a/Changelog.markdown +++ b/Changelog.markdown @@ -1,5 +1,6 @@ -# Future +# 2024-01-12 (v0.9.9) +* revert to using streamly 0.9.0 due to over-the-wire corruption bug in 0.10.0 * fixed toAtom/fromAtom for NonEmpty lists (#363) # 2023-12-30 (v0.9.8) diff --git a/project-m36.cabal b/project-m36.cabal index a7c85457..e3a36998 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -1,6 +1,6 @@ Cabal-Version: 2.2 Name: project-m36 -Version: 0.9.8 +Version: 0.9.9 License: MIT --note that this license specification is erroneous and only labeled MIT to appease hackage which does not recognize public domain packages in cabal >2.2- Project:M36 is dedicated to the public domain Build-Type: Simple From bb94fab75fb2c409d3e7d487cdc640d52635df34 Mon Sep 17 00:00:00 2001 From: AgentM Date: Sat, 13 Jan 2024 00:58:35 -0500 Subject: [PATCH 08/10] fix docker build with downgrade to streamly 0.9.0 and curryer-rpc 0.3.5 --- project-m36.cabal | 2 +- release.nix | 13 +++++++------ 2 files changed, 8 insertions(+), 7 deletions(-) diff --git a/project-m36.cabal b/project-m36.cabal index e3a36998..731bc3bf 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -35,7 +35,7 @@ Flag haskell-scripting Default: True Library - Build-Depends: base>=4.16 && < 4.19, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, filepath, zlib, directory, temporary, stm, time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256, text-manipulate >= 0.2.0.1 && < 0.4, winery >= 1.4, curryer-rpc>=0.3.4, network, async, vector-instances, recursion-schemes, streamly == 0.9.0, convertible, fast-builder, scientific + Build-Depends: base>=4.16 && < 4.19, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, filepath, zlib, directory, temporary, stm, time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256, text-manipulate >= 0.2.0.1 && < 0.4, winery >= 1.4, curryer-rpc>=0.3.5, network, async, vector-instances, recursion-schemes, streamly == 0.9.0, convertible, fast-builder, scientific if flag(haskell-scripting) Build-Depends: ghc >= 9.0 && < 9.5 CPP-Options: -DPM36_HASKELL_SCRIPTING diff --git a/release.nix b/release.nix index a3baca49..f09ea202 100644 --- a/release.nix +++ b/release.nix @@ -15,18 +15,19 @@ let overrides = self: super: { curryer-rpc = self.callHackageDirect { pkg = "curryer-rpc"; - ver = "0.3.3"; - sha256 = "sha256-IzUOtMOfsnDG9BBvXnlywIMAUntctX0jNPZxzOQnmHo="; } {}; + ver = "0.3.5"; + sha256 = "sha256-7mEJOBKzA2rTnLxZme8E6zFv0VkiXBo5L/jUJSNPaNE="; } {}; streamly = self.callHackageDirect { pkg = "streamly"; - ver = "0.10.0"; - sha256 = "sha256-QkqfJ7ta+Odfv5wYL+SvOpM6ZmVTDSPxDPDhjNRU2wE="; } {}; + ver = "0.9.0"; + sha256 = "sha256-eOxVb8qQjZDo1+S7CStqYSExOg2QHWkMY+zlOYqwZak="; } {}; streamly-core = self.callHackageDirect { pkg = "streamly-core"; - ver = "0.2.0"; - sha256 = "sha256-fMo5dz/AY0CUZaP1lhXqjfsuGVO4GtAW3/q9W9N6D3Q="; } {}; + ver = "0.1.0"; + sha256 = "sha256-hoSV6Q2+X5a7hFnJAArqNPjcMaCVyX9Vz4FcxeJ+jgI="; } {}; + streamly-bytestring = self.callHackageDirect { pkg = "streamly-bytestring"; ver = "0.2.1"; From 4dd0d84aecd32d14db8699da1c1a15fcd82cd8f4 Mon Sep 17 00:00:00 2001 From: AgentM Date: Mon, 15 Jan 2024 16:19:52 -0500 Subject: [PATCH 09/10] be more careful when trimming the transaction graph- make sure to include transactions referenced by the truly relevant transactions resolves #364 --- project-m36.cabal | 3 +- src/lib/ProjectM36/Atomable.hs | 2 +- src/lib/ProjectM36/Base.hs | 8 +- src/lib/ProjectM36/Error.hs | 3 +- .../ProjectM36/ReferencedTransactionIds.hs | 117 ++++++++++++++++++ src/lib/ProjectM36/TransactionGraph.hs | 21 +++- src/lib/ProjectM36/TransactionGraph/Merge.hs | 8 +- test/TransactionGraph/Merge.hs | 4 +- 8 files changed, 148 insertions(+), 18 deletions(-) create mode 100644 src/lib/ProjectM36/ReferencedTransactionIds.hs diff --git a/project-m36.cabal b/project-m36.cabal index e3a36998..11b7b332 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -134,7 +134,8 @@ Library ProjectM36.Trace, ProjectM36.HashSecurely, ProjectM36.DDLType, - ProjectM36.RegisteredQuery + ProjectM36.RegisteredQuery, + ProjectM36.ReferencedTransactionIds GHC-Options: -Wall -rdynamic if os(windows) Build-Depends: Win32 >= 2.12 diff --git a/src/lib/ProjectM36/Atomable.hs b/src/lib/ProjectM36/Atomable.hs index 4be5c421..78f84404 100644 --- a/src/lib/ProjectM36/Atomable.hs +++ b/src/lib/ProjectM36/Atomable.hs @@ -161,7 +161,7 @@ instance Atomable a => Atomable (NE.NonEmpty a) where toAtom (x NE.:| xs) = ConstructedAtom "NECons" (nonEmptyListAtomType (toAtomType (Proxy :: Proxy a))) [toAtom x, toAtom xs] fromAtom (ConstructedAtom "NECons" _ [x]) = fromAtom x NE.:| [] fromAtom (ConstructedAtom "NECons" _ [x,y] ) = fromAtom x NE.:| fromAtom y - fromAtom x = error "improper fromAtom (NonEmptyList a)" + fromAtom _x = error "improper fromAtom (NonEmptyList a)" toAtomType _ = ConstructedAtomType "NonEmptyList" (M.singleton "a" (toAtomType (Proxy :: Proxy a))) toAddTypeExpr _ = NoOperation diff --git a/src/lib/ProjectM36/Base.hs b/src/lib/ProjectM36/Base.hs index 8717b78b..21a66082 100644 --- a/src/lib/ProjectM36/Base.hs +++ b/src/lib/ProjectM36/Base.hs @@ -454,6 +454,9 @@ transactionHeadsForGraph (TransactionGraph hs _) = hs transactionsForGraph :: TransactionGraph -> S.Set Transaction transactionsForGraph (TransactionGraph _ ts) = ts +transactionIdsForGraph :: TransactionGraph -> S.Set TransactionId +transactionIdsForGraph = S.map transactionId . transactionsForGraph + -- | Every transaction has context-specific information attached to it. -- The `TransactionDiff`s represent child/edge relationships to previous transactions (branches or continuations of the same branch). data TransactionInfo = TransactionInfo { @@ -463,11 +466,6 @@ data TransactionInfo = TransactionInfo { } deriving (Show, Generic) type TransactionParents = NE.NonEmpty TransactionId -{- -data TransactionInfo = TransactionInfo TransactionId TransactionDiffs UTCTime | -- 1 parent + n children - MergeTransactionInfo TransactionId TransactionId TransactionDiffs UTCTime -- 2 parents, n children - deriving (Show, Generic) --} -- | Every set of modifications made to the database are atomically committed to the transaction graph as a transaction. type TransactionId = UUID diff --git a/src/lib/ProjectM36/Error.hs b/src/lib/ProjectM36/Error.hs index a5d2c401..16d85dfe 100644 --- a/src/lib/ProjectM36/Error.hs +++ b/src/lib/ProjectM36/Error.hs @@ -131,7 +131,8 @@ data MergeError = SelectedHeadMismatchMergeError | InvalidMergeStrategyError MergeStrategy | -- this is an internal coding error DisconnectedTransactionNotAMergeHeadError TransactionId | StrategyViolatesComponentMergeError | --failed merge in inc deps, relvars, etc. - StrategyViolatesRelationVariableMergeError | + StrategyViolatesRelationVariableMergeError RelationalError | + StrategyWithoutPreferredBranchResolutionMergeError | StrategyViolatesTypeConstructorMergeError | StrategyViolatesRegisteredQueryMergeError [RegisteredQueryName] deriving (Show, Eq, Generic, Typeable) diff --git a/src/lib/ProjectM36/ReferencedTransactionIds.hs b/src/lib/ProjectM36/ReferencedTransactionIds.hs new file mode 100644 index 00000000..56033428 --- /dev/null +++ b/src/lib/ProjectM36/ReferencedTransactionIds.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE FlexibleInstances #-} +module ProjectM36.ReferencedTransactionIds where +import ProjectM36.Base +import qualified Data.Map as M +import qualified Data.Set as S + +type TransactionIds = S.Set TransactionId + +-- return all transactionIds referenced recursively- can be used to create subgraph of transaction dependencies +class ReferencedTransactionIds a where + referencedTransactionIds :: a -> TransactionIds + +instance ReferencedTransactionIds a => ReferencedTransactionIds (RelationalExprBase a) where + referencedTransactionIds x = case x of + MakeRelationFromExprs (Just attrExprs) tupleExprs -> + S.unions (referencedTransactionIds tupleExprs : map referencedTransactionIds attrExprs) + MakeRelationFromExprs Nothing tupleExprs -> + referencedTransactionIds tupleExprs + MakeStaticRelation{} -> S.empty + ExistingRelation{} -> S.empty + RelationVariable _ marker -> referencedTransactionIds marker + Project attrNames expr -> S.union (referencedTransactionIds attrNames) (referencedTransactionIds expr) + Union exprA exprB -> S.union (referencedTransactionIds exprA) (referencedTransactionIds exprB) + Join exprA exprB -> S.union (referencedTransactionIds exprA) (referencedTransactionIds exprB) + Rename _ _ expr -> referencedTransactionIds expr + Difference exprA exprB -> S.union (referencedTransactionIds exprA) (referencedTransactionIds exprB) + Group attrNames _ expr -> S.union (referencedTransactionIds attrNames) (referencedTransactionIds expr) + Ungroup _ expr -> referencedTransactionIds expr + Restrict pred' expr -> S.union (referencedTransactionIds pred') (referencedTransactionIds expr) + Equals exprA exprB -> S.union (referencedTransactionIds exprA) (referencedTransactionIds exprB) + NotEquals exprA exprB -> S.union (referencedTransactionIds exprA) (referencedTransactionIds exprB) + Extend extendTupleExpr expr -> S.union (referencedTransactionIds extendTupleExpr) (referencedTransactionIds expr) + With assocs expr -> S.unions (referencedTransactionIds expr : map tAssocs assocs) + where + tAssocs (withNameExpr, rExpr) = S.union (referencedTransactionIds withNameExpr) (referencedTransactionIds rExpr) + +instance ReferencedTransactionIds a => ReferencedTransactionIds (AttributeExprBase a) where + referencedTransactionIds NakedAttributeExpr{} = S.empty + referencedTransactionIds (AttributeAndTypeNameExpr _ _ marker) = referencedTransactionIds marker + +instance ReferencedTransactionIds a => ReferencedTransactionIds (TupleExprBase a) where + referencedTransactionIds (TupleExpr tMap) = + S.unions (referencedTransactionIds <$> M.elems tMap) + +instance ReferencedTransactionIds a => ReferencedTransactionIds (TupleExprsBase a) where + referencedTransactionIds (TupleExprs marker tupleExprs) = + S.unions (referencedTransactionIds marker : (referencedTransactionIds <$> tupleExprs)) + +instance ReferencedTransactionIds GraphRefTransactionMarker where + referencedTransactionIds (TransactionMarker tid) = S.singleton tid + referencedTransactionIds UncommittedContextMarker = S.empty -- we have other methods to determine if there is an uncommitted transaction marker in the expr + +instance ReferencedTransactionIds a => ReferencedTransactionIds (AttributeNamesBase a) where + referencedTransactionIds names = + case names of + AttributeNames{} -> S.empty + InvertedAttributeNames{} -> S.empty + UnionAttributeNames exprA exprB -> + S.union (referencedTransactionIds exprA) (referencedTransactionIds exprB) + IntersectAttributeNames exprA exprB -> + S.union (referencedTransactionIds exprA) (referencedTransactionIds exprB) + RelationalExprAttributeNames rExpr -> + referencedTransactionIds rExpr + +instance ReferencedTransactionIds a => ReferencedTransactionIds (RestrictionPredicateExprBase a) where + referencedTransactionIds expr = + case expr of + TruePredicate -> mempty + AndPredicate exprA exprB -> + S.union (referencedTransactionIds exprA) (referencedTransactionIds exprB) + OrPredicate exprA exprB -> + S.union (referencedTransactionIds exprA) (referencedTransactionIds exprB) + NotPredicate exprA -> + referencedTransactionIds exprA + RelationalExprPredicate rExpr -> + referencedTransactionIds rExpr + AtomExprPredicate aExpr -> + referencedTransactionIds aExpr + AttributeEqualityPredicate _ aExpr -> + referencedTransactionIds aExpr + +instance ReferencedTransactionIds a => ReferencedTransactionIds (ExtendTupleExprBase a) where + referencedTransactionIds (AttributeExtendTupleExpr _ aExpr) = + referencedTransactionIds aExpr + +instance ReferencedTransactionIds a => ReferencedTransactionIds (WithNameExprBase a) where + referencedTransactionIds (WithNameExpr _ marker) = referencedTransactionIds marker + +instance ReferencedTransactionIds a => ReferencedTransactionIds (AtomExprBase a) where + referencedTransactionIds expr = + case expr of + AttributeAtomExpr{} -> mempty + NakedAtomExpr{} -> mempty + FunctionAtomExpr _ args marker -> + S.unions (referencedTransactionIds marker : (referencedTransactionIds <$> args)) + RelationAtomExpr rExpr -> + referencedTransactionIds rExpr + ConstructedAtomExpr _ args marker -> + S.unions (referencedTransactionIds marker : (referencedTransactionIds <$> args)) + +-- only the relvars can reference other transactions +instance ReferencedTransactionIds DatabaseContext where + referencedTransactionIds dbc = + S.unions [ + --referencedTransactionIds (inclusionDependencies dbc), + referencedTransactionIds (relationVariables dbc) + --referencedTransactionIds (atomFunctions dbc), + --referencedTransactionIds (dbcFunctions dbc), + --referencedTransactionIds (notifications dbc), + --referencedTransactionIds (typeConstructorMapping dbc), + --referencedTransactionIds (registeredQueries dbc) + ] + +instance ReferencedTransactionIds RelationVariables where + referencedTransactionIds relVars = + S.unions (referencedTransactionIds <$> M.elems relVars) + diff --git a/src/lib/ProjectM36/TransactionGraph.hs b/src/lib/ProjectM36/TransactionGraph.hs index 59eabeab..821b19d6 100644 --- a/src/lib/ProjectM36/TransactionGraph.hs +++ b/src/lib/ProjectM36/TransactionGraph.hs @@ -13,6 +13,7 @@ import ProjectM36.MerkleHash import qualified ProjectM36.DisconnectedTransaction as Discon import qualified ProjectM36.Attribute as A import ProjectM36.HashSecurely +import ProjectM36.ReferencedTransactionIds import Codec.Winery import Control.Monad.Except hiding (join) @@ -373,7 +374,7 @@ validateHeadName headName graph (t1, t2) = else pure trans --- Algorithm: start at one transaction and work backwards up the parents. If there is a node we have not yet visited as a child, then walk that up to its head. If that branch contains the goal transaction, then we have completed a valid subgraph traversal. +-- Algorithm: start at one transaction and work backwards up the parents. If there is a node we have not yet visited as a child, then walk that up to its head. If that branch contains the goal transaction, then we have completed a valid subgraph traversal. The subgraph must also include any transactions which are referenced by other transactions. subGraphOfFirstCommonAncestor :: TransactionGraph -> TransactionHeads -> Transaction -> Transaction -> S.Set Transaction -> Either RelationalError TransactionGraph subGraphOfFirstCommonAncestor origGraph resultHeads currentTrans' goalTrans traverseSet = do let currentid = transactionId currentTrans' @@ -398,8 +399,15 @@ subGraphOfFirstCommonAncestor origGraph resultHeads currentTrans' goalTrans trav Left err -> Left err Right currentTransParent -> subGraphOfFirstCommonAncestor origGraph resultHeads currentTransParent goalTrans (S.insert currentTrans' traverseSet) - else -- we found a path - Right (TransactionGraph resultHeads (S.unions (traverseSet : pathsFound))) + else do -- we found a path + -- we union all the relevant path transactions together, but we are missing any transactions which these transaction may reference. To make a valid transaction graph, we must include these referenced transactions. + let openSet = S.unions (traverseSet : pathsFound) + transactionIncluder acc trans = do + let allTids = referencedTransactionIds (concreteDatabaseContext trans) + allTrans <- mapM (`transactionForId` origGraph) (S.toList allTids) + pure $ S.unions (S.singleton trans : S.fromList allTrans : [acc]) + closedTransactionSet <- foldM transactionIncluder mempty (S.toList openSet) + Right (TransactionGraph resultHeads closedTransactionSet) where oneParent (Transaction _ tinfo _) = transactionForId (NE.head (parents tinfo)) origGraph @@ -437,9 +445,12 @@ mergeTransactions stamp' newId parentId mergeStrategy (headNameA, headNameB) = d transB <- transactionForHeadErr headNameB disconParent <- gfTransForId parentId let subHeads = M.filterWithKey (\k _ -> k `elem` [headNameA, headNameB]) (transactionHeadsForGraph graph) + -- is this an optimization??? subGraph <- runE $ subGraphOfFirstCommonAncestor graph subHeads transA transB S.empty subGraph' <- runE $ filterSubGraph subGraph subHeads - mergedTrans <- local (const (freshGraphRefRelationalExprEnv Nothing subGraph')) $ createMergeTransaction stamp' newId mergeStrategy (transA, transB) + -- we cannot cut the transaction graph away only to "relevant" transactions because transactions can reference other transactions via relvar expressions + mergedTrans <- local (const (freshGraphRefRelationalExprEnv Nothing subGraph')) $ + createMergeTransaction stamp' newId mergeStrategy (transA, transB) case headNameForTransaction disconParent graph of Nothing -> throwError (TransactionIsNotAHeadError parentId) Just headName -> do @@ -625,3 +636,5 @@ validateMerkleHashes graph = case validateMerkleHash trans graph of Left err -> err : acc _ -> acc + + diff --git a/src/lib/ProjectM36/TransactionGraph/Merge.hs b/src/lib/ProjectM36/TransactionGraph/Merge.hs index 537d742b..5edad854 100644 --- a/src/lib/ProjectM36/TransactionGraph/Merge.hs +++ b/src/lib/ProjectM36/TransactionGraph/Merge.hs @@ -26,14 +26,14 @@ unionMergeMaps prefer mapA mapB = case prefer of unionMergeRelation :: MergePreference -> GraphRefRelationalExpr -> GraphRefRelationalExpr -> GraphRefRelationalExprM GraphRefRelationalExpr unionMergeRelation prefer relA relB = do let unioned = Union relA relB - mergeErr = MergeTransactionError StrategyViolatesRelationVariableMergeError + mergeErr e = MergeTransactionError (StrategyViolatesRelationVariableMergeError e) preferredRelVar = case prefer of PreferFirst -> pure relA PreferSecond -> pure relB - PreferNeither -> throwError mergeErr + PreferNeither -> throwError (MergeTransactionError StrategyWithoutPreferredBranchResolutionMergeError) handler AttributeNamesMismatchError{} = preferredRelVar - handler _err' = throwError mergeErr + handler err' = throwError (mergeErr err') --typecheck first? (evalGraphRefRelationalExpr unioned >> pure (Union relA relB)) `catchError` handler @@ -47,7 +47,7 @@ unionMergeRelVars prefer relvarsA relvarsB = do lookupA = findRel relvarsA lookupB = findRel relvarsB case (lookupA, lookupB) of - (Just relA, Just relB) -> + (Just relA, Just relB) -> do unionMergeRelation prefer relA relB (Nothing, Just relB) -> pure relB (Just relA, Nothing) -> pure relA diff --git a/test/TransactionGraph/Merge.hs b/test/TransactionGraph/Merge.hs index 0b293285..3a3ee42b 100644 --- a/test/TransactionGraph/Merge.hs +++ b/test/TransactionGraph/Merge.hs @@ -99,7 +99,7 @@ testSubGraphToFirstAncestorBasic = TestCase $ do transB <- assertMaybe (transactionForHead "branchB" graph) "failed to get branchB" subgraph <- assertEither $ subGraphOfFirstCommonAncestor graph (transactionHeadsForGraph graph) transA transB S.empty let graphEq graphArg = S.map transactionId (transactionsForGraph graphArg) - assertEqual "no graph changes" (graphEq subgraph) (graphEq graph) + assertEqual "no graph changes" (graphEq graph) (graphEq subgraph) -- | Test that a branch anchored at the root transaction is removed when using the first ancestor function. testSubGraphToFirstAncestorSnipBranch :: Test @@ -247,7 +247,7 @@ testUnionMergeStrategy = TestCase $ do gfEnv' = freshGraphRefRelationalExprEnv Nothing graph''' case failingMerge of Right _ -> assertFailure "expected merge failure" - Left err -> assertEqual "merge failure" err (MergeTransactionError StrategyViolatesRelationVariableMergeError) + Left err -> assertEqual "merge failure" err (MergeTransactionError StrategyWithoutPreferredBranchResolutionMergeError) -- test that a merge will fail if a constraint is violated testUnionMergeIncDepViolation :: Test From a0f99bcb15449e812a3fa1012aa0abeb2ea3af0b Mon Sep 17 00:00:00 2001 From: AgentM Date: Fri, 19 Jan 2024 11:21:58 -0500 Subject: [PATCH 10/10] fix missing recursion in transaction referenced ids we weren't recursing parent ids, just one level of relvar tids resolves #364 --- .../ProjectM36/ReferencedTransactionIds.hs | 26 ++++++++++++++++-- src/lib/ProjectM36/TransactionGraph.hs | 27 ++++++++++++------- 2 files changed, 42 insertions(+), 11 deletions(-) diff --git a/src/lib/ProjectM36/ReferencedTransactionIds.hs b/src/lib/ProjectM36/ReferencedTransactionIds.hs index 56033428..581f662b 100644 --- a/src/lib/ProjectM36/ReferencedTransactionIds.hs +++ b/src/lib/ProjectM36/ReferencedTransactionIds.hs @@ -1,8 +1,12 @@ {-# LANGUAGE FlexibleInstances #-} module ProjectM36.ReferencedTransactionIds where import ProjectM36.Base +import ProjectM36.Error +import qualified ProjectM36.Transaction as T +import ProjectM36.RelationalExpression import qualified Data.Map as M import qualified Data.Set as S +import Control.Monad (foldM) type TransactionIds = S.Set TransactionId @@ -112,6 +116,24 @@ instance ReferencedTransactionIds DatabaseContext where ] instance ReferencedTransactionIds RelationVariables where - referencedTransactionIds relVars = - S.unions (referencedTransactionIds <$> M.elems relVars) + referencedTransactionIds relVars = + S.unions (referencedTransactionIds <$> M.elems relVars) + +-- | Recurse relvars references and transaction parents to extract a subset of relevant transactions. +-- probably could do some trimming of transactions that are not referenced by relvars, but that is rare, so probably of not much benefit +-- should be trim merge parents that don't contribute to the relvars? maybe +referencedTransactionIdsForTransaction :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction) +referencedTransactionIdsForTransaction trans graph + | parentIds == T.rootParent = pure (S.singleton trans) + | otherwise = + foldM folder (S.singleton trans) parentIds + where + parentIds = parents (transactionInfo trans) + folder acc transId' = do + trans' <- transactionForId transId' graph + transSet <- referencedTransactionIdsForTransaction trans' graph + pure (S.union acc transSet) + + + diff --git a/src/lib/ProjectM36/TransactionGraph.hs b/src/lib/ProjectM36/TransactionGraph.hs index 821b19d6..2d9d229c 100644 --- a/src/lib/ProjectM36/TransactionGraph.hs +++ b/src/lib/ProjectM36/TransactionGraph.hs @@ -403,9 +403,8 @@ subGraphOfFirstCommonAncestor origGraph resultHeads currentTrans' goalTrans trav -- we union all the relevant path transactions together, but we are missing any transactions which these transaction may reference. To make a valid transaction graph, we must include these referenced transactions. let openSet = S.unions (traverseSet : pathsFound) transactionIncluder acc trans = do - let allTids = referencedTransactionIds (concreteDatabaseContext trans) - allTrans <- mapM (`transactionForId` origGraph) (S.toList allTids) - pure $ S.unions (S.singleton trans : S.fromList allTrans : [acc]) + allTrans <- referencedTransactionIdsForTransaction trans origGraph + pure $ S.union allTrans acc closedTransactionSet <- foldM transactionIncluder mempty (S.toList openSet) Right (TransactionGraph resultHeads closedTransactionSet) where @@ -447,6 +446,8 @@ mergeTransactions stamp' newId parentId mergeStrategy (headNameA, headNameB) = d let subHeads = M.filterWithKey (\k _ -> k `elem` [headNameA, headNameB]) (transactionHeadsForGraph graph) -- is this an optimization??? subGraph <- runE $ subGraphOfFirstCommonAncestor graph subHeads transA transB S.empty + _ <- runE $ validateConnectivity subGraph + subGraph' <- runE $ filterSubGraph subGraph subHeads -- we cannot cut the transaction graph away only to "relevant" transactions because transactions can reference other transactions via relvar expressions mergedTrans <- local (const (freshGraphRefRelationalExprEnv Nothing subGraph')) $ @@ -463,18 +464,20 @@ mergeTransactions stamp' newId parentId mergeStrategy (headNameA, headNameB) = d pure (newDiscon, newGraph') --TEMPORARY COPY/PASTE -showTransactionStructureX :: Transaction -> TransactionGraph -> String -showTransactionStructureX trans graph = headInfo ++ " " ++ show (transactionId trans) ++ " " ++ parentTransactionsInfo +showTransactionStructureX :: Bool -> Transaction -> TransactionGraph -> String +showTransactionStructureX showRelVars trans graph = headInfo ++ " " ++ show (transactionId trans) ++ " " ++ parentTransactionsInfo ++ relVarsInfo where + relVarsInfo | showRelVars == False = "" + | otherwise = "\n" <> concatMap show (M.toList (relationVariables (concreteDatabaseContext trans))) headInfo = maybe "" show (headNameForTransaction trans graph) parentTransactionsInfo = if isRootTransaction trans then "root" else case parentTransactions trans graph of Left err -> show err Right parentTransSet -> concat $ S.toList $ S.map (show . transactionId) parentTransSet -showGraphStructureX :: TransactionGraph -> String -showGraphStructureX graph@(TransactionGraph heads transSet) = headsInfo ++ S.foldr folder "" transSet +showGraphStructureX :: Bool -> TransactionGraph -> String +showGraphStructureX showRelVars graph@(TransactionGraph heads transSet) = headsInfo ++ S.foldr folder "" transSet where - folder trans acc = acc ++ showTransactionStructureX trans graph ++ "\n" + folder trans acc = acc ++ showTransactionStructureX showRelVars trans graph ++ "\n" headsInfo = show $ M.map transactionId heads -- | After splicing out a subgraph, run it through this function to remove references to transactions which are not in the subgraph. @@ -637,4 +640,10 @@ validateMerkleHashes graph = Left err -> err : acc _ -> acc - +-- | Ensure that referenced transactions remain in the graph. +validateConnectivity :: TransactionGraph -> Either RelationalError TransactionGraph +validateConnectivity graph = do + let validateTrans trans = + mapM_ (`transactionForId` graph) (referencedTransactionIds (concreteDatabaseContext trans)) + mapM_ validateTrans (transactionsForGraph graph) + pure graph