yam 0.5.3 → 0.5.4
raw patch · 17 files changed
+620/−282 lines, 17 filesdep +scientificdep +timedep +unordered-containers
Dependencies added: scientific, time, unordered-containers
Files
- src/Data/Opentracing.hs +9/−0
- src/Data/Opentracing/Simple.hs +33/−0
- src/Data/Opentracing/Tracer.hs +83/−0
- src/Data/Opentracing/Types.hs +38/−0
- src/Yam.hs +12/−2
- src/Yam/Auth.hs +0/−49
- src/Yam/Internal.hs +27/−34
- src/Yam/Logger.hs +11/−19
- src/Yam/Middleware.hs +35/−0
- src/Yam/Middleware/Auth.hs +64/−0
- src/Yam/Middleware/Trace.hs +117/−0
- src/Yam/Swagger.hs +12/−5
- src/Yam/Trace.hs +0/−15
- src/Yam/Types.hs +29/−150
- src/Yam/Types/Env.hs +43/−0
- src/Yam/Types/Prelude.hs +79/−0
- yam.cabal +28/−8
+ src/Data/Opentracing.hs view
@@ -0,0 +1,9 @@+module Data.Opentracing(+ module Data.Opentracing.Tracer+ , module Data.Opentracing.Types+ , module Data.Opentracing.Simple+ ) where++import Data.Opentracing.Simple+import Data.Opentracing.Tracer+import Data.Opentracing.Types
+ src/Data/Opentracing/Simple.hs view
@@ -0,0 +1,33 @@+module Data.Opentracing.Simple where++import Control.Monad.State+import Data.Opentracing.Tracer+import Data.Opentracing.Types++newtype TracerT m a = TracerT { runTracer :: StateT (Maybe Span, SpanContext) m a }+ deriving (Functor, Applicative, Monad, MonadTrans)++instance MonadIO m => MonadIO (TracerT m) where+ liftIO = TracerT . liftIO++instance MonadIO m => MonadTracer (TracerT m) where+ askSpanContext = TracerT $ gets snd++instance MonadIO m => MonadTracing (TracerT m) where+ runInSpan name notify action = do+ (s,c) <- TracerT get+ n <- case s of+ Just sp -> newChildSpan name sp+ _ -> newSpan name+ TracerT $ put (Just n,c)+ notify n+ a <- action n+ finishSpan n >>= notify+ return a++type Tracer = TracerT IO++runTracing :: TracerT IO a -> IO a+runTracing a = do+ c <- newContext+ fst <$> runStateT (runTracer a) (Nothing, c)
+ src/Data/Opentracing/Tracer.hs view
@@ -0,0 +1,83 @@+module Data.Opentracing.Tracer(+ SpanName+ , newSpan+ , newChildSpan+ , newSpan'+ , forkSpan+ , setReferences+ , setBaggage+ , tag+ , addLog+ , finishSpan+ , MonadTracer(..)+ , MonadTracing(..)+ , newContext+ ) where++import Control.Monad.IO.Class+import qualified Data.HashMap.Lazy as HM+import Data.Opentracing.Types+import Data.Text (Text, justifyRight, pack)+import Data.Time+import Data.Word+import Numeric+import System.Random++type SpanName = Text++class MonadIO m => MonadTracer m where+ askSpanContext :: m SpanContext++class MonadTracer m => MonadTracing m where+ runInSpan :: SpanName -> (Span -> m ()) -> (Span -> m a) -> m a++{-# INLINE newId #-}+newId :: MonadIO m => m Text+newId = liftIO $ do+ c <- randomIO :: IO Word64+ return $ justifyRight 16 '0' $ pack $ showHex c ""++newSpan :: MonadTracer m => SpanName -> m Span+newSpan name = do+ context <- askSpanContext+ newSpan' name context []++newSpan' :: MonadTracer m => SpanName -> SpanContext -> [SpanReference] -> m Span+newSpan' name context references = do+ spanId <- if null references then return (traceId context) else newId+ startTime <- liftIO getCurrentTime+ let finishTime = Nothing+ tags = HM.empty+ logs = HM.empty+ return Span {..}++newChildSpan :: MonadTracer m => SpanName -> Span -> m Span+newChildSpan name parent = newSpan' name (context parent) [SpanReference ChildOf $ spanId parent]++forkSpan :: MonadTracer m => SpanName -> Span -> m Span+forkSpan name parent = newSpan' name (context parent) [SpanReference FollowsFrom $ spanId parent]++setReferences :: Span -> [SpanReference] -> Span+setReferences Span{..} rs = Span{ references = rs, ..}++tag :: Span -> Text -> SpanTag -> Span+tag Span{..} k t = Span{ tags = HM.insert k t tags, ..}++addLog :: Span -> Text -> Text -> Span+addLog Span{..} k t = Span{ logs = HM.insert k t logs, ..}++setBaggage :: Span -> Text -> Maybe Text -> Span+setBaggage Span{..} k t =+ let SpanContext{..} = context+ in Span{ context = SpanContext{ baggage = HM.insert k t baggage ,..}, ..}++finishSpan :: MonadTracer m => Span -> m Span+finishSpan Span{..} = do+ ts <- liftIO getCurrentTime+ return Span {finishTime = Just ts, ..}++newContext :: MonadIO m => m SpanContext+newContext = do+ traceId <- newId+ let baggage = HM.empty+ return SpanContext{..}
+ src/Data/Opentracing/Types.hs view
@@ -0,0 +1,38 @@+module Data.Opentracing.Types where++import qualified Data.HashMap.Lazy as HM+import Data.Scientific+import Data.Text (Text)+import Data.Time++data SpanTag+ = TagString Text+ | TagBool Bool+ | TagNum Scientific+ deriving (Eq, Show)++data SpanContext = SpanContext+ { traceId :: Text+ , baggage :: HM.HashMap Text (Maybe Text)+ } deriving (Eq, Show)++data SpanReferenceType+ = FollowsFrom+ | ChildOf+ deriving (Eq, Show)++data SpanReference = SpanReference+ { referenceType :: SpanReferenceType+ , parentId :: Text+ } deriving (Eq, Show)++data Span = Span+ { spanId :: Text+ , name :: Text+ , startTime :: UTCTime+ , finishTime :: Maybe UTCTime+ , tags :: HM.HashMap Text SpanTag+ , logs :: HM.HashMap Text Text+ , context :: SpanContext+ , references :: [SpanReference]+ } deriving (Eq, Show)
src/Yam.hs view
@@ -1,7 +1,17 @@ module Yam( module Yam.Internal- , module Yam.Auth+ , module Yam.Logger+ , module Yam.Types+ , module Yam.Swagger+ , module Yam.Middleware+ , module Yam.Middleware.Auth+ , module Yam.Middleware.Trace ) where -import Yam.Auth import Yam.Internal+import Yam.Logger+import Yam.Middleware+import Yam.Middleware.Auth+import Yam.Middleware.Trace+import Yam.Swagger+import Yam.Types
− src/Yam/Auth.hs
@@ -1,49 +0,0 @@-module Yam.Auth where-import Control.Lens-import Data.Default-import Data.Swagger-import Servant.Server.Internal.RoutingApplication-import Servant.Swagger-import Servant.Swagger.Internal-import System.IO.Unsafe (unsafePerformIO)-import Yam.Internal hiding (name)--data CheckAuth (principal :: *)--newtype AuthChecker principal = AuthChecker { runCheckAuth :: Request -> App principal }--instance Default (AuthChecker principal) where- def = AuthChecker $ \_ -> throwS err401 "No Auth Checker"--class HasAuthKey principal where- authKey :: Key (AuthChecker principal)- authKey = unsafePerformIO newKey--instance ( HasContextEntry context Env- , HasServer api context- , HasAuthKey principal)- => HasServer (CheckAuth principal :> api) context where- type ServerT (CheckAuth principal :> api) m = principal -> ServerT api m- hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s- route _ context server = route (Proxy :: Proxy api) context $ server `addAuthCheck` authCheck- where- env :: Env- env = getContextEntry context- checker :: Request -> App principal- checker = runCheckAuth $ reqAttr authKey env- authCheck :: DelayedIO principal- authCheck = withRequest $ \req -> liftIO $ runAppM env { reqAttributes = Just (vault req)} (checker req)--instance (HasSwagger api, ToParamSchema principal) => HasSwagger (CheckAuth principal :> api) where- toSwagger _ = toSwagger (Proxy :: Proxy api)- & addParam param- where- param = mempty- & Data.Swagger.name .~ "Authorization"- & required ?~ True- & schema .~ ParamOther (mempty- & in_ .~ ParamHeader- & paramSchema .~ toParamSchema (Proxy :: Proxy principal))--authAppMiddleware :: HasAuthKey principal => AuthChecker principal -> AppMiddleware-authAppMiddleware = simpleAppMiddleware (True, "Auth Plugin") authKey
src/Yam/Internal.hs view
@@ -4,84 +4,77 @@ -- * Application Functions startYam , start- , App- , module Yam.Logger- , module Yam.Types- , SwaggerConfig(..)- -- * Utilities- , readConf ) where -import Control.Exception hiding (Handler)-import qualified Data.ByteString.Lazy.Char8 as B-import qualified Data.Salak as S-import qualified Data.Vault.Lazy as L-import Network.Wai.Handler.Warp (run)+import qualified Data.ByteString.Lazy.Char8 as B+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.Swagger-import Yam.Trace import Yam.Types -type App = AppM IO--runApp :: Env -> App a -> Handler a-runApp b c = do- res :: Either SomeException a <- liftIO $ try (runAppM b c)- case res of- Left e -> throwError $ fromMaybe err400 { errBody = B.pack $ show e } (fromException e :: Maybe ServantErr)- Right r -> return r+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- -> Bool+ -> TraceConfig -> Version -> [AppMiddleware] -> Proxy api -> ServerT api App -> IO ()-startYam ac@AppConfig{..} sw@SwaggerConfig{..} logConfig enableTrace vs middlewares proxy server+startYam ac@AppConfig{..} sw@SwaggerConfig{..} logConfig traceConfig vs middlewares proxy server = withLogger name logConfig $ do logInfo $ "Start Service [" <> name <> "] ..." logger <- askLoggerIO- let act = runAM $ foldr1 (<>) (traceMiddleware enableTrace : middlewares)- act (setLogger logger $ Env L.empty Nothing ac) $ \(env, middleware) -> do+ let act = runAM $ foldr1 (<>) (traceMiddleware traceConfig : middlewares)+ act (putLogger logger $ Env L.empty Nothing ac) $ \(env, middleware) -> do let cxt = env :. EmptyContext pCxt = Proxy :: Proxy '[Env] portText = showText port proxy' = Proxy :: Proxy (Vault :> api) server' = runRequest proxy pCxt server+ settings = defaultSettings+ & setPort port+ & setOnException (\_ _ -> return ())+ & setOnExceptionResponse whenException when enabled $ logInfo $ "Swagger enabled: http://localhost:" <> portText <> "/" <> pack urlDir logInfo $ "Servant started on port(s): " <> portText- lift $ run port+ lift $ runSettings settings $ middleware $ serveWithContextAndSwagger sw ac vs proxy' cxt- $ hoistServerWithContext proxy' pCxt (runApp env) server'+ $ hoistServerWithContext proxy' pCxt (transApp env) server' runRequest :: (HasServer api context) => Proxy api -> Proxy context -> ServerT api App -> Vault -> ServerT api App runRequest p pc a v = hoistServerWithContext p pc go a where {-# INLINE go #-} go :: App a -> App a- go = withAppM (\env -> env { reqAttributes = Just v})+ go = local (\env -> env { reqAttributes = Just v}) -readConf :: (Default a, S.FromProperties a) => Text -> S.Properties -> a-readConf k p = fromMaybe def $ S.lookup k p+transApp :: Env -> App a -> Handler a+transApp b c = liftIO $ runApp b c start :: forall api. (HasSwagger api, HasServer api '[Env])- => S.Properties+ => Properties -> Version -> [AppMiddleware] -> Proxy api -> ServerT api App -> IO () start p = startYam- (readConf "yam.application" p)- (readConf "yam.swagger" p)- (readConf "yam.logging" p)- (fromMaybe True $ S.lookup "yam.trace.enabled" p)+ (readConfig "yam.application" p)+ (readConfig "yam.swagger" p)+ (readConfig "yam.logging" p)+ (readConfig "yam.trace" p)
src/Yam/Logger.hs view
@@ -2,21 +2,21 @@ module Yam.Logger( -- * Logger Function withLogger- , setLogger+ , putLogger , setExtendLog+ , getLogger , extensionLogKey , throwS , LogConfig(..) ) where -import Control.Exception (bracket, throw)-import Control.Monad (when)-import Control.Monad.Reader import qualified Data.Text as T import GHC.Stack+import Servant import System.IO.Unsafe (unsafePerformIO) import System.Log.FastLogger-import Yam.Types+import Yam.Types.Env+import Yam.Types.Prelude instance FromJSON LogLevel where parseJSON v = go . T.toLower <$> parseJSON v@@ -65,8 +65,8 @@ return (toLogger l, close) where toLogger 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"+ 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" withLogger :: Text -> LogConfig -> LoggingT IO a -> IO a withLogger n lc action = bracket (newLogger n lc) snd $ \(f,_) -> runLoggingT action f@@ -85,8 +85,8 @@ setExtendLog :: (Text -> Text) -> Env -> Env setExtendLog f env = let mt = fromMaybe "" $ getAttr extensionLogKey env in setAttr extensionLogKey (f mt) env -setLogger :: LogFunc -> Env -> Env-setLogger = setAttr loggerKey+putLogger :: LogFunc -> Env -> Env+putLogger = setAttr loggerKey getLogger :: Env -> LogFunc getLogger env =@@ -97,15 +97,7 @@ nlf x _ = x in maybe (\_ _ _ _ -> return ()) (`nlf` trace) logger -instance MonadIO m => MonadLogger (AppM m) where- monadLoggerLog a b c d = do- env <- ask- liftIO $ getLogger env a b c $ toLogStr d--instance (MonadIO m) => MonadLoggerIO (AppM m) where- askLoggerIO = asks getLogger--throwS :: (HasCallStack, MonadIO m) => ServantErr -> Text -> AppM m a+throwS :: (HasCallStack, MonadIO m, MonadLogger m) => ServantErr -> Text -> m a throwS e msg = do logErrorCS ?callStack msg- lift $ throw e+ liftIO $ throw e
+ src/Yam/Middleware.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE ImplicitParams #-}+module Yam.Middleware(+ AppMiddleware(..)+ , simpleAppMiddleware+ , simpleWebMiddleware+ ) where++import Yam.Types.Env+import Yam.Types.Prelude++-- | Application Middleware+newtype AppMiddleware = AppMiddleware {runAM :: Env -> ((Env, Middleware)-> LoggingT IO ()) -> LoggingT IO ()}++instance Semigroup AppMiddleware where+ (AppMiddleware am) <> (AppMiddleware bm) = AppMiddleware $ \e f -> am e $ \(e', mw) -> bm e' $ \(e'',mw') -> f (e'', mw . mw')++instance Monoid AppMiddleware where+ mempty = AppMiddleware $ \a f -> f (a,id)++-- | Simple AppMiddleware+simpleAppMiddleware :: HasCallStack => (Bool, Text) -> Key a -> a -> AppMiddleware+simpleAppMiddleware (enabled,amname) k v =+ if enabled+ then AppMiddleware $ \e f -> do+ logInfoCS ?callStack $ amname <> " enabled"+ f (setAttr k v e, id)+ else mempty++simpleWebMiddleware :: HasCallStack => (Bool, Text) -> Middleware -> AppMiddleware+simpleWebMiddleware (enabled,amname) m =+ if enabled+ then AppMiddleware $ \e f -> do+ logInfoCS ?callStack $ amname <> " enabled"+ f (e,m)+ else mempty
+ src/Yam/Middleware/Auth.hs view
@@ -0,0 +1,64 @@+module Yam.Middleware.Auth where+import Control.Lens+import Data.Swagger+import qualified Data.Vault.Lazy as L+import Servant+import Servant.Server.Internal.RoutingApplication+import Servant.Swagger+import Servant.Swagger.Internal+import System.IO.Unsafe (unsafePerformIO)+import Yam.Logger+import Yam.Middleware+import Yam.Types++data CheckAuth (principal :: *)++newtype AuthChecker principal = AuthChecker { runCheckAuth :: Request -> App principal }++instance Default (AuthChecker principal) where+ def = AuthChecker $ \_ -> throwS err401 "No Auth Checker"++class HasAuthKey principal where+ authKey :: Key (AuthChecker principal)+ authKey = unsafePerformIO newKey+ toLog :: principal -> Text++instance ( HasContextEntry context Env+ , HasServer api context+ , HasAuthKey principal)+ => HasServer (CheckAuth principal :> api) context where+ type ServerT (CheckAuth principal :> api) m = principal -> ServerT api m+ hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s+ route _ context server = route (Proxy :: Proxy api) context $ server `addFixAuthCheck` authCheck+ where+ env :: Env+ env = getContextEntry context+ checker :: Request -> App principal+ checker = runCheckAuth $ reqAttr authKey env+ authCheck :: DelayedIO principal+ authCheck = withRequest $ \req -> liftIO $ runApp env { reqAttributes = Just (vault req)} (checker req)+ -- Fix Origin `addAuthCheck`, add logger info+ addFixAuthCheck+ :: Delayed env (principal -> b)+ -> DelayedIO principal+ -> Delayed env b+ addFixAuthCheck Delayed{..} new =+ Delayed+ { authD = (,) <$> authD <*> new+ , serverD = \ c p h (y, v) b req -> ($ v) <$> serverD c p h y b req { vault = L.adjust (\x -> x <> "," <> toLog v) extensionLogKey $ vault req}+ , ..+ }++instance (HasSwagger api, ToParamSchema principal) => HasSwagger (CheckAuth principal :> api) where+ toSwagger _ = toSwagger (Proxy :: Proxy api)+ & addParam param+ where+ param = mempty+ & Data.Swagger.name .~ "Authorization"+ & required ?~ True+ & schema .~ ParamOther (mempty+ & in_ .~ ParamHeader+ & paramSchema .~ toParamSchema (Proxy :: Proxy principal))++authAppMiddleware :: HasAuthKey principal => AuthChecker principal -> AppMiddleware+authAppMiddleware = simpleAppMiddleware (True, "Auth Plugin") authKey
+ src/Yam/Middleware/Trace.hs view
@@ -0,0 +1,117 @@+module Yam.Middleware.Trace(+ MonadTracer(..)+ , MonadTracing(..)+ , TraceConfig(..)+ , hTraceId+ , hParentTraceId+ , hSpanId+ , hSampled+ , traceMiddleware+ ) where++import qualified Data.HashMap.Lazy as HM+import Data.Opentracing+import qualified Data.Text as T+import qualified Data.Vault.Lazy as L+import System.IO.Unsafe (unsafePerformIO)+import Yam.Logger+import Yam.Middleware+import Yam.Types++data TraceConfig = TraceConfig+ { enabled :: Bool+ , method :: TraceNotifyType+ } deriving (Eq, Show)++data TraceNotifyType+ = NoTracer+ deriving (Eq, Show)++instance FromJSON TraceNotifyType where+ parseJSON v = go . T.toLower <$> parseJSON v+ where+ go :: Text -> TraceNotifyType+ go _ = NoTracer++instance FromJSON TraceConfig where+ parseJSON = withObject "TraceConfig" $ \v -> TraceConfig+ <$> v .:? "enabled" .!= True+ <*> v .:? "type" .!= NoTracer++instance Default TraceConfig where+ def = TraceConfig True NoTracer++notifier :: TraceNotifyType -> Span -> App ()+notifier _ _ = return ()++{-# NOINLINE spanContextKey #-}+spanContextKey :: Key SpanContext+spanContextKey = unsafePerformIO newKey++{-# NOINLINE spanKey #-}+spanKey :: Key Span+spanKey = unsafePerformIO newKey++instance MonadTracer App where+ askSpanContext = requireAttr spanContextKey++instance MonadTracing App where+ runInSpan name notify action = do+ s <- askAttr spanKey+ n <- case s of+ Just sp -> newChildSpan name sp+ _ -> newSpan name+ notify n+ a <- withAttr spanKey n $ action n+ finishSpan n >>= notify+ return a++hTraceId :: HeaderName+hTraceId = "X-B3-TraceId"++hParentTraceId :: HeaderName+hParentTraceId = "X-B3-ParentSpanId"++hSpanId :: HeaderName+hSpanId = "X-B3-SpanId"++hSampled :: HeaderName+hSampled = "X-B3-Sampled"++parseSpan :: RequestHeaders -> Env -> Env+parseSpan headers env =+ let sc = fromMaybe (SpanContext "" HM.empty) $ getAttr spanContextKey env+ in case lookup hTraceId headers of+ Just tid -> let sc' = sc { traceId = decodeUtf8 tid }+ in env & setAttr spanContextKey sc'+ & go (maybe (traceId sc') decodeUtf8 $ lookup hSpanId headers) sc'+ _ -> env+ where+ go spanId context env' =+ let name = "-"+ startTime = undefined+ finishTime = Nothing+ tags = HM.empty+ logs = HM.empty+ references = []+ in setAttr spanKey Span{..} env'++traceMw :: Env -> (Span -> App ()) -> Middleware+traceMw env notify app req resH = runApp (parseSpan (requestHeaders req) env) $+ runInSpan ((decodeUtf8 $ requestMethod req) <> " /" <> T.intercalate "/" (pathInfo req)) notify $ \s@Span{..} -> do+ let SpanContext{..} = context+ tid = traceId <> "," <> spanId+ v = L.insert extensionLogKey tid (vault req)+ v' = L.insert spanKey s v+ liftIO $ app req {vault = v'}+ $ resH . mapResponseHeaders (\hs -> (hTraceId,encodeUtf8 traceId):(hSpanId, encodeUtf8 spanId):hs)++traceMiddleware :: TraceConfig -> AppMiddleware+traceMiddleware TraceConfig{..}+ = AppMiddleware $ \env f -> if enabled+ then do+ c <- newContext+ let env' = setAttr spanContextKey c env+ f (env', traceMw env' $ notifier method)+ else f (env, id)+
src/Yam/Swagger.hs view
@@ -1,13 +1,20 @@ {-# LANGUAGE NoPolyKinds #-}-module Yam.Swagger where+module Yam.Swagger(+ SwaggerConfig(..)+ , serveWithContextAndSwagger+ , module Control.Lens+ ) where -import Control.Lens hiding (Context)+import Control.Lens hiding (Context, allOf, (.=)) import Data.Reflection import Data.Swagger hiding (name, port)+import qualified Data.Swagger as S import GHC.TypeLits+import Servant import Servant.Swagger import Servant.Swagger.UI-import Yam.Types+import Yam.Types.Env+import Yam.Types.Prelude data SwaggerConfig = SwaggerConfig { urlDir :: String@@ -54,5 +61,5 @@ g4 s = s & info .~ (mempty & title .~ (name <> " API Documents")- & version .~ pack (showVersion versions))- & host ?~ Host "http://localhost" (Just $ fromIntegral port)+ & S.version .~ pack (showVersion versions))+ & host ?~ Host "localhost" (Just $ fromIntegral port)
− src/Yam/Trace.hs
@@ -1,15 +0,0 @@-module Yam.Trace where--import qualified Data.Vault.Lazy as L-import Network.Wai-import Yam.Logger-import Yam.Types--traceMw :: Middleware-traceMw app req resH = do- traceId <- randomString 12- let h = ("X-TRACE-ID",encodeUtf8 traceId)- app req {vault = L.insert extensionLogKey traceId (vault req)} (resH . mapResponseHeaders (h:))--traceMiddleware :: Bool -> AppMiddleware-traceMiddleware enabled = simpleWebMiddleware (enabled, "Trace") traceMw
src/Yam/Types.hs view
@@ -1,173 +1,52 @@-{-# LANGUAGE ImplicitParams #-} module Yam.Types(- -- * Environment- AppConfig(..)- , Env(..)- , getAttr- , setAttr- , reqAttr -- * AppM Monad- , AppM- , runAppM- , withAppM+ App+ , runApp , askApp , askAttr , withAttr , requireAttr- -- * Application Middleware- , AppMiddleware(..)- , simpleAppMiddleware- , simpleWebMiddleware- -- * Utilities- , LogFunc- , randomString- , showText- , defJson- -- * Reexport Functions- , Key- , newKey- , Middleware- , Request(..)- , lift- , when- , Default(..)- , Text- , pack- , encodeUtf8- , decodeUtf8- , MonadIO- , liftIO- , withReaderT- , module Control.Monad.Logger.CallStack- , module Data.Maybe- , module Servant- , module Data.Aeson- , module Data.Word- , module Data.Function- , module Data.Version+ , module Yam.Types.Env+ , module Yam.Types.Prelude ) where -import Control.Monad.IO.Unlift-import Control.Monad.Logger.CallStack-import Control.Monad.Reader-import Data.Aeson-import Data.Default-import Data.Function-import Data.Maybe-import Data.Text (Text, justifyRight, pack)-import Data.Text.Encoding (decodeUtf8, encodeUtf8)-import Data.Vault.Lazy (Key, newKey)-import qualified Data.Vault.Lazy as L-import Data.Version-import Data.Word-import GHC.Stack-import Network.Wai-import Numeric-import Servant-import System.Random--data AppConfig = AppConfig- { name :: Text- , port :: Int- } deriving (Eq, Show)--instance FromJSON AppConfig where- parseJSON = withObject "AppConfig" $ \v -> AppConfig- <$> v .:? "name" .!= "application"- <*> v .:? "port" .!= 8888--defJson :: FromJSON a => a-defJson = fromJust $ decode "{}"--instance Default AppConfig where- def = defJson--data Env = Env- { attributes :: Vault- , reqAttributes :: Maybe Vault- , application :: AppConfig- }--instance Default Env where- def = Env L.empty Nothing def--getAttr :: Key a -> Env -> Maybe a-getAttr k Env{..} = listToMaybe $ catMaybes $ L.lookup k <$> catMaybes [reqAttributes, Just attributes]--reqAttr :: Default a => Key a -> Env -> a-reqAttr k = fromMaybe def . getAttr k--setAttr :: 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--newtype AppM m a = AppM { runAppM' :: ReaderT Env m a } deriving (Functor, Applicative, Monad, MonadTrans, MonadIO)-type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO ()+import Yam.Logger+import Yam.Types.Env+import Yam.Types.Prelude -runAppM :: Env -> AppM m a -> m a-runAppM e a = runReaderT (runAppM' a) e+newtype App a = App { runApp' :: ReaderT Env IO a } deriving+ ( Functor+ , Applicative+ , Monad+ , MonadIO+ , MonadReader Env) -instance Monad m => MonadReader Env (AppM m) where- ask = AppM ask- local f (AppM a) = AppM $ local f a+runApp :: Env -> App a -> IO a+runApp e a = runReaderT (runApp' a) e -instance MonadUnliftIO m => MonadUnliftIO (AppM m) where+instance MonadUnliftIO App where withRunInIO f = do env <- ask- lift $ withRunInIO (\g -> f $ g . runAppM env)+ App $ withRunInIO (\g -> f $ g . lift . runApp env) -withAppM :: MonadIO m => (Env -> Env) -> AppM m a -> AppM m a-withAppM f a = do- env <- ask- lift $ runAppM (f env) a+instance MonadLogger App where+ monadLoggerLog a b c d = do+ env <- ask+ liftIO $ getLogger env a b c $ toLogStr d -askApp :: Monad m => AppM m AppConfig+instance MonadLoggerIO App where+ askLoggerIO = asks getLogger++askApp :: App AppConfig askApp = asks application -requireAttr :: MonadIO m => Key a -> AppM m a+requireAttr :: Key a -> App a requireAttr k = fromJust <$> askAttr k -askAttr :: MonadIO m => Key a -> AppM m (Maybe a)+askAttr :: Key a -> App (Maybe a) askAttr = asks . getAttr -withAttr :: MonadIO m => Key a -> a -> AppM m b -> AppM m b-withAttr k v = withAppM (setAttr k v)---- | Application Middleware-newtype AppMiddleware = AppMiddleware {runAM :: Env -> ((Env, Middleware)-> LoggingT IO ()) -> LoggingT IO ()}--instance Semigroup AppMiddleware where- (AppMiddleware am) <> (AppMiddleware bm) = AppMiddleware $ \e f -> am e $ \(e', mw) -> bm e' $ \(e'',mw') -> f (e'', mw . mw')--instance Monoid AppMiddleware where- mempty = AppMiddleware $ \a f -> f (a,id)---- | Simple AppMiddleware-simpleAppMiddleware :: HasCallStack => (Bool, Text) -> Key a -> a -> AppMiddleware-simpleAppMiddleware (enabled,amname) k v =- if enabled- then AppMiddleware $ \e f -> do- logInfoCS ?callStack $ amname <> " enabled"- f (setAttr k v e, id)- else mempty--simpleWebMiddleware :: HasCallStack => (Bool, Text) -> Middleware -> AppMiddleware-simpleWebMiddleware (enabled,amname) m =- if enabled- then AppMiddleware $ \e f -> do- logInfoCS ?callStack $ amname <> " enabled"- f (e,m)- else mempty---- | Utility-{-# INLINE randomString #-}-randomString :: Int -> IO Text-randomString n = do- c <- randomIO :: IO Word64- return $ justifyRight n '0' $ pack $ take n $ showHex c ""+withAttr :: Key a -> a -> App b -> App b+withAttr k v = local (setAttr k v) -{-# INLINE showText #-}-showText :: Show a => a -> Text-showText = pack . show
+ src/Yam/Types/Env.hs view
@@ -0,0 +1,43 @@+module Yam.Types.Env(+ AppConfig(..)+ , Env(..)+ , getAttr+ , reqAttr+ , setAttr+ ) where++import qualified Data.Vault.Lazy as L+import Yam.Types.Prelude++data AppConfig = AppConfig+ { name :: Text+ , port :: Int+ } deriving (Eq, Show)++instance FromJSON AppConfig where+ parseJSON = withObject "AppConfig" $ \v -> AppConfig+ <$> v .:? "name" .!= "application"+ <*> v .:? "port" .!= 8888++instance Default AppConfig where+ def = defJson++data Env = Env+ { attributes :: Vault+ , reqAttributes :: Maybe Vault+ , application :: AppConfig+ }++instance Default Env where+ def = Env L.empty Nothing def++getAttr :: Key a -> Env -> Maybe a+getAttr k Env{..} = listToMaybe $ catMaybes $ L.lookup k <$> catMaybes [reqAttributes, Just attributes]++reqAttr :: Default a => Key a -> Env -> a+reqAttr k = fromMaybe def . getAttr k++setAttr :: 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
@@ -0,0 +1,79 @@+module Yam.Types.Prelude(+ defJson+ , randomString+ , showText+ , readConfig+ , LogFunc+ , Default(..)+ , Text+ , pack+ , HasCallStack+ , MonadError(..)+ , MonadUnliftIO(..)+ , SomeException(..)+ , fromException+ , bracket+ , throw+ , try+ , module Data.Proxy+ , module Data.Vault.Lazy+ , module Data.Maybe+ , module Data.Aeson+ , module Data.Word+ , module Data.Text.Encoding+ , module Data.Function+ , module Data.Salak+ , module Data.Version+ , module Control.Monad+ , module Control.Monad.Reader+ , module Control.Monad.Logger.CallStack+ , module Network.Wai+ , module Network.HTTP.Types+ ) where++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 Data.Aeson+import Data.Default+import Data.Function+import Data.Maybe+import Data.Proxy+import Data.Salak+ ( FromProperties (..)+ , Properties+ , defaultPropertiesWithFile+ )+import qualified Data.Salak as S+import Data.Text (Text, justifyRight, 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 Numeric+import System.Random++type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO ()++defJson :: FromJSON a => a+defJson = fromJust $ decode "{}"++-- | Utility+{-# INLINE randomString #-}+randomString :: Int -> IO Text+randomString n = do+ c <- randomIO :: IO Word64+ return $ justifyRight n '0' $ pack $ take n $ showHex c ""++{-# INLINE showText #-}+showText :: Show a => a -> Text+showText = pack . show++readConfig :: (Default a, FromProperties a) => Text -> Properties -> a+readConfig k p = fromMaybe def $ S.lookup k p
yam.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.12 name: yam-version: 0.5.3+version: 0.5.4 license: BSD3 license-file: LICENSE copyright: (c) 2018 Daniel YU@@ -18,13 +18,20 @@ exposed-modules: Yam Yam.Internal- Yam.Auth- hs-source-dirs: src- other-modules:+ Yam.Middleware+ Yam.Middleware.Auth+ Yam.Middleware.Trace+ Yam.Swagger Yam.Types+ Yam.Types.Prelude+ Yam.Types.Env Yam.Logger- Yam.Swagger- Yam.Trace+ hs-source-dirs: src+ other-modules:+ Data.Opentracing+ Data.Opentracing.Types+ Data.Opentracing.Tracer+ Data.Opentracing.Simple default-language: Haskell2010 default-extensions: AutoDeriveTypeable BangPatterns BinaryLiterals ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable@@ -54,12 +61,15 @@ random ==1.1.*, reflection >=2.1.4 && <2.2, salak >=0.1.4 && <0.2,+ scientific >=0.3.6.2 && <0.4, 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, warp >=3.2.25 && <3.3@@ -69,13 +79,20 @@ main-is: Spec.hs hs-source-dirs: test src other-modules:+ Data.Opentracing+ Data.Opentracing.Simple+ Data.Opentracing.Tracer+ Data.Opentracing.Types Yam- Yam.Auth Yam.Internal Yam.Logger+ Yam.Middleware+ Yam.Middleware.Auth+ Yam.Middleware.Trace Yam.Swagger- Yam.Trace Yam.Types+ Yam.Types.Env+ Yam.Types.Prelude Paths_yam default-language: Haskell2010 default-extensions: AutoDeriveTypeable BangPatterns BinaryLiterals@@ -108,12 +125,15 @@ random ==1.1.*, reflection >=2.1.4 && <2.2, salak >=0.1.4 && <0.2,+ scientific >=0.3.6.2 && <0.4, 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, warp >=3.2.25 && <3.3