{-# LANGUAGE OverloadedStrings #-}
module Experimenter.DB where
import Conduit as C
import Control.Monad.Logger
import Control.Monad.Trans.Reader (ReaderT)
import Data.Char
import Data.List (foldl')
import qualified Data.Text as T
import qualified Database.Esqueleto as E
import Database.Persist.Postgresql (SqlBackend, withPostgresqlPool)
import Experimenter.DatabaseSetting
type DB m = ReaderT SqlBackend (LoggingT (ResourceT m))
type SimpleDB = DB IO
logFun :: (MonadIO m) => LoggingT m a -> m a
logFun :: LoggingT m a -> m a
logFun = LoggingT m a -> m a
forall (m :: * -> *) a. MonadIO m => LoggingT m a -> m a
runStdoutLoggingT (LoggingT m a -> m a)
-> (LoggingT m a -> LoggingT m a) -> LoggingT m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogSource -> LogLevel -> Bool) -> LoggingT m a -> LoggingT m a
forall (m :: * -> *) a.
(LogSource -> LogLevel -> Bool) -> LoggingT m a -> LoggingT m a
filterLogger (\LogSource
s LogLevel
_ -> LogSource
s LogSource -> LogSource -> Bool
forall a. Eq a => a -> a -> Bool
/= LogSource
"SQL")
runDB :: (MonadUnliftIO m) => DatabaseSetting -> DB m a -> m a
runDB :: DatabaseSetting -> DB m a -> m a
runDB = (ResourceT m a -> m a) -> DatabaseSetting -> DB m a -> m a
forall (m1 :: * -> *) a (m :: * -> *).
MonadUnliftIO m1 =>
(m1 a -> m a)
-> DatabaseSetting -> ReaderT SqlBackend (LoggingT m1) a -> m a
runDBWithM ResourceT m a -> m a
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT
runDBSimple :: DatabaseSetting -> SimpleDB a -> IO a
runDBSimple :: DatabaseSetting -> SimpleDB a -> IO a
runDBSimple = (ResourceT IO a -> IO a) -> DatabaseSetting -> SimpleDB a -> IO a
forall (m1 :: * -> *) a (m :: * -> *).
MonadUnliftIO m1 =>
(m1 a -> m a)
-> DatabaseSetting -> ReaderT SqlBackend (LoggingT m1) a -> m a
runDBWithM ResourceT IO a -> IO a
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT
runDBWithM :: (MonadUnliftIO m1) => (m1 a -> m a) -> DatabaseSetting -> ReaderT SqlBackend (LoggingT m1) a -> m a
runDBWithM :: (m1 a -> m a)
-> DatabaseSetting -> ReaderT SqlBackend (LoggingT m1) a -> m a
runDBWithM m1 a -> m a
runM DatabaseSetting
dbSetting ReaderT SqlBackend (LoggingT m1) a
action = m1 a -> m a
runM (m1 a -> m a) -> m1 a -> m a
forall a b. (a -> b) -> a -> b
$ LoggingT m1 a -> m1 a
forall (m :: * -> *) a. MonadIO m => LoggingT m a -> m a
logFun (LoggingT m1 a -> m1 a) -> LoggingT m1 a -> m1 a
forall a b. (a -> b) -> a -> b
$ ConnectionString
-> Int -> (Pool SqlBackend -> LoggingT m1 a) -> LoggingT m1 a
forall (m :: * -> *) a.
(MonadLogger m, MonadUnliftIO m) =>
ConnectionString -> Int -> (Pool SqlBackend -> m a) -> m a
withPostgresqlPool (DatabaseSetting -> ConnectionString
connectionString DatabaseSetting
dbSetting) (DatabaseSetting -> Int
parallelConnections DatabaseSetting
dbSetting) ((Pool SqlBackend -> LoggingT m1 a) -> LoggingT m1 a)
-> (Pool SqlBackend -> LoggingT m1 a) -> LoggingT m1 a
forall a b. (a -> b) -> a -> b
$ \Pool SqlBackend
pool -> ReaderT SqlBackend (LoggingT m1) a
-> Pool SqlBackend -> LoggingT m1 a
forall backend (m :: * -> *) a.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a -> Pool backend -> m a
E.runSqlPool ReaderT SqlBackend (LoggingT m1) a
action Pool SqlBackend
pool
indexCreation :: (MonadIO m) => ReaderT SqlBackend (NoLoggingT (ResourceT m)) ()
indexCreation :: ReaderT SqlBackend (NoLoggingT (ResourceT m)) ()
indexCreation = (LogSource -> ReaderT SqlBackend (NoLoggingT (ResourceT m)) ())
-> [LogSource] -> ReaderT SqlBackend (NoLoggingT (ResourceT m)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((\LogSource
x -> LogSource
-> [PersistValue]
-> ReaderT SqlBackend (NoLoggingT (ResourceT m)) ()
forall (m :: * -> *) backend.
(MonadIO m, BackendCompatible SqlBackend backend) =>
LogSource -> [PersistValue] -> ReaderT backend m ()
E.rawExecute (LogSource
"CREATE INDEX IF NOT EXISTS " LogSource -> LogSource -> LogSource
forall a. Semigroup a => a -> a -> a
<> LogSource -> LogSource
mkName LogSource
x LogSource -> LogSource -> LogSource
forall a. Semigroup a => a -> a -> a
<> LogSource
" ON " LogSource -> LogSource -> LogSource
forall a. Semigroup a => a -> a -> a
<> LogSource
x) []) (LogSource -> ReaderT SqlBackend (NoLoggingT (ResourceT m)) ())
-> (LogSource -> LogSource)
-> LogSource
-> ReaderT SqlBackend (NoLoggingT (ResourceT m)) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogSource -> LogSource
mkLowerCase) [LogSource]
indices
where
mkName :: LogSource -> LogSource
mkName LogSource
txt = (LogSource -> (LogSource, LogSource) -> LogSource)
-> LogSource -> [(LogSource, LogSource)] -> LogSource
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\LogSource
acc (LogSource
from, LogSource
to) -> LogSource -> LogSource -> LogSource -> LogSource
T.replace LogSource
from LogSource
to LogSource
acc) (LogSource
txt LogSource -> LogSource -> LogSource
forall a. Semigroup a => a -> a -> a
<> LogSource
"index") [(LogSource, LogSource)]
replacements
replacements :: [(LogSource, LogSource)]
replacements = [(LogSource
"(", LogSource
"_"), (LogSource
")", LogSource
"_"), (LogSource
",", LogSource
"_"), (LogSource
"\"", LogSource
"")]
mkLowerCase :: LogSource -> LogSource
mkLowerCase LogSource
x = LogSource -> LogSource
toLowerCase ( (Char -> Bool) -> LogSource -> LogSource
T.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'(') LogSource
x) LogSource -> LogSource -> LogSource
forall a. Semigroup a => a -> a -> a
<> Char -> LogSource
T.singleton Char
'(' LogSource -> LogSource -> LogSource
forall a. Semigroup a => a -> a -> a
<> LogSource -> LogSource
toLowerCase (LogSource -> LogSource
T.tail (LogSource -> LogSource) -> LogSource -> LogSource
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> LogSource -> LogSource
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'(') LogSource
x)
toLowerCase :: LogSource -> LogSource
toLowerCase =
let go :: Char -> LogSource
go Char
c
| Char -> Bool
isUpper Char
c = String -> LogSource
T.pack [Char
'_', Char -> Char
toLower Char
c]
| Bool
otherwise = Char -> LogSource
T.singleton Char
c
in (Char -> Bool) -> LogSource -> LogSource
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_') (LogSource -> LogSource)
-> (LogSource -> LogSource) -> LogSource -> LogSource
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> LogSource) -> LogSource -> LogSource
T.concatMap Char -> LogSource
go
indices :: [LogSource]
indices =
[
LogSource
"RepResultStep(measure)"
, LogSource
"WarmUpResultStep(measure)"
, LogSource
"PrepResultStep(measure)"
, LogSource
"RepMeasure(repResult)"
, LogSource
"WarmUpMeasure(repResult)"
, LogSource
"PrepMeasure(prepResultData)"
, LogSource
"RepInputValue(repInput)"
, LogSource
"WarmUpInputValue(warmUpInput)"
, LogSource
"PrepInputValue(prepInput)"
, LogSource
"RepStartStatePart(resultData)"
, LogSource
"RepEndStatePart(resultData)"
]