yam 0.5.11 → 0.5.12
raw patch · 10 files changed
+74/−43 lines, 10 filesdep +aesondep +menshendep ~salakdep ~waidep ~warp
Dependencies added: aeson, menshen
Dependency ranges changed: salak, wai, warp
Files
- src/Yam/Internal.hs +10/−6
- src/Yam/Logger.hs +14/−9
- src/Yam/Middleware.hs +12/−2
- src/Yam/Middleware/Client.hs +3/−1
- src/Yam/Middleware/Trace.hs +5/−4
- src/Yam/Swagger.hs +1/−0
- src/Yam/Types.hs +5/−0
- src/Yam/Types/Env.hs +4/−3
- src/Yam/Types/Prelude.hs +9/−11
- yam.cabal +11/−7
src/Yam/Internal.hs view
@@ -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
src/Yam/Logger.hs view
@@ -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
src/Yam/Middleware.hs view
@@ -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 ()
src/Yam/Middleware/Client.hs view
@@ -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
src/Yam/Middleware/Trace.hs view
@@ -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
src/Yam/Swagger.hs view
@@ -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
src/Yam/Types.hs view
@@ -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
src/Yam/Types/Env.hs view
@@ -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
src/Yam/Types/Prelude.hs view
@@ -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)
yam.cabal view
@@ -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