e426984 · project-m36 · git.iko.soy

git.iko.soy/project-m36

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

commite4269844cd94d65cdab770a952ade24498e7d539 authorAgentM <agentm@themactionfaction.com> dateMon 12 Sep 2016, 23:41 (10 years ago) parentc58fbdb

4 files changed+51−34

compare with master

unifiedsplit

src/lib/ProjectM36/AtomFunctionBody.hs+8−3 src/lib/ProjectM36/Client.hs+13−5 src/lib/ProjectM36/Error.hs+1 src/lib/ProjectM36/RelationalExpression.hs+29−26

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

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

1212import GHC

1313import GHC.Paths (libdir)

1414import DynFlags

15+import Panic

1516import Outputable hiding ((<>))

1617import PprTyThing

1718import Type hiding (pprTyThing)

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

2122 hscEnv :: HscEnv,

2223 atomFunctionBodyType :: Type

2324 }

25+

26+data ScriptSessionError = ScriptSessionLoadError GhcException

27+ deriving (Show)

2428

2529-- | 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)

2731initScriptSession ghcPkgPaths = do

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

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

30− runGhc (Just libdir) $ do

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

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

3136 dflags <- getSessionDynFlags

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

3338

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

7782 "ProjectM36.Base"])

7883 env <- getSession

7984 fType <- mkAtomFunctionBodyType

80− pure (ScriptSession env fType)

85+ pure (Right (ScriptSession env fType))

8186

8287mkAtomFunctionBodyType :: Ghc Type

8388mkAtomFunctionBodyType = do

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

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

9696import Data.Binary (Binary)

9797import GHC.Generics (Generic)

9898import Control.DeepSeq (force)

99+import System.IO

99100--import Debug.Trace

100101

101102type Hostname = String

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

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

149150type ClientNodes = STMSet.Set ProcessId

150151

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

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

152153 RemoteProcessConnection LocalNode ProcessId

153154

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

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

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

190191 Right localNode -> forkProcess localNode (notificationListener callback)

191192

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+

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

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

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

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

203211 clientNodes <- STMSet.newIO

204212 sessions <- STMMap.newIO

205213 notificationPid <- startNotificationListener notificationCallback

206− interpreterSession <- initScriptSession ghcPkgPaths

207− let conn = InProcessConnection strat clientNodes sessions graphTvar interpreterSession

214+ mScriptSession <- createScriptSession ghcPkgPaths

215+ let conn = InProcessConnection strat clientNodes sessions graphTvar mScriptSession

208216 addClientNode conn notificationPid

209217 pure (Right conn)

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

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

251259 tvarGraph <- newTVarIO graph'

252260 sessions <- STMMap.newIO

253261 clientNodes <- STMSet.newIO

254− scriptSession <- initScriptSession ghcPkgPaths

255− let conn = InProcessConnection strat clientNodes sessions tvarGraph scriptSession

262+ mScriptSession <- createScriptSession ghcPkgPaths

263+ let conn = InProcessConnection strat clientNodes sessions tvarGraph mScriptSession

256264 notificationPid <- startNotificationListener notificationCallback

257265 addClientNode conn notificationPid

258266 pure (Right conn)

src/lib/ProjectM36/Error.hs+1

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

104104

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

106106 SyntaxErrorCompilationError String |

107+ ScriptCompilationDisabledError |

107108 OtherScriptCompilationError String

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

109110

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

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

339339 else

340340 pure (Just (AtomFunctionNameNotInUseError funcName))

341341

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

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

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

345− setSession (hscEnv scriptSession)

346− let atomFuncs = atomFunctions currentContext

347− --compile the function

348− eCompiledFunc <- compileAtomFunctionScript scriptSession script

349− pure $ case eCompiledFunc of

350− Left err -> Left (AtomFunctionBodyScriptError err)

351− Right compiledFunc -> do

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

353− let updatedFuncs = HS.insert newAtomFunc atomFuncs

354− newContext = currentContext { atomFunctions = updatedFuncs }

355− newAtomFunc = AtomFunction { atomFuncName = funcName,

356− atomFuncType = funcAtomType,

357− atomFuncBody = AtomFunctionBody (Just script) compiledFunc }

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

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

344+ case mScriptSession of

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

346+ Just scriptSession -> do

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

348+ setSession (hscEnv scriptSession)

349+ let atomFuncs = atomFunctions currentContext

350+ --compile the function

351+ eCompiledFunc <- compileAtomFunctionScript scriptSession script

352+ pure $ case eCompiledFunc of

353+ Left err -> Left (AtomFunctionBodyScriptError err)

354+ Right compiledFunc -> do

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

356+ let updatedFuncs = HS.insert newAtomFunc atomFuncs

357+ newContext = currentContext { atomFunctions = updatedFuncs }

358+ newAtomFunc = AtomFunction { atomFuncName = funcName,

359+ atomFuncType = funcAtomType,

360+ atomFuncBody = AtomFunctionBody (Just script) compiledFunc }

358361

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

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

361− Left (AtomFunctionNameInUseError funcName)

362− else do

363− Right newContext

364− case res of

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

366− Right eContext -> case eContext of

367− Left err -> pure (Left err)

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

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

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

364+ Left (AtomFunctionNameInUseError funcName)

365+ else do

366+ Right newContext

367+ case res of

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

369+ Right eContext -> case eContext of

370+ Left err -> pure (Left err)

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

369372

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

371374updateTupleWithAtomExprs exprMap context tupIn = do