module Tonatona.Persist.Sqlite
  ( 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.Sqlite (withSqlitePool, wrapConnection)
import Database.Persist.Sql (Migration, SqlBackend, runMigration, runSqlPool)
import Database.Sqlite (open)

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
  SqliteConn
connType <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Config -> SqliteConn
sqliteConn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall env config. HasConfig env config => env -> config
config)
  case SqliteConn
connType of
    SqliteConn SqlBackend
sqlBackend -> forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT TonaDbM env a
query SqlBackend
sqlBackend
    SqliteConnPool Pool SqlBackend
pool -> 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
":memory:"

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
dbConnString :: DbConnStr
  , Config -> DbConnNum
dbConnNum :: DbConnNum
  , Config -> SqliteConn
sqliteConn :: SqliteConn
  }

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
    let textConnStr :: Text
textConnStr = ByteString -> Text
decodeUtf8Lenient forall a b. (a -> b) -> a -> b
$ DbConnStr -> ByteString
unDbConnStr DbConnStr
connStr
    forall a. ((a -> IO ()) -> IO ()) -> Parser a
liftWith forall a b. (a -> b) -> a -> b
$ \Config -> IO ()
action -> do
      case DbConnStr
connStr of
        DbConnStr
":memory:" -> do
          Connection
conn <- Text -> IO Connection
open Text
":memory:"
          SqlBackend
backend <- Connection -> LogFunc -> IO SqlBackend
wrapConnection Connection
conn LogFunc
stdoutLogger
          Config -> IO ()
action forall a b. (a -> b) -> a -> b
$
            DbConnStr -> DbConnNum -> SqliteConn -> Config
Config DbConnStr
connStr DbConnNum
connNum (SqlBackend -> SqliteConn
SqliteConn SqlBackend
backend)
        DbConnStr
_ ->
          forall (m :: * -> *) a. LoggingT m a -> LogFunc -> m a
runLoggingT
            (forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLoggerIO m) =>
Text -> Int -> (Pool SqlBackend -> m a) -> m a
withSqlitePool
               Text
textConnStr
               (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 -> SqliteConn -> Config
Config DbConnStr
connStr DbConnNum
connNum forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pool SqlBackend -> SqliteConn
SqliteConnPool))
            LogFunc
stdoutLogger

data SqliteConn
  = SqliteConn SqlBackend
  | SqliteConnPool (Pool SqlBackend)

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