@@ -1,3 +1,4 @@
1+{-# LANGUAGE TypeApplications #-}
12module ProjectM36.Transaction.Persist where
23import ProjectM36.Base
34import ProjectM36.Error
@@ -15,13 +16,17 @@ import qualified Data.Text as T
1516import Control.Monad
1617import ProjectM36.ScriptSession
1718import ProjectM36.AtomFunctions.Basic (precompiledAtomFunctions)
18−import Control.Exception
19−import GHC
20−import GHC.Paths
19+
2120import Codec.Compression.GZip
2221import qualified Data.ByteString as BS
2322import qualified Data.ByteString.Lazy as BSL
2423
24+#ifdef PM36_HASKELL_SCRIPTING
25+import GHC
26+import Control.Exception
27+import GHC.Paths
28+#endif
29+
2530getDirectoryNames :: FilePath -> IO [FilePath]
2631getDirectoryNames path =
2732 filter (\ n -> n `notElem` ["..", "."]) <$> getDirectoryContents path
@@ -128,33 +133,40 @@ readAtomFuncs transDir mScriptSession = do
128133 pure (HS.union precompiledAtomFunctions (HS.fromList funcs))
129134
130135loadAtomFunc :: AtomFunctions -> Maybe ScriptSession -> AtomFunctionName -> [AtomType] -> Maybe AtomFunctionBodyScript -> IO AtomFunction
131−loadAtomFunc precompiledFuncs mScriptSession funcName funcType mFuncScript = case mFuncScript of
136+loadAtomFunc precompiledFuncs _mScriptSession funcName _funcType mFuncScript = case mFuncScript of
132137 --handle pre-compiled case- pull it from the precompiled list
133138 Nothing -> case atomFunctionForName funcName precompiledFuncs of
134139 --WARNING: possible landmine here if we remove a precompiled atom function in the future, then the transaction cannot be restored
135140 Left _ -> error ("expected precompiled atom function: " ++ T.unpack funcName)
136141 Right realFunc -> pure realFunc
137142 --handle a real Haskell scripted function- compile and load
138− Just funcScript ->
139− case mScriptSession of
143+ Just _funcScript ->
144+#ifdef PM36_HASKELL_SCRIPTING
145+ case _mScriptSession of
140146 Nothing -> error "attempted to read serialized AtomFunction without scripting enabled"
141147 Just scriptSession -> do
142148 --risk of GHC exception during compilation here
143149 eCompiledScript <- runGhc (Just libdir) $ do
144150 setSession (hscEnv scriptSession)
145− compileScript (atomFunctionBodyType scriptSession) funcScript
151+ compileScript (atomFunctionBodyType scriptSession) _funcScript
146152 case eCompiledScript of
147153 Left err -> throwIO err
148154 Right compiledScript -> pure AtomFunction { atomFuncName = funcName,
149− atomFuncType = funcType,
150− atomFuncBody = AtomFunctionBody (Just funcScript) compiledScript }
155+ atomFuncType = _funcType,
156+ atomFuncBody = AtomFunctionBody (Just _funcScript) compiledScript }
157+#else
158+ error "Haskell scripting is disabled"
159+#endif
151160
152161--if the script session is enabled, compile the script, otherwise, hard error!
153162
154163readAtomFunc :: FilePath -> AtomFunctionName -> Maybe ScriptSession -> AtomFunctions -> IO AtomFunction
164+#if !defined(PM36_HASKELL_SCRIPTING)
165+readAtomFunc _ _ _ _ = error "Haskell scripting is disabled"
166+#else
155167readAtomFunc transDir funcName mScriptSession precompiledFuncs = do
156168 let atomFuncPath = atomFuncsPath transDir
157− (funcType, mFuncScript) <- B.decodeFile atomFuncPath
169+ (funcType, mFuncScript) <- B.decodeFile @([AtomType],Maybe T.Text) atomFuncPath
158170 case mFuncScript of
159171 --handle pre-compiled case- pull it from the precompiled list
160172 Nothing -> case atomFunctionForName funcName precompiledFuncs of
@@ -162,7 +174,8 @@ readAtomFunc transDir funcName mScriptSession precompiledFuncs = do
162174 Left _ -> error ("expected precompiled atom function: " ++ T.unpack funcName)
163175 Right realFunc -> pure realFunc
164176 --handle a real Haskell scripted function- compile and load
165− Just funcScript ->
177+ Just funcScript ->
178+
166179 case mScriptSession of
167180 Nothing -> error "attempted to read serialized AtomFunction without scripting enabled"
168181 Just scriptSession -> do
@@ -175,6 +188,7 @@ readAtomFunc transDir funcName mScriptSession precompiledFuncs = do
175188 Right compiledScript -> pure AtomFunction { atomFuncName = funcName,
176189 atomFuncType = funcType,
177190 atomFuncBody = AtomFunctionBody (Just funcScript) compiledScript }
191+#endif
178192
179193
180194writeDBCFuncs :: DiskSync -> FilePath -> DatabaseContextFunctions -> IO ()
@@ -193,26 +207,34 @@ readDBCFuncs transDir mScriptSession = do
193207 let funcs = mapM ((\name -> readDBCFunc transDir name mScriptSession precompiledDatabaseContextFunctions) . T.pack) funcNames
194208 HS.union basicDatabaseContextFunctions . HS.fromList <$> funcs
195209
196−readDBCFunc :: FilePath -> DatabaseContextFunctionName -> Maybe ScriptSession -> DatabaseContextFunctions -> IO DatabaseContextFunction
210+readDBCFunc :: FilePath -> DatabaseContextFunctionName -> Maybe ScriptSession -> DatabaseContextFunctions -> IO DatabaseContextFunction
211+#if !defined(PM36_HASKELL_SCRIPTING)
212+readDBCFunc transDir funcName _ precompiledFuncs = do
213+#else
197214readDBCFunc transDir funcName mScriptSession precompiledFuncs = do
215+#endif
198216 let dbcFuncPath = dbcFuncsDir transDir </> T.unpack funcName
199− (funcType, mFuncScript) <- B.decodeFile dbcFuncPath
217+ (_funcType, mFuncScript) <- B.decodeFile @([AtomType], Maybe T.Text) dbcFuncPath
200218 case mFuncScript of
201219 Nothing -> case databaseContextFunctionForName funcName precompiledFuncs of
202220 Left _ -> error ("expected precompiled dbc function: " ++ T.unpack funcName)
203221 Right realFunc -> pure realFunc --return precompiled function
204− Just funcScript ->
222+ Just _funcScript ->
223+#ifdef PM36_HASKELL_SCRIPTING
205224 case mScriptSession of
206225 Nothing -> error "attempted to read serialized AtomFunction without scripting enabled"
207226 Just scriptSession -> do
208227 eCompiledScript <- runGhc (Just libdir) $ do
209228 setSession (hscEnv scriptSession)
210− compileScript (dbcFunctionBodyType scriptSession) funcScript
229+ compileScript (dbcFunctionBodyType scriptSession) _funcScript
211230 case eCompiledScript of
212231 Left err -> throwIO err
213232 Right compiledScript -> pure DatabaseContextFunction { dbcFuncName = funcName,
214− dbcFuncType = funcType,
215− dbcFuncBody = DatabaseContextFunctionBody (Just funcScript) compiledScript}
233+ dbcFuncType = _funcType,
234+ dbcFuncBody = DatabaseContextFunctionBody (Just _funcScript) compiledScript}
235+#else
236+ error "Haskell scripting is disabled"
237+#endif
216238
217239writeIncDep :: DiskSync -> FilePath -> (IncDepName, InclusionDependency) -> IO ()
218240writeIncDep sync transDir (incDepName, incDep) =
@@ -252,4 +274,4 @@ readTypeConstructorMapping path = do
252274 let atPath = typeConsPath path
253275 B.decodeFile atPath
254276
255−
277+