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

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

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
    let textConnStr :: Text
textConnStr = ByteString -> Text
decodeUtf8Lenient (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ DbConnStr -> ByteString
unDbConnStr DbConnStr
connStr
    ((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
      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 (Config -> IO ()) -> Config -> IO ()
forall a b. (a -> b) -> a -> b
$
            DbConnStr -> DbConnNum -> SqliteConn -> Config
Config DbConnStr
connStr DbConnNum
connNum (SqlBackend -> SqliteConn
SqliteConn SqlBackend
backend)
        DbConnStr
_ ->
          LoggingT IO () -> LogFunc -> IO ()
forall (m :: * -> *) a. LoggingT m a -> LogFunc -> m a
runLoggingT
            (Text
-> Int -> (Pool SqlBackend -> LoggingT IO ()) -> LoggingT IO ()
forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLogger m) =>
Text -> Int -> (Pool SqlBackend -> m a) -> m a
withSqlitePool
               Text
textConnStr
               (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 -> SqliteConn -> Config
Config DbConnStr
connStr DbConnNum
connNum (SqliteConn -> Config)
-> (Pool SqlBackend -> SqliteConn) -> Pool SqlBackend -> Config
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 <- LoggingT IO LogFunc -> IO LogFunc
forall (m :: * -> *) a. MonadIO m => LoggingT m a -> m a
runStdoutLoggingT (LoggingT IO LogFunc -> IO LogFunc)
-> LoggingT IO LogFunc -> IO LogFunc
forall a b. (a -> b) -> a -> b
$ (LogFunc -> IO LogFunc) -> LoggingT IO LogFunc
forall (m :: * -> *) a. (LogFunc -> m a) -> LoggingT m a
LoggingT LogFunc -> IO LogFunc
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  LogFunc
func Loc
loc Text
source LogLevel
level LogStr
msg