{-# 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")

-- logFun :: NoLoggingT m a -> m a
-- logFun = runNoLoggingT


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


-- withPostgresqlPool :: (MonadLogger m, MonadUnliftIO m) => ConnectionString -> Int -> (Pool SqlBackend -> m a) -> m a
-- runSqlPool :: (MonadUnliftIO m, BackendCompatible SqlBackend backend) => ReaderT backend m a -> Pool backend -> m a

-- | Create indices for fast lookups in the DB.
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 =
      [ -- "ExpsInfoParam(exps)"
      -- , "ExpsMaster(exps)"
      -- , "ExpsSetup(exps)"
      -- , "Param(exps)"
      -- , "Exp(exps)"
      -- , "ExpExecutionLock(exp)"
      -- , "ExpProgress(exp)"
      -- , "ParamSetting(exp)"
      -- , "ExpResult(exp)"
      -- , "PrepStartStatePart(resultData)"
      -- , "PrepEndStatePart(resultData)"
      -- , "PrepInput(prepResultData)"
      -- , "PrepInputValue(prepInput)"
      -- , "PrepMeasure(prepResultData)"
      -- , "PrepResultStep(measure)"
      -- , "RepResult(expResult)"

        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)"


      -- , "\"user\"(ident)" -- user is a postgres keyword!
      ]