project-m36 1.2.4 → 1.2.5

raw patch · 12 files changed

+220/−113 lines, 12 filesdep ~basedep ~base16-bytestringdep ~ghcPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base, base16-bytestring, ghc, megaparsec, stm-containers

API changes (from Hackage documentation)

Files

• Changelog.markdown +4/−0
• examples/zoo.hs +45/−65
• project-m36.cabal +48/−7
• src/lib/ProjectM36/AccessControlList.hs +22/−2
• src/lib/ProjectM36/Client.hs +13/−2
• src/lib/ProjectM36/Function.hs +15/−1
• src/lib/ProjectM36/Module.hs +5/−2
• src/lib/ProjectM36/RelationalExpression.hs +37/−26
• src/lib/ProjectM36/ScriptSession.hs +18/−4
• src/lib/ProjectM36/Server.hs +4/−1
• src/lib/ProjectM36/Server/EntryPoints.hs +6/−2
• src/lib/ProjectM36/StaticOptimizer.hs +3/−1

@@ -1,3 +1,7 @@+# 2026-02-22 (v1.2.5)++* include GHC in docker image so that users can use the new Haskell module functionality+ # 2026-02-16 (v1.2.4)  * fix bug resulting in duplicate rows after group operator application

@@ -1,74 +1,54 @@-{-# 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)+{-# LANGUAGE OverloadedStrings #-}+-- | A variant of the zoo module example to test compilation.+--module Zoo where+import ProjectM36.Module+import ProjectM36.AccessControlList 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")+import ProjectM36.Base+import qualified Data.Map as M -  -- create a session on the master branch-  sessionId <- failFast $ createSessionAtHead conn "master"+{- Setup+:addloginrole ticket_seller maylogin+ticket_sales := relation{ticketId Integer, visitorAge Integer, price Integer, visitDate Day}+-} -  -- 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)+type Age = Integer+type Price = Integer -  -- 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)+applyDiscount :: Age -> Price -> Price+applyDiscount age price =+  if age <= 10 then+    price `div` 2+    else+    price -  -- print out the resultant relation-  Right ticketSalesRelation <- executeRelationalExpr sessionId conn (RelationVariable "ticket_sales" ())-  T.putStrLn $ showRelation ticketSalesRelation+{-+applyDiscount :: Age -> Price -> Day -> Integer+applyDiscount age price day =+  if age <= 10 && not isNewYearsDay then+    price `div` 2+    else+    price+ where+  isNewYearsDay =+    case toGregorian day of+      (_, m, d) -> m == 1 && d == 1+-} - +addSale :: Integer -> Integer -> Integer -> Day -> DatabaseContextFunctionMonad ()+addSale ticketId age price purchaseDay = do+  let tuples = [TupleExpr (M.fromList [("ticketId", i ticketId),+                                       ("visitorAge", i age),+                                       ("price", FunctionAtomExpr "applyDiscount" [i age, i price] ()),+                                       ("visitDate", NakedAtomExpr (DayAtom purchaseDay))])]+      i = NakedAtomExpr . IntegerAtom+  executeDatabaseContextExpr (Insert "ticket_sales" (MakeRelationFromExprs Nothing (TupleExprs () tuples)))  --- | 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+projectM36Functions :: EntryPoints ()+projectM36Functions = do+  declareAtomFunction "applyDiscount"+--  declareDatabaseContextFunction "addSale" (permissionForRole ExecuteDBCFunctionPermission "ticket_seller" <> allPermissionsForRole "admin") -  +main :: IO ()+main = pure ()

@@ -1,6 +1,6 @@ Cabal-Version: 2.2 Name: project-m36-Version: 1.2.4+Version: 1.2.5 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@@ -31,6 +31,11 @@     Manual: True     Default: False +Flag build-examples+     Description: build example executables+     Manual: True+     Default: False+ Flag haskell-scripting      Description: enables Haskell scripting which links against GHC as a library      Manual: True@@ -459,7 +464,8 @@     Default-Language: Haskell2010     Default-Extensions: OverloadedStrings -Executable bigrel+Benchmark bigrel+    Type: exitcode-stdio-1.0               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, curryer-rpc@@ -660,6 +666,10 @@     main-is: Server/Main.hs  Executable Example-SimpleClient+    if flag(build-examples)+      buildable: True+    else+      buildable: False            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, curryer-rpc@@ -667,6 +677,10 @@     GHC-Options: -Wall -threaded  Executable Example-OutOfTheTarpit+    if flag(build-examples)+      buildable: True+    else+      buildable: False            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@@ -674,6 +688,10 @@     GHC-Options: -Wall -threaded  Executable Example-Blog+    if flag(build-examples)+      buildable: True+    else+      buildable: False            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.30, blaze-html, http-types, winery, random@@ -681,6 +699,10 @@     GHC-Options: -Wall -threaded  Executable Example-Hair+    if flag(build-examples)+      buildable: True+    else+      buildable: False            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@@ -688,6 +710,10 @@     GHC-Options: -Wall -threaded  Executable Example-Plantfarm+    if flag(build-examples)+      buildable: True+    else+      buildable: False            Default-Language: Haskell2010     Default-Extensions: OverloadedStrings     Build-Depends:  aeson, barbies, base, containers, deepseq, hashable, project-m36, random, scotty >= 0.22, text, winery, exceptions@@ -695,6 +721,10 @@     GHC-Options: -Wall -threaded  Executable Example-CustomTupleable+    if flag(build-examples)+      buildable: True+    else+      buildable: False            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@@ -702,25 +732,35 @@     GHC-Options: -Wall -threaded  Executable Example-Hospital+    if flag(build-examples)+      buildable: True+    else+      buildable: False            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 flag(build-examples)+      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+    if flag(build-examples)+      buildable: True+    else+      buildable: False            Default-Language: Haskell2010-    Build-Depends: base, text, deepseq, project-m36, winery, random, time+    Build-Depends: base, text, deepseq, project-m36, winery, random, time, containers     Main-Is: examples/zoo.hs     GHC-Options: -Wall -threaded-           Test-Suite test-scripts     import: commontest@@ -776,7 +816,8 @@     type: exitcode-stdio-1.0  -- test for file handle leaks-Executable handles+Benchmark handles+    Type: exitcode-stdio-1.0               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, curryer-rpc

@@ -8,6 +8,7 @@ import qualified Data.Map as M import Data.Maybe (fromMaybe) import Data.Default+import Control.Monad (foldM)  newtype AccessControlList role' permission =     AccessControlList (M.Map role' (RoleAccess permission))@@ -120,9 +121,12 @@ 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))))+allPermissionsForRole :: (AllPermissions p, Ord p) => r -> AccessControlList r p+allPermissionsForRole roleid = AccessControlList (M.singleton roleid (M.fromList (map (,True) (S.toList allPermissions)))) +permissionForRole :: Ord p => p -> r -> AccessControlList r p+permissionForRole perm roleid = AccessControlList (M.singleton roleid (M.singleton perm False))+ 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@@ -191,4 +195,20 @@                       SomeDBCFunctionPermission DBCFunctionPermission                     deriving (Show, NFData, Generic, Eq, Hashable) +-- | Resolve the first parameter in the AccessContrList, typically a role name resolving to a role id.+resolve :: Ord r2 => (r1 -> IO (Maybe r2)) -> AccessControlList r1 a -> IO (Either r1 (AccessControlList r2 a))+resolve resolver (AccessControlList aclIn) = do+  let folder (Right acc) (r, v) = do+        eR2 <- resolver r+        case eR2 of+          Nothing -> pure (Left r)+          Just r2 -> pure (Right ((r2,v):acc))+      folder (Left acc) _ = pure (Left acc)+  eres <- foldM folder (Right []) (M.toList aclIn)+  case eres of+    Left errR -> pure (Left errR)+    Right res ->+      pure (Right (AccessControlList (M.fromList res)))++         

@@ -186,7 +186,7 @@ import ProjectM36.ValueMarker import ProjectM36.AccessControl import ProjectM36.Sessions-import ProjectM36.AccessControlList+import ProjectM36.AccessControlList as ACL import ProjectM36.HashSecurely (SecureHash) import ProjectM36.RegisteredQuery import qualified ProjectM36.Cache.RelationalExprCache as RelExprCache@@ -769,7 +769,18 @@     Left err -> pure (Left err)     Right session -> do       graph <- readTVarIO (ipTransactionGraph conf)-      let env = RE.DatabaseContextIOEvalEnv transId graph scriptSession myRoleId objFilesPath dbcFuncUtils+      let env = RE.DatabaseContextIOEvalEnv transId graph scriptSession myRoleId resolveRoleNameACL objFilesPath dbcFuncUtils+          resolveRoleNameACL :: forall a. AccessControlList RoleName a -> IO (Either RelationalError (AccessControlList RoleId a))+          resolveRoleNameACL acl' = do+            eRes <- ACL.resolve (\r -> do+                            eRid <- LoginRoles.roleIdForRoleName r (ipLoginRoles conf)+                            pure $ case eRid of+                              Left _err -> Nothing+                              Right rid -> Just rid+                        ) acl'+            case eRes of+              Left badR -> pure (Left (NoSuchRoleNameError badR))+              Right res -> pure (Right res)           dbcEnv = RE.mkDatabaseContextEvalEnv transId graph dbcFuncUtils           roleNameResolver nam = fst <$> lookup nam roles                 dbcFuncUtils = DBC.DatabaseContextFunctionUtils {

@@ -113,4 +113,18 @@   "runDatabaseContextFunctionMonad env dbContext $ do\n" <>   "  " <> T.unpack funcName' <> " " <>   unwords (map (\i -> "val" <> show i) [1 .. length aType])-  ++findFunctionByName :: FunctionName -> HS.HashSet (Function a acl) -> Maybe (Function a acl)+findFunctionByName fname funcs =+  case HS.toList (HS.filter (\f -> funcName f == fname) funcs) of+    [match] -> Just match+    _ -> Nothing -- returns nothing on multiple matches, too!++addOrReplaceFunction :: Function a acl -> HS.HashSet (Function a acl) -> HS.HashSet (Function a acl)+addOrReplaceFunction addFunc funcs =+  case findFunctionByName (funcName addFunc) funcs of+    Nothing -> -- no match, so just insert+      HS.insert addFunc funcs+    Just funcToReplace ->+      HS.insert addFunc (HS.delete funcToReplace funcs)+      

@@ -9,10 +9,13 @@ import Control.Monad.Except (ExceptT, throwError, runExceptT) import Data.Functor.Identity +-- | Variant of ACLs which use roles to be later resolved to role ids used by user-facing ProjectM36.Module.+type DBCFunctionRoleNameAccessControlList = AccessControlList RoleName DBCFunctionPermission+ declareAtomFunction :: FunctionName -> EntryPoints () declareAtomFunction nam = tell [DeclareAtomFunction nam] -declareDatabaseContextFunction :: FunctionName -> DBCFunctionAccessControlList -> EntryPoints ()+declareDatabaseContextFunction :: FunctionName -> DBCFunctionRoleNameAccessControlList -> EntryPoints () declareDatabaseContextFunction nam acl' = tell [DeclareDatabaseContextFunction nam acl']  type EntryPoints = Writer [DeclareFunction]@@ -21,7 +24,7 @@ runEntryPoints = execWriter  data DeclareFunctionBase a = DeclareAtomFunction a |-                             DeclareDatabaseContextFunction a DBCFunctionAccessControlList+                             DeclareDatabaseContextFunction a DBCFunctionRoleNameAccessControlList   deriving (Show)  type DeclareFunction = DeclareFunctionBase FunctionName

@@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE OverloadedStrings  #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-} module ProjectM36.RelationalExpression where import ProjectM36.Relation import ProjectM36.Tuple@@ -51,7 +52,7 @@ import ProjectM36.NormalizeExpr import ProjectM36.WithNameExpr import ProjectM36.Function-import ProjectM36.AccessControlList as ACL+import ProjectM36.AccessControlList (RoleId, AccessControlList, SomePermission(..), relvarsACL, dbcFunctionsACL, schemaACL, transGraphACL, aclACL, allPermissionsForRole, addAccess, removeAccess) import Test.QuickCheck import Data.Functor (void) import qualified Data.Functor.Foldable as Fold@@ -65,8 +66,10 @@ import GHC hiding (getContext) import Control.Exception import GHC.Paths+--import System.FilePath --import GHC.Unit.State (emptyUnitState) --import GHC.Driver.Ppr (showSDocForUser)+--import GHC.Utils.Outputable (ppr) --import GHC.Unit.Finder.Types (FindResult(..)) --import GHC.Unit.Finder (findImportedModule) import GHC.Types.Name.Occurrence (mkVarOcc, mkTcOcc)@@ -77,7 +80,7 @@ import GHC.Core.TyCo.Compare (eqType) import Unsafe.Coerce import Control.Monad (forM)---import GHC.Utils.Outputable (ppr)+ #endif  data DatabaseContextExprDetails = CountUpdatedTuples@@ -557,6 +560,7 @@     dbcio_graph :: TransactionGraph,     dbcio_mScriptSession :: Maybe ScriptSession,     dbcio_roleId :: RoleId,+    resolveRoleNameACL :: forall x. AccessControlList RoleName x -> IO (Either RelationalError (AccessControlList RoleId x)),     dbcio_mModulesDirectory :: Maybe FilePath, -- ^ when running in persistent mode, this must be a Just value to a directory containing .o/.so/.dynlib files which the user has placed there for access to compiled functions     dbcio_dbcfunctionUtils :: DatabaseContextFunctionUtils   }@@ -660,7 +664,7 @@                     funcName = funcName',                     funcType = funcAtomType,                     funcBody = FunctionScriptBody script compiledFunc,-                    funcACL = allPermissionsForRoleId myRoleId+                    funcACL = allPermissionsForRole myRoleId                     }                 -- check if the name is already in use               if HS.member funcName' (HS.map funcName dbcFuncs) then@@ -1888,6 +1892,7 @@ importModuleFromPath _scriptSession _moduleSource = throwError (ScriptError ScriptCompilationDisabledError) #else importModuleFromPath scriptSession moduleSource = do+  resolveRoleNameACLF <- resolveRoleNameACL <$> ask   res <- liftIO $ try $ do     withSystemTempFile "pm36module" $ \tempModulePath tempModuleHandle -> do       hClose tempModuleHandle@@ -1895,7 +1900,7 @@       runGhc (Just libdir) $ do     -- GHC needs to see the module on disk, so we write it to a temporary location         setSession (hscEnv scriptSession)-        dflags <- getSessionDynFlags        +        dflags <- getSessionDynFlags         let target = Target {               targetId = TargetFile tempModulePath Nothing,               targetAllowObjCode = False,@@ -1907,7 +1912,7 @@         case loadSuccess of           Failed -> pure (Left (ScriptError ModuleLoadError))           Succeeded -> do-            {-modRes <- liftIO $ findImportedModule (hscEnv scriptSession) (mkModuleName "ProjectM36.Base") NoPkgQual+{-            modRes <- liftIO $ findImportedModule (hscEnv scriptSession) (mkModuleName "ProjectM36.Base") NoPkgQual             liftIO $ case modRes of               Found modLoc _mod -> do                 let packageLoc = takeDirectory (takeDirectory (takeDirectory (ml_dyn_obj_file modLoc)))@@ -1958,26 +1963,31 @@                               tyConv <- mkTypeConversions                                                             mkFunctions <- forM funcDeclarations $ \funcDecl -> do                                   case funcDecl of-                                    DeclareDatabaseContextFunction funcS acl' -> do-                                      fType <- exprType TM_Default (T.unpack funcS)-                                      dbcFuncMonadType <- exprType TM_Default "undefined :: DatabaseContextFunctionMonad ()"                                      -                                      -- extract arguments for dbc function-                                      let eAtomFuncType = convertGhcTypeToDatabaseContextFunctionAtomType dflags tyConv dbcFuncMonadType fType-                                      case eAtomFuncType of-                                        Left err -> throw (OtherScriptCompilationError (show err))-                                        Right dbcFuncType -> do-                                          let interpretedFunc = wrapDatabaseContextFunction dbcFuncType funcS-                                          dbcFunc :: DatabaseContextFunctionBodyType <- unsafeCoerce <$> compileExpr interpretedFunc-                                          let newDBCFunc = Function { funcName = funcS,-                                                                            funcType = dbcFuncType,-                                                                            funcBody = FunctionScriptBody (T.pack interpretedFunc) dbcFunc,-                                                                            funcACL = acl' }-                                          pure (MkDatabaseContextFunction newDBCFunc)+                                    DeclareDatabaseContextFunction funcS roleNameACL -> do+                                      --resolve role name ACL into role-id-based ACL                                      +                                      eACL <- liftIO $ resolveRoleNameACLF roleNameACL+                                      case eACL of+                                        Left err -> throw err+                                        Right acl' -> do+                                          fType <- exprType TM_Default (T.unpack funcS)+                                          dbcFuncMonadType <- exprType TM_Default "undefined :: DatabaseContextFunctionMonad ()"                                      +                                          -- extract arguments for dbc function+                                          let eAtomFuncType = convertGhcTypeToDatabaseContextFunctionAtomType dflags tyConv dbcFuncMonadType fType+                                          case eAtomFuncType of+                                            Left err -> throw (OtherScriptCompilationError (show err))+                                            Right dbcFuncType -> do+                                              let interpretedFunc = wrapDatabaseContextFunction dbcFuncType funcS+                                              dbcFunc :: DatabaseContextFunctionBodyType <- unsafeCoerce <$> compileExpr interpretedFunc+                                              let newDBCFunc = Function { funcName = funcS,+                                                                          funcType = dbcFuncType,+                                                                          funcBody = FunctionScriptBody (T.pack interpretedFunc) dbcFunc,+                                                                          funcACL = acl' }+                                              pure (MkDatabaseContextFunction newDBCFunc)                                     DeclareAtomFunction funcS -> do                                       --extract type from function in script                                       fType <- exprType TM_Default (T.unpack funcS)                                       let eAtomFuncType = convertGhcTypeToFunctionAtomType dflags tyConv fType -                                      --liftIO $ print eAtomFuncType+                                      liftIO $ print eAtomFuncType                                       --liftIO $ putStrLn $ showSDocForUser dflags emptyUnitState alwaysQualify (ppr fType)                                       case eAtomFuncType of                                         Left err -> error (show err)@@ -2012,13 +2022,14 @@             ctx <- getDBCIOContext             atomFuncs <- resolveIODBC atomFunctions             dbcFuncs <- resolveIODBC dbcFunctions+            -- must must delete the function from the hashset in order to replace it             let foldMkFunction (atomFuncHS, dbcFuncHS) (MkAtomFunction atomFunc) =-                  (HS.insert atomFunc atomFuncHS, dbcFuncHS)+                  (addOrReplaceFunction atomFunc atomFuncHS, dbcFuncHS)                 foldMkFunction (atomFuncHS, dbcFuncHS) (MkDatabaseContextFunction dbcFunc) =-                  (atomFuncHS, HS.insert dbcFunc dbcFuncHS)-                (newAtomFuncs, newDBCFuncs) = foldl' foldMkFunction (mempty, mempty) mkFunctions-                ctx' = ctx { dbcFunctions = ValueMarker $ HS.union newDBCFuncs dbcFuncs,-                             atomFunctions = ValueMarker $ HS.union newAtomFuncs atomFuncs+                  (atomFuncHS, addOrReplaceFunction dbcFunc dbcFuncHS)+                (newAtomFuncs, newDBCFuncs) = foldl' foldMkFunction (atomFuncs, dbcFuncs) mkFunctions+                ctx' = ctx { dbcFunctions = ValueMarker newDBCFuncs,+                             atomFunctions = ValueMarker newAtomFuncs                             }              putDBCIOContext ctx'

@@ -28,10 +28,11 @@ -- GHC 9.4+ import Data.List.NonEmpty(NonEmpty(..)) import GHC.Utils.Panic (handleGhcException)-import GHC.Driver.Session (projectVersion, PackageDBFlag(PackageDB), PkgDbRef(PkgDbPath), TrustFlag(TrustPackage), gopt_set, xopt_set, PackageFlag(ExposePackage), PackageArg(PackageArg), ModRenaming(ModRenaming))+import GHC.Driver.Session (projectVersion, PackageDBFlag(PackageDB), PkgDbRef(PkgDbPath), TrustFlag(TrustPackage), gopt_set, xopt_set, PackageFlag(ExposePackage), PackageArg(PackageArg), ModRenaming(ModRenaming), runCmdLineP, setFlagsFromEnvFile)+import GHC.Driver.CmdLine (runEwM) import GHC.Types.SourceText (SourceText(NoSourceText)) import GHC.Driver.Ppr (showSDocForUser)-import GHC.Utils.Outputable (ppr, Outputable)+import GHC.Utils.Outputable (Outputable, ppr) --import GHC.Unit.Module.Graph (showModMsg, mgModSummaries') import GHC.Core.TyCo.Ppr (pprType) import GHC.Utils.Encoding (zEncodeString)@@ -148,8 +149,10 @@                              "project-m36",                              "bytestring"]         packages = map (\m -> ExposePackage ("-package " ++ m) (PackageArg m) (ModRenaming True [])) required_packages-  --liftIO $ traceShowM (showSDoc dflags' (ppr packages))-    _ <- setSessionDynFlags dflags'+    --liftIO $ traceShowM (showSDoc dflags' (ppr packages))+    -- load GHC environment file, if specific in environment variables+    dflags'' <- loadGhcEnvFile dflags'+    _ <- setSessionDynFlags dflags''     let unqualifiedModules = map (\modn -> IIDecl $ safeImportDecl modn Nothing) [           "Prelude",           "Data.Map",@@ -429,4 +432,15 @@       rest <- convertGhcTypeToDatabaseContextFunctionAtomType dflags tyConv dbcFuncMonadType (ft_res fun)       pure (arg <> rest)     other -> Left (UnsupportedTypeConversionError (pprShow other dflags))++loadGhcEnvFile :: GhcMonad m => DynFlags -> m DynFlags+loadGhcEnvFile dflags = do+  mEnvPath <- liftIO $ lookupEnv "GHC_ENVIRONMENT"+--  traceShowM ("GHC_ENVIRONMENT"::String, mEnvPath)+  case mEnvPath of+    Nothing -> pure dflags+    Just envPath -> do+      content <- liftIO $ readFile envPath+      let (_, dflags') = runCmdLineP (runEwM (setFlagsFromEnvFile envPath content)) dflags+      pure dflags' #endif

@@ -131,7 +131,10 @@                         handleRetrieveNotificationsAsRelation ti sessionId conn),      RequestHandler (\sState (ExecuteAlterTransactionGraphExpr sessionId expr) -> do                         conn <- getConn sState-                        handleExecuteAlterTransactionGraphExpr ti sessionId conn expr)+                        handleExecuteAlterTransactionGraphExpr ti sessionId conn expr),+     RequestHandler (\sState (ExecuteAlterLoginRolesExpr sessionId expr) -> do+                        conn <- getConn sState+                        handleExecuteAlterLoginRolesExpr ti sessionId conn expr)      ] ++ if testFlag then testModeHandlers ti else []  getConn :: ConnectionState ServerState -> IO Connection

@@ -5,6 +5,7 @@ import ProjectM36.HashSecurely import ProjectM36.SQL.Select import ProjectM36.SQL.DBUpdate+import ProjectM36.LoginRoles import ProjectM36.Client as C import Data.Map import Control.Concurrent (threadDelay)@@ -19,13 +20,12 @@     Just micros ->       timeout (fromIntegral micros) act -timeoutRelErr :: Maybe Timeout -> IO (Either RelationalError a) -> IO (Either RelationalError a)+timeoutRelErr :: Maybe Timeout -> IO (Either e a) -> IO (Either e a) timeoutRelErr mMicros act = do   ret <- timeoutOrDie mMicros act   case ret of     Nothing -> throw TimeoutException     Just v -> pure v-                                        handleExecuteRelationalExpr :: Maybe Timeout -> SessionId -> Connection -> RelationalExpr -> IO (Either RelationalError Relation) handleExecuteRelationalExpr ti sessionId conn expr = @@ -176,3 +176,7 @@ handleRetrieveNotificationsAsRelation :: Maybe Timeout -> SessionId -> Connection -> IO (Either RelationalError Relation) handleRetrieveNotificationsAsRelation ti sessionId conn =   timeoutRelErr ti (C.notificationsAsRelation sessionId conn)++handleExecuteAlterLoginRolesExpr :: Maybe Timeout -> SessionId -> Connection -> AlterLoginRolesExpr -> IO (Either LoginRoleError SuccessResult)+handleExecuteAlterLoginRolesExpr ti session conn expr =+  timeoutRelErr ti (C.executeAlterLoginRolesExpr session conn expr)

@@ -205,8 +205,9 @@ optimizeAndEvalTransGraphRelationalExpr :: TransactionGraph -> TransGraphRelationalExpr -> Either RelationalError Relation optimizeAndEvalTransGraphRelationalExpr graph tgExpr = do   gfExpr <- TGRE.process (TransGraphEvalEnv graph) tgExpr-  optExpr <- runGraphRefSOptRelationalExprM Nothing graph (fullOptimizeGraphRefRelationalExpr gfExpr)   let gfEnv = freshGraphRefRelationalExprEnv Nothing graph+  _ <- runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr)+  optExpr <- runGraphRefSOptRelationalExprM Nothing graph (fullOptimizeGraphRefRelationalExpr gfExpr)   runGraphRefRelationalExprM gfEnv (evalGraphRefRelationalExpr optExpr)  optimizeAndEvalTransGraphRelationalExprWithCache :: RandomGen r => r -> TransactionGraph -> TransGraphRelationalExpr -> RelExprCache -> IO (Either RelationalError Relation)@@ -214,6 +215,7 @@   let gfEnv = freshGraphRefRelationalExprEnv Nothing graph       res = do         gfExpr <- TGRE.process (TransGraphEvalEnv graph) tgExpr+        _typ <- runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr)         runGraphRefSOptRelationalExprM Nothing graph (fullOptimizeGraphRefRelationalExpr gfExpr)   case res of     Left err -> pure (Left err)