diff --git a/src/Yam/Internal.hs b/src/Yam/Internal.hs --- a/src/Yam/Internal.hs +++ b/src/Yam/Internal.hs @@ -6,6 +6,7 @@ , start ) where +import Data.Salak import qualified Data.Vault.Lazy as L import Network.Wai.Handler.Warp import Servant @@ -20,7 +21,7 @@ :: forall api. (HasSwagger api, HasServer api '[Env]) => AppConfig -> SwaggerConfig - -> LogConfig + -> IO LogConfig -> Bool -> Version -> [AppMiddleware] @@ -69,8 +70,11 @@ -> Proxy api -> ServerT api App -> IO () -start p = startYam - (p .>> "yam.application") - (p .>> "yam.swagger" ) - (p .>> "yam.logging" ) - (p .?> "yam.middleware.default.enabled" .|= True) +start p a b c d = do + (lc,_) <- runLoader p $ (,) <$> load "yam.logging" <*> askSetProperties + startYam + (p .>> "yam.application") + (p .>> "yam.swagger" ) + lc + (p .?> "yam.middleware.default.enabled" .|= True) + a b c d diff --git a/src/Yam/Logger.hs b/src/Yam/Logger.hs --- a/src/Yam/Logger.hs +++ b/src/Yam/Logger.hs @@ -10,7 +10,9 @@ , LogConfig(..) ) where +import Data.Salak import qualified Data.Text as T +import qualified Data.Vault.Lazy as L import System.IO.Unsafe (unsafePerformIO) import System.Log.FastLogger import Yam.Types.Env @@ -55,9 +57,10 @@ <*> p .?> "max-history" .?= rotateHistory def <*> p .?> "level" .?= level def -newLogger :: Text -> LogConfig -> IO (LogFunc, IO ()) -newLogger name LogConfig{..} = do - tc <- newTimeCache "%Y-%m-%d %T" +newLogger :: Text -> IO LogConfig -> IO (LogFunc, IO ()) +newLogger name lc = do + LogConfig{..} <- lc + tc <- newTimeCache "%Y-%m-%d %T" let ft = if file == "" then LogStdout $ fromIntegral bufferSize else LogFile (FileLogSpec file (toInteger maxSize) (fromIntegral rotateHistory)) $ fromIntegral bufferSize @@ -65,22 +68,24 @@ (l,close) <- newTimedFastLogger tc ft return (toLogger ln l, close) where - toLogger xn f Loc{..} _ ll s = when (level <= ll) $ f $ \t -> - let locate = if ll /= LevelError then "" else " @" <> toLogStr loc_filename <> toLogStr (show loc_start) - in toLogStr t <> " " <> toStr ll <> xn <> toLogStr loc_module <> locate <> " - " <> s <> "\n" + toLogger xn f Loc{..} _ ll s = do + c <- lc + when (level c <= ll) $ f $ \t -> + let locate = if ll /= LevelError then "" else " @" <> toLogStr loc_filename <> toLogStr (show loc_start) + in toLogStr t <> " " <> toStr ll <> xn <> toLogStr loc_module <> locate <> " - " <> s <> "\n" -withLogger :: Text -> LogConfig -> LoggingT IO a -> IO a +withLogger :: Text -> IO LogConfig -> LoggingT IO a -> IO a withLogger n lc action = bracket (newLogger n lc) snd $ \(f,_) -> runLoggingT action f addTrace :: LogFunc -> Text -> LogFunc addTrace f tid a b c d = let p = "[" <> toLogStr tid <> "] " in f a b c (p <> d) {-# NOINLINE loggerKey #-} -loggerKey :: Key LogFunc +loggerKey :: L.Key LogFunc loggerKey = unsafePerformIO newKey {-# NOINLINE extensionLogKey #-} -extensionLogKey :: Key Text +extensionLogKey :: L.Key Text extensionLogKey = unsafePerformIO newKey setExtendLog :: (Text -> Text) -> Env -> Env diff --git a/src/Yam/Middleware.hs b/src/Yam/Middleware.hs --- a/src/Yam/Middleware.hs +++ b/src/Yam/Middleware.hs @@ -4,6 +4,7 @@ AppMiddleware(..) , simpleAppMiddleware , simpleWebMiddleware + , simplePoolMiddleware , runMiddleware ) where @@ -30,7 +31,7 @@ simpleAppMiddleware (enabled,amname) k v = v `seq` if enabled then AppMiddleware $ \e f -> do - logInfoCS ?callStack $ amname <> " enabled" + logInfoCS ?callStack $ "app:" <> amname <> " enabled" f (setAttr k v e, id) else mempty @@ -38,8 +39,17 @@ simpleWebMiddleware (enabled,amname) m = if enabled then AppMiddleware $ \e f -> do - logInfoCS ?callStack $ amname <> " enabled" + logInfoCS ?callStack $ "web:" <> amname <> " enabled" f (e,m) + else mempty + +simplePoolMiddleware :: HasCallStack => (Bool, Text) -> Key a -> App a -> (a -> App ()) -> AppMiddleware +simplePoolMiddleware (enabled, amname) key open close = + if enabled + then AppMiddleware $ \e f -> do + logInfoCS ?callStack $ "pool:" <> amname <> " enabled" + lf <- askLoggerIO + liftIO $ bracket (runApp e open) (runApp e . close) $ \a -> runLoggingT (f (setAttr key a e, id)) lf else mempty runMiddleware :: MonadIO m => AppMiddleware -> App a -> m () diff --git a/src/Yam/Middleware/Client.hs b/src/Yam/Middleware/Client.hs --- a/src/Yam/Middleware/Client.hs +++ b/src/Yam/Middleware/Client.hs @@ -7,6 +7,8 @@ , BaseUrl ) where +import Data.Salak +import qualified Data.Vault.Lazy as L import Network.HTTP.Client import Servant.Client import System.IO.Unsafe (unsafePerformIO) @@ -25,7 +27,7 @@ <$> p .?> "enabled" .?= enabled def {-# NOINLINE managerKey #-} -managerKey :: Key Manager +managerKey :: L.Key Manager managerKey = unsafePerformIO newKey clientMiddleware :: ClientConfig -> AppMiddleware diff --git a/src/Yam/Middleware/Trace.hs b/src/Yam/Middleware/Trace.hs --- a/src/Yam/Middleware/Trace.hs +++ b/src/Yam/Middleware/Trace.hs @@ -12,6 +12,7 @@ import qualified Data.HashMap.Lazy as HM import Data.Opentracing +import Data.Salak import qualified Data.Text as T import qualified Data.Vault.Lazy as L import System.IO.Unsafe (unsafePerformIO) @@ -46,11 +47,11 @@ notifier _ _ = return () {-# NOINLINE spanContextKey #-} -spanContextKey :: Key SpanContext +spanContextKey :: L.Key SpanContext spanContextKey = unsafePerformIO newKey {-# NOINLINE spanKey #-} -spanKey :: Key Span +spanKey :: L.Key Span spanKey = unsafePerformIO newKey instance MonadTracer App where @@ -82,11 +83,11 @@ parseSpan :: RequestHeaders -> Env -> IO Env parseSpan headers env = let sc = fromMaybe (SpanContext "" HM.empty) $ getAttr spanContextKey env - in case lookup hTraceId headers of + in case Prelude.lookup hTraceId headers of Just tid -> let sc' = sc { traceId = tid } in return $ env & setAttr spanContextKey sc' - & go (fromMaybe (traceId sc') $ lookup hSpanId headers) sc' + & go (fromMaybe (traceId sc') $ Prelude.lookup hSpanId headers) sc' _ -> do c <- newContext return $ setAttr spanContextKey c env diff --git a/src/Yam/Swagger.hs b/src/Yam/Swagger.hs --- a/src/Yam/Swagger.hs +++ b/src/Yam/Swagger.hs @@ -6,6 +6,7 @@ import Control.Lens hiding (Context, Empty, allOf, (.=)) import Data.Reflection +import Data.Salak import Data.Swagger hiding (name, port) import qualified Data.Swagger as S import GHC.TypeLits diff --git a/src/Yam/Types.hs b/src/Yam/Types.hs --- a/src/Yam/Types.hs +++ b/src/Yam/Types.hs @@ -11,6 +11,8 @@ , module Yam.Types.Prelude ) where +import Data.Menshen +import Servant (err400) import Yam.Logger import Yam.Types.Env import Yam.Types.Prelude @@ -21,6 +23,9 @@ , Monad , MonadIO , MonadReader Env) + +instance HasValid App where + invalid a = throwS err400 (pack $ toI18n a) runApp :: MonadIO m => Env -> App a -> m a runApp e a = liftIO $ runReaderT (runApp' a) e diff --git a/src/Yam/Types/Env.hs b/src/Yam/Types/Env.hs --- a/src/Yam/Types/Env.hs +++ b/src/Yam/Types/Env.hs @@ -7,6 +7,7 @@ , setAttr ) where +import Data.Salak import qualified Data.Vault.Lazy as L import Yam.Types.Prelude @@ -34,13 +35,13 @@ instance Default Env where def = Env L.empty Nothing def -getAttr :: Key a -> Env -> Maybe a +getAttr :: L.Key a -> Env -> Maybe a getAttr k Env{..} = (reqAttributes >>= L.lookup k) <|> L.lookup k attributes -reqAttr :: Default a => Key a -> Env -> a +reqAttr :: Default a => L.Key a -> Env -> a reqAttr k = fromMaybe def . getAttr k -setAttr :: Key a -> a -> Env -> Env +setAttr :: L.Key a -> a -> Env -> Env setAttr k v Env{..} = case reqAttributes of Just av -> Env attributes (Just $ L.insert k v av) application _ -> Env (L.insert k v attributes) reqAttributes application diff --git a/src/Yam/Types/Prelude.hs b/src/Yam/Types/Prelude.hs --- a/src/Yam/Types/Prelude.hs +++ b/src/Yam/Types/Prelude.hs @@ -30,7 +30,6 @@ , module Data.Word , module Data.Text.Encoding , module Data.Function - , module Data.Salak , module Data.Version , module Control.Applicative , module Control.Monad @@ -47,6 +46,7 @@ import Control.Monad.IO.Unlift import Control.Monad.Logger.CallStack import Control.Monad.Reader +import Data.Aeson import qualified Data.Binary as B import Data.ByteString (ByteString) import qualified Data.ByteString.Base16.Lazy as B16 @@ -56,14 +56,6 @@ import Data.Maybe import Data.Monoid ((<>)) import Data.Proxy -import Data.Salak - ( FromProperties (..) - , Properties - , Property (..) - , Return - , defaultPropertiesWithFile - ) -import Data.Salak ((.>>), (.?=), (.?>), (.|=)) import Data.Text (Text, pack) import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Vault.Lazy (Key, Vault, newKey) @@ -92,11 +84,17 @@ showText :: Show a => a -> Text showText = pack . show +data WebErrResult = WebErrResult + { message :: Text + } + +instance ToJSON WebErrResult where + toJSON WebErrResult{..} = object [ "message" .= message ] + throwS :: (HasCallStack, MonadIO m, MonadLogger m) => ServantErr -> Text -> m a throwS e msg = do logErrorCS ?callStack msg - liftIO $ throw e - + liftIO $ throw e { errBody = encode $ WebErrResult msg} whenException :: SomeException -> Response whenException e = responseServantErr $ fromMaybe err400 (fromException e :: Maybe ServantErr) diff --git a/yam.cabal b/yam.cabal --- a/yam.cabal +++ b/yam.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 name: yam -version: 0.5.11 +version: 0.5.12 license: BSD3 license-file: LICENSE copyright: (c) 2018 Daniel YU @@ -49,6 +49,7 @@ TypeSynonymInstances ViewPatterns ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures build-depends: + aeson >=1.4.2.0 && <1.5, base >=4.9 && <5, base16-bytestring >=0.1.1.6 && <0.2, binary >=0.8.6.0 && <0.9, @@ -58,11 +59,12 @@ http-client >=0.5.14 && <0.6, http-types >=0.12.2 && <0.13, lens ==4.17.*, + menshen >=0.0.1 && <0.1, monad-logger >=0.3.30 && <0.4, mtl >=2.2.2 && <2.3, mwc-random >=0.14.0.0 && <0.15, reflection >=2.1.4 && <2.2, - salak >=0.1.6 && <0.3, + salak >=0.1.8 && <0.3, scientific >=0.3.6.2 && <0.4, servant-client ==0.15.*, servant-server ==0.15.*, @@ -74,8 +76,8 @@ unordered-containers >=0.2.9.0 && <0.3, vault >=0.3.1.2 && <0.4, vector >=0.12.0.2 && <0.13, - wai >=3.2.1.2 && <3.3, - warp >=3.2.25 && <3.3 + wai >=3.2.2 && <3.3, + warp >=3.2.26 && <3.3 test-suite spec type: exitcode-stdio-1.0 @@ -115,6 +117,7 @@ ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures build-depends: QuickCheck >=2.12.6.1 && <2.13, + aeson >=1.4.2.0 && <1.5, base >=4.9 && <5, base16-bytestring >=0.1.1.6 && <0.2, binary >=0.8.6.0 && <0.9, @@ -125,11 +128,12 @@ http-client >=0.5.14 && <0.6, http-types >=0.12.2 && <0.13, lens ==4.17.*, + menshen >=0.0.1 && <0.1, monad-logger >=0.3.30 && <0.4, mtl >=2.2.2 && <2.3, mwc-random >=0.14.0.0 && <0.15, reflection >=2.1.4 && <2.2, - salak >=0.1.6 && <0.3, + salak >=0.1.8 && <0.3, scientific >=0.3.6.2 && <0.4, servant-client ==0.15.*, servant-server ==0.15.*, @@ -141,5 +145,5 @@ unordered-containers >=0.2.9.0 && <0.3, vault >=0.3.1.2 && <0.4, vector >=0.12.0.2 && <0.13, - wai >=3.2.1.2 && <3.3, - warp >=3.2.25 && <3.3 + wai >=3.2.2 && <3.3, + warp >=3.2.26 && <3.3