61b6c35 · project-m36 · git.iko.soy

git.iko.soy/project-m36

first pass at implementing Serialise instances

hoping to cut down on compilation time by moving serialization instances to external modules

commit61b6c3529250496fa052cf97e23837cff855308c authorAgentM <agentm@themactionfaction.com> dateFri 23 Oct 2020, 17:57 (6 years ago) parenta79cfdf

24 files changed+302−189

compare with master

unifiedsplit

cabal.project+10

@@ -7,3 +7,13 @@ source-repository-package

77 type: git

88 location: https://github.com/agentm/distributed-process.git

99 tag: f352e097fbe494ad648b4e09249f865893ae90a3

10+

11+source-repository-package

12+ type: git

13+ location: https://github.com/agentm/curryer.git

14+ tag: 08578c17071c61ce59dbc6cb442c7ec17aeb1294

15+

16+source-repository-package

17+ type: git

18+ location: https://github.com/composewell/streamly.git

19+ tag: e218fb9d8f4263fd69d32a2ff318bac0e179c642

project-m36.cabal+5−2

@@ -34,7 +34,7 @@ Flag haskell-scripting

3434 Default: True

3535

3636Library

37− Build-Depends: base>=4.8 && < 4.15, 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, binary, filepath, zlib, directory, vector-binary-instances, temporary, stm, time, hashable-time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, network-transport, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, distributed-process-client-server >= 0.2.3, distributed-process >= 0.7.4, distributed-process-extras >= 0.3.2, distributed-process-async >= 0.2.4.1, network-transport-tcp >= 0.6.0, network-transport, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256, text-manipulate >= 0.2.0.1 && < 0.3

37+ Build-Depends: base>=4.8 && < 4.15, 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, binary, filepath, zlib, directory, vector-binary-instances, temporary, stm, time, hashable-time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, network-transport, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, distributed-process-client-server >= 0.2.3, distributed-process >= 0.7.4, distributed-process-extras >= 0.3.2, distributed-process-async >= 0.2.4.1, network-transport-tcp >= 0.6.0, network-transport, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256, text-manipulate >= 0.2.0.1 && < 0.3, winery

3838 if flag(haskell-scripting)

3939 Build-Depends: ghc >= 8.2 && < 8.11

4040 CPP-Options: -DPM36_HASKELL_SCRIPTING

@@ -51,6 +51,8 @@ Library

5151 ProjectM36.TransactionGraph.Merge,

5252 ProjectM36.TransGraphRelationalExpression,

5353 ProjectM36.Base,

54+ ProjectM36.Serialise.Base,

55+ ProjectM36.Serialise.Error,

5456 ProjectM36.DataFrame,

5557 ProjectM36.Attribute,

5658 ProjectM36.AttributeNames,

@@ -177,7 +179,8 @@ Executable tutd

177179 attoparsec,

178180 stm-containers >= 1.0.0,

179181 list-t,

180− parser-combinators

182+ parser-combinators,

183+ curryer

181184 Other-Modules: TutorialD.Interpreter,

182185 TutorialD.Interpreter.Base,

183186 TutorialD.Interpreter.DatabaseContextExpr,

src/lib/ProjectM36/AtomFunction.hs+7−5

@@ -1,6 +1,7 @@

11{-# LANGUAGE CPP #-}

22module ProjectM36.AtomFunction where

33import ProjectM36.Base

4+import ProjectM36.Serialise.Base

45import ProjectM36.Error

56import ProjectM36.Relation

67import ProjectM36.AtomType

@@ -11,6 +12,7 @@ import qualified Data.HashSet as HS

1112import qualified Data.Text as T

1213import qualified Data.ByteString.Lazy as BL

1314import Data.Binary as B

15+import Codec.Winery

1416

1517foldAtomFuncType :: AtomType -> AtomType -> [AtomType]

1618--the underscore in the attribute name means that any attributes are acceptable

@@ -91,10 +93,10 @@ atomFunctionsAsRelation funcs = mkRelationFromList attrs tups

9193

9294--for calculating the merkle hash

9395hashBytes :: AtomFunction -> BL.ByteString

94−hashBytes func = mconcat [B.encode (atomFuncName func),

95− B.encode (atomFuncType func),

96− bodyBin

97− ]

96+hashBytes func = BL.fromChunks [serialise (atomFuncName func),

97+ serialise (atomFuncType func),

98+ bodyBin

99+ ]

98100 where

99101 bodyBin = case atomFuncBody func of

100− AtomFunctionBody mScript _ -> B.encode mScript

102+ AtomFunctionBody mScript _ -> serialise mScript

src/lib/ProjectM36/AtomFunctionError.hs+1−2

@@ -1,6 +1,5 @@

11{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}

22module ProjectM36.AtomFunctionError where

3−import Data.Binary

43import GHC.Generics

54import Control.DeepSeq

65import Data.Text

@@ -14,5 +13,5 @@ data AtomFunctionError = AtomFunctionUserError String |

1413 AtomTypeDoesNotSupportOrderingError Text |

1514 AtomTypeDoesNotSupportIntervalError Text |

1615 AtomFunctionBytesDecodingError String

17− deriving(Generic, Eq, Show, Binary, NFData)

16+ deriving(Generic, Eq, Show, NFData)

1817

src/lib/ProjectM36/Atomable.hs+2−2

@@ -13,13 +13,13 @@ import qualified Data.Map as M

1313import qualified Data.Text as T

1414import qualified Data.Vector as V

1515import Control.DeepSeq (NFData)

16−import Data.Binary

1716import Control.Applicative

1817import Data.Time.Calendar

1918import Data.ByteString (ByteString)

2019import Data.Time.Clock

2120import Data.Proxy

2221import qualified Data.List.NonEmpty as NE

22+import Codec.Winery

2323

2424--also add haskell scripting atomable support

2525--rename this module to Atomable along with test

@@ -35,7 +35,7 @@ data Test3T = Test3Ca | Test3Cb

3535 deriving (Generic, Show, Eq, Binary, NFData, Atomable)

3636-}

3737-- | All database values ("atoms") adhere to the 'Atomable' typeclass. This class is derivable allowing new datatypes to be easily marshaling between Haskell values and database values.

38−class (Eq a, NFData a, Binary a, Show a) => Atomable a where

38+class (Eq a, NFData a, Serialise a, Show a) => Atomable a where

3939 toAtom :: a -> Atom

4040 default toAtom :: (Generic a, AtomableG (Rep a)) => a -> Atom

4141 toAtom v = toAtomG (from v) (toAtomTypeG (from v))

src/lib/ProjectM36/Base.hs+23−76

@@ -1,4 +1,4 @@

1−{-# LANGUAGE ExistentialQuantification,DeriveGeneric,DeriveAnyClass,FlexibleInstances,OverloadedStrings, DeriveTraversable #-}

1+{-# LANGUAGE ExistentialQuantification,DeriveGeneric,DeriveAnyClass,FlexibleInstances,OverloadedStrings, DeriveTraversable, DerivingVia #-}

22{-# OPTIONS_GHC -fno-warn-orphans #-}

44module ProjectM36.Base where

@@ -18,15 +18,15 @@ import GHC.Stack

1818import qualified Data.Vector as V

1919import qualified Data.List as L

2020import Data.Text (Text,unpack)

21−import Data.Binary

2221import Data.Vector.Binary()

2322import Data.Time.Clock

24−import Data.Time.Clock.POSIX

25−import Data.Time.Calendar (Day,toGregorian,fromGregorian)

2623import Data.Hashable.Time ()

24+import Data.Time.Calendar (Day)

2725import Data.Typeable

2826import Data.ByteString (ByteString)

2927import qualified Data.List.NonEmpty as NE

28+--import Codec.Winery

29+

3030type StringType = Text

3131

3232-- | Database atoms are the smallest, undecomposable units of a tuple. Common examples are integers, text, or unique identity keys.

@@ -40,7 +40,7 @@ data Atom = IntegerAtom Integer |

4040 BoolAtom Bool |

4141 RelationAtom Relation |

4242 ConstructedAtom DataConstructorName AtomType [Atom]

43− deriving (Eq, Show, Binary, Typeable, NFData, Generic)

43+ deriving (Eq, Show, Typeable, NFData, Generic)

4444

4545instance Hashable Atom where

4646 hashWithSalt salt (ConstructedAtom dConsName _ atoms) = salt `hashWithSalt` atoms

@@ -55,16 +55,6 @@ instance Hashable Atom where

5555 hashWithSalt salt (BoolAtom b) = salt `hashWithSalt` b

5656 hashWithSalt salt (RelationAtom r) = salt `hashWithSalt` r

5757

58−instance Binary UTCTime where

59− put utc = put $ toRational (utcTimeToPOSIXSeconds utc)

60− get = posixSecondsToUTCTime . fromRational <$> (get :: Get Rational)

61−

62−instance Binary Day where

63− put day = put $ toGregorian day

64− get = do

65− (y,m,d) <- get :: Get (Integer, Int, Int)

66− return (fromGregorian y m d)

67−

6858-- I suspect the definition of ConstructedAtomType with its name alone is insufficient to disambiguate the cases; for example, one could create a type named X, remove a type named X, and re-add it using different constructors. However, as long as requests are served from only one DatabaseContext at-a-time, the type name is unambiguous. This will become a problem for time-travel, however.

6959-- | The AtomType uniquely identifies the type of a atom.

7060data AtomType = IntAtomType |

@@ -79,7 +69,7 @@ data AtomType = IntAtomType |

7969 ConstructedAtomType TypeConstructorName TypeVarMap |

8070 TypeVariableType TypeVarName

8171 --wildcard used in Atom Functions and tuples for data constructors which don't provide all arguments to the type constructor

82− deriving (Eq, NFData, Generic, Binary, Show)

72+ deriving (Eq, NFData, Generic, Show)

8373

8474instance Ord AtomType where

8575 compare = undefined

@@ -98,7 +88,7 @@ isRelationAtomType _ = False

9888type AttributeName = StringType

9989

10090-- | A relation's type is composed of attribute names and types.

101−data Attribute = Attribute AttributeName AtomType deriving (Eq, Show, Generic, NFData, Binary)

91+data Attribute = Attribute AttributeName AtomType deriving (Eq, Show, Generic, NFData)

10292

10393instance Hashable Attribute where

10494 hashWithSalt salt (Attribute attrName _) = hashWithSalt salt attrName

@@ -116,10 +106,7 @@ sortedAttributesIndices :: Attributes -> [(Int, Attribute)]

116106sortedAttributesIndices attrs = L.sortBy (\(_, Attribute name1 _) (_,Attribute name2 _) -> compare name1 name2) $ V.toList (V.indexed attrs)

117107

118108-- | The relation's tuple set is the body of the relation.

119−newtype RelationTupleSet = RelationTupleSet { asList :: [RelationTuple] } deriving (Hashable, Show, Generic, Binary)

120−

121−instance Read Relation where

122− readsPrec = error "relation read not supported"

109+newtype RelationTupleSet = RelationTupleSet { asList :: [RelationTuple] } deriving (Hashable, Show, Generic)

123110

124111instance Eq RelationTupleSet where

125112 set1 == set2 = hset set1 == hset set2

@@ -146,8 +133,6 @@ instance Hashable RelationTuple where

146133-- | A tuple is a set of attributes mapped to their 'Atom' values.

147134data RelationTuple = RelationTuple Attributes (V.Vector Atom) deriving (Show, Generic)

148135

149−instance Binary RelationTuple

150−

151136instance Eq RelationTuple where

152137 (==) tuple1@(RelationTuple attrs1 _) tuple2@(RelationTuple attrs2 _) = attributesEqual attrs1 attrs2 && atomsEqual

153138 where

@@ -158,7 +143,6 @@ instance Eq RelationTuple where

158143

159144instance NFData RelationTuple where rnf = genericRnf

160145

161−

162146data Relation = Relation Attributes RelationTupleSet deriving (Show, Generic,Typeable)

163147

164148instance Eq Relation where

@@ -173,8 +157,6 @@ instance Hashable Relation where

173157 where

174158 sortedAttrs = map snd (sortedAttributesIndices attrs)

175159

176−instance Binary Relation

177−

178160-- | Used to represent the number of tuples in a relation.

179161data RelationCardinality = Countable | Finite Int deriving (Eq, Show, Generic, Ord)

180162

@@ -221,15 +203,11 @@ data RelationalExprBase a =

221203 With [(WithNameExprBase a, RelationalExprBase a)] (RelationalExprBase a)

222204 deriving (Show, Eq, Generic, NFData, Foldable, Functor, Traversable)

223205

224−instance Binary RelationalExpr

225−

226206data WithNameExprBase a = WithNameExpr RelVarName a

227207 deriving (Show, Eq, Generic, NFData, Foldable, Functor, Traversable)

228208

229209type WithNameExpr = WithNameExprBase ()

230210

231−instance Binary WithNameExpr

232−

233211type GraphRefWithNameExpr = WithNameExprBase GraphRefTransactionMarker

234212

235213type NotificationName = StringType

@@ -241,14 +219,14 @@ data Notification = Notification {

241219 reportOldExpr :: RelationalExpr, --run the expression in the pre-change context

242220 reportNewExpr :: RelationalExpr --run the expression in the post-change context

243221 }

244− deriving (Show, Eq, Binary, Generic, NFData)

222+ deriving (Show, Eq, Generic, NFData)

245223

246224type TypeVarName = StringType

247225

248226-- | Metadata definition for type constructors such as @data Either a b@.

249227data TypeConstructorDef = ADTypeConstructorDef TypeConstructorName [TypeVarName] |

250228 PrimitiveTypeConstructorDef TypeConstructorName AtomType

251− deriving (Show, Generic, Binary, Eq, NFData)

229+ deriving (Show, Generic, Eq, NFData)

252230

253231-- | Found in data constructors and type declarations: Left (Either Int Text) | Right Int

254232type TypeConstructor = TypeConstructorBase ()

@@ -256,7 +234,7 @@ data TypeConstructorBase a = ADTypeConstructor TypeConstructorName [TypeConstruc

256234 PrimitiveTypeConstructor TypeConstructorName AtomType |

257235 RelationAtomTypeConstructor [AttributeExprBase a] |

258236 TypeVariable TypeVarName

259− deriving (Show, Generic, Binary, Eq, NFData)

237+ deriving (Show, Generic, Eq, NFData)

260238

261239type TypeConstructorMapping = [(TypeConstructorDef, DataConstructorDefs)]

262240

@@ -266,20 +244,20 @@ type DataConstructorName = StringType

266244type AtomTypeName = StringType

267245

268246-- | Used to define a data constructor in a type constructor context such as @Left a | Right b@

269−data DataConstructorDef = DataConstructorDef DataConstructorName [DataConstructorDefArg] deriving (Eq, Show, Binary, Generic, NFData)

247+data DataConstructorDef = DataConstructorDef DataConstructorName [DataConstructorDefArg] deriving (Eq, Show, Generic, NFData)

270248

271249type DataConstructorDefs = [DataConstructorDef]

272250

273251data DataConstructorDefArg = DataConstructorDefTypeConstructorArg TypeConstructor |

274252 DataConstructorDefTypeVarNameArg TypeVarName

275− deriving (Show, Generic, Binary, Eq, NFData)

253+ deriving (Show, Generic, Eq, NFData)

276254

277255type InclusionDependencies = M.Map IncDepName InclusionDependency

278256type RelationVariables = M.Map RelVarName GraphRefRelationalExpr

279257

280258data GraphRefTransactionMarker = TransactionMarker TransactionId |

281259 UncommittedContextMarker

282− deriving (Eq, Show, Binary, Generic, NFData, Ord)

260+ deriving (Eq, Show, Generic, NFData, Ord)

283261

284262-- a fundamental relational expr to which other relational expressions compile

285263type GraphRefRelationalExpr = RelationalExprBase GraphRefTransactionMarker

@@ -290,17 +268,18 @@ type Subschemas = M.Map SchemaName Schema

290268

291269-- | Every transaction has one concrete database context and any number of isomorphic subschemas.

292270data Schemas = Schemas DatabaseContext Subschemas

271+ deriving (Generic)

293272

294273-- | The DatabaseContext is a snapshot of a database's evolving state and contains everything a database client can change over time.

295274-- I spent some time thinking about whether the VirtualDatabaseContext/Schema and DatabaseContext data constructors should be the same constructor, but that would allow relation variables to be created in a "virtual" context which would appear to defeat the isomorphisms of the contexts. It should be possible to switch to an alternative schema to view the same equivalent information without information loss. However, allowing all contexts to reference another context while maintaining its own relation variables, new types, etc. could be interesting from a security perspective. For example, if a user creates a new relvar in a virtual context, then does it necessarily appear in all linked contexts? After deliberation, I think the relvar should appear in *all* linked contexts to retain the isomorphic properties, even when the isomorphism is for a subset of the context. This hints that the IsoMorphs should allow for "fall-through"; that is, when a relvar is not defined in the virtual context (for morphing), then the lookup should fall through to the underlying context.

296275newtype Schema = Schema SchemaIsomorphs

297− deriving (Generic, Binary)

276+ deriving (Generic)

298277

299278data SchemaIsomorph = IsoRestrict RelVarName RestrictionPredicateExpr (RelVarName, RelVarName) |

300279 IsoRename RelVarName RelVarName |

301280 IsoUnion (RelVarName, RelVarName) RestrictionPredicateExpr RelVarName --maps two relvars to one relvar

302281 -- IsoTypeConstructor in morphAttrExpr

303− deriving (Generic, Binary, Show)

282+ deriving (Generic, Show)

304283

305284type SchemaIsomorphs = [SchemaIsomorph]

306285

@@ -318,8 +297,6 @@ type IncDepName = StringType

318297-- | Inclusion dependencies represent every possible database constraint. Constraints enforce specific, arbitrarily-complex rules to which the database context's relation variables must adhere unconditionally.

319298data InclusionDependency = InclusionDependency RelationalExpr RelationalExpr deriving (Show, Eq, Generic, NFData)

320299

321−instance Binary InclusionDependency

322−

323300type AttributeNameAtomExprMap = M.Map AttributeName AtomExpr

324301

325302--used for returning information about individual expressions

@@ -329,8 +306,6 @@ type DatabaseContextExpr = DatabaseContextExprBase ()

329306

330307type GraphRefDatabaseContextExpr = DatabaseContextExprBase GraphRefTransactionMarker

331308

332−instance Binary GraphRefDatabaseContextExpr

333−

334309-- | Database context expressions modify the database context.

335310data DatabaseContextExprBase a =

336311 NoOperation |

@@ -360,8 +335,6 @@ data DatabaseContextExprBase a =

360335 MultipleExpr [DatabaseContextExprBase a]

361336 deriving (Show, Eq, Generic)

362337

363−instance Binary DatabaseContextExpr

364−

365338type ObjModuleName = StringType

366339type ObjFunctionName = StringType

367340type Range = (Int,Int)

@@ -372,7 +345,7 @@ data DatabaseContextIOExprBase a =

372345 AddDatabaseContextFunction DatabaseContextFunctionName [TypeConstructor] DatabaseContextFunctionBodyScript |

373346 LoadDatabaseContextFunctions ObjModuleName ObjFunctionName FilePath |

374347 CreateArbitraryRelation RelVarName [AttributeExprBase a] Range

375− deriving (Show, Eq, Generic, Binary)

348+ deriving (Show, Eq, Generic)

376349

377350type GraphRefDatabaseContextIOExpr = DatabaseContextIOExprBase GraphRefTransactionMarker

378351

@@ -393,8 +366,6 @@ data RestrictionPredicateExprBase a =

393366 AttributeEqualityPredicate AttributeName (AtomExprBase a) -- relationalexpr must result in relation with single tuple

394367 deriving (Show, Eq, Generic, NFData, Foldable, Functor, Traversable)

395368

396−instance Binary RestrictionPredicateExpr

397−

398369-- child + parent links

399370-- | A transaction graph's head name references the leaves of the transaction graph and can be used during session creation to indicate at which point in the graph commits should persist.

400371type HeadName = StringType

@@ -403,6 +374,7 @@ type TransactionHeads = M.Map HeadName Transaction

403374

404375-- | The transaction graph is the global database's state which references every committed transaction.

405376data TransactionGraph = TransactionGraph TransactionHeads (S.Set Transaction)

377+ deriving Generic

406378

407379transactionHeadsForGraph :: TransactionGraph -> TransactionHeads

408380transactionHeadsForGraph (TransactionGraph hs _) = hs

@@ -425,12 +397,11 @@ data TransactionInfo = TransactionInfo TransactionId TransactionDiffs UTCTime |

425397 deriving (Show, Generic)

426398-}

427399

428−instance Binary TransactionInfo

429−

430400-- | Every set of modifications made to the database are atomically committed to the transaction graph as a transaction.

431401type TransactionId = UUID

432402

433403data Transaction = Transaction TransactionId TransactionInfo Schemas

404+ deriving Generic

434405

435406-- | The disconnected transaction represents an in-progress workspace used by sessions before changes are committed. This is similar to git's "index". After a transaction is committed, it is "connected" in the transaction graph and can no longer be modified.

436407data DisconnectedTransaction = DisconnectedTransaction TransactionId Schemas DirtyFlag

@@ -464,8 +435,6 @@ data AtomExprBase a = AttributeAtomExpr AttributeName |

464435 ConstructedAtomExpr DataConstructorName [AtomExprBase a] a

465436 deriving (Eq,Show,Generic, NFData, Foldable, Functor, Traversable)

466437

467−instance Binary AtomExpr

468−

469438-- | Used in tuple creation when creating a relation.

470439data ExtendTupleExprBase a = AttributeExtendTupleExpr AttributeName (AtomExprBase a)

471440 deriving (Show, Eq, Generic, NFData, Foldable, Functor, Traversable)

@@ -473,8 +442,6 @@ data ExtendTupleExprBase a = AttributeExtendTupleExpr AttributeName (AtomExprBas

473442type ExtendTupleExpr = ExtendTupleExprBase ()

474443type GraphRefExtendTupleExpr = ExtendTupleExprBase GraphRefTransactionMarker

475444

476−instance Binary ExtendTupleExpr

477−

478445--enumerates the list of functions available to be run as part of tuple expressions

479446type AtomFunctions = HS.HashSet AtomFunction

480447

@@ -485,6 +452,7 @@ type AtomFunctionBodyScript = StringType

485452type AtomFunctionBodyType = [Atom] -> Either AtomFunctionError Atom

486453

487454data AtomFunctionBody = AtomFunctionBody (Maybe AtomFunctionBodyScript) AtomFunctionBodyType

455+ deriving Generic

488456

489457instance NFData AtomFunctionBody where

490458 rnf (AtomFunctionBody mScript _) = rnf mScript

@@ -525,8 +493,6 @@ type AttributeNames = AttributeNamesBase ()

525493

526494type GraphRefAttributeNames = AttributeNamesBase GraphRefTransactionMarker

527495

528−instance Binary AttributeNames

529−

530496-- | The persistence strategy is a global database option which represents how to persist the database in the filesystem, if at all.

531497data PersistenceStrategy = NoPersistence | -- ^ no filesystem persistence/memory-only database

532498 MinimalPersistence FilePath | -- ^ fsync off, not crash-safe

@@ -539,14 +505,12 @@ type GraphRefAttributeExpr = AttributeExprBase GraphRefTransactionMarker

539505-- | Create attributes dynamically.

540506data AttributeExprBase a = AttributeAndTypeNameExpr AttributeName TypeConstructor a |

541507 NakedAttributeExpr Attribute

542− deriving (Eq, Show, Generic, Binary, NFData, Foldable, Functor, Traversable)

508+ deriving (Eq, Show, Generic, NFData, Foldable, Functor, Traversable)

543509

544510-- | Dynamically create a tuple from attribute names and 'AtomExpr's.

545511newtype TupleExprBase a = TupleExpr (M.Map AttributeName (AtomExprBase a))

546512 deriving (Eq, Show, Generic, NFData, Foldable, Functor, Traversable)

547513

548−instance Binary TupleExpr

549−

550514type TupleExpr = TupleExprBase ()

551515

552516type GraphRefTupleExpr = TupleExprBase GraphRefTransactionMarker

@@ -558,8 +522,6 @@ type GraphRefTupleExprs = TupleExprsBase GraphRefTransactionMarker

558522

559523type TupleExprs = TupleExprsBase ()

560524

561−instance Binary TupleExprs

562−

563525data MergeStrategy =

564526 -- | After a union merge, the merge transaction is a result of union'ing relvars of the same name, introducing all uniquely-named relvars, union of constraints, union of atom functions, notifications, and types (unless the names and definitions collide, e.g. two types of the same name with different definitions)

565527 UnionMergeStrategy |

@@ -567,7 +529,7 @@ data MergeStrategy =

567529 UnionPreferMergeStrategy HeadName |

568530 -- | Similar to the our/theirs merge strategy in git, the merge transaction's context is identical to that of the last transaction in the selected branch.

569531 SelectedBranchMergeStrategy HeadName

570− deriving (Eq, Show, Binary, Generic, NFData)

532+ deriving (Eq, Show, Generic, NFData)

571533

572534type DatabaseContextFunctionName = StringType

573535

@@ -635,20 +597,5 @@ unimplemented :: HasCallStack => a

635597unimplemented = undefined

636598

637599--for serializing GraphRefRelationalExpr as part of transaction serialization

638−instance Binary (TupleExprsBase GraphRefTransactionMarker)

639−

640−instance Binary (TupleExprBase GraphRefTransactionMarker)

641−

642−instance Binary GraphRefRelationalExpr

643−

644−instance Binary (AtomExprBase GraphRefTransactionMarker)

645−

646−instance Binary (AttributeNamesBase GraphRefTransactionMarker)

647−

648−instance Binary (RestrictionPredicateExprBase GraphRefTransactionMarker)

649−

650−instance Binary (ExtendTupleExprBase GraphRefTransactionMarker)

651−

652−instance Binary GraphRefWithNameExpr

653600

654601

src/lib/ProjectM36/Client.hs−15

@@ -136,24 +136,9 @@ import qualified ProjectM36.Relation as R

136136import Control.Exception.Base

137137import GHC.Conc.Sync

138138

139−import Network.Transport (Transport(closeTransport))

140−#if MIN_VERSION_network_transport_tcp(0,7,0)

141−import Network.Transport.TCP (createTransport, defaultTCPParameters, defaultTCPAddr)

142−import Network.Transport.TCP.Internal (encodeEndPointAddress)

143−#elif MIN_VERSION_network_transport_tcp(0,6,0)

144−import Network.Transport.TCP (createTransport, defaultTCPParameters)

145−import Network.Transport.TCP.Internal (encodeEndPointAddress)

146−#else

147−import Network.Transport.TCP (encodeEndPointAddress, createTransport, defaultTCPParameters)

148−#endif

149−

150−import Control.Distributed.Process.Node (newLocalNode, initRemoteTable, runProcess, LocalNode, forkProcess, closeLocalNode)

151−import Control.Distributed.Process.Extras.Internal.Types (whereisRemote)

152−import Control.Distributed.Process.ManagedProcess.Client (call, safeCall)

153139import Data.Either (isRight)

154140import Data.UUID.V4 (nextRandom)

155141import Data.Word

156−import Control.Distributed.Process (ProcessId, Process, receiveWait, send, match, NodeId(..), reconnect)

157142import Control.Exception (IOException, handle, AsyncException, throwIO, fromException, Exception)

158143import Control.Concurrent.MVar

159144import qualified Data.Map as M

src/lib/ProjectM36/DataFrame.hs+18−8

@@ -1,9 +1,10 @@

1−{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}

1+{-# LANGUAGE DeriveGeneric, DeriveAnyClass, DerivingVia #-}

22{- A dataframe is a strongly-typed, ordered list of named tuples. A dataframe differs from a relation in that its tuples are ordered.-}

33module ProjectM36.DataFrame where

44import ProjectM36.Base

55import ProjectM36.Attribute as A

66import ProjectM36.Error

7+import ProjectM36.Serialise.Base

78import qualified ProjectM36.Relation as R

89import ProjectM36.Relation.Show.Term

910import qualified ProjectM36.Relation.Show.HTML as RelHTML

@@ -16,15 +17,20 @@ import qualified Data.List as L

1617import qualified Data.Set as S

1718import Data.Maybe

1819import qualified Data.Text as T

19−import Data.Binary

2020import Control.Arrow

2121#if __GLASGOW_HASKELL__ < 804

2222import Data.Monoid

2323#endif

2424

25−data AttributeOrderExpr = AttributeOrderExpr AttributeName Order deriving (Show, Generic, Binary)

26−data AttributeOrder = AttributeOrder AttributeName Order deriving (Show, Generic, Binary)

27−data Order = AscendingOrder | DescendingOrder deriving (Eq, Show, Generic, Binary)

25+data AttributeOrderExpr = AttributeOrderExpr AttributeName Order

26+ deriving (Show, Generic)

27+

28+data AttributeOrder = AttributeOrder AttributeName Order

29+ deriving (Show, Generic)

30+

31+data Order = AscendingOrder | DescendingOrder

32+ deriving (Eq, Show, Generic)

33+

2834

2935ascending :: T.Text

3036ascending = "⬆"

@@ -39,9 +45,11 @@ data DataFrame = DataFrame {

3945 orders :: [AttributeOrder],

4046 attributes :: Attributes,

4147 tuples :: [DataFrameTuple]

42− } deriving (Show, Generic, Binary)

48+ }

49+ deriving (Show, Generic)

4350

44−data DataFrameTuple = DataFrameTuple Attributes (V.Vector Atom) deriving (Eq, Show, Generic, Binary)

51+data DataFrameTuple = DataFrameTuple Attributes (V.Vector Atom)

52+ deriving (Eq, Show, Generic)

4553

4654sortDataFrameBy :: [AttributeOrder] -> DataFrame -> Either RelationalError DataFrame

4755sortDataFrameBy attrOrders frame = do

@@ -122,7 +130,9 @@ data DataFrameExpr = DataFrameExpr {

122130 orderExprs :: [AttributeOrderExpr],

123131 offset :: Maybe Integer,

124132 limit :: Maybe Integer

125− } deriving (Show, Binary, Generic)

133+ }

134+ deriving (Show, Generic)

135+

126136

127137dataFrameAsHTML :: DataFrame -> T.Text

128138-- web browsers don't display tables with empty cells or empty headers, so we have to insert some placeholders- it's not technically the same, but looks as expected in the browser

src/lib/ProjectM36/DatabaseContext.hs+6−5

@@ -10,6 +10,7 @@ import qualified Data.ByteString.Lazy as BL

1010import Data.Binary as B

1111import ProjectM36.AtomFunction as AF

1212import ProjectM36.DatabaseContextFunction as DBCF

13+import Codec.Winery

1314

1415empty :: DatabaseContext

1516empty = DatabaseContext { inclusionDependencies = M.empty,

@@ -44,11 +45,11 @@ basicDatabaseContext = DatabaseContext { inclusionDependencies = M.empty,

4445

4546--for building the Merkle hash

4647hashBytes :: DatabaseContext -> BL.ByteString

47−hashBytes ctx = mconcat [incDeps, rvs, atomFs, dbcFs, nots, tConsMap]

48+hashBytes ctx = BL.fromChunks [incDeps, rvs, nots, tConsMap] <> atomFs <> dbcFs

4849 where

49− incDeps = B.encode (inclusionDependencies ctx)

50− rvs = B.encode (relationVariables ctx)

50+ incDeps = serialise (inclusionDependencies ctx)

51+ rvs = serialise (relationVariables ctx)

5152 atomFs = HS.foldr (mappend . AF.hashBytes) mempty (atomFunctions ctx)

5253 dbcFs = HS.foldr (mappend . DBCF.hashBytes) mempty (dbcFunctions ctx)

53− nots = B.encode (notifications ctx)

54− tConsMap = B.encode (typeConstructorMapping ctx)

54+ nots = serialise (notifications ctx)

55+ tConsMap = serialise (typeConstructorMapping ctx)

src/lib/ProjectM36/DatabaseContextFunction.hs+6−5

@@ -3,6 +3,7 @@ module ProjectM36.DatabaseContextFunction where

33--implements functions which operate as: [Atom] -> DatabaseContextExpr -> Either RelationalError DatabaseContextExpr

44import ProjectM36.Base

55import ProjectM36.Error

6+import ProjectM36.Serialise.Base

67import ProjectM36.Attribute as A

78import ProjectM36.Relation

89import ProjectM36.AtomType

@@ -11,7 +12,7 @@ import qualified Data.Map as M

1112import ProjectM36.ScriptSession

1213import qualified Data.Text as T

1314import qualified Data.ByteString.Lazy as BL

14−import Data.Binary as B

15+import Codec.Winery

1516

1617emptyDatabaseContextFunction :: DatabaseContextFunctionName -> DatabaseContextFunction

1718emptyDatabaseContextFunction name = DatabaseContextFunction {

@@ -82,9 +83,9 @@ databaseContextFunctionsAsRelation dbcFuncs = mkRelationFromList attrs tups

8283

8384-- for merkle hash

8485hashBytes :: DatabaseContextFunction -> BL.ByteString

85−hashBytes func = mconcat [fname, ftype, fbody]

86+hashBytes func = BL.fromChunks [fname, ftype, fbody]

8687 where

87− fname = B.encode (dbcFuncName func)

88− ftype = B.encode (dbcFuncType func)

88+ fname = serialise (dbcFuncName func)

89+ ftype = serialise (dbcFuncType func)

8990 fbody = case dbcFuncBody func of

90− DatabaseContextFunctionBody mBody _ -> B.encode mBody

91+ DatabaseContextFunctionBody mBody _ -> serialise mBody

src/lib/ProjectM36/Error.hs+6−7

@@ -9,7 +9,6 @@ import Control.DeepSeq (NFData, rnf)

99import Control.DeepSeq.Generics (genericRnf)

1010import GHC.Generics (Generic)

1111import qualified Data.Text as T

12−import Data.Binary

1312import Data.Typeable

1413import Control.Exception

1514

@@ -106,12 +105,12 @@ data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName)

106105 | MerkleHashValidationError TransactionId MerkleHash MerkleHash

107106

108107 | MultipleErrors [RelationalError]

109− deriving (Show,Eq,Generic,Binary,Typeable, NFData)

108+ deriving (Show,Eq,Generic,Typeable, NFData)

110109

111110data PersistenceError = InvalidDirectoryError FilePath |

112111 MissingTransactionError TransactionId |

113112 WrongDatabaseFormatVersionError String String

114− deriving (Show, Eq, Generic, Binary, NFData)

113+ deriving (Show, Eq, Generic, NFData)

115114

116115--collapse list of errors into normal error- if there is just one, just return one

117116someErrors :: [RelationalError] -> RelationalError

@@ -129,7 +128,7 @@ data MergeError = SelectedHeadMismatchMergeError |

129128 StrategyViolatesComponentMergeError | --failed merge in inc deps, relvars, etc.

130129 StrategyViolatesRelationVariableMergeError |

131130 StrategyViolatesTypeConstructorMergeError

132− deriving (Show, Eq, Generic, Binary, Typeable)

131+ deriving (Show, Eq, Generic, Typeable)

133132

134133instance NFData MergeError where rnf = genericRnf

135134

@@ -137,17 +136,17 @@ data ScriptCompilationError = TypeCheckCompilationError String String | --expect

137136 SyntaxErrorCompilationError String |

138137 ScriptCompilationDisabledError |

139138 OtherScriptCompilationError String

140− deriving (Show, Eq, Generic, Binary, Typeable, NFData)

139+ deriving (Show, Eq, Generic, Typeable, NFData)

141140

142141instance Exception ScriptCompilationError

143142

144143data SchemaError = RelVarReferencesMissing (S.Set RelVarName) |

145144 RelVarInReferencedMoreThanOnce RelVarName |

146145 RelVarOutReferencedMoreThanOnce RelVarName

147− deriving (Show, Eq, Generic, Binary, Typeable, NFData)

146+ deriving (Show, Eq, Generic, Typeable, NFData)

148147

149148

150149-- errors returned from the distributed-process call handlers

151150data ServerError = RequestTimeoutError |

152151 ProcessDiedError String

153− deriving (Generic, Binary, Eq)

152+ deriving (Generic, Eq)

src/lib/ProjectM36/IsomorphicSchema.hs+4−3

@@ -1,4 +1,4 @@

1−{-# LANGUAGE DeriveGeneric, DeriveAnyClass, LambdaCase #-}

1+{-# LANGUAGE DeriveGeneric, DeriveAnyClass, LambdaCase, DerivingVia #-}

22module ProjectM36.IsomorphicSchema where

33import ProjectM36.Base

44import ProjectM36.Error

@@ -9,10 +9,10 @@ import ProjectM36.RelationalExpression

99import qualified ProjectM36.AttributeNames as AN

1010import Control.Monad

1111import GHC.Generics

12−import Data.Binary

1312import qualified Data.Map as M

1413import qualified Data.Set as S

1514import qualified Data.List as L

15+import Codec.Winery hiding (Schema)

1616#if __GLASGOW_HASKELL__ < 804

1717import Data.Monoid

1818#endif

@@ -28,7 +28,8 @@ import Data.Monoid

2828

2929data SchemaExpr = AddSubschema SchemaName SchemaIsomorphs |

3030 RemoveSubschema SchemaName

31− deriving (Generic, Binary, Show)

31+ deriving (Generic, Show)

32+ deriving Serialise via WineryVariant SchemaExpr

3233

3334

3435isomorphs :: Schema -> SchemaIsomorphs

src/lib/ProjectM36/Persist.hs+3−3

@@ -100,10 +100,10 @@ syncDirectory :: DiskSync -> FilePath -> IO ()

100100syncDirectory FsyncDiskSync path = directoryFsync path

101101syncDirectory NoDiskSync _ = pure ()

102102

103−writeBSFileSync :: DiskSync -> FilePath -> BS.ByteString -> IO ()

103+writeBSFileSync :: DiskSync -> FilePath -> BS'.ByteString -> IO ()

104104writeBSFileSync sync path bstring =

105105 withFile path WriteMode $ \handle -> do

106− BS.hPut handle bstring

106+ BS'.hPut handle bstring

107107 syncHandle sync handle

108108

109109directoryFsync :: FilePath -> IO ()

@@ -131,4 +131,4 @@ fdCount = do

131131 fds <- getDirectoryContents FDDIR

132132 pure ((length fds) - 2)

133133--not supported on non-linux

134−#endif

134+#endif

src/lib/ProjectM36/Serialise/AtomFunctionError.hsnew file+9

@@ -0,0 +1,9 @@

1+{-# LANGUAGE DerivingVia, StandaloneDeriving #-}

2+{-# OPTIONS_GHC -fno-warn-orphans #-}

3+module ProjectM36.Serialise.AtomFunctionError where

4+import ProjectM36.Error

5+import Codec.Winery

6+import ProjectM36.Serialise.Base

7+import ProjectM36.AtomFunctionError

9+deriving via WineryVariant AtomFunctionError instance Serialise AtomFunctionError

src/lib/ProjectM36/Serialise/Base.hsnew file+77

@@ -0,0 +1,77 @@

1+{-# LANGUAGE StandaloneDeriving, DerivingVia, TypeApplications, TypeSynonymInstances, ScopedTypeVariables, GeneralizedNewtypeDeriving #-}

2+{-# OPTIONS_GHC -fno-warn-orphans #-}

3+--Serialise instances for ProjectM36.Base data types- orphan instance city

4+module ProjectM36.Serialise.Base where

5+import Codec.Winery hiding (Schema)

6+import Codec.Winery.Internal hiding (Schema)

7+import Control.Monad

8+import ProjectM36.Base

9+import ProjectM36.MerkleHash

10+import Data.UUID

11+import Data.Proxy

12+import Data.Word

13+import qualified Data.List.NonEmpty as NE

14+import qualified Data.Vector as V

15+import Data.Time.Calendar (Day,toGregorian,fromGregorian)

16+

17+deriving via WineryVariant Atom instance Serialise Atom

18+deriving via WineryVariant AtomType instance Serialise AtomType

19+deriving via WineryVariant Attribute instance Serialise Attribute

20+deriving via WineryVariant RelationTupleSet instance Serialise RelationTupleSet

21+deriving via WineryVariant RelationTuple instance Serialise RelationTuple

22+deriving via WineryVariant Relation instance Serialise Relation

23+deriving via WineryVariant RelationCardinality instance Serialise RelationCardinality

24+deriving via WineryVariant (RelationalExprBase a) instance Serialise a => Serialise (RelationalExprBase a)

25+deriving via WineryVariant (WithNameExprBase a) instance Serialise a => Serialise (WithNameExprBase a)

26+deriving via WineryVariant Notification instance Serialise Notification

27+deriving via WineryVariant TypeConstructorDef instance Serialise TypeConstructorDef

28+deriving via WineryVariant (TypeConstructorBase a) instance Serialise a => Serialise (TypeConstructorBase a)

29+deriving via WineryVariant DataConstructorDef instance Serialise DataConstructorDef

30+deriving via WineryVariant DataConstructorDefArg instance Serialise DataConstructorDefArg

31+deriving via WineryVariant GraphRefTransactionMarker instance Serialise GraphRefTransactionMarker

32+deriving via WineryVariant SchemaIsomorph instance Serialise SchemaIsomorph

33+deriving via WineryVariant InclusionDependency instance Serialise InclusionDependency

34+deriving via WineryVariant (DatabaseContextExprBase a) instance Serialise a => Serialise (DatabaseContextExprBase a)

35+deriving via WineryVariant (DatabaseContextIOExprBase a) instance Serialise a => Serialise (DatabaseContextIOExprBase a)

36+deriving via WineryVariant (RestrictionPredicateExprBase a) instance Serialise a => Serialise (RestrictionPredicateExprBase a)

37+deriving via WineryVariant TransactionInfo instance Serialise TransactionInfo

38+deriving via WineryVariant (AtomExprBase a) instance Serialise a => Serialise (AtomExprBase a)

39+deriving via WineryVariant MerkleHash instance Serialise MerkleHash

40+deriving via WineryVariant (AttributeExprBase a) instance Serialise a => Serialise (AttributeExprBase a)

41+deriving via WineryVariant (TupleExprsBase a) instance Serialise a => Serialise (TupleExprsBase a)

42+deriving via WineryVariant (TupleExprBase a) instance Serialise a => Serialise (TupleExprBase a)

43+deriving via WineryVariant (AttributeNamesBase a) instance Serialise a => Serialise (AttributeNamesBase a)

44+deriving via WineryVariant (ExtendTupleExprBase a) instance Serialise a => Serialise (ExtendTupleExprBase a)

45+deriving via WineryVariant Schema instance Serialise Schema

46+deriving via WineryVariant MergeStrategy instance Serialise MergeStrategy

47+

48+

49+fromWordsTup :: (Word32, Word32, Word32, Word32) -> TransactionId

50+fromWordsTup (a,b,c,d) = fromWords a b c d

51+

52+instance Serialise TransactionId where

53+ schemaGen _ = getSchema (Proxy @(Word32, Word32, Word32, Word32))

54+ toBuilder uuid = toBuilder (toWords uuid)

55+ extractor = fromWordsTup <$> extractor

56+ decodeCurrent = fromWordsTup <$> decodeCurrent

57+

58+instance Serialise a => Serialise (NE.NonEmpty a) where

59+ schemaGen _ = SVector <$> getSchema (Proxy @a)

60+ toBuilder xs = varInt (length xs) <> foldMap toBuilder xs

61+ extractor = NE.fromList . V.toList <$> extractListBy extractor --use nonempty instead to replace error with winery error

62+ decodeCurrent = do

63+ n <- decodeVarInt

64+ l <- replicateM n decodeCurrent

65+ pure (NE.fromList l)

66+

67+fromGregorianTup :: (Integer, Int, Int) -> Day

68+fromGregorianTup (a, b, c) = fromGregorian a b c

69+

70+instance Serialise Day where

71+ schemaGen _ = getSchema (Proxy @(Integer, Int, Int))

72+ toBuilder day = toBuilder (toGregorian day)

73+ extractor = fromGregorianTup <$> extractor

74+ decodeCurrent = fromGregorianTup <$> decodeCurrent

75+

76+

77+

src/lib/ProjectM36/Serialise/DataFrame.hsnew file+12

@@ -0,0 +1,12 @@

1+{-# LANGUAGE DerivingVia, StandaloneDeriving #-}

2+{-# OPTIONS_GHC -fno-warn-orphans #-}

3+module ProjectM36.Serialise.DataFrame where

4+import Codec.Winery

5+import ProjectM36.DataFrame

7+deriving via WineryVariant AttributeOrderExpr instance Serialise AttributeOrderExpr

8+deriving via WineryVariant AttributeOrder instance Serialise AttributeOrder

9+deriving via WineryVariant Order instance Serialise Order

10+deriving via WineryRecord DataFrame instance Serialise DataFrame

11+deriving via WineryVariant DataFrameTuple instance Serialise DataFrameTuple

12+deriving via WineryRecord DataFrameExpr instance Serialise DataFrameExpr

src/lib/ProjectM36/Serialise/DatabaseContextFunctionError.hsnew file+9

@@ -0,0 +1,9 @@

1+{-# LANGUAGE DerivingVia, StandaloneDeriving #-}

2+{-# OPTIONS_GHC -fno-warn-orphans #-}

3+module ProjectM36.Serialise.DatabaseContextFunctionError where

4+import ProjectM36.Error

5+import Codec.Winery

6+import ProjectM36.Serialise.Base

7+import ProjectM36.DatabaseContextFunctionError

9+deriving via WineryVariant DatabaseContextFunctionError instance Serialise DatabaseContextFunctionError

src/lib/ProjectM36/Serialise/Error.hsnew file+14

@@ -0,0 +1,14 @@

1+{-# LANGUAGE DerivingVia, StandaloneDeriving #-}

2+{-# OPTIONS_GHC -fno-warn-orphans #-}

3+module ProjectM36.Serialise.Error where

4+import ProjectM36.Error

5+import Codec.Winery

6+import ProjectM36.Serialise.Base

7+import ProjectM36.Serialise.AtomFunctionError

8+import ProjectM36.Serialise.DatabaseContextFunctionError

10+deriving via WineryVariant RelationalError instance Serialise RelationalError

11+deriving via WineryVariant MergeError instance Serialise MergeError

12+deriving via WineryVariant ScriptCompilationError instance Serialise ScriptCompilationError

13+deriving via WineryVariant PersistenceError instance Serialise PersistenceError

14+deriving via WineryVariant SchemaError instance Serialise SchemaError

src/lib/ProjectM36/Serialise/MergeError.hsnew file+1

@@ -0,0 +1 @@

src/lib/ProjectM36/Server.hs−10

@@ -8,16 +8,6 @@ import ProjectM36.Server.Config (ServerConfig(..))

88import ProjectM36.FSType

1010import Control.Monad.IO.Class (liftIO)

11−#if MIN_VERSION_network_transport_tcp(0,7,0)

12−import Network.Transport.TCP (createTransport, defaultTCPParameters, defaultTCPAddr)

13−#else

14−import Network.Transport.TCP (createTransport, defaultTCPParameters)

15−#endif

16−import Network.Transport (EndPointAddress(..), newEndPoint, address)

17−import Control.Distributed.Process.Node (initRemoteTable, runProcess, newLocalNode, initRemoteTable)

18−import Control.Distributed.Process.Extras.Time (Delay(..))

19−import Control.Distributed.Process (Process, register, getSelfPid)

20−import Control.Distributed.Process.ManagedProcess (defaultProcess, UnhandledMessagePolicy(..), ProcessDefinition(..), handleCall, serve, InitHandler, InitResult(..))

2111import Control.Concurrent.MVar (putMVar, MVar)

2212import System.IO (stderr, hPutStrLn)

2313import System.FilePath (takeDirectory)

src/lib/ProjectM36/Server/RemoteCallTypes.hs+59−1

@@ -1,15 +1,72 @@

1−{-# LANGUAGE DeriveAnyClass, DeriveGeneric #-}

1+{-# LANGUAGE DeriveAnyClass, DeriveGeneric, DerivingVia #-}

22module ProjectM36.Server.RemoteCallTypes where

33import ProjectM36.Base

4+import ProjectM36.Error

5+import ProjectM36.Serialise.Error

6+import Data.Map (Map)

47import ProjectM36.IsomorphicSchema

58import ProjectM36.TransactionGraph

69import ProjectM36.DataFrame

710import ProjectM36.TransGraphRelationalExpression

811import ProjectM36.Session

12+import ProjectM36.Serialise.DataFrame

913import GHC.Generics

1014import Data.Binary

1115import Control.Distributed.Process (ProcessId)

16+import Codec.Winery

1217

18+data Request = Login |

19+ Logout |

20+ ExecuteRelationalExpr SessionId RelationalExpr |

21+ ExecuteDataFrameExpr SessionId DataFrameExpr |

22+ ExecuteDatabaseConextExpr SessionId DatabaseContextExpr |

23+ ExecuteDatabaseContextIOExpr SessionId DatabaseContextIOExpr |

24+ ExecuteGraphExpr SessionId TransactionGraphOperator |

25+ ExecuteTransGraphRelationalExpr SessionId TransGraphRelationalExpr |

26+ ExecuteHeadName SessionId |

27+ ExecuteTypeForRelationalExpr SessionId RelationalExpr |

28+ ExecuteSchemaExpr SessionId SchemaExpr |

29+ ExecuteSetCurrentSchema SessionId SchemaName |

30+ RetrieveInclusionDependencies SessionId |

31+ RetrievePlanForDatabaseContextExpr SessionId DatabaseContextExpr |

32+ RetrieveTransactionGraph SessionId |

33+ RetrieveHeadTransactionId SessionId |

34+ CreateSessionAtCommit TransactionId |

35+ CreateSessionAtHead HeadName |

36+ CloseSession SessionId |

37+ RetrieveAtomTypesAsRelation SessionId |

38+ RetrieveRelationVariableSummary SessionId |

39+ RetrieveAtomFunctionSummary SessionId |

40+ RetrieveDatabaseContextFunctionSummary SessionId |

41+ RetrieveCurrentSchemaName SessionId |

42+ TestTimeout SessionId |

43+ RetrieveSessionIsDirty SessionId |

44+ ExecuteAutoMergeToHead SessionId MergeStrategy HeadName |

45+ RetrieveTypeConstructorMapping SessionId |

46+ ExecuteValidateMerkleHashes SessionId

47+ deriving (Generic)

48+ deriving Serialise via WineryVariant Request

49+

50+data Response = RelationResp (Either RelationalError Relation) |

51+ DataFrameResp (Either RelationalError DataFrame) |

52+ EUnitResp (Either RelationalError ()) |

53+ HeadNameResp (Either RelationalError HeadName) |

54+ BoolResp Bool |

55+ InclusionDependenciesMapResp (Map IncDepName InclusionDependency) |

56+ GraphRefDatabaseContextExprResp (Either RelationalError GraphRefDatabaseContextExpr) |

57+ TransactionIdResp (Either RelationalError TransactionId) |

58+ SessionIdResp (Either RelationalError SessionId) |

59+ UnitResp () |

60+ SchemaNameResp (Either RelationalError SchemaName) |

61+ EBoolResp (Either RelationalError Bool) |

62+ TypeConstructorMappingResp (Either RelationalError TypeConstructorMapping)

63+ deriving (Generic)

64+ deriving Serialise via WineryVariant Response

65+

66+

67+

68+{-

69+

1370{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}

1471-- | The initial login message. The argument should be the process id of the initiating client. This ProcessId will receive notification callbacks.

1572data Login = Login ProcessId

@@ -72,3 +129,4 @@ data RetrieveTypeConstructorMapping = RetrieveTypeConstructorMapping SessionId

72129

73130data ExecuteValidateMerkleHashes = ExecuteValidateMerkleHashes SessionId

74131 deriving (Binary, Generic)

132+-}

src/lib/ProjectM36/TransGraphRelationalExpression.hs−17

@@ -10,43 +10,26 @@ import Control.Monad.Trans.Reader

1010import Control.Monad.Trans.Class

1111import Control.Monad.Trans.Except

1212import Data.Functor.Identity

13−import Data.Binary

1413

1514-- | The TransGraphRelationalExpression is equivalent to a relational expression except that relation variables can reference points in the transaction graph (at previous points in time).

1615type TransGraphRelationalExpr = RelationalExprBase TransactionIdLookup

1716

18−instance Binary TransGraphRelationalExpr

19−

2017type TransGraphAttributeNames = AttributeNamesBase TransactionIdLookup

2118

22−instance Binary TransGraphAttributeNames

23−

2419type TransGraphExtendTupleExpr = ExtendTupleExprBase TransactionIdLookup

2520

26−instance Binary TransGraphExtendTupleExpr

27−

2821type TransGraphTupleExpr = TupleExprBase TransactionIdLookup

2922

30−instance Binary TransGraphTupleExpr

31−

3223type TransGraphTupleExprs = TupleExprsBase TransactionIdLookup

3324

34−instance Binary TransGraphTupleExprs

35−

3625type TransGraphRestrictionPredicateExpr = RestrictionPredicateExprBase TransactionIdLookup

3726

38−instance Binary TransGraphRestrictionPredicateExpr

39−

4027type TransGraphAtomExpr = AtomExprBase TransactionIdLookup

4128

42−instance Binary TransGraphAtomExpr

43−

4429type TransGraphAttributeExpr = AttributeExprBase TransactionIdLookup

4530

4631type TransGraphWithNameExpr = WithNameExprBase TransactionIdLookup

4732

48−instance Binary TransGraphWithNameExpr

49−

5033newtype TransGraphEvalEnv = TransGraphEvalEnv {

5134 tge_graph :: TransactionGraph

5235 }

src/lib/ProjectM36/Transaction/Persist.hs+16−16

@@ -8,13 +8,13 @@ import ProjectM36.AtomFunction

88import ProjectM36.Persist (writeBSFileSync, DiskSync, renameSync)

99import qualified Data.Map as M

1010import qualified Data.HashSet as HS

11−import qualified Data.Binary as B

1211import System.FilePath

1312import System.Directory

1413import qualified Data.Text as T

1514import Control.Monad

1615import ProjectM36.ScriptSession

1716import ProjectM36.AtomFunctions.Basic (precompiledAtomFunctions)

17+import Codec.Winery

1818

1919#ifdef PM36_HASKELL_SCRIPTING

2020import GHC

@@ -62,7 +62,7 @@ readTransaction dbdir transId mScriptSession = do

6262 return $ Left $ MissingTransactionError transId

6363 else do

6464 relvars <- readRelVars transDir

65− transInfo <- B.decodeFile (transactionInfoPath transDir)

65+ transInfo <- readFileDeserialise (transactionInfoPath transDir)

6666 incDeps <- readIncDeps transDir

6767 typeCons <- readTypeConstructorMapping transDir

6868 sschemas <- readSubschemas transDir

@@ -92,28 +92,28 @@ writeTransaction sync dbdir trans = do

9292 writeDBCFuncs sync tempTransDir (dbcFunctions context)

9393 writeTypeConstructorMapping sync tempTransDir (typeConstructorMapping context)

9494 writeSubschemas sync tempTransDir (subschemas trans)

95− B.encodeFile (transactionInfoPath tempTransDir) (transactionInfo trans)

95+ writeFileSerialise (transactionInfoPath tempTransDir) (transactionInfo trans)

9696 --move the temp directory to final location

9797 renameSync sync tempTransDir finalTransDir

9898

9999writeRelVars :: DiskSync -> FilePath -> RelationVariables -> IO ()

100100writeRelVars sync transDir relvars = do

101101 let path = relvarsPath transDir

102− writeBSFileSync sync path (B.encode relvars)

102+ writeBSFileSync sync path (serialise relvars)

103103

104104readRelVars :: FilePath -> IO RelationVariables

105105readRelVars transDir =

106− B.decodeFile (relvarsPath transDir)

106+ readFileDeserialise (relvarsPath transDir)

107107

108108writeAtomFuncs :: DiskSync -> FilePath -> AtomFunctions -> IO ()

109109writeAtomFuncs sync transDir funcs = do

110110 let atomFuncPath = atomFuncsPath transDir

111− writeBSFileSync sync atomFuncPath (B.encode $ map (\f -> (atomFuncType f, atomFuncName f, atomFunctionScript f)) (HS.toList funcs))

111+ writeBSFileSync sync atomFuncPath (serialise $ map (\f -> (atomFuncType f, atomFuncName f, atomFunctionScript f)) (HS.toList funcs))

112112

113113--all the atom functions are in one file

114114readAtomFuncs :: FilePath -> Maybe ScriptSession -> IO AtomFunctions

115115readAtomFuncs transDir mScriptSession = do

116− atomFuncsList <- B.decodeFile (atomFuncsPath transDir)

116+ atomFuncsList <- readFileDeserialise (atomFuncsPath transDir)

117117 --only Haskell script functions can be serialized

118118 --we always return the pre-compiled functions

119119 funcs <- mapM (\(funcType, funcName, mFuncScript) -> loadAtomFunc precompiledAtomFunctions mScriptSession funcName funcType mFuncScript) atomFuncsList

@@ -153,7 +153,7 @@ readAtomFunc _ _ _ _ = error "Haskell scripting is disabled"

153153#else

154154readAtomFunc transDir funcName mScriptSession precompiledFuncs = do

155155 let atomFuncPath = atomFuncsPath transDir

156− (funcType, mFuncScript) <- B.decodeFile @([AtomType],Maybe T.Text) atomFuncPath

156+ (funcType, mFuncScript) <- readFileDeserialise @([AtomType],Maybe T.Text) atomFuncPath

157157 case mFuncScript of

158158 --handle pre-compiled case- pull it from the precompiled list

159159 Nothing -> case atomFunctionForName funcName precompiledFuncs of

@@ -184,7 +184,7 @@ writeDBCFuncs sync transDir funcs = mapM_ (writeDBCFunc sync transDir) (HS.toLis

184184writeDBCFunc :: DiskSync -> FilePath -> DatabaseContextFunction -> IO ()

185185writeDBCFunc sync transDir func = do

186186 let dbcFuncPath = dbcFuncsDir transDir </> T.unpack (dbcFuncName func)

187− writeBSFileSync sync dbcFuncPath (B.encode (dbcFuncType func, databaseContextFunctionScript func))

187+ writeBSFileSync sync dbcFuncPath (serialise (dbcFuncType func, databaseContextFunctionScript func))

188188

189189readDBCFuncs :: FilePath -> Maybe ScriptSession -> IO DatabaseContextFunctions

190190readDBCFuncs transDir mScriptSession = do

@@ -201,7 +201,7 @@ readDBCFunc transDir funcName _ precompiledFuncs = do

201201readDBCFunc transDir funcName mScriptSession precompiledFuncs = do

202202#endif

203203 let dbcFuncPath = dbcFuncsDir transDir </> T.unpack funcName

204− (_funcType, mFuncScript) <- B.decodeFile @([AtomType], Maybe T.Text) dbcFuncPath

204+ (_funcType, mFuncScript) <- readFileDeserialise @([AtomType], Maybe T.Text) dbcFuncPath

205205 case mFuncScript of

206206 Nothing -> case databaseContextFunctionForName funcName precompiledFuncs of

207207 Left _ -> error ("expected precompiled dbc function: " ++ T.unpack funcName)

@@ -225,7 +225,7 @@ readDBCFunc transDir funcName mScriptSession precompiledFuncs = do

225225

226226writeIncDep :: DiskSync -> FilePath -> (IncDepName, InclusionDependency) -> IO ()

227227writeIncDep sync transDir (incDepName, incDep) =

228− writeBSFileSync sync (incDepsDir transDir </> T.unpack incDepName) $ B.encode incDep

228+ writeBSFileSync sync (incDepsDir transDir </> T.unpack incDepName) $ serialise incDep

229229

230230writeIncDeps :: DiskSync -> FilePath -> M.Map IncDepName InclusionDependency -> IO ()

231231writeIncDeps sync transDir incdeps = mapM_ (writeIncDep sync transDir) $ M.toList incdeps

@@ -233,7 +233,7 @@ writeIncDeps sync transDir incdeps = mapM_ (writeIncDep sync transDir) $ M.toLis

233233readIncDep :: FilePath -> IncDepName -> IO (IncDepName, InclusionDependency)

234234readIncDep transDir incdepName = do

235235 let incDepPath = incDepsDir transDir </> T.unpack incdepName

236− incDepData <- B.decodeFile incDepPath

236+ incDepData <- readFileDeserialise incDepPath

237237 pure (incdepName, incDepData)

238238

239239readIncDeps :: FilePath -> IO (M.Map IncDepName InclusionDependency)

@@ -245,20 +245,20 @@ readIncDeps transDir = do

245245readSubschemas :: FilePath -> IO Subschemas

246246readSubschemas transDir = do

247247 let sschemasPath = subschemasPath transDir

248− B.decodeFile sschemasPath

248+ readFileDeserialise sschemasPath

249249

250250writeSubschemas :: DiskSync -> FilePath -> Subschemas -> IO ()

251251writeSubschemas sync transDir sschemas = do

252252 let sschemasPath = subschemasPath transDir

253− writeBSFileSync sync sschemasPath (B.encode sschemas)

253+ writeBSFileSync sync sschemasPath (serialise sschemas)

254254

255255writeTypeConstructorMapping :: DiskSync -> FilePath -> TypeConstructorMapping -> IO ()

256256writeTypeConstructorMapping sync path types = let atPath = typeConsPath path in

257− writeBSFileSync sync atPath $ B.encode types

257+ writeBSFileSync sync atPath $ serialise types

258258

259259readTypeConstructorMapping :: FilePath -> IO TypeConstructorMapping

260260readTypeConstructorMapping path = do

261261 let atPath = typeConsPath path

262− B.decodeFile atPath

262+ readFileDeserialise atPath

263263

264264

src/lib/ProjectM36/TransactionGraph.hs+14−12

@@ -1,4 +1,4 @@

1−{-# LANGUAGE DeriveAnyClass, DeriveGeneric, CPP, FlexibleContexts #-}

1+{-# LANGUAGE DeriveAnyClass, DeriveGeneric, CPP, FlexibleContexts, DerivingVia #-}

22module ProjectM36.TransactionGraph where

33import ProjectM36.Base

44import ProjectM36.Error

@@ -13,6 +13,7 @@ import ProjectM36.MerkleHash

1313import qualified ProjectM36.DisconnectedTransaction as Discon

1414import qualified ProjectM36.Attribute as A

1515

16+import Codec.Winery

1617import Control.Monad.Except hiding (join)

1718import Control.Monad.Reader hiding (join)

1819import qualified Data.Vector as V

@@ -23,7 +24,6 @@ import qualified Data.List.NonEmpty as NE

2324import Data.Time.Clock

2425import qualified Data.Text as T

2526import GHC.Generics

26−import Data.Binary as B

2727import Data.Either (lefts, rights, isRight)

2828#if __GLASGOW_HASKELL__ < 804

2929import Data.Monoid

@@ -38,13 +38,15 @@ import Crypto.Hash.SHA256

3838-- | Record a lookup for a specific transaction in the graph.

3939data TransactionIdLookup = TransactionIdLookup TransactionId |

4040 TransactionIdHeadNameLookup HeadName [TransactionIdHeadBacktrack]

41− deriving (Show, Eq, Binary, Generic)

41+ deriving (Show, Eq, Generic)

42+ deriving Serialise via WineryVariant TransactionIdLookup

4243

4344-- | Used for git-style head backtracking such as topic~3^2.

44−data TransactionIdHeadBacktrack = TransactionIdHeadParentBacktrack Int | -- ^ git equivalent of ~: walk back n parents, arbitrarily choosing a parent when a choice must be made

45+data TransactionIdHeadBacktrack = TransactionIdHeadParentBacktrack Int | -- ^ git equivalent of ~v: walk back n parents, arbitrarily choosing a parent when a choice must be made

4546 TransactionIdHeadBranchBacktrack Int | -- ^ git equivalent of ^: walk back one parent level to the nth arbitrarily-chosen parent

4647 TransactionStampHeadBacktrack UTCTime -- ^ git equivalent of 'git-rev-list -n 1 --before X' find the first transaction which was created before the timestamp

47− deriving (Show, Eq, Binary, Generic)

48+ deriving (Show, Eq, Generic)

49+ deriving Serialise via WineryVariant TransactionIdHeadBacktrack

4850

4951

5052-- | Operators which manipulate a transaction graph and which transaction the current 'Session' is based upon.

@@ -56,7 +58,8 @@ data TransactionGraphOperator = JumpToHead HeadName |

5658 MergeTransactions MergeStrategy HeadName HeadName |

5759 Commit |

5860 Rollback

59− deriving (Eq, Show, Binary, Generic)

61+ deriving (Eq, Show, Generic)

62+ deriving Serialise via WineryVariant TransactionGraphOperator

6063

6164isCommit :: TransactionGraphOperator -> Bool

6265isCommit Commit = True

@@ -593,10 +596,9 @@ addMerkleHash graph trans = Transaction (transactionId trans) newInfo (schemas t

593596

594597-- the new hash includes the parents' ids, the current id, and the hash of the context, and the merkle hashes of the parent transactions

595598calculateMerkleHash :: Transaction -> TransactionGraph -> MerkleHash

596−calculateMerkleHash trans graph = MerkleHash $ hashlazy (mconcat [transIds,

597− dbcBytes,

598− schemasBytes,

599− parentMerkleHashes])

599+calculateMerkleHash trans graph = MerkleHash $ hashlazy (BL.fromChunks [transIds,

600+ schemasBytes

601+ ] <> dbcBytes <> parentMerkleHashes)

600602 where

601603 parentMerkleHashes = BL.fromChunks $ map (_unMerkleHash . getMerkleHash) parentTranses

602604 parentTranses =

@@ -605,9 +607,9 @@ calculateMerkleHash trans graph = MerkleHash $ hashlazy (mconcat [transIds,

605607 Left e -> error ("failed to find transaction in Merkle hash construction: " ++ show e)

606608 Right t -> S.toList t

607609 getMerkleHash t = merkleHash (transactionInfo t)

608− transIds = B.encode (transactionId trans : S.toList (parentIds trans))

610+ transIds = serialise (transactionId trans : S.toList (parentIds trans))

609611 dbcBytes = DBC.hashBytes (concreteDatabaseContext trans)

610− schemasBytes = B.encode (subschemas trans)

612+ schemasBytes = serialise (subschemas trans)

611613

612614validateMerkleHash :: Transaction -> TransactionGraph -> Either MerkleValidationError ()

613615validateMerkleHash trans graph =