diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,19 +1,36 @@ # yam +| package name | version | +|-|-| +| yam |[![Hackage](https://img.shields.io/hackage/v/yam.svg)](https://hackage.haskell.org/package/yam)| +| yam-datasource |[![Hackage](https://img.shields.io/hackage/v/yam-datasource.svg)](https://hackage.haskell.org/package/yam-datasource)| +| yam-redis |[![Hackage](https://img.shields.io/hackage/v/yam-redis.svg)](https://hackage.haskell.org/package/yam-redis)| + +[![stackage LTS package](http://stackage.org/package/yam/badge/lts)](http://stackage.org/lts/package/yam) +[![stackage Nightly package](http://stackage.org/package/yam/badge/nightly)](http://stackage.org/nightly/package/yam) +[![Build Status](https://travis-ci.org/leptonyu/yam.svg?branch=master)](https://travis-ci.org/leptonyu/yam) + Servant based Web Wrapper for Production in Haskell. ```Haskell -import qualified Data.Salak as S +import Salak +import Salak.Yaml +import Servant import Yam +import qualified Control.Category as C +import Data.Version type API = "hello" :> Get '[PlainText] Text -service :: ServerT API App +service :: ServerT API AppSimple service = return "world" -main = start S.empty [] (Proxy :: Proxy API) service - +main = runSalakWith "app" YAML $ do + al <- require "yam.application" + sw <- require "yam.swagger" + lc <- requireD "yam.logging" + start al sw (makeVersion []) lc spanNoNotifier emptyAM serveWarp (Proxy @API) service ``` diff --git a/src/Data/Opentracing/Tracer.hs b/src/Data/Opentracing/Tracer.hs --- a/src/Data/Opentracing/Tracer.hs +++ b/src/Data/Opentracing/Tracer.hs @@ -18,7 +18,7 @@ import qualified Data.HashMap.Lazy as HM import Data.Opentracing.Types -- import Data.Time.Clock.POSIX -import Yam.Types.Prelude +import Yam.Prelude type SpanName = Text diff --git a/src/Yam.hs b/src/Yam.hs --- a/src/Yam.hs +++ b/src/Yam.hs @@ -1,22 +1,186 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE NoPolyKinds #-} +-- | +-- Module: Yam +-- Copyright: (c) 2019 Daniel YU +-- License: BSD3 +-- Maintainer: leptonyu@gmail.com +-- Stability: experimental +-- Portability: portable +-- +-- A out-of-the-box wrapper of [servant](https://hackage.haskell.org/package/servant-server), +-- providing configuration loader [salak](https://hackage.haskell.org/package/salak) and flexible extension with 'AppMiddleware'. +-- module Yam( - -- * Application - module Yam.Internal - , module Yam.Types + -- * How to use this library + -- $use + + -- * Yam Server + start + , serveWarp + -- ** Application Configuration + , AppConfig(..) + -- ** Application Context + , AppT + , AppV + , AppIO + , AppSimple + , Simple + , runAppT + , runVault + , throwS + -- ** Application Middleware + , AppMiddleware(..) + , emptyAM + , simpleContext + , simpleConfig + , simpleConfig' + , simpleMiddleware -- * Modules - , module Yam.Logger - , module Yam.Swagger - -- * Middlewares - , module Yam.Middleware - , module Yam.Middleware.Auth - , module Yam.Middleware.Client - , module Yam.Middleware.Trace + -- ** Logger + , LogConfig(..) + , HasLogger + , LogFuncHolder + , VaultHolder + -- ** Context + , Context(..) + , HasContextEntry(..) + , TryContextEntry(..) + , getEntry + , tryEntry + -- ** Swagger + , SwaggerConfig(..) + , serveWithContextAndSwagger + , baseInfo + -- * Reexport + , spanNoNotifier + , Span(..) + , SpanContext(..) + , SpanTag(..) + , SpanReference(..) + , showText + , randomString + , randomCode + , decodeUtf8 + , encodeUtf8 + , pack + , liftIO + , fromMaybe + , throw ) where -import Yam.Internal +import qualified Control.Category as C +import Control.Monad.Logger.CallStack +import Data.Opentracing +import Network.Wai +import Salak +import Servant +import Servant.Swagger +import Yam.App +import Yam.Config import Yam.Logger -import Yam.Middleware -import Yam.Middleware.Auth -import Yam.Middleware.Client +import Yam.Middleware.Error import Yam.Middleware.Trace +import Yam.Prelude import Yam.Swagger -import Yam.Types + +-- | Application Middleware. +newtype AppMiddleware a b = AppMiddleware + { runAM :: Context a -> Middleware -> (Context b -> Middleware -> LoggingT IO ()) -> LoggingT IO () } + +instance C.Category AppMiddleware where + id = AppMiddleware $ \a m f -> f a m + (AppMiddleware fbc) . (AppMiddleware fab) = AppMiddleware $ \a m f -> fab a m $ \b m1 -> fbc b m1 f + +-- | Simple Application Middleware, just provide a config to context. +simpleContext :: a -> AppMiddleware cxt (a ': cxt) +simpleContext a = AppMiddleware $ \c m f -> f (a :. c) m + +-- | Simple Application Middleware, just provide a config to context. +simpleConfig' :: (HasSalak cxt, FromProp a) => Text -> (a -> AppT cxt (LoggingT IO) b) -> AppMiddleware cxt (b ': cxt) +simpleConfig' key g = AppMiddleware $ \c m f -> runAppT c (require key) >>= \a -> runAppT c (g a) >>= \b -> f (b :. c) m + +-- | Simple Application Middleware, just provide a config to context. +simpleConfig :: (HasSalak cxt, FromProp a) => Text -> AppMiddleware cxt (a ': cxt) +simpleConfig key = simpleConfig' key return + +-- | Simple Application Middleware, promote a 'Middleware' to 'AppMiddleware' +simpleMiddleware :: Middleware -> AppMiddleware cxt cxt +simpleMiddleware m = AppMiddleware $ \c m2 f -> f c (m . m2) + +-- | Standard Starter of Yam. +start + :: forall api cxt + . ( HasServer api cxt + , HasSwagger api) + => AppConfig -- ^ Application Config + -> SwaggerConfig -- ^ SwaggerConfig + -> Version -- ^ Application Version + -> IO LogConfig -- ^ Logger Config + -> (Span -> AppV cxt IO ()) -- ^ Opentracing notifier + -> AppMiddleware Simple cxt -- ^ Application Middleware + -> (AppConfig -> Application -> IO ()) -- ^ Run Application + -> Proxy api -- ^ Application API Proxy + -> ServerT api (AppV cxt IO) -- ^ Application API Server + -> IO () +start ac@AppConfig{..} sw@SwaggerConfig{..} vs logConfig f am runHttp p api = + withLogger name logConfig $ \logger -> do + logInfo $ "Start Service [" <> name <> "] ..." + let portText = showText port + baseCxt = LF logger :. EmptyContext + runAM am baseCxt id $ \cxt middleware -> do + when enabled $ + logInfo $ "Swagger enabled: http://localhost:" <> portText <> "/" <> pack urlDir + logInfo $ "Servant started on port(s): " <> portText + liftIO + $ runHttp ac + $ traceMiddleware (\v -> runAppT (VH v :. cxt) . f) + $ middleware + $ errorMiddleware baseCxt + $ serveWithContextAndSwagger sw (baseInfo hostname name vs port) (Proxy @(Vault :> api)) cxt + $ \v -> hoistServerWithContext p (Proxy @cxt) (nt cxt v) api + +-- | default http server by warp. +serveWarp :: AppConfig -> Application -> IO () +serveWarp AppConfig{..} = runSettings + $ defaultSettings + & setPort port + & setOnException (\_ _ -> return ()) + & setOnExceptionResponse whenException + & setSlowlorisSize slowlorisSize + +-- | Empty span notifier. +spanNoNotifier :: Span -> AppV cxt IO () +spanNoNotifier _ = return () + +-- | Empty Application Middleware. +emptyAM :: AppMiddleware cxt cxt +emptyAM = C.id + +-- | Simple Application context +type Simple = '[LogFuncHolder] + +-- | Simple Application with logger context. +type AppSimple = AppV Simple IO + + +-- $use +-- +-- > import Salak +-- > import Salak.Yaml +-- > import Servant +-- > import Yam +-- > import qualified Control.Category as C +-- > import Data.Version +-- > +-- > type API = "hello" :> Get '[PlainText] Text +-- > +-- > service :: ServerT API AppSimple +-- > service = return "world" +-- > +-- > main = runSalakWith "app" YAML $ do +-- > al <- require "yam.application" +-- > sw <- require "yam.swagger" +-- > lc <- requireD "yam.logging" +-- > start al sw (makeVersion []) lc spanNoNotifier emptyAM serveWarp (Proxy @API) service + diff --git a/src/Yam/App.hs b/src/Yam/App.hs new file mode 100644 --- /dev/null +++ b/src/Yam/App.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +module Yam.App where + +import Control.Monad.IO.Unlift +import Control.Monad.Logger.CallStack +import Control.Monad.Reader +import Data.Menshen +import Salak +import Servant +import Yam.Logger +import Yam.Prelude + +-- | Application Context Monad. +newtype AppT cxt m a = AppT { runAppT' :: ReaderT (Context cxt) m a } deriving (Functor, Applicative, Monad) + +-- | Application on IO. +type AppIO cxt = AppT cxt IO + +-- | Application with 'Vault' +type AppV cxt = AppT (VaultHolder : cxt) + +instance MonadTrans (AppT cxt) where + lift = AppT . lift + +instance MonadIO m => MonadIO (AppT cxt m) where + liftIO = AppT . liftIO + +instance Monad m => MonadReader (Context cxt) (AppT cxt m) where + ask = AppT ask + local f (AppT a) = AppT $ local f a + +instance MonadUnliftIO m => MonadUnliftIO (AppT cxt m) where + askUnliftIO = do + cxt <- ask + uio <- lift askUnliftIO + return (UnliftIO $ unliftIO uio . runAppT cxt) + +instance (HasLogger cxt, MonadIO m) => HasValid (AppT cxt m) where + invalid a = throwS err400 (pack $ toI18n a) + +instance (HasLogger cxt, MonadIO m) => MonadLogger (AppT cxt m) where + monadLoggerLog a b c d = do + f <- getEntry + v <- tryEntry + liftIO $ getLogger v f a b c (toLogStr d) + +instance (HasLogger cxt, MonadIO m) => MonadLoggerIO (AppT cxt m) where + askLoggerIO = do + f <- getEntry + v <- tryEntry + return (getLogger v f) + +-- | Get entry from 'AppT' +getEntry :: (HasContextEntry cxt entry, Monad m) => AppT cxt m entry +getEntry = asks getContextEntry + +-- | Try get entry from 'AppT' +tryEntry :: (TryContextEntry cxt entry, Monad m) => AppT cxt m (Maybe entry) +tryEntry = asks tryContextEntry + +-- | Run Application with context. +runAppT :: Context cxt -> AppT cxt m a -> m a +runAppT c a = runReaderT (runAppT' a) c + +instance (HasContextEntry cxt SourcePack, Monad m) => HasSourcePack (AppT cxt m) where + askSourcePack = getEntry + +type HasSalak cxt = HasContextEntry cxt SourcePack + +-- | Run Application with 'Vault'. +runVault :: MonadIO m => Context cxt -> Vault -> AppV cxt IO a -> m a +runVault c v a = liftIO $ runAppT (VH v :. c) a + +nt :: Context cxt -> Vault -> AppV cxt IO a -> Handler a +nt = runVault diff --git a/src/Yam/Config.hs b/src/Yam/Config.hs new file mode 100644 --- /dev/null +++ b/src/Yam/Config.hs @@ -0,0 +1,26 @@ +module Yam.Config( + AppConfig(..) + , module Network.Wai.Handler.Warp + ) where + +import Network.Wai.Handler.Warp +import Salak +import Yam.Prelude + +-- | Application Configuration. +data AppConfig = AppConfig + { name :: Text -- ^ Application name. + , hostname :: String -- ^ Applicatoin hostname, used in swagger. + , port :: Int -- ^ Application http port. + , slowlorisSize :: Int -- ^ Slowloris size in Bytes, show in 'Settings' + } deriving (Eq, Show) + +instance Default AppConfig where + def = AppConfig "application" "localhost" 8888 2048 + +instance FromProp AppConfig where + fromProp = AppConfig + <$> "name" .?: name + <*> "host" .?: hostname + <*> "port" .?: port + <*> "slowloris-size" .?: slowlorisSize diff --git a/src/Yam/Internal.hs b/src/Yam/Internal.hs deleted file mode 100644 --- a/src/Yam/Internal.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE NoPolyKinds #-} -module Yam.Internal( - -- * Application Functions - startYam - ) where - -import qualified Data.Vault.Lazy as L -import Network.Wai.Handler.Warp -import Servant -import Servant.Swagger -import Yam.Logger -import Yam.Middleware -import Yam.Middleware.Default -import Yam.Swagger -import Yam.Types - -startYam - :: forall api. (HasSwagger api, HasServer api '[Env]) - => AppConfig - -> SwaggerConfig - -> IO LogConfig - -> Bool - -> Version - -> [AppMiddleware] - -> Proxy api - -> ServerT api App - -> IO () -startYam ac@AppConfig{..} sw@SwaggerConfig{..} logConfig enableDefaultMiddleware vs middlewares proxy server = - withLogger name logConfig $ do - logInfo $ "Start Service [" <> name <> "] ..." - logger <- askLoggerIO - let at = runAM $ foldr1 (<>) ((if enableDefaultMiddleware then defaultMiddleware else []) <> middlewares) - at (putLogger logger $ Env L.empty Nothing ac) $ \(env, middleware) -> do - let cxt = env :. EmptyContext - pCxt = Proxy @'[Env] - portText = showText port - settings = defaultSettings - & 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 - lift - $ runSettings settings - $ middleware - $ serveWithContextAndSwagger sw (baseInfo name vs port) (Proxy @(Vault :> api)) cxt - $ \v -> hoistServerWithContext proxy pCxt (transApp v env) server - -transApp :: Vault -> Env -> App a -> Handler a -transApp v b = liftIO . runApp b . local (\env -> env { reqAttributes = Just v}) - - diff --git a/src/Yam/Logger.hs b/src/Yam/Logger.hs --- a/src/Yam/Logger.hs +++ b/src/Yam/Logger.hs @@ -1,21 +1,22 @@ -{-# LANGUAGE ImplicitParams #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Yam.Logger( -- * Logger Function withLogger - , putLogger - , setExtendLog , getLogger , extensionLogKey - , throwS , LogConfig(..) + , HasLogger + , LogFuncHolder(..) + , VaultHolder(..) ) where +import Control.Monad.Logger.CallStack +import qualified Data.Vault.Lazy as L +import Data.Word import Salak -import qualified Data.Vault.Lazy as L -import System.IO.Unsafe (unsafePerformIO) +import System.IO.Unsafe (unsafePerformIO) import System.Log.FastLogger -import Yam.Types.Env -import Yam.Types.Prelude +import Yam.Prelude instance FromEnumProp LogLevel where fromEnumProp "debug" = Right LevelDebug @@ -32,12 +33,13 @@ toStr LevelError = "ERROR" toStr (LevelOther l) = toLogStr l +-- | Logger config data LogConfig = LogConfig - { bufferSize :: Word16 - , file :: FilePath - , maxSize :: Word32 - , rotateHistory :: Word16 - , level :: LogLevel + { bufferSize :: Word16 -- ^ Logger buffer size. + , file :: FilePath -- ^ Logger file path. + , maxSize :: Word32 -- ^ Max logger file size. + , rotateHistory :: Word16 -- ^ Max number of logger files should be reserved. + , level :: LogLevel -- ^ Log level to show. } deriving (Eq, Show) instance Default LogConfig where @@ -68,31 +70,29 @@ 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 -> IO LogConfig -> LoggingT IO a -> IO a -withLogger n lc action = bracket (newLogger n lc) snd $ \(f,_) -> runLoggingT action f +withLogger :: Text -> IO LogConfig -> (LogFunc -> LoggingT IO a) -> IO a +withLogger n lc action = bracket (newLogger n lc) snd $ \(f,_) -> runLoggingT (askLoggerIO >>= 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 :: L.Key LogFunc -loggerKey = unsafePerformIO newKey - {-# NOINLINE extensionLogKey #-} extensionLogKey :: L.Key Text -extensionLogKey = unsafePerformIO newKey - -setExtendLog :: (Text -> Text) -> Env -> Env -setExtendLog f env = let mt = fromMaybe "" $ getAttr extensionLogKey env in setAttr extensionLogKey (f mt) env - -putLogger :: LogFunc -> Env -> Env -putLogger = setAttr loggerKey +extensionLogKey = unsafePerformIO L.newKey -getLogger :: Env -> LogFunc -getLogger env = - let trace :: Maybe Text = getAttr extensionLogKey env - logger :: Maybe LogFunc = getAttr loggerKey env - {-# INLINE nlf #-} +getLogger :: Maybe VaultHolder -> LogFuncHolder -> LogFunc +getLogger (Just (VH vault)) (LF logger) = + let {-# INLINE nlf #-} nlf x (Just t) = addTrace x t nlf x _ = x - in maybe (\_ _ _ _ -> return ()) (`nlf` trace) logger + in nlf logger $ L.lookup extensionLogKey vault +getLogger _ (LF logger) = logger + +-- | Holder for 'LogFunc' +newtype LogFuncHolder = LF LogFunc +-- | Holder for 'Vault' +newtype VaultHolder = VH L.Vault + +-- | Context with logger. +type HasLogger cxt = (HasContextEntry cxt LogFuncHolder, TryContextEntry cxt VaultHolder) + diff --git a/src/Yam/Middleware.hs b/src/Yam/Middleware.hs deleted file mode 100644 --- a/src/Yam/Middleware.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ImplicitParams #-} -module Yam.Middleware( - AppMiddleware(..) - , simpleAppMiddleware - , simpleWebMiddleware - , simplePoolMiddleware - , runMiddleware - ) where - -import Yam.Logger -import Yam.Types - --- | Application Middleware -newtype AppMiddleware = AppMiddleware {runAM :: Env -> ((Env, Middleware)-> LoggingT IO ()) -> LoggingT IO ()} - -instance Monoid AppMiddleware where - mempty = AppMiddleware $ \a f -> f (a,id) -#if __GLASGOW_HASKELL__ >= 804 -instance Semigroup AppMiddleware where - (<>) = _append -#else - mappend = _append -#endif - - -_append (AppMiddleware am) (AppMiddleware bm) = AppMiddleware $ \e f -> am e $ \(e', mw) -> bm e' $ \(e'',mw') -> f (e'', mw . mw') - --- | Simple AppMiddleware -simpleAppMiddleware :: HasCallStack => (Bool, Text) -> Key a -> a -> AppMiddleware -simpleAppMiddleware (enabled,amname) k v = - v `seq` if enabled - then AppMiddleware $ \e f -> do - logInfoCS ?callStack $ "app:" <> 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 $ "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 () -runMiddleware (AppMiddleware f) a = liftIO $ withLogger "test" def $ do - lf <- askLoggerIO - f (putLogger lf def) $ \(e,_) -> liftIO $ void $ runApp e a diff --git a/src/Yam/Middleware/Auth.hs b/src/Yam/Middleware/Auth.hs deleted file mode 100644 --- a/src/Yam/Middleware/Auth.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# LANGUAGE CPP #-} -module Yam.Middleware.Auth( - -- * Auth Middleware - authAppMiddleware - , CheckAuth - , HasAuthKey(..) - , AuthChecker(..) - ) where -import Control.Lens -import Data.Swagger -import qualified Data.Vault.Lazy as L -import Servant -#if MIN_VERSION_servant_server(0,16,0) -import Servant.Server.Internal.Delayed -import Servant.Server.Internal.DelayedIO -#else -import Servant.Server.Internal.RoutingApplication -#endif -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 diff --git a/src/Yam/Middleware/Client.hs b/src/Yam/Middleware/Client.hs deleted file mode 100644 --- a/src/Yam/Middleware/Client.hs +++ /dev/null @@ -1,47 +0,0 @@ -module Yam.Middleware.Client( - -- * Client Middleware - ClientConfig(..) - , runClient - , clientMiddleware - , parseBaseUrl - , BaseUrl - ) where - -import qualified Data.Vault.Lazy as L -import Network.HTTP.Client -import Salak -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 FromProp ClientConfig where - fromProp = ClientConfig <$> "enabled" .?: enabled - -{-# NOINLINE managerKey #-} -managerKey :: L.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 diff --git a/src/Yam/Middleware/Default.hs b/src/Yam/Middleware/Default.hs deleted file mode 100644 --- a/src/Yam/Middleware/Default.hs +++ /dev/null @@ -1,15 +0,0 @@ -module Yam.Middleware.Default( - -- * Default Middleware - defaultMiddleware - ) where - -import Yam.Middleware -import Yam.Middleware.Client -import Yam.Middleware.Trace -import Yam.Types.Prelude - -defaultMiddleware :: [AppMiddleware] -defaultMiddleware = - [ traceMiddleware def - , clientMiddleware def - ] diff --git a/src/Yam/Middleware/Error.hs b/src/Yam/Middleware/Error.hs new file mode 100644 --- /dev/null +++ b/src/Yam/Middleware/Error.hs @@ -0,0 +1,13 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Yam.Middleware.Error where + +import Network.Wai +import Servant +import Yam.App +import Yam.Logger +import Yam.Prelude + +errorMiddleware :: HasLogger cxt => Context cxt -> Middleware +errorMiddleware cxt app req resH = app req resH `catch` (\e -> go e >> resH (whenException e)) + where + go = runVault cxt (vault req) . logError . showText 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 @@ -1,8 +1,8 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} module Yam.Middleware.Trace( -- * Trace Middleware - MonadTracer(..) - , MonadTracing(..) - , TraceConfig(..) + TraceConfig(..) + , Span(..) , hTraceId , hParentTraceId , hSpanId @@ -10,15 +10,19 @@ , traceMiddleware ) where -import qualified Data.HashMap.Lazy as HM +import Control.Monad.State +import Data.Default +import qualified Data.HashMap.Lazy as HM import Data.Opentracing -import qualified Data.Text as T -import qualified Data.Vault.Lazy as L +import qualified Data.Text as T +import qualified Data.Vault.Lazy as L +import Network.HTTP.Types +import Network.Wai import Salak -import System.IO.Unsafe (unsafePerformIO) +import Servant +import System.IO.Unsafe (unsafePerformIO) import Yam.Logger -import Yam.Middleware -import Yam.Types +import Yam.Prelude data TraceConfig = TraceConfig { enabled :: Bool @@ -40,30 +44,13 @@ instance Default TraceConfig where def = TraceConfig True NoTracer -notifier :: TraceNotifyType -> Span -> App () -notifier _ _ = return () - {-# NOINLINE spanContextKey #-} spanContextKey :: L.Key SpanContext -spanContextKey = unsafePerformIO newKey +spanContextKey = unsafePerformIO L.newKey {-# NOINLINE spanKey #-} spanKey :: L.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 +spanKey = unsafePerformIO L.newKey hTraceId :: HeaderName hTraceId = "X-B3-TraceId" @@ -77,45 +64,57 @@ hSampled :: HeaderName hSampled = "X-B3-Sampled" -parseSpan :: RequestHeaders -> Env -> IO Env -parseSpan headers env = - let sc = fromMaybe (SpanContext "" HM.empty) $ getAttr spanContextKey env +parseSpan :: RequestHeaders -> Vault -> IO Vault +parseSpan headers vault = + let sc = fromMaybe (SpanContext "" HM.empty) $ L.lookup spanContextKey vault in case Prelude.lookup hTraceId headers of Just tid -> let sc' = sc { traceId = tid } - in return $ env - & setAttr spanContextKey sc' - & go (fromMaybe (traceId sc') $ Prelude.lookup hSpanId headers) sc' + in return $ vault + & L.insert spanContextKey sc' + & go (fromMaybe tid $ Prelude.lookup hSpanId headers) sc' _ -> do c <- newContext - return $ setAttr spanContextKey c env + return $ L.insert spanContextKey c vault where - go spanId context env' = + go spanId context vault' = let name = "-" startTime = undefined finishTime = Nothing tags = HM.empty logs = HM.empty references = [] - in setAttr spanKey Span{..} env' + in L.insert spanKey Span{..} vault' -traceMw :: Env -> (Span -> App ()) -> Middleware -traceMw env' notify app req resH = do - env <- parseSpan (requestHeaders req) env' - runApp env $ - runInSpan (decodeUtf8 (requestMethod req) <> " /" <> T.intercalate "/" (pathInfo req)) notify $ \s@Span{..} -> do - let SpanContext{..} = context - tid = decodeUtf8 $ traceId <> "," <> spanId - v = L.insert extensionLogKey tid (vault req) - v' = L.insert spanKey s v - rh' = resH . mapResponseHeaders (\hs -> (hTraceId, traceId):(hSpanId, spanId):hs) - c e = do - runApp env { reqAttributes = Just v} (logError $ showText e) - rh' $ whenException e - liftIO (app req {vault = v'} rh' `catch` c) +instance MonadIO m => MonadTracer (StateT Request m) where + askSpanContext = do + req <- get + v <- liftIO $ parseSpan (requestHeaders req) (vault req) + put req { vault = v} + return $ fromJust $ L.lookup spanContextKey v -traceMiddleware :: TraceConfig -> AppMiddleware -traceMiddleware TraceConfig{..} - = AppMiddleware $ \env f -> if enabled - then f (env, traceMw env $ notifier method) - else f (env, id) +instance MonadIO m => MonadTracing (StateT Request m) where + runInSpan name nt a = do + req <- get + n <- case L.lookup spanKey $ vault req of + Just sp -> newChildSpan name sp + _ -> newSpan name + nt n + a' <- a n + finishSpan n >>= nt + return a' + +traceMiddleware :: (Vault -> Span -> IO ()) -> Middleware +traceMiddleware notify app req resH = (`evalStateT` req) + $ runInSpan (decodeUtf8 (requestMethod req) <> " /" <> T.intercalate "/" (pathInfo req)) go + $ \s@Span{..} -> do + let SpanContext{..} = context + tid = decodeUtf8 $ traceId <> "," <> spanId + v = L.insert extensionLogKey tid (vault req) + v' = L.insert spanKey s v + rh' = resH . mapResponseHeaders (\hs -> (hTraceId, traceId):(hSpanId, spanId):hs) + liftIO (app req {vault = v'} rh') + where + go s = do + req' <- get + liftIO (notify (vault req') s) diff --git a/src/Yam/Prelude.hs b/src/Yam/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Yam/Prelude.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ImplicitParams #-} + +module Yam.Prelude( + -- * Utilities + randomString + , showText + , throwS + , randomCode + , whenException + -- * Reexport Functions + , LogFunc + , Default(..) + , Text + , pack + , HasCallStack + , MonadError(..) + , MonadUnliftIO(..) + , SomeException(..) + , fromException + , bracket + , throw + , try + , catch + , when + , (<>) + , LogLevel(..) + , logInfo + , logError + , logWarn + , logDebug + , Loc(..) + , MonadIO(..) + , HasContextEntry(..) + , TryContextEntry(..) + , fromMaybe + , (&) + , decodeUtf8 + , encodeUtf8 + , fromJust + , Version + , Middleware + ) where + +import Control.Exception hiding (Handler) +import Control.Monad +import Control.Monad.Except +import Control.Monad.IO.Unlift +import Control.Monad.Logger.CallStack +import Data.Aeson +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 +import Data.Monoid ((<>)) +import Data.Text (Text, pack) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import qualified Data.Vector as V +import Data.Version +import Data.Word +import GHC.Stack +import Network.Wai +import Servant +import Servant.Server.Internal.ServerError +import System.IO.Unsafe (unsafePerformIO) +import System.Random.MWC + +type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO () + +{-# NOINLINE randomGen #-} +randomGen :: GenIO +randomGen = unsafePerformIO createSystemRandom + +-- | Utility +randomString :: IO ByteString +randomString = L.toStrict . B16.encode . B.encode <$> (uniform randomGen :: IO Word64) + +-- | Show text. +{-# INLINE showText #-} +showText :: Show a => a -> Text +showText = pack . show + +data WebErrResult = WebErrResult + { message :: Text + } + +instance ToJSON WebErrResult where + toJSON WebErrResult{..} = object [ "message" .= message ] + +-- | throw 'ServerError' with message +throwS + :: (HasCallStack, MonadIO m, MonadLogger m) + => ServerError -- ^ Server error + -> Text -- ^ message + -> m a +throwS e msg = do + logErrorCS ?callStack msg + liftIO $ throw e { errBody = encode $ WebErrResult msg} + +-- | Convert exception to 'Response' +whenException :: SomeException -> Response +whenException e = responseServerError $ fromMaybe err400 { errBody = encode $ WebErrResult $ showText e} (fromException e :: Maybe ServerError) + +-- | Utility +randomCode :: V.Vector Char -> Int -> IO String +randomCode seed v = do + let l = V.length seed + vs <- replicateM v (uniformR (0, l - 1) randomGen) + return $ (seed V.!) <$> vs + +-- | This class provide a optional supports for get entry from 'Context'. +class TryContextEntry (cxt :: [*]) (entry :: *) where + tryContextEntry :: Context cxt -> Maybe entry + +instance {-# OVERLAPPABLE #-} TryContextEntry as entry => TryContextEntry (a ': as) entry where + tryContextEntry (_ :. as) = tryContextEntry as + +instance {-# OVERLAPPABLE #-} TryContextEntry a entry where + tryContextEntry _ = Nothing + +instance TryContextEntry (entry ': as) entry where + tryContextEntry (a :. _) = Just a + + + + diff --git a/src/Yam/Swagger.hs b/src/Yam/Swagger.hs --- a/src/Yam/Swagger.hs +++ b/src/Yam/Swagger.hs @@ -7,32 +7,35 @@ import Control.Lens hiding (Context) import Data.Reflection -import Salak import Data.Swagger +import Data.Version (showVersion) +import Salak import Servant import Servant.Swagger import Servant.Swagger.UI -import Yam.Types.Prelude +import Yam.Prelude +-- | Swagger Configuration data SwaggerConfig = SwaggerConfig - { urlDir :: String - , urlSchema :: String - , enabled :: Bool + { urlDir :: String -- ^ Url path for swagger. + , urlSchema :: String -- ^ Api schema path for swagger. + , enabled :: Bool -- ^ If enable swagger. } deriving (Eq, Show) instance FromProp SwaggerConfig where fromProp = SwaggerConfig - <$> "dir" .?= "swagger-ui" + <$> "dir" .?= "swagger-ui" <*> "schema" .?= "swagger-ui.json" <*> "enabled" .?= True +-- | Serve with swagger. serveWithContextAndSwagger :: forall api context. (HasSwagger api, HasServer api context) - => SwaggerConfig - -> (Swagger -> Swagger) - -> Proxy api - -> Context context - -> ServerT api Handler + => SwaggerConfig -- ^ Swagger configuration. + -> (Swagger -> Swagger) -- ^ Swagger modification. + -> Proxy api -- ^ Application API Proxy. + -> Context context -- ^ Application context. + -> ServerT api Handler -- ^ Application API Server -> Application serveWithContextAndSwagger SwaggerConfig{..} g5 proxy cxt api = if enabled @@ -43,11 +46,18 @@ go :: forall dir schema. Proxy api -> Proxy dir -> Proxy schema -> Proxy (SwaggerSchemaUI dir schema :<|> api) go _ _ _ = Proxy -baseInfo :: Text -> Version -> Int -> Swagger -> Swagger -baseInfo n v p s = s +-- | Swagger modification +baseInfo + :: String -- ^ Hostname + -> Text -- ^ Server Name + -> Version -- ^ Server version + -> Int -- ^ Port + -> Swagger -- ^ Old swagger + -> Swagger +baseInfo hostName n v p s = s & info . title .~ n - & info . version .~ showText v - & host ?~ Host "localhost" (Just $ fromIntegral p) + & info . version .~ pack (showVersion v) + & host ?~ Host hostName (Just $ fromIntegral p) diff --git a/src/Yam/Types.hs b/src/Yam/Types.hs deleted file mode 100644 --- a/src/Yam/Types.hs +++ /dev/null @@ -1,61 +0,0 @@ -module Yam.Types( - -- * App Monad - App - , runApp - , runTestApp - , askApp - , askAttr - , withAttr - , requireAttr - , module Yam.Types.Env - , module Yam.Types.Prelude - ) where - -import Data.Menshen -import Servant (err400) -import Yam.Logger -import Yam.Types.Env -import Yam.Types.Prelude - -newtype App a = App { runApp' :: ReaderT Env IO a } deriving - ( Functor - , Applicative - , 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 - -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 - env <- ask - App $ withRunInIO (\g -> f $ g . lift . runApp env) - -instance MonadLogger App where - monadLoggerLog a b c d = do - env <- ask - liftIO $ getLogger env a b c $ toLogStr d - -instance MonadLoggerIO App where - askLoggerIO = asks getLogger - -askApp :: App AppConfig -askApp = asks application - -requireAttr :: Key a -> App a -requireAttr k = fromJust <$> askAttr k - -askAttr :: Key a -> App (Maybe a) -askAttr = asks . getAttr - -withAttr :: Key a -> a -> App b -> App b -withAttr k v = local (setAttr k v) - - diff --git a/src/Yam/Types/Env.hs b/src/Yam/Types/Env.hs deleted file mode 100644 --- a/src/Yam/Types/Env.hs +++ /dev/null @@ -1,47 +0,0 @@ -module Yam.Types.Env( - -- * Environment - AppConfig(..) - , Env(..) - , getAttr - , reqAttr - , setAttr - ) where - -import Salak -import qualified Data.Vault.Lazy as L -import Yam.Types.Prelude - -data AppConfig = AppConfig - { name :: Text - , port :: Int - , slowlorisSize :: Int -- Bytes - } deriving (Eq, Show) - -instance Default AppConfig where - def = AppConfig "application" 8888 2048 - -instance FromProp AppConfig where - fromProp = AppConfig - <$> "name" .?: name - <*> "port" .?: port - <*> "slowloris-size" .?: slowlorisSize - -data Env = Env - { attributes :: Vault - , reqAttributes :: Maybe Vault - , application :: AppConfig - } - -instance Default Env where - def = Env L.empty Nothing def - -getAttr :: L.Key a -> Env -> Maybe a -getAttr k Env{..} = (reqAttributes >>= L.lookup k) <|> L.lookup k attributes - -reqAttr :: Default a => L.Key a -> Env -> a -reqAttr k = fromMaybe def . getAttr k - -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 deleted file mode 100644 --- a/src/Yam/Types/Prelude.hs +++ /dev/null @@ -1,113 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE UndecidableInstances #-} - -module Yam.Types.Prelude( - -- * Utilities - randomString - , showText - , throwS - , randomCode - , whenException - -- * Reexport Functions - , LogFunc - , Default(..) - , Text - , pack - , HasCallStack - , MonadError(..) - , MonadUnliftIO(..) - , SomeException(..) - , fromException - , bracket - , throw - , try - , catch - , (<>) - , module Data.Proxy - , module Data.Vault.Lazy - , module Data.Maybe - , module Data.Word - , module Data.Text.Encoding - , module Data.Function - , module Data.Version - , module Control.Applicative - , module Control.Monad - , module Control.Monad.Reader - , module Control.Monad.Logger.CallStack - , module Network.Wai - , module Network.HTTP.Types - ) where - -import Control.Applicative -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 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 -import Data.Monoid ((<>)) -import Data.Proxy -import Data.Text (Text, pack) -import Data.Text.Encoding (decodeUtf8, encodeUtf8) -import Data.Vault.Lazy (Key, Vault, newKey) -import qualified Data.Vector as V -import Data.Version -import Data.Word -import GHC.Stack -import Network.HTTP.Types -import Network.Wai -import Servant -import System.IO.Unsafe (unsafePerformIO) -import System.Random.MWC -#if MIN_VERSION_servant_server(0,16,0) -import Servant.Server.Internal.ServerError -type ServantErr = ServerError -responseServantErr = responseServerError -#else -import Servant.Server.Internal.ServantErr -#endif - -type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO () - -{-# NOINLINE randomGen #-} -randomGen :: GenIO -randomGen = unsafePerformIO createSystemRandom - --- | Utility -randomString :: IO ByteString -randomString = L.toStrict . B16.encode . B.encode <$> (uniform randomGen :: IO Word64) - -{-# INLINE showText #-} -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 { errBody = encode $ WebErrResult msg} - -whenException :: SomeException -> Response -whenException e = responseServantErr $ fromMaybe err400 (fromException e :: Maybe ServantErr) - --- | Utility -randomCode :: V.Vector Char -> Int -> IO String -randomCode seed v = do - let l = V.length seed - vs <- sequence $ replicate v $ uniformR (0,l-1) randomGen - return $ (seed V.!) <$> vs diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -7,17 +7,18 @@ import qualified Data.ByteString as B import Test.Hspec import Test.QuickCheck.Monadic -import Yam +import Yam.Prelude +main :: IO () main = hspec spec spec :: Spec spec = do describe "Yam.Config" specConfig - -specConfig = do - context "randomTest" $ do - it "random" $ do - monadicIO $ do - s <- run $ randomString - assert (B.length s == 16) + where + specConfig = do + context "randomTest" $ do + it "random" $ do + monadicIO $ do + s <- run $ randomString + assert (B.length s == 16) diff --git a/yam.cabal b/yam.cabal --- a/yam.cabal +++ b/yam.cabal @@ -1,13 +1,15 @@ cabal-version: 1.12 name: yam -version: 0.5.17 +version: 0.6.0 license: BSD3 license-file: LICENSE copyright: (c) 2018 Daniel YU maintainer: Daniel YU author: Daniel YU -homepage: https://github.com/leptonyu/yam/yam#readme -synopsis: Yam Web +homepage: https://github.com/leptonyu/yam#readme +synopsis: A wrapper of servant +description: + A out-of-the-box wrapper of [servant](https://hackage.haskell.org/package/servant-server). category: Web build-type: Simple extra-source-files: @@ -17,19 +19,15 @@ library exposed-modules: Yam - Yam.Internal - Yam.Middleware - Yam.Middleware.Default - Yam.Middleware.Auth - Yam.Middleware.Trace - Yam.Middleware.Client - Yam.Swagger - Yam.Types - Yam.Logger hs-source-dirs: src other-modules: - Yam.Types.Prelude - Yam.Types.Env + Yam.Swagger + Yam.Logger + Yam.App + Yam.Prelude + Yam.Config + Yam.Middleware.Trace + Yam.Middleware.Error Data.Opentracing Data.Opentracing.Types Data.Opentracing.Tracer @@ -47,7 +45,7 @@ RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeOperators TypeSynonymInstances ViewPatterns - ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures + ghc-options: -Wall build-depends: aeson >=1.4.2.0 && <1.5, base >=4.10 && <5, @@ -55,25 +53,23 @@ binary >=0.8.6.0 && <0.9, 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.7, + fast-logger >=2.4.15 && <2.5, http-types >=0.12.3 && <0.13, lens ==4.17.*, - menshen >=0.0.2 && <0.1, + menshen >=0.0.3 && <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.10 && <0.3, + salak >=0.2.9 && <0.3, scientific >=0.3.6.2 && <0.4, - servant-client >=0.15 && <0.17, - servant-server >=0.15 && <0.17, + servant-server ==0.16.*, servant-swagger >=1.1.7 && <1.2, servant-swagger-ui >=0.3.2.3.19.3 && <0.4, swagger2 >=2.3.1.1 && <2.4, text >=1.2.3.1 && <1.3, unliftio-core >=0.1.2.0 && <0.2, - unordered-containers >=0.2.9.0 && <0.3, + unordered-containers >=0.2.10.0 && <0.3, vault >=0.3.1.2 && <0.4, vector >=0.12.0.2 && <0.13, wai >=3.2.2 && <3.3, @@ -89,17 +85,13 @@ Data.Opentracing.Tracer Data.Opentracing.Types Yam - Yam.Internal + Yam.App + Yam.Config Yam.Logger - Yam.Middleware - Yam.Middleware.Auth - Yam.Middleware.Client - Yam.Middleware.Default + Yam.Middleware.Error Yam.Middleware.Trace + Yam.Prelude Yam.Swagger - Yam.Types - Yam.Types.Env - Yam.Types.Prelude Paths_yam default-language: Haskell2010 default-extensions: AutoDeriveTypeable BangPatterns BinaryLiterals @@ -114,7 +106,7 @@ RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeOperators TypeSynonymInstances ViewPatterns - ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures + ghc-options: -Wall build-depends: QuickCheck >=2.12.6.1 && <2.14, aeson >=1.4.2.0 && <1.5, @@ -123,26 +115,24 @@ binary >=0.8.6.0 && <0.9, bytestring >=0.10.8.2 && <0.11, data-default >=0.7.1.1 && <0.8, - fast-logger >=2.4.13 && <2.5, + fast-logger >=2.4.15 && <2.5, hspec ==2.*, - http-client >=0.5.14 && <0.7, http-types >=0.12.3 && <0.13, lens ==4.17.*, - menshen >=0.0.2 && <0.1, + menshen >=0.0.3 && <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.10 && <0.3, + salak >=0.2.9 && <0.3, scientific >=0.3.6.2 && <0.4, - servant-client >=0.15 && <0.17, - servant-server >=0.15 && <0.17, + servant-server ==0.16.*, servant-swagger >=1.1.7 && <1.2, servant-swagger-ui >=0.3.2.3.19.3 && <0.4, swagger2 >=2.3.1.1 && <2.4, text >=1.2.3.1 && <1.3, unliftio-core >=0.1.2.0 && <0.2, - unordered-containers >=0.2.9.0 && <0.3, + unordered-containers >=0.2.10.0 && <0.3, vault >=0.3.1.2 && <0.4, vector >=0.12.0.2 && <0.13, wai >=3.2.2 && <3.3,