├── jupyter ├── itutd │ ├── __init__.py │ └── __main__.py ├── kernel.json └── setup.py ├── shell.nix ├── default.nix ├── src ├── lib │ └── ProjectM36 │ │ ├── Serialise │ │ ├── MergeError.hs │ │ ├── AtomFunctionError.hs │ │ ├── IsomorphicSchema.hs │ │ ├── DatabaseContextFunctionError.hs │ │ ├── DataFrame.hs │ │ └── Error.hs │ │ ├── Server │ │ ├── EntryPoints │ │ │ └── Json.hs │ │ └── Config.hs │ │ ├── Relation │ │ ├── Representation.hs │ │ └── Show │ │ │ ├── CSV.hs │ │ │ └── HTML.hs │ │ ├── AtomFunctionUtils.hs │ │ ├── Transaction │ │ └── Type.hs │ │ ├── AtomFunctionBody.hs │ │ ├── AttributeExpr.hs │ │ ├── TransactionDiffs.hs │ │ ├── MerkleHash.hs │ │ ├── Trace.hs │ │ ├── DatabaseContextFunctionError.hs │ │ ├── SQL │ │ ├── DropTable.hs │ │ ├── Delete.hs │ │ ├── Insert.hs │ │ ├── Update.hs │ │ ├── DBUpdate.hs │ │ └── CreateTable.hs │ │ ├── MiscUtils.hs │ │ ├── TransactionInfo.hs │ │ ├── TypeConstructorDef.hs │ │ ├── TransactionGraph │ │ ├── Types.hs │ │ ├── Show.hs │ │ └── Show │ │ │ └── Dot.hs │ │ ├── TypeConstructor.hs │ │ ├── SQLDatabaseContext.hs │ │ ├── RegisteredQuery.hs │ │ ├── DataConstructorDef.hs │ │ ├── DataTypes │ │ ├── Basic.hs │ │ ├── ByteString.hs │ │ ├── DateTime.hs │ │ ├── Either.hs │ │ ├── Day.hs │ │ ├── Sorting.hs │ │ ├── Maybe.hs │ │ ├── Primitive.hs │ │ ├── NonEmptyList.hs │ │ └── List.hs │ │ ├── DatabaseContextFunctionUtils.hs │ │ ├── AtomFunctionError.hs │ │ ├── DisconnectedTransaction.hs │ │ ├── AttributeNames.hs │ │ ├── Notifications.hs │ │ ├── FunctionalDependency.hs │ │ ├── InclusionDependency.hs │ │ ├── AtomFunctions │ │ └── Basic.hs │ │ ├── TupleSet.hs │ │ ├── Sessions.hs │ │ ├── Atom.hs │ │ ├── Session.hs │ │ ├── GraphRefRelationalExpr.hs │ │ ├── Transaction.hs │ │ ├── Function.hs │ │ ├── DatabaseContext.hs │ │ ├── Win32Handle.hs │ │ ├── DDLType.hs │ │ ├── FileLock.hs │ │ ├── DatabaseContextFunction.hs │ │ └── Key.hs └── bin │ ├── ProjectM36 │ ├── Server │ │ ├── WebSocket │ │ │ ├── websocket-config.js │ │ │ └── websocket-server.hs │ │ └── project-m36-server.hs │ ├── Client │ │ └── Json.hs │ └── Interpreter.hs │ ├── SQL │ └── Interpreter │ │ ├── Info.hs │ │ ├── DropTable.hs │ │ ├── ImportBasicExample.hs │ │ ├── Insert.hs │ │ ├── Delete.hs │ │ ├── DBUpdate.hs │ │ ├── TransactionGraphOperator.hs │ │ ├── Update.hs │ │ ├── sqlegacy.hs │ │ ├── CreateTable.hs │ │ └── Base.hs │ ├── TutorialD │ ├── Interpreter │ │ ├── Export │ │ │ ├── Base.hs │ │ │ └── CSV.hs │ │ ├── Import │ │ │ ├── BasicExamples.hs │ │ │ ├── CSV.hs │ │ │ └── Base.hs │ │ ├── TransGraphRelationalOperator.hs │ │ ├── DatabaseContextIOOperator.hs │ │ ├── SchemaOperator.hs │ │ └── InformationOperator.hs │ └── tutd.hs │ └── benchmark │ ├── Relation.hs │ ├── OnDiskClient.hs │ └── Server.hs ├── scripts ├── multiline.tutd ├── cjdate.sql └── DateExamples.tutd ├── runghcid.sh ├── test ├── TutorialD │ ├── Interpreter │ │ └── Import │ │ │ ├── httpimporttest.tutd │ │ │ └── ImportTest.hs │ └── PrinterTest.hs ├── scripts.hs ├── Relation │ └── Import │ │ └── CSV.hs ├── MultiProcessDatabaseAccess.hs ├── DataFrame.hs └── Client │ └── Simple.hs ├── h2svg.sh ├── install_tools.sh ├── hp2svg.sh ├── docs ├── initial_database_state.dot ├── committed_database_state.dot ├── index.markdown ├── websocket_server.markdown ├── dev_setup.markdown ├── javascript_driver.markdown ├── sqlegacy.markdown ├── server_mode.markdown ├── simple_api.markdown ├── jupyter_kernel.markdown ├── dataframes.markdown ├── projectm36_client_library.markdown ├── acid_assessment.markdown ├── import_export_csv.markdown ├── merkle_transaction_graph.markdown └── replication.markdown ├── .vscode └── settings.json ├── .gitignore ├── .appveyor └── preload_certs.ps ├── cbits ├── darwin_statfs.c └── DirectoryFsync.c ├── stack.ghc9.4.yaml ├── stack.ghc9.2.yaml ├── docker.nix ├── examples ├── DynamicAtomFunctions.hs ├── DynamicDatabaseContextFunctions.hs ├── DerivingCustomTupleable.hs ├── hair.hs ├── SimpleClient.hs ├── Hospital.hs └── CustomTupleable.hs ├── LICENSE ├── .appveyor.yml ├── cabal.project ├── nix └── sources.json ├── sql_optimizations_applied ├── release.nix └── .github └── workflows └── ci.yaml /jupyter/itutd/__init__.py: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | (import ./release.nix { }).shell -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | (import ./release.nix { }).project -------------------------------------------------------------------------------- /src/lib/ProjectM36/Serialise/MergeError.hs: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/Server/EntryPoints/Json.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /scripts/multiline.tutd: -------------------------------------------------------------------------------- 1 | x:=relation{ 2 | tuple{ x 2}} -- nice 3 | -------------------------------------------------------------------------------- /runghcid.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | ~/.cabal/bin/ghcid --command="cabal new-repl $1" 3 | -------------------------------------------------------------------------------- /test/TutorialD/Interpreter/Import/httpimporttest.tutd: -------------------------------------------------------------------------------- 1 | x:=true; 2 | y:=false; -------------------------------------------------------------------------------- /h2svg.sh: -------------------------------------------------------------------------------- 1 | ./.cabal-sandbox/bin/ghc-prof-flamegraph < bigrel.prof | perl ~/Dev/flamegraph.pl -------------------------------------------------------------------------------- /install_tools.sh: -------------------------------------------------------------------------------- 1 | cabal install --enable-profiling --enable-tests 2 | cabal install ghc-prof-flamegraph 3 | cabal install hp2pretty -------------------------------------------------------------------------------- /src/lib/ProjectM36/Relation/Representation.hs: -------------------------------------------------------------------------------- 1 | module ProjectM36.Relation.Representation where 2 | import ProjectM36.Base 3 | 4 | 5 | -------------------------------------------------------------------------------- /hp2svg.sh: -------------------------------------------------------------------------------- 1 | cabal run bigrel -- --attribute-count 10 --tuple-count 10000 -d "x:=x" +RTS -h > /dev/null 2 | ./.cabal-sandbox/bin/hp2pretty bigrel.hp 3 | -------------------------------------------------------------------------------- /docs/initial_database_state.dot: -------------------------------------------------------------------------------- 1 | digraph G { 2 | base[label="base transaction",shape=rectangle]; 3 | new[label="mutable database context"]; 4 | new -> base; 5 | } -------------------------------------------------------------------------------- /jupyter/itutd/__main__.py: -------------------------------------------------------------------------------- 1 | from ipykernel.kernelapp import IPKernelApp 2 | from . import ITutorialDKernel 3 | 4 | IPKernelApp.launch_instance(kernel_class=ITutorialDKernel) 5 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/AtomFunctionUtils.hs: -------------------------------------------------------------------------------- 1 | --convenience functions useful from with AtomFunctions 2 | module ProjectM36.AtomFunctionUtils where 3 | import ProjectM36.Base 4 | 5 | -------------------------------------------------------------------------------- /jupyter/kernel.json: -------------------------------------------------------------------------------- 1 | { 2 | "language":"TutorialD", 3 | "display_name":"TutorialD (Project:M36)", 4 | "argv":["python", "-m", "itutd.ITutorialDKernel", "-f", "{connection_file}"] 5 | } -------------------------------------------------------------------------------- /.vscode/settings.json: -------------------------------------------------------------------------------- 1 | { 2 | "files.exclude": { 3 | ".stack-work": true, 4 | "**/*.hi": true, 5 | "**/*~": true, 6 | "**/#*#": true, 7 | "dist-newstyle": true 8 | } 9 | } -------------------------------------------------------------------------------- /src/bin/ProjectM36/Server/WebSocket/websocket-config.js: -------------------------------------------------------------------------------- 1 | var defaultConfig = { 'protocol': 'ws', 2 | 'host': 'localhost', 3 | 'port': '8000', 4 | 'path': 'ws/', 5 | 'dbname': 'test' } 6 | -------------------------------------------------------------------------------- /docs/committed_database_state.dot: -------------------------------------------------------------------------------- 1 | digraph G { 2 | base[label="base transaction",shape=rectangle]; 3 | discon[label="mutable database context"]; 4 | fresh[label="newly committed transaction",shape=rectangle]; 5 | fresh -> base; 6 | discon -> fresh; 7 | } -------------------------------------------------------------------------------- /src/lib/ProjectM36/Transaction/Type.hs: -------------------------------------------------------------------------------- 1 | module ProjectM36.Transaction where 2 | import ProjectM36.Base 3 | 4 | uid :: Transaction -> TransactionId 5 | uid (Transaction uid _ _) = uid 6 | 7 | info :: Transaction -> TransactionInfo 8 | info (Transaction _ info _) = info 9 | -------------------------------------------------------------------------------- /src/bin/SQL/Interpreter/Info.hs: -------------------------------------------------------------------------------- 1 | module SQL.Interpreter.Info where 2 | import ProjectM36.Interpreter 3 | import SQL.Interpreter.Base 4 | import Data.Functor 5 | 6 | data InfoOperator = HelpOperator deriving Show 7 | 8 | infoP :: Parser InfoOperator 9 | infoP = reserved "help" $> HelpOperator 10 | -------------------------------------------------------------------------------- /src/bin/ProjectM36/Server/project-m36-server.hs: -------------------------------------------------------------------------------- 1 | import ProjectM36.Server 2 | import ProjectM36.Server.ParseArgs 3 | import System.Exit (exitSuccess, exitFailure) 4 | 5 | main :: IO () 6 | main = do 7 | serverConfig <- parseConfig 8 | ret <- launchServer serverConfig Nothing 9 | if ret then exitSuccess else exitFailure -------------------------------------------------------------------------------- /src/lib/ProjectM36/AtomFunctionBody.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | --tools to execute an atom function body 3 | module ProjectM36.AtomFunctionBody where 4 | import ProjectM36.Base 5 | 6 | compiledAtomFunctionBody :: AtomFunctionBodyType -> AtomFunctionBody 7 | compiledAtomFunctionBody = FunctionBuiltInBody 8 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/AttributeExpr.hs: -------------------------------------------------------------------------------- 1 | module ProjectM36.AttributeExpr where 2 | import ProjectM36.Base 3 | import ProjectM36.Attribute as A 4 | 5 | attributeName :: AttributeExprBase a -> AttributeName 6 | attributeName (AttributeAndTypeNameExpr nam _ _) = nam 7 | attributeName (NakedAttributeExpr attr) = A.attributeName attr -------------------------------------------------------------------------------- /src/bin/SQL/Interpreter/DropTable.hs: -------------------------------------------------------------------------------- 1 | module SQL.Interpreter.DropTable where 2 | import ProjectM36.SQL.DropTable 3 | import SQL.Interpreter.Select 4 | import SQL.Interpreter.Base 5 | import ProjectM36.Interpreter 6 | 7 | dropTableP :: Parser DropTable 8 | dropTableP = do 9 | reserveds "drop table" 10 | DropTable <$> tableNameP 11 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/Serialise/AtomFunctionError.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia, StandaloneDeriving #-} 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | module ProjectM36.Serialise.AtomFunctionError where 4 | import Codec.Winery 5 | import ProjectM36.AtomFunctionError 6 | 7 | deriving via WineryVariant AtomFunctionError instance Serialise AtomFunctionError 8 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/Serialise/IsomorphicSchema.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StandaloneDeriving, DerivingVia, TypeSynonymInstances, ScopedTypeVariables #-} 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | module ProjectM36.Serialise.IsomorphicSchema where 4 | import Codec.Winery 5 | import ProjectM36.IsomorphicSchema 6 | 7 | deriving via WineryVariant SchemaExpr instance Serialise SchemaExpr 8 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/TransactionDiffs.hs: -------------------------------------------------------------------------------- 1 | module ProjectM36.TransactionDiffs where 2 | import ProjectM36.Base 3 | import Data.List.NonEmpty 4 | import Data.UUID as U 5 | 6 | {- 7 | root :: TransactionDiffs 8 | root = single U.nil NoOperation 9 | 10 | single :: TransactionId -> TransactionDiffExpr -> TransactionDiffs 11 | single tid expr = (tid, expr) :| [] 12 | -} 13 | -------------------------------------------------------------------------------- /docs/index.markdown: -------------------------------------------------------------------------------- 1 | # Contents 2 | 1. [Introduction to the Relational Algebra](introduction_to_the_relational_algebra.markdown) 3 | 1. [Introduction to ProjectM36](introduction_to_projectm36.markdown) 4 | 1. [TutorialD Tutorial](tutd_tutorial.markdown) 5 | 1. [Transaction Graph Operators](transaction_graph_operators.markdown) 6 | 1. [ProjectM36.Client Library](projectm36_client_library.markdown) -------------------------------------------------------------------------------- /src/lib/ProjectM36/Serialise/DatabaseContextFunctionError.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia, StandaloneDeriving #-} 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | module ProjectM36.Serialise.DatabaseContextFunctionError where 4 | import Codec.Winery 5 | import ProjectM36.DatabaseContextFunctionError 6 | 7 | deriving via WineryVariant DatabaseContextFunctionError instance Serialise DatabaseContextFunctionError 8 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | *.hi 3 | *~ 4 | dist/ 5 | .cabal-sandbox/ 6 | cabal.sandbox.config 7 | .stack-work 8 | dist-newstyle/ 9 | dist_build/ 10 | NOTES 11 | RelatedPapers/ 12 | _shake 13 | nextsteps 14 | \#*\# 15 | .\#* 16 | view-system-notes 17 | persistence-notes 18 | *.pyc 19 | jupyter/itutd.egg-info 20 | jupyter/build 21 | juyter/dist 22 | .ipynb_checkpoints 23 | project-m36.nix 24 | stack.yaml 25 | release.nix 26 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/MerkleHash.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveGeneric, DerivingVia #-} 2 | module ProjectM36.MerkleHash where 3 | import Data.ByteString (ByteString) 4 | import GHC.Generics 5 | import Control.DeepSeq (NFData) 6 | 7 | newtype MerkleHash = MerkleHash { _unMerkleHash :: ByteString } 8 | deriving (Show, Eq, Generic, Monoid, Semigroup, NFData) 9 | 10 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/Trace.hs: -------------------------------------------------------------------------------- 1 | module ProjectM36.Trace where 2 | import Debug.Trace (traceEventIO) 3 | -- utility module to enable easy enabling/disabling of eventlog data 4 | 5 | -- | Utility function for tracing with ghc-events-analyze using START and STOP markers 6 | traceBlock :: String -> IO () -> IO () 7 | traceBlock label m = do 8 | traceEventIO ("START " <> label) 9 | m 10 | traceEventIO ("STOP " <> label) 11 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/DatabaseContextFunctionError.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} 2 | module ProjectM36.DatabaseContextFunctionError where 3 | import GHC.Generics 4 | import Control.DeepSeq 5 | 6 | {-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-} 7 | data DatabaseContextFunctionError = DatabaseContextFunctionUserError String 8 | deriving (Generic, Eq, Show, NFData) 9 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/SQL/DropTable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric, DerivingVia, DeriveAnyClass #-} 2 | module ProjectM36.SQL.DropTable where 3 | import ProjectM36.SQL.Select 4 | import Control.DeepSeq 5 | import Codec.Winery 6 | import GHC.Generics 7 | 8 | newtype DropTable = DropTable 9 | { target :: TableName } 10 | deriving (Show, Eq, Generic, NFData) 11 | deriving Serialise via WineryRecord DropTable 12 | 13 | 14 | 15 | -------------------------------------------------------------------------------- /.appveyor/preload_certs.ps: -------------------------------------------------------------------------------- 1 | # Windows won't have these certificate CAs preloaded, so we have to do it by accessing hackage 2 | # https://stackoverflow.com/questions/32654493/stack-haskell-throws-tlsexception-in-windows 3 | $tls_urls = @("https://github.com", "https://www.hackage.org", "https://stackage.haskell.org", "https://s3.amazonaws.com") 4 | $tls_urls |` 5 | ForEach-Object { 6 | Invoke-WebRequest -Uri $_ -UseBasicParsing | out-null 7 | } 8 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/MiscUtils.hs: -------------------------------------------------------------------------------- 1 | module ProjectM36.MiscUtils where 2 | 3 | --returns duplicates of a pre-sorted list 4 | dupes :: Eq a => [a] -> [a] 5 | dupes [] = [] 6 | dupes [_] = [] 7 | dupes [x,y] = [x | x == y] 8 | dupes (x:y:xs) = dupes(x:[y]) ++ dupes(y : xs) 9 | 10 | --Data.Vector.indexed but for lists 11 | indexed :: [a] -> [(Int, a)] 12 | indexed = go 0 13 | where 14 | go _ [] = [] 15 | go i (v:ys) = (i,v):go (i+1) ys 16 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/TransactionInfo.hs: -------------------------------------------------------------------------------- 1 | module ProjectM36.TransactionInfo where 2 | import ProjectM36.Base 3 | import Data.Time.Clock 4 | import qualified Data.List.NonEmpty as NE 5 | 6 | -- | Create a TransactionInfo with just one parent transaction ID. 7 | singleParent :: TransactionId -> UTCTime -> TransactionInfo 8 | singleParent tid stamp' = TransactionInfo { 9 | parents = tid NE.:| [], 10 | stamp = stamp', 11 | merkleHash = mempty } 12 | 13 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/TypeConstructorDef.hs: -------------------------------------------------------------------------------- 1 | module ProjectM36.TypeConstructorDef where 2 | import ProjectM36.Base 3 | 4 | name :: TypeConstructorDef -> TypeConstructorName 5 | name (ADTypeConstructorDef nam _) = nam 6 | name (PrimitiveTypeConstructorDef nam _) = nam 7 | 8 | typeVars :: TypeConstructorDef -> [TypeVarName] 9 | typeVars (PrimitiveTypeConstructorDef _ _) = [] 10 | typeVars (ADTypeConstructorDef _ args) = args 11 | 12 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/SQL/Delete.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric, DerivingVia, DeriveAnyClass #-} 2 | module ProjectM36.SQL.Delete where 3 | import ProjectM36.SQL.Select 4 | import Control.DeepSeq 5 | import Codec.Winery 6 | import GHC.Generics 7 | 8 | data Delete = Delete { target :: TableName, 9 | restriction :: RestrictionExpr 10 | } 11 | deriving (Show, Eq, Generic, NFData) 12 | deriving Serialise via WineryRecord Delete 13 | -------------------------------------------------------------------------------- /src/bin/SQL/Interpreter/ImportBasicExample.hs: -------------------------------------------------------------------------------- 1 | module SQL.Interpreter.ImportBasicExample where 2 | import qualified Data.Text as T 3 | import SQL.Interpreter.Base 4 | import ProjectM36.Interpreter 5 | 6 | newtype ImportBasicExampleOperator = ImportBasicExampleOperator T.Text 7 | deriving (Show) 8 | 9 | importBasicExampleP :: Parser ImportBasicExampleOperator 10 | importBasicExampleP = do 11 | reserveds "IMPORT EXAMPLE CJDATE" 12 | pure (ImportBasicExampleOperator "cjdate") 13 | -------------------------------------------------------------------------------- /cbits/darwin_statfs.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | #ifndef _PROJECT_M36_STATFS_ 6 | #define _PROJECT_M36_STATFS_ 7 | #ifdef __APPLE__ 8 | int cDarwinFSJournaled(const char* path) 9 | { 10 | struct statfs s = {0}; 11 | int ret = statfs(path, &s); 12 | if(ret < 0) 13 | { 14 | /* error */ 15 | return ret; 16 | } 17 | else 18 | { 19 | return s.f_flags & MNT_JOURNALED; 20 | } 21 | } 22 | #endif 23 | #endif 24 | -------------------------------------------------------------------------------- /src/bin/SQL/Interpreter/Insert.hs: -------------------------------------------------------------------------------- 1 | module SQL.Interpreter.Insert where 2 | import SQL.Interpreter.Select 3 | import ProjectM36.SQL.Insert 4 | import SQL.Interpreter.Base 5 | import ProjectM36.Interpreter 6 | 7 | insertP :: Parser Insert 8 | insertP = do 9 | reserveds "insert into" 10 | tname <- tableNameP 11 | colNames <- parens (sepByComma1 unqualifiedColumnNameP) 12 | q <- queryP 13 | pure (Insert { target = tname, 14 | targetColumns = colNames, 15 | source = q }) 16 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/TransactionGraph/Types.hs: -------------------------------------------------------------------------------- 1 | module ProjectM36.TransactionGraph.Types where 2 | import ProjectM36.Base 3 | 4 | transactions :: TransactionGraph -> S.Set Transaction 5 | transactions (TransactionGraph _ t) = t 6 | 7 | transactionHeads :: TransactionGraph -> TransactionHeads 8 | transactionHeads (TransactionGraph heads _) = heads 9 | 10 | transactionInfoDiffs :: TransactionInfo -> TransactionDiffs 11 | transactionInfoDiffs (TransactionInfo _ d _) = d 12 | transactionInfoDiffs (MergeTransactionInfo _ _ d _ ) = d 13 | -------------------------------------------------------------------------------- /src/bin/SQL/Interpreter/Delete.hs: -------------------------------------------------------------------------------- 1 | module SQL.Interpreter.Delete where 2 | import SQL.Interpreter.Select 3 | import ProjectM36.SQL.Delete 4 | import ProjectM36.SQL.Select 5 | import SQL.Interpreter.Base 6 | import ProjectM36.Interpreter 7 | import Control.Applicative 8 | 9 | deleteP :: Parser Delete 10 | deleteP = do 11 | reserveds "delete from" 12 | tname <- tableNameP 13 | restrictExpr <- whereP <|> pure (RestrictionExpr (BooleanLiteral True)) 14 | pure $ Delete { target = tname, 15 | restriction = restrictExpr } 16 | -------------------------------------------------------------------------------- /stack.ghc9.4.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-21.0 2 | packages: 3 | - "." 4 | 5 | extra-deps: 6 | - streamly-0.10.1 7 | - streamly-core-0.2.2 8 | - streamly-bytestring-0.2.2 9 | - curryer-rpc-0.4.0 10 | - fast-builder-0.1.4.0 11 | - rset-1.0.0 12 | - winery-1.4 13 | - barbies-th-0.1.11 14 | - base16-bytestring-1.0.2.0 15 | - unicode-data-0.2.0 16 | - stm-containers-1.2 17 | - stm-hamt-1.2.0.7 18 | - scotty-0.22 19 | - wai-extra-3.1.14 20 | - wai-3.2.4 21 | 22 | flags: 23 | project-m36: 24 | stack: true 25 | allow-newer: true 26 | -------------------------------------------------------------------------------- /stack.ghc9.2.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-20.26 2 | packages: 3 | - "." 4 | 5 | extra-deps: 6 | - streamly-0.10.1 7 | - streamly-core-0.2.2 8 | - streamly-bytestring-0.2.2 9 | - curryer-rpc-0.4.0 10 | - fast-builder-0.1.4.0 11 | - rset-1.0.0 12 | - winery-1.4 13 | - barbies-th-0.1.11 14 | - base16-bytestring-1.0.2.0 15 | - unicode-data-0.2.0 16 | - stm-containers-1.2 17 | - stm-hamt-1.2.0.7 18 | - scotty-0.22 19 | - wai-extra-3.1.14 20 | - wai-3.2.4 21 | 22 | flags: 23 | project-m36: 24 | stack: true 25 | allow-newer: true 26 | -------------------------------------------------------------------------------- /src/bin/ProjectM36/Client/Json.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | module ProjectM36.Client.Json where 3 | import Data.Aeson 4 | import ProjectM36.Server.RemoteCallTypes.Json () 5 | import ProjectM36.Client 6 | import ProjectM36.TransactionGraph 7 | import Control.Exception (IOException) 8 | 9 | instance ToJSON EvaluatedNotification 10 | instance FromJSON EvaluatedNotification 11 | 12 | instance ToJSON ConnectionError 13 | 14 | instance ToJSON IOException where 15 | toJSON err = object ["IOException" .= show err] 16 | 17 | instance ToJSON MerkleValidationError 18 | -------------------------------------------------------------------------------- /docker.nix: -------------------------------------------------------------------------------- 1 | { compiler ? "ghc928" 2 | , sources ? import ./nix/sources.nix 3 | , pkgs ? import sources.nixpkgs { } 4 | }: 5 | let 6 | release = import ./release.nix { inherit pkgs compiler sources; }; 7 | static-project-m36 = pkgs.haskell.lib.dontCheck (pkgs.haskell.lib.justStaticExecutables release.project); 8 | in 9 | pkgs.dockerTools.buildImage { 10 | name = "project-m36"; 11 | tag = "latest"; 12 | copyToRoot = [ static-project-m36 ]; 13 | # expose default project-m36 and websocket server ports 14 | config = { 15 | Env = [ "LC_ALL=en_US.UTF-8" ]; 16 | ExposedPorts = { "6543/tcp" = { }; "8000/tcp" = { }; }; 17 | }; 18 | } 19 | -------------------------------------------------------------------------------- /jupyter/setup.py: -------------------------------------------------------------------------------- 1 | from setuptools import setup 2 | 3 | setup( 4 | name='itutd', 5 | version='0.1', 6 | packages=['itutd'], 7 | description='TutorialD Jupyter kernel for Project:M36', 8 | author='AgentM', 9 | author_email='agentm@themactionfaction.com', 10 | url='https://github.com/agentm/project-m36/jupyter/', 11 | install_requires=[ 12 | 'jupyter_client', 'IPython', 'ipykernel', 'websocket-client' 13 | ], 14 | classifiers=[ 15 | 'Intended Audience :: Developers', 16 | 'License :: OSI Approved :: Public Domain', 17 | 'Programming Language :: Python :: 2', 18 | ], 19 | ) 20 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/SQL/Insert.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric, DerivingVia, DeriveAnyClass #-} 2 | module ProjectM36.SQL.Insert where 3 | import ProjectM36.SQL.Select 4 | import ProjectM36.Serialise.Base () 5 | import Control.DeepSeq 6 | import Codec.Winery 7 | import GHC.Generics 8 | 9 | data Insert = Insert 10 | { target :: TableName, 11 | targetColumns :: [UnqualifiedColumnName], -- because ProjectM36 does not support default values in columns, all columns from the underlying table must be included here 12 | source :: Query 13 | } 14 | deriving (Show, Eq, Generic, NFData) 15 | deriving Serialise via WineryRecord Insert 16 | 17 | -------------------------------------------------------------------------------- /src/bin/SQL/Interpreter/DBUpdate.hs: -------------------------------------------------------------------------------- 1 | module SQL.Interpreter.DBUpdate where 2 | import ProjectM36.Interpreter 3 | import ProjectM36.SQL.DBUpdate 4 | import SQL.Interpreter.Update 5 | import SQL.Interpreter.Insert 6 | import SQL.Interpreter.Delete 7 | import SQL.Interpreter.CreateTable 8 | import SQL.Interpreter.DropTable 9 | import Text.Megaparsec 10 | 11 | dbUpdatesP :: Parser [DBUpdate] 12 | dbUpdatesP = some dbUpdateP 13 | 14 | dbUpdateP :: Parser DBUpdate 15 | dbUpdateP = (UpdateUpdate <$> updateP) <|> 16 | (UpdateInsert <$> insertP) <|> 17 | (UpdateDelete <$> deleteP) <|> 18 | (UpdateCreateTable <$> createTableP) <|> 19 | (UpdateDropTable <$> dropTableP) 20 | 21 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/Serialise/DataFrame.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia, StandaloneDeriving #-} 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | module ProjectM36.Serialise.DataFrame where 4 | import Codec.Winery 5 | import ProjectM36.DataFrame 6 | import ProjectM36.Serialise.Base () 7 | 8 | deriving via WineryVariant AttributeOrderExpr instance Serialise AttributeOrderExpr 9 | deriving via WineryVariant AttributeOrder instance Serialise AttributeOrder 10 | deriving via WineryVariant Order instance Serialise Order 11 | deriving via WineryRecord DataFrame instance Serialise DataFrame 12 | deriving via WineryVariant DataFrameTuple instance Serialise DataFrameTuple 13 | deriving via WineryRecord DataFrameExpr instance Serialise DataFrameExpr 14 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/TypeConstructor.hs: -------------------------------------------------------------------------------- 1 | module ProjectM36.TypeConstructor where 2 | import ProjectM36.Base 3 | 4 | name :: TypeConstructor -> TypeConstructorName 5 | name (ADTypeConstructor name' _) = name' 6 | name (PrimitiveTypeConstructor name' _) = name' 7 | name (RelationAtomTypeConstructor _) = error "name called on RelationAtomTypeConstructor" 8 | name (TypeVariable _) = error "name called on TypeVariable" --v --not really the name, but this is used for display only 9 | 10 | arguments :: TypeConstructor -> [TypeConstructor] 11 | arguments (ADTypeConstructor _ args) = args 12 | arguments (PrimitiveTypeConstructor _ _) = [] 13 | arguments (RelationAtomTypeConstructor _) = [] 14 | arguments (TypeVariable _) = [] 15 | 16 | 17 | 18 | -------------------------------------------------------------------------------- /src/bin/SQL/Interpreter/TransactionGraphOperator.hs: -------------------------------------------------------------------------------- 1 | module SQL.Interpreter.TransactionGraphOperator where 2 | import ProjectM36.Interpreter 3 | import SQL.Interpreter.Base 4 | import Control.Applicative 5 | import Data.Functor (($>)) 6 | 7 | data TransactionGraphOperator = Begin | Commit | Rollback 8 | deriving (Show, Eq) 9 | 10 | transactionGraphOperatorP :: Parser TransactionGraphOperator 11 | transactionGraphOperatorP = beginP <|> commitP <|> rollbackP 12 | 13 | beginP :: Parser TransactionGraphOperator 14 | beginP = reserved "begin" $> Begin 15 | 16 | commitP :: Parser TransactionGraphOperator 17 | commitP = reserved "commit" $> Commit 18 | 19 | rollbackP :: Parser TransactionGraphOperator 20 | rollbackP = reserved "rollback" $> Rollback 21 | -------------------------------------------------------------------------------- /src/bin/TutorialD/Interpreter/Export/Base.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module TutorialD.Interpreter.Export.Base where 3 | import ProjectM36.Base 4 | import ProjectM36.Error 5 | #if __GLASGOW_HASKELL__ < 804 6 | import Data.Monoid 7 | #endif 8 | 9 | data RelVarDataExportOperator = RelVarDataExportOperator RelationalExpr FilePath (RelVarDataExportOperator -> Relation -> IO (Maybe RelationalError)) 10 | 11 | instance Show RelVarDataExportOperator where 12 | show (RelVarDataExportOperator expr path _) = "RelVarDataExportOperator " <> show expr <> " " <> path 13 | 14 | evalRelVarDataExportOperator :: RelVarDataExportOperator -> Relation -> IO (Maybe RelationalError) 15 | evalRelVarDataExportOperator op@(RelVarDataExportOperator _ _ exportFunc) = exportFunc op 16 | 17 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/SQLDatabaseContext.hs: -------------------------------------------------------------------------------- 1 | -- | Enables SQL-equivalent features such as NULL types in the database in addition to Project:M36 basic functions. 2 | module ProjectM36.SQLDatabaseContext where 3 | import ProjectM36.Base 4 | import ProjectM36.DatabaseContext 5 | import ProjectM36.DataTypes.SQL.Null 6 | 7 | sqlDatabaseContext :: DatabaseContext 8 | sqlDatabaseContext = basicDatabaseContext { atomFunctions = 9 | atomFunctions basicDatabaseContext <> nullAtomFunctions, 10 | typeConstructorMapping = 11 | typeConstructorMapping basicDatabaseContext <> nullTypeConstructorMapping 12 | } 13 | 14 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/SQL/Update.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric, DerivingVia, DeriveAnyClass #-} 2 | module ProjectM36.SQL.Update where 3 | import ProjectM36.SQL.Select 4 | import ProjectM36.Serialise.Base () 5 | import Control.DeepSeq 6 | import Codec.Winery 7 | import GHC.Generics 8 | 9 | data Update = Update 10 | { target :: TableName, 11 | -- targetAlias :: Maybe TableAlias, 12 | --SET 13 | setColumns :: [(UnqualifiedColumnName, ScalarExpr)], --we don't support multi-column SET yet 14 | mRestriction :: Maybe RestrictionExpr 15 | } 16 | --RETURNING not yet supported- how would we support this anyway- we must force the update to be materialized 17 | deriving (Show, Eq, Generic, NFData) 18 | deriving Serialise via WineryRecord Update 19 | 20 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/SQL/DBUpdate.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric, DerivingVia, DeriveAnyClass #-} 2 | module ProjectM36.SQL.DBUpdate where 3 | import ProjectM36.SQL.Update 4 | import ProjectM36.SQL.Insert 5 | import ProjectM36.SQL.Delete 6 | import ProjectM36.SQL.CreateTable 7 | import ProjectM36.SQL.DropTable 8 | import Control.DeepSeq 9 | import Codec.Winery 10 | import GHC.Generics 11 | 12 | -- | represents any SQL expression which can change the current transaction state such as 13 | data DBUpdate = UpdateUpdate Update | 14 | UpdateInsert Insert | 15 | UpdateDelete Delete | 16 | UpdateCreateTable CreateTable | 17 | UpdateDropTable DropTable 18 | deriving (Show, Eq, Generic, NFData) 19 | deriving Serialise via WineryVariant DBUpdate 20 | 21 | 22 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/RegisteredQuery.hs: -------------------------------------------------------------------------------- 1 | module ProjectM36.RegisteredQuery where 2 | import ProjectM36.Base 3 | import ProjectM36.Attribute 4 | import ProjectM36.Error 5 | import ProjectM36.IsomorphicSchema 6 | import ProjectM36.Relation 7 | import qualified Data.Map as M 8 | 9 | registeredQueriesAsRelationInSchema :: Schema -> RegisteredQueries -> Either RelationalError Relation 10 | registeredQueriesAsRelationInSchema schema regQs = do 11 | tups <- mapM regQToTuple (M.toList regQs) 12 | mkRelationFromList attrs tups 13 | where 14 | attrs = attributesFromList [Attribute "name" TextAtomType, 15 | Attribute "expr" RelationalExprAtomType] 16 | regQToTuple (qname, qexpr) = do 17 | qexpr' <- processRelationalExprInSchema schema qexpr 18 | pure [TextAtom qname, RelationalExprAtom qexpr'] 19 | 20 | -------------------------------------------------------------------------------- /src/bin/SQL/Interpreter/Update.hs: -------------------------------------------------------------------------------- 1 | module SQL.Interpreter.Update where 2 | import SQL.Interpreter.Select 3 | import ProjectM36.SQL.Update 4 | import SQL.Interpreter.Base 5 | import ProjectM36.Interpreter 6 | import Control.Applicative 7 | import Text.Megaparsec 8 | 9 | updateP :: Parser Update 10 | updateP = do 11 | reserved "update" 12 | tname <- tableNameP 13 | --mTAlias <- try (reserved "as" *> (Just <$> tableAliasP)) <|> pure Nothing 14 | reserved "set" 15 | setCols <- sepByComma1 $ do 16 | calias <- unqualifiedColumnNameP 17 | reserved "=" 18 | sexpr <- scalarExprP 19 | pure (calias, sexpr) 20 | mWhere <- try (Just <$> whereP) <|> pure Nothing 21 | pure (Update { 22 | target = tname, 23 | -- targetAlias = mTAlias, 24 | setColumns = setCols, 25 | mRestriction = mWhere 26 | }) 27 | -------------------------------------------------------------------------------- /src/bin/TutorialD/tutd.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | import TutorialD.Interpreter 3 | import ProjectM36.Cli 4 | import ProjectM36.DatabaseContext 5 | import System.Directory 6 | import System.FilePath 7 | 8 | #if !defined(VERSION_project_m36) 9 | # error Failed to discover proper version from cabal_macros.h 10 | # define VERSION_project_m36 "" 11 | #endif 12 | 13 | printWelcome :: IO () 14 | printWelcome = do 15 | putStrLn $ "Project:M36 TutorialD Interpreter " ++ VERSION_project_m36 16 | putStrLn "Type \":help\" for more information." 17 | putStrLn "A full tutorial is available at:" 18 | putStrLn "https://github.com/agentm/project-m36/blob/master/docs/tutd_tutorial.markdown" 19 | 20 | main :: IO () 21 | main = do 22 | homeDir <- getHomeDirectory 23 | mainLoop printWelcome (homeDir ".tutd_history") runTutorialD promptText runTutorialD basicDatabaseContext 24 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/DataConstructorDef.hs: -------------------------------------------------------------------------------- 1 | module ProjectM36.DataConstructorDef where 2 | import ProjectM36.Base as B 3 | import qualified Data.Set as S 4 | 5 | emptyDataConstructor :: DataConstructorName -> DataConstructorDef 6 | emptyDataConstructor name' = DataConstructorDef name' [] 7 | 8 | name :: DataConstructorDef -> DataConstructorName 9 | name (DataConstructorDef name' _) = name' 10 | 11 | fields :: DataConstructorDef -> [DataConstructorDefArg] 12 | fields (DataConstructorDef _ args) = args 13 | 14 | typeVars :: DataConstructorDef -> S.Set TypeVarName 15 | typeVars (DataConstructorDef _ tConsArgs) = S.unions $ map typeVarsInDefArg tConsArgs 16 | 17 | typeVarsInDefArg :: DataConstructorDefArg -> S.Set TypeVarName 18 | typeVarsInDefArg (DataConstructorDefTypeConstructorArg tCons) = B.typeVars tCons 19 | typeVarsInDefArg (DataConstructorDefTypeVarNameArg pVarName) = S.singleton pVarName 20 | 21 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/DataTypes/Basic.hs: -------------------------------------------------------------------------------- 1 | -- wraps up primitives plus other basic data types 2 | module ProjectM36.DataTypes.Basic where 3 | import ProjectM36.DataTypes.Primitive 4 | import ProjectM36.DataTypes.Either 5 | import ProjectM36.DataTypes.Maybe 6 | import ProjectM36.DataTypes.List 7 | import ProjectM36.DataTypes.NonEmptyList 8 | import ProjectM36.DataTypes.Interval 9 | import ProjectM36.Base 10 | 11 | basicTypeConstructorMapping :: TypeConstructorMapping 12 | basicTypeConstructorMapping = primitiveTypeConstructorMapping ++ 13 | maybeTypeConstructorMapping ++ 14 | eitherTypeConstructorMapping ++ 15 | listTypeConstructorMapping ++ 16 | nonEmptyListTypeConstructorMapping ++ 17 | intervalTypeConstructorMapping 18 | 19 | 20 | -------------------------------------------------------------------------------- /examples/DynamicAtomFunctions.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | --compile with `cabal exec ghc -- examples/DynamicAtomFunctions.hs -package project-m36` 3 | -- for persistent databases, copy "DynamicAtomFunctions.o" to "/compiled_modules", then 4 | -- load with `loadatomfunctions "DynamicAtomFunctions" "someAtomFunctions" "DynamicAtomFunctions.o"` 5 | -- for transient databases, 6 | -- load with `loadatomfunctions "DynamicAtomFunctions" "someAtomFunctions" "examples/DynamicAtomFunctions.o"` 7 | 8 | module DynamicAtomFunctions where 9 | import ProjectM36.Base 10 | import ProjectM36.AtomFunction 11 | 12 | someAtomFunctions :: [AtomFunction] 13 | someAtomFunctions = [Function{ 14 | funcName = "constTrue", 15 | funcType = [TypeVariableType "a", BoolAtomType], 16 | funcBody = externalAtomFunction (\(x:_) -> pure (BoolAtom True))}] 17 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/DataTypes/ByteString.hs: -------------------------------------------------------------------------------- 1 | module ProjectM36.DataTypes.ByteString where 2 | import ProjectM36.Base 3 | import ProjectM36.AtomFunctionError 4 | import ProjectM36.AtomFunctionBody 5 | import qualified Data.HashSet as HS 6 | import qualified Data.ByteString.Base64 as B64 7 | import qualified Data.Text.Encoding as TE 8 | 9 | bytestringAtomFunctions :: AtomFunctions 10 | bytestringAtomFunctions = HS.fromList [ 11 | Function { funcName = "bytestring", 12 | funcType = [TextAtomType, ByteStringAtomType], 13 | funcBody = compiledAtomFunctionBody $ 14 | \case 15 | TextAtom textIn:_ -> case B64.decode (TE.encodeUtf8 textIn) of 16 | Left err -> Left (AtomFunctionBytesDecodingError err) 17 | Right bs -> pure (ByteStringAtom bs) 18 | _ -> Left AtomFunctionTypeMismatchError 19 | } 20 | ] 21 | 22 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/Serialise/Error.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia, StandaloneDeriving #-} 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | module ProjectM36.Serialise.Error where 4 | import ProjectM36.Error 5 | import Codec.Winery 6 | import ProjectM36.Serialise.Base () 7 | import ProjectM36.Serialise.AtomFunctionError () 8 | import ProjectM36.Serialise.DatabaseContextFunctionError () 9 | 10 | deriving via WineryVariant RelationalError instance Serialise RelationalError 11 | deriving via WineryVariant MergeError instance Serialise MergeError 12 | deriving via WineryVariant ScriptCompilationError instance Serialise ScriptCompilationError 13 | deriving via WineryVariant PersistenceError instance Serialise PersistenceError 14 | deriving via WineryVariant SchemaError instance Serialise SchemaError 15 | deriving via WineryVariant ImportError' instance Serialise ImportError' 16 | deriving via WineryVariant SQLError instance Serialise SQLError 17 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/DataTypes/DateTime.hs: -------------------------------------------------------------------------------- 1 | module ProjectM36.DataTypes.DateTime where 2 | import ProjectM36.Base 3 | import ProjectM36.AtomFunctionBody 4 | import ProjectM36.AtomFunctionError 5 | import qualified Data.HashSet as HS 6 | import Data.Time.Clock.POSIX 7 | 8 | dateTimeAtomFunctions :: AtomFunctions 9 | dateTimeAtomFunctions = HS.fromList [ Function { 10 | funcName = "dateTimeFromEpochSeconds", 11 | funcType = [IntegerAtomType, DateTimeAtomType], 12 | funcBody = compiledAtomFunctionBody $ 13 | \case 14 | IntegerAtom epoch:_ -> pure (DateTimeAtom (posixSecondsToUTCTime (realToFrac epoch))) 15 | _ -> Left AtomFunctionTypeMismatchError 16 | }] 17 | 18 | 19 | -------------------------------------------------------------------------------- /docs/websocket_server.markdown: -------------------------------------------------------------------------------- 1 | # Project:M36 WebSocket Server 2 | 3 | ## Purpose 4 | 5 | The Project:M36 WebSocket server makes it easy to connect non-Haskell programs to the Project:M36 database. This server operates as a proxy to an actual Project:M36 database. 6 | 7 | ## Setup 8 | 9 | The websocket server is started with the same arguments as the normal [Project:M36 server](server_mode.markdown): 10 | 11 | ``` 12 | cabal run project-m36-websocket-server -- --database mydbname --hostname 127.0.0.1 13 | ``` 14 | 15 | except that the websocket server is now listening for websocket connections on port 8888. 16 | 17 | ## Client Connection 18 | 19 | A [simple JavaScript library](/src/bin/ProjectM36/Server/WebSocket/project-m36.js) to manage the WebSocket connection is available. 20 | 21 | ## Sample Application 22 | 23 | The [WebSocket example application](/src/bin/ProjectM36/Server/WebSocket/websocket-client.html) can be used to learn TutorialD and for remote database access from the web browser. 24 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/TransactionGraph/Show.hs: -------------------------------------------------------------------------------- 1 | module ProjectM36.TransactionGraph.Show where 2 | import ProjectM36.Base 3 | import ProjectM36.TransactionGraph 4 | import qualified Data.Set as S 5 | 6 | showTransactionStructure :: Transaction -> TransactionGraph -> String 7 | showTransactionStructure trans graph = headInfo ++ " " ++ show (transactionId trans) ++ " p" ++ parentTransactionsInfo 8 | where 9 | headInfo = maybe "" show (headNameForTransaction trans graph) 10 | parentTransactionsInfo = if isRootTransaction trans then "root" else case parentTransactions trans graph of 11 | Left err -> show err 12 | Right parentTransSet -> concat $ S.toList $ S.map (show . transactionId) parentTransSet 13 | 14 | 15 | showGraphStructure :: TransactionGraph -> String 16 | showGraphStructure graph@(TransactionGraph _ transSet) = S.foldr folder "" transSet 17 | where 18 | folder trans acc = acc ++ showTransactionStructure trans graph ++ "\n" 19 | 20 | 21 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/DatabaseContextFunctionUtils.hs: -------------------------------------------------------------------------------- 1 | module ProjectM36.DatabaseContextFunctionUtils where 2 | import ProjectM36.RelationalExpression 3 | import ProjectM36.Base 4 | import ProjectM36.DatabaseContextFunctionError 5 | import ProjectM36.Error 6 | import ProjectM36.StaticOptimizer 7 | 8 | executeDatabaseContextExpr :: DatabaseContextExpr -> TransactionId -> TransactionGraph -> DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext 9 | executeDatabaseContextExpr expr transId graph context' = 10 | case run of 11 | Right st -> pure (dbc_context st) 12 | Left err -> error (show err) 13 | where 14 | env = mkDatabaseContextEvalEnv transId graph 15 | run = runDatabaseContextEvalMonad context' env (optimizeAndEvalDatabaseContextExpr True expr) 16 | 17 | executeRelationalExpr :: RelationalExpr -> DatabaseContext -> TransactionGraph -> Either RelationalError Relation 18 | executeRelationalExpr expr context graph = 19 | run 20 | where 21 | env = mkRelationalExprEnv context graph 22 | run = optimizeAndEvalRelationalExpr env expr 23 | -------------------------------------------------------------------------------- /docs/dev_setup.markdown: -------------------------------------------------------------------------------- 1 | # Developer Setup 2 | 3 | Project:M36 is developed in Haskell with GHC 9.2+ and stack or cabal. Project:M36 includes server and client executables, a test suite, and example programs. See [project-m36.cabal](https://github.com/agentm/project-m36/blob/master/project-m36.cabal) for the available options. 4 | 5 | 6 | ## cabal 7 | 8 | Use [`ghcup`](https://www.haskell.org/ghcup/) to install GHC and `cabal` to build and run `tutd`. 9 | 10 | ``` 11 | ghcup install ghc 12 | cabal new-run tutd 13 | ``` 14 | 15 | ## stack 16 | 17 | Use [`stack`](https://docs.haskellstack.org/en/stable/README/) to build and run `tutd`. 18 | 19 | ``` 20 | stack --stack-yaml=stack.ghc.9.2.yaml run tutd 21 | ``` 22 | 23 | ## VSCode 24 | 25 | Project:M36 can be used with the haskell-language-server (HLS) with the Haskell Language plugin to VSCode with either `stack` or `cabal`. 26 | 27 | ### cabal 28 | 29 | Before launching VSCode, rename `cabal.hie.yaml` to `hie.yaml`. 30 | 31 | ### stack 32 | 33 | Before launching VSCode, rename `stack.hie.yaml` to `hie.yaml`. 34 | 35 | 36 | 37 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/AtomFunctionError.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} 2 | module ProjectM36.AtomFunctionError where 3 | import GHC.Generics 4 | import Control.DeepSeq 5 | import Data.Text 6 | 7 | data AtomFunctionError = AtomFunctionUserError String | 8 | AtomFunctionTypeMismatchError | 9 | AtomFunctionParseError String | 10 | InvalidIntervalOrderingError | 11 | InvalidIntervalBoundariesError | 12 | AtomFunctionAttributeNameNotFoundError Text | 13 | InvalidIntBoundError | 14 | InvalidUUIDString Text | 15 | RelationAtomExpectedError Text | 16 | AtomFunctionEmptyRelationError | 17 | AtomTypeDoesNotSupportOrderingError Text | 18 | AtomTypeDoesNotSupportIntervalError Text | 19 | AtomFunctionBytesDecodingError String 20 | deriving (Generic, Eq, Show, NFData) 21 | 22 | -------------------------------------------------------------------------------- /test/scripts.hs: -------------------------------------------------------------------------------- 1 | -- read each .tutd file in the /scripts directory and execute it with the tutd interpreter 2 | import Test.HUnit 3 | import TutorialD.Interpreter.Import.TutorialD 4 | import System.Directory 5 | import Data.List (isSuffixOf) 6 | import System.Exit 7 | import qualified Data.Text as T 8 | import Text.URI 9 | 10 | testList :: IO Test 11 | testList = do 12 | let scriptsDir = "scripts/" 13 | dirFiles <- getDirectoryContents scriptsDir 14 | let scriptList = map (scriptsDir ++) $ filter (".tutd" `isSuffixOf`) dirFiles 15 | pure (TestList $ map testScript scriptList) 16 | 17 | main :: IO () 18 | main = do 19 | tests <- testList 20 | tcounts <- runTestTT tests 21 | if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess 22 | 23 | testScript :: FilePath -> Test 24 | testScript tutdFile = TestCase $ do 25 | fileURI <- mkURI (T.pack ("file://" <> tutdFile)) 26 | eImport <- importTutorialDFromFile fileURI Nothing 27 | case eImport of 28 | Left err -> assertFailure ("tutd import failure in " ++ tutdFile ++ ": " ++ show err) 29 | Right _ -> pure () 30 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/DisconnectedTransaction.hs: -------------------------------------------------------------------------------- 1 | module ProjectM36.DisconnectedTransaction where 2 | import ProjectM36.Base 3 | import Data.Map 4 | 5 | concreteDatabaseContext :: DisconnectedTransaction -> DatabaseContext 6 | concreteDatabaseContext (DisconnectedTransaction _ (Schemas context _) _) = context 7 | 8 | schemas :: DisconnectedTransaction -> Schemas 9 | schemas (DisconnectedTransaction _ s _) = s 10 | 11 | loadGraphRefRelVarsOnly :: TransactionId -> Schemas -> Schemas 12 | loadGraphRefRelVarsOnly commitId (Schemas concreteCtx subschemas) = 13 | let f k _ = RelationVariable k (TransactionMarker commitId) 14 | ctx' = concreteCtx { relationVariables = mapWithKey f (relationVariables concreteCtx)} 15 | in Schemas ctx' subschemas 16 | 17 | 18 | 19 | parentId :: DisconnectedTransaction -> TransactionId 20 | parentId (DisconnectedTransaction pid _ _) = pid 21 | 22 | isDirty :: DisconnectedTransaction -> Bool 23 | isDirty (DisconnectedTransaction _ _ flag) = flag 24 | 25 | freshTransaction :: TransactionId -> Schemas -> DisconnectedTransaction 26 | freshTransaction tid schemas' = DisconnectedTransaction tid schemas' False 27 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/TransactionGraph/Show/Dot.hs: -------------------------------------------------------------------------------- 1 | module ProjectM36.TransactionGraph.Show.Dot where 2 | import ProjectM36.Transaction 3 | import ProjectM36.Base 4 | import qualified Data.Text as T 5 | import qualified Data.Set as S 6 | import qualified Data.Map as M 7 | 8 | graphAsDot :: TransactionGraph -> String 9 | graphAsDot (TransactionGraph heads transSet) = "digraph {" ++ dot ++ headInfo ++ "}" 10 | where 11 | dot = S.foldr transactionAsDot "" transSet 12 | transactionAsDot trans acc = acc ++ childArrows trans ++ parentArrows trans 13 | arrows trans = S.foldr (\c acc' -> acc' ++ oneArrow trans c) "" 14 | childArrows trans = arrows trans (transactionChildIds trans) 15 | parentArrows trans = arrows trans (transactionParentIds trans) 16 | transLabel t = tidLabel (transactionId t) 17 | tidLabel l = "\"" ++ show l ++ "\"" 18 | oneArrow trans tid = transLabel trans ++ " -> " ++ tidLabel tid ++ ";" 19 | headInfo = M.foldrWithKey (\headName t acc -> transLabel t ++ " [label=\"" ++ (show . transactionId) t ++ ":" ++ T.unpack headName ++ "\"];" ++ acc) "" heads 20 | 21 | 22 | 23 | -------------------------------------------------------------------------------- /src/bin/TutorialD/Interpreter/Import/BasicExamples.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | --includes some hardcoded examples which can be imported even during safe evaluation (no file I/O) 3 | module TutorialD.Interpreter.Import.BasicExamples where 4 | import ProjectM36.DateExamples 5 | import ProjectM36.Base 6 | import ProjectM36.Interpreter 7 | import ProjectM36.DatabaseContext 8 | import TutorialD.Interpreter.Base 9 | 10 | #if !MIN_VERSION_megaparsec(6,0,0) 11 | import Text.Megaparsec.Text 12 | #endif 13 | 14 | data ImportBasicExampleOperator = ImportBasicDateExampleOperator 15 | deriving (Show) 16 | 17 | evalImportBasicExampleOperator :: ImportBasicExampleOperator -> DatabaseContextExpr 18 | evalImportBasicExampleOperator ImportBasicDateExampleOperator = databaseContextAsDatabaseContextExpr dateExamples 19 | 20 | importBasicExampleOperatorP :: Parser ImportBasicExampleOperator 21 | importBasicExampleOperatorP = do 22 | reservedOp ":importexample" 23 | example <- identifierP 24 | if example == "cjdate" then 25 | pure ImportBasicDateExampleOperator 26 | else 27 | fail "Unknown example name" 28 | 29 | -------------------------------------------------------------------------------- /src/bin/benchmark/Relation.hs: -------------------------------------------------------------------------------- 1 | import Criterion.Main 2 | import ProjectM36.Relation 3 | import ProjectM36.Base 4 | import ProjectM36.Error 5 | import qualified ProjectM36.Attribute as A 6 | import qualified Data.Text as T 7 | import qualified Data.Vector as V 8 | 9 | -- returns a relation with tupleCount tuples with a set of integer attributes attributesCount long 10 | -- this is useful for performance and resource usage testing 11 | matrixRelation :: Int -> Int -> Either RelationalError Relation 12 | matrixRelation attributeCount tupleCount = do 13 | let attrs = A.attributesFromList $ map (\c-> Attribute (T.pack $ "a" ++ show c) IntAtomType) [0 .. attributeCount-1] 14 | tuple tupleX = RelationTuple attrs (V.generate attributeCount (\_ -> IntAtom tupleX)) 15 | tuples = map tuple [0 .. tupleCount] 16 | mkRelationDeferVerify attrs (RelationTupleSet tuples) 17 | 18 | main :: IO () 19 | main = defaultMain [ 20 | bgroup "Big Relation" [ 21 | bench "100" $ whnf (matrixRelation 10) 100, 22 | bench "1000" $ whnf (matrixRelation 10) 1000, 23 | bench "10000" $ whnf (matrixRelation 10) 10000 24 | ] 25 | ] 26 | 27 | 28 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/AttributeNames.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module ProjectM36.AttributeNames where 3 | import ProjectM36.Base 4 | import qualified Data.Set as S 5 | #if MIN_VERSION_base(4,20,0) 6 | #else 7 | import Data.Foldable (foldl') 8 | #endif 9 | --AttributeNames is a data structure which can represent inverted projection attributes and attribute names derived from relational expressions 10 | 11 | empty :: AttributeNamesBase a 12 | empty = AttributeNames S.empty 13 | 14 | all :: AttributeNamesBase a 15 | all = InvertedAttributeNames S.empty 16 | 17 | -- | Coalesce a bunch of AttributeNames into a single AttributeNames. 18 | some :: Eq a => [AttributeNamesBase a] -> AttributeNamesBase a 19 | some [] = ProjectM36.AttributeNames.all 20 | some [an] = an 21 | some (a:as) = foldl' folder a as 22 | where 23 | folder :: Eq a => AttributeNamesBase a -> AttributeNamesBase a -> AttributeNamesBase a 24 | folder acc names = 25 | case acc of 26 | AttributeNames an | S.null an -> names 27 | acc' -> if names == empty then 28 | acc 29 | else 30 | UnionAttributeNames acc' names 31 | 32 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/DataTypes/Either.hs: -------------------------------------------------------------------------------- 1 | module ProjectM36.DataTypes.Either where 2 | import ProjectM36.Base 3 | import ProjectM36.AtomFunction 4 | import ProjectM36.AtomFunctionError 5 | import qualified Data.HashSet as HS 6 | import qualified Data.Map as M 7 | 8 | eitherAtomType :: AtomType -> AtomType -> AtomType 9 | eitherAtomType tA tB = ConstructedAtomType "Either" (M.fromList [("a", tA), ("b", tB)]) 10 | 11 | eitherTypeConstructorMapping :: TypeConstructorMapping 12 | eitherTypeConstructorMapping = [(ADTypeConstructorDef "Either" ["a", "b"], 13 | [DataConstructorDef "Left" [DataConstructorDefTypeVarNameArg "a"], 14 | DataConstructorDef "Right" [DataConstructorDefTypeVarNameArg "b"]])] 15 | 16 | eitherAtomFunctions :: AtomFunctions 17 | eitherAtomFunctions = HS.fromList [ 18 | compiledAtomFunction "isLeft" [eitherAtomType (TypeVariableType "a") (TypeVariableType "b"), BoolAtomType] $ \case 19 | (ConstructedAtom dConsName _ _:_) -> pure (BoolAtom (dConsName == "Left")) 20 | _ -> Left AtomFunctionTypeMismatchError 21 | ] 22 | -------------------------------------------------------------------------------- /cbits/DirectoryFsync.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include 7 | 8 | #ifndef _DIRECTORY_FSYNC_ 9 | #define _DIRECTORY_FSYNC_ 10 | /* open a directory for reading and fsync the resultant fd */ 11 | int cDirectoryFsync(char *path) 12 | { 13 | int fd = 0; 14 | int ret = 0; 15 | struct stat fdstat = {0}; 16 | 17 | fd = open(path, O_RDONLY); 18 | if(fd < 0) 19 | { 20 | return errno; 21 | } 22 | 23 | /* ensure that opened fd is a directory fd. Otherwise, fsync will fail (on a read-only file descriptor */ 24 | ret = fstat(fd,&fdstat); 25 | if(ret < 0) 26 | { 27 | close(fd); 28 | return errno; 29 | } 30 | 31 | if(!S_ISDIR(fdstat.st_mode)) 32 | { 33 | close(fd); 34 | return ENOTDIR; 35 | } 36 | 37 | /* execute the fsync */ 38 | 39 | #if defined(__APPLE__) && defined(__MACH__) && defined(F_FULLFSYNC) 40 | ret = fcntl(fd, F_FULLFSYNC); 41 | #else 42 | ret = fsync(fd); 43 | #endif 44 | close(fd); 45 | if(ret < 0) 46 | { 47 | return errno; 48 | } 49 | return 0; 50 | } 51 | #endif 52 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/Notifications.hs: -------------------------------------------------------------------------------- 1 | module ProjectM36.Notifications where 2 | import ProjectM36.Base 3 | import ProjectM36.Error 4 | import ProjectM36.RelationalExpression 5 | import ProjectM36.StaticOptimizer 6 | import qualified Data.Map as M 7 | import Data.Either (isRight) 8 | 9 | -- | Returns the notifications which should be triggered based on the transition from the first 'DatabaseContext' to the second 'DatabaseContext'. 10 | notificationChanges :: Notifications -> TransactionGraph -> DatabaseContext -> DatabaseContext -> Notifications 11 | notificationChanges nots graph context1 context2 = M.filter notificationFilter nots 12 | where 13 | notificationFilter (Notification chExpr _ _) = oldChangeEval /= newChangeEval && isRight oldChangeEval 14 | where 15 | oldChangeEval = evalChangeExpr chExpr (mkRelationalExprEnv context1 graph) 16 | newChangeEval = evalChangeExpr chExpr (mkRelationalExprEnv context2 graph) 17 | 18 | evalChangeExpr :: RelationalExpr -> RelationalExprEnv -> Either RelationalError Relation 19 | evalChangeExpr chExpr env = 20 | optimizeAndEvalRelationalExpr env chExpr 21 | 22 | 23 | -------------------------------------------------------------------------------- /docs/javascript_driver.markdown: -------------------------------------------------------------------------------- 1 | # Project:M36 JavaScript Driver 2 | 3 | ## Introduction 4 | 5 | The JavaScript database driver for Project:M36 is a fully-featured database driver for the Project:M36 Relational Algebra Engine DBMS. The driver's only dependency is a working websockets implementation which is provided by virtually any modern web browser and node.js. The API is callback-based. 6 | 7 | ## Usage 8 | 9 | 1. [Download the driver](/src/bin/ProjectM36/Websocket/project-m36.js). 10 | 1. Connect to the websocket server with a ```new ProjectM36Connection(..)``` including the asynchronous callback functions. 11 | 1. When the ```openCallback``` is called, the database is ready to execute TutorialD sing the ```executeTutorialD()``` function. 12 | 1. Implement ```statusCallback``` to update your user interface for expected and asynchronous event handling. 13 | 14 | ## Example 15 | 16 | A fully-functioning interactive websocket client is available: 17 | 18 | * [websocket-client.html](/src/bin/ProjectM36/Server/WebSocket/websocket-client.html) 19 | * [websocket-client.js](/src/bin/ProjectM36/Server/WebSocket/websocket-client.js) 20 | 21 | This example also powers [try.project-m36.io](https://try.project-m36.io). 22 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/SQL/CreateTable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric, DerivingVia, DeriveAnyClass #-} 2 | module ProjectM36.SQL.CreateTable where 3 | import ProjectM36.SQL.Select 4 | import Control.DeepSeq 5 | import Codec.Winery 6 | import GHC.Generics 7 | 8 | data CreateTable = CreateTable 9 | { target :: TableName, 10 | targetColumns :: [(UnqualifiedColumnName, ColumnType, PerColumnConstraints)] 11 | } 12 | deriving (Show, Eq, Generic, NFData) 13 | deriving Serialise via WineryRecord CreateTable 14 | 15 | data ColumnType = 16 | IntegerColumnType | 17 | TextColumnType | 18 | BoolColumnType | 19 | DoubleColumnType | 20 | DateTimeColumnType | -- timestamp with timezone 21 | DateColumnType | 22 | ByteaColumnType 23 | deriving (Show, Eq, Generic, NFData) 24 | deriving Serialise via WineryVariant ColumnType 25 | 26 | -- | Used to represent constraints which are defined next to a column name and type. 27 | data PerColumnConstraints = PerColumnConstraints { 28 | notNullConstraint :: Bool, 29 | uniquenessConstraint :: Bool, 30 | references :: Maybe (TableName, UnqualifiedColumnName) 31 | } 32 | deriving (Show, Eq, Generic, NFData) 33 | deriving Serialise via WineryVariant PerColumnConstraints 34 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/FunctionalDependency.hs: -------------------------------------------------------------------------------- 1 | module ProjectM36.FunctionalDependency where 2 | import ProjectM36.Base 3 | import qualified Data.Set as S 4 | 5 | data FunctionalDependency = FunctionalDependency AttributeNames AttributeNames RelationalExpr 6 | 7 | --(s{city} group ({city} as x) : {z:=count(@x)}) {z} 8 | -- as defined in Relational Algebra and All That Jazz page 21 9 | inclusionDependenciesForFunctionalDependency :: FunctionalDependency -> (InclusionDependency, InclusionDependency) 10 | inclusionDependenciesForFunctionalDependency (FunctionalDependency attrNamesSource attrNamesDependent relExpr) = ( 11 | InclusionDependency countSource countDep, 12 | InclusionDependency countDep countSource) 13 | where 14 | countDep = relExprCount relExpr (UnionAttributeNames attrNamesSource attrNamesDependent) 15 | countSource = relExprCount relExpr attrNamesSource 16 | projectZName = Project (AttributeNames (S.singleton "z")) 17 | zCount = FunctionAtomExpr "count" [AttributeAtomExpr "x"] () 18 | extendZName = Extend (AttributeExtendTupleExpr "z" zCount) 19 | relExprCount expr projectionAttrNames = projectZName (extendZName 20 | (Group projectionAttrNames "x" (Project projectionAttrNames expr))) 21 | -------------------------------------------------------------------------------- /src/bin/TutorialD/Interpreter/Export/CSV.hs: -------------------------------------------------------------------------------- 1 | module TutorialD.Interpreter.Export.CSV where 2 | import ProjectM36.Relation.Show.CSV 3 | import ProjectM36.Interpreter 4 | import TutorialD.Interpreter.Export.Base 5 | import TutorialD.Interpreter.RelationalExpr 6 | import TutorialD.Interpreter.Base hiding (try) 7 | import ProjectM36.Base 8 | import ProjectM36.Error 9 | import qualified Data.ByteString.Lazy as BS 10 | import Control.Exception (try) 11 | import qualified Data.Text as T 12 | 13 | exportCSVP :: Parser RelVarDataExportOperator 14 | exportCSVP = do 15 | reserved ":exportcsv" 16 | exportExpr <- relExprP 17 | path <- quotedString 18 | return $ RelVarDataExportOperator exportExpr (T.unpack path) exportRelationCSV 19 | 20 | exportRelationCSV :: RelVarDataExportOperator -> Relation -> IO (Maybe RelationalError) 21 | exportRelationCSV (RelVarDataExportOperator _ pathOut _) rel = 22 | case relationAsCSV rel of 23 | Left err -> return $ Just err 24 | Right csvData -> do 25 | writeResult <- try (BS.writeFile pathOut csvData) :: IO (Either IOError ()) 26 | case writeResult of 27 | Left err -> return $ Just (ExportError $ T.pack (show err)) 28 | Right _ -> return Nothing 29 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | This is free and unencumbered software released into the public domain. 2 | 3 | Anyone is free to copy, modify, publish, use, compile, sell, or 4 | distribute this software, either in source code form or as a compiled 5 | binary, for any purpose, commercial or non-commercial, and by any 6 | means. 7 | 8 | In jurisdictions that recognize copyright laws, the author or authors 9 | of this software dedicate any and all copyright interest in the 10 | software to the public domain. We make this dedication for the benefit 11 | of the public at large and to the detriment of our heirs and 12 | successors. We intend this dedication to be an overt act of 13 | relinquishment in perpetuity of all present and future rights to this 14 | software under copyright law. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 19 | IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR 20 | OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, 21 | ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 22 | OTHER DEALINGS IN THE SOFTWARE. 23 | 24 | For more information, please refer to 25 | 26 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/DataTypes/Day.hs: -------------------------------------------------------------------------------- 1 | module ProjectM36.DataTypes.Day where 2 | import ProjectM36.Base 3 | import ProjectM36.AtomFunctionBody 4 | import ProjectM36.AtomFunctionError 5 | import qualified Data.HashSet as HS 6 | import Data.Time.Calendar 7 | 8 | 9 | dayAtomFunctions :: AtomFunctions 10 | dayAtomFunctions = HS.fromList [ 11 | Function { funcName = "fromGregorian", 12 | funcType = [IntegerAtomType, IntegerAtomType, IntegerAtomType, DayAtomType], 13 | funcBody = compiledAtomFunctionBody $ 14 | \case 15 | IntegerAtom year:IntegerAtom month:IntegerAtom day:_ -> pure $ DayAtom (fromGregorian (fromIntegral year) (fromIntegral month) (fromIntegral day)) 16 | _ -> Left AtomFunctionTypeMismatchError 17 | }, 18 | Function { funcName = "dayEarlierThan", 19 | funcType = [DayAtomType, DayAtomType, BoolAtomType], 20 | funcBody = compiledAtomFunctionBody $ 21 | \case 22 | ConstructedAtom _ _ (IntAtom dayA:_):ConstructedAtom _ _ (IntAtom dayB:_):_ -> pure (BoolAtom (dayA < dayB)) 23 | _ -> Left AtomFunctionTypeMismatchError 24 | } 25 | ] 26 | -------------------------------------------------------------------------------- /examples/DynamicDatabaseContextFunctions.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | --compile with `cabal exec ghc -- examples/DynamicDatabaseContextFunctions.hs -package project-m36` 3 | --load with `loaddatabasecontextfunctions "DynamicDatabaseContextFunctions" "someDBCFunctions" "examples/DynamicDatabaseContextFunctions.o"` 4 | module DynamicDatabaseContextFunctions where 5 | import ProjectM36.Base 6 | import ProjectM36.Relation 7 | import ProjectM36.DatabaseContextFunction 8 | import ProjectM36.DatabaseContextFunctionError 9 | import qualified ProjectM36.Attribute as A 10 | 11 | import qualified Data.Map as M 12 | 13 | 14 | someDBCFunctions :: [DatabaseContextFunction] 15 | someDBCFunctions = [Function { 16 | funcName = "addtestrel", 17 | funcType = [], 18 | funcBody = externalDatabaseContextFunction addTestRel 19 | }] 20 | where 21 | addTestRel _ ctx = do 22 | let attrExprs = [NakedAttributeExpr (Attribute "word" TextAtomType)] 23 | newRelExpr = MakeRelationFromExprs (Just attrExprs) (TupleExprs UncommittedContextMarker [TupleExpr (M.singleton "word" (NakedAtomExpr (TextAtom "nice")))]) 24 | pure $ ctx { relationVariables = 25 | M.insert "testRel" newRelExpr (relationVariables ctx) } 26 | 27 | 28 | -------------------------------------------------------------------------------- /.appveyor.yml: -------------------------------------------------------------------------------- 1 | build: off 2 | 3 | version: 1.0.{build}-{branch} 4 | 5 | image: Visual Studio 2022 6 | 7 | before_test: 8 | # http://help.appveyor.com/discussions/problems/6312-curl-command-not-found 9 | - set PATH=C:\Program Files\Git\mingw64\bin;%PATH% 10 | 11 | - curl -sS -ostack.zip -L --insecure http://www.stackage.org/stack/windows-x86_64 12 | - 7z x stack.zip stack.exe 13 | - powershell .appveyor/preload_certs.ps 14 | 15 | clone_folder: "c:\\project-m36" 16 | clone_depth: 2 17 | environment: 18 | global: 19 | STACK_ROOT: "c:\\sr" 20 | matrix: 21 | # don't forget to also change the cache directory below 22 | - YAML: "stack.ghc9.2.yaml" 23 | 24 | platform: 25 | - x64 26 | 27 | cache: 28 | - "c:\\sr" 29 | - "%LocalAppData%\\Programs\\stack\\x86_64-windows\\ghc-9.0.2" 30 | # - ".stack-work" # send us over the 1 GB limit 31 | 32 | test_script: 33 | - stack setup > nul 34 | # The ugly echo "" hack is to avoid complaints about 0 being an invalid file 35 | # descriptor 36 | - echo "" | stack --stack-yaml %YAML% --no-terminal test 37 | # - 7z.exe a -t7z -m0=lzma -mx=9 -mfb=64 -md=32m -ms=on project-m36.7z .stack-work\install\*\bin\project-m36-server.exe .stack-work\install\*\bin\project-m36-websocket-server.exe .stack-work\install\*\bin\tutd.exe .stack-work\install\*\bin\project-m36-server.exe 38 | 39 | #artifacts: 40 | # - path: project-m36.7z 41 | # name: project-m36.7z 42 | -------------------------------------------------------------------------------- /scripts/cjdate.sql: -------------------------------------------------------------------------------- 1 | -- creates the cjdate sample database in SQL for comparison with TutorialD 2 | BEGIN; 3 | CREATE TABLE s ( 4 | "s#" varchar(2) primary key, 5 | sname varchar(10) NOT NULL, 6 | status int NOT NULL, 7 | city varchar(10) NOT NULL 8 | ); 9 | 10 | CREATE TABLE p ( 11 | "p#" varchar(2) primary key, 12 | pname varchar(10) NOT NULL, 13 | color varchar(10) NOT NULL, 14 | weight real NOT NULL, 15 | city varchar(10) NOT NULL 16 | ); 17 | 18 | CREATE TABLE sp ( 19 | "s#" varchar(2) NOT NULL REFERENCES s("s#"), 20 | "p#" varchar(2) NOT NULL REFERENCES p("p#"), 21 | qty int NOT NULL, 22 | PRIMARY KEY ("s#", "p#") 23 | ); 24 | 25 | INSERT INTO s(city, "s#", sname, status) VALUES ('Athens','S5','Adams',30),('Paris','S3','Blake',30),('London','S1','Smith',20),('Paris','S2','Jones',10),('London','S4','Clark',20); 26 | 27 | INSERT INTO p(city,color,"p#",pname,weight) VALUES ('London','Red','P6','Cog',19),('Oslo','Blue','P3','Screw',17),('London','Red','P4','Screw',14),('London','Red','P1','Nut',12),('Paris','Green','P2','Bolt',17),('Paris','Blue','P5','Cam',12); 28 | 29 | INSERT INTO sp("p#",qty,"s#") VALUES ('P1',300,'S2'),('P1',300,'S1'),('P2',400,'S2'),('P2',200,'S4'),('P2',200,'S3'),('P2',200,'S1'),('P3',400,'S1'),('P4',200,'S1'),('P4',300,'S4'),('P5',400,'S4'),('P5',100,'S1'),('P6',100,'S1'); 30 | COMMIT; -------------------------------------------------------------------------------- /src/bin/TutorialD/Interpreter/Import/CSV.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module TutorialD.Interpreter.Import.CSV where 3 | import TutorialD.Interpreter.Import.Base 4 | import ProjectM36.Base 5 | import ProjectM36.Interpreter 6 | import ProjectM36.Error 7 | import ProjectM36.Relation.Parse.CSV hiding (quotedString) 8 | import qualified Data.ByteString.Lazy as BS 9 | import qualified Data.Text as T 10 | import TutorialD.Interpreter.Base hiding (try) 11 | import Control.Exception 12 | 13 | importCSVRelation :: RelVarName -> TypeConstructorMapping -> Attributes -> FilePath -> IO (Either RelationalError DatabaseContextExpr) 14 | importCSVRelation relVarName tConsMap attrs pathIn = do 15 | --TODO: handle filesystem errors 16 | csvData <- try (BS.readFile pathIn) :: IO (Either IOError BS.ByteString) 17 | case csvData of 18 | Left err -> pure $ Left (ImportError (ImportFileError (T.pack (show err)))) 19 | Right csvData' -> case csvAsRelation attrs tConsMap csvData' of 20 | Left err -> pure $ Left (ParseError $ T.pack (show err)) 21 | Right csvRel -> pure $ Right (Insert relVarName (ExistingRelation csvRel)) 22 | 23 | importCSVP :: Parser RelVarDataImportOperator 24 | importCSVP = do 25 | reserved ":importcsv" 26 | path <- quotedString 27 | spaceConsumer 28 | relVarName <- identifierP 29 | return $ RelVarDataImportOperator relVarName (T.unpack path) importCSVRelation 30 | 31 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/InclusionDependency.hs: -------------------------------------------------------------------------------- 1 | module ProjectM36.InclusionDependency where 2 | import ProjectM36.Base 3 | import ProjectM36.Attribute 4 | import ProjectM36.Error 5 | import ProjectM36.Relation 6 | import qualified Data.Map as M 7 | 8 | inclusionDependenciesAsRelation :: InclusionDependencies -> Either RelationalError Relation 9 | inclusionDependenciesAsRelation incDeps = 10 | mkRelationFromList attrs (map incDepAsAtoms (M.toList incDeps)) 11 | where 12 | attrs = attributesFromList [Attribute "name" TextAtomType, 13 | Attribute "sub" RelationalExprAtomType, 14 | Attribute "super" RelationalExprAtomType 15 | ] 16 | incDepAsAtoms (name, InclusionDependency exprA exprB) = [TextAtom name, 17 | RelationalExprAtom exprA, 18 | RelationalExprAtom exprB] 19 | 20 | -- validate that the given AtomExpr is true for an relvar 21 | inclusionDependencyForAtomExpr :: RelVarName -> AtomExpr -> InclusionDependency 22 | inclusionDependencyForAtomExpr rvname atomExpr = 23 | InclusionDependency 24 | (NotEquals (ExistingRelation relationTrue) 25 | (Project (AttributeNames mempty) (Restrict check (RelationVariable rvname ()))) 26 | ) 27 | (ExistingRelation relationFalse) 28 | where 29 | check = AtomExprPredicate atomExpr 30 | 31 | -------------------------------------------------------------------------------- /scripts/DateExamples.tutd: -------------------------------------------------------------------------------- 1 | s := relation{tuple{s# "S1",sname "Smith",status 20, city "London"}, 2 | tuple{s# "S2",sname "Jones",status 10,city "Paris"}, 3 | tuple{s# "S3",sname "Blake",status 30,city "Paris"}, 4 | tuple{s# "S4",sname "Clark",status 20,city "London"}, 5 | tuple{s# "S5",sname "Adams",status 30,city "Athens"}}; 6 | p := relation{tuple{p# "P1",pname "Nut",color "Red",weight 12,city "London"}, 7 | tuple{p# "P2",pname "Bolt",color "Green",weight 17,city "Paris"}, 8 | tuple{p# "P3",pname "Screw",color "Blue",weight 17,city "Oslo"}, 9 | tuple{p# "P4",pname "Screw",color "Red",weight 14,city "London"}, 10 | tuple{p# "P5",pname "Cam",color "Blue",weight 12,city "Paris"}, 11 | tuple{p# "P6", pname "Cog", color "Red",weight 19,city "London"}}; 12 | sp := relation{tuple{s# "S1",p# "P1",qty 300}, 13 | tuple{s# "S1",p# "P2",qty 200}, 14 | tuple{s# "S1",p# "P3",qty 400}, 15 | tuple{s# "S1",p# "P4",qty 200}, 16 | tuple{s# "S1",p# "P5",qty 100}, 17 | tuple{s# "S1",p# "P6",qty 100}, 18 | tuple{s# "S2",p# "P1",qty 300}, 19 | tuple{s# "S2",p# "P2",qty 400}, 20 | tuple{s# "S3",p# "P2",qty 200}, 21 | tuple{s# "S4",p# "P4",qty 300}, 22 | tuple{s# "S4",p# "P5",qty 400}}; 23 | key s_pkey {s#} s; 24 | key p_key {p#} p; 25 | foreign key s_sp_fk sp{s#} in s{s#}; 26 | foreign key p_sp_fk sp{p#} in p{p#}; -------------------------------------------------------------------------------- /test/Relation/Import/CSV.hs: -------------------------------------------------------------------------------- 1 | import Test.HUnit 2 | import ProjectM36.Base 3 | import ProjectM36.Relation.Parse.CSV 4 | import ProjectM36.Relation 5 | import qualified ProjectM36.Attribute as A 6 | import ProjectM36.DataTypes.Basic 7 | 8 | import System.Exit 9 | import qualified Data.Text.Lazy as T 10 | import Data.Text.Lazy.Encoding 11 | 12 | 13 | main :: IO () 14 | main = do 15 | tcounts <- runTestTT $ TestList [testCSVSuccess] 16 | if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess 17 | 18 | testCSVSuccess :: Test 19 | testCSVSuccess = TestCase $ do 20 | let sampleCSV = (encodeUtf8 . T.pack) "S#,CITY,STATUS,SNAME\n\"S8\",\"Boston\",150,\"Mike\"\nS9,Londonderry,170,Perry" 21 | expectedAttrs = A.attributesFromList [Attribute "S#" TextAtomType, 22 | Attribute "SNAME" TextAtomType, 23 | Attribute "STATUS" IntAtomType, 24 | Attribute "CITY" TextAtomType] 25 | expectedRel = mkRelationFromList expectedAttrs [ 26 | [TextAtom "S9", TextAtom "Perry", IntAtom 170, TextAtom "Londonderry"], 27 | [TextAtom "S8", TextAtom "Mike", IntAtom 150, TextAtom "Boston"]] 28 | case csvAsRelation expectedAttrs basicTypeConstructorMapping sampleCSV of 29 | Left err -> assertFailure $ show err 30 | Right csvRel -> assertEqual "csv->relation" expectedRel (Right csvRel) 31 | 32 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/DataTypes/Sorting.hs: -------------------------------------------------------------------------------- 1 | module ProjectM36.DataTypes.Sorting where 2 | import ProjectM36.Base 3 | 4 | compareAtoms :: Atom -> Atom -> Ordering 5 | compareAtoms (IntegerAtom i1) (IntegerAtom i2) = compare i1 i2 6 | compareAtoms (IntAtom i1) (IntAtom i2) = compare i1 i2 7 | compareAtoms (DoubleAtom d1) (DoubleAtom d2) = compare d1 d2 8 | compareAtoms (ScientificAtom s1) (ScientificAtom s2) = compare s1 s2 9 | compareAtoms (TextAtom t1) (TextAtom t2) = compare t1 t2 10 | compareAtoms (DayAtom d1) (DayAtom d2) = compare d1 d2 11 | compareAtoms (DateTimeAtom d1) (DateTimeAtom d2) = compare d1 d2 12 | compareAtoms (ByteStringAtom b1) (ByteStringAtom b2) = compare b1 b2 13 | compareAtoms (BoolAtom b1) (BoolAtom b2) = compare b1 b2 14 | compareAtoms (UUIDAtom u1) (UUIDAtom u2) = compare u1 u2 15 | compareAtoms (RelationAtom _) _ = EQ 16 | compareAtoms ConstructedAtom{} _ = EQ 17 | compareAtoms _ _ = EQ 18 | 19 | isSortableAtomType :: AtomType -> Bool 20 | isSortableAtomType typ = case typ of 21 | IntAtomType -> True 22 | IntegerAtomType -> True 23 | DoubleAtomType -> True 24 | ScientificAtomType -> True 25 | TextAtomType -> True 26 | DayAtomType -> True 27 | DateTimeAtomType -> True 28 | ByteStringAtomType -> False 29 | BoolAtomType -> True 30 | UUIDAtomType -> False 31 | RelationalExprAtomType -> False 32 | RelationAtomType _ -> False 33 | SubrelationFoldAtomType{} -> False 34 | ConstructedAtomType _ _ -> False 35 | TypeVariableType _ -> False 36 | 37 | 38 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/AtomFunctions/Basic.hs: -------------------------------------------------------------------------------- 1 | --atom functions on primitive atom values plus the basic atom functions 2 | module ProjectM36.AtomFunctions.Basic where 3 | import ProjectM36.Base 4 | import ProjectM36.DataTypes.Day 5 | import ProjectM36.DataTypes.Either 6 | import ProjectM36.DataTypes.Maybe 7 | import ProjectM36.DataTypes.Interval 8 | import ProjectM36.DataTypes.ByteString 9 | import ProjectM36.DataTypes.NonEmptyList 10 | import ProjectM36.AtomFunctions.Primitive 11 | import ProjectM36.AtomFunction 12 | import ProjectM36.DataTypes.List 13 | import ProjectM36.DataTypes.DateTime 14 | import qualified Data.HashSet as HS 15 | 16 | basicAtomFunctions :: AtomFunctions 17 | basicAtomFunctions = HS.unions [primitiveAtomFunctions, 18 | dayAtomFunctions, 19 | dateTimeAtomFunctions, 20 | eitherAtomFunctions, 21 | maybeAtomFunctions, 22 | listAtomFunctions, 23 | nonEmptyListAtomFunctions, 24 | bytestringAtomFunctions, 25 | intervalAtomFunctions] 26 | 27 | --these special atom functions aren't scripted so they can't be serialized normally. Instead, the body remains in the binary and the serialization/deserialization happens by name only. 28 | precompiledAtomFunctions :: AtomFunctions 29 | precompiledAtomFunctions = HS.filter (not . isScriptedAtomFunction) basicAtomFunctions -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | project-m36.cabal 3 | 4 | package * 5 | split-sections: True 6 | 7 | -- Required patch from head.hackage to fix: 8 | -- * `winery` compilation with GHC-9.6 9 | if impl(ghc >= 9.6) 10 | repository head.hackage.ghc.haskell.org 11 | url: https://ghc.gitlab.haskell.org/head.hackage/ 12 | secure: True 13 | key-threshold: 3 14 | root-keys: 15 | 26021a13b401500c8eb2761ca95c61f2d625bfef951b939a8124ed12ecf07329 16 | 7541f32a4ccca4f97aea3b22f5e593ba2c0267546016b992dfadcd2fe944e55d 17 | f76d08be13e9a61a377a85e2fb63f4c5435d40f8feb3e12eb05905edb8cdea89 18 | 19 | -- Loosened dependency bounds for compatibility with various versions of GHC. 20 | -- Remove these upper bound relaxations once the dependency has a new version 21 | -- released with higher upper bounds. 22 | -- 23 | -- Note: The 'allow-newer' fields are /concatenative/, meaning that each 24 | -- conditional statement which is satisfied will have thier listed packages 25 | -- unioned together into an aggregated set of 'allow-newer' packages constraints. 26 | -- Hence the 'allow-newer' constraints /accumulate/ as GHC versions increase. 27 | if impl(ghc >= 9.6) 28 | allow-newer: 29 | barbies-th:base, 30 | barbies-th:template-haskell 31 | 32 | if impl(ghc >= 9.8) 33 | allow-newer: 34 | streamly-bytestring:bytestring, 35 | 36 | if impl(ghc >= 9.10) 37 | allow-newer: 38 | streamly:base, 39 | streamly:template-haskell, 40 | streamly-core:base, 41 | streamly-core:template-haskell, 42 | websockets:containers, 43 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/Server/Config.hs: -------------------------------------------------------------------------------- 1 | module ProjectM36.Server.Config where 2 | import ProjectM36.Client 3 | 4 | data ServerConfig = ServerConfig { persistenceStrategy :: PersistenceStrategy, 5 | checkFS :: Bool, 6 | databaseName :: DatabaseName, 7 | bindAddress :: RemoteServerAddress, 8 | ghcPkgPaths :: [String], -- used for AtomFunction dynamic compilation 9 | perRequestTimeout :: Int, 10 | testMode :: Bool -- used exclusively for automated testing of the server, thus not accessible from the command line 11 | } 12 | deriving (Show) 13 | 14 | data WebsocketServerConfig = WebsocketServerConfig { wsServerConfig :: ServerConfig, 15 | tlsCertificatePath :: Maybe String, 16 | tlsKeyPath :: Maybe String 17 | } 18 | deriving (Show) 19 | 20 | defaultServerConfig :: ServerConfig 21 | defaultServerConfig = 22 | ServerConfig { persistenceStrategy = NoPersistence, 23 | checkFS = True, 24 | databaseName = "base", 25 | bindAddress = RemoteServerHostAddress "127.0.0.1" 6543, 26 | ghcPkgPaths = [], 27 | perRequestTimeout = 0, 28 | testMode = False 29 | } 30 | -------------------------------------------------------------------------------- /examples/DerivingCustomTupleable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric, DerivingVia, GeneralizedNewtypeDeriving, TypeOperators, DataKinds, OverloadedStrings #-} 2 | 3 | import ProjectM36.Tupleable.Deriving 4 | import ProjectM36.Atomable (Atomable) 5 | import Control.DeepSeq (NFData) 6 | import Data.Text (Text) 7 | import Codec.Winery 8 | 9 | newtype BlogId = BlogId { getBlogId :: Int } 10 | deriving stock (Eq, Ord, Show, Generic) 11 | deriving newtype (Num) 12 | deriving Serialise via WineryRecord BlogId 13 | 14 | instance NFData BlogId 15 | instance Atomable BlogId 16 | 17 | data Blog = Blog 18 | { blogId :: BlogId 19 | , blogTitle :: Text 20 | , blogAuthorName :: Text 21 | } 22 | deriving stock (Show, Generic) 23 | deriving (Tupleable) 24 | via Codec (Field (DropPrefix "blog" >>> CamelCase)) Blog 25 | deriving Serialise via WineryRecord Blog 26 | 27 | data Comment = Comment 28 | { commentAuthorName :: Text 29 | , commentComment :: Text 30 | , commentFor :: BlogId 31 | } 32 | deriving stock (Show, Generic) 33 | deriving (Tupleable) 34 | via Codec (Field (DropPrefix "comment" >>> CamelCase)) Comment 35 | deriving Serialise via WineryRecord Comment 36 | 37 | main :: IO () 38 | main = do 39 | let exampleBlog = Blog 40 | { blogId = 0 41 | , blogTitle = "Cat Pics" 42 | , blogAuthorName = "Alice" 43 | } 44 | exampleComment = Comment 45 | { commentAuthorName = "Bob" 46 | , commentComment = "great" 47 | , commentFor = 0 48 | } 49 | print exampleBlog 50 | print (toTuple exampleBlog) 51 | putStrLn "" 52 | print exampleComment 53 | print (toTuple exampleComment) 54 | -------------------------------------------------------------------------------- /docs/sqlegacy.markdown: -------------------------------------------------------------------------------- 1 | # SQLegacy: SQL on a Relational Algebra Engine 2 | 3 | ## Introduction 4 | 5 | Project:M36 is a relational algebra engine supporting Haskell, TutorialD, and SQL interfaces. While SQL purports to based on the relational algebra, SQL [takes liberties](why_sqlegacy.markdown) which cause it to stray from the mathematics of the algebra. Regardless, SQL is a popular and well-supported language for database interaction, so Project:M36 supports its own dialect of SQL called "SQLegacy" to emphasize that it is not the preferred interface to the relational algebra. This document explains how to use the SQLegacy console for legacy SQL usage. 6 | 7 | ## Setting Up 8 | 9 | To run the SQLegacy interactive console: 10 | 11 | ``` 12 | docker run -it projectm36/project-m36 sqlegacy 13 | ``` 14 | 15 | results in: 16 | 17 | ``` 18 | Project:M36 SQLegacy Interpreter 0.9.9 19 | SQL does not support the complete relational algebra. To access the complete relational algebra, use the bundled "tutd" interpreter. 20 | Type "help" for more information. 21 | SQLegacy (master/main): 22 | ``` 23 | 24 | ## SQL Commands 25 | 26 | The following commands are supported: 27 | 28 | * `SELECT` 29 | * `UPDATE` 30 | * `DELETE` 31 | * `INSERT` 32 | * `CREATE TABLE` 33 | * `DROP TABLE` 34 | * `BEGIN` 35 | * `COMMIT` 36 | * `ROLLBACK` 37 | * `IMPORT EXAMPLE CJDATE;` to load your database with tables "s", "sp", and "p" from C.J. Date's books on the relational algebra 38 | 39 | More information on how to use SQL can be found at existing [PostgreSQL tutorials](https://www.postgresqltutorial.com/). 40 | 41 | 42 | ## Limitations 43 | 44 | SQLegacy does not support duplicate rows in any context. To create "duplicate" rows, create a surrogate primary key column such as with a UUID. -------------------------------------------------------------------------------- /docs/server_mode.markdown: -------------------------------------------------------------------------------- 1 | # Project:M36 Server Mode 2 | 3 | ## Introduction 4 | 5 | While Project:M36 is easy-to-use as an interactive, in-process database management system, it can also be run as a server-based daemon to serve requests from multiple client applications. 6 | 7 | ## Starting the Server 8 | 9 | To start the Project:M36 server to serve the local host with a database named "mydbname", run ```cabal run project-m36-server -- --database mydbname --hostname 127.0.0.1``` in the project-m36 source directory. The double-dash indicates that the arguments should be passed to ```project-m36-server``` instead of ```cabal```. Under normal conditions, this command will print nothing and block indefinitely to serve incoming requests on the default port 6543. 10 | 11 | Note that the above invocation will serve an in-memory, transient "mydbname" database. The database is deleted when the server exits. To serve a database with filesystem persistence, invoke ```cabal run project-m36-server -- --database mydbname --hostname 127.0.0.1 --database-directory /path/to/dbdirectory --fsync```. 12 | 13 | ## Connecting an Interactive Client 14 | 15 | To start an interactive session with the server, run ```cabal run tutd -- --database mydbname --host 127.0.0.1```. This will open a TutorialD shell to the remote database and should operate exactly like a local session. Note that the import and export functions import and export from/to the client host's filesystem. There is currently no function to import or export from/to the server host's filesystem. 16 | 17 | ## Connecting a Haskell Client 18 | 19 | Connecting to a local or remote database uses the same API found in ```ProjectM36.Client```. See [this annotated example](../examples/SimpleClient.hs) for more information. 20 | 21 | 22 | -------------------------------------------------------------------------------- /nix/sources.json: -------------------------------------------------------------------------------- 1 | { 2 | "curryer": { 3 | "branch": "master", 4 | "description": "Fast Haskell RPC", 5 | "homepage": null, 6 | "owner": "agentm", 7 | "repo": "curryer", 8 | "rev": "74ecaac619ad1165a4517d5c0f4e530493bda130", 9 | "sha256": "1izdvzj00k0y76ixm7dfgvq2fzphb8h4nzqgwkl3p0bg0806rsn1", 10 | "type": "tarball", 11 | "url": "https://github.com/agentm/curryer/archive/74ecaac619ad1165a4517d5c0f4e530493bda130.tar.gz", 12 | "url_template": "https://github.com///archive/.tar.gz" 13 | }, 14 | "niv": { 15 | "branch": "master", 16 | "description": "Easy dependency management for Nix projects", 17 | "homepage": "https://github.com/nmattia/niv", 18 | "owner": "nmattia", 19 | "repo": "niv", 20 | "rev": "1819632b5823e0527da28ad82fecd6be5136c1e9", 21 | "sha256": "08jz17756qchq0zrqmapcm33nr4ms9f630mycc06i6zkfwl5yh5i", 22 | "type": "tarball", 23 | "url": "https://github.com/nmattia/niv/archive/1819632b5823e0527da28ad82fecd6be5136c1e9.tar.gz", 24 | "url_template": "https://github.com///archive/.tar.gz" 25 | }, 26 | "nixpkgs": { 27 | "branch": "master", 28 | "description": "Nix Packages collection", 29 | "homepage": "", 30 | "owner": "NixOS", 31 | "repo": "nixpkgs", 32 | "rev": "9fafaa30660e204bb27a35b3c608f03609705a5d", 33 | "sha256": "sha256:0ijw5yvglmh1kicxdailn0hvv2lbwbwgs9p9dshnxv0pvgvqi433", 34 | "type": "tarball", 35 | "url": "https://github.com/NixOS/nixpkgs/archive/9fafaa30660e204bb27a35b3c608f03609705a5d.tar.gz", 36 | "url_template": "https://github.com///archive/.tar.gz" 37 | } 38 | } 39 | -------------------------------------------------------------------------------- /examples/hair.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric, DeriveAnyClass, OverloadedStrings, DerivingVia #-} 2 | import ProjectM36.Client 3 | import ProjectM36.Relation.Show.Term 4 | import GHC.Generics 5 | import Data.Text 6 | import Control.DeepSeq 7 | import qualified Data.Map as M 8 | import qualified Data.Text.IO as TIO 9 | import Data.Proxy 10 | import Codec.Winery 11 | 12 | data Hair = Bald | Brown | Blond | OtherColor Text 13 | deriving (Generic, Show, Eq, NFData, Atomable) 14 | deriving Serialise via WineryVariant Hair 15 | 16 | main :: IO () 17 | main = do 18 | --connect to the database 19 | let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback [] basicDatabaseContext 20 | eCheck v = do 21 | x <- v 22 | case x of 23 | Left err -> error (show err) 24 | Right x' -> pure x' 25 | conn <- eCheck $ connectProjectM36 connInfo 26 | 27 | --create a database session at the default branch of the fresh database 28 | sessionId <- eCheck $ createSessionAtHead conn "master" 29 | 30 | --create the data type in the database context 31 | eCheck $ executeDatabaseContextExpr sessionId conn (toAddTypeExpr (Proxy :: Proxy Hair)) 32 | 33 | --create a relation with the new Hair AtomType 34 | let blond = NakedAtomExpr (toAtom Blond) 35 | eCheck $ executeDatabaseContextExpr sessionId conn 36 | (Assign "people" 37 | (MakeRelationFromExprs Nothing $ TupleExprs () [ 38 | TupleExpr (M.fromList [("hair", blond), ("name", NakedAtomExpr (TextAtom "Colin"))])])) 39 | 40 | let restrictionPredicate = AttributeEqualityPredicate "hair" blond 41 | peopleRel <- eCheck $ executeRelationalExpr sessionId conn (Restrict restrictionPredicate (RelationVariable "people" ())) 42 | 43 | TIO.putStrLn (showRelation peopleRel) 44 | 45 | -------------------------------------------------------------------------------- /src/bin/TutorialD/Interpreter/Import/Base.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module TutorialD.Interpreter.Import.Base where 3 | import ProjectM36.Base 4 | import ProjectM36.Error 5 | import Text.URI (URI) 6 | import Data.Text (Text) 7 | #if __GLASGOW_HASKELL__ < 804 8 | import Data.Monoid 9 | #endif 10 | 11 | -- | import data into a relation variable 12 | data RelVarDataImportOperator = RelVarDataImportOperator RelVarName FilePath (RelVarName -> TypeConstructorMapping -> Attributes -> FilePath -> IO (Either RelationalError DatabaseContextExpr)) 13 | 14 | instance Show RelVarDataImportOperator where 15 | show (RelVarDataImportOperator rv path _) = "RelVarDataImportOperator " <> show rv <> " " <> path 16 | 17 | type HashVerification = Maybe Text 18 | 19 | -- | import data into a database context 20 | data DatabaseContextDataImportOperator = DatabaseContextDataImportOperator URI HashVerification (URI -> HashVerification -> IO (Either RelationalError DatabaseContextExpr)) 21 | 22 | instance Show DatabaseContextDataImportOperator where 23 | show (DatabaseContextDataImportOperator uri hash _) = 24 | "DatabaseContextDataImportOperator " <> show uri <> " " <> show hash 25 | 26 | -- perhaps create a structure to import a whole transaction graph section in the future 27 | 28 | evalRelVarDataImportOperator :: RelVarDataImportOperator -> TypeConstructorMapping -> Attributes -> IO (Either RelationalError DatabaseContextExpr) 29 | evalRelVarDataImportOperator (RelVarDataImportOperator relVarName path importFunc) tConsMap attrs = importFunc relVarName tConsMap attrs path 30 | 31 | evalDatabaseContextDataImportOperator :: DatabaseContextDataImportOperator -> IO (Either RelationalError DatabaseContextExpr) 32 | evalDatabaseContextDataImportOperator (DatabaseContextDataImportOperator uri hash importFunc) = importFunc uri hash 33 | -------------------------------------------------------------------------------- /docs/simple_api.markdown: -------------------------------------------------------------------------------- 1 | # The Project:M36 Simple Client Interface 2 | 3 | ## Introduction 4 | 5 | For common use cases, the `ProjectM36.Client.Simple` API can assist in transaction management. The API is designed to be less overwhelming than the full-featured `ProjectM36.Client` (see [documentation](projectm36_client_library.markdown)). 6 | 7 | As such, not all features are available through the simple API, but, because the simple API is a thin layer over the complete API, the user may dip into the complete API at any time. 8 | 9 | ## Usage 10 | 11 | 1. Create a `DbConn` to connect to the database: 12 | 13 | ```haskell 14 | import ProjectM36.Client.Simple 15 | ... 16 | let connInfo = InProcessConnectionInfo (CrashSafePersistence "my.db") emptyNotificationCallback [] 17 | eDbconn <- simpleConnectProjectM36 connInfo 18 | ``` 19 | 20 | The result is `Either` a `DbError` or a connection linked to the `"master"` branch of the database. 21 | 22 | 1. Run the `Db` monad using `withTransaction`: 23 | 24 | ```haskell 25 | withTransaction dbconn $ do 26 | execute $ Assign "x" (ExistingRelation relationTrue) 27 | query $ RelationVariable "x" () 28 | ``` 29 | 30 | If there is an error in the above update or query, then an exception is thrown behind the scenes which cancels the transactions, rolls back any changes, and the error is returned by `withTransaction`. 31 | 32 | `query` is used with `RelationalExpr` queries which read the current database state. 33 | 34 | `execute` is used with `DatabaseContextExpr` values which write the current database state. 35 | 36 | To execute a query without cancelling the transaction on an error, use the `queryOrErr` and `executeOrErr` variants. 37 | 38 | 1. Close the connection: 39 | 40 | ```haskell 41 | close dbconn 42 | ``` 43 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/TupleSet.hs: -------------------------------------------------------------------------------- 1 | module ProjectM36.TupleSet where 2 | import ProjectM36.Base 3 | import ProjectM36.Tuple 4 | import ProjectM36.Error 5 | import qualified Data.HashSet as HS 6 | import qualified Data.Vector as V 7 | import qualified Control.Parallel.Strategies as P 8 | import Data.Either 9 | 10 | emptyTupleSet :: RelationTupleSet 11 | emptyTupleSet = RelationTupleSet [] 12 | 13 | singletonTupleSet :: RelationTupleSet 14 | singletonTupleSet = RelationTupleSet [emptyTuple] 15 | 16 | --ensure that all maps have the same keys and key count 17 | 18 | verifyTupleSet :: Attributes -> RelationTupleSet -> Either RelationalError RelationTupleSet 19 | verifyTupleSet attrs tupleSet = do 20 | --check that all tuples have the same attributes and that the atom types match 21 | let tupleList = map (verifyTuple attrs) (asList tupleSet) `P.using` P.parListChunk chunkSize P.r0 22 | chunkSize = (length . asList) tupleSet `div` 24 23 | --let tupleList = P.parMap P.rdeepseq (verifyTuple attrs) (HS.toList tupleSet) 24 | case lefts tupleList of 25 | x : _ -> Left x 26 | _ -> pure $ RelationTupleSet $ (HS.toList . HS.fromList) (rights tupleList) 27 | 28 | mkTupleSet :: Attributes -> [RelationTuple] -> Either RelationalError RelationTupleSet 29 | mkTupleSet attrs tuples = verifyTupleSet attrs (RelationTupleSet tuples) 30 | 31 | mkTupleSetFromList :: Attributes -> [[Atom]] -> Either RelationalError RelationTupleSet 32 | mkTupleSetFromList attrs atomMatrix = mkTupleSet attrs $ map (mkRelationTuple attrs . V.fromList) atomMatrix 33 | 34 | 35 | -- | Union two tuplesets while reordering their attribute/atom mapping properly. 36 | tupleSetUnion :: Attributes -> RelationTupleSet -> RelationTupleSet -> RelationTupleSet 37 | tupleSetUnion targetAttrs tupSet1 tupSet2 = RelationTupleSet $ HS.toList . HS.fromList $ reorder (asList tupSet1) ++ reorder (asList tupSet2) 38 | where 39 | reorder = map (reorderTuple targetAttrs) 40 | -------------------------------------------------------------------------------- /test/MultiProcessDatabaseAccess.hs: -------------------------------------------------------------------------------- 1 | --tests which cover multi-process access to the same database directory 2 | import Test.HUnit 3 | import ProjectM36.Client 4 | 5 | import System.IO.Temp 6 | import System.Exit 7 | import System.FilePath 8 | 9 | main :: IO () 10 | main = do 11 | tcounts <- runTestTT testList 12 | if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess 13 | 14 | assertIOEither :: (Show a) => IO (Either a b) -> IO b 15 | assertIOEither x = do 16 | ret <- x 17 | case ret of 18 | Left err -> assertFailure (show err) >> undefined 19 | Right val -> pure val 20 | 21 | testList :: Test 22 | testList = TestList [testMultipleProcessAccess] 23 | 24 | testMultipleProcessAccess :: Test 25 | testMultipleProcessAccess = TestCase $ 26 | withSystemTempDirectory "pm36" $ \tmpdir -> do 27 | let connInfo = InProcessConnectionInfo (MinimalPersistence dbdir) emptyNotificationCallback [] basicDatabaseContext 28 | master = "master" 29 | dudExpr = Assign "x" (RelationVariable "true" ()) 30 | dbdir = tmpdir "db" 31 | conn1 <- assertIOEither $ connectProjectM36 connInfo 32 | conn2 <- assertIOEither $ connectProjectM36 connInfo 33 | session1 <- assertIOEither (createSessionAtHead conn1 master) 34 | session2 <- assertIOEither (createSessionAtHead conn2 master) 35 | --add a commit on conn1 which conn2 doesn't know about 36 | assertIOEither $ executeDatabaseContextExpr session1 conn1 dudExpr 37 | assertIOEither $ commit session1 conn1 38 | 39 | assertIOEither $ executeDatabaseContextExpr session2 conn2 dudExpr 40 | eHeadId <- headTransactionId session2 conn2 41 | headId <- case eHeadId of 42 | Left err -> assertFailure ("headTransactionId failed: " ++ show err) >> undefined 43 | Right x -> pure x 44 | res <- commit session2 conn2 45 | assertEqual "commit should fail" (Left (TransactionIsNotAHeadError headId)) res 46 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/Sessions.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PackageImports #-} 2 | module ProjectM36.Sessions where 3 | import Control.Concurrent.STM 4 | #if MIN_VERSION_stm_containers(1,0,0) 5 | import qualified StmContainers.Map as StmMap 6 | import qualified StmContainers.Set as StmSet 7 | #else 8 | import qualified STMContainers.Map as StmMap 9 | import qualified STMContainers.Set as StmSet 10 | #endif 11 | import ProjectM36.Attribute 12 | import ProjectM36.Base 13 | import ProjectM36.Session 14 | import ProjectM36.Relation 15 | import ProjectM36.Error 16 | import qualified Data.UUID as U 17 | #if MIN_VERSION_stm_containers(1,0,0) 18 | import qualified Control.Foldl as Foldl 19 | import qualified DeferredFolds.UnfoldlM as UF 20 | #else 21 | import "list-t" ListT 22 | #endif 23 | 24 | type Sessions = StmMap.Map SessionId Session 25 | 26 | --from https://github.com/nikita-volkov/stm-containers/blob/master/test/Main/MapTests.hs 27 | stmMapToList :: StmMap.Map k v -> STM [(k, v)] 28 | #if MIN_VERSION_stm_containers(1,0,0) 29 | stmMapToList = UF.foldM (Foldl.generalize Foldl.list) . StmMap.unfoldlM 30 | #else 31 | stmMapToList = ListT.fold (\l -> return . (:l)) [] . StmMap.stream 32 | #endif 33 | 34 | stmSetToList :: StmSet.Set v -> STM [v] 35 | #if MIN_VERSION_stm_containers(1,0,0) 36 | stmSetToList = UF.foldM (Foldl.generalize Foldl.list) . StmSet.unfoldlM 37 | #else 38 | stmSetToList = ListT.fold (\l -> return . (:l)) [] . StmSet.stream 39 | #endif 40 | 41 | uuidAtom :: U.UUID -> Atom 42 | uuidAtom = TextAtom . U.toText 43 | 44 | sessionsAsRelation :: Sessions -> STM (Either RelationalError Relation) 45 | sessionsAsRelation sessions = do 46 | sessionAssocs <- stmMapToList sessions 47 | let atomMatrix = map (\(sessionId, session) -> [uuidAtom sessionId, uuidAtom (parentId session)]) sessionAssocs 48 | pure $ mkRelationFromList (attributesFromList [Attribute "sessionid" TextAtomType, 49 | Attribute "parentCommit" TextAtomType]) atomMatrix 50 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/Atom.hs: -------------------------------------------------------------------------------- 1 | module ProjectM36.Atom where 2 | import ProjectM36.Base 3 | import ProjectM36.Error 4 | import ProjectM36.DataTypes.Interval 5 | import qualified Data.Text as T 6 | #if __GLASGOW_HASKELL__ < 804 7 | import Data.Monoid 8 | #endif 9 | 10 | relationForAtom :: Atom -> Either RelationalError Relation 11 | relationForAtom (RelationAtom rel) = Right rel 12 | relationForAtom _ = Left $ AttributeIsNotRelationValuedError "" 13 | 14 | atomToText :: Atom -> T.Text 15 | atomToText (IntegerAtom i) = (T.pack . show) i 16 | atomToText (IntAtom i) = (T.pack . show) i 17 | atomToText (ScientificAtom s) = (T.pack . show) s 18 | atomToText (DoubleAtom i) = (T.pack . show) i 19 | atomToText (TextAtom i) = (T.pack . show) i --quotes necessary for ConstructedAtom subatoms 20 | atomToText (DayAtom i) = (T.pack . show) i 21 | atomToText (DateTimeAtom i) = (T.pack . show) i 22 | atomToText (ByteStringAtom i) = (T.pack . show) i 23 | atomToText (BoolAtom i) = (T.pack . show) i 24 | atomToText (UUIDAtom u) = (T.pack . show) u 25 | atomToText (RelationalExprAtom re) = (T.pack . show) re 26 | atomToText (SubrelationFoldAtom rel attrName) = (T.pack . show) rel <> " @" <> attrName 27 | atomToText (RelationAtom i) = (T.pack . show) i 28 | atomToText (ConstructedAtom dConsName typ atoms) 29 | | isIntervalAtomType typ = case atoms of --special handling for printing intervals 30 | [b, e, BoolAtom bo, BoolAtom be] -> 31 | let beginp = if bo then "(" else "[" 32 | begin = atomToText b 33 | end = atomToText e 34 | endp = if be then ")" else "]" in 35 | beginp <> begin <> "," <> end <> endp 36 | _ -> "invalid interval" 37 | | otherwise = dConsName <> dConsArgs 38 | where 39 | parensAtomToText a@(ConstructedAtom _ _ []) = atomToText a 40 | parensAtomToText a@ConstructedAtom{} = "(" <> atomToText a <> ")" 41 | parensAtomToText a = atomToText a 42 | 43 | dConsArgs = case atoms of 44 | [] -> "" 45 | args -> " " <> T.intercalate " " (map parensAtomToText args) 46 | 47 | 48 | 49 | -------------------------------------------------------------------------------- /examples/SimpleClient.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | -- This suppresses the incomplete pattern match on @(Right tupSet)@ 3 | {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} 4 | import ProjectM36.Client 5 | import ProjectM36.TupleSet 6 | import ProjectM36.Relation.Show.Term 7 | import Data.Text.IO as TIO 8 | 9 | main :: IO () 10 | main = do 11 | -- 1. create a ConnectionInfo 12 | let connInfo = RemoteConnectionInfo "mytestdb" defaultRemoteServerAddress emptyNotificationCallback 13 | -- 2. connected to the remote database 14 | eConn <- connectProjectM36 connInfo 15 | case eConn of 16 | Left err -> print err 17 | Right conn -> do 18 | --3. create a session on the "master" branch 19 | eSessionId <- createSessionAtHead conn "master" 20 | case eSessionId of 21 | Left err -> print err 22 | Right sessionId -> do 23 | --4. define a new relation variable with a DatabaseContext expression 24 | let attrList = [Attribute "name" TextAtomType, 25 | Attribute "age" IntAtomType] 26 | attrs = attributesFromList attrList 27 | mErr1 <- executeDatabaseContextExpr sessionId conn (Define "person" (map NakedAttributeExpr attrList)) 28 | print mErr1 29 | --5. add a tuple to the relation referenced by the relation variable 30 | let (Right tupSet) = mkTupleSetFromList attrs [[TextAtom "Bob", IntAtom 45]] 31 | mErr2 <- executeDatabaseContextExpr sessionId conn (Insert "person" (MakeStaticRelation attrs tupSet)) 32 | print mErr2 33 | 34 | --6. execute a relational algebra query 35 | let restrictionPredicate = AttributeEqualityPredicate "name" (NakedAtomExpr (TextAtom "Steve")) 36 | eRel <- executeRelationalExpr sessionId conn (Restrict restrictionPredicate (RelationVariable "person" ())) 37 | case eRel of 38 | Left err -> print err 39 | Right rel -> TIO.putStrLn (showRelation rel) 40 | 41 | --7. close the connection 42 | close conn 43 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/Session.hs: -------------------------------------------------------------------------------- 1 | module ProjectM36.Session where 2 | import ProjectM36.Base 3 | import Data.UUID 4 | import qualified Data.Map as M 5 | import ProjectM36.Error 6 | import qualified ProjectM36.DisconnectedTransaction as Discon 7 | 8 | type SessionId = UUID 9 | 10 | --the persistence of a session is as long as the life of the database (not serialized to disk) 11 | -- sessions are not associated with connections and have separate lifetimes 12 | -- | Represents a pointer into the database's transaction graph which the 'DatabaseContextExpr's can then modify subsequently be committed to extend the transaction graph. The session contains staged (uncommitted) database changes as well as the means to switch between isomorphic schemas. 13 | data Session = Session DisconnectedTransaction SchemaName 14 | 15 | defaultSchemaName :: SchemaName 16 | defaultSchemaName = "main" 17 | 18 | disconnectedTransaction :: Session -> DisconnectedTransaction 19 | disconnectedTransaction (Session discon _) = discon 20 | 21 | isDirty :: Session -> DirtyFlag 22 | isDirty (Session discon _) = Discon.isDirty discon 23 | 24 | concreteDatabaseContext :: Session -> DatabaseContext 25 | concreteDatabaseContext (Session (DisconnectedTransaction _ (Schemas context _) _) _) = context 26 | 27 | parentId :: Session -> TransactionId 28 | parentId (Session (DisconnectedTransaction parentUUID _ _) _) = parentUUID 29 | 30 | subschemas :: Session -> Subschemas 31 | subschemas (Session (DisconnectedTransaction _ (Schemas _ s) _) _) = s 32 | 33 | schemas :: Session -> Schemas 34 | schemas (Session (DisconnectedTransaction _ s _) _) = s 35 | 36 | schemaName :: Session -> SchemaName 37 | schemaName (Session _ s) = s 38 | 39 | setSchemaName :: SchemaName -> Session -> Either RelationalError Session 40 | setSchemaName sname session = if sname == defaultSchemaName || M.member sname (subschemas session) then 41 | pure (Session (disconnectedTransaction session) sname) 42 | else 43 | Left (SubschemaNameNotInUseError sname) 44 | 45 | -------------------------------------------------------------------------------- /docs/jupyter_kernel.markdown: -------------------------------------------------------------------------------- 1 | # TutorialD Jupyter Kernel for Project:M36 2 | 3 | ## Introduction 4 | 5 | [The Jupyter Notebook](https://jupyter-notebook.readthedocs.io/en/stable/notebook.html) is web-based tool for experimenting with various languages. Project:M36 offers a Jupyter kernel for the TutorialD interpreter. 6 | 7 | The kernel automatically starts and stops its own websocket-server-based database and offers no filesystem persistence, which is similar to other jupyter kernels. 8 | 9 | ## Installation 10 | 11 | To install the `tutd` kernel: 12 | 13 | * install the `itutd` module into your jupyter virtual environment: 14 | ``` 15 | $ cd project-m36/jupyter/itutd 16 | $ pip install . 17 | ``` 18 | 19 | * install `kernel.json`: 20 | 21 | ```$ mkdir ~/Library/Jupyter/kernels/itutd && cp project-m36/jupyter/kernel.json ~/Library/Jupyter/kernels/itutd``` (macOS) 22 | 23 | ```$ mkdir ~/.local/share/jupyter/kernels/tutd && cp project-m36/jupyter/kernel.json ~/.local/share/jupyter/kernels/tutd``` (Linux) 24 | 25 | ```$ mkdir %APPDATA%\jupyter\kernels\tutd && copy project-m36\jupyter\kernel.json %APPDATA%\jupyter\kernels\tutd``` (Windows) 26 | 27 | * check that the kernel is detected: 28 | ``` 29 | $ jupyter kernelspec list 30 | Available kernels: 31 | python2 ... 32 | tutd ... 33 | ``` 34 | 35 | * add `project-m36-server` to `PATH` environment variable 36 | 37 | ``` 38 | $ export PATH=$PATH: 39 | $ which project-m36-websocket-server 40 | /path/to/project-m36-websocket-server 41 | ``` 42 | 43 | From within this python virtual environment, you can now start jupyter with TutorialD support. 44 | 45 | ## Usage 46 | 47 | With the kernel installed, run `jupyter notebook` for the web-based interface and click "New" at the top right of the page. The TutorialD kernel should be in the list. 48 | 49 | Once a new TutorialD notebook is opened, the interpreter is identical to the `tutd` command line interpreter and accepts the same commands. If you are new to Project:M36-flavored TutorialD, please [read the tutorial](/docs/tutd_tutorial.markdown). 50 | -------------------------------------------------------------------------------- /src/bin/SQL/Interpreter/sqlegacy.hs: -------------------------------------------------------------------------------- 1 | -- the sqlegacy SQL interpreter wrap 2 | {-# LANGUAGE CPP #-} 3 | import ProjectM36.Base 4 | import ProjectM36.Cli 5 | import SQL.Interpreter 6 | import ProjectM36.SQLDatabaseContext 7 | import ProjectM36.Error 8 | import System.Directory 9 | import System.FilePath 10 | import qualified ProjectM36.Client as C 11 | import qualified Data.Text as T 12 | import Data.Either (fromRight) 13 | import Control.Exception (catchJust) 14 | import ProjectM36.Interpreter 15 | 16 | #if !defined(VERSION_project_m36) 17 | # warning Failed to discover proper version from cabal_macros.h 18 | # define VERSION_project_m36 "" 19 | #endif 20 | 21 | main :: IO () 22 | main = do 23 | homeDir <- getHomeDirectory 24 | let historyPath = homeDir ".sqlegacy_history" 25 | mainLoop printWelcome historyPath sqlReprLoop promptText sqlReprLoop sqlDatabaseContext 26 | 27 | printWelcome :: IO () 28 | printWelcome = do 29 | putStrLn ("Project:M36 SQLegacy Interpreter " ++ VERSION_project_m36) 30 | putStrLn "SQL does not support the complete relational algebra. To access the complete relational algebra, use the bundled \"tutd\" interpreter." 31 | putStrLn "Type \"help;\" for more information." 32 | 33 | sqlReprLoop :: C.SessionId -> C.Connection -> Maybe PromptLength -> T.Text -> IO () 34 | sqlReprLoop sessionId conn mPromptLength userInput = do 35 | case parseSQLUserInput userInput of 36 | Left err -> 37 | displayResult (DisplayParseErrorResult mPromptLength err) 38 | Right parsed -> 39 | catchJust (\exc -> if exc == C.RequestTimeoutException then Just exc else Nothing) (do 40 | evald <- evalSQLInteractive sessionId conn UnsafeEvaluation True parsed 41 | mapM_ displayResult evald) 42 | (\_ -> displayResult (DisplayErrorResult "Request timed out.")) 43 | 44 | 45 | promptText :: Either RelationalError HeadName -> Either RelationalError SchemaName -> StringType 46 | promptText eHeadName eSchemaName = "SQLegacy (" <> transInfo <> "): " 47 | where 48 | transInfo = fromRight "" eHeadName <> "/" <> fromRight "" eSchemaName 49 | 50 | -------------------------------------------------------------------------------- /sql_optimizations_applied: -------------------------------------------------------------------------------- 1 | https://blog.jooq.org/2017/09/28/10-cool-sql-optimisations-that-do-not-depend-on-the-cost-model/#top3 2 | 3 | 1. Transitive Closure - done 4 | 5 | SELECT first_name, last_name, film_id 6 | FROM actor a 7 | JOIN film_actor fa ON a.actor_id = fa.actor_id 8 | WHERE a.actor_id = 1; 9 | 10 | --> 11 | 12 | SELECT first_name, last_name, film_id 13 | FROM actor a 14 | JOIN film_actor fa ON a.actor_id = fa.actor_id 15 | WHERE a.actor_id = 1 16 | AND fa.actor_id = 1; 17 | 18 | (x join y [on x.a = y.a]) where x.a = 1 19 | -> 20 | (x where x.a = 1) join (y where y.a = 1) 21 | 22 | or 23 | 24 | x where a=@b and b=3 25 | -> 26 | x where a=3 and b=3 27 | 28 | 2. Impossible Predicates - Done 29 | 30 | s where 3 = 5 31 | s where true -> s 32 | s where false -> emptied s 33 | 34 | 3. Join Elimination - Done 35 | 36 | SELECT first_name, last_name 37 | FROM customer c 38 | JOIN address a ON c.address_id = a.address_id 39 | 40 | --> 41 | 42 | SELECT first_name, last_name 43 | FROM customer c 44 | 45 | 46 | (x join y){x.attrs only} iff there is a foreign key constraint on the full join condition from x to y 47 | 48 | 4. Silly Predicates - done 49 | 50 | where true -> X 51 | where attr = attr -> X 52 | insert s s where name = @name -> X 53 | 54 | 5. Projections in Exists Subqueries 55 | 56 | Our exists clause is a projection against zero attributes already. 57 | 58 | 6. Predicate Merging - Done 59 | 60 | where X and X -> where X 61 | where X or X -> where X 62 | 63 | 7. Empty Sets 64 | 65 | Use constraints to determine if a predicate is provably false: 66 | 67 | constraint x > 100 68 | where x = 10 -> where false 69 | 70 | X join false -> x where false 71 | x join true -> x where false 72 | 73 | 8. CHECK() constraints 74 | 75 | not relevant - see 7 76 | 77 | 9. Unneeded self join - done 78 | 79 | x join x -> x 80 | (x where c1) join (x where c2) -> x where c1 and c2 81 | (x where c1) union (x where c2) -> x where c1 or c2 82 | 83 | 10. Predicate Pushdown - done 84 | 85 | (x where c1) where c2 -> x where c1 and c2 - done 86 | x{proj} where c1 -> (x where c1){proj} #project on fewer tuples 87 | (x union y) where c -> (x where c) union (y where c) -------------------------------------------------------------------------------- /src/lib/ProjectM36/GraphRefRelationalExpr.hs: -------------------------------------------------------------------------------- 1 | module ProjectM36.GraphRefRelationalExpr where 2 | --evaluate relational expressions across the entire transaction graph to support cross-transaction referencing 3 | import ProjectM36.Base 4 | import qualified Data.Set as S 5 | 6 | data SingularTransactionRef = SingularTransactionRef GraphRefTransactionMarker | 7 | MultipleTransactionsRef | 8 | NoTransactionsRef 9 | deriving (Eq, Show) 10 | 11 | instance Semigroup SingularTransactionRef where 12 | NoTransactionsRef <> x = x 13 | MultipleTransactionsRef <> _ = MultipleTransactionsRef 14 | SingularTransactionRef tidA <> s@(SingularTransactionRef tidB) = 15 | if tidA == tidB then 16 | s 17 | else 18 | MultipleTransactionsRef 19 | s@SingularTransactionRef{} <> NoTransactionsRef = s 20 | _ <> MultipleTransactionsRef = MultipleTransactionsRef 21 | 22 | instance Monoid SingularTransactionRef where 23 | mempty = NoTransactionsRef 24 | 25 | -- | return `Just transid` if this GraphRefRelationalExpr refers to just one transaction in the graph. This is useful for determining if certain optimizations can apply. 26 | singularTransaction :: Foldable t => t GraphRefTransactionMarker -> SingularTransactionRef 27 | singularTransaction expr = case S.toList $ foldr S.insert S.empty expr of 28 | [] -> NoTransactionsRef 29 | x : xs -> case xs of 30 | [] -> SingularTransactionRef x 31 | _ -> MultipleTransactionsRef 32 | 33 | -- | Return True if two 'GraphRefRelationalExpr's both refer exclusively to the same transaction (or none at all). 34 | inSameTransaction :: GraphRefRelationalExpr -> GraphRefRelationalExpr -> Maybe GraphRefTransactionMarker 35 | inSameTransaction exprA exprB = case (stA, stB) of 36 | (SingularTransactionRef tA, SingularTransactionRef tB) | tA == tB -> Just tA 37 | _ -> Nothing 38 | where stA = singularTransaction exprA 39 | stB = singularTransaction exprB 40 | 41 | singularTransactions :: (Foldable f, Foldable t) => f (t GraphRefTransactionMarker) -> SingularTransactionRef 42 | singularTransactions = foldMap singularTransaction 43 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/Relation/Show/CSV.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | module ProjectM36.Relation.Show.CSV where 3 | import ProjectM36.Base 4 | import ProjectM36.Attribute as A 5 | import Data.Csv 6 | import ProjectM36.Tuple 7 | import qualified Data.ByteString.Lazy as BS 8 | import qualified Data.Vector as V 9 | import ProjectM36.Error 10 | import qualified Data.Text.Encoding as TE 11 | import ProjectM36.Atom 12 | 13 | --spit out error for relations without attributes (since relTrue and relFalse cannot be distinguished then as CSV) and for relations with relation-valued attributes 14 | relationAsCSV :: Relation -> Either RelationalError BS.ByteString 15 | relationAsCSV (Relation attrs tupleSet) 16 | --check for relvalued attributes 17 | | relValAttrs /= [] = 18 | Left $ RelationValuedAttributesNotSupportedError (map attributeName relValAttrs) 19 | --check that there is at least one attribute 20 | | A.null attrs = 21 | Left $ TupleAttributeCountMismatchError 0 22 | | otherwise = 23 | Right $ encodeByName bsAttrNames $ map RecordRelationTuple (asList tupleSet) 24 | where 25 | relValAttrs = V.toList $ V.filter (isRelationAtomType . atomType) (attributesVec attrs) 26 | bsAttrNames = V.map (TE.encodeUtf8 . attributeName) (attributesVec attrs) 27 | 28 | {- 29 | instance ToRecord RelationTuple where 30 | toRecord tuple = toRecord $ map toField (V.toList $ tupleAtoms tuple) 31 | -} 32 | 33 | newtype RecordRelationTuple = RecordRelationTuple {unTuple :: RelationTuple} 34 | 35 | instance ToNamedRecord RecordRelationTuple where 36 | toNamedRecord rTuple = namedRecord $ map (\(k,v) -> TE.encodeUtf8 k .= RecordAtom v) (tupleAssocs $ unTuple rTuple) 37 | 38 | instance DefaultOrdered RecordRelationTuple where 39 | headerOrder (RecordRelationTuple tuple) = V.map (TE.encodeUtf8 . attributeName) (attributesVec (tupleAttributes tuple)) 40 | 41 | newtype RecordAtom = RecordAtom {unAtom :: Atom} 42 | 43 | instance ToField RecordAtom where 44 | toField (RecordAtom (TextAtom atomVal)) = TE.encodeUtf8 atomVal --without this, CSV text atoms are doubly quoted 45 | toField (RecordAtom atomVal) = (TE.encodeUtf8 . atomToText) atomVal 46 | 47 | 48 | -------------------------------------------------------------------------------- /src/bin/TutorialD/Interpreter/TransGraphRelationalOperator.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | module TutorialD.Interpreter.TransGraphRelationalOperator where 4 | import ProjectM36.TransGraphRelationalExpression 5 | import ProjectM36.TransactionGraph 6 | import ProjectM36.Interpreter 7 | import TutorialD.Interpreter.Types 8 | import qualified ProjectM36.Client as C 9 | 10 | import TutorialD.Interpreter.Base 11 | import TutorialD.Interpreter.RelationalExpr 12 | 13 | import qualified Data.Text as T 14 | 15 | instance RelationalMarkerExpr TransactionIdLookup where 16 | parseMarkerP = string "@" *> transactionIdLookupP 17 | 18 | newtype TransGraphRelationalOperator = ShowTransGraphRelation TransGraphRelationalExpr 19 | deriving Show 20 | 21 | transactionIdLookupP :: Parser TransactionIdLookup 22 | transactionIdLookupP = (TransactionIdLookup <$> uuidP) <|> 23 | (TransactionIdHeadNameLookup <$> identifierP <*> many transactionIdHeadBacktrackP) 24 | 25 | transactionIdHeadBacktrackP :: Parser TransactionIdHeadBacktrack 26 | transactionIdHeadBacktrackP = (string "~" *> (TransactionIdHeadParentBacktrack <$> backtrackP)) <|> 27 | (string "^" *> (TransactionIdHeadBranchBacktrack <$> backtrackP)) <|> 28 | (string "@" *> (TransactionStampHeadBacktrack <$> utcTimeP)) 29 | 30 | backtrackP :: Parser Int 31 | backtrackP = fromIntegral <$> integer <|> pure 1 32 | 33 | transGraphRelationalOpP :: Parser TransGraphRelationalOperator 34 | transGraphRelationalOpP = showTransGraphRelationalOpP 35 | 36 | showTransGraphRelationalOpP :: Parser TransGraphRelationalOperator 37 | showTransGraphRelationalOpP = do 38 | reservedOp ":showtransgraphexpr" 39 | ShowTransGraphRelation <$> relExprP 40 | 41 | evalTransGraphRelationalOp :: C.SessionId -> C.Connection -> TransGraphRelationalOperator -> IO ConsoleResult 42 | evalTransGraphRelationalOp sessionId conn (ShowTransGraphRelation expr) = do 43 | res <- C.executeTransGraphRelationalExpr sessionId conn expr 44 | case res of 45 | Left err -> pure $ DisplayErrorResult $ T.pack (show err) 46 | Right rel -> pure $ DisplayRelationResult rel 47 | 48 | -------------------------------------------------------------------------------- /docs/dataframes.markdown: -------------------------------------------------------------------------------- 1 | # Project:M36 DataFrames 2 | 3 | Users of typical relational algebra engines have come to expect sorting and limiting of query results despite the fact that relations do not support ordering. To that end, Project:M36 supports converting relations to "data frames" to support sorting on attributes and limiting the maximum tuple count in the result set. 4 | 5 | The equivalent feature in SQL is invoked by the `ORDER BY`, `LIMIT`, and `OFFSET` clauses. 6 | 7 | ## Usage 8 | 9 | From within the `tutd` console, converting a relation to be sorted as a data frame is invoked using the `:showdataframe` command. 10 | 11 | ``` 12 | :showdataframe orderby {} {offset } {limit } 13 | ``` 14 | 15 | The default sort order is `ascending`. 16 | 17 | ## Examples 18 | 19 | ``` 20 | TutorialD (master/main): :showdataframe (s) orderby {status} 21 | ┌──┬───────────┬─────────┬────────────┬────────────────┐ 22 | │DF│city::Text↕│s#::Text↕│sname::Text↕│status::Integer⬆│ 23 | ├──┼───────────┼─────────┼────────────┼────────────────┤ 24 | │1 │"Paris" │"S2" │"Jones" │10 │ 25 | │2 │"London" │"S1" │"Smith" │20 │ 26 | │3 │"London" │"S4" │"Clark" │20 │ 27 | │4 │"Athens" │"S5" │"Adams" │30 │ 28 | │5 │"Paris" │"S3" │"Blake" │30 │ 29 | └──┴───────────┴─────────┴────────────┴────────────────┘ 30 | TutorialD (master/main): :showdataframe (s{status}) orderby {status} 31 | ┌──┬────────────────┐ 32 | │DF│status::Integer⬆│ 33 | ├──┼────────────────┤ 34 | │1 │10 │ 35 | │2 │20 │ 36 | │3 │30 │ 37 | └──┴────────────────┘ 38 | TutorialD (master/main): :showdataframe (s{status}) orderby {status descending} limit 1 39 | ┌──┬────────────────┐ 40 | │DF│status::Integer⬇│ 41 | ├──┼────────────────┤ 42 | │1 │30 │ 43 | └──┴────────────────┘ 44 | TutorialD (master/main): :showdataframe (s{status}) orderby {status descending} offset 1 limit 3 45 | ┌──┬────────────────┐ 46 | │DF│status::Integer⬇│ 47 | ├──┼────────────────┤ 48 | │1 │20 │ 49 | │2 │10 │ 50 | └──┴────────────────┘ 51 | 52 | ``` 53 | The arrow in the attributes indicates the sort order while the DF column indicates the row number based on the sort order. Column ordering can also be arbitrary. -------------------------------------------------------------------------------- /src/bin/TutorialD/Interpreter/DatabaseContextIOOperator.hs: -------------------------------------------------------------------------------- 1 | --compiling the script requires the IO monad because it must load modules from the filesystem, so we create the function and generate the requisite DatabaseExpr here. 2 | module TutorialD.Interpreter.DatabaseContextIOOperator where 3 | import ProjectM36.Base 4 | import ProjectM36.Interpreter 5 | import TutorialD.Interpreter.Base 6 | import TutorialD.Interpreter.Types 7 | import Data.Text 8 | 9 | addAtomFunctionExprP :: Parser DatabaseContextIOExpr 10 | addAtomFunctionExprP = dbioexprP "addatomfunction" AddAtomFunction 11 | 12 | addDatabaseContextFunctionExprP :: Parser DatabaseContextIOExpr 13 | addDatabaseContextFunctionExprP = dbioexprP "adddatabasecontextfunction" AddDatabaseContextFunction 14 | 15 | createArbitraryRelationP :: Parser DatabaseContextIOExpr 16 | createArbitraryRelationP = do 17 | reserved "createarbitraryrelation" 18 | relVarName <- identifierP 19 | attrExprs <- makeAttributeExprsP :: Parser [AttributeExpr] 20 | min' <- fromInteger <$> integer 21 | _ <- symbol "-" 22 | max' <- fromInteger <$> integer 23 | pure $ CreateArbitraryRelation relVarName attrExprs (min',max') 24 | 25 | dbioexprP :: ParseStr -> (Text -> [TypeConstructor] -> Text -> DatabaseContextIOExpr) -> Parser DatabaseContextIOExpr 26 | dbioexprP res adt = do 27 | reserved res 28 | funcName' <- quotedString 29 | funcType' <- atomTypeSignatureP 30 | adt funcName' funcType' <$> quotedString 31 | 32 | atomTypeSignatureP :: Parser [TypeConstructor] 33 | atomTypeSignatureP = sepBy typeConstructorP arrow 34 | 35 | dbContextIOExprP :: Parser DatabaseContextIOExpr 36 | dbContextIOExprP = addAtomFunctionExprP <|> 37 | addDatabaseContextFunctionExprP <|> 38 | loadAtomFunctionsP <|> 39 | loadDatabaseContextFunctionsP <|> 40 | createArbitraryRelationP 41 | 42 | loadAtomFunctionsP :: Parser DatabaseContextIOExpr 43 | loadAtomFunctionsP = do 44 | reserved "loadatomfunctions" 45 | LoadAtomFunctions <$> quotedString <*> quotedString <*> fmap unpack quotedString 46 | 47 | loadDatabaseContextFunctionsP :: Parser DatabaseContextIOExpr 48 | loadDatabaseContextFunctionsP = do 49 | reserved "loaddatabasecontextfunctions" 50 | LoadDatabaseContextFunctions <$> quotedString <*> quotedString <*> fmap unpack quotedString 51 | 52 | -------------------------------------------------------------------------------- /examples/Hospital.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass,DeriveGeneric #-} 2 | module Hospital where 3 | 4 | import ProjectM36.Client 5 | import ProjectM36.Atom 6 | import Data.Typeable 7 | import ProjectM36.Relation 8 | import Data.Binary 9 | import Control.DeepSeq 10 | import Data.Text 11 | import GHC.Generics 12 | import Data.Hashable 13 | import ProjectM36.Tuple 14 | 15 | data AgeType = PreciseAge Int | 16 | ForgotToAsk | 17 | RefusedToDisclose | 18 | NotApplicable | 19 | ApproximateAge Int Int 20 | deriving (Eq,Show,Read,Hashable,Binary,Typeable,NFData,Generic) 21 | 22 | instance Atomable AgeType 23 | 24 | failFastMaybe :: (Show a) => Maybe a -> IO () 25 | failFastMaybe (Just err) = error (show err) 26 | failFastMaybe Nothing = return () 27 | 28 | failFastEither :: Show a => Either a b -> IO b 29 | failFastEither (Left err) = error (show err) 30 | failFastEither (Right val) = return val 31 | 32 | ageAtomType :: AtomType 33 | ageAtomType = atomTypeForProxy (Proxy :: Proxy AgeType) 34 | 35 | runExample :: IO () 36 | runExample = do 37 | let bob_relation_attrs = attributesFromList [Attribute "name" stringAtomType, 38 | Attribute "age" ageAtomType] 39 | relvar_name = "hospital_patient" 40 | age_value_in = ApproximateAge 30 40 41 | bob_relation_err = mkRelationFromList 42 | bob_relation_attrs 43 | [[Atom ("Bob"::Text), Atom age_value_in]] 44 | 45 | connerr <- connectProjectM36 (InProcessConnectionInfo NoPersistence) 46 | conn <- failFastEither connerr 47 | bob_relation <- failFastEither bob_relation_err 48 | merr <- executeDatabaseContextExpr conn (Assign relvar_name (ExistingRelation bob_relation)) 49 | failFastMaybe merr 50 | result_err <- executeRelationalExpr conn (RelationVariable relvar_name) 51 | result <- failFastEither result_err 52 | case singletonTuple result of 53 | Nothing -> error "not a singleton relation!" 54 | Just tuple -> do 55 | (Atom age_value_out) <- failFastEither $ atomForAttributeName "age" tuple 56 | print age_value_in 57 | print age_value_out 58 | case cast age_value_out of 59 | Nothing -> error "wrong datatype" 60 | Just age_value_out' -> 61 | print (age_value_in == age_value_out') 62 | 63 | 64 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/DataTypes/Maybe.hs: -------------------------------------------------------------------------------- 1 | module ProjectM36.DataTypes.Maybe where 2 | import ProjectM36.Base 3 | import ProjectM36.DataTypes.Primitive 4 | import ProjectM36.AtomFunctionError 5 | import qualified Data.HashSet as HS 6 | import qualified Data.Map as M 7 | 8 | maybeAtomType :: AtomType -> AtomType 9 | maybeAtomType arg = ConstructedAtomType "Maybe" (M.singleton "a" arg) 10 | 11 | maybeTypeConstructorMapping :: TypeConstructorMapping 12 | maybeTypeConstructorMapping = [(ADTypeConstructorDef "Maybe" ["a"], 13 | [DataConstructorDef "Nothing" [], 14 | DataConstructorDef "Just" [DataConstructorDefTypeVarNameArg "a"]]) 15 | ] 16 | 17 | maybeAtomFunctions :: AtomFunctions 18 | maybeAtomFunctions = HS.fromList [ 19 | Function { 20 | funcName ="isJust", 21 | funcType = [maybeAtomType (TypeVariableType "a"), BoolAtomType], 22 | funcBody = FunctionBuiltInBody $ 23 | \case 24 | ConstructedAtom dConsName _ _:_ -> pure $ BoolAtom (dConsName /= "Nothing") 25 | _ -> Left AtomFunctionTypeMismatchError 26 | }, 27 | Function { 28 | funcName = "fromMaybe", 29 | funcType = [TypeVariableType "a", maybeAtomType (TypeVariableType "a"), TypeVariableType "a"], 30 | funcBody = FunctionBuiltInBody $ 31 | \case 32 | (defaultAtom:ConstructedAtom dConsName _ (atomVal:_):_) -> if atomTypeForAtom defaultAtom /= atomTypeForAtom atomVal then Left AtomFunctionTypeMismatchError else if dConsName == "Nothing" then pure defaultAtom else pure atomVal 33 | _ ->Left AtomFunctionTypeMismatchError 34 | } 35 | ] 36 | 37 | {- To create an inclusion dependency for uniqueness for "Just a" values only 38 | person := relation{name Text, boss Maybe Text}{tuple{name "Steve",boss Nothing}, tuple{name "Bob", boss Just "Steve"}} 39 | :showexpr ((relation{tuple{}}:{a:=person where ^isJust(@boss)}):{b:=count(@a)}){b} 40 | :showexpr ((relation{tuple{}}:{a:=person{boss} where ^isJust(@boss)}):{b:=count(@a)}){b} 41 | constraint uniqueJust ((relation{tuple{}}:{a:=person where ^isJust(@boss)}):{b:=count(@a)}){b} in ((relation{tuple{}}:{a:=person{boss} where ^isJust(@boss)}):{b:=count(@a)}){b} 42 | person := relation{name Text, boss Maybe Text}{tuple{name "Steve",boss Nothing}, tuple{name "Bob", boss Just "Steve"}, tuple{name "Jim", boss Just "Steve"}} 43 | ERR: InclusionDependencyCheckError "uniqueJust" 44 | -} 45 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/DataTypes/Primitive.hs: -------------------------------------------------------------------------------- 1 | module ProjectM36.DataTypes.Primitive where 2 | import ProjectM36.Base 3 | 4 | primitiveTypeConstructorMapping :: TypeConstructorMapping 5 | primitiveTypeConstructorMapping = boolMapping : map (\(name, aType) -> 6 | (PrimitiveTypeConstructorDef name aType, [])) prims 7 | where 8 | prims = [("Integer", IntegerAtomType), 9 | ("Int", IntAtomType), 10 | ("Text", TextAtomType), 11 | ("Double", DoubleAtomType), 12 | ("UUID", UUIDAtomType), 13 | ("ByteString", ByteStringAtomType), 14 | ("DateTime", DateTimeAtomType), 15 | ("Day", DayAtomType) 16 | ] 17 | boolMapping = (PrimitiveTypeConstructorDef "Bool" BoolAtomType, 18 | [DataConstructorDef "True" [], 19 | DataConstructorDef "False" []]) 20 | 21 | intTypeConstructor :: TypeConstructor 22 | intTypeConstructor = PrimitiveTypeConstructor "Int" IntAtomType 23 | 24 | doubleTypeConstructor :: TypeConstructor 25 | doubleTypeConstructor = PrimitiveTypeConstructor "Double" DoubleAtomType 26 | 27 | textTypeConstructor :: TypeConstructor 28 | textTypeConstructor = PrimitiveTypeConstructor "Text" TextAtomType 29 | 30 | dayTypeConstructor :: TypeConstructor 31 | dayTypeConstructor = PrimitiveTypeConstructor "Day" DayAtomType 32 | 33 | dateTimeTypeConstructor :: TypeConstructor 34 | dateTimeTypeConstructor = PrimitiveTypeConstructor "DateTime" DayAtomType 35 | 36 | uUIDTypeConstructor :: TypeConstructor 37 | uUIDTypeConstructor = PrimitiveTypeConstructor "UUID" UUIDAtomType 38 | 39 | -- | Return the type of an 'Atom'. 40 | atomTypeForAtom :: Atom -> AtomType 41 | atomTypeForAtom (IntAtom _) = IntAtomType 42 | atomTypeForAtom (IntegerAtom _) = IntegerAtomType 43 | atomTypeForAtom (ScientificAtom _) = ScientificAtomType 44 | atomTypeForAtom (DoubleAtom _) = DoubleAtomType 45 | atomTypeForAtom (TextAtom _) = TextAtomType 46 | atomTypeForAtom (DayAtom _) = DayAtomType 47 | atomTypeForAtom (DateTimeAtom _) = DateTimeAtomType 48 | atomTypeForAtom (ByteStringAtom _) = ByteStringAtomType 49 | atomTypeForAtom (BoolAtom _) = BoolAtomType 50 | atomTypeForAtom (UUIDAtom _) = UUIDAtomType 51 | atomTypeForAtom (RelationAtom (Relation attrs _)) = RelationAtomType attrs 52 | atomTypeForAtom (ConstructedAtom _ aType _) = aType 53 | atomTypeForAtom (RelationalExprAtom _) = RelationalExprAtomType 54 | atomTypeForAtom (SubrelationFoldAtom _ _) = SubrelationFoldAtomType (TypeVariableType "a") 55 | -------------------------------------------------------------------------------- /test/DataFrame.hs: -------------------------------------------------------------------------------- 1 | import ProjectM36.Client 2 | import ProjectM36.DataFrame 3 | import TutorialD.Interpreter.TestBase 4 | 5 | import Test.HUnit 6 | import System.Exit 7 | import qualified Data.Set as S 8 | 9 | testList :: Test 10 | testList = TestList [testOrderBy, testLimit, testOffset] 11 | 12 | main :: IO () 13 | main = do 14 | tcounts <- runTestTT testList 15 | if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess 16 | 17 | testOrderBy :: Test 18 | testOrderBy = TestCase $ do 19 | (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback 20 | Right df <- executeDataFrameExpr sessionId dbconn ( 21 | DataFrameExpr { 22 | convertExpr = Project (AttributeNames (S.singleton "status")) (RelationVariable "s" ()), 23 | orderExprs = [AttributeOrderExpr "status" AscendingOrder], 24 | offset = Nothing, 25 | limit = Nothing 26 | }) 27 | let vals = map (\tup -> case atomForAttributeName "status" tup of 28 | Left err -> error (show err) 29 | Right atom -> atom) (tuples df) 30 | assertEqual "sort order of s" [IntegerAtom 10, IntegerAtom 20, IntegerAtom 30] vals 31 | 32 | testOffset :: Test 33 | testOffset = TestCase $ do 34 | (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback 35 | Right df <- executeDataFrameExpr sessionId dbconn ( 36 | DataFrameExpr { 37 | convertExpr = Project (AttributeNames (S.singleton "status")) (RelationVariable "s" ()), 38 | orderExprs = [AttributeOrderExpr "status" AscendingOrder], 39 | offset = Just 1, 40 | limit = Nothing 41 | }) 42 | let vals = map (\tup -> case atomForAttributeName "status" tup of 43 | Left err -> error (show err) 44 | Right atom -> atom) (tuples df) 45 | assertEqual "sort + offset" [IntegerAtom 20, IntegerAtom 30] vals 46 | 47 | testLimit :: Test 48 | testLimit = TestCase $ do 49 | (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback 50 | Right df <- executeDataFrameExpr sessionId dbconn ( 51 | DataFrameExpr { 52 | convertExpr = Project (AttributeNames (S.singleton "status")) (RelationVariable "s" ()), 53 | orderExprs = [AttributeOrderExpr "status" DescendingOrder], 54 | offset = Nothing, 55 | limit = Just 1 56 | }) 57 | let vals = map (\tup -> case atomForAttributeName "status" tup of 58 | Left err -> error (show err) 59 | Right atom -> atom) (tuples df) 60 | assertEqual "sort + limit" [IntegerAtom 30] vals 61 | 62 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/Transaction.hs: -------------------------------------------------------------------------------- 1 | module ProjectM36.Transaction where 2 | import ProjectM36.Base 3 | import qualified Data.Set as S 4 | import qualified Data.UUID as U 5 | import Data.Time.Clock 6 | import qualified Data.List.NonEmpty as NE 7 | 8 | parentIds :: Transaction -> S.Set TransactionId 9 | parentIds (Transaction _ tinfo _) = S.fromList (NE.toList (parents tinfo)) 10 | 11 | rootParent :: TransactionParents 12 | rootParent = singleParent U.nil 13 | 14 | singleParent :: TransactionId -> TransactionParents 15 | singleParent tid = tid NE.:| [] 16 | 17 | -- | Return the same transaction but referencing only the specific child transactions. This is useful when traversing a graph and returning a subgraph. This doesn't filter parent transactions because it assumes a head-to-root traversal. 18 | filterTransactionInfoTransactions :: S.Set TransactionId -> TransactionInfo -> TransactionInfo 19 | filterTransactionInfoTransactions filterIds tinfo = 20 | tinfo { parents = case 21 | NE.filter (`S.member` filterIds) (parents tinfo) of 22 | [] -> rootParent 23 | xs -> NE.fromList xs} 24 | 25 | filterParent :: TransactionId -> S.Set TransactionId -> TransactionId 26 | filterParent parentId validIds = if S.member parentId validIds then parentId else U.nil 27 | 28 | -- | Remove any child or parent transaction references not in the valud UUID set. 29 | filterTransaction :: S.Set TransactionId -> Transaction -> Transaction 30 | filterTransaction filterIds (Transaction selfId tInfo context) = Transaction selfId (filterTransactionInfoTransactions filterIds tInfo) context 31 | 32 | -- | Return the singular context which is not virtual. 33 | concreteDatabaseContext :: Transaction -> DatabaseContext 34 | concreteDatabaseContext (Transaction _ _ (Schemas context _)) = context 35 | 36 | -- | Returns all schemas including the concrete schema. 37 | schemas :: Transaction -> Schemas 38 | schemas (Transaction _ _ schemas') = schemas' 39 | 40 | -- | Returns all subschemas which are isomorphic or sub-isomorphic to the concrete schema. 41 | subschemas :: Transaction -> Subschemas 42 | subschemas (Transaction _ _ (Schemas _ sschemas)) = sschemas 43 | 44 | fresh :: TransactionId -> UTCTime -> Schemas -> Transaction 45 | fresh freshId stamp' = Transaction freshId tinfo 46 | where 47 | tinfo = TransactionInfo {parents = rootParent, 48 | stamp = stamp', 49 | merkleHash = mempty 50 | } 51 | 52 | timestamp :: Transaction -> UTCTime 53 | timestamp (Transaction _ tinfo _) = stamp tinfo 54 | 55 | -------------------------------------------------------------------------------- /src/bin/SQL/Interpreter/CreateTable.hs: -------------------------------------------------------------------------------- 1 | module SQL.Interpreter.CreateTable where 2 | import SQL.Interpreter.Select 3 | import ProjectM36.SQL.Select 4 | import ProjectM36.SQL.CreateTable 5 | import SQL.Interpreter.Base 6 | import ProjectM36.Interpreter 7 | import Text.Megaparsec 8 | import Control.Monad.Permutations 9 | import Data.Functor (($>)) 10 | 11 | createTableP :: Parser CreateTable 12 | createTableP = do 13 | reserveds "create table" 14 | tname <- tableNameP 15 | colsAndTypes <- parens columnNamesAndTypesP 16 | pure $ CreateTable { target = tname, 17 | targetColumns = colsAndTypes 18 | } 19 | 20 | columnNamesAndTypesP :: Parser [(UnqualifiedColumnName, ColumnType, PerColumnConstraints)] 21 | columnNamesAndTypesP = 22 | sepByComma $ do 23 | colName <- unqualifiedColumnNameP 24 | colType <- columnTypeP 25 | perColConstraints <- perColConstraintsP 26 | pure (colName, colType, perColConstraints) 27 | 28 | columnTypeP :: Parser ColumnType 29 | columnTypeP = choice (map (\(nam, typ) -> reserved nam $> typ) types) 30 | where 31 | types = [("integer", IntegerColumnType), 32 | ("int", IntegerColumnType), 33 | ("text", TextColumnType), 34 | ("bool", BoolColumnType), 35 | ("double", DoubleColumnType), 36 | ("datetime", DateTimeColumnType)] 37 | 38 | data PerColumnConstraintsParse = 39 | PerColumnConstraintsParse { parse_notNullConstraint :: Bool, 40 | parse_uniquenessConstraint :: Bool, 41 | parse_primaryKeyConstraint :: Bool, 42 | parse_references :: Maybe (TableName, UnqualifiedColumnName) 43 | } 44 | 45 | referencesP :: Parser (TableName, UnqualifiedColumnName) 46 | referencesP = do 47 | reserved "references" 48 | (,) <$> tableNameP <*> parens unqualifiedColumnNameP 49 | 50 | perColConstraintsP :: Parser PerColumnConstraints 51 | perColConstraintsP = do 52 | parsed <- runPermutation $ 53 | PerColumnConstraintsParse <$> 54 | toPermutationWithDefault False (try (reserveds "not null" $> True)) <*> 55 | toPermutationWithDefault False (reserved "unique" $> True) <*> 56 | toPermutationWithDefault False (reserved "primary key" $> True) <*> 57 | toPermutationWithDefault Nothing (Just <$> referencesP) 58 | pure (PerColumnConstraints { notNullConstraint = parse_notNullConstraint parsed || parse_primaryKeyConstraint parsed, 59 | uniquenessConstraint = parse_uniquenessConstraint parsed || parse_primaryKeyConstraint parsed, 60 | references = parse_references parsed }) 61 | 62 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/DataTypes/NonEmptyList.hs: -------------------------------------------------------------------------------- 1 | module ProjectM36.DataTypes.NonEmptyList where 2 | import ProjectM36.Base 3 | import qualified Data.Map as M 4 | import qualified Data.HashSet as HS 5 | import ProjectM36.AtomFunctionError 6 | import ProjectM36.DataTypes.List 7 | 8 | nonEmptyListAtomType :: AtomType -> AtomType 9 | nonEmptyListAtomType arg = ConstructedAtomType "NonEmptyList" (M.singleton "a" arg) 10 | 11 | -- data NonEmptyList = NECons a (Cons a) 12 | nonEmptyListTypeConstructorMapping :: TypeConstructorMapping 13 | nonEmptyListTypeConstructorMapping = [(ADTypeConstructorDef "NonEmptyList" ["a"], 14 | [DataConstructorDef "NECons" [DataConstructorDefTypeVarNameArg "a", 15 | DataConstructorDefTypeConstructorArg (ADTypeConstructor "List" [TypeVariable "a"])]])] 16 | 17 | nonEmptyListLength :: Atom -> Either AtomFunctionError Int 18 | nonEmptyListLength (ConstructedAtom "NECons" _ (_:nextCons:_)) = do 19 | c <- listLength nextCons 20 | pure (c + 1) 21 | nonEmptyListLength (ConstructedAtom "NECons" _ _) = pure 1 22 | nonEmptyListLength _ = Left AtomFunctionTypeMismatchError 23 | 24 | nonEmptyListHead :: Atom -> Either AtomFunctionError Atom 25 | nonEmptyListHead (ConstructedAtom "NECons" _ (val:_)) = pure val 26 | nonEmptyListHead _ = Left AtomFunctionTypeMismatchError 27 | 28 | {- 29 | listMaybeHead :: Atom -> Either AtomFunctionError Atom 30 | listMaybeHead (ConstructedAtom "Cons" _ (val:_)) = pure (ConstructedAtom "Just" aType [val]) 31 | where 32 | aType = maybeAtomType (atomTypeForAtom val) 33 | listMaybeHead (ConstructedAtom "Empty" (ConstructedAtomType _ tvMap) _) = 34 | case M.lookup "a" tvMap of 35 | Nothing -> Left AtomFunctionTypeMismatchError 36 | Just aType -> pure (ConstructedAtom "Nothing" aType []) 37 | listMaybeHead _ = Left AtomFunctionTypeMismatchError 38 | -} 39 | 40 | nonEmptyListAtomFunctions :: AtomFunctions 41 | nonEmptyListAtomFunctions = HS.fromList [ 42 | Function { 43 | funcName = "nonEmptyListLength", 44 | funcType = [nonEmptyListAtomType (TypeVariableType "a"), IntAtomType], 45 | funcBody = FunctionBuiltInBody $ 46 | \case 47 | (nonEmptyListAtom:_) -> 48 | IntAtom . fromIntegral <$> nonEmptyListLength nonEmptyListAtom 49 | _ -> Left AtomFunctionTypeMismatchError 50 | }, 51 | Function { 52 | funcName = "nonEmptyListHead", 53 | funcType = [nonEmptyListAtomType (TypeVariableType "a"), TypeVariableType "a"], 54 | funcBody = FunctionBuiltInBody $ 55 | \case 56 | (nonEmptyListAtom:_) -> nonEmptyListHead nonEmptyListAtom 57 | _ -> Left AtomFunctionTypeMismatchError 58 | } 59 | ] 60 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/DataTypes/List.hs: -------------------------------------------------------------------------------- 1 | module ProjectM36.DataTypes.List where 2 | import ProjectM36.Base 3 | import ProjectM36.DataTypes.Maybe 4 | import ProjectM36.DataTypes.Primitive 5 | import qualified Data.Map as M 6 | import qualified Data.HashSet as HS 7 | import ProjectM36.AtomFunctionError 8 | 9 | listAtomType :: AtomType -> AtomType 10 | listAtomType arg = ConstructedAtomType "List" (M.singleton "a" arg) 11 | 12 | listTypeConstructorMapping :: TypeConstructorMapping 13 | listTypeConstructorMapping = [(ADTypeConstructorDef "List" ["a"], 14 | [DataConstructorDef "Empty" [], 15 | DataConstructorDef "Cons" [DataConstructorDefTypeVarNameArg "a", 16 | DataConstructorDefTypeConstructorArg (ADTypeConstructor "List" [TypeVariable "a"])]])] 17 | 18 | listLength :: Atom -> Either AtomFunctionError Int 19 | listLength (ConstructedAtom "Cons" _ (_:nextCons:_)) = do 20 | c <- listLength nextCons 21 | pure (c + 1) 22 | listLength (ConstructedAtom "Empty" _ _) = pure 0 23 | listLength _ = Left AtomFunctionTypeMismatchError 24 | 25 | listMaybeHead :: Atom -> Either AtomFunctionError Atom 26 | listMaybeHead (ConstructedAtom "Cons" _ (val:_)) = pure (ConstructedAtom "Just" aType [val]) 27 | where 28 | aType = maybeAtomType (atomTypeForAtom val) 29 | listMaybeHead (ConstructedAtom "Empty" (ConstructedAtomType _ tvMap) _) = 30 | case M.lookup "a" tvMap of 31 | Nothing -> Left AtomFunctionTypeMismatchError 32 | Just aType -> pure (ConstructedAtom "Nothing" aType []) 33 | listMaybeHead _ = Left AtomFunctionTypeMismatchError 34 | 35 | listAtomFunctions :: AtomFunctions 36 | listAtomFunctions = HS.fromList [ 37 | Function { 38 | funcName = "length", 39 | funcType = [listAtomType (TypeVariableType "a"), IntAtomType], 40 | funcBody = FunctionBuiltInBody $ 41 | \case 42 | (listAtom:_) -> 43 | IntAtom . fromIntegral <$> listLength listAtom 44 | _ -> Left AtomFunctionTypeMismatchError 45 | }, 46 | Function { 47 | funcName = "maybeHead", 48 | funcType = [listAtomType (TypeVariableType "a"), maybeAtomType (TypeVariableType "a")], 49 | funcBody = FunctionBuiltInBody $ 50 | \case 51 | (listAtom:_) -> listMaybeHead listAtom 52 | _ -> Left AtomFunctionTypeMismatchError 53 | } 54 | ] 55 | 56 | --just a private utility function 57 | listCons :: AtomType -> [Atom] -> Atom 58 | listCons typ [] = ConstructedAtom "Empty" (listAtomType typ) [] 59 | listCons typ (a:as) = ConstructedAtom "Cons" (listAtomType typ) [a, listCons typ as] 60 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/Relation/Show/HTML.hs: -------------------------------------------------------------------------------- 1 | module ProjectM36.Relation.Show.HTML where 2 | import ProjectM36.Base 3 | import ProjectM36.Relation 4 | import ProjectM36.Tuple 5 | import ProjectM36.Atom 6 | import ProjectM36.Attribute as A 7 | import ProjectM36.AtomType 8 | import qualified Data.List as L 9 | import Data.Text (Text, pack) 10 | import qualified Data.Text as T 11 | import qualified Data.Text.IO as TIO 12 | #if __GLASGOW_HASKELL__ < 804 13 | import Data.Monoid 14 | #endif 15 | 16 | attributesAsHTML :: Attributes -> Text 17 | attributesAsHTML attrs = "" <> T.concat (map oneAttrHTML (A.toList attrs)) <> "" 18 | where 19 | oneAttrHTML attr = "" <> prettyAttribute attr <> "" 20 | 21 | relationAsHTML :: Relation -> Text 22 | -- 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 23 | relationAsHTML rel@(Relation attrNameSet tupleSet) 24 | | rel == relationTrue = pm36relcss <> 25 | tablestart <> 26 | "" <> 27 | "" <> 28 | tablefooter <> "" 29 | | rel == relationFalse = pm36relcss <> 30 | tablestart <> 31 | "" <> 32 | tablefooter <> 33 | "" 34 | | otherwise = pm36relcss <> 35 | tablestart <> 36 | attributesAsHTML attrNameSet <> 37 | tupleSetAsHTML tupleSet <> 38 | tablefooter <> 39 | "" 40 | where 41 | pm36relcss = "" 42 | tablefooter = "" <> pack (show (cardinality rel)) <> " tuples" 43 | tablestart = "" 44 | 45 | writeHTML :: Text -> IO () 46 | writeHTML = TIO.writeFile "/home/agentm/rel.html" 47 | 48 | writeRel :: Relation -> IO () 49 | writeRel = writeHTML . relationAsHTML 50 | 51 | tupleAsHTML :: RelationTuple -> Text 52 | tupleAsHTML tuple = "" <> T.concat (L.map tupleFrag (tupleAssocs tuple)) <> "" 53 | where 54 | tupleFrag tup = "" 55 | atomAsHTML (RelationAtom rel) = relationAsHTML rel 56 | atomAsHTML (TextAtom t) = """ <> t <> """ 57 | atomAsHTML atom = atomToText atom 58 | 59 | tupleSetAsHTML :: RelationTupleSet -> Text 60 | tupleSetAsHTML tupSet = foldr folder "" (asList tupSet) 61 | where 62 | folder tuple acc = acc <> tupleAsHTML tuple 63 | 64 | -------------------------------------------------------------------------------- /examples/CustomTupleable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric, OverloadedStrings #-} 2 | --this example shows how to implement a non-generics-defined Tupleable instance which is required in scenarios where Haskell-side types are not supported server-side or where one wishes to represent a nested relation 3 | import ProjectM36.Client 4 | import ProjectM36.Tuple 5 | import ProjectM36.Tupleable 6 | import ProjectM36.Relation 7 | import ProjectM36.Atom 8 | import ProjectM36.Attribute as A 9 | import qualified Data.Set as S 10 | import qualified Data.Map as M 11 | import Data.Text (Text) 12 | import GHC.Generics 13 | import Data.Proxy 14 | 15 | --in this contrived example, we wish to represent one relation with a nested relation of comments 16 | data Blog = Blog { 17 | title :: Text, 18 | comments :: S.Set Comment 19 | } deriving (Show) 20 | 21 | data Comment = Comment { 22 | authorName :: Text, 23 | comment :: Text 24 | } deriving (Eq, Show, Generic, Ord) 25 | 26 | instance Tupleable Comment 27 | 28 | instance Tupleable Blog where 29 | toTuple blogentry = 30 | mkRelationTupleFromMap (M.fromList [("title", TextAtom (title blogentry)), 31 | ("comments", RelationAtom relFromComments)]) 32 | where 33 | commentTuples = map toTuple (S.toList (comments blogentry)) 34 | relFromComments = case mkRelationFromTuples (toAttributes (Proxy :: Proxy Comment)) commentTuples of 35 | Left err -> error (show err) 36 | Right rel -> rel 37 | 38 | fromTuple tupIn = do 39 | titleAtom <- atomForAttributeName "title" tupIn 40 | commentsAtom <- atomForAttributeName "comments" tupIn 41 | commentsRel <- relationForAtom commentsAtom 42 | comments' <- mapM fromTuple (tuplesList commentsRel) 43 | pure Blog { 44 | title = atomToText titleAtom, 45 | comments = S.fromList comments'} 46 | 47 | toAttributes _ = A.attributesFromList [Attribute "title" TextAtomType, 48 | Attribute "comments" $ RelationAtomType (toAttributes (Proxy :: Proxy Comment))] 49 | 50 | main :: IO () 51 | main = do 52 | let exampleBlog = Blog { title = "Cat Pics", 53 | comments = S.fromList [Comment {authorName = "Steve", 54 | comment = "great"}, 55 | Comment {authorName = "Bob", 56 | comment = "enough"} 57 | ]} 58 | print (toTuple exampleBlog) 59 | print (fromTuple (toTuple exampleBlog) :: Either RelationalError Blog) 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | -------------------------------------------------------------------------------- /src/bin/ProjectM36/Interpreter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | -- functions common to both SQL and TutorialD interpreters 3 | module ProjectM36.Interpreter where 4 | import ProjectM36.Base 5 | import ProjectM36.Error 6 | import ProjectM36.DataFrame 7 | import Text.Megaparsec 8 | import Data.Void 9 | import Data.Text 10 | import GHC.Generics 11 | import qualified Data.Text.IO as TIO 12 | import qualified Data.Text as T 13 | import qualified Data.List.NonEmpty as NE 14 | import System.IO 15 | import Control.Monad.Random 16 | import ProjectM36.Relation.Show.Term 17 | import ProjectM36.Relation 18 | 19 | type Parser = Parsec Void Text 20 | type ParserError = ParseErrorBundle Text Void 21 | type PromptLength = Int 22 | 23 | data SafeEvaluationFlag = SafeEvaluation | UnsafeEvaluation deriving (Eq) 24 | 25 | data ConsoleResult = QuitResult | 26 | DisplayResult StringType | 27 | DisplayIOResult (IO ()) | 28 | DisplayRelationResult Relation | 29 | DisplayDataFrameResult DataFrame | 30 | DisplayHintWith Text ConsoleResult | 31 | DisplayErrorResult StringType | 32 | DisplayRelationalErrorResult RelationalError | 33 | DisplayParseErrorResult (Maybe PromptLength) ParserError | -- PromptLength refers to length of prompt text 34 | QuietSuccessResult 35 | deriving (Generic) 36 | 37 | type InteractiveConsole = Bool 38 | 39 | displayResult :: ConsoleResult -> IO () 40 | displayResult QuitResult = return () 41 | displayResult (DisplayResult out) = TIO.putStrLn out 42 | displayResult (DisplayIOResult ioout) = ioout 43 | displayResult (DisplayErrorResult err) = let outputf = if T.length err > 0 && T.last err /= '\n' then TIO.hPutStrLn else TIO.hPutStr in 44 | outputf stderr ("ERR: " <> err) 45 | displayResult QuietSuccessResult = return () 46 | displayResult (DisplayRelationResult rel) = do 47 | gen <- newStdGen 48 | let randomlySortedRel = evalRand (randomizeTupleOrder rel) gen 49 | TIO.putStrLn (showRelation randomlySortedRel) 50 | displayResult (DisplayParseErrorResult mPromptLength err) = do 51 | let errorIndent = errorOffset . NE.head . bundleErrors $ err 52 | errString = T.pack (parseErrorPretty . NE.head . bundleErrors $ err) 53 | pointyString len = T.justifyRight (len + fromIntegral errorIndent) '_' "^" 54 | maybe (pure ()) (TIO.putStrLn . pointyString) mPromptLength 55 | TIO.putStr ("ERR:" <> errString) 56 | displayResult (DisplayDataFrameResult dFrame) = TIO.putStrLn (showDataFrame dFrame) 57 | displayResult (DisplayRelationalErrorResult err) = 58 | TIO.putStrLn ("ERR:" <> T.pack (show err)) 59 | displayResult (DisplayHintWith hint result) = do 60 | displayResult (DisplayResult hint) 61 | displayResult result 62 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/Function.hs: -------------------------------------------------------------------------------- 1 | -- | Module for functionality common between the various Function types (AtomFunction, DatabaseContextFunction). 2 | module ProjectM36.Function where 3 | import ProjectM36.Base 4 | import ProjectM36.Error 5 | import ProjectM36.Serialise.Base () 6 | import ProjectM36.ScriptSession 7 | import qualified Data.HashSet as HS 8 | 9 | -- for merkle hash 10 | 11 | -- | Return the underlying function to run the Function. 12 | function :: FunctionBody a -> a 13 | function (FunctionScriptBody _ f) = f 14 | function (FunctionBuiltInBody f) = f 15 | function (FunctionObjectLoadedBody _ _ _ f) = f 16 | 17 | -- | Return the text-based Haskell script, if applicable. 18 | functionScript :: Function a -> Maybe FunctionBodyScript 19 | functionScript func = case funcBody func of 20 | FunctionScriptBody script _ -> Just script 21 | _ -> Nothing 22 | 23 | -- | Change atom function definition to reference proper object file source. Useful when moving the object file into the database directory. 24 | processObjectLoadedFunctionBody :: ObjectModuleName -> ObjectFileEntryFunctionName -> FilePath -> FunctionBody a -> FunctionBody a 25 | processObjectLoadedFunctionBody modName fentry objPath body = 26 | FunctionObjectLoadedBody objPath modName fentry f 27 | where 28 | f = function body 29 | 30 | processObjectLoadedFunctions :: Functor f => ObjectModuleName -> ObjectFileEntryFunctionName -> FilePath -> f (Function a) -> f (Function a) 31 | processObjectLoadedFunctions modName entryName path = 32 | fmap (\f -> f { funcBody = processObjectLoadedFunctionBody modName entryName path (funcBody f) } ) 33 | 34 | loadFunctions :: ModName -> FuncName -> Maybe FilePath -> FilePath -> IO (Either LoadSymbolError [Function a]) 35 | #ifdef PM36_HASKELL_SCRIPTING 36 | loadFunctions modName funcName' mModDir objPath = 37 | case mModDir of 38 | Just modDir -> do 39 | eNewFs <- loadFunctionFromDirectory LoadAutoObjectFile modName funcName' modDir objPath 40 | case eNewFs of 41 | Left err -> pure (Left err) 42 | Right newFs -> 43 | pure (Right (processFuncs newFs)) 44 | Nothing -> do 45 | loadFunction LoadAutoObjectFile modName funcName' objPath 46 | where 47 | --functions inside object files probably won't have the right function body metadata 48 | processFuncs = map processor 49 | processor newF = newF { funcBody = processObjectLoadedFunctionBody modName funcName' objPath (funcBody newF)} 50 | #else 51 | loadFunctions _ _ _ _ = pure (Left LoadSymbolError) 52 | #endif 53 | 54 | functionForName :: FunctionName -> HS.HashSet (Function a) -> Either RelationalError (Function a) 55 | functionForName funcName' funcSet = 56 | case HS.toList $ HS.filter (\f -> funcName f == funcName') funcSet of 57 | [] -> Left $ NoSuchFunctionError funcName' 58 | x : _ -> Right x 59 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/DatabaseContext.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | module ProjectM36.DatabaseContext where 3 | import ProjectM36.Base 4 | import Control.Monad (void) 5 | import qualified Data.Map as M 6 | import qualified Data.HashSet as HS 7 | import ProjectM36.DataTypes.Basic 8 | import ProjectM36.AtomFunctions.Basic 9 | import ProjectM36.Relation 10 | import ProjectM36.DatabaseContextFunction 11 | 12 | empty :: DatabaseContext 13 | empty = DatabaseContext { inclusionDependencies = M.empty, 14 | relationVariables = M.empty, 15 | notifications = M.empty, 16 | atomFunctions = HS.empty, 17 | dbcFunctions = HS.empty, 18 | typeConstructorMapping = mempty, 19 | registeredQueries = mempty } 20 | 21 | 22 | -- | Remove TransactionId markers on GraphRefRelationalExpr 23 | stripGraphRefRelationalExpr :: GraphRefRelationalExpr -> RelationalExpr 24 | stripGraphRefRelationalExpr = void 25 | 26 | -- | convert an existing database context into its constituent expression. 27 | databaseContextAsDatabaseContextExpr :: DatabaseContext -> DatabaseContextExpr 28 | databaseContextAsDatabaseContextExpr context = MultipleExpr $ relVarsExprs ++ incDepsExprs ++ funcsExprs 29 | where 30 | relVarsExprs = map (\(name, rel) -> Assign name (stripGraphRefRelationalExpr rel)) (M.toList (relationVariables context)) 31 | incDepsExprs :: [DatabaseContextExpr] 32 | incDepsExprs = map (uncurry AddInclusionDependency) (M.toList (inclusionDependencies context)) 33 | funcsExprs = [] -- map (\func -> ) (HS.toList funcs) -- there are no databaseExprs to add atom functions yet-} 34 | 35 | basicDatabaseContext :: DatabaseContext 36 | basicDatabaseContext = DatabaseContext { inclusionDependencies = M.empty, 37 | relationVariables = M.fromList [("true", ExistingRelation relationTrue), 38 | ("false", ExistingRelation relationFalse)], 39 | atomFunctions = basicAtomFunctions, 40 | dbcFunctions = basicDatabaseContextFunctions, 41 | notifications = M.empty, 42 | typeConstructorMapping = basicTypeConstructorMapping, 43 | registeredQueries = M.singleton "booleans" (Union (RelationVariable "true" ()) (RelationVariable "false" ())) 44 | } 45 | 46 | someDatabaseContextExprs :: [DatabaseContextExpr] -> DatabaseContextExpr 47 | someDatabaseContextExprs [s] = s 48 | someDatabaseContextExprs (s:ss) = MultipleExpr (s:ss) 49 | someDatabaseContextExprs [] = NoOperation 50 | 51 | 52 | -------------------------------------------------------------------------------- /src/bin/TutorialD/Interpreter/SchemaOperator.hs: -------------------------------------------------------------------------------- 1 | module TutorialD.Interpreter.SchemaOperator where 2 | import Text.Megaparsec 3 | import ProjectM36.Interpreter 4 | import ProjectM36.Base 5 | import ProjectM36.IsomorphicSchema 6 | import ProjectM36.Session 7 | import ProjectM36.Client 8 | import TutorialD.Interpreter.RelationalExpr 9 | import TutorialD.Interpreter.Base 10 | 11 | data SchemaOperator = ModifySchemaExpr SchemaExpr | 12 | SetCurrentSchema SchemaName 13 | deriving Show 14 | 15 | schemaOperatorP :: Parser SchemaOperator 16 | schemaOperatorP = (ModifySchemaExpr <$> schemaExprP) <|> 17 | setCurrentSchemaP 18 | 19 | setCurrentSchemaP :: Parser SchemaOperator 20 | setCurrentSchemaP = do 21 | reserved ":setschema" 22 | SetCurrentSchema <$> identifierP 23 | 24 | schemaExprP :: Parser SchemaExpr 25 | schemaExprP = addSubschemaP <|> 26 | removeSubschemaP 27 | 28 | addSubschemaP :: Parser SchemaExpr 29 | addSubschemaP = do 30 | reserved ":addschema" 31 | AddSubschema <$> identifierP <*> parens (sepBy schemaIsomorphP comma) 32 | 33 | schemaIsomorphP :: Parser SchemaIsomorph 34 | schemaIsomorphP = isoRestrictP <|> isoUnionP <|> isoRenameP <|> isoPassthrough 35 | 36 | removeSubschemaP :: Parser SchemaExpr 37 | removeSubschemaP = do 38 | reserved ":removeschema" 39 | RemoveSubschema <$> identifier 40 | 41 | isoRestrictP :: Parser SchemaIsomorph 42 | isoRestrictP = do 43 | reserved "isorestrict" 44 | relVarIn <- qrelVarP 45 | relvarsOut <- isoRestrictOutRelVarsP 46 | IsoRestrict relVarIn <$> restrictionPredicateP <*> pure relvarsOut 47 | 48 | isoRestrictOutRelVarsP :: Parser (RelVarName, RelVarName) 49 | isoRestrictOutRelVarsP = (,) <$> qrelVarP <*> qrelVarP 50 | 51 | qrelVarP :: Parser RelVarName 52 | qrelVarP = quotedString 53 | 54 | isoUnionP :: Parser SchemaIsomorph 55 | isoUnionP = do 56 | reserved "isounion" 57 | relVarsIn <- isoUnionInRelVarsP 58 | relVarsOut <- qrelVarP 59 | IsoUnion relVarsIn <$> restrictionPredicateP <*> pure relVarsOut 60 | 61 | isoRenameP :: Parser SchemaIsomorph 62 | isoRenameP = do 63 | reserved "isorename" 64 | IsoRename <$> qrelVarP <*> qrelVarP 65 | 66 | isoPassthrough :: Parser SchemaIsomorph 67 | isoPassthrough = do 68 | reserved "isopassthrough" 69 | rv <- qrelVarP 70 | pure (IsoRename rv rv) 71 | 72 | isoUnionInRelVarsP :: Parser (RelVarName, RelVarName) 73 | isoUnionInRelVarsP = (,) <$> qrelVarP <*> qrelVarP 74 | 75 | evalSchemaOperator :: SessionId -> Connection -> SchemaOperator -> IO (Either RelationalError ()) 76 | evalSchemaOperator sessionId conn (ModifySchemaExpr expr) = executeSchemaExpr sessionId conn expr 77 | evalSchemaOperator sessionId conn (SetCurrentSchema sname) = setCurrentSchemaName sessionId conn sname 78 | 79 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/Win32Handle.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module ProjectM36.Win32Handle where 3 | import System.Win32.Types 4 | import Control.Exception (bracket) 5 | import Foreign.StablePtr 6 | import Foreign.C.Types 7 | import Control.Concurrent.MVar 8 | 9 | #if __GLASGOW_HASKELL__ >= 612 10 | import GHC.IO.Handle.Types (Handle(..), Handle__(..)) 11 | import GHC.IO.FD (FD(..)) -- A wrapper around an Int32 12 | import Data.Typeable 13 | #else 14 | import GHC.IOBase (Handle(..), Handle__(..)) 15 | import qualified GHC.IOBase as IOBase (FD) -- Just an Int32 16 | #endif 17 | 18 | -- This essential function comes from the C runtime system. It is certainly provided by msvcrt, and also seems to be provided by the mingw C library - hurrah! 19 | #if __GLASGOW_HASKELL__ >= 612 20 | foreign import ccall unsafe "_get_osfhandle" cget_osfhandle :: CInt -> IO HANDLE 21 | #else 22 | foreign import ccall unsafe "_get_osfhandle" cget_osfhandle :: IOBase.FD -> IO HANDLE 23 | #endif 24 | 25 | -- copied from ansi-terminal package 26 | -- | This bit is all highly dubious. The problem is that we want to output ANSI to arbitrary Handles rather than forcing 27 | -- people to use stdout. However, the Windows ANSI emulator needs a Windows HANDLE to work it's magic, so we need to be able 28 | -- to extract one of those from the Haskell Handle. 29 | -- 30 | -- This code accomplishes this, albeit at the cost of only being compatible with GHC. 31 | withHandleToHANDLE :: Handle -> (HANDLE -> IO a) -> IO a 32 | withHandleToHANDLE haskell_handle action = 33 | -- Create a stable pointer to the Handle. This prevents the garbage collector 34 | -- getting to it while we are doing horrible manipulations with it, and hence 35 | -- stops it being finalized (and closed). 36 | withStablePtr haskell_handle $ const $ do 37 | -- Grab the write handle variable from the Handle 38 | let write_handle_mvar = case haskell_handle of 39 | FileHandle _ handle_mvar -> handle_mvar 40 | DuplexHandle _ _ handle_mvar -> handle_mvar -- This is "write" MVar, we could also take the "read" one 41 | 42 | -- Get the FD from the algebraic data type 43 | #if __GLASGOW_HASKELL__ < 612 44 | fd <- haFD <$> readMVar write_handle_mvar 45 | #else 46 | --readMVar write_handle_mvar >>= \(Handle__ { haDevice = dev }) -> print (typeOf dev) 47 | Just fd <- fmap (\(Handle__ { haDevice = dev }) -> fmap fdFD (cast dev)) $ readMVar write_handle_mvar 48 | #endif 49 | 50 | -- Finally, turn that (C-land) FD into a HANDLE using msvcrt 51 | windows_handle <- cget_osfhandle fd 52 | 53 | -- Do what the user originally wanted 54 | action windows_handle 55 | 56 | #if MIN_VERSION_Win32(2,5,1) 57 | #else 58 | withStablePtr :: a -> (StablePtr a -> IO b) -> IO b 59 | withStablePtr value = bracket (newStablePtr value) freeStablePtr 60 | #endif -------------------------------------------------------------------------------- /src/bin/SQL/Interpreter/Base.hs: -------------------------------------------------------------------------------- 1 | module SQL.Interpreter.Base where 2 | import ProjectM36.Interpreter 3 | import Text.Megaparsec 4 | import Text.Megaparsec.Char 5 | import qualified Text.Megaparsec.Char.Lexer as Lex 6 | import Data.Text as T (Text, singleton, pack, splitOn, toLower) 7 | import Data.Functor (($>)) 8 | 9 | -- consumes only horizontal spaces 10 | spaceConsumer :: Parser () 11 | spaceConsumer = Lex.space space1 (Lex.skipLineComment "--") (Lex.skipBlockComment "{-" "-}") 12 | 13 | opChar :: Parser Char 14 | opChar = oneOf (":!#$%&*+./<=>?\\^|-~" :: String)-- remove "@" so it can be used as attribute marker without spaces 15 | 16 | -- parse case-insensitive keyword 17 | reserved :: Text -> Parser () 18 | reserved word = do 19 | try (string' word *> spaceConsumer) 20 | 21 | reserveds :: Text -> Parser () 22 | reserveds words' = do 23 | let words'' = T.splitOn " " words' 24 | reserveds' words'' 25 | 26 | reserveds' :: [Text] -> Parser () 27 | reserveds' = mapM_ reserved 28 | 29 | -- does not consume trailing spaces 30 | qualifiedNameSegment :: Text -> Parser Text 31 | qualifiedNameSegment sym = T.toLower <$> string' sym 32 | 33 | reservedOp :: Text -> Parser () 34 | reservedOp op = try (spaceConsumer *> string op *> notFollowedBy opChar *> spaceConsumer) 35 | 36 | parens :: Parser a -> Parser a 37 | parens = between (symbol "(") (symbol ")") 38 | 39 | braces :: Parser a -> Parser a 40 | braces = between (symbol "{") (symbol "}") 41 | 42 | identifier :: Parser Text 43 | identifier = do 44 | istart <- letterChar <|> char '_' 45 | (toLower <$> identifierRemainder istart) <* spaceConsumer 46 | 47 | identifierRemainder :: Char -> Parser Text 48 | identifierRemainder c = do 49 | rest <- many (alphaNumChar <|> char '_' <|> char '#') 50 | spaceConsumer 51 | pure (pack (c:rest)) 52 | 53 | symbol :: Text -> Parser Text 54 | symbol = Lex.symbol spaceConsumer 55 | 56 | comma :: Parser Text 57 | comma = symbol "," 58 | 59 | sepByComma1 :: Parser a -> Parser [a] 60 | sepByComma1 p = sepBy1 p comma 61 | 62 | sepByComma :: Parser a -> Parser [a] 63 | sepByComma p = sepBy p comma 64 | 65 | pipe :: Parser Text 66 | pipe = symbol "|" 67 | 68 | semi :: Parser Text 69 | semi = symbol ";" 70 | 71 | nline :: Parser Text 72 | nline = (T.singleton <$> newline) <|> crlf 73 | 74 | integer :: Parser Integer 75 | integer = Lex.signed (pure ()) Lex.decimal <* spaceConsumer 76 | 77 | natural :: Parser Integer 78 | natural = Lex.decimal <* spaceConsumer 79 | 80 | double :: Parser Double 81 | double = Lex.float <* spaceConsumer 82 | 83 | -- | When an identifier is quoted, it can contain any string. 84 | quotedIdentifier :: Parser Text 85 | quotedIdentifier = 86 | (T.pack <$> (doubleQuote *> many (escapedDoubleQuote <|> notDoubleQuote) <* doubleQuote)) <* spaceConsumer 87 | where 88 | doubleQuote = char '"' 89 | escapedDoubleQuote = chunk "\"\"" $> '"' 90 | notDoubleQuote = satisfy ('"' /=) 91 | 92 | 93 | -------------------------------------------------------------------------------- /src/bin/ProjectM36/Server/WebSocket/websocket-server.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | import Control.Concurrent 4 | import Control.Exception 5 | import Control.Monad (when, void) 6 | import Data.Maybe (isJust) 7 | import Data.String (fromString) 8 | import Network.HTTP.Types (status400) 9 | import Network.Socket 10 | import Network.Wai (Application, responseLBS) 11 | import Network.Wai.Handler.Warp 12 | import Network.Wai.Handler.WarpTLS (runTLS, tlsSettings) 13 | import qualified Network.Wai.Handler.WebSockets as WS 14 | import Network.WebSockets (defaultConnectionOptions) 15 | import ProjectM36.Server 16 | import ProjectM36.Server.Config 17 | import ProjectM36.Server.ParseArgs 18 | import ProjectM36.Server.WebSocket 19 | import ProjectM36.Client (RemoteServerAddress(..)) 20 | 21 | main :: IO () 22 | main = do 23 | -- launch normal project-m36-server 24 | addressMVar <- newEmptyMVar 25 | wsConfig <- parseWSConfigWithDefaults (defaultServerConfig {bindAddress = RemoteServerHostAddress "127.0.0.1" 8000}) 26 | 27 | --usurp the serverConfig for our websocket server and make the proxied server run locally 28 | let serverConfig = wsServerConfig wsConfig 29 | wsAddress = bindAddress serverConfig 30 | (wsHost, wsPort) = case wsAddress of 31 | RemoteServerHostAddress host port -> (host, port) 32 | _ -> error "expected host-based address" 33 | serverHost = "127.0.0.1" 34 | serverConfig' = serverConfig {bindAddress = RemoteServerHostAddress serverHost 0} 35 | configCertificateFile = tlsCertificatePath wsConfig 36 | configKeyFile = tlsKeyPath wsConfig 37 | 38 | when (isJust configCertificateFile /= isJust configKeyFile) $ 39 | throwIO $ ErrorCall "TLS_CERTIFICATE_PATH and TLS_KEY_PATH must be set in tandem" 40 | 41 | _ <- forkFinally (void (launchServer serverConfig' (Just addressMVar))) (either throwIO pure) 42 | --wait for server to be listening 43 | addr <- takeMVar addressMVar 44 | let port = 45 | case addr of 46 | SockAddrInet port' _ -> fromIntegral port' 47 | _ -> error "unsupported socket address (IPv4 only currently)" 48 | wsApp = websocketProxyServer port serverHost 49 | waiApp = WS.websocketsOr defaultConnectionOptions wsApp backupApp 50 | settings = warpSettings wsHost (fromIntegral wsPort) 51 | 52 | case (configCertificateFile, configKeyFile) of 53 | (Just certificate, Just key) -> runTLS (tlsSettings certificate key) settings waiApp 54 | _ -> runSettings settings waiApp 55 | 56 | backupApp :: Application 57 | backupApp _ respond = respond $ responseLBS status400 [] "Not a WebSocket request" 58 | 59 | warpSettings :: HostName -> Port -> Settings 60 | warpSettings host port = 61 | setHost (fromString host) 62 | . setPort port 63 | . setServerName "project-m36" 64 | . setTimeout 3600 65 | . setGracefulShutdownTimeout (Just 5) 66 | $ defaultSettings 67 | -------------------------------------------------------------------------------- /docs/projectm36_client_library.markdown: -------------------------------------------------------------------------------- 1 | # Project:M36 Client Library 2 | 3 | The Project:M36 client library is the preferred method for interacting with Project:M36 databases. It supports all features of the DBMS while other interfaces may not. 4 | 5 | **Note:** A less featureful but more convenient client API also is available: see [documentation](simple_api.markdown). 6 | 7 | The client supports both in-process and remote Project:M36 access. 8 | 9 | ## Build Configuration 10 | 11 | If using cabal to build, run `cabal install --lib` to make Project:M36 a library accessible from other cabal projects. 12 | 13 | If using stack to build, copy the `extra-deps` section from the relevant stack.ghc..yaml configuration into your own project and run `stack build` to install the Project:M36 library. 14 | 15 | ## Setup 16 | 17 | 1. Import the library's symbols 18 | ```haskell 19 | import ProjectM36.Client 20 | ``` 21 | 2. Create a Connection with a `ConnectionInfo` in the Either monad 22 | ```haskell 23 | conn <- connectProjectM36 (InProcessConnectionInfo NoPersistence) 24 | ``` 25 | 26 | ## Executing Expressions 27 | 28 | 1. Execute relational expression queries 29 | ```haskell 30 | result <- executeRelationalExpr conn (Union (RelationVariable "x") (RelationVariable "y")) 31 | ``` 32 | 2. Execute database context expressions which modify the current, mutable database context 33 | ```haskell 34 | maybeErr <- executeDatabaseContextExpr conn (Define "person" (attributesFromList [Attribute "name" StringAtomType, Attribute "age" IntAtomType, Attribute "id" StringAtomType])) 35 | ``` 36 | 3. Execute a transaction graph expression 37 | ```haskell 38 | maybeErr <- executeGraphExpr conn (JumpToHead "branch2") 39 | ``` 40 | 41 | ## Dealing with Concurrency 42 | 43 | As in all databases, transactions contend concurrently for access to the the latest database state. Unlike most DBMSs, Project:M36 features multiple heads to reduce contention. Still, at a high transaction rate, Project:M36 clients would still be likely to receive lots of ```TransactionIsNotAHeadError```s because the server's head has received additional commits by the time a client wants to commit its own transaction. To reduce the incidence of this error, the server offers an ```autoMergeToHead``` function which: 44 | 45 | 1. creates a temporary branch 46 | 1. commits the current disconnected transaction to the temporary branch 47 | 1. attempts a merge back to the original branch 48 | 49 | The operations above occur atomically on the server. The purpose of this "automerge" is to reduce reliance on repeated client attempts to commit when head contention is high. The trade-off is that the client must handle any merge errors or use a different merge strategy. 50 | 51 | This feature is similar to git's ```rebase``` functionality except that the merge occurs server side and is fully validated and committed, if possible. 52 | 53 | ## Cleanup 54 | 55 | 1. Close the connection 56 | ```haskell 57 | close conn 58 | -------------------------------------------------------------------------------- /docs/acid_assessment.markdown: -------------------------------------------------------------------------------- 1 | # ACID Database Properties 2 | 3 | ## Introduction 4 | 5 | [ACID](https://en.wikipedia.org/wiki/ACID) properties are the most important guarantees any database must make to the database user. ACID is an acronym which refers to how a database handles: 6 | 7 | * **Atomicity** - state changes from committed transactions must never be partially visible; transactions are *atomically* applied to the database state 8 | * **Consistency** - database constraints hold at all times 9 | * **Isolation** - new transactions can only see state from previously committed transactions; transactions are *isolated* from each other, even if there are multiple, fresh transactions in flux 10 | * **Durability** - committed transactions must be accessible even after sudden power loss or certain types of corruption 11 | 12 | ### Importance 13 | 14 | The importance of these properties cannot be understated. Any single component missing could make a database unsuitable for high-value data. 15 | 16 | ## A.C.I.D. Assessment for Project:M36 17 | 18 | ### Atomicity 19 | 20 | Through normal use of functional programming's immutable data structures, it is impossible to compile Project:M36 to reference any transactions which are not already part of the committed transaction graph. 21 | 22 | Compliance: 100% 23 | 24 | ### Consistency 25 | 26 | While user may create and destroy arbitrary database constraints, there is no feature to relax the constraints, even temporarily. Project:M36 supports all possible, definable database constraints in the form of inclusion dependencies. 27 | 28 | Compliance: 100% 29 | 30 | ### Isolation 31 | 32 | Each transaction can only reference data from its parent transactions. It is impossible to query data from uncommitted transactions. Software transactional memory is used to ensure that the transaction graph is updated consistently even under concurrent-use conditions. 33 | 34 | Compliance: 100% 35 | 36 | ### Durability 37 | 38 | Project:M36 uses write-once files and directories coupled with fdatasync()/fsync() and journaled filesystems to avoid the need of double-writing with the write-ahead-log method. When a transaction is committed, its changes are written to a temporary directory, the directory's files are fdatasync()'d, then the temporary directory is atomically rename()'d into the database directory and the directory is fsync()'d. 39 | 40 | However, Project:M36 allows the user to disable fsync()'ing, for example, for the purposes of creating temporary, disposable databases or for in-memory-only databases. 41 | 42 | In addition, Project:M36 relies on the user to use Project:M36 databases on ordered, journaled metadata filesystems only. A future improvement could be to detect scenarios under which Project:M36 is not offering guaranteed durability. Write-ahead-logs do not suffer from this requirement. 43 | 44 | Database directories can be shared across multiple Project:M36 database processes. This operates similarly to SQLite and relies on POSIX advisory locking and Windows file locking to ensure consistency. 45 | 46 | Compliance: 100% 47 | -------------------------------------------------------------------------------- /test/TutorialD/Interpreter/Import/ImportTest.hs: -------------------------------------------------------------------------------- 1 | import Test.HUnit 2 | import ProjectM36.Base 3 | import TutorialD.Interpreter.Import.TutorialD 4 | import System.Exit 5 | import qualified Data.Text as T 6 | import System.IO.Temp 7 | import System.FilePath 8 | import qualified Data.Map as M 9 | import System.IO 10 | import qualified Data.ByteString as BS 11 | import qualified Data.ByteString.Lazy as BSL 12 | import qualified Data.Text.Encoding as TE 13 | import Text.URI hiding (makeAbsolute) 14 | import Network.Wai.Handler.Warp 15 | import Control.Concurrent.MVar 16 | import Control.Concurrent 17 | import Network.Wai 18 | import Network.HTTP.Types 19 | 20 | main :: IO () 21 | main = do 22 | tcounts <- runTestTT $ TestList [testTutdFileImport 23 | ,testTutdHTTPSImport 24 | ] 25 | if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess 26 | 27 | testTutdFileImport :: Test 28 | testTutdFileImport = TestCase $ 29 | withSystemTempFile "m.tutd" $ \tempPath handle -> do 30 | BS.hPut handle (TE.encodeUtf8 "x:=relation{tuple{a 5,b \"spam\"}}; y:=relation{tuple{b \"漢字\"}}") 31 | hClose handle 32 | let expectedExpr = MultipleExpr [ 33 | Assign "x" (MakeRelationFromExprs Nothing 34 | $ TupleExprs () [TupleExpr (M.fromList [("a", NakedAtomExpr $ IntegerAtom 5), 35 | ("b", NakedAtomExpr $ TextAtom "spam")])]), 36 | Assign "y" (MakeRelationFromExprs Nothing 37 | $ TupleExprs () [TupleExpr (M.fromList [("b", NakedAtomExpr (TextAtom "漢字"))])])] 38 | --on Windows, the file URI should not include the drive letter "/c/Users..." -> "/Users" 39 | let uri = "file://" <> map (\c -> if c == '\\' then '/' else c) ( joinDrive "/" (dropDrive tempPath)) 40 | fileURI <- mkURI (T.pack uri) 41 | imported <- importTutorialDFromFile fileURI Nothing 42 | assertEqual "import tutd" (Right expectedExpr) imported 43 | 44 | 45 | startTestHTTPServer :: MVar () -> IO ThreadId 46 | startTestHTTPServer startVar = do 47 | let settings = setHost "127.0.0.1" $ setBeforeMainLoop (putMVar startVar ()) $ setPort 8899 defaultSettings 48 | app req respond = do 49 | case pathInfo req of 50 | ["test1"] -> respond $ responseLBS status200 [] "x:=true;\ny:=false;" 51 | other -> respond $ responseLBS status404 [] (BSL.fromStrict $ TE.encodeUtf8 $ T.pack ("no path at" <> show other)) 52 | forkIO $ runSettings settings app 53 | 54 | testTutdHTTPSImport :: Test 55 | testTutdHTTPSImport = TestCase $ do 56 | uri <- mkURI "http://localhost:8899/test1" 57 | let hash = "effe32b247586dc3ac0079fc241b9618d41d189afcaeb7907edbe5a8b45992a4" 58 | expected = Right (MultipleExpr [Assign "x" (RelationVariable "true" ()),Assign "y" (RelationVariable "false" ())]) 59 | continueTestVar <- newEmptyMVar 60 | httpServerThread <- startTestHTTPServer continueTestVar 61 | actual <- importTutorialDViaHTTP uri (Just hash) 62 | assertEqual "github https" expected actual 63 | killThread httpServerThread 64 | 65 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/DDLType.hs: -------------------------------------------------------------------------------- 1 | module ProjectM36.DDLType where 2 | import ProjectM36.HashSecurely 3 | import ProjectM36.Base 4 | import ProjectM36.RelationalExpression 5 | import ProjectM36.Error 6 | import ProjectM36.Attribute 7 | import qualified Data.Map as M 8 | import ProjectM36.Relation 9 | import ProjectM36.InclusionDependency 10 | import ProjectM36.AtomFunction 11 | import ProjectM36.DatabaseContextFunction 12 | import ProjectM36.IsomorphicSchema 13 | 14 | -- | Return a hash of just DDL-specific (schema) attributes. This is useful for determining if a client has the appropriate updates needed to work with the current schema. 15 | ddlHash :: DatabaseContext -> TransactionGraph -> Either RelationalError SecureHash 16 | ddlHash ctx tgraph = do 17 | -- we cannot merely hash the relational representation of the type because the order of items matters when hashing 18 | -- registered queries are not included here because a client could be compatible with a schema even if the queries are not registered. The client should validate registered query state up-front. Perhaps there should be another hash for registered queries. 19 | rvtypemap <- typesForRelationVariables ctx tgraph 20 | pure $ mkDDLHash ctx rvtypemap 21 | 22 | -- | Process all relations within the context of the transaction graph to extract the relation variables types. 23 | typesForRelationVariables :: DatabaseContext -> TransactionGraph -> Either RelationalError (M.Map RelVarName Relation) 24 | typesForRelationVariables ctx tgraph = do 25 | let gfEnv = freshGraphRefRelationalExprEnv (Just ctx) tgraph 26 | M.fromList <$> mapM (\(rvname, rvexpr) -> do 27 | rvtype <- runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr rvexpr) 28 | pure (rvname, rvtype) 29 | ) (M.toList (relationVariables ctx)) 30 | 31 | 32 | -- | Return a Relation which represents the database context's current DDL schema. 33 | ddlType :: Schema -> DatabaseContext -> TransactionGraph -> Either RelationalError Relation 34 | ddlType schema ctx tgraph = do 35 | incDepsRel <- inclusionDependenciesInSchema schema (inclusionDependencies ctx) >>= inclusionDependenciesAsRelation 36 | atomFuncsRel <- atomFunctionsAsRelation (atomFunctions ctx) 37 | dbcFuncsRel <- databaseContextFunctionsAsRelation (dbcFunctions ctx) 38 | typesRel <- typesAsRelation (typeConstructorMapping ctx) 39 | relvarTypesRel <- relationVariablesAsRelationInSchema ctx schema tgraph 40 | let attrsAssocs = [("inclusion_dependencies", incDepsRel), 41 | ("atom_functions", atomFuncsRel), 42 | ("database_context_functions", dbcFuncsRel), 43 | ("types", typesRel), 44 | ("relation_variables", relvarTypesRel)] 45 | attrs = attributesFromList $ map (\(n, rv) -> Attribute n (RelationAtomType (attributes rv))) attrsAssocs 46 | tuples = [[RelationAtom incDepsRel, 47 | RelationAtom atomFuncsRel, 48 | RelationAtom dbcFuncsRel, 49 | RelationAtom typesRel, 50 | RelationAtom relvarTypesRel]] 51 | mkRelationFromList attrs tuples 52 | 53 | -------------------------------------------------------------------------------- /docs/import_export_csv.markdown: -------------------------------------------------------------------------------- 1 | # Project:M36 CSV Import/Export 2 | 3 | Project:M36's `tutd` console supports the import and export of CSV files as a lowest-common denominator format for moving data. Because the CSV file format does not support all the features of Project:M36- most notably, nested relations- not all relation variables can be marshalled to-and-from CSV files. 4 | 5 | ## CSV Export 6 | 7 | If a relation variable cannot be exported due to data types which are not supported by the CSV format- such as with a nested relation- then Project:M36 throws an error rather than export a partial file. 8 | 9 | ### Example Export 10 | 11 | ``` 12 | TutorialD (master/main): :importexample cjdate 13 | TutorialD (master/main): :exportcsv s "/tmp/csv" 14 | ``` 15 | ``` 16 | $ cat /tmp/csv 17 | s#,sname,status,city 18 | S2,Jones,10,Paris 19 | S1,Smith,20,London 20 | S4,Clark,20,London 21 | S5,Adams,30,Athens 22 | S3,Blake,30,Paris 23 | ``` 24 | 25 | ## CSV Import 26 | 27 | An import is equivalent to an insert and does not replace the target relation variable. 28 | 29 | Because relations do not have a natural ordering for their attributes, the CSV file to import must contain a header row which matches the names of attributes. 30 | 31 | If a value in the CSV file cannot be converted to the expected type (determined by the existing relation attributes), then the entire import is aborted rather than perform a partial import. 32 | 33 | Note that all text fields must be double-quoted. This disambiguates the CSV file and makes it more easily parsable. On export, Project:M36 automatically double-quotes all text fields. If you importing a CSV file not generated by Project:M36, change its export procedure to double-quote all text fields. 34 | 35 | ### Example Import 36 | ``` 37 | $ cat /tmp/csv 38 | s#,sname,status,city 39 | S6,Samson,100,New York 40 | ``` 41 | ``` 42 | TutorialD (master/main): :importexample cjdate 43 | TutorialD (master/main): :showexpr s 44 | ┌──────────┬────────┬───────────┬───────────────┐ 45 | │city::Text│s#::Text│sname::Text│status::Integer│ 46 | ├──────────┼────────┼───────────┼───────────────┤ 47 | │"Paris" │"S2" │"Jones" │10 │ 48 | │"Paris" │"S3" │"Blake" │30 │ 49 | │"London" │"S4" │"Clark" │20 │ 50 | │"London" │"S1" │"Smith" │20 │ 51 | │"Athens" │"S5" │"Adams" │30 │ 52 | └──────────┴────────┴───────────┴───────────────┘ 53 | TutorialD (master/main): :importcsv "/tmp/csv" s 54 | TutorialD (master/main): :showexpr s 55 | ┌──────────┬────────┬───────────┬───────────────┐ 56 | │city::Text│s#::Text│sname::Text│status::Integer│ 57 | ├──────────┼────────┼───────────┼───────────────┤ 58 | │"Paris" │"S3" │"Blake" │30 │ 59 | │"London" │"S4" │"Clark" │20 │ 60 | │"New York"│"S6" │"Samson" │100 │ 61 | │"Athens" │"S5" │"Adams" │30 │ 62 | │"London" │"S1" │"Smith" │20 │ 63 | │"Paris" │"S2" │"Jones" │10 │ 64 | └──────────┴────────┴───────────┴───────────────┘ 65 | ``` 66 | 67 | Note that relations do not have ordering, thus, no ordering from the CSV file is preserved. 68 | -------------------------------------------------------------------------------- /docs/merkle_transaction_graph.markdown: -------------------------------------------------------------------------------- 1 | # Project:M36: Merkle Hashing for Transaction Graph 2 | 3 | ## Introduction 4 | 5 | Project:M36 supports an append-only transaction graph model (similar to git) whereby new transactions can be added to the graph but not removed. As with any graph, each node can contain a Merkle hash which ensures not only that it's state since being added to the graph has not changed but also that none of its parent nodes all the way to the root node (initial state) have not been modified. This validation has a number of use cases. 6 | 7 | ## Usage 8 | 9 | Project:M36 automatically adds Merkle hashes to every transaction. All data which represents the database state at that transaction is included in the hash including (but not limited to) relation variable definitions, atom and database context functions, constraints, and types. 10 | 11 | Project:M36 validates all merkle hashes at database startup. For users who need validation after the database is started, the user can issue `:validatemerklehashes` at the `tutd` command line. 12 | 13 | ### Audit Logging 14 | 15 | Project:M36 supports audit logging by allowing users to travel to transactions in the past and recreate the database state at that past point-in-time. To ensure that those past states cannot be modified either by malicious on-disk or in-memory changes, each transaction is protected by its own Merkle hash. If the calculated hash does not match the stored hash, Project:M36 can immediately report which transaction triggered the tamper-proof log. 16 | 17 | ### Reproducibility 18 | 19 | Since a Merkle tree is effectively immutable except to add more nodes, it can be used to save and restore a whole database with very high confidence in the results. This feature could also be used to restore a database partially; for example, to duplicate just the latest database state on a second machine for OLAP analysis. 20 | 21 | ### High-Availability 22 | 23 | Merkle tree hashes can be used to assert database integrity across high-availibility or database replication. Since the hash covers all database state, it can be used to validate log-shipping-based replication. Corrupted cache tuple data can be easily detected and flushed. 24 | 25 | ## Merkle Hashes in Other DBMSes 26 | 27 | While Merkle hashes have become prevalent in blockchain-style databases, they have not made many appearances in typical SQL databases. This is likely due to the fact that such databases consider any additional operations against the large tuple stores as prohibitively expensive. Project:M36 is able to skirt this cost by only hashing database update expressions rather than the result of these executed expressions. This also means that the Merkle hash can be computed against transactions which have been created but never executed. 28 | 29 | ## Conclusion 30 | 31 | Merkle hashes are an obvious improvement to any graph-based transaction log and are a low-cost method of ensuring data integrity. 32 | 33 | A further improvement could allow users to specify an initial key provided by an admin user to salt the hash used to create the database. Additionally, a multi-user system could allow individual users to sign their committed transactions. The signature would then be included in the Merkle hash. 34 | -------------------------------------------------------------------------------- /src/bin/benchmark/OnDiskClient.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia, DeriveGeneric, DeriveAnyClass, TypeApplications #-} 2 | -- create a simple, on-disk database of ~20 MB so that we can get a heap profile 3 | import ProjectM36.Client 4 | import Data.Text (Text) 5 | import Codec.Winery 6 | import Options.Applicative 7 | import Data.Time.Clock 8 | import GHC.Generics 9 | import Control.DeepSeq 10 | import ProjectM36.Tupleable 11 | import Data.Time.Calendar 12 | import Data.Proxy 13 | 14 | data WeatherReading = 15 | WeatherReading 16 | { stamp :: UTCTime, 17 | temperature :: Integer, 18 | raining :: Bool, 19 | city :: Text, 20 | latitude :: Integer, 21 | longitude :: Integer 22 | } 23 | deriving (Generic, Show, Eq, NFData, Tupleable) 24 | deriving Serialise via WineryRecord WeatherReading 25 | 26 | data Opts = Opts { datadir :: FilePath, 27 | writeData :: Bool, --read or write mode 28 | tupleCount :: Int 29 | } 30 | 31 | parseOptions :: Parser Opts 32 | parseOptions = Opts <$> 33 | strOption (long "datadir" <> short 'd') <*> 34 | switch (long "write-data" <> short 'w') <*> 35 | option auto (long "tuple-count" <> short 'c' <> value 10000) 36 | 37 | main :: IO () 38 | main = do 39 | let parser = info (parseOptions <**> helper) (fullDesc <> progDesc "Read or write data for heap profiling.") 40 | opts <- execParser parser 41 | let connInfo = InProcessConnectionInfo (MinimalPersistence (datadir opts)) emptyNotificationCallback [] basicDatabaseContext 42 | eCheck v = do 43 | x <- v 44 | case x of 45 | Left err -> error (show err) 46 | Right x' -> pure x' 47 | conn <- eCheck $ connectProjectM36 connInfo 48 | sessionId <- eCheck $ createSessionAtHead conn "master" 49 | if writeData opts then do 50 | putStrLn $ "writing " <> show (tupleCount opts) <> " tuples" 51 | let baseUTC = UTCTime { utctDay = fromGregorian 2022 2 22, 52 | utctDayTime = secondsToDiffTime 0 } 53 | let addData = map (\i -> 54 | WeatherReading { stamp = addUTCTime (secondsToNominalDiffTime (fromIntegral i)) baseUTC, 55 | temperature = i, 56 | raining = even i, 57 | city = "Mexico City", 58 | latitude = i, 59 | longitude = -i 60 | }) [1 .. fromIntegral (tupleCount opts)] 61 | defineExpr = toDefineExpr (Proxy @WeatherReading) "x" 62 | insertExpr <- eCheck (pure $ toInsertExpr addData "x") 63 | eCheck $ executeDatabaseContextExpr sessionId conn defineExpr 64 | eCheck $ executeDatabaseContextExpr sessionId conn insertExpr 65 | eCheck $ commit sessionId conn 66 | else do 67 | putStrLn "reading" 68 | --read one row to see how heap is affected (will load all rows) 69 | let readOneRow = Restrict (AttributeEqualityPredicate "temperature" (NakedAtomExpr (IntegerAtom 900))) (RelationVariable "x" ()) 70 | val <- eCheck $ executeRelationalExpr sessionId conn readOneRow 71 | print val 72 | 73 | 74 | 75 | -------------------------------------------------------------------------------- /test/TutorialD/PrinterTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | import Test.HUnit 3 | import ProjectM36.Base 4 | import System.Exit 5 | import Prettyprinter 6 | import Data.Map (fromList) 7 | import TutorialD.Printer () 8 | import TutorialD.Interpreter.RelationalExpr 9 | import Text.Megaparsec 10 | import Data.Text (pack) 11 | 12 | testList :: Test 13 | testList = TestList [ 14 | testPretty "true" (RelationVariable "true" ()), 15 | 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"))])])), 16 | testPretty "true:{a:=1, b:=1}" (Extend (AttributeExtendTupleExpr "b" (NakedAtomExpr (IntegerAtom 1))) (Extend (AttributeExtendTupleExpr "a" (NakedAtomExpr (IntegerAtom 1))) (RelationVariable "true" ()))), 17 | 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)] ())])])), 18 | testPretty "relation{tuple{a bytestring(\"dGVzdGRhdGE=\")}}" (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (fromList [("a",FunctionAtomExpr "bytestring" [NakedAtomExpr (TextAtom "dGVzdGRhdGE=")] ())])])), 19 | testPretty "relation{tuple{a True}}" (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (fromList [("a",NakedAtomExpr (BoolAtom True))])])), 20 | 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" [] ()] ()] ())])])), 21 | testPretty "relation{a Int, b Text, c Bool}{}" (MakeRelationFromExprs (Just [AttributeAndTypeNameExpr "a" (ADTypeConstructor "Int" []) (),AttributeAndTypeNameExpr "b" (ADTypeConstructor "Text" []) (),AttributeAndTypeNameExpr "c" (ADTypeConstructor "Bool" []) ()]) (TupleExprs () [])), 22 | testPretty "relation{a relation{b Int}}{}" (MakeRelationFromExprs (Just [AttributeAndTypeNameExpr "a" (RelationAtomTypeConstructor [AttributeAndTypeNameExpr "b" (ADTypeConstructor "Int" []) ()]) ()]) (TupleExprs () [])) 23 | ] 24 | 25 | main :: IO () 26 | main = do 27 | tcounts <- runTestTT testList 28 | if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess 29 | 30 | testPretty :: String -> RelationalExpr -> Test 31 | testPretty tutdStr relExprADT = 32 | TestCase $ do 33 | let relExprStr = show (pretty relExprADT) 34 | print relExprStr 35 | roundTrip <- parseRelExpr relExprStr 36 | {-tutdIn <- parseRelExpr tutdStr 37 | print ("tutd parsed", tutdIn)-} 38 | assertEqual ("pretty ADT " <> tutdStr) tutdStr relExprStr 39 | assertEqual ("round-trip " <> tutdStr) relExprADT roundTrip 40 | 41 | --round trip tutoriald 42 | parseRelExpr :: String -> IO RelationalExpr 43 | parseRelExpr tutdStr = 44 | case parse relExprP "test" (pack tutdStr) of 45 | Left err -> 46 | assertFailure (show err) 47 | Right parsed -> pure parsed 48 | -------------------------------------------------------------------------------- /docs/replication.markdown: -------------------------------------------------------------------------------- 1 | # Project:M36 Multi-Node Replication 2 | 3 | ## Introduction 4 | 5 | The stored transaction graph feature makes Project:M36 naturally more suitable for replication. Just like with git, having access to historical transactions makes merging transactional data much more logical and unambiguous. 6 | 7 | ## Current Multi-Master Support 8 | 9 | Project:M36 plans to support logical replication in the future. In the meantime, multi-master replication is supported through shared database directories. Using NFS or SMB shares where file locking is properly supported, one can run multiple ```project-m36-server``` instances on the same database directory. This is a shared-storage form of multi-master operation. 10 | 11 | Multi-master replication is enabled and reasonably fast due to the intentional design decision to rewrite as few files as possible. Typical databases write and rewrite the same files which back relation variables (or tables) directly which necessitates heavy use of file locking or even locks on file content regions. Project:M36 operates on a write-once, read-many (WORM) principle whereby transaction data can be written without holding locks so only the transaction graph itself needs synchronization. 12 | 13 | Multi-master support can also be useful for simple databases where one wishes to avoid running and maintaining a ```project-m36-server```. Instead, one can create in-process database instances which share the same database directory. This is similar to the use-case for SQLite. However, Project:M36 seamlessly supports server and in-process modes which makes moving from a small, local database to a larger server installation trivial; the storage format is identical. 14 | 15 | To use the simple multi-master mode, start two instances of ```project-m36-server``` which point at the same local or remote database directory over NFS or SMB. No further configuration is required. 16 | 17 | ## Caveats 18 | 19 | Project:M36 does not and cannot detect if the filesystem's implementation of file locking is actually functioning. 20 | 21 | On Linux and macOS, any recent on-disk filesystems and NFS should support POSIX advisory locking, as required. However, sharing the database over samba (SMB) shares or mixed operating systems may result in database transaction graph corruption. The symptom will be that arbitrary, committed transactions may be missing from the transaction graph. 22 | 23 | On Windows, locking is implemented using mandatory locking controls which any supported version of Windows offers. Cross-platform use of locking (such as with samba server on Linux) is probably *not* safe. 24 | 25 | If a commit happens behind the back of another ```project-m36-server``` and one server attempts to commit, two possibilities can occur: 26 | 27 | 1. The commits occurred on two disparate branches, so the transaction graph can be updated without conflict. 28 | 1. The commits occurred on the same branch, so one transaction commit will be rejected with a ```TransactionIsNotAHead``` error. This means that the head (leaf node) of the transaction graph for that branch has moved on, so the transaction needs to be re-executed and committed. 29 | 30 | To avoid ```TransactionIsNotAHead``` errors, branch the transaction graph and merge it to the head when ready to commit. 31 | -------------------------------------------------------------------------------- /release.nix: -------------------------------------------------------------------------------- 1 | { compiler ? "ghc928" 2 | , sources ? import ./nix/sources.nix 3 | , pkgs ? import sources.nixpkgs { } 4 | }: 5 | let 6 | doJailbreak = pkgs.haskell.lib.doJailbreak; 7 | needsCocoa = drv: 8 | if pkgs.stdenv.isDarwin 9 | then drv.overrideDerivation (old: 10 | { buildInputs = [ pkgs.darwin.apple_sdk.frameworks.Cocoa ] ++ old.buildInputs; } 11 | ) 12 | else drv; 13 | 14 | haskellPackages = pkgs.haskell.packages.${compiler}.override { 15 | overrides = self: super: { 16 | curryer-rpc = self.callHackageDirect { 17 | pkg = "curryer-rpc"; 18 | ver = "0.4.0"; 19 | sha256 = "sha256-rGNTiZBJjDA1HpXoxQIsupvgQ5HpYh0U8JZVTdVDnIk="; } {}; 20 | 21 | streamly = self.callHackageDirect { 22 | pkg = "streamly"; 23 | ver = "0.10.1"; 24 | sha256 = "sha256-9tWZ/8YteD9ljhEmj8oYKIAyFcbQflX0D20j/NTe3qM="; } {}; 25 | 26 | streamly-core = self.callHackageDirect { 27 | pkg = "streamly-core"; 28 | ver = "0.2.2"; 29 | sha256 = "sha256-Ggo5ius3dp/TJFfrZSk31A6gSZHA6kLMtxFKe9MIvqQ="; } {}; 30 | 31 | streamly-bytestring = self.callHackageDirect { 32 | pkg = "streamly-bytestring"; 33 | ver = "0.2.2"; 34 | sha256 = "sha256-E/sMAvaJ5zGYwb5KAXa2KQo3FqyB+T2mRO6zOTCXpoY="; } {}; 35 | 36 | lockfree-queue = self.callHackageDirect { 37 | pkg = "lockfree-queue"; 38 | ver = "0.2.4"; 39 | sha256 = "sha256-h1s/tiBq5Gzl8FtenQacmxJp7zPJPnmZXtKDPvxTSa4="; } {}; 40 | 41 | 42 | unicode-data = self.callHackageDirect { 43 | pkg = "unicode-data"; 44 | ver = "0.2.0"; 45 | sha256 = "14crb68g79yyw87fgh49z2fn4glqx0zr53v6mapihaxzkikhkkc3"; 46 | } {}; 47 | 48 | winery = self.callHackageDirect { 49 | pkg = "winery"; 50 | ver = "1.4"; 51 | sha256 = "sha256-ApJg6Qc25UyNZtSN52N9OrUQ/9K4w258oSE5BokO4tE="; 52 | } {}; 53 | 54 | barbies-th = self.callHackageDirect { 55 | pkg = "barbies-th"; 56 | ver = "0.1.11"; 57 | sha256 = "sha256-U9mHuHAA0v74dKB2w2kLGx9dBKU6w8CRObtYQF97Gao="; 58 | } {}; 59 | 60 | scotty = self.callHackageDirect { 61 | pkg = "scotty"; 62 | ver = "0.22"; 63 | sha256 = "sha256-DY4lKmAmqGTrzKq93Mft9bu9Qc0QcsEVpKzgoWcBL2I="; 64 | } {}; 65 | 66 | wai = self.callHackageDirect { 67 | pkg = "wai"; 68 | ver = "3.2.4"; 69 | sha256 = "sha256-NARmVhT5G1eMdtMM1xp7RFpevunThAB4tltCMih+qu8="; 70 | } {}; 71 | 72 | wai-extra = self.callHackageDirect { 73 | pkg = "wai-extra"; 74 | ver = "3.1.14"; 75 | sha256 = "sha256-wMI9eTituRbMvYvbcA9pgIwFxkbdL1+2Xw78lghfWaU="; 76 | } {}; 77 | 78 | project-m36 = ((self.callCabal2nixWithOptions "project-m36" ./. "-f-haskell-scripting" {})); 79 | }; 80 | }; 81 | in 82 | { 83 | project = haskellPackages.project-m36; 84 | 85 | shell = haskellPackages.shellFor { 86 | packages = p: [ 87 | p.project-m36 88 | ]; 89 | buildInputs = [ 90 | haskellPackages.ghcid 91 | haskellPackages.hlint 92 | pkgs.docker 93 | ]; 94 | withHoogle = true; 95 | }; 96 | } 97 | -------------------------------------------------------------------------------- /test/Client/Simple.hs: -------------------------------------------------------------------------------- 1 | import ProjectM36.Client.Simple 2 | import Test.HUnit 3 | import System.Exit 4 | import ProjectM36.Relation 5 | import qualified ProjectM36.Client as C 6 | import ProjectM36.DateExamples 7 | import ProjectM36.DatabaseContext 8 | import System.IO.Temp 9 | import System.FilePath 10 | import ProjectM36.TupleSet 11 | import ProjectM36.Attribute 12 | import qualified Data.Map as M 13 | 14 | main :: IO () 15 | main = do 16 | tcounts <- runTestTT testList 17 | if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess 18 | 19 | testList :: Test 20 | testList = TestList [testSimpleCommitSuccess, testSimpleCommitFailure, testSimpleUpdate] 21 | 22 | assertEither :: (Show a) => IO (Either a b) -> IO b 23 | assertEither x = do 24 | res <- x 25 | case res of 26 | Left err -> assertFailure (show err) >> undefined 27 | Right val -> pure val 28 | 29 | testSimpleCommitSuccess :: Test 30 | testSimpleCommitSuccess = TestCase $ 31 | withSystemTempDirectory "m36tempdb" $ \tempdir -> do 32 | let connInfo = InProcessConnectionInfo (MinimalPersistence (tempdir "db")) emptyNotificationCallback [] basicDatabaseContext 33 | relExpr = Union (RelationVariable "x" ()) (RelationVariable "y" ()) 34 | 35 | dbconn <- assertEither (simpleConnectProjectM36 connInfo) 36 | Right rel <- withTransaction dbconn $ do 37 | 38 | execute (Assign "x" (ExistingRelation relationTrue)) 39 | execute (Assign "y" (ExistingRelation relationFalse)) 40 | query relExpr 41 | 42 | assertEqual "true/false simple" relationTrue rel 43 | -- re-open with standard API and validate that the relvars are available 44 | conn <- assertEither $ C.connectProjectM36 connInfo 45 | 46 | sess <- assertEither $ C.createSessionAtHead conn "master" 47 | eRes <- C.executeRelationalExpr sess conn relExpr 48 | assertEqual "x and y" (Right relationTrue) eRes 49 | 50 | 51 | testSimpleCommitFailure :: Test 52 | testSimpleCommitFailure = TestCase $ do 53 | let failAttrs = attributesFromList [Attribute "fail" IntAtomType] 54 | err <- withSystemTempDirectory "m36tempdb" $ \tempdir -> do 55 | let connInfo = InProcessConnectionInfo (MinimalPersistence (tempdir "db")) emptyNotificationCallback [] basicDatabaseContext 56 | dbconn <- assertEither (simpleConnectProjectM36 connInfo) 57 | withTransaction dbconn $ do 58 | execute $ Assign "x" (ExistingRelation relationTrue) 59 | --cause error 60 | execute $ Assign "x" (MakeStaticRelation failAttrs emptyTupleSet) 61 | let expectedErr = Left (RelError (RelationTypeMismatchError mempty failAttrs)) 62 | assertEqual "dbc error" expectedErr err 63 | 64 | -- #176 default merge couldn't handle Update 65 | testSimpleUpdate :: Test 66 | testSimpleUpdate = TestCase $ do 67 | let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback [] basicDatabaseContext 68 | dbconn <- assertEither (simpleConnectProjectM36 connInfo) 69 | assertEither $ withTransaction dbconn $ 70 | execute $ databaseContextAsDatabaseContextExpr dateExamples 71 | assertEither $ withTransaction dbconn $ 72 | execute $ Update "s" (M.singleton "sname" (C.NakedAtomExpr (C.TextAtom "Blakey"))) (C.AttributeEqualityPredicate "sname" (C.NakedAtomExpr (C.TextAtom "Blake"))) 73 | -------------------------------------------------------------------------------- /src/bin/benchmark/Server.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia, DeriveGeneric #-} 2 | import ProjectM36.Tupleable 3 | import ProjectM36.Client 4 | 5 | import Criterion.Main 6 | import Codec.Winery 7 | import Data.Text (Text) 8 | import Data.Proxy 9 | import GHC.Generics 10 | import Control.Monad 11 | 12 | 13 | handleIOError :: Show e => IO (Either e a) -> IO a 14 | handleIOError m = do 15 | v <- m 16 | handleError v 17 | 18 | handleError :: Show e => Either e a -> IO a 19 | handleError eErr = case eErr of 20 | Left err -> print err >> error "Died due to errors." 21 | Right v -> pure v 22 | 23 | --test local connection speeds of inserts, updates, and deletes to look for space leaks, etc. 24 | main :: IO () 25 | main = do 26 | conn <- handleIOError $ connectProjectM36 (InProcessConnectionInfo NoPersistence emptyNotificationCallback [] basicDatabaseContext) 27 | sess <- handleIOError $ createSessionAtHead conn "master" 28 | _ <- handleIOError $ executeDatabaseContextExpr sess conn (toDefineExpr (Proxy :: Proxy User) "user") 29 | 30 | let count = 100 31 | insertUsers sess conn count 32 | defaultMain [ 33 | bgroup "inserts" [ 34 | bench "insert" $ nfIO $ insertUsers sess conn count] 35 | {-,bgroup "updates" [ 36 | bench "update" $ nfIO $ updateUsers sess conn count 37 | ]-} 38 | ,bgroup "delete" [ 39 | bench "delete" $ nfIO $ deleteUsers sess conn count 40 | ] 41 | ] 42 | 43 | 44 | insertUsers :: SessionId -> Connection -> Int -> IO () 45 | insertUsers sess conn count = 46 | forM_ [1 .. count] $ \newId -> do 47 | let newUser = User { userId = newId 48 | , userFirstName = "Steve" 49 | , userLastName = "Stevens" 50 | , userEmail = "bench@bench.com" 51 | } 52 | newUserExpr <- handleError (toInsertExpr [newUser] "user") 53 | handleIOError $ executeDatabaseContextExpr sess conn newUserExpr 54 | 55 | {- 56 | updateUsers :: SessionId -> Connection -> Int -> IO () 57 | updateUsers sess conn count = 58 | forM_ [1 .. count] $ \uid -> do 59 | let changeUser = User { userId = uid 60 | , userFirstName = "Steve" 61 | , userLastName = "Stevens III" 62 | , userEmail = "bench@bench.com" 63 | } 64 | updateExpr = toUpdateExpr "user" ["userId"] changeUser 65 | updateUserExpr <- handleError updateExpr 66 | handleIOError $ executeDatabaseContextExpr sess conn updateUserExpr 67 | -} 68 | deleteUsers :: SessionId -> Connection -> Int -> IO () 69 | deleteUsers sess conn count = 70 | forM_ [1 .. count] $ \uid -> do 71 | let delUser = User { userId = uid 72 | , userFirstName = "Steve" 73 | , userLastName = "Stevens III" 74 | , userEmail = "bench@bench.com" 75 | } 76 | delUserExpr <- handleError (toDeleteExpr "user" ["userId"] delUser) 77 | handleIOError $ executeDatabaseContextExpr sess conn delUserExpr 78 | 79 | data User = User 80 | { userId :: Int 81 | , userFirstName :: Text 82 | , userLastName :: Text 83 | , userEmail :: Text 84 | } 85 | deriving Generic 86 | deriving Serialise via WineryRecord User 87 | 88 | instance Tupleable User 89 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/FileLock.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | --cross-platform file locking utilizing POSIX file locking on Unix/Linux and Windows file locking 3 | --hackage's System.FileLock doesn't support POSIX advisory locks nor locking file based on file descriptors, hence this needless rewrite 4 | module ProjectM36.FileLock where 5 | 6 | 7 | #if defined(mingw32_HOST_OS) 8 | import System.Win32.Types 9 | import Foreign.Marshal.Alloc 10 | import System.Win32.File 11 | import System.Win32.Mem 12 | import Data.Bits 13 | 14 | #if defined(i386_HOST_ARCH) 15 | # define WINDOWS_CCONV stdcall 16 | #elif defined(x86_64_HOST_ARCH) 17 | # define WINDOWS_CCONV ccall 18 | #else 19 | # error Unknown mingw32 arch 20 | #endif 21 | foreign import WINDOWS_CCONV "LockFileEx" c_lockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> DWORD -> LPOVERLAPPED -> IO BOOL 22 | 23 | foreign import WINDOWS_CCONV "UnlockFileEx" c_unlockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> LPOVERLAPPED -> IO BOOL 24 | 25 | type LockFile = HANDLE 26 | 27 | openLockFile :: FilePath -> IO LockFile 28 | openLockFile path = createFile path 29 | (gENERIC_READ .|. gENERIC_WRITE) 30 | (fILE_SHARE_READ .|. fILE_SHARE_WRITE) 31 | Nothing 32 | oPEN_ALWAYS 33 | fILE_ATTRIBUTE_NORMAL 34 | Nothing 35 | 36 | closeLockFile :: LockFile -> IO () 37 | closeLockFile file = do 38 | closeHandle file 39 | 40 | --swiped from System.FileLock package 41 | lockFile :: HANDLE -> LockType -> IO () 42 | lockFile winHandle lock = do 43 | let exFlag = case lock of 44 | WriteLock -> 2 45 | ReadLock -> 0 46 | blockFlag = 0 --always block 47 | sizeof_OVERLAPPED = 32 48 | 49 | allocaBytes sizeof_OVERLAPPED $ \op -> do 50 | zeroMemory op $ fromIntegral sizeof_OVERLAPPED 51 | failIfFalse_ "LockFileEx" $ c_lockFileEx winHandle (exFlag .|. blockFlag) 0 1 0 op 52 | 53 | unlockFile :: HANDLE -> IO () 54 | unlockFile winHandle = do 55 | let sizeof_OVERLAPPED = 32 56 | allocaBytes sizeof_OVERLAPPED $ \op -> do 57 | zeroMemory op $ fromIntegral sizeof_OVERLAPPED 58 | failIfFalse_ "UnlockFileEx" $ c_unlockFileEx winHandle 0 1 0 op 59 | 60 | #else 61 | --all of this complicated nonsense is fixed if we switch to GHC 8.2 which includes native flock support on handles 62 | import qualified System.Posix.IO as P 63 | import System.Posix.Types 64 | import System.Posix.Files 65 | import System.IO 66 | 67 | lockStruct :: P.LockRequest -> P.FileLock 68 | lockStruct req = (req, AbsoluteSeek, 0, 0) 69 | 70 | newtype LockFile = LockFile Fd 71 | 72 | --we cannot use openFile from System.IO because it implements complicated locking which prevents opening the same file twice in write mode in the same process with no way to bypass the check. 73 | openLockFile :: FilePath -> IO LockFile 74 | openLockFile path = 75 | LockFile <$> P.createFile path ownerWriteMode 76 | 77 | closeLockFile :: LockFile -> IO () 78 | closeLockFile (LockFile fd) = 79 | P.closeFd fd 80 | 81 | --blocks on lock, if necessary 82 | lockFile :: LockFile -> LockType -> IO () 83 | lockFile (LockFile fd) lock = do 84 | let lockt = case lock of 85 | WriteLock -> P.WriteLock 86 | ReadLock -> P.ReadLock 87 | P.waitToSetLock fd (lockStruct lockt) 88 | 89 | unlockFile :: LockFile -> IO () 90 | unlockFile (LockFile fd) = 91 | P.waitToSetLock fd (lockStruct P.Unlock) 92 | #endif 93 | 94 | data LockType = ReadLock | WriteLock deriving (Show) 95 | 96 | 97 | -------------------------------------------------------------------------------- /.github/workflows/ci.yaml: -------------------------------------------------------------------------------- 1 | name: "Stack" 2 | on: 3 | pull_request: 4 | push: 5 | jobs: 6 | dockerimage: 7 | runs-on: ubuntu-latest 8 | steps: 9 | - uses: actions/checkout@v4 10 | - uses: cachix/install-nix-action@v20 11 | with: 12 | nix_path: nixpkgs=channel:nixos-unstable 13 | - uses: cachix/cachix-action@v15 14 | with: 15 | name: project-m36 16 | signingKey: "${{ secrets.CACHIX_SIGNING_KEY }}" 17 | - run: cachix use iohk 18 | - name: docker load 19 | run: docker load < $(nix-build docker.nix) 20 | - name: docker login 21 | if: ${{ github.ref == 'refs/heads/master' }} 22 | run: echo ${{secrets.DOCKERHUB_PASSWORD}} | docker login --username ${{secrets.DOCKERHUB_USER}} --password-stdin 23 | - name: docker tag with version 24 | run: docker tag project-m36:latest projectm36/project-m36:$(awk '/^Version:/ {print $2}' project-m36.cabal) 25 | if: ${{ github.ref == 'refs/heads/master' }} 26 | - name: docker tag latest 27 | run: docker tag project-m36:latest projectm36/project-m36:latest 28 | if: ${{ github.ref == 'refs/heads/master' }} 29 | - run: docker push projectm36/project-m36 30 | if: ${{ github.ref == 'refs/heads/master' }} 31 | 32 | stack-build: 33 | runs-on: ${{ matrix.os }} 34 | strategy: 35 | matrix: 36 | os: [ubuntu-latest] 37 | ghc_version: 38 | - 9.2 39 | - 9.4 40 | # - 9.6 41 | # - 9.8 42 | # - 9.10 43 | include: 44 | - os: macos-latest 45 | ghc_version: 9.2 46 | env: 47 | STACK_YAML: stack.ghc${{ matrix.ghc_version }}.yaml 48 | steps: 49 | - uses: actions/checkout@v4 50 | - name: Cache 51 | uses: actions/cache@v4 52 | with: 53 | path: ~/.stack 54 | key: ${{ runner.os }}-build-stack-ghc${{ matrix.ghc_version }}-${{ hashFiles(env.STACK_YAML) }}-${{ hashFiles('**/*.cabal') }} 55 | restore-keys: | 56 | ${{ runner.os }}-build-stack-ghc${{ matrix.ghc_version }}-${{ hashFiles(env.STACK_YAML) }} 57 | ${{ runner.os }}-build-stack-ghc${{ matrix.ghc_version }} 58 | - name: Fix macOS cache bug 59 | run: rm -rf ~/.stack/setup-exe-cache 60 | # - name: HLint 61 | # run: curl -sSL https://raw.github.com/ndmitchell/hlint/master/misc/run.sh | sh -s . 62 | - name: Install ghcup dependencies 63 | run: sudo apt-get install build-essential curl libffi-dev libffi8ubuntu1 libgmp-dev libgmp10 libncurses-dev libncurses6 libtinfo6 64 | if: runner.os == 'Linux' 65 | - name: Setup GHCUp 66 | run: | 67 | curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | BOOTSTRAP_HASKELL_NONINTERACTIVE=1 BOOTSTRAP_HASKELL_MINIMAL=1 sh 68 | echo "$HOME/.ghcup/bin" >> $GITHUB_PATH 69 | ls -al $HOME/.ghcup/bin 70 | echo $GITHUB_PATH 71 | - name: Install GHC 72 | run: ghcup install ghc ${{ matrix.ghc_version }} 73 | - name: Install Stack 74 | run: ghcup install stack 75 | - name: Build 76 | run: stack build --ghc-options -O2 --local-bin-path out --copy-bins 77 | - name: Test 78 | run: stack test --stack-yaml=${{ env.STACK_YAML }} 79 | - name: Haddock 80 | run: stack --no-install-ghc --system-ghc --no-haddock-deps haddock 81 | - uses: actions/upload-artifact@v4 82 | with: 83 | name: project-m36-${{ matrix.os }}-ghc${{ matrix.ghc_version }} 84 | path: out/ 85 | -------------------------------------------------------------------------------- /src/bin/TutorialD/Interpreter/InformationOperator.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module TutorialD.Interpreter.InformationOperator where 3 | import Data.Text 4 | import ProjectM36.Interpreter 5 | import Text.Megaparsec 6 | import TutorialD.Interpreter.Base 7 | -- older versions of stack fail to 8 | #if !defined(VERSION_project_m36) 9 | # warning Failed to discover proper version from cabal_macros.h 10 | # define VERSION_project_m36 "" 11 | #endif 12 | 13 | -- this module provides information about the current interpreter 14 | 15 | data InformationOperator = HelpOperator | 16 | GetVersionOperator 17 | deriving (Show) 18 | 19 | infoOpP :: Parser InformationOperator 20 | infoOpP = helpOpP <|> getVersionP 21 | 22 | helpOpP :: Parser InformationOperator 23 | helpOpP = reserved ":help" >> pure HelpOperator 24 | 25 | getVersionP :: Parser InformationOperator 26 | getVersionP = reserved ":version" >> pure GetVersionOperator 27 | 28 | evalInformationOperator :: InformationOperator -> Either Text Text 29 | evalInformationOperator GetVersionOperator = Right ("tutd " `append` VERSION_project_m36) 30 | -- display generic help 31 | evalInformationOperator HelpOperator = Right $ intercalate "\n" help 32 | where 33 | help = ["tutd Help", 34 | "Quick Examples:", 35 | ":showexpr true", 36 | ":showexpr relation{name Text, address Text}{tuple{name \"Steve\", address \"Main St.\"}}", 37 | "address := relation{tuple{name \"Steve\", address \"Main St.\"}}", 38 | ":showexpr true join false = false", 39 | "Relational Operators:", 40 | ":showexpr relation{a Int, b Text}{} -- relation creation", 41 | ":showexpr relation{tuple{c t}} -- relation creation", 42 | ":showexpr relation{tuple{a 4, b 4}}{a} -- projection", 43 | ":showexpr relation{tuple{a 5}} rename {a as num} -- rename", 44 | ":showexpr relation{tuple{d 10}} where d=10 or d=5 -- restriction", 45 | ":showexpr relation{tuple{d 10}} : {e:=add(@d,5)} -- extension", 46 | "Database Context Operators:", 47 | "animal := relation{tuple{name \"octopus\", legs_count 8}} -- assignment", 48 | "insert animal relation{tuple{name \"cat\", legs_count 4}} -- insertion", 49 | "car :: {model Text, make Text, year Int} -- definition", 50 | "undefine car -- undefine", 51 | "delete animal where legs_count=4 -- deletion", 52 | "update animal where name=\"octopus\" (name:=\"Mr. Octopus\") -- updating", 53 | "employee:=relation{id Int, name Text, age Int}{}; key emp_unique_id {id} employee --uniqueness constraint", 54 | "constraint age_gt_zero (employee{age} where ^lt(@age,0)){} equals false -- constraint", 55 | "notify teenager_added employee where ^lt(@age,20) and ^gte(@age,13) employee{age} where ^lt(@age,20) and ^gte(@age,13) -- change notification", 56 | "Graph Operators: ", 57 | ":jumphead - change the current database context to point to a current head", 58 | ":jump - change the current database context to that of a past transaction", 59 | ":commit - push the current context into the current head and make it immutable", 60 | ":rollback - discard any changes made in the current context", 61 | ":showgraph - display the transaction graph", 62 | "View more documentation at: https://github.com/agentm/project-m36/blob/master/docs/tutd_tutorial.markdown" 63 | ] 64 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/DatabaseContextFunction.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module ProjectM36.DatabaseContextFunction where 3 | --implements functions which operate as: [Atom] -> DatabaseContextExpr -> Either RelationalError DatabaseContextExpr 4 | import ProjectM36.Base 5 | import ProjectM36.Error 6 | import ProjectM36.Serialise.Base () 7 | import ProjectM36.Attribute as A 8 | import ProjectM36.Relation 9 | import ProjectM36.AtomType 10 | import ProjectM36.Function 11 | import qualified Data.HashSet as HS 12 | import qualified Data.Map as M 13 | import qualified Data.Text as T 14 | import Data.Maybe (isJust) 15 | 16 | externalDatabaseContextFunction :: DatabaseContextFunctionBodyType -> DatabaseContextFunctionBody 17 | externalDatabaseContextFunction = FunctionBuiltInBody 18 | 19 | emptyDatabaseContextFunction :: FunctionName -> DatabaseContextFunction 20 | emptyDatabaseContextFunction name = Function { 21 | funcName = name, 22 | funcType = [], 23 | funcBody = FunctionBuiltInBody (\_ ctx -> pure ctx) 24 | } 25 | 26 | databaseContextFunctionForName :: FunctionName -> DatabaseContextFunctions -> Either RelationalError DatabaseContextFunction 27 | databaseContextFunctionForName funcName' funcs = 28 | case HS.toList $ HS.filter (\f -> funcName f == funcName') funcs of 29 | [] -> Left $ NoSuchFunctionError funcName' 30 | x : _ -> Right x 31 | 32 | evalDatabaseContextFunction :: DatabaseContextFunction -> [Atom] -> DatabaseContext -> Either RelationalError DatabaseContext 33 | evalDatabaseContextFunction func args ctx = 34 | case f args ctx of 35 | Left err -> Left (DatabaseContextFunctionUserError err) 36 | Right c -> pure c 37 | where 38 | f = function (funcBody func) 39 | 40 | basicDatabaseContextFunctions :: DatabaseContextFunctions 41 | basicDatabaseContextFunctions = HS.fromList [ 42 | Function { funcName = "deleteAll", 43 | funcType = [], 44 | funcBody = FunctionBuiltInBody (\_ ctx -> pure $ ctx { relationVariables = M.empty }) 45 | } 46 | ] 47 | 48 | --the precompiled functions are special because they cannot be serialized. Their names are therefore used in perpetuity so that the functions can be "serialized" (by name). 49 | precompiledDatabaseContextFunctions :: DatabaseContextFunctions 50 | precompiledDatabaseContextFunctions = HS.filter (not . isScriptedDatabaseContextFunction) basicDatabaseContextFunctions 51 | 52 | isScriptedDatabaseContextFunction :: DatabaseContextFunction -> Bool 53 | isScriptedDatabaseContextFunction func = isJust (functionScript func) 54 | 55 | databaseContextFunctionReturnType :: TypeConstructor -> TypeConstructor 56 | databaseContextFunctionReturnType tCons = ADTypeConstructor "Either" [ 57 | ADTypeConstructor "DatabaseContextFunctionError" [], 58 | tCons] 59 | 60 | createScriptedDatabaseContextFunction :: FunctionName -> [TypeConstructor] -> TypeConstructor -> FunctionBodyScript -> DatabaseContextIOExpr 61 | createScriptedDatabaseContextFunction funcName' argsIn retArg = AddDatabaseContextFunction funcName' (argsIn ++ [databaseContextFunctionReturnType retArg]) 62 | 63 | databaseContextFunctionsAsRelation :: DatabaseContextFunctions -> Either RelationalError Relation 64 | databaseContextFunctionsAsRelation dbcFuncs = mkRelationFromList attrs tups 65 | where 66 | attrs = A.attributesFromList [Attribute "name" TextAtomType, 67 | Attribute "arguments" TextAtomType] 68 | tups = map dbcFuncToTuple (HS.toList dbcFuncs) 69 | dbcFuncToTuple func = [TextAtom (funcName func), 70 | TextAtom (dbcTextType (funcType func))] 71 | dbcTextType typ = T.intercalate " -> " (map prettyAtomType typ ++ ["DatabaseContext", "DatabaseContext"]) 72 | 73 | -------------------------------------------------------------------------------- /src/lib/ProjectM36/Key.hs: -------------------------------------------------------------------------------- 1 | module ProjectM36.Key where 2 | import ProjectM36.Base 3 | import ProjectM36.Relation 4 | import qualified Data.Set as S 5 | import qualified Data.Text as T 6 | #if __GLASGOW_HASKELL__ < 804 7 | import Data.Monoid 8 | #endif 9 | 10 | {- 11 | keys can be implemented using inclusion dependencies as well: the count of the projection of the keys' attributes must be equal to the count of the tuples- p. 120 Database in Depth 12 | 13 | example: 14 | :showexpr ((relation{tuple{}}:{a:=S}):{b:=count(@a)}){b} 15 | ┌─┐ 16 | │b│ 17 | ├─┤ 18 | │5│ 19 | └─┘ 20 | ((relation{tuple{}}:{a:=S{S#}}):{b:=count(@a)}){b} 21 | ┌─┐ 22 | │b│ 23 | ├─┤ 24 | │5│ 25 | └─┘ 26 | -} 27 | 28 | -- | Create a uniqueness constraint for the attribute names and relational expression. Note that constraint can span multiple relation variables. 29 | inclusionDependencyForKey :: AttributeNames -> RelationalExpr -> InclusionDependency 30 | inclusionDependencyForKey attrNames relExpr = --InclusionDependency name (exprCount relExpr) (exprCount (projectedOnKeys relExpr)) 31 | InclusionDependency equalityExpr (ExistingRelation relationFalse) 32 | where 33 | projectedOnKeys = Project attrNames 34 | exprAsSubRelation expr = Extend (AttributeExtendTupleExpr "a" (RelationAtomExpr expr)) (ExistingRelation relationTrue) 35 | exprCount expr = projectionForCount (Extend (AttributeExtendTupleExpr "b" (FunctionAtomExpr "count" [AttributeAtomExpr "a"] () )) (exprAsSubRelation expr)) 36 | projectionForCount = Project (AttributeNames $ S.fromList ["b"]) 37 | equalityExpr = NotEquals (exprCount relExpr) (exprCount (projectedOnKeys relExpr)) 38 | 39 | -- | Create a 'DatabaseContextExpr' which can be used to add a uniqueness constraint to attributes on one relation variable. 40 | databaseContextExprForUniqueKey :: RelVarName -> [AttributeName] -> DatabaseContextExpr 41 | databaseContextExprForUniqueKey rvName attrNames = AddInclusionDependency (rvName <> "_" <> cols <> "_key") $ inclusionDependencyForKey (AttributeNames (S.fromList attrNames)) (RelationVariable rvName ()) 42 | where 43 | cols = T.intercalate "_" attrNames 44 | 45 | -- | Create a foreign key constraint from the first relation variable and attributes to the second. 46 | databaseContextExprForForeignKey :: IncDepName -> (RelVarName, [AttributeName]) -> (RelVarName, [AttributeName]) -> DatabaseContextExpr 47 | databaseContextExprForForeignKey fkName infoA infoB = 48 | AddInclusionDependency fkName (inclusionDependencyForForeignKey infoA infoB) 49 | 50 | inclusionDependencyForForeignKey :: (RelVarName, [AttributeName]) -> (RelVarName, [AttributeName]) -> InclusionDependency 51 | inclusionDependencyForForeignKey (rvA, attrsA) (rvB, attrsB) = 52 | InclusionDependency ( 53 | renameIfNecessary attrsB attrsA (Project (attrsL attrsA) 54 | (RelationVariable rvA ()))) ( 55 | Project (attrsL attrsB) (RelationVariable rvB ())) 56 | where 57 | attrsL = AttributeNames . S.fromList 58 | renameIfNecessary attrsExpected attrsExisting expr = foldr folder expr (zip attrsExpected attrsExisting) 59 | folder (attrExpected, attrExisting) expr = if attrExpected == attrExisting then 60 | expr 61 | else 62 | Rename (S.singleton (attrExisting, attrExpected)) expr 63 | 64 | -- if the constraint is a foreign key constraint, then return the relations and attributes involved - this only detects foreign keys created with `databaseContextExprForForeignKey` 65 | isForeignKeyFor :: InclusionDependency -> (RelVarName, [AttributeName]) -> (RelVarName, [AttributeName]) -> Bool 66 | isForeignKeyFor incDep infoA infoB = incDep == checkIncDep 67 | where 68 | checkIncDep = inclusionDependencyForForeignKey infoA infoB 69 | 70 | 71 | 72 | 73 | --------------------------------------------------------------------------------
" <> atomAsHTML (snd tup) <> "