e426984 · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

#43 allow executables to run with atom function scripting disabled if the feature's dependencies are missing

e426984AgentM10 years ago

src/lib/ProjectM36/AtomFunctionBody.hs+8−3

compare with master

unifiedsplit

@@ -12,6 +12,7 @@ import Unsafe.Coerce

12import GHC

13import GHC.Paths (libdir)

14import DynFlags

15+import Panic

15import Outputable hiding ((<>))

16import Outputable hiding ((<>))

16import PprTyThing

17import PprTyThing

17import Type hiding (pprTyThing)

18import Type hiding (pprTyThing)

@@ -21,13 +22,17 @@ data ScriptSession = ScriptSession {

21 hscEnv :: HscEnv,

22 hscEnv :: HscEnv,

22 atomFunctionBodyType :: Type

23 atomFunctionBodyType :: Type

23 }

24 }

25+

26+data ScriptSessionError = ScriptSessionLoadError GhcException

27+ deriving (Show)

25-- | Configure a GHC environment/session which we will use for all script compilation.

29-- | Configure a GHC environment/session which we will use for all script compilation.

26−initScriptSession :: [String] -> IO ScriptSession

30+initScriptSession :: [String] -> IO (Either ScriptSessionError ScriptSession)

27initScriptSession ghcPkgPaths = do

31initScriptSession ghcPkgPaths = do

28 --for the sake of convenience, for developers' builds, include the local cabal sandbox pacakge database

32 --for the sake of convenience, for developers' builds, include the local cabal sandbox pacakge database

29 sandboxPkgPaths <- liftIO (glob ".cabal-sandbox/*packages.conf.d")

33 sandboxPkgPaths <- liftIO (glob ".cabal-sandbox/*packages.conf.d")

34+ let excHandler exc = pure $ Left (ScriptSessionLoadError exc)

30− runGhc (Just libdir) $ do

35+ handleGhcException excHandler $ runGhc (Just libdir) $ do

31 dflags <- getSessionDynFlags

36 dflags <- getSessionDynFlags

32 let localPkgPaths = map PkgConfFile (ghcPkgPaths ++ sandboxPkgPaths)

37 let localPkgPaths = map PkgConfFile (ghcPkgPaths ++ sandboxPkgPaths)

@@ -77,7 +82,7 @@ initScriptSession ghcPkgPaths = do

77 "ProjectM36.Base"])

82 "ProjectM36.Base"])

78 env <- getSession

83 env <- getSession

79 fType <- mkAtomFunctionBodyType

84 fType <- mkAtomFunctionBodyType

80− pure (ScriptSession env fType)

85+ pure (Right (ScriptSession env fType))

82mkAtomFunctionBodyType :: Ghc Type

87mkAtomFunctionBodyType :: Ghc Type

83mkAtomFunctionBodyType = do

88mkAtomFunctionBodyType = do

src/lib/ProjectM36/Client.hs+13−5

@@ -96,6 +96,7 @@ import ListT

96import Data.Binary (Binary)

97import GHC.Generics (Generic)

98import Control.DeepSeq (force)

99+import System.IO

99--import Debug.Trace

100--import Debug.Trace

100

101

101type Hostname = String

102type Hostname = String

@@ -148,7 +149,7 @@ defaultRemoteConnectionInfo = RemoteProcessConnectionInfo defaultDatabaseName (c

148-- | The 'Connection' represents either local or remote access to a database. All operations flow through the connection.

149-- | The 'Connection' represents either local or remote access to a database. All operations flow through the connection.

149type ClientNodes = STMSet.Set ProcessId

150type ClientNodes = STMSet.Set ProcessId

150

151

151−data Connection = InProcessConnection PersistenceStrategy ClientNodes Sessions (TVar TransactionGraph) ScriptSession |

152+data Connection = InProcessConnection PersistenceStrategy ClientNodes Sessions (TVar TransactionGraph) (Maybe ScriptSession) |

152 RemoteProcessConnection LocalNode ProcessId

153 RemoteProcessConnection LocalNode ProcessId

153

154

154-- | There are several reasons why a connection can fail.

155-- | There are several reasons why a connection can fail.

@@ -189,6 +190,13 @@ startNotificationListener callback = do

189 Left err -> error ("Failed to start local notification listener: " ++ show err)

190 Left err -> error ("Failed to start local notification listener: " ++ show err)

190 Right localNode -> forkProcess localNode (notificationListener callback)

191 Right localNode -> forkProcess localNode (notificationListener callback)

191

192

193+createScriptSession :: [String] -> IO (Maybe ScriptSession)

194+createScriptSession ghcPkgPaths = do

195+ eScriptSession <- initScriptSession ghcPkgPaths

196+ case eScriptSession of

197+ Left err -> hPutStrLn stderr ("Failed to load scripting engine- scripting disabled: " ++ (show err)) >> pure Nothing --not a fatal error, but the scripting feature must be disabled

198+ Right s -> pure (Just s)

199+

192-- | To create a 'Connection' to a remote or local database, create a connectionInfo and call 'connectProjectM36'.

200-- | To create a 'Connection' to a remote or local database, create a connectionInfo and call 'connectProjectM36'.

193connectProjectM36 :: ConnectionInfo -> IO (Either ConnectionError Connection)

201connectProjectM36 :: ConnectionInfo -> IO (Either ConnectionError Connection)

194--create a new in-memory database/transaction graph

202--create a new in-memory database/transaction graph

@@ -203,8 +211,8 @@ connectProjectM36 (InProcessConnectionInfo strat notificationCallback ghcPkgPath

203 clientNodes <- STMSet.newIO

211 clientNodes <- STMSet.newIO

204 sessions <- STMMap.newIO

212 sessions <- STMMap.newIO

205 notificationPid <- startNotificationListener notificationCallback

213 notificationPid <- startNotificationListener notificationCallback

206− interpreterSession <- initScriptSession ghcPkgPaths

214+ mScriptSession <- createScriptSession ghcPkgPaths

207− let conn = InProcessConnection strat clientNodes sessions graphTvar interpreterSession

215+ let conn = InProcessConnection strat clientNodes sessions graphTvar mScriptSession

208 addClientNode conn notificationPid

216 addClientNode conn notificationPid

209 pure (Right conn)

217 pure (Right conn)

210 MinimalPersistence dbdir -> connectPersistentProjectM36 strat NoDiskSync dbdir freshGraph notificationCallback ghcPkgPaths

218 MinimalPersistence dbdir -> connectPersistentProjectM36 strat NoDiskSync dbdir freshGraph notificationCallback ghcPkgPaths

@@ -251,8 +259,8 @@ connectPersistentProjectM36 strat sync dbdir freshGraph notificationCallback ghc

251 tvarGraph <- newTVarIO graph'

259 tvarGraph <- newTVarIO graph'

252 sessions <- STMMap.newIO

260 sessions <- STMMap.newIO

253 clientNodes <- STMSet.newIO

261 clientNodes <- STMSet.newIO

254− scriptSession <- initScriptSession ghcPkgPaths

262+ mScriptSession <- createScriptSession ghcPkgPaths

255− let conn = InProcessConnection strat clientNodes sessions tvarGraph scriptSession

263+ let conn = InProcessConnection strat clientNodes sessions tvarGraph mScriptSession

256 notificationPid <- startNotificationListener notificationCallback

264 notificationPid <- startNotificationListener notificationCallback

257 addClientNode conn notificationPid

265 addClientNode conn notificationPid

258 pure (Right conn)

266 pure (Right conn)

src/lib/ProjectM36/Error.hs+1

@@ -104,6 +104,7 @@ instance NFData MergeError where rnf = genericRnf

104

105data AtomFunctionBodyCompilationError = TypeCheckCompilationError String String | --expected, got

106 SyntaxErrorCompilationError String |

107+ ScriptCompilationDisabledError |

107 OtherScriptCompilationError String

108 OtherScriptCompilationError String

108 deriving (Show,Eq, Generic, Binary, Typeable, NFData)

109 deriving (Show,Eq, Generic, Binary, Typeable, NFData)

109

110

src/lib/ProjectM36/RelationalExpression.hs+29−26

@@ -339,33 +339,36 @@ evalContextExpr (RemoveAtomFunction funcName) = do

339 else

340 pure (Just (AtomFunctionNameNotInUseError funcName))

341

342−evalDatabaseContextIOExpr :: ScriptSession -> DatabaseContext -> DatabaseContextIOExpr -> IO (Either RelationalError DatabaseContext)

342+evalDatabaseContextIOExpr :: Maybe ScriptSession -> DatabaseContext -> DatabaseContextIOExpr -> IO (Either RelationalError DatabaseContext)

343−evalDatabaseContextIOExpr scriptSession currentContext (AddAtomFunction funcName funcType script) = do

343+evalDatabaseContextIOExpr mScriptSession currentContext (AddAtomFunction funcName funcType script) = do

344+ case mScriptSession of

345+ Nothing -> pure (Left (AtomFunctionBodyScriptError ScriptCompilationDisabledError))

346+ Just scriptSession -> do

344− res <- try $ runGhc (Just libdir) $ do

347+ res <- try $ runGhc (Just libdir) $ do

345− setSession (hscEnv scriptSession)

348+ setSession (hscEnv scriptSession)

346− let atomFuncs = atomFunctions currentContext

349+ let atomFuncs = atomFunctions currentContext

347− --compile the function

350+ --compile the function

348− eCompiledFunc <- compileAtomFunctionScript scriptSession script

351+ eCompiledFunc <- compileAtomFunctionScript scriptSession script

349− pure $ case eCompiledFunc of

352+ pure $ case eCompiledFunc of

350− Left err -> Left (AtomFunctionBodyScriptError err)

353+ Left err -> Left (AtomFunctionBodyScriptError err)

351− Right compiledFunc -> do

354+ Right compiledFunc -> do

352− funcAtomType <- mapM (\funcTypeArg -> atomTypeForTypeConstructor funcTypeArg (typeConstructorMapping currentContext)) funcType

355+ funcAtomType <- mapM (\funcTypeArg -> atomTypeForTypeConstructor funcTypeArg (typeConstructorMapping currentContext)) funcType

353− let updatedFuncs = HS.insert newAtomFunc atomFuncs

356+ let updatedFuncs = HS.insert newAtomFunc atomFuncs

354− newContext = currentContext { atomFunctions = updatedFuncs }

357+ newContext = currentContext { atomFunctions = updatedFuncs }

355− newAtomFunc = AtomFunction { atomFuncName = funcName,

358+ newAtomFunc = AtomFunction { atomFuncName = funcName,

356− atomFuncType = funcAtomType,

359+ atomFuncType = funcAtomType,

357− atomFuncBody = AtomFunctionBody (Just script) compiledFunc }

360+ atomFuncBody = AtomFunctionBody (Just script) compiledFunc }

358

361

359− -- check if the name is already in use

362+ -- check if the name is already in use

360− if HS.member funcName (HS.map atomFuncName atomFuncs) then

363+ if HS.member funcName (HS.map atomFuncName atomFuncs) then

361− Left (AtomFunctionNameInUseError funcName)

364+ Left (AtomFunctionNameInUseError funcName)

362− else do

365+ else do

363− Right newContext

366+ Right newContext

364− case res of

367+ case res of

365− Left (exc :: SomeException) -> pure $ Left (AtomFunctionBodyScriptError (OtherScriptCompilationError (show exc)))

368+ Left (exc :: SomeException) -> pure $ Left (AtomFunctionBodyScriptError (OtherScriptCompilationError (show exc)))

366− Right eContext -> case eContext of

369+ Right eContext -> case eContext of

367− Left err -> pure (Left err)

370+ Left err -> pure (Left err)

368− Right context' -> pure (Right context')

371+ Right context' -> pure (Right context')

369

372

370updateTupleWithAtomExprs :: (M.Map AttributeName AtomExpr) -> DatabaseContext -> RelationTuple -> Either RelationalError RelationTuple

373updateTupleWithAtomExprs :: (M.Map AttributeName AtomExpr) -> DatabaseContext -> RelationTuple -> Either RelationalError RelationTuple

371updateTupleWithAtomExprs exprMap context tupIn = do

374updateTupleWithAtomExprs exprMap context tupIn = do