project-m36 1.1.1 → 1.2.0

raw patch · 144 files changed

+7699/−1781 lines, 144 filesdep +byteunitsdep +cryptondep +ghc-bignumdep ~aesondep ~basedep ~base16-bytestringnew-component:exe:Example-Hospitalnew-component:exe:Example-ZooPVP ok

version bump matches the API change (PVP)

Dependencies added: byteunits, crypton, ghc-bignum, integer-gmp, linux-xattr, network-byte-order, process, sqlite-simple, streamly-core, system-linux-proc

Dependency ranges changed: aeson, base, base16-bytestring, cassava, curryer-rpc, data-default, ghc, megaparsec, stm-containers, streamly, uuid, winery

API changes (from Hackage documentation)

Files

• Changelog.markdown +9/−0
• README.markdown +2/−1
• examples/Hospital.hs +70/−0
• examples/Plantfarm.hs +3/−2
• examples/SimpleClient.hs +2/−1
• examples/blog.hs +3/−4
• examples/hair.hs +4/−1
• examples/out_of_the_tarpit.hs +4/−1
• examples/zoo.hs +74/−0
• project-m36.cabal +179/−54
• src/bin/ProjectM36/Cli.hs +52/−19
• src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs +27/−4
• src/bin/ProjectM36/Server/WebSocket.hs +10/−5
• src/bin/SQL/Interpreter.hs +7/−2
• src/bin/SQL/Interpreter/sqlegacy.hs +8/−5
• src/bin/TutorialD/Interpreter.hs +35/−15
• src/bin/TutorialD/Interpreter/Base.hs +10/−0
• src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs +55/−2
• src/bin/TutorialD/Interpreter/DatabaseContextIOOperator.hs +38/−3
• src/bin/TutorialD/Interpreter/Import/BasicExamples.hs +2/−2
• src/bin/TutorialD/Interpreter/Import/TutorialD.hs +1/−1
• src/bin/TutorialD/Interpreter/LoginRolesOperator.hs +64/−0
• src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs +36/−22
• src/bin/TutorialD/Interpreter/SchemaOperator.hs +1/−0
• src/bin/TutorialD/Interpreter/TransactionGraphOperator.hs +13/−10
• src/bin/TutorialD/Printer.hs +49/−0
• src/bin/TutorialD/tutd.hs +1/−1
• src/bin/benchmark/BTree.hs +42/−0
• src/bin/benchmark/Basic.hs +3/−2
• src/bin/benchmark/Handles.hs +3/−4
• src/bin/benchmark/OnDiskClient.hs +22/−5
• src/bin/benchmark/Relation.hs +2/−2
• src/bin/benchmark/Server.hs +3/−2
• src/bin/benchmark/bigrel.hs +5/−6
• src/lib/ProjectM36/AccessControl.hs +141/−0
• src/lib/ProjectM36/AccessControlList.hs +194/−0
• src/lib/ProjectM36/AtomFunction.hs +4/−2
• src/lib/ProjectM36/AtomFunctions/Primitive.hs +63/−27
• src/lib/ProjectM36/AtomFunctions/SelfTest.hs +36/−0
• src/lib/ProjectM36/Atomable.hs +1/−3
• src/lib/ProjectM36/Attribute.hs +26/−0
• src/lib/ProjectM36/AttributeExpr.hs +5/−0
• src/lib/ProjectM36/BTree.hs +239/−0
• src/lib/ProjectM36/Base.hs +61/−119
• src/lib/ProjectM36/Cache/RelationalExprCache.hs +202/−0
• src/lib/ProjectM36/Cache/Tuple.hs +170/−0
• src/lib/ProjectM36/Client.hs +687/−281
• src/lib/ProjectM36/Client/Simple.hs +3/−2
• src/lib/ProjectM36/DDLType.hs +20/−7
• src/lib/ProjectM36/DataTypes/ByteString.hs +2/−1
• src/lib/ProjectM36/DataTypes/DateTime.hs +2/−1
• src/lib/ProjectM36/DataTypes/Day.hs +4/−2
• src/lib/ProjectM36/DataTypes/Interval.hs +4/−2
• src/lib/ProjectM36/DataTypes/List.hs +4/−2
• src/lib/ProjectM36/DataTypes/Maybe.hs +4/−2
• src/lib/ProjectM36/DataTypes/NonEmptyList.hs +4/−2
• src/lib/ProjectM36/DataTypes/SQL/Null.hs +26/−13
• src/lib/ProjectM36/DatabaseContext.hs +59/−34
• src/lib/ProjectM36/DatabaseContext/Basic.hs +23/−0
• src/lib/ProjectM36/DatabaseContext/Fields.hs +15/−0
• src/lib/ProjectM36/DatabaseContext/SelfTest.hs +12/−0
• src/lib/ProjectM36/DatabaseContext/Types.hs +47/−0
• src/lib/ProjectM36/DatabaseContextExpr.hs +110/−0
• src/lib/ProjectM36/DatabaseContextFunction.hs +12/−22
• src/lib/ProjectM36/DatabaseContextFunctionError.hs +0/−8
• src/lib/ProjectM36/DatabaseContextFunctionUtils.hs +13/−4
• src/lib/ProjectM36/DatabaseContextFunctions/Basic.hs +26/−0
• src/lib/ProjectM36/DateExamples.hs +23/−7
• src/lib/ProjectM36/DisconnectedTransaction.hs +46/−15
• src/lib/ProjectM36/Error.hs +15/−5
• src/lib/ProjectM36/FSType.hs +5/−10
• src/lib/ProjectM36/Function.hs +5/−5
• src/lib/ProjectM36/GraphRefRelationalExpr.hs +9/−0
• src/lib/ProjectM36/HashSecurely.hs +29/−12
• src/lib/ProjectM36/IsomorphicSchema.hs +22/−19
• src/lib/ProjectM36/IsomorphicSchema/Types.hs +28/−0
• src/lib/ProjectM36/LoginRoles.hs +347/−0
• src/lib/ProjectM36/NormalizeExpr.hs +2/−1
• src/lib/ProjectM36/Notifications.hs +4/−0
• src/lib/ProjectM36/Persist.hs +33/−4
• src/lib/ProjectM36/PinnedRelationalExpr.hs +40/−0
• src/lib/ProjectM36/PrettyBytes.hs +13/−0
• src/lib/ProjectM36/ReferencedTransactionIds.hs +11/−4
• src/lib/ProjectM36/RegisteredQuery.hs +1/−0
• src/lib/ProjectM36/RelExprSize.hs +115/−0
• src/lib/ProjectM36/Relation.hs +52/−21
• src/lib/ProjectM36/Relation/Show/HTML.hs +2/−2
• src/lib/ProjectM36/Relation/Show/Term.hs +2/−2
• src/lib/ProjectM36/RelationVariablesMentioned.hs +90/−0
• src/lib/ProjectM36/RelationalExpression.hs +543/−262
• src/lib/ProjectM36/SQL/Convert.hs +5/−3
• src/lib/ProjectM36/SQLDatabaseContext.hs +11/−8
• src/lib/ProjectM36/ScriptSession.hs +7/−4
• src/lib/ProjectM36/Serialise/Base.hs +51/−4
• src/lib/ProjectM36/Serialise/DatabaseContextFunctionError.hs +0/−7
• src/lib/ProjectM36/Serialise/Error.hs +3/−1
• src/lib/ProjectM36/Serialise/LoginRoles.hs +9/−0
• src/lib/ProjectM36/Server.hs +38/−13
• src/lib/ProjectM36/Server/Config.hs +18/−2
• src/lib/ProjectM36/Server/EntryPoints.hs +21/−14
• src/lib/ProjectM36/Server/ParseArgs.hs +59/−11
• src/lib/ProjectM36/Server/RemoteCallTypes.hs +16/−4
• src/lib/ProjectM36/Session.hs +39/−20
• src/lib/ProjectM36/StaticOptimizer.hs +163/−36
• src/lib/ProjectM36/Streaming/RelationalExpression.hs +709/−0
• src/lib/ProjectM36/Streaming/Tuple.hs +175/−0
• src/lib/ProjectM36/SystemMemory.hs +129/−0
• src/lib/ProjectM36/TransGraphRelationalExpression.hs +2/−0
• src/lib/ProjectM36/Transaction.hs +4/−21
• src/lib/ProjectM36/Transaction/Persist.hs +279/−62
• src/lib/ProjectM36/Transaction/Types.hs +69/−0
• src/lib/ProjectM36/TransactionGraph.hs +182/−152
• src/lib/ProjectM36/TransactionGraph/Merge.hs +107/−38
• src/lib/ProjectM36/TransactionGraph/Persist.hs +29/−21
• src/lib/ProjectM36/TransactionGraph/Show.hs +3/−2
• src/lib/ProjectM36/TransactionGraph/Types.hs +48/−0
• src/lib/ProjectM36/TransactionInfo.hs +1/−0
• src/lib/ProjectM36/Tuple.hs +41/−13
• src/lib/ProjectM36/TupleSet.hs +7/−4
• src/lib/ProjectM36/Tupleable.hs +2/−2
• src/lib/ProjectM36/Tupleable/Deriving.hs +1/−1
• src/lib/ProjectM36/ValueMarker.hs +16/−0
• src/lib/ProjectM36/Win32Handle.hs +1/−1
• src/lib/ProjectM36/WithNameExpr.hs +66/−4
• test/AccessControl.hs +104/−0
• test/AccessControlList.hs +39/−0
• test/Cache.hs +198/−0
• test/Client/Simple.hs +12/−7
• test/IsomorphicSchema.hs +26/−16
• test/LoginRoles.hs +92/−0
• test/MultiProcessDatabaseAccess.hs +3/−1
• test/Relation/Basic.hs +5/−4
• test/Relation/StaticOptimizer.hs +18/−11
• test/SQL/InterpreterTest.hs +24/−17
• test/Server/Main.hs +21/−22
• test/Server/WebSocket.hs +4/−1
• test/TransactionGraph/Automerge.hs +7/−4
• test/TransactionGraph/Merge.hs +180/−90
• test/TransactionGraph/Persist.hs +64/−14
• test/TutorialD/Interpreter/DatabaseContextFunctionScript.hs +5/−5
• test/TutorialD/Interpreter/Import/ImportTest.hs +6/−2
• test/TutorialD/Interpreter/TestBase.hs +9/−8
• test/TutorialD/InterpreterTest.hs +75/−51
• test/scripts.hs +1/−1

@@ -1,3 +1,12 @@+# 2026-01-06 (v1.2.0)++* add LRU result caching layer+* add parallel execution engine based on [streamly 0.9.0](https://github.com/composewell/streamly)+* reduce copying of database context fields in persistence layer by enabling references to previous transactions+* require GHC 9.4++* add TLS encryption including mutual TLS support for client authentication+* add role-based authentication for a variety of database permissions+ # 2025-03-30 (v1.1.1)  * upgrade to curryer-rpc 0.4.0 which includes support for IPv6 and Unix domain socket communications

@@ -4,7 +4,6 @@ [![Public Domain](https://img.shields.io/badge/license-Public%20Domain-brightgreen.svg)](http://unlicense.org) [![Hackage](https://img.shields.io/hackage/v/project-m36.svg)](http://hackage.haskell.org/package/project-m36) [![Hackage dependency status](https://img.shields.io/hackage-deps/v/project-m36.svg)](http://packdeps.haskellers.com/feed?needle=project-m36)-[![Windows Build status](https://ci.appveyor.com/api/projects/status/q7jyddd6dy1ibqdo/branch/master?svg=true)](https://ci.appveyor.com/project/agentm/project-m36) [![Github Workflow status](https://github.com/agentm/project-m36/workflows/CI/badge.svg)](https://github.com/agentm/project-m36/actions?query=workflow%3ACI)  @@ -83,6 +82,8 @@  ### Advanced Features +1. [Role-Based Access Control](docs/role-based_access_control.markdown)+1. [Authentication](docs/authentication.markdown) 1. [Transaction Graph Operators](docs/transaction_graph_operators.markdown) 1. [ProjectM36.Client Library](docs/projectm36_client_library.markdown) 1. [Data Frames for Sorting](docs/dataframes.markdown)

@@ -0,0 +1,70 @@+{-# LANGUAGE DeriveGeneric, DerivingVia, TypeApplications #-}+import ProjectM36.Client+import Data.Typeable+import ProjectM36.Relation+import GHC.Generics+import ProjectM36.Tuple+import System.Random (initStdGen)++-- define a custom data type to use in both the client and database+data AgeType = PreciseAge Int |+               ForgotToAsk |+               RefusedToDisclose |+               NotApplicable |+               ApproximateAge Int Int+               deriving (Eq, Show, Generic)++-- define an automatically-derived Atomable instance+instance Atomable AgeType++failFast :: Show a => IO (Either a b) -> IO b+failFast m = do+  ret <- m+  case ret of+    Left err -> error (show err)+    Right val -> pure val++ageAtomType :: AtomType+ageAtomType = toAtomType (Proxy :: Proxy AgeType)+               +main :: IO ()+main = do+  let bob_relation_attrs = attributesFromList [Attribute "name" TextAtomType,+                                               Attribute "age" ageAtomType]+      relvar_name = "hospital_patient"+      age_value_in = ApproximateAge 30 40 +      mk_bob_relation = mkRelationFromList +                     bob_relation_attrs +                     [[TextAtom "Bob",+                       toAtom age_value_in]]++  rando <- initStdGen+  -- create the database+  conn <- failFast $ connectProjectM36 (InProcessConnectionInfo NoPersistence emptyNotificationCallback [] basicDatabaseContext rando "admin")++  -- create the session at the head of master branch+  sessionId <- failFast $ createSessionAtHead conn "master"++  -- create the data type in the database+  failFast $ executeDatabaseContextExpr sessionId conn (toAddTypeExpr (Proxy :: Proxy AgeType))+  +  -- create the patient data in a relation+  bob_relation <- failFast (pure mk_bob_relation)++  -- save the data to the database+  failFast $ executeDatabaseContextExpr sessionId conn (Assign relvar_name (ExistingRelation bob_relation))++  -- retrieve the data from the database+  result <- failFast $ executeRelationalExpr sessionId conn (RelationVariable relvar_name ())++  -- print the data+  case singletonTuple result of+    Nothing -> error "not a singleton relation!"+    Just tuple -> do+      case atomForAttributeName "age" tuple of+        Left err -> error (show err)+        Right age_value_out -> do+          print age_value_in+          print (fromAtom @AgeType age_value_out)+      +            

@@ -22,7 +22,7 @@ import Data.Text as T (Text,pack) import GHC.Generics (Generic) import qualified ProjectM36.Base as Base-import ProjectM36.DatabaseContext+import ProjectM36.DatabaseContext.Basic import ProjectM36.Client        ( AtomExprBase(NakedAtomExpr)        , Atomable(toAddTypeExpr, toAtom)@@ -365,7 +365,8 @@ dbConnection :: IO DBConnection dbConnection = do   --  connect to the database-  let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback [] basicDatabaseContext+  rando <- R.initStdGen+  let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback [] basicDatabaseContext rando "admin"   --  The code below persists the data in a DB with the name "base". \\ --  let connInfo = InProcessConnectionInfo (CrashSafePersistence "base") emptyNotificationCallback [] \\   --  In addition minimal persistence is available. \\

@@ -5,11 +5,12 @@ import ProjectM36.TupleSet import ProjectM36.Relation.Show.Term import Data.Text.IO as TIO+import Network.RPC.Curryer.Client (ClientConnectionConfig(..))  main :: IO () main = do   -- 1. create a ConnectionInfo-  let connInfo = RemoteConnectionInfo "mytestdb" defaultRemoteServerAddress emptyNotificationCallback+  let connInfo = RemoteConnectionInfo "mytestdb" defaultRemoteServerAddress UnencryptedConnectionConfig emptyNotificationCallback "admin"   -- 2. connected to the remote database   eConn <- connectProjectM36 connInfo   case eConn of

@@ -16,9 +16,6 @@ import Data.Time.Calendar import Control.DeepSeq import Data.Proxy-#if __GLASGOW_HASKELL__ < 804-import Data.Monoid-#endif import Data.List import Control.Monad (when, forM_) import Codec.Winery@@ -30,6 +27,7 @@ --import Control.Monad.IO.Class (liftIO) import Network.HTTP.Types.Status import Data.Time.Format.ISO8601+import System.Random  --define your data types data Blog = Blog {@@ -76,7 +74,8 @@ main :: IO ()                        main = do   --connect to the database-  let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback [] basicDatabaseContext+  rando <- initStdGen+  let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback [] basicDatabaseContext rando "admin"   conn <- handleIOError $ connectProjectM36 connInfo      sessionId <- handleIOError $ createSessionAtHead conn "master"

@@ -8,6 +8,7 @@ import qualified Data.Text.IO as TIO import Data.Proxy import Codec.Winery+import System.Random  data Hair = Bald | Brown | Blond | OtherColor Text    deriving (Generic, Show, Eq, NFData, Atomable)@@ -16,7 +17,9 @@ main :: IO () main = do  --connect to the database-  let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback [] basicDatabaseContext+  rando <- initStdGen++  let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback [] basicDatabaseContext rando "admin"       eCheck v = do         x <- v         case x of 

@@ -5,6 +5,7 @@ import ProjectM36.Tupleable import ProjectM36.Relation import ProjectM36.Error+import ProjectM36.AtomFunction import Data.Either import GHC.Generics import Control.DeepSeq@@ -12,6 +13,7 @@ import Data.Time.Calendar import Data.Proxy import Codec.Winery+import System.Random (initStdGen)  --create various database value (atom) types type Price = Double@@ -39,7 +41,8 @@ main :: IO () main = do   --connect to the database-  let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback [] basicDatabaseContext+  rando <- initStdGen+  let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback [] basicDatabaseContext rando "admin"       check x = case x of          Left err -> error (show err)         Right x' -> x'

@@ -0,0 +1,74 @@+{-# LANGUAGE DeriveGeneric, DerivingVia, DeriveAnyClass, OverloadedStrings #-}+import ProjectM36.Client+import ProjectM36.Relation+import ProjectM36.Tupleable+import ProjectM36.TupleSet+import ProjectM36.Relation.Show.Term++import Data.Typeable+import GHC.Generics+import System.Random (initStdGen)+import Data.Time.Calendar+import qualified Data.Text.IO as T++data Ticket = Ticket+  { ticketId   :: Integer+  , visitorAge :: Integer    -- years+  , basePrice  :: Integer  -- base price before adjustments+  , visitDate  :: Day+}+ deriving (Generic, Tupleable)+++main :: IO ()+main = do+  let ticketAttrs = toAttributes (Proxy :: Proxy Ticket)+      ticket1 = Ticket { ticketId = 1,+                         visitorAge = 8,+                         basePrice = 20,+                         visitDate = fromGregorian 2025 10 01 }+      ticket2 = Ticket { ticketId = 2,+                         visitorAge = 25,+                         basePrice = 20,+                         visitDate = fromGregorian 2025 12 25 }+      Right ticketTupleSet = mkTupleSet ticketAttrs [toTuple ticket1,+                                          toTuple ticket2]+      Right ticketRel = mkRelation ticketAttrs ticketTupleSet+  rando <- initStdGen+  -- connect to the database+  conn <- failFast $ connectProjectM36 (InProcessConnectionInfo NoPersistence emptyNotificationCallback [] basicDatabaseContext rando "admin")++  -- create a session on the master branch+  sessionId <- failFast $ createSessionAtHead conn "master"++  -- add the ticket discount function+  let func_type = [integerTypeCons, integerTypeCons, ADTypeConstructor "Either" [ADTypeConstructor "AtomFunctionError" [], integerTypeCons]]+      integerTypeCons = PrimitiveTypeConstructor "Integer" IntegerAtomType+      func_body = "(\\[IntegerAtom age,IntegerAtom price] -> pure (IntegerAtom (if age < 10 then price `div` 2 else price))) :: [Atom] -> Either AtomFunctionError Atom"+  failFast $ executeDatabaseContextIOExpr sessionId conn (AddAtomFunction "apply_discount" func_type func_body)++  -- calculate the proper discount per ticket and add it to the database+  let discountedTicketRel = Extend (AttributeExtendTupleExpr "discounted_price" func_apply_discount) (ExistingRelation ticketRel)+      func_apply_discount = FunctionAtomExpr "apply_discount" [AttributeAtomExpr "visitorAge", AttributeAtomExpr "basePrice"] ()+  failFast $ executeDatabaseContextExpr sessionId conn (Assign "ticket_sales" discountedTicketRel)++  -- print out the resultant relation+  Right ticketSalesRelation <- executeRelationalExpr sessionId conn (RelationVariable "ticket_sales" ())+  T.putStrLn $ showRelation ticketSalesRelation++ +++-- | Apply a 50% discount for kids under 10 years old. Arguments: age, base price+applyDiscount :: Integer -> Integer -> Integer+applyDiscount age base_price =+  if age < 10 then base_price `div` 2 else base_price++failFast :: Show a => IO (Either a b) -> IO b+failFast m = do+  ret <- m+  case ret of+    Left err -> error (show err)+    Right val -> pure val++  

@@ -1,6 +1,6 @@ Cabal-Version: 2.2 Name: project-m36-Version: 1.1.1+Version: 1.2.0 License: MIT --note that this license specification is erroneous and only labeled MIT to appease hackage which does not recognize public domain packages in cabal >2.2- Project:M36 is dedicated to the public domain Build-Type: Simple@@ -14,7 +14,7 @@ Description: A relational algebra engine which can be used to persist and query Haskell data types. Extra-Source-Files: scripts/DateExamples.tutd scripts/multiline.tutd Extra-Doc-Files: Changelog.markdown README.markdown-tested-with: GHC ==9.2.8 || ==9.4.8 || ==9.6.6 || ==9.8.2 || ==9.10.1+tested-with: GHC ==9.4.8 || ==9.6.6 || ==9.8.2 || ==9.10.1  Source-Repository head     Type: git@@ -46,8 +46,10 @@                   hashable,                   haskeline,                   directory,-                  MonadRandom, +                  MonadRandom,+                  random,                   random-shuffle,+                  prettyprinter,                   uuid >= 1.3.12,                   cassava >= 0.4.5.1 && < 0.6,                   text,@@ -89,7 +91,7 @@                   cryptohash-sha256,                   text-manipulate >= 0.2.0.1 && < 0.4,                   winery >= 1.4,-                  curryer-rpc>=0.4.0,+                  curryer-rpc>=0.5.0,                   network,                   async,                   vector-instances,@@ -97,7 +99,16 @@                   streamly == 0.10.1,                   convertible,                   fast-builder,-                  scientific+                  scientific,+                  crypton,+                  streamly-core,+                  streamly,+                  network-byte-order,+                  sqlite-simple,+                  data-default,+                  process,+                  system-linux-proc,+                  megaparsec      if flag(haskell-scripting)         Build-Depends: ghc >= 9.0         CPP-Options: -DPM36_HASKELL_SCRIPTING@@ -106,6 +117,10 @@         ghc-boot, ghci     if impl(ghc>= 8.6)         Build-Depends: deferred-folds+    if impl(ghc >= 9)+        Build-Depends: ghc-bignum+    if !impl(ghc >= 9)+        Build-Depends: integer-gmp     Exposed-Modules: ProjectM36.Error,                      ProjectM36.Transaction,                      ProjectM36.TransactionGraph,@@ -116,23 +131,28 @@                      ProjectM36.Base,                      ProjectM36.Serialise.Base,                      ProjectM36.Serialise.Error,+                     ProjectM36.Serialise.LoginRoles,                      ProjectM36.DataFrame,                      ProjectM36.Attribute,                      ProjectM36.AttributeNames,                      ProjectM36.Tuple,                      ProjectM36.TupleSet,+                     ProjectM36.RelationVariablesMentioned,                      ProjectM36.Function,                      ProjectM36.Atom,                      ProjectM36.AtomFunction,-                     ProjectM36.AtomFunctionError,+                     ProjectM36.BTree,                      ProjectM36.ScriptSession,                      ProjectM36.Shortcuts,                      ProjectM36.DatabaseContextFunction,-                     ProjectM36.DatabaseContextFunctionError,                      ProjectM36.DatabaseContextFunctionUtils,                      ProjectM36.Key,                      ProjectM36.FunctionalDependency,                      ProjectM36.DatabaseContext,+                     ProjectM36.DatabaseContext.Types,+                     ProjectM36.ValueMarker,+                     ProjectM36.DatabaseContextFunctions.Basic,+                     ProjectM36.TransactionGraph.Types,                      ProjectM36.DateExamples,                      ProjectM36.DisconnectedTransaction,                      ProjectM36.AtomFunctionBody,@@ -154,6 +174,9 @@                      ProjectM36.AttributeExpr,                      ProjectM36.AtomFunctions.Basic,                      ProjectM36.AtomFunctions.Primitive,+                     ProjectM36.AtomFunctionError,+                     ProjectM36.DatabaseContext.SelfTest,+                     ProjectM36.AtomFunctions.SelfTest,                      ProjectM36.Atomable,                      ProjectM36.Tupleable,                      ProjectM36.Tupleable.Deriving,@@ -170,7 +193,10 @@                      ProjectM36.DataTypes.Interval,                      ProjectM36.DataTypes.ByteString,                      ProjectM36.DataTypes.SQL.Null,-                     ProjectM36.SQLDatabaseContext,+                     ProjectM36.SQLDatabaseContext,                     +                     ProjectM36.DatabaseContext.Basic,+                     ProjectM36.DatabaseContext.Fields,                     +                     ProjectM36.DatabaseContextExpr,                                           ProjectM36.MiscUtils,                      ProjectM36.Notifications,                      ProjectM36.Relation,@@ -181,11 +207,12 @@                      ProjectM36.Server.RemoteCallTypes,                      ProjectM36.Serialise.AtomFunctionError,                      ProjectM36.Serialise.DataFrame,-                     ProjectM36.Serialise.DatabaseContextFunctionError,                      ProjectM36.Serialise.IsomorphicSchema,                      ProjectM36.Session,                      ProjectM36.Sessions,                      ProjectM36.Transaction.Persist,+                     ProjectM36.Transaction.Types,+                     ProjectM36.IsomorphicSchema.Types,                      ProjectM36.TypeConstructor,                      ProjectM36.TypeConstructorDef,                      ProjectM36.FileLock,@@ -196,6 +223,11 @@                      ProjectM36.TransactionInfo,                      ProjectM36.WithNameExpr,                       ProjectM36.Trace,+                     ProjectM36.Streaming.Tuple,+                     ProjectM36.Streaming.RelationalExpression,     +                     ProjectM36.Cache.RelationalExprCache,+                     ProjectM36.Cache.Tuple,+                     ProjectM36.RelExprSize,                      ProjectM36.HashSecurely,                      ProjectM36.DDLType,                      ProjectM36.RegisteredQuery,@@ -206,8 +238,14 @@                      ProjectM36.SQL.Delete,                      ProjectM36.SQL.DBUpdate,                      ProjectM36.SQL.CreateTable,-                     ProjectM36.SQL.DropTable-                     ProjectM36.ReferencedTransactionIds+                     ProjectM36.SQL.DropTable,+                     ProjectM36.ReferencedTransactionIds,+                     ProjectM36.SystemMemory,+                     ProjectM36.PinnedRelationalExpr,+                     ProjectM36.AccessControlList,+                     ProjectM36.AccessControl,+                     ProjectM36.LoginRoles,+                     ProjectM36.PrettyBytes     GHC-Options: -Wall -rdynamic     if os(windows)       Build-Depends: Win32 >= 2.12@@ -215,10 +253,10 @@     else       --219-  too many exported symbols under Windows and GHC 8.4       GHC-Options: -rdynamic -fexternal-interpreter-      if impl(ghc <9.4)-        GHC-Options: -eventlog       C-sources: cbits/DirectoryFsync.c, cbits/darwin_statfs.c       Build-Depends: unix+    if os(linux)+      Build-Depends: linux-xattr     CC-Options: -fPIC     Hs-Source-Dirs: ./src/lib     Default-Language: Haskell2010@@ -228,8 +266,8 @@  Executable tutd     if flag(haskell-scripting)-        Build-Depends: ghc >= 9.0-    Build-Depends: base >=4.8,+        Build-Depends: ghc >= 9.4+    Build-Depends: base >=4.17,                    ghc-paths,                    project-m36,                    containers,@@ -240,10 +278,11 @@                    mtl,                    uuid,                    deepseq-generics,-                   MonadRandom, MonadRandom,+                   MonadRandom,                    vector,                    text,                    time,+                   process,                    bytestring,                    stm,                    deepseq,@@ -256,7 +295,7 @@                    temporary,                    megaparsec >= 5.2.0 && < 10,                    haskeline,-                   random, MonadRandom,+                   random,                    base64-bytestring,                    optparse-applicative,                    attoparsec,@@ -272,8 +311,7 @@                    modern-uri,                    http-types,                    recursion-schemes,-                   data-default < 0.8-                   --data-default 0.8.0.0 breaks http-tls-client+                   data-default      Other-Modules: TutorialD.Interpreter,                    TutorialD.Interpreter.Base,                    TutorialD.Interpreter.DatabaseContextExpr,@@ -291,6 +329,7 @@                    TutorialD.Interpreter.Types,                    TutorialD.Interpreter.TransGraphRelationalOperator,                    TutorialD.Interpreter.SchemaOperator,+                   TutorialD.Interpreter.LoginRolesOperator,                    TutorialD.Printer,                    ProjectM36.Cli,                    ProjectM36.Interpreter@@ -299,8 +338,6 @@     GHC-Options: -Wall -threaded -rtsopts     if !os(windows)       GHC-Options: -rdynamic-    if impl(ghc <9.4)-      GHC-Options: -eventlog     if flag(profiler)       GHC-Prof-Options: -fprof-auto -rtsopts -threaded     Hs-Source-Dirs: ./src/bin@@ -309,7 +346,7 @@  Executable sqlegacy     if flag(haskell-scripting)-        Build-Depends: ghc >= 9.0+        Build-Depends: ghc >= 9.4     Build-Depends: base,                    ghc-paths,                    project-m36,@@ -383,7 +420,7 @@  Executable project-m36-server     if flag(haskell-scripting)-        Build-Depends: ghc >= 9.0+        Build-Depends: ghc >= 9.4     Build-Depends: base,                    ghc-paths,                    transformers,@@ -413,9 +450,9 @@                    scientific     Main-Is: ./src/bin/ProjectM36/Server/project-m36-server.hs     if os(windows)-      GHC-Options: -Wall -threaded -rtsopts+      GHC-Options: -Wall -threaded -rtsopts -with-rtsopts=-N     else-      GHC-Options: -Wall -threaded -rtsopts -rdynamic+      GHC-Options: -Wall -threaded -rtsopts -rdynamic -with-rtsopts=-N     if flag(profiler)       GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall     Default-Language: Haskell2010@@ -424,14 +461,15 @@ Executable bigrel     Default-Language: Haskell2010     Default-Extensions: OverloadedStrings-    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, bytestring, uuid, stm, deepseq, deepseq-generics, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, optparse-applicative, stm-containers, list-t, ghc, ghc-paths, transformers, project-m36, random, MonadRandom, semigroups, parser-combinators+    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, bytestring, uuid, stm, deepseq, deepseq-generics, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, optparse-applicative, stm-containers, list-t, ghc, ghc-paths, transformers, project-m36, random, MonadRandom, semigroups, parser-combinators, curryer-rpc     Other-Modules: TutorialD.Interpreter.Base,                    TutorialD.Interpreter.DatabaseContextExpr,                    TutorialD.Interpreter.RelationalExpr,                    TutorialD.Interpreter.Types,-                   ProjectM36.Interpreter+                   ProjectM36.Interpreter,+                   ProjectM36.Cli     main-is: benchmark/bigrel.hs-    GHC-Options: -Wall -threaded -rtsopts+    GHC-Options: -Wall -threaded -rtsopts -with-rtsopts=-N     HS-Source-Dirs: ./src/bin     if flag(profiler)       GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall@@ -440,27 +478,39 @@  Common commontest     Default-Language: Haskell2010-    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, websockets, optparse-applicative, network, aeson, project-m36, random, MonadRandom, semigroups, parser-combinators, winery, curryer-rpc, prettyprinter, base64-bytestring, modern-uri, http-types, http-conduit, base16-bytestring, cryptohash-sha256, scientific+    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, websockets, optparse-applicative, network, aeson, project-m36, random, MonadRandom, semigroups, parser-combinators, winery, curryer-rpc, prettyprinter, base64-bytestring, modern-uri, http-types, http-conduit, base16-bytestring, cryptohash-sha256, scientific, streamly     Default-Extensions: OverloadedStrings-    GHC-Options: -Wall -threaded+    GHC-Options: -Wall -threaded -with-rtsopts=-N     Hs-Source-Dirs: test, src/bin+    Other-Modules: ProjectM36.Interpreter, ProjectM36.Cli  Benchmark basic-benchmark     Default-Language: Haskell2010     Default-Extensions: OverloadedStrings-    Build-Depends: base, criterion, project-m36, text, vector, transformers, containers, temporary, directory, filepath+    Build-Depends: base, criterion, project-m36, text, vector, containers, temporary, directory, filepath     Main-Is: benchmark/Basic.hs     Type: exitcode-stdio-1.0-    GHC-Options: -Wall -threaded -rtsopts+    GHC-Options: -Wall -threaded -rtsopts -Wunused-packages     HS-Source-Dirs: ./src/bin     if flag(profiler)       GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall +Benchmark btree-benchmark+    Default-Language: Haskell2010+    Default-Extensions: OverloadedStrings+    Build-Depends: base, criterion, project-m36, text, vector, transformers, containers, temporary, directory, filepath, deepseq, byteunits+    Main-Is: benchmark/BTree.hs+    Type: exitcode-stdio-1.0+    GHC-Options: -Wall -threaded -rtsopts -Wunused-packages+    HS-Source-Dirs: ./src/bin+    if flag(profiler)+      GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall+ --benchmark inserts, updates, deletes for a basic use-case to shake out any space leaks Benchmark update-exprs   Default-Language: Haskell2010   Default-Extensions: OverloadedStrings-  Build-Depends: base, criterion, project-m36, text, winery+  Build-Depends: base, criterion, project-m36, text, winery, random   Main-Is: benchmark/Server.hs   Type: exitcode-stdio-1.0   GHC-Options: -Wall -threaded -rtsopts@@ -474,6 +524,7 @@     main-is: SQL/InterpreterTest.hs     Other-Modules: SQL.Interpreter.Select, SQL.Interpreter.Base, TutorialD.Interpreter.Base, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.RODatabaseContextOperator, ProjectM36.Interpreter, SQL.Interpreter.CreateTable                    TutorialD.Printer,+                   ProjectM36.Cli,                    SQL.Interpreter.DBUpdate,                    SQL.Interpreter.Delete,                    SQL.Interpreter.DropTable,@@ -486,19 +537,21 @@     import: commontest     type: exitcode-stdio-1.0     main-is: TutorialD/InterpreterTest.hs-    Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer, ProjectM36.Interpreter+    Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer, ProjectM36.Interpreter, ProjectM36.Cli, TutorialD.Interpreter.LoginRolesOperator     Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, bytestring, uuid, stm, deepseq, deepseq-generics, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, list-t, project-m36, random, MonadRandom, semigroups, parser-combinators, prettyprinter, scientific  Test-Suite test-tutoriald-atomfunctionscript     import: commontest     type: exitcode-stdio-1.0-    Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer, ProjectM36.Interpreter+    Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer, ProjectM36.Interpreter, TutorialD.Interpreter.LoginRolesOperator     main-is: TutorialD/Interpreter/AtomFunctionScript.hs  Test-Suite test-tutoriald-databasecontextfunctionscript     import: commontest     type: exitcode-stdio-1.0-    Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer, ProjectM36.Interpreter+    if flag(haskell-scripting)+        CPP-Options: -DPM36_HASKELL_SCRIPTING+    Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer, ProjectM36.Interpreter, TutorialD.Interpreter.LoginRolesOperator     main-is: TutorialD/Interpreter/DatabaseContextFunctionScript.hs  Test-Suite test-relation@@ -560,6 +613,26 @@     GHC-Options: -rtsopts -Wall -threaded -finfo-table-map -fdistinct-constructor-tables     if impl(ghc <9.4)       GHC-Options: -eventlog+    Other-Modules: ProjectM36.Cli,+        TutorialD.Interpreter,+        TutorialD.Interpreter.Base,+        TutorialD.Interpreter.DatabaseContextExpr,+        TutorialD.Interpreter.DatabaseContextIOOperator,+        TutorialD.Interpreter.Export.Base,+        TutorialD.Interpreter.Export.CSV,+        TutorialD.Interpreter.Import.Base,+        TutorialD.Interpreter.Import.BasicExamples,+        TutorialD.Interpreter.Import.CSV,+        TutorialD.Interpreter.Import.TutorialD,+        TutorialD.Interpreter.InformationOperator,+        TutorialD.Interpreter.RODatabaseContextOperator,+        TutorialD.Interpreter.RelationalExpr,+        TutorialD.Interpreter.SchemaOperator,+        TutorialD.Interpreter.TransGraphRelationalOperator,+        TutorialD.Interpreter.TransactionGraphOperator,+        TutorialD.Interpreter.Types,+        TutorialD.Interpreter.LoginRolesOperator,+        TutorialD.Printer  Test-Suite test-server     import: commontest@@ -569,28 +642,28 @@ Executable Example-SimpleClient     Default-Language: Haskell2010     Default-Extensions: OverloadedStrings-    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, ghc, ghc-paths, project-m36, random, MonadRandom+    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, ghc, ghc-paths, project-m36, random, MonadRandom, curryer-rpc     Main-Is: examples/SimpleClient.hs     GHC-Options: -Wall -threaded  Executable Example-OutOfTheTarpit     Default-Language: Haskell2010     Default-Extensions: OverloadedStrings-    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36, winery+    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36, winery, random     Main-Is: examples/out_of_the_tarpit.hs     GHC-Options: -Wall -threaded  Executable Example-Blog     Default-Language: Haskell2010     Default-Extensions: OverloadedStrings-    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36, scotty >= 0.22, blaze-html, http-types, winery+    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36, scotty >= 0.22, blaze-html, http-types, winery, random     Main-Is: examples/blog.hs     GHC-Options: -Wall -threaded  Executable Example-Hair     Default-Language: Haskell2010     Default-Extensions: OverloadedStrings-    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36, winery+    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36, winery, random     Main-Is: examples/hair.hs     GHC-Options: -Wall -threaded @@ -608,27 +681,38 @@     Main-Is: examples/CustomTupleable.hs     GHC-Options: -Wall -threaded +Executable Example-Hospital+    Default-Language: Haskell2010+    Default-Extensions: OverloadedStrings+    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36, winery, random+    Main-Is: examples/Hospital.hs+    GHC-Options: -Wall -threaded+               + Executable Example-DerivingCustomTupleable-    if impl(ghc>=8.6)-      Buildable: True-    else-      Buildable: False     Default-Language: Haskell2010     Build-Depends: base, text, deepseq, project-m36, winery     Main-Is: examples/DerivingCustomTupleable.hs     GHC-Options: -Wall -threaded +Executable Example-Zoo+    Default-Language: Haskell2010+    Build-Depends: base, text, deepseq, project-m36, winery, random, time+    Main-Is: examples/zoo.hs+    GHC-Options: -Wall -threaded+         + Test-Suite test-scripts     import: commontest     type: exitcode-stdio-1.0     main-is: scripts.hs-    Other-Modules: TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Printer+    Other-Modules: TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Printer, TutorialD.Interpreter.LoginRolesOperator  Executable project-m36-websocket-server     Default-Language: Haskell2010-    Build-Depends: base, aeson, path-pieces, either, conduit, http-api-data, template-haskell, websockets, aeson, optparse-applicative, project-m36, containers, bytestring, text, vector, uuid, megaparsec, haskeline, mtl, directory, base64-bytestring, random, MonadRandom, time, semigroups, attoparsec, parser-combinators, prettyprinter, network, modern-uri, http-conduit, base16-bytestring, http-types, cryptohash-sha256, wai, wai-websockets, warp, warp-tls, scientific+    Build-Depends: base, aeson, path-pieces, either, conduit, http-api-data, template-haskell, websockets, optparse-applicative, project-m36, containers, bytestring, text, vector, uuid, megaparsec, haskeline, mtl, directory, base64-bytestring, random, MonadRandom, time, semigroups, attoparsec, parser-combinators, prettyprinter, network, modern-uri, http-conduit, base16-bytestring, http-types, cryptohash-sha256, wai, wai-websockets, warp, warp-tls, scientific, curryer-rpc     Main-Is: ProjectM36/Server/WebSocket/websocket-server.hs-    Other-Modules:  ProjectM36.Client.Json, ProjectM36.Server.RemoteCallTypes.Json, ProjectM36.Server.WebSocket, TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer, ProjectM36.Interpreter+    Other-Modules:  ProjectM36.Cli, ProjectM36.Client.Json, ProjectM36.Server.RemoteCallTypes.Json, ProjectM36.Server.WebSocket, TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer, ProjectM36.Interpreter, TutorialD.Interpreter.LoginRolesOperator     GHC-Options: -Wall -threaded     Hs-Source-Dirs: ./src/bin     Default-Extensions: OverloadedStrings@@ -637,7 +721,7 @@     import: commontest     type: exitcode-stdio-1.0     main-is: Server/WebSocket.hs-    Other-Modules: TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.TransactionGraphOperator, ProjectM36.Client.Json, ProjectM36.Server.RemoteCallTypes.Json, ProjectM36.Server.WebSocket, TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer, ProjectM36.Interpreter+    Other-Modules: TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.TransactionGraphOperator, ProjectM36.Client.Json, ProjectM36.Server.RemoteCallTypes.Json, ProjectM36.Server.WebSocket, TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer, ProjectM36.Interpreter, ProjectM36.Cli, TutorialD.Interpreter.LoginRolesOperator  Test-Suite test-isomorphic-schemas     import: commontest@@ -648,7 +732,7 @@     import: commontest     type: exitcode-stdio-1.0     main-is: Relation/Atomable.hs-    Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.SchemaOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Printer+    Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.SchemaOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Printer, ProjectM36.Cli, TutorialD.Interpreter.LoginRolesOperator  Test-Suite test-multiprocess-access     import: commontest@@ -659,7 +743,7 @@     import: commontest     type: exitcode-stdio-1.0     main-is: TransactionGraph/Automerge.hs-    Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.SchemaOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Printer+    Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.SchemaOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Printer, ProjectM36.Cli, TutorialD.Interpreter.LoginRolesOperator  Test-Suite test-tupleable     import: commontest@@ -675,7 +759,7 @@ Executable handles     Default-Language: Haskell2010     Default-Extensions: OverloadedStrings-    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, optparse-applicative, stm-containers, list-t, ghc, ghc-paths, transformers, project-m36, random, MonadRandom, semigroups, parser-combinators, prettyprinter, modern-uri, http-types, http-conduit, base16-bytestring, cryptohash-sha256+    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, optparse-applicative, stm-containers, list-t, ghc, ghc-paths, transformers, project-m36, random, MonadRandom, semigroups, parser-combinators, prettyprinter, modern-uri, http-types, http-conduit, base16-bytestring, cryptohash-sha256, curryer-rpc     main-is: benchmark/Handles.hs     Other-Modules: TutorialD.Interpreter,       TutorialD.Interpreter.Base,@@ -695,7 +779,9 @@       TutorialD.Interpreter.TransactionGraphOperator,       TutorialD.Interpreter.Types,       TutorialD.Printer,-      ProjectM36.Interpreter+      ProjectM36.Interpreter,+      ProjectM36.Cli,+      TutorialD.Interpreter.LoginRolesOperator     GHC-Options: -Wall -threaded -rtsopts     HS-Source-Dirs: ./src/bin     if flag(profiler)@@ -705,7 +791,46 @@     import: commontest     type: exitcode-stdio-1.0     Main-Is: DataFrame.hs-    Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr,  TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.SchemaOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Printer, ProjectM36.Interpreter+    Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr,  TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.SchemaOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Printer, ProjectM36.Interpreter, TutorialD.Interpreter.LoginRolesOperator +Test-Suite test-cache+   import: commontest+   type: exitcode-stdio-1.0+   Main-Is: Cache.hs -  +Test-Suite test-accesscontrollist+    import: commontest+    type: exitcode-stdio-1.0+    Main-Is: AccessControlList.hs++Test-Suite test-loginroles+    import: commontest+    type: exitcode-stdio-1.0    +    Main-Is: LoginRoles.hs++Test-Suite test-accesscontrol+    import: commontest+    type: exitcode-stdio-1.0    +    Main-Is: AccessControl.hs+    Other-Modules:+        TutorialD.Interpreter+        TutorialD.Interpreter.Base+        TutorialD.Interpreter.DatabaseContextExpr+        TutorialD.Interpreter.DatabaseContextIOOperator+        TutorialD.Interpreter.Export.Base+        TutorialD.Interpreter.Export.CSV+        TutorialD.Interpreter.Import.Base+        TutorialD.Interpreter.Import.BasicExamples+        TutorialD.Interpreter.Import.CSV+        TutorialD.Interpreter.Import.TutorialD+        TutorialD.Interpreter.InformationOperator+        TutorialD.Interpreter.LoginRolesOperator+        TutorialD.Interpreter.RODatabaseContextOperator+        TutorialD.Interpreter.RelationalExpr+        TutorialD.Interpreter.SchemaOperator+        TutorialD.Interpreter.TestBase+        TutorialD.Interpreter.TransGraphRelationalOperator+        TutorialD.Interpreter.TransactionGraphOperator+        TutorialD.Interpreter.Types+        TutorialD.Printer+ 

@@ -4,6 +4,8 @@ import qualified ProjectM36.Client as C import qualified Data.Text as T import ProjectM36.Base+import ProjectM36.DatabaseContext.Types+import ProjectM36.IsomorphicSchema.Types import ProjectM36.Client (RemoteServerAddress(..)) import System.Console.Haskeline import Control.Exception@@ -20,6 +22,8 @@ import Text.Megaparsec.Error import Data.Void (Void) import ProjectM36.Interpreter hiding (Parser)+import Network.RPC.Curryer.Client+import System.Random (StdGen, initStdGen)  type GhcPkgPath = String type TutorialDExec = String@@ -28,8 +32,8 @@ type DirectExecute = String type ParserError = ParseErrorBundle T.Text Void -data InterpreterConfig = LocalInterpreterConfig PersistenceStrategy HeadName (Maybe DirectExecute) [GhcPkgPath] CheckFS |-                         RemoteInterpreterConfig RemoteServerAddress C.DatabaseName HeadName (Maybe TutorialDExec) CheckFS+data InterpreterConfig = LocalInterpreterConfig PersistenceStrategy HeadName (Maybe DirectExecute) [GhcPkgPath] CheckFS RoleName |+                         RemoteInterpreterConfig RemoteServerAddress ClientConnectionConfig C.DatabaseName HeadName (Maybe TutorialDExec) CheckFS RoleName  outputNotificationCallback :: C.NotificationCallback outputNotificationCallback notName evaldNot = hPutStrLn stderr $ "Notification received " ++ show notName ++ ":\n" ++ "\n" ++ prettyEvaluatedNotification evaldNot@@ -41,15 +45,15 @@   eRelShow (C.reportOldRelation eNotif) <> "\n" <> eRelShow (C.reportNewRelation eNotif)  type ReprLoopEvaluator = C.SessionId -> C.Connection -> Maybe PromptLength -> T.Text -> IO ()-type MakePrompt = Either RelationalError HeadName -> Either RelationalError SchemaName -> StringType+type MakePrompt = Either RelationalError C.CurrentHead -> Either RelationalError SchemaName -> StringType type HistoryFilePath = FilePath    reprLoop :: InterpreterConfig -> HistoryFilePath -> ReprLoopEvaluator -> MakePrompt -> C.SessionId -> C.Connection -> IO () reprLoop config historyFilePath reprLoopEvaluator promptText sessionId conn = do   let settings = defaultSettings {historyFile = Just historyFilePath} -- (homeDirectory ++ "/.tutd_history")}-  eHeadName <- C.headName sessionId conn+  eCurrentHead <- C.currentHead sessionId conn   eSchemaName <- C.currentSchemaName sessionId conn-  let prompt = promptText eHeadName eSchemaName+  let prompt = promptText eCurrentHead eSchemaName       catchInterrupt = handleJust (\case                                       UserInterrupt -> Just Nothing                                       _ -> Nothing) (\_ -> do@@ -63,9 +67,37 @@       reprLoop config historyFilePath reprLoopEvaluator promptText sessionId conn  parseArgs :: Parser InterpreterConfig-parseArgs = LocalInterpreterConfig <$> parsePersistenceStrategy <*> parseHeadName <*> parseDirectExecute <*> many parseGhcPkgPath <*> parseCheckFS <|>-            RemoteInterpreterConfig <$> parseServerAddress <*> parseDatabaseName <*> parseHeadName <*> parseDirectExecute <*> parseCheckFS+parseArgs = LocalInterpreterConfig <$> parsePersistenceStrategy <*> parseHeadName <*> parseDirectExecute <*> many parseGhcPkgPath <*> parseCheckFS <*> parseRoleName <|>+            RemoteInterpreterConfig <$> parseServerAddress <*> parseClientConnectionConfig <*> parseDatabaseName <*> parseHeadName <*> parseDirectExecute <*> parseCheckFS <*> parseRoleName +parseClientConnectionConfig :: Parser ClientConnectionConfig+parseClientConnectionConfig =+  flag' UnencryptedConnectionConfig (long "disable-tls" <>+                                       help "Disable encryption when connecting to the server.")+  <|>+  EncryptedConnectionConfig <$> parseClientTLSConfig++parseClientTLSConfig :: Parser ClientTLSConfig+parseClientTLSConfig =+  ClientTLSConfig <$>+    parseClientTLSCertInfo <*>+    parseHostname "localhost" <*>+    parseServiceName ""++parseClientTLSCertInfo :: Parser ClientTLSCertInfo+parseClientTLSCertInfo =+  ClientTLSCertInfo <$>+  optional ((,) <$>+              strOption (long "public-x509-key" <>+                         metavar "KEY_PATH" <>+                         help "Enables TLS with path to public key.") <*>+              strOption (long "private-x509-key" <>+                         metavar "KEY_PATH" <>+                         help "Enables TLS with path to private key.")) <*>+  optional (strOption (long "certificate-x509-path" <>+                        metavar "CERT_PATH" <>+                        help "Path to certificate for TLS. Elide to use system's certificate store."))+     parseHeadName :: Parser HeadName                parseHeadName = option auto (long "head" <>                              help "Start session at head name." <>@@ -83,11 +115,12 @@ type PrintWelcome = IO () type ExecUserInput = C.SessionId -> C.Connection -> Maybe PromptLength -> T.Text -> IO () -mainLoop :: IO () -> HistoryFilePath -> ReprLoopEvaluator -> MakePrompt -> ExecUserInput -> DatabaseContext -> IO ()+mainLoop :: IO () -> HistoryFilePath -> ReprLoopEvaluator -> MakePrompt -> ExecUserInput -> ResolvedDatabaseContext -> IO () mainLoop printWelcome historyFilePath reprLoopEvaluator promptText execUserInput defaultDBContext = do   setLocaleIfNecessary   interpreterConfig <- execParser opts-  let connInfo = connectionInfoForConfig interpreterConfig defaultDBContext+  rando <- initStdGen+  let connInfo = connectionInfoForConfig interpreterConfig defaultDBContext rando   fscheck <- checkFSType (checkFSForConfig interpreterConfig) (fromMaybe NoPersistence (persistenceStrategyForConfig interpreterConfig))   if not fscheck then     errDie checkFSErrorMsg@@ -119,24 +152,24 @@ opts :: ParserInfo InterpreterConfig             opts = info (parseArgs <**> helpOption) idm -connectionInfoForConfig :: InterpreterConfig -> DatabaseContext -> C.ConnectionInfo-connectionInfoForConfig (LocalInterpreterConfig pStrategy _ _ ghcPkgPaths _) defaultDBContext = C.InProcessConnectionInfo pStrategy outputNotificationCallback ghcPkgPaths defaultDBContext-connectionInfoForConfig (RemoteInterpreterConfig remoteAddress remoteDBName _ _ _) _ = C.RemoteConnectionInfo remoteDBName remoteAddress outputNotificationCallback+connectionInfoForConfig :: InterpreterConfig -> ResolvedDatabaseContext -> StdGen -> C.ConnectionInfo+connectionInfoForConfig (LocalInterpreterConfig pStrategy _ _ ghcPkgPaths _ roleName) defaultDBContext rando = C.InProcessConnectionInfo pStrategy outputNotificationCallback ghcPkgPaths defaultDBContext rando roleName+connectionInfoForConfig (RemoteInterpreterConfig remoteAddress connConfig remoteDBName _ _ _ roleName) _ _ = C.RemoteConnectionInfo remoteDBName remoteAddress connConfig outputNotificationCallback roleName  headNameForConfig :: InterpreterConfig -> HeadName-headNameForConfig (LocalInterpreterConfig _ headn _ _ _) = headn-headNameForConfig (RemoteInterpreterConfig _ _ headn _ _) = headn+headNameForConfig (LocalInterpreterConfig _ headn _ _ _ _) = headn+headNameForConfig (RemoteInterpreterConfig _ _ _ headn _ _ _) = headn  directExecForConfig :: InterpreterConfig -> Maybe String-directExecForConfig (LocalInterpreterConfig _ _ t _ _) = t-directExecForConfig (RemoteInterpreterConfig _ _ _ t _) = t+directExecForConfig (LocalInterpreterConfig _ _ t _ _ _) = t+directExecForConfig (RemoteInterpreterConfig _ _ _ _ t _ _) = t  checkFSForConfig :: InterpreterConfig -> Bool-checkFSForConfig (LocalInterpreterConfig _ _ _ _ c) = c-checkFSForConfig (RemoteInterpreterConfig _ _ _ _ c) = c+checkFSForConfig (LocalInterpreterConfig _ _ _ _ c _) = c+checkFSForConfig (RemoteInterpreterConfig _ _ _ _ _ c _) = c  persistenceStrategyForConfig :: InterpreterConfig -> Maybe PersistenceStrategy-persistenceStrategyForConfig (LocalInterpreterConfig strat _ _ _ _) = Just strat+persistenceStrategyForConfig (LocalInterpreterConfig strat _ _ _ _ _) = Just strat persistenceStrategyForConfig RemoteInterpreterConfig{} = Nothing                           errDie :: String -> IO ()                                                           

@@ -5,9 +5,11 @@ import ProjectM36.AtomFunctionError import ProjectM36.Base import ProjectM36.DataFrame-import ProjectM36.DatabaseContextFunctionError+import ProjectM36.IsomorphicSchema.Types import ProjectM36.DataTypes.Primitive+import ProjectM36.DatabaseContext.Fields import ProjectM36.Error+import ProjectM36.AccessControlList import ProjectM36.IsomorphicSchema import ProjectM36.Server.RemoteCallTypes import ProjectM36.MerkleHash@@ -217,12 +219,12 @@ instance ToJSON MergeError instance FromJSON MergeError +instance ToJSON DatabaseContextField+instance FromJSON DatabaseContextField+ instance ToJSON ImportError' instance FromJSON ImportError' -instance ToJSON DatabaseContextFunctionError-instance FromJSON DatabaseContextFunctionError- instance ToJSON MergeStrategy instance FromJSON MergeStrategy @@ -306,3 +308,24 @@  instance ToJSON QueryOperator instance FromJSON QueryOperator++instance ToJSON SomePermission+instance FromJSON SomePermission++instance ToJSON AlterTransGraphPermission+instance FromJSON AlterTransGraphPermission++instance ToJSON RelVarPermission+instance FromJSON RelVarPermission++instance ToJSON AlterSchemaPermission+instance FromJSON AlterSchemaPermission++instance ToJSON FunctionPermission+instance FromJSON FunctionPermission++instance ToJSON DBCFunctionPermission+instance FromJSON DBCFunctionPermission++instance ToJSON ACLPermission+instance FromJSON ACLPermission

@@ -16,7 +16,7 @@ import Data.Aeson import ProjectM36.Base import TutorialD.Interpreter-import ProjectM36.Interpreter (ConsoleResult(..), SafeEvaluationFlag(..))+import ProjectM36.Interpreter as I (ConsoleResult(..), SafeEvaluationFlag(..))  import ProjectM36.Client import Control.Exception import Text.Megaparsec.Error@@ -25,6 +25,7 @@ import qualified Data.UUID as UUID import GHC.Generics import qualified Data.Text.Encoding as TE+import qualified Network.RPC.Curryer.Client as CRPC  #if MIN_VERSION_megaparsec(7,0,0) import Data.List.NonEmpty as NE@@ -92,7 +93,7 @@  --this creates a new database for each connection- perhaps not what we want (?) createConnection :: WS.Connection -> DatabaseName -> Port -> Hostname -> IO (Either ConnectionError Connection)-createConnection wsconn dbname port host = connectProjectM36 (RemoteConnectionInfo dbname (RemoteServerHostAddress host port) (notificationCallback wsconn))+createConnection wsconn dbname port host = connectProjectM36 (RemoteConnectionInfo dbname (RemoteServerHostAddress host port) CRPC.UnencryptedConnectionConfig (notificationCallback wsconn) "admin")  -- should use TLS auth  handleResponse :: WS.Connection -> Connection -> Response -> IO () handleResponse conn dbconn resp =@@ -131,7 +132,7 @@     DisplayParseErrorResult _ err ->        let err' = ParseError $ T.pack (parseErrorPretty . NE.head . bundleErrors $ err) in         RelationalErrorResponse reqId err'-    QuietSuccessResult ->+    I.QuietSuccessResult ->       SuccessResponse reqId     DisplayRelationResult rel ->       RelationResponse reqId rel presentation@@ -150,9 +151,13 @@ -- get current schema and head name for client promptInfo :: SessionId -> Connection -> IO (HeadName, SchemaName) promptInfo sessionId conn = do-  eHeadName <- headName sessionId conn+  eCurrentHead <- currentHead sessionId conn   eSchemaName <- currentSchemaName sessionId conn-  pure (fromRight "<unknown>" eHeadName, fromRight "<no schema>" eSchemaName)+  let headName = case eCurrentHead of+                   Left _err -> "<unknown>"+                   Right (CurrentHeadTransactionId tid) -> T.pack (show tid)+                   Right (CurrentHeadBranch hname) -> hname+  pure (headName, fromRight "<no schema>" eSchemaName)  sendPromptInfo :: (HeadName, SchemaName) -> WS.Connection -> IO () sendPromptInfo (hName, sName) conn = WS.sendTextData conn (encode (object ["promptInfo" .= object ["headname" .= hName, "schemaname" .= sName]]))

@@ -3,7 +3,9 @@ import ProjectM36.Interpreter import ProjectM36.SQL.Select import ProjectM36.DatabaseContext+import ProjectM36.DatabaseContextExpr import ProjectM36.DateExamples+import ProjectM36.TransactionGraph (emptyTransactionGraph) import ProjectM36.Error import TutorialD.Printer import SQL.Interpreter.ImportBasicExample@@ -72,8 +74,11 @@             Left err -> pure $ DisplayRelationalErrorResult err             Right df -> pure $ DisplayHintWith ("[Equivalent TutorialD] " <> hint) (DisplayDataFrameResult df)     ImportBasicExampleOp (ImportBasicExampleOperator exampleName) -> do-      if exampleName == "cjdate" then-        evalOneCommand (DatabaseContextExprOp (databaseContextAsDatabaseContextExpr dateExamples))+      if exampleName == "cjdate" then do+        case databaseContextAsDatabaseContextExpr (toDatabaseContext dateExamples) emptyTransactionGraph of+          Left err -> pure $ DisplayRelationalErrorResult err+          Right dbexpr ->+            evalOneCommand (DatabaseContextExprOp dbexpr)         else           pure (DisplayErrorResult ("No such example: " <> exampleName))     DatabaseContextExprOp dbcExpr -> do

@@ -1,10 +1,8 @@ -- the sqlegacy SQL interpreter wrap {-# LANGUAGE CPP #-}-import ProjectM36.Base import ProjectM36.Cli import SQL.Interpreter import ProjectM36.SQLDatabaseContext-import ProjectM36.Error import System.Directory import System.FilePath import qualified ProjectM36.Client as C@@ -42,8 +40,13 @@         (\_ -> displayResult (DisplayErrorResult "Request timed out."))        -promptText :: Either RelationalError HeadName -> Either RelationalError SchemaName -> StringType-promptText eHeadName eSchemaName = "SQLegacy (" <> transInfo <> "): "+promptText :: MakePrompt+promptText eCurrentHead eSchemaName = "SQLegacy (" <> transInfo <> "): "   where-    transInfo = fromRight "<unknown>" eHeadName <> "/" <> fromRight "<no schema>" eSchemaName+    headStr = case eCurrentHead of+      Left _ -> "<unknown>"+      Right (C.CurrentHeadTransactionId tid) -> T.pack (show tid)+      Right (C.CurrentHeadBranch branch) -> branch+    transInfo = headStr <> "/" <> fromRight "<no schema>" eSchemaName+   

@@ -9,6 +9,9 @@ import TutorialD.Interpreter.DatabaseContextIOOperator import TutorialD.Interpreter.TransGraphRelationalOperator import TutorialD.Interpreter.SchemaOperator+import TutorialD.Interpreter.RelationalExpr+import TutorialD.Interpreter.LoginRolesOperator+import TutorialD.Interpreter.Types  import TutorialD.Interpreter.Import.CSV import TutorialD.Interpreter.Import.TutorialD@@ -20,7 +23,9 @@  import ProjectM36.Base import ProjectM36.Error+import ProjectM36.Cli (MakePrompt) import ProjectM36.TransactionGraph+import ProjectM36.LoginRoles (AlterLoginRolesExpr) import qualified ProjectM36.Client as C import ProjectM36.Relation (attributes) @@ -41,9 +46,10 @@ -} data ParsedOperation = RODatabaseContextOp RODatabaseContextOperator |                        DatabaseContextExprOp DatabaseContextExpr |-                       DatabaseContextIOExprOp DatabaseContextIOExpr |+                       DatabaseContextIOExprOp DatabaseContextIOOperator |                        InfoOp InformationOperator |-                       GraphOp TransactionGraphOperator |+                       GraphOp TransactionGraphExpr |+                       AlterGraphOp AlterTransactionGraphExpr |                        ConvenienceGraphOp ConvenienceTransactionGraphOperator |                        ROGraphOp ROTransactionGraphOperator |                        ImportRelVarOp RelVarDataImportOperator |@@ -51,7 +57,8 @@                        ImportBasicExampleOp ImportBasicExampleOperator |                        RelVarExportOp RelVarDataExportOperator |                        TransGraphRelationalOp TransGraphRelationalOperator |-                       SchemaOp SchemaOperator+                       SchemaOp SchemaOperator |+                       LoginRolesOp AlterLoginRolesExpr                        deriving (Show)  interpreterParserP :: Parser ParsedOperation@@ -59,24 +66,30 @@                      fmap ImportRelVarOp (importCSVP <* eof) <|>                      fmap ImportDBContextOp (tutdImportP <* eof) <|>                      fmap RelVarExportOp (exportCSVP <* eof) <|>-                     fmap DatabaseContextIOExprOp (dbContextIOExprP <* eof)+                     fmap DatabaseContextIOExprOp (databaseContextIOOperatorP <* eof)  -- the safe interpreter never reads or writes the file system safeInterpreterParserP :: Parser ParsedOperation safeInterpreterParserP = fmap RODatabaseContextOp (roDatabaseContextOperatorP <* eof) <|>                          fmap InfoOp (infoOpP <* eof) <|>                          fmap GraphOp (transactionGraphOpP <* eof) <|>+                         fmap AlterGraphOp (alterTransactionGraphOpP <* eof) <|>                          fmap ConvenienceGraphOp (convenienceTransactionGraphOpP <* eof) <|>                          fmap ROGraphOp (roTransactionGraphOpP <* eof) <|>                          fmap DatabaseContextExprOp (databaseExprOpP <* eof) <|>                          fmap ImportBasicExampleOp (importBasicExampleOperatorP <* eof) <|>                          fmap TransGraphRelationalOp (transGraphRelationalOpP <* eof) <|>-                         fmap SchemaOp (schemaOperatorP <* eof)+                         fmap SchemaOp (schemaOperatorP <* eof) <|> +                         fmap LoginRolesOp (alterLoginRolesExprP <* eof) -promptText :: Either RelationalError HeadName -> Either RelationalError SchemaName -> StringType-promptText eHeadName eSchemaName = "TutorialD (" <> transInfo <> "): "+promptText :: MakePrompt+promptText eCurrentHead eSchemaName = "TutorialD (" <> transInfo <> "): "   where-    transInfo = fromRight "<unknown>" eHeadName <> "/" <> fromRight "<no schema>" eSchemaName+    headStr = case eCurrentHead of+      Left _ -> "<unknown>"+      Right (C.CurrentHeadTransactionId tid) -> T.pack (show tid)+      Right (C.CurrentHeadBranch branch) -> branch+    transInfo = headStr <> "/" <> fromRight "<no schema>" eSchemaName  parseTutorialD :: T.Text -> Either ParserError ParsedOperation parseTutorialD = parse interpreterParserP ""@@ -85,6 +98,9 @@ safeParseTutorialD :: T.Text -> Either ParserError ParsedOperation safeParseTutorialD = parse safeInterpreterParserP "" +-- | Utility method for external apps such as benchmarks to parse a relational expression for execution.+parseRelationalExpr :: RelationalMarkerExpr a => T.Text -> Either ParserError (RelationalExprBase a)+parseRelationalExpr = parse relExprP ""  evalTutorialD :: C.SessionId -> C.Connection -> SafeEvaluationFlag -> ParsedOperation -> IO ConsoleResult evalTutorialD sessionId conn safe = evalTutorialDInteractive sessionId conn safe False@@ -109,13 +125,18 @@   (DatabaseContextIOExprOp execOp) ->     if needsSafe then       unsafeError-      else-      eHandler $ C.executeDatabaseContextIOExpr sessionId conn execOp-+      else do+      eIOExpr <- interpretDatabaseContextIOOperator execOp+      case eIOExpr of+        Left err -> pure (DisplayRelationalErrorResult err)+        Right ioexpr ->+          eHandler $ C.executeDatabaseContextIOExpr sessionId conn ioexpr   (GraphOp execOp) -> do+    eHandler $ C.executeTransactionGraphExpr sessionId conn execOp+  (AlterGraphOp execOp) -> do     -- warn if the graph op could cause uncommited changes to be discarded     eIsDirty <- C.disconnectedTransactionIsDirty sessionId conn-    let runGraphOp = eHandler $ C.executeGraphExpr sessionId conn execOp+    let runGraphOp = eHandler $ C.executeAlterTransactionGraphExpr sessionId conn execOp         settings = Settings {complete = noCompletion,                              historyFile = Nothing,                              autoAddHistory = False}@@ -206,6 +227,8 @@     evalTutorialD sessionId conn safe (DatabaseContextExprOp dbcontextexpr)   (TransGraphRelationalOp execOp) ->     evalTransGraphRelationalOp sessionId conn execOp+  (LoginRolesOp alterLoginRoleExpr) -> do+    evalAlterLoginRolesExpr sessionId conn alterLoginRoleExpr   where     needsSafe = safe == SafeEvaluation     unsafeError = pure $ DisplayErrorResult "File I/O operation prohibited."@@ -218,9 +241,6 @@       case eErr of         Left err -> barf err         Right () -> return QuietSuccessResult---  runTutorialD :: C.SessionId -> C.Connection -> Maybe PromptLength -> T.Text -> IO () runTutorialD sessionId conn mPromptLength tutd =

@@ -72,6 +72,13 @@ identifierP :: Parser Text identifierP = identifier <* spaceConsumer +-- | Roles may include human names, so be generous in what we accept+roleNameP :: Parser Text+roleNameP = normalQuotedString <|> takeWhile1P (Just "non-whitespace character") (not . isSpace) <* spaceConsumer++permissionP :: Parser Text+permissionP = normalQuotedString <|> takeWhile1P (Just "non-whitespace character") (not . isSpace) <* spaceConsumer+   identifierRemainder :: Char -> Parser Text identifierRemainder c = do   rest <- many (alphaNumChar <|> char '_' <|> char '#')@@ -164,6 +171,9 @@  quotedString :: Parser Text quotedString = try tripleQuotedString <|> normalQuotedString++quotedFilePath :: Parser FilePath+quotedFilePath = T.unpack <$> quotedString  quoted :: Parser a -> Parser a quoted = between quote quote

@@ -2,7 +2,11 @@ module TutorialD.Interpreter.DatabaseContextExpr where import ProjectM36.Base import ProjectM36.Interpreter+import ProjectM36.DatabaseContext.Types import ProjectM36.DatabaseContext+import ProjectM36.AccessControlList+import ProjectM36.TransactionGraph.Types+import ProjectM36.DatabaseContextExpr import TutorialD.Interpreter.Base import qualified Data.Text as T import TutorialD.Interpreter.RelationalExpr@@ -18,6 +22,7 @@ import Data.Monoid #endif import Data.Functor+import qualified Data.UUID as UUID  --parsers which create "database expressions" which modify the database context (such as relvar assignment) databaseContextExprP :: Parser DatabaseContextExpr@@ -40,6 +45,7 @@                                removeDatabaseContextFunctionP,                                addRegisteredQueryP,                                removeRegisteredQueryP,+                               AlterACL <$> alterACLP,                                nothingP]              nothingP :: Parser DatabaseContextExpr            @@ -193,6 +199,43 @@   reserved "unregisterquery"   RemoveRegisteredQuery <$> quotedString +-- grant perm rolename maygrant+alterACLP :: Parser AlterDBCACLExpr+alterACLP = do+  let grantP = do+        reserved "grant"+        GrantAccessExpr <$> roleNameP <*> somePermissionP  <*> mayGrantP+      mayGrantP = (reserved "maygrant" $> True) <|> (reserved "nogrant" $> False)+      revokeP = do+        reserved "revoke"+        RevokeAccessExpr <$> roleNameP <*> somePermissionP+      grantDBCFuncP = do+        GrantDBCFunctionAccessExpr <$> roleNameP <*> functionNameP <*> dbcFunctionPermP <*> mayGrantP+      revokeDBCFuncP = do+        RevokeDBCFunctionAccessExpr <$> roleNameP <*> functionNameP <*> dbcFunctionPermP+  (try (reserved "grant" >> reserved "dbcfunction") >> grantDBCFuncP) <|>+    (try (reserved "revoke" >> reserved "dbcfunction") >> revokeDBCFuncP) <|>        +    grantP <|> revokeP++dbcFunctionPermP :: Parser DBCFunctionPermission+dbcFunctionPermP = (reserved "viewfunction" $> ViewDBCFunctionPermission) <|>+                   (reserved "executefunction" $> ExecuteDBCFunctionPermission) <|>+                   (reserved "alterfunction" $> AlterDBCFunctionPermission)++somePermissionP :: Parser SomePermission+somePermissionP =+  (reserved "accessrelvars" $> SomeRelVarPermission AccessRelVarsPermission) <|>++  (reserved "executefunctions" $> SomeFunctionPermission ExecuteFunctionPermission) <|>+  (reserved "viewfunctions" $> SomeFunctionPermission ViewFunctionPermission) <|>+  (reserved "alterfunctions" $> SomeFunctionPermission AlterFunctionPermission) <|>++  (reserved "alterschema" $> SomeAlterSchemaPermission AlterSchemaPermission) <|>++  (reserved "alteracl" $> SomeACLPermission AlterACLPermission) <|>+  (reserved "viewacl" $> SomeACLPermission ViewACLPermission) <|>+  (reserved "committransaction" $> SomeAlterTransGraphPermission CommitTransactionPermission)+ executeDatabaseContextFunctionP :: Parser DatabaseContextExpr executeDatabaseContextFunctionP = do   reserved "execute"@@ -212,13 +255,23 @@         (Left err, _) -> Left err -} +-- | Used exclusively by tests, bypasses role-based access control. interpretDatabaseContextExpr :: DatabaseContext -> TransactionId -> TransactionGraph -> T.Text -> Either RelationalError DatabaseContext interpretDatabaseContextExpr context transId graph tutdstring =   case parse databaseExprOpP "" tutdstring of     Left err -> Left $ PM36E.ParseError (T.pack (show err))     Right parsed -> do-      let env = RE.mkDatabaseContextEvalEnv transId graph-      RE.dbc_context <$> RE.runDatabaseContextEvalMonad context env (optimizeAndEvalDatabaseContextExpr True parsed)+      let roleNameResolver _roleName = pure UUID.nil+      case resolveRoleIds roleNameResolver parsed of+        Left err -> Left err+        Right parsed' -> do+          let env = RE.mkDatabaseContextEvalEnv transId graph dbcFuncUtils+              dbcFuncUtils = DatabaseContextFunctionUtils {+                executeDatabaseContextExpr = error "unexpected executeDatabaseContextExpr in test func",+                executeRelationalExpr = error "unexpected executeRelationalExpr in test func"+                }+      +          RE.dbc_context <$> RE.runDatabaseContextEvalMonad context env (optimizeAndEvalDatabaseContextExpr True parsed')  {- --no optimization

@@ -2,10 +2,19 @@ module TutorialD.Interpreter.DatabaseContextIOOperator where import ProjectM36.Base import ProjectM36.Interpreter+import ProjectM36.Error import TutorialD.Interpreter.Base import TutorialD.Interpreter.Types-import Data.Text+import Data.Text as T+import qualified Data.Text.IO as TIO+import Control.Exception (IOException, handle, displayException) +data DatabaseContextIOOperator =+  DatabaseContextIOOp DatabaseContextIOExpr |+  LoadAtomFunctionFromFileOp FunctionName [TypeConstructor] FilePath |+  LoadDatabaseContextFunctionFromFileOp FunctionName [TypeConstructor] FilePath+  deriving (Show, Eq)+ addAtomFunctionExprP :: Parser DatabaseContextIOExpr addAtomFunctionExprP = dbioexprP "addatomfunction" AddAtomFunction   @@ -32,13 +41,19 @@ atomTypeSignatureP :: Parser [TypeConstructor] atomTypeSignatureP = sepBy typeConstructorP arrow -dbContextIOExprP :: Parser DatabaseContextIOExpr-dbContextIOExprP = addAtomFunctionExprP <|> +databaseContextIOExprP :: Parser DatabaseContextIOExpr+databaseContextIOExprP = addAtomFunctionExprP <|>                     addDatabaseContextFunctionExprP <|>                     loadAtomFunctionsP <|>                    loadDatabaseContextFunctionsP <|>                    createArbitraryRelationP +databaseContextIOOperatorP :: Parser DatabaseContextIOOperator+databaseContextIOOperatorP = +  (DatabaseContextIOOp <$> databaseContextIOExprP) <|>+  (reserved "loadatomfunctionfromfile" >> (LoadAtomFunctionFromFileOp <$> quotedString <*> atomTypeSignatureP <*> quotedFilePath)) <|>+  (reserved "loaddatabasecontextfunctionfromfile" >> (LoadDatabaseContextFunctionFromFileOp <$> quotedString <*> atomTypeSignatureP <*> quotedFilePath))+   loadAtomFunctionsP :: Parser DatabaseContextIOExpr loadAtomFunctionsP = do   reserved "loadatomfunctions"@@ -49,3 +64,23 @@   reserved "loaddatabasecontextfunctions"   LoadDatabaseContextFunctions <$> quotedString <*> quotedString <*> fmap unpack quotedString                                              +interpretDatabaseContextIOOperator :: DatabaseContextIOOperator -> IO (Either RelationalError DatabaseContextIOExpr)+interpretDatabaseContextIOOperator expr = do+  let loadFromFile typ functionName functionArgs functionFilePath = do+        let handler :: IOException -> IO (Either RelationalError Text)+            handler e = pure (Left (ImportError (ImportFileError (T.pack (displayException e)))))+        eFuncBody <- handle handler (Right <$> TIO.readFile functionFilePath)+        case eFuncBody of+          Left err -> pure (Left err)+          Right functionBody ->+            pure (Right (typ functionName functionArgs functionBody))+        +  case expr of+    DatabaseContextIOOp expr' ->+      pure (Right expr')+    LoadAtomFunctionFromFileOp functionName functionArgs functionFilePath ->+      loadFromFile AddAtomFunction functionName functionArgs functionFilePath+    LoadDatabaseContextFunctionFromFileOp functionName functionArgs functionFilePath ->+      loadFromFile AddDatabaseContextFunction functionName functionArgs functionFilePath++

@@ -4,7 +4,7 @@ import ProjectM36.DateExamples import ProjectM36.Base import ProjectM36.Interpreter-import ProjectM36.DatabaseContext+import ProjectM36.DatabaseContextExpr import TutorialD.Interpreter.Base  #if !MIN_VERSION_megaparsec(6,0,0)@@ -15,7 +15,7 @@                                 deriving (Show)  evalImportBasicExampleOperator :: ImportBasicExampleOperator -> DatabaseContextExpr-evalImportBasicExampleOperator ImportBasicDateExampleOperator = databaseContextAsDatabaseContextExpr dateExamples+evalImportBasicExampleOperator ImportBasicDateExampleOperator = resolvedDatabaseContextAsDatabaseContextExpr dateExamples  importBasicExampleOperatorP :: Parser ImportBasicExampleOperator importBasicExampleOperatorP = do 

@@ -31,7 +31,7 @@             Right tutdBytes' -> importTutorialDBytes tutdBytes'     _ -> pure (Left (ImportError (InvalidFileURIError (URI.render fileURI))))   where-    filePath = drop (length ("file://" :: String)) (URI.renderStr fileURI)+    filePath = drop (length ("file:" :: String)) (URI.renderStr fileURI)           importTutorialDBytes :: BS.ByteString -> IO (Either RelationalError DatabaseContextExpr)

@@ -0,0 +1,64 @@+module TutorialD.Interpreter.LoginRolesOperator where+import ProjectM36.Client as C+import qualified ProjectM36.LoginRoles as LoginRoles+import ProjectM36.Interpreter as I+import qualified Data.Text as T+import Data.Functor++import TutorialD.Interpreter.Base++alterLoginRolesExprP :: Parser AlterLoginRolesExpr+alterLoginRolesExprP =+  showAllRolesExprP <|>+  alterRoleNameExprP <|>+  alterRoleMayLoginExprP <|>+  showRolesForRoleExprP <|>+  addLoginRoleToRoleExprP <|>  +  addLoginRoleExprP <|>+  removeLoginRoleExprP <|>+  removeLoginRoleFromRoleExprP <|>+  addPermissionToRoleExprP <|>+  removePermissionFromRoleExprP+  where+    mayGrantP = do+      (reserved "maygrant" $> True) <|> (reserved "nogrant" $> False)+    mayLoginP = do+      (reserved "maylogin" $> True) <|> (reserved "maynotlogin" $> False)+    showRolesForRoleExprP = do+      colonOp ":showloginrole" +      ShowRolesForRoleExpr <$> roleNameP+    addLoginRoleExprP = do+      colonOp ":addloginrole"+      AddLoginRoleExpr <$> roleNameP <*> mayLoginP+    removeLoginRoleExprP = do+      colonOp ":removeloginrole"+      RemoveLoginRoleExpr <$> roleNameP+    showAllRolesExprP = do+      colonOp ":showloginroles"+      pure ShowAllRolesExpr+    addLoginRoleToRoleExprP = do+      colonOp ":addloginroletorole"+      AddRoleToRoleExpr <$> roleNameP <*> roleNameP <*> mayGrantP+    removeLoginRoleFromRoleExprP = do+      colonOp ":removeloginrolefromrole"+      RemoveRoleFromRoleExpr <$> roleNameP <*> roleNameP+    addPermissionToRoleExprP = do+      colonOp ":addpermissiontologinrole"+      AddPermissionToRoleExpr <$> permissionP <*> roleNameP <*> mayGrantP+    removePermissionFromRoleExprP = do+      colonOp ":removepermissionfromloginrole"+      RemovePermissionFromRoleExpr <$> roleNameP <*> permissionP+    alterRoleNameExprP = do+      colonOp ":alterrolename"+      AlterLoginRoleExpr <$> roleNameP <*> (Just <$> roleNameP) <*> pure Nothing+    alterRoleMayLoginExprP = do+      colonOp ":alterrolemaylogin"+      AlterLoginRoleExpr <$> roleNameP <*> pure Nothing <*> (Just <$> mayLoginP)++evalAlterLoginRolesExpr :: SessionId -> Connection -> AlterLoginRolesExpr -> IO ConsoleResult+evalAlterLoginRolesExpr sessionId conn expr = do+  result <- C.executeAlterLoginRolesExpr sessionId conn expr+  case result of+    Left err -> pure (DisplayErrorResult (T.pack (show err)))+    Right LoginRoles.QuietSuccessResult -> pure I.QuietSuccessResult+    Right (LoginRoles.InfoResult info) -> pure (DisplayResult info)

@@ -21,22 +21,24 @@ import Data.Functor  --operators which only rely on database context reading-data RODatabaseContextOperator where-  ShowRelation :: RelationalExpr -> RODatabaseContextOperator-  PlotRelation :: RelationalExpr -> RODatabaseContextOperator-  ShowRelationType :: RelationalExpr -> RODatabaseContextOperator-  ShowConstraints :: StringType -> RODatabaseContextOperator-  ShowPlan :: DatabaseContextExpr -> RODatabaseContextOperator-  ShowTypes :: RODatabaseContextOperator-  ShowRelationVariables :: RODatabaseContextOperator-  ShowAtomFunctions :: RODatabaseContextOperator-  ShowDatabaseContextFunctions :: RODatabaseContextOperator-  ShowNotifications :: RODatabaseContextOperator-  ShowDataFrame :: DF.DataFrameExpr -> RODatabaseContextOperator-  GetDDLHash :: RODatabaseContextOperator-  ShowDDL :: RODatabaseContextOperator-  ShowRegisteredQueries :: RODatabaseContextOperator-  Quit :: RODatabaseContextOperator++data RODatabaseContextOperator =+  ShowRelation RelationalExpr |+  PlotRelation RelationalExpr |+  ShowRelationType RelationalExpr |+  ShowConstraints StringType |+  ShowDatabaseContextExprPlan DatabaseContextExpr |+  ShowRelationalExprPlan RelationalExpr |+  ShowTypes |+  ShowRelationVariables |+  ShowAtomFunctions |+  ShowDatabaseContextFunctions |+  ShowNotifications |+  ShowDataFrame DF.DataFrameExpr |+  GetDDLHash |+  ShowDDL |+  ShowRegisteredQueries |+  Quit   deriving (Show)  typeP :: Parser RODatabaseContextOperator@@ -49,11 +51,16 @@   colonOp ":showexpr"   ShowRelation <$> relExprP -showPlanP :: Parser RODatabaseContextOperator-showPlanP = do-  colonOp ":showplan"-  ShowPlan <$> databaseContextExprP+showDatabaseContextExprPlanP :: Parser RODatabaseContextOperator+showDatabaseContextExprPlanP = do+  colonOp ":showdbcexprplan"+  ShowDatabaseContextExprPlan <$> databaseContextExprP +showRelationalExprPlanP :: Parser RODatabaseContextOperator+showRelationalExprPlanP = do+  colonOp ":showrelexprplan"+  ShowRelationalExprPlan <$> relExprP+ showTypesP :: Parser RODatabaseContextOperator showTypesP = colonOp ":showtypes" >> pure ShowTypes @@ -90,7 +97,8 @@              <|> showRelationVariables              <|> plotRelExprP              <|> showConstraintsP-             <|> showPlanP+             <|> showDatabaseContextExprPlanP+             <|> showRelationalExprPlanP              <|> showTypesP              <|> showAtomFunctionsP              <|> showDatabaseContextFunctionsP@@ -137,11 +145,17 @@      Left err -> DisplayErrorResult (T.pack (show err))      Right rel -> DisplayRelationResult rel -evalRODatabaseContextOp sessionId conn (ShowPlan dbExpr) = do+evalRODatabaseContextOp sessionId conn (ShowDatabaseContextExprPlan dbExpr) = do   plan <- C.planForDatabaseContextExpr sessionId conn dbExpr   pure $ case plan of      Left err -> DisplayErrorResult (T.pack (show err))     Right optDbExpr -> DisplayResult $ T.pack (show optDbExpr)++evalRODatabaseContextOp sessionId conn (ShowRelationalExprPlan relExpr) = do+  plan <- C.planForRelationalExpr sessionId conn relExpr+  pure $ case plan of+    Left err -> DisplayErrorResult (T.pack (show err))+    Right optRelExpr -> DisplayResult optRelExpr  evalRODatabaseContextOp sessionId conn ShowTypes = do     eRel <- C.atomTypesAsRelation sessionId conn

@@ -3,6 +3,7 @@ import ProjectM36.Interpreter import ProjectM36.Base import ProjectM36.IsomorphicSchema+import ProjectM36.IsomorphicSchema.Types import ProjectM36.Session import ProjectM36.Client import TutorialD.Interpreter.RelationalExpr

@@ -19,37 +19,37 @@   reserved ":automergetohead"   AutoMergeToHead <$> mergeTransactionStrategyP <*> identifierP -jumpToHeadP :: Parser TransactionGraphOperator+jumpToHeadP :: Parser TransactionGraphExpr jumpToHeadP = do   reservedOp ":jumphead"   JumpToHead <$> identifierP -jumpToTransactionP :: Parser TransactionGraphOperator+jumpToTransactionP :: Parser TransactionGraphExpr jumpToTransactionP = do   reservedOp ":jump"   JumpToTransaction <$> uuidP   -walkBackToTimeP :: Parser TransactionGraphOperator  +walkBackToTimeP :: Parser TransactionGraphExpr  walkBackToTimeP = do   reservedOp ":walkbacktotime"   WalkBackToTime <$> utcTimeP -branchTransactionP :: Parser TransactionGraphOperator+branchTransactionP :: Parser AlterTransactionGraphExpr branchTransactionP = do   reservedOp ":branch"   Branch <$> identifierP -deleteBranchP :: Parser TransactionGraphOperator+deleteBranchP :: Parser AlterTransactionGraphExpr deleteBranchP = do   reserved ":deletebranch"   DeleteBranch <$> identifierP -commitTransactionP :: Parser TransactionGraphOperator+commitTransactionP :: Parser AlterTransactionGraphExpr commitTransactionP = do   reservedOp ":commit"   pure Commit  -rollbackTransactionP :: Parser TransactionGraphOperator+rollbackTransactionP :: Parser AlterTransactionGraphExpr rollbackTransactionP = do   reservedOp ":rollback"   return Rollback@@ -68,7 +68,7 @@                                 reserved "unionpreferbranch"                                 UnionPreferMergeStrategy <$> identifierP)   -mergeTransactionsP :: Parser TransactionGraphOperator+mergeTransactionsP :: Parser AlterTransactionGraphExpr mergeTransactionsP = do   reservedOp ":mergetrans"   MergeTransactions <$> mergeTransactionStrategyP <*> identifierP <*> identifierP@@ -76,12 +76,15 @@ validateMerkleHashesP :: Parser ROTransactionGraphOperator validateMerkleHashesP = reservedOp ":validatemerklehashes" $> ValidateMerkleHashes -transactionGraphOpP :: Parser TransactionGraphOperator+transactionGraphOpP :: Parser TransactionGraphExpr transactionGraphOpP =    jumpToHeadP   <|> jumpToTransactionP   <|> walkBackToTimeP-  <|> branchTransactionP++alterTransactionGraphOpP :: Parser AlterTransactionGraphExpr+alterTransactionGraphOpP =+  branchTransactionP   <|> deleteBranchP   <|> commitTransactionP   <|> rollbackTransactionP

@@ -7,6 +7,7 @@ import ProjectM36.Base import ProjectM36.Attribute as A hiding (null) import ProjectM36.DataFrame+import ProjectM36.AccessControlList import Prettyprinter import Prettyprinter.Render.Text import qualified Data.Set as S hiding (fromList)@@ -242,8 +243,56 @@         "registerquery" <+> pretty rQName <+> pretty relExpr       RemoveRegisteredQuery rQName ->         "unregisterquery" <+> pretty rQName+      AlterACL expr' -> pretty expr'       MultipleExpr dbcExprs ->         group (encloseSep "" "" "; " (pretty <$> dbcExprs))++prettyMayGrant :: MayGrant -> Doc ann+prettyMayGrant True = "maygrant"+prettyMayGrant False = "nogrant"++instance Pretty SomePermission where+  pretty perm =+    case perm of+      SomeRelVarPermission perm' -> pretty perm'+      SomeFunctionPermission perm' -> pretty perm'+      SomeAlterSchemaPermission perm' -> pretty perm'+      SomeAlterTransGraphPermission perm' -> pretty perm'+      SomeACLPermission perm' -> pretty perm'+      SomeDBCFunctionPermission perm' -> pretty perm'++instance Pretty RelVarPermission where+  pretty AccessRelVarsPermission = "accessrelvars"++instance Pretty FunctionPermission where+  pretty ExecuteFunctionPermission = "executefunctions"+  pretty ViewFunctionPermission = "viewfunctions"+  pretty AlterFunctionPermission = "alterfunctions"++instance Pretty AlterTransGraphPermission where+  pretty CommitTransactionPermission = "committransaction"++instance Pretty AlterSchemaPermission where+  pretty AlterSchemaPermission = "alterschema"++instance Pretty ACLPermission where+  pretty ViewACLPermission = "viewacls"+  pretty AlterACLPermission = "alteracls"++instance Pretty DBCFunctionPermission where+  pretty ViewDBCFunctionPermission = "viewfunction"+  pretty ExecuteDBCFunctionPermission = "executefunction"+  pretty AlterDBCFunctionPermission = "alterfunction"++instance Pretty AlterDBCACLExpr where+  pretty (GrantAccessExpr roleName somePerm mayGrant) =+    "grant" <+> pretty roleName <+> pretty somePerm <+> prettyMayGrant mayGrant+  pretty (RevokeAccessExpr roleName somePerm) =+    "revoke" <+> pretty roleName <+> pretty somePerm+  pretty (GrantDBCFunctionAccessExpr roleName funcName' perm mayGrant) =+    "grant dbcfunction" <+> pretty roleName <+> pretty funcName' <+> pretty perm <+> prettyMayGrant mayGrant+  pretty (RevokeDBCFunctionAccessExpr roleName funcName' perm) =+    "revoke dbcfunction" <+> pretty roleName <+> pretty funcName' <+> pretty perm  instance Pretty AttributeNameAtomExprMap where   pretty m =

@@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-} import TutorialD.Interpreter import ProjectM36.Cli-import ProjectM36.DatabaseContext+import ProjectM36.DatabaseContext.Basic import System.Directory import System.FilePath 

@@ -0,0 +1,42 @@+{-# LANGUAGE ScopedTypeVariables #-}+import ProjectM36.BTree+import Criterion.Main+import qualified Data.Vector.Unboxed as V+import Control.DeepSeq+import Data.ByteUnits++-- | creates a completely BTree from a uniform distribution of positive integers.++createBTree :: Branches -> Int -> BTree+createBTree branches' itemCount = build branches' (V.fromList [0..itemCount - 1])+  +main :: IO ()+main = do+  let sizes = map (10 ^) [1..7 :: Int]+      prettyBytes x = getShortHand (getAppropriateUnits (ByteValue (fromIntegral x) Bytes))+      btrees16 = force $ map (createBTree 16) sizes+      btrees64 = force $ map (createBTree 64) sizes+      btrees100 = force $ map (createBTree 100) sizes  +      btrees128 = force $ map (createBTree 128) sizes+--  gen <- getStdGen+--  let rands = randomRs gen (0,100)+  +  defaultMain [{-bgroup "create branch-level 4 x " $+               map (\count ->+                       bench (show count) (nf (createBTree 4) count)) sizes,-}+    bgroup "member branch-level 16 x " $+      map (\btree -> bench (show (size btree) <> " " <> prettyBytes (totalBytes btree)) (nf (member 91) btree)) btrees16,++    bgroup "member branch-level 64 x " $+      map (\btree -> bench (show (size btree) <> " " <> prettyBytes (totalBytes btree)) (nf (member 91) btree)) btrees64,++    bgroup "member branch-level 100 x " $+      map (\btree -> bench (show (size btree) <> " " <> prettyBytes (totalBytes btree)) (nf (member 91) btree)) btrees100,+      ++    bgroup "member branch-level 128 x " $+      map (\btree -> bench (show (size btree) <> " " <> prettyBytes (totalBytes btree)) (nf (member 91) btree)) btrees128+      +      +    ]+              

@@ -1,4 +1,5 @@ import ProjectM36.Base+import ProjectM36.DatabaseContext import Criterion.Main import qualified ProjectM36.Attribute as A import ProjectM36.Relation@@ -8,7 +9,7 @@ import ProjectM36.TransactionGraph import qualified Data.Text as T import qualified Data.Vector as V-import qualified ProjectM36.DatabaseContext as DBC+import qualified ProjectM36.DatabaseContext.Basic as DBC import qualified Data.Set as S import System.IO.Temp import System.FilePath@@ -48,7 +49,7 @@   predicateMatch = AtomExprPredicate (FunctionAtomExpr "lte" [AttributeAtomExpr "a0", NakedAtomExpr (IntAtom cutoff)] ())  basicREEnv :: RelationalExprEnv-basicREEnv = mkRelationalExprEnv DBC.basicDatabaseContext emptyTransactionGraph+basicREEnv = mkRelationalExprEnv (toDatabaseContext DBC.basicDatabaseContext) emptyTransactionGraph  projectRelationToAttributes :: AttributeNames -> Relation -> Relation projectRelationToAttributes attrNames rel = validate (runRelationalExprM basicREEnv (evalRelationalExpr projection))

@@ -7,10 +7,8 @@ import ProjectM36.Interpreter hiding (Parser) import TutorialD.Interpreter.Base hiding (option) import qualified Data.Text as T-#if __GLASGOW_HASKELL__ < 804-import Data.Monoid-#endif import Control.Monad+import System.Random  data HandlesArgs = HandlesArgs {   openCloseCount :: Int,@@ -49,7 +47,8 @@  runOpenClose :: T.Text -> T.Text -> Int -> FilePath -> IO () runOpenClose tutdSetup' tutdIterate' tCount dbdir' = do-  let connInfo = InProcessConnectionInfo (MinimalPersistence dbdir') emptyNotificationCallback [] basicDatabaseContext+  rando <- initStdGen+  let connInfo = InProcessConnectionInfo (MinimalPersistence dbdir') emptyNotificationCallback [] basicDatabaseContext rando "admin"   eConn <- connectProjectM36 connInfo    case eConn of     Left err -> error (show err)

@@ -1,6 +1,7 @@ {-# LANGUAGE DerivingVia, DeriveGeneric, DeriveAnyClass, TypeApplications #-} -- create a simple, on-disk database of ~20 MB so that we can get a heap profile import ProjectM36.Client+import TutorialD.Interpreter (parseRelationalExpr) import Data.Text (Text) import Codec.Winery import Options.Applicative@@ -10,6 +11,8 @@ import ProjectM36.Tupleable import Data.Time.Calendar import Data.Proxy+import Data.Maybe+import System.Random  data WeatherReading =   WeatherReading@@ -25,20 +28,23 @@  data Opts = Opts { datadir :: FilePath,                    writeData :: Bool, --read or write mode-                   tupleCount :: Int+                   tupleCount :: Int,+                   execTutorialD :: Maybe Text                  }  parseOptions :: Parser Opts parseOptions = Opts <$>   strOption (long "datadir" <> short 'd') <*>   switch (long "write-data" <> short 'w') <*>-  option auto (long "tuple-count" <> short 'c' <> value 10000)+  option auto (long "tuple-count" <> short 'c' <> value 10000) <*>+  optional (strOption (long "exec-tutd" <> short 'e'))  main :: IO () main = do   let parser = info (parseOptions <**> helper) (fullDesc <> progDesc "Read or write data for heap profiling.")   opts <- execParser parser-  let connInfo = InProcessConnectionInfo (MinimalPersistence (datadir opts)) emptyNotificationCallback [] basicDatabaseContext+  rando <- initStdGen+  let connInfo = InProcessConnectionInfo (MinimalPersistence (datadir opts)) emptyNotificationCallback [] basicDatabaseContext rando adminRoleName       eCheck v = do         x <- v         case x of @@ -64,11 +70,22 @@     eCheck $ executeDatabaseContextExpr sessionId conn insertExpr     eCheck $ commit sessionId conn     else do+    {-+    --switch to extend to try to exercise parallel mapM (filter is not parallelized in streamly yet)     putStrLn "reading"     --read one row to see how heap is affected (will load all rows)-    let readOneRow = Restrict (AttributeEqualityPredicate "temperature" (NakedAtomExpr (IntegerAtom 900))) (RelationVariable "x" ())+    let readOneRow = Restrict (AttributeEqualityPredicate "temperature" expensiveMatch) (RelationVariable "x" ())+        expensiveMatch = FunctionAtomExpr "test_bcrypt" [NakedAtomExpr (IntegerAtom 20), NakedAtomExpr (TextAtom "password"), NakedAtomExpr (IntegerAtom 900)] ()+        --simpleMatch = NakedAtomExpr (IntegerAtom 900)     val <- eCheck $ executeRelationalExpr sessionId conn readOneRow     print val-    +    -}+    let tutd = fromMaybe "x where temperature = 5" (execTutorialD opts)+    case parseRelationalExpr tutd of+      Left err -> error (show err)+      Right parsed -> do+        val <- eCheck $ executeRelationalExpr sessionId conn parsed+        print val+            

@@ -18,8 +18,8 @@ main :: IO () main = defaultMain [   bgroup "Big Relation" [ -     bench "100" $ whnf (matrixRelation 10) 100,-     bench "1000" $ whnf (matrixRelation 10) 1000,+--     bench "100" $ whnf (matrixRelation 10) 100,+--     bench "1000" $ whnf (matrixRelation 10) 1000,      bench "10000" $ whnf (matrixRelation 10) 10000      ]   ]

@@ -8,7 +8,7 @@ import Data.Proxy import GHC.Generics import Control.Monad-+import System.Random  handleIOError :: Show e => IO (Either e a) -> IO a handleIOError m = do@@ -23,7 +23,8 @@ --test local connection speeds of inserts, updates, and deletes to look for space leaks, etc. main :: IO () main = do-  conn <- handleIOError $ connectProjectM36 (InProcessConnectionInfo NoPersistence emptyNotificationCallback [] basicDatabaseContext)+  rando <- initStdGen+  conn <- handleIOError $ connectProjectM36 (InProcessConnectionInfo NoPersistence emptyNotificationCallback [] basicDatabaseContext rando adminRoleName)   sess <- handleIOError $ createSessionAtHead conn "master"   _ <- handleIOError $ executeDatabaseContextExpr sess conn (toDefineExpr (Proxy :: Proxy User) "user") 

@@ -13,6 +13,7 @@ import ProjectM36.Relation.Show.HTML import ProjectM36.RelationalExpression import ProjectM36.TransactionGraph+import ProjectM36.DatabaseContext --import qualified Data.HashSet as HS --import qualified Data.ByteString.Lazy.Char8 as BS --import qualified Data.IntMap as IM@@ -25,9 +26,7 @@ import Data.Text hiding (map) import Data.Time.Clock import Data.UUID.V4-#if __GLASGOW_HASKELL__ < 804-import Data.Monoid-#endif+import qualified ProjectM36.DatabaseContextFunctionUtils as Util   {-@@ -69,9 +68,9 @@                    now <- getCurrentTime                    tid <- nextRandom                    let setx = Assign "x" (ExistingRelation (force rel))-                       graph = bootstrapTransactionGraph now tid dateExamples-                       env = mkDatabaseContextEvalEnv tid graph-                       eNewState = runDatabaseContextEvalMonad dateExamples env (optimizeAndEvalDatabaseContextExpr True setx)+                       graph = bootstrapTransactionGraph now tid (toDatabaseContext dateExamples)+                       env = mkDatabaseContextEvalEnv tid graph Util.dud+                       eNewState = runDatabaseContextEvalMonad (toDatabaseContext dateExamples) env (optimizeAndEvalDatabaseContextExpr True setx)                        --plan = interpretRODatabaseContextOp context $ ":showplan " ++ tutd                    --displayOpResult plan                    case eNewState of

@@ -0,0 +1,141 @@+-- | Applies access control lists to the current role to determine whether should be granted+{-# LANGUAGE RankNTypes #-}+module ProjectM36.AccessControl where+import ProjectM36.Base+import ProjectM36.Error+import ProjectM36.AccessControlList+import ProjectM36.TransactionGraph+import ProjectM36.RelationalExpression+import ProjectM36.DatabaseContext.Types+import ProjectM36.RelationVariablesMentioned+import ProjectM36.IsomorphicSchema+import ProjectM36.Function+import Control.Monad.Except+import Control.Monad (when, forM_)++applyACLRelationalExpr :: Show a => [RoleId] -> RelVarAccessControlList -> RelationalExprBase a -> Either RelationalError ()+applyACLRelationalExpr roleIds acl' expr = do+  let checkPerm perm =+        if hasAccess roleIds perm acl' then+          pure ()+          else+          Left (AccessDeniedError (SomeRelVarPermission perm))+  when (mentionsRelVar expr) (checkPerm AccessRelVarsPermission)++applyACLAlterTransGraphExpr :: [RoleId] -> AlterTransGraphAccessControlList -> AlterTransactionGraphExpr -> Either RelationalError ()+applyACLAlterTransGraphExpr roleIds acl' _alterExpr =+  if hasAccess roleIds CommitTransactionPermission acl' then+    pure ()+    else+    Left (AccessDeniedError (SomeAlterTransGraphPermission CommitTransactionPermission))++-- we should probably have finer-grained permission here+applyACLDatabaseContextIOExpr :: [RoleId] -> DatabaseContextIOExpr -> DatabaseContextIOEvalMonad ()+applyACLDatabaseContextIOExpr roleIds _expr = do+   acl' <- resolveIODBC acl  +   if hasAccess roleIds AlterFunctionPermission (dbcFunctionsACL acl') then+     pure ()+     else+     throwError (AccessDeniedError (SomeFunctionPermission AlterFunctionPermission))++applyACLDatabaseContextExpr :: [RoleId] -> DatabaseContextExpr' -> DatabaseContextEvalMonad ()+applyACLDatabaseContextExpr roleIds expr = do+  dbcAcl <- resolveDBC acl+  dbcFuncs <- resolveDBC dbcFunctions+  let checkRVPerm perm acl' =+        if hasAccess roleIds perm acl' then+          pure ()+        else+          dbErr (AccessDeniedError (SomeRelVarPermission perm))+{-      checkFuncPerm perm acl' =+        if hasAccess roleIds perm acl' then+          pure ()+        else+          dbErr (AccessDeniedError (SomeFunctionPermission perm))-}+      checkACLPerm perm acl' =+          if hasAccess roleIds perm acl' then+            pure ()+          else+            dbErr (AccessDeniedError (SomeACLPermission perm))+      checkFuncPerm perm acl' = do +        -- check dbc-function-level permissions+        if hasAccess roleIds perm acl' then+          pure ()+          else+          dbErr (AccessDeniedError (SomeFunctionPermission perm))+      checkDBCFuncPerm fname perm = do+        -- check specific function-level permissions+          case functionForName fname dbcFuncs of+            Left err -> dbErr err+            Right func ->+              if hasAccess roleIds perm (funcACL func) then +                pure ()+              else+                dbErr (AccessDeniedError (SomeDBCFunctionPermission perm))+      rvAcl = relvarsACL dbcAcl+      aclAcl = aclACL dbcAcl+      funcAcl = dbcFunctionsACL dbcAcl+  case expr of+    NoOperation -> pure ()+    Define{} ->+      checkRVPerm AccessRelVarsPermission rvAcl+    Undefine{} ->+      checkRVPerm AccessRelVarsPermission rvAcl+    Assign{} ->+      checkRVPerm AccessRelVarsPermission rvAcl+    Insert{} ->+      checkRVPerm AccessRelVarsPermission rvAcl+    Delete{} ->+      checkRVPerm AccessRelVarsPermission rvAcl+    Update{} ->+      checkRVPerm AccessRelVarsPermission rvAcl+    AddInclusionDependency{} ->+      checkRVPerm AccessRelVarsPermission rvAcl+    RemoveInclusionDependency{} ->+      checkRVPerm AccessRelVarsPermission rvAcl+    AddNotification{} ->+      checkRVPerm AccessRelVarsPermission rvAcl+    RemoveNotification{} ->+      checkRVPerm AccessRelVarsPermission rvAcl+    AddTypeConstructor{} ->+      checkRVPerm AccessRelVarsPermission rvAcl+    RemoveTypeConstructor{} ->+      checkRVPerm AccessRelVarsPermission rvAcl+    RemoveAtomFunction{} ->+      checkRVPerm AccessRelVarsPermission rvAcl+    RemoveDatabaseContextFunction fname -> do+      checkFuncPerm AlterFunctionPermission funcAcl+      checkDBCFuncPerm fname AlterDBCFunctionPermission +    ExecuteDatabaseContextFunction fname _args -> do+      checkFuncPerm ExecuteFunctionPermission funcAcl+      checkDBCFuncPerm fname ExecuteDBCFunctionPermission       +    AddRegisteredQuery{} ->+      checkRVPerm AccessRelVarsPermission rvAcl+    RemoveRegisteredQuery{} ->+      checkRVPerm AccessRelVarsPermission rvAcl+    AlterACL{} ->+      checkACLPerm AlterACLPermission aclAcl+    MultipleExpr exprs ->+      mapM_ (applyACLDatabaseContextExpr roleIds) exprs+{-+applyACLTransGraphRelationalExpr :: [RoleId] -> RelVarAccessControlList -> TransGraphRelationalExpr -> Either RelationalError ()+applyACLTransGraphRelationalExpr roleIds acl' expr =+  when (mentionsRelVar expr) $+    if hasAccess roleIds AccessRelVarsPermission acl' then+      pure ()+      else+      Left (AccessDeniedError (SomeRelVarPermission AccessRelVarsPermission))+-}++-- | Validate that any reference to a relvar within a transaction has AccessRelVarsPermission at that transactionId. Pass relevant access control lists extracted from the original expression which reference relvars at specific transaction ids.+applyACLGraphRefRelationalExpr :: [RoleId] -> [RelVarAccessControlList] -> Either RelationalError ()+applyACLGraphRefRelationalExpr roleIds transACLs =+  forM_ transACLs $ \acl' -> applyACLRelationalExpr roleIds acl' (RelationVariable "true" ())+    +applyACLSchemaExpr :: [RoleId] -> SchemaAccessControlList -> SchemaExpr -> Either RelationalError ()+applyACLSchemaExpr roleIds acl' _expr =+  if hasAccess roleIds AlterSchemaPermission acl' then+    pure ()+    else+    Left (AccessDeniedError (SomeAlterSchemaPermission AlterSchemaPermission))+

@@ -0,0 +1,194 @@+{-# LANGUAGE DeriveGeneric, DeriveAnyClass, RankNTypes, TupleSections #-}+module ProjectM36.AccessControlList where+import qualified Data.Set as S+import Data.UUID+import Control.DeepSeq (NFData)+import GHC.Generics+import Data.Hashable+import qualified Data.Map as M+import Data.Maybe (fromMaybe)+import Data.Default++newtype AccessControlList role' permission =+    AccessControlList (M.Map role' (RoleAccess permission))+   deriving (Show, NFData, Generic, Read, Eq)++instance Ord r => Default (AccessControlList r p) where+  def = AccessControlList mempty++instance (Ord p, Eq r, Ord r) => Semigroup (AccessControlList r p) where+  a <> b = merge a b+  +instance (Ord p, Eq r, Ord r) => Monoid (AccessControlList r p) where+  mempty = empty++type MayGrant = Bool++type RoleAccess permission = M.Map permission MayGrant++type RoleId = UUID++-- | Determine if the role can view or alter underlying relation variables.+type RelVarAccessControlList = AccessControlList RoleId RelVarPermission++type FunctionAccessControlList = AccessControlList RoleId FunctionPermission++type AlterTransGraphAccessControlList = AccessControlList RoleId AlterTransGraphPermission++type SchemaAccessControlList = AccessControlList RoleId AlterSchemaPermission++type ACLAccessControlList = AccessControlList RoleId ACLPermission++type DBCFunctionAccessControlList = AccessControlList RoleId DBCFunctionPermission++grantable :: perm -> M.Map perm MayGrant+grantable perm = M.singleton perm True++notGrantable :: perm -> M.Map perm MayGrant+notGrantable perm = M.singleton perm False++class AllPermissions a where+  allPermissions :: S.Set a++data RelVarPermission = AccessRelVarsPermission {-| AccessTypeConstructorsPermission -}+  deriving (Eq, Show, Ord, Generic, NFData, Read, Hashable)++instance AllPermissions RelVarPermission where+  allPermissions = S.fromList [AccessRelVarsPermission]++data FunctionPermission =+  ExecuteFunctionPermission -- ^ allow the role to execute the function+  | ViewFunctionPermission -- ^ allow the role to see that the function exists+  | AlterFunctionPermission -- ^ allow the role to load functions from outside the database or replace existing functions+  deriving (Eq, Show, Ord, Generic, NFData, Hashable)++instance AllPermissions FunctionPermission where+  allPermissions = S.fromList [ExecuteFunctionPermission, ViewFunctionPermission, AlterFunctionPermission]++data AlterTransGraphPermission =+  CommitTransactionPermission -- ^ allow the role to commit a transaction to the graph+  deriving (Eq, Show, Ord, Generic, NFData, Hashable)++instance AllPermissions AlterTransGraphPermission where+  allPermissions = S.fromList [CommitTransactionPermission]++data AlterSchemaPermission =+  AlterSchemaPermission -- ^ allow the role to add or remove a schema+  deriving (Eq, Show, Ord, Generic, NFData, Hashable)++instance AllPermissions AlterSchemaPermission where+  allPermissions = S.fromList [AlterSchemaPermission]++data ACLPermission =+  ViewACLPermission |+  AlterACLPermission+  deriving (Eq, Show, Ord, Generic, NFData, Hashable)++instance AllPermissions ACLPermission where+  allPermissions = S.fromList [ViewACLPermission, AlterACLPermission]++data DBCFunctionPermission =+  ViewDBCFunctionPermission |+  ExecuteDBCFunctionPermission |+  AlterDBCFunctionPermission -- ^ change or delete this function+  deriving (Eq, Show, Ord, Generic, NFData, Hashable)++instance AllPermissions DBCFunctionPermission where+  allPermissions = S.fromList [ViewDBCFunctionPermission,+                               ExecuteDBCFunctionPermission,+                               AlterDBCFunctionPermission]++hasAccess :: (Ord perm, Ord role', Eq role', Eq perm) => [role'] -> perm -> AccessControlList role' perm -> Bool+hasAccess hasRoles checkPerm (AccessControlList acl) =+  any (\role -> M.member checkPerm (fromMaybe mempty (M.lookup role acl))) hasRoles++addAccess :: (Eq role', Ord role', Eq perm, Ord perm) => role' -> perm -> MayGrant -> AccessControlList role' perm -> AccessControlList role' perm+addAccess targetRole newPerm mayGrant (AccessControlList ras) =+  AccessControlList $ M.insertWith M.union targetRole (M.singleton newPerm mayGrant) ras++removeAccess :: (Eq role', Ord role', Eq perm, Ord perm) => role' -> perm -> AccessControlList role' perm -> AccessControlList role' perm+removeAccess targetRole targetPerm (AccessControlList acl) =+  normalize $ AccessControlList $ M.alter alterFunc targetRole acl+  where+    alterFunc (Just ras) = Just $ M.delete targetPerm ras+    alterFunc Nothing = Nothing++-- | Remove empty dictionaries (roles without permissions).+normalize :: AccessControlList r p -> AccessControlList r p+normalize (AccessControlList acl) = AccessControlList $ M.filter (not . M.null) acl++empty :: Ord r => AccessControlList r p+empty = AccessControlList mempty++allPermissionsForRoleId :: (AllPermissions p, Ord p) => r -> AccessControlList r p+allPermissionsForRoleId roleid = AccessControlList (M.singleton roleid (M.fromList (map (,True) (S.toList allPermissions))))++merge :: (Ord p, Eq r, Ord r) => AccessControlList r p -> AccessControlList r p -> AccessControlList r p+merge (AccessControlList acl1) (AccessControlList acl2) =+  normalize $ AccessControlList $ M.unionWith mergeFunc acl1 acl2+  where+    mergeFunc = M.unionWith (||)++data DatabaseContextACL =+  DatabaseContextACL {+  relvarsACL :: RelVarAccessControlList,+  dbcFunctionsACL :: FunctionAccessControlList,+  transGraphACL :: AlterTransGraphAccessControlList,+  schemaACL :: SchemaAccessControlList,+  aclACL :: ACLAccessControlList+      }+  deriving (Show, NFData, Generic)++instance Semigroup DatabaseContextACL where+  a <> b = DatabaseContextACL {+    relvarsACL = relvarsACL a <> relvarsACL b,+    dbcFunctionsACL = dbcFunctionsACL a <> dbcFunctionsACL b,+    transGraphACL = transGraphACL a <> transGraphACL b,+    schemaACL = schemaACL a <> schemaACL b,+    aclACL = aclACL a <> aclACL b+    }++instance Monoid DatabaseContextACL where+  mempty = DatabaseContextACL {+    relvarsACL = mempty,+    dbcFunctionsACL = mempty,+    transGraphACL = mempty,+    schemaACL = mempty,+    aclACL = mempty+    }++basic :: DatabaseContextACL+basic = DatabaseContextACL {+  relvarsACL = AccessControlList (M.singleton adminRoleId+                                   (grantableL allPermissions)+                                 ),+  dbcFunctionsACL = AccessControlList (M.singleton adminRoleId+                                        (grantableL allPermissions)+                                      ),+  transGraphACL = AccessControlList (M.singleton adminRoleId+                                      (grantableL allPermissions)+                                    ),+  schemaACL = AccessControlList (M.singleton adminRoleId+                                  (grantableL allPermissions)+                                ),+  aclACL = AccessControlList (M.singleton adminRoleId+                               (grantableL allPermissions)+                             )+  }+  where+    grantableL :: forall perm. Ord perm => S.Set perm -> RoleAccess perm+    grantableL perms = M.fromList (map (, True) (S.toList perms))++adminRoleId :: RoleId+adminRoleId = nil++-- used in access control error reporting+data SomePermission = SomeRelVarPermission RelVarPermission |+                      SomeFunctionPermission FunctionPermission |+                      SomeAlterSchemaPermission AlterSchemaPermission |+                      SomeAlterTransGraphPermission AlterTransGraphPermission |+                      SomeACLPermission ACLPermission |+                      SomeDBCFunctionPermission DBCFunctionPermission+                    deriving (Show, NFData, Generic, Eq, Hashable)++

@@ -30,7 +30,8 @@                                     funcBody = FunctionBuiltInBody $                                                \case                                                  x:_ -> pure x-                                                 _ -> Left AtomFunctionTypeMismatchError+                                                 _ -> Left AtomFunctionTypeMismatchError,+                                    funcACL = ()                                   }                                                                                      @@ -38,7 +39,8 @@ compiledAtomFunction :: FunctionName -> [AtomType] -> AtomFunctionBodyType -> AtomFunction compiledAtomFunction name aType body = Function { funcName = name,                                                   funcType = aType,-                                                  funcBody = FunctionBuiltInBody body }+                                                  funcBody = FunctionBuiltInBody body,+                                                  funcACL = () }  --the atom function really should offer some way to return an error evalAtomFunction :: AtomFunction -> [Atom] -> Either AtomFunctionError Atom

@@ -19,64 +19,82 @@              funcType = [IntegerAtomType, IntegerAtomType, IntegerAtomType],              funcBody = body (\case                                  IntegerAtom i1:IntegerAtom i2:_ -> pure (IntegerAtom (i1 + i2))-                                 _ -> Left AtomFunctionTypeMismatchError)},+                                 _ -> Left AtomFunctionTypeMismatchError),+             funcACL = ()},     Function { funcName = "abs",                funcType = [IntegerAtomType, IntegerAtomType],                funcBody = body (\case                                    IntegerAtom i:_ -> pure $ IntegerAtom (abs i)                                    _ -> Left AtomFunctionTypeMismatchError-                               )+                               ),+               funcACL = ()              },     Function { funcName = "id",                funcType = [TypeVariableType "a", TypeVariableType "a"],                funcBody = body (\case                                    x:_ -> pure x                                    _ -> Left AtomFunctionTypeMismatchError-                               )},+                               ),+               funcACL = ()},         Function { funcName = "sum",                funcType = foldAtomFuncType IntegerAtomType IntegerAtomType,-               funcBody = body $ relationFoldFunc relationSum+               funcBody = body $ relationFoldFunc relationSum,+               funcACL = ()                             },     Function { funcName = "count",                funcType = [anyRelationAtomType,                            IntegerAtomType],-               funcBody = body $ relationAtomFunc relationCount+               funcBody = body $ relationAtomFunc relationCount,+               funcACL = ()                             },     Function { funcName = "max",                funcType = foldAtomFuncType IntegerAtomType IntegerAtomType,-               funcBody = body $ relationFoldFunc relationMax +               funcBody = body $ relationFoldFunc relationMax,+               funcACL = ()                             },     Function { funcName = "min",                funcType = foldAtomFuncType IntegerAtomType IntegerAtomType,-               funcBody = body $ relationFoldFunc relationMin+               funcBody = body $ relationFoldFunc relationMin,+               funcACL = ()                             },     Function { funcName = "mean",                funcType = foldAtomFuncType IntegerAtomType IntegerAtomType,-               funcBody = body $ relationFoldFunc relationMean+               funcBody = body $ relationFoldFunc relationMean,+               funcACL = ()                             },     Function { funcName = "eq",                funcType = [TypeVariableType "a", TypeVariableType "a", BoolAtomType],                funcBody = body $ \case                                          [i1,i2] -> pure (BoolAtom (i1 == i2))-                                         _ -> Left AtomFunctionTypeMismatchError+                                         _ -> Left AtomFunctionTypeMismatchError,+               funcACL = ()                             },     Function { funcName = "lt",                funcType = [IntegerAtomType, IntegerAtomType, BoolAtomType],-               funcBody = body $ integerAtomFuncLessThan False},+               funcBody = body $ integerAtomFuncLessThan False,+               funcACL = ()+             },     Function { funcName = "lte",                funcType = [IntegerAtomType, IntegerAtomType, BoolAtomType],-               funcBody = body $ integerAtomFuncLessThan True},+               funcBody = body $ integerAtomFuncLessThan True,+               funcACL = ()+               },     Function { funcName = "gte",                funcType = [IntegerAtomType, IntegerAtomType, BoolAtomType],-               funcBody = body $ integerAtomFuncLessThan False >=> boolAtomNot},+               funcBody = body $ integerAtomFuncLessThan False >=> boolAtomNot,+               funcACL = ()+             },     Function { funcName = "gt",                funcType = [IntegerAtomType, IntegerAtomType, BoolAtomType],-               funcBody = body $ integerAtomFuncLessThan True >=> boolAtomNot},+               funcBody = body $ integerAtomFuncLessThan True >=> boolAtomNot,+               funcACL = ()+             },     Function { funcName = "not",                funcType = [BoolAtomType, BoolAtomType],                funcBody = body $ \case                                          [b] -> boolAtomNot b-                                         _ -> Left AtomFunctionTypeMismatchError+                                         _ -> Left AtomFunctionTypeMismatchError,+               funcACL = ()                             },     Function { funcName = "int",                funcType = [IntegerAtomType, IntAtomType],@@ -87,13 +105,15 @@                                     pure (IntAtom (fromIntegral v))                                   else                                     Left InvalidIntBoundError-                                _ -> Left AtomFunctionTypeMismatchError+                                _ -> Left AtomFunctionTypeMismatchError,+               funcACL = ()                             },     Function { funcName = "integer",                funcType = [IntAtomType, IntegerAtomType],                funcBody = body $ \case                  [IntAtom v] -> Right $ IntegerAtom $ fromIntegral v-                 _ -> Left AtomFunctionTypeMismatchError+                 _ -> Left AtomFunctionTypeMismatchError,+               funcACL = ()                             },     Function { funcName = "uuid",                funcType = [TextAtomType, UUIDAtomType],@@ -103,27 +123,38 @@                      case mUUID of                        Just u -> pure $ UUIDAtom u                        Nothing -> Left $ InvalidUUIDString v-                 _ -> Left AtomFunctionTypeMismatchError+                 _ -> Left AtomFunctionTypeMismatchError,+               funcACL = ()                             },     Function { funcName = "and",                funcType = [BoolAtomType, BoolAtomType, BoolAtomType],                funcBody = body $ \case                  [BoolAtom b1, BoolAtom b2] ->                    Right $ BoolAtom (b1 && b2)-                 _ -> Left AtomFunctionTypeMismatchError+                 _ -> Left AtomFunctionTypeMismatchError,+               funcACL = ()                             },     Function { funcName = "or",                funcType = [BoolAtomType, BoolAtomType, BoolAtomType],                funcBody = body $ \case                  [BoolAtom b1, BoolAtom b2] ->                    Right $ BoolAtom (b1 || b2)-                 _ -> Left AtomFunctionTypeMismatchError                   +                 _ -> Left AtomFunctionTypeMismatchError,+               funcACL = ()                             },     Function { funcName = "increment",                funcType = [IntegerAtomType, IntegerAtomType],                funcBody = body $ \case                  [IntegerAtom i] -> pure (IntegerAtom (i+1))-                 _ -> Left AtomFunctionTypeMismatchError+                 _ -> Left AtomFunctionTypeMismatchError,+               funcACL = ()               +             },+    Function { funcName = "text_length",+               funcType = [TextAtomType, IntegerAtomType],+               funcBody = body $ \case+                 [TextAtom t] -> pure (IntegerAtom (toInteger (T.length t)))+                 _ -> Left AtomFunctionTypeMismatchError,+               funcACL = ()              }        ] <> scientificAtomFunctions@@ -198,7 +229,6 @@ castInteger (IntegerAtom i) = i  castInteger _ = error "attempted to cast non-IntegerAtom to Integer" - scientificAtomFunctions :: AtomFunctions scientificAtomFunctions = HS.fromList [   Function { funcName = "read_scientific",@@ -208,29 +238,35 @@                  case APT.parseOnly (APT.scientific <* APT.endOfInput) t of                    Left err -> Left (AtomFunctionParseError err)                    Right sci -> pure (ScientificAtom sci)-               _ -> Left AtomFunctionTypeMismatchError+               _ -> Left AtomFunctionTypeMismatchError,+             funcACL = ()                         },   Function { funcName = "scientific",              funcType = [IntegerAtomType, IntAtomType, ScientificAtomType],              funcBody = body $ \case                [IntegerAtom c,IntAtom e] -> pure (ScientificAtom $ scientific c e)-               _ -> Left AtomFunctionTypeMismatchError+               _ -> Left AtomFunctionTypeMismatchError,+             funcACL = ()                         },   Function { funcName = "scientific_add",              funcType = binaryFuncType,-             funcBody = binaryFuncBody (+)+             funcBody = binaryFuncBody (+),+             funcACL = ()                         },   Function { funcName = "scientific_subtract",              funcType = binaryFuncType,-             funcBody = binaryFuncBody (-)+             funcBody = binaryFuncBody (-),+             funcACL = ()                         },   Function { funcName = "scientific_multiply",              funcType = binaryFuncType,-             funcBody = binaryFuncBody (*)+             funcBody = binaryFuncBody (*),+             funcACL = ()                         },   Function { funcName = "scientific_divide",              funcType = binaryFuncType,-             funcBody = binaryFuncBody (/)+             funcBody = binaryFuncBody (/),+             funcACL = ()            }   ]   where body = FunctionBuiltInBody

@@ -0,0 +1,36 @@+module ProjectM36.AtomFunctions.SelfTest where+import ProjectM36.Base+import ProjectM36.AtomFunctionError+import qualified Data.HashSet as HS+import Control.Concurrent (threadDelay)+import System.IO.Unsafe (unsafePerformIO)+import Crypto.KDF.BCrypt (bcrypt)+import qualified Data.Text.Encoding as TE+import Debug.Trace++-- functions which should only exist for testing Project:M36+selfTestAtomFunctions :: AtomFunctions+selfTestAtomFunctions = HS.fromList [+  Function { funcName = "test_expensive" --returns the first argument after pausing X microseconds in the second argument to simulate a time-consuming function+           , funcType = [TypeVariableType "a", IntegerAtomType, TypeVariableType "a"]+           , funcBody = FunctionBuiltInBody (+             \case+               atom:(IntegerAtom microseconds):_ ->+                 unsafePerformIO $ do+                   traceShowM ("test_expensive threadDelay"::String, fromIntegral microseconds::Int)+                   threadDelay (fromIntegral microseconds)+                   pure (Right atom)+               _ -> Left AtomFunctionTypeMismatchError)+           , funcACL = ()+           },+    Function { funcName = "test_bcrypt", -- pass a value through but calculate something expensive, not for actual encryption use since it uses a fixed seed+               funcType = [IntegerAtomType, TextAtomType, TypeVariableType "a", TypeVariableType "a"],+               funcBody = FunctionBuiltInBody (+                 \case+                   (IntegerAtom costVal):(TextAtom plaintextPassword):atom:_ ->+                     let hashed = bcrypt (fromIntegral costVal) (TE.encodeUtf8 "1234567890123456") (TE.encodeUtf8 plaintextPassword) in+                       Right (ByteStringAtom hashed `seq` atom)+                   _ -> Left AtomFunctionTypeMismatchError)+             , funcACL = ()+             }+  ]

@@ -12,18 +12,16 @@ import qualified Data.Map as M import qualified Data.Text as T import qualified Data.Vector as V-import Control.DeepSeq (NFData) import Control.Applicative import Data.Time.Calendar import Data.ByteString (ByteString) import Data.Time.Clock import Data.Proxy import qualified Data.List.NonEmpty as NE-import Codec.Winery import Data.UUID  -- | All database values ("atoms") adhere to the 'Atomable' typeclass. This class is derivable allowing new datatypes to be easily marshaling between Haskell values and database values.-class (Eq a, NFData a, Serialise a, Show a) => Atomable a where+class Atomable a where   toAtom :: a -> Atom   default toAtom :: (Generic a, AtomableG (Rep a)) => a -> Atom   toAtom v = toAtomG (from v) (toAtomTypeG (from v))

@@ -104,6 +104,21 @@       --,attributesSet = attributesSet attrs1 <> attributesSet attrs2       } +{-+-- | Return the intersection of attributes. If the attributes share the same name, but not the same types, return an error.+intersection :: Attributes -> Attributes -> Either Relation Attributes+intersection attrsA attrsB =+  if overlappingAttrs attrsA  == overlappingAttrs attrsB then+    pure $ overlappingAttrs attrA+  else+    Left (TupleAttributeTypeMismatchError (attributesForNames overlappingNames attrsA))+  where+    nameSet1 = attributeNameSet attrsA+    nameSet2 = attributeNameSet attrsB+    overlappingNames = S.intersection nameSet1 nameSet2+    overlappingAttrs = attributesForNames overlappingNames+-}    + addAttributes :: Attributes -> Attributes -> Attributes addAttributes = (<>) @@ -284,3 +299,14 @@   where     hset = HS.intersection (attributesSet attrsA) (attributesSet attrsB)     vec = HS.foldr (flip V.snoc) mempty hset++-- | reorder the attributes according to the order of the attributes input. Useful during typechecking because the incoming attributes may be unresolved.+reorderAttributes :: Attributes -> Attributes -> Either RelationalError Attributes+reorderAttributes attrsOrder attrs =+  if attributesAndOrderEqual attrsOrder attrs then+    pure attrs+    else do+    Attributes <$> V.mapM mapper (attributesVec attrsOrder)+  where+    mapper attrOrder = do+      attributeForName (attributeName attrOrder) attrs

@@ -5,3 +5,8 @@ attributeName :: AttributeExprBase a -> AttributeName attributeName (AttributeAndTypeNameExpr nam _ _) = nam attributeName (NakedAttributeExpr attr) = A.attributeName attr++-- | Identify all type constructors mentioned in the expression.+typeConstructor :: AttributeExprBase a -> Maybe TypeConstructor+typeConstructor NakedAttributeExpr{} = Nothing+typeConstructor (AttributeAndTypeNameExpr _ tCons _) = Just tCons

@@ -0,0 +1,239 @@+-- implements a write-once, read-many B+tree layed out using the eytzinger format for less CPU cache churn+{-# LANGUAGE TypeApplications, DeriveAnyClass, DeriveGeneric #-}+module ProjectM36.BTree (build, member, BTree(..), Branches, Level, Index, size, totalBytes) where+import qualified Data.Vector.Unboxed as V+import qualified Data.Vector.Unboxed.Mutable as VM+import Control.Monad+import Control.DeepSeq+import Data.Maybe+--import Text.Printf+import GHC.Generics++import Debug.Trace++data BTree = BTree {+  branches :: Branches,+  elemCount :: Int,+  vec :: V.Vector Int }+  deriving (Show, Generic, NFData)++type Branches = Int+type Level = Int+type Index = Int++-- | return slicepoints for the b slices (returns b-1 indexes so that b nearly-equal slices are made)+sliceIndexes :: Branches -> Int -> [Int]+sliceIndexes b n | n < b = []+sliceIndexes b n | n == b = [0..b-2]+sliceIndexes b n = map islice [1 .. nodec]+  where+    nodec = b - 1+    islice x = (n * x) `divr` b+     +divr :: Integral a => a -> a -> a    +divr a b =+  --the `round` function rounds based even/odd integers- we just want dumb, unbiased rounding+  -- warning: this does not round properly+  if res - fromIntegral intres < 0.5 then+    intres+    else+    intres + 1+  where+    intres = floor res+    res :: Double+    res = fromIntegral a / fromIntegral b++-- | Calculate the size needed to flatten a sorted list into an Eytzinger b-tree (which may be sparse).+vectorSize :: Branches -> Int -> (Int, Int)+vectorSize b n = firstFit (zip (availableSizes b) [0..])+  where+    firstFit [] = (0,0) -- impossible+    firstFit ((size',i):ss) =+      if size' >= n then+        (size', i)+        else+        firstFit ss++-- | return list of vector sizes available for tree of node-branch factor b.+availableSizes :: Int -> [Int]+availableSizes b = takeWhile (>0) $ scanl (\acc x -> acc + (b - 1) * b ^ x) (b - 1) [(1 :: Int) ..]++-- | slice a vector into b+1 equally-sized slices and return the b roots+treeSlicer :: Branches -> V.Vector Int -> ([Int], [V.Vector Int])+treeSlicer b vin =+  if n >= b then+    (roots, slicesThroughIndexes sliceindexes vin)+  else+    (V.toList vin, [])+  where+    n = V.length vin+    sliceindexes = sliceIndexes b n+    roots = map (vin V.!) sliceindexes++-- cut up a vector into new vectors at the indexes but do not include the indexed value+slicesThroughIndexes :: [Int] -> V.Vector Int -> [V.Vector Int]+slicesThroughIndexes [] vin = [vin]+slicesThroughIndexes (i:is) vin =+  case V.splitAt i vin of+    (s1, sr) -> s1 : slicesThroughIndexes (map (\x -> x - i - 1) is) (V.tail sr)++sparseVal :: Int+sparseVal = -1 -- maxBound++-- the logical offset path within a tree, starting with the leaves (not the root).+type TreePath = [Int]++{-0+3 6 9 12+15 18 21 24+-}+-- | Returns the offset in the eytzinger encoding of the b-tree to the start of the (b-1) roots.+offsetForPath :: Branches -> TreePath -> Int+offsetForPath _ [] = 0+offsetForPath b path =+  levelOffset + --base offset to get to correct level in tree+  foldr (\(o, ri) acc -> +           acc ++           intraLevelOffset o ri+           ) 0 (zip path [pathLen, pathLen - 1 .. 1])+  where+    pathLen = length path+    kBlockSize l = (0 : availableSizes b) !! l+    kRootSize l = (b - 1) * (b ^ (l - 1)) -- 0, 3, 3*4, 3*4^2+    levelOffset = kBlockSize pathLen+    intraLevelOffset o ri = --traceShow ("o", o, "ri", ri, "i", i, "kRootSize", kRootSize ri)+      o * kRootSize ri+                       +-- | uses a sorted list to create a static Eytzinger representation of the b-tree- this structure does not support mutability. Since Project:M36 writes data using a WORM strategy, the Eytzinger is ideal since the structure emphasizes cache locality, reduces pointer indirection, and is quite compact with no need for extraneous padding.++--should build take a streamly stream or a list instead so that we won't need the sorted list in memory?+build :: Branches -> V.Vector Int -> BTree+build b sortedList = --input list should be de-duplicated to reduce b-tree size, but is otherwise a non-fatal construction of a b-tree (with some duplicate nodes)+  BTree {+    branches = b,+    elemCount = V.length sortedList,+    vec = vout}+  where+    n = V.length sortedList+    ksize = ceiling (logBase @Double (fromIntegral (b - 1)) (fromIntegral n))+    newArrSize = availableSizes b !! (ksize - 1)+    vout =+     V.create $ do+      --traceShowM ("ksize" :: String, ksize, "newArrSize" :: String, newArrSize, "n" :: String, n)+      v <- VM.replicate newArrSize sparseVal+      --split input list into `b` slices, extract the b roots by slicing the array into three equal-sized slices+      let writelevel path items = do+            let (roots, childSlices) = treeSlicer b items+                childSliceSizes = map V.length childSlices+                almostEqualSized = foldr (\x acc ->+                                            case acc of+                                              Nothing -> Nothing+                                              Just acc' -> if abs (acc' - x) > 2 then Nothing else Just x) (Just (head childSliceSizes)) childSliceSizes+            --first lay out all root-k values, then, k+1, etc.+            --space needed for each k level is (b-1) * b^k elements+            --traceShowM ("vsize" :: String, V.length items, "k" :: String, (k:: Int), "ksize" :: String, ksize, "roots" :: String, roots, "childSizes" :: String , map V.length childSlices, "childVecs" :: String, childSlices, "path" :: String, path)+            when (isNothing almostEqualSized) $ error ("uneven slices" <> show childSliceSizes)+            --write roots+            forM_ (zip roots [0..]) $ \(r,i) -> do+              let pos = offsetForPath b path + i+                  --dbgStr :: String+                  -- dbgStr = printf "%d + %d * (%d - 1) * (%d ^ %d) + %d" kOffset offset b b k i+                  -- dbgStr = printf "offset %d blockOffset %d k %d" offset blockOffset k+                  --dbgStr = printf "path %s pos %d" (show path) pos+              --traceShowM ("write" :: String, dbgStr)+              oldval <- VM.read v pos+              when (oldval /= sparseVal) $ traceShowM ("overwrite pos" :: String,+                                                        pos, "oldval" :: String,+                                                        oldval, "newval" :: String,+                                                        r)+              --traceShowM ("write val " <> show r <> " at " <> show pos)+              VM.write v pos r+            forM_ (zip childSlices [0..]) $ \(childVec, i) -> do+{-              let childRootOffset = kOffset + i * (b - 1) ^ k+                  kOffset = (0 : availableSizes b) !! (k + 1)-}+              unless (V.null childVec) $+                writelevel (i : path) childVec+      writelevel [] sortedList+      pure v++{- 0..16+5 should be written to pos+   [   ]/ [     ]  [     ]  [       ]  [       ] / [      ]  [      ] [      ] [      ] [      ]+k  0 1 2  3  4  5  6  7  8  9  10  11  12 13 14    15 16 17  18 19 20 21 22 23 24 25 26 27 28 29+0  4 9 13 +1         0  1  2  5  6  7  10 11  12  14 15 16+2                                                            3yes++4 * 3 ^ k++                          0                           n=1+     3              6          9            12        n=4+15 18 21 24    27 30 33 36  39 42 45 48  51 54 57 60  n=16 k+1 offset + (3 * 4 ^ 1) * parentOffset + 3 * childOffset+++                          0                           k=0+     1              2          3            4         k=1 offset+5  6  7  8       9 10 11 12  13 14 15 16  17 18 19 20 k=2 +-}++{-indexForRoots :: Branches -> Level -> Index -> Int+indexForRoots b k i = ((0 : availableSizes b) !! k) + i * (b - 1) +  -}+  +member :: Int -> BTree -> Bool+member needle bt = memberk 0 []+  where+    b = branches bt+    vin = vec bt+    (_,maxk) = vectorSize b (V.length vin) -- we don't care about the actual number of items in the tree+    memberk :: Level -> TreePath -> Bool+    memberk k _ | k > maxk = False+    memberk k path =+      let startIndex = offsetForPath b path+          roots = V.slice startIndex (b - 1) vin+      in +        case gteBinarySearch needle roots of+          Nothing -> -- follow right-most branch+            memberk (k+1) (b - 1 : path)+          Just gteIndex ->+            (roots V.! gteIndex == needle) || -- found it!+            memberk (k + 1) (gteIndex : path) -- search left branch of this root++-- | Search a sorted vector using binary search to find the first index >= to the needle, but takes into account the sparseVal.+gteBinarySearch :: Int -> V.Vector Int -> Maybe Int+gteBinarySearch needle haystack =+  if V.null haystack then+    Nothing+    else+    bsearch 0 (V.length haystack - 1)+  where+    bsearch low high+      | low == high =+        if haystack V.! low >= needle then+          Just low+          else+          Nothing+      | otherwise = +        let index = (high + low) `div` 2+            item = haystack V.! index+        in+          if item == needle then+            Just index+          else if item < needle && item /= sparseVal then do+            --we need to search to higher indexes+            bsearch (index + 1) high+          else+            --search lower indexes+            bsearch low index++size :: BTree -> Int+size = elemCount++totalBytes :: BTree -> Int+totalBytes bt = V.length (vec bt)+{-+-- | Useful for joins using two btrees.+intersect :: BTree -> BTree -> [Int]+intersect bta btb =+  go = +-}

@@ -1,11 +1,9 @@-{-# LANGUAGE ExistentialQuantification,DeriveGeneric,DeriveAnyClass,FlexibleInstances,OverloadedStrings, DeriveTraversable, DerivingVia, TemplateHaskell, TypeFamilies, BangPatterns #-}+{-# LANGUAGE ExistentialQuantification,DeriveGeneric,DeriveAnyClass,FlexibleInstances,OverloadedStrings, DeriveTraversable, DerivingVia, TemplateHaskell, TypeFamilies, BangPatterns, DuplicateRecordFields #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  module ProjectM36.Base where-import ProjectM36.DatabaseContextFunctionError import ProjectM36.AtomFunctionError-import ProjectM36.MerkleHash-+import ProjectM36.AccessControlList import Data.Functor.Foldable.TH import qualified Data.Map as M import qualified Data.HashSet as HS@@ -23,7 +21,6 @@ import Data.Time.Calendar (Day(..)) import Data.Typeable import Data.ByteString (ByteString)-import qualified Data.List.NonEmpty as NE import Data.Vector.Instances () import Data.Scientific @@ -31,17 +28,9 @@  type DatabaseName = String -#if !(MIN_VERSION_hashable(1,3,4))---support for hashable < 1.3, hashable 1.3+ includes instance for containers-instance Hashable (M.Map TypeVarName AtomType) where -  hashWithSalt salt tvmap = hashWithSalt salt (M.keys tvmap)--instance Hashable (M.Map AttributeName AtomExpr) where-  hashWithSalt salt m = salt `hashWithSalt` M.toList m+type RoleName = Text -instance Hashable (S.Set AttributeName) where-  hashWithSalt salt s = salt `hashWithSalt` S.toList s-#endif+type Permission = Text  -- time-compat includes these instances but time-compat is a dependency that is problematic, so just copy the instances here instance Hashable Day where@@ -124,7 +113,7 @@ type AttributeName = StringType  -- | A relation's type is composed of attribute names and types.-data Attribute = Attribute AttributeName AtomType deriving (Eq, Show, Read, Generic, NFData)+data Attribute = Attribute AttributeName !AtomType deriving (Eq, Show, Read, Generic, NFData)  instance Hashable Attribute where   hashWithSalt salt (Attribute attrName _) = hashWithSalt salt attrName@@ -223,6 +212,8 @@  type RelationalExpr = RelationalExprBase () +type RenameAssocs = S.Set (AttributeName, AttributeName)+ -- | A relational expression represents query (read) operations on a database. data RelationalExprBase a =   --- | Create a relation from tuple expressions.@@ -245,7 +236,7 @@   --- | Create a join of two relational expressions. The join occurs on attributes which are identical. If the expressions have no overlapping attributes, the join becomes a cross-product of both tuple sets.   Join (RelationalExprBase a) (RelationalExprBase a)  |   --- | Rename an attribute (first argument) to another (second argument).-  Rename (S.Set (AttributeName, AttributeName)) (RelationalExprBase a) | -- should the rename be a Map?+  Rename RenameAssocs (RelationalExprBase a) | -- should the rename be a Map?   --- | Return a relation containing all tuples of the first argument which do not appear in the second argument (minus).   Difference (RelationalExprBase a) (RelationalExprBase a) |   --- | Create a sub-relation composed of the first argument's attributes which will become an attribute of the result expression. The unreferenced attributes are not altered in the result but duplicate tuples in the projection of the expression minus the attribute names are compressed into one. For more information, <https://github.com/agentm/project-m36/blob/master/docs/introduction_to_the_relational_algebra.markdown#group read the relational algebra tutorial.>@@ -265,6 +256,13 @@  instance Hashable RelationalExpr +-- | Used for fixed relational expressions (useful for caching).+type PinnedRelationalExpr = RelationalExprBase TransactionId++instance Hashable PinnedRelationalExpr+    +type TransactionId = UUID+ type WithNamesAssocs = WithNamesAssocsBase ()  type WithNamesAssocsBase a = [(WithNameExprBase a, RelationalExprBase a)]@@ -335,41 +333,12 @@ -- a fundamental relational expr to which other relational expressions compile type GraphRefRelationalExpr = RelationalExprBase GraphRefTransactionMarker -type SchemaName = StringType                         --type Subschemas = M.Map SchemaName Schema---- | Every transaction has one concrete database context and any number of isomorphic subschemas.-data Schemas = Schemas DatabaseContext Subschemas-  deriving (Generic)---- | The DatabaseContext is a snapshot of a database's evolving state and contains everything a database client can change over time.--- I spent some time thinking about whether the VirtualDatabaseContext/Schema and DatabaseContext data constructors should be the same constructor, but that would allow relation variables to be created in a "virtual" context which would appear to defeat the isomorphisms of the contexts. It should be possible to switch to an alternative schema to view the same equivalent information without information loss. However, allowing all contexts to reference another context while maintaining its own relation variables, new types, etc. could be interesting from a security perspective. For example, if a user creates a new relvar in a virtual context, then does it necessarily appear in all linked contexts? After deliberation, I think the relvar should appear in *all* linked contexts to retain the isomorphic properties, even when the isomorphism is for a subset of the context. This hints that the IsoMorphs should allow for "fall-through"; that is, when a relvar is not defined in the virtual context (for morphing), then the lookup should fall through to the underlying context.-newtype Schema = Schema SchemaIsomorphs-              deriving (Generic)-                              -data SchemaIsomorph = IsoRestrict RelVarName RestrictionPredicateExpr (RelVarName, RelVarName) | -                      IsoRename RelVarName RelVarName |-                      IsoUnion (RelVarName, RelVarName) RestrictionPredicateExpr RelVarName  --maps two relvars to one relvar-                      -- IsoTypeConstructor in morphAttrExpr-                      deriving (Generic, Show)-                      -type SchemaIsomorphs = [SchemaIsomorph]+type HeadName = StringType  type RegisteredQueryName = StringType  type RegisteredQueries = M.Map RegisteredQueryName RelationalExpr-                              -data DatabaseContext = DatabaseContext {-  inclusionDependencies :: InclusionDependencies,-  relationVariables :: RelationVariables,-  atomFunctions :: AtomFunctions,-  dbcFunctions :: DatabaseContextFunctions,-  notifications :: Notifications,-  typeConstructorMapping :: TypeConstructorMapping,-  registeredQueries :: RegisteredQueries-  } deriving (NFData, Generic)-             +   type IncDepName = StringType               -- | Inclusion dependencies represent every possible database constraint. Constraints enforce specific, arbitrarily-complex rules to which the database context's relation variables must adhere unconditionally.@@ -380,14 +349,18 @@ --used for returning information about individual expressions type DatabaseContextExprName = StringType -type DatabaseContextExpr = DatabaseContextExprBase ()+type DatabaseContextExpr = DatabaseContextExprBase () RoleName +type DatabaseContextExpr' = DatabaseContextExprBase () RoleId+ instance Hashable DatabaseContextExpr  -type GraphRefDatabaseContextExpr = DatabaseContextExprBase GraphRefTransactionMarker+type GraphRefDatabaseContextExpr = DatabaseContextExprBase GraphRefTransactionMarker RoleName +type GraphRefDatabaseContextExpr' = DatabaseContextExprBase GraphRefTransactionMarker RoleId+ -- | Database context expressions modify the database context.-data DatabaseContextExprBase a = +data DatabaseContextExprBase a r =    NoOperation |   Define RelVarName [AttributeExprBase a] |   Undefine RelVarName | --forget existence of relvar X@@ -414,9 +387,11 @@    AddRegisteredQuery RegisteredQueryName RelationalExpr |   RemoveRegisteredQuery RegisteredQueryName |++  AlterACL (AlterDBCACLExprBase r) |   -  MultipleExpr [DatabaseContextExprBase a]-  deriving (Show, Read, Eq, Generic, NFData)+  MultipleExpr [DatabaseContextExprBase a r]+  deriving (Show, Eq, Generic, NFData)  type ObjModuleName = StringType type ObjFunctionName = StringType@@ -438,6 +413,8 @@  instance Hashable RestrictionPredicateExpr +instance Hashable (RestrictionPredicateExprBase TransactionId)+ type GraphRefRestrictionPredicateExpr = RestrictionPredicateExprBase GraphRefTransactionMarker  -- | Restriction predicates are boolean algebra components which, when composed, indicate whether or not a tuple should be retained during a restriction (filtering) operation.@@ -451,65 +428,16 @@   AttributeEqualityPredicate AttributeName (AtomExprBase a) -- relationalexpr must result in relation with single tuple   deriving (Show, Read, Eq, Generic, NFData, Foldable, Functor, Traversable) --- child + parent links--- | A transaction graph's head name references the leaves of the transaction graph and can be used during session creation to indicate at which point in the graph commits should persist.-type HeadName = StringType--type TransactionHeads = M.Map HeadName Transaction---- | The transaction graph is the global database's state which references every committed transaction.-data TransactionGraph = TransactionGraph TransactionHeads (S.Set Transaction)-  deriving Generic--transactionHeadsForGraph :: TransactionGraph -> TransactionHeads-transactionHeadsForGraph (TransactionGraph hs _) = hs--transactionsForGraph :: TransactionGraph -> S.Set Transaction-transactionsForGraph (TransactionGraph _ ts) = ts--transactionIdsForGraph :: TransactionGraph -> S.Set TransactionId-transactionIdsForGraph = S.map transactionId . transactionsForGraph---- | Every transaction has context-specific information attached to it.--- The `TransactionDiff`s represent child/edge relationships to previous transactions (branches or continuations of the same branch).-data TransactionInfo = TransactionInfo {-  parents :: TransactionParents,-  stamp :: UTCTime,-  merkleHash :: MerkleHash-  } deriving (Show, Generic)--type TransactionParents = NE.NonEmpty TransactionId---- | Every set of modifications made to the database are atomically committed to the transaction graph as a transaction.-type TransactionId = UUID--data Transaction = Transaction TransactionId TransactionInfo Schemas-  deriving Generic-                            --- | The disconnected transaction represents an in-progress workspace used by sessions before changes are committed. This is similar to git's "index". After a transaction is committed, it is "connected" in the transaction graph and can no longer be modified.-data DisconnectedTransaction = DisconnectedTransaction TransactionId Schemas DirtyFlag---the database context expression represents a difference between the disconnected transaction and its immutable parent transaction- is this diff expr used at all?- type DirtyFlag = Bool  type TransactionDiffExpr = DatabaseContextExpr-                            -transactionId :: Transaction -> TransactionId-transactionId (Transaction tid _ _) = tid -transactionInfo :: Transaction -> TransactionInfo-transactionInfo (Transaction _ info _) = info--instance Eq Transaction where                            -  (Transaction uuidA _ _) == (Transaction uuidB _ _) = uuidA == uuidB-                   -instance Ord Transaction where                            -  compare (Transaction uuidA _ _) (Transaction uuidB _ _) = compare uuidA uuidB- type AtomExpr = AtomExprBase ()  instance Hashable AtomExpr +instance Hashable (AtomExprBase TransactionId)+ type GraphRefAtomExpr = AtomExprBase GraphRefTransactionMarker  type AggAtomFuncExprInfo = (AttributeName, AttributeName) -- (relvar attribute name, subrel attribute name)@@ -532,6 +460,8 @@ type ExtendTupleExpr = ExtendTupleExprBase ()  instance Hashable ExtendTupleExpr++instance Hashable (ExtendTupleExprBase TransactionId)    type GraphRefExtendTupleExpr = ExtendTupleExprBase GraphRefTransactionMarker @@ -558,6 +488,8 @@  instance Hashable AttributeNames +instance Hashable (AttributeNamesBase TransactionId)+ type GraphRefAttributeNames = AttributeNamesBase GraphRefTransactionMarker  -- | The persistence strategy is a global database option which represents how to persist the database in the filesystem, if at all.@@ -585,6 +517,8 @@  instance Hashable TupleExpr +instance Hashable (TupleExprBase TransactionId)+ type TupleExpr = TupleExprBase ()  type GraphRefTupleExpr = TupleExprBase GraphRefTransactionMarker@@ -594,6 +528,8 @@  instance Hashable TupleExprs +instance Hashable (TupleExprsBase TransactionId)+ type GraphRefTupleExprs = TupleExprsBase GraphRefTransactionMarker  type TupleExprs = TupleExprsBase ()@@ -603,30 +539,26 @@   UnionMergeStrategy |   -- | Similar to a union merge, but, on conflict, prefer the unmerged section (relvar, function, etc.) from the branch named as the argument.   UnionPreferMergeStrategy HeadName |-  -- | Similar to the our/theirs merge strategy in git, the merge transaction's context is identical to that of the last transaction in the selected branch.+  -- | Similar to the our/theirs merge strategy in git, the merge transaction's context is identical to that of the head of the selected branch.   SelectedBranchMergeStrategy HeadName                      deriving (Eq, Show, Generic, NFData) ---type DatabaseContextFunctionBodyType = [Atom] -> DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext-type DatabaseContextFunctions = HS.HashSet DatabaseContextFunction- type FunctionName = StringType type FunctionBodyScript = StringType  -- | Represents stored, user-created or built-in functions which can operates of types such as Atoms or DatabaseContexts.-data Function a = Function {+data Function a acl = Function {   funcName :: FunctionName,   funcType :: [AtomType],-  funcBody :: FunctionBody a+  funcBody :: FunctionBody a,+  funcACL :: acl   }   deriving (Generic, NFData) -instance Eq (Function a) where                           +instance Eq (Function a acl) where                              f1 == f2 = funcName f1 == funcName f2 -instance Hashable (Function a) where+instance Hashable (Function a acl) where   hashWithSalt salt func = salt `hashWithSalt` funcName func `hashWithSalt` funcType func `hashWithSalt` hashfuncbody     where     hashfuncbody =@@ -646,12 +578,9 @@   rnf (FunctionBuiltInBody _) = rnf ()   rnf (FunctionObjectLoadedBody fp mod' entryf _) = rnf (fp, mod', entryf) -type AtomFunction = Function AtomFunctionBodyType+type AtomFunction = Function AtomFunctionBodyType () type AtomFunctionBody = FunctionBody AtomFunctionBodyType -type DatabaseContextFunction = Function DatabaseContextFunctionBodyType-type DatabaseContextFunctionBody = FunctionBody DatabaseContextFunctionBodyType- attrTypeVars :: Attribute -> S.Set TypeVarName attrTypeVars (Attribute _ aType) = case aType of   IntAtomType -> S.empty@@ -699,7 +628,20 @@  unimplemented :: HasCallStack => a unimplemented = error "unimplemented"++data AlterDBCACLExprBase r =+  GrantAccessExpr r SomePermission MayGrant |+  RevokeAccessExpr r SomePermission |+  GrantDBCFunctionAccessExpr r FunctionName DBCFunctionPermission MayGrant | -- refactor to support other function types; for example, an AtomFunction could contain sensitive business logic which only some users can run+  RevokeDBCFunctionAccessExpr r FunctionName DBCFunctionPermission+  deriving (Show, Generic, Eq, NFData, Hashable)++type AlterDBCACLExpr = AlterDBCACLExprBase RoleName++-- | Variant of ACL expression with RoleName resolved to RoleId.+type AlterDBCACLRoleIdExpr = AlterDBCACLExprBase RoleId             makeBaseFunctor ''RelationalExprBase-+makeBaseFunctor ''DatabaseContextExprBase+makeBaseFunctor ''AlterDBCACLExprBase 

@@ -0,0 +1,202 @@+-- an in-memory cache for relational expression results keyed off of the expressions+module ProjectM36.Cache.RelationalExprCache where+import ProjectM36.Base+import Data.Time.Clock.POSIX+import Data.Time.Clock+import Data.Int+import qualified StmContainers.Map as STMMap+import Control.Concurrent.STM+import GHC.Conc (unsafeIOToSTM)+import System.Random+import Control.Monad+import qualified ProjectM36.RelExprSize as RE+import ProjectM36.SystemMemory+import ProjectM36.RelExprSize (ByteCount)+import qualified Data.List.NonEmpty as NE+import ListT+import Data.List (sortBy)++--caching for uncommitted transactions may be a useful, future extension, but cannot be supported here since they are not (yet) uniquely identified++{- both the key and value of this cache are relational expressions, allowing for maximum flexibility++* if a key is a partial match of a large rel expr, then it can be used+* if a value is something other than a set of tuples, it can allow for a natural compression++Project:M36 passes all results to the cache, which decides if it is worth caching based on the time it took to calculate the result and how large the result is (if it won't blow out the cache maximum level).++In the future, the cache can be populated by predicting which queries are likely to be issued.+-}+++data RelExprCache = RelExprCache {+  upperBound :: TVar ByteCount,+  currentSize :: TVar ByteCount,+  cacheMap :: STMMap.Map PinnedRelationalExpr RelExprCacheInfo+  }++-- | Use all available RAM. In the future, some sort of memory heuristics engine could juggle how much memory is allocated to caching vs. processing.+defaultUpperBound :: IO ByteCount+defaultUpperBound = do+  mem <- getMemoryStats+  case mem of+    Left _err -> pure 0+    Right (_,totalMem) -> pure totalMem++empty :: ByteCount -> IO RelExprCache+empty upper = do+  maxSize <- newTVarIO upper+  curSize <- newTVarIO 0+  newMap <- STMMap.newIO+  pure $ RelExprCache {+    upperBound = maxSize,+    currentSize = curSize,+    cacheMap = newMap+    }++-- | Relational results can be represented using multiple representations such as+-- * unsorted tupleset+-- * tuples sorted by some ordering+-- * pinned relational expression (which may have been partially evaluated and could refer to other potentially-cached expressions)+-- * b+tree with tuples+-- All representations are immutable and pegged to specific transactions.+-- These representations are used to cache evaluated relational expressions out of the transaction graph+data RelationRepresentation =+  PinnedExpressionRep PinnedRelationalExpr |+  UnsortedTupleSetRep Attributes RelationTupleSet |+  SortedTuplesRep [RelationTuple] (NE.NonEmpty (AttributeName, SortOrder))++instance RE.Size RelationRepresentation where+  size (PinnedExpressionRep pRelExpr) = RE.size pRelExpr+  size (UnsortedTupleSetRep _ tupSet) = RE.size tupSet+  size (SortedTuplesRep tups _) = RE.size tups++data SortOrder = AscSortOrder | DescSortOrder  +    +data RelExprCacheInfo =+  RelExprCacheInfo { calculatedInTime :: !NominalDiffTime, -- ^ the duration of time it took to compute the relational expression without this cache entry. This can be used to determine if using the cache is worthwhile.+                     result :: RelationRepresentation, -- ^ the cached relational expr (in memory)+                     createTime :: !UTCTime, -- ^  when this entry was added to the cache+                     lastRequestTime :: !(Maybe UTCTime), -- when this entry was last used+                     size :: !ByteCount+                   }++-- identify the least-recently-used entries whose size sum to the target size or more.+leastRecentlyUsedEntries :: ByteCount -> RelExprCache -> STM [PinnedRelationalExpr]+leastRecentlyUsedEntries targetSize cache = do+  cacheMapAssoc <- toList $ STMMap.listT (cacheMap cache)+  let lrusorted = sortBy lrusort cacheMapAssoc+      lrusort (_, cacheInfoA) (_,cacheInfoB) =+        lastRequestTime cacheInfoB `compare` lastRequestTime cacheInfoA -- lru should be at the front of the list+      keysToRemove = snd $ foldr sumToTargetSize (0,[]) lrusorted+      sumToTargetSize (k,cacheInfo) acc@(bytesAcc, keysAcc) = +        if bytesAcc >= targetSize then+          acc+          else+          (size cacheInfo + bytesAcc, k : keysAcc)+  pure keysToRemove++-- | Delete the least-important cache items until the target size for this cache is reached.+purgeToSize :: RelExprCache -> ByteCount -> STM ()+purgeToSize = undefined++lookup :: PinnedRelationalExpr -> RelExprCache -> STM (Maybe RelExprCacheInfo)+lookup key cache = STMMap.lookup key (cacheMap cache)++type HitCount = Int64+type Probability = Double++-- | Decide probabalistically which cache entries to expunge depending on cache pressure. Any entry has a non-zero chance of being expunged.+--trimCache :: RelExprCache -> STM ()+--trimCache = do+  --attribute probability to all cache entries based on cache size, time to compute the entry, last request time++type MemoryPressure = Double++-- | A simple LRU-based cache where the upper-bound is the available memory.+executeLRUStrategy :: ByteCount -> -- ^ size of new, potential cache entry+                      NominalDiffTime -> -- ^ time it took to calculate this cache entry+                      RelExprCache ->+                      FreeMemBytes ->+                      STM (Probability, [PinnedRelationalExpr]) -- ^ return the probability that the cache should retain this entry and, if so, which entries to purge to make room for it+executeLRUStrategy entrySize _calcTime cache freeMem = do+    upperBound' <- readTVar (upperBound cache)+    currentSize' <- readTVar (currentSize cache)+    let proposedFreeMem = freeMem - entrySize+        prob = normalizedLogProb 1.0 (fromIntegral proposedFreeMem) (fromIntegral upperBound')+        --prob = logisticProb (fromIntegral proposedFreeMem) (fromIntegral upperBound')+--    traceShowM ("cache prob"::String, proposedFreeMem, upperBound', prob)+    if entrySize + currentSize' < upperBound' then+      pure (prob, []) -- should we probabilistically remove cache entries before the cache is full?+      else do+      -- evict entries were least-recently used+      entriesToEvict <- leastRecentlyUsedEntries entrySize cache+      pure (prob, entriesToEvict)++type IsRegisteredQuery = Bool++--allow the cache to decide if this result or one of it constituents should be cached+add :: RandomGen g +    => g+    -> PinnedRelationalExpr+    -> RelationRepresentation+    -> NominalDiffTime -- ^ time it took to calculate this value+    -> IsRegisteredQuery -- ^ Used to determine if the result to cache may potentially be used to evaluate a registered query, which should increase the result's likelihood of being cached.+    -> MemoryStats+    -> RelExprCache+    -> STM g+add rgen expr exprResult calcTime _isRegisteredQuery memStats cache = do+  -- if the time to calculate is less than a certain threshold, don't bother caching it+  now <- unsafeIOToSTM getCurrentTime+  let newCacheInfo = RelExprCacheInfo { calculatedInTime = calcTime,+                                        result = exprResult,+                                        createTime = now,+                                        lastRequestTime = Nothing,+                                        size = RE.size exprResult + RE.size expr}+  mCacheInfo <- STMMap.lookup expr (cacheMap cache) --opt: replace with `focus`+  case mCacheInfo of+        Nothing -> do+          -- calculate new entry size+          let keySize = RE.size expr+              valSize = RE.size exprResult+          -- calculate probability of retention and, if retaining, which entries to evict+          upperBound' <- readTVar (upperBound cache)          +          (probRetain, entriesToEvict) <- executeLRUStrategy (keySize + valSize) calcTime cache (min (fst memStats) upperBound')+          let (rand, rgen') = uniformR (0.0, 1.0) rgen+          --traceShowM ("probRetain"::String, probRetain, "rand"::String, rand, probRetain >= rand)+          when (probRetain >= rand) $ do+            forM_ entriesToEvict $ \key -> do+              mval <- STMMap.lookup key (cacheMap cache)+              let delSize = maybe 0 size mval+              currentSize' <- readTVar (currentSize cache)                    +              STMMap.delete key (cacheMap cache)+              writeTVar (currentSize cache) (currentSize' - delSize)+            --traceShowM ("adding to cache"::String, expr)+            STMMap.insert newCacheInfo expr (cacheMap cache)+            currentSize'' <- readTVar (currentSize cache)             +            writeTVar (currentSize cache) (keySize + valSize + currentSize'')+          pure rgen'+        Just _ -> do -- then entry is already cached, nothing to do+          --traceShowM ("key already cached"::String)+          pure rgen++-- p(m) = log(1 + α*m) / log(1 + α*Mmax)+normalizedLogProb :: Double -> Double -> Double -> Double+normalizedLogProb alpha m mmax+  | m <= 0    = 0+  | m >= mmax = 1+  | otherwise = logBase (1 + alpha * mmax) (1 + alpha * m) ++logistic :: Double -> Double -> Double -> Double+logistic k m x0 =+  1.0 / (1.0 + (euler ** ((-k) * (m - x0))))++stdlogistic :: Double -> Double+stdlogistic m =+  logistic 1.0 m 0.0++logisticProb :: Double -> Double -> Double+logisticProb freeMem memMax = logistic 1.0 freeMem (memMax / 2.0)++euler :: Double+euler = 2.718281828459045        

@@ -0,0 +1,170 @@+-- | Define a file which can be used to cache tuples for arbitrary, flat tuple sets.+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ScopedTypeVariables #-}++module ProjectM36.Cache.Tuple where+import ProjectM36.Base+import ProjectM36.Serialise.Base ()+import ProjectM36.RelExprSize+import qualified Data.Vector as V+import qualified Data.ByteString as BS+import Network.ByteOrder+import Data.Time.Clock+import Codec.Winery as W+import System.IO+import GHC.Generics+import Control.Monad (when, foldM)+import Control.Exception+import qualified Streamly.Data.Stream.Prelude as SP+import qualified Streamly.Internal.Data.Stream as SD+import Control.Monad.IO.Class (liftIO, MonadIO)+import Data.Bifunctor+import Data.Proxy++{- file format for tuple cache+-bytecount for info at end of file+TupleCacheInfo++-use blockSizes to get the next block of bytes+-}+type FileMagic = BS.ByteString++newtype InvalidFileMagicException = InvalidFileMagicException BS.ByteString deriving (Show)+newtype TruncatedFileException = TruncatedFileException ByteCount deriving (Show)+data SerialisationSchemaMismatch = SerialisationSchemaMismatch deriving (Show)++instance Exception InvalidFileMagicException+instance Exception TruncatedFileException+instance Exception SerialisationSchemaMismatch++fileMagic :: FileMagic+fileMagic = "PM36CacheTuple_v000"++type ByteOffset = ByteCount++data TupleCacheInfo =+  TupleCacheInfo { blockSizes :: V.Vector (ByteOffset, ByteCount),+                   representing :: PinnedRelationalExpr,+                   created :: UTCTime,+                   tupleSchema :: W.Schema -- the schema is shared amongst all tuples+                 }+  deriving (Generic, Show)+  deriving Serialise via WineryRecord TupleCacheInfo++blockCount :: TupleCacheInfo -> Int+blockCount i = V.length (blockSizes i)++readByteCount :: Handle -> IO Int+readByteCount h = do+  bytes <- BS.hGet h 8+  when (BS.length bytes /= 8) $ throw (TruncatedFileException 8)+  pure (fromIntegral $ word64 bytes)++-- | Runs checks such as confirming that the file size can accommodate the blockSizes in the cache info, but without reading the entire file so that this can be done routinely.+validateQuickly :: Handle -> IO ()+validateQuickly = undefined++--read and deserialize block of bytes prefixed by a byte count+readBlock :: Serialise a => Handle -> IO a+readBlock h = do+  bc <- readByteCount h+  bytes <- BS.hGetNonBlocking h bc+  when (BS.length bytes /= bc) $ throw (InvalidFileMagicException bytes)+  case deserialise bytes of+    Left err -> throw err+    Right val -> pure val+  +-- | get the cache info from a tuple cache file, may throw IO exception or InvalidFileMagicException+readCacheInfo :: Handle -> IO TupleCacheInfo+readCacheInfo h = do+  --look for magic+  potentialMagic <- BS.hGetNonBlocking h (BS.length fileMagic)+  when (potentialMagic /= fileMagic) $ throw (InvalidFileMagicException potentialMagic)+  readBlock h ++-- since this is just for caching, IO errors can be logged and ignored due to cache creation failure+writeTupleStream :: Handle -> PinnedRelationalExpr -> ByteCount -> [RelationTuple] -> IO ()+writeTupleStream h expr groupSize tuples = do+  --how can I write the tuple info if I only have a stream of the tuples :/ should the tuple info be at the back of the file then?+  --create slices and record sizes for metadata+  --write tuple info+  --write metadata plus metadata size at end+  now <- getCurrentTime+  BS.hPutStr h fileMagic+  let writeTupleBlock tuples' = do+          let tupleListBytes = serialiseOnly tuples'+              bytesCount = fromIntegral (BS.length tupleListBytes)+          BS.hPutStr h tupleListBytes+          pure bytesCount+      tupleBlockWriter (accsize, offset', accTuples, metadata) nextTuple = do+        -- add a new grouping, if we go over the size limit+        let estimatedTupleSize = size nextTuple+        if accsize + estimatedTupleSize >= groupSize then do+          tupleListByteCount <- writeTupleBlock (accTuples <> [nextTuple])+          pure (0,+                offset' + tupleListByteCount,+                [],+                metadata <> [(offset', tupleListByteCount)])+          else do+          pure (accsize + estimatedTupleSize,+                offset',+                accTuples <> [nextTuple],+                metadata)+      writeFinalBlock x@(_, _, [], _) = pure x+      writeFinalBlock (acc, offset', accTuples, metadata) = do+        bytesWritten <- writeTupleBlock accTuples+        pure (acc, offset', [], metadata <> [(offset', bytesWritten)])+        +  (_, _, _, blockSizeMetadata) <- foldM tupleBlockWriter (0,0,mempty,mempty) tuples >>= writeFinalBlock+  --write remaining tuples which didn't get get us over the last threshold+  --create block metadata at end of file, offset by file magic at beginning of file+  let tupleCacheInfo = TupleCacheInfo { blockSizes = V.fromList (map (first offsetByMagic) blockSizeMetadata),+                                        representing = expr,+                                        created = now,+                                        tupleSchema = schema (Proxy :: Proxy RelationTuple)+                                        }+      offsetByMagic = (+) (fromIntegral (BS.length fileMagic))+      tInfoData = serialise tupleCacheInfo+  BS.hPutStr h tInfoData+  BS.hPutStr h (bytestring64 (fromIntegral (BS.length tInfoData)))+  pure ()++readTupleStream :: MonadIO m => Handle -> SP.Stream m RelationTuple+readTupleStream h = SD.unCross $ do+  --skip filemagic+  --jump to end to read tuple cache info+  --deserialise blocks from metadata+  tupleCacheInfo <- liftIO $ do+    potentialMagic <- BS.hGetNonBlocking h (BS.length fileMagic)+    when (potentialMagic /= fileMagic) $ throw (InvalidFileMagicException potentialMagic)+    --get size of tuple cache info+    hSeek h SeekFromEnd (-8)+    infoSize <- readByteCount h+    hSeek h SeekFromEnd (-(fromIntegral (8 + infoSize)))+    tcacheInfo <- deserialise <$> BS.hGet h infoSize+    case tcacheInfo of+      Left err -> throw err+      Right info -> do+        when (tupleSchema info /= schema (Proxy :: Proxy RelationTuple)) $ throw SerialisationSchemaMismatch+        --print (blockSizes info)+        pure info+  let readTupleBlock (offset', byteLength) = liftIO $ do+--        print ("readTupleBlock", offset', byteLength)+        hSeek h AbsoluteSeek (fromIntegral offset')+        tuples <- deserialiseOnly' <$> BS.hGet h (fromIntegral byteLength)+        case tuples of+          Left err -> throw err+          Right tuples' -> do+--            print ("readTupleBlock", tuples')+            pure $ SP.fromList tuples'+  SD.mkCross $ SP.concatMapM readTupleBlock (SP.fromList (V.toList (blockSizes tupleCacheInfo)))+  +deserialiseOnly' :: forall s. Serialise s => BS.ByteString -> Either WineryException s+deserialiseOnly' bytes = do+  dec <- getDecoder (schema (Proxy :: Proxy s))+  pure (evalDecoder dec bytes)++    +          

@@ -11,6 +11,7 @@        Hostname,        ServiceName,        DatabaseName,+       TlsConfig(..),        ConnectionError(..),        connectProjectM36,        close,@@ -19,7 +20,8 @@        executeDatabaseContextExpr,        executeDatabaseContextIOExpr,        executeDataFrameExpr,-       executeGraphExpr,+       executeTransactionGraphExpr,+       executeAlterTransactionGraphExpr,        executeSchemaExpr,        executeTransGraphRelationalExpr,        commit,@@ -29,6 +31,7 @@        ProjectM36.Client.typeConstructorMapping,        ProjectM36.Client.databaseContextFunctionsAsRelation,              planForDatabaseContextExpr,+       planForRelationalExpr,        currentSchemaName,        SchemaName,        HeadName,@@ -40,7 +43,7 @@        ddlAsRelation,        ProjectM36.Client.atomFunctionsAsRelation,        disconnectedTransactionIsDirty,-       headName,+       currentHead,        remoteDBLookupName,        defaultServerPort,        headTransactionId,@@ -56,17 +59,19 @@        RelationalExprBase(..),        DatabaseContextExprBase(..),        DatabaseContextExpr,+       ExtendTupleExprBase(..),        DatabaseContextIOExprBase(..),        DatabaseContextIOExpr,        Attribute(..),        MergeStrategy(..),        attributesFromList,-       createSessionAtCommit,+       createSessionAtTransactionId,        createSessionAtHead,        closeSession,        callTestTimeout_,        RelationCardinality(..),-       TransactionGraphOperator(..),+       TransactionGraphExpr(..),+       AlterTransactionGraphExpr(..),        ProjectM36.Client.autoMergeToHead,        transactionGraph_,        disconnectedTransaction_,@@ -84,7 +89,6 @@        inclusionDependencyForKey,        databaseContextExprForUniqueKey,        databaseContextExprForForeignKey,-       createScriptedAtomFunction,        ProjectM36.Client.validateMerkleHashes,        AttributeExprBase(..),        TypeConstructorBase(..),@@ -113,13 +117,30 @@        RemoteServerAddress(..),        resolveRemoteServerAddress,        defaultRemoteServerAddress,-       defaultServerHostname+       defaultServerHostname,+       Discon.CurrentHead(..),+       LoginRoles.adminRoleName,+       SRPC.ClientAuth(..),+       ClientInfo(..),+       InProcessConnectionConf(..),+       executeAlterLoginRolesExpr,+       setRoleName,+       LoginRoles.AlterLoginRolesExpr(..),+       LoginRoles.SuccessResult(..),+       SomePermission(..),+       FunctionPermission(..),+       DBCFunctionPermission(..),       +       AlterDBCACLExprBase(..),+       RelVarPermission(..),+       RoleName        ) where-import ProjectM36.Base hiding (inclusionDependencies) --defined in this module as well-import qualified ProjectM36.Base as B+import ProjectM36.Base import ProjectM36.Serialise.Error () import ProjectM36.Error-import ProjectM36.DatabaseContext+import qualified ProjectM36.DatabaseContext.Types as DBC+import ProjectM36.DatabaseContext.Basic+import qualified ProjectM36.DatabaseContext as DBC+import ProjectM36.DatabaseContext.Types (DatabaseContext, notifications) import ProjectM36.Atomable import ProjectM36.AtomFunction as AF import ProjectM36.StaticOptimizer@@ -127,23 +148,23 @@ import qualified ProjectM36.DataFrame as DF import ProjectM36.DatabaseContextFunction as DCF import qualified ProjectM36.IsomorphicSchema as Schema-#if MIN_VERSION_base(4,16,0)-import Control.Monad (forever, forM, forM_, unless, void)-#endif---import Control.Monad.State+import Control.Monad (forever, forM, forM_, unless, void, when) import qualified ProjectM36.RelationalExpression as RE import qualified ProjectM36.TransactionGraph as Graph import ProjectM36.TransactionGraph as TG-import qualified ProjectM36.Transaction as Trans+import qualified ProjectM36.Transaction.Types as Trans+import ProjectM36.IsomorphicSchema.Types hiding (subschemas, concreteDatabaseContext) import ProjectM36.TransactionGraph.Persist import ProjectM36.Attribute-import ProjectM36.TransGraphRelationalExpression as TGRE (TransGraphRelationalExpr)+import ProjectM36.TransGraphRelationalExpression as TGRE (TransGraphRelationalExpr, process, TransGraphEvalEnv(..)) import ProjectM36.Persist (DiskSync(..)) import ProjectM36.FileLock import ProjectM36.DDLType import ProjectM36.NormalizeExpr import ProjectM36.Notifications import ProjectM36.Server.RemoteCallTypes+import ProjectM36.GraphRefRelationalExpr+import ProjectM36.Streaming.RelationalExpression (planGraphRefRelationalExpr, renderPretty) import qualified ProjectM36.DisconnectedTransaction as Discon import ProjectM36.Relation (typesAsRelation) import ProjectM36.ScriptSession (initScriptSession, ScriptSession)@@ -152,37 +173,47 @@ import Control.Concurrent.STM import Control.Concurrent.Async -import Data.Either (isRight) import Data.UUID.V4 (nextRandom)+import Data.UUID (nil) import Data.Word import Data.Hashable import Control.Concurrent.MVar import Codec.Winery hiding (Schema, schema) import qualified Data.Map as M-#if MIN_VERSION_stm_containers(1,0,0) import qualified StmContainers.Map as StmMap-import qualified StmContainers.Set as StmSet-#else-import qualified STMContainers.Map as StmMap-import qualified STMContainers.Set as StmSet-#endif import qualified ProjectM36.Session as Sess import ProjectM36.Session+import ProjectM36.ValueMarker+import ProjectM36.AccessControl import ProjectM36.Sessions+import ProjectM36.AccessControlList import ProjectM36.HashSecurely (SecureHash) import ProjectM36.RegisteredQuery+import qualified ProjectM36.Cache.RelationalExprCache as RelExprCache+import ProjectM36.Cache.RelationalExprCache (RelExprCache) import GHC.Generics (Generic) import Control.DeepSeq (force) import System.IO+import qualified Data.Text as T import Data.Time.Clock-import qualified Network.RPC.Curryer.Client as RPC-import qualified Network.RPC.Curryer.Server as RPC-import Network.Socket (Socket, AddrInfo(..), getAddrInfo, defaultHints, SocketType(..), ServiceName, SockAddr, Family(..), SockAddr(..))+import qualified Network.RPC.Curryer.Client as CRPC+import qualified Network.RPC.Curryer.Server as SRPC+import Network.Socket (AddrInfo(..), getAddrInfo, defaultHints, SocketType(..), ServiceName, SockAddr, Family(..), SockAddr(..)) import GHC.Conc (unsafeIOToSTM) import ProjectM36.SQL.Select as SQL import ProjectM36.SQL.DBUpdate as SQL import ProjectM36.SQL.Convert+import ProjectM36.TransactionGraph.Types+import ProjectM36.DisconnectedTransaction (DisconnectedTransaction(..))+import ProjectM36.DatabaseContextExpr+import qualified Data.Set as S+import qualified ProjectM36.LoginRoles as LoginRoles import Streamly.Internal.Network.Socket (SockSpec(..))+import System.FilePath ((</>))+import Data.Maybe (catMaybes)+import qualified Network.Socket as Socket+import qualified Data.HashSet as HS+import System.Random (StdGen)  type Hostname = String type Port = Word16@@ -211,8 +242,8 @@ instance Exception RequestTimeoutException  -- | Construct a 'ConnectionInfo' to describe how to make the 'Connection'. The database can be run within the current process or running remotely via RPC.-data ConnectionInfo = InProcessConnectionInfo PersistenceStrategy NotificationCallback [GhcPkgPath] DatabaseContext |-                      RemoteConnectionInfo DatabaseName RemoteServerAddress NotificationCallback+data ConnectionInfo = InProcessConnectionInfo PersistenceStrategy NotificationCallback [GhcPkgPath] DBC.ResolvedDatabaseContext StdGen RoleName |+                      RemoteConnectionInfo DatabaseName RemoteServerAddress CRPC.ClientConnectionConfig NotificationCallback RoleName                        type EvaluatedNotifications = M.Map NotificationName EvaluatedNotification @@ -248,14 +279,14 @@ defaultRemoteServerAddress = RemoteServerHostAddress "127.0.0.1" defaultServerPort  -- | Create a connection configuration which connects to the localhost on the default server port and default server database name. The configured notification callback is set to ignore all events.-defaultRemoteConnectionInfo :: ConnectionInfo+defaultRemoteConnectionInfo :: RoleName -> ConnectionInfo defaultRemoteConnectionInfo =-  RemoteConnectionInfo defaultDatabaseName defaultRemoteServerAddress emptyNotificationCallback+  RemoteConnectionInfo defaultDatabaseName defaultRemoteServerAddress CRPC.defaultClientConnectionConfig emptyNotificationCallback  defaultServerHostname :: Hostname defaultServerHostname = "localhost" -newtype RemoteConnectionConf = RemoteConnectionConf RPC.Connection+newtype RemoteConnectionConf = RemoteConnectionConf CRPC.Connection    data Connection = InProcessConnection InProcessConnectionConf |                   RemoteConnection RemoteConnectionConf@@ -299,47 +330,54 @@       sockAddr = SockAddrUnix sockPath   pure (sockSpec, sockAddr) --- | To create a 'Connection' to a remote or local database, create a 'ConnectionInfo' and call 'connectProjectM36'.+-- | To create a 'Connection' to a remote or local database, create a 'ConnectionInfo' and call 'connectProjectM36'. Requires "login" permission to connect successfully. connectProjectM36 :: ConnectionInfo -> IO (Either ConnectionError Connection) --create a new in-memory database/transaction graph-connectProjectM36 (InProcessConnectionInfo strat notificationCallback ghcPkgPaths bootstrapDatabaseContext) = do+connectProjectM36 (InProcessConnectionInfo strat notificationCallback ghcPkgPaths bootstrapDatabaseContext rando roleName) = do   freshId <- nextRandom   tstamp <- getCurrentTime-  let freshGraph = bootstrapTransactionGraph tstamp freshId bootstrapDatabaseContext+  let freshGraph = bootstrapTransactionGraph tstamp freshId (DBC.toDatabaseContext bootstrapDatabaseContext)   case strat of-    --create date examples graph for now- probably should be empty context in the future     NoPersistence -> do         graphTvar <- newTVarIO freshGraph-        clientNodes <- StmSet.newIO+        clientNodes <- StmMap.newIO         sessions <- StmMap.newIO         mScriptSession <- createScriptSession ghcPkgPaths         notifAsync <- startNotificationListener clientNodes notificationCallback+        maxCacheSize <- RelExprCache.defaultUpperBound+        cache <- RelExprCache.empty maxCacheSize+        loginRoles <- LoginRoles.openNoPersistence+        LoginRoles.setupDatabaseIfNecessary loginRoles         let conn = InProcessConnection InProcessConnectionConf {-                                           ipPersistenceStrategy = strat, -                                           ipClientNodes = clientNodes, -                                           ipSessions = sessions, -                                           ipTransactionGraph = graphTvar, -                                           ipScriptSession = mScriptSession,-                                           ipLocks = Nothing,-                                           ipCallbackAsync = notifAsync-                                           }+                    ipPersistenceStrategy = strat, +                    ipClientNodes = clientNodes, +                    ipSessions = sessions, +                    ipTransactionGraph = graphTvar, +                    ipScriptSession = mScriptSession,+                    ipLocks = Nothing,+                    ipCallbackAsync = notifAsync,+                    ipRelExprCache = cache,+                    ipLoginRoles = loginRoles,+                    ipRoleName = roleName,+                    ipRandomGen = rando+                  }         pure (Right conn)-    MinimalPersistence dbdir -> connectPersistentProjectM36 strat NoDiskSync dbdir freshGraph notificationCallback ghcPkgPaths-    CrashSafePersistence dbdir -> connectPersistentProjectM36 strat FsyncDiskSync dbdir freshGraph notificationCallback ghcPkgPaths+    MinimalPersistence dbdir -> connectPersistentProjectM36 strat NoDiskSync dbdir freshGraph notificationCallback ghcPkgPaths rando roleName+    CrashSafePersistence dbdir -> connectPersistentProjectM36 strat FsyncDiskSync dbdir freshGraph notificationCallback ghcPkgPaths rando roleName         -connectProjectM36 (RemoteConnectionInfo dbName remoteAddress notificationCallback) = do+connectProjectM36 (RemoteConnectionInfo dbName remoteAddress connConfig notificationCallback roleName) = do   (sockSpec, sockAddr) <- resolveRemoteServerAddress remoteAddress   let notificationHandlers =-        [RPC.ClientAsyncRequestHandler $+        [CRPC.ClientAsyncRequestHandler $           \(NotificationMessage notifications') ->             forM_ (M.toList notifications') (uncurry notificationCallback)         ]       connectExcHandler (e :: IOException) = pure $ Left (IOExceptionError e)-  eConn <- (Right <$> RPC.connect notificationHandlers sockSpec sockAddr) `catch` connectExcHandler+  eConn <- (Right <$> CRPC.connect notificationHandlers connConfig sockSpec sockAddr) `catch` connectExcHandler   case eConn of     Left err -> pure (Left err)     Right conn -> do-      eRet <- RPC.call conn (Login dbName)+      eRet <- CRPC.call conn (Login dbName roleName)       case eRet of         Left err -> error (show err)         Right False -> error "wtf"@@ -348,27 +386,43 @@           pure (Right (RemoteConnection (RemoteConnectionConf conn)))  --convert RPC errors into exceptions-convertRPCErrors :: RPC.ConnectionError -> IO a+convertRPCErrors :: SRPC.ConnectionError -> IO a convertRPCErrors err =   case err of-    RPC.TimeoutError -> throw RequestTimeoutException-    RPC.CodecError msg -> error $ "decoding message failed on server: " <> msg-    RPC.ExceptionError msg -> error $ "server threw exception: " <> msg+    SRPC.TimeoutError -> throw RequestTimeoutException+    SRPC.CodecError msg -> error $ "decoding message failed on server: " <> msg+    SRPC.ExceptionError msg -> error $ "server threw exception: " <> msg -addClientNode :: Connection -> RPC.Locking Socket -> IO ()-addClientNode (RemoteConnection _) _ = error "addClientNode called on remote connection"-addClientNode (InProcessConnection conf) lockSock = atomically (StmSet.insert clientInfo (ipClientNodes conf))-  where-    clientInfo = RemoteClientInfo lockSock+addClientNode :: Connection -> SRPC.ClientConnectionId -> SRPC.SocketContext -> RoleName -> IO ()+addClientNode (RemoteConnection _) _ _ _ = error "addClientNode called on remote connection"+addClientNode (InProcessConnection conf) clientId sockCtx roleName = do+  let lrdb = ipLoginRoles conf+      dropConn = SRPC.withLock (SRPC.lockingSocket sockCtx) $ \sock -> Socket.close sock+  LoginRoles.withTransaction lrdb $ do+    --check the role has login privilege+    eMayLogin <- LoginRoles.roleNameMayLogin roleName lrdb+    case eMayLogin of+      Left{} -> dropConn+      Right False -> dropConn+      Right True -> do+        -- collect roleids for rolename to pass to ACL validation functions+        eRoleIds <- LoginRoles.roleIdsForRoleName roleName lrdb+        case eRoleIds of+          Left{} -> dropConn+          Right _roleIds -> do+            let clientInfo = RemoteClientInfo sockCtx roleName+            atomically (StmMap.insert clientInfo clientId (ipClientNodes conf))  connectPersistentProjectM36 :: PersistenceStrategy ->                                DiskSync ->                                FilePath ->                                 TransactionGraph ->                                NotificationCallback ->-                               [GhcPkgPath] -> +                               [GhcPkgPath] ->+                               StdGen ->+                               RoleName ->                                IO (Either ConnectionError Connection)      -connectPersistentProjectM36 strat sync dbdir freshGraph notificationCallback ghcPkgPaths = do+connectPersistentProjectM36 strat sync dbdir freshGraph notificationCallback ghcPkgPaths rando roleName = do   err <- setupDatabaseDir sync dbdir freshGraph    case err of     Left err' -> return $ Left (SetupDatabaseDirectoryError err')@@ -383,52 +437,62 @@             Right _ -> do               tvarGraph <- newTVarIO graph'               sessions <- StmMap.newIO-              clientNodes <- StmSet.newIO+              clientNodes <- StmMap.newIO               lockMVar <- newMVar digest               notifAsync <- startNotificationListener clientNodes notificationCallback+              maxCacheSize <- RelExprCache.defaultUpperBound+              cache <- RelExprCache.empty maxCacheSize+              loginRoles <- LoginRoles.open (dbdir </> "loginroles.sqlite3")               let conn = InProcessConnection InProcessConnectionConf {-                                             ipPersistenceStrategy = strat,-                                             ipClientNodes = clientNodes,-                                             ipSessions = sessions,-                                             ipTransactionGraph = tvarGraph,-                                             ipScriptSession = mScriptSession,-                                             ipLocks = Just (lockFileH, lockMVar),-                                             ipCallbackAsync = notifAsync-                                             }+                          ipPersistenceStrategy = strat,+                          ipClientNodes = clientNodes,+                          ipSessions = sessions,+                          ipTransactionGraph = tvarGraph,+                          ipScriptSession = mScriptSession,+                          ipLocks = Just (lockFileH, lockMVar),+                          ipCallbackAsync = notifAsync,+                          ipRelExprCache = cache,+                          ipLoginRoles = loginRoles,+                          ipRoleName = roleName,+                          ipRandomGen = rando+                        }               pure (Right conn)  --startup local async process to handle notification callbacks startNotificationListener :: ClientNodes -> NotificationCallback -> IO (Async ()) startNotificationListener cNodes notificationCallback = do   inProcessClientInfo@(InProcessClientInfo notifMVar) <- InProcessClientInfo <$> newEmptyMVar          -  atomically $ StmSet.insert inProcessClientInfo cNodes +  atomically $ StmMap.insert inProcessClientInfo nil cNodes    async $ forever $ do     notifs <- takeMVar notifMVar     forM_ (M.toList notifs) $ uncurry notificationCallback --- | Create a new session at the transaction id and return the session's Id.-createSessionAtCommit :: Connection -> TransactionId -> IO (Either RelationalError SessionId)-createSessionAtCommit conn@(InProcessConnection _) commitId = do+-- | Create a new session at the transaction id and return the session's Id. +createSessionAtTransactionId :: Connection -> TransactionId -> IO (Either RelationalError SessionId)+createSessionAtTransactionId conn@(InProcessConnection _) commitId = do    newSessionId <- nextRandom-   atomically $ createSessionAtCommit_ commitId newSessionId conn-createSessionAtCommit conn@(RemoteConnection _) uuid = remoteCall conn (CreateSessionAtCommit uuid)+   atomically $ createSessionAtTransactionId_ Nothing commitId newSessionId conn+createSessionAtTransactionId conn@(RemoteConnection _) uuid = remoteCall conn (CreateSessionAtTransactionId uuid) -createSessionAtCommit_ :: TransactionId -> SessionId -> Connection -> STM (Either RelationalError SessionId)-createSessionAtCommit_ commitId newSessionId (InProcessConnection conf) = do+createSessionAtTransactionId_ :: Maybe HeadName -> TransactionId -> SessionId -> Connection -> STM (Either RelationalError SessionId)+createSessionAtTransactionId_ mHeadName commitId newSessionId (InProcessConnection conf) = do     let sessions = ipSessions conf         graphTvar = ipTransactionGraph conf     graph <- readTVar graphTvar     case RE.transactionForId commitId graph of         Left err -> pure (Left err)         Right transaction -> do-            let freshDiscon = DisconnectedTransaction commitId (Discon.loadGraphRefRelVarsOnly commitId (Trans.schemas transaction)) False+            let freshDiscon = Discon.freshTransaction' currentHead' commitId (Trans.schemas transaction)+                currentHead' = case mHeadName of+                                Just hname -> Discon.CurrentHeadBranch hname+                                Nothing -> Discon.CurrentHeadTransactionId commitId             keyDuplication <- StmMap.lookup newSessionId sessions             case keyDuplication of                 Just _ -> pure $ Left (SessionIdInUseError newSessionId)                 Nothing -> do                    StmMap.insert (Session freshDiscon defaultSchemaName) newSessionId sessions                    pure $ Right newSessionId-createSessionAtCommit_ _ _ (RemoteConnection _) = error "createSessionAtCommit_ called on remote connection"+createSessionAtTransactionId_ _ _ _ (RemoteConnection _) = error "createSessionAtTransactionId_ called on remote connection"    -- | Call 'createSessionAtHead' with a transaction graph's head's name to create a new session pinned to that head. This function returns a 'SessionId' which can be used in other function calls to reference the point in the transaction graph. createSessionAtHead :: Connection -> HeadName -> IO (Either RelationalError SessionId)@@ -439,10 +503,11 @@         graph <- readTVar graphTvar         case transactionForHead headn graph of             Nothing -> pure $ Left (NoSuchHeadNameError headn)-            Just trans -> createSessionAtCommit_ (transactionId trans) newSessionId conn+            Just trans -> createSessionAtTransactionId_ (Just headn) (Trans.transactionId trans) newSessionId conn createSessionAtHead conn@(RemoteConnection _) headn = remoteCall conn (CreateSessionAtHead headn)  -- | Discards a session, eliminating any uncommitted changes present in the session.+-- TODO: should sessions only be closed by the role which opened it? Yes. Otherwise we risk DoS attacks. closeSession :: SessionId -> Connection -> IO () closeSession sessionId (InProcessConnection conf) =      atomically $ StmMap.delete sessionId (ipSessions conf)@@ -466,12 +531,12 @@     Just (lockFileH, _) -> closeLockFile lockFileH  close (RemoteConnection (RemoteConnectionConf conn)) =-  RPC.close conn+  CRPC.close conn  --used only by the server EntryPoints closeRemote_ :: Connection -> IO () closeRemote_ (InProcessConnection _) = error "invalid call of closeRemote_ on InProcessConnection"-closeRemote_ (RemoteConnection (RemoteConnectionConf conn)) = RPC.close conn+closeRemote_ (RemoteConnection (RemoteConnectionConf conn)) = CRPC.close conn    --we need to actually close the localNode's connection to the remote --within the database server, we must catch and handle all exception lest they take down the database process- this handling might be different for other use-cases@@ -487,7 +552,7 @@ remoteCall :: (Serialise a, Serialise b) => Connection -> a -> IO b remoteCall (InProcessConnection _ ) _ = error "remoteCall called on local connection" remoteCall (RemoteConnection (RemoteConnectionConf rpcConn)) arg = do-  eRet <- RPC.call rpcConn arg+  eRet <- CRPC.call rpcConn arg   case eRet of     Left err -> convertRPCErrors err     Right val -> pure val@@ -496,23 +561,28 @@ sessionForSessionId sessionId sessions =    maybe (Left $ NoSuchSessionError sessionId) Right <$> StmMap.lookup sessionId sessions   -schemaForSessionId :: Session -> STM (Either RelationalError Schema)  -schemaForSessionId session = do+schemaForSessionId :: Session -> InProcessConnectionConf -> STM (Either RelationalError Schema)+schemaForSessionId session conf = do   let sname = schemaName session   if sname == defaultSchemaName then     pure (Right (Schema [])) -- the main schema includes no transformations (but neither do empty schemas :/ )-    else-    case M.lookup sname (subschemas session) of-      Nothing -> pure (Left (SubschemaNameNotInUseError sname))-      Just schema -> pure (Right schema)+    else do+    graph <- readTVar (ipTransactionGraph conf)      +    case resolveSubschemas session graph of+      Left err -> pure (Left err)+      Right sschemas ->+        case M.lookup sname sschemas of+          Nothing -> pure (Left (SubschemaNameNotInUseError sname))+          Just schema -> pure (Right schema)   -sessionAndSchema :: SessionId -> Sessions -> STM (Either RelationalError (Session, Schema))-sessionAndSchema sessionId sessions = do+sessionAndSchema :: SessionId -> InProcessConnectionConf -> STM (Either RelationalError (Session, Schema))+sessionAndSchema sessionId conf = do+  let sessions = ipSessions conf     eSession <- sessionForSessionId sessionId sessions   case eSession of     Left err -> pure (Left err)-    Right session -> do  -      eSchema <- schemaForSessionId session+    Right session -> do+      eSchema <- schemaForSessionId session conf       case eSchema of         Left err -> pure (Left err)         Right schema -> pure (Right (session, schema))@@ -534,70 +604,116 @@   eSession <- sessionForSessionId sessionId sessions   case eSession of     Left err -> pure (Left err)-    Right session -> case Sess.setSchemaName sname session of-      Left err -> pure (Left err)-      Right newSession -> StmMap.insert newSession sessionId sessions >> pure (Right ())+    Right session -> do+      graph <- readTVar (ipTransactionGraph conf)  +      case Sess.setSchemaName sname session graph of+        Left err -> pure (Left err)+        Right newSession -> StmMap.insert newSession sessionId sessions >> pure (Right ()) setCurrentSchemaName sessionId conn@(RemoteConnection _) sname = remoteCall conn (ExecuteSetCurrentSchema sessionId sname) --- | Execute a relational expression in the context of the session and connection. Relational expressions are queries and therefore cannot alter the database.+-- | Execute a relational expression in the context of the session and connection. Relational expressions are queries and therefore cannot alter the database. Requires `AccessRelVars` permission if the relational expression includes a reference to a relation variable. executeRelationalExpr :: SessionId -> Connection -> RelationalExpr -> IO (Either RelationalError Relation)-executeRelationalExpr sessionId (InProcessConnection conf) expr = excEither $ atomically $ do-  let sessions = ipSessions conf-  eSession <- sessionAndSchema sessionId sessions-  case eSession of+executeRelationalExpr sessionId (InProcessConnection conf) expr = do+  res <- excEither $ atomically $ do+   eSession <- sessionAndSchema sessionId conf+   case eSession of     Left err -> pure $ Left err     Right (session, schema) -> do       let expr' = if schemaName session /= defaultSchemaName then                     Schema.processRelationalExprInSchema schema expr                   else-                    Right expr+                    Right expr                           case expr' of         Left err -> pure (Left err)         Right expr'' -> do           let graphTvar = ipTransactionGraph conf           graph <- readTVar graphTvar-          let reEnv = RE.mkRelationalExprEnv (Sess.concreteDatabaseContext session) graph-          case optimizeAndEvalRelationalExpr reEnv expr'' of-            Right rel -> pure (force (Right rel)) -- this is necessary so that any undefined/error exceptions are spit out here +          let reEnv = RE.mkRelationalExprEnv dbctx graph+              dbctx = Sess.concreteDatabaseContext session+          pure (Right (graph, reEnv, expr''))+  case res of+    Left err -> pure (Left err)+    Right (graph, reEnv, rexpr) -> do+      case RE.resolveDBC' graph (RE.re_context reEnv) DBC.acl of+        Left err -> pure (Left err)+        Right acl' -> do+          roleIds <- roleIdsForRoleName conf+          case applyACLRelationalExpr roleIds (relvarsACL acl') rexpr of             Left err -> pure (Left err)+            Right () -> do+              qres <- optimizeAndEvalRelationalExpr' reEnv rexpr (ipRelExprCache conf)+              case qres of+                Right rel -> pure (force (Right rel)) -- this is necessary so that any undefined/error exceptions are spit out here +                Left err -> pure (Left err)  executeRelationalExpr sessionId conn@(RemoteConnection _) relExpr = remoteCall conn (ExecuteRelationalExpr sessionId relExpr) --- | Execute a database context expression in the context of the session and connection. Database expressions modify the current session's disconnected transaction but cannot modify the transaction graph.+-- | Execute a database context expression in the context of the session and connection. Database expressions modify the current session's disconnected transaction but cannot modify the transaction graph. Requires AccessRelVarsPermission. Requires ExecuteFunctionPermission if a function is executed. executeDatabaseContextExpr :: SessionId -> Connection -> DatabaseContextExpr -> IO (Either RelationalError ())-executeDatabaseContextExpr sessionId (InProcessConnection conf) expr = excEither $ atomically $ do+executeDatabaseContextExpr sessionId (InProcessConnection conf) expr = do+ roleIds <- roleIdsForRoleName conf+ roles <- LoginRoles.allRoles (ipLoginRoles conf)+ excEither $ atomically $ do   let sessions = ipSessions conf-  eSession <- sessionAndSchema sessionId sessions+  eSession <- sessionAndSchema sessionId conf   case eSession of     Left err -> pure (Left err)     Right (session, schema) -> do-      let expr' = if schemaName session == defaultSchemaName then-                    Right expr-                  else-                    Schema.processDatabaseContextExprInSchema schema expr+      let expr' = if schemaName session == defaultSchemaName then do+                    resolveRoleIds roleNameResolver expr+                  else +                    resolveRoleIds roleNameResolver expr >>= Schema.processDatabaseContextExprInSchema schema+          roleNameResolver nam = fst <$> lookup nam roles       case expr' of          Left err -> pure (Left err)         Right expr'' -> do           graph <- readTVar (ipTransactionGraph conf)           let ctx = Sess.concreteDatabaseContext session-              env = RE.mkDatabaseContextEvalEnv transId graph+              dbcfuncutils = DBC.DatabaseContextFunctionUtils {+                DBC.executeDatabaseContextExpr = \ctx' dbexpr' -> +                    case resolveRoleIds roleNameResolver dbexpr' of+                      Left err -> Left err+                      Right dbexpr'' ->+                        case RE.runDatabaseContextEvalMonad ctx' env (optimizeAndEvalDatabaseContextExpr True dbexpr'') of+                          Left err -> Left err+                          Right reState -> pure (RE.dbc_context reState)+                      ,+                DBC.executeRelationalExpr = \ctx' relExpr ->+                          let reEnv = RE.mkRelationalExprEnv ctx' graph in +                          optimizeAndEvalRelationalExpr reEnv relExpr+                      }+              env = RE.mkDatabaseContextEvalEnv transId graph dbcfuncutils               transId = Sess.parentId session-          case RE.runDatabaseContextEvalMonad ctx env (optimizeAndEvalDatabaseContextExpr True expr'') of+              runExpr = do+                applyACLDatabaseContextExpr roleIds expr''+                optimizeAndEvalDatabaseContextExpr True expr''+          case RE.runDatabaseContextEvalMonad ctx env runExpr of             Left err -> pure (Left err)             Right newState ->-              if not (RE.dbc_dirty newState) then --nothing dirtied, nothing to do+              if not (DBC.isUpdated (RE.dbc_context newState)) then do --nothing dirtied, nothing to do                 pure (Right ())               else do-                let newDiscon = DisconnectedTransaction (Sess.parentId session) newSchemas True-                    context' = RE.dbc_context newState-                    newSubschemas = Schema.processDatabaseContextExprSchemasUpdate (Sess.subschemas session) expr-                    newSchemas = Schemas context' newSubschemas-                    newSession = Session newDiscon (Sess.schemaName session)-                StmMap.insert newSession sessionId sessions-                pure (Right ())+                case resolveSubschemas session graph of+                  Left err -> pure (Left err)+                  Right sschemas -> do+                    let newDiscon = DisconnectedTransaction {+                          disconTransactionId = Sess.parentId session,+                          disconSchemas = newSchemas,+                          disconCurrentHead = Discon.disconCurrentHead (Sess.disconnectedTransaction session)+                          }+                        ctcontext = RE.dbc_context newState+                        newSubschemas = Schema.processDatabaseContextExprSchemasUpdate sschemas expr+                        newSubschemas' = if newSubschemas == sschemas then+                                           NotChangedSinceMarker transId+                                         else+                                           ValueMarker newSubschemas+                        newSchemas = Schemas ctcontext newSubschemas' -- the schemas in the disconnectedtransaction need to pass the ctdbc around until commit time+                        newSession = Session newDiscon (Sess.schemaName session)+                    StmMap.insert newSession sessionId sessions+                    pure (Right ()) executeDatabaseContextExpr sessionId conn@(RemoteConnection _) dbExpr = remoteCall conn (ExecuteDatabaseContextExpr sessionId dbExpr) --- | Similar to a git rebase, 'autoMergeToHead' atomically creates a temporary branch and merges it to the latest commit of the branch referred to by the 'HeadName' and commits the merge. This is useful to reduce incidents of 'TransactionIsNotAHeadError's but at the risk of merge errors (thus making it similar to rebasing). Alternatively, as an optimization, if a simple commit is possible (meaning that the head has not changed), then a fast-forward commit takes place instead.+-- | Similar to a git rebase, 'autoMergeToHead' atomically creates a temporary branch and merges it to the latest commit of the branch referred to by the 'HeadName' and commits the merge. This is useful to reduce incidents of 'TransactionIsNotAHeadError's but at the risk of merge errors (thus making it similar to rebasing). Alternatively, as an optimization, if a simple commit is possible (meaning that the head has not changed), then a fast-forward commit takes place instead. Requires CommitTransactionPermission. autoMergeToHead :: SessionId -> Connection -> MergeStrategy -> HeadName -> IO (Either RelationalError ()) autoMergeToHead sessionId (InProcessConnection conf) strat headName' = do   let sessions = ipSessions conf@@ -605,6 +721,7 @@   id2 <- nextRandom   id3 <- nextRandom   tstamp <- getCurrentTime+  roleIds <- roleIdsForRoleName conf   commitLock_ sessionId conf $ \graph -> do     eSession <- sessionForSessionId sessionId sessions       case eSession of@@ -614,22 +731,37 @@           Nothing -> pure (Left (NoSuchHeadNameError headName'))           Just headTrans -> do             --attempt fast-forward commit, if possible-            let graphInfo = if Sess.parentId session == transactionId headTrans then do-                              ret <- Graph.evalGraphOp tstamp id1 (Sess.disconnectedTransaction session) graph Commit-                              pure (ret, [id1])-                            else do-                              ret <- Graph.autoMergeToHead tstamp (id1, id2, id3) (Sess.disconnectedTransaction session) headName' strat graph -                              pure (ret, [id1,id2,id3])-            case graphInfo of+            let disconIn = Sess.disconnectedTransaction session+                dbctx = Sess.concreteDatabaseContext session+            --check permission+            case RE.resolveDBC' graph dbctx DBC.acl of               Left err -> pure (Left err)-              Right ((discon', graph'), transactionIdsAdded) ->-                pure (Right (discon', graph', transactionIdsAdded))+              Right acl' -> do+                let alterTGACL = transGraphACL acl'+                case applyACLAlterTransGraphExpr roleIds alterTGACL Commit of+                  Left err -> pure (Left err)+                  Right () -> do+                    if Sess.parentId session == Trans.transactionId headTrans then do+                      let ret = Graph.evalAlterTransactionGraphExpr tstamp id1 disconIn graph Commit+                      case ret of+                        Left err -> pure (Left err)+                        Right (discon', mtrans', tGraph) ->+                          pure (Right (discon', TransactionGraphIncrementalWriteInfo {+                                          uncommittedTransactions = S.fromList (catMaybes [mtrans']),+                                          newGraph = tGraph+                                          }))+                      else do+                      pure $ Graph.autoMergeToHead tstamp (id1, id2, id3) disconIn headName' strat graph autoMergeToHead sessionId conn@(RemoteConnection _) strat headName' = remoteCall conn (ExecuteAutoMergeToHead sessionId strat headName')       --- | Execute a database context IO-monad-based expression for the given session and connection. `DatabaseContextIOExpr`s modify the DatabaseContext but cannot be purely implemented.+-- | Execute a database context IO-monad-based expression for the given session and connection. `DatabaseContextIOExpr`s modify the DatabaseContext but cannot be purely implemented. Requires ExecuteFunctionPermission. --this is almost completely identical to executeDatabaseContextExpr above executeDatabaseContextIOExpr :: SessionId -> Connection -> DatabaseContextIOExpr -> IO (Either RelationalError ())-executeDatabaseContextIOExpr sessionId (InProcessConnection conf) expr = excEither $ do+executeDatabaseContextIOExpr sessionId (InProcessConnection conf) expr = do+ roleIds <- roleIdsForRoleName conf+ roles <- LoginRoles.allRoles (ipLoginRoles conf) + myRoleId <- primaryRoleIdForRoleName conf+ excEither $ do   let sessions = ipSessions conf       scriptSession = ipScriptSession conf   eSession <- atomically $ sessionForSessionId sessionId sessions --potentially race condition due to interleaved IO?@@ -637,22 +769,45 @@     Left err -> pure (Left err)     Right session -> do       graph <- readTVarIO (ipTransactionGraph conf)-      let env = RE.DatabaseContextIOEvalEnv transId graph scriptSession objFilesPath+      let env = RE.DatabaseContextIOEvalEnv transId graph scriptSession myRoleId objFilesPath dbcFuncUtils+          dbcEnv = RE.mkDatabaseContextEvalEnv transId graph dbcFuncUtils+          roleNameResolver nam = fst <$> lookup nam roles      +          dbcFuncUtils = DBC.DatabaseContextFunctionUtils {+            DBC.executeDatabaseContextExpr = \ctx' expr' ->+                    case resolveRoleIds roleNameResolver expr' of+                      Left err -> Left err+                      Right expr'' ->+                        case RE.runDatabaseContextEvalMonad ctx' dbcEnv (optimizeAndEvalDatabaseContextExpr True expr'') of+                          Left err -> Left err+                          Right reState -> pure (RE.dbc_context reState)+                      ,+            DBC.executeRelationalExpr = \ctx' relExpr ->+                          let reEnv = RE.mkRelationalExprEnv ctx' graph in +                          optimizeAndEvalRelationalExpr reEnv relExpr+            }           objFilesPath = objectFilesPath <$> persistenceDirectory (ipPersistenceStrategy conf)           transId = Sess.parentId session           context = Sess.concreteDatabaseContext session-      res <- RE.runDatabaseContextIOEvalMonad env context (optimizeAndEvalDatabaseContextIOExpr expr)+          runExpr = do+            --check perms+            applyACLDatabaseContextIOExpr roleIds expr+            optimizeAndEvalDatabaseContextIOExpr expr+      res <- RE.runDatabaseContextIOEvalMonad env context runExpr       case res of         Left err -> pure (Left err)         Right newState -> do-          let newDiscon = DisconnectedTransaction (Sess.parentId session) newSchemas False+          let newDiscon = DisconnectedTransaction {+                disconTransactionId = Sess.parentId session,+                disconSchemas = newSchemas,+                disconCurrentHead = Discon.disconCurrentHead (Sess.disconnectedTransaction session)+                }               newSchemas = Schemas context' (Sess.subschemas session)               newSession = Session newDiscon (Sess.schemaName session)               context' = RE.dbc_context newState           atomically $ StmMap.insert newSession sessionId sessions           pure (Right ()) executeDatabaseContextIOExpr sessionId conn@(RemoteConnection _) dbExpr = remoteCall conn (ExecuteDatabaseContextIOExpr sessionId dbExpr)-         +                                                                           -- process notifications for commits executeCommitExprSTM_   :: TransactionGraph@@ -661,8 +816,10 @@   -> ClientNodes   -> STM (EvaluatedNotifications, ClientNodes) executeCommitExprSTM_ graph oldContext newContext nodes = do-  let nots = notifications oldContext-      fireNots = notificationChanges nots graph oldContext newContext +  nots <- case RE.resolveDBC' graph oldContext notifications of+            Left err -> throwSTM err+            Right nots' -> pure nots'+  let fireNots = notificationChanges nots graph oldContext newContext       evaldNots = M.map mkEvaldNot fireNots       evalInContext expr ctx = optimizeAndEvalRelationalExpr (RE.mkRelationalExprEnv ctx graph) expr  @@ -671,99 +828,211 @@                                                  reportNewRelation = evalInContext (reportNewExpr notif) newContext}   pure (evaldNots, nodes)   --- | Execute a transaction graph expression in the context of the session and connection. Transaction graph operators modify the transaction graph state.+-- | Execute a transaction graph expression in the context of the session and connection. Transaction graph operators cannot modify the transaction graph state. Does not require any permission.+executeTransactionGraphExpr :: SessionId -> Connection -> TransactionGraphExpr -> IO (Either RelationalError ())+executeTransactionGraphExpr sessionId (InProcessConnection conf) graphExpr = excEither $ do+  let sessions = ipSessions conf+  commitLock_ sessionId conf $ \updatedGraph -> do+    eSession <- sessionForSessionId sessionId sessions+    case eSession of+      Left err -> pure (Left err)+      Right session -> do+        let discon = Sess.disconnectedTransaction session+        case evalTransactionGraphExpr discon updatedGraph graphExpr of+          Left err -> pure (Left err)+          Right discon' -> do+            pure (Right (discon', TransactionGraphIncrementalWriteInfo {+                            uncommittedTransactions = mempty,+                            newGraph = updatedGraph+                            })) --- OPTIMIZATION OPPORTUNITY: no locks are required to write new transaction data, only to update the transaction graph id file--- if writing data is re-entrant, we may be able to use unsafeIOtoSTM--- perhaps keep hash of data file instead of checking if our head was updated on every write-executeGraphExpr :: SessionId -> Connection -> TransactionGraphOperator -> IO (Either RelationalError ())-executeGraphExpr sessionId (InProcessConnection conf) graphExpr = excEither $ do+executeTransactionGraphExpr sessionId conn@(RemoteConnection _) graphExpr = remoteCall conn (ExecuteGraphExpr sessionId graphExpr)++-- | Execute an operator which alters the transaction graph such as commit, branching, or merge. Requires CommitTransactionPermission.+executeAlterTransactionGraphExpr :: SessionId -> Connection -> AlterTransactionGraphExpr -> IO (Either RelationalError ())+executeAlterTransactionGraphExpr sessionId (InProcessConnection conf) alterGraphExpr = do   let sessions = ipSessions conf   freshId <- nextRandom   tstamp <- getCurrentTime+  roleIds <- roleIdsForRoleName conf   commitLock_ sessionId conf $ \updatedGraph -> do     eSession <- sessionForSessionId sessionId sessions     case eSession of       Left err -> pure (Left err)       Right session -> do         let discon = Sess.disconnectedTransaction session-        case evalGraphOp tstamp freshId discon updatedGraph graphExpr of+            dbctx = Sess.concreteDatabaseContext session        +        case RE.resolveDBC' updatedGraph dbctx DBC.acl of           Left err -> pure (Left err)-          Right (discon', graph') -> do-            --if freshId appears in the graph, then we need to pass it on-            let transIds = [freshId | isRight (RE.transactionForId freshId graph')]-            pure (Right (discon', graph', transIds))+          Right acl' -> do+            let alterTGACL = transGraphACL acl'+            case applyACLAlterTransGraphExpr roleIds alterTGACL alterGraphExpr of+              Left err -> pure (Left err)+              Right () -> do -executeGraphExpr sessionId conn@(RemoteConnection _) graphExpr = remoteCall conn (ExecuteGraphExpr sessionId graphExpr)+                case evalAlterTransactionGraphExpr tstamp freshId discon updatedGraph alterGraphExpr of+                  Left err -> pure (Left err)+                  Right (discon', mtrans', graph') -> do+                    pure (Right (discon', TransactionGraphIncrementalWriteInfo {+                                    uncommittedTransactions = S.fromList (catMaybes [mtrans']),+                                    newGraph = graph'+                                    }))+executeAlterTransactionGraphExpr sessionId conn@RemoteConnection{} alterGraphExpr =+  remoteCall conn (ExecuteAlterTransactionGraphExpr sessionId alterGraphExpr) --- | A trans-graph expression is a relational query executed against the entirety of a transaction graph.+-- | A trans-graph expression is a relational query executed against the entirety of a transaction graph. Requires AccessRelVarsPermission if the expression mentions a relation variable. executeTransGraphRelationalExpr :: SessionId -> Connection -> TransGraphRelationalExpr -> IO (Either RelationalError Relation)-executeTransGraphRelationalExpr _ (InProcessConnection conf) tgraphExpr = excEither . atomically $ do-  let graphTvar = ipTransactionGraph conf-  graph <- readTVar graphTvar-  pure $ force $ optimizeAndEvalTransGraphRelationalExpr graph tgraphExpr+executeTransGraphRelationalExpr sessionId (InProcessConnection conf) tgraphExpr = do+  roleIds <- roleIdsForRoleName conf+  eGraph <- atomically $ do+    eSession <- sessionAndSchema sessionId conf    +    case eSession of+      Left err -> pure $ Left err+      Right (session, _schema) -> do+        let dbctx = Sess.concreteDatabaseContext session+            graphTvar = ipTransactionGraph conf+        graph <- readTVar graphTvar+        case RE.resolveDBC' graph dbctx DBC.acl of+          Left err -> pure (Left err)+          Right acl' -> do+            let rvACL = relvarsACL acl'+            case TGRE.process (TransGraphEvalEnv graph) tgraphExpr of+              Left err -> pure (Left err)+              Right gfExpr -> do+                -- security check- get rvs mentioned at any transaction ids+                let rvMentionedMarkers = decomposeGraphRefTransactionMarkers gfExpr+                    -- collect acls from those transactions+                    lookupACL UncommittedContextMarker = do+                      applyACLRelationalExpr roleIds rvACL (RelationVariable "true" ())+                    lookupACL (TransactionMarker tid) = do+                      trans <- TG.lookupTransaction graph (TransactionIdLookup tid)+                      let dbctx' = Trans.concreteDatabaseContext trans+                      rvacl <- relvarsACL <$> RE.resolveDBC' graph dbctx' DBC.acl+                      applyACLRelationalExpr roleIds rvacl (RelationVariable "true" ())+                case forM_ rvMentionedMarkers (\(marker, _rvname) -> lookupACL marker) of+                  Left err -> pure (Left err)+                  Right () -> pure (Right graph)+  case eGraph of+    Left err -> pure (Left err)+    Right graph -> +      optimizeAndEvalTransGraphRelationalExprWithCache (ipRandomGen conf) graph tgraphExpr (ipRelExprCache conf)+   executeTransGraphRelationalExpr sessionId conn@(RemoteConnection _) tgraphExpr = remoteCall conn (ExecuteTransGraphRelationalExpr sessionId tgraphExpr)   --- | Schema expressions manipulate the isomorphic schemas for the current 'DatabaseContext'.+-- | Schema expressions manipulate the isomorphic schemas for the current 'DatabaseContext'. Requires AlterSchemaPermission. executeSchemaExpr :: SessionId -> Connection -> Schema.SchemaExpr -> IO (Either RelationalError ())-executeSchemaExpr sessionId (InProcessConnection conf) schemaExpr = atomically $ do+executeSchemaExpr sessionId (InProcessConnection conf) schemaExpr = do+ roleIds <- roleIdsForRoleName conf+ roles <- LoginRoles.allRoles (ipLoginRoles conf)  + atomically $ do   let sessions = ipSessions conf-  eSession <- sessionAndSchema sessionId sessions  +  eSession <- sessionAndSchema sessionId conf+  graph <- readTVar (ipTransactionGraph conf)   case eSession of     Left err -> pure (Left err)     Right (session, _) -> do-      let subschemas' = subschemas session-          transId = Sess.parentId session-          context = Sess.concreteDatabaseContext session-      graph <- readTVar (ipTransactionGraph conf)-      case Schema.evalSchemaExpr schemaExpr context transId graph subschemas' of+      case resolveSubschemas session graph of         Left err -> pure (Left err)-        Right (newSubschemas, newContext) -> do-          --hm- maybe we should start using lenses-          let discon = Sess.disconnectedTransaction session -              newSchemas = Schemas newContext newSubschemas-              newSession = Session (DisconnectedTransaction (Discon.parentId discon) newSchemas False) (Sess.schemaName session)-          StmMap.insert newSession sessionId sessions-          pure (Right ())+        Right subschemas' -> do+          let transId = Sess.parentId session+              context = Sess.concreteDatabaseContext session+              roleNameResolver nam = fst <$> lookup nam roles+          case RE.resolveDBC' graph context DBC.acl of+            Left err -> pure (Left err)+            Right acl' ->+              case applyACLSchemaExpr roleIds (schemaACL acl') schemaExpr of+                Left err -> pure (Left err)+                Right () -> do+                  let dbcEnv = RE.mkDatabaseContextEvalEnv transId graph dbcFunctionUtils+                      dbcFunctionUtils = DBC.DatabaseContextFunctionUtils {+                        DBC.executeDatabaseContextExpr =+                            \ctx' dbexpr ->+                              case resolveRoleIds roleNameResolver dbexpr of+                                Left err -> Left err+                                Right expr'' ->+                                  case RE.runDatabaseContextEvalMonad ctx' dbcEnv (optimizeAndEvalDatabaseContextExpr True expr'') of+                                    Left err -> Left err+                                    Right reState -> pure (RE.dbc_context reState)+                              ,+                        DBC.executeRelationalExpr =+                        \ctx' relExpr ->+                          let reEnv = RE.mkRelationalExprEnv ctx' graph in +                          optimizeAndEvalRelationalExpr reEnv relExpr+                        }+                  case Schema.evalSchemaExpr schemaExpr context transId graph dbcFunctionUtils subschemas' of+                    Left err -> pure (Left err)+                    Right (newSubschemas, newContext) -> do+                      --hm- maybe we should start using lenses+                      let discon = Sess.disconnectedTransaction session +                          newSchemas = Schemas newContext (ValueMarker newSubschemas)+                          newSession = Session (DisconnectedTransaction {+                                                   disconTransactionId = Discon.parentId discon,+                                                   disconSchemas = newSchemas,+                                                   disconCurrentHead = Discon.disconCurrentHead (Sess.disconnectedTransaction session) }) (Sess.schemaName session)+                      StmMap.insert newSession sessionId sessions+                      pure (Right ()) executeSchemaExpr sessionId conn@(RemoteConnection _) schemaExpr = remoteCall conn (ExecuteSchemaExpr sessionId schemaExpr)            -- | After modifying a 'DatabaseContext', 'commit' the transaction to the transaction graph at the head which the session is referencing. This will also trigger checks for any notifications which need to be propagated. commit :: SessionId -> Connection -> IO (Either RelationalError ())-commit sessionId conn@(InProcessConnection _) = executeGraphExpr sessionId conn Commit -commit sessionId conn@(RemoteConnection _) = remoteCall conn (ExecuteGraphExpr sessionId Commit)+commit sessionId conn@(InProcessConnection _) = executeAlterTransactionGraphExpr sessionId conn Commit +commit sessionId conn@(RemoteConnection _) = remoteCall conn (ExecuteAlterTransactionGraphExpr sessionId Commit) -sendNotifications :: [ClientInfo] -> EvaluatedNotifications -> IO ()-sendNotifications clients notifs =+-- | Sends notifications to client who have registered notifications. Only sends notifications to roles which have the AccessRelVarsPermission.+sendNotifications :: InProcessConnectionConf -> RelVarAccessControlList -> [ClientInfo] -> EvaluatedNotifications -> IO ()+sendNotifications conf acl' clients notifs =   unless (M.null notifs) $ forM_ clients sender  where-  sender (RemoteClientInfo sock) = RPC.sendMessage sock (NotificationMessage notifs)+   --check if role has access to relvars based on the context- make sure that roles which have had permission in the past but have had it revoked no longer get notifications- find a solution to send notifications for changes in DBC function results.+  sender (RemoteClientInfo sock roleName) = do+    eRoles <- LoginRoles.roleIdsForRoleName roleName (ipLoginRoles conf)+    case eRoles of+      Left _err -> pure ()+      Right roleIds ->+        when (hasAccess roleIds AccessRelVarsPermission acl') $+          SRPC.sendMessage sock (NotificationMessage notifs)   sender (InProcessClientInfo tvar) = putMVar tvar notifs --- | Discard any changes made in the current 'Session' and 'DatabaseContext'. This resets the disconnected transaction to reference the original database context of the parent transaction and is a very cheap operation.+-- | Discard any changes made in the current 'Session' and 'DatabaseContext'. This resets the disconnected transaction to reference the original database context of the parent transaction and is a very cheap operation. Requires CommitTransactionPermission. rollback :: SessionId -> Connection -> IO (Either RelationalError ())-rollback sessionId conn@(InProcessConnection _) = executeGraphExpr sessionId conn Rollback      -rollback sessionId conn@(RemoteConnection _) = remoteCall conn (ExecuteGraphExpr sessionId Rollback)+rollback sessionId conn@(InProcessConnection _) = executeAlterTransactionGraphExpr sessionId conn Rollback >> pure (Right ())+rollback sessionId conn@(RemoteConnection _) = remoteCall conn (ExecuteAlterTransactionGraphExpr sessionId Rollback)  -- | Write the transaction graph to disk. This function can be used to incrementally write new transactions to disk.-processTransactionGraphPersistence :: PersistenceStrategy -> [TransactionId] -> TransactionGraph -> IO ()-processTransactionGraphPersistence NoPersistence _ _ = pure ()-processTransactionGraphPersistence (MinimalPersistence dbdir) transIds graph = void $ transactionGraphPersist NoDiskSync dbdir transIds graph-processTransactionGraphPersistence (CrashSafePersistence dbdir) transIds graph = void $ transactionGraphPersist FsyncDiskSync dbdir transIds graph+processTransactionGraphPersistence :: PersistenceStrategy -> TransactionGraphIncrementalWriteInfo -> IO ()+processTransactionGraphPersistence NoPersistence _ = pure ()+processTransactionGraphPersistence (MinimalPersistence dbdir) tWriteInfo = void $ transactionGraphPersistIncremental NoDiskSync dbdir tWriteInfo+processTransactionGraphPersistence (CrashSafePersistence dbdir) tWriteInfo = void $ transactionGraphPersistIncremental FsyncDiskSync dbdir tWriteInfo  readGraphTransactionIdDigest :: PersistenceStrategy -> IO LockFileHash readGraphTransactionIdDigest NoPersistence = error "attempt to read digest from transaction log without persistence enabled" readGraphTransactionIdDigest (MinimalPersistence dbdir) = readGraphTransactionIdFileDigest dbdir  readGraphTransactionIdDigest (CrashSafePersistence dbdir) = readGraphTransactionIdFileDigest dbdir  --- | Return a relation whose type would match that of the relational expression if it were executed. This is useful for checking types and validating a relational expression's types.+-- | Return a relation whose type would match that of the relational expression if it were executed. This is useful for checking types and validating a relational expression's types. If relvars are mentioned, requires AccessRelVarsPermission. If functions are mentioned, requires ViewFunctionPermission. typeForRelationalExpr :: SessionId -> Connection -> RelationalExpr -> IO (Either RelationalError Relation)-typeForRelationalExpr sessionId conn@(InProcessConnection _) relExpr = atomically $ typeForRelationalExprSTM sessionId conn relExpr+typeForRelationalExpr sessionId (InProcessConnection conf) relExpr = do+  roleIds <- roleIdsForRoleName conf+  atomically $ do+    eSession <- sessionAndSchema sessionId conf+    case eSession of+      Left err -> pure $ Left err+      Right (session, _schema) -> do+        graph <- readTVar (ipTransactionGraph conf)+        let dbctx = Sess.concreteDatabaseContext session+            reEnv = RE.mkRelationalExprEnv dbctx graph+        case RE.resolveDBC' graph (RE.re_context reEnv) DBC.acl of+          Left err -> pure (Left err)+          Right acl' -> do+            case applyACLRelationalExpr roleIds (relvarsACL acl') relExpr of+              Left err -> pure (Left err)+              Right () ->+                typeForRelationalExprSTM sessionId conf relExpr typeForRelationalExpr sessionId conn@(RemoteConnection _) relExpr = remoteCall conn (ExecuteTypeForRelationalExpr sessionId relExpr)     -typeForRelationalExprSTM :: SessionId -> Connection -> RelationalExpr -> STM (Either RelationalError Relation)    -typeForRelationalExprSTM sessionId (InProcessConnection conf) relExpr = do-  let sessions = ipSessions conf-  eSession <- sessionAndSchema sessionId sessions+typeForRelationalExprSTM :: SessionId -> InProcessConnectionConf -> RelationalExpr -> STM (Either RelationalError Relation)    +typeForRelationalExprSTM sessionId conf relExpr = do+  eSession <- sessionAndSchema sessionId conf   case eSession of     Left err -> pure $ Left err     Right (session, schema) -> do@@ -776,45 +1045,50 @@         Right relExpr' -> do           graph <- readTVar (ipTransactionGraph conf)                     let reEnv = RE.mkRelationalExprEnv (Sess.concreteDatabaseContext session) graph-          pure $ RE.runRelationalExprM reEnv (RE.typeForRelationalExpr relExpr') -    -typeForRelationalExprSTM _ _ _ = error "typeForRelationalExprSTM called on non-local connection"-+          pure $ RE.runRelationalExprM reEnv (RE.typeForRelationalExpr relExpr')+           -- | Return a 'Map' of the database's constraints at the context of the session and connection. inclusionDependencies :: SessionId -> Connection -> IO (Either RelationalError InclusionDependencies) inclusionDependencies sessionId (InProcessConnection conf) = do-  let sessions = ipSessions conf   atomically $ do-    eSession <- sessionAndSchema sessionId sessions+    eSession <- sessionAndSchema sessionId conf     case eSession of       Left err -> pure $ Left err        Right (session, schema) -> do+            graph <- readTVar (ipTransactionGraph conf)                     let context = Sess.concreteDatabaseContext session-            if schemaName session == defaultSchemaName then-              pure $ Right (B.inclusionDependencies context)-              else-              pure (Schema.inclusionDependenciesInSchema schema (B.inclusionDependencies context))+            case RE.resolveDBC' graph context DBC.inclusionDependencies of+              Left err -> pure (Left err)+              Right incDeps -> do+                if schemaName session == defaultSchemaName then+                  pure (Right incDeps)+                  else+                    pure $ Schema.inclusionDependenciesInSchema schema incDeps  inclusionDependencies sessionId conn@(RemoteConnection _) = remoteCall conn (RetrieveInclusionDependencies sessionId)  typeConstructorMapping :: SessionId -> Connection -> IO (Either RelationalError TypeConstructorMapping) typeConstructorMapping sessionId (InProcessConnection conf) = do-  let sessions = ipSessions conf   atomically $ do-    eSession <- sessionAndSchema sessionId sessions+    eSession <- sessionAndSchema sessionId conf     case eSession of       Left err -> pure $ Left err -      Right (session, _) -> --warning, no schema support for typeconstructors-        pure (Right (B.typeConstructorMapping (Sess.concreteDatabaseContext session)))+      Right (session, _) -> do --warning, no schema support for typeconstructors+        let context = Sess.concreteDatabaseContext session+        graph <- readTVar (ipTransactionGraph conf)            +        case RE.resolveDBC' graph context DBC.typeConstructorMapping of+          Left err -> pure (Left err)+          Right tConsMap ->+            pure (Right tConsMap) typeConstructorMapping sessionId conn@(RemoteConnection _) = remoteCall conn (RetrieveTypeConstructorMapping sessionId)    -- | Return an optimized database expression which is logically equivalent to the input database expression. This function can be used to determine which expression will actually be evaluated. planForDatabaseContextExpr :: SessionId -> Connection -> DatabaseContextExpr -> IO (Either RelationalError GraphRefDatabaseContextExpr)   planForDatabaseContextExpr sessionId (InProcessConnection conf) dbExpr = do-  let sessions = ipSessions conf+  roles <- LoginRoles.allRoles (ipLoginRoles conf)   atomically $ do     graph <- readTVar (ipTransactionGraph conf)    -    eSession <- sessionAndSchema sessionId sessions+    eSession <- sessionAndSchema sessionId conf     case eSession of       Left err -> pure $ Left err        Right (session, _) ->@@ -822,12 +1096,45 @@           let ctx = Sess.concreteDatabaseContext session               transId = Sess.parentId session               gfExpr = runProcessExprM UncommittedContextMarker (processDatabaseContextExpr dbExpr)-          pure $ runGraphRefSOptDatabaseContextExprM transId ctx graph (optimizeGraphRefDatabaseContextExpr gfExpr)+              roleNameResolver nam = fst <$> lookup nam roles+              roleIdResolver roleId = lookup roleId (map (\(a,(b,_c)) -> (b,a)) roles)+          case resolveRoleIds roleNameResolver gfExpr of+            Left err -> pure (Left err)+            Right gfExpr' -> do+              let dbcFuncUtils = DBC.DatabaseContextFunctionUtils {+                    DBC.executeDatabaseContextExpr = undefined,+                    DBC.executeRelationalExpr = undefined+                    }+              case runGraphRefSOptDatabaseContextExprM transId ctx graph dbcFuncUtils (optimizeGraphRefDatabaseContextExpr gfExpr') of+                Left err -> pure (Left err)+                Right optExpr -> +              -- convert roleIds back roleNames to avoid leaking role ids to the client+                  case resolveRoleNames roleIdResolver optExpr of+                    Left err -> pure (Left err)+                    Right optExpr' -> pure (Right optExpr')         else -- don't show any optimization because the current optimization infrastructure relies on access to the base context- this probably underscores the need for each schema to have its own DatabaseContext, even if it is generated on-the-fly-}           pure (Left NonConcreteSchemaPlanError)  planForDatabaseContextExpr sessionId conn@(RemoteConnection _) dbExpr = remoteCall conn (RetrievePlanForDatabaseContextExpr sessionId dbExpr)-             ++planForRelationalExpr :: SessionId -> Connection -> RelationalExpr -> IO (Either RelationalError T.Text)+planForRelationalExpr sessionId (InProcessConnection conf) rexpr = do+  atomically $ do+    graph <- readTVar (ipTransactionGraph conf)    +    eSession <- sessionAndSchema sessionId conf+    case eSession of+      Left err -> pure $ Left err +      Right (session, schema) ->+        case  Schema.processRelationalExprInSchema schema rexpr of+          Left err -> pure (Left err)+          Right rexpr' -> do+            let ctx = Sess.concreteDatabaseContext session+                gfExpr = runProcessExprM UncommittedContextMarker (processRelationalExpr rexpr')+                gfEnv = RE.freshGraphRefRelationalExprEnv (Just ctx) graph+            pure (renderPretty <$> planGraphRefRelationalExpr gfExpr gfEnv)++planForRelationalExpr sessionId conn@RemoteConnection{} expr = remoteCall conn (RetrievePlanForRelationalExpr sessionId expr)+ -- | Return a relation which represents the current state of the global transaction graph. The attributes are  --    * current- boolean attribute representing whether or not the current session references this transaction --    * head- text attribute which is a non-empty 'HeadName' iff the transaction references a head.@@ -846,13 +1153,19 @@      transactionGraphAsRelation sessionId conn@(RemoteConnection _) = remoteCall conn (RetrieveTransactionGraph sessionId)  +-- | Alter roles (users) which can login to the database.+executeAlterLoginRolesExpr :: SessionId -> Connection -> LoginRoles.AlterLoginRolesExpr -> IO (Either LoginRoles.LoginRoleError LoginRoles.SuccessResult)+executeAlterLoginRolesExpr _sessionId (InProcessConnection conf) expr = do+  LoginRoles.executeAlterLoginRolesExpr (ipRoleName conf) (ipLoginRoles conf) expr+executeAlterLoginRolesExpr sessionId conn@RemoteConnection{} expr = do+  remoteCall conn (ExecuteAlterLoginRolesExpr sessionId expr)+ -- | Returns the names and types of the relation variables in the current 'Session'. relationVariablesAsRelation :: SessionId -> Connection -> IO (Either RelationalError Relation) relationVariablesAsRelation sessionId (InProcessConnection conf) = do-  let sessions = ipSessions conf   atomically $ do     graph <- readTVar (ipTransactionGraph conf)-    eSession <- sessionAndSchema sessionId sessions+    eSession <- sessionAndSchema sessionId conf     case eSession of       Left err -> pure (Left err)       Right (session, schema) -> do@@ -864,10 +1177,9 @@ -- | Returns a relation representing the complete DDL of the current `DatabaseContext`. ddlAsRelation :: SessionId -> Connection -> IO (Either RelationalError Relation) ddlAsRelation sessionId (InProcessConnection conf) = do-  let sessions = ipSessions conf   atomically $ do     graph <- readTVar (ipTransactionGraph conf)-    eSession <- sessionAndSchema sessionId sessions+    eSession <- sessionAndSchema sessionId conf     case eSession of       Left err -> pure (Left err)       Right (session, schema) -> do@@ -878,37 +1190,71 @@ -- | Returns the names and types of the atom functions in the current 'Session'. atomFunctionsAsRelation :: SessionId -> Connection -> IO (Either RelationalError Relation) atomFunctionsAsRelation sessionId (InProcessConnection conf) = do-  let sessions = ipSessions conf   atomically $ do-    eSession <- sessionAndSchema sessionId sessions+    eSession <- sessionAndSchema sessionId conf     case eSession of       Left err -> pure (Left err)-      Right (session, _) -> -        pure (AF.atomFunctionsAsRelation (atomFunctions (concreteDatabaseContext session)))+      Right (session, _) -> do+        graph <- readTVar (ipTransactionGraph conf)+        let context = concreteDatabaseContext session+        case RE.resolveDBC' graph context DBC.atomFunctions of+          Left err -> pure (Left err)+          Right afuncs ->+            pure (AF.atomFunctionsAsRelation afuncs)          atomFunctionsAsRelation sessionId conn@(RemoteConnection _) = remoteCall conn (RetrieveAtomFunctionSummary sessionId)         +-- | Return a relation representing all database context functions. Requires ViewFunctionPermission and ViewDBCFunctionPermission per function. databaseContextFunctionsAsRelation :: SessionId -> Connection -> IO (Either RelationalError Relation) databaseContextFunctionsAsRelation sessionId (InProcessConnection conf) = do-  let sessions = ipSessions conf+  roleIds <- roleIdsForRoleName conf   atomically $ do-    eSession <- sessionAndSchema sessionId sessions+    eSession <- sessionAndSchema sessionId conf     case eSession of       Left err -> pure (Left err)-      Right (session, _) ->-        pure (DCF.databaseContextFunctionsAsRelation (dbcFunctions (concreteDatabaseContext session)))+      Right (session, _) -> do+        graph <- readTVar (ipTransactionGraph conf)+        let context = concreteDatabaseContext session+            reEnv = RE.mkRelationalExprEnv context graph+            requiredPerm = ViewFunctionPermission+        case RE.resolveDBC' graph (RE.re_context reEnv) DBC.acl of+          Left err -> pure (Left err)+          Right acl' -> do+            if hasAccess roleIds requiredPerm (dbcFunctionsACL acl') then+                case RE.resolveDBC' graph context DBC.dbcFunctions of+                  Left err -> pure (Left err)+                  Right dbcFuncs -> do+                    -- filter out dbcFuncs to which this user does not have ViewDBCFunctionPermission+                    let dbcFuncsFiltered = HS.filter dbcFuncFilter dbcFuncs+                        dbcFuncFilter f = hasAccess roleIds ViewDBCFunctionPermission (funcACL f)+                    pure (DCF.databaseContextFunctionsAsRelation dbcFuncsFiltered)+            else+               pure (Left (AccessDeniedError (SomeFunctionPermission requiredPerm)))  databaseContextFunctionsAsRelation sessionId conn@(RemoteConnection _) = remoteCall conn (RetrieveDatabaseContextFunctionSummary sessionId) +-- | Show notifications in a relation format. Requires RelVarsAccessPermission. notificationsAsRelation :: SessionId -> Connection -> IO (Either RelationalError Relation) notificationsAsRelation sessionId (InProcessConnection conf) = do-  let sessions = ipSessions conf+  roleIds <- roleIdsForRoleName conf       atomically $ do-    eSession <- sessionAndSchema sessionId sessions+    eSession <- sessionAndSchema sessionId conf     case eSession of       Left err -> pure (Left err)-      Right (session, schema) ->-        pure (Schema.notificationsAsRelationInSchema (notifications (concreteDatabaseContext session)) schema)+      Right (session, schema) -> do+        graph <- readTVar (ipTransactionGraph conf)+        let context = concreteDatabaseContext session+        case RE.resolveDBC' graph context DBC.notifications of+          Left err -> pure (Left err)+          Right notifs ->+            case relvarsACL <$> RE.resolveDBC' graph context DBC.acl of+              Left err -> pure (Left err)+              Right rvacl' ->+                if hasAccess roleIds AccessRelVarsPermission rvacl' then+                  pure (Schema.notificationsAsRelationInSchema notifs schema)+                else+                  pure (Left (AccessDeniedError (SomeRelVarPermission AccessRelVarsPermission)))                  + notificationsAsRelation sessionId conn@RemoteConnection{} = remoteCall conn (RetrieveNotificationsAsRelation sessionId)  -- | Returns the transaction id for the connection's disconnected transaction committed parent transaction.  @@ -922,27 +1268,22 @@       Right session -> pure $ Right (Sess.parentId session) headTransactionId sessionId conn@(RemoteConnection _) = remoteCall conn (RetrieveHeadTransactionId sessionId)     -headNameSTM_ :: SessionId -> Sessions -> TVar TransactionGraph -> STM (Either RelationalError HeadName)  -headNameSTM_ sessionId sessions graphTvar = do-    graph <- readTVar graphTvar+currentHeadSTM_ :: SessionId -> Sessions -> STM (Either RelationalError Discon.CurrentHead)  +currentHeadSTM_ sessionId sessions = do     eSession <- sessionForSessionId sessionId sessions     case eSession of       Left err -> pure (Left err)-      Right session -> case RE.transactionForId (Sess.parentId session) graph of-        Left err -> pure (Left err)-        Right parentTrans -> case headNameForTransaction parentTrans graph of-          Nothing -> pure (Left UnknownHeadError)-          Just headName' -> pure (Right headName')+      Right session ->+        pure (Right (Discon.disconCurrentHead (Sess.disconnectedTransaction session)))   --- | Returns Just the name of the head of the current disconnected transaction or Nothing.    -headName :: SessionId -> Connection -> IO (Either RelationalError HeadName)-headName sessionId (InProcessConnection conf) = do+-- | Returns Just the current head of the current disconnected transaction which may be a branch name or a transaction id.+currentHead :: SessionId -> Connection -> IO (Either RelationalError Discon.CurrentHead)+currentHead sessionId (InProcessConnection conf) = do   let sessions = ipSessions conf-      graphTvar = ipTransactionGraph conf-  atomically (headNameSTM_ sessionId sessions graphTvar)-headName sessionId conn@(RemoteConnection _) = remoteCall conn (ExecuteHeadName sessionId)+  atomically (currentHeadSTM_ sessionId sessions)+currentHead sessionId conn@(RemoteConnection _) = remoteCall conn (ExecuteHeadName sessionId) --- | Returns a listing of all available atom types.+-- | Returns a listing of all available atom types. Requires no specific permission. atomTypesAsRelation :: SessionId -> Connection -> IO (Either RelationalError Relation) atomTypesAsRelation sessionId (InProcessConnection conf) = do   let sessions = ipSessions conf@@ -950,10 +1291,15 @@     eSession <- sessionForSessionId sessionId sessions     case eSession of       Left err -> pure (Left err)-      Right session ->-        case typesAsRelation (B.typeConstructorMapping (Sess.concreteDatabaseContext session)) of+      Right session -> do+        graph <- readTVar (ipTransactionGraph conf)+        let context = concreteDatabaseContext session+        case RE.resolveDBC' graph context DBC.typeConstructorMapping of           Left err -> pure (Left err)-          Right rel -> pure (Right rel)+          Right tConsMap ->+            case typesAsRelation tConsMap of+              Left err -> pure (Left err)+              Right rel -> pure (Right rel) atomTypesAsRelation sessionId conn@(RemoteConnection _) = remoteCall conn (RetrieveAtomTypesAsRelation sessionId)  disconnectedTransactionIsDirty :: SessionId -> Connection -> IO (Either RelationalError Bool)@@ -964,7 +1310,7 @@     case eSession of       Left err -> pure (Left err)       Right session ->-        pure (Right (isDirty session))+        pure (Right (Sess.isUpdated session)) disconnectedTransactionIsDirty sessionId conn@(RemoteConnection _) = remoteCall conn (RetrieveSessionIsDirty sessionId)          --used only for testing- we expect this to throw an exception@@ -988,10 +1334,11 @@ disconnectedTransaction_ _ _= error "remote connection used"  -- wrap a graph evaluation in file locking+-- the wrapped function returns multiple disconnected transaction and transaction ids because we anticipate coalescing multiple in-flight commits into one big fsync commitLock_ :: SessionId ->                 InProcessConnectionConf ->                 (TransactionGraph -> -                STM (Either RelationalError (DisconnectedTransaction, TransactionGraph, [TransactionId]))) -> +                STM (Either RelationalError (DisconnectedTransaction, TransactionGraphIncrementalWriteInfo))) ->                 IO (Either RelationalError ()) commitLock_ sessionId conf stmBlock = do   let sessions = ipSessions conf@@ -1033,29 +1380,35 @@         case eRefreshedGraph of           Left err -> pure (Left (DatabaseLoadError err))           Right refreshedGraph -> do-            eGraph <- stmBlock refreshedGraph-            case eGraph of+            eTransWriteInfo <- stmBlock refreshedGraph+            case eTransWriteInfo of               Left err -> pure (Left err)-              Right (discon', graph', transactionIdsToPersist) -> do-                writeTVar graphTvar graph'-                let newSession = Session discon' (Sess.schemaName session)-                StmMap.insert newSession sessionId sessions-                case RE.transactionForId (Sess.parentId session) oldGraph of-                  Left err -> pure $ Left err-                  Right previousTrans ->-                    if not (Prelude.null transactionIdsToPersist) then do-                      (evaldNots, nodes) <- executeCommitExprSTM_ graph' (Trans.concreteDatabaseContext previousTrans) (Sess.concreteDatabaseContext session) clientNodes-                      nodesToNotify <- stmSetToList nodes-                      pure $ Right (evaldNots, nodesToNotify, graph', transactionIdsToPersist)-                    else pure (Right (M.empty, [], graph', []))+              Right (discon, tWriteInfo) -> do+                writeTVar graphTvar (newGraph tWriteInfo)+                let newSession = Session discon (Sess.schemaName session)+                    dbctx = Discon.concreteDatabaseContext discon+                case RE.resolveDBC' (newGraph tWriteInfo) dbctx DBC.acl of+                  Left err -> pure (Left err)+                  Right acl' -> do+                    let rvacl = relvarsACL acl'+                    StmMap.insert newSession sessionId sessions+                    case RE.transactionForId (Sess.parentId session) oldGraph of+                      Left err -> pure $ Left err+                      Right previousTrans ->+                        if not (Prelude.null (uncommittedTransactions tWriteInfo)) then do+                          (evaldNots, nodes) <- executeCommitExprSTM_ (newGraph tWriteInfo) (Trans.concreteDatabaseContext previousTrans) (Sess.concreteDatabaseContext session) clientNodes+                          clientNodeMap <- stmMapToList nodes+                          let nodesToNotify = map snd clientNodeMap+                          pure $ Right (evaldNots, nodesToNotify, tWriteInfo, rvacl)+                        else pure (Right (M.empty, [], tWriteInfo, rvacl))        --handle notification firing                   case manip of      Left err -> pure (Left err)-    Right (notsToFire, nodesToNotify, newGraph, transactionIdsToPersist) -> do+    Right (notsToFire, nodesToNotify, tWriteInfo, acl') -> do       --update filesystem database, if necessary-      processTransactionGraphPersistence strat transactionIdsToPersist newGraph-      sendNotifications nodesToNotify notsToFire+      processTransactionGraphPersistence strat tWriteInfo+      sendNotifications conf acl' nodesToNotify notsToFire       pure (Right ())  -- | Runs an IO monad, commits the result when the monad returns no errors, otherwise, rolls back the changes and the error.@@ -1082,6 +1435,7 @@                   else -- no updates executed, so don't create a commit                   pure (Right val) +-- | Execute an expression which returns a dataframe. Requires permissions to run the underlying relational expression. executeDataFrameExpr :: SessionId -> Connection -> DF.DataFrameExpr -> IO (Either RelationalError DF.DataFrame) executeDataFrameExpr sessionId conn@(InProcessConnection _) dfExpr = do   eRel <- executeRelationalExpr sessionId conn (DF.convertExpr dfExpr)@@ -1109,7 +1463,8 @@                   dFrame'' = maybe dFrame' (`DF.take'` dFrame') (DF.limit dfExpr)               pure (Right dFrame'') executeDataFrameExpr sessionId conn@(RemoteConnection _) dfExpr = remoteCall conn (ExecuteDataFrameExpr sessionId dfExpr)-        ++-- | Run a check on the transaction graph to validate all merkle hashes. Requires no specific permission. validateMerkleHashes :: SessionId -> Connection -> IO (Either RelationalError ()) validateMerkleHashes sessionId (InProcessConnection conf) = do   let sessions = ipSessions conf@@ -1124,28 +1479,34 @@           Right () -> pure (Right ()) validateMerkleHashes sessionId conn@RemoteConnection{} = remoteCall conn (ExecuteValidateMerkleHashes sessionId) --- | Calculate a hash on the DDL of the current database context (not the graph). This is useful for validating on the client that the database schema meets the client's expectation. Any DDL change will change this hash. This hash does not change based on the current isomorphic schema being examined. This function is not affected by the current schema (since they are all isomorphic anyway, they should return the same hash).+-- | Calculate a hash on the DDL of the current database context (not the graph). This is useful for validating on the client that the database schema meets the client's expectation. Any DDL change will change this hash. This hash does not change based on the current isomorphic schema being examined. This function is not affected by the current schema (since they are all isomorphic anyway, they should return the same hash). Requires AccessRelVarsPermission. getDDLHash :: SessionId -> Connection -> IO (Either RelationalError SecureHash) getDDLHash sessionId (InProcessConnection conf) = do+  roleIds <- roleIdsForRoleName conf         let sessions = ipSessions conf   atomically $ do     eSession <- sessionForSessionId sessionId sessions     case eSession of       Left err -> pure (Left err)       Right session -> do-        let ctx = Sess.concreteDatabaseContext session            +        let ctx = Sess.concreteDatabaseContext session         graph <- readTVar (ipTransactionGraph conf)-        pure (ddlHash ctx graph)+        case RE.resolveDBC' graph ctx DBC.acl of+          Left err -> pure (Left err)+          Right acl' -> +            if hasAccess roleIds AccessRelVarsPermission (relvarsACL acl') then+              pure (ddlHash ctx graph)+            else+               pure (Left (AccessDeniedError (SomeRelVarPermission AccessRelVarsPermission)))               getDDLHash sessionId conn@RemoteConnection{} = remoteCall conn (GetDDLHash sessionId)  -- | Convert a SQL Query expression into a DataFrameExpr. Because the conversion process requires substantial database metadata access (such as retrieving types for various subexpressions), we cannot process SQL client-side. However, the underlying DBMS is completely unaware that the resultant DataFrameExpr has come from SQL. convertSQLQuery :: SessionId -> Connection -> Query -> IO (Either RelationalError DF.DataFrameExpr) convertSQLQuery sessionId (InProcessConnection conf) query = do-  let sessions = ipSessions conf-      graphTvar = ipTransactionGraph conf  +  let graphTvar = ipTransactionGraph conf     atomically $ do     transGraph <- readTVar graphTvar    -    eSession <- sessionAndSchema sessionId sessions+    eSession <- sessionAndSchema sessionId conf     case eSession of       Left err -> pure (Left err)       Right (session, _schema) -> do -- TODO: enable SQL to leverage isomorphic schemas@@ -1161,11 +1522,10 @@  convertSQLDBUpdates :: SessionId -> Connection -> [SQL.DBUpdate] -> IO (Either RelationalError DatabaseContextExpr) convertSQLDBUpdates sessionId (InProcessConnection conf) updates = do-  let sessions = ipSessions conf-      graphTvar = ipTransactionGraph conf  +  let graphTvar = ipTransactionGraph conf     atomically $ do     transGraph <- readTVar graphTvar    -    eSession <- sessionAndSchema sessionId sessions+    eSession <- sessionAndSchema sessionId conf     case eSession of       Left err -> pure (Left err)       Right (session, _schema) -> do -- TODO: enable SQL to leverage isomorphic schemas@@ -1178,40 +1538,86 @@           Right updateExpr -> pure (Right updateExpr) convertSQLDBUpdates sessionId conn@RemoteConnection{} ups = remoteCall conn (ConvertSQLUpdates sessionId ups)    +-- | Registered queries are queries must always typecheck. Return a relation of them. Requires AccessRelVarsPermission. registeredQueriesAsRelation :: SessionId -> Connection -> IO (Either RelationalError Relation) registeredQueriesAsRelation sessionId (InProcessConnection conf) = do-  let sessions = ipSessions conf+  roleIds <- roleIdsForRoleName conf     atomically $ do-    eSession <- sessionAndSchema sessionId sessions+    eSession <- sessionAndSchema sessionId conf     case eSession of       Left err -> pure (Left err)       Right (session, schema) -> do-        let ctx = Sess.concreteDatabaseContext session        -        pure $ registeredQueriesAsRelationInSchema schema (registeredQueries ctx)+        graph <- readTVar (ipTransactionGraph conf)        +        let context = Sess.concreteDatabaseContext session+        case RE.resolveDBC' graph context DBC.acl of+          Left err -> pure (Left err)+          Right acl' -> +            if hasAccess roleIds AccessRelVarsPermission (relvarsACL acl') then+              case RE.resolveDBC' graph context DBC.registeredQueries of+                Left err -> pure (Left err)+                Right regQs ->+                  pure $ registeredQueriesAsRelationInSchema schema regQs+            else+               pure (Left (AccessDeniedError (SomeRelVarPermission AccessRelVarsPermission)))                             registeredQueriesAsRelation sessionId conn@RemoteConnection{} = remoteCall conn (RetrieveRegisteredQueries sessionId)         -type ClientNodes = StmSet.Set ClientInfo+type ClientNodes = StmMap.Map SRPC.ClientConnectionId ClientInfo  -- internal structure specific to in-process connections data InProcessConnectionConf = InProcessConnectionConf {   ipPersistenceStrategy :: PersistenceStrategy,    ipClientNodes :: ClientNodes, -  ipSessions :: Sessions, +  ipSessions :: Sessions,   ipTransactionGraph :: TVar TransactionGraph,   ipScriptSession :: Maybe ScriptSession,   ipLocks :: Maybe (LockFile, MVar LockFileHash), -- nothing when NoPersistence-  ipCallbackAsync :: Async ()+  ipCallbackAsync :: Async (),+  ipRelExprCache :: RelExprCache, -- can the remote client also include such a pinned expr cache? should that cache be controlled by the server or client?+  ipLoginRoles :: LoginRoles.LoginRolesDB, -- ^ roles allowed to connect to the database, access control is otherwise handled by ACLs in the database context+  ipRoleName :: RoleName, -- ^ role name for the user accessing the database+  ipRandomGen :: StdGen -- ^ random number generator   }  -- clients may connect associate one socket/mvar with the server to register for change callbacks-data ClientInfo = RemoteClientInfo (RPC.Locking Socket) |+data ClientInfo = RemoteClientInfo SRPC.SocketContext RoleName |                   InProcessClientInfo (MVar EvaluatedNotifications)  instance Eq ClientInfo where-  (RemoteClientInfo a) == (RemoteClientInfo b) = RPC.lockless a == RPC.lockless b+  (RemoteClientInfo a roleNameA) == (RemoteClientInfo b roleNameB) = a == b && roleNameA == roleNameB   (InProcessClientInfo a) == (InProcessClientInfo b) = a == b   _ == _ = False  instance Hashable ClientInfo where-  hashWithSalt salt (RemoteClientInfo sock) = hashWithSalt salt (show (RPC.lockless sock))+  hashWithSalt salt (RemoteClientInfo sockCtx roleName) = salt `hashWithSalt` show (SRPC.lockless (SRPC.lockingSocket sockCtx)) `hashWithSalt` roleName   hashWithSalt salt (InProcessClientInfo _) = hashWithSalt salt (1::Int)++data TlsConfig = TlsConfig+  {+    serverTlsHostName :: String,+    serverTlsServiceName :: String,+    serverX509PublicPrivateKeyPaths :: Maybe (FilePath, FilePath),+    serverX509CertificatePath :: Maybe FilePath -- ^ Using Nothing indicates referencing the system certificate store.+  }+  deriving Show++roleIdsForRoleName :: InProcessConnectionConf -> IO [RoleId]+roleIdsForRoleName conf = do+  eRoles <- LoginRoles.roleIdsForRoleName (ipRoleName conf) (ipLoginRoles conf)+  --ignore errors and expect ACL functions to handle empty role id list+  case eRoles of+    Left _err -> pure []+    Right roleIds -> pure roleIds++primaryRoleIdForRoleName :: InProcessConnectionConf -> IO RoleId+primaryRoleIdForRoleName conf = do+  eRoleId <- LoginRoles.roleIdForRoleName (ipRoleName conf) (ipLoginRoles conf)+  case eRoleId of+    Left _err -> error ("role id for role name \"" <> T.unpack (ipRoleName conf) <> "\" no longer exists")+    Right roleId -> pure roleId++-- | Useful for in-process connections to change the role related to access control. Remote connections authenticate via TLS, so require new connections to change roles.+setRoleName :: RoleName -> Connection -> Connection+setRoleName newRoleName (InProcessConnection conf) =+  InProcessConnection (conf { ipRoleName = newRoleName })+setRoleName _ RemoteConnection{} = error "setRoleName can only be used with in-process connections"+  

@@ -78,10 +78,11 @@ -- | Same as 'withTransaction' except that the merge strategy can be specified. withTransactionUsing :: DbConn -> MergeStrategy -> Db a -> IO (Either DbError a) withTransactionUsing (sess, conn) strat dbm = do-  eHeadName <- C.headName sess conn+  eHeadName <- C.currentHead sess conn   case eHeadName of     Left err -> pure (Left (RelError err))-    Right headName -> do+    Right (C.CurrentHeadTransactionId tid) -> pure (Left (RelError (MergeTransactionError (DisconnectedTransactionNotAMergeHeadError tid))))+    Right (C.CurrentHeadBranch headName) -> do       let successFunc = C.autoMergeToHead sess conn strat headName           block = runReaderT (runDb dbm) (sess, conn)           handler :: TransactionCancelled -> IO (Either DbError a)

@@ -10,32 +10,45 @@ import ProjectM36.AtomFunction import ProjectM36.DatabaseContextFunction import ProjectM36.IsomorphicSchema+import ProjectM36.DatabaseContext.Types+import ProjectM36.TransactionGraph.Types+import ProjectM36.IsomorphicSchema.Types --- | 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.+-- | 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. The database context is fully resolved and materialized so that no references to previous transactions exist in the hash calculation. ddlHash :: DatabaseContext -> TransactionGraph -> Either RelationalError SecureHash ddlHash ctx tgraph = do   -- we cannot merely hash the relational representation of the type because the order of items matters when hashing   -- 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.   rvtypemap <- typesForRelationVariables ctx tgraph-  pure $ mkDDLHash ctx rvtypemap+  resDBContext <- toResolvedDatabaseContext ctx tgraph+  pure $ mkDDLHash resDBContext rvtypemap  -- | Process all relations within the context of the transaction graph to extract the relation variables types. typesForRelationVariables :: DatabaseContext -> TransactionGraph -> Either RelationalError (M.Map RelVarName Relation) typesForRelationVariables ctx tgraph = do+  rvs <- resolveDBC' tgraph ctx relationVariables   let gfEnv = freshGraphRefRelationalExprEnv (Just ctx) tgraph   M.fromList <$> mapM (\(rvname, rvexpr) -> do            rvtype <- runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr rvexpr)            pure (rvname, rvtype)-                      ) (M.toList (relationVariables ctx))+                      ) (M.toList rvs)   -- | Return a Relation which represents the database context's current DDL schema. ddlType :: Schema -> DatabaseContext -> TransactionGraph -> Either RelationalError Relation ddlType schema ctx tgraph = do-  incDepsRel <- inclusionDependenciesInSchema schema (inclusionDependencies ctx) >>= inclusionDependenciesAsRelation-  atomFuncsRel <- atomFunctionsAsRelation (atomFunctions ctx)-  dbcFuncsRel <- databaseContextFunctionsAsRelation (dbcFunctions ctx)-  typesRel <- typesAsRelation (typeConstructorMapping ctx)+  incDeps <- resolveDBC' tgraph ctx inclusionDependencies+  incDepsRel <- inclusionDependenciesInSchema schema incDeps >>= inclusionDependenciesAsRelation++  atomFuncs <- resolveDBC' tgraph ctx atomFunctions+  atomFuncsRel <- atomFunctionsAsRelation atomFuncs++  dbcFuncs <- resolveDBC' tgraph ctx dbcFunctions+  dbcFuncsRel <- databaseContextFunctionsAsRelation dbcFuncs++  tConsMap <- resolveDBC' tgraph ctx typeConstructorMapping+  typesRel <- typesAsRelation tConsMap+     relvarTypesRel <- relationVariablesAsRelationInSchema ctx schema tgraph   let attrsAssocs = [("inclusion_dependencies", incDepsRel),                      ("atom_functions", atomFuncsRel),

@@ -15,7 +15,8 @@                TextAtom textIn:_ -> case B64.decode (TE.encodeUtf8 textIn) of                    Left err -> Left (AtomFunctionBytesDecodingError err)                    Right bs -> pure (ByteStringAtom bs)-               _ -> Left AtomFunctionTypeMismatchError+               _ -> Left AtomFunctionTypeMismatchError,+             funcACL = ()                }   ]        

@@ -12,7 +12,8 @@                                      funcBody = compiledAtomFunctionBody $                                        \case                                          IntegerAtom epoch:_ -> pure (DateTimeAtom (posixSecondsToUTCTime (realToFrac epoch)))-                                         _ -> Left AtomFunctionTypeMismatchError+                                         _ -> Left AtomFunctionTypeMismatchError,+                                     funcACL = ()                                      }]                                                   

@@ -13,13 +13,15 @@                  funcBody = compiledAtomFunctionBody $                             \case                               IntegerAtom year:IntegerAtom month:IntegerAtom day:_ -> pure $ DayAtom (fromGregorian (fromIntegral year) (fromIntegral month) (fromIntegral day))-                              _ -> Left AtomFunctionTypeMismatchError+                              _ -> Left AtomFunctionTypeMismatchError,+                 funcACL = ()                  },   Function { funcName = "dayEarlierThan",                  funcType = [DayAtomType, DayAtomType, BoolAtomType],                  funcBody = compiledAtomFunctionBody $                             \case                               ConstructedAtom _ _ (IntAtom dayA:_):ConstructedAtom _ _ (IntAtom dayB:_):_ -> pure (BoolAtom (dayA < dayB))-                              _ -> Left AtomFunctionTypeMismatchError+                              _ -> Left AtomFunctionTypeMismatchError,+                funcACL = ()                }   ]

@@ -112,7 +112,8 @@                      createInterval atom1 atom2 bopen eopen                      else                      Left (AtomTypeDoesNotSupportIntervalError (prettyAtomType aType))-               _ -> Left AtomFunctionTypeMismatchError+               _ -> Left AtomFunctionTypeMismatchError,+             funcACL = ()                },   Function {     funcName = "interval_overlaps",@@ -123,7 +124,8 @@       \case         i1@ConstructedAtom{}:i2@ConstructedAtom{}:_ ->            BoolAtom <$> intervalOverlaps i1 i2-        _ -> Left AtomFunctionTypeMismatchError+        _ -> Left AtomFunctionTypeMismatchError,+    funcACL = ()           }]                          isIntervalAtomType :: AtomType -> Bool

@@ -41,7 +41,8 @@        \case                (listAtom:_) ->                  IntAtom . fromIntegral <$> listLength listAtom-               _ -> Left AtomFunctionTypeMismatchError+               _ -> Left AtomFunctionTypeMismatchError,+     funcACL = ()      },   Function {     funcName = "maybeHead",@@ -49,7 +50,8 @@     funcBody = FunctionBuiltInBody $                \case                  (listAtom:_) -> listMaybeHead listAtom-                 _ -> Left AtomFunctionTypeMismatchError+                 _ -> Left AtomFunctionTypeMismatchError,+    funcACL = ()     }   ]                     

@@ -22,7 +22,8 @@      funcBody = FunctionBuiltInBody $        \case                ConstructedAtom dConsName _ _:_ -> pure $ BoolAtom (dConsName /= "Nothing")-               _ -> Left AtomFunctionTypeMismatchError+               _ -> Left AtomFunctionTypeMismatchError,+     funcACL = ()      },   Function {      funcName = "fromMaybe",@@ -30,7 +31,8 @@      funcBody = FunctionBuiltInBody $        \case          (defaultAtom:ConstructedAtom dConsName _ (atomVal:_):_) -> if atomTypeForAtom defaultAtom /= atomTypeForAtom atomVal then Left AtomFunctionTypeMismatchError else if dConsName == "Nothing" then pure defaultAtom else pure atomVal-         _ ->Left AtomFunctionTypeMismatchError         +         _ -> Left AtomFunctionTypeMismatchError,+     funcACL = ()      }   ] 

@@ -46,7 +46,8 @@        \case          (nonEmptyListAtom:_) ->            IntAtom . fromIntegral <$> nonEmptyListLength nonEmptyListAtom-         _ -> Left AtomFunctionTypeMismatchError+         _ -> Left AtomFunctionTypeMismatchError,+     funcACL = ()      },   Function {     funcName = "nonEmptyListHead",@@ -54,6 +55,7 @@     funcBody = FunctionBuiltInBody $       \case         (nonEmptyListAtom:_) -> nonEmptyListHead nonEmptyListAtom-        _ -> Left AtomFunctionTypeMismatchError+        _ -> Left AtomFunctionTypeMismatchError,+    funcACL = ()     }   ]

@@ -31,67 +31,79 @@       funcType = [TypeVariableType "a",                   TypeVariableType "b", -- either type could be SQLNullable or a NakedAtom                   nullAtomType BoolAtomType],-      funcBody = FunctionBuiltInBody sqlEquals+      funcBody = FunctionBuiltInBody sqlEquals,+      funcACL = ()       },     Function {       funcName = "sql_and",       funcType = [TypeVariableType "a", TypeVariableType "b", nullAtomType BoolAtomType], -- for a more advanced typechecker, this should be BoolAtomType or SQLNullable BoolAtomType-      funcBody = FunctionBuiltInBody nullAnd+      funcBody = FunctionBuiltInBody nullAnd,+      funcACL = ()       },     Function {       funcName = "sql_or",       funcType = [TypeVariableType "a", TypeVariableType "b", nullAtomType BoolAtomType], -- for a more advanced typechecker, this should be BoolAtomType or SQLNullable BoolAtomType-      funcBody = FunctionBuiltInBody nullOr+      funcBody = FunctionBuiltInBody nullOr,+      funcACL = ()              },     Function {       funcName = "sql_coalesce_bool", -- used in where clause so that NULLs are filtered out       funcType = [TypeVariableType "a",                   BoolAtomType],-      funcBody = FunctionBuiltInBody coalesceBool+      funcBody = FunctionBuiltInBody coalesceBool,+      funcACL = ()       },     Function {       funcName = "sql_add",       funcType = [TypeVariableType "a",                    TypeVariableType "b",                   nullAtomType IntegerAtomType],-      funcBody = FunctionBuiltInBody (sqlIntegerBinaryFunction IntegerAtomType (\a b -> IntegerAtom (a + b)))+      funcBody = FunctionBuiltInBody (sqlIntegerBinaryFunction IntegerAtomType (\a b -> IntegerAtom (a + b))),+      funcACL = ()       },     Function {       funcName = "sql_abs",       funcType = [TypeVariableType "a",                   nullAtomType IntegerAtomType],-      funcBody = FunctionBuiltInBody sqlAbs+      funcBody = FunctionBuiltInBody sqlAbs,+      funcACL = ()       },     Function {       funcName = "sql_negate",       funcType = [TypeVariableType "a",                   nullAtomType IntegerAtomType],-      funcBody = FunctionBuiltInBody (sqlIntegerUnaryFunction IntegerAtomType (\a -> IntegerAtom (- a)))+      funcBody = FunctionBuiltInBody (sqlIntegerUnaryFunction IntegerAtomType (\a -> IntegerAtom (- a))),+      funcACL = ()       },     Function {       funcName = "sql_max",       funcType = foldAtomFuncType (TypeVariableType "a") (nullAtomType IntegerAtomType),-      funcBody = FunctionBuiltInBody sqlMax+      funcBody = FunctionBuiltInBody sqlMax,+      funcACL = ()       },     Function {       funcName = "sql_min",       funcType = foldAtomFuncType (TypeVariableType "a") (nullAtomType IntegerAtomType),-      funcBody = FunctionBuiltInBody sqlMin+      funcBody = FunctionBuiltInBody sqlMin,+      funcACL = ()       },     Function {       funcName = "sql_count",       funcType = foldAtomFuncType (TypeVariableType "a") IntegerAtomType,-      funcBody = FunctionBuiltInBody sqlCount+      funcBody = FunctionBuiltInBody sqlCount,+      funcACL = ()       },     Function {       funcName = "sql_sum",       funcType = foldAtomFuncType (TypeVariableType "a") (nullAtomType IntegerAtomType),-      funcBody = FunctionBuiltInBody sqlSum+      funcBody = FunctionBuiltInBody sqlSum,+      funcACL = ()       },     Function {       funcName = "sql_isnull",       funcType = [TypeVariableType "a", BoolAtomType],-      funcBody = FunctionBuiltInBody sqlIsNull+      funcBody = FunctionBuiltInBody sqlIsNull,+      funcACL = ()       }     ] <> sqlCompareFunctions @@ -104,7 +116,8 @@       Function {       funcName = sql_func,         funcType = [TypeVariableType "a", TypeVariableType "b", nullAtomType BoolAtomType],-        funcBody = FunctionBuiltInBody (sqlCompareFunc (opi, opt))+        funcBody = FunctionBuiltInBody (sqlCompareFunc (opi, opt)),+        funcACL = ()       }     boolNull = nullAtom BoolAtomType Nothing     sqlCompareFunc :: (Integer -> Integer -> Bool, Text -> Text -> Bool) -> [Atom] -> Either AtomFunctionError Atom

@@ -1,51 +1,76 @@-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RankNTypes, MultiParamTypeClasses, ExistentialQuantification #-} module ProjectM36.DatabaseContext where import ProjectM36.Base+import ProjectM36.DatabaseContext.Types as DBT+import ProjectM36.ValueMarker as VM import Control.Monad (void)-import qualified Data.Map as M-import qualified Data.HashSet as HS-import ProjectM36.DataTypes.Basic-import ProjectM36.AtomFunctions.Basic-import ProjectM36.Relation-import ProjectM36.DatabaseContextFunction+import Data.Functor.Identity -empty :: DatabaseContext-empty = DatabaseContext { inclusionDependencies = M.empty, -                          relationVariables = M.empty, -                          notifications = M.empty,-                          atomFunctions = HS.empty,-                          dbcFunctions = HS.empty,-                          typeConstructorMapping = mempty,-                          registeredQueries = mempty }+-- | The DatabaseContext is a snapshot of a database's evolving state and contains everything a database client can change over time.+-- I spent some time thinking about whether the VirtualDatabaseContext/Schema and DatabaseContext data constructors should be the same constructor, but that would allow relation variables to be created in a "virtual" context which would appear to defeat the isomorphisms of the contexts. It should be possible to switch to an alternative schema to view the same equivalent information without information loss. However, allowing all contexts to reference another context while maintaining its own relation variables, new types, etc. could be interesting from a security perspective. For example, if a user creates a new relvar in a virtual context, then does it necessarily appear in all linked contexts? After deliberation, I think the relvar should appear in *all* linked contexts to retain the isomorphic properties, even when the isomorphism is for a subset of the context. This hints that the IsoMorphs should allow for "fall-through"; that is, when a relvar is not defined in the virtual context (for morphing), then the lookup should fall through to the underlying context.+-- | Used for read-only database context within a transaction. +-- | Indicate whether a record field has been changed in this transaction. This is used in the DatabaseContext ot mark fields which have been modified relative to the previous transactions' state as an optimization when persisting transactions on disk.++empty :: DatabaseContext+empty = DatabaseContext { inclusionDependencies = emptyValue, +                          relationVariables = emptyValue,+                          notifications = emptyValue,+                          atomFunctions = emptyValue,+                          dbcFunctions = emptyValue,+                          typeConstructorMapping = emptyValue,+                          registeredQueries = emptyValue,+                          acl = emptyValue            +                          }    -- | Remove TransactionId markers on GraphRefRelationalExpr stripGraphRefRelationalExpr :: GraphRefRelationalExpr -> RelationalExpr stripGraphRefRelationalExpr = void-        --- | convert an existing database context into its constituent expression.   -databaseContextAsDatabaseContextExpr :: DatabaseContext -> DatabaseContextExpr-databaseContextAsDatabaseContextExpr context = MultipleExpr $ relVarsExprs ++ incDepsExprs ++ funcsExprs-  where-    relVarsExprs = map (\(name, rel) -> Assign name (stripGraphRefRelationalExpr rel)) (M.toList (relationVariables context))-    incDepsExprs :: [DatabaseContextExpr]-    incDepsExprs = map (uncurry AddInclusionDependency) (M.toList (inclusionDependencies context))-    funcsExprs = [] -- map (\func -> ) (HS.toList funcs) -- there are no databaseExprs to add atom functions yet-} -basicDatabaseContext :: DatabaseContext-basicDatabaseContext = DatabaseContext { inclusionDependencies = M.empty,-                                         relationVariables = M.fromList [("true", ExistingRelation relationTrue),-                                                                         ("false", ExistingRelation relationFalse)],-                                         atomFunctions = basicAtomFunctions,-                                         dbcFunctions = basicDatabaseContextFunctions,-                                         notifications = M.empty,-                                         typeConstructorMapping = basicTypeConstructorMapping,-                                         registeredQueries = M.singleton "booleans" (Union (RelationVariable "true" ()) (RelationVariable "false" ()))-                                         }+-- | If the database context has any values which do *not* reference previous transactions, it must be new data.+isUpdated :: DatabaseContext -> Bool+isUpdated ctx = or [VM.valueIsUpdated (inclusionDependencies ctx),+                     VM.valueIsUpdated (relationVariables ctx),+                     VM.valueIsUpdated (atomFunctions ctx),+                     VM.valueIsUpdated (dbcFunctions ctx),+                     VM.valueIsUpdated (notifications ctx),+                     VM.valueIsUpdated (typeConstructorMapping ctx),+                     VM.valueIsUpdated (registeredQueries ctx),+                     VM.valueIsUpdated (acl ctx)+                   ]  someDatabaseContextExprs :: [DatabaseContextExpr] -> DatabaseContextExpr someDatabaseContextExprs [s] = s someDatabaseContextExprs (s:ss) = MultipleExpr (s:ss) someDatabaseContextExprs [] = NoOperation +-- | The "fresh" database context is created after a commit, so all values will refer to previous transactions.+freshDatabaseContext :: TransactionId -> DatabaseContext -> DatabaseContext+freshDatabaseContext previousTransactionId ctx =+  DatabaseContext { inclusionDependencies = freshen (inclusionDependencies ctx),+                    relationVariables = freshen (relationVariables ctx),+                    atomFunctions = freshen (atomFunctions ctx),+                    dbcFunctions = freshen (dbcFunctions ctx),+                    notifications = freshen (notifications ctx),+                    typeConstructorMapping = freshen (typeConstructorMapping ctx),+                    registeredQueries = freshen (registeredQueries ctx),+                    acl = freshen (acl ctx)+                  }+  where+    freshen :: forall a. ValueMarker a -> ValueMarker a+    freshen (ValueMarker _) = NotChangedSinceMarker previousTransactionId+    freshen m@NotChangedSinceMarker{} = m+                    +toDatabaseContext :: ResolvedDatabaseContext -> DatabaseContext+toDatabaseContext r =+  DatabaseContext {+    inclusionDependencies = ValueMarker (runIdentity (inclusionDependencies r)),+    relationVariables = ValueMarker (runIdentity (relationVariables r)),+    atomFunctions = ValueMarker (runIdentity (atomFunctions r)),+    dbcFunctions = ValueMarker (runIdentity (dbcFunctions r)),+    notifications = ValueMarker (runIdentity (notifications r)),+    typeConstructorMapping = ValueMarker (runIdentity (typeConstructorMapping r)),+    registeredQueries = ValueMarker (runIdentity (registeredQueries r)),+    acl = ValueMarker (runIdentity (acl r))+    } 

@@ -0,0 +1,23 @@+module ProjectM36.DatabaseContext.Basic where+import ProjectM36.DatabaseContext.Types+import ProjectM36.Base+import ProjectM36.Relation+import ProjectM36.DataTypes.Basic+import ProjectM36.AtomFunctions.Basic+import ProjectM36.DatabaseContextFunctions.Basic+import ProjectM36.AccessControlList as ACL+import qualified Data.Map as M+import Data.Functor.Identity++basicDatabaseContext :: ResolvedDatabaseContext+basicDatabaseContext = DatabaseContext { inclusionDependencies = Identity mempty,+                                         relationVariables =+                                           Identity $ M.fromList [("true", ExistingRelation relationTrue),+                                                                      ("false", ExistingRelation relationFalse)],+                                         atomFunctions = Identity basicAtomFunctions,+                                         dbcFunctions = Identity basicDatabaseContextFunctions,+                                         notifications = Identity mempty,+                                         typeConstructorMapping = Identity basicTypeConstructorMapping,+                                         registeredQueries = Identity $ M.singleton "booleans" (Union (RelationVariable "true" ()) (RelationVariable "false" ())),+                                         acl = Identity ACL.basic+                                         }

@@ -0,0 +1,15 @@+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}+module ProjectM36.DatabaseContext.Fields where+import GHC.Generics+import Control.DeepSeq (NFData)++data DatabaseContextField =+  InclusionDependenciesField |+  RelationVariablesField |+  NotificationsField |+  AtomFunctionsField |+  DbcFunctionsField |+  TypeConstructorMappingField |+  RegisteredQueriesField+  deriving (Show, Eq, NFData, Generic)+

@@ -0,0 +1,12 @@+-- | Include some test utility functions on top of the basic database context.+module ProjectM36.DatabaseContext.SelfTest where+import ProjectM36.DatabaseContext.Types+import ProjectM36.DatabaseContext.Basic+import ProjectM36.AtomFunctions.Basic+import ProjectM36.AtomFunctions.SelfTest+import Data.Functor.Identity++selfTestDatabaseContext :: ResolvedDatabaseContext+selfTestDatabaseContext = basicDatabaseContext {+  atomFunctions = Identity (basicAtomFunctions <> selfTestAtomFunctions)+  }

@@ -0,0 +1,47 @@+{-# LANGUAGE RankNTypes, DeriveGeneric, DeriveAnyClass, MultiParamTypeClasses, ExistentialQuantification, StandaloneDeriving, FlexibleInstances #-}+module ProjectM36.DatabaseContext.Types where+import GHC.Generics+import Control.DeepSeq (NFData)+import ProjectM36.Base+import ProjectM36.Error+import ProjectM36.AccessControlList+import ProjectM36.ValueMarker+import qualified Data.HashSet as HS+import Data.Functor.Identity++data DatabaseContextBase a = DatabaseContext {+  inclusionDependencies :: a InclusionDependencies,+  relationVariables :: a RelationVariables,+  atomFunctions :: a AtomFunctions,+  dbcFunctions :: a DatabaseContextFunctions,+  notifications :: a Notifications,+  typeConstructorMapping :: a TypeConstructorMapping,+  registeredQueries :: a RegisteredQueries,+  acl :: a DatabaseContextACL+  } ++-- | The type of the database context when stored in the graph. It can reference data from other transactions in the graph.+type DatabaseContext = DatabaseContextBase ValueMarker++deriving instance NFData DatabaseContext+deriving instance Generic DatabaseContext++-- | The type of the database context when it is fully resolved (of transaction markers such as in the TransactionRefDatabaseContext); standalone, ready-to-use.+type ResolvedDatabaseContext = DatabaseContextBase Identity++data TransactionIdMarker a = TransactionIdMarker TransactionId a+  deriving (NFData, Generic)++-- | Utility functions to pass to Haskell-written database context functions.+data DatabaseContextFunctionUtils =+  DatabaseContextFunctionUtils {+  executeDatabaseContextExpr :: DatabaseContext -> DatabaseContextExpr -> Either RelationalError DatabaseContext,+  executeRelationalExpr :: DatabaseContext -> RelationalExpr -> Either RelationalError Relation+                               }++type DatabaseContextFunctionBodyType = DatabaseContextFunctionUtils -> [Atom] -> DatabaseContext -> Either RelationalError DatabaseContext+type DatabaseContextFunctions = HS.HashSet DatabaseContextFunction++type DatabaseContextFunction = Function DatabaseContextFunctionBodyType DBCFunctionAccessControlList+type DatabaseContextFunctionBody = FunctionBody DatabaseContextFunctionBodyType+