project-m36 0.8.1 → 0.9.0
raw patch · 58 files changed
+1354/−1020 lines, 58 filesdep +asyncdep +curryer-rpcdep +prettyprinterdep −distributed-processdep −distributed-process-asyncdep −distributed-process-client-serverdep ~aesondep ~basedep ~cassava
Dependencies added: async, curryer-rpc, prettyprinter, vector-instances, winery
Dependencies removed: distributed-process, distributed-process-async, distributed-process-client-server, distributed-process-extras, network-transport, network-transport-tcp
Dependency ranges changed: aeson, base, cassava, megaparsec, stm-containers, uuid
Files
- Changelog.markdown +13/−0
- README.markdown +1/−1
- examples/DerivingCustomTupleable.hs +4/−2
- examples/SimpleClient.hs +1/−1
- examples/blog.hs +4/−3
- examples/hair.hs +4/−3
- examples/out_of_the_tarpit.hs +10/−6
- project-m36.cabal +76/−132
- src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs +3/−0
- src/bin/ProjectM36/Server/WebSocket.hs +1/−1
- src/bin/ProjectM36/Server/WebSocket/websocket-server.hs +7/−10
- src/bin/TutorialD/Interpreter.hs +1/−1
- src/bin/TutorialD/Interpreter/Base.hs +8/−2
- src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs +33/−16
- src/bin/TutorialD/Interpreter/RelationalExpr.hs +24/−6
- src/bin/TutorialD/Printer.hs +165/−0
- src/bin/TutorialD/tutd.hs +5/−18
- src/lib/ProjectM36/Arbitrary.hs +5/−0
- src/lib/ProjectM36/Atom.hs +1/−0
- src/lib/ProjectM36/AtomFunction.hs +7/−6
- src/lib/ProjectM36/AtomFunctionError.hs +1/−2
- src/lib/ProjectM36/AtomType.hs +1/−0
- src/lib/ProjectM36/Atomable.hs +3/−19
- src/lib/ProjectM36/Base.hs +68/−88
- src/lib/ProjectM36/Client.hs +159/−291
- src/lib/ProjectM36/DataFrame.hs +15/−8
- src/lib/ProjectM36/DataTypes/Interval.hs +2/−0
- src/lib/ProjectM36/DataTypes/Primitive.hs +1/−0
- src/lib/ProjectM36/DataTypes/Sorting.hs +1/−0
- src/lib/ProjectM36/DatabaseContext.hs +6/−6
- src/lib/ProjectM36/DatabaseContextFunction.hs +6/−5
- src/lib/ProjectM36/DatabaseContextFunctionError.hs +1/−2
- src/lib/ProjectM36/Error.hs +6/−12
- src/lib/ProjectM36/InclusionDependency.hs +4/−5
- src/lib/ProjectM36/IsomorphicSchema.hs +2/−4
- src/lib/ProjectM36/MerkleHash.hs +2/−3
- src/lib/ProjectM36/Persist.hs +2/−3
- src/lib/ProjectM36/Relation/Parse/CSV.hs +5/−0
- src/lib/ProjectM36/RelationalExpression.hs +71/−2
- src/lib/ProjectM36/Serialise/AtomFunctionError.hs +7/−0
- src/lib/ProjectM36/Serialise/Base.hs +76/−0
- src/lib/ProjectM36/Serialise/DataFrame.hs +13/−0
- src/lib/ProjectM36/Serialise/DatabaseContextFunctionError.hs +7/−0
- src/lib/ProjectM36/Serialise/Error.hs +14/−0
- src/lib/ProjectM36/Serialise/IsomorphicSchema.hs +7/−0
- src/lib/ProjectM36/Server.hs +166/−91
- src/lib/ProjectM36/Server/EntryPoints.hs +108/−140
- src/lib/ProjectM36/Server/ParseArgs.hs +1/−1
- src/lib/ProjectM36/Server/RemoteCallTypes.hs +65/−36
- src/lib/ProjectM36/TransGraphRelationalExpression.hs +0/−17
- src/lib/ProjectM36/Transaction/Persist.hs +16/−16
- src/lib/ProjectM36/TransactionGraph.hs +14/−12
- test/Relation/Atomable.hs +28/−15
- test/Relation/Tupleable.hs +13/−2
- test/Server/Main.hs +13/−20
- test/Server/WebSocket.hs +3/−9
- test/TutorialD/Interpreter.hs +27/−3
- test/TutorialD/Printer.hs +47/−0
Changelog.markdown view
@@ -1,3 +1,16 @@+# 2020-12-27 (v0.9.0)++* replace unmaintained distributed-process-client-server RPC package with new curryer RPC package+* drop support for GHC 8.2 and GHC 8.4 due to dependency on DerivingVia extension++# 2020-11-21 (v0.8.2)++* support multiple extend expressions in TutorialD+* fix parsing of Bool atoms in TutorialD+* fix database context expressions which include self-references such as `s:=s union s`+* show constraints as TutorialD when using tutd console+* add `RelationalExprAtom` data type useful for storing `RelationalExpr` within the database+ # 2020-10-05 (v0.8.1) * support GHC 8.10
README.markdown view
@@ -95,7 +95,7 @@ ## Development -Project:M36 is developed in Haskell and compiled with GHC 8.2.2 or later.+Project:M36 is developed in Haskell and compiled with GHC 8.6 or later. ## Related Projects
examples/DerivingCustomTupleable.hs view
@@ -3,16 +3,16 @@ import ProjectM36.Tupleable.Deriving import ProjectM36.Atomable (Atomable) import Control.DeepSeq (NFData)-import Data.Binary (Binary) import Data.Text (Text) import GHC.Generics (Generic)+import Codec.Winery newtype BlogId = BlogId { getBlogId :: Int } deriving stock (Eq, Ord, Show, Generic) deriving newtype (Num)+ deriving Serialise via WineryRecord BlogId instance NFData BlogId-instance Binary BlogId instance Atomable BlogId data Blog = Blog@@ -23,6 +23,7 @@ deriving stock (Show, Generic) deriving (Tupleable) via Codec (Field (DropPrefix "blog" >>> CamelCase)) Blog+ deriving Serialise via WineryRecord Blog data Comment = Comment { commentAuthorName :: Text@@ -32,6 +33,7 @@ deriving stock (Show, Generic) deriving (Tupleable) via Codec (Field (DropPrefix "comment" >>> CamelCase)) Comment+ deriving Serialise via WineryRecord Comment main :: IO () main = do
examples/SimpleClient.hs view
@@ -6,7 +6,7 @@ main :: IO () main = do -- 1. create a ConnectionInfo- let connInfo = RemoteProcessConnectionInfo "mytestdb" (createNodeId "127.0.0.1" defaultServerPort) emptyNotificationCallback+ let connInfo = RemoteConnectionInfo "mytestdb" "127.0.0.1" (show defaultServerPort) emptyNotificationCallback -- 2. conncted to the remote database eConn <- connectProjectM36 connInfo case eConn of
examples/blog.hs view
@@ -1,5 +1,5 @@ -- a simple example of a blog schema-{-# LANGUAGE DeriveAnyClass, DeriveGeneric, OverloadedStrings, CPP #-}+{-# LANGUAGE DeriveAnyClass, DeriveGeneric, OverloadedStrings, CPP, DerivingVia #-} import ProjectM36.Client import ProjectM36.Base@@ -10,7 +10,6 @@ import Data.Either import GHC.Generics-import Data.Binary import qualified Data.Text as T import qualified Data.Text.Lazy as TL import Data.Time.Clock@@ -22,6 +21,7 @@ #endif import Data.List import Control.Monad (when, forM_)+import Codec.Winery import Web.Scotty as S import Text.Blaze.Html5 (h1, h2, h3, p, form, input, (!), toHtml, Html, a, toValue, hr, textarea)@@ -52,7 +52,8 @@ instance Tupleable Comment data Category = Food | Cats | Photos | Other T.Text -- note that this data type could not be represented by an "enumeration" as found in SQL databases- deriving (Atomable, Eq, Show, NFData, Binary, Generic) -- derive Atomable so that values of this type can be stored as a database value+ deriving (Atomable, Eq, Show, NFData, Generic) -- derive Atomable so that values of this type can be stored as a database value+ deriving Serialise via WineryVariant Category -- derive Serialisable to be able to transmit this data remotely -- add some short-hand error handling- your application should have proper handling handleIOError :: Show e => IO (Either e a) -> IO a
examples/hair.hs view
@@ -1,16 +1,17 @@-{-# LANGUAGE DeriveGeneric, DeriveAnyClass, OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric, DeriveAnyClass, OverloadedStrings, DerivingVia #-} import ProjectM36.Client import ProjectM36.Relation.Show.Term import GHC.Generics import Data.Text-import Data.Binary import Control.DeepSeq import qualified Data.Map as M import qualified Data.Text.IO as TIO import Data.Proxy+import Codec.Winery data Hair = Bald | Brown | Blond | OtherColor Text- deriving (Generic, Show, Eq, Binary, NFData, Atomable)+ deriving (Generic, Show, Eq, NFData, Atomable)+ deriving Serialise via WineryVariant Hair main :: IO () main = do
examples/out_of_the_tarpit.hs view
@@ -1,5 +1,5 @@ -- the Out-of-the-Tarpit example in Haskell and Project:M36-{-# LANGUAGE DeriveAnyClass, DeriveGeneric, OverloadedStrings #-}+{-# LANGUAGE DeriveAnyClass, DeriveGeneric, OverloadedStrings, DerivingVia #-} import ProjectM36.Client import ProjectM36.DataTypes.Primitive import ProjectM36.Tupleable@@ -7,11 +7,11 @@ import ProjectM36.Error import Data.Either import GHC.Generics-import Data.Binary import Control.DeepSeq import qualified Data.Text as T import Data.Time.Calendar import Data.Proxy+import Codec.Winery --create various database value (atom) types type Price = Double@@ -21,16 +21,20 @@ type Address = T.Text data RoomType = Kitchen | Bathroom | LivingRoom- deriving (Generic, Atomable, Eq, Show, Binary, NFData)+ deriving (Generic, Atomable, Eq, Show, NFData)+ deriving Serialise via WineryVariant RoomType data PriceBand = Low | Medium | High | Premium- deriving (Generic, Atomable, Eq, Show, Binary, NFData)+ deriving (Generic, Atomable, Eq, Show, NFData)+ deriving Serialise via WineryVariant PriceBand data AreaCode = City | Suburban | Rural- deriving (Generic, Atomable, Eq, Show, Binary, NFData)+ deriving (Generic, Atomable, Eq, Show, NFData)+ deriving Serialise via WineryVariant AreaCode data SpeedBand = VeryFastBand | FastBand | MediumBand | SlowBand - deriving (Generic, Atomable, Eq, Show, Binary, NFData)+ deriving (Generic, Atomable, Eq, Show, NFData)+ deriving Serialise via WineryVariant SpeedBand main :: IO () main = do
project-m36.cabal view
@@ -1,6 +1,8 @@+Cabal-Version: 2.2 Name: project-m36-Version: 0.8.1-License: PublicDomain+Version: 0.9.0+License: MIT+--note that this license specification is erroneous and only labeled MIT to appease hackage which does not recognize public domain packages in cabal >2.2- Project:M36 is dedicated to the public domain Build-Type: Simple Homepage: https://github.com/agentm/project-m36 Bug-Reports: https://github.com/agentm/project-m36/issues@@ -8,7 +10,6 @@ Stability: experimental Category: Relational Algebra Maintainer: agentm@themactionfaction.com-Cabal-Version: >= 1.10 Synopsis: Relational Algebra Engine Description: A relational algebra engine which can be used to persist and query Haskell data types. Extra-Source-Files: Changelog.markdown README.markdown@@ -34,7 +35,7 @@ Default: True Library- 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+ 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, filepath, zlib, directory, temporary, stm, time, hashable-time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256, text-manipulate >= 0.2.0.1 && < 0.3, winery, curryer-rpc, network, async, vector-instances if flag(haskell-scripting) Build-Depends: ghc >= 8.2 && < 8.11 CPP-Options: -DPM36_HASKELL_SCRIPTING@@ -51,6 +52,8 @@ ProjectM36.TransactionGraph.Merge, ProjectM36.TransGraphRelationalExpression, ProjectM36.Base,+ ProjectM36.Serialise.Base,+ ProjectM36.Serialise.Error, ProjectM36.DataFrame, ProjectM36.Attribute, ProjectM36.AttributeNames,@@ -110,6 +113,10 @@ ProjectM36.Server.EntryPoints, ProjectM36.Server.ParseArgs, ProjectM36.Server.RemoteCallTypes,+ ProjectM36.Serialise.AtomFunctionError,+ ProjectM36.Serialise.DataFrame,+ ProjectM36.Serialise.DatabaseContextFunctionError,+ ProjectM36.Serialise.IsomorphicSchema, ProjectM36.Session, ProjectM36.Sessions, ProjectM36.Transaction.Persist,@@ -155,13 +162,11 @@ MonadRandom, MonadRandom, vector, text,- vector-binary-instances, time, hashable-time, bytestring, stm, deepseq,- binary, data-interval, parallel, cassava,@@ -177,7 +182,9 @@ attoparsec, stm-containers >= 1.0.0, list-t,- parser-combinators+ parser-combinators,+ curryer-rpc,+ prettyprinter Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr,@@ -196,6 +203,7 @@ TutorialD.Interpreter.SchemaOperator, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator+ TutorialD.Printer main-is: TutorialD/tutd.hs CC-Options: -fPIC GHC-Options: -Wall -threaded@@ -208,9 +216,8 @@ Build-Depends: ghc >= 8.2 && < 8.11 Build-Depends: base, ghc-paths,- project-m36,- binary, transformers,+ project-m36, temporary, data-interval, deepseq,@@ -245,7 +252,7 @@ Executable bigrel Default-Language: Haskell2010 Default-Extensions: OverloadedStrings- Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, optparse-applicative, stm-containers, list-t, ghc, ghc-paths, transformers, project-m36, random, MonadRandom, semigroups, parser-combinators+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, optparse-applicative, stm-containers, list-t, ghc, ghc-paths, transformers, project-m36, random, MonadRandom, semigroups, parser-combinators Other-Modules: TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.RelationalExpr,@@ -256,6 +263,13 @@ if flag(profiler) GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall +Common commontest+ Default-Language: Haskell2010 + Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, websockets, optparse-applicative, network, aeson, project-m36, random, MonadRandom, semigroups, parser-combinators, winery, curryer-rpc, prettyprinter, base64-bytestring+ Default-Extensions: OverloadedStrings+ GHC-Options: -Wall -threaded+ Hs-Source-Dirs: ./src/bin, ., test/+ Benchmark basic-benchmark Default-Language: Haskell2010 Default-Extensions: OverloadedStrings@@ -268,146 +282,111 @@ GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall Test-Suite test-tutoriald- Default-Language: Haskell2010- Default-Extensions: OverloadedStrings+ import: commontest type: exitcode-stdio-1.0 main-is: test/TutorialD/Interpreter.hs- Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, list-t, project-m36, random, MonadRandom, semigroups, parser-combinators- Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator- GHC-Options: -Wall -threaded- Hs-Source-Dirs: ./src/bin, ., test+ Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, list-t, project-m36, random, MonadRandom, semigroups, parser-combinators, prettyprinter Test-Suite test-tutoriald-atomfunctionscript- Default-Language: Haskell2010- Default-Extensions: OverloadedStrings+ import: commontest type: exitcode-stdio-1.0- Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.SchemaOperator+ Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer main-is: test/TutorialD/Interpreter/AtomFunctionScript.hs- Build-Depends: base, HUnit, project-m36, uuid, containers, megaparsec, text, vector, directory, bytestring, mtl, haskeline, random, MonadRandom, semigroups, time, parser-combinators- GHC-Options: -Wall -threaded- Hs-Source-Dirs: ./src/bin, ./test, . Test-Suite test-tutoriald-databasecontextfunctionscript- Default-Language: Haskell2010- Default-Extensions: OverloadedStrings+ import: commontest type: exitcode-stdio-1.0- Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.SchemaOperator+ Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer main-is: test/TutorialD/Interpreter/DatabaseContextFunctionScript.hs- Build-Depends: base, HUnit, project-m36, uuid, containers, megaparsec, text, vector, directory, bytestring, mtl, haskeline, random, MonadRandom, semigroups, time, parser-combinators- GHC-Options: -Wall -threaded- Hs-Source-Dirs: ./src/bin, ./test, . Test-Suite test-relation- Default-Language: Haskell2010- Default-Extensions: OverloadedStrings+ import: commontest type: exitcode-stdio-1.0 main-is: test/Relation/Basic.hs- Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, project-m36, transformers- GHC-Options: -Wall -threaded Test-Suite test-static-optimizer- Default-Language: Haskell2010- Default-Extensions: OverloadedStrings+ import: commontest type: exitcode-stdio-1.0 main-is: test/Relation/StaticOptimizer.hs- Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, project-m36, transformers- GHC-Options: -Wall -threaded Test-Suite test-transactiongraph-persist- Default-Language: Haskell2010- Default-Extensions: OverloadedStrings+ import: commontest type: exitcode-stdio-1.0 main-is: test/TransactionGraph/Persist.hs- Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, project-m36, random, MonadRandom, semigroups, parser-combinators- Other-Modules: TutorialD.Interpreter.Base, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.BasicExamples- Hs-Source-Dirs: ., ./src/bin- GHC-Options: -Wall -threaded+ Other-Modules: TutorialD.Interpreter.Base, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Printer Test-Suite test-relation-import-csv- Default-Language: Haskell2010- Default-Extensions: OverloadedStrings+ import: commontest type: exitcode-stdio-1.0 main-is: test/Relation/Import/CSV.hs- Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, project-m36- GHC-Options: -Wall -threaded Test-Suite test-tutoriald-import-tutoriald- Default-Language: Haskell2010- Default-Extensions: OverloadedStrings+ import: commontest type: exitcode-stdio-1.0 main-is: test/TutorialD/Interpreter/Import/TutorialD.hs- Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, project-m36, random, MonadRandom, semigroups, parser-combinators- Other-Modules: TutorialD.Interpreter.Base, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.BasicExamples- GHC-Options: -Wall -threaded- Hs-Source-Dirs: ., ./src/bin+ Other-Modules: TutorialD.Interpreter.Base, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Printer Test-Suite test-relation-export-csv- Default-Language: Haskell2010- Default-Extensions: OverloadedStrings+ import: commontest type: exitcode-stdio-1.0 main-is: test/Relation/Export/CSV.hs- Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, project-m36- GHC-Options: -Wall -threaded Test-Suite test-transactiongraph-merge- Default-Language: Haskell2010- Default-Extensions: OverloadedStrings+ import: commontest type: exitcode-stdio-1.0 main-is: test/TransactionGraph/Merge.hs- Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, template-haskell, transformers, aeson, conduit, either, path-pieces, http-api-data, stm-containers, list-t, project-m36- GHC-Options: -Wall -threaded ++Test-Suite test-prettyprinter+ import: commontest+ type: exitcode-stdio-1.0+ main-is: test/TutorialD/Printer.hs+ Other-Modules: TutorialD.Printer, TutorialD.Interpreter.Base, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types+ benchmark bench- Default-Language: Haskell2010- Default-Extensions: OverloadedStrings+ import: commontest type: exitcode-stdio-1.0 main-is: benchmark/Relation.hs- Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, criterion, stm-containers, project-m36- GHC-Options: -Wall -rtsopts -threaded- Hs-Source-Dirs: ./src/bin Test-Suite test-server- Default-Language: Haskell2010- Default-Extensions: OverloadedStrings+ import: commontest type: exitcode-stdio-1.0 main-is: test/Server/Main.hs- Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, network-transport-tcp, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, project-m36, network-transport, semigroups- HS-Source-Dirs: ., ./src/bin- GHC-Options: -Wall -threaded + Executable Example-SimpleClient Default-Language: Haskell2010 Default-Extensions: OverloadedStrings- Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, ghc, ghc-paths, project-m36, random, MonadRandom+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, ghc, ghc-paths, project-m36, random, MonadRandom Main-Is: examples/SimpleClient.hs GHC-Options: -Wall -threaded Executable Example-OutOfTheTarpit Default-Language: Haskell2010 Default-Extensions: OverloadedStrings- Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36, winery Main-Is: examples/out_of_the_tarpit.hs GHC-Options: -Wall -threaded Executable Example-Blog Default-Language: Haskell2010 Default-Extensions: OverloadedStrings- Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36, scotty, blaze-html, http-types+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36, scotty, blaze-html, http-types, winery Main-Is: examples/blog.hs GHC-Options: -Wall -threaded - Executable Example-Hair Default-Language: Haskell2010 Default-Extensions: OverloadedStrings- Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36, winery Main-Is: examples/hair.hs GHC-Options: -Wall -threaded Executable Example-CustomTupleable Default-Language: Haskell2010 Default-Extensions: OverloadedStrings- Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36, winery Main-Is: examples/CustomTupleable.hs GHC-Options: -Wall -threaded @@ -417,100 +396,68 @@ else Buildable: False Default-Language: Haskell2010- Build-Depends: base, text, deepseq, binary, project-m36+ Build-Depends: base, text, deepseq, project-m36, winery Main-Is: examples/DerivingCustomTupleable.hs GHC-Options: -Wall -threaded Test-Suite test-scripts- Default-Language: Haskell2010- Default-Extensions: OverloadedStrings+ import: commontest type: exitcode-stdio-1.0 main-is: test/scripts.hs- Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, network-transport-tcp, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, project-m36, random, MonadRandom, semigroups, parser-combinators- Other-Modules: TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.Import.BasicExamples- GHC-Options: -Wall -threaded- Hs-Source-Dirs: ., ./src/bin+ Other-Modules: TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Printer Executable project-m36-websocket-server Default-Language: Haskell2010- Build-Depends: base, aeson, path-pieces, either, conduit, http-api-data, template-haskell, websockets, aeson, optparse-applicative, project-m36, containers, bytestring, text, vector, uuid, megaparsec, haskeline, mtl, directory, base64-bytestring, random, MonadRandom, time, network-transport-tcp, semigroups, attoparsec, parser-combinators+ Build-Depends: base, aeson, path-pieces, either, conduit, http-api-data, template-haskell, websockets, aeson, optparse-applicative, project-m36, containers, bytestring, text, vector, uuid, megaparsec, haskeline, mtl, directory, base64-bytestring, random, MonadRandom, time, semigroups, attoparsec, parser-combinators, prettyprinter, network Main-Is: ProjectM36/Server/WebSocket/websocket-server.hs- Other-Modules: ProjectM36.Client.Json, ProjectM36.Server.RemoteCallTypes.Json, ProjectM36.Server.WebSocket, TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator+ Other-Modules: ProjectM36.Client.Json, ProjectM36.Server.RemoteCallTypes.Json, ProjectM36.Server.WebSocket, TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer GHC-Options: -Wall -threaded Hs-Source-Dirs: ./src/bin Default-Extensions: OverloadedStrings Test-Suite test-websocket-server- Default-Language: Haskell2010+ import: commontest type: exitcode-stdio-1.0 main-is: test/Server/WebSocket.hs- Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, websockets, optparse-applicative, network, aeson, project-m36, random, MonadRandom, network-transport-tcp, semigroups, parser-combinators- Other-Modules: TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.TransactionGraphOperator, ProjectM36.Client.Json, ProjectM36.Server.RemoteCallTypes.Json, ProjectM36.Server.WebSocket, TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator- Default-Extensions: OverloadedStrings- GHC-Options: -Wall -threaded- Hs-Source-Dirs: ./src/bin, .+ Other-Modules: TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.TransactionGraphOperator, ProjectM36.Client.Json, ProjectM36.Server.RemoteCallTypes.Json, ProjectM36.Server.WebSocket, TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer Test-Suite test-isomorphic-schemas- Default-Language: Haskell2010+ import: commontest type: exitcode-stdio-1.0 main-is: test/IsomorphicSchema.hs- Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, websockets, optparse-applicative, network, aeson, project-m36- Default-Extensions: OverloadedStrings- GHC-Options: -Wall -threaded- Hs-Source-Dirs: ./src/bin, . Test-Suite test-atomable- Default-Language: Haskell2010+ import: commontest type: exitcode-stdio-1.0 main-is: test/Relation/Atomable.hs- Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, websockets, optparse-applicative, network, aeson, project-m36, random, MonadRandom, semigroups, parser-combinators- Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.SchemaOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types- Default-Extensions: OverloadedStrings- GHC-Options: -Wall -threaded- Hs-Source-Dirs: ./src/bin, ., test/+ Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.SchemaOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Printer Test-Suite test-multiprocess-access- Default-Language: Haskell2010+ import: commontest type: exitcode-stdio-1.0 main-is: test/MultiProcessDatabaseAccess.hs- Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, websockets, optparse-applicative, network, aeson, project-m36, random, MonadRandom- Default-Extensions: OverloadedStrings- GHC-Options: -Wall -threaded- Hs-Source-Dirs: ./src/bin, ., test/ Test-Suite test-transactiongraph-automerge- Default-Language: Haskell2010+ import: commontest type: exitcode-stdio-1.0 main-is: test/TransactionGraph/Automerge.hs- Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, websockets, optparse-applicative, network, aeson, project-m36, random, MonadRandom, semigroups, parser-combinators- Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.SchemaOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types- Default-Extensions: OverloadedStrings- GHC-Options: -Wall -threaded- Hs-Source-Dirs: ./src/bin, ., test/+ Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.SchemaOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Printer Test-Suite test-tupleable- Default-Language: Haskell2010+ import: commontest type: exitcode-stdio-1.0 main-is: test/Relation/Tupleable.hs- Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, websockets, optparse-applicative, network, aeson, project-m36, random, MonadRandom, semigroups- Default-Extensions: OverloadedStrings- GHC-Options: -Wall -threaded- Hs-Source-Dirs: ./src/bin, ., test/ Test-Suite test-client-simple- Default-Language: Haskell2010+ import: commontest Main-Is: test/Client/Simple.hs type: exitcode-stdio-1.0- Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, websockets, optparse-applicative, network, aeson, project-m36, random, MonadRandom, semigroups- Default-Extensions: OverloadedStrings- GHC-Options: -Wall -threaded- Hs-Source-Dirs: ./src/bin, ., test/ -- test for file handle leaks Executable handles Default-Language: Haskell2010 Default-Extensions: OverloadedStrings- Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, optparse-applicative, stm-containers, list-t, ghc, ghc-paths, transformers, project-m36, random, MonadRandom, semigroups, parser-combinators+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, optparse-applicative, stm-containers, list-t, ghc, ghc-paths, transformers, project-m36, random, MonadRandom, semigroups, parser-combinators, prettyprinter main-is: benchmark/Handles.hs Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base,@@ -529,17 +476,14 @@ TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types+ TutorialD.Printer GHC-Options: -Wall -threaded -rtsopts HS-Source-Dirs: ./src/bin if flag(profiler) GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall-+ Test-Suite test-dataframe- Default-Language: Haskell2010- Main-Is: test/DataFrame.hs+ import: commontest type: exitcode-stdio-1.0- Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.SchemaOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types- Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, websockets, optparse-applicative, network, aeson, project-m36, random, MonadRandom, semigroups, parser-combinators- Default-Extensions: OverloadedStrings- GHC-Options: -Wall -threaded- Hs-Source-Dirs: ./src/bin, ., test/+ Main-Is: test/DataFrame.hs+ Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.SchemaOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Printer
src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs view
@@ -99,6 +99,8 @@ "val" .= i ] toJSON atom@(RelationAtom i) = object [ "type" .= atomTypeForAtom atom, "val" .= i ]+ toJSON atom@(RelationalExprAtom i) = object [ "type" .= atomTypeForAtom atom,+ "val" .= i ] toJSON (ConstructedAtom dConsName atomtype atomlist) = object [ "dataconstructorname" .= dConsName, "type" .= toJSON atomtype,@@ -126,6 +128,7 @@ Left err -> fail ("Failed to parse base64-encoded ByteString: " ++ err) Right bs -> pure (ByteStringAtom bs) BoolAtomType -> BoolAtom <$> o .: "val"+ RelationalExprAtomType -> RelationalExprAtom <$> o .: "val" instance ToJSON Notification instance FromJSON Notification
src/bin/ProjectM36/Server/WebSocket.hs view
@@ -85,7 +85,7 @@ --this creates a new database for each connection- perhaps not what we want (?) createConnection :: WS.Connection -> DatabaseName -> Port -> Hostname -> IO (Either ConnectionError Connection)-createConnection wsconn dbname port host = connectProjectM36 (RemoteProcessConnectionInfo dbname (createNodeId host port) (notificationCallback wsconn))+createConnection wsconn dbname port host = connectProjectM36 (RemoteConnectionInfo dbname host (show port) (notificationCallback wsconn)) sendError :: (ToJSON a) => WS.Connection -> a -> IO () sendError conn err = WS.sendTextData conn (encode (object ["displayerror" .= err]))
src/bin/ProjectM36/Server/WebSocket/websocket-server.hs view
@@ -5,14 +5,8 @@ import ProjectM36.Server import Control.Concurrent import qualified Network.WebSockets as WS--#if MIN_VERSION_network_transport_tcp(0,6,0) -import Network.Transport.TCP.Internal (decodeEndPointAddress)-#else-import Network.Transport.TCP (decodeEndPointAddress)-#endif- import Control.Exception+import Network.Socket main :: IO () main = do@@ -26,8 +20,11 @@ serverConfig' = serverConfig {bindPort = 0, bindHost = serverHost} _ <- forkFinally (launchServer serverConfig' (Just addressMVar) >> pure ()) (either throwIO pure) --wait for server to be listening- address <- takeMVar addressMVar- let Just (_, serverPort, _) = decodeEndPointAddress address+ addr <- takeMVar addressMVar+ let port =+ case addr of+ SockAddrInet port' _ -> fromIntegral port'+ _ -> error "unsupported socket address (IPv4 only currently)" --this built-in server is apparently not meant for production use, but it's easier to test than starting up the wai or snap interfaces- WS.runServer wsHost (fromIntegral wsPort) (websocketProxyServer (read serverPort) serverHost)+ WS.runServer wsHost (fromIntegral wsPort) (websocketProxyServer port serverHost)
src/bin/TutorialD/Interpreter.hs view
@@ -227,7 +227,7 @@ type CheckFS = Bool data InterpreterConfig = LocalInterpreterConfig PersistenceStrategy HeadName (Maybe TutorialDExec) [GhcPkgPath] CheckFS |- RemoteInterpreterConfig C.NodeId C.DatabaseName HeadName (Maybe TutorialDExec) CheckFS+ RemoteInterpreterConfig C.Hostname C.Port C.DatabaseName HeadName (Maybe TutorialDExec) CheckFS outputNotificationCallback :: C.NotificationCallback outputNotificationCallback notName evaldNot = hPutStrLn stderr $ "Notification received " ++ show notName ++ ":\n" ++ "\n" ++ prettyEvaluatedNotification evaldNot
src/bin/TutorialD/Interpreter/Base.hs view
@@ -137,9 +137,9 @@ integer :: Parser Integer #if MIN_VERSION_megaparsec(6,0,0)-integer = Lex.signed spaceConsumer Lex.decimal+integer = Lex.signed (pure ()) Lex.decimal <* spaceConsumer #else-integer = Lex.signed spaceConsumer Lex.integer+integer = Lex.signed (pure ()) Lex.integer <* spaceConsumer #endif natural :: Parser Integer@@ -222,3 +222,9 @@ case parseTimeM True defaultTimeLocale "%Y-%m-%d %H:%M:%S" (T.unpack timeStr) of Nothing -> fail "invalid datetime input, use \"YYYY-MM-DD HH:MM:SS\"" Just stamp' -> pure stamp'+++colonOp :: Text -> Parser ()+colonOp opStr = do+ _ <- string opStr <* (void spaceChar <|> eof) <* spaceConsumer+ pure ()
src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs view
@@ -1,13 +1,16 @@ {-# LANGUAGE GADTs #-} module TutorialD.Interpreter.RODatabaseContextOperator where import ProjectM36.Base+import ProjectM36.Relation import qualified ProjectM36.DataFrame as DF import ProjectM36.Error+import ProjectM36.Tuple import ProjectM36.InclusionDependency import qualified ProjectM36.Client as C import TutorialD.Interpreter.Base import TutorialD.Interpreter.RelationalExpr import TutorialD.Interpreter.DatabaseContextExpr+import TutorialD.Printer import Control.Monad.State import qualified Data.Text as T import ProjectM36.Relation.Show.Gnuplot@@ -19,7 +22,7 @@ ShowRelation :: RelationalExpr -> RODatabaseContextOperator PlotRelation :: RelationalExpr -> RODatabaseContextOperator ShowRelationType :: RelationalExpr -> RODatabaseContextOperator- ShowConstraint :: StringType -> RODatabaseContextOperator+ ShowConstraints :: StringType -> RODatabaseContextOperator ShowPlan :: DatabaseContextExpr -> RODatabaseContextOperator ShowTypes :: RODatabaseContextOperator ShowRelationVariables :: RODatabaseContextOperator@@ -31,44 +34,44 @@ typeP :: Parser RODatabaseContextOperator typeP = do- reservedOp ":type"+ colonOp ":type" ShowRelationType <$> relExprP showRelP :: Parser RODatabaseContextOperator showRelP = do- reservedOp ":showexpr"+ colonOp ":showexpr" ShowRelation <$> relExprP showPlanP :: Parser RODatabaseContextOperator showPlanP = do- reservedOp ":showplan"+ colonOp ":showplan" ShowPlan <$> databaseContextExprP showTypesP :: Parser RODatabaseContextOperator-showTypesP = reserved ":showtypes" >> pure ShowTypes+showTypesP = colonOp ":showtypes" >> pure ShowTypes showRelationVariables :: Parser RODatabaseContextOperator-showRelationVariables = reserved ":showrelvars" >> pure ShowRelationVariables+showRelationVariables = colonOp ":showrelvars" >> pure ShowRelationVariables showAtomFunctionsP :: Parser RODatabaseContextOperator-showAtomFunctionsP = reserved ":showatomfunctions" >> pure ShowAtomFunctions+showAtomFunctionsP = colonOp ":showatomfunctions" >> pure ShowAtomFunctions showDatabaseContextFunctionsP :: Parser RODatabaseContextOperator-showDatabaseContextFunctionsP = reserved ":showdatabasecontextfunctions" >> pure ShowDatabaseContextFunctions+showDatabaseContextFunctionsP = colonOp ":showdatabasecontextfunctions" >> pure ShowDatabaseContextFunctions quitP :: Parser RODatabaseContextOperator quitP = do- reservedOp ":quit"+ colonOp ":quit" return Quit showConstraintsP :: Parser RODatabaseContextOperator showConstraintsP = do- reservedOp ":constraints"- ShowConstraint <$> option "" identifier+ colonOp ":constraints"+ ShowConstraints <$> option "" identifier plotRelExprP :: Parser RODatabaseContextOperator plotRelExprP = do- reserved ":plotexpr"+ colonOp ":plotexpr" PlotRelation <$> relExprP roDatabaseContextOperatorP :: Parser RODatabaseContextOperator@@ -106,15 +109,16 @@ err <- plotRelation rel when (isJust err) $ print err -evalRODatabaseContextOp sessionId conn (ShowConstraint name) = do+evalRODatabaseContextOp sessionId conn (ShowConstraints name) = do eIncDeps <- C.inclusionDependencies sessionId conn let val = case eIncDeps of Left err -> Left err Right incDeps -> case name of- "" -> inclusionDependenciesAsRelation incDeps+ "" -> inclusionDependenciesAsRelation incDeps >>= renderRelExprsInIncDeps depName -> case M.lookup depName incDeps of Nothing -> Left (InclusionDependencyNameNotInUseError depName)- Just dep -> inclusionDependenciesAsRelation (M.singleton depName dep)+ Just dep -> + inclusionDependenciesAsRelation (M.singleton depName dep) >>= renderRelExprsInIncDeps pure $ case val of Left err -> DisplayErrorResult (T.pack (show err)) Right rel -> DisplayRelationResult rel@@ -164,7 +168,7 @@ showDataFrameP :: Parser RODatabaseContextOperator showDataFrameP = do- reservedOp ":showdataframe"+ colonOp ":showdataframe" relExpr <- relExprP reservedOp "orderby" attrOrdersExpr <- attrOrdersExprP@@ -191,3 +195,16 @@ orderP :: Parser DF.Order orderP = try (reservedOp "ascending" >> pure DF.AscendingOrder) <|> try (reservedOp "descending" >> pure DF.DescendingOrder) <|> pure DF.AscendingOrder++-- render RelationalExprAtoms as TutorialD+renderRelExprsInIncDeps :: Relation -> Either RelationalError Relation+renderRelExprsInIncDeps = relMogrify tupMapper attrs+ where+ tupMapper tup = pure $ mkRelationTupleFromMap (M.map mapper (tupleToMap tup))+ mapper (RelationalExprAtom expr) = TextAtom (T.pack (show (prettyRelationalExpr expr)))+ mapper atom = atom+ attrs = C.attributesFromList [Attribute "name" TextAtomType,+ Attribute "sub" TextAtomType,+ Attribute "super" TextAtomType+ ]+
src/bin/TutorialD/Interpreter/RelationalExpr.hs view
@@ -20,10 +20,19 @@ attributeListP = (reservedOp "all but" >> InvertedAttributeNames . S.fromList <$> sepBy attributeNameP comma) <|>+ (reservedOp "all from" >> RelationalExprAttributeNames <$> relExprP) <|>- (AttributeNames . S.fromList <$> sepBy attributeNameP comma) + (reservedOp "union of" >>+ UnionAttributeNames <$> braces attributeListP <*> braces attributeListP) <|>++ (reservedOp "intersection of" >>+ IntersectAttributeNames <$> braces attributeListP <*> braces attributeListP) <|>+ + (AttributeNames . S.fromList <$> sepBy attributeNameP comma) + + makeRelationP :: RelationalMarkerExpr a => Parser (RelationalExprBase a) makeRelationP = do reserved "relation"@@ -102,7 +111,11 @@ extendP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a) extendP = do reservedOp ":"- Extend <$> braces extendTupleExpressionP+ extends <- braces (sepBy extendTupleExpressionP comma)+ case extends of+ [] -> pure (Restrict TruePredicate)+ extends' ->+ pure $ \expr -> foldl (flip Extend) expr extends' semijoinP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a -> RelationalExprBase a) semijoinP = do@@ -129,7 +142,8 @@ [InfixL antijoinP], [InfixL (reservedOp "union" >> return Union)], [InfixL (reservedOp "minus" >> return Difference)],- [InfixN (reservedOp "=" >> return Equals)],+ [InfixN (reservedOp "=" >> return Equals),+ InfixN (reservedOp "/=" >> return NotEquals)], [Postfix extendP] ] @@ -200,7 +214,7 @@ try (parens (constructedAtomExprP True)) <|> constructedAtomExprP consume <|> attributeAtomExprP <|>- nakedAtomExprP <|>+ try nakedAtomExprP <|> relationalAtomExprP attributeAtomExprP :: Parser (AtomExprBase a)@@ -242,8 +256,12 @@ boolAtomP :: Parser Atom boolAtomP = do- val <- char 't' <|> char 'f'- return $ BoolAtom (val == 't')+ v <- identifier+ if v == "t" || v == "f" then+ pure $ BoolAtom (v == "t") + else+ fail "invalid boolAtom"+ relationAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a) relationAtomExprP = RelationAtomExpr <$> makeRelationP
+ src/bin/TutorialD/Printer.hs view
@@ -0,0 +1,165 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+module TutorialD.Printer where+import ProjectM36.Base+import ProjectM36.Attribute hiding (null)+import Data.Text.Prettyprint.Doc +import qualified Data.Set as S hiding (fromList)+import qualified Data.Vector as V+import qualified Data.Map.Strict as M+import Data.Time.Calendar+import Data.Time.Clock.POSIX+import qualified Data.ByteString.Base64 as B64+import qualified Data.Text.Encoding as TE++instance Pretty Atom where+ pretty (IntegerAtom x) = pretty x+ pretty (IntAtom x) = "int" <> parensList [pretty x]+ pretty (DoubleAtom x) = pretty x+ pretty (TextAtom x) = dquotes (pretty x)+ pretty (DayAtom x) = "fromGregorian" <> parensList [pretty a, pretty b, pretty c]+ where+ (a,b,c) = toGregorian x+ pretty (DateTimeAtom time) = "dateTimeFromEpochSeconds" <> parensList [pretty @Integer (round (utcTimeToPOSIXSeconds time))]+ pretty (ByteStringAtom bs) = "bytestring" <> parensList [dquotes (pretty (TE.decodeUtf8 (B64.encode bs)))]+ pretty (BoolAtom x) = if x then "t" else "f"+ pretty (RelationAtom x) = pretty x+ pretty (RelationalExprAtom re) = pretty re+ pretty (ConstructedAtom n _ as) = pretty n <+> prettyList as++instance Pretty AtomExpr where+ pretty (AttributeAtomExpr attrName) = pretty attrName+ pretty (NakedAtomExpr atom) = pretty atom+ pretty (FunctionAtomExpr atomFuncName' atomExprs _) = pretty atomFuncName' <> prettyAtomExprsAsArguments atomExprs+ pretty (RelationAtomExpr relExpr) = pretty relExpr+ pretty (ConstructedAtomExpr dName [] _) = pretty dName+ pretty (ConstructedAtomExpr dName atomExprs _) = pretty dName <+> hsep (map prettyAtomExpr atomExprs)+ +prettyAtomExpr :: AtomExpr -> Doc ann+prettyAtomExpr atomExpr =+ case atomExpr of+ AttributeAtomExpr attrName -> "@" <> pretty attrName+ ConstructedAtomExpr dConsName [] () -> pretty dConsName+ ConstructedAtomExpr dConsName atomExprs () -> parens (pretty dConsName <+> hsep (map prettyAtomExpr atomExprs))+ _ -> pretty atomExpr+ +prettyAtomExprsAsArguments :: [AtomExpr] -> Doc ann+prettyAtomExprsAsArguments = align . parensList . map addAt+ where addAt (atomExpr :: AtomExpr) =+ case atomExpr of+ AttributeAtomExpr attrName -> "@" <> pretty attrName+ _ -> pretty atomExpr++instance Pretty TupleExpr where+ pretty (TupleExpr map') = "tuple" <> bracesList (Prelude.map (\(attrName,atom)-> pretty attrName <+> pretty atom) (M.toList map'))++instance Pretty RelationTuple where+ pretty (RelationTuple attrs atoms) = "tuple" <> bracesList (zipWith (\x y-> pretty x <+> pretty y) (V.toList (attributeNames attrs)) (V.toList atoms))++instance Pretty Relation where+ pretty (Relation attrs tupSet) | attrs == V.empty && null (asList tupSet) = "false"+ pretty (Relation attrs tupSet) | attrs == V.empty && asList tupSet == [RelationTuple V.empty V.empty] = "true"+ pretty (Relation attrs tupSet) = "relation" <> prettyBracesList (V.toList attrs) <> prettyBracesList (asList tupSet)++instance Pretty Attribute where+ pretty (Attribute n aTy) = pretty n <+> pretty (show aTy) -- workaround++instance Pretty RelationalExpr where+ pretty (RelationVariable n _) = pretty n+ pretty (ExistingRelation r) = pretty r+ pretty (NotEquals a b) = pretty' a <+> "!=" <+> pretty' b+ pretty (Equals a b) = pretty' a <+> "==" <+> pretty' b+ pretty (Project ns r) = pretty' (ignoreProjects r) <> pretty ns+ pretty (Extend ext r) = collectExtends r <> pretty ext <> "}"+ pretty (MakeRelationFromExprs Nothing (TupleExprs () tupExprs)) = "relation" <> prettyBracesList tupExprs+ pretty (MakeRelationFromExprs (Just attrExprs) (TupleExprs () tupExprs)) = "relation" <> prettyBracesList attrExprs <> prettyBracesList tupExprs+ pretty (MakeStaticRelation attrs tupSet) = "relation" <> prettyBracesList (V.toList attrs) <> prettyBracesList (asList tupSet)+ pretty (Union a b) = parens $ pretty' a <+> "union" <+> pretty' b+ pretty (Join a b) = parens $ pretty' a <+> "join" <+> pretty' b+ pretty (Rename n1 n2 relExpr) = parens $ pretty relExpr <+> "rename" <+> braces (pretty n1 <+> "as" <+> pretty n2)+ pretty (Difference a b) = parens $ pretty' a <+> "minus" <+> pretty' b+ pretty (Group attrNames attrName relExpr) = parens $ pretty relExpr <+> "group" <+> parens (pretty attrNames <+> "as" <+> pretty attrName)+ pretty (Ungroup attrName relExpr) = parens $ pretty' relExpr <+> "ungroup" <+> pretty attrName+ pretty (Restrict resPreExpr relExpr) = parens $ pretty' relExpr <+> "where" <+> pretty resPreExpr + pretty (With pairs a) = "with" <+> parensList (map (\(name,expr)-> pretty name <+> "as" <+> pretty expr) pairs) <+> pretty' a++-- relvar:{a:=?}:{b:=?}:... in ADTs => relvar:{a:=?, b:=?, ...} in Doc ann+collectExtends :: RelationalExpr -> Doc ann+collectExtends (Extend ext r) = collectExtends r <> pretty ext <> ", "+collectExtends r = pretty r <> ":{" ++--relvar{a,b,c,...}{a,b,...}..{a} => relvar{a}+ignoreProjects :: RelationalExpr -> RelationalExpr+ignoreProjects (Project _ r) = ignoreProjects r+ignoreProjects r = r++prettyRelationalExpr :: RelationalExpr -> Doc n+prettyRelationalExpr (RelationVariable n _) = pretty n+prettyRelationalExpr r = parens (pretty r)++pretty' :: RelationalExpr -> Doc n+pretty' = prettyRelationalExpr++instance Pretty AttributeNames where+ pretty (AttributeNames attrNames) = prettyBracesList (S.toList attrNames)+ pretty (InvertedAttributeNames attrNames) = braces $ "all but" <+> concatWith (surround ", ") (map pretty (S.toList attrNames))+ pretty (RelationalExprAttributeNames relExpr) = braces $ "all from" <+> pretty relExpr+ pretty (UnionAttributeNames aAttrNames bAttrNames) = braces ("union of" <+> pretty aAttrNames <+> pretty bAttrNames)+ pretty (IntersectAttributeNames aAttrNames bAttrNames) = braces ("intersection of" <+> pretty aAttrNames <+> pretty bAttrNames)++instance Pretty AttributeExpr where+ pretty (NakedAttributeExpr attr) = pretty attr+ pretty (AttributeAndTypeNameExpr name typeCons _) = pretty name <+> pretty typeCons++instance Pretty TypeConstructor where+ pretty (ADTypeConstructor tcName []) = pretty tcName+ pretty (ADTypeConstructor tcName tConsArgs) = pretty tcName <+> hsep (map pretty tConsArgs)+ pretty (PrimitiveTypeConstructor tcName atomType') = pretty tcName <+> pretty atomType'+ pretty (RelationAtomTypeConstructor attrExprs) = "relation" <> prettyBracesList attrExprs+ pretty (TypeVariable x) = pretty x++instance Pretty AtomType where+ pretty IntAtomType = "Int"+ pretty IntegerAtomType = "Integer"+ pretty DoubleAtomType = "Double"+ pretty TextAtomType = "Text"+ pretty DayAtomType = "Day"+ pretty DateTimeAtomType = "DateTime"+ pretty ByteStringAtomType = "ByteString"+ pretty BoolAtomType = "Bool"+ pretty (RelationAtomType attrs) = "relation " <+> prettyBracesList (V.toList attrs)+ pretty (ConstructedAtomType tcName tvMap) = pretty tcName <+> hsep (map pretty (M.toList tvMap)) --order matters+ pretty RelationalExprAtomType = "RelationalExpr"+ pretty (TypeVariableType x) = pretty x+ +instance Pretty ExtendTupleExpr where+ pretty (AttributeExtendTupleExpr attrName atomExpr) = pretty attrName <> ":=" <> pretty atomExpr+++instance Pretty RestrictionPredicateExpr where+ pretty TruePredicate = "true"+ pretty (AndPredicate a b) = pretty a <+> "and" <+> pretty b + pretty (OrPredicate a b) = pretty a <+> "or" <+> pretty b + pretty (NotPredicate a) = "not" <+> pretty a + pretty (RelationalExprPredicate relExpr) = pretty relExpr+ pretty (AtomExprPredicate atomExpr) = pretty atomExpr+ pretty (AttributeEqualityPredicate attrName atomExpr) = pretty attrName <> "=" <> pretty atomExpr++instance Pretty WithNameExpr where+ pretty (WithNameExpr name _) = pretty name++bracesList :: [Doc ann] -> Doc ann+bracesList = group . encloseSep (flatAlt "{ " "{") (flatAlt " }" "}") ", "++prettyBracesList :: Pretty a => [a] -> Doc ann+prettyBracesList = align . bracesList . map pretty++parensList :: [Doc ann] -> Doc ann+parensList = group . encloseSep (flatAlt "( " "(") (flatAlt " )" ")") ", "++prettyParensList :: Pretty a => [a] -> Doc ann+prettyParensList = align . parensList . map pretty+
src/bin/TutorialD/tutd.hs view
@@ -22,7 +22,7 @@ parseArgs :: Parser InterpreterConfig parseArgs = LocalInterpreterConfig <$> parsePersistenceStrategy <*> parseHeadName <*> parseTutDExec <*> many parseGhcPkgPath <*> parseCheckFS <|>- RemoteInterpreterConfig <$> parseNodeId <*> parseDatabaseName <*> parseHeadName <*> parseTutDExec <*> parseCheckFS+ RemoteInterpreterConfig <$> parseHostname "127.0.0.1" <*> parsePort defaultServerPort <*> parseDatabaseName <*> parseHeadName <*> parseTutDExec <*> parseCheckFS parseHeadName :: Parser HeadName parseHeadName = option auto (long "head" <>@@ -31,19 +31,6 @@ value "master" ) -parseNodeId :: Parser NodeId-parseNodeId = createNodeId <$> - strOption (long "host" <> - short 'h' <>- help "Remote host name" <>- metavar "HOSTNAME" <>- value "127.0.0.1") <*> - option auto (long "port" <>- metavar "PORT NUMBER" <>- short 'p' <>- help "Remote port" <>- value defaultServerPort)- --just execute some tutd and exit parseTutDExec :: Parser (Maybe TutorialDExec) parseTutDExec = optional $ strOption (long "exec-tutd" <>@@ -57,19 +44,19 @@ connectionInfoForConfig :: InterpreterConfig -> ConnectionInfo connectionInfoForConfig (LocalInterpreterConfig pStrategy _ _ ghcPkgPaths _) = InProcessConnectionInfo pStrategy outputNotificationCallback ghcPkgPaths-connectionInfoForConfig (RemoteInterpreterConfig remoteNodeId remoteDBName _ _ _) = RemoteProcessConnectionInfo remoteDBName remoteNodeId outputNotificationCallback+connectionInfoForConfig (RemoteInterpreterConfig remoteHost remotePort remoteDBName _ _ _) = RemoteConnectionInfo remoteDBName remoteHost (show remotePort) outputNotificationCallback headNameForConfig :: InterpreterConfig -> HeadName headNameForConfig (LocalInterpreterConfig _ headn _ _ _) = headn-headNameForConfig (RemoteInterpreterConfig _ _ headn _ _) = headn+headNameForConfig (RemoteInterpreterConfig _ _ _ headn _ _) = headn execTutDForConfig :: InterpreterConfig -> Maybe String execTutDForConfig (LocalInterpreterConfig _ _ t _ _) = t-execTutDForConfig (RemoteInterpreterConfig _ _ _ t _) = t+execTutDForConfig (RemoteInterpreterConfig _ _ _ _ t _) = t checkFSForConfig :: InterpreterConfig -> Bool checkFSForConfig (LocalInterpreterConfig _ _ _ _ c) = c-checkFSForConfig (RemoteInterpreterConfig _ _ _ _ c) = c+checkFSForConfig (RemoteInterpreterConfig _ _ _ _ _ c) = c persistenceStrategyForConfig :: InterpreterConfig -> Maybe PersistenceStrategy persistenceStrategyForConfig (LocalInterpreterConfig strat _ _ _ _) = Just strat
src/lib/ProjectM36/Arbitrary.hs view
@@ -9,6 +9,7 @@ import ProjectM36.Attribute (atomType) import ProjectM36.DataConstructorDef as DCD import ProjectM36.DataTypes.Interval+import ProjectM36.Relation import qualified Data.Vector as V import Data.Text (Text) import Test.QuickCheck@@ -48,6 +49,10 @@ arbitrary' BoolAtomType = Right . BoolAtom <$> lift (arbitrary :: Gen Bool)++arbitrary' RelationalExprAtomType =+ pure (Right (RelationalExprAtom (ExistingRelation relationTrue))) -- don't bother with arbitrary relational expressions+ arbitrary' constructedAtomType@(ConstructedAtomType tcName tvMap) --special-casing for Interval type | isIntervalAtomType constructedAtomType = createArbitraryInterval (intervalSubType constructedAtomType)
src/lib/ProjectM36/Atom.hs view
@@ -20,6 +20,7 @@ atomToText (DateTimeAtom i) = (T.pack . show) i atomToText (ByteStringAtom i) = (T.pack . show) i atomToText (BoolAtom i) = (T.pack . show) i+atomToText (RelationalExprAtom re) = (T.pack . show) re atomToText (RelationAtom i) = (T.pack . show) i atomToText (ConstructedAtom dConsName typ atoms)
src/lib/ProjectM36/AtomFunction.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} module ProjectM36.AtomFunction where import ProjectM36.Base+import ProjectM36.Serialise.Base () import ProjectM36.Error import ProjectM36.Relation import ProjectM36.AtomType@@ -10,7 +11,7 @@ import qualified Data.HashSet as HS import qualified Data.Text as T import qualified Data.ByteString.Lazy as BL-import Data.Binary as B+import Codec.Winery foldAtomFuncType :: AtomType -> AtomType -> [AtomType] --the underscore in the attribute name means that any attributes are acceptable@@ -91,10 +92,10 @@ --for calculating the merkle hash hashBytes :: AtomFunction -> BL.ByteString-hashBytes func = mconcat [B.encode (atomFuncName func),- B.encode (atomFuncType func),- bodyBin- ]+hashBytes func = BL.fromChunks [serialise (atomFuncName func),+ serialise (atomFuncType func),+ bodyBin+ ] where bodyBin = case atomFuncBody func of- AtomFunctionBody mScript _ -> B.encode mScript+ AtomFunctionBody mScript _ -> serialise mScript
src/lib/ProjectM36/AtomFunctionError.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} module ProjectM36.AtomFunctionError where-import Data.Binary import GHC.Generics import Control.DeepSeq import Data.Text@@ -14,5 +13,5 @@ AtomTypeDoesNotSupportOrderingError Text | AtomTypeDoesNotSupportIntervalError Text | AtomFunctionBytesDecodingError String- deriving(Generic, Eq, Show, Binary, NFData)+ deriving(Generic, Eq, Show, NFData)
src/lib/ProjectM36/AtomType.hs view
@@ -442,6 +442,7 @@ DateTimeAtomType -> True ByteStringAtomType -> True BoolAtomType -> True+ RelationalExprAtomType -> True RelationAtomType attrs -> isResolvedAttributes attrs ConstructedAtomType _ tvMap -> all isResolvedType (M.elems tvMap) TypeVariableType _ -> False
src/lib/ProjectM36/Atomable.hs view
@@ -13,29 +13,16 @@ import qualified Data.Text as T import qualified Data.Vector as V import Control.DeepSeq (NFData)-import Data.Binary import Control.Applicative import Data.Time.Calendar import Data.ByteString (ByteString) import Data.Time.Clock import Data.Proxy import qualified Data.List.NonEmpty as NE----also add haskell scripting atomable support---rename this module to Atomable along with test+import Codec.Winery -{--data Test1T = Test1C Int- deriving (Generic, Show, Eq, Binary, NFData, Atomable)- -data Test2T = Test2C Int Int - deriving (Generic, Show, Eq, Binary, NFData, Atomable)- -data Test3T = Test3Ca | Test3Cb - deriving (Generic, Show, Eq, Binary, NFData, Atomable)--} -- | 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.-class (Eq a, NFData a, Binary a, Show a) => Atomable a where+class (Eq a, NFData a, Serialise a, Show a) => Atomable a where toAtom :: a -> Atom default toAtom :: (Generic a, AtomableG (Rep a)) => a -> Atom toAtom v = toAtomG (from v) (toAtomTypeG (from v))@@ -165,10 +152,6 @@ toAtomType _ = ConstructedAtomType "NonEmptyList" (M.singleton "a" (toAtomType (Proxy :: Proxy a))) toAddTypeExpr _ = NoOperation -#if !MIN_VERSION_binary(0,8,4)-instance Binary a => Binary (NE.NonEmpty a) -#endif- -- Generics class AtomableG g where --type AtomTG g@@ -252,6 +235,7 @@ typeToTypeConstructor x@DateTimeAtomType = PrimitiveTypeConstructor "DateTime" x typeToTypeConstructor x@ByteStringAtomType = PrimitiveTypeConstructor "ByteString" x typeToTypeConstructor x@BoolAtomType = PrimitiveTypeConstructor "Bool" x+typeToTypeConstructor x@RelationalExprAtomType = PrimitiveTypeConstructor "RelationalExpr" x typeToTypeConstructor (RelationAtomType attrs) = RelationAtomTypeConstructor $ map attrToAttrExpr $ V.toList attrs where
src/lib/ProjectM36/Base.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ExistentialQuantification,DeriveGeneric,DeriveAnyClass,FlexibleInstances,OverloadedStrings, DeriveTraversable #-}+{-# LANGUAGE ExistentialQuantification,DeriveGeneric,DeriveAnyClass,FlexibleInstances,OverloadedStrings, DeriveTraversable, DerivingVia #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module ProjectM36.Base where@@ -18,16 +18,17 @@ import qualified Data.Vector as V import qualified Data.List as L import Data.Text (Text,unpack)-import Data.Binary-import Data.Vector.Binary() import Data.Time.Clock-import Data.Time.Clock.POSIX-import Data.Time.Calendar (Day,toGregorian,fromGregorian) import Data.Hashable.Time ()+import Data.Time.Calendar (Day) import Data.Typeable import Data.ByteString (ByteString) import qualified Data.List.NonEmpty as NE+import Data.Vector.Instances ()+ type StringType = Text++type DatabaseName = String -- | Database atoms are the smallest, undecomposable units of a tuple. Common examples are integers, text, or unique identity keys. data Atom = IntegerAtom Integer |@@ -39,8 +40,9 @@ ByteStringAtom ByteString | BoolAtom Bool | RelationAtom Relation |+ RelationalExprAtom RelationalExpr | --used for returning inc deps ConstructedAtom DataConstructorName AtomType [Atom]- deriving (Eq, Show, Binary, Typeable, NFData, Generic)+ deriving (Eq, Show, Typeable, NFData, Generic, Read) instance Hashable Atom where hashWithSalt salt (ConstructedAtom dConsName _ atoms) = salt `hashWithSalt` atoms@@ -54,16 +56,7 @@ hashWithSalt salt (ByteStringAtom bs) = salt `hashWithSalt` bs hashWithSalt salt (BoolAtom b) = salt `hashWithSalt` b hashWithSalt salt (RelationAtom r) = salt `hashWithSalt` r--instance Binary UTCTime where- put utc = put $ toRational (utcTimeToPOSIXSeconds utc)- get = posixSecondsToUTCTime . fromRational <$> (get :: Get Rational)- -instance Binary Day where - put day = put $ toGregorian day- get = do- (y,m,d) <- get :: Get (Integer, Int, Int)- return (fromGregorian y m d)+ hashWithSalt salt (RelationalExprAtom re) = salt `hashWithSalt` re -- 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. -- | The AtomType uniquely identifies the type of a atom.@@ -77,13 +70,15 @@ BoolAtomType | RelationAtomType Attributes | ConstructedAtomType TypeConstructorName TypeVarMap |+ RelationalExprAtomType | TypeVariableType TypeVarName --wildcard used in Atom Functions and tuples for data constructors which don't provide all arguments to the type constructor- deriving (Eq, NFData, Generic, Binary, Show)+ deriving (Eq, NFData, Generic, Show, Read, Hashable) instance Ord AtomType where compare = undefined- ++-- this should probably be an ordered dictionary in order to be able to round-trip these arguments type TypeVarMap = M.Map TypeVarName AtomType instance Hashable TypeVarMap where @@ -98,7 +93,7 @@ type AttributeName = StringType -- | A relation's type is composed of attribute names and types.-data Attribute = Attribute AttributeName AtomType deriving (Eq, Show, Generic, NFData, Binary)+data Attribute = Attribute AttributeName AtomType deriving (Eq, Show, Read, Generic, NFData) instance Hashable Attribute where hashWithSalt salt (Attribute attrName _) = hashWithSalt salt attrName@@ -116,7 +111,7 @@ sortedAttributesIndices attrs = L.sortBy (\(_, Attribute name1 _) (_,Attribute name2 _) -> compare name1 name2) $ V.toList (V.indexed attrs) -- | The relation's tuple set is the body of the relation.-newtype RelationTupleSet = RelationTupleSet { asList :: [RelationTuple] } deriving (Hashable, Show, Generic, Binary)+newtype RelationTupleSet = RelationTupleSet { asList :: [RelationTuple] } deriving (Hashable, Show, Generic, Read) instance Read Relation where readsPrec = error "relation read not supported"@@ -144,9 +139,7 @@ sortedTupVec = V.map (\(index, _) -> tupVec V.! index) $ V.fromList sortedAttrsIndices -- | A tuple is a set of attributes mapped to their 'Atom' values.-data RelationTuple = RelationTuple Attributes (V.Vector Atom) deriving (Show, Generic)--instance Binary RelationTuple+data RelationTuple = RelationTuple Attributes (V.Vector Atom) deriving (Show, Read, Generic) instance Eq RelationTuple where (==) tuple1@(RelationTuple attrs1 _) tuple2@(RelationTuple attrs2 _) = attributesEqual attrs1 attrs2 && atomsEqual@@ -158,7 +151,6 @@ instance NFData RelationTuple where rnf = genericRnf - data Relation = Relation Attributes RelationTupleSet deriving (Show, Generic,Typeable) instance Eq Relation where@@ -173,8 +165,6 @@ where sortedAttrs = map snd (sortedAttributesIndices attrs) -instance Binary Relation - -- | Used to represent the number of tuples in a relation. data RelationCardinality = Countable | Finite Int deriving (Eq, Show, Generic, Ord) @@ -219,17 +209,15 @@ --Summarize :: AtomExpr -> AttributeName -> RelationalExpr -> RelationalExpr -> RelationalExpr -- a special case of Extend --Evaluate relationalExpr with scoped views With [(WithNameExprBase a, RelationalExprBase a)] (RelationalExprBase a)- deriving (Show, Eq, Generic, NFData, Foldable, Functor, Traversable)- -instance Binary RelationalExpr+ deriving (Show, Read, Eq, Generic, NFData, Foldable, Functor, Traversable) +instance Hashable RelationalExpr+ data WithNameExprBase a = WithNameExpr RelVarName a- deriving (Show, Eq, Generic, NFData, Foldable, Functor, Traversable)+ deriving (Show, Read, Eq, Generic, NFData, Foldable, Functor, Traversable, Hashable) type WithNameExpr = WithNameExprBase () -instance Binary WithNameExpr- type GraphRefWithNameExpr = WithNameExprBase GraphRefTransactionMarker type NotificationName = StringType@@ -241,22 +229,22 @@ reportOldExpr :: RelationalExpr, --run the expression in the pre-change context reportNewExpr :: RelationalExpr --run the expression in the post-change context }- deriving (Show, Eq, Binary, Generic, NFData)+ deriving (Show, Eq, Generic, NFData) type TypeVarName = StringType -- | Metadata definition for type constructors such as @data Either a b@. data TypeConstructorDef = ADTypeConstructorDef TypeConstructorName [TypeVarName] | PrimitiveTypeConstructorDef TypeConstructorName AtomType- deriving (Show, Generic, Binary, Eq, NFData)+ deriving (Show, Generic, Eq, NFData, Hashable, Read) -- | Found in data constructors and type declarations: Left (Either Int Text) | Right Int type TypeConstructor = TypeConstructorBase () data TypeConstructorBase a = ADTypeConstructor TypeConstructorName [TypeConstructor] |- PrimitiveTypeConstructor TypeConstructorName AtomType |- RelationAtomTypeConstructor [AttributeExprBase a] |- TypeVariable TypeVarName- deriving (Show, Generic, Binary, Eq, NFData)+ PrimitiveTypeConstructor TypeConstructorName AtomType |+ RelationAtomTypeConstructor [AttributeExprBase a] |+ TypeVariable TypeVarName+ deriving (Show, Generic, Eq, NFData, Hashable, Read) type TypeConstructorMapping = [(TypeConstructorDef, DataConstructorDefs)] @@ -266,20 +254,20 @@ type AtomTypeName = StringType -- | Used to define a data constructor in a type constructor context such as @Left a | Right b@-data DataConstructorDef = DataConstructorDef DataConstructorName [DataConstructorDefArg] deriving (Eq, Show, Binary, Generic, NFData)+data DataConstructorDef = DataConstructorDef DataConstructorName [DataConstructorDefArg] deriving (Eq, Show, Generic, NFData, Hashable, Read) type DataConstructorDefs = [DataConstructorDef] data DataConstructorDefArg = DataConstructorDefTypeConstructorArg TypeConstructor | DataConstructorDefTypeVarNameArg TypeVarName- deriving (Show, Generic, Binary, Eq, NFData)+ deriving (Show, Generic, Eq, NFData, Hashable, Read) type InclusionDependencies = M.Map IncDepName InclusionDependency type RelationVariables = M.Map RelVarName GraphRefRelationalExpr data GraphRefTransactionMarker = TransactionMarker TransactionId | UncommittedContextMarker- deriving (Eq, Show, Binary, Generic, NFData, Ord)+ deriving (Eq, Show, Generic, NFData, Ord) -- a fundamental relational expr to which other relational expressions compile type GraphRefRelationalExpr = RelationalExprBase GraphRefTransactionMarker@@ -290,17 +278,18 @@ -- | Every transaction has one concrete database context and any number of isomorphic subschemas. data Schemas = Schemas DatabaseContext Subschemas+ deriving (Generic) -- | The DatabaseContext is a snapshot of a database's evolving state and contains everything a database client can change over time. -- 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. newtype Schema = Schema SchemaIsomorphs- deriving (Generic, Binary)+ deriving (Generic) data SchemaIsomorph = IsoRestrict RelVarName RestrictionPredicateExpr (RelVarName, RelVarName) | IsoRename RelVarName RelVarName | IsoUnion (RelVarName, RelVarName) RestrictionPredicateExpr RelVarName --maps two relvars to one relvar -- IsoTypeConstructor in morphAttrExpr- deriving (Generic, Binary, Show)+ deriving (Generic, Show) type SchemaIsomorphs = [SchemaIsomorph] @@ -316,9 +305,7 @@ type IncDepName = StringType -- | Inclusion dependencies represent every possible database constraint. Constraints enforce specific, arbitrarily-complex rules to which the database context's relation variables must adhere unconditionally.-data InclusionDependency = InclusionDependency RelationalExpr RelationalExpr deriving (Show, Eq, Generic, NFData)--instance Binary InclusionDependency+data InclusionDependency = InclusionDependency RelationalExpr RelationalExpr deriving (Show, Eq, Generic, NFData, Hashable, Read) type AttributeNameAtomExprMap = M.Map AttributeName AtomExpr @@ -327,9 +314,9 @@ type DatabaseContextExpr = DatabaseContextExprBase () -type GraphRefDatabaseContextExpr = DatabaseContextExprBase GraphRefTransactionMarker+instance Hashable DatabaseContextExpr -instance Binary GraphRefDatabaseContextExpr+type GraphRefDatabaseContextExpr = DatabaseContextExprBase GraphRefTransactionMarker -- | Database context expressions modify the database context. data DatabaseContextExprBase a = @@ -358,9 +345,10 @@ ExecuteDatabaseContextFunction DatabaseContextFunctionName [AtomExprBase a] | MultipleExpr [DatabaseContextExprBase a]- deriving (Show, Eq, Generic)+ deriving (Show, Read, Eq, Generic, NFData) -instance Binary DatabaseContextExpr+instance Hashable (M.Map AttributeName AtomExpr) where+ hashWithSalt salt m = salt `hashWithSalt` M.toList m type ObjModuleName = StringType type ObjFunctionName = StringType@@ -372,7 +360,7 @@ AddDatabaseContextFunction DatabaseContextFunctionName [TypeConstructor] DatabaseContextFunctionBodyScript | LoadDatabaseContextFunctions ObjModuleName ObjFunctionName FilePath | CreateArbitraryRelation RelVarName [AttributeExprBase a] Range- deriving (Show, Eq, Generic, Binary)+ deriving (Show, Eq, Generic) type GraphRefDatabaseContextIOExpr = DatabaseContextIOExprBase GraphRefTransactionMarker @@ -380,6 +368,8 @@ type RestrictionPredicateExpr = RestrictionPredicateExprBase () +instance Hashable RestrictionPredicateExpr+ type GraphRefRestrictionPredicateExpr = RestrictionPredicateExprBase GraphRefTransactionMarker -- | Restriction predicates are boolean algebra components which, when composed, indicate whether or not a tuple should be retained during a restriction (filtering) operation.@@ -391,9 +381,7 @@ RelationalExprPredicate (RelationalExprBase a) | --type must be same as true and false relations (no attributes) AtomExprPredicate (AtomExprBase a) | --atom must evaluate to boolean AttributeEqualityPredicate AttributeName (AtomExprBase a) -- relationalexpr must result in relation with single tuple- deriving (Show, Eq, Generic, NFData, Foldable, Functor, Traversable)--instance Binary RestrictionPredicateExpr+ deriving (Show, Read, Eq, Generic, NFData, Foldable, Functor, Traversable) -- child + parent links -- | 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.@@ -403,6 +391,7 @@ -- | The transaction graph is the global database's state which references every committed transaction. data TransactionGraph = TransactionGraph TransactionHeads (S.Set Transaction)+ deriving Generic transactionHeadsForGraph :: TransactionGraph -> TransactionHeads transactionHeadsForGraph (TransactionGraph hs _) = hs@@ -425,12 +414,11 @@ deriving (Show, Generic) -} -instance Binary TransactionInfo - -- | Every set of modifications made to the database are atomically committed to the transaction graph as a transaction. type TransactionId = UUID data Transaction = Transaction TransactionId TransactionInfo Schemas+ deriving Generic -- | 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. data DisconnectedTransaction = DisconnectedTransaction TransactionId Schemas DirtyFlag@@ -454,6 +442,8 @@ type AtomExpr = AtomExprBase () +instance Hashable AtomExpr+ type GraphRefAtomExpr = AtomExprBase GraphRefTransactionMarker -- | An atom expression represents an action to take when extending a relation or when statically defining a relation or a new tuple.@@ -462,18 +452,17 @@ FunctionAtomExpr AtomFunctionName [AtomExprBase a] a | RelationAtomExpr (RelationalExprBase a) | ConstructedAtomExpr DataConstructorName [AtomExprBase a] a- deriving (Eq,Show,Generic, NFData, Foldable, Functor, Traversable)+ deriving (Eq, Show, Read, Generic, NFData, Foldable, Functor, Traversable) -instance Binary AtomExpr - -- | Used in tuple creation when creating a relation. data ExtendTupleExprBase a = AttributeExtendTupleExpr AttributeName (AtomExprBase a)- deriving (Show, Eq, Generic, NFData, Foldable, Functor, Traversable)+ deriving (Show, Read, Eq, Generic, NFData, Foldable, Functor, Traversable) type ExtendTupleExpr = ExtendTupleExprBase ()-type GraphRefExtendTupleExpr = ExtendTupleExprBase GraphRefTransactionMarker -instance Binary ExtendTupleExpr+instance Hashable ExtendTupleExpr+ +type GraphRefExtendTupleExpr = ExtendTupleExprBase GraphRefTransactionMarker --enumerates the list of functions available to be run as part of tuple expressions type AtomFunctions = HS.HashSet AtomFunction@@ -485,6 +474,7 @@ type AtomFunctionBodyType = [Atom] -> Either AtomFunctionError Atom data AtomFunctionBody = AtomFunctionBody (Maybe AtomFunctionBodyScript) AtomFunctionBodyType+ deriving Generic instance NFData AtomFunctionBody where rnf (AtomFunctionBody mScript _) = rnf mScript@@ -519,14 +509,17 @@ UnionAttributeNames (AttributeNamesBase a) (AttributeNamesBase a) | IntersectAttributeNames (AttributeNamesBase a) (AttributeNamesBase a) | RelationalExprAttributeNames (RelationalExprBase a) -- use attribute names from the relational expression's type- deriving (Eq, Show, Generic, NFData, Foldable, Functor, Traversable)+ deriving (Eq, Show, Read, Generic, NFData, Foldable, Functor, Traversable)++instance Hashable AttributeNames++instance Hashable (S.Set AttributeName) where+ hashWithSalt salt s = salt `hashWithSalt` S.toList s type AttributeNames = AttributeNamesBase () type GraphRefAttributeNames = AttributeNamesBase GraphRefTransactionMarker -instance Binary AttributeNames- -- | The persistence strategy is a global database option which represents how to persist the database in the filesystem, if at all. data PersistenceStrategy = NoPersistence | -- ^ no filesystem persistence/memory-only database MinimalPersistence FilePath | -- ^ fsync off, not crash-safe@@ -539,27 +532,27 @@ -- | Create attributes dynamically. data AttributeExprBase a = AttributeAndTypeNameExpr AttributeName TypeConstructor a | NakedAttributeExpr Attribute- deriving (Eq, Show, Generic, Binary, NFData, Foldable, Functor, Traversable)+ deriving (Eq, Show, Read, Generic, NFData, Foldable, Functor, Traversable, Hashable) -- | Dynamically create a tuple from attribute names and 'AtomExpr's. newtype TupleExprBase a = TupleExpr (M.Map AttributeName (AtomExprBase a))- deriving (Eq, Show, Generic, NFData, Foldable, Functor, Traversable)- -instance Binary TupleExpr+ deriving (Eq, Show, Read, Generic, NFData, Foldable, Functor, Traversable) +instance Hashable TupleExpr+ type TupleExpr = TupleExprBase () type GraphRefTupleExpr = TupleExprBase GraphRefTransactionMarker data TupleExprsBase a = TupleExprs a [TupleExprBase a]- deriving (Eq, Show, Generic, NFData, Foldable, Functor, Traversable)+ deriving (Eq, Show, Read, Generic, NFData, Foldable, Functor, Traversable) +instance Hashable TupleExprs+ type GraphRefTupleExprs = TupleExprsBase GraphRefTransactionMarker type TupleExprs = TupleExprsBase () -instance Binary TupleExprs- data MergeStrategy = -- | 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) UnionMergeStrategy |@@ -567,7 +560,7 @@ UnionPreferMergeStrategy HeadName | -- | 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. SelectedBranchMergeStrategy HeadName- deriving (Eq, Show, Binary, Generic, NFData)+ deriving (Eq, Show, Generic, NFData) type DatabaseContextFunctionName = StringType @@ -604,6 +597,7 @@ DateTimeAtomType -> S.empty ByteStringAtomType -> S.empty BoolAtomType -> S.empty+ RelationalExprAtomType -> S.empty (RelationAtomType attrs) -> S.unions (map attrTypeVars (V.toList attrs)) (ConstructedAtomType _ tvMap) -> M.keysSet tvMap (TypeVariableType nam) -> S.singleton nam@@ -627,6 +621,7 @@ atomTypeVars DateTimeAtomType = S.empty atomTypeVars ByteStringAtomType = S.empty atomTypeVars BoolAtomType = S.empty+atomTypeVars RelationalExprAtomType = S.empty atomTypeVars (RelationAtomType attrs) = S.unions (map attrTypeVars (V.toList attrs)) atomTypeVars (ConstructedAtomType _ tvMap) = M.keysSet tvMap atomTypeVars (TypeVariableType nam) = S.singleton nam@@ -635,20 +630,5 @@ unimplemented = undefined --for serializing GraphRefRelationalExpr as part of transaction serialization-instance Binary (TupleExprsBase GraphRefTransactionMarker)--instance Binary (TupleExprBase GraphRefTransactionMarker)--instance Binary GraphRefRelationalExpr --instance Binary (AtomExprBase GraphRefTransactionMarker)--instance Binary (AttributeNamesBase GraphRefTransactionMarker)--instance Binary (RestrictionPredicateExprBase GraphRefTransactionMarker)--instance Binary (ExtendTupleExprBase GraphRefTransactionMarker)--instance Binary GraphRefWithNameExpr
src/lib/ProjectM36/Client.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveAnyClass, DeriveGeneric, ScopedTypeVariables, MonoLocalBinds #-}+{-# LANGUAGE DeriveGeneric, ScopedTypeVariables, MonoLocalBinds, DerivingVia #-} {-| Module: ProjectM36.Client @@ -9,6 +9,7 @@ Connection(..), Port, Hostname,+ ServiceName, DatabaseName, ConnectionError(..), connectProjectM36,@@ -43,6 +44,7 @@ defaultDatabaseName, defaultRemoteConnectionInfo, defaultHeadName,+ addClientNode, PersistenceStrategy(..), RelationalExpr, RelationalExprBase(..),@@ -53,11 +55,9 @@ Attribute(..), MergeStrategy(..), attributesFromList,- createNodeId, createSessionAtCommit, createSessionAtHead, closeSession,- addClientNode, callTestTimeout_, RelationCardinality(..), TransactionGraphOperator(..),@@ -67,7 +67,6 @@ TransGraphRelationalExpr, TransactionIdLookup(..), TransactionIdHeadBacktrack(..),- NodeId(..), Atom(..), Session, SessionId,@@ -107,6 +106,7 @@ ) where import ProjectM36.Base hiding (inclusionDependencies) --defined in this module as well import qualified ProjectM36.Base as B+import ProjectM36.Serialise.Error () import ProjectM36.Error import ProjectM36.Atomable import ProjectM36.AtomFunction as AF@@ -134,28 +134,16 @@ import ProjectM36.ScriptSession (initScriptSession, ScriptSession) import qualified ProjectM36.Relation as R import Control.Exception.Base-import GHC.Conc.Sync--import Network.Transport (Transport(closeTransport))-#if MIN_VERSION_network_transport_tcp(0,7,0)-import Network.Transport.TCP (createTransport, defaultTCPParameters, defaultTCPAddr)-import Network.Transport.TCP.Internal (encodeEndPointAddress)-#elif MIN_VERSION_network_transport_tcp(0,6,0)-import Network.Transport.TCP (createTransport, defaultTCPParameters)-import Network.Transport.TCP.Internal (encodeEndPointAddress)-#else-import Network.Transport.TCP (encodeEndPointAddress, createTransport, defaultTCPParameters)-#endif+import Control.Concurrent.STM+import Control.Concurrent.Async -import Control.Distributed.Process.Node (newLocalNode, initRemoteTable, runProcess, LocalNode, forkProcess, closeLocalNode)-import Control.Distributed.Process.Extras.Internal.Types (whereisRemote)-import Control.Distributed.Process.ManagedProcess.Client (call, safeCall) import Data.Either (isRight) import Data.UUID.V4 (nextRandom) import Data.Word-import Control.Distributed.Process (ProcessId, Process, receiveWait, send, match, NodeId(..), reconnect)+import Data.Hashable import Control.Exception (IOException, handle, AsyncException, throwIO, fromException, Exception) import Control.Concurrent.MVar+import Codec.Winery hiding (Schema, schema) import qualified Data.Map as M #if MIN_VERSION_stm_containers(1,0,0) import qualified StmContainers.Map as StmMap@@ -167,19 +155,19 @@ import qualified ProjectM36.Session as Sess import ProjectM36.Session import ProjectM36.Sessions-import Data.Binary (Binary) import GHC.Generics (Generic) import Control.DeepSeq (force) import System.IO import Data.Time.Clock-import Data.Typeable+import qualified Network.RPC.Curryer.Client as RPC+import qualified Network.RPC.Curryer.Server as RPC+import Network.Socket (Socket, AddrInfo(..), getAddrInfo, defaultHints, AddrInfoFlag(..), SocketType(..), ServiceName, hostAddressToTuple, SockAddr(..))+import GHC.Conc (unsafeIOToSTM) type Hostname = String type Port = Word16 -type DatabaseName = String- -- | The type for notifications callbacks in the client. When a registered notification fires due to a changed relational expression evaluation, the server propagates the notifications to the clients in the form of the callback. type NotificationCallback = NotificationName -> EvaluatedNotification -> IO () @@ -199,15 +187,16 @@ instance Exception RequestTimeoutException --- | Construct a 'ConnectionInfo' to describe how to make the 'Connection'. The database can be run within the current process or running remotely via distributed-process.-data ConnectionInfo = InProcessConnectionInfo PersistenceStrategy NotificationCallback [GhcPkgPath]|- RemoteProcessConnectionInfo DatabaseName NodeId NotificationCallback+-- | Construct a 'ConnectionInfo' to describe how to make the 'Connection'. The database can be run within the current process or running remotely via RPC.+data ConnectionInfo = InProcessConnectionInfo PersistenceStrategy NotificationCallback [GhcPkgPath] |+ RemoteConnectionInfo DatabaseName Hostname ServiceName NotificationCallback type EvaluatedNotifications = M.Map NotificationName EvaluatedNotification -- | Used for callbacks from the server when monitored changes have been made. newtype NotificationMessage = NotificationMessage EvaluatedNotifications- deriving (Binary, Eq, Show, Generic)+ deriving (Eq, Show, Generic)+ deriving Serialise via WineryVariant NotificationMessage -- | When a notification is fired, the 'reportOldExpr' is evaluated in the commit's pre-change context while the 'reportNewExpr' is evaluated in the post-change context and they are returned along with the original notification. data EvaluatedNotification = EvaluatedNotification {@@ -215,13 +204,10 @@ reportOldRelation :: Either RelationalError Relation, reportNewRelation :: Either RelationalError Relation }- deriving(Binary, Eq, Show, Generic)+ deriving (Eq, Show, Generic)+ deriving Serialise via WineryRecord EvaluatedNotification --- | Create a 'NodeId' for use in connecting to a remote server using distributed-process.-createNodeId :: Hostname -> Port -> NodeId -createNodeId host port = NodeId $ encodeEndPointAddress host (show port) 1- -- | Use this for connecting to remote servers on the default port. defaultServerPort :: Port defaultServerPort = 6543@@ -236,31 +222,16 @@ -- | Create a connection configuration which connects to the localhost on the default server port and default server database name. The configured notification callback is set to ignore all events. defaultRemoteConnectionInfo :: ConnectionInfo-defaultRemoteConnectionInfo = RemoteProcessConnectionInfo defaultDatabaseName (createNodeId "127.0.0.1" defaultServerPort) emptyNotificationCallback ---- | The 'Connection' represents either local or remote access to a database. All operations flow through the connection.-type ClientNodes = StmSet.Set ProcessId+defaultRemoteConnectionInfo =+ RemoteConnectionInfo defaultDatabaseName defaultServerHostname (show defaultServerPort) emptyNotificationCallback --- internal structure specific to in-process connections-data InProcessConnectionConf = InProcessConnectionConf {- ipPersistenceStrategy :: PersistenceStrategy, - ipClientNodes :: ClientNodes, - ipSessions :: Sessions, - ipTransactionGraph :: TVar TransactionGraph,- ipScriptSession :: Maybe ScriptSession,- ipLocalNode :: LocalNode,- ipTransport :: Transport, -- we hold onto this so that we can close it gracefully- ipLocks :: Maybe (LockFile, MVar LockFileHash) -- nothing when NoPersistence- }+defaultServerHostname :: Hostname+defaultServerHostname = "localhost" -data RemoteProcessConnectionConf = RemoteProcessConnectionConf {- rLocalNode :: LocalNode, - rProcessId :: ProcessId, --remote processId- rTransport :: Transport --the TCP socket transport- }+newtype RemoteConnectionConf = RemoteConnectionConf RPC.Connection data Connection = InProcessConnection InProcessConnectionConf |- RemoteProcessConnection RemoteProcessConnectionConf+ RemoteConnection RemoteConnectionConf -- | There are several reasons why a connection can fail. data ConnectionError = SetupDatabaseDirectoryError PersistenceError |@@ -273,39 +244,6 @@ remoteDBLookupName :: DatabaseName -> String remoteDBLookupName = (++) "db-" -createLocalNode :: IO (LocalNode, Transport)-createLocalNode = do-#if MIN_VERSION_network_transport_tcp(0,7,0)- eLocalTransport <- createTransport (defaultTCPAddr "127.0.0.1" "0") defaultTCPParameters-#elif MIN_VERSION_network_transport_tcp(0,6,0) - eLocalTransport <- createTransport "127.0.0.1" "0" (\sn -> ("127.0.0.1", sn)) defaultTCPParameters-#else- eLocalTransport <- createTransport "127.0.0.1" "0" defaultTCPParameters-#endif- case eLocalTransport of- Left err -> error ("failed to create transport: " ++ show err)- Right localTransport -> do- localNode <- newLocalNode localTransport initRemoteTable - pure (localNode, localTransport)- -notificationListener :: NotificationCallback -> Process () -notificationListener callback = do- --pid <- getSelfPid- --liftIO $ putStrLn $ "LISTENER THREAD START " ++ show pid- _ <- forever $- receiveWait [- match (\(NotificationMessage eNots) ->- --say $ "NOTIFICATION: " ++ show eNots- -- when notifications are thrown, they are not adjusted for the current schema which could be problematic, but we don't have access to the current session here- liftIO $ mapM_ (uncurry callback) (M.toList eNots)- )- ]- --say "LISTENER THREAD EXIT"- pure ()- -startNotificationListener :: LocalNode -> NotificationCallback -> IO ProcessId-startNotificationListener localNode callback = forkProcess localNode (notificationListener callback)- createScriptSession :: [String] -> IO (Maybe ScriptSession) createScriptSession ghcPkgPaths = do eScriptSession <- initScriptSession ghcPkgPaths@@ -313,6 +251,7 @@ Left err -> hPutStrLn stderr ("Failed to load scripting engine- scripting disabled: " ++ show err) >> pure Nothing --not a fatal error, but the scripting feature must be disabled Right s -> pure (Just s) + -- | To create a 'Connection' to a remote or local database, create a 'ConnectionInfo' and call 'connectProjectM36'. connectProjectM36 :: ConnectionInfo -> IO (Either ConnectionError Connection) --create a new in-memory database/transaction graph@@ -327,43 +266,62 @@ graphTvar <- newTVarIO freshGraph clientNodes <- StmSet.newIO sessions <- StmMap.newIO- (localNode, transport) <- createLocalNode- notificationPid <- startNotificationListener localNode notificationCallback mScriptSession <- createScriptSession ghcPkgPaths- + notifAsync <- startNotificationListener clientNodes notificationCallback let conn = InProcessConnection InProcessConnectionConf { ipPersistenceStrategy = strat, ipClientNodes = clientNodes, ipSessions = sessions, ipTransactionGraph = graphTvar, ipScriptSession = mScriptSession,- ipLocalNode = localNode,- ipTransport = transport, - ipLocks = Nothing}- addClientNode conn notificationPid+ ipLocks = Nothing,+ ipCallbackAsync = notifAsync+ } pure (Right conn) MinimalPersistence dbdir -> connectPersistentProjectM36 strat NoDiskSync dbdir freshGraph notificationCallback ghcPkgPaths CrashSafePersistence dbdir -> connectPersistentProjectM36 strat FsyncDiskSync dbdir freshGraph notificationCallback ghcPkgPaths -connectProjectM36 (RemoteProcessConnectionInfo databaseName serverNodeId notificationCallback) = do- connStatus <- newEmptyMVar- (localNode, transport) <- createLocalNode- let dbName = remoteDBLookupName databaseName- --putStrLn $ "Connecting to " ++ show serverNodeId ++ " " ++ dbName- notificationListenerPid <- startNotificationListener localNode notificationCallback- runProcess localNode $ do- --even a failed connection retains an open socket!- mServerProcessId <- whereisRemote serverNodeId dbName- case mServerProcessId of- Nothing -> liftIO $ putMVar connStatus $ Left (NoSuchDatabaseByNameError databaseName)- Just serverProcessId -> do- loginConfirmation <- safeLogin (Login notificationListenerPid) serverProcessId- if not loginConfirmation then- liftIO $ putMVar connStatus (Left LoginError)- else- liftIO $ putMVar connStatus (Right $ RemoteProcessConnection RemoteProcessConnectionConf {rLocalNode = localNode, rProcessId = serverProcessId, rTransport = transport})- takeMVar connStatus+connectProjectM36 (RemoteConnectionInfo dbName hostName servicePort notificationCallback) = do+ --TODO- add notification callback thread+ let resolutionHints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV],+ addrSocketType = Stream+ }+ resolved <- getAddrInfo (Just resolutionHints) (Just hostName) (Just servicePort)+ case resolved of+ [] -> error ("DNS resolution failed for" <> hostName <> ":" <> servicePort)+ addrInfo:_ -> do+ --supports IPv4 only for now+ let (SockAddrInet port addr) = addrAddress addrInfo+ notificationHandlers =+ [RPC.ClientAsyncRequestHandler $+ \(NotificationMessage notifications') ->+ forM_ (M.toList notifications') (uncurry notificationCallback)+ ]+-- TODO missing async callback+ conn <- RPC.connect notificationHandlers (hostAddressToTuple addr) port+ eRet <- RPC.call conn (Login dbName)+-- TODO handle connection errors + case eRet of+ Left err -> error (show err)+ Right False -> error "wtf"+ Right True ->+ --TODO handle connection errors!+ pure (Right (RemoteConnection (RemoteConnectionConf conn))) +--convert RPC errors into exceptions+convertRPCErrors :: RPC.ConnectionError -> IO a+convertRPCErrors err =+ case err of+ RPC.TimeoutError -> throw RequestTimeoutException+ RPC.CodecError msg -> error $ "decoding message failed on server: " <> msg+ RPC.ExceptionError msg -> error $ "server threw exception: " <> msg++addClientNode :: Connection -> RPC.Locking Socket -> IO ()+addClientNode (RemoteConnection _) _ = error "addClientNode called on remote connection"+addClientNode (InProcessConnection conf) lockSock = atomically (StmSet.insert clientInfo (ipClientNodes conf))+ where+ clientInfo = RemoteClientInfo lockSock+ connectPersistentProjectM36 :: PersistenceStrategy -> DiskSync -> FilePath -> @@ -387,29 +345,34 @@ tvarGraph <- newTVarIO graph' sessions <- StmMap.newIO clientNodes <- StmSet.newIO- (localNode, transport) <- createLocalNode lockMVar <- newMVar digest+ notifAsync <- startNotificationListener clientNodes notificationCallback let conn = InProcessConnection InProcessConnectionConf { ipPersistenceStrategy = strat, ipClientNodes = clientNodes, ipSessions = sessions, ipTransactionGraph = tvarGraph, ipScriptSession = mScriptSession,- ipLocalNode = localNode,- ipTransport = transport,- ipLocks = Just (lockFileH, lockMVar)+ ipLocks = Just (lockFileH, lockMVar),+ ipCallbackAsync = notifAsync }-- notificationPid <- startNotificationListener localNode notificationCallback- addClientNode conn notificationPid pure (Right conn)- ++--startup local async process to handle notification callbacks+startNotificationListener :: ClientNodes -> NotificationCallback -> IO (Async ())+startNotificationListener cNodes notificationCallback = do+ inProcessClientInfo@(InProcessClientInfo notifMVar) <- InProcessClientInfo <$> newEmptyMVar + atomically $ StmSet.insert inProcessClientInfo cNodes + async $ forever $ do+ notifs <- takeMVar notifMVar+ forM_ (M.toList notifs) $ uncurry notificationCallback+ -- | Create a new session at the transaction id and return the session's Id. createSessionAtCommit :: Connection -> TransactionId -> IO (Either RelationalError SessionId) createSessionAtCommit conn@(InProcessConnection _) commitId = do newSessionId <- nextRandom atomically $ createSessionAtCommit_ commitId newSessionId conn-createSessionAtCommit conn@(RemoteProcessConnection _) uuid = remoteCall conn (CreateSessionAtCommit uuid)+createSessionAtCommit conn@(RemoteConnection _) uuid = remoteCall conn (CreateSessionAtCommit uuid) createSessionAtCommit_ :: TransactionId -> SessionId -> Connection -> STM (Either RelationalError SessionId) createSessionAtCommit_ commitId newSessionId (InProcessConnection conf) = do@@ -426,7 +389,7 @@ Nothing -> do StmMap.insert (Session freshDiscon defaultSchemaName) newSessionId sessions pure $ Right newSessionId-createSessionAtCommit_ _ _ (RemoteProcessConnection _) = error "createSessionAtCommit_ called on remote connection"+createSessionAtCommit_ _ _ (RemoteConnection _) = error "createSessionAtCommit_ called on remote connection" -- | Call 'createSessionAtHead' with a transaction graph's head's name to create a new session pinned to that head. This function returns a 'SessionId' which can be used in other function calls to reference the point in the transaction graph. createSessionAtHead :: Connection -> HeadName -> IO (Either RelationalError SessionId)@@ -438,22 +401,18 @@ case transactionForHead headn graph of Nothing -> pure $ Left (NoSuchHeadNameError headn) Just trans -> createSessionAtCommit_ (transactionId trans) newSessionId conn-createSessionAtHead conn@(RemoteProcessConnection _) headn = remoteCall conn (CreateSessionAtHead headn)---- | Used internally for server connections to keep track of remote nodes for the purpose of sending notifications later.-addClientNode :: Connection -> ProcessId -> IO ()-addClientNode (RemoteProcessConnection _) _ = error "addClientNode called on remote connection"-addClientNode (InProcessConnection conf) newProcessId = atomically (StmSet.insert newProcessId (ipClientNodes conf))+createSessionAtHead conn@(RemoteConnection _) headn = remoteCall conn (CreateSessionAtHead headn) -- | Discards a session, eliminating any uncommitted changes present in the session. closeSession :: SessionId -> Connection -> IO () closeSession sessionId (InProcessConnection conf) = atomically $ StmMap.delete sessionId (ipSessions conf)-closeSession sessionId conn@(RemoteProcessConnection _) = remoteCall conn (CloseSession sessionId) +closeSession sessionId conn@(RemoteConnection _) = remoteCall conn (CloseSession sessionId) -- | 'close' cleans up the database access connection and closes any relevant sockets. close :: Connection -> IO () close (InProcessConnection conf) = do+ cancel (ipCallbackAsync conf) atomically $ do let sessions = ipSessions conf #if MIN_VERSION_stm_containers(1,0,0) @@ -462,22 +421,18 @@ StmMap.deleteAll sessions #endif pure ()- closeLocalNode (ipLocalNode conf)- closeTransport (ipTransport conf) let mLocks = ipLocks conf case mLocks of Nothing -> pure () Just (lockFileH, _) -> closeLockFile lockFileH -close conn@(RemoteProcessConnection conf) = do- _ <- remoteCall conn Logout :: IO Bool- closeLocalNode (rLocalNode conf)- closeTransport (rTransport conf)+close (RemoteConnection (RemoteConnectionConf conn)) =+ RPC.close conn --used only by the server EntryPoints closeRemote_ :: Connection -> IO () closeRemote_ (InProcessConnection _) = error "invalid call of closeRemote_ on InProcessConnection"-closeRemote_ (RemoteProcessConnection conf) = runProcess (rLocalNode conf) (reconnect (rProcessId conf))+closeRemote_ (RemoteConnection (RemoteConnectionConf conn)) = RPC.close conn --we need to actually close the localNode's connection to the remote --within the database server, we must catch and handle all exception lest they take down the database process- this handling might be different for other use-cases@@ -488,35 +443,15 @@ where handler exc | Just (_ :: AsyncException) <- fromException exc = throwIO exc | otherwise = pure (Left (UnhandledExceptionError (show exc)))- -runProcessResult :: LocalNode -> Process a -> IO a -runProcessResult localNode proc = do- ret <- newEmptyMVar- runProcess localNode $ do- val <- proc- liftIO $ putMVar ret val- takeMVar ret -safeLogin :: Login -> ProcessId -> Process Bool-safeLogin login procId = do - ret <- call procId login- case ret of- Left (_ :: ServerError) -> pure False- Right val -> pure val -remoteCall :: (Binary a, Binary b, Typeable a, Typeable b) => Connection -> a -> IO b+remoteCall :: (Serialise a, Serialise b) => Connection -> a -> IO b remoteCall (InProcessConnection _ ) _ = error "remoteCall called on local connection"-remoteCall (RemoteProcessConnection conf) arg = runProcessResult localNode $ do- ret <- safeCall serverProcessId arg- case ret of- Left err -> error ("server died: " ++ show err)- Right ret' -> case ret' of- Left RequestTimeoutError -> liftIO (throwIO RequestTimeoutException)- Left (ProcessDiedError _) -> liftIO (throwIO RemoteProcessDiedException)- Right val -> pure val- where- localNode = rLocalNode conf- serverProcessId = rProcessId conf+remoteCall (RemoteConnection (RemoteConnectionConf rpcConn)) arg = do+ eRet <- RPC.call rpcConn arg+ case eRet of+ Left err -> convertRPCErrors err+ Right val -> pure val sessionForSessionId :: SessionId -> Sessions -> STM (Either RelationalError Session) sessionForSessionId sessionId sessions = @@ -551,7 +486,7 @@ case eSession of Left err -> pure (Left err) Right session -> pure (Right (Sess.schemaName session))-currentSchemaName sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveCurrentSchemaName sessionId)+currentSchemaName sessionId conn@(RemoteConnection _) = remoteCall conn (RetrieveCurrentSchemaName sessionId) -- | Switch to the named isomorphic schema. setCurrentSchemaName :: SessionId -> Connection -> SchemaName -> IO (Either RelationalError ())@@ -563,7 +498,7 @@ Right session -> case Sess.setSchemaName sname session of Left err -> pure (Left err) Right newSession -> StmMap.insert newSession sessionId sessions >> pure (Right ())-setCurrentSchemaName sessionId conn@(RemoteProcessConnection _) sname = remoteCall conn (ExecuteSetCurrentSchema sessionId sname)+setCurrentSchemaName sessionId conn@(RemoteConnection _) sname = remoteCall conn (ExecuteSetCurrentSchema sessionId sname) -- | Execute a relational expression in the context of the session and connection. Relational expressions are queries and therefore cannot alter the database. executeRelationalExpr :: SessionId -> Connection -> RelationalExpr -> IO (Either RelationalError Relation)@@ -587,7 +522,7 @@ Right rel -> pure (force (Right rel)) -- this is necessary so that any undefined/error exceptions are spit out here Left err -> pure (Left err) -executeRelationalExpr sessionId conn@(RemoteProcessConnection _) relExpr = remoteCall conn (ExecuteRelationalExpr sessionId relExpr)+executeRelationalExpr sessionId conn@(RemoteConnection _) relExpr = remoteCall conn (ExecuteRelationalExpr sessionId relExpr) -- | Execute a database context expression in the context of the session and connection. Database expressions modify the current session's disconnected transaction but cannot modify the transaction graph. executeDatabaseContextExpr :: SessionId -> Connection -> DatabaseContextExpr -> IO (Either RelationalError ())@@ -621,7 +556,7 @@ newSession = Session newDiscon (Sess.schemaName session) StmMap.insert newSession sessionId sessions pure (Right ())-executeDatabaseContextExpr sessionId conn@(RemoteProcessConnection _) dbExpr = remoteCall conn (ExecuteDatabaseContextExpr sessionId dbExpr)+executeDatabaseContextExpr sessionId conn@(RemoteConnection _) dbExpr = remoteCall conn (ExecuteDatabaseContextExpr sessionId dbExpr) -- | Similar to a git rebase, 'autoMergeToHead' atomically creates a temporary branch and merges it to the latest commit of the branch referred to by the 'HeadName' and commits the merge. This is useful to reduce incidents of 'TransactionIsNotAHeadError's but at the risk of merge errors (thus making it similar to rebasing). Alternatively, as an optimization, if a simple commit is possible (meaning that the head has not changed), then a fast-forward commit takes place instead. autoMergeToHead :: SessionId -> Connection -> MergeStrategy -> HeadName -> IO (Either RelationalError ())@@ -650,7 +585,7 @@ Left err -> pure (Left err) Right ((discon', graph'), transactionIdsAdded) -> pure (Right (discon', graph', transactionIdsAdded))-autoMergeToHead sessionId conn@(RemoteProcessConnection _) strat headName' = remoteCall conn (ExecuteAutoMergeToHead sessionId strat headName')+autoMergeToHead sessionId conn@(RemoteConnection _) strat headName' = remoteCall conn (ExecuteAutoMergeToHead sessionId strat headName') -- | Execute a database context IO-monad-based expression for the given session and connection. `DatabaseContextIOExpr`s modify the DatabaseContext but cannot be purely implemented. --this is almost completely identical to executeDatabaseContextExpr above@@ -676,22 +611,8 @@ context' = RE.dbc_context newState atomically $ StmMap.insert newSession sessionId sessions pure (Right ())-executeDatabaseContextIOExpr sessionId conn@(RemoteProcessConnection _) dbExpr = remoteCall conn (ExecuteDatabaseContextIOExpr sessionId dbExpr)+executeDatabaseContextIOExpr sessionId conn@(RemoteConnection _) dbExpr = remoteCall conn (ExecuteDatabaseContextIOExpr sessionId dbExpr) -{--executeGraphExprSTM_ :: TransactionId -> SessionId -> Session -> Sessions -> TransactionGraphOperator -> TransactionGraph -> TVar TransactionGraph -> STM (Either RelationalError (TransactionGraph, DisconnectedTransaction)-executeGraphExprSTM_ freshId sessionId session sessions graphExpr graph graphTVar= do- case evalGraphOp freshId (Sess.disconnectedTransaction session) graph graphExpr of- Left err -> do- when updateGraphOnError (writeTVar graphTVar graph)- pure $ Left err- Right (discon', graph') -> do- writeTVar graphTVar graph'- let newSession = Session discon' (Sess.schemaName session)- STMMap.insert newSession sessionId sessions- pure $ Right graph'--}- -- process notifications for commits executeCommitExprSTM_ :: TransactionGraph@@ -732,89 +653,16 @@ --if freshId appears in the graph, then we need to pass it on let transIds = [freshId | isRight (RE.transactionForId freshId graph')] pure (Right (discon', graph', transIds))-{--executeGraphExpr sessionId (InProcessConnection conf) graphExpr = excEither $ do- let strat = ipPersistenceStrategy conf- clientNodes = ipClientNodes conf- sessions = ipSessions conf- graphTvar = ipTransactionGraph conf- mLockFileH = ipLocks conf- lockHandler body = case graphExpr of- Commit -> case mLockFileH of- Nothing -> body False- Just (lockFileH, lockMVar) -> let acquireLocks = do- lastWrittenDigest <- takeMVar lockMVar - lockFile lockFileH WriteLock- latestDigest <- readGraphTransactionIdDigest strat- pure (latestDigest /= lastWrittenDigest)- - releaseLocks _ = do- --still holding the lock- get the latest digest- gDigest <- readGraphTransactionIdDigest strat- unlockFile lockFileH - putMVar lockMVar gDigest- in bracket acquireLocks releaseLocks body- _ -> body False- freshId <- nextRandom- lockHandler $ \dbWrittenByOtherProcess -> do- --if the database file has been updated since we wrote it last, load it before trying to sync our version done- this can result in TransactionNotAHeadErrors- --read transaction data and compare to existing graph- --in the future, we can detect if updated transaction graph can be safely merged (such as with a transaction on a separate head) (rebase-able commits should force the user to rebase from the client to confirm that the action makes sense)- manip <- atomically $ do- eSession <- sessionForSessionId sessionId sessions- --handle graph update by other process- oldGraph <- readTVar graphTvar- case eSession of- Left err -> pure (Left err)- Right session -> do- let mScriptSession = ipScriptSession conf - dbdir = case strat of- MinimalPersistence x -> x- CrashSafePersistence x -> x- _ -> error "accessing dbdir on non-persisted connection"- eRefreshedGraph <- if dbWrittenByOtherProcess then- unsafeIOToSTM (transactionGraphLoad dbdir oldGraph mScriptSession)- else- pure (Right oldGraph)- case eRefreshedGraph of- Left err -> pure (Left (DatabaseLoadError err))- Right refreshedGraph -> do- --snip it- eGraph <- executeGraphExprSTM_ dbWrittenByOtherProcess freshId sessionId session sessions graphExpr refreshedGraph graphTvar- --snip it- case eGraph of- Left err -> pure (Left err)- Right newGraph -> do- --handle commit- if isCommit graphExpr then do- case transactionForId (Sess.parentId session) oldGraph of- Left err -> pure $ Left err- Right previousTrans -> do- (evaldNots, nodes) <- executeCommitExprSTM_ (Trans.concreteDatabaseContext previousTrans) (Sess.concreteDatabaseContext session) clientNodes- nodesToNotify <- toList (StmSet.stream nodes)- pure $ Right (evaldNots, nodesToNotify, newGraph)- else- pure $ Right (M.empty, [], newGraph)- case manip of - Left err -> return $ Just err- Right (notsToFire, nodesToNotify, newGraph) -> do- --update filesystem database, if necessary- processTransactionGraphPersistence strat newGraph- sendNotifications nodesToNotify (ipLocalNode conf) notsToFire- pure Nothing--}-executeGraphExpr sessionId conn@(RemoteProcessConnection _) graphExpr = remoteCall conn (ExecuteGraphExpr sessionId graphExpr) +executeGraphExpr sessionId conn@(RemoteConnection _) graphExpr = remoteCall conn (ExecuteGraphExpr sessionId graphExpr)+ -- | A trans-graph expression is a relational query executed against the entirety of a transaction graph. executeTransGraphRelationalExpr :: SessionId -> Connection -> TransGraphRelationalExpr -> IO (Either RelationalError Relation) executeTransGraphRelationalExpr _ (InProcessConnection conf) tgraphExpr = excEither . atomically $ do let graphTvar = ipTransactionGraph conf graph <- readTVar graphTvar pure $ force $ optimizeAndEvalTransGraphRelationalExpr graph tgraphExpr-{- case runReader (RE.evalRelationalExpr relExpr) (RE.mkRelationalExprState DBC.empty) of- Left err -> pure (Left err)- Right rel -> pure (force (Right rel))-}-executeTransGraphRelationalExpr sessionId conn@(RemoteProcessConnection _) tgraphExpr = remoteCall conn (ExecuteTransGraphRelationalExpr sessionId tgraphExpr) +executeTransGraphRelationalExpr sessionId conn@(RemoteConnection _) tgraphExpr = remoteCall conn (ExecuteTransGraphRelationalExpr sessionId tgraphExpr) -- | Schema expressions manipulate the isomorphic schemas for the current 'DatabaseContext'. executeSchemaExpr :: SessionId -> Connection -> Schema.SchemaExpr -> IO (Either RelationalError ())@@ -837,23 +685,24 @@ newSession = Session (DisconnectedTransaction (Discon.parentId discon) newSchemas False) (Sess.schemaName session) StmMap.insert newSession sessionId sessions pure (Right ())-executeSchemaExpr sessionId conn@(RemoteProcessConnection _) schemaExpr = remoteCall conn (ExecuteSchemaExpr sessionId schemaExpr) +executeSchemaExpr sessionId conn@(RemoteConnection _) schemaExpr = remoteCall conn (ExecuteSchemaExpr sessionId schemaExpr) -- | After modifying a 'DatabaseContext', 'commit' the transaction to the transaction graph at the head which the session is referencing. This will also trigger checks for any notifications which need to be propagated. commit :: SessionId -> Connection -> IO (Either RelationalError ()) commit sessionId conn@(InProcessConnection _) = executeGraphExpr sessionId conn Commit -commit sessionId conn@(RemoteProcessConnection _) = remoteCall conn (ExecuteGraphExpr sessionId Commit)- -sendNotifications :: [ProcessId] -> LocalNode -> EvaluatedNotifications -> IO ()-sendNotifications pids localNode nots = mapM_ sendNots pids- where- sendNots remoteClientPid =- unless (M.null nots) $ runProcess localNode $ send remoteClientPid (NotificationMessage nots)- +commit sessionId conn@(RemoteConnection _) = remoteCall conn (ExecuteGraphExpr sessionId Commit)++sendNotifications :: [ClientInfo] -> EvaluatedNotifications -> IO ()+sendNotifications clients notifs =+ unless (M.null notifs) $ forM_ clients sender+ where+ sender (RemoteClientInfo sock) = RPC.sendMessage sock (NotificationMessage notifs)+ sender (InProcessClientInfo tvar) = putMVar tvar notifs+ -- | Discard any changes made in the current 'Session' and 'DatabaseContext'. This resets the disconnected transaction to reference the original database context of the parent transaction and is a very cheap operation. rollback :: SessionId -> Connection -> IO (Either RelationalError ()) rollback sessionId conn@(InProcessConnection _) = executeGraphExpr sessionId conn Rollback -rollback sessionId conn@(RemoteProcessConnection _) = remoteCall conn (ExecuteGraphExpr sessionId Rollback)+rollback sessionId conn@(RemoteConnection _) = remoteCall conn (ExecuteGraphExpr sessionId Rollback) -- | Write the transaction graph to disk. This function can be used to incrementally write new transactions to disk. processTransactionGraphPersistence :: PersistenceStrategy -> [TransactionId] -> TransactionGraph -> IO ()@@ -869,7 +718,7 @@ -- | Return a relation whose type would match that of the relational expression if it were executed. This is useful for checking types and validating a relational expression's types. typeForRelationalExpr :: SessionId -> Connection -> RelationalExpr -> IO (Either RelationalError Relation) typeForRelationalExpr sessionId conn@(InProcessConnection _) relExpr = atomically $ typeForRelationalExprSTM sessionId conn relExpr-typeForRelationalExpr sessionId conn@(RemoteProcessConnection _) relExpr = remoteCall conn (ExecuteTypeForRelationalExpr sessionId relExpr)+typeForRelationalExpr sessionId conn@(RemoteConnection _) relExpr = remoteCall conn (ExecuteTypeForRelationalExpr sessionId relExpr) typeForRelationalExprSTM :: SessionId -> Connection -> RelationalExpr -> STM (Either RelationalError Relation) typeForRelationalExprSTM sessionId (InProcessConnection conf) relExpr = do@@ -906,7 +755,7 @@ else pure (Schema.inclusionDependenciesInSchema schema (B.inclusionDependencies context)) -inclusionDependencies sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveInclusionDependencies sessionId)+inclusionDependencies sessionId conn@(RemoteConnection _) = remoteCall conn (RetrieveInclusionDependencies sessionId) typeConstructorMapping :: SessionId -> Connection -> IO (Either RelationalError TypeConstructorMapping) typeConstructorMapping sessionId (InProcessConnection conf) = do@@ -917,7 +766,7 @@ Left err -> pure $ Left err Right (session, _) -> --warning, no schema support for typeconstructors pure (Right (B.typeConstructorMapping (Sess.concreteDatabaseContext session)))-typeConstructorMapping sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveTypeConstructorMapping sessionId)+typeConstructorMapping sessionId conn@(RemoteConnection _) = remoteCall conn (RetrieveTypeConstructorMapping sessionId) -- | Return an optimized database expression which is logically equivalent to the input database expression. This function can be used to determine which expression will actually be evaluated. planForDatabaseContextExpr :: SessionId -> Connection -> DatabaseContextExpr -> IO (Either RelationalError GraphRefDatabaseContextExpr) @@ -937,7 +786,7 @@ else -- don't show any optimization because the current optimization infrastructure relies on access to the base context- this probably underscores the need for each schema to have its own DatabaseContext, even if it is generated on-the-fly-} pure (Left NonConcreteSchemaPlanError) -planForDatabaseContextExpr sessionId conn@(RemoteProcessConnection _) dbExpr = remoteCall conn (RetrievePlanForDatabaseContextExpr sessionId dbExpr)+planForDatabaseContextExpr sessionId conn@(RemoteConnection _) dbExpr = remoteCall conn (RetrievePlanForDatabaseContextExpr sessionId dbExpr) -- | Return a relation which represents the current state of the global transaction graph. The attributes are -- * current- boolean attribute representing whether or not the current session references this transaction@@ -955,7 +804,7 @@ Right session -> graphAsRelation (Sess.disconnectedTransaction session) <$> readTVar tvar -transactionGraphAsRelation sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveTransactionGraph sessionId) +transactionGraphAsRelation sessionId conn@(RemoteConnection _) = remoteCall conn (RetrieveTransactionGraph sessionId) -- | Returns the names and types of the relation variables in the current 'Session'. relationVariablesAsRelation :: SessionId -> Connection -> IO (Either RelationalError Relation)@@ -977,7 +826,7 @@ let schemaContext = context {relationVariables = relvars } pure $ RE.relationVariablesAsRelation schemaContext graph -relationVariablesAsRelation sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveRelationVariableSummary sessionId)+relationVariablesAsRelation sessionId conn@(RemoteConnection _) = remoteCall conn (RetrieveRelationVariableSummary sessionId) -- | Returns the names and types of the atom functions in the current 'Session'. atomFunctionsAsRelation :: SessionId -> Connection -> IO (Either RelationalError Relation)@@ -990,7 +839,7 @@ Right (session, _) -> pure (AF.atomFunctionsAsRelation (atomFunctions (concreteDatabaseContext session))) -atomFunctionsAsRelation sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveAtomFunctionSummary sessionId) +atomFunctionsAsRelation sessionId conn@(RemoteConnection _) = remoteCall conn (RetrieveAtomFunctionSummary sessionId) databaseContextFunctionsAsRelation :: SessionId -> Connection -> IO (Either RelationalError Relation) databaseContextFunctionsAsRelation sessionId (InProcessConnection conf) = do@@ -1002,7 +851,7 @@ Right (session, _) -> pure (DCF.databaseContextFunctionsAsRelation (dbcFunctions (concreteDatabaseContext session))) -databaseContextFunctionsAsRelation sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveDatabaseContextFunctionSummary sessionId) +databaseContextFunctionsAsRelation sessionId conn@(RemoteConnection _) = remoteCall conn (RetrieveDatabaseContextFunctionSummary sessionId) -- | Returns the transaction id for the connection's disconnected transaction committed parent transaction. headTransactionId :: SessionId -> Connection -> IO (Either RelationalError TransactionId)@@ -1013,7 +862,7 @@ case eSession of Left err -> pure (Left err) Right session -> pure $ Right (Sess.parentId session)-headTransactionId sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveHeadTransactionId sessionId)+headTransactionId sessionId conn@(RemoteConnection _) = remoteCall conn (RetrieveHeadTransactionId sessionId) headNameSTM_ :: SessionId -> Sessions -> TVar TransactionGraph -> STM (Either RelationalError HeadName) headNameSTM_ sessionId sessions graphTvar = do@@ -1033,7 +882,7 @@ let sessions = ipSessions conf graphTvar = ipTransactionGraph conf atomically (headNameSTM_ sessionId sessions graphTvar)-headName sessionId conn@(RemoteProcessConnection _) = remoteCall conn (ExecuteHeadName sessionId)+headName sessionId conn@(RemoteConnection _) = remoteCall conn (ExecuteHeadName sessionId) -- | Returns a listing of all available atom types. atomTypesAsRelation :: SessionId -> Connection -> IO (Either RelationalError Relation)@@ -1047,7 +896,7 @@ case typesAsRelation (B.typeConstructorMapping (Sess.concreteDatabaseContext session)) of Left err -> pure (Left err) Right rel -> pure (Right rel)-atomTypesAsRelation sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveAtomTypesAsRelation sessionId)+atomTypesAsRelation sessionId conn@(RemoteConnection _) = remoteCall conn (RetrieveAtomTypesAsRelation sessionId) disconnectedTransactionIsDirty :: SessionId -> Connection -> IO (Either RelationalError Bool) disconnectedTransactionIsDirty sessionId (InProcessConnection conf) = do@@ -1058,12 +907,12 @@ Left err -> pure (Left err) Right session -> pure (Right (isDirty session))-disconnectedTransactionIsDirty sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveSessionIsDirty sessionId)+disconnectedTransactionIsDirty sessionId conn@(RemoteConnection _) = remoteCall conn (RetrieveSessionIsDirty sessionId) --used only for testing- we expect this to throw an exception callTestTimeout_ :: SessionId -> Connection -> IO Bool callTestTimeout_ _ (InProcessConnection _) = error "bad testing call"-callTestTimeout_ sessionId conn@(RemoteProcessConnection _) = remoteCall conn (TestTimeout sessionId)+callTestTimeout_ sessionId conn@(RemoteConnection _) = remoteCall conn (TestTimeout sessionId) --used in tests only transactionGraph_ :: Connection -> IO TransactionGraph@@ -1148,15 +997,8 @@ Right (notsToFire, nodesToNotify, newGraph, transactionIdsToPersist) -> do --update filesystem database, if necessary processTransactionGraphPersistence strat transactionIdsToPersist newGraph- sendNotifications nodesToNotify (ipLocalNode conf) notsToFire+ sendNotifications nodesToNotify notsToFire pure (Right ())-{--writeDisconAndGraph_ :: TVar TransactionGraph -> SessionId -> Session -> Sessions -> DisconnectedTransaction -> TransactionGraph -> STM ()-writeDisconAndGraph_ graphTvar sessionId session sessions discon graph = do- writeTVar graphTvar graph- let newSession = Session discon (Sess.schemaName session)- StmMap.insert newSession sessionId sessions--} -- | Runs an IO monad, commits the result when the monad returns no errors, otherwise, rolls back the changes and the error. withTransaction :: SessionId -> Connection -> IO (Either RelationalError a) -> IO (Either RelationalError ()) -> IO (Either RelationalError a)@@ -1208,7 +1050,7 @@ let dFrame' = maybe dFrame (`DF.drop'` dFrame) (DF.offset dfExpr) dFrame'' = maybe dFrame' (`DF.take'` dFrame') (DF.limit dfExpr) pure (Right dFrame'')-executeDataFrameExpr sessionId conn@(RemoteProcessConnection _) dfExpr = remoteCall conn (ExecuteDataFrameExpr sessionId dfExpr)+executeDataFrameExpr sessionId conn@(RemoteConnection _) dfExpr = remoteCall conn (ExecuteDataFrameExpr sessionId dfExpr) validateMerkleHashes :: SessionId -> Connection -> IO (Either RelationalError ()) validateMerkleHashes sessionId (InProcessConnection conf) = do@@ -1222,4 +1064,30 @@ case Graph.validateMerkleHashes graph of Left merkleErrs -> pure $ Left $ someErrors (map (\(MerkleValidationError tid expected actual) -> MerkleHashValidationError tid expected actual) merkleErrs) Right () -> pure (Right ())-validateMerkleHashes sessionId conn@RemoteProcessConnection{} = remoteCall conn (ExecuteValidateMerkleHashes sessionId)+validateMerkleHashes sessionId conn@RemoteConnection{} = remoteCall conn (ExecuteValidateMerkleHashes sessionId)++type ClientNodes = StmSet.Set ClientInfo++-- internal structure specific to in-process connections+data InProcessConnectionConf = InProcessConnectionConf {+ ipPersistenceStrategy :: PersistenceStrategy, + ipClientNodes :: ClientNodes, + ipSessions :: Sessions, + ipTransactionGraph :: TVar TransactionGraph,+ ipScriptSession :: Maybe ScriptSession,+ ipLocks :: Maybe (LockFile, MVar LockFileHash), -- nothing when NoPersistence+ ipCallbackAsync :: Async ()+ }++-- clients may connect associate one socket/mvar with the server to register for change callbacks+data ClientInfo = RemoteClientInfo (RPC.Locking Socket) |+ InProcessClientInfo (MVar EvaluatedNotifications)++instance Eq ClientInfo where+ (RemoteClientInfo a) == (RemoteClientInfo b) = RPC.lockless a == RPC.lockless b+ (InProcessClientInfo a) == (InProcessClientInfo b) = a == b+ _ == _ = False++instance Hashable ClientInfo where+ hashWithSalt salt (RemoteClientInfo sock) = hashWithSalt salt (show (RPC.lockless sock))+ hashWithSalt salt (InProcessClientInfo _) = hashWithSalt salt (1::Int)
src/lib/ProjectM36/DataFrame.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric, DerivingVia #-} {- A dataframe is a strongly-typed, ordered list of named tuples. A dataframe differs from a relation in that its tuples are ordered.-} module ProjectM36.DataFrame where import ProjectM36.Base@@ -16,16 +16,20 @@ import qualified Data.Set as S import Data.Maybe import qualified Data.Text as T-import Data.Binary import Control.Arrow #if __GLASGOW_HASKELL__ < 804 import Data.Monoid #endif -data AttributeOrderExpr = AttributeOrderExpr AttributeName Order deriving (Show, Generic, Binary)-data AttributeOrder = AttributeOrder AttributeName Order deriving (Show, Generic, Binary)-data Order = AscendingOrder | DescendingOrder deriving (Eq, Show, Generic, Binary)+data AttributeOrderExpr = AttributeOrderExpr AttributeName Order+ deriving (Show, Generic) +data AttributeOrder = AttributeOrder AttributeName Order+ deriving (Show, Generic)++data Order = AscendingOrder | DescendingOrder+ deriving (Eq, Show, Generic)+ ascending :: T.Text ascending = "⬆" @@ -39,9 +43,11 @@ orders :: [AttributeOrder], attributes :: Attributes, tuples :: [DataFrameTuple]- } deriving (Show, Generic, Binary)+ }+ deriving (Show, Generic) -data DataFrameTuple = DataFrameTuple Attributes (V.Vector Atom) deriving (Eq, Show, Generic, Binary)+data DataFrameTuple = DataFrameTuple Attributes (V.Vector Atom)+ deriving (Eq, Show, Generic) sortDataFrameBy :: [AttributeOrder] -> DataFrame -> Either RelationalError DataFrame sortDataFrameBy attrOrders frame = do@@ -122,7 +128,8 @@ orderExprs :: [AttributeOrderExpr], offset :: Maybe Integer, limit :: Maybe Integer- } deriving (Show, Binary, Generic)+ }+ deriving (Show, Generic) dataFrameAsHTML :: DataFrame -> T.Text -- 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/DataTypes/Interval.hs view
@@ -37,6 +37,7 @@ BoolAtomType -> False RelationAtomType _ -> False ConstructedAtomType _ _ -> False --once we support an interval-style typeclass, we might enable this+ RelationalExprAtomType -> False TypeVariableType _ -> False supportsOrdering :: AtomType -> Bool @@ -50,6 +51,7 @@ ByteStringAtomType -> False BoolAtomType -> False RelationAtomType _ -> False+ RelationalExprAtomType -> False ConstructedAtomType _ _ -> False --once we support an interval-style typeclass, we might enable this TypeVariableType _ -> False
src/lib/ProjectM36/DataTypes/Primitive.hs view
@@ -42,3 +42,4 @@ atomTypeForAtom (BoolAtom _) = BoolAtomType atomTypeForAtom (RelationAtom (Relation attrs _)) = RelationAtomType attrs atomTypeForAtom (ConstructedAtom _ aType _) = aType+atomTypeForAtom (RelationalExprAtom _) = RelationalExprAtomType
src/lib/ProjectM36/DataTypes/Sorting.hs view
@@ -24,6 +24,7 @@ DateTimeAtomType -> True ByteStringAtomType -> False BoolAtomType -> True+ RelationalExprAtomType -> False RelationAtomType _ -> False ConstructedAtomType _ _ -> False TypeVariableType _ -> False
src/lib/ProjectM36/DatabaseContext.hs view
@@ -7,9 +7,9 @@ import ProjectM36.AtomFunctions.Basic import ProjectM36.Relation import qualified Data.ByteString.Lazy as BL-import Data.Binary as B import ProjectM36.AtomFunction as AF import ProjectM36.DatabaseContextFunction as DBCF+import Codec.Winery empty :: DatabaseContext empty = DatabaseContext { inclusionDependencies = M.empty, @@ -44,11 +44,11 @@ --for building the Merkle hash hashBytes :: DatabaseContext -> BL.ByteString-hashBytes ctx = mconcat [incDeps, rvs, atomFs, dbcFs, nots, tConsMap]+hashBytes ctx = BL.fromChunks [incDeps, rvs, nots, tConsMap] <> atomFs <> dbcFs where- incDeps = B.encode (inclusionDependencies ctx)- rvs = B.encode (relationVariables ctx)+ incDeps = serialise (inclusionDependencies ctx)+ rvs = serialise (relationVariables ctx) atomFs = HS.foldr (mappend . AF.hashBytes) mempty (atomFunctions ctx) dbcFs = HS.foldr (mappend . DBCF.hashBytes) mempty (dbcFunctions ctx)- nots = B.encode (notifications ctx)- tConsMap = B.encode (typeConstructorMapping ctx)+ nots = serialise (notifications ctx)+ tConsMap = serialise (typeConstructorMapping ctx)
src/lib/ProjectM36/DatabaseContextFunction.hs view
@@ -3,6 +3,7 @@ --implements functions which operate as: [Atom] -> DatabaseContextExpr -> Either RelationalError DatabaseContextExpr import ProjectM36.Base import ProjectM36.Error+import ProjectM36.Serialise.Base () import ProjectM36.Attribute as A import ProjectM36.Relation import ProjectM36.AtomType@@ -11,7 +12,7 @@ import ProjectM36.ScriptSession import qualified Data.Text as T import qualified Data.ByteString.Lazy as BL-import Data.Binary as B+import Codec.Winery emptyDatabaseContextFunction :: DatabaseContextFunctionName -> DatabaseContextFunction emptyDatabaseContextFunction name = DatabaseContextFunction { @@ -82,9 +83,9 @@ -- for merkle hash hashBytes :: DatabaseContextFunction -> BL.ByteString-hashBytes func = mconcat [fname, ftype, fbody]+hashBytes func = BL.fromChunks [fname, ftype, fbody] where- fname = B.encode (dbcFuncName func)- ftype = B.encode (dbcFuncType func)+ fname = serialise (dbcFuncName func)+ ftype = serialise (dbcFuncType func) fbody = case dbcFuncBody func of- DatabaseContextFunctionBody mBody _ -> B.encode mBody+ DatabaseContextFunctionBody mBody _ -> serialise mBody
src/lib/ProjectM36/DatabaseContextFunctionError.hs view
@@ -1,9 +1,8 @@ {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} module ProjectM36.DatabaseContextFunctionError where import GHC.Generics-import Data.Binary import Control.DeepSeq {-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-} data DatabaseContextFunctionError = DatabaseContextFunctionUserError String- deriving (Generic, Eq, Show, Binary, NFData)+ deriving (Generic, Eq, Show, NFData)
src/lib/ProjectM36/Error.hs view
@@ -9,7 +9,6 @@ import Control.DeepSeq.Generics (genericRnf) import GHC.Generics (Generic) import qualified Data.Text as T-import Data.Binary import Data.Typeable import Control.Exception @@ -104,14 +103,14 @@ | TupleExprsReferenceMultipleMarkersError | MerkleHashValidationError TransactionId MerkleHash MerkleHash- + | MultipleErrors [RelationalError]- deriving (Show,Eq,Generic,Binary,Typeable, NFData) + deriving (Show,Eq,Generic,Typeable, NFData) data PersistenceError = InvalidDirectoryError FilePath | MissingTransactionError TransactionId | WrongDatabaseFormatVersionError String String- deriving (Show, Eq, Generic, Binary, NFData)+ deriving (Show, Eq, Generic, NFData) --collapse list of errors into normal error- if there is just one, just return one someErrors :: [RelationalError] -> RelationalError @@ -129,7 +128,7 @@ StrategyViolatesComponentMergeError | --failed merge in inc deps, relvars, etc. StrategyViolatesRelationVariableMergeError | StrategyViolatesTypeConstructorMergeError- deriving (Show, Eq, Generic, Binary, Typeable)+ deriving (Show, Eq, Generic, Typeable) instance NFData MergeError where rnf = genericRnf @@ -137,17 +136,12 @@ SyntaxErrorCompilationError String | ScriptCompilationDisabledError | OtherScriptCompilationError String- deriving (Show, Eq, Generic, Binary, Typeable, NFData)+ deriving (Show, Eq, Generic, Typeable, NFData) instance Exception ScriptCompilationError data SchemaError = RelVarReferencesMissing (S.Set RelVarName) | RelVarInReferencedMoreThanOnce RelVarName | RelVarOutReferencedMoreThanOnce RelVarName- deriving (Show, Eq, Generic, Binary, Typeable, NFData)+ deriving (Show, Eq, Generic, Typeable, NFData) - --- errors returned from the distributed-process call handlers-data ServerError = RequestTimeoutError |- ProcessDiedError String- deriving (Generic, Binary, Eq)
src/lib/ProjectM36/InclusionDependency.hs view
@@ -4,17 +4,16 @@ import ProjectM36.Error import ProjectM36.Relation import qualified Data.Map as M-import qualified Data.Text as T inclusionDependenciesAsRelation :: InclusionDependencies -> Either RelationalError Relation inclusionDependenciesAsRelation incDeps = mkRelationFromList attrs (map incDepAsAtoms (M.toList incDeps)) where attrs = attributesFromList [Attribute "name" TextAtomType,- Attribute "sub" TextAtomType,- Attribute "super" TextAtomType+ Attribute "sub" RelationalExprAtomType,+ Attribute "super" RelationalExprAtomType ] incDepAsAtoms (name, InclusionDependency exprA exprB) = [TextAtom name,- TextAtom (T.pack (show exprA)),- TextAtom (T.pack (show exprB))]+ RelationalExprAtom exprA,+ RelationalExprAtom exprB]
src/lib/ProjectM36/IsomorphicSchema.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveGeneric, DeriveAnyClass, LambdaCase #-}+{-# LANGUAGE DeriveGeneric, LambdaCase, DerivingVia #-} module ProjectM36.IsomorphicSchema where import ProjectM36.Base import ProjectM36.Error@@ -9,7 +9,6 @@ import qualified ProjectM36.AttributeNames as AN import Control.Monad import GHC.Generics-import Data.Binary import qualified Data.Map as M import qualified Data.Set as S import qualified Data.List as L@@ -28,8 +27,7 @@ data SchemaExpr = AddSubschema SchemaName SchemaIsomorphs | RemoveSubschema SchemaName- deriving (Generic, Binary, Show)-+ deriving (Generic, Show) isomorphs :: Schema -> SchemaIsomorphs isomorphs (Schema i) = i
src/lib/ProjectM36/MerkleHash.hs view
@@ -1,10 +1,9 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveGeneric, DerivingVia #-} module ProjectM36.MerkleHash where import Data.ByteString (ByteString) import GHC.Generics-import Data.Binary (Binary) import Control.DeepSeq (NFData) newtype MerkleHash = MerkleHash { _unMerkleHash :: ByteString }- deriving (Show, Eq, Binary, Generic, Monoid, Semigroup, NFData)+ deriving (Show, Eq, Generic, Monoid, Semigroup, NFData)
src/lib/ProjectM36/Persist.hs view
@@ -36,7 +36,6 @@ #endif import System.IO (withFile, IOMode(WriteMode), Handle)-import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString as BS' import qualified Data.Text.Encoding as TE @@ -100,10 +99,10 @@ syncDirectory FsyncDiskSync path = directoryFsync path syncDirectory NoDiskSync _ = pure () -writeBSFileSync :: DiskSync -> FilePath -> BS.ByteString -> IO ()+writeBSFileSync :: DiskSync -> FilePath -> BS'.ByteString -> IO () writeBSFileSync sync path bstring = withFile path WriteMode $ \handle -> do- BS.hPut handle bstring+ BS'.hPut handle bstring syncHandle sync handle directoryFsync :: FilePath -> IO ()
src/lib/ProjectM36/Relation/Parse/CSV.hs view
@@ -83,6 +83,11 @@ case readMaybe bString of Nothing -> fail ("invalid BoolAtom string: " ++ bString) Just b -> pure (Right (BoolAtom b))+parseCSVAtomP _ _ RelationalExprAtomType = do+ reString <- T.unpack <$> takeToEndOfData + case readMaybe reString of+ Nothing -> fail ("invalid RelationalExprAtom string: " ++ reString)+ Just b -> pure (Right (RelationalExprAtom b)) parseCSVAtomP attrName tConsMap typ@(ConstructedAtomType _ tvmap) | isIntervalAtomType typ = do begin <- (APT.char '[' >> pure False) <|> (APT.char '(' >> pure True)
src/lib/ProjectM36/RelationalExpression.hs view
@@ -367,8 +367,9 @@ setRelVar :: RelVarName -> GraphRefRelationalExpr -> DatabaseContextEvalMonad () setRelVar relVarName relExpr = do currentContext <- getStateContext- --prevent recursive relvar definition- let newRelVars = M.insert relVarName relExpr $ relationVariables currentContext+ --prevent recursive relvar definition by resolving references to relvars in previous states+ relExpr' <- resolve relExpr+ let newRelVars = M.insert relVarName relExpr' $ relationVariables currentContext potentialContext = currentContext { relationVariables = newRelVars } --optimization: if the relexpr is unchanged, skip the update if M.lookup relVarName (relationVariables currentContext) == Just relExpr then@@ -1544,3 +1545,71 @@ Nothing -> throwError (RelVarNotDefinedError rvName) Just gfexpr -> pure gfexpr +-- | resolve UncommittedTransactionMarker whenever possible- this is important in the DatabaseContext in order to mitigate self-referencing loops for updates+class ResolveGraphRefTransactionMarker a where+ resolve :: a -> DatabaseContextEvalMonad a++-- s := s union t+instance ResolveGraphRefTransactionMarker GraphRefRelationalExpr where+ resolve (MakeRelationFromExprs mAttrs tupleExprs) =+ MakeRelationFromExprs mAttrs <$> resolve tupleExprs+ resolve orig@MakeStaticRelation{} = pure orig+ resolve orig@ExistingRelation{} = pure orig+ resolve orig@(RelationVariable rvName UncommittedContextMarker) = do+ rvMap <- relationVariables <$> getStateContext+ case M.lookup rvName rvMap of+ Nothing -> pure orig+ Just resolvedRv -> resolve resolvedRv+ resolve orig@RelationVariable{} = pure orig+ resolve (Project attrNames relExpr) = Project <$> resolve attrNames <*> resolve relExpr+ resolve (Union exprA exprB) = Union <$> resolve exprA <*> resolve exprB+ resolve (Join exprA exprB) = Join <$> resolve exprA <*> resolve exprB+ resolve (Rename attrA attrB expr) = Rename attrA attrB <$> resolve expr+ resolve (Difference exprA exprB) = Difference <$> resolve exprA <*> resolve exprB+ resolve (Group namesA nameB expr) = Group <$> resolve namesA <*> pure nameB <*> resolve expr+ resolve (Ungroup nameA expr) = Ungroup nameA <$> resolve expr+ resolve (Restrict restrictExpr relExpr) = Restrict <$> resolve restrictExpr <*> resolve relExpr+ resolve (Equals exprA exprB) = Equals <$> resolve exprA <*> resolve exprB+ resolve (NotEquals exprA exprB) = NotEquals <$> resolve exprA <*> resolve exprB+ resolve (Extend extendExpr relExpr) = Extend <$> resolve extendExpr <*> resolve relExpr+ resolve (With withExprs relExpr) = With <$> mapM (\(nam, expr) -> (,) <$> resolve nam <*> resolve expr) withExprs <*> resolve relExpr++instance ResolveGraphRefTransactionMarker GraphRefTupleExprs where+ resolve (TupleExprs marker tupleExprs) =+ TupleExprs marker <$> mapM resolve tupleExprs++instance ResolveGraphRefTransactionMarker GraphRefTupleExpr where+ resolve (TupleExpr tupMap) = do+ tupMap' <- mapM (\(attrName, expr) -> (,) attrName <$> resolve expr ) (M.toList tupMap)+ pure (TupleExpr (M.fromList tupMap'))++instance ResolveGraphRefTransactionMarker GraphRefAttributeNames where+ resolve orig@AttributeNames{} = pure orig+ resolve orig@InvertedAttributeNames{} = pure orig+ resolve (UnionAttributeNames namesA namesB) = UnionAttributeNames <$> resolve namesA <*> resolve namesB+ resolve (IntersectAttributeNames namesA namesB) = IntersectAttributeNames <$> resolve namesA <*> resolve namesB+ resolve (RelationalExprAttributeNames expr) = RelationalExprAttributeNames <$> resolve expr++instance ResolveGraphRefTransactionMarker GraphRefRestrictionPredicateExpr where+ resolve TruePredicate = pure TruePredicate+ resolve (AndPredicate exprA exprB) = AndPredicate <$> resolve exprA <*> resolve exprB+ resolve (OrPredicate exprA exprB) = OrPredicate <$> resolve exprA <*> resolve exprB+ resolve (NotPredicate expr) = NotPredicate <$> resolve expr+ resolve (RelationalExprPredicate expr) = RelationalExprPredicate <$> resolve expr+ resolve (AtomExprPredicate expr) = AtomExprPredicate <$> resolve expr+ resolve (AttributeEqualityPredicate nam expr)= AttributeEqualityPredicate nam <$> resolve expr++instance ResolveGraphRefTransactionMarker GraphRefExtendTupleExpr where+ resolve (AttributeExtendTupleExpr nam atomExpr) = AttributeExtendTupleExpr nam <$> resolve atomExpr++instance ResolveGraphRefTransactionMarker GraphRefWithNameExpr where+ resolve orig@WithNameExpr{} = pure orig -- match uncommitted marker?++instance ResolveGraphRefTransactionMarker GraphRefAtomExpr where+ resolve orig@AttributeAtomExpr{} = pure orig+ resolve orig@NakedAtomExpr{} = pure orig+ resolve (FunctionAtomExpr nam atomExprs marker) =+ FunctionAtomExpr nam <$> mapM resolve atomExprs <*> pure marker+ resolve (RelationAtomExpr expr) = RelationAtomExpr <$> resolve expr+ resolve (ConstructedAtomExpr dConsName atomExprs marker) =+ ConstructedAtomExpr dConsName <$> mapM resolve atomExprs <*> pure marker
+ src/lib/ProjectM36/Serialise/AtomFunctionError.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE DerivingVia, StandaloneDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module ProjectM36.Serialise.AtomFunctionError where+import Codec.Winery+import ProjectM36.AtomFunctionError++deriving via WineryVariant AtomFunctionError instance Serialise AtomFunctionError
+ src/lib/ProjectM36/Serialise/Base.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE StandaloneDeriving, DerivingVia, TypeApplications, TypeSynonymInstances, ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+--Serialise instances for ProjectM36.Base data types- orphan instance city+module ProjectM36.Serialise.Base where+import Codec.Winery hiding (Schema)+import Codec.Winery.Internal+import Control.Monad+import ProjectM36.Base+import ProjectM36.MerkleHash+import Data.UUID+import Data.Proxy+import Data.Word+import qualified Data.List.NonEmpty as NE+import qualified Data.Vector as V+import Data.Time.Calendar (Day,toGregorian,fromGregorian)++deriving via WineryVariant Atom instance Serialise Atom+deriving via WineryVariant AtomType instance Serialise AtomType+deriving via WineryVariant Attribute instance Serialise Attribute+deriving via WineryVariant RelationTupleSet instance Serialise RelationTupleSet+deriving via WineryVariant RelationTuple instance Serialise RelationTuple+deriving via WineryVariant Relation instance Serialise Relation+deriving via WineryVariant RelationCardinality instance Serialise RelationCardinality+deriving via WineryVariant (RelationalExprBase a) instance Serialise a => Serialise (RelationalExprBase a)+deriving via WineryVariant (WithNameExprBase a) instance Serialise a => Serialise (WithNameExprBase a)+deriving via WineryVariant Notification instance Serialise Notification+deriving via WineryVariant TypeConstructorDef instance Serialise TypeConstructorDef+deriving via WineryVariant (TypeConstructorBase a) instance Serialise a => Serialise (TypeConstructorBase a)+deriving via WineryVariant DataConstructorDef instance Serialise DataConstructorDef+deriving via WineryVariant DataConstructorDefArg instance Serialise DataConstructorDefArg+deriving via WineryVariant GraphRefTransactionMarker instance Serialise GraphRefTransactionMarker+deriving via WineryVariant SchemaIsomorph instance Serialise SchemaIsomorph+deriving via WineryVariant InclusionDependency instance Serialise InclusionDependency+deriving via WineryVariant (DatabaseContextExprBase a) instance Serialise a => Serialise (DatabaseContextExprBase a)+deriving via WineryVariant (DatabaseContextIOExprBase a) instance Serialise a => Serialise (DatabaseContextIOExprBase a)+deriving via WineryVariant (RestrictionPredicateExprBase a) instance Serialise a => Serialise (RestrictionPredicateExprBase a)+deriving via WineryVariant TransactionInfo instance Serialise TransactionInfo+deriving via WineryVariant (AtomExprBase a) instance Serialise a => Serialise (AtomExprBase a)+deriving via WineryVariant MerkleHash instance Serialise MerkleHash+deriving via WineryVariant (AttributeExprBase a) instance Serialise a => Serialise (AttributeExprBase a)+deriving via WineryVariant (TupleExprsBase a) instance Serialise a => Serialise (TupleExprsBase a)+deriving via WineryVariant (TupleExprBase a) instance Serialise a => Serialise (TupleExprBase a)+deriving via WineryVariant (AttributeNamesBase a) instance Serialise a => Serialise (AttributeNamesBase a)+deriving via WineryVariant (ExtendTupleExprBase a) instance Serialise a => Serialise (ExtendTupleExprBase a)+deriving via WineryVariant Schema instance Serialise Schema+deriving via WineryVariant MergeStrategy instance Serialise MergeStrategy++fromWordsTup :: (Word32, Word32, Word32, Word32) -> TransactionId+fromWordsTup (a,b,c,d) = fromWords a b c d++instance Serialise TransactionId where+ schemaGen _ = getSchema (Proxy @(Word32, Word32, Word32, Word32))+ toBuilder uuid = toBuilder (toWords uuid)+ extractor = fromWordsTup <$> extractor+ decodeCurrent = fromWordsTup <$> decodeCurrent++instance Serialise a => Serialise (NE.NonEmpty a) where+ schemaGen _ = SVector <$> getSchema (Proxy @a)+ toBuilder xs = varInt (length xs) <> foldMap toBuilder xs+ extractor = NE.fromList . V.toList <$> extractListBy extractor --use nonempty instead to replace error with winery error+ decodeCurrent = do+ n <- decodeVarInt+ l <- replicateM n decodeCurrent+ pure (NE.fromList l)++fromGregorianTup :: (Integer, Int, Int) -> Day+fromGregorianTup (a, b, c) = fromGregorian a b c++instance Serialise Day where+ schemaGen _ = getSchema (Proxy @(Integer, Int, Int))+ toBuilder day = toBuilder (toGregorian day)+ extractor = fromGregorianTup <$> extractor+ decodeCurrent = fromGregorianTup <$> decodeCurrent+++
+ src/lib/ProjectM36/Serialise/DataFrame.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE DerivingVia, StandaloneDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module ProjectM36.Serialise.DataFrame where+import Codec.Winery+import ProjectM36.DataFrame+import ProjectM36.Serialise.Base ()+ +deriving via WineryVariant AttributeOrderExpr instance Serialise AttributeOrderExpr+deriving via WineryVariant AttributeOrder instance Serialise AttributeOrder+deriving via WineryVariant Order instance Serialise Order+deriving via WineryRecord DataFrame instance Serialise DataFrame+deriving via WineryVariant DataFrameTuple instance Serialise DataFrameTuple+deriving via WineryRecord DataFrameExpr instance Serialise DataFrameExpr
+ src/lib/ProjectM36/Serialise/DatabaseContextFunctionError.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE DerivingVia, StandaloneDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module ProjectM36.Serialise.DatabaseContextFunctionError where+import Codec.Winery+import ProjectM36.DatabaseContextFunctionError++deriving via WineryVariant DatabaseContextFunctionError instance Serialise DatabaseContextFunctionError
+ src/lib/ProjectM36/Serialise/Error.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE DerivingVia, StandaloneDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module ProjectM36.Serialise.Error where+import ProjectM36.Error+import Codec.Winery+import ProjectM36.Serialise.Base ()+import ProjectM36.Serialise.AtomFunctionError ()+import ProjectM36.Serialise.DatabaseContextFunctionError ()++deriving via WineryVariant RelationalError instance Serialise RelationalError+deriving via WineryVariant MergeError instance Serialise MergeError+deriving via WineryVariant ScriptCompilationError instance Serialise ScriptCompilationError+deriving via WineryVariant PersistenceError instance Serialise PersistenceError+deriving via WineryVariant SchemaError instance Serialise SchemaError
+ src/lib/ProjectM36/Serialise/IsomorphicSchema.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE StandaloneDeriving, DerivingVia, TypeSynonymInstances, ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module ProjectM36.Serialise.IsomorphicSchema where+import Codec.Winery+import ProjectM36.IsomorphicSchema++deriving via WineryVariant SchemaExpr instance Serialise SchemaExpr
src/lib/ProjectM36/Server.hs view
@@ -7,77 +7,119 @@ import ProjectM36.Server.Config (ServerConfig(..)) import ProjectM36.FSType -import Control.Monad.IO.Class (liftIO)-#if MIN_VERSION_network_transport_tcp(0,7,0)-import Network.Transport.TCP (createTransport, defaultTCPParameters, defaultTCPAddr) -#else-import Network.Transport.TCP (createTransport, defaultTCPParameters)-#endif-import Network.Transport (EndPointAddress(..), newEndPoint, address)-import Control.Distributed.Process.Node (initRemoteTable, runProcess, newLocalNode, initRemoteTable)-import Control.Distributed.Process.Extras.Time (Delay(..))-import Control.Distributed.Process (Process, register, getSelfPid)-import Control.Distributed.Process.ManagedProcess (defaultProcess, UnhandledMessagePolicy(..), ProcessDefinition(..), handleCall, serve, InitHandler, InitResult(..))-import Control.Concurrent.MVar (putMVar, MVar)+import Control.Concurrent.MVar (MVar) import System.IO (stderr, hPutStrLn) import System.FilePath (takeDirectory) import System.Directory (doesDirectoryExist)+import Network.RPC.Curryer.Server+import Network.Socket+import qualified StmContainers.Map as StmMap+import Control.Concurrent.STM --- the state should be a mapping of remote connection to the disconnected transaction- the graph should be the same, so discon must be removed from the stm tuple---trying to refactor this for less repetition is very challenging because the return type cannot be polymorphic or the distributed-process call gets confused and drops messages-serverDefinition :: Bool -> Timeout -> ProcessDefinition Connection-serverDefinition testBool ti = defaultProcess {- apiHandlers = [ - handleCall (\conn (ExecuteHeadName sessionId) -> handleExecuteHeadName ti sessionId conn),- handleCall (\conn (ExecuteRelationalExpr sessionId expr) -> handleExecuteRelationalExpr ti sessionId conn expr),- handleCall (\conn (ExecuteDataFrameExpr sessionId expr) -> handleExecuteDataFrameExpr ti sessionId conn expr), - handleCall (\conn (ExecuteDatabaseContextExpr sessionId expr) -> handleExecuteDatabaseContextExpr ti sessionId conn expr),- handleCall (\conn (ExecuteDatabaseContextIOExpr sessionId expr) -> handleExecuteDatabaseContextIOExpr ti sessionId conn expr),- handleCall (\conn (ExecuteGraphExpr sessionId expr) -> handleExecuteGraphExpr ti sessionId conn expr),- handleCall (\conn (ExecuteTransGraphRelationalExpr sessionId expr) -> handleExecuteTransGraphRelationalExpr ti sessionId conn expr), - handleCall (\conn (ExecuteTypeForRelationalExpr sessionId expr) -> handleExecuteTypeForRelationalExpr ti sessionId conn expr),- handleCall (\conn (RetrieveInclusionDependencies sessionId) -> handleRetrieveInclusionDependencies ti sessionId conn),- handleCall (\conn (RetrievePlanForDatabaseContextExpr sessionId dbExpr) -> handleRetrievePlanForDatabaseContextExpr ti sessionId conn dbExpr),- handleCall (\conn (RetrieveHeadTransactionId sessionId) -> handleRetrieveHeadTransactionId ti sessionId conn),- handleCall (\conn (RetrieveTransactionGraph sessionId) -> handleRetrieveTransactionGraph ti sessionId conn),- handleCall (\conn (Login procId) -> handleLogin ti conn procId),- handleCall (\conn (CreateSessionAtHead headn) -> handleCreateSessionAtHead ti conn headn),- handleCall (\conn (CreateSessionAtCommit commitId) -> handleCreateSessionAtCommit ti conn commitId),- handleCall (\conn (CloseSession sessionId) -> handleCloseSession ti sessionId conn),- handleCall (\conn (RetrieveAtomTypesAsRelation sessionId) -> handleRetrieveAtomTypesAsRelation ti sessionId conn),- handleCall (\conn (RetrieveRelationVariableSummary sessionId) -> handleRetrieveRelationVariableSummary ti sessionId conn),- handleCall (\conn (RetrieveAtomFunctionSummary sessionId) -> handleRetrieveAtomFunctionSummary ti sessionId conn),- handleCall (\conn (RetrieveDatabaseContextFunctionSummary sessionId) -> handleRetrieveDatabaseContextFunctionSummary ti sessionId conn), - handleCall (\conn (RetrieveCurrentSchemaName sessionId) -> handleRetrieveCurrentSchemaName ti sessionId conn),- handleCall (\conn (ExecuteSchemaExpr sessionId schemaExpr) -> handleExecuteSchemaExpr ti sessionId conn schemaExpr),- handleCall (\conn (RetrieveSessionIsDirty sessionId) -> handleRetrieveSessionIsDirty ti sessionId conn),- handleCall (\conn (ExecuteAutoMergeToHead sessionId strat headName') -> handleExecuteAutoMergeToHead ti sessionId conn strat headName'),- handleCall (\conn (RetrieveTypeConstructorMapping sessionId) -> handleRetrieveTypeConstructorMapping ti sessionId conn),- handleCall (\conn (ExecuteValidateMerkleHashes sessionId) -> handleValidateMerkleHashes ti sessionId conn),- handleCall (\conn Logout -> handleLogout ti conn)- ] ++ testModeHandlers,- unhandledMessagePolicy = Terminate- --unhandledMessagePolicy = Log- }- where- testModeHandlers = [handleCall (\conn (TestTimeout sessionId) -> handleTestTimeout ti sessionId conn) | testBool]- -initServer :: InitHandler (Connection, DatabaseName, Maybe (MVar EndPointAddress), EndPointAddress) Connection-initServer (conn, dbname, mAddressMVar, saddress) = do- registerDB dbname- case mAddressMVar of- Nothing -> pure ()- Just addressMVar -> liftIO $ putMVar addressMVar saddress- --traceShowM ("server started on " ++ show saddress)- pure $ InitOk conn Infinity+type TestMode = Bool -registerDB :: DatabaseName -> Process ()-registerDB dbname = do- self <- getSelfPid- let dbname' = remoteDBLookupName dbname - register dbname' self- --liftIO $ putStrLn $ "registered " ++ (show self) ++ " " ++ dbname'- +requestHandlers :: TestMode -> Maybe Timeout -> RequestHandlers ServerState+requestHandlers testFlag ti =+ [+ RequestHandler (\sState (Login dbName) -> do+ addClientLogin dbName sState+ conn <- getConn sState+ handleLogin conn (connectionSocket sState)),+ RequestHandler (\sState Logout -> do+ conn <- getConn sState + handleLogout ti conn),+ RequestHandler $ \sState (ExecuteHeadName sessionId) -> do+ --socket -> dbname --maybe create a socket->client state mapping in the server state, too+ conn <- getConn sState+ handleExecuteHeadName ti sessionId conn,+ RequestHandler (\sState (ExecuteRelationalExpr sessionId expr) -> do+ conn <- getConn sState + handleExecuteRelationalExpr ti sessionId conn expr),+ RequestHandler (\sState (ExecuteDataFrameExpr sessionId expr) -> do+ conn <- getConn sState+ handleExecuteDataFrameExpr ti sessionId conn expr), + RequestHandler (\sState (ExecuteDatabaseContextExpr sessionId expr) -> do+ conn <- getConn sState+ handleExecuteDatabaseContextExpr ti sessionId conn expr),+ RequestHandler (\sState (ExecuteDatabaseContextIOExpr sessionId expr) -> do+ conn <- getConn sState+ handleExecuteDatabaseContextIOExpr ti sessionId conn expr),+ RequestHandler (\sState (ExecuteGraphExpr sessionId expr) -> do+ conn <- getConn sState+ handleExecuteGraphExpr ti sessionId conn expr),+ RequestHandler (\sState (ExecuteTransGraphRelationalExpr sessionId expr) -> do+ conn <- getConn sState+ handleExecuteTransGraphRelationalExpr ti sessionId conn expr),+ RequestHandler (\sState (ExecuteTypeForRelationalExpr sessionId expr) -> do+ conn <- getConn sState + handleExecuteTypeForRelationalExpr ti sessionId conn expr),+ RequestHandler (\sState (RetrieveInclusionDependencies sessionId) -> do+ conn <- getConn sState+ handleRetrieveInclusionDependencies ti sessionId conn),+ RequestHandler (\sState (RetrievePlanForDatabaseContextExpr sessionId dbExpr) -> do+ conn <- getConn sState + handleRetrievePlanForDatabaseContextExpr ti sessionId conn dbExpr),+ RequestHandler (\sState (RetrieveHeadTransactionId sessionId) -> do+ conn <- getConn sState + handleRetrieveHeadTransactionId ti sessionId conn),+ RequestHandler (\sState (RetrieveTransactionGraph sessionId) -> do+ conn <- getConn sState + handleRetrieveTransactionGraph ti sessionId conn),+ RequestHandler (\sState (CreateSessionAtHead headn) -> do+ conn <- getConn sState + handleCreateSessionAtHead ti conn headn),+ RequestHandler (\sState (CreateSessionAtCommit commitId) -> do+ conn <- getConn sState+ handleCreateSessionAtCommit ti conn commitId),+ RequestHandler (\sState (CloseSession sessionId) -> do+ conn <- getConn sState + handleCloseSession sessionId conn),+ RequestHandler (\sState (RetrieveAtomTypesAsRelation sessionId) -> do+ conn <- getConn sState + handleRetrieveAtomTypesAsRelation ti sessionId conn),+ RequestHandler (\sState (RetrieveRelationVariableSummary sessionId) -> do+ conn <- getConn sState + handleRetrieveRelationVariableSummary ti sessionId conn),+ RequestHandler (\sState (RetrieveAtomFunctionSummary sessionId) -> do+ conn <- getConn sState+ handleRetrieveAtomFunctionSummary ti sessionId conn),+ RequestHandler (\sState (RetrieveDatabaseContextFunctionSummary sessionId) -> do+ conn <- getConn sState+ handleRetrieveDatabaseContextFunctionSummary ti sessionId conn), RequestHandler (\sState (RetrieveCurrentSchemaName sessionId) -> do+ conn <- getConn sState+ handleRetrieveCurrentSchemaName ti sessionId conn),+ RequestHandler (\sState (ExecuteSchemaExpr sessionId schemaExpr) -> do+ conn <- getConn sState+ handleExecuteSchemaExpr ti sessionId conn schemaExpr),+ RequestHandler (\sState (RetrieveSessionIsDirty sessionId) -> do+ conn <- getConn sState+ handleRetrieveSessionIsDirty ti sessionId conn),+ RequestHandler (\sState (ExecuteAutoMergeToHead sessionId strat headName') -> do+ conn <- getConn sState + handleExecuteAutoMergeToHead ti sessionId conn strat headName'),+ RequestHandler (\sState (RetrieveTypeConstructorMapping sessionId) -> do+ conn <- getConn sState+ handleRetrieveTypeConstructorMapping ti sessionId conn),+ RequestHandler (\sState (ExecuteValidateMerkleHashes sessionId) -> do+ conn <- getConn sState + handleValidateMerkleHashes ti sessionId conn)+ ] ++ if testFlag then testModeHandlers ti else []++getConn :: ConnectionState ServerState -> IO Connection+getConn connState = do+ let sock = lockless (connectionSocket connState)+ sState = connectionServerState connState+ mConn <- connectionForClient sock sState+ case mConn of+ Nothing -> error "failed to find socket in client map"+ Just conn -> pure conn++testModeHandlers :: Maybe Timeout -> RequestHandlers ServerState+testModeHandlers ti = [RequestHandler (\sState (TestTimeout sessionId) -> do+ conn <- getConn sState+ handleTestTimeout ti sessionId conn)]++ -- | A notification callback which logs the notification to stderr and does nothing else. loggingNotificationCallback :: NotificationCallback loggingNotificationCallback notName evaldNot = hPutStrLn stderr $ "Notification received \"" ++ show notName ++ "\": " ++ show evaldNot@@ -102,9 +144,47 @@ checkFSErrorMsg :: String checkFSErrorMsg = "The filesystem does not support journaling so writes may not be crash-safe. Use --disable-fscheck to disable this fatal error." +-- Sockets do not implement hashable, so we just use their string values as keys+type SocketString = String++data ServerState =+ ServerState {+ --map available databases to local database configurations+ stateDBMap :: StmMap.Map DatabaseName Connection,+ --map clients to database names- after logging in, clients are afixed to specific database names+ stateClientMap :: StmMap.Map SocketString DatabaseName+ }++-- add a client socket to the database mapping+addClientLogin :: DatabaseName -> ConnectionState ServerState -> IO ()+addClientLogin dbName cState = do+ let clientMap = stateClientMap (connectionServerState cState)+ sock = lockless (connectionSocket cState)+ atomically $ do+ mVal <- StmMap.lookup (show sock) clientMap+ case mVal of+ Nothing -> StmMap.insert dbName (show sock) clientMap+ Just _ -> pure () --TODO: throw exception- user already logged in+ +connectionForClient :: Socket -> ServerState -> IO (Maybe Connection)+connectionForClient sock sState =+ atomically $ do+ mdbname <- StmMap.lookup (show sock) (stateClientMap sState)+ case mdbname of+ Nothing -> pure Nothing+ Just dbname -> + StmMap.lookup dbname (stateDBMap sState)++initialServerState :: DatabaseName -> Connection -> IO ServerState+initialServerState dbName conn = + atomically $ do+ dbmap <- StmMap.new+ clientMap <- StmMap.new+ StmMap.insert conn dbName dbmap+ pure (ServerState { stateDBMap = dbmap, stateClientMap = clientMap }) -- | A synchronous function to start the project-m36 daemon given an appropriate 'ServerConfig'. Note that this function only returns if the server exits. Returns False if the daemon exited due to an error. If the second argument is not Nothing, the port is put after the server is ready to service the port.-launchServer :: ServerConfig -> Maybe (MVar EndPointAddress) -> IO Bool-launchServer daemonConfig mAddressMVar = do+launchServer :: ServerConfig -> Maybe (MVar SockAddr) -> IO Bool+launchServer daemonConfig mAddr = do checkFSResult <- checkFSType (checkFS daemonConfig) (persistenceStrategy daemonConfig) if not checkFSResult then do hPutStrLn stderr checkFSErrorMsg@@ -117,26 +197,21 @@ pure False Right conn -> do let hostname = bindHost daemonConfig- port = bindPort daemonConfig-#if MIN_VERSION_network_transport_tcp(0,7,0)- etransport <- createTransport (defaultTCPAddr hostname (show port)) defaultTCPParameters-#elif MIN_VERSION_network_transport_tcp(0,6,0) - etransport <- createTransport hostname (show port) (\nam -> (hostname, nam)) defaultTCPParameters -#else - etransport <- createTransport hostname (show port) defaultTCPParameters-#endif- case etransport of- Left err -> error ("failed to create transport: " ++ show err)- Right transport -> do- eEndpoint <- newEndPoint transport- case eEndpoint of - Left err -> hPutStrLn stderr ("Failed to create transport: " ++ show err) >> pure False- Right endpoint -> do- localTCPNode <- newLocalNode transport initRemoteTable- --traceShowM ("newLocalNode in Server " ++ show (localNodeId localTCPNode))- runProcess localTCPNode $ do- let testBool = testMode daemonConfig- reqTimeout = perRequestTimeout daemonConfig- serve (conn, databaseName daemonConfig, mAddressMVar, address endpoint) initServer (serverDefinition testBool reqTimeout)- liftIO $ putStrLn "serve returned"- pure True+ port = fromIntegral (bindPort daemonConfig)+++ --curryer only supports IPv4 for now+ let addrHints = defaultHints { addrSocketType = Stream, addrFamily = AF_INET }+ hostAddrs <- getAddrInfo (Just addrHints) (Just hostname) Nothing+ case hostAddrs of+ [] -> hPutStrLn stderr ("Failed to resolve: " <> hostname) >> pure False+ (AddrInfo _ _ _ _ (SockAddrInet _ addr32) _):_ -> do+ let hostAddr = hostAddressToTuple addr32+ mTimeout = fromIntegral <$> case perRequestTimeout daemonConfig of+ 0 -> Nothing+ v -> Just v+ + sState <- initialServerState (databaseName daemonConfig) conn+ serve (requestHandlers (testMode daemonConfig) mTimeout) sState hostAddr port mAddr+ _ -> error "unsupported socket addressing mode (IPv4 only currently)"+
src/lib/ProjectM36/Server/EntryPoints.hs view
@@ -3,176 +3,144 @@ import ProjectM36.Base hiding (inclusionDependencies) import ProjectM36.IsomorphicSchema import ProjectM36.Client as C-import ProjectM36.Error-import Control.Distributed.Process (Process, ProcessId)-import Control.Distributed.Process.ManagedProcess (ProcessReply)-import Control.Distributed.Process.ManagedProcess.Server (reply)-import Control.Distributed.Process.Async (async, task, waitCancelTimeout, AsyncResult(..))-import Control.Monad.IO.Class (liftIO) import Data.Map import Control.Concurrent (threadDelay)-import Data.Typeable-import Data.Binary+import Network.RPC.Curryer.Server+import System.Timeout+import Network.Socket+import Control.Exception -timeoutOrDie :: (Binary a, Typeable a) => Timeout -> IO a -> Process (Either ServerError a)-timeoutOrDie micros act = - if micros == 0 then- liftIO act >>= \x -> pure (Right x)- else do- asyncUnit <- async (task (liftIO act))- asyncRes <- waitCancelTimeout micros asyncUnit- case asyncRes of- AsyncDone x -> pure (Right x)- AsyncCancelled -> pure (Left RequestTimeoutError)- AsyncFailed reason -> pure (Left (ProcessDiedError (show reason)))- AsyncLinkFailed reason -> pure (Left (ProcessDiedError (show reason)))- AsyncPending -> pure (Left (ProcessDiedError "process pending"))- -type Timeout = Int+timeoutOrDie :: Maybe Timeout -> IO a -> IO (Maybe a)+timeoutOrDie mMicros act = + case mMicros of+ Nothing -> Just <$> act+ Just micros ->+ timeout (fromIntegral micros) act -type Reply a = Process (ProcessReply (Either ServerError a) Connection)- -handleExecuteRelationalExpr :: Timeout -> SessionId -> Connection -> RelationalExpr -> Reply (Either RelationalError Relation)-handleExecuteRelationalExpr ti sessionId conn expr = do- ret <- timeoutOrDie ti (executeRelationalExpr sessionId conn expr)- reply ret conn+timeoutRelErr :: Maybe Timeout -> IO (Either RelationalError a) -> IO (Either RelationalError a)+timeoutRelErr mMicros act = do+ ret <- timeoutOrDie mMicros act+ case ret of+ Nothing -> throw TimeoutException+ Just v -> pure v+ -handleExecuteDataFrameExpr :: Timeout -> SessionId -> Connection -> DataFrameExpr -> Reply (Either RelationalError DataFrame)-handleExecuteDataFrameExpr ti sessionId conn expr = do- ret <- timeoutOrDie ti (executeDataFrameExpr sessionId conn expr)- reply ret conn+handleExecuteRelationalExpr :: Maybe Timeout -> SessionId -> Connection -> RelationalExpr -> IO (Either RelationalError Relation)+handleExecuteRelationalExpr ti sessionId conn expr = + timeoutRelErr ti (executeRelationalExpr sessionId conn expr)++handleExecuteDataFrameExpr :: Maybe Timeout -> SessionId -> Connection -> DataFrameExpr -> IO (Either RelationalError DataFrame)+handleExecuteDataFrameExpr ti sessionId conn expr =+ timeoutRelErr ti (executeDataFrameExpr sessionId conn expr) -handleExecuteDatabaseContextExpr :: Timeout -> SessionId -> Connection -> DatabaseContextExpr -> Reply (Either RelationalError ())-handleExecuteDatabaseContextExpr ti sessionId conn dbexpr = do- ret <- timeoutOrDie ti (executeDatabaseContextExpr sessionId conn dbexpr)- reply ret conn+handleExecuteDatabaseContextExpr :: Maybe Timeout -> SessionId -> Connection -> DatabaseContextExpr -> IO (Either RelationalError ())+handleExecuteDatabaseContextExpr ti sessionId conn dbexpr =+ timeoutRelErr ti (executeDatabaseContextExpr sessionId conn dbexpr) -handleExecuteDatabaseContextIOExpr :: Timeout -> SessionId -> Connection -> DatabaseContextIOExpr -> Reply (Either RelationalError ())-handleExecuteDatabaseContextIOExpr ti sessionId conn dbexpr = do- ret <- timeoutOrDie ti (executeDatabaseContextIOExpr sessionId conn dbexpr)- reply ret conn+handleExecuteDatabaseContextIOExpr :: Maybe Timeout -> SessionId -> Connection -> DatabaseContextIOExpr -> IO (Either RelationalError ())+handleExecuteDatabaseContextIOExpr ti sessionId conn dbexpr =+ timeoutRelErr ti (executeDatabaseContextIOExpr sessionId conn dbexpr) -handleExecuteHeadName :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError HeadName)-handleExecuteHeadName ti sessionId conn = do- ret <- timeoutOrDie ti (headName sessionId conn)- reply ret conn+handleExecuteHeadName :: Maybe Timeout -> SessionId -> Connection -> IO (Either RelationalError HeadName)+handleExecuteHeadName ti sessionId conn =+ timeoutRelErr ti (headName sessionId conn) -handleLogin :: Timeout -> Connection -> ProcessId -> Reply Bool-handleLogin ti conn newClientProcessId = do- ret <- timeoutOrDie ti (addClientNode conn newClientProcessId)- case ret of- Right () -> reply (Right True) conn- Left err -> reply (Left err) conn+handleLogin :: Connection -> Locking Socket -> IO Bool+handleLogin conn lockSock = do+ addClientNode conn lockSock+ pure True -handleExecuteGraphExpr :: Timeout -> SessionId -> Connection -> TransactionGraphOperator -> Reply (Either RelationalError ())-handleExecuteGraphExpr ti sessionId conn graphExpr = do- ret <- timeoutOrDie ti (executeGraphExpr sessionId conn graphExpr)- reply ret conn+handleExecuteGraphExpr :: Maybe Timeout -> SessionId -> Connection -> TransactionGraphOperator -> IO (Either RelationalError ())+handleExecuteGraphExpr ti sessionId conn graphExpr =+ timeoutRelErr ti (executeGraphExpr sessionId conn graphExpr) -handleExecuteTransGraphRelationalExpr :: Timeout -> SessionId -> Connection -> TransGraphRelationalExpr -> Reply (Either RelationalError Relation)-handleExecuteTransGraphRelationalExpr ti sessionId conn graphExpr = do- ret <- timeoutOrDie ti (executeTransGraphRelationalExpr sessionId conn graphExpr)- reply ret conn+handleExecuteTransGraphRelationalExpr :: Maybe Timeout -> SessionId -> Connection -> TransGraphRelationalExpr -> IO (Either RelationalError Relation)+handleExecuteTransGraphRelationalExpr ti sessionId conn graphExpr =+ timeoutRelErr ti (executeTransGraphRelationalExpr sessionId conn graphExpr) -handleExecuteTypeForRelationalExpr :: Timeout -> SessionId -> Connection -> RelationalExpr -> Reply (Either RelationalError Relation)-handleExecuteTypeForRelationalExpr ti sessionId conn relExpr = do- ret <- timeoutOrDie ti (typeForRelationalExpr sessionId conn relExpr)- reply ret conn+handleExecuteTypeForRelationalExpr :: Maybe Timeout -> SessionId -> Connection -> RelationalExpr -> IO (Either RelationalError Relation)+handleExecuteTypeForRelationalExpr ti sessionId conn relExpr =+ timeoutRelErr ti (typeForRelationalExpr sessionId conn relExpr) -handleRetrieveInclusionDependencies :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError (Map IncDepName InclusionDependency))-handleRetrieveInclusionDependencies ti sessionId conn = do- ret <- timeoutOrDie ti (inclusionDependencies sessionId conn)- reply ret conn+handleRetrieveInclusionDependencies :: Maybe Timeout -> SessionId -> Connection -> IO (Either RelationalError (Map IncDepName InclusionDependency))+handleRetrieveInclusionDependencies ti sessionId conn =+ timeoutRelErr ti (inclusionDependencies sessionId conn) -handleRetrievePlanForDatabaseContextExpr :: Timeout -> SessionId -> Connection -> DatabaseContextExpr -> Reply (Either RelationalError GraphRefDatabaseContextExpr)-handleRetrievePlanForDatabaseContextExpr ti sessionId conn dbExpr = do- ret <- timeoutOrDie ti (planForDatabaseContextExpr sessionId conn dbExpr)- reply ret conn+handleRetrievePlanForDatabaseContextExpr :: Maybe Timeout -> SessionId -> Connection -> DatabaseContextExpr -> IO (Either RelationalError GraphRefDatabaseContextExpr)+handleRetrievePlanForDatabaseContextExpr ti sessionId conn dbExpr =+ timeoutRelErr ti (planForDatabaseContextExpr sessionId conn dbExpr) -handleRetrieveTransactionGraph :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError Relation) -handleRetrieveTransactionGraph ti sessionId conn = do - ret <- timeoutOrDie ti (transactionGraphAsRelation sessionId conn)- reply ret conn+handleRetrieveTransactionGraph :: Maybe Timeout -> SessionId -> Connection -> IO (Either RelationalError Relation) +handleRetrieveTransactionGraph ti sessionId conn =+ timeoutRelErr ti (transactionGraphAsRelation sessionId conn) -handleRetrieveHeadTransactionId :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError TransactionId)-handleRetrieveHeadTransactionId ti sessionId conn = do- ret <- timeoutOrDie ti (headTransactionId sessionId conn)- reply ret conn+handleRetrieveHeadTransactionId :: Maybe Timeout -> SessionId -> Connection -> IO (Either RelationalError TransactionId)+handleRetrieveHeadTransactionId ti sessionId conn =+ timeoutRelErr ti (headTransactionId sessionId conn) -handleCreateSessionAtCommit :: Timeout -> Connection -> TransactionId -> Reply (Either RelationalError SessionId)-handleCreateSessionAtCommit ti conn commitId = do- ret <- timeoutOrDie ti (createSessionAtCommit conn commitId)- reply ret conn+handleCreateSessionAtCommit :: Maybe Timeout -> Connection -> TransactionId -> IO (Either RelationalError SessionId)+handleCreateSessionAtCommit ti conn commitId =+ timeoutRelErr ti (createSessionAtCommit conn commitId) -handleCreateSessionAtHead :: Timeout -> Connection -> HeadName -> Reply (Either RelationalError SessionId)-handleCreateSessionAtHead ti conn headn = do- ret <- timeoutOrDie ti (createSessionAtHead conn headn)- reply ret conn+handleCreateSessionAtHead :: Maybe Timeout -> Connection -> HeadName -> IO (Either RelationalError SessionId)+handleCreateSessionAtHead ti conn headn = + timeoutRelErr ti (createSessionAtHead conn headn) -handleCloseSession :: Timeout -> SessionId -> Connection -> Reply () -handleCloseSession ti sessionId conn = do- ret <- timeoutOrDie ti (closeSession sessionId conn)- case ret of- Right () -> reply (Right ()) conn- Left err -> reply (Left err) conn+handleCloseSession :: SessionId -> Connection -> IO () +handleCloseSession =+ closeSession -handleRetrieveAtomTypesAsRelation :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError Relation)-handleRetrieveAtomTypesAsRelation ti sessionId conn = do- ret <- timeoutOrDie ti (atomTypesAsRelation sessionId conn)- reply ret conn+handleRetrieveAtomTypesAsRelation :: Maybe Timeout -> SessionId -> Connection -> IO (Either RelationalError Relation)+handleRetrieveAtomTypesAsRelation ti sessionId conn =+ timeoutRelErr ti (atomTypesAsRelation sessionId conn) -- | Returns a relation which lists the names of relvars in the current session as well as its types. -handleRetrieveRelationVariableSummary :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError Relation)-handleRetrieveRelationVariableSummary ti sessionId conn = do- ret <- timeoutOrDie ti (relationVariablesAsRelation sessionId conn)- reply ret conn +handleRetrieveRelationVariableSummary :: Maybe Timeout -> SessionId -> Connection -> IO (Either RelationalError Relation)+handleRetrieveRelationVariableSummary ti sessionId conn =+ timeoutRelErr ti (relationVariablesAsRelation sessionId conn) -handleRetrieveAtomFunctionSummary :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError Relation)-handleRetrieveAtomFunctionSummary ti sessionId conn = do- ret <- timeoutOrDie ti (atomFunctionsAsRelation sessionId conn)- reply ret conn +handleRetrieveAtomFunctionSummary :: Maybe Timeout -> SessionId -> Connection -> IO (Either RelationalError Relation)+handleRetrieveAtomFunctionSummary ti sessionId conn = + timeoutRelErr ti (atomFunctionsAsRelation sessionId conn) -handleRetrieveDatabaseContextFunctionSummary :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError Relation)-handleRetrieveDatabaseContextFunctionSummary ti sessionId conn = do- ret <- timeoutOrDie ti (databaseContextFunctionsAsRelation sessionId conn)- reply ret conn +handleRetrieveDatabaseContextFunctionSummary :: Maybe Timeout -> SessionId -> Connection -> IO (Either RelationalError Relation)+handleRetrieveDatabaseContextFunctionSummary ti sessionId conn = + timeoutRelErr ti (databaseContextFunctionsAsRelation sessionId conn) -handleRetrieveCurrentSchemaName :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError SchemaName)-handleRetrieveCurrentSchemaName ti sessionId conn = do- ret <- timeoutOrDie ti (currentSchemaName sessionId conn)- reply ret conn +handleRetrieveCurrentSchemaName :: Maybe Timeout -> SessionId -> Connection -> IO (Either RelationalError SchemaName)+handleRetrieveCurrentSchemaName ti sessionId conn =+ timeoutRelErr ti (currentSchemaName sessionId conn) -handleExecuteSchemaExpr :: Timeout -> SessionId -> Connection -> SchemaExpr -> Reply (Either RelationalError ())-handleExecuteSchemaExpr ti sessionId conn schemaExpr = do- ret <- timeoutOrDie ti (executeSchemaExpr sessionId conn schemaExpr)- reply ret conn+handleExecuteSchemaExpr :: Maybe Timeout -> SessionId -> Connection -> SchemaExpr -> IO (Either RelationalError ())+handleExecuteSchemaExpr ti sessionId conn schemaExpr =+ timeoutRelErr ti (executeSchemaExpr sessionId conn schemaExpr) -handleLogout :: Timeout -> Connection -> Reply Bool-handleLogout _ = +handleLogout :: Maybe Timeout -> Connection -> IO Bool+handleLogout _ _ = --liftIO $ closeRemote_ conn- reply (pure True)+ pure True -handleTestTimeout :: Timeout -> SessionId -> Connection -> Reply Bool -handleTestTimeout ti _ conn = do- ret <- timeoutOrDie ti (threadDelay 100000 >> pure True)- reply ret conn+handleTestTimeout :: Maybe Timeout -> SessionId -> Connection -> IO Bool +handleTestTimeout ti _ _ = do+ ret <- timeoutRelErr ti (threadDelay 100000 >> pure (Right ()))+ case ret of+ Right () -> pure True+ Left _ -> pure False -handleRetrieveSessionIsDirty :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError Bool)-handleRetrieveSessionIsDirty ti sessionId conn = do- ret <- timeoutOrDie ti (disconnectedTransactionIsDirty sessionId conn)- reply ret conn+ ++handleRetrieveSessionIsDirty :: Maybe Timeout -> SessionId -> Connection -> IO (Either RelationalError Bool)+handleRetrieveSessionIsDirty ti sessionId conn =+ timeoutRelErr ti (disconnectedTransactionIsDirty sessionId conn) -handleExecuteAutoMergeToHead :: Timeout -> SessionId -> Connection -> MergeStrategy -> HeadName -> Reply (Either RelationalError ())-handleExecuteAutoMergeToHead ti sessionId conn strat headName' = do- ret <- timeoutOrDie ti (autoMergeToHead sessionId conn strat headName')- reply ret conn+handleExecuteAutoMergeToHead :: Maybe Timeout -> SessionId -> Connection -> MergeStrategy -> HeadName -> IO (Either RelationalError ())+handleExecuteAutoMergeToHead ti sessionId conn strat headName' =+ timeoutRelErr ti (autoMergeToHead sessionId conn strat headName') -handleRetrieveTypeConstructorMapping :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError TypeConstructorMapping) -handleRetrieveTypeConstructorMapping ti sessionId conn = do- ret <- timeoutOrDie ti (C.typeConstructorMapping sessionId conn)- reply ret conn+handleRetrieveTypeConstructorMapping :: Maybe Timeout -> SessionId -> Connection -> IO (Either RelationalError TypeConstructorMapping) +handleRetrieveTypeConstructorMapping ti sessionId conn =+ timeoutRelErr ti (C.typeConstructorMapping sessionId conn) -handleValidateMerkleHashes :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError ())-handleValidateMerkleHashes ti sessionId conn = do- ret <- timeoutOrDie ti (C.validateMerkleHashes sessionId conn)- reply ret conn+handleValidateMerkleHashes :: Maybe Timeout -> SessionId -> Connection -> IO (Either RelationalError ())+handleValidateMerkleHashes ti sessionId conn = + timeoutRelErr ti (C.validateMerkleHashes sessionId conn)
src/lib/ProjectM36/Server/ParseArgs.hs view
@@ -50,7 +50,7 @@ metavar "HOST_NAME" <> value defHostname) -parsePort :: Port -> Parser Port +parsePort :: Port -> Parser Port parsePort defPort = option auto (short 'p' <> long "port" <> metavar "PORT_NUMBER" <>
src/lib/ProjectM36/Server/RemoteCallTypes.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveAnyClass, DeriveGeneric #-}+{-# LANGUAGE DeriveGeneric, DerivingVia, CPP #-} module ProjectM36.Server.RemoteCallTypes where import ProjectM36.Base import ProjectM36.IsomorphicSchema@@ -6,69 +6,98 @@ import ProjectM36.DataFrame import ProjectM36.TransGraphRelationalExpression import ProjectM36.Session+import ProjectM36.Serialise.DataFrame ()+import ProjectM36.Serialise.IsomorphicSchema () import GHC.Generics-import Data.Binary-import Control.Distributed.Process (ProcessId)+import Codec.Winery +#define RPCData(typeName) deriving Generic \+ deriving Serialise via WineryVariant typeName+ {-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-} -- | The initial login message. The argument should be the process id of the initiating client. This ProcessId will receive notification callbacks.-data Login = Login ProcessId- deriving (Binary, Generic)+data Login = Login DatabaseName+ RPCData(Login) data Logout = Logout- deriving (Binary, Generic)-data ExecuteRelationalExpr = ExecuteRelationalExpr SessionId RelationalExpr - deriving (Binary, Generic)+ RPCData(Logout)++data ExecuteRelationalExpr = ExecuteRelationalExpr SessionId RelationalExpr+ RPCData(ExecuteRelationalExpr)+ data ExecuteDataFrameExpr = ExecuteDataFrameExpr SessionId DataFrameExpr- deriving (Binary, Generic)+ RPCData(ExecuteDataFrameExpr)+ data ExecuteDatabaseContextExpr = ExecuteDatabaseContextExpr SessionId DatabaseContextExpr- deriving (Binary, Generic)+ RPCData(ExecuteDatabaseContextExpr)+ data ExecuteDatabaseContextIOExpr = ExecuteDatabaseContextIOExpr SessionId DatabaseContextIOExpr- deriving (Binary, Generic) + RPCData(ExecuteDatabaseContextIOExpr)+ data ExecuteGraphExpr = ExecuteGraphExpr SessionId TransactionGraphOperator - deriving (Binary, Generic)+ RPCData(ExecuteGraphExpr)+ data ExecuteTransGraphRelationalExpr = ExecuteTransGraphRelationalExpr SessionId TransGraphRelationalExpr - deriving (Binary, Generic)+ RPCData(ExecuteTransGraphRelationalExpr)+ data ExecuteHeadName = ExecuteHeadName SessionId- deriving (Binary, Generic)+ RPCData(ExecuteHeadName)+ data ExecuteTypeForRelationalExpr = ExecuteTypeForRelationalExpr SessionId RelationalExpr- deriving (Binary, Generic)-data ExecuteSchemaExpr = ExecuteSchemaExpr SessionId SchemaExpr - deriving (Binary, Generic)+ RPCData(ExecuteTypeForRelationalExpr)+ +data ExecuteSchemaExpr = ExecuteSchemaExpr SessionId SchemaExpr RPCData(ExecuteSchemaExpr) + data ExecuteSetCurrentSchema = ExecuteSetCurrentSchema SessionId SchemaName- deriving (Binary, Generic)+ RPCData(ExecuteSetCurrentSchema)+ data RetrieveInclusionDependencies = RetrieveInclusionDependencies SessionId- deriving (Binary, Generic)+ RPCData(RetrieveInclusionDependencies)+ data RetrievePlanForDatabaseContextExpr = RetrievePlanForDatabaseContextExpr SessionId DatabaseContextExpr- deriving (Binary, Generic)+ RPCData(RetrievePlanForDatabaseContextExpr)+ data RetrieveTransactionGraph = RetrieveTransactionGraph SessionId- deriving (Binary, Generic)+ RPCData(RetrieveTransactionGraph)+ data RetrieveHeadTransactionId = RetrieveHeadTransactionId SessionId- deriving (Binary, Generic)+ RPCData(RetrieveHeadTransactionId)+ data CreateSessionAtCommit = CreateSessionAtCommit TransactionId- deriving (Binary, Generic)+ RPCData(CreateSessionAtCommit)+ data CreateSessionAtHead = CreateSessionAtHead HeadName- deriving (Binary, Generic)+ RPCData(CreateSessionAtHead)+ data CloseSession = CloseSession SessionId- deriving (Binary, Generic)+ RPCData(CloseSession)+ data RetrieveAtomTypesAsRelation = RetrieveAtomTypesAsRelation SessionId- deriving (Binary, Generic)+ RPCData(RetrieveAtomTypesAsRelation)+ data RetrieveRelationVariableSummary = RetrieveRelationVariableSummary SessionId- deriving (Binary, Generic)+ RPCData(RetrieveRelationVariableSummary)+ data RetrieveAtomFunctionSummary = RetrieveAtomFunctionSummary SessionId- deriving (Binary, Generic)+ RPCData(RetrieveAtomFunctionSummary)+ data RetrieveDatabaseContextFunctionSummary = RetrieveDatabaseContextFunctionSummary SessionId- deriving (Binary, Generic)+ RPCData(RetrieveDatabaseContextFunctionSummary)+ data RetrieveCurrentSchemaName = RetrieveCurrentSchemaName SessionId- deriving (Binary, Generic)+ RPCData(RetrieveCurrentSchemaName)+ data TestTimeout = TestTimeout SessionId - deriving (Binary, Generic)-data RetrieveSessionIsDirty = RetrieveSessionIsDirty SessionId - deriving (Binary, Generic)+ RPCData(TestTimeout)+ +data RetrieveSessionIsDirty = RetrieveSessionIsDirty SessionId+ RPCData(RetrieveSessionIsDirty)+ data ExecuteAutoMergeToHead = ExecuteAutoMergeToHead SessionId MergeStrategy HeadName- deriving (Binary, Generic)+ RPCData(ExecuteAutoMergeToHead)+ data RetrieveTypeConstructorMapping = RetrieveTypeConstructorMapping SessionId - deriving (Binary, Generic)+ RPCData(RetrieveTypeConstructorMapping) data ExecuteValidateMerkleHashes = ExecuteValidateMerkleHashes SessionId- deriving (Binary, Generic)+ RPCData(ExecuteValidateMerkleHashes)
src/lib/ProjectM36/TransGraphRelationalExpression.hs view
@@ -10,42 +10,25 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.Except import Data.Functor.Identity-import Data.Binary -- | The TransGraphRelationalExpression is equivalent to a relational expression except that relation variables can reference points in the transaction graph (at previous points in time). type TransGraphRelationalExpr = RelationalExprBase TransactionIdLookup -instance Binary TransGraphRelationalExpr- type TransGraphAttributeNames = AttributeNamesBase TransactionIdLookup -instance Binary TransGraphAttributeNames- type TransGraphExtendTupleExpr = ExtendTupleExprBase TransactionIdLookup -instance Binary TransGraphExtendTupleExpr- type TransGraphTupleExpr = TupleExprBase TransactionIdLookup -instance Binary TransGraphTupleExpr- type TransGraphTupleExprs = TupleExprsBase TransactionIdLookup -instance Binary TransGraphTupleExprs- type TransGraphRestrictionPredicateExpr = RestrictionPredicateExprBase TransactionIdLookup -instance Binary TransGraphRestrictionPredicateExpr- type TransGraphAtomExpr = AtomExprBase TransactionIdLookup -instance Binary TransGraphAtomExpr - type TransGraphAttributeExpr = AttributeExprBase TransactionIdLookup type TransGraphWithNameExpr = WithNameExprBase TransactionIdLookup--instance Binary TransGraphWithNameExpr newtype TransGraphEvalEnv = TransGraphEvalEnv { tge_graph :: TransactionGraph
src/lib/ProjectM36/Transaction/Persist.hs view
@@ -8,13 +8,13 @@ import ProjectM36.Persist (writeBSFileSync, DiskSync, renameSync) import qualified Data.Map as M import qualified Data.HashSet as HS-import qualified Data.Binary as B import System.FilePath import System.Directory import qualified Data.Text as T import Control.Monad import ProjectM36.ScriptSession import ProjectM36.AtomFunctions.Basic (precompiledAtomFunctions)+import Codec.Winery #ifdef PM36_HASKELL_SCRIPTING import GHC@@ -62,7 +62,7 @@ return $ Left $ MissingTransactionError transId else do relvars <- readRelVars transDir- transInfo <- B.decodeFile (transactionInfoPath transDir)+ transInfo <- readFileDeserialise (transactionInfoPath transDir) incDeps <- readIncDeps transDir typeCons <- readTypeConstructorMapping transDir sschemas <- readSubschemas transDir@@ -92,28 +92,28 @@ writeDBCFuncs sync tempTransDir (dbcFunctions context) writeTypeConstructorMapping sync tempTransDir (typeConstructorMapping context) writeSubschemas sync tempTransDir (subschemas trans)- B.encodeFile (transactionInfoPath tempTransDir) (transactionInfo trans)+ writeFileSerialise (transactionInfoPath tempTransDir) (transactionInfo trans) --move the temp directory to final location renameSync sync tempTransDir finalTransDir writeRelVars :: DiskSync -> FilePath -> RelationVariables -> IO () writeRelVars sync transDir relvars = do let path = relvarsPath transDir- writeBSFileSync sync path (B.encode relvars)+ writeBSFileSync sync path (serialise relvars) readRelVars :: FilePath -> IO RelationVariables readRelVars transDir = - B.decodeFile (relvarsPath transDir)+ readFileDeserialise (relvarsPath transDir) writeAtomFuncs :: DiskSync -> FilePath -> AtomFunctions -> IO () writeAtomFuncs sync transDir funcs = do let atomFuncPath = atomFuncsPath transDir - writeBSFileSync sync atomFuncPath (B.encode $ map (\f -> (atomFuncType f, atomFuncName f, atomFunctionScript f)) (HS.toList funcs))+ writeBSFileSync sync atomFuncPath (serialise $ map (\f -> (atomFuncType f, atomFuncName f, atomFunctionScript f)) (HS.toList funcs)) --all the atom functions are in one file readAtomFuncs :: FilePath -> Maybe ScriptSession -> IO AtomFunctions readAtomFuncs transDir mScriptSession = do- atomFuncsList <- B.decodeFile (atomFuncsPath transDir)+ atomFuncsList <- readFileDeserialise (atomFuncsPath transDir) --only Haskell script functions can be serialized --we always return the pre-compiled functions funcs <- mapM (\(funcType, funcName, mFuncScript) -> loadAtomFunc precompiledAtomFunctions mScriptSession funcName funcType mFuncScript) atomFuncsList@@ -153,7 +153,7 @@ #else readAtomFunc transDir funcName mScriptSession precompiledFuncs = do let atomFuncPath = atomFuncsPath transDir- (funcType, mFuncScript) <- B.decodeFile @([AtomType],Maybe T.Text) atomFuncPath+ (funcType, mFuncScript) <- readFileDeserialise @([AtomType],Maybe T.Text) atomFuncPath case mFuncScript of --handle pre-compiled case- pull it from the precompiled list Nothing -> case atomFunctionForName funcName precompiledFuncs of@@ -184,7 +184,7 @@ writeDBCFunc :: DiskSync -> FilePath -> DatabaseContextFunction -> IO () writeDBCFunc sync transDir func = do let dbcFuncPath = dbcFuncsDir transDir </> T.unpack (dbcFuncName func) - writeBSFileSync sync dbcFuncPath (B.encode (dbcFuncType func, databaseContextFunctionScript func))+ writeBSFileSync sync dbcFuncPath (serialise (dbcFuncType func, databaseContextFunctionScript func)) readDBCFuncs :: FilePath -> Maybe ScriptSession -> IO DatabaseContextFunctions readDBCFuncs transDir mScriptSession = do@@ -201,7 +201,7 @@ readDBCFunc transDir funcName mScriptSession precompiledFuncs = do #endif let dbcFuncPath = dbcFuncsDir transDir </> T.unpack funcName- (_funcType, mFuncScript) <- B.decodeFile @([AtomType], Maybe T.Text) dbcFuncPath+ (_funcType, mFuncScript) <- readFileDeserialise @([AtomType], Maybe T.Text) dbcFuncPath case mFuncScript of Nothing -> case databaseContextFunctionForName funcName precompiledFuncs of Left _ -> error ("expected precompiled dbc function: " ++ T.unpack funcName)@@ -225,7 +225,7 @@ writeIncDep :: DiskSync -> FilePath -> (IncDepName, InclusionDependency) -> IO () writeIncDep sync transDir (incDepName, incDep) = - writeBSFileSync sync (incDepsDir transDir </> T.unpack incDepName) $ B.encode incDep+ writeBSFileSync sync (incDepsDir transDir </> T.unpack incDepName) $ serialise incDep writeIncDeps :: DiskSync -> FilePath -> M.Map IncDepName InclusionDependency -> IO () writeIncDeps sync transDir incdeps = mapM_ (writeIncDep sync transDir) $ M.toList incdeps @@ -233,7 +233,7 @@ readIncDep :: FilePath -> IncDepName -> IO (IncDepName, InclusionDependency) readIncDep transDir incdepName = do let incDepPath = incDepsDir transDir </> T.unpack incdepName- incDepData <- B.decodeFile incDepPath+ incDepData <- readFileDeserialise incDepPath pure (incdepName, incDepData) readIncDeps :: FilePath -> IO (M.Map IncDepName InclusionDependency) @@ -245,20 +245,20 @@ readSubschemas :: FilePath -> IO Subschemas readSubschemas transDir = do let sschemasPath = subschemasPath transDir- B.decodeFile sschemasPath+ readFileDeserialise sschemasPath writeSubschemas :: DiskSync -> FilePath -> Subschemas -> IO () writeSubschemas sync transDir sschemas = do let sschemasPath = subschemasPath transDir- writeBSFileSync sync sschemasPath (B.encode sschemas)+ writeBSFileSync sync sschemasPath (serialise sschemas) writeTypeConstructorMapping :: DiskSync -> FilePath -> TypeConstructorMapping -> IO () writeTypeConstructorMapping sync path types = let atPath = typeConsPath path in- writeBSFileSync sync atPath $ B.encode types+ writeBSFileSync sync atPath $ serialise types readTypeConstructorMapping :: FilePath -> IO TypeConstructorMapping readTypeConstructorMapping path = do let atPath = typeConsPath path- B.decodeFile atPath+ readFileDeserialise atPath
src/lib/ProjectM36/TransactionGraph.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveAnyClass, DeriveGeneric, CPP, FlexibleContexts #-}+{-# LANGUAGE DeriveGeneric, CPP, FlexibleContexts, DerivingVia #-} module ProjectM36.TransactionGraph where import ProjectM36.Base import ProjectM36.Error@@ -13,6 +13,7 @@ import qualified ProjectM36.DisconnectedTransaction as Discon import qualified ProjectM36.Attribute as A +import Codec.Winery import Control.Monad.Except hiding (join) import Control.Monad.Reader hiding (join) import qualified Data.Vector as V@@ -23,7 +24,6 @@ import Data.Time.Clock import qualified Data.Text as T import GHC.Generics-import Data.Binary as B import Data.Either (lefts, rights, isRight) #if __GLASGOW_HASKELL__ < 804 import Data.Monoid@@ -38,13 +38,15 @@ -- | Record a lookup for a specific transaction in the graph. data TransactionIdLookup = TransactionIdLookup TransactionId | TransactionIdHeadNameLookup HeadName [TransactionIdHeadBacktrack]- deriving (Show, Eq, Binary, Generic)+ deriving (Show, Eq, Generic)+ deriving Serialise via WineryVariant TransactionIdLookup -- | Used for git-style head backtracking such as topic~3^2.-data TransactionIdHeadBacktrack = TransactionIdHeadParentBacktrack Int | -- ^ git equivalent of ~: walk back n parents, arbitrarily choosing a parent when a choice must be made+data TransactionIdHeadBacktrack = TransactionIdHeadParentBacktrack Int | -- ^ git equivalent of ~v: walk back n parents, arbitrarily choosing a parent when a choice must be made TransactionIdHeadBranchBacktrack Int | -- ^ git equivalent of ^: walk back one parent level to the nth arbitrarily-chosen parent TransactionStampHeadBacktrack UTCTime -- ^ git equivalent of 'git-rev-list -n 1 --before X' find the first transaction which was created before the timestamp- deriving (Show, Eq, Binary, Generic)+ deriving (Show, Eq, Generic)+ deriving Serialise via WineryVariant TransactionIdHeadBacktrack -- | Operators which manipulate a transaction graph and which transaction the current 'Session' is based upon.@@ -56,7 +58,8 @@ MergeTransactions MergeStrategy HeadName HeadName | Commit | Rollback- deriving (Eq, Show, Binary, Generic)+ deriving (Eq, Show, Generic)+ deriving Serialise via WineryVariant TransactionGraphOperator isCommit :: TransactionGraphOperator -> Bool isCommit Commit = True@@ -593,10 +596,9 @@ -- the new hash includes the parents' ids, the current id, and the hash of the context, and the merkle hashes of the parent transactions calculateMerkleHash :: Transaction -> TransactionGraph -> MerkleHash-calculateMerkleHash trans graph = MerkleHash $ hashlazy (mconcat [transIds,- dbcBytes,- schemasBytes,- parentMerkleHashes])+calculateMerkleHash trans graph = MerkleHash $ hashlazy (BL.fromChunks [transIds,+ schemasBytes+ ] <> dbcBytes <> parentMerkleHashes) where parentMerkleHashes = BL.fromChunks $ map (_unMerkleHash . getMerkleHash) parentTranses parentTranses =@@ -605,9 +607,9 @@ Left e -> error ("failed to find transaction in Merkle hash construction: " ++ show e) Right t -> S.toList t getMerkleHash t = merkleHash (transactionInfo t)- transIds = B.encode (transactionId trans : S.toList (parentIds trans))+ transIds = serialise (transactionId trans : S.toList (parentIds trans)) dbcBytes = DBC.hashBytes (concreteDatabaseContext trans)- schemasBytes = B.encode (subschemas trans)+ schemasBytes = serialise (subschemas trans) validateMerkleHash :: Transaction -> TransactionGraph -> Either MerkleValidationError () validateMerkleHash trans graph =
test/Relation/Atomable.hs view
@@ -1,8 +1,7 @@ --Test Atomable typeclass which allows users to use existing Haskell datatypes to marshal them to and from the database as ConstructedAtoms.-{-# LANGUAGE DeriveGeneric, DeriveAnyClass, OverloadedStrings, TypeApplications #-}+{-# LANGUAGE DeriveGeneric, DeriveAnyClass, OverloadedStrings, TypeApplications, DerivingVia #-} import Test.HUnit import ProjectM36.Client-import Data.Binary import Control.DeepSeq import System.Exit import TutorialD.Interpreter.TestBase@@ -13,52 +12,65 @@ import Data.Text import qualified Data.Map as M import Data.Proxy+import Codec.Winery {-# ANN module ("Hlint: ignore Use newtype instead of data" :: String) #-} data Test1T = Test1C Integer- deriving (Generic, Show, Eq, Binary, NFData, Atomable)+ deriving (Generic, Show, Eq, NFData, Atomable)+ deriving Serialise via WineryVariant Test1T data Test2T x = Test2C x- deriving (Show, Generic, Eq, Binary, NFData, Atomable)+ deriving (Show, Generic, Eq, NFData, Atomable)+ deriving Serialise via WineryVariant (Test2T x) data Test3T = Test3C Integer Integer - deriving (Show, Generic, Eq, Binary, NFData, Atomable)+ deriving (Show, Generic, Eq, NFData, Atomable)+ deriving Serialise via WineryVariant Test3T data Test4T = Test4Ca Integer | Test4Cb Integer - deriving (Show, Generic, Eq, Binary, NFData, Atomable)+ deriving (Show, Generic, Eq, NFData, Atomable)+ deriving Serialise via WineryVariant Test4T data TestListT = TestListC [Integer]- deriving (Show, Generic, Eq, Binary, NFData, Atomable)+ deriving (Show, Generic, Eq, NFData, Atomable)+ deriving Serialise via WineryVariant TestListT data TestNonEmptyT = TestNonEmptyC [Integer]- deriving (Show, Generic, Eq, Binary, NFData, Atomable)+ deriving (Show, Generic, Eq, NFData, Atomable)+ deriving Serialise via WineryVariant TestNonEmptyT data Test5T = Test5C { con1 :: Integer, con2 :: Integer- } deriving (Show, Generic, Eq, Binary, NFData, Atomable)+ } deriving (Show, Generic, Eq, NFData, Atomable)+ deriving Serialise via WineryRecord Test5T data Test6T = Test6C (Maybe Integer) - deriving (Show, Generic, Eq, Binary, NFData, Atomable)+ deriving (Show, Generic, Eq, NFData, Atomable)+ deriving Serialise via WineryVariant Test6T data Test7T = Test7C (Either Integer Integer)- deriving (Show, Generic, Eq, Binary, NFData, Atomable)+ deriving (Show, Generic, Eq, NFData, Atomable)+ deriving Serialise via WineryVariant Test7T data Test8T = Test8C Test1T- deriving (Show, Generic, Eq, Binary, NFData, Atomable)+ deriving (Show, Generic, Eq, NFData, Atomable)+ deriving Serialise via WineryVariant Test8T data User = User { userFirstName :: Text , userLastName :: Text- } deriving (Eq, Ord, Show, Generic, NFData, Binary, Atomable)+ } deriving (Eq, Ord, Show, Generic, NFData, Atomable)+ deriving Serialise via WineryRecord User data Test9_4T = Test9_4C { f9_41 :: Int, f9_42 :: Int, f9_43 :: Int, f9_44 :: Int }- deriving (Show, Generic, Eq, Binary, NFData, Atomable)+ deriving (Show, Generic, Eq, NFData, Atomable)+ deriving Serialise via WineryRecord Test9_4T data Test9_5T = Test9_5C { f9_51 :: Int,@@ -67,7 +79,8 @@ f9_54 :: Int, f9_55 :: Int }- deriving (Show, Generic, Eq, Binary, NFData, Atomable) + deriving (Show, Generic, Eq, NFData, Atomable)+ deriving Serialise via WineryRecord Test9_5T main :: IO () main = do
test/Relation/Tupleable.hs view
@@ -8,13 +8,13 @@ , DataKinds , TypeOperators , AllowAmbiguousTypes+ , DerivingVia #-} import Test.HUnit import ProjectM36.Tupleable.Deriving import ProjectM36.Atomable import ProjectM36.Attribute import ProjectM36.Error-import Data.Binary import ProjectM36.Base import Control.DeepSeq (NFData) import qualified Data.Vector as V@@ -23,6 +23,7 @@ import qualified Data.Set as S import System.Exit import Data.Proxy+import Codec.Winery {-# ANN module ("Hlint: ignore Use newtype instead of data" :: String) #-} @@ -30,35 +31,43 @@ attrA :: Integer } deriving (Generic, Eq, Show)+ deriving Serialise via WineryRecord Test1T data Test2T = Test2C { attrB :: Integer, attrC :: Integer } deriving (Generic, Eq, Show)+ deriving Serialise via WineryRecord Test2T data Test3T = Test3C Integer deriving (Generic, Eq, Show)+ deriving Serialise via WineryVariant Test3T data Test4T = Test4C deriving (Generic, Eq, Show)+ deriving Serialise via WineryVariant Test4T data Test5T = Test5C1 Integer | Test5C2 Integer deriving (Generic, Eq, Show)+ deriving Serialise via WineryVariant Test5T data Test6T = Test6C T.Text Integer Double deriving (Generic, Eq, Show) data Test7A = Test7AC Integer- deriving (Generic, Show, Eq, Binary, NFData, Atomable)+ deriving (Generic, Show, Eq, NFData, Atomable)+ deriving Serialise via WineryVariant Test7A data Test7T = Test7C Test7A deriving (Generic, Show, Eq)+ deriving Serialise via WineryVariant Test7T data Test8T = Test8C deriving (Generic, Show, Eq)+ deriving Serialise via WineryVariant Test8T data Test9T = Test9C { @@ -67,6 +76,7 @@ attr9C :: Double } deriving (Generic, Show, Eq)+ deriving Serialise via WineryRecord Test9T data Test10T = Test10C { longAttrNameA10 :: Integer,@@ -74,6 +84,7 @@ longMixed_attr_NameC10 :: Integer } deriving (Generic, Show, Eq)+ deriving Serialise via WineryRecord Test10T instance Tupleable Test1T
test/Server/Main.hs view
@@ -5,7 +5,6 @@ import Test.HUnit import ProjectM36.Client import qualified ProjectM36.Client as C-import ProjectM36.Server.EntryPoints import ProjectM36.Server import ProjectM36.Server.Config import ProjectM36.Relation@@ -14,16 +13,8 @@ import ProjectM36.Base import System.Exit-+import Network.Socket (SockAddr(..)) import Control.Concurrent-import Network.Transport (EndPointAddress)--#if MIN_VERSION_network_transport_tcp(0,6,0) -import Network.Transport.TCP.Internal (encodeEndPointAddress, decodeEndPointAddress)-#else-import Network.Transport.TCP (encodeEndPointAddress, decodeEndPointAddress)-#endif- import Data.Either (isRight) import Control.Exception import System.IO.Temp@@ -32,6 +23,10 @@ import System.Directory #endif +import Debug.Trace++type Timeout = Int+ testList :: SessionId -> Connection -> MVar () -> Test testList sessionId conn notificationTestMVar = TestList $ serverTests ++ sessionTests where@@ -69,11 +64,9 @@ testDatabaseName :: DatabaseName testDatabaseName = "test" -testConnection :: EndPointAddress -> MVar () -> IO (Either ConnectionError (SessionId, Connection))-testConnection serverAddress mvar = do- let Just (host, service, _) = decodeEndPointAddress serverAddress- serverAddress' = encodeEndPointAddress host service 1 - let connInfo = RemoteProcessConnectionInfo testDatabaseName (NodeId serverAddress') (testNotificationCallback mvar)+testConnection :: Port -> MVar () -> IO (Either ConnectionError (SessionId, Connection))+testConnection serverPort mvar = do+ let connInfo = RemoteConnectionInfo testDatabaseName "127.0.0.1" (show serverPort) (testNotificationCallback mvar) --putStrLn ("testConnection: " ++ show serverAddress) eConn <- connectProjectM36 connInfo case eConn of @@ -85,7 +78,7 @@ Right sessionId -> pure $ Right (sessionId, conn) -- | A version of 'launchServer' which returns the port on which the server is listening on a secondary thread-launchTestServer :: Timeout -> IO (EndPointAddress, ThreadId)+launchTestServer :: Timeout -> IO (Port, ThreadId) launchTestServer ti = do addressMVar <- newEmptyMVar tid <- forkIO $ @@ -99,9 +92,9 @@ } launchServer config (Just addressMVar) >> pure ()- endPointAddress <- takeMVar addressMVar+ (SockAddrInet port _) <- takeMVar addressMVar --liftIO $ putStrLn ("launched server on " ++ show endPointAddress)- pure (endPointAddress, tid)+ pure (fromIntegral port, tid) testRelationalExpr :: SessionId -> Connection -> Test testRelationalExpr sessionId conn = TestCase $ do@@ -216,8 +209,8 @@ case eTestConn of Left err -> putStrLn ("failed to connect: " ++ show err) >> exitFailure Right (session, testConn) -> do- res <- catchJust (\exc -> if exc == RequestTimeoutException then Just exc else Nothing) (callTestTimeout_ session testConn) (const (pure False))- assertBool "exception was not thrown" (not res)+ res <- catchJust (\exc -> if traceShowId exc == RequestTimeoutException then Just exc else Nothing) (callTestTimeout_ session testConn) (const (pure False))+ assertBool "timeout exception was not thrown" (not res) killThread serverTid testFileDescriptorCount :: Test
test/Server/WebSocket.hs view
@@ -18,13 +18,7 @@ import qualified Data.Map as M import qualified Data.ByteString.Lazy as BS import ProjectM36.Relation-#if MIN_VERSION_network_transport_tcp(0,6,0) -import Network.Transport.TCP.Internal (decodeEndPointAddress)-#else-import Network.Transport.TCP (decodeEndPointAddress)-#endif - --start the websocket server -- run some tutoriald against it @@ -37,12 +31,12 @@ testDatabaseName = "test" -- start normal server _ <- forkIO (launchServer config (Just addressMVar) >> pure ())- serverAddress <- takeMVar addressMVar+ (SockAddrInet dbPort _) <- takeMVar addressMVar let wsServerHost = "127.0.0.1" wsServerPort = 8889- Just (dbHost, dbPort, _) = decodeEndPointAddress serverAddress + dbHost = "127.0.0.1" -- start websocket server proxy -- runServer doesn't support returning an arbitrary socket- _ <- forkIO (WS.runServer wsServerHost wsServerPort (websocketProxyServer (read dbPort) dbHost))+ _ <- forkIO (WS.runServer wsServerHost wsServerPort (websocketProxyServer (fromIntegral dbPort) dbHost)) --wait for socket to be listening waitForListenSocket 5 (fromIntegral wsServerPort) pure (fromIntegral wsServerPort, testDatabaseName)
test/TutorialD/Interpreter.hs view
@@ -79,7 +79,9 @@ testInvalidDataConstructor, testBasicList, testRelationDeclarationMismatch,- testInvalidTuples+ testInvalidTuples,+ testSelfReferencingUncommittedContext,+ testUnionAndIntersectionAttributeExprs ] simpleRelTests :: Test@@ -120,7 +122,8 @@ ("x:=relation{tuple{a 5}} : {b:=6}", mkRelationFromTuples simpleDAttributes [RelationTuple simpleDAttributes (V.fromList [IntegerAtom 5, IntegerAtom 6])]), ("x:=relation{tuple{a 5}} : {b:=add(@a,5)}", mkRelationFromTuples simpleDAttributes [RelationTuple simpleDAttributes (V.fromList [IntegerAtom 5, IntegerAtom 10])]), ("x:=relation{tuple{a 5}} : {b:=add(@a,\"spam\")}", Left (AtomFunctionTypeError "add" 2 IntegerAtomType TextAtomType)),- ("x:=relation{tuple{a 5}} : {b:=add(add(@a,2),5)}", mkRelationFromTuples simpleDAttributes [RelationTuple simpleDAttributes (V.fromList [IntegerAtom 5, IntegerAtom 12])])+ ("x:=relation{tuple{a 5}} : {b:=add(add(@a,2),5)}", mkRelationFromTuples simpleDAttributes [RelationTuple simpleDAttributes (V.fromList [IntegerAtom 5, IntegerAtom 12])]),+ ("x:=false:{a:=1,b:=2}", mkRelationFromTuples simpleDAttributes []) ] simpleAAttributes = A.attributesFromList [Attribute "a" IntegerAtomType] simpleBAttributes = A.attributesFromList [Attribute "d" IntegerAtomType]@@ -230,7 +233,7 @@ commit sessionId dbconn >>= eitherFail discon <- disconnectedTransaction_ sessionId dbconn let context = Discon.concreteDatabaseContext discon- assertEqual "ensure x was added" (M.lookup "x" (relationVariables context)) (Just (RelationVariable "s" UncommittedContextMarker))+ assertEqual "ensure x was added" (M.lookup "x" (relationVariables context)) (Just (ExistingRelation suppliersRel)) transactionRollbackTest :: Test transactionRollbackTest = TestCase $ do@@ -700,3 +703,24 @@ expectTutorialDErr sessionId dbconn (T.isPrefixOf "AttributeNamesMismatchError") ":showexpr relation{tuple{a 1},tuple{b 2}}" expectTutorialDErr sessionId dbconn (T.isPrefixOf "AttributeNamesMismatchError") ":showexpr relation{tuple{a 1},tuple{a 2, b 3}}" -- expectTutorialDErr sessionId dbconn (T.isPrefixOf "ParseErrorBundle") ":showexpr relation{tuple{a 2, a 3}}" --parse failure can't be validated with this function++testSelfReferencingUncommittedContext :: Test+testSelfReferencingUncommittedContext = TestCase $ do+ (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback+ executeTutorialD sessionId dbconn "s:=s union s"+ eS <- executeRelationalExpr sessionId dbconn (RelationVariable "s" ())+ _ <- rollback sessionId dbconn+ eSorig <- executeRelationalExpr sessionId dbconn (RelationVariable "s" ()) + assertEqual "s=s'" eSorig eS++testUnionAndIntersectionAttributeExprs :: Test+testUnionAndIntersectionAttributeExprs = TestCase $ do+ (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback+ executeTutorialD sessionId dbconn "x:=s{intersection of {all but sname} {sname}}"+ xRel <- executeRelationalExpr sessionId dbconn (RelationVariable "x" ())+ assertEqual "intersection attrs" (Right relationTrue) xRel++ executeTutorialD sessionId dbconn "y:=s{union of {all but sname} {sname}}"+ yRel <- executeRelationalExpr sessionId dbconn (RelationVariable "y" ())+ assertEqual "union attrs" (Right suppliersRel) yRel+
+ test/TutorialD/Printer.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE OverloadedStrings #-}+import Test.HUnit+import ProjectM36.Base+import System.Exit+import Data.Text.Prettyprint.Doc+import Data.Map (fromList)+import TutorialD.Printer ()+import TutorialD.Interpreter.RelationalExpr+import Text.Megaparsec+import Data.Text (pack)++testList :: Test+testList = TestList [+ testPretty "true" (RelationVariable "true" ()),+ testPretty "relation{tuple{a 3, b \"x\"}, tuple{a 4, b \"y\"}}" (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (fromList [("a",NakedAtomExpr (IntegerAtom 3)),("b",NakedAtomExpr (TextAtom "x"))]),TupleExpr (fromList [("a",NakedAtomExpr (IntegerAtom 4)),("b",NakedAtomExpr (TextAtom "y"))])])),+ testPretty "true:{a:=1, b:=1}" (Extend (AttributeExtendTupleExpr "b" (NakedAtomExpr (IntegerAtom 1))) (Extend (AttributeExtendTupleExpr "a" (NakedAtomExpr (IntegerAtom 1))) (RelationVariable "true" ()))),+ testPretty "relation{tuple{a fromGregorian(2014, 2, 4)}}" (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (fromList [("a",FunctionAtomExpr "fromGregorian" [NakedAtomExpr (IntegerAtom 2014),NakedAtomExpr (IntegerAtom 2),NakedAtomExpr (IntegerAtom 4)] ())])])),+ testPretty "relation{tuple{a bytestring(\"dGVzdGRhdGE=\")}}" (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (fromList [("a",FunctionAtomExpr "bytestring" [NakedAtomExpr (TextAtom "dGVzdGRhdGE=")] ())])])),+ testPretty "relation{tuple{a t}}" (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (fromList [("a",NakedAtomExpr (BoolAtom True))])])),+ testPretty "relation{tuple{a Cons 4 (Cons 5 Empty)}}" (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (fromList [("a",ConstructedAtomExpr "Cons" [NakedAtomExpr (IntegerAtom 4),ConstructedAtomExpr "Cons" [NakedAtomExpr (IntegerAtom 5),ConstructedAtomExpr "Empty" [] ()] ()] ())])])),+ testPretty "relation{a Int, b Text, c Bool}{}" (MakeRelationFromExprs (Just [AttributeAndTypeNameExpr "a" (ADTypeConstructor "Int" []) (),AttributeAndTypeNameExpr "b" (ADTypeConstructor "Text" []) (),AttributeAndTypeNameExpr "c" (ADTypeConstructor "Bool" []) ()]) (TupleExprs () [])),+ testPretty "relation{a relation{b Int}}{}" (MakeRelationFromExprs (Just [AttributeAndTypeNameExpr "a" (RelationAtomTypeConstructor [AttributeAndTypeNameExpr "b" (ADTypeConstructor "Int" []) ()]) ()]) (TupleExprs () []))+ ]++main :: IO () +main = do + tcounts <- runTestTT testList+ if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess++testPretty :: String -> RelationalExpr -> Test+testPretty tutdStr relExprADT =+ TestCase $ do+ let relExprStr = show (pretty relExprADT)+ print relExprStr+ roundTrip <- parseRelExpr relExprStr+ {-tutdIn <- parseRelExpr tutdStr+ print ("tutd parsed", tutdIn)-}+ assertEqual ("pretty ADT " <> tutdStr) tutdStr relExprStr+ assertEqual ("round-trip " <> tutdStr) relExprADT roundTrip++--round trip tutoriald+parseRelExpr :: String -> IO RelationalExpr+parseRelExpr tutdStr =+ case parse relExprP "test" (pack tutdStr) of+ Left err ->+ assertFailure (show err)+ Right parsed -> pure parsed