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

git.iko.soy/project-m36

on master help sign in

first pass at implementing Serialise instances

61b6c35AgentM6 years ago

cabal.project+10

compare with master

unifiedsplit

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

7 type: git

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

9 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

34 Default: True

36Library

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

38 if flag(haskell-scripting)

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

40 CPP-Options: -DPM36_HASKELL_SCRIPTING

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

51 ProjectM36.TransactionGraph.Merge,

52 ProjectM36.TransGraphRelationalExpression,

53 ProjectM36.Base,

54+ ProjectM36.Serialise.Base,

55+ ProjectM36.Serialise.Error,

54 ProjectM36.DataFrame,

56 ProjectM36.DataFrame,

55 ProjectM36.Attribute,

57 ProjectM36.Attribute,

56 ProjectM36.AttributeNames,

58 ProjectM36.AttributeNames,

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

177 attoparsec,

179 attoparsec,

178 stm-containers >= 1.0.0,

180 stm-containers >= 1.0.0,

179 list-t,

181 list-t,

180− parser-combinators

182+ parser-combinators,

183+ curryer

181 Other-Modules: TutorialD.Interpreter,

184 Other-Modules: TutorialD.Interpreter,

182 TutorialD.Interpreter.Base,

185 TutorialD.Interpreter.Base,

183 TutorialD.Interpreter.DatabaseContextExpr,

186 TutorialD.Interpreter.DatabaseContextExpr,

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

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

1{-# LANGUAGE CPP #-}

2module ProjectM36.AtomFunction where

3import ProjectM36.Base

4+import ProjectM36.Serialise.Base

4import ProjectM36.Error

5import ProjectM36.Error

5import ProjectM36.Relation

6import ProjectM36.Relation

6import ProjectM36.AtomType

7import ProjectM36.AtomType

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

11import qualified Data.Text as T

12import qualified Data.Text as T

12import qualified Data.ByteString.Lazy as BL

13import qualified Data.ByteString.Lazy as BL

13import Data.Binary as B

14import Data.Binary as B

15+import Codec.Winery

15foldAtomFuncType :: AtomType -> AtomType -> [AtomType]

17foldAtomFuncType :: AtomType -> AtomType -> [AtomType]

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

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

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

92--for calculating the merkle hash

94--for calculating the merkle hash

93hashBytes :: AtomFunction -> BL.ByteString

95hashBytes :: AtomFunction -> BL.ByteString

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

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

95− B.encode (atomFuncType func),

97+ serialise (atomFuncType func),

96− bodyBin

98+ bodyBin

97− ]

99+ ]

98 where

100 where

99 bodyBin = case atomFuncBody func of

101 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 @@

1{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}

2module ProjectM36.AtomFunctionError where

3−import Data.Binary

4import GHC.Generics

3import GHC.Generics

5import Control.DeepSeq

4import Control.DeepSeq

6import Data.Text

5import Data.Text

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

14 AtomTypeDoesNotSupportOrderingError Text |

13 AtomTypeDoesNotSupportOrderingError Text |

15 AtomTypeDoesNotSupportIntervalError Text |

14 AtomTypeDoesNotSupportIntervalError Text |

16 AtomFunctionBytesDecodingError String

15 AtomFunctionBytesDecodingError String

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

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

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

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

13import qualified Data.Text as T

14import qualified Data.Vector as V

15import Control.DeepSeq (NFData)

16−import Data.Binary

17import Control.Applicative

16import Control.Applicative

18import Data.Time.Calendar

17import Data.Time.Calendar

19import Data.ByteString (ByteString)

18import Data.ByteString (ByteString)

20import Data.Time.Clock

19import Data.Time.Clock

21import Data.Proxy

20import Data.Proxy

22import qualified Data.List.NonEmpty as NE

21import qualified Data.List.NonEmpty as NE

22+import Codec.Winery

24--also add haskell scripting atomable support

25--rename this module to Atomable along with test

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

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

36-}

37-- | 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

39 toAtom :: a -> Atom

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

41 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 #-}

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

4module ProjectM36.Base where

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

18import qualified Data.Vector as V

19import qualified Data.List as L

20import Data.Text (Text,unpack)

21−import Data.Binary

22import Data.Vector.Binary()

21import Data.Vector.Binary()

23import Data.Time.Clock

22import Data.Time.Clock

24−import Data.Time.Clock.POSIX

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

26import Data.Hashable.Time ()

23import Data.Hashable.Time ()

24+import Data.Time.Calendar (Day)

27import Data.Typeable

25import Data.Typeable

28import Data.ByteString (ByteString)

26import Data.ByteString (ByteString)

29import qualified Data.List.NonEmpty as NE

27import qualified Data.List.NonEmpty as NE

28+--import Codec.Winery

29+

30type StringType = Text

32-- | 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 |

40 BoolAtom Bool |

41 RelationAtom Relation |

42 ConstructedAtom DataConstructorName AtomType [Atom]

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

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

45instance Hashable Atom where

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

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

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

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

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−

68-- 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.

58-- 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.

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

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

70data AtomType = IntAtomType |

60data AtomType = IntAtomType |

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

79 ConstructedAtomType TypeConstructorName TypeVarMap |

69 ConstructedAtomType TypeConstructorName TypeVarMap |

80 TypeVariableType TypeVarName

70 TypeVariableType TypeVarName

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

71 --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)

84instance Ord AtomType where

74instance Ord AtomType where

85 compare = undefined

75 compare = undefined

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

98type AttributeName = StringType

88type AttributeName = StringType

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

90-- | 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)

102

103instance Hashable Attribute where

93instance Hashable Attribute where

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

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

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

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

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

117

107

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

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

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

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

120−

121−instance Read Relation where

122− readsPrec = error "relation read not supported"

123

110

124instance Eq RelationTupleSet where

111instance Eq RelationTupleSet where

125 set1 == set2 = hset set1 == hset set2

112 set1 == set2 = hset set1 == hset set2

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

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

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

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

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

148

135

149−instance Binary RelationTuple

150−

151instance Eq RelationTuple where

136instance Eq RelationTuple where

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

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

153 where

138 where

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

158

143

159instance NFData RelationTuple where rnf = genericRnf

144instance NFData RelationTuple where rnf = genericRnf

160

145

161−

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

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

163

147

164instance Eq Relation where

148instance Eq Relation where

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

173 where

157 where

174 sortedAttrs = map snd (sortedAttributesIndices attrs)

158 sortedAttrs = map snd (sortedAttributesIndices attrs)

175

159

176−instance Binary Relation

177−

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

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

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

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

180

162

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

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

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

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

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

223

205

224−instance Binary RelationalExpr

225−

226data WithNameExprBase a = WithNameExpr RelVarName a

206data WithNameExprBase a = WithNameExpr RelVarName a

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

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

228

208

229type WithNameExpr = WithNameExprBase ()

209type WithNameExpr = WithNameExprBase ()

230

210

231−instance Binary WithNameExpr

232−

233type GraphRefWithNameExpr = WithNameExprBase GraphRefTransactionMarker

211type GraphRefWithNameExpr = WithNameExprBase GraphRefTransactionMarker

234

212

235type NotificationName = StringType

213type NotificationName = StringType

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

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

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

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

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

243 }

221 }

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

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

245

223

246type TypeVarName = StringType

224type TypeVarName = StringType

247

225

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

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

249data TypeConstructorDef = ADTypeConstructorDef TypeConstructorName [TypeVarName] |

227data TypeConstructorDef = ADTypeConstructorDef TypeConstructorName [TypeVarName] |

250 PrimitiveTypeConstructorDef TypeConstructorName AtomType

228 PrimitiveTypeConstructorDef TypeConstructorName AtomType

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

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

252

230

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

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

254type TypeConstructor = TypeConstructorBase ()

232type TypeConstructor = TypeConstructorBase ()

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

256 PrimitiveTypeConstructor TypeConstructorName AtomType |

234 PrimitiveTypeConstructor TypeConstructorName AtomType |

257 RelationAtomTypeConstructor [AttributeExprBase a] |

235 RelationAtomTypeConstructor [AttributeExprBase a] |

258 TypeVariable TypeVarName

236 TypeVariable TypeVarName

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

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

260

238

261type TypeConstructorMapping = [(TypeConstructorDef, DataConstructorDefs)]

239type TypeConstructorMapping = [(TypeConstructorDef, DataConstructorDefs)]

262

240

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

266type AtomTypeName = StringType

244type AtomTypeName = StringType

267

245

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

246-- | 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)

270

248

271type DataConstructorDefs = [DataConstructorDef]

249type DataConstructorDefs = [DataConstructorDef]

272

250

273data DataConstructorDefArg = DataConstructorDefTypeConstructorArg TypeConstructor |

251data DataConstructorDefArg = DataConstructorDefTypeConstructorArg TypeConstructor |

274 DataConstructorDefTypeVarNameArg TypeVarName

252 DataConstructorDefTypeVarNameArg TypeVarName

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

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

276

254

277type InclusionDependencies = M.Map IncDepName InclusionDependency

255type InclusionDependencies = M.Map IncDepName InclusionDependency

278type RelationVariables = M.Map RelVarName GraphRefRelationalExpr

256type RelationVariables = M.Map RelVarName GraphRefRelationalExpr

279

257

280data GraphRefTransactionMarker = TransactionMarker TransactionId |

258data GraphRefTransactionMarker = TransactionMarker TransactionId |

281 UncommittedContextMarker

259 UncommittedContextMarker

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

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

283

261

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

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

285type GraphRefRelationalExpr = RelationalExprBase GraphRefTransactionMarker

263type GraphRefRelationalExpr = RelationalExprBase GraphRefTransactionMarker

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

290

268

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

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

292data Schemas = Schemas DatabaseContext Subschemas

270data Schemas = Schemas DatabaseContext Subschemas

271+ deriving (Generic)

293

272

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

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

295-- 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.

274-- 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.

296newtype Schema = Schema SchemaIsomorphs

275newtype Schema = Schema SchemaIsomorphs

297− deriving (Generic, Binary)

276+ deriving (Generic)

298

277

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

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

300 IsoRename RelVarName RelVarName |

279 IsoRename RelVarName RelVarName |

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

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

302 -- IsoTypeConstructor in morphAttrExpr

281 -- IsoTypeConstructor in morphAttrExpr

303− deriving (Generic, Binary, Show)

282+ deriving (Generic, Show)

304

283

305type SchemaIsomorphs = [SchemaIsomorph]

284type SchemaIsomorphs = [SchemaIsomorph]

306

285

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

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

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

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

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

320

299

321−instance Binary InclusionDependency

322−

323type AttributeNameAtomExprMap = M.Map AttributeName AtomExpr

300type AttributeNameAtomExprMap = M.Map AttributeName AtomExpr

324

301

325--used for returning information about individual expressions

302--used for returning information about individual expressions

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

329

306

330type GraphRefDatabaseContextExpr = DatabaseContextExprBase GraphRefTransactionMarker

307type GraphRefDatabaseContextExpr = DatabaseContextExprBase GraphRefTransactionMarker

331

308

332−instance Binary GraphRefDatabaseContextExpr

333−

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

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

335data DatabaseContextExprBase a =

310data DatabaseContextExprBase a =

336 NoOperation |

311 NoOperation |

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

360 MultipleExpr [DatabaseContextExprBase a]

335 MultipleExpr [DatabaseContextExprBase a]

361 deriving (Show, Eq, Generic)

336 deriving (Show, Eq, Generic)

362

337

363−instance Binary DatabaseContextExpr

364−

365type ObjModuleName = StringType

338type ObjModuleName = StringType

366type ObjFunctionName = StringType

339type ObjFunctionName = StringType

367type Range = (Int,Int)

340type Range = (Int,Int)

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

372 AddDatabaseContextFunction DatabaseContextFunctionName [TypeConstructor] DatabaseContextFunctionBodyScript |

345 AddDatabaseContextFunction DatabaseContextFunctionName [TypeConstructor] DatabaseContextFunctionBodyScript |

373 LoadDatabaseContextFunctions ObjModuleName ObjFunctionName FilePath |

346 LoadDatabaseContextFunctions ObjModuleName ObjFunctionName FilePath |

374 CreateArbitraryRelation RelVarName [AttributeExprBase a] Range

347 CreateArbitraryRelation RelVarName [AttributeExprBase a] Range

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

348+ deriving (Show, Eq, Generic)

376

349

377type GraphRefDatabaseContextIOExpr = DatabaseContextIOExprBase GraphRefTransactionMarker

350type GraphRefDatabaseContextIOExpr = DatabaseContextIOExprBase GraphRefTransactionMarker

378

351

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

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

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

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

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

395

368

396−instance Binary RestrictionPredicateExpr

397−

398-- child + parent links

369-- child + parent links

399-- | 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.

370-- | 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.

400type HeadName = StringType

371type HeadName = StringType

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

403

374

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

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

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

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

377+ deriving Generic

406

378

407transactionHeadsForGraph :: TransactionGraph -> TransactionHeads

379transactionHeadsForGraph :: TransactionGraph -> TransactionHeads

408transactionHeadsForGraph (TransactionGraph hs _) = hs

380transactionHeadsForGraph (TransactionGraph hs _) = hs

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

425 deriving (Show, Generic)

397 deriving (Show, Generic)

426-}

398-}

427

399

428−instance Binary TransactionInfo

429−

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

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

431type TransactionId = UUID

401type TransactionId = UUID

432

402

433data Transaction = Transaction TransactionId TransactionInfo Schemas

403data Transaction = Transaction TransactionId TransactionInfo Schemas

404+ deriving Generic

434

405

435-- | 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.

406-- | 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.

436data DisconnectedTransaction = DisconnectedTransaction TransactionId Schemas DirtyFlag

407data DisconnectedTransaction = DisconnectedTransaction TransactionId Schemas DirtyFlag

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

464 ConstructedAtomExpr DataConstructorName [AtomExprBase a] a

435 ConstructedAtomExpr DataConstructorName [AtomExprBase a] a

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

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

466

437

467−instance Binary AtomExpr

468−

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

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

470data ExtendTupleExprBase a = AttributeExtendTupleExpr AttributeName (AtomExprBase a)

439data ExtendTupleExprBase a = AttributeExtendTupleExpr AttributeName (AtomExprBase a)

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

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

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

473type ExtendTupleExpr = ExtendTupleExprBase ()

442type ExtendTupleExpr = ExtendTupleExprBase ()

474type GraphRefExtendTupleExpr = ExtendTupleExprBase GraphRefTransactionMarker

443type GraphRefExtendTupleExpr = ExtendTupleExprBase GraphRefTransactionMarker

475

444

476−instance Binary ExtendTupleExpr

477−

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

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

479type AtomFunctions = HS.HashSet AtomFunction

446type AtomFunctions = HS.HashSet AtomFunction

480

447

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

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

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

486

453

487data AtomFunctionBody = AtomFunctionBody (Maybe AtomFunctionBodyScript) AtomFunctionBodyType

454data AtomFunctionBody = AtomFunctionBody (Maybe AtomFunctionBodyScript) AtomFunctionBodyType

455+ deriving Generic

488

456

489instance NFData AtomFunctionBody where

457instance NFData AtomFunctionBody where

490 rnf (AtomFunctionBody mScript _) = rnf mScript

458 rnf (AtomFunctionBody mScript _) = rnf mScript

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

525

493

526type GraphRefAttributeNames = AttributeNamesBase GraphRefTransactionMarker

494type GraphRefAttributeNames = AttributeNamesBase GraphRefTransactionMarker

527

495

528−instance Binary AttributeNames

529−

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

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

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

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

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

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

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

539-- | Create attributes dynamically.

505-- | Create attributes dynamically.

540data AttributeExprBase a = AttributeAndTypeNameExpr AttributeName TypeConstructor a |

506data AttributeExprBase a = AttributeAndTypeNameExpr AttributeName TypeConstructor a |

541 NakedAttributeExpr Attribute

507 NakedAttributeExpr Attribute

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

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

543

509

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

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

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

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

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

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

547

513

548−instance Binary TupleExpr

549−

550type TupleExpr = TupleExprBase ()

514type TupleExpr = TupleExprBase ()

551

515

552type GraphRefTupleExpr = TupleExprBase GraphRefTransactionMarker

516type GraphRefTupleExpr = TupleExprBase GraphRefTransactionMarker

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

558

522

559type TupleExprs = TupleExprsBase ()

523type TupleExprs = TupleExprsBase ()

560

524

561−instance Binary TupleExprs

562−

563data MergeStrategy =

525data MergeStrategy =

564 -- | 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)

526 -- | 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)

565 UnionMergeStrategy |

527 UnionMergeStrategy |

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

567 UnionPreferMergeStrategy HeadName |

529 UnionPreferMergeStrategy HeadName |

568 -- | 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.

530 -- | 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.

569 SelectedBranchMergeStrategy HeadName

531 SelectedBranchMergeStrategy HeadName

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

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

571

533

572type DatabaseContextFunctionName = StringType

534type DatabaseContextFunctionName = StringType

573

535

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

635unimplemented = undefined

597unimplemented = undefined

636

598

637--for serializing GraphRefRelationalExpr as part of transaction serialization

599--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

653

600

654

601

src/lib/ProjectM36/Client.hs−15

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

136import Control.Exception.Base

137import GHC.Conc.Sync

138

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)

153import Data.Either (isRight)

139import Data.Either (isRight)

154import Data.UUID.V4 (nextRandom)

140import Data.UUID.V4 (nextRandom)

155import Data.Word

141import Data.Word

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

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

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

158import Control.Concurrent.MVar

143import Control.Concurrent.MVar

159import qualified Data.Map as M

144import 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 #-}

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

3module ProjectM36.DataFrame where

4import ProjectM36.Base

5import ProjectM36.Attribute as A

6import ProjectM36.Error

7+import ProjectM36.Serialise.Base

7import qualified ProjectM36.Relation as R

8import qualified ProjectM36.Relation as R

8import ProjectM36.Relation.Show.Term

9import ProjectM36.Relation.Show.Term

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

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

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

16import qualified Data.Set as S

17import qualified Data.Set as S

17import Data.Maybe

18import Data.Maybe

18import qualified Data.Text as T

19import qualified Data.Text as T

19−import Data.Binary

20import Control.Arrow

21#if __GLASGOW_HASKELL__ < 804

22import Data.Monoid

23#endif

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

25+data AttributeOrderExpr = AttributeOrderExpr AttributeName Order

26+ deriving (Show, Generic)

27+

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

28+data AttributeOrder = AttributeOrder AttributeName Order

29+ deriving (Show, Generic)

30+

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

31+data Order = AscendingOrder | DescendingOrder

32+ deriving (Eq, Show, Generic)

33+

29ascending :: T.Text

35ascending :: T.Text

30ascending = "⬆"

36ascending = "⬆"

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

39 orders :: [AttributeOrder],

45 orders :: [AttributeOrder],

40 attributes :: Attributes,

46 attributes :: Attributes,

41 tuples :: [DataFrameTuple]

47 tuples :: [DataFrameTuple]

48+ }

42− } deriving (Show, Generic, Binary)

49+ deriving (Show, Generic)

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)

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

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

47sortDataFrameBy attrOrders frame = do

55sortDataFrameBy attrOrders frame = do

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

122 orderExprs :: [AttributeOrderExpr],

130 orderExprs :: [AttributeOrderExpr],

123 offset :: Maybe Integer,

131 offset :: Maybe Integer,

124 limit :: Maybe Integer

132 limit :: Maybe Integer

133+ }

125− } deriving (Show, Binary, Generic)

134+ deriving (Show, Generic)

135+

126

136

127dataFrameAsHTML :: DataFrame -> T.Text

137dataFrameAsHTML :: DataFrame -> T.Text

128-- 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

138-- 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

10import Data.Binary as B

11import ProjectM36.AtomFunction as AF

12import ProjectM36.DatabaseContextFunction as DBCF

13+import Codec.Winery

14empty :: DatabaseContext

15empty :: DatabaseContext

15empty = DatabaseContext { inclusionDependencies = M.empty,

16empty = DatabaseContext { inclusionDependencies = M.empty,

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

45--for building the Merkle hash

46--for building the Merkle hash

46hashBytes :: DatabaseContext -> BL.ByteString

47hashBytes :: DatabaseContext -> BL.ByteString

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

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

48 where

49 where

49− incDeps = B.encode (inclusionDependencies ctx)

50+ incDeps = serialise (inclusionDependencies ctx)

50− rvs = B.encode (relationVariables ctx)

51+ rvs = serialise (relationVariables ctx)

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

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

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

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

53− nots = B.encode (notifications ctx)

54+ nots = serialise (notifications ctx)

54− tConsMap = B.encode (typeConstructorMapping ctx)

55+ tConsMap = serialise (typeConstructorMapping ctx)

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

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

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

4import ProjectM36.Base

5import ProjectM36.Error

6+import ProjectM36.Serialise.Base

6import ProjectM36.Attribute as A

7import ProjectM36.Attribute as A

7import ProjectM36.Relation

8import ProjectM36.Relation

8import ProjectM36.AtomType

9import ProjectM36.AtomType

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

11import ProjectM36.ScriptSession

12import ProjectM36.ScriptSession

12import qualified Data.Text as T

13import qualified Data.Text as T

13import qualified Data.ByteString.Lazy as BL

14import qualified Data.ByteString.Lazy as BL

14−import Data.Binary as B

15+import Codec.Winery

16emptyDatabaseContextFunction :: DatabaseContextFunctionName -> DatabaseContextFunction

17emptyDatabaseContextFunction :: DatabaseContextFunctionName -> DatabaseContextFunction

17emptyDatabaseContextFunction name = DatabaseContextFunction {

18emptyDatabaseContextFunction name = DatabaseContextFunction {

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

83-- for merkle hash

84-- for merkle hash

84hashBytes :: DatabaseContextFunction -> BL.ByteString

85hashBytes :: DatabaseContextFunction -> BL.ByteString

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

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

86 where

87 where

87− fname = B.encode (dbcFuncName func)

88+ fname = serialise (dbcFuncName func)

88− ftype = B.encode (dbcFuncType func)

89+ ftype = serialise (dbcFuncType func)

89 fbody = case dbcFuncBody func of

90 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)

9import Control.DeepSeq.Generics (genericRnf)

10import GHC.Generics (Generic)

11import qualified Data.Text as T

12−import Data.Binary

13import Data.Typeable

12import Data.Typeable

14import Control.Exception

13import Control.Exception

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

106 | MerkleHashValidationError TransactionId MerkleHash MerkleHash

105 | MerkleHashValidationError TransactionId MerkleHash MerkleHash

107

106

108 | MultipleErrors [RelationalError]

107 | MultipleErrors [RelationalError]

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

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

110

109

111data PersistenceError = InvalidDirectoryError FilePath |

110data PersistenceError = InvalidDirectoryError FilePath |

112 MissingTransactionError TransactionId |

111 MissingTransactionError TransactionId |

113 WrongDatabaseFormatVersionError String String

112 WrongDatabaseFormatVersionError String String

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

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

115

114

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

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

117someErrors :: [RelationalError] -> RelationalError

116someErrors :: [RelationalError] -> RelationalError

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

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

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

130 StrategyViolatesRelationVariableMergeError |

129 StrategyViolatesRelationVariableMergeError |

131 StrategyViolatesTypeConstructorMergeError

130 StrategyViolatesTypeConstructorMergeError

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

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

133

132

134instance NFData MergeError where rnf = genericRnf

133instance NFData MergeError where rnf = genericRnf

135

134

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

137 SyntaxErrorCompilationError String |

136 SyntaxErrorCompilationError String |

138 ScriptCompilationDisabledError |

137 ScriptCompilationDisabledError |

139 OtherScriptCompilationError String

138 OtherScriptCompilationError String

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

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

141

140

142instance Exception ScriptCompilationError

141instance Exception ScriptCompilationError

143

142

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

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

145 RelVarInReferencedMoreThanOnce RelVarName |

144 RelVarInReferencedMoreThanOnce RelVarName |

146 RelVarOutReferencedMoreThanOnce RelVarName

145 RelVarOutReferencedMoreThanOnce RelVarName

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

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

148

147

149

148

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

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

151data ServerError = RequestTimeoutError |

150data ServerError = RequestTimeoutError |

152 ProcessDiedError String

151 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 #-}

2module ProjectM36.IsomorphicSchema where

3import ProjectM36.Base

4import ProjectM36.Error

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

9import qualified ProjectM36.AttributeNames as AN

10import Control.Monad

11import GHC.Generics

12−import Data.Binary

13import qualified Data.Map as M

12import qualified Data.Map as M

14import qualified Data.Set as S

13import qualified Data.Set as S

15import qualified Data.List as L

14import qualified Data.List as L

15+import Codec.Winery hiding (Schema)

16#if __GLASGOW_HASKELL__ < 804

17import Data.Monoid

18#endif

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

29data SchemaExpr = AddSubschema SchemaName SchemaIsomorphs |

30 RemoveSubschema SchemaName

31− deriving (Generic, Binary, Show)

31+ deriving (Generic, Show)

32+ deriving Serialise via WineryVariant SchemaExpr

34isomorphs :: Schema -> SchemaIsomorphs

35isomorphs :: Schema -> SchemaIsomorphs

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

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

100syncDirectory FsyncDiskSync path = directoryFsync path

101syncDirectory NoDiskSync _ = pure ()

102

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

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

104writeBSFileSync sync path bstring =

105 withFile path WriteMode $ \handle -> do

106− BS.hPut handle bstring

106+ BS'.hPut handle bstring

107 syncHandle sync handle

108

109directoryFsync :: FilePath -> IO ()

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

131 fds <- getDirectoryContents FDDIR

132 pure ((length fds) - 2)

133--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(..))

8import ProjectM36.FSType

10import 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(..))

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

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

22import System.IO (stderr, hPutStrLn)

12import System.IO (stderr, hPutStrLn)

23import System.FilePath (takeDirectory)

13import System.FilePath (takeDirectory)

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

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

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

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

2module ProjectM36.Server.RemoteCallTypes where

3import ProjectM36.Base

4+import ProjectM36.Error

5+import ProjectM36.Serialise.Error

6+import Data.Map (Map)

4import ProjectM36.IsomorphicSchema

7import ProjectM36.IsomorphicSchema

5import ProjectM36.TransactionGraph

8import ProjectM36.TransactionGraph

6import ProjectM36.DataFrame

9import ProjectM36.DataFrame

7import ProjectM36.TransGraphRelationalExpression

10import ProjectM36.TransGraphRelationalExpression

8import ProjectM36.Session

11import ProjectM36.Session

12+import ProjectM36.Serialise.DataFrame

9import GHC.Generics

13import GHC.Generics

10import Data.Binary

14import Data.Binary

11import Control.Distributed.Process (ProcessId)

15import Control.Distributed.Process (ProcessId)

16+import Codec.Winery

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+

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

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

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

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

15data Login = Login ProcessId

72data Login = Login ProcessId

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

129

73data ExecuteValidateMerkleHashes = ExecuteValidateMerkleHashes SessionId

130data ExecuteValidateMerkleHashes = ExecuteValidateMerkleHashes SessionId

74 deriving (Binary, Generic)

131 deriving (Binary, Generic)

132+-}

src/lib/ProjectM36/TransGraphRelationalExpression.hs−17

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

10import Control.Monad.Trans.Class

11import Control.Monad.Trans.Except

12import Data.Functor.Identity

13−import Data.Binary

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

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

16type TransGraphRelationalExpr = RelationalExprBase TransactionIdLookup

15type TransGraphRelationalExpr = RelationalExprBase TransactionIdLookup

18−instance Binary TransGraphRelationalExpr

19−

20type TransGraphAttributeNames = AttributeNamesBase TransactionIdLookup

17type TransGraphAttributeNames = AttributeNamesBase TransactionIdLookup

22−instance Binary TransGraphAttributeNames

23−

24type TransGraphExtendTupleExpr = ExtendTupleExprBase TransactionIdLookup

19type TransGraphExtendTupleExpr = ExtendTupleExprBase TransactionIdLookup

26−instance Binary TransGraphExtendTupleExpr

27−

28type TransGraphTupleExpr = TupleExprBase TransactionIdLookup

21type TransGraphTupleExpr = TupleExprBase TransactionIdLookup

30−instance Binary TransGraphTupleExpr

31−

32type TransGraphTupleExprs = TupleExprsBase TransactionIdLookup

23type TransGraphTupleExprs = TupleExprsBase TransactionIdLookup

34−instance Binary TransGraphTupleExprs

35−

36type TransGraphRestrictionPredicateExpr = RestrictionPredicateExprBase TransactionIdLookup

25type TransGraphRestrictionPredicateExpr = RestrictionPredicateExprBase TransactionIdLookup

38−instance Binary TransGraphRestrictionPredicateExpr

39−

40type TransGraphAtomExpr = AtomExprBase TransactionIdLookup

27type TransGraphAtomExpr = AtomExprBase TransactionIdLookup

42−instance Binary TransGraphAtomExpr

43−

44type TransGraphAttributeExpr = AttributeExprBase TransactionIdLookup

29type TransGraphAttributeExpr = AttributeExprBase TransactionIdLookup

46type TransGraphWithNameExpr = WithNameExprBase TransactionIdLookup

31type TransGraphWithNameExpr = WithNameExprBase TransactionIdLookup

48−instance Binary TransGraphWithNameExpr

49−

50newtype TransGraphEvalEnv = TransGraphEvalEnv {

33newtype TransGraphEvalEnv = TransGraphEvalEnv {

51 tge_graph :: TransactionGraph

34 tge_graph :: TransactionGraph

52 }

35 }

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

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

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

9import qualified Data.Map as M

10import qualified Data.HashSet as HS

11−import qualified Data.Binary as B

12import System.FilePath

11import System.FilePath

13import System.Directory

12import System.Directory

14import qualified Data.Text as T

13import qualified Data.Text as T

15import Control.Monad

14import Control.Monad

16import ProjectM36.ScriptSession

15import ProjectM36.ScriptSession

17import ProjectM36.AtomFunctions.Basic (precompiledAtomFunctions)

16import ProjectM36.AtomFunctions.Basic (precompiledAtomFunctions)

17+import Codec.Winery

19#ifdef PM36_HASKELL_SCRIPTING

20import GHC

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

62 return $ Left $ MissingTransactionError transId

63 else do

64 relvars <- readRelVars transDir

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

65+ transInfo <- readFileDeserialise (transactionInfoPath transDir)

66 incDeps <- readIncDeps transDir

67 typeCons <- readTypeConstructorMapping transDir

68 sschemas <- readSubschemas transDir

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

92 writeDBCFuncs sync tempTransDir (dbcFunctions context)

93 writeTypeConstructorMapping sync tempTransDir (typeConstructorMapping context)

94 writeSubschemas sync tempTransDir (subschemas trans)

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

95+ writeFileSerialise (transactionInfoPath tempTransDir) (transactionInfo trans)

96 --move the temp directory to final location

97 renameSync sync tempTransDir finalTransDir

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

100writeRelVars sync transDir relvars = do

101 let path = relvarsPath transDir

102− writeBSFileSync sync path (B.encode relvars)

102+ writeBSFileSync sync path (serialise relvars)

103

104readRelVars :: FilePath -> IO RelationVariables

105readRelVars transDir =

106− B.decodeFile (relvarsPath transDir)

106+ readFileDeserialise (relvarsPath transDir)

107

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

109writeAtomFuncs sync transDir funcs = do

110 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))

112

113--all the atom functions are in one file

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

115readAtomFuncs transDir mScriptSession = do

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

116+ atomFuncsList <- readFileDeserialise (atomFuncsPath transDir)

117 --only Haskell script functions can be serialized

118 --we always return the pre-compiled functions

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

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

153#else

154readAtomFunc transDir funcName mScriptSession precompiledFuncs = do

155 let atomFuncPath = atomFuncsPath transDir

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

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

157 case mFuncScript of

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

159 Nothing -> case atomFunctionForName funcName precompiledFuncs of

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

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

185writeDBCFunc sync transDir func = do

186 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))

188

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

190readDBCFuncs transDir mScriptSession = do

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

201readDBCFunc transDir funcName mScriptSession precompiledFuncs = do

202#endif

203 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

205 case mFuncScript of

206 Nothing -> case databaseContextFunctionForName funcName precompiledFuncs of

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

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

225

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

227writeIncDep 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

229

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

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

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

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

234readIncDep transDir incdepName = do

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

236− incDepData <- B.decodeFile incDepPath

236+ incDepData <- readFileDeserialise incDepPath

237 pure (incdepName, incDepData)

238

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

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

245readSubschemas :: FilePath -> IO Subschemas

246readSubschemas transDir = do

247 let sschemasPath = subschemasPath transDir

248− B.decodeFile sschemasPath

248+ readFileDeserialise sschemasPath

249

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

251writeSubschemas sync transDir sschemas = do

252 let sschemasPath = subschemasPath transDir

253− writeBSFileSync sync sschemasPath (B.encode sschemas)

253+ writeBSFileSync sync sschemasPath (serialise sschemas)

254

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

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

257− writeBSFileSync sync atPath $ B.encode types

257+ writeBSFileSync sync atPath $ serialise types

258

259readTypeConstructorMapping :: FilePath -> IO TypeConstructorMapping

260readTypeConstructorMapping path = do

261 let atPath = typeConsPath path

262− B.decodeFile atPath

262+ readFileDeserialise atPath

263

264

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

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

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

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

2module ProjectM36.TransactionGraph where

3import ProjectM36.Base

4import ProjectM36.Error

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

13import qualified ProjectM36.DisconnectedTransaction as Discon

14import qualified ProjectM36.Attribute as A

16+import Codec.Winery

16import Control.Monad.Except hiding (join)

17import Control.Monad.Except hiding (join)

17import Control.Monad.Reader hiding (join)

18import Control.Monad.Reader hiding (join)

18import qualified Data.Vector as V

19import qualified Data.Vector as V

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

23import Data.Time.Clock

24import Data.Time.Clock

24import qualified Data.Text as T

25import qualified Data.Text as T

25import GHC.Generics

26import GHC.Generics

26−import Data.Binary as B

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

28#if __GLASGOW_HASKELL__ < 804

29import Data.Monoid

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

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

39data TransactionIdLookup = TransactionIdLookup TransactionId |

40 TransactionIdHeadNameLookup HeadName [TransactionIdHeadBacktrack]

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

41+ deriving (Show, Eq, Generic)

42+ deriving Serialise via WineryVariant TransactionIdLookup

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

44-- | 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

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

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

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

47 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

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

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

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

56 MergeTransactions MergeStrategy HeadName HeadName |

58 MergeTransactions MergeStrategy HeadName HeadName |

57 Commit |

59 Commit |

58 Rollback

60 Rollback

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

61+ deriving (Eq, Show, Generic)

62+ deriving Serialise via WineryVariant TransactionGraphOperator

61isCommit :: TransactionGraphOperator -> Bool

64isCommit :: TransactionGraphOperator -> Bool

62isCommit Commit = True

65isCommit Commit = True

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

593

596

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

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

595calculateMerkleHash :: Transaction -> TransactionGraph -> MerkleHash

598calculateMerkleHash :: Transaction -> TransactionGraph -> MerkleHash

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

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

597− dbcBytes,

600+ schemasBytes

598− schemasBytes,

599− parentMerkleHashes])

601+ ] <> dbcBytes <> parentMerkleHashes)

600 where

602 where

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

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

602 parentTranses =

604 parentTranses =

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

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

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

606 Right t -> S.toList t

608 Right t -> S.toList t

607 getMerkleHash t = merkleHash (transactionInfo t)

609 getMerkleHash t = merkleHash (transactionInfo t)

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

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

609 dbcBytes = DBC.hashBytes (concreteDatabaseContext trans)

611 dbcBytes = DBC.hashBytes (concreteDatabaseContext trans)

610− schemasBytes = B.encode (subschemas trans)

612+ schemasBytes = serialise (subschemas trans)

611

613

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

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

613validateMerkleHash trans graph =

615validateMerkleHash trans graph =