module Tonatona.Persist.Postgresql
  ( run
  , TonaDbM
  , Config(..)
  , DbConnStr(..)
  , DbConnNum(..)
  , runMigrate
  ) where

import RIO

import Control.Monad.Logger as Logger (Loc, LoggingT(..), LogLevel, LogSource, LogStr, runStdoutLoggingT)
import Data.Pool (Pool)
import Database.Persist.Postgresql (withPostgresqlPool)
import Database.Persist.Sql (Migration, SqlBackend, runMigration, runSqlPool)

import Tonatona (HasConfig(..), HasParser(..))
import TonaParser ((.||), argLong, envVar, liftWith, optionalVal)

type TonaDbM env
  = ReaderT SqlBackend (RIO env)

runMigrate :: (HasConfig env Config) => Migration -> RIO env ()
runMigrate :: Migration -> RIO env ()
runMigrate Migration
migration = TonaDbM env () -> RIO env ()
forall env a. HasConfig env Config => TonaDbM env a -> RIO env a
run (TonaDbM env () -> RIO env ()) -> TonaDbM env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Migration -> TonaDbM env ()
forall (m :: * -> *).
MonadIO m =>
Migration -> ReaderT SqlBackend m ()
runMigration Migration
migration

-- | Main function.
run :: (HasConfig env Config) => TonaDbM env a -> RIO env a
run :: TonaDbM env a -> RIO env a
run TonaDbM env a
query = do
  Pool SqlBackend
pool <- (env -> Pool SqlBackend) -> RIO env (Pool SqlBackend)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Config -> Pool SqlBackend
connPool (Config -> Pool SqlBackend)
-> (env -> Config) -> env -> Pool SqlBackend
forall b c a. (b -> c) -> (a -> b) -> a -> c
. env -> Config
forall env config. HasConfig env config => env -> config
config)
  TonaDbM env a -> Pool SqlBackend -> RIO env a
forall (m :: * -> *) backend a.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a -> Pool backend -> m a
runSqlPool TonaDbM env a
query Pool SqlBackend
pool

------------
-- Config --
------------

newtype DbConnStr = DbConnStr
  { DbConnStr -> ByteString
unDbConnStr :: ByteString
  } deriving (DbConnStr -> DbConnStr -> Bool
(DbConnStr -> DbConnStr -> Bool)
-> (DbConnStr -> DbConnStr -> Bool) -> Eq DbConnStr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DbConnStr -> DbConnStr -> Bool
$c/= :: DbConnStr -> DbConnStr -> Bool
== :: DbConnStr -> DbConnStr -> Bool
$c== :: DbConnStr -> DbConnStr -> Bool
Eq, String -> DbConnStr
(String -> DbConnStr) -> IsString DbConnStr
forall a. (String -> a) -> IsString a
fromString :: String -> DbConnStr
$cfromString :: String -> DbConnStr
IsString, ReadPrec [DbConnStr]
ReadPrec DbConnStr
Int -> ReadS DbConnStr
ReadS [DbConnStr]
(Int -> ReadS DbConnStr)
-> ReadS [DbConnStr]
-> ReadPrec DbConnStr
-> ReadPrec [DbConnStr]
-> Read DbConnStr
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [DbConnStr]
$creadListPrec :: ReadPrec [DbConnStr]
readPrec :: ReadPrec DbConnStr
$creadPrec :: ReadPrec DbConnStr
readList :: ReadS [DbConnStr]
$creadList :: ReadS [DbConnStr]
readsPrec :: Int -> ReadS DbConnStr
$creadsPrec :: Int -> ReadS DbConnStr
Read, Int -> DbConnStr -> ShowS
[DbConnStr] -> ShowS
DbConnStr -> String
(Int -> DbConnStr -> ShowS)
-> (DbConnStr -> String)
-> ([DbConnStr] -> ShowS)
-> Show DbConnStr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DbConnStr] -> ShowS
$cshowList :: [DbConnStr] -> ShowS
show :: DbConnStr -> String
$cshow :: DbConnStr -> String
showsPrec :: Int -> DbConnStr -> ShowS
$cshowsPrec :: Int -> DbConnStr -> ShowS
Show)

instance HasParser DbConnStr where
  parser :: Parser DbConnStr
parser = ByteString -> DbConnStr
DbConnStr (ByteString -> DbConnStr) -> Parser ByteString -> Parser DbConnStr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    Description -> Source -> ByteString -> Parser ByteString
forall a. Var a => Description -> Source -> a -> Parser a
optionalVal
      Description
"Formatted string to connect postgreSQL"
      (String -> Source
argLong String
"db-conn-string" Source -> Source -> Source
.|| String -> Source
envVar String
"DB_CONN_STRING")
      ByteString
"postgresql://myuser:mypass@localhost:5432/mydb"

newtype DbConnNum = DbConnNum { DbConnNum -> Int
unDbConnNum :: Int }
  deriving (DbConnNum -> DbConnNum -> Bool
(DbConnNum -> DbConnNum -> Bool)
-> (DbConnNum -> DbConnNum -> Bool) -> Eq DbConnNum
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DbConnNum -> DbConnNum -> Bool
$c/= :: DbConnNum -> DbConnNum -> Bool
== :: DbConnNum -> DbConnNum -> Bool
$c== :: DbConnNum -> DbConnNum -> Bool
Eq, Integer -> DbConnNum
DbConnNum -> DbConnNum
DbConnNum -> DbConnNum -> DbConnNum
(DbConnNum -> DbConnNum -> DbConnNum)
-> (DbConnNum -> DbConnNum -> DbConnNum)
-> (DbConnNum -> DbConnNum -> DbConnNum)
-> (DbConnNum -> DbConnNum)
-> (DbConnNum -> DbConnNum)
-> (DbConnNum -> DbConnNum)
-> (Integer -> DbConnNum)
-> Num DbConnNum
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> DbConnNum
$cfromInteger :: Integer -> DbConnNum
signum :: DbConnNum -> DbConnNum
$csignum :: DbConnNum -> DbConnNum
abs :: DbConnNum -> DbConnNum
$cabs :: DbConnNum -> DbConnNum
negate :: DbConnNum -> DbConnNum
$cnegate :: DbConnNum -> DbConnNum
* :: DbConnNum -> DbConnNum -> DbConnNum
$c* :: DbConnNum -> DbConnNum -> DbConnNum
- :: DbConnNum -> DbConnNum -> DbConnNum
$c- :: DbConnNum -> DbConnNum -> DbConnNum
+ :: DbConnNum -> DbConnNum -> DbConnNum
$c+ :: DbConnNum -> DbConnNum -> DbConnNum
Num, ReadPrec [DbConnNum]
ReadPrec DbConnNum
Int -> ReadS DbConnNum
ReadS [DbConnNum]
(Int -> ReadS DbConnNum)
-> ReadS [DbConnNum]
-> ReadPrec DbConnNum
-> ReadPrec [DbConnNum]
-> Read DbConnNum
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [DbConnNum]
$creadListPrec :: ReadPrec [DbConnNum]
readPrec :: ReadPrec DbConnNum
$creadPrec :: ReadPrec DbConnNum
readList :: ReadS [DbConnNum]
$creadList :: ReadS [DbConnNum]
readsPrec :: Int -> ReadS DbConnNum
$creadsPrec :: Int -> ReadS DbConnNum
Read, Int -> DbConnNum -> ShowS
[DbConnNum] -> ShowS
DbConnNum -> String
(Int -> DbConnNum -> ShowS)
-> (DbConnNum -> String)
-> ([DbConnNum] -> ShowS)
-> Show DbConnNum
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DbConnNum] -> ShowS
$cshowList :: [DbConnNum] -> ShowS
show :: DbConnNum -> String
$cshow :: DbConnNum -> String
showsPrec :: Int -> DbConnNum -> ShowS
$cshowsPrec :: Int -> DbConnNum -> ShowS
Show)

instance HasParser DbConnNum where
  parser :: Parser DbConnNum
parser = Int -> DbConnNum
DbConnNum (Int -> DbConnNum) -> Parser Int -> Parser DbConnNum
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    Description -> Source -> Int -> Parser Int
forall a. Var a => Description -> Source -> a -> Parser a
optionalVal
      Description
"Number of connections which connection pool uses"
      ( String -> Source
argLong String
"db-conn-num" Source -> Source -> Source
.|| String -> Source
envVar String
"DB_CONN_NUM")
      Int
10

data Config = Config
  { Config -> DbConnStr
connString :: DbConnStr
  , Config -> DbConnNum
connNum :: DbConnNum
  , Config -> Pool SqlBackend
connPool :: Pool SqlBackend
  }
  deriving (Int -> Config -> ShowS
[Config] -> ShowS
Config -> String
(Int -> Config -> ShowS)
-> (Config -> String) -> ([Config] -> ShowS) -> Show Config
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Config] -> ShowS
$cshowList :: [Config] -> ShowS
show :: Config -> String
$cshow :: Config -> String
showsPrec :: Int -> Config -> ShowS
$cshowsPrec :: Int -> Config -> ShowS
Show)

instance HasParser Config where
  parser :: Parser Config
parser = do
    DbConnStr
connStr <- Parser DbConnStr
forall a. HasParser a => Parser a
parser
    DbConnNum
connNum <- Parser DbConnNum
forall a. HasParser a => Parser a
parser
    ((Config -> IO ()) -> IO ()) -> Parser Config
forall a. ((a -> IO ()) -> IO ()) -> Parser a
liftWith (((Config -> IO ()) -> IO ()) -> Parser Config)
-> ((Config -> IO ()) -> IO ()) -> Parser Config
forall a b. (a -> b) -> a -> b
$ \Config -> IO ()
action -> do
      LoggingT IO ()
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> IO ()
forall (m :: * -> *) a.
LoggingT m a
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT
        (ByteString
-> Int -> (Pool SqlBackend -> LoggingT IO ()) -> LoggingT IO ()
forall (m :: * -> *) a.
(MonadLogger m, MonadUnliftIO m) =>
ByteString -> Int -> (Pool SqlBackend -> m a) -> m a
withPostgresqlPool
           (DbConnStr -> ByteString
unDbConnStr DbConnStr
connStr)
           (DbConnNum -> Int
unDbConnNum DbConnNum
connNum)
           (IO () -> LoggingT IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> LoggingT IO ())
-> (Pool SqlBackend -> IO ()) -> Pool SqlBackend -> LoggingT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> IO ()
action (Config -> IO ())
-> (Pool SqlBackend -> Config) -> Pool SqlBackend -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DbConnStr -> DbConnNum -> Pool SqlBackend -> Config
Config DbConnStr
connStr DbConnNum
connNum))
        Loc -> LogSource -> LogLevel -> LogStr -> IO ()
stdoutLogger

stdoutLogger :: Loc -> Logger.LogSource -> Logger.LogLevel -> LogStr -> IO ()
stdoutLogger :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
stdoutLogger Loc
loc LogSource
source LogLevel
level LogStr
msg = do
  Loc -> LogSource -> LogLevel -> LogStr -> IO ()
func <- LoggingT IO (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> IO (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
forall (m :: * -> *) a. MonadIO m => LoggingT m a -> m a
runStdoutLoggingT (LoggingT IO (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
 -> IO (Loc -> LogSource -> LogLevel -> LogStr -> IO ()))
-> LoggingT IO (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> IO (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
forall a b. (a -> b) -> a -> b
$ ((Loc -> LogSource -> LogLevel -> LogStr -> IO ())
 -> IO (Loc -> LogSource -> LogLevel -> LogStr -> IO ()))
-> LoggingT IO (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
forall (m :: * -> *) a.
((Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a)
-> LoggingT m a
LoggingT (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> IO (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Loc -> LogSource -> LogLevel -> LogStr -> IO ()
func Loc
loc LogSource
source LogLevel
level LogStr
msg