yam-transaction 0.3.1 → 0.3.2
raw patch · 2 files changed
+45/−28 lines, 2 filesdep +resource-pooldep +vaultdep −mtl
Dependencies added: resource-pool, vault
Dependencies removed: mtl
Files
- src/Yam/Transaction.hs +41/−25
- yam-transaction.cabal +4/−3
src/Yam/Transaction.hs view
@@ -1,19 +1,21 @@+{-# LANGUAGE UndecidableInstances #-}+ module Yam.Transaction( Transaction , DataSourceConfig(..) , DataSourceProvider(..) , dataSource+ , closeDataSource , DataSource , runTrans , query , selectValue , selectNow- , now ) where import Yam.Logger -import Control.Monad.IO.Unlift (MonadUnliftIO)+import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO) import Control.Monad.Logger import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Reader@@ -26,6 +28,8 @@ 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@@ -34,12 +38,13 @@ type Transaction m = SqlPersistT (ReaderT DataSource m) data DataSourceConfig = DataSourceConfig- { dstype :: Text- , url :: Text- , user :: Text- , pass :: Text- , port :: Int- , thread :: Int+ { dstype :: Text+ , url :: Text+ , user :: Text+ , pass :: Text+ , port :: Int+ , thread :: Int+ , enabled :: Bool } deriving Show instance FromJSON DataSourceConfig where@@ -50,6 +55,7 @@ <*> v .:? "password" .!= "" <*> v .:? "port" .!= 0 <*> v .:? "pool-size" .!= 10+ <*> v .:? "enabled" .!= True parseJSON v = typeMismatch "DataSourceConfig" v instance Default DataSourceConfig where@@ -61,18 +67,32 @@ , createConnectionPool :: DataSourceConfig -> LoggingT IO ConnectionPool } -type DataSource = (DataSourceProvider, 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 = case lookup dstype $ fmap (\p->(datasource p,p)) ps of- Nothing -> error $ "DataSource Type " <> unpack dstype <> " Not Supported"- Just v -> (v,) <$> runLoggingT (createConnectionPool v dsc) (toMonadLogger lc)+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) -runTrans :: MonadUnliftIO m => DataSource -> Transaction m a -> m a+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- (_,pool) <- ask- runSqlPool trans pool+ 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 @@ -82,22 +102,18 @@ instance FromPersistValue Text where parsePersistValue = intercalate "," . rights . map fromPersistValueText -query :: FromPersistValue a => Text -> [PersistValue] -> Transaction IO [a]+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 :: Transaction IO UTCTime+selectNow :: MonadUnliftIO m => Transaction m UTCTime selectNow = do- (p,_) <- lift $ ask+ DataSource (p,_,_) <- lift ask head <$> selectValue (currentSQL p) -selectValue :: (PersistField a) => Text -> Transaction IO [a]+selectValue :: (PersistField a, MonadUnliftIO m) => Text -> Transaction m [a] selectValue sql = fmap unSingle <$> rawSql sql [] -now :: DataSource -> IO UTCTime-now p = runTrans p selectNow----+instance LoggerMonad m => LoggerMonad (Transaction m) where+ loggerConfig = lift $ lift loggerConfig
yam-transaction.cabal view
@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 55a898afe139e7898846588eafb823c7cd3af91dd3fef6fe544384f41d793f88+-- hash: 4739d7a08350b4c0aaf0a184e357f36d395a74259c23535bd9a4bf4329948f8b name: yam-transaction-version: 0.3.1+version: 0.3.2 synopsis: Yam transaction description: transaction module for yam category: Project@@ -40,15 +40,16 @@ , conduit , data-default , monad-logger- , mtl , persistent , persistent-postgresql , persistent-sqlite+ , resource-pool , resourcet , string-conversions , text , time , transformers , unliftio-core+ , vault , yam-logger default-language: Haskell2010