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

-- | Main function.
run :: (HasConfig env Config) => TonaDbM env a -> RIO env a
run :: forall env a. HasConfig env Config => TonaDbM env a -> RIO env a
run TonaDbM env a
query = do
  Pool SqlBackend
pool <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Config -> Pool SqlBackend
connPool forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall env config. HasConfig env config => env -> config
config)
  forall backend (m :: * -> *) 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
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
forall a. (String -> a) -> IsString a
fromString :: String -> DbConnStr
$cfromString :: String -> DbConnStr
IsString, ReadPrec [DbConnStr]
ReadPrec DbConnStr
Int -> ReadS DbConnStr
ReadS [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
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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    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
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
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]
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
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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    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
  }

instance HasParser Config where
  parser :: Parser Config
parser = do
    DbConnStr
connStr <- forall a. HasParser a => Parser a
parser
    DbConnNum
connNum <- forall a. HasParser a => Parser a
parser
    forall a. ((a -> IO ()) -> IO ()) -> Parser a
liftWith forall a b. (a -> b) -> a -> b
$ \Config -> IO ()
action -> do
      forall (m :: * -> *) a.
LoggingT m a
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT
        (forall (m :: * -> *) a.
(MonadLoggerIO m, MonadUnliftIO m) =>
ByteString -> Int -> (Pool SqlBackend -> m a) -> m a
withPostgresqlPool
           (DbConnStr -> ByteString
unDbConnStr DbConnStr
connStr)
           (DbConnNum -> Int
unDbConnNum DbConnNum
connNum)
           (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> IO ()
action 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 <- forall (m :: * -> *) a. MonadIO m => LoggingT m a -> m a
runStdoutLoggingT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
((Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a)
-> LoggingT m a
LoggingT forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Loc -> LogSource -> LogLevel -> LogStr -> IO ()
func Loc
loc LogSource
source LogLevel
level LogStr
msg