yam-app (empty) → 0.1.0.0
raw patch · 14 files changed
+805/−0 lines, 14 filesdep +aesondep +basedep +containerssetup-changed
Dependencies added: aeson, base, containers, ctrie, data-default, directory, exceptions, fast-logger, monad-control, monad-logger, persistent, persistent-sqlite, random, reflection, resource-pool, string-conversions, text, time, transformers, unordered-containers, wai-logger, yaml
Files
- LICENSE +30/−0
- README.md +1/−0
- Setup.hs +2/−0
- src/Yam/App.hs +147/−0
- src/Yam/App/Context.hs +56/−0
- src/Yam/Event.hs +38/−0
- src/Yam/Import.hs +61/−0
- src/Yam/Logger.hs +144/−0
- src/Yam/Logger/MonadLogger.hs +23/−0
- src/Yam/Logger/WaiLogger.hs +13/−0
- src/Yam/Prop.hs +116/−0
- src/Yam/Transaction.hs +98/−0
- src/Yam/Transaction/Sqlite.hs +22/−0
- yam-app.cabal +54/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Daniel YU (c) 2018++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Daniel YU nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,1 @@+# yam-app
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Yam/App.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Yam.App(+ module Yam.App.Context+ , module Yam.Import+ , module Yam.Event+ , module Yam.Logger+ , module Yam.Prop+ , module Yam.Transaction+ , runAppM+ , AppM+ , RunMode(..)+ , defaultContext+ , registerEventHandler+ , registerEventHandler'+ , evalPropOrDefault+ , evalProp+ ) where++import Yam.App.Context+import Yam.Event+import Yam.Import+import Yam.Logger+import Yam.Prop+import Yam.Transaction++import Control.Monad.Trans.Control (MonadBaseControl)+import Data.Aeson+import Data.Foldable+import Data.Proxy+++type AppM = ReaderT YamContext++data RunMode = Development | Production deriving (Show, Eq)++instance FromJSON RunMode where+ parseJSON v = go <$> parseJSON v+ where go :: Text -> RunMode+ go "production" = Production+ go _ = Development++runAppM :: (Monad m) => YamContext -> AppM m a -> m a+runAppM = flip runReaderT++instance MonadIO m => HasYamContext (AppM m) where+ yamContext = ask++defaultContext :: IO YamContext+defaultContext = do+ context <- emptyContext+ logger <- stdoutLogger+ runAppM context $ do+ setExtension keyLogger logger+ loadProps+ initLogger+ return context++loadProps :: AppM IO ()+loadProps = do+ context <- ask+ let showLog :: IO PropertySource -> IO PropertySource+ showLog a = do+ src@(f,_) <- a+ runAppM context $ debugLn $ "Load Config " <> f <> " .."+ return src+ source <- liftIO $ do+ cmdSource <- showLog loadCommandLineArgs+ envSource <- showLog loadEnv+ let baseSource@(_,v) = mergePropertySource [cmdSource, envSource]+ mayConf <- runProp v $ getProp "config"+ case mayConf of+ Nothing -> return baseSource+ Just c -> do+ confSource@(_,cv) <- showLog $ loadYaml c+ configs <- runProp cv $ getPropOrDefault [] "configs"+ addtionalSource <- mapM (showLog . loadYaml) configs+ return $ mergePropertySource $ baseSource:confSource:addtionalSource+ setExtension keyProp source++initLogger :: AppM IO ()+initLogger = do+ mayLogFile <- getProp "log.file"+ logRank <- getPropOrDefault DEBUG "log.level"+ withLoggerRank logRank $ case mayLogFile of+ Just file -> do+ newLogger <- liftIO $ fileLogger file+ setExtension keyLogger logger+ Nothing -> return ()++enable :: FromJSON a => Text -> Bool -> Text -> (Maybe a -> AppM IO ()) -> AppM IO ()+enable keyEnable def key action = do+ enables <- getPropOrDefault def keyEnable+ when enables $ getProp key >>= action++keyLogger :: Text+keyLogger = "Extension.Logger"++instance MonadIO m => MonadLogger (AppM m) where+ loggerConfig = requireExtension keyLogger+ withLoggerConfig l action = setExtension keyLogger l >> action++keyProp :: Text+keyProp = "Extension.Prop"++instance MonadIO m => MonadProp (AppM m) where+ propertySource = requireExtension keyProp++evalProp :: FromJSON a => YamContext -> Text -> IO (Maybe a)+evalProp c = runAppM c . getProp++evalPropOrDefault :: FromJSON a => a -> YamContext -> Text -> IO a+evalPropOrDefault a c key = fromMaybe a <$> evalProp c key++keyTransaction :: Text+keyTransaction = "Extension.Transaction"+keySecondaryTransaction :: Text+keySecondaryTransaction = "Extension.Transaction.Secondary"++instance (MonadIO m, MonadBaseControl IO m) => MonadTransaction (AppM m) where+ connectionPool = requireExtension keyTransaction+ setConnectionPool p s = do+ setExtension keyTransaction p+ forM_ s (setExtension keySecondaryTransaction)++keyEvent :: Text+keyEvent = "Extension.Event."++instance MonadIO m => MonadEvent (AppM m) where+ eventHandler proxy = getExtensionOrDefault [] $ keyEvent <> cs (eventKey proxy)++registerEventHandler :: (MonadIO m, Event e) => Proxy e -> (e -> AppM IO ()) -> AppM m ()+registerEventHandler p = registerEventHandler' p Nothing++registerEventHandler' :: (MonadIO m, Event e) => Proxy e -> Maybe Text -> (e -> AppM IO ()) -> AppM m ()+registerEventHandler' p hname h = do+ hs <- eventHandler p+ context <- ask+ let key = keyEvent <> cs (eventKey p)+ h' = runAppM context . h+ name = fromMaybe (key <> "." <> showText (length hs + 1)) hname+ infoLn $ "Register eventHandler " <> name <> " for " <> key+ setExtension key (h':hs)
+ src/Yam/App/Context.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE OverloadedStrings #-}++module Yam.App.Context(+ YamContext(..)+ , HasYamContext(..)+ , requireExtension+ , getExtensionOrDefault+ , setExtension+ , lockExtenstion+ , emptyContext+ ) where++import Yam.Import+import Yam.Logger++import qualified Control.Concurrent.Map as M+import Data.Dynamic++type YamExtension = M.Map Text Dynamic++newtype YamContext = YamContext {extensions :: YamExtension}++emptyContext :: IO YamContext+emptyContext = YamContext <$> M.empty++class MonadIO m => HasYamContext m where+ yamContext :: m YamContext++extensionLockKey :: Text+extensionLockKey = "Extension.Lock"++extension :: HasYamContext m => m YamExtension+extension = extensions <$> yamContext++requireExtension :: (HasYamContext m, Typeable a) => Text -> m a+requireExtension key = extension >>= liftIO . M.lookup key >>= get . (fromDynamic =<<)+ where get Nothing = error $ "Module " <> cs key <> " not loaded"+ get (Just r) = return r++getExtensionOrDefault :: (HasYamContext m, Typeable a) => a -> Text -> m a+getExtensionOrDefault a key = (fromMaybe a . (fromDynamic =<<)) <$> (extension >>= liftIO . M.lookup key)++setExtension :: (MonadLogger m, HasYamContext m, Typeable a) => Text -> a -> m ()+setExtension key a = do+ checkLock+ void $ extension >>= liftIO . M.insert key (toDyn a)+ when (extensionLockKey /= key)+ (debugLn $ "Register extension <<" <> key <> ">>")++checkLock :: HasYamContext m => m ()+checkLock = getExtensionOrDefault False extensionLockKey >>= go+ where go True = error "Extension has freezed, cannot modify now"+ go _ = return ()++lockExtenstion :: (MonadLogger m, HasYamContext m) => m ()+lockExtenstion = setExtension extensionLockKey True
+ src/Yam/Event.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE OverloadedStrings #-}++module Yam.Event(+ MonadEvent(..)+ , Event(..)+ , thenNotify+ ) where+import Yam.Import++import Yam.Logger++import Control.Exception (SomeException)+import Data.Aeson+import Data.Proxy+import Data.Typeable++encodeToText :: ToJSON e => e -> Text+encodeToText = cs . encode++class (Monad m) => MonadEvent m where+ eventHandler :: Event e => Proxy e -> m [e -> IO ()]++class (ToJSON e, Typeable e) => Event e where+ eventKey :: Proxy e -> String+ eventKey = show . typeRep++thenNotify :: (Event e, MonadLogger m, MonadMask m, MonadEvent m) => m a -> e -> m a+thenNotify ma e = do+ a <- ma+ let printStack :: (Event e, MonadLogger m) => e -> SomeException -> m ()+ printStack e x = do+ errorLn $ "Event " <> encodeToText e <> " Failed!"+ errorLn $ "Exception: " <> showText x+ withLoggerName "Event" $ do+ infoLn $ "Event " <> encodeToText e <> " Received!"+ ec <- eventHandler (Proxy :: Proxy e)+ mapM_ (\h -> liftIO (h e) `catchAll` printStack e) ec+ return a
+ src/Yam/Import.hs view
@@ -0,0 +1,61 @@+module Yam.Import(+ Text+ , pack+ , cs+ , showText+ , lift+ , MonadIO+ , liftIO+ , when+ , unless+ , void+ , (<>)+ , myThreadId+ , ThreadId+ , killThread+ , fromMaybe+ , maybe+ , mapMaybe+ , catMaybes+ , selectMaybe+ , finally+ , MonadMask+ , MonadThrow+ , MonadCatch+ , catchAll+ , runReaderT+ , ReaderT+ , ask+ , Generic+ , UTCTime+ , randomHex+ , Proxy(..)+ ) where++import Control.Concurrent+import Control.Monad (unless, void, when)+import Control.Monad.Catch+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)+import Data.Maybe+import Data.Monoid ((<>))+import Data.Proxy+import Data.String.Conversions (cs)+import Data.Text (Text, pack)+import Data.Time.Clock+import GHC.Generics+import System.Random (newStdGen, randoms)+++showText :: Show a => a -> Text+showText = cs . show++_hex = ['0'..'9'] <> ['a'..'f']++randomHex :: Int -> IO Text+randomHex n = (pack . map (go _hex 16) . take n . randoms) <$> newStdGen+ where go gs l v = gs !! mod v l++selectMaybe :: [Maybe a] -> Maybe a+selectMaybe = listToMaybe . catMaybes
+ src/Yam/Logger.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++module Yam.Logger(+ LogRank(..)+ , LoggerConfig(..)+ , MonadLogger(..)+ , logL+ , logLn+ , errorLn+ , warnLn+ , infoLn+ , debugLn+ , traceLn+ , stdoutLogger+ , fileLogger+ , withLoggerRank+ , withLoggerName+ ) where++import Yam.Import++import qualified Control.Concurrent.Map as M+import Control.Monad.Catch (bracket_)+import Control.Monad.Trans.Reader+import Data.Aeson+import System.Log.FastLogger++data LogRank = TRACE+ | DEBUG+ | INFO+ | WARN+ | ERROR+ deriving (Show,Eq,Ord)++instance FromJSON LogRank where+ parseJSON v = go <$> parseJSON v+ where go :: Text -> LogRank+ go "trace" = TRACE+ go "debug" = DEBUG+ go "info" = INFO+ go "warn" = WARN+ go "error" = ERROR+ go _ = INFO++type LoggerCache = M.Map ThreadId Text+type LoggerFunc = Text -> Maybe Text -> LogRank -> LogStr -> IO ()+data LoggerConfig = LoggerConfig+ { logger :: LoggerFunc+ , clock :: IO FormattedTime+ , rank :: LogRank+ , name :: LoggerCache+ }++class (MonadIO m) => MonadLogger m where+ loggerConfig :: m LoggerConfig+ withLoggerConfig :: LoggerConfig -> m a -> m a++instance (MonadIO m) => MonadLogger (ReaderT LoggerConfig m) where+ loggerConfig = ask+ withLoggerConfig = withReaderT . const++logL :: (MonadLogger m) => forall msg . (ToLogStr msg) => LogRank -> msg -> m ()+logL r msg = do+ conf <- loggerConfig+ mayName <- fetchName+ liftIO $ when (r >= rank conf) $ do+ now <- clock conf+ logger conf (cs now) (cs <$> mayName) r (toLogStr msg)++fetchName :: MonadLogger m => m (Maybe Text)+fetchName = do+ conf <- loggerConfig+ liftIO $ do+ threadId <- myThreadId+ M.lookup threadId $ name conf++setName :: MonadLogger m => Maybe Text -> m ()+setName m = do+ conf <- loggerConfig+ liftIO $ myThreadId >>= void . go m (name conf)+ where go (Just m) cache tid = M.insert tid m cache+ go _ cache tid = M.delete tid cache++logLn :: (MonadLogger m) => LogRank -> Text -> m ()+logLn l msg = logL l $ msg <> "\n"++traceLn :: (MonadLogger m) => Text -> m ()+traceLn = logLn TRACE+debugLn :: (MonadLogger m) => Text -> m ()+debugLn = logLn DEBUG+infoLn :: (MonadLogger m) => Text -> m ()+infoLn = logLn INFO+warnLn :: (MonadLogger m) => Text -> m ()+warnLn = logLn WARN+errorLn :: (MonadLogger m) => Text -> m ()+errorLn = logLn ERROR++defaultLoggerConfig :: LoggerFunc -> IO LoggerConfig+defaultLoggerConfig func = do+ nm <- M.empty+ timeCache <- newTimeCache "%F %X"+ return $ LoggerConfig func timeCache DEBUG nm++stdoutLogger :: IO LoggerConfig+stdoutLogger = newStdoutLoggerSet 4096 >>= newLog++fileLogger :: FilePath -> IO LoggerConfig+fileLogger file = newFileLoggerSet 4096 file >>= newLog++newLog :: LoggerSet -> IO LoggerConfig+newLog = defaultLoggerConfig . mkLogger . pushLogStr+ where mkLogger :: FastLogger -> LoggerFunc+ mkLogger logger time mayName rank msg = do+ thread <- myThreadId+ let name = time+ <> " ["+ <> showText thread+ <> "] "+ <> showText rank+ <> " "+ <> fromMaybe "" mayName+ <> " - "+ logger $ toLogStr name <> msg++withLoggerRank :: (MonadLogger m) => LogRank -> m a -> m a+withLoggerRank = withLogger . go+ where go rk conf = conf {rank = rk}++withLoggerName :: (MonadLogger m, MonadMask m) => Text -> m a -> m a+withLoggerName nm action = do+ mayName <- fetchName+ let mayName' = Just $ merge nm mayName+ bracket_ (setName mayName') (setName mayName) action+ where merge n (Just v) = v <> "." <> n+ merge n _ = n++withLogger :: (MonadLogger m) => (LoggerConfig -> LoggerConfig) -> m a -> m a+withLogger modify action = do+ conf <- loggerConfig+ withLoggerConfig (modify conf) action++
+ src/Yam/Logger/MonadLogger.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE OverloadedStrings #-}++module Yam.Logger.MonadLogger(+ toMonadLogger+ , runLoggingT+ ) where++import Yam.Import+import Yam.Logger++import Control.Monad.Logger++type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO ()++toMonadLogger :: (Yam.Logger.MonadLogger m) => m LogFunc+toMonadLogger = mkLogger <$> loggerConfig+ where toRank LevelDebug = DEBUG+ toRank LevelInfo = INFO+ toRank LevelWarn = WARN+ toRank LevelError = ERROR+ toRank _ = INFO+ mkLogger :: LoggerConfig -> LogFunc+ mkLogger context _ name level msg = runReaderT (withLoggerName name $ logL (toRank level) (msg <> "\n")) context
+ src/Yam/Logger/WaiLogger.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE OverloadedStrings #-}++module Yam.Logger.WaiLogger where++import Yam.Import+import Yam.Logger++import Network.Wai.Logger++toWaiLogger :: (MonadLogger m) => m ApacheLogger+toWaiLogger = do mkLogger <- flip runReaderT <$> loggerConfig+ liftIO $ apacheLogger+ <$> initLogger FromFallback (LogCallback (mkLogger . logL INFO) $ return ()) (return "")
+ src/Yam/Prop.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Yam.Prop(+ PropertySource+ , emptyPropertySource+ , MonadProp(..)+ , getProp+ , getPropOrDefault+ , requiredProp+ , tryLoadYaml+ , loadYaml+ , loadEnv+ , loadCommandLineArgs+ , mergePropertySource+ , runProp+ ) where++import Yam.Import++import Data.Aeson (Result (..), fromJSON)+import qualified Data.HashMap.Strict as M+import Data.List (foldl')+import qualified Data.Text as T+import Data.Yaml+import System.Directory (doesFileExist, getFileSize)+import System.Environment (getArgs, getEnvironment)++type PropertySource = (Text, Value)++emptyPropertySource :: PropertySource+emptyPropertySource = ("DEFAULT", Null)++class Monad m => MonadProp m where+ propertySource :: m PropertySource++type ValueProperty = ReaderT PropertySource++instance (Monad m) => MonadProp (ValueProperty m) where+ propertySource = ask++runProp :: (Monad m) => Value -> ValueProperty m a -> m a+runProp v ma = runReaderT ma ("NO_NAME", v)++getPropOrDefault :: (FromJSON a, MonadProp m) => a -> Text -> m a+getPropOrDefault def key = fromMaybe def <$> getProp key++requiredProp :: (FromJSON a, MonadProp m) => Text -> m a+requiredProp key = getProp key >>= maybe (error $ "key " <> cs key <> " not found") return++getProp :: (FromJSON a, MonadProp m) => Text -> m (Maybe a)+getProp key = propertySource >>= go (splitKey key)+ where go :: (FromJSON a, Monad m) => [Text] -> PropertySource -> m (Maybe a)+ go hs (s,v) = to s $ foldl' fetch v hs+ fetch :: Value -> Text -> Value+ fetch (Object map) h = fromMaybe Null $ M.lookup h map+ fetch _ _ = Null+ to :: (FromJSON a, Monad m) => Text -> Value -> m (Maybe a)+ to _ Null = return Nothing+ to s v = case fromJSON v of+ Error e -> error e+ Success a -> return (Just a)+splitKey :: Text -> [Text]+splitKey k | T.null k = []+ | otherwise = T.split (=='.') k++tryLoadYaml :: (MonadIO m) => FilePath -> m (Maybe PropertySource)+tryLoadYaml file = do+ exists <- liftIO $ doesFileExist file+ if exists+ then do+ size <- liftIO $ getFileSize file+ if size > 0 then+ Just . (cs file,) <$> (liftIO (decodeFile file) >>= maybe (error $ file <> " load failed") return)+ else return Nothing+ else return Nothing++loadYaml :: (MonadIO m) => FilePath -> m PropertySource+loadYaml file = tryLoadYaml file >>= maybe (error $ file <> " not found") return++loadEnv :: (MonadIO m) => m PropertySource+loadEnv = do+ env <- liftIO getEnvironment+ return ("System.Environment", convertValue env)++loadCommandLineArgs :: (MonadIO m) => m PropertySource+loadCommandLineArgs = do+ args <- liftIO getArgs+ return ("CommandLine", convertValue $ go args)+ where go = mapMaybe (select . break (=='='))+ select ("", _) = Nothing+ select (_, "") = Nothing+ select (k, '=':vs) = Just (k,vs)+ select kvs = Just kvs++convertValue :: [(String, String)] -> Value+convertValue = toValue . mapMaybe go+ where go :: (String, String) -> Maybe ([Text], Value)+ go (k,v) = (toKey $ cs k, ) <$> decode (cs v)+ toKey = splitKey . T.toLower . T.map (\a -> if a == '_' then '.' else a)+ to :: ([Text], Value) -> Maybe (Text, [([Text], Value)])+ to (h:hs, v) = Just (h, [(hs,v)])+ to ([], _) = Nothing+ toValue :: [([Text], Value)] -> Value+ toValue [([],value)] = value+ toValue vs = Object $ M.map toValue $ M.fromListWith (++) $ mapMaybe to vs++mergePropertySource :: [PropertySource] -> PropertySource+mergePropertySource = foldl' merge emptyPropertySource+ where merge :: (Text, Value) -> (Text, Value) -> (Text, Value)+ merge (n1,v1) (n2,v2) = (n1, merge' v1 v2)+ merge' Null a = a+ merge' (Object a) (Object b) = Object (M.unionWith merge' a b)+ merge' a _ = a
+ src/Yam/Transaction.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}++module Yam.Transaction(+ Transaction+ , TransactionPool(..)+ , DataSource(..)+ , MonadTransaction(..)+ , DataSourceConnector+ , DataSourceProvider+ , HasDataSource(..)+ , runTrans+ , selectValue+ , selectNow+ , now+ , initDataSource+ ) where++import Yam.Import+import Yam.Logger+import Yam.Logger.MonadLogger++import Control.Monad.Trans.Control (MonadBaseControl)+import Data.Aeson+import Data.Default+import qualified Data.Map as M+import Data.Pool+import Data.Proxy+import Data.Reflection+import Database.Persist.Sql+import GHC.TypeLits++-- SqlPersistT ~ ReaderT SqlBackend+type Transaction = SqlPersistT IO++type TransactionPool = Pool SqlBackend++data DataSource = DataSource+ { dbtype :: Text+ , conn :: Text+ , thread :: Int+ , migrate :: Bool+ , extra :: Maybe (M.Map Text Text)+ } deriving (Show, Generic, FromJSON)++instance Default DataSource where+ def = DataSource "sqlite" ":memory:" 10 True Nothing++class (MonadIO m, MonadBaseControl IO m, MonadLogger m) => MonadTransaction m where+ connectionPool :: m TransactionPool+ setConnectionPool :: TransactionPool -> Maybe TransactionPool -> m ()+ secondaryPool :: m (Maybe TransactionPool)+ secondaryPool = return Nothing++type DataSourceConnector m a = LogFunc -> DataSource -> (TransactionPool -> m a) -> m a+type DataSourceProvider m a = (Text, DataSourceConnector m a)++class HasDataSource ds where+ connector :: MonadTransaction m => Proxy ds -> DataSourceConnector m a++initDataSource :: MonadTransaction m => [DataSourceProvider m a] -> DataSource -> Maybe DataSource -> m a -> m a+initDataSource maps ds ds2nd action = let map = M.fromList maps in go map (Just ds) $ go map ds2nd action+ where go _ Nothing action = action+ go map (Just ds) action = case M.lookup (dbtype ds) map of+ Nothing -> error $ "Datasource " <> cs (dbtype ds) <> " not supported"+ Just db -> do+ logger <- toMonadLogger+ db logger ds $ \p -> setConnectionPool p Nothing >> action++runTrans :: MonadTransaction m => Transaction a -> m a+runTrans trans = connectionPool >>= liftIO . runSqlPool trans++runSecondaryTrans :: MonadTransaction m => Transaction a -> m a+runSecondaryTrans trans = do+ pool <- secondaryPool+ case pool of+ Nothing -> error "Secondary Pool not exists"+ Just p -> liftIO $ runSqlPool trans p++selectNow :: Transaction UTCTime+selectNow = head <$> (ask >>= dbNow . connRDBMS)+ where dbNow :: Text -> Transaction [UTCTime]+ dbNow "sqlite" = selectValue "SELECT CURRENT_TIMESTAMP"+ dbNow "postgresql" = selectValue "SELECT CURRENT_TIMESTAMP"+ dbNow "oracle" = selectValue "SELECT SYSDATE FROM DUAL"+ dbNow dbms = error $ "Datasource " <> cs dbms <> " not supported"++selectValue :: (PersistField a) => Text -> Transaction [a]+selectValue sql = fmap unSingle <$> rawSql sql []++now :: MonadTransaction m => m UTCTime+now = runTrans selectNow
+ src/Yam/Transaction/Sqlite.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}++module Yam.Transaction.Sqlite where++import Yam.Import+import Yam.Logger.MonadLogger+import Yam.Transaction++import Data.Default+import Database.Persist.Sqlite+++data SQLite++instance HasDataSource SQLite where+ connector _ logger ds a = runLoggingT (withSqlitePool (conn ds) (toThread ds) (lift.a)) logger+ where toThread ds | conn ds == conn def = 1+ | otherwise = thread ds++sqliteProvider :: MonadTransaction m => DataSourceProvider m a+sqliteProvider = ("sqlite", connector (Proxy :: Proxy SQLite))
+ yam-app.cabal view
@@ -0,0 +1,54 @@+name: yam-app+version: 0.1.0.0+synopsis: Yam App+description: Base Module for Yam+homepage: https://github.com/leptonyu/yam/yam-app#readme+license: BSD3+license-file: LICENSE+author: Daniel YU+maintainer: i@icymint.me+copyright: Copyright: (c) 2017 Daniel YU+category: Web+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++library+ hs-source-dirs: src+ exposed-modules: Yam.App+ , Yam.Import+ , Yam.Transaction+ , Yam.Transaction.Sqlite+ , Yam.Logger.MonadLogger+ , Yam.Logger.WaiLogger+ , Yam.Event+ , Yam.Logger+ , Yam.Prop+ other-modules: Yam.App.Context+ build-depends: base >= 4.7 && < 5+ , monad-control+ , transformers+ , aeson+ , yaml+ , text+ , string-conversions+ , exceptions+ , time+ , random+ , data-default+ , unordered-containers+ , containers+ , ctrie+ , directory+ , fast-logger+ , monad-logger+ , wai-logger+ , persistent+ , resource-pool+ , reflection+ , persistent-sqlite+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/leptonyu/yam-app