{-# LANGUAGE UndecidableInstances #-}
module Yam.Transaction(
Transaction
, DataSourceConfig(..)
, DataSourceProvider(..)
, dataSource
, closeDataSource
, DataSource
, runTrans
, query
, selectValue
, selectNow
) where
import Yam.Logger
import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO)
import Control.Monad.Logger
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Reader
import Data.Acquire (withAcquire)
import Data.Aeson
import Data.Aeson.Types
import Data.Conduit
import qualified Data.Conduit.List as CL
import Data.Default
import Data.Either (rights)
import Data.Maybe (fromJust)
import Data.Monoid ((<>))
import Data.Pool
import Data.Pool (withResource)
import Data.Text (Text, intercalate, unpack)
import Data.Time (UTCTime)
import Database.Persist.Sql
type Transaction m = SqlPersistT (ReaderT DataSource m)
data DataSourceConfig = DataSourceConfig
{ dstype :: Text
, dbname :: Text
, url :: Text
, user :: Text
, pass :: Text
, extra :: Text
, port :: Int
, thread :: Int
, enabled :: Bool
} deriving Show
instance FromJSON DataSourceConfig where
parseJSON (Object v) = DataSourceConfig
<$> v .:? "type" .!= "sqlite"
<*> v .:? "dbname" .!= ":memory:"
<*> v .:? "url" .!= "localhost"
<*> v .:? "username" .!= "sa"
<*> v .:? "password" .!= ""
<*> v .:? "extra" .!= ""
<*> v .:? "port" .!= 0
<*> v .:? "pool-size" .!= 10
<*> v .:? "enabled" .!= True
parseJSON v = typeMismatch "DataSourceConfig" v
instance Default DataSourceConfig where
def = fromJust $ decode "{}"
data DataSourceProvider = DataSourceProvider
{ datasource :: Text
, currentSQL :: Text
, createConnectionPool :: DataSourceConfig -> LoggingT IO ConnectionPool
}
newtype DataSource = DataSource (DataSourceProvider, DataSourceConfig , ConnectionPool)
instance Show DataSource where
show (DataSource (_,dsc,_)) = show dsc
dataSource :: LoggerConfig -> DataSourceConfig -> [DataSourceProvider] -> IO DataSource
dataSource lc dsc@DataSourceConfig{..} ps = do
logger lc INFO $ "Initialize database " <> toLogStr dstype <> "\n"
case Prelude.lookup dstype $ fmap (\p->(datasource p,p)) ps of
Nothing -> error $ "DataSource Type " <> unpack dstype <> " Not Supported"
Just v -> (\d -> DataSource (v,dsc,d)) <$> runLoggingT (createConnectionPool v dsc) (fixLn $ toMonadLogger lc)
closeDataSource :: LoggerConfig -> DataSource -> IO ()
closeDataSource lc (DataSource (_,DataSourceConfig{..},pool)) = do
logger lc INFO $ "Close database " <> toLogStr dstype <> "\n"
destroyAllResources pool
runTrans :: (LoggerMonad m, MonadUnliftIO m) => DataSource -> Transaction m a -> m a
runTrans ds trans = flip runReaderT ds $ do
DataSource (_,_,pool) <- ask
lc <- lift loggerConfig
withRunInIO $ \run -> withResource pool $ run . \c -> runSqlConn trans c {connLogFunc = fixLn $ toMonadLogger lc}
fixLn :: LogFunc -> LogFunc
fixLn f a b c str = f a b c $ str <> "\n"
class FromPersistValue a where
parsePersistValue :: [PersistValue] -> a
instance PersistField a => FromPersistValue [a] where
parsePersistValue = rights . map fromPersistValue
instance FromPersistValue Text where
parsePersistValue = intercalate "," . rights . map fromPersistValueText
query :: (MonadUnliftIO m, FromPersistValue a) => Text -> [PersistValue] -> Transaction m [a]
query sql params = do res <- rawQueryRes sql params
withAcquire res (\a -> runConduit $ a .| CL.fold i [])
where i b ps = parsePersistValue ps : b
selectNow :: MonadUnliftIO m => Transaction m UTCTime
selectNow = do
DataSource (p,_,_) <- lift ask
head <$> selectValue (currentSQL p)
selectValue :: (PersistField a, MonadUnliftIO m) => Text -> Transaction m [a]
selectValue sql = fmap unSingle <$> rawSql sql []
instance LoggerMonad m => LoggerMonad (Transaction m) where
loggerConfig = lift $ lift loggerConfig