yam-app 0.1.4 → 0.1.5
raw patch · 9 files changed
+118/−54 lines, 9 filesdep +conduitdep +resourcetdep −reflection
Dependencies added: conduit, resourcet
Dependencies removed: reflection
Files
- src/Yam/App.hs +13/−13
- src/Yam/App/Context.hs +18/−3
- src/Yam/Event.hs +0/−5
- src/Yam/Import.hs +36/−7
- src/Yam/Logger.hs +0/−6
- src/Yam/Prop.hs +1/−1
- src/Yam/Transaction.hs +46/−15
- src/Yam/Transaction/Sqlite.hs +1/−2
- yam-app.cabal +3/−2
src/Yam/App.hs view
@@ -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)
src/Yam/App/Context.hs view
@@ -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
src/Yam/Event.hs view
@@ -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 ()]
src/Yam/Import.hs view
@@ -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
src/Yam/Logger.hs view
@@ -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
src/Yam/Prop.hs view
@@ -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)])
src/Yam/Transaction.hs view
@@ -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)
src/Yam/Transaction/Sqlite.hs view
@@ -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
yam-app.cabal view
@@ -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