project-m36 0.9.5 → 0.9.6

raw patch · 35 files changed

+1018/−150 lines, 35 filesdep ~Win32dep ~aesondep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: Win32, aeson, base, base16-bytestring, cassava, curryer-rpc, megaparsec, stm-containers, uuid, winery

API changes (from Hackage documentation)

Files

• Changelog.markdown +7/−0
• README.markdown +1/−0
• project-m36.cabal +13/−4
• src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs +12/−0
• src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs +41/−0
• src/bin/benchmark/OnDiskClient.hs +74/−0
• src/lib/ProjectM36/AtomFunction.hs +0/−12
• src/lib/ProjectM36/AtomType.hs +2/−2
• src/lib/ProjectM36/Base.hs +11/−3
• src/lib/ProjectM36/Client.hs +47/−4
• src/lib/ProjectM36/DDLType.hs +52/−0
• src/lib/ProjectM36/DatabaseContext.hs +6/−15
• src/lib/ProjectM36/DisconnectedTransaction.hs +2/−2
• src/lib/ProjectM36/Error.hs +6/−1
• src/lib/ProjectM36/Function.hs +0/−11
• src/lib/ProjectM36/GraphRefRelationalExpr.hs +0/−2
• src/lib/ProjectM36/HashSecurely.hs +360/−0
• src/lib/ProjectM36/IsomorphicSchema.hs +75/−13
• src/lib/ProjectM36/NormalizeExpr.hs +2/−0
• src/lib/ProjectM36/Persist.hs +2/−0
• src/lib/ProjectM36/RegisteredQuery.hs +19/−0
• src/lib/ProjectM36/Relation/Parse/CSV.hs +33/−30
• src/lib/ProjectM36/RelationalExpression.hs +43/−16
• src/lib/ProjectM36/Serialise/Base.hs +34/−2
• src/lib/ProjectM36/Server.hs +10/−1
• src/lib/ProjectM36/Server/EntryPoints.hs +13/−0
• src/lib/ProjectM36/Server/RemoteCallTypes.hs +9/−0
• src/lib/ProjectM36/StaticOptimizer.hs +2/−1
• src/lib/ProjectM36/Transaction/Persist.hs +19/−4
• src/lib/ProjectM36/TransactionGraph.hs +8/−22
• src/lib/ProjectM36/TransactionGraph/Merge.hs +14/−0
• src/lib/ProjectM36/TransactionGraph/Persist.hs +1/−1
• test/Relation/Basic.hs +1/−1
• test/TutorialD/Interpreter/Import/ImportTest.hs +20/−2
• test/TutorialD/InterpreterTest.hs +79/−1

@@ -1,3 +1,10 @@+# 2022-11-05 (v0.9.6)++* fix tuple context passed down to extended expressions+* add ddl hash- useful for validating that the client supports the current schema+* add registered queries- useful for constraining what DDL can be applied to the database so as not to break client applications+* reduce memory usage during Merkle hashing by an order of magnitude by using strict serialization and hashing+	 # 2022-08-19 (v0.9.5)    * removed necessity for caret "^" when using boolean atom expressions in restriction predicates

@@ -86,6 +86,7 @@ 1. [Replication](docs/replication.markdown) 1. [Basic Operator Benchmarks](https://rawgit.com/agentm/project-m36/master/docs/basic_benchmarks.html) 1. [Merkle Transaction Hashes](docs/merkle_transaction_graph.markdown)+1. [Handling DDL Changes](docs/Handling_DDL_Changes.markdown)  ### Integrations 

@@ -1,6 +1,6 @@ Cabal-Version: 2.2 Name: project-m36-Version: 0.9.5+Version: 0.9.6 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@@ -131,10 +131,13 @@                      ProjectM36.NormalizeExpr,                      ProjectM36.TransactionInfo,                      ProjectM36.WithNameExpr, -                     ProjectM36.Trace+                     ProjectM36.Trace,+                     ProjectM36.HashSecurely,+                     ProjectM36.DDLType,+                     ProjectM36.RegisteredQuery     GHC-Options: -Wall -rdynamic     if os(windows)-      Build-Depends: Win32 >= 2.5.4.1+      Build-Depends: Win32 >= 2.12       Other-Modules: ProjectM36.Win32Handle     else       --219-  too many exported symbols under Windows and GHC 8.4@@ -351,6 +354,7 @@ Test-Suite test-tutoriald-import-tutoriald     import: commontest     type: exitcode-stdio-1.0+    build-depends: warp, wai     main-is: TutorialD/Interpreter/Import/ImportTest.hs     Other-Modules: TutorialD.Interpreter.Base, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Printer @@ -376,11 +380,16 @@     type: exitcode-stdio-1.0     main-is: benchmark/Relation.hs +benchmark ondiskclient+    import: commontest+    type: exitcode-stdio-1.0+    main-is: benchmark/OnDiskClient.hs+    GHC-Options: -rtsopts -Wall -threaded -eventlog -O2 -finfo-table-map -fdistinct-constructor-tables+ Test-Suite test-server     import: commontest     type: exitcode-stdio-1.0     main-is: Server/Main.hs-  Executable Example-SimpleClient     Default-Language: Haskell2010

@@ -36,6 +36,8 @@                                removeAtomFunctionP,                                executeDatabaseContextFunctionP,                                removeDatabaseContextFunctionP,+                               addRegisteredQueryP,+                               removeRegisteredQueryP,                                nothingP]              nothingP :: Parser DatabaseContextExpr            @@ -178,6 +180,16 @@ removeDatabaseContextFunctionP = do   reserved "removedatabasecontextfunction"   RemoveDatabaseContextFunction <$> quotedString++addRegisteredQueryP :: Parser DatabaseContextExpr+addRegisteredQueryP = do+  reserved "registerquery"+  AddRegisteredQuery <$> quotedString <*> relExprP++removeRegisteredQueryP :: Parser DatabaseContextExpr+removeRegisteredQueryP = do+  reserved "unregisterquery"+  RemoveRegisteredQuery <$> quotedString  executeDatabaseContextFunctionP :: Parser DatabaseContextExpr executeDatabaseContextFunctionP = do

@@ -14,8 +14,10 @@ import Control.Monad.State import qualified Data.Text as T import ProjectM36.Relation.Show.Gnuplot+import ProjectM36.HashSecurely import qualified Data.Map as M import Data.Maybe+import Data.Functor  --operators which only rely on database context reading data RODatabaseContextOperator where@@ -29,6 +31,9 @@   ShowAtomFunctions :: RODatabaseContextOperator   ShowDatabaseContextFunctions :: RODatabaseContextOperator   ShowDataFrame :: DF.DataFrameExpr -> RODatabaseContextOperator+  GetDDLHash :: RODatabaseContextOperator+  ShowDDL :: RODatabaseContextOperator+  ShowRegisteredQueries :: RODatabaseContextOperator   Quit :: RODatabaseContextOperator   deriving (Show) @@ -85,6 +90,9 @@              <|> showAtomFunctionsP              <|> showDatabaseContextFunctionsP              <|> showDataFrameP+             <|> ddlHashP+             <|> showDDLP+             <|> showRegisteredQueriesP              <|> quitP  --logically, these read-only operations could happen purely, but not if a remote call is required@@ -158,6 +166,31 @@   case eDataFrame of     Left err -> pure (DisplayErrorResult (T.pack (show err)))     Right dframe -> pure (DisplayDataFrameResult dframe)++evalRODatabaseContextOp sessionId conn GetDDLHash = do+  eHash <- C.getDDLHash sessionId conn+  case eHash of+    Left err -> pure (DisplayErrorResult (T.pack (show err)))+    Right h -> do+      let eRel = mkRelationFromList (C.attributesFromList [Attribute "ddlHash" ByteStringAtomType]) [[ByteStringAtom (_unSecureHash h)]]+      case eRel of+        Left err -> pure (DisplayErrorResult (T.pack (show err)))+        Right rel -> +          evalRODatabaseContextOp sessionId conn (ShowRelation (ExistingRelation rel))++evalRODatabaseContextOp sessionId conn ShowDDL = do+  eDDL <- C.ddlAsRelation sessionId conn+  case eDDL of+    Left err -> pure (DisplayErrorResult (T.pack (show err)))+    Right ddl ->+      evalRODatabaseContextOp sessionId conn (ShowRelation (ExistingRelation ddl))++evalRODatabaseContextOp sessionId conn ShowRegisteredQueries = do+  eRv <- C.registeredQueriesAsRelation sessionId conn+  case eRv of+    Left err -> pure (DisplayErrorResult (T.pack (show err)))+    Right rv ->+      evalRODatabaseContextOp sessionId conn (ShowRelation (ExistingRelation rv))         evalRODatabaseContextOp _ _ Quit = pure QuitResult @@ -208,3 +241,11 @@                                   Attribute "super" TextAtomType                                  ]     +ddlHashP :: Parser RODatabaseContextOperator+ddlHashP = colonOp ":ddlhash" $> GetDDLHash++showDDLP :: Parser RODatabaseContextOperator+showDDLP = colonOp ":showddl" $> ShowDDL++showRegisteredQueriesP :: Parser RODatabaseContextOperator+showRegisteredQueriesP = colonOp ":showregisteredqueries" $> ShowRegisteredQueries

@@ -0,0 +1,74 @@+{-# 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 Data.Text (Text)+import Codec.Winery+import Options.Applicative+import Data.Time.Clock+import GHC.Generics+import Control.DeepSeq+import ProjectM36.Tupleable+import Data.Time.Calendar+import Data.Proxy++data WeatherReading =+  WeatherReading+  { stamp :: UTCTime,+    temperature :: Integer,+    raining :: Bool,+    city :: Text,+    latitude :: Integer,+    longitude :: Integer+    }+   deriving (Generic, Show, Eq, NFData, Tupleable)+   deriving Serialise via WineryRecord WeatherReading++data Opts = Opts { datadir :: FilePath,+                   writeData :: Bool, --read or write mode+                   tupleCount :: Int+                 }++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)++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 []+      eCheck v = do+        x <- v+        case x of +          Left err -> error (show err)+          Right x' -> pure x'+  conn <- eCheck $ connectProjectM36 connInfo+  sessionId <- eCheck $ createSessionAtHead conn "master"+  if writeData opts then do+    putStrLn $ "writing " <> show (tupleCount opts) <> " tuples"+    let baseUTC = UTCTime { utctDay = fromGregorian 2022 2 22,+                            utctDayTime = secondsToDiffTime 0 }+    let addData = map (\i ->+                         WeatherReading { stamp = addUTCTime (secondsToNominalDiffTime (fromIntegral i)) baseUTC,+                                          temperature = i,+                                          raining = even i,+                                          city = "Mexico City",+                                          latitude = i,+                                          longitude = -i+                                        }) [1 .. fromIntegral (tupleCount opts)]+        defineExpr = toDefineExpr (Proxy @WeatherReading) "x"+    insertExpr <- eCheck (pure $ toInsertExpr addData "x")+    eCheck $ executeDatabaseContextExpr sessionId conn defineExpr    +    eCheck $ executeDatabaseContextExpr sessionId conn insertExpr+    eCheck $ commit sessionId conn+    else do+    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" ())+    val <- eCheck $ executeRelationalExpr sessionId conn readOneRow+    print val+    +  +

@@ -10,8 +10,6 @@ import qualified ProjectM36.Attribute as A import qualified Data.HashSet as HS import qualified Data.Text as T-import qualified Data.ByteString.Lazy as BL-import Codec.Winery  foldAtomFuncType :: AtomType -> AtomType -> [AtomType] --the underscore in the attribute name means that any attributes are acceptable@@ -105,16 +103,6 @@         atomFuncTypeToText aFunc = T.intercalate " -> " (map prettyAtomType (funcType aFunc))  --for calculating the merkle hash-hashBytes :: AtomFunction -> BL.ByteString-hashBytes func = BL.fromChunks [serialise (funcName func),-                                serialise (funcType func),-                                bodyBin-                               ]-  where-    bodyBin = case funcBody func of-                FunctionScriptBody mScript _ -> serialise mScript-                FunctionBuiltInBody _ -> ""-                FunctionObjectLoadedBody f m n _ -> serialise (f,m,n)    -- | Used to mark functions which are loaded externally from the server.       externalAtomFunction :: AtomFunctionBodyType -> AtomFunctionBody

@@ -301,9 +301,9 @@                             -- | Validate that the type is provided with complete type variables for type constructors. validateAtomType :: AtomType -> TypeConstructorMapping -> Either RelationalError ()-validateAtomType typ@(ConstructedAtomType tConsName tVarMap) tConss =+validateAtomType (ConstructedAtomType tConsName tVarMap) tConss =   case findTypeConstructor tConsName tConss of -    Nothing -> Left (TypeConstructorAtomTypeMismatch tConsName typ)+    Nothing -> Left (NoSuchTypeConstructorError tConsName)     Just (tConsDef, _) -> case tConsDef of       ADTypeConstructorDef _ tVarNames -> let expectedTyVarNames = S.fromList tVarNames                                               actualTyVarNames = M.keysSet tVarMap

@@ -187,7 +187,7 @@       atomForAttribute attr (RelationTuple attrs tupVec) = case V.findIndex (== attr) (attributesVec attrs) of         Nothing -> Nothing         Just index -> tupVec V.!? index-      atomsEqual = V.all (== True) $ V.map (\attr -> atomForAttribute attr tuple1 == atomForAttribute attr tuple2) (attributesVec attrs1)+      atomsEqual = V.all id $ V.map (\attr -> atomForAttribute attr tuple1 == atomForAttribute attr tuple2) (attributesVec attrs1)  instance NFData RelationTuple where rnf = genericRnf @@ -332,6 +332,10 @@                       deriving (Generic, Show)                        type SchemaIsomorphs = [SchemaIsomorph]++type RegisteredQueryName = StringType++type RegisteredQueries = M.Map RegisteredQueryName RelationalExpr                                data DatabaseContext = DatabaseContext {   inclusionDependencies :: InclusionDependencies,@@ -339,7 +343,8 @@   atomFunctions :: AtomFunctions,   dbcFunctions :: DatabaseContextFunctions,   notifications :: Notifications,-  typeConstructorMapping :: TypeConstructorMapping+  typeConstructorMapping :: TypeConstructorMapping,+  registeredQueries :: RegisteredQueries   } deriving (NFData, Generic)               type IncDepName = StringType             @@ -383,6 +388,9 @@   RemoveDatabaseContextFunction FunctionName |      ExecuteDatabaseContextFunction FunctionName [AtomExprBase a] |++  AddRegisteredQuery RegisteredQueryName RelationalExpr |+  RemoveRegisteredQuery RegisteredQueryName |      MultipleExpr [DatabaseContextExprBase a]   deriving (Show, Read, Eq, Generic, NFData)@@ -485,7 +493,7 @@  -- | An atom expression represents an action to take when extending a relation or when statically defining a relation or a new tuple. data AtomExprBase a = AttributeAtomExpr AttributeName |-                      NakedAtomExpr Atom |+                      NakedAtomExpr !Atom |                       FunctionAtomExpr FunctionName [AtomExprBase a] a |                       RelationAtomExpr (RelationalExprBase a) |                       ConstructedAtomExpr DataConstructorName [AtomExprBase a] a

@@ -35,6 +35,8 @@        setCurrentSchemaName,        transactionGraphAsRelation,        relationVariablesAsRelation,+       registeredQueriesAsRelation,+       ddlAsRelation,        ProjectM36.Client.atomFunctionsAsRelation,        disconnectedTransactionIsDirty,        headName,@@ -45,6 +47,7 @@        defaultRemoteConnectionInfo,        defaultHeadName,        addClientNode,+       getDDLHash,        PersistenceStrategy(..),        RelationalExpr,        RelationalExprBase(..),@@ -126,6 +129,7 @@ import ProjectM36.TransGraphRelationalExpression as TGRE (TransGraphRelationalExpr) import ProjectM36.Persist (DiskSync(..)) import ProjectM36.FileLock+import ProjectM36.DDLType import ProjectM36.NormalizeExpr import ProjectM36.Notifications import ProjectM36.Server.RemoteCallTypes@@ -154,6 +158,8 @@ import qualified ProjectM36.Session as Sess import ProjectM36.Session import ProjectM36.Sessions+import ProjectM36.HashSecurely (SecureHash)+import ProjectM36.RegisteredQuery import GHC.Generics (Generic) import Control.DeepSeq (force) import System.IO@@ -821,13 +827,24 @@       Left err -> pure (Left err)       Right (session, schema) -> do         let context = Sess.concreteDatabaseContext session-        if Sess.schemaName session == defaultSchemaName then-          pure $ RE.relationVariablesAsRelation context graph-          else-          pure $ Schema.relationVariablesAsRelationInSchema context schema graph+        pure $ Schema.relationVariablesAsRelationInSchema context schema graph        relationVariablesAsRelation sessionId conn@(RemoteConnection _) = remoteCall conn (RetrieveRelationVariableSummary sessionId) +-- | 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+    case eSession of+      Left err -> pure (Left err)+      Right (session, schema) -> do+        let context = Sess.concreteDatabaseContext session+        pure (ddlType schema context graph)+ddlAsRelation sessionId conn@RemoteConnection{} = remoteCall conn (RetrieveDDLAsRelation sessionId)+ -- | 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@@ -1065,6 +1082,32 @@           Left merkleErrs -> pure $ Left $ someErrors (map (\(MerkleValidationError tid expected actual) -> MerkleHashValidationError tid expected actual) merkleErrs)           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).+getDDLHash :: SessionId -> Connection -> IO (Either RelationalError SecureHash)+getDDLHash sessionId (InProcessConnection conf) = do+  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            +        graph <- readTVar (ipTransactionGraph conf)+        pure (ddlHash ctx graph)+getDDLHash sessionId conn@RemoteConnection{} = remoteCall conn (GetDDLHash sessionId)++registeredQueriesAsRelation :: SessionId -> Connection -> IO (Either RelationalError Relation)+registeredQueriesAsRelation sessionId (InProcessConnection conf) = do+  let sessions = ipSessions conf+  atomically $ do+    eSession <- sessionAndSchema sessionId sessions+    case eSession of+      Left err -> pure (Left err)+      Right (session, schema) -> do+        let ctx = Sess.concreteDatabaseContext session        +        pure $ registeredQueriesAsRelationInSchema schema (registeredQueries ctx)+registeredQueriesAsRelation sessionId conn@RemoteConnection{} = remoteCall conn (RetrieveRegisteredQueries sessionId)          type ClientNodes = StmSet.Set ClientInfo 

@@ -0,0 +1,52 @@+module ProjectM36.DDLType where+import ProjectM36.HashSecurely+import ProjectM36.Base+import ProjectM36.RelationalExpression+import ProjectM36.Error+import ProjectM36.Attribute+import qualified Data.Map as M+import ProjectM36.Relation+import ProjectM36.InclusionDependency+import ProjectM36.AtomFunction+import ProjectM36.DatabaseContextFunction+import ProjectM36.IsomorphicSchema++-- | 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.+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++-- | 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+  let gfEnv = freshGraphRefRelationalExprEnv (Just ctx) tgraph+  M.fromList <$> mapM (\(rvname, rvexpr) -> do+           rvtype <- runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr rvexpr)+           pure (rvname, rvtype)+                      ) (M.toList (relationVariables ctx))+++-- | 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)+  relvarTypesRel <- relationVariablesAsRelationInSchema ctx schema tgraph+  let attrsAssocs = [("inclusion_dependencies", incDepsRel),+                     ("atom_functions", atomFuncsRel),+                     ("database_context_functions", dbcFuncsRel),+                     ("types", typesRel),+                     ("relation_variables", relvarTypesRel)]+      attrs = attributesFromList $ map (\(n, rv) -> Attribute n (RelationAtomType (attributes rv))) attrsAssocs+      tuples = [[RelationAtom incDepsRel,+                 RelationAtom atomFuncsRel,+                 RelationAtom dbcFuncsRel,+                 RelationAtom typesRel,+                 RelationAtom relvarTypesRel]]+  mkRelationFromList attrs tuples+

@@ -1,3 +1,4 @@+{-# LANGUAGE RankNTypes #-} module ProjectM36.DatabaseContext where import ProjectM36.Base import Control.Monad (void)@@ -6,10 +7,7 @@ import ProjectM36.DataTypes.Basic import ProjectM36.AtomFunctions.Basic import ProjectM36.Relation-import qualified Data.ByteString.Lazy as BL import ProjectM36.DatabaseContextFunction-import Codec.Winery-import ProjectM36.Function as F  empty :: DatabaseContext empty = DatabaseContext { inclusionDependencies = M.empty, @@ -17,8 +15,10 @@                           notifications = M.empty,                           atomFunctions = HS.empty,                           dbcFunctions = HS.empty,-                          typeConstructorMapping = [] }+                          typeConstructorMapping = mempty,+                          registeredQueries = mempty } +   -- | Remove TransactionId markers on GraphRefRelationalExpr stripGraphRefRelationalExpr :: GraphRefRelationalExpr -> RelationalExpr stripGraphRefRelationalExpr = void@@ -39,16 +39,7 @@                                          atomFunctions = basicAtomFunctions,                                          dbcFunctions = basicDatabaseContextFunctions,                                          notifications = M.empty,-                                         typeConstructorMapping = basicTypeConstructorMapping+                                         typeConstructorMapping = basicTypeConstructorMapping,+                                         registeredQueries = M.singleton "booleans" (Union (RelationVariable "true" ()) (RelationVariable "false" ()))                                          } ---for building the Merkle hash-hashBytes :: DatabaseContext -> BL.ByteString-hashBytes ctx = BL.fromChunks [incDeps, rvs, nots, tConsMap] <> atomFs <> dbcFs-  where-    incDeps = serialise (inclusionDependencies ctx)-    rvs = serialise (relationVariables ctx)-    atomFs = HS.foldr (mappend . F.hashBytes) mempty (atomFunctions ctx)-    dbcFs = HS.foldr (mappend . F.hashBytes) mempty (dbcFunctions ctx)-    nots = serialise (notifications ctx)-    tConsMap = serialise (typeConstructorMapping ctx)

@@ -9,9 +9,9 @@ schemas (DisconnectedTransaction _ s _) = s  loadGraphRefRelVarsOnly :: TransactionId -> Schemas -> Schemas-loadGraphRefRelVarsOnly commitId (Schemas ctx@(DatabaseContext _ rv _ _ _ _) subschemas) = +loadGraphRefRelVarsOnly commitId (Schemas concreteCtx subschemas) =    let f k _ = RelationVariable k (TransactionMarker commitId)-      ctx' = ctx { relationVariables = mapWithKey f rv}+      ctx' = concreteCtx { relationVariables = mapWithKey f (relationVariables concreteCtx)}   in Schemas ctx' subschemas  

@@ -105,6 +105,10 @@                       | MerkleHashValidationError TransactionId MerkleHash MerkleHash +                     | RegisteredQueryValidationError RegisteredQueryName RelationalError+                     | RegisteredQueryNameInUseError RegisteredQueryName+                     | RegisteredQueryNameNotInUseError RegisteredQueryName+                      | MultipleErrors [RelationalError]                        deriving (Show,Eq,Generic,Typeable, NFData)  @@ -128,7 +132,8 @@                   DisconnectedTransactionNotAMergeHeadError TransactionId |                   StrategyViolatesComponentMergeError | --failed merge in inc deps, relvars, etc.                   StrategyViolatesRelationVariableMergeError |-                  StrategyViolatesTypeConstructorMergeError+                  StrategyViolatesTypeConstructorMergeError |+                  StrategyViolatesRegisteredQueryMergeError [RegisteredQueryName]                   deriving (Show, Eq, Generic, Typeable)                             instance NFData MergeError where rnf = genericRnf                           

@@ -4,20 +4,9 @@ import ProjectM36.Error import ProjectM36.Serialise.Base () import ProjectM36.ScriptSession-import qualified Data.ByteString.Lazy as BL-import Codec.Winery import qualified Data.HashSet as HS  -- for merkle hash                       -hashBytes :: Function a -> BL.ByteString-hashBytes func = BL.fromChunks [fname, ftype, fbody]-  where-    fname = serialise (funcName func)-    ftype = serialise (funcType func)-    fbody = case funcBody func of-      FunctionScriptBody s _ -> serialise s-      FunctionBuiltInBody _ -> serialise ()-      FunctionObjectLoadedBody a b c _ -> serialise (a,b,c)  -- | Return the underlying function to run the Function. function :: FunctionBody a -> a

@@ -3,8 +3,6 @@ import ProjectM36.Base import qualified Data.Set as S ---import Debug.Trace- data SingularTransactionRef = SingularTransactionRef GraphRefTransactionMarker |                               MultipleTransactionsRef |                               NoTransactionsRef

@@ -0,0 +1,360 @@+-- | A unified class for walking the database structure to produce a hash used for Merkle trees and validation.+{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, RankNTypes, ExistentialQuantification, BangPatterns #-}+module ProjectM36.HashSecurely where+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString as B+import qualified Data.ByteString.Builder as BSB+import qualified Data.ByteString.Builder.Scientific as BSB+import ProjectM36.Base+import ProjectM36.Tuple (tupleAttributes, tupleAtoms)+import ProjectM36.Serialise.Base ()+import ProjectM36.IsomorphicSchema+import ProjectM36.Transaction+import qualified Data.HashSet as HS+import qualified ProjectM36.DataConstructorDef as DC+import ProjectM36.MerkleHash+import Data.List (sortOn)+import qualified Data.Map as M+import qualified ProjectM36.TypeConstructorDef as TCons+import qualified Crypto.Hash.SHA256 as SHA256+import qualified Data.Text.Encoding as TE+import qualified Data.Text as T+import qualified Data.UUID as UUID+import qualified Data.Vector as V+import qualified Data.Set as S+import Data.Time.Calendar+import Data.Time.Clock+import Codec.Winery (Serialise)+import Data.Int (Int64)++newtype SecureHash = SecureHash { _unSecureHash :: B.ByteString }+  deriving (Serialise, Show, Eq)++-- run a SHA256 hasher across the necessary data structures+class HashBytes a where+  hashBytes :: a -> SHA256.Ctx -> SHA256.Ctx++instance HashBytes Atom where+  hashBytes atm ctx =+    case atm of+      IntegerAtom i -> up ("IntegerAtom" <> build (BSB.integerDec i))+      IntAtom i -> up ("IntAtom" <> build (BSB.intDec i))+      ScientificAtom s -> up ("ScientificAtom" <> build (BSB.scientificBuilder s))+      DoubleAtom d -> up ("DoubleAtom" <> build (BSB.doubleDec d))+      TextAtom t -> up ("TextAtom" <> TE.encodeUtf8 t)+      DayAtom d -> up ("DayAtom" <> build (BSB.integerDec (toModifiedJulianDay d)))+      DateTimeAtom dt -> up ("DateTimeAtom" <>+                             build (BSB.integerDec (toModifiedJulianDay (utctDay dt)) <>+                              BSB.integerDec (diffTimeToPicoseconds (utctDayTime dt))))+      ByteStringAtom bs -> up ("ByteStringAtom" <> bs)+      BoolAtom b -> up ("BoolAtom" <> if b then "1" else "0")+      UUIDAtom u -> up ("UUIDAtom" <> BL.toStrict (UUID.toByteString u))+      RelationAtom r -> hashBytesL ctx "RelationAtom" [SHash r]+      RelationalExprAtom e -> hashBytesL ctx "RelationalExprAtom" [SHash e]+      ConstructedAtom d typ args ->+          hashBytesL ctx "ConstructedAtom" ([SHash d, SHash typ] <> map SHash args)+      where+        build = BL.toStrict . BSB.toLazyByteString+        up = SHA256.update ctx+++instance HashBytes T.Text where+  hashBytes t ctx = SHA256.update ctx (TE.encodeUtf8 t)+  +instance HashBytes Relation where+  hashBytes (Relation attrs tupSet) ctx =+    hashBytesL ctx "Relation" [SHash attrs, SHash tupSet]++data SHash = forall a. HashBytes a => SHash !a++hashBytesL :: Foldable f => SHA256.Ctx -> B.ByteString -> f SHash -> SHA256.Ctx+hashBytesL ctx name = foldr (\(SHash i) ctx'@(SHA256.Ctx !bs) -> bs `seq` hashBytes i ctx') (SHA256.update ctx name)++instance HashBytes a => HashBytes (RelationalExprBase a) where+  hashBytes (MakeRelationFromExprs mAttrs tupleExprs) ctx =+    hashBytesL ctx "MakeRelationFromExprs" [SHash mAttrs, SHash tupleExprs]+  hashBytes (MakeStaticRelation attrs tupSet) ctx = -- blowing up here!+    hashBytesL ctx "MakeStaticRelation" [SHash attrs, SHash tupSet]+--  hashBytes _ ctx = ctx+  hashBytes (ExistingRelation (Relation attrs tupSet)) ctx =+    hashBytesL ctx "ExistingRelation" [SHash tupSet, SHash attrs]+  hashBytes (RelationVariable rvName marker) ctx =+    hashBytesL ctx "RelationVariable" [SHash rvName, SHash marker]+  hashBytes (Project attrNames expr) ctx =+    hashBytesL ctx "Project" [SHash attrNames, SHash expr]+  hashBytes (Union exprA exprB) ctx =+    hashBytesL ctx "Union" [SHash exprA, SHash exprB]+  hashBytes (Join exprA exprB) ctx =+    hashBytesL ctx "Join" [SHash exprA, SHash exprB]+  hashBytes (Rename nameA nameB expr) ctx =+    hashBytesL ctx "Rename" [SHash nameA, SHash nameB, SHash expr]+  hashBytes (Difference exprA exprB) ctx =+    hashBytesL ctx "Difference" [SHash exprA, SHash exprB]+  hashBytes (Group names name expr) ctx =+    hashBytesL ctx "Group" [SHash names, SHash name, SHash expr]+  hashBytes (Ungroup name expr) ctx =+    hashBytesL ctx "Ungroup" [SHash name, SHash expr]+  hashBytes (Restrict pred' expr) ctx =+    hashBytesL ctx "Restrict" [SHash pred', SHash expr]+  hashBytes (Equals exprA exprB) ctx =+    hashBytesL ctx "Equals" [SHash exprA, SHash exprB]+  hashBytes (NotEquals exprA exprB) ctx =+    hashBytesL ctx "NotEquals" [SHash exprA, SHash exprB]+  hashBytes (Extend ext expr) ctx =+    hashBytesL ctx "Extend" [SHash ext, SHash expr]+  hashBytes (With withExprs expr) ctx =+    hashBytesL ctx "With" (SHash expr: map SHash (sortOn (\(WithNameExpr rv _, _) -> rv) withExprs))++instance HashBytes a => HashBytes (AttributeNamesBase a) where+  hashBytes (AttributeNames s) ctx = hashBytesL ctx "AttributeNames" (map SHash (S.toAscList s))+  hashBytes (InvertedAttributeNames s) ctx = hashBytesL ctx "InvertedAttributeNames" (map SHash (S.toAscList s))+  hashBytes (UnionAttributeNames a b) ctx = hashBytesL ctx "UnionAttributeNames" [SHash a, SHash b]+  hashBytes (IntersectAttributeNames a b) ctx = hashBytesL ctx "IntersectAttributeNames" [SHash a, SHash b]+  hashBytes (RelationalExprAttributeNames r) ctx = hashBytesL ctx "RelationalExprAttributeNames" [SHash r]++instance HashBytes a => HashBytes (ExtendTupleExprBase a) where+  hashBytes (AttributeExtendTupleExpr name expr) ctx =+    hashBytesL ctx "AttributeExtendTupleExpr" [SHash name, SHash expr]++instance HashBytes a => HashBytes (WithNameExprBase a) where+  hashBytes (WithNameExpr rv marker) ctx = hashBytesL ctx "WithNameExpr" [SHash rv, SHash marker]+  +instance HashBytes GraphRefTransactionMarker where+  hashBytes (TransactionMarker tid) ctx = SHA256.update ctx (BL.toStrict ("TransactionMarker" <> UUID.toByteString tid))+  hashBytes UncommittedContextMarker ctx = SHA256.update ctx "UncommittedContextMarker"+++instance HashBytes a => HashBytes (TupleExprBase a) where+  hashBytes (TupleExpr exprMap) ctx =+    foldr (\(attrName, atomExpr) ctx' ->+             hashBytesL ctx' "TupleExpr" [SHash attrName, SHash atomExpr]) +    ctx (M.toAscList exprMap)++instance HashBytes a => HashBytes (AtomExprBase a) where+  hashBytes atomExpr ctx =+    case atomExpr of+      (AttributeAtomExpr a) -> hashBytesL ctx "AttributeAtomExpr" [SHash a]+      (NakedAtomExpr a) -> hashBytesL ctx "NakedAtomExpr" [SHash a]+      (FunctionAtomExpr fname args marker) ->+        hashBytesL ctx "FunctionAtomExpr" $ [SHash fname, SHash marker] <> map SHash args+      (RelationAtomExpr r) -> hashBytesL ctx "RelationAtomExpr" [SHash r]+      (ConstructedAtomExpr dConsName args marker) ->+        hashBytesL ctx "ConstructedAtomExpr" ([SHash dConsName, SHash marker] <> map SHash args)++instance HashBytes () where+  hashBytes () ctx = SHA256.update ctx "()"++instance HashBytes AtomType where+  hashBytes typ ctx =+    case typ of+      IntAtomType -> hashb "IntAtomType"+      IntegerAtomType -> hashb "IntegerAtomType"+      ScientificAtomType -> hashb "ScientificAtomType"+      DoubleAtomType -> hashb "DoubleAtomType"+      TextAtomType -> hashb "TextAtomType"+      DayAtomType -> hashb "DayAtomType"+      DateTimeAtomType -> hashb "DateTimeAtomType"+      ByteStringAtomType -> hashb "ByteStringAtomType"+      BoolAtomType -> hashb "BoolAtomType"+      UUIDAtomType -> hashb "UUIDAtomType"+      RelationAtomType attrs -> hashBytesL ctx "RelationAtomType" (V.map SHash (attributesVec attrs))+      ConstructedAtomType tConsName tvarMap -> hashBytesL ctx "ConstructedAtomType" (SHash tConsName : map SHash (M.toAscList tvarMap))+      RelationalExprAtomType -> hashb "RelationalExprAtomType"+      TypeVariableType tvn -> hashBytesL ctx "TypeVariableType" [SHash tvn]+    where+      hashb = SHA256.update ctx++instance HashBytes Attributes where+  hashBytes attrs ctx =+    hashBytesL ctx "Attributes" (V.map SHash (attributesVec attrs))++instance HashBytes RelationTupleSet where+  hashBytes tupSet ctx =+    hashBytesL ctx "RelationTupleSet" (map SHash (asList tupSet))++instance HashBytes a => HashBytes (Maybe [AttributeExprBase a]) where+  hashBytes Nothing ctx = SHA256.update ctx "MaybeAttributeExprBaseNothing"+  hashBytes (Just exprs) ctx =+    hashBytesL ctx "MaybeAttributeExprBase" (map SHash exprs)++instance HashBytes a => HashBytes (TupleExprsBase a) where+  hashBytes (TupleExprs marker tupleExprs) ctx =+    hashBytesL ctx "TupleExprs" (SHash marker : map SHash tupleExprs)++instance HashBytes Attribute where+  hashBytes (Attribute name typ) ctx =+    hashBytesL ctx "Attribute" [SHash name, SHash typ]++instance (HashBytes a, HashBytes b) => HashBytes (a, b) where+  hashBytes (a,b) ctx =+    hashBytesL ctx "HTuple" [SHash a, SHash b]++instance HashBytes RelationTuple where+  hashBytes tup ctx =+    hashBytesL ctx "RelationTuple" (V.cons (SHash (tupleAttributes tup)) (V.map SHash (tupleAtoms tup)))++instance HashBytes a => HashBytes (AttributeExprBase a) where+  hashBytes (AttributeAndTypeNameExpr aname tcons marker) ctx =+    hashBytesL ctx "AttributeAndTypeNameExpr" [SHash aname, SHash tcons, SHash marker]+  hashBytes (NakedAttributeExpr attr) ctx =+    hashBytesL ctx "NakedAttributeExpr" [SHash attr]++instance HashBytes TypeConstructor where+  hashBytes tcons ctx =+    case tcons of+      ADTypeConstructor tName args ->+        hashBytesL ctx "ADTypeConstructor" (SHash tName : map SHash args)+      PrimitiveTypeConstructor tConsName typ ->+        hashBytesL ctx "PrimitiveTypeConstructor" [SHash tConsName, SHash typ]+      RelationAtomTypeConstructor attrExprs ->+        hashBytesL ctx "RelationAtomTypeConstructor" (map SHash attrExprs)+      TypeVariable tv ->+        hashBytesL ctx "TypeVariable" [SHash tv]++instance HashBytes TransactionId where+  hashBytes tid ctx = SHA256.update ctx ("TransactionId" <> BL.toStrict (UUID.toByteString tid))++instance HashBytes Schema where+  hashBytes (Schema morphs) ctx =+    hashBytesL ctx "Schema" (map SHash (sortOn sortIso morphs))+    where+      sortIso iso = mconcat (isomorphInRelVarNames iso)+                            ++instance HashBytes SchemaIsomorph where+  hashBytes (IsoRestrict r p (a,b)) ctx =+    hashBytesL ctx "IsoRestrict" [SHash r, SHash p, SHash a, SHash b]+  hashBytes (IsoRename a b) ctx =+    hashBytesL ctx "IsoRename" [SHash a, SHash b]+  hashBytes (IsoUnion (a,b) p r) ctx =+    hashBytesL ctx "IsoUnion" [SHash a, SHash b, SHash p, SHash r]++instance HashBytes a => HashBytes (RestrictionPredicateExprBase a) where+  hashBytes TruePredicate ctx = SHA256.update ctx "TruePredicate"+  hashBytes (AndPredicate a b) ctx = hashBytesL ctx "AndPredicate" [SHash a, SHash b]+  hashBytes (OrPredicate a b) ctx = hashBytesL ctx "OrPredicate" [SHash a, SHash b]+  hashBytes (NotPredicate a) ctx = hashBytesL ctx "NotPredicate" [SHash a]+  hashBytes (RelationalExprPredicate e) ctx = hashBytesL ctx "RelationalExprPredicate" [SHash e]+  hashBytes (AtomExprPredicate a) ctx = hashBytesL ctx "AtomExprPredicate" [SHash a]+  hashBytes (AttributeEqualityPredicate a e) ctx = hashBytesL ctx "AttributeEqualityPredicate" [SHash a, SHash e]+++instance HashBytes MerkleHash where+  hashBytes h ctx =+    SHA256.update ctx (_unMerkleHash h)++instance HashBytes UTCTime where+  hashBytes tim ctx =+    SHA256.update ctx (BL.toStrict ("UTCTime" <>+                                    BSB.toLazyByteString (BSB.integerDec (toModifiedJulianDay (utctDay tim))) <>+                                    BSB.toLazyByteString (BSB.integerDec (diffTimeToPicoseconds (utctDayTime tim)))))++instance HashBytes DatabaseContext where+  hashBytes db ctx =+    hashBytesL ctx "DatabaseContext" [SHash (inclusionDependencies db),+                                      SHash (relationVariables db),+                                      SHash (notifications db),+                                      SHash (typeConstructorMapping db),+                                      SHash (atomFunctions db),+                                      SHash (dbcFunctions db)]++instance HashBytes InclusionDependencies where+  hashBytes incDeps ctx =+    hashBytesL ctx "InclusionDependencies" (map SHash (M.toAscList incDeps))++instance HashBytes RelationVariables where+  hashBytes rvs ctx =+    hashBytesL ctx "RelationVariables" (map SHash (M.toAscList rvs))++instance HashBytes Notifications where+  hashBytes nots ctx =+    hashBytesL ctx "Notifications" (map SHash (M.toAscList nots))++instance HashBytes TypeConstructorMapping where+  hashBytes tConsMap ctx =+    hashBytesL ctx "TypeConstructorMapping" (map SHash (sortOn (TCons.name . fst) tConsMap))++instance HashBytes AtomFunctions where+  hashBytes afuncs ctx =+    hashBytesL ctx "AtomFunctions" (map SHash (sortOn funcName (HS.toList afuncs)))++instance HashBytes AtomFunction where+  hashBytes func ctx =+    hashBytesL ctx "AtomFunction" (SHash (funcName func):+                                   SHash (funcBody func):+                                   map SHash (funcType func))++instance HashBytes DatabaseContextFunction where+  hashBytes func ctx =+    hashBytesL ctx "DatabaseContextFunction" (SHash (funcName func):+                                              SHash (funcBody func):+                                              map SHash (funcType func))++instance HashBytes DatabaseContextFunctions where+  hashBytes dbcfuncs ctx =+    hashBytesL ctx "DatabaseContextFunctions" (map SHash (sortOn funcName (HS.toList dbcfuncs)))++instance HashBytes InclusionDependency where    +  hashBytes (InclusionDependency exprA exprB) ctx =+    hashBytesL ctx "InclusionDependency" [SHash exprA, SHash exprB]++instance HashBytes Notification where+  hashBytes notif ctx =+    hashBytesL ctx "Notification" [SHash (changeExpr notif),+                                   SHash (reportOldExpr notif),+                                   SHash (reportNewExpr notif)]++instance HashBytes DataConstructorDef where+  hashBytes (DataConstructorDef dConsName args) ctx =+    hashBytesL ctx "DataConstructorDef" (SHash dConsName : map SHash args)++instance HashBytes [DataConstructorDef] where+  hashBytes defs ctx =+    hashBytesL ctx "DataConstructoDefList" (map SHash (sortOn DC.name defs))++instance HashBytes TypeConstructorDef where+  hashBytes (ADTypeConstructorDef tCons args) ctx =+    hashBytesL ctx "ADTypeConstructorDef" (SHash tCons: map SHash args)+  hashBytes (PrimitiveTypeConstructorDef tCons typ) ctx =+    hashBytesL ctx "PrimitiveTypeConstructorDef" [SHash tCons, SHash typ]++instance HashBytes (FunctionBody a) where+  hashBytes (FunctionScriptBody s _) ctx = hashBytesL ctx "FunctionScriptBody" [SHash s]+  hashBytes (FunctionBuiltInBody _) ctx = SHA256.update ctx "FunctionBuiltInBody"+  hashBytes (FunctionObjectLoadedBody a b c _) ctx = hashBytesL ctx "FunctionObjectLoadedBody" (map (SHash . T.pack) [a,b,c])++instance HashBytes DataConstructorDefArg where+  hashBytes (DataConstructorDefTypeConstructorArg tCons) ctx =+    hashBytesL ctx "DataConstructorDefTypeConstructorArg" [SHash tCons]+  hashBytes (DataConstructorDefTypeVarNameArg tv) ctx =+    hashBytesL ctx "DataConstructorDefTypeVarNameArg" [SHash tv]++instance HashBytes (M.Map RelVarName Relation) where+  hashBytes m ctx =+    hashBytesL ctx "rvtypes" (map SHash (M.toAscList m))++-- | Hash a transaction within its graph context to create a Merkle hash for it.+hashTransaction :: Transaction -> S.Set Transaction -> MerkleHash+hashTransaction trans parentTranses = MerkleHash (SHA256.finalize newHash)+  where+    newHash = hashBytesL SHA256.init "Transaction" (map SHash transIds <>+                                         map SHash (M.toAscList (subschemas trans)) <>+                                         map SHash parentMerkleHashes <>+                                         [SHash tstamp,+                                         SHash (concreteDatabaseContext trans)]+                                                   )+    tstamp = stamp (transactionInfo trans)+    parentMerkleHashes = map getMerkleHash (S.toAscList parentTranses)+    getMerkleHash t = merkleHash (transactionInfo t)+    transIds = transactionId trans : S.toAscList (parentIds trans)++-- | 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.+mkDDLHash :: DatabaseContext -> M.Map RelVarName Relation -> SecureHash+mkDDLHash ctx rvtypemap = 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.+  SecureHash $ SHA256.finalize $ hashBytesL SHA256.init "DDLHash" [SHash (inclusionDependencies ctx),+                                                                    SHash (atomFunctions ctx),+                                                                    SHash (dbcFunctions ctx),+                                                                    SHash (typeConstructorMapping ctx),+                                                                    SHash rvtypemap]

@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveGeneric, LambdaCase, DerivingVia #-}+{-# LANGUAGE DeriveGeneric, LambdaCase, DerivingVia, FlexibleInstances #-} module ProjectM36.IsomorphicSchema where import ProjectM36.Base import ProjectM36.Error@@ -91,12 +91,13 @@     validRelVarNames = isomorphsInRelVarNames (isomorphs schema)    processRelationalExprInSchema :: Schema -> RelationalExpr -> Either RelationalError RelationalExpr+processRelationalExprInSchema (Schema []) expr = pure expr processRelationalExprInSchema schema relExprIn = do   --validate that all rvs are present in the virtual schema- this prevents relation variables being referenced in the underlying schema (falling through the transformation)   let processRelExpr rexpr morph = relExprMogrify (relExprMorph morph) rexpr   validateRelationalExprInSchema schema relExprIn                       foldM processRelExpr relExprIn (isomorphs schema)-  + validateDatabaseContextExprInSchema :: Schema -> DatabaseContextExpr -> Either RelationalError ()   validateDatabaseContextExprInSchema schema dbExpr = mapM_ (\morph -> databaseContextExprMorph morph (\e -> validateRelationalExprInSchema schema e >> pure e) dbExpr) (isomorphs schema)   @@ -134,21 +135,25 @@   -}  -- | Morph a relational expression in one schema to another isomorphic schema.-relExprMorph :: SchemaIsomorph -> (RelationalExpr -> Either RelationalError RelationalExpr)+-- Returns a function which can be used to morph a 'GraphRefRelationalExpr'. Here, we naively apply the morphs in the current context ignoring past contexts because:+-- * the current schema may not exist in past+-- * this function should only be used for showing DDL, not for expression evaluation.+-- * if a schema were renamed, then the path to past isomorphisms in the transaction graph tree would be lost.+relExprMorph :: SchemaIsomorph -> RelationalExpr -> Either RelationalError RelationalExpr relExprMorph (IsoRestrict relIn _ (relOutTrue, relOutFalse)) = \case-  RelationVariable rv () | rv == relIn -> Right (Union (RelationVariable relOutTrue ()) (RelationVariable relOutFalse ()))+  RelationVariable rv m | rv == relIn -> Right (Union (RelationVariable relOutTrue m) (RelationVariable relOutFalse m))   orig -> Right orig relExprMorph (IsoUnion (relInT, relInF) predi relTarget) = \case   --only the true predicate portion appears in the virtual schema  -  RelationVariable rv () | rv == relInT -> Right (Restrict predi (RelationVariable relTarget ()))+  RelationVariable rv m | rv == relInT -> Right (Restrict predi (RelationVariable relTarget m)) -  RelationVariable rv () | rv == relInF -> Right (Restrict (NotPredicate predi) (RelationVariable relTarget ()))+  RelationVariable rv m | rv == relInF -> Right (Restrict (NotPredicate predi) (RelationVariable relTarget m))   orig -> Right orig relExprMorph (IsoRename relIn relOut) = \case-  RelationVariable rv () | rv == relIn -> Right (RelationVariable relOut ())+  RelationVariable rv m | rv == relIn -> Right (RelationVariable relOut m)   orig -> Right orig   -relExprMogrify :: (RelationalExpr -> Either RelationalError RelationalExpr) -> RelationalExpr -> Either RelationalError RelationalExpr+relExprMogrify :: (RelationalExprBase a -> Either RelationalError (RelationalExprBase a)) -> RelationalExprBase a -> Either RelationalError (RelationalExprBase a) relExprMogrify func (Project attrs expr) = func expr >>= \ex -> func (Project attrs ex) relExprMogrify func (Union exprA exprB) = do   exA <- func exprA@@ -272,6 +277,7 @@  -- | Show metadata about the relation variables in the isomorphic schema. relationVariablesAsRelationInSchema :: DatabaseContext -> Schema -> TransactionGraph -> Either RelationalError Relation+relationVariablesAsRelationInSchema ctx (Schema []) graph = relationVariablesAsRelation ctx graph -- no schema morphism relationVariablesAsRelationInSchema concreteDbContext schema graph = do   rvDefsInConcreteSchema <- relationVariablesInSchema schema   let gfEnv = freshGraphRefRelationalExprEnv (Just concreteDbContext) graph@@ -295,11 +301,16 @@ Concrete ...| Virtual Isomorphs -}-  +{-   applyRelationVariablesSchemaIsomorphs :: SchemaIsomorphs -> RelationVariables -> Either RelationalError RelationVariables                                                                 -applyRelationVariablesSchemaIsomorphs = undefined-  -+applyRelationVariablesSchemaIsomorphs {-morphs rvs -}= undefined+-}+{-  M.fromList <$> mapM (\(rvname, rvexpr) -> do+                          morphed <- applyRelationalExprSchemaIsomorphs morphs rvexpr+                          pure (rvname, morphed)+                      ) (M.toList rvs)+  -}+{- applySchemaIsomorphsToDatabaseContext :: SchemaIsomorphs -> DatabaseContext -> Either RelationalError DatabaseContext applySchemaIsomorphsToDatabaseContext morphs context = do --  incdeps <- inclusionDependen morphs (inclusionDependencies context)@@ -310,7 +321,7 @@                   --notifications = notifs,                   --typeConstructorMapping = tconsmapping                 })-    +  -}   {-     validate :: SchemaIsomorph -> S.Set RelVarName -> Either RelationalError SchemaIsomorph validate morph underlyingRvNames = if S.size invalidRvNames > 0 then @@ -353,4 +364,55 @@                                            pure (M.delete sname sschemas, context)                                          else                                            Left (SubschemaNameNotInUseError sname)+++-- | Apply SchemaIsomorphs to database context data.+class Morph a where+  morphToSchema :: Schema -> TransactionGraph -> a -> Either RelationalError a++instance Morph RelationalExpr where+  morphToSchema schema _ relExprIn = do+      let processRelExpr rexpr morph = relExprMogrify (relExprMorph morph) rexpr+      validateRelationalExprInSchema schema relExprIn                    +      foldM processRelExpr relExprIn (isomorphs schema)++-- | The names of inclusion dependencies might leak context about a different schema, but that's arbitrary and cannot be altered without having the user provide a renaming function or a new set of incDep names- seems extraneous.+instance Morph InclusionDependency where+  morphToSchema schema _ (InclusionDependency rexprA rexprB) = do+    let schemaRelVars = isomorphsInRelVarNames (isomorphs schema)+    rvAssoc <- mapM (\rvIn -> do +                      rvOut <- processRelationalExprInSchema schema (RelationVariable rvIn ())+                      pure (rvOut, RelationVariable rvIn ())+                  )+             (S.toList schemaRelVars)+    let replacer exprOrig = foldM (\expr (find, replace) -> if expr == find then+                                                              pure replace+                                                            else+                                                              pure expr) exprOrig rvAssoc+    rexprA' <- relExprMogrify replacer rexprA+    rexprB' <- relExprMogrify replacer rexprB+    pure (InclusionDependency rexprA' rexprB')++instance Morph InclusionDependencies where+  morphToSchema schema tg incDeps = M.fromList <$> mapM (\(n,incdep) -> (,) n <$> morphToSchema schema tg incdep) (M.toList incDeps)++{-+-- cannot be implemented because relvars map to transaction-graph-traversing expressions and we do not track schema changes over time+instance Morph RelationVariables where+  morphToSchema schema tg relVars = do+    let folder acc (IsoRename rvBase rvSchema) = +          case M.lookup rvBase relVars of+            Nothing -> Left (RelVarNotDefinedError rvBase)+            Just gfExpr -> do+              gfExprSchema <- morphToSchema schema tg gfExpr+              pure (acc <> [(rvSchema, gfExprSchema)])+    M.fromList <$> foldM folder mempty (isomorphs schema)+-}+{-+instance Morph GraphRefRelationalExpr where+-- cannot be supported because we don't track how the schema changes over the lifetime of a transaction graph+-}+                                                                                                                 +  +   

@@ -77,6 +77,8 @@     RemoveAtomFunction aFuncName -> pure (RemoveAtomFunction aFuncName)     RemoveDatabaseContextFunction funcName' -> pure (RemoveDatabaseContextFunction funcName')     ExecuteDatabaseContextFunction funcName' atomExprs -> ExecuteDatabaseContextFunction funcName' <$> mapM processAtomExpr atomExprs+    AddRegisteredQuery n q -> pure (AddRegisteredQuery n q)+    RemoveRegisteredQuery n -> pure (RemoveRegisteredQuery n)     MultipleExpr exprs -> MultipleExpr <$> mapM processDatabaseContextExpr exprs  processDatabaseContextIOExpr :: DatabaseContextIOExpr -> ProcessExprM GraphRefDatabaseContextIOExpr

@@ -43,6 +43,8 @@ #if defined(mingw32_HOST_OS) import ProjectM36.Win32Handle #else+-- maybe this could be "safe" for GC since we only use it with withCString+-- https://www.reddit.com/r/haskell/comments/xlm4qv/haskell_ffi_call_safety_and_garbage_collection/ foreign import ccall unsafe "cDirectoryFsync" cHSDirectoryFsync :: CString -> IO CInt #endif 

@@ -0,0 +1,19 @@+module ProjectM36.RegisteredQuery where+import ProjectM36.Base+import ProjectM36.Attribute+import ProjectM36.Error+import ProjectM36.IsomorphicSchema+import ProjectM36.Relation+import qualified Data.Map as M++registeredQueriesAsRelationInSchema :: Schema -> RegisteredQueries -> Either RelationalError Relation+registeredQueriesAsRelationInSchema schema regQs = do+  tups <- mapM regQToTuple (M.toList regQs)+  mkRelationFromList attrs tups+  where+    attrs = attributesFromList [Attribute "name" TextAtomType,+                                Attribute "expr" RelationalExprAtomType]+    regQToTuple (qname, qexpr) = do+      qexpr' <- processRelationalExprInSchema schema qexpr+      pure [TextAtom qname, RelationalExprAtom qexpr']+  

@@ -41,7 +41,7 @@         convertMap hmap = HM.fromList $ L.map (decodeUtf8 *** (T.unpack . decodeUtf8)) (HM.toList hmap)         attrNameSet = A.attributeNameSet attrs         headerSet = S.fromList (V.toList strHeader)-        parseAtom attrName aType textIn = case APT.parseOnly (parseCSVAtomP attrName tConsMap aType <* APT.endOfInput) textIn of+        parseAtom attrName aType textIn = case APT.parseOnly (parseCSVAtomP attrName tConsMap aType takeToEndOfColumnData <* APT.endOfInput) textIn of           Left err -> Left (ParseError (T.pack err))           Right eAtom -> eAtom          makeTupleList :: HM.HashMap AttributeName String -> [Either CsvImportError Atom]@@ -57,53 +57,53 @@       Left $ HeaderAttributeMismatchError (S.difference attrNameSet headerSet)  -parseCSVAtomP :: AttributeName -> TypeConstructorMapping -> AtomType -> APT.Parser (Either RelationalError Atom)-parseCSVAtomP _ _ IntegerAtomType = Right . IntegerAtom <$> APT.decimal-parseCSVAtomP _ _ IntAtomType = Right . IntAtom <$> APT.decimal-parseCSVAtomP _ _ ScientificAtomType = Right . ScientificAtom <$> APT.scientific-parseCSVAtomP _ _ DoubleAtomType = Right . DoubleAtom <$> APT.double-parseCSVAtomP _ _ TextAtomType = -  Right . TextAtom <$> (quotedString <|> takeToEndOfData)-parseCSVAtomP _ _ DayAtomType = do+parseCSVAtomP :: AttributeName -> TypeConstructorMapping -> AtomType -> APT.Parser T.Text -> APT.Parser (Either RelationalError Atom)+parseCSVAtomP _ _ IntegerAtomType _ = Right . IntegerAtom <$> APT.decimal+parseCSVAtomP _ _ IntAtomType _ = Right . IntAtom <$> APT.decimal+parseCSVAtomP _ _ ScientificAtomType _ = Right . ScientificAtom <$> APT.scientific+parseCSVAtomP _ _ DoubleAtomType _ = Right . DoubleAtom <$> APT.double+parseCSVAtomP _ _ TextAtomType takeToEndOfData = +  Right . TextAtom <$> takeToEndOfData+parseCSVAtomP _ _ DayAtomType takeToEndOfData = do   dString <- T.unpack <$> takeToEndOfData   case readMaybe dString of     Nothing -> fail ("invalid Day string: " ++ dString)     Just date -> pure (Right (DayAtom date))-parseCSVAtomP _ _ DateTimeAtomType = do    +parseCSVAtomP _ _ DateTimeAtomType takeToEndOfData = do       dString <- T.unpack <$> takeToEndOfData   case readMaybe dString of     Nothing -> fail ("invalid Date string: " ++ dString)     Just date -> pure (Right (DateTimeAtom date))-parseCSVAtomP _ _ ByteStringAtomType = do    +parseCSVAtomP _ _ ByteStringAtomType takeToEndOfData = do       bsString <- T.unpack <$> takeToEndOfData   case readMaybe bsString of     Nothing -> fail ("invalid ByteString string: " ++ bsString)     Just bs -> pure (Right (ByteStringAtom bs))-parseCSVAtomP _ _ BoolAtomType = do+parseCSVAtomP _ _ BoolAtomType takeToEndOfData = do   bString <- T.unpack <$> takeToEndOfData   case readMaybe bString of     Nothing -> fail ("invalid BoolAtom string: " ++ bString)     Just b -> pure (Right (BoolAtom b))-parseCSVAtomP _ _ UUIDAtomType = do+parseCSVAtomP _ _ UUIDAtomType takeToEndOfData = do   uString <- T.unpack <$> takeToEndOfData   case readMaybe uString of     Nothing -> fail ("invalid UUIDAtom string: " ++ uString)     Just u -> pure (Right (UUIDAtom u))-parseCSVAtomP _ _ RelationalExprAtomType = do+parseCSVAtomP _ _ RelationalExprAtomType takeToEndOfData = do   reString <- T.unpack <$> takeToEndOfData         case readMaybe reString of     Nothing -> fail ("invalid RelationalExprAtom string: " ++ reString)     Just b -> pure (Right (RelationalExprAtom b))-parseCSVAtomP attrName tConsMap typ@(ConstructedAtomType _ tvmap) +parseCSVAtomP attrName tConsMap typ@(ConstructedAtomType _ tvmap) takeToEndOfData    | isIntervalAtomType typ = do     begin <- (APT.char '[' >> pure False) <|> (APT.char '(' >> pure True)     let iType = intervalSubType typ-    eBeginv <- parseCSVAtomP attrName tConsMap iType+    eBeginv <- parseCSVAtomP attrName tConsMap iType takeToEndOfIntervalBlock     case eBeginv of       Left err -> pure (Left err)       Right beginv -> do         _ <- APT.char ','-        eEndv <- parseCSVAtomP attrName tConsMap iType+        eEndv <- parseCSVAtomP attrName tConsMap iType takeToEndOfIntervalBlock         case eEndv of           Left err -> pure (Left err)           Right endv -> do@@ -123,18 +123,19 @@         case resolvedAtomTypesForDataConstructorDefArgs tConsMap tvmap dConsDef of           Left err -> pure (Left err)           Right argAtomTypes -> do-            atomArgs <- mapM (\argTyp -> let parseNextAtom = parseCSVAtomP attrName tConsMap argTyp <* APT.skipSpace in-                               case argTyp of-                                 ConstructedAtomType _ _ -> -                                   parens parseNextAtom <|>-                                   parseNextAtom-                                 _ -> parseNextAtom-                             ) argAtomTypes+            let argMapper argTyp = let parseNextAtom = parseCSVAtomP attrName tConsMap argTyp takeToEndOfData <* APT.skipSpace in+                                      case argTyp of+                                        TextAtomType -> pure . TextAtom <$> quotedString <* APT.skipSpace+                                        ConstructedAtomType _ _ -> +                                          parens parseNextAtom <|>+                                          parseNextAtom+                                        _ -> parseNextAtom+            atomArgs <- mapM argMapper argAtomTypes             case lefts atomArgs of               [] -> pure (Right (ConstructedAtom dConsName typ (rights atomArgs)))               errs -> pure (Left (someErrors errs))-parseCSVAtomP attrName _ (RelationAtomType _) = pure (Left (RelationValuedAttributesNotSupportedError [attrName]))-parseCSVAtomP _ _ (TypeVariableType x) = pure (Left (TypeConstructorTypeVarMissing x))+parseCSVAtomP attrName _ (RelationAtomType _) _ = pure (Left (RelationValuedAttributesNotSupportedError [attrName]))+parseCSVAtomP _ _ (TypeVariableType x) _ = pure (Left (TypeConstructorTypeVarMissing x))        capitalizedIdentifier :: APT.Parser T.Text capitalizedIdentifier = do@@ -142,9 +143,12 @@   rest <- APT.takeWhile (\c -> not (isSpace c || c == ')')) APT.<?> "data constructor name"   pure (fletter `T.cons` rest)   +takeToEndOfColumnData :: APT.Parser T.Text+takeToEndOfColumnData = APT.takeWhile (APT.notInClass "")+ --read data for Text.Read parser but be wary of end of interval blocks  -takeToEndOfData :: APT.Parser T.Text-takeToEndOfData = APT.takeWhile (APT.notInClass ",)]")+takeToEndOfIntervalBlock :: APT.Parser T.Text+takeToEndOfIntervalBlock = APT.takeWhile (APT.notInClass ",)]")    parens :: APT.Parser a -> APT.Parser a   parens p = do@@ -159,7 +163,7 @@ quotedString = do   let escapeMap = [('"','"'), ('n', '\n'), ('r', '\r')]       doubleQuote = void $ APT.char '"'-  doubleQuote      +  doubleQuote   (_, s) <- APT.runScanner [] (\prevl nextChar -> case prevl of                              [] -> Just [nextChar]                              chars | last chars == '\\' ->@@ -170,4 +174,3 @@                                    | otherwise -> Just (chars ++ [nextChar]))   doubleQuote   pure (T.pack s)-  

@@ -481,6 +481,25 @@                      case evalDatabaseContextFunction func (rights eAtomArgs) context of                        Left err -> dbErr err                        Right newContext -> putStateContext newContext++evalGraphRefDatabaseContextExpr (AddRegisteredQuery regName regExpr) = do+  context <- getStateContext+  tgraph <- dbcGraph+  tid <- dbcTransId+  case M.lookup regName (registeredQueries context) of+    Just _ -> dbErr (RegisteredQueryNameInUseError regName)+    Nothing -> do+      let context' = context { registeredQueries = M.insert regName regExpr (registeredQueries context) }+      case checkConstraints context' tid tgraph of+        Left err -> dbErr err+        Right _ -> putStateContext context'+evalGraphRefDatabaseContextExpr (RemoveRegisteredQuery regName) = do+  context <- getStateContext  +  case M.lookup regName (registeredQueries context) of+    Nothing -> dbErr (RegisteredQueryNameNotInUseError regName)+    Just _ -> putStateContext (context { registeredQueries = M.delete regName (registeredQueries context) })+  + data DatabaseContextIOEvalEnv = DatabaseContextIOEvalEnv   { dbcio_transId :: TransactionId,     dbcio_graph :: TransactionGraph,@@ -664,7 +683,8 @@ --run verification on all constraints checkConstraints :: DatabaseContext -> TransactionId -> TransactionGraph -> Either RelationalError () checkConstraints context transId graph@(TransactionGraph graphHeads transSet) = do-  mapM_ (uncurry checkIncDep) (M.toList deps) +  mapM_ (uncurry checkIncDep) (M.toList deps)+  mapM_ checkRegisteredQuery (M.toList (registeredQueries context))   where     potentialGraph = TransactionGraph graphHeads (S.insert tempTrans transSet)     tempStamp = UTCTime { utctDay = fromGregorian 2000 1 1,@@ -677,28 +697,35 @@                                       }          deps = inclusionDependencies context+    process = runProcessExprM UncommittedContextMarker+    gfEnv = freshGraphRefRelationalExprEnv (Just context) graph       -- no optimization available here, really? perhaps the optimizer should be passed down to here or the eval function should be passed through the environment     checkIncDep depName (InclusionDependency subsetExpr supersetExpr) = do-      let process = runProcessExprM UncommittedContextMarker-          gfSubsetExpr = process (processRelationalExpr subsetExpr)+      let gfSubsetExpr = process (processRelationalExpr subsetExpr)           gfSupersetExpr = process (processRelationalExpr supersetExpr)       --if both expressions are of a single-attribute (such as with a simple foreign key), the names of the attributes are irrelevant (they need not match) because the expression is unambiguous, but special-casing this to rename the attribute automatically would not be orthogonal behavior and probably cause confusion. Instead, special case the error to make it clear.-      let gfEnv = freshGraphRefRelationalExprEnv (Just context) graph           runGfRel e = case runGraphRefRelationalExprM gfEnv e of-            Left err -> Left (InclusionDependencyCheckError depName (Just err))-            Right v -> Right v+                         Left err -> Left (wrapIncDepErr (Just err))+                         Right v -> Right v+          wrapIncDepErr = InclusionDependencyCheckError depName       typeSub <- runGfRel (typeForGraphRefRelationalExpr gfSubsetExpr)       typeSuper <- runGfRel (typeForGraphRefRelationalExpr gfSupersetExpr)-      when (typeSub /= typeSuper) (Left (RelationTypeMismatchError (attributes typeSub) (attributes typeSuper)))+      when (typeSub /= typeSuper) (Left (wrapIncDepErr (Just (RelationTypeMismatchError (attributes typeSub) (attributes typeSuper)))))       let checkExpr = Equals gfSupersetExpr (Union gfSubsetExpr gfSupersetExpr)           gfEvald = runGraphRefRelationalExprM gfEnv' (evalGraphRefRelationalExpr checkExpr)           gfEnv' = freshGraphRefRelationalExprEnv (Just context) potentialGraph       case gfEvald of-        Left err -> Left err+        Left err -> Left (wrapIncDepErr (Just err))         Right resultRel -> if resultRel == relationTrue then                                    pure ()                                 else -                                  Left (InclusionDependencyCheckError depName Nothing)+                                  Left (wrapIncDepErr Nothing)+    --registered queries just need to typecheck- think of them as a constraints on the schema/DDL+    checkRegisteredQuery (qName, relExpr) = do+      let gfExpr = process (processRelationalExpr relExpr)+      case runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr) of+        Left err -> Left (RegisteredQueryValidationError qName err)+        Right _ -> pure ()  -- the type of a relational expression is equal to the relation attribute set returned from executing the relational expression; therefore, the type can be cheaply derived by evaluating a relational expression and ignoring and tuple processing -- furthermore, the type of a relational expression is the resultant header of the evaluated empty-tupled relation@@ -764,12 +791,12 @@   let attrs' = A.union attrs (envAttributes env)       ctxtup' = envTuple env   atomExprType <- typeForGraphRefAtomExpr attrs' atomExpr-  attr <- lift $ except $ case A.attributeForName attrName attrs of+  attr <- lift $ except $ case A.attributeForName attrName attrs' of       Right attr -> Right attr-      Left (NoSuchAttributeNamesError _) -> case A.attributeForName attrName (tupleAttributes ctxtup') of-        Right ctxattr -> Right ctxattr-        Left err2@(NoSuchAttributeNamesError _) -> Left err2-        Left err -> Left err+      Left (NoSuchAttributeNamesError _) -> case A.attributeForName attrName (tupleAttributes ctxtup') of +                                              Right ctxattr -> Right ctxattr+                                              Left err2@(NoSuchAttributeNamesError _) -> Left err2+                                              Left err -> Left err       Left err -> Left err   if atomExprType /= A.atomType attr then       throwError (TupleAttributeTypeMismatchError (A.attributesFromList [attr]))@@ -912,7 +939,7 @@             Right tvMap ->               lift $ except $ resolveFunctionReturnValue funcName' tvMap funcRetType typeForGraphRefAtomExpr attrs (RelationAtomExpr relExpr) = do-  relType <- R.local (mergeAttributesIntoGraphRefRelationalExprEnv attrs) (typeForGraphRefRelationalExpr relExpr)+  relType <- R.local (mergeAttributesIntoGraphRefRelationalExprEnv attrs) (typeForGraphRefRelationalExpr relExpr)     pure (RelationAtomType (attributes relType)) -- grab the type of the data constructor, then validate that the args match the expected types typeForGraphRefAtomExpr _ (ConstructedAtomExpr tOrF [] _) | tOrF `elem` ["True", "False"] =@@ -1425,4 +1452,4 @@     _ -> orig applyRestrictionCollapse expr = expr -                                +

@@ -7,6 +7,9 @@ import Control.Monad import ProjectM36.Base import ProjectM36.MerkleHash+import ProjectM36.Relation+import ProjectM36.Tuple+import ProjectM36.TupleSet import Data.UUID import Data.Proxy import Data.Word@@ -21,9 +24,7 @@ deriving via WineryVariant Atom instance Serialise Atom deriving via WineryVariant AtomType instance Serialise AtomType deriving via WineryVariant Attribute instance Serialise Attribute-deriving via WineryVariant RelationTupleSet instance Serialise RelationTupleSet deriving via WineryVariant RelationTuple instance Serialise RelationTuple-deriving via WineryVariant Relation instance Serialise Relation deriving via WineryVariant RelationCardinality instance Serialise RelationCardinality deriving via WineryVariant (RelationalExprBase a) instance Serialise a => Serialise (RelationalExprBase a) deriving via WineryVariant (WithNameExprBase a) instance Serialise a => Serialise (WithNameExprBase a)@@ -89,3 +90,34 @@     n <- decodeVarInt     l <- replicateM n decodeCurrent     pure (A.attributesFromList l)++-- | A special instance of Serialise which cuts down on duplicate attributes- we should only serialise the attributes at the top-level and not duplicate them per tuple.+instance Serialise Relation where+  schemaGen _ = getSchema (Proxy @(Attributes, [V.Vector Atom]))+  toBuilder rel = toBuilder (attributes rel, map tupleAtoms (tuplesList rel))+  extractor = makeRelation <$> extractor+   where+    makeRelation (attrs, atomList) =  Relation attrs (RelationTupleSet (map (RelationTuple attrs) atomList))+  decodeCurrent = do+    (attrs, atomList) <- decodeCurrent+    pure (Relation attrs (RelationTupleSet (map (RelationTuple attrs) atomList)))   ++type SlimTupleSet = Either () (Attributes, [V.Vector Atom])++slimTupleSet :: RelationTupleSet -> SlimTupleSet+slimTupleSet tupSet =+  case asList tupSet of+    [] -> Left ()+    tup:tups -> Right (tupleAttributes tup, map tupleAtoms (tup:tups))++-- | restore slimmed tuple set to include single shared attributes list+fattenTupleSet :: SlimTupleSet -> RelationTupleSet+fattenTupleSet Left{} = emptyTupleSet+fattenTupleSet (Right (attrs, vtups)) = RelationTupleSet $ map (RelationTuple attrs) vtups++-- | A special instance of Serialise which cuts down on duplicate attributes- we should only serialise the attributes at the top-level and not duplicate them per tuple. If we have an empty tupleset, we lack all attributes which is fine in this case.+instance Serialise RelationTupleSet where+  schemaGen _ = getSchema (Proxy @SlimTupleSet)+  toBuilder tupSet = toBuilder (slimTupleSet tupSet)+  extractor = fattenTupleSet <$> extractor+  decodeCurrent = fattenTupleSet <$> decodeCurrent

@@ -102,7 +102,16 @@                         handleRetrieveTypeConstructorMapping ti sessionId conn),      RequestHandler (\sState (ExecuteValidateMerkleHashes sessionId) -> do                         conn <- getConn sState                        -                        handleValidateMerkleHashes ti sessionId conn)+                        handleValidateMerkleHashes ti sessionId conn),+     RequestHandler (\sState (GetDDLHash sessionId) -> do+                        conn <- getConn sState+                        handleGetDDLHash ti sessionId conn),+     RequestHandler (\sState (RetrieveDDLAsRelation sessionId) -> do+                        conn <- getConn sState+                        handleRetrieveDDLAsRelation ti sessionId conn),+     RequestHandler (\sState (RetrieveRegisteredQueries sessionId) -> do+                        conn <- getConn sState+                        handleRetrieveRegisteredQueries ti sessionId conn)      ] ++ if testFlag then testModeHandlers ti else []  getConn :: ConnectionState ServerState -> IO Connection

@@ -2,6 +2,7 @@ module ProjectM36.Server.EntryPoints where import ProjectM36.Base hiding (inclusionDependencies) import ProjectM36.IsomorphicSchema+import ProjectM36.HashSecurely import ProjectM36.Client as C import Data.Map import Control.Concurrent (threadDelay)@@ -144,3 +145,15 @@ handleValidateMerkleHashes :: Maybe Timeout -> SessionId -> Connection -> IO (Either RelationalError ()) handleValidateMerkleHashes ti sessionId conn =    timeoutRelErr ti (C.validateMerkleHashes sessionId conn)++handleGetDDLHash :: Maybe Timeout -> SessionId -> Connection -> IO (Either RelationalError SecureHash)+handleGetDDLHash ti sessionId conn =+  timeoutRelErr ti (C.getDDLHash sessionId conn)++handleRetrieveDDLAsRelation :: Maybe Timeout -> SessionId -> Connection -> IO (Either RelationalError Relation)+handleRetrieveDDLAsRelation ti sessionId conn =+  timeoutRelErr ti (C.ddlAsRelation sessionId conn)++handleRetrieveRegisteredQueries :: Maybe Timeout -> SessionId -> Connection -> IO (Either RelationalError Relation)+handleRetrieveRegisteredQueries ti sessionId conn =+  timeoutRelErr ti (C.registeredQueriesAsRelation sessionId conn)

@@ -101,3 +101,12 @@  data ExecuteValidateMerkleHashes = ExecuteValidateMerkleHashes SessionId   RPCData(ExecuteValidateMerkleHashes)++data GetDDLHash = GetDDLHash SessionId+  RPCData(GetDDLHash)++data RetrieveDDLAsRelation = RetrieveDDLAsRelation SessionId+  RPCData(RetrieveDDLAsRelation)++data RetrieveRegisteredQueries = RetrieveRegisteredQueries SessionId+  RPCData(RetrieveRegisteredQueries)

@@ -316,7 +316,8 @@ optimizeGraphRefDatabaseContextExpr c@(RemoveAtomFunction _) = pure c optimizeGraphRefDatabaseContextExpr c@(RemoveDatabaseContextFunction _) = pure c optimizeGraphRefDatabaseContextExpr c@(ExecuteDatabaseContextFunction _ _) = pure c-+optimizeGraphRefDatabaseContextExpr c@AddRegisteredQuery{} = pure c+optimizeGraphRefDatabaseContextExpr c@RemoveRegisteredQuery{} = pure c --optimization: from pgsql lists- check for join condition referencing foreign key- if join projection project away the referenced table, then it does not need to be scanned  --applyStaticDatabaseOptimization (MultipleExpr exprs) = pure $ Right $ MultipleExpr exprs

@@ -63,6 +63,9 @@ subschemasPath :: FilePath -> FilePath subschemasPath transdir = transdir </> "schemas" +registeredQueriesPath :: FilePath -> FilePath+registeredQueriesPath transdir = transdir </> "registered_queries"+ -- | where compiled modules are stored within the database directory objectFilesPath :: FilePath -> FilePath objectFilesPath transdir = transdir </> ".." </> "compiled_modules"@@ -81,12 +84,14 @@     sschemas <- readSubschemas transDir     dbcFuncs <- readFuncs transDir (dbcFuncsPath transDir) basicDatabaseContextFunctions mScriptSession     atomFuncs <- readFuncs transDir (atomFuncsPath transDir) precompiledAtomFunctions mScriptSession+    registeredQs <- readRegisteredQueries transDir     let newContext = DatabaseContext { inclusionDependencies = incDeps,                                        relationVariables = relvars,                                        typeConstructorMapping = typeCons,                                        notifications = M.empty,                                        atomFunctions = atomFuncs, -                                       dbcFunctions = dbcFuncs }+                                       dbcFunctions = dbcFuncs,+                                       registeredQueries = registeredQs }         newSchemas = Schemas newContext sschemas     return $ Right $ Transaction transId transInfo newSchemas         @@ -105,7 +110,9 @@     writeFuncs sync (dbcFuncsPath tempTransDir) (HS.toList (dbcFunctions context))     writeTypeConstructorMapping sync tempTransDir (typeConstructorMapping context)     writeSubschemas sync tempTransDir (subschemas trans)-    writeFileSerialise (transactionInfoPath tempTransDir) (transactionInfo trans)    --move the temp directory to final location+    writeRegisteredQueries sync tempTransDir (registeredQueries context)+    writeFileSerialise (transactionInfoPath tempTransDir) (transactionInfo trans)+    --move the temp directory to final location     renameSync sync tempTransDir finalTransDir  writeRelVars :: DiskSync -> FilePath -> RelationVariables -> IO ()@@ -248,7 +255,7 @@ readSubschemas transDir = do   let sschemasPath = subschemasPath transDir   readFileDeserialise sschemasPath-  + writeSubschemas :: DiskSync -> FilePath -> Subschemas -> IO ()   writeSubschemas sync transDir sschemas = do   let sschemasPath = subschemasPath transDir@@ -264,4 +271,12 @@   let atPath = typeConsPath path   readFileDeserialise atPath   -  +readRegisteredQueries :: FilePath -> IO RegisteredQueries+readRegisteredQueries transDir = do+  let regQsPath = registeredQueriesPath transDir+  readFileDeserialise regQsPath++writeRegisteredQueries :: DiskSync -> FilePath -> RegisteredQueries -> IO ()+writeRegisteredQueries sync transDir regQs = do+  let regQsPath = registeredQueriesPath transDir+  traceBlock "write registered queries" $ writeSerialiseSync sync regQsPath regQs

@@ -12,6 +12,7 @@ import ProjectM36.MerkleHash import qualified ProjectM36.DisconnectedTransaction as Discon import qualified ProjectM36.Attribute as A+import ProjectM36.HashSecurely  import Codec.Winery import Control.Monad.Except hiding (join)@@ -31,9 +32,6 @@ import Control.Arrow import Data.Maybe import Data.UUID.V4-import qualified Data.ByteString.Lazy as BL-import ProjectM36.DatabaseContext as DBC-import Crypto.Hash.SHA256  -- | Record a lookup for a specific transaction in the graph. data TransactionIdLookup = TransactionIdLookup TransactionId |@@ -500,6 +498,7 @@   notifs <- liftMergeE $ unionMergeMaps preference (notifications contextA) (notifications contextB)   types <- liftMergeE $ unionMergeTypeConstructorMapping preference (typeConstructorMapping contextA) (typeConstructorMapping contextB)   dbcFuncs <- liftMergeE $ unionMergeDatabaseContextFunctions preference (dbcFunctions contextA) (dbcFunctions contextB)+  registeredQs <- liftMergeE $ unionMergeRegisteredQueries preference (registeredQueries contextA) (registeredQueries contextB)   -- TODO: add merge of subschemas   let newContext = DatabaseContext {         inclusionDependencies = incDeps, @@ -507,7 +506,8 @@         atomFunctions = atomFuncs,          dbcFunctions = dbcFuncs,         notifications = notifs,-        typeConstructorMapping = types+        typeConstructorMapping = types,+        registeredQueries = registeredQs         }       newSchemas = Schemas newContext (subschemas t1)   pure $ addMerkleHash graph $@@ -595,29 +595,15 @@ addMerkleHash graph trans = Transaction (transactionId trans) newInfo (schemas trans)   where     newInfo = (transactionInfo trans) { merkleHash = calculateMerkleHash trans graph }-  --- the new hash includes the parents' ids, the current id, and the hash of the context, and the merkle hashes of the parent transactions+  -- the new hash includes the parents' ids, the current id, and the hash of the context, and the merkle hashes of the parent transactions calculateMerkleHash :: Transaction -> TransactionGraph -> MerkleHash-calculateMerkleHash trans graph = -  MerkleHash newHash+calculateMerkleHash trans graph = hashTransaction trans parentTranses   where-    newHash = hashlazy (BL.fromChunks [transIdsBytes,-                                         schemasBytes,-                                         tstampBytes-                                       ] <> dbcBytes <> parentMerkleHashes)-    tstamp = stamp (transactionInfo trans)-    tstampBytes = serialise tstamp-    parentMerkleHashes = BL.fromChunks $ map (_unMerkleHash . getMerkleHash) parentTranses     parentTranses =       case transactionsForIds (parentIds trans) graph of-        Left RootTransactionTraversalError -> []+        Left RootTransactionTraversalError -> mempty         Left e -> error ("failed to find transaction in Merkle hash construction: " ++ show e)-        Right t -> S.toList t-    getMerkleHash t = merkleHash (transactionInfo t)-    transIds = transactionId trans : S.toAscList (parentIds trans)-    transIdsBytes = serialise transIds-    dbcBytes = DBC.hashBytes (concreteDatabaseContext trans)-    schemasBytes = serialise (subschemas trans)+        Right t -> t  validateMerkleHash :: Transaction -> TransactionGraph -> Either MerkleValidationError () validateMerkleHash trans graph = 

@@ -92,3 +92,17 @@   PreferFirst -> pure $ HS.union funcsA funcsB   PreferSecond -> pure $ HS.union funcsB funcsA   PreferNeither -> pure $ HS.union funcsA funcsB++unionMergeRegisteredQueries :: MergePreference -> RegisteredQueries -> RegisteredQueries -> Either MergeError RegisteredQueries+unionMergeRegisteredQueries prefer regQsA regQsB =+  case prefer of+    PreferFirst -> pure (M.union regQsA regQsB)+    PreferSecond -> pure (M.union regQsB regQsA)+    PreferNeither -> do+      let isect = M.filter id $ M.mapWithKey (\qname val -> M.lookup qname regQsB /= Just val) (M.intersection regQsA regQsB)+      --if the values in the intersection are the same, we can merge them      +      if M.null isect then+        pure (M.union regQsA regQsB)+        else+        Left (StrategyViolatesRegisteredQueryMergeError (M.keys isect))+        

@@ -44,7 +44,7 @@ -}  expectedVersion :: Int-expectedVersion = 6+expectedVersion = 7  transactionLogFileName :: FilePath  transactionLogFileName = "m36v" ++ show expectedVersion

@@ -62,7 +62,7 @@                                                                                 Left $ TupleAttributeTypeMismatchError A.emptyAttributes                                                                             ) (Right rel) (asList tupSet)   where-    tupleAtomCheck tuple = V.all (== True) (attrChecks tuple)+    tupleAtomCheck tuple = V.all id (attrChecks tuple)     attrChecks tuple = V.map (\attr -> case atomForAttributeName (A.attributeName attr) tuple of                                  Left _ -> False                                  Right atom -> Right (atomTypeForAtom atom) ==

@@ -8,8 +8,14 @@ import qualified Data.Map as M import System.IO import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL import qualified Data.Text.Encoding as TE import Text.URI hiding (makeAbsolute)+import Network.Wai.Handler.Warp+import Control.Concurrent.MVar+import Control.Concurrent+import Network.Wai+import Network.HTTP.Types  main :: IO () main = do @@ -35,12 +41,24 @@     imported <- importTutorialDFromFile fileURI Nothing     assertEqual "import tutd" (Right expectedExpr) imported ++startTestHTTPServer :: MVar () -> IO ThreadId+startTestHTTPServer startVar = do+  let settings = setHost "127.0.0.1" $ setBeforeMainLoop (putMVar startVar ()) $ setPort 8899 defaultSettings+      app req respond = do+        case pathInfo req of+          ["test1"] -> respond $ responseLBS status200 [] "x:=true;\ny:=false;"+          other -> respond $ responseLBS status404 [] (BSL.fromStrict $ TE.encodeUtf8 $ T.pack ("no path at" <> show other))+  forkIO $ runSettings settings app+ testTutdHTTPSImport :: Test testTutdHTTPSImport = TestCase $ do-  uri <- mkURI "https://raw.githubusercontent.com/agentm/project-m36/master/test/TutorialD/Interpreter/Import/httpimporttest.tutd"+  uri <- mkURI "http://localhost:8899/test1"   let hash = "effe32b247586dc3ac0079fc241b9618d41d189afcaeb7907edbe5a8b45992a4"       expected = Right (MultipleExpr [Assign "x" (RelationVariable "true" ()),Assign "y" (RelationVariable "false" ())])+  continueTestVar <- newEmptyMVar+  httpServerThread <- startTestHTTPServer continueTestVar    actual <- importTutorialDViaHTTP uri (Just hash)   assertEqual "github https" expected actual-  +  killThread httpServerThread   

@@ -18,6 +18,7 @@ import ProjectM36.Base hiding (Finite) import ProjectM36.TransactionGraph import ProjectM36.Client+import ProjectM36.HashSecurely import qualified ProjectM36.DisconnectedTransaction as Discon import qualified ProjectM36.AttributeNames as AN import qualified ProjectM36.Session as Sess@@ -36,6 +37,7 @@ import Data.Time.Calendar (fromGregorian) import Data.Either import Data.Scientific+import Data.ByteString.Base64 as B64  main :: IO () main = do@@ -86,7 +88,11 @@       testUnionAndIntersectionAttributeExprs,       testUndefineConstraints,       testQuotedRelVarNames,-      testScientific+      testScientific,+      testExtendProcessorTuplePushdown,+      testDDLHash,+      testShowDDL,+      testRegisteredQueries       ]  simpleRelTests :: Test@@ -769,3 +775,75 @@   executeTutorialD sessionId dbconn "x:=relation{tuple{a scientific_add(scientific(2,int(100)),scientific(1,int(100)))}}"   addSciRel <- getX   assertEqual "scientific add" (mkRelationFromList attrs [[ScientificAtom (scientific 3 100)]]) addSciRel++testExtendProcessorTuplePushdown :: Test+testExtendProcessorTuplePushdown = TestCase $ do+  --test that context-based tuples are pushed through to the tuple extend processor used commonly in OUTER-JOIN-equivalent extensions+  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback+  executeTutorialD sessionId dbconn "x := (relation{tuple{p# \"P7\", city \"Reykjavik\", color \"Beige\", pname \"Widget\", weight 21}} union p : {suppliers := (sp rename {p# as pid} where p#=@pid) {s#}}) {p#,suppliers}"+  {-+:showexpr relation{tuple{p# "P5", suppliers relation{tuple{s# "S1"}, tuple{s# "S4"}}}, tuple{p# "P4", suppliers relation{tuple{s# "S1"}, tuple{s# "S4"}}}, tuple{p# "P2", suppliers relation{tuple{s# "S1"}, tuple{s# "S2"}, tuple{s# "S3"}, tuple{s# "S4"}}}, tuple{p# "P3", suppliers relation{tuple{s# "S1"}}}, tuple{p# "P6", suppliers relation{tuple{s# "S1"}}}, tuple{p# "P1", suppliers relation{tuple{s# "S1"},tuple{s# "S2"}}}, tuple{p# "P7", suppliers relation{s# Text}}} ++-}+  executeTutorialD sessionId dbconn "y := relation{tuple{p# \"P5\", suppliers relation{tuple{s# \"S1\"}, tuple{s# \"S4\"}}}, tuple{p# \"P4\", suppliers relation{tuple{s# \"S1\"}, tuple{s# \"S4\"}}}, tuple{p# \"P2\", suppliers relation{tuple{s# \"S1\"}, tuple{s# \"S2\"}, tuple{s# \"S3\"}, tuple{s# \"S4\"}}}, tuple{p# \"P3\", suppliers relation{tuple{s# \"S1\"}}}, tuple{p# \"P6\", suppliers relation{tuple{s# \"S1\"}}}, tuple{p# \"P1\", suppliers relation{tuple{s# \"S1\"},tuple{s# \"S2\"}}}, tuple{p# \"P7\", suppliers relation{s# Text}}}"+  res <- executeRelationalExpr sessionId dbconn (Equals (RelationVariable "x" ()) (RelationVariable "y" ()))+  assertEqual "outer join grouping" (Right relationTrue) res +  +testDDLHash :: Test+testDDLHash = TestCase $ do+  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback+  Right hash1 <- getDDLHash sessionId dbconn+  -- add a new rv+  executeTutorialD sessionId dbconn "x:=true"+  Right hash2 <- getDDLHash sessionId dbconn  +  assertBool "add relvar" (hash1 /= hash2)+  -- the test should break if the hash is calculated differently+  assertEqual "static hash check" "Gu8Uaw7WAl484jAEprlbeXRnF1tKKX4MvYBjL1TPnHI=" (B64.encode (_unSecureHash hash1))+  -- remove an rv+  executeTutorialD sessionId dbconn "undefine x"+  Right hash3 <- getDDLHash sessionId dbconn+  assertEqual "undefine relvar" hash1 hash3+  -- add a constraint+  executeTutorialD sessionId dbconn "constraint s_status_less_than_50 (s where gte(@status,50)){} in false"+  Right hash4 <- getDDLHash sessionId dbconn+  assertBool "add relvar" (hash4 `notElem` [hash1, hash2, hash3])+  -- change an rv's attributes+  executeTutorialD sessionId dbconn "y:=relation{a Integer}"+  Right hash5 <- getDDLHash sessionId dbconn+  executeTutorialD sessionId dbconn "undefine y"+  executeTutorialD sessionId dbconn "y:=relation{b Integer}"+  Right hash6 <- getDDLHash sessionId dbconn+  assertBool "change rv attribute" (hash6 `notElem` [hash1, hash2, hash3, hash4, hash5])+  -- change an rv name+  executeTutorialD sessionId dbconn "undefine y"+  executeTutorialD sessionId dbconn "z:=relation{b Integer}"+  Right hash7 <- getDDLHash sessionId dbconn+  assertBool "change rv attribute" (hash7 `notElem` [hash1, hash2, hash3, hash4, hash5, hash6])  ++testShowDDL :: Test+testShowDDL = TestCase $ do+  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback+  Right ddl <- ddlAsRelation sessionId dbconn+  --save it back to the db to run tutd on it+  _ <- executeDatabaseContextExpr sessionId dbconn (Assign "x" (ExistingRelation ddl))+  executeTutorialD sessionId dbconn "y := ((x{relation_variables}) ungroup relation_variables){name}"+  rel1 <- executeRelationalExpr sessionId dbconn (RelationVariable "y" ())+  let expected = mkRelationFromList (attributesFromList [Attribute "name" TextAtomType]) (map ((:[]) . TextAtom) ["s","p","sp","true", "false"])+  assertEqual "rv names" expected rel1++testRegisteredQueries :: Test+testRegisteredQueries = TestCase $ do+  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback+  -- test that an invalid query cannot be added+  Left err <- executeDatabaseContextExpr sessionId dbconn (AddRegisteredQuery "invalid_query" (RelationVariable "x" ()))+  assertEqual "invalid registered query" (RegisteredQueryValidationError "invalid_query" (RelVarNotDefinedError "x")) err+  -- add a query, then test that removing the rv triggers an error+  executeTutorialD sessionId dbconn "x:=relation{tuple{a 5}}"+  Right () <- executeDatabaseContextExpr sessionId dbconn (AddRegisteredQuery "protect_x" (RelationVariable "x" ()))+  Left err' <- executeDatabaseContextExpr sessionId dbconn (Undefine "x")+  assertEqual "prevent x deletion" (RegisteredQueryValidationError "protect_x" (RelVarNotDefinedError "x")) err'+  -- remove the query+  Right () <- executeDatabaseContextExpr sessionId dbconn (RemoveRegisteredQuery "protect_x")+  Right () <- executeDatabaseContextExpr sessionId dbconn (Undefine "x")  +  pure ()+