diff --git a/Changelog.markdown b/Changelog.markdown --- a/Changelog.markdown +++ b/Changelog.markdown @@ -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 diff --git a/examples/zoo.hs b/examples/zoo.hs --- a/examples/zoo.hs +++ b/examples/zoo.hs @@ -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 () diff --git a/project-m36.cabal b/project-m36.cabal --- a/project-m36.cabal +++ b/project-m36.cabal @@ -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 diff --git a/src/lib/ProjectM36/AccessControlList.hs b/src/lib/ProjectM36/AccessControlList.hs --- a/src/lib/ProjectM36/AccessControlList.hs +++ b/src/lib/ProjectM36/AccessControlList.hs @@ -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))) + + diff --git a/src/lib/ProjectM36/Client.hs b/src/lib/ProjectM36/Client.hs --- a/src/lib/ProjectM36/Client.hs +++ b/src/lib/ProjectM36/Client.hs @@ -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 { diff --git a/src/lib/ProjectM36/Function.hs b/src/lib/ProjectM36/Function.hs --- a/src/lib/ProjectM36/Function.hs +++ b/src/lib/ProjectM36/Function.hs @@ -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) + diff --git a/src/lib/ProjectM36/Module.hs b/src/lib/ProjectM36/Module.hs --- a/src/lib/ProjectM36/Module.hs +++ b/src/lib/ProjectM36/Module.hs @@ -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 diff --git a/src/lib/ProjectM36/RelationalExpression.hs b/src/lib/ProjectM36/RelationalExpression.hs --- a/src/lib/ProjectM36/RelationalExpression.hs +++ b/src/lib/ProjectM36/RelationalExpression.hs @@ -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' diff --git a/src/lib/ProjectM36/ScriptSession.hs b/src/lib/ProjectM36/ScriptSession.hs --- a/src/lib/ProjectM36/ScriptSession.hs +++ b/src/lib/ProjectM36/ScriptSession.hs @@ -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 diff --git a/src/lib/ProjectM36/Server.hs b/src/lib/ProjectM36/Server.hs --- a/src/lib/ProjectM36/Server.hs +++ b/src/lib/ProjectM36/Server.hs @@ -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 diff --git a/src/lib/ProjectM36/Server/EntryPoints.hs b/src/lib/ProjectM36/Server/EntryPoints.hs --- a/src/lib/ProjectM36/Server/EntryPoints.hs +++ b/src/lib/ProjectM36/Server/EntryPoints.hs @@ -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) diff --git a/src/lib/ProjectM36/StaticOptimizer.hs b/src/lib/ProjectM36/StaticOptimizer.hs --- a/src/lib/ProjectM36/StaticOptimizer.hs +++ b/src/lib/ProjectM36/StaticOptimizer.hs @@ -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)