@@ -2,6 +2,8 @@ module ProjectM36.Transaction.Persist where
22import ProjectM36.Base
33import ProjectM36.Error
44import ProjectM36.Transaction
5+import ProjectM36.DatabaseContextFunction
6+import ProjectM36.AtomFunction
57import ProjectM36.Persist (writeBSFileSync, DiskSync, renameSync)
68import qualified Data.Map as M
79import qualified Data.HashSet as HS
@@ -11,7 +13,13 @@ import System.FilePath
1113import System.Directory
1214import qualified Data.Text as T
1315import Control.Monad
14−import ProjectM36.AtomFunctions.Basic (basicAtomFunctions)
16+import ProjectM36.ScriptSession
17+import ProjectM36.AtomFunctions.Basic (precompiledAtomFunctions)
18+import Control.Exception
19+import GHC
20+import GHC.Paths
21+
22+import Debug.Trace
1523
1624getDirectoryNames :: FilePath -> IO [FilePath]
1725getDirectoryNames path = do
@@ -36,14 +44,17 @@ incDepsDir transdir = transdir </> "incdeps"
3644atomFuncsDir :: FilePath -> FilePath
3745atomFuncsDir transdir = transdir </> "atomfuncs"
3846
47+dbcFuncsDir :: FilePath -> FilePath
48+dbcFuncsDir transdir = transdir </> "dbcfuncs"
49+
3950typeConsPath :: FilePath -> FilePath
4051typeConsPath transdir = transdir </> "typecons"
4152
4253subschemasPath :: FilePath -> FilePath
4354subschemasPath transdir = transdir </> "schemas"
4455
45−readTransaction :: FilePath -> TransactionId -> IO (Either PersistenceError Transaction)
46−readTransaction dbdir transId = do
56+readTransaction :: FilePath -> TransactionId -> Maybe ScriptSession -> IO (Either PersistenceError Transaction)
57+readTransaction dbdir transId mScriptSession = do
4758 let transDir = transactionDir dbdir transId
4859 transDirExists <- doesDirectoryExist transDir
4960 if not transDirExists then
@@ -54,15 +65,14 @@ readTransaction dbdir transId = do
5465 incDeps <- readIncDeps transDir
5566 typeCons <- readTypeConstructorMapping transDir
5667 sschemas <- readSubschemas transDir
57− --dbcFuncs <-
58− --atomFuncs <- readAtomFuncs transDir -- not yet supported since there is no bytecode to serialize yet
59− let atomFuncs = basicAtomFunctions
68+ dbcFuncs <- readDBCFuncs transDir mScriptSession
69+ atomFuncs <- readAtomFuncs transDir mScriptSession
6070 let newContext = DatabaseContext { inclusionDependencies = incDeps,
6171 relationVariables = relvars,
6272 typeConstructorMapping = typeCons,
6373 notifications = M.empty,
6474 atomFunctions = atomFuncs,
65− dbcFunctions = HS.empty }
75+ dbcFunctions = dbcFuncs }
6676 newSchemas = Schemas newContext sschemas
6777 return $ Right $ Transaction transId transInfo newSchemas
6878
@@ -71,13 +81,14 @@ writeTransaction sync dbdir trans = do
7181 let tempTransDir = tempTransactionDir dbdir (transactionId trans)
7282 finalTransDir = transactionDir dbdir (transactionId trans)
7383 context = concreteDatabaseContext trans
74− transDirExists <- doesDirectoryExist finalTransDir
84+ transDirExists <- doesDirectoryExist finalTransDir
7585 if not transDirExists then do
7686 --create sub directories
77− mapM_ createDirectory [tempTransDir, relvarsDir tempTransDir, incDepsDir tempTransDir, atomFuncsDir tempTransDir]
87+ mapM_ createDirectory [tempTransDir, relvarsDir tempTransDir, incDepsDir tempTransDir, atomFuncsDir tempTransDir, dbcFuncsDir tempTransDir]
7888 writeRelVars sync tempTransDir (relationVariables context)
7989 writeIncDeps sync tempTransDir (inclusionDependencies context)
8090 writeAtomFuncs sync tempTransDir (atomFunctions context)
91+ writeDBCFuncs sync tempTransDir (dbcFunctions context)
8192 writeTypeConstructorMapping sync tempTransDir (typeConstructorMapping context)
8293 writeSubschemas sync tempTransDir (subschemas trans)
8394 BS.writeFile (transactionInfoPath tempTransDir) (B.encode $ transactionInfo trans)
@@ -107,24 +118,83 @@ writeAtomFuncs :: DiskSync -> FilePath -> AtomFunctions -> IO ()
107118writeAtomFuncs sync transDir funcs = mapM_ (writeAtomFunc sync transDir) $ HS.toList funcs
108119
109120--all the atom functions are in one file (???)
110−readAtomFuncs :: FilePath -> IO (AtomFunctions)
111−readAtomFuncs transDir = do
121+readAtomFuncs :: FilePath -> Maybe ScriptSession -> IO AtomFunctions
122+readAtomFuncs transDir mScriptSession = do
112123 funcNames <- getDirectoryNames (atomFuncsDir transDir)
113− funcs <- mapM (readAtomFunc transDir) (map T.pack funcNames)
114− return $ HS.fromList funcs
124+ --only Haskell script functions can be serialized
125+ --we always return the pre-compiled functions
126+ funcs <- mapM (\name -> readAtomFunc transDir name mScriptSession precompiledAtomFunctions) (map T.pack funcNames)
127+ pure (HS.union precompiledAtomFunctions (HS.fromList funcs))
115128
116129--to write the atom functions, we really some bytecode to write (GHCi bytecode?)
117130writeAtomFunc :: DiskSync -> FilePath -> AtomFunction -> IO ()
118131writeAtomFunc sync transDir func = do
119132 let atomFuncPath = atomFuncsDir transDir </> T.unpack (atomFuncName func)
120− writeBSFileSync sync atomFuncPath BS.empty
133+ writeBSFileSync sync atomFuncPath (B.encode (atomFuncType func, atomFunctionScript func))
121134
122−readAtomFunc :: FilePath -> AtomFunctionName -> IO (AtomFunction)
123−readAtomFunc transDir funcName = do
135+--if the script session is enabled, compile the script, otherwise, hard error!
136+readAtomFunc :: FilePath -> AtomFunctionName -> Maybe ScriptSession -> AtomFunctions -> IO (AtomFunction)
137+readAtomFunc transDir funcName mScriptSession precompiledFuncs = do
124138 let atomFuncPath = atomFuncsDir transDir </> T.unpack funcName
125− _ <- BS.readFile atomFuncPath
126− return undefined
139+ (funcType, mFuncScript) <- liftM B.decode (BS.readFile atomFuncPath)
140+ case mFuncScript of
141+ --handle pre-compiled case- pull it from the precompiled list
142+ Nothing -> case atomFunctionForName funcName precompiledFuncs of
143+ --WARNING: possible landmine here if we remove a precompiled atom function in the future, then the transaction cannot be restored
144+ Left _ -> error ("expected precompiled atom function: " ++ T.unpack funcName)
145+ Right realFunc -> pure realFunc
146+ --handle a real Haskell scripted function- compile and load
147+ Just funcScript -> do
148+ case mScriptSession of
149+ Nothing -> error "attempted to read serialized AtomFunction without scripting enabled"
150+ Just scriptSession -> do
151+ --risk of GHC exception during compilation here
152+ eCompiledScript <- runGhc (Just libdir) $ do
153+ setSession (hscEnv scriptSession)
154+ compileScript (atomFunctionBodyType scriptSession) funcScript
155+ case eCompiledScript of
156+ Left err -> throwIO err
157+ Right compiledScript -> pure (AtomFunction { atomFuncName = funcName,
158+ atomFuncType = funcType,
159+ atomFuncBody = AtomFunctionBody (Just funcScript) compiledScript })
160+
161+writeDBCFuncs :: DiskSync -> FilePath -> DatabaseContextFunctions -> IO ()
162+writeDBCFuncs sync transDir funcs = mapM_ (writeDBCFunc sync transDir) (HS.toList funcs)
127163
164+writeDBCFunc :: DiskSync -> FilePath -> DatabaseContextFunction -> IO ()
165+writeDBCFunc sync transDir func = do
166+ let dbcFuncPath = dbcFuncsDir transDir </> T.unpack (dbcFuncName func)
167+ writeBSFileSync sync (traceShowId dbcFuncPath) (B.encode (dbcFuncType func, databaseContextFunctionScript func))
168+
169+readDBCFuncs :: FilePath -> Maybe ScriptSession -> IO DatabaseContextFunctions
170+readDBCFuncs transDir mScriptSession = do
171+ funcNames <- getDirectoryNames (dbcFuncsDir transDir)
172+ --only Haskell script functions can be serialized
173+ --we always return the pre-compiled functions
174+ funcs <- mapM (\name -> readDBCFunc transDir name mScriptSession precompiledDatabaseContextFunctions) (map T.pack funcNames)
175+ return $ HS.union basicDatabaseContextFunctions (HS.fromList funcs)
176+
177+readDBCFunc :: FilePath -> DatabaseContextFunctionName -> Maybe ScriptSession -> DatabaseContextFunctions -> IO DatabaseContextFunction
178+readDBCFunc transDir funcName mScriptSession precompiledFuncs = do
179+ let dbcFuncPath = dbcFuncsDir transDir </> T.unpack funcName
180+ (funcType, mFuncScript) <- liftM B.decode (BS.readFile dbcFuncPath)
181+ case mFuncScript of
182+ Nothing -> case databaseContextFunctionForName funcName precompiledFuncs of
183+ Left _ -> error ("expected precompiled dbc function: " ++ T.unpack funcName)
184+ Right realFunc -> pure realFunc --return precompiled function
185+ Just funcScript -> do
186+ case mScriptSession of
187+ Nothing -> error "attempted to read serialized AtomFunction without scripting enabled"
188+ Just scriptSession -> do
189+ eCompiledScript <- runGhc (Just libdir) $ do
190+ setSession (hscEnv scriptSession)
191+ compileScript (dbcFunctionBodyType scriptSession) funcScript
192+ case eCompiledScript of
193+ Left err -> throwIO err
194+ Right compiledScript -> pure (DatabaseContextFunction { dbcFuncName = funcName,
195+ dbcFuncType = funcType,
196+ dbcFuncBody = DatabaseContextFunctionBody (Just funcScript) compiledScript})
197+
128198writeIncDep :: DiskSync -> FilePath -> (IncDepName, InclusionDependency) -> IO ()
129199writeIncDep sync transDir (incDepName, incDep) = do
130200 writeBSFileSync sync (incDepsDir transDir </> T.unpack incDepName) $ B.encode incDep