{-# 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 :: forall (m :: * -> *) a. MonadIO m => LoggingT m a -> m a
logFun = forall (m :: * -> *) a. MonadIO m => LoggingT m a -> m a
runStdoutLoggingT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
(LogSource -> LogLevel -> Bool) -> LoggingT m a -> LoggingT m a
filterLogger (\LogSource
s LogLevel
_ -> LogSource
s forall a. Eq a => a -> a -> Bool
/= LogSource
"SQL")
runDB :: (MonadUnliftIO m) => DatabaseSetting -> DB m a -> m a
runDB :: forall (m :: * -> *) a.
MonadUnliftIO m =>
DatabaseSetting -> DB m a -> m a
runDB = forall (m1 :: * -> *) a (m :: * -> *).
MonadUnliftIO m1 =>
(m1 a -> m a)
-> DatabaseSetting -> ReaderT SqlBackend (LoggingT m1) a -> m a
runDBWithM forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT
runDBSimple :: DatabaseSetting -> SimpleDB a -> IO a
runDBSimple :: forall a. DatabaseSetting -> SimpleDB a -> IO a
runDBSimple = forall (m1 :: * -> *) a (m :: * -> *).
MonadUnliftIO m1 =>
(m1 a -> m a)
-> DatabaseSetting -> ReaderT SqlBackend (LoggingT m1) a -> m a
runDBWithM 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 :: forall (m1 :: * -> *) a (m :: * -> *).
MonadUnliftIO m1 =>
(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 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => LoggingT m a -> m a
logFun forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadLoggerIO m, MonadUnliftIO m) =>
ConnectionString -> Int -> (Pool SqlBackend -> m a) -> m a
withPostgresqlPool (DatabaseSetting -> ConnectionString
connectionString DatabaseSetting
dbSetting) (DatabaseSetting -> Int
parallelConnections DatabaseSetting
dbSetting) forall a b. (a -> b) -> a -> b
$ \Pool SqlBackend
pool -> 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 :: forall (m :: * -> *).
MonadIO m =>
ReaderT SqlBackend (NoLoggingT (ResourceT m)) ()
indexCreation = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((\LogSource
x -> forall (m :: * -> *) backend.
(MonadIO m, BackendCompatible SqlBackend backend) =>
LogSource -> [PersistValue] -> ReaderT backend m ()
E.rawExecute (LogSource
"CREATE INDEX IF NOT EXISTS " forall a. Semigroup a => a -> a -> a
<> LogSource -> LogSource
mkName LogSource
x forall a. Semigroup a => a -> a -> a
<> LogSource
" ON " forall a. Semigroup a => a -> a -> a
<> LogSource
x) []) forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogSource -> LogSource
mkLowerCase) [LogSource]
indices
where
mkName :: LogSource -> LogSource
mkName LogSource
txt = 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 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 (forall a. Eq a => a -> a -> Bool
/= Char
'(') LogSource
x) forall a. Semigroup a => a -> a -> a
<> Char -> LogSource
T.singleton Char
'(' forall a. Semigroup a => a -> a -> a
<> LogSource -> LogSource
toLowerCase (LogSource -> LogSource
T.tail forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> LogSource -> LogSource
T.dropWhile (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 (forall a. Eq a => a -> a -> Bool
== Char
'_') 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)"
]