diff --git a/src/Yam/App.hs b/src/Yam/App.hs --- a/src/Yam/App.hs +++ b/src/Yam/App.hs @@ -30,9 +30,6 @@ import Yam.Transaction import Control.Monad.Trans.Control (MonadBaseControl) -import Data.Aeson -import Data.Foldable -import Data.Proxy type AppM = ReaderT YamContext @@ -54,12 +51,9 @@ defaultContext :: IO YamContext defaultContext = do context <- emptyContext - logger <- stdoutLogger runAppM context $ do - setExtension keyLogger logger loadProps initLogger - return context loadProps :: AppM IO () loadProps = do @@ -83,15 +77,18 @@ return $ mergePropertySource $ baseSource:confSource:addtionalSource setExtension keyProp source -initLogger :: AppM IO () +initLogger :: AppM IO YamContext initLogger = do mayLogFile <- getProp "log.file" logRank <- getPropOrDefault DEBUG "log.level" - withLoggerRank logRank $ case mayLogFile of + context <- ask + let config = defLogger context + case mayLogFile of Just file -> do newLogger <- liftIO $ fileLogger file - setExtension keyLogger logger - Nothing -> return () + setExtension keyLogger $ newLogger { rank = logRank } + return context + Nothing -> return context { defLogger = config {rank = logRank} } enable :: FromJSON a => Text -> Bool -> Text -> (Maybe a -> AppM IO ()) -> AppM IO () enable keyEnable def key action = do @@ -102,8 +99,10 @@ keyLogger = "Extension.Logger" instance MonadIO m => MonadLogger (AppM m) where - loggerConfig = requireExtension keyLogger - withLoggerConfig l action = setExtension keyLogger l >> action + loggerConfig = do + context <- yamContext + getExtensionOrDefault (defLogger context) keyLogger + withLoggerConfig = (>>) . setExtension keyLogger keyProp :: Text keyProp = "Extension.Prop" @@ -122,8 +121,9 @@ keySecondaryTransaction :: Text keySecondaryTransaction = "Extension.Transaction.Secondary" -instance (MonadIO m, MonadBaseControl IO m) => MonadTransaction (AppM m) where +instance (MonadIO m, MonadBaseControl IO m, MonadMask m) => MonadTransaction (AppM m) where connectionPool = requireExtension keyTransaction + secondaryPool = getExtension keySecondaryTransaction setConnectionPool p s = do setExtension keyTransaction p forM_ s (setExtension keySecondaryTransaction) diff --git a/src/Yam/App/Context.hs b/src/Yam/App/Context.hs --- a/src/Yam/App/Context.hs +++ b/src/Yam/App/Context.hs @@ -5,9 +5,11 @@ , HasYamContext(..) , requireExtension , getExtensionOrDefault + , getExtension , setExtension , lockExtenstion , emptyContext + , cleanContext ) where import Yam.Import @@ -18,10 +20,13 @@ type YamExtension = M.Map Text Dynamic -newtype YamContext = YamContext {extensions :: YamExtension} +data YamContext = YamContext + { defLogger :: LoggerConfig + , extensions :: YamExtension + } emptyContext :: IO YamContext -emptyContext = YamContext <$> M.empty +emptyContext = YamContext <$> stdoutLogger <*> M.empty class MonadIO m => HasYamContext m where yamContext :: m YamContext @@ -37,12 +42,16 @@ where get Nothing = error $ "Module " <> cs key <> " not loaded" get (Just r) = return r +getExtension :: (HasYamContext m, Typeable a) => Text -> m (Maybe a) +getExtension key = (fromDynamic =<<) <$> (extension >>= liftIO . M.lookup key) + 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 + when (extensionLockKey /= key) + checkLock void $ extension >>= liftIO . M.insert key (toDyn a) when (extensionLockKey /= key) (debugLn $ "Register extension <<" <> key <> ">>") @@ -54,3 +63,9 @@ lockExtenstion :: (MonadLogger m, HasYamContext m) => m () lockExtenstion = setExtension extensionLockKey True + +unlockExtenstion :: (MonadLogger m, HasYamContext m) => m () +unlockExtenstion = setExtension extensionLockKey False + +cleanContext :: (MonadLogger m, HasYamContext m) => m () -> m () +cleanContext action = unlockExtenstion >> action diff --git a/src/Yam/Event.hs b/src/Yam/Event.hs --- a/src/Yam/Event.hs +++ b/src/Yam/Event.hs @@ -10,12 +10,7 @@ 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 ()] diff --git a/src/Yam/Import.hs b/src/Yam/Import.hs --- a/src/Yam/Import.hs +++ b/src/Yam/Import.hs @@ -4,6 +4,7 @@ , cs , showText , lift + , join , MonadIO , liftIO , when @@ -19,6 +20,8 @@ , mapMaybe , catMaybes , selectMaybe + , isNothing + , isJust , finally , MonadMask , MonadThrow @@ -29,25 +32,51 @@ , ask , Generic , UTCTime + , addUTCTime + , fromTime + , millisToUTC , randomHex , Proxy(..) + , encodeToText + , FromJSON(..) + , ToJSON(..) + , decode + , Default(..) + , MonadBaseControl ) where import Control.Concurrent import Control.Monad import Control.Monad.Catch -import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Class -import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT) +import Control.Monad.Trans.Control (MonadBaseControl) +import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT) +import Data.Aeson +import Data.Default import Data.Maybe -import Data.Monoid ((<>)) +import Data.Monoid ((<>)) import Data.Proxy -import Data.String.Conversions (cs) -import Data.Text (Text, pack) -import Data.Time.Clock +import Data.String.Conversions (cs) +import Data.Text (Text, pack) +import Data.Time (UTCTime) +import Data.Time.Clock (addUTCTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Data.Time.Format (defaultTimeLocale, formatTime) +import Data.Time.LocalTime (utcToLocalZonedTime) import GHC.Generics -import System.Random (newStdGen, randoms) +import System.Random (newStdGen, randoms) + +millisToUTC :: Integer -> UTCTime +millisToUTC t = posixSecondsToUTCTime $ fromInteger t / 1000 + +fromTime :: Text -> UTCTime -> IO Text +fromTime p t = do zt <- utcToLocalZonedTime t + return $ cs $ formatTime defaultTimeLocale (cs p) zt + +encodeToText :: ToJSON e => e -> Text +encodeToText = cs . encode showText :: Show a => a -> Text showText = cs . show diff --git a/src/Yam/Logger.hs b/src/Yam/Logger.hs --- a/src/Yam/Logger.hs +++ b/src/Yam/Logger.hs @@ -15,7 +15,6 @@ , traceLn , stdoutLogger , fileLogger - , withLoggerRank , withLoggerName ) where @@ -24,7 +23,6 @@ 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 @@ -123,10 +121,6 @@ <> 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 diff --git a/src/Yam/Prop.hs b/src/Yam/Prop.hs --- a/src/Yam/Prop.hs +++ b/src/Yam/Prop.hs @@ -98,7 +98,7 @@ convertValue :: [(String, String)] -> Value convertValue = toValue . mapMaybe go where go :: (String, String) -> Maybe ([Text], Value) - go (k,v) = (toKey $ cs k, ) <$> decode (cs v) + go (k,v) = (toKey $ cs k, ) <$> Data.Yaml.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)]) diff --git a/src/Yam/Transaction.hs b/src/Yam/Transaction.hs --- a/src/Yam/Transaction.hs +++ b/src/Yam/Transaction.hs @@ -5,6 +5,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} module Yam.Transaction( @@ -21,21 +22,23 @@ , now , initDataSource , runSecondaryTrans + , query ) where import Yam.Import import Yam.Logger import Yam.Logger.MonadLogger +import Yam.Prop import Control.Monad.Trans.Control (MonadBaseControl) -import Data.Aeson -import Data.Default +import Data.Acquire (with) +import Data.Conduit +import qualified Data.Conduit.List as CL +import Data.Either (rights) import qualified Data.Map as M import Data.Pool -import Data.Proxy -import Data.Reflection +import qualified Data.Text as T import Database.Persist.Sql -import GHC.TypeLits -- SqlPersistT ~ ReaderT SqlBackend type Transaction = SqlPersistT IO @@ -48,12 +51,21 @@ , thread :: Int , migrate :: Bool , extra :: Maybe (M.Map Text Text) - } deriving (Show, Generic, FromJSON) + } deriving Show +instance FromJSON DataSource where + parseJSON v = runProp v $ do + dsDt <- getPropOrDefault (dbtype def) "type" + dsCn <- getPropOrDefault (conn def) "conn" + dsTh <- getPropOrDefault (thread def) "thread" + dsMi <- getPropOrDefault (Yam.Transaction.migrate def) "migrate" + dsEx <- getProp "extra" + return $ DataSource dsDt dsCn dsTh dsMi dsEx + instance Default DataSource where def = DataSource "sqlite" ":memory:" 10 True Nothing -class (MonadIO m, MonadBaseControl IO m, MonadLogger m) => MonadTransaction m where +class (MonadIO m, MonadBaseControl IO m, MonadLogger m, MonadMask m) => MonadTransaction m where connectionPool :: m TransactionPool setConnectionPool :: TransactionPool -> Maybe TransactionPool -> m () secondaryPool :: m (Maybe TransactionPool) @@ -66,23 +78,42 @@ 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 +initDataSource maps ds ds2nd action = let map = M.fromList maps in go map ds ds2nd action + where go map ds ds2 action = do + logger <- toMonadLogger + getConnector map logger ds $ \p -> do + case ds2 of + Nothing -> setConnectionPool p Nothing >> action + Just s2 -> getConnector map logger s2 $ \v -> setConnectionPool p (Just v) >> action + getConnector map logger ds = 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 + Just db -> db logger ds runTrans :: MonadTransaction m => Transaction a -> m a -runTrans trans = connectionPool >>= liftIO . runSqlPool trans +runTrans trans = connectionPool >>= executePool trans +executePool trans p = liftIO (runSqlPool trans p) + 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 + Just p -> withLoggerName "Backup" $ executePool trans p + +class FromPersistValue a where + parsePersistValue :: [PersistValue] -> a + +instance PersistField a => FromPersistValue [a] where + parsePersistValue = rights . map fromPersistValue + +instance FromPersistValue Text where + parsePersistValue = T.intercalate "," . rights . map fromPersistValueText + +query :: FromPersistValue a => Text -> [PersistValue] -> Transaction [a] +query sql params = do res <- rawQueryRes sql params + liftIO $ with res ($$ CL.fold i []) + where i b ps = parsePersistValue ps : b selectNow :: Transaction UTCTime selectNow = head <$> (ask >>= dbNow . connRDBMS) diff --git a/src/Yam/Transaction/Sqlite.hs b/src/Yam/Transaction/Sqlite.hs --- a/src/Yam/Transaction/Sqlite.hs +++ b/src/Yam/Transaction/Sqlite.hs @@ -3,11 +3,10 @@ module Yam.Transaction.Sqlite where +import Control.Monad.Logger (runLoggingT) import Yam.Import -import Yam.Logger.MonadLogger import Yam.Transaction -import Data.Default import Database.Persist.Sqlite diff --git a/yam-app.cabal b/yam-app.cabal --- a/yam-app.cabal +++ b/yam-app.cabal @@ -1,5 +1,5 @@ name: yam-app -version: 0.1.4 +version: 0.1.5 synopsis: Yam App description: Base Module for Yam homepage: https://github.com/leptonyu/yam/yam-app#readme @@ -45,8 +45,9 @@ , wai-logger , persistent , resource-pool - , reflection , persistent-sqlite + , conduit + , resourcet default-language: Haskell2010 source-repository head