{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE CPP #-}
#ifdef PM36_HASKELL_SCRIPTING
{-# LANGUAGE TypeApplications #-}
#endif
module ProjectM36.Transaction.Persist where
import ProjectM36.Trace
import ProjectM36.Base
import ProjectM36.Error
import ProjectM36.Transaction
import ProjectM36.DatabaseContextFunction
import ProjectM36.AtomFunction
import ProjectM36.Persist (DiskSync, renameSync, writeSerialiseSync)
import ProjectM36.Function
import qualified Data.Map as M
import qualified Data.HashSet as HS
import System.FilePath
import System.Directory
import qualified Data.Text as T
import Data.Foldable (toList)
import Control.Monad
import ProjectM36.ScriptSession
import ProjectM36.AtomFunctions.Basic (precompiledAtomFunctions)
import Codec.Winery

#ifdef PM36_HASKELL_SCRIPTING
import GHC
import Control.Exception
import GHC.Paths
#endif

getDirectoryNames :: FilePath -> IO [FilePath]
getDirectoryNames :: [Char] -> IO [[Char]]
getDirectoryNames [Char]
path =
  forall a. (a -> Bool) -> [a] -> [a]
filter (\ [Char]
n -> [Char]
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [[Char]
"..", [Char]
"."]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO [[Char]]
getDirectoryContents [Char]
path


tempTransactionDir :: FilePath -> TransactionId -> FilePath
tempTransactionDir :: [Char] -> TransactionId -> [Char]
tempTransactionDir [Char]
dbdir TransactionId
transId = [Char]
dbdir [Char] -> [Char] -> [Char]
</> [Char]
"." forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show TransactionId
transId

transactionDir :: FilePath -> TransactionId -> FilePath
transactionDir :: [Char] -> TransactionId -> [Char]
transactionDir [Char]
dbdir TransactionId
transId = [Char]
dbdir [Char] -> [Char] -> [Char]
</> forall a. Show a => a -> [Char]
show TransactionId
transId

transactionInfoPath :: FilePath -> FilePath
transactionInfoPath :: [Char] -> [Char]
transactionInfoPath [Char]
transdir = [Char]
transdir [Char] -> [Char] -> [Char]
</> [Char]
"info"

notificationsPath :: FilePath -> FilePath
notificationsPath :: [Char] -> [Char]
notificationsPath [Char]
transdir = [Char]
transdir [Char] -> [Char] -> [Char]
</> [Char]
"notifs"

relvarsPath :: FilePath -> FilePath        
relvarsPath :: [Char] -> [Char]
relvarsPath [Char]
transdir = [Char]
transdir [Char] -> [Char] -> [Char]
</> [Char]
"relvars"

incDepsDir :: FilePath -> FilePath
incDepsDir :: [Char] -> [Char]
incDepsDir [Char]
transdir = [Char]
transdir [Char] -> [Char] -> [Char]
</> [Char]
"incdeps"

atomFuncsPath :: FilePath -> FilePath
atomFuncsPath :: [Char] -> [Char]
atomFuncsPath [Char]
transdir = [Char]
transdir [Char] -> [Char] -> [Char]
</> [Char]
"atomfuncs"

dbcFuncsPath :: FilePath -> FilePath
dbcFuncsPath :: [Char] -> [Char]
dbcFuncsPath [Char]
transdir = [Char]
transdir [Char] -> [Char] -> [Char]
</> [Char]
"dbcfuncs"

typeConsPath :: FilePath -> FilePath
typeConsPath :: [Char] -> [Char]
typeConsPath [Char]
transdir = [Char]
transdir [Char] -> [Char] -> [Char]
</> [Char]
"typecons"

subschemasPath :: FilePath -> FilePath
subschemasPath :: [Char] -> [Char]
subschemasPath [Char]
transdir = [Char]
transdir [Char] -> [Char] -> [Char]
</> [Char]
"schemas"

registeredQueriesPath :: FilePath -> FilePath
registeredQueriesPath :: [Char] -> [Char]
registeredQueriesPath [Char]
transdir = [Char]
transdir [Char] -> [Char] -> [Char]
</> [Char]
"registered_queries"

aggregateFunctionsPath :: FilePath -> FilePath
aggregateFunctionsPath :: [Char] -> [Char]
aggregateFunctionsPath [Char]
transdir = [Char]
transdir [Char] -> [Char] -> [Char]
</> [Char]
"aggregateFunctions"

-- | where compiled modules are stored within the database directory
objectFilesPath :: FilePath -> FilePath
objectFilesPath :: [Char] -> [Char]
objectFilesPath [Char]
transdir = [Char]
transdir [Char] -> [Char] -> [Char]
</> [Char]
".." [Char] -> [Char] -> [Char]
</> [Char]
"compiled_modules"

readTransaction :: FilePath -> TransactionId -> Maybe ScriptSession -> IO (Either PersistenceError Transaction)
readTransaction :: [Char]
-> TransactionId
-> Maybe ScriptSession
-> IO (Either PersistenceError Transaction)
readTransaction [Char]
dbdir TransactionId
transId Maybe ScriptSession
mScriptSession = do
  let transDir :: [Char]
transDir = [Char] -> TransactionId -> [Char]
transactionDir [Char]
dbdir TransactionId
transId
  Bool
transDirExists <- [Char] -> IO Bool
doesDirectoryExist [Char]
transDir
  if Bool -> Bool
not Bool
transDirExists then    
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ TransactionId -> PersistenceError
MissingTransactionError TransactionId
transId
    else do
    RelationVariables
relvars <- [Char] -> IO RelationVariables
readRelVars [Char]
transDir
    TransactionInfo
transInfo <- forall a. Serialise a => [Char] -> IO a
readFileDeserialise ([Char] -> [Char]
transactionInfoPath [Char]
transDir)
    Map Text InclusionDependency
incDeps <- [Char] -> IO (Map Text InclusionDependency)
readIncDeps [Char]
transDir
    TypeConstructorMapping
typeCons <- [Char] -> IO TypeConstructorMapping
readTypeConstructorMapping [Char]
transDir
    Subschemas
sschemas <- [Char] -> IO Subschemas
readSubschemas [Char]
transDir
    Notifications
notifs <- [Char] -> IO Notifications
readNotifications [Char]
transDir
    HashSet (Function DatabaseContextFunctionBodyType)
dbcFuncs <- forall a.
[Char]
-> [Char]
-> HashSet (Function a)
-> Maybe ScriptSession
-> IO (HashSet (Function a))
readFuncs [Char]
transDir ([Char] -> [Char]
dbcFuncsPath [Char]
transDir) HashSet (Function DatabaseContextFunctionBodyType)
basicDatabaseContextFunctions Maybe ScriptSession
mScriptSession
    HashSet (Function AtomFunctionBodyType)
atomFuncs <- forall a.
[Char]
-> [Char]
-> HashSet (Function a)
-> Maybe ScriptSession
-> IO (HashSet (Function a))
readFuncs [Char]
transDir ([Char] -> [Char]
atomFuncsPath [Char]
transDir) HashSet (Function AtomFunctionBodyType)
precompiledAtomFunctions Maybe ScriptSession
mScriptSession
    RegisteredQueries
registeredQs <- [Char] -> IO RegisteredQueries
readRegisteredQueries [Char]
transDir
    let newContext :: DatabaseContext
newContext = DatabaseContext { inclusionDependencies :: Map Text InclusionDependency
inclusionDependencies = Map Text InclusionDependency
incDeps,
                                       relationVariables :: RelationVariables
relationVariables = RelationVariables
relvars,
                                       typeConstructorMapping :: TypeConstructorMapping
typeConstructorMapping = TypeConstructorMapping
typeCons,
                                       notifications :: Notifications
notifications = Notifications
notifs,
                                       atomFunctions :: HashSet (Function AtomFunctionBodyType)
atomFunctions = HashSet (Function AtomFunctionBodyType)
atomFuncs,
                                       dbcFunctions :: HashSet (Function DatabaseContextFunctionBodyType)
dbcFunctions = HashSet (Function DatabaseContextFunctionBodyType)
dbcFuncs,
                                       registeredQueries :: RegisteredQueries
registeredQueries = RegisteredQueries
registeredQs }
        newSchemas :: Schemas
newSchemas = DatabaseContext -> Subschemas -> Schemas
Schemas DatabaseContext
newContext Subschemas
sschemas
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ TransactionId -> TransactionInfo -> Schemas -> Transaction
Transaction TransactionId
transId TransactionInfo
transInfo Schemas
newSchemas
        
writeTransaction :: DiskSync -> FilePath -> Transaction -> IO ()
writeTransaction :: DiskSync -> [Char] -> Transaction -> IO ()
writeTransaction DiskSync
sync [Char]
dbdir Transaction
trans = do
  let tempTransDir :: [Char]
tempTransDir = [Char] -> TransactionId -> [Char]
tempTransactionDir [Char]
dbdir (Transaction -> TransactionId
transactionId Transaction
trans)
      finalTransDir :: [Char]
finalTransDir = [Char] -> TransactionId -> [Char]
transactionDir [Char]
dbdir (Transaction -> TransactionId
transactionId Transaction
trans)
      context :: DatabaseContext
context = Transaction -> DatabaseContext
concreteDatabaseContext Transaction
trans
  Bool
transDirExists <- [Char] -> IO Bool
doesDirectoryExist [Char]
finalTransDir
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
transDirExists forall a b. (a -> b) -> a -> b
$ do
    --create sub directories
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [Char] -> IO ()
createDirectory [[Char]
tempTransDir, [Char] -> [Char]
incDepsDir [Char]
tempTransDir]
    DiskSync -> [Char] -> RelationVariables -> IO ()
writeRelVars DiskSync
sync [Char]
tempTransDir (DatabaseContext -> RelationVariables
relationVariables DatabaseContext
context)
    DiskSync -> [Char] -> Map Text InclusionDependency -> IO ()
writeIncDeps DiskSync
sync [Char]
tempTransDir (DatabaseContext -> Map Text InclusionDependency
inclusionDependencies DatabaseContext
context)
    forall (t :: * -> *) a.
Traversable t =>
DiskSync -> [Char] -> t (Function a) -> IO ()
writeFuncs DiskSync
sync ([Char] -> [Char]
atomFuncsPath [Char]
tempTransDir) (forall a. HashSet a -> [a]
HS.toList (DatabaseContext -> HashSet (Function AtomFunctionBodyType)
atomFunctions DatabaseContext
context))
    forall (t :: * -> *) a.
Traversable t =>
DiskSync -> [Char] -> t (Function a) -> IO ()
writeFuncs DiskSync
sync ([Char] -> [Char]
dbcFuncsPath [Char]
tempTransDir) (forall a. HashSet a -> [a]
HS.toList (DatabaseContext
-> HashSet (Function DatabaseContextFunctionBodyType)
dbcFunctions DatabaseContext
context))
    DiskSync -> [Char] -> Notifications -> IO ()
writeNotifications DiskSync
sync [Char]
tempTransDir (DatabaseContext -> Notifications
notifications DatabaseContext
context)
    DiskSync -> [Char] -> TypeConstructorMapping -> IO ()
writeTypeConstructorMapping DiskSync
sync [Char]
tempTransDir (DatabaseContext -> TypeConstructorMapping
typeConstructorMapping DatabaseContext
context)
    DiskSync -> [Char] -> Subschemas -> IO ()
writeSubschemas DiskSync
sync [Char]
tempTransDir (Transaction -> Subschemas
subschemas Transaction
trans)
    DiskSync -> [Char] -> RegisteredQueries -> IO ()
writeRegisteredQueries DiskSync
sync [Char]
tempTransDir (DatabaseContext -> RegisteredQueries
registeredQueries DatabaseContext
context)
    forall a. Serialise a => [Char] -> a -> IO ()
writeFileSerialise ([Char] -> [Char]
transactionInfoPath [Char]
tempTransDir) (Transaction -> TransactionInfo
transactionInfo Transaction
trans)
    --move the temp directory to final location
    DiskSync -> [Char] -> [Char] -> IO ()
renameSync DiskSync
sync [Char]
tempTransDir [Char]
finalTransDir

writeRelVars :: DiskSync -> FilePath -> RelationVariables -> IO ()
writeRelVars :: DiskSync -> [Char] -> RelationVariables -> IO ()
writeRelVars DiskSync
sync [Char]
transDir RelationVariables
relvars = do
  let path :: [Char]
path = [Char] -> [Char]
relvarsPath [Char]
transDir
  [Char] -> IO () -> IO ()
traceBlock [Char]
"write relvars" forall a b. (a -> b) -> a -> b
$ forall a. Serialise a => DiskSync -> [Char] -> a -> IO ()
writeSerialiseSync DiskSync
sync [Char]
path RelationVariables
relvars

readRelVars :: FilePath -> IO RelationVariables
readRelVars :: [Char] -> IO RelationVariables
readRelVars [Char]
transDir = 
  forall a. Serialise a => [Char] -> IO a
readFileDeserialise ([Char] -> [Char]
relvarsPath [Char]
transDir)

writeFuncs :: Traversable t => DiskSync -> FilePath -> t (Function a) -> IO ()
writeFuncs :: forall (t :: * -> *) a.
Traversable t =>
DiskSync -> [Char] -> t (Function a) -> IO ()
writeFuncs DiskSync
sync [Char]
funcWritePath t (Function a)
funcs = [Char] -> IO () -> IO ()
traceBlock [Char]
"write functions" forall a b. (a -> b) -> a -> b
$ do
  t (Function a)
funcs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM t (Function a)
funcs forall a b. (a -> b) -> a -> b
$ \Function a
fun -> do
    case forall a. Function a -> FunctionBody a
funcBody Function a
fun of
      FunctionScriptBody{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Function a
fun
      FunctionBuiltInBody{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Function a
fun
      FunctionObjectLoadedBody [Char]
objPath [Char]
a [Char]
b a
c -> do
         let newFuncBody :: FunctionBody a
newFuncBody = forall a. [Char] -> [Char] -> [Char] -> a -> FunctionBody a
FunctionObjectLoadedBody [Char]
objPath [Char]
a [Char]
b a
c
         forall (f :: * -> *) a. Applicative f => a -> f a
pure (Function a
fun { funcBody :: FunctionBody a
funcBody = FunctionBody a
newFuncBody })
  --write additional data for object-loaded functions (which are not built-in or scripted)
  let functionData :: Function a -> ([AtomType], Text, Maybe Text, Maybe ObjectFileInfo)
functionData Function a
f =
          (forall a. Function a -> [AtomType]
funcType Function a
f, forall a. Function a -> Text
funcName Function a
f, forall a. Function a -> Maybe Text
functionScript Function a
f, forall a. Function a -> Maybe ObjectFileInfo
objInfo Function a
f)
      objInfo :: Function a -> Maybe ObjectFileInfo
      objInfo :: forall a. Function a -> Maybe ObjectFileInfo
objInfo Function a
f =
        case forall a. Function a -> FunctionBody a
funcBody Function a
f of
          FunctionObjectLoadedBody [Char]
objPath [Char]
modName [Char]
entryFunc a
_ ->
            forall a. a -> Maybe a
Just (([Char], [Char], [Char]) -> ObjectFileInfo
ObjectFileInfo ([Char]
objPath, [Char]
modName, [Char]
entryFunc))
          FunctionScriptBody{} -> forall a. Maybe a
Nothing
          FunctionBuiltInBody{} -> forall a. Maybe a
Nothing
  forall a. Serialise a => DiskSync -> [Char] -> a -> IO ()
writeSerialiseSync DiskSync
sync [Char]
funcWritePath (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a}.
Function a -> ([AtomType], Text, Maybe Text, Maybe ObjectFileInfo)
functionData (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t (Function a)
funcs'))

readFuncs :: FilePath -> FilePath -> HS.HashSet (Function a) -> Maybe ScriptSession -> IO (HS.HashSet (Function a))
readFuncs :: forall a.
[Char]
-> [Char]
-> HashSet (Function a)
-> Maybe ScriptSession
-> IO (HashSet (Function a))
readFuncs [Char]
transDir [Char]
funcPath HashSet (Function a)
precompiledFunctions Maybe ScriptSession
mScriptSession = do
  [([AtomType], Text, Maybe Text, Maybe ObjectFileInfo)]
funcsList <- forall a. Serialise a => [Char] -> IO a
readFileDeserialise [Char]
funcPath
  --we always return the pre-compiled functions
  --load object files and functions in objects (shared libraries or flat object files)
  let objFilesDir :: [Char]
objFilesDir = [Char] -> [Char]
objectFilesPath [Char]
transDir
  [Function a]
funcs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\([AtomType]
funcType', Text
funcName', Maybe Text
mFuncScript, Maybe ObjectFileInfo
mObjInfo) -> 
                    forall a.
[Char]
-> HashSet (Function a)
-> Maybe ScriptSession
-> Text
-> [AtomType]
-> Maybe Text
-> Maybe ObjectFileInfo
-> IO (Function a)
loadFunc [Char]
objFilesDir HashSet (Function a)
precompiledFunctions Maybe ScriptSession
mScriptSession Text
funcName' [AtomType]
funcType' Maybe Text
mFuncScript Maybe ObjectFileInfo
mObjInfo) [([AtomType], Text, Maybe Text, Maybe ObjectFileInfo)]
funcsList
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Eq a => HashSet a -> HashSet a -> HashSet a
HS.union HashSet (Function a)
precompiledFunctions (forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList [Function a]
funcs))

newtype ObjectFileInfo = ObjectFileInfo { ObjectFileInfo -> ([Char], [Char], [Char])
_unFileInfo :: (FilePath, String, String) }
 deriving (Int -> ObjectFileInfo -> [Char] -> [Char]
[ObjectFileInfo] -> [Char] -> [Char]
ObjectFileInfo -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [ObjectFileInfo] -> [Char] -> [Char]
$cshowList :: [ObjectFileInfo] -> [Char] -> [Char]
show :: ObjectFileInfo -> [Char]
$cshow :: ObjectFileInfo -> [Char]
showsPrec :: Int -> ObjectFileInfo -> [Char] -> [Char]
$cshowsPrec :: Int -> ObjectFileInfo -> [Char] -> [Char]
Show, Typeable ObjectFileInfo
BundleSerialise ObjectFileInfo
Extractor ObjectFileInfo
Decoder ObjectFileInfo
Proxy ObjectFileInfo -> SchemaGen Schema
ObjectFileInfo -> Builder
forall a.
Typeable a
-> (Proxy a -> SchemaGen Schema)
-> (a -> Builder)
-> Extractor a
-> Decoder a
-> BundleSerialise a
-> Serialise a
bundleSerialise :: BundleSerialise ObjectFileInfo
$cbundleSerialise :: BundleSerialise ObjectFileInfo
decodeCurrent :: Decoder ObjectFileInfo
$cdecodeCurrent :: Decoder ObjectFileInfo
extractor :: Extractor ObjectFileInfo
$cextractor :: Extractor ObjectFileInfo
toBuilder :: ObjectFileInfo -> Builder
$ctoBuilder :: ObjectFileInfo -> Builder
schemaGen :: Proxy ObjectFileInfo -> SchemaGen Schema
$cschemaGen :: Proxy ObjectFileInfo -> SchemaGen Schema
Serialise)
-- deriving Serialise via WineryVariant ObjectFileInfo

loadFunc :: FilePath -> HS.HashSet (Function a) -> Maybe ScriptSession -> FunctionName -> [AtomType] -> Maybe FunctionBodyScript -> Maybe ObjectFileInfo -> IO (Function a)
loadFunc :: forall a.
[Char]
-> HashSet (Function a)
-> Maybe ScriptSession
-> Text
-> [AtomType]
-> Maybe Text
-> Maybe ObjectFileInfo
-> IO (Function a)
loadFunc [Char]
objFilesDir HashSet (Function a)
precompiledFuncs Maybe ScriptSession
_mScriptSession Text
funcName' [AtomType]
_funcType Maybe Text
mFuncScript Maybe ObjectFileInfo
mObjInfo = do
  case Maybe ObjectFileInfo
mObjInfo of
    --load from shared or static object library
    Just (ObjectFileInfo ([Char]
path, [Char]
modName, [Char]
entryFunc)) -> do
      Either LoadSymbolError [Function a]
eFuncs <- forall a.
[Char]
-> [Char]
-> Maybe [Char]
-> [Char]
-> IO (Either LoadSymbolError [Function a])
loadFunctions [Char]
modName [Char]
entryFunc (forall a. a -> Maybe a
Just [Char]
objFilesDir) [Char]
path
      case Either LoadSymbolError [Function a]
eFuncs of
        Left LoadSymbolError
_ -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Failed to load " forall a. Semigroup a => a -> a -> a
<> [Char]
path
        Right [Function a]
funcs -> 
          case forall a. (a -> Bool) -> [a] -> [a]
filter (\Function a
f -> forall a. Function a -> Text
funcName Function a
f forall a. Eq a => a -> a -> Bool
== Text
funcName'
                      ) [Function a]
funcs of
            [Function a
f] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Function a
f
            [] -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Failed to find function \"" forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
funcName' forall a. Semigroup a => a -> a -> a
<> [Char]
"\" in " forall a. Semigroup a => a -> a -> a
<> [Char]
path
            [Function a]
_ -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"impossible error in loading \"" forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
funcName' forall a. Semigroup a => a -> a -> a
<> [Char]
"\""
    Maybe ObjectFileInfo
Nothing -> 
      case Maybe Text
mFuncScript of
        --handle pre-compiled case- pull it from the precompiled list
        Maybe Text
Nothing -> case forall a.
Text -> HashSet (Function a) -> Either RelationalError (Function a)
functionForName Text
funcName' HashSet (Function a)
precompiledFuncs of
          --WARNING: possible landmine here if we remove a precompiled atom function in the future, then the transaction cannot be restored
          Left RelationalError
_ -> forall a. HasCallStack => [Char] -> a
error ([Char]
"expected precompiled atom function: " forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
funcName')
          Right Function a
realFunc -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Function a
realFunc
        --handle a real Haskell scripted function- compile and load
        Just Text
_funcScript ->
#ifdef PM36_HASKELL_SCRIPTING
          case Maybe ScriptSession
_mScriptSession of
            Maybe ScriptSession
Nothing -> forall a. HasCallStack => [Char] -> a
error [Char]
"attempted to read serialized AtomFunction without scripting enabled"
            Just ScriptSession
scriptSession -> do
              --risk of GHC exception during compilation here
              Either ScriptCompilationError a
eCompiledScript <- forall a. Maybe [Char] -> Ghc a -> IO a
runGhc (forall a. a -> Maybe a
Just [Char]
libdir) forall a b. (a -> b) -> a -> b
$ do
                forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession (ScriptSession -> HscEnv
hscEnv ScriptSession
scriptSession)
                forall a. Type -> Text -> Ghc (Either ScriptCompilationError a)
compileScript (ScriptSession -> Type
atomFunctionBodyType ScriptSession
scriptSession) Text
_funcScript
              case Either ScriptCompilationError a
eCompiledScript of
                Left ScriptCompilationError
err -> forall e a. Exception e => e -> IO a
throwIO ScriptCompilationError
err
                Right a
compiledScript -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Function { funcName :: Text
funcName = Text
funcName',
                                                        funcType :: [AtomType]
funcType = [AtomType]
_funcType,
                                                        funcBody :: FunctionBody a
funcBody = forall a. Text -> a -> FunctionBody a
FunctionScriptBody Text
_funcScript a
compiledScript }
#else
         error "Haskell scripting is disabled"
#endif                                    

--if the script session is enabled, compile the script, otherwise, hard error!  
  
readAtomFunc :: FilePath -> FunctionName -> Maybe ScriptSession -> AtomFunctions -> IO AtomFunction
#if !defined(PM36_HASKELL_SCRIPTING)
readAtomFunc _ _ _ _ = error "Haskell scripting is disabled"
#else
readAtomFunc :: [Char]
-> Text
-> Maybe ScriptSession
-> HashSet (Function AtomFunctionBodyType)
-> IO (Function AtomFunctionBodyType)
readAtomFunc [Char]
transDir Text
funcName' Maybe ScriptSession
mScriptSession HashSet (Function AtomFunctionBodyType)
precompiledFuncs = do
  let atomFuncPath :: [Char]
atomFuncPath = [Char] -> [Char]
atomFuncsPath [Char]
transDir
  ([AtomType]
funcType', Maybe Text
mFuncScript) <- forall a. Serialise a => [Char] -> IO a
readFileDeserialise @([AtomType],Maybe T.Text) [Char]
atomFuncPath
  case Maybe Text
mFuncScript of
    --handle pre-compiled case- pull it from the precompiled list
    Maybe Text
Nothing -> case Text
-> HashSet (Function AtomFunctionBodyType)
-> Either RelationalError (Function AtomFunctionBodyType)
atomFunctionForName Text
funcName' HashSet (Function AtomFunctionBodyType)
precompiledFuncs of
      --WARNING: possible landmine here if we remove a precompiled atom function in the future, then the transaction cannot be restored
      Left RelationalError
_ -> forall a. HasCallStack => [Char] -> a
error ([Char]
"expected precompiled atom function: " forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
funcName')
      Right Function AtomFunctionBodyType
realFunc -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Function AtomFunctionBodyType
realFunc
    --handle a real Haskell scripted function- compile and load
    Just Text
funcScript ->

      case Maybe ScriptSession
mScriptSession of
        Maybe ScriptSession
Nothing -> forall a. HasCallStack => [Char] -> a
error [Char]
"attempted to read serialized AtomFunction without scripting enabled"
        Just ScriptSession
scriptSession -> do
          --risk of GHC exception during compilation here
          Either ScriptCompilationError AtomFunctionBodyType
eCompiledScript <- forall a. Maybe [Char] -> Ghc a -> IO a
runGhc (forall a. a -> Maybe a
Just [Char]
libdir) forall a b. (a -> b) -> a -> b
$ do
            forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession (ScriptSession -> HscEnv
hscEnv ScriptSession
scriptSession)
            forall a. Type -> Text -> Ghc (Either ScriptCompilationError a)
compileScript (ScriptSession -> Type
atomFunctionBodyType ScriptSession
scriptSession) Text
funcScript
          case Either ScriptCompilationError AtomFunctionBodyType
eCompiledScript of
            Left ScriptCompilationError
err -> forall e a. Exception e => e -> IO a
throwIO ScriptCompilationError
err
            Right AtomFunctionBodyType
compiledScript -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Function { funcName :: Text
funcName = Text
funcName',
                                                    funcType :: [AtomType]
funcType = [AtomType]
funcType',
                                                    funcBody :: FunctionBody AtomFunctionBodyType
funcBody = forall a. Text -> a -> FunctionBody a
FunctionScriptBody Text
funcScript AtomFunctionBodyType
compiledScript }
#endif

writeIncDep :: DiskSync -> FilePath -> (IncDepName, InclusionDependency) -> IO ()  
writeIncDep :: DiskSync -> [Char] -> (Text, InclusionDependency) -> IO ()
writeIncDep DiskSync
sync [Char]
transDir (Text
incDepName, InclusionDependency
incDep) = do
  forall a. Serialise a => DiskSync -> [Char] -> a -> IO ()
writeSerialiseSync DiskSync
sync ([Char] -> [Char]
incDepsDir [Char]
transDir [Char] -> [Char] -> [Char]
</> Text -> [Char]
T.unpack Text
incDepName) InclusionDependency
incDep
  
writeIncDeps :: DiskSync -> FilePath -> M.Map IncDepName InclusionDependency -> IO ()  
writeIncDeps :: DiskSync -> [Char] -> Map Text InclusionDependency -> IO ()
writeIncDeps DiskSync
sync [Char]
transDir Map Text InclusionDependency
incdeps = 
  [Char] -> IO () -> IO ()
traceBlock [Char]
"write incdeps" forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DiskSync -> [Char] -> (Text, InclusionDependency) -> IO ()
writeIncDep DiskSync
sync [Char]
transDir) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.toList Map Text InclusionDependency
incdeps 
  
readIncDep :: FilePath -> IncDepName -> IO (IncDepName, InclusionDependency)
readIncDep :: [Char] -> Text -> IO (Text, InclusionDependency)
readIncDep [Char]
transDir Text
incdepName = do
  let incDepPath :: [Char]
incDepPath = [Char] -> [Char]
incDepsDir [Char]
transDir [Char] -> [Char] -> [Char]
</> Text -> [Char]
T.unpack Text
incdepName
  InclusionDependency
incDepData <- forall a. Serialise a => [Char] -> IO a
readFileDeserialise [Char]
incDepPath
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
incdepName, InclusionDependency
incDepData)
  
readIncDeps :: FilePath -> IO (M.Map IncDepName InclusionDependency)  
readIncDeps :: [Char] -> IO (Map Text InclusionDependency)
readIncDeps [Char]
transDir = do
  let incDepsPath :: [Char]
incDepsPath = [Char] -> [Char]
incDepsDir [Char]
transDir
  [[Char]]
incDepNames <- [Char] -> IO [[Char]]
getDirectoryNames [Char]
incDepsPath
  forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Char] -> Text -> IO (Text, InclusionDependency)
readIncDep [Char]
transDir forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack) [[Char]]
incDepNames
  
readSubschemas :: FilePath -> IO Subschemas  
readSubschemas :: [Char] -> IO Subschemas
readSubschemas [Char]
transDir = do
  let sschemasPath :: [Char]
sschemasPath = [Char] -> [Char]
subschemasPath [Char]
transDir
  forall a. Serialise a => [Char] -> IO a
readFileDeserialise [Char]
sschemasPath

writeSubschemas :: DiskSync -> FilePath -> Subschemas -> IO ()  
writeSubschemas :: DiskSync -> [Char] -> Subschemas -> IO ()
writeSubschemas DiskSync
sync [Char]
transDir Subschemas
sschemas = do
  let sschemasPath :: [Char]
sschemasPath = [Char] -> [Char]
subschemasPath [Char]
transDir
  [Char] -> IO () -> IO ()
traceBlock [Char]
"write subschemas" forall a b. (a -> b) -> a -> b
$ forall a. Serialise a => DiskSync -> [Char] -> a -> IO ()
writeSerialiseSync DiskSync
sync [Char]
sschemasPath Subschemas
sschemas
  
writeTypeConstructorMapping :: DiskSync -> FilePath -> TypeConstructorMapping -> IO ()  
writeTypeConstructorMapping :: DiskSync -> [Char] -> TypeConstructorMapping -> IO ()
writeTypeConstructorMapping DiskSync
sync [Char]
path TypeConstructorMapping
types = do
  let atPath :: [Char]
atPath = [Char] -> [Char]
typeConsPath [Char]
path
  [Char] -> IO () -> IO ()
traceBlock [Char]
"write tconsmap" forall a b. (a -> b) -> a -> b
$ forall a. Serialise a => DiskSync -> [Char] -> a -> IO ()
writeSerialiseSync DiskSync
sync [Char]
atPath TypeConstructorMapping
types

readTypeConstructorMapping :: FilePath -> IO TypeConstructorMapping
readTypeConstructorMapping :: [Char] -> IO TypeConstructorMapping
readTypeConstructorMapping [Char]
path = do
  let atPath :: [Char]
atPath = [Char] -> [Char]
typeConsPath [Char]
path
  forall a. Serialise a => [Char] -> IO a
readFileDeserialise [Char]
atPath
  
readRegisteredQueries :: FilePath -> IO RegisteredQueries
readRegisteredQueries :: [Char] -> IO RegisteredQueries
readRegisteredQueries [Char]
transDir = do
  let regQsPath :: [Char]
regQsPath = [Char] -> [Char]
registeredQueriesPath [Char]
transDir
  forall a. Serialise a => [Char] -> IO a
readFileDeserialise [Char]
regQsPath

writeRegisteredQueries :: DiskSync -> FilePath -> RegisteredQueries -> IO ()
writeRegisteredQueries :: DiskSync -> [Char] -> RegisteredQueries -> IO ()
writeRegisteredQueries DiskSync
sync [Char]
transDir RegisteredQueries
regQs = do
  let regQsPath :: [Char]
regQsPath = [Char] -> [Char]
registeredQueriesPath [Char]
transDir
  [Char] -> IO () -> IO ()
traceBlock [Char]
"write registered queries" forall a b. (a -> b) -> a -> b
$ forall a. Serialise a => DiskSync -> [Char] -> a -> IO ()
writeSerialiseSync DiskSync
sync [Char]
regQsPath RegisteredQueries
regQs

readNotifications :: FilePath -> IO Notifications
readNotifications :: [Char] -> IO Notifications
readNotifications [Char]
transDir = do
  let notifsPath :: [Char]
notifsPath = [Char] -> [Char]
notificationsPath [Char]
transDir
  forall a. Serialise a => [Char] -> IO a
readFileDeserialise [Char]
notifsPath

writeNotifications :: DiskSync -> FilePath -> Notifications -> IO ()
writeNotifications :: DiskSync -> [Char] -> Notifications -> IO ()
writeNotifications DiskSync
sync [Char]
transDir Notifications
notifs = do
  let notifsPath :: [Char]
notifsPath = [Char] -> [Char]
notificationsPath [Char]
transDir
  [Char] -> IO () -> IO ()
traceBlock [Char]
"write notifications" forall a b. (a -> b) -> a -> b
$ forall a. Serialise a => DiskSync -> [Char] -> a -> IO ()
writeSerialiseSync DiskSync
sync [Char]
notifsPath Notifications
notifs