yam-app 0.1.5 → 0.1.6
raw patch · 10 files changed
+145/−100 lines, 10 filesdep +mtl
Dependencies added: mtl
Files
- src/Yam/App.hs +6/−6
- src/Yam/App/Context.hs +13/−7
- src/Yam/Event.hs +2/−2
- src/Yam/Import.hs +24/−0
- src/Yam/Logger.hs +60/−22
- src/Yam/Logger/MonadLogger.hs +0/−23
- src/Yam/Logger/WaiLogger.hs +0/−13
- src/Yam/Prop.hs +33/−16
- src/Yam/Transaction.hs +3/−6
- yam-app.cabal +4/−5
src/Yam/App.hs view
@@ -45,7 +45,7 @@ runAppM :: (Monad m) => YamContext -> AppM m a -> m a runAppM = flip runReaderT -instance MonadIO m => HasYamContext (AppM m) where+instance (MonadIO m, MonadThrow m) => HasYamContext (AppM m) where yamContext = ask defaultContext :: IO YamContext@@ -98,7 +98,7 @@ keyLogger :: Text keyLogger = "Extension.Logger" -instance MonadIO m => MonadLogger (AppM m) where+instance (MonadIO m, MonadThrow m) => MonadYamLogger (AppM m) where loggerConfig = do context <- yamContext getExtensionOrDefault (defLogger context) keyLogger@@ -107,7 +107,7 @@ keyProp :: Text keyProp = "Extension.Prop" -instance MonadIO m => MonadProp (AppM m) where+instance (MonadIO m, MonadThrow m) => MonadProp (AppM m) where propertySource = requireExtension keyProp evalProp :: FromJSON a => YamContext -> Text -> IO (Maybe a)@@ -131,13 +131,13 @@ keyEvent :: Text keyEvent = "Extension.Event." -instance MonadIO m => MonadEvent (AppM m) where+instance (MonadIO m, MonadThrow 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 :: (MonadIO m, MonadThrow 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' :: (MonadIO m, MonadThrow m, Event e) => Proxy e -> Maybe Text -> (e -> AppM IO ()) -> AppM m () registerEventHandler' p hname h = do hs <- eventHandler p context <- ask
src/Yam/App/Context.hs view
@@ -10,6 +10,7 @@ , lockExtenstion , emptyContext , cleanContext+ , YamContextException ) where import Yam.Import@@ -28,7 +29,7 @@ emptyContext :: IO YamContext emptyContext = YamContext <$> stdoutLogger <*> M.empty -class MonadIO m => HasYamContext m where+class (MonadIO m, MonadThrow m) => HasYamContext m where yamContext :: m YamContext extensionLockKey :: Text@@ -37,9 +38,14 @@ extension :: HasYamContext m => m YamExtension extension = extensions <$> yamContext +data YamContextException = ExtensionNotFound Text+ | ExtensionHasFreezed+ deriving Show+instance Exception YamContextException+ 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"+ where get Nothing = throwM $ ExtensionNotFound key get (Just r) = return r getExtension :: (HasYamContext m, Typeable a) => Text -> m (Maybe a)@@ -48,7 +54,7 @@ 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 :: (MonadYamLogger m, HasYamContext m, Typeable a) => Text -> a -> m () setExtension key a = do when (extensionLockKey /= key) checkLock@@ -58,14 +64,14 @@ checkLock :: HasYamContext m => m () checkLock = getExtensionOrDefault False extensionLockKey >>= go- where go True = error "Extension has freezed, cannot modify now"+ where go True = throwM ExtensionHasFreezed go _ = return () -lockExtenstion :: (MonadLogger m, HasYamContext m) => m ()+lockExtenstion :: (MonadYamLogger m, HasYamContext m) => m () lockExtenstion = setExtension extensionLockKey True -unlockExtenstion :: (MonadLogger m, HasYamContext m) => m ()+unlockExtenstion :: (MonadYamLogger m, HasYamContext m) => m () unlockExtenstion = setExtension extensionLockKey False -cleanContext :: (MonadLogger m, HasYamContext m) => m () -> m ()+cleanContext :: (MonadYamLogger m, HasYamContext m) => m () -> m () cleanContext action = unlockExtenstion >> action
src/Yam/Event.hs view
@@ -19,10 +19,10 @@ eventKey :: Proxy e -> String eventKey = show . typeRep -thenNotify :: (Event e, MonadLogger m, MonadMask m, MonadEvent m) => m a -> e -> m a+thenNotify :: (Event e, MonadYamLogger 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 ()+ let printStack :: (Event e, MonadYamLogger m) => e -> SomeException -> m () printStack e x = do errorLn $ "Event " <> encodeToText e <> " Failed!" errorLn $ "Exception: " <> showText x
src/Yam/Import.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+ module Yam.Import( Text , pack@@ -20,6 +23,7 @@ , mapMaybe , catMaybes , selectMaybe+ , mergeMaybe , isNothing , isJust , finally@@ -27,6 +31,7 @@ , MonadThrow , MonadCatch , catchAll+ , Yam.Import.throwM , runReaderT , ReaderT , ask@@ -43,9 +48,11 @@ , decode , Default(..) , MonadBaseControl+ , Exception ) where import Control.Concurrent+import Control.Exception (Exception (..)) import Control.Monad import Control.Monad.Catch import Control.Monad.IO.Class (MonadIO, liftIO)@@ -53,6 +60,7 @@ import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT) import Data.Aeson+import Data.Aeson.Types import Data.Default import Data.Maybe import Data.Monoid ((<>))@@ -65,8 +73,24 @@ import Data.Time.Format (defaultTimeLocale, formatTime) import Data.Time.LocalTime (utcToLocalZonedTime) import GHC.Generics+import GHC.Stack import System.Random (newStdGen, randoms) +instance MonadThrow Parser where+ throwM e = fail $ show e++mergeMaybe :: Monoid a => Maybe a -> Maybe a -> Maybe a+mergeMaybe (Just a) (Just b) = Just $ a <> b+mergeMaybe Nothing b = b+mergeMaybe a _ = a++data StackException = forall e. Exception e => StackException e CallStack+instance Show StackException where+ show (StackException e call) = show e <> "\n" <> prettyCallStack call+instance Exception StackException++throwM :: (Exception e, HasCallStack, MonadThrow m) => e -> m a+throwM e = Control.Monad.Catch.throwM $ StackException e callStack millisToUTC :: Integer -> UTCTime millisToUTC t = posixSecondsToUTCTime $ fromInteger t / 1000
src/Yam/Logger.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}@@ -5,7 +6,7 @@ module Yam.Logger( LogRank(..) , LoggerConfig(..)- , MonadLogger(..)+ , MonadYamLogger(..) , logL , logLn , errorLn@@ -16,13 +17,19 @@ , stdoutLogger , fileLogger , withLoggerName+ , toMonadLogger+ , toWaiLogger+ , runLoggingT ) where import Yam.Import import qualified Control.Concurrent.Map as M import Control.Monad.Catch (bracket_)+import Control.Monad.Logger import Control.Monad.Trans.Reader+import GHC.Stack+import Network.Wai.Logger import System.Log.FastLogger data LogRank = TRACE@@ -51,50 +58,63 @@ , name :: LoggerCache } -class (MonadIO m) => MonadLogger m where+class (MonadIO m) => MonadYamLogger m where loggerConfig :: m LoggerConfig withLoggerConfig :: LoggerConfig -> m a -> m a -instance (MonadIO m) => MonadLogger (ReaderT LoggerConfig m) where+instance (MonadIO m) => MonadYamLogger (ReaderT LoggerConfig m) where loggerConfig = ask withLoggerConfig = withReaderT . const -logL :: (MonadLogger m) => forall msg . (ToLogStr msg) => LogRank -> msg -> m ()-logL r msg = do+logL :: (MonadYamLogger m, HasCallStack) => forall msg . (ToLogStr msg) => LogRank -> msg -> m ()+logL = logL' callStack++logL' :: (MonadYamLogger m) => forall msg . (ToLogStr msg) => CallStack -> LogRank -> msg -> m ()+logL' callStack 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)+ logger conf (cs now) (cs <$> mayName `mergeMaybe` getName (getCallStack callStack)) r (toLogStr msg)+ where getName [] = Nothing+ getName ((_,loc):_) = Just $ cs $ srcLocModule loc -fetchName :: MonadLogger m => m (Maybe Text)+fetchName :: MonadYamLogger m => m (Maybe Text) fetchName = do conf <- loggerConfig liftIO $ do threadId <- myThreadId M.lookup threadId $ name conf -setName :: MonadLogger m => Maybe Text -> m ()+setName :: MonadYamLogger 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"+logLn :: (MonadYamLogger m, HasCallStack) => LogRank -> Text -> m ()+logLn = logLn' callStack -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+logLn' :: (MonadYamLogger m) => CallStack -> LogRank -> Text -> m ()+logLn' call l msg = logL' call l $ msg <> "\n" +traceLn :: (MonadYamLogger m, HasCallStack) => Text -> m ()+traceLn = logLn' callStack TRACE+{-# INLINE traceLn #-}+debugLn :: (MonadYamLogger m, HasCallStack) => Text -> m ()+debugLn = logLn' callStack DEBUG+{-# INLINE debugLn #-}+infoLn :: (MonadYamLogger m, HasCallStack) => Text -> m ()+infoLn = logLn' callStack INFO+{-# INLINE infoLn #-}+warnLn :: (MonadYamLogger m, HasCallStack) => Text -> m ()+warnLn = logLn' callStack WARN+{-# INLINE warnLn #-}+errorLn :: (MonadYamLogger m, HasCallStack) => Text -> m ()+errorLn = logLn' callStack ERROR+{-# INLINE errorLn #-}+ defaultLoggerConfig :: LoggerFunc -> IO LoggerConfig defaultLoggerConfig func = do nm <- M.empty@@ -122,7 +142,7 @@ <> " - " logger $ toLogStr name <> msg -withLoggerName :: (MonadLogger m, MonadMask m) => Text -> m a -> m a+withLoggerName :: (MonadYamLogger m, MonadMask m) => Text -> m a -> m a withLoggerName nm action = do mayName <- fetchName let mayName' = Just $ merge nm mayName@@ -130,9 +150,27 @@ where merge n (Just v) = v <> "." <> n merge n _ = n -withLogger :: (MonadLogger m) => (LoggerConfig -> LoggerConfig) -> m a -> m a+withLogger :: (MonadYamLogger m) => (LoggerConfig -> LoggerConfig) -> m a -> m a withLogger modify action = do conf <- loggerConfig withLoggerConfig (modify conf) action +type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO ()++toMonadLogger :: (MonadYamLogger m) => m LogFunc+toMonadLogger = mkLogger <$> loggerConfig+ where toRank LevelDebug = DEBUG+ toRank LevelInfo = INFO+ toRank LevelWarn = WARN+ toRank LevelError = ERROR+ toRank _ = INFO+ mkLogger :: HasCallStack => LoggerConfig -> LogFunc+ mkLogger context _ name level msg = runReaderT (withLoggerName name $ logL' callStack (toRank level) (msg <> "\n")) context++toWaiLogger :: (MonadYamLogger m) => m ApacheLogger+toWaiLogger = do mkLogger <- flip runReaderT <$> loggerConfig+ liftIO $ apacheLogger+ <$> initLogger FromFallback (LogCallback (mkLogger . go) $ return ()) (return "")+ where go :: HasCallStack => LogStr -> ReaderT LoggerConfig IO ()+ go = logL' callStack INFO
− src/Yam/Logger/MonadLogger.hs
@@ -1,23 +0,0 @@-{-# 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
@@ -1,13 +0,0 @@-{-# 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
@@ -16,31 +16,48 @@ , loadCommandLineArgs , mergePropertySource , runProp+ , parseProp ) 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 Control.Monad.Except (ExceptT (..), runExceptT)+import Data.Aeson (Result (..), fromJSON)+import Data.Aeson.Types+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)+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+class (Monad m, MonadThrow m) => MonadProp m where propertySource :: m PropertySource type ValueProperty = ReaderT PropertySource -instance (Monad m) => MonadProp (ValueProperty m) where+instance (Monad m, MonadThrow m) => MonadProp (ValueProperty m) where propertySource = ask +data PropException = ParseFailed Text+ | KeyNotFound Text+ | FileNotFound FilePath+ | FileLoadFailed FilePath+ deriving Show+instance Exception PropException++parseProp :: Value -> ValueProperty (ExceptT PropException Parser) a -> Parser a+parseProp v ma = do+ eab <- runExceptT $ runProp v ma+ case eab of+ Left e -> fail $ show e+ Right v -> return v+ runProp :: (Monad m) => Value -> ValueProperty m a -> m a runProp v ma = runReaderT ma ("NO_NAME", v) @@ -48,37 +65,37 @@ 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+requiredProp key = getProp key >>= maybe (throwM $ KeyNotFound key) 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)+ where go :: (FromJSON a, Monad m, MonadThrow 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 :: (FromJSON a, Monad m, MonadThrow m) => Text -> Value -> m (Maybe a) to _ Null = return Nothing to s v = case fromJSON v of- Error e -> error e+ Error e -> throwM $ ParseFailed $ cs 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 :: (MonadIO m, MonadThrow 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)+ Just . (cs file,) <$> (liftIO (decodeFile file) >>= maybe (throwM $ FileLoadFailed file) return) else return Nothing else return Nothing -loadYaml :: (MonadIO m) => FilePath -> m PropertySource-loadYaml file = tryLoadYaml file >>= maybe (error $ file <> " not found") return+loadYaml :: (MonadIO m, MonadThrow m) => FilePath -> m PropertySource+loadYaml file = tryLoadYaml file >>= maybe (throwM $ FileNotFound file) return loadEnv :: (MonadIO m) => m PropertySource loadEnv = do
src/Yam/Transaction.hs view
@@ -1,6 +1,4 @@ {-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}@@ -27,7 +25,6 @@ import Yam.Import import Yam.Logger-import Yam.Logger.MonadLogger import Yam.Prop import Control.Monad.Trans.Control (MonadBaseControl)@@ -54,7 +51,7 @@ } deriving Show instance FromJSON DataSource where- parseJSON v = runProp v $ do+ parseJSON v = parseProp v $ do dsDt <- getPropOrDefault (dbtype def) "type" dsCn <- getPropOrDefault (conn def) "conn" dsTh <- getPropOrDefault (thread def) "thread"@@ -65,7 +62,7 @@ instance Default DataSource where def = DataSource "sqlite" ":memory:" 10 True Nothing -class (MonadIO m, MonadBaseControl IO m, MonadLogger m, MonadMask m) => MonadTransaction m where+class (MonadIO m, MonadBaseControl IO m, MonadYamLogger m, MonadMask m) => MonadTransaction m where connectionPool :: m TransactionPool setConnectionPool :: TransactionPool -> Maybe TransactionPool -> m () secondaryPool :: m (Maybe TransactionPool)@@ -81,7 +78,7 @@ 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+ getConnector map logger ds $ \p -> case ds2 of Nothing -> setConnectionPool p Nothing >> action Just s2 -> getConnector map logger s2 $ \v -> setConnectionPool p (Just v) >> action
yam-app.cabal view
@@ -1,8 +1,8 @@ name: yam-app-version: 0.1.5+version: 0.1.6 synopsis: Yam App description: Base Module for Yam-homepage: https://github.com/leptonyu/yam/yam-app#readme+homepage: https://github.com/leptonyu/yam/tree/master/yam-app#readme license: BSD3 license-file: LICENSE author: Daniel YU@@ -19,8 +19,6 @@ , Yam.Import , Yam.Transaction , Yam.Transaction.Sqlite- , Yam.Logger.MonadLogger- , Yam.Logger.WaiLogger , Yam.Event , Yam.Logger , Yam.Prop@@ -48,8 +46,9 @@ , persistent-sqlite , conduit , resourcet+ , mtl default-language: Haskell2010 source-repository head type: git- location: https://github.com/leptonyu/yam-app+ location: https://github.com/leptonyu/yam