yam 0.5.6 → 0.5.7
raw patch · 12 files changed
+167/−64 lines, 12 filesdep +http-clientdep +servant-clientdep +wai-extradep −time
Dependencies added: http-client, servant-client, wai-extra
Dependencies removed: time
Files
- src/Data/Opentracing/Tracer.hs +3/−2
- src/Yam.hs +2/−0
- src/Yam/Internal.hs +7/−11
- src/Yam/Logger.hs +7/−13
- src/Yam/Middleware.hs +9/−3
- src/Yam/Middleware/Client.hs +45/−0
- src/Yam/Middleware/Default.hs +12/−0
- src/Yam/Middleware/Trace.hs +6/−3
- src/Yam/Types.hs +6/−2
- src/Yam/Types/Env.hs +7/−5
- src/Yam/Types/Prelude.hs +52/−22
- yam.cabal +11/−3
src/Data/Opentracing/Tracer.hs view
@@ -17,7 +17,7 @@ import Control.Monad.IO.Class import qualified Data.HashMap.Lazy as HM import Data.Opentracing.Types-import Data.Time.Clock.POSIX+-- import Data.Time.Clock.POSIX import Yam.Types.Prelude type SpanName = Text@@ -35,7 +35,8 @@ getNow :: MonadIO m => m Int-getNow = liftIO $ round . (* 1000) <$> getPOSIXTime+-- getNow = liftIO $ round . (* 1000) <$> getPOSIXTime+getNow = return 0 newSpan' :: MonadTracer m => SpanName -> SpanContext -> [SpanReference] -> m Span newSpan' name context references = do
src/Yam.hs view
@@ -5,6 +5,7 @@ , module Yam.Swagger , module Yam.Middleware , module Yam.Middleware.Auth+ , module Yam.Middleware.Client , module Yam.Middleware.Trace ) where @@ -12,6 +13,7 @@ import Yam.Logger import Yam.Middleware import Yam.Middleware.Auth+import Yam.Middleware.Client import Yam.Middleware.Trace import Yam.Swagger import Yam.Types
src/Yam/Internal.hs view
@@ -6,37 +6,32 @@ , start ) where -import qualified Data.ByteString.Lazy.Char8 as B-import qualified Data.Vault.Lazy as L+import qualified Data.Vault.Lazy as L import Network.Wai.Handler.Warp import Servant-import Servant.Server.Internal.ServantErr import Servant.Swagger import Yam.Logger import Yam.Middleware-import Yam.Middleware.Trace+import Yam.Middleware.Default import Yam.Swagger import Yam.Types -whenException :: SomeException -> Response-whenException e = responseServantErr $ fromMaybe err400 { errBody = B.pack $ show e } (fromException e :: Maybe ServantErr)- startYam :: forall api. (HasSwagger api, HasServer api '[Env]) => AppConfig -> SwaggerConfig -> LogConfig- -> TraceConfig+ -> Bool -> Version -> [AppMiddleware] -> Proxy api -> ServerT api App -> IO ()-startYam ac@AppConfig{..} sw@SwaggerConfig{..} logConfig traceConfig vs middlewares proxy server+startYam ac@AppConfig{..} sw@SwaggerConfig{..} logConfig enableDefaultMiddleware vs middlewares proxy server = withLogger name logConfig $ do logInfo $ "Start Service [" <> name <> "] ..." logger <- askLoggerIO- let act = runAM $ foldr1 (<>) (traceMiddleware traceConfig : middlewares)+ let act = runAM $ foldr1 (<>) ((if enableDefaultMiddleware then defaultMiddleware else []) <> middlewares) act (putLogger logger $ Env L.empty Nothing ac) $ \(env, middleware) -> do let cxt = env :. EmptyContext pCxt = Proxy :: Proxy '[Env]@@ -47,6 +42,7 @@ & setPort port & setOnException (\_ _ -> return ()) & setOnExceptionResponse whenException+ & setSlowlorisSize slowlorisSize when enabled $ logInfo $ "Swagger enabled: http://localhost:" <> portText <> "/" <> pack urlDir logInfo $ "Servant started on port(s): " <> portText@@ -77,4 +73,4 @@ (p .>> "yam.application") (p .>> "yam.swagger" ) (p .>> "yam.logging" )- (p .>> "yam.trace" )+ (p .?> "yam.middleware.default.enabled" .|= True)
src/Yam/Logger.hs view
@@ -11,8 +11,6 @@ ) where import qualified Data.Text as T-import GHC.Stack-import Servant import System.IO.Unsafe (unsafePerformIO) import System.Log.FastLogger import Yam.Types.Env@@ -22,8 +20,8 @@ fromProperties = fromProperties >=> go where go :: Property -> Return LogLevel- go (PStr t) = OK (gt $ T.toLower t)- go _ = Fail "loglevel shoudbe string"+ go (PStr t) = return (gt $ T.toLower t)+ go _ = error "loglevel shoudbe string" gt "debug" = LevelDebug gt "info" = LevelInfo gt "warn" = LevelWarn@@ -63,18 +61,19 @@ let ft = if file == "" then LogStdout $ fromIntegral bufferSize else LogFile (FileLogSpec file (toInteger maxSize) (fromIntegral rotateHistory)) $ fromIntegral bufferSize+ ln = " [" <> toLogStr name <> "] " (l,close) <- newTimedFastLogger tc ft- return (toLogger l, close)+ return (toLogger ln l, close) where- toLogger f Loc{..} _ ll s = when (level <= ll) $ f $ \t ->+ 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 <> " [" <> toLogStr name <> "] " <> toLogStr loc_module <> locate <> " - " <> s <> "\n"+ in toLogStr t <> " " <> toStr ll <> xn <> toLogStr loc_module <> locate <> " - " <> s <> "\n" withLogger :: Text -> 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 = f a b c ("[" <> toLogStr tid <> "] " <> d)+addTrace f tid a b c d = let p = "[" <> toLogStr tid <> "] " in f a b c (p <> d) {-# NOINLINE loggerKey #-} loggerKey :: Key LogFunc@@ -98,8 +97,3 @@ nlf x (Just t) = addTrace x t nlf x _ = x in maybe (\_ _ _ _ -> return ()) (`nlf` trace) logger--throwS :: (HasCallStack, MonadIO m, MonadLogger m) => ServantErr -> Text -> m a-throwS e msg = do- logErrorCS ?callStack msg- liftIO $ throw e
src/Yam/Middleware.hs view
@@ -3,10 +3,11 @@ AppMiddleware(..) , simpleAppMiddleware , simpleWebMiddleware+ , runMiddleware ) where -import Yam.Types.Env-import Yam.Types.Prelude+import Yam.Logger+import Yam.Types -- | Application Middleware newtype AppMiddleware = AppMiddleware {runAM :: Env -> ((Env, Middleware)-> LoggingT IO ()) -> LoggingT IO ()}@@ -20,7 +21,7 @@ -- | Simple AppMiddleware simpleAppMiddleware :: HasCallStack => (Bool, Text) -> Key a -> a -> AppMiddleware simpleAppMiddleware (enabled,amname) k v =- if enabled+ v `seq` if enabled then AppMiddleware $ \e f -> do logInfoCS ?callStack $ amname <> " enabled" f (setAttr k v e, id)@@ -33,3 +34,8 @@ logInfoCS ?callStack $ amname <> " enabled" f (e,m) else mempty++runMiddleware :: MonadIO m => AppMiddleware -> App a -> m ()+runMiddleware (AppMiddleware f) a = liftIO $ withLogger "test" def $ do+ lf <- askLoggerIO+ f (putLogger lf def) $ \(e,_) -> liftIO $ void $ runApp e a
+ src/Yam/Middleware/Client.hs view
@@ -0,0 +1,45 @@+module Yam.Middleware.Client(+ ClientConfig(..)+ , runClient+ , clientMiddleware+ , parseBaseUrl+ , BaseUrl+ ) where++import Network.HTTP.Client+import Servant.Client+import System.IO.Unsafe (unsafePerformIO)+import Yam.Middleware+import Yam.Types++data ClientConfig = ClientConfig+ { enabled :: Bool+ } deriving (Eq, Show)++instance Default ClientConfig where+ def = ClientConfig True++instance FromProperties ClientConfig where+ fromProperties p = ClientConfig+ <$> p .?> "enabled" .?= enabled def++{-# NOINLINE managerKey #-}+managerKey :: Key Manager+managerKey = unsafePerformIO newKey++clientMiddleware :: ClientConfig -> AppMiddleware+clientMiddleware ClientConfig{..} = AppMiddleware $ \e f -> do+ mg <- liftIO $ newManager defaultManagerSettings { managerModifyRequest = go e}+ f (setAttr managerKey mg e, id)+ where+ go env req = do+ runApp env $ logDebug $ showText req+ return req++runClient :: ClientM a -> BaseUrl -> App a+runClient action url = do+ mg <- requireAttr managerKey+ c <- liftIO $ runClientM action $ mkClientEnv mg url+ case c of+ Left e -> throw e+ Right a -> return a
+ src/Yam/Middleware/Default.hs view
@@ -0,0 +1,12 @@+module Yam.Middleware.Default where++import Yam.Middleware+import Yam.Middleware.Client+import Yam.Middleware.Trace+import Yam.Types.Prelude++defaultMiddleware :: [AppMiddleware]+defaultMiddleware =+ [ traceMiddleware def+ , clientMiddleware def+ ]
src/Yam/Middleware/Trace.hs view
@@ -31,7 +31,7 @@ fromProperties = fromProperties >=> go where go :: Property -> Return TraceNotifyType- go _ = OK NoTracer+ go _ = return NoTracer instance FromProperties TraceConfig where fromProperties p = TraceConfig@@ -108,8 +108,11 @@ tid = decodeUtf8 $ traceId <> "," <> spanId v = L.insert extensionLogKey tid (vault req) v' = L.insert spanKey s v- liftIO $ app req {vault = v'}- $ resH . mapResponseHeaders (\hs -> (hTraceId, traceId):(hSpanId, spanId):hs)+ rh' = resH . mapResponseHeaders (\hs -> (hTraceId, traceId):(hSpanId, spanId):hs)+ c e = do+ runApp env (logError $ showText e)+ rh' $ whenException e+ liftIO (app req {vault = v'} rh' `catch` c) traceMiddleware :: TraceConfig -> AppMiddleware traceMiddleware TraceConfig{..}
src/Yam/Types.hs view
@@ -2,6 +2,7 @@ -- * AppM Monad App , runApp+ , runTestApp , askApp , askAttr , withAttr@@ -21,8 +22,11 @@ , MonadIO , MonadReader Env) -runApp :: Env -> App a -> IO a-runApp e a = runReaderT (runApp' a) e+runApp :: MonadIO m => Env -> App a -> m a+runApp e a = liftIO $ runReaderT (runApp' a) e++runTestApp :: Key a -> a -> App b -> IO b+runTestApp k v a = runApp def $ withAttr k v a instance MonadUnliftIO App where withRunInIO f = do
src/Yam/Types/Env.hs view
@@ -10,17 +10,19 @@ import Yam.Types.Prelude data AppConfig = AppConfig- { name :: Text- , port :: Int+ { name :: Text+ , port :: Int+ , slowlorisSize :: Int -- Bytes } deriving (Eq, Show) instance FromProperties AppConfig where fromProperties p = AppConfig- <$> p .?> "name" .?= name def- <*> p .?> "port" .?= port def+ <$> p .?> "name" .?= name def+ <*> p .?> "port" .?= port def+ <*> p .?> "slowloris-size" .?= slowlorisSize def instance Default AppConfig where- def = AppConfig "application" 8888+ def = AppConfig "application" 8888 2048 data Env = Env { attributes :: Vault
src/Yam/Types/Prelude.hs view
@@ -1,10 +1,18 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE UndecidableInstances #-} module Yam.Types.Prelude( randomString , showText+ , throwS+ , whenException+#if MIN_VERSION_salak(0,2,1)+#else , (.>>) , (.?>) , (.?=) , (.|=)+#endif , LogFunc , Default(..) , Text@@ -17,6 +25,7 @@ , bracket , throw , try+ , catch , module Data.Proxy , module Data.Vault.Lazy , module Data.Maybe@@ -34,16 +43,16 @@ ) where import Control.Applicative-import Control.Exception hiding (Handler)+import Control.Exception hiding (Handler) import Control.Monad import Control.Monad.Except import Control.Monad.IO.Unlift import Control.Monad.Logger.CallStack import Control.Monad.Reader-import qualified Data.Binary as B-import Data.ByteString (ByteString)-import qualified Data.ByteString.Base16.Lazy as B16-import qualified Data.ByteString.Lazy as L+import qualified Data.Binary as B+import Data.ByteString (ByteString)+import qualified Data.ByteString.Base16.Lazy as B16+import qualified Data.ByteString.Lazy as L import Data.Default import Data.Function import Data.Maybe@@ -52,50 +61,63 @@ ( FromProperties (..) , Properties , Property (..)- , Return (..)+ , Return , defaultPropertiesWithFile+#if MIN_VERSION_salak(0,2,1)+ , (.>>)+ , (.?=)+ , (.?>)+ , (.|=)+#endif )-import qualified Data.Salak as S-import Data.Text (Text, pack, unpack)-import Data.Text.Encoding (decodeUtf8, encodeUtf8)-import Data.Vault.Lazy (Key, Vault, newKey)+import Data.Text (Text, pack)+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import Data.Vault.Lazy (Key, Vault, newKey) import Data.Version import Data.Word import GHC.Stack import Network.HTTP.Types import Network.Wai-import System.IO.Unsafe (unsafePerformIO)+import Servant+import Servant.Server.Internal.ServantErr+import System.IO.Unsafe (unsafePerformIO) import System.Random.MWC +#if MIN_VERSION_salak(0,2,1)+#else+import qualified Data.Salak as S+import Data.Text (unpack)+ infixl 5 .?> (.?>) :: FromProperties a => Properties -> Text -> Return a (.?>) = flip S.lookup' infixl 5 .|= (.|=) :: Return a -> a -> a-(.|=) (OK a) _ = a-(.|=) (Fail e) _ = error e-(.|=) _ d = d+(.|=) (S.OK a) _ = a+(.|=) (S.Fail e) _ = error e+(.|=) _ d = d infixl 5 .?= (.?=) :: Return a -> a -> Return a-(.?=) a b = OK (a .|= b)+(.?=) a b = S.OK (a .|= b) infixl 5 .>> (.>>) :: FromProperties a => Properties -> Text -> a (.>>) p k = case p .?> k of- OK v -> v- Empty -> case fromProperties S.empty of- (OK a) -> a- (Fail e) -> error e- _ -> error $ "Config " <> unpack k <> " not found"- Fail e -> error e+ S.OK v -> v+ S.Empty -> case fromProperties S.empty of+ (S.OK a) -> a+ (S.Fail e) -> error e+ _ -> error $ "Config " <> unpack k <> " not found"+ S.Fail e -> error e+#endif type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO () {-# NOINLINE randomGen #-} randomGen :: GenIO-randomGen = unsafePerformIO create+randomGen = unsafePerformIO createSystemRandom -- | Utility randomString :: IO ByteString@@ -105,3 +127,11 @@ showText :: Show a => a -> Text showText = pack . show +throwS :: (HasCallStack, MonadIO m, MonadLogger m) => ServantErr -> Text -> m a+throwS e msg = do+ logErrorCS ?callStack msg+ liftIO $ throw e+++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.6+version: 0.5.7 license: BSD3 license-file: LICENSE copyright: (c) 2018 Daniel YU@@ -19,8 +19,10 @@ Yam Yam.Internal Yam.Middleware+ Yam.Middleware.Default Yam.Middleware.Auth Yam.Middleware.Trace+ Yam.Middleware.Client Yam.Swagger Yam.Types Yam.Types.Prelude@@ -55,6 +57,7 @@ bytestring >=0.10.8.2 && <0.11, data-default >=0.7.1.1 && <0.8, fast-logger >=2.4.13 && <2.5,+ http-client >=0.5.14 && <0.6, http-types >=0.12.2 && <0.13, lens ==4.17.*, monad-logger >=0.3.30 && <0.4,@@ -63,16 +66,17 @@ reflection >=2.1.4 && <2.2, salak >=0.1.4 && <0.3, scientific >=0.3.6.2 && <0.4,+ servant-client ==0.15.*, servant-server ==0.15.*, servant-swagger >=1.1.7 && <1.2, servant-swagger-ui >=0.3.2.3.19.3 && <0.4, swagger2 >=2.3.1 && <2.4, text >=1.2.3.1 && <1.3,- time >=1.8.0.2 && <1.9, unliftio-core >=0.1.2.0 && <0.2, unordered-containers >=0.2.9.0 && <0.3, vault >=0.3.1.2 && <0.4, wai >=3.2.1.2 && <3.3,+ wai-extra >=3.0.24.3 && <3.1, warp >=3.2.25 && <3.3 test-suite spec@@ -89,6 +93,8 @@ Yam.Logger Yam.Middleware Yam.Middleware.Auth+ Yam.Middleware.Client+ Yam.Middleware.Default Yam.Middleware.Trace Yam.Swagger Yam.Types@@ -120,6 +126,7 @@ data-default >=0.7.1.1 && <0.8, fast-logger >=2.4.13 && <2.5, hspec ==2.*,+ http-client >=0.5.14 && <0.6, http-types >=0.12.2 && <0.13, lens ==4.17.*, monad-logger >=0.3.30 && <0.4,@@ -128,14 +135,15 @@ reflection >=2.1.4 && <2.2, salak >=0.1.4 && <0.3, scientific >=0.3.6.2 && <0.4,+ servant-client ==0.15.*, servant-server ==0.15.*, servant-swagger >=1.1.7 && <1.2, servant-swagger-ui >=0.3.2.3.19.3 && <0.4, swagger2 >=2.3.1 && <2.4, text >=1.2.3.1 && <1.3,- time >=1.8.0.2 && <1.9, unliftio-core >=0.1.2.0 && <0.2, unordered-containers >=0.2.9.0 && <0.3, vault >=0.3.1.2 && <0.4, wai >=3.2.1.2 && <3.3,+ wai-extra >=3.0.24.3 && <3.1, warp >=3.2.25 && <3.3