yam-web (empty) → 0.3.0
raw patch · 7 files changed
+244/−0 lines, 7 filesdep +aesondep +basedep +data-defaultsetup-changed
Dependencies added: aeson, base, data-default, lens, mtl, reflection, servant-server, servant-swagger, servant-swagger-ui, string-conversions, swagger2, text, transformers, vault, wai, wai-extra, warp, yam-logger
Files
- README.md +1/−0
- Setup.hs +2/−0
- src/Yam/Web.hs +19/−0
- src/Yam/Web/Internal.hs +40/−0
- src/Yam/Web/Middleware.hs +32/−0
- src/Yam/Web/Swagger.hs +94/−0
- yam-web.cabal +56/−0
+ README.md view
@@ -0,0 +1,1 @@+# yam-web
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Yam/Web.hs view
@@ -0,0 +1,19 @@+module Yam.Web(+ module Yam.Web.Internal+ , module Yam.Web.Swagger+ , module Yam.Web.Middleware+ , runDemo+ ) where++import Yam.Web.Internal hiding (API', mkServe')+import Yam.Web.Middleware+import Yam.Web.Swagger++import Data.Proxy+import Network.Wai.Handler.Warp (run)+import Servant++runDemo :: IO ()+runDemo = do+ ys <- defaultYamSettings+ run 8080 $ mkServeWithSwagger ys (Proxy :: Proxy EmptyAPI) undefined
+ src/Yam/Web/Internal.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE NoPolyKinds #-}++module Yam.Web.Internal(+ prepareMiddleware+ , errorMiddleware+ , API+ , API'+ , mkServe+ , mkServe'+ , AppM+ , App+ ) where++import Yam.Web.Middleware++import Control.Monad.Trans.Reader (ReaderT (..), runReaderT)+import Data.Foldable (foldr')+import Data.Vault.Lazy+import Network.Wai+import Servant++type API api = HasServer api '[Vault]+type AppM = ReaderT Vault+type App = AppM Handler++runAppM :: Vault -> AppM m a -> m a+runAppM = flip runReaderT++type API' api = (Proxy api, Server api)++mkServe' :: (API api, API api') => (API' api -> API' api') -> Vault -> [Middleware] -> Proxy api -> ServerT api App -> Application+mkServe' f vault middlewares proxy server =+ let server' = hoistServerWithContext proxy (Proxy :: Proxy '[Vault]) (runAppM vault :: App a -> Handler a) server+ (p,s) = f (proxy, server')+ app = serveWithContext p (vault :. EmptyContext) s+ m = prepareMiddleware (return . union vault)+ in foldr' ($) app $ m:servantErrorMiddleware:middlewares++mkServe :: API api => Vault -> [Middleware] -> Proxy api -> ServerT api App -> Application+mkServe = mkServe' id
+ src/Yam/Web/Middleware.hs view
@@ -0,0 +1,32 @@+module Yam.Web.Middleware where++import Yam.Logger++import Control.Exception+ ( SomeException+ , catch+ , throw+ )+import Data.Default+import Data.String.Conversions (cs)+import Data.Vault.Lazy+import Network.Wai+import Network.Wai.Middleware.RequestLogger+import Servant.Server++prepareMiddleware :: (Vault -> IO Vault) -> Middleware+prepareMiddleware pre app req resH = do+ vault' <- pre $ vault req+ app req {vault = vault'} resH++errorMiddleware :: (Request -> SomeException -> IO Response) -> Middleware+errorMiddleware f app req resH = app req resH `catch` (\e -> f req e >>= resH)++loggerMiddleware :: LoggerConfig -> IO Middleware+loggerMiddleware lc@LoggerConfig{..} = mkRequestLogger def {destination=Callback $ logger lc {names = "Request":names} INFO}++stdLoggerMiddleware :: IO Middleware+stdLoggerMiddleware = stdoutLoggerConfig >>= loggerMiddleware++servantErrorMiddleware :: Middleware+servantErrorMiddleware = errorMiddleware $ \_ e -> throw err400 { errBody = cs $ show e}
+ src/Yam/Web/Swagger.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE NoPolyKinds #-}++module Yam.Web.Swagger(+ SwaggerConfig(..)+ , mkServeWithSwagger+ , YamSettings(..)+ , defaultYamSettings+ ) where++import Control.Lens hiding (Context)+import Data.Aeson+import Data.Aeson.Types (typeMismatch)+import Data.Default+import Data.Maybe+import Data.Reflection+import Data.Swagger+import Data.Text (Text)+import Data.Vault.Lazy+import GHC.TypeLits+import Network.Wai+import Servant+import Servant.Swagger+import Servant.Swagger.UI++import Yam.Web.Internal+import Yam.Web.Middleware++data SwaggerUIType = Classic | Jensoleg deriving Show+data SwaggerConfig = SwaggerConfig+ { uiType :: SwaggerUIType+ , uiPath :: String+ , apiPath :: String+ , enabled :: Bool+ , apiTitle :: Text+ , apiVersion :: Text+ , contractName :: Maybe Text+ , contractEmail :: Maybe Text+ } deriving Show++instance FromJSON SwaggerUIType where+ parseJSON v = go <$> parseJSON v+ where go :: Text -> SwaggerUIType+ go "default" = Classic+ go _ = Jensoleg++instance FromJSON SwaggerConfig where+ parseJSON (Object v) = SwaggerConfig+ <$> v .:? "ui-type" .!= Classic+ <*> v .:? "ui-path" .!= "swagger-ui.html"+ <*> v .:? "api-path" .!= "swagger.json"+ <*> v .:? "enabled" .!= True+ <*> v .:? "api-title" .!= ""+ <*> v .:? "api-version" .!= "1.0.0"+ <*> v .:? "contract-name"+ <*> v .:? "contract-email"+ parseJSON invalid = typeMismatch "SwaggerConfig" invalid++instance Default SwaggerConfig where+ def = fromJust $ decode "{}"++swagger :: (HasSwagger api) => SwaggerConfig -> Proxy (SwaggerSchemaUI dir schema :<|> api) -> Proxy api -> Server api -> Server (SwaggerSchemaUI dir schema :<|> api)+swagger conf _ proxy api = go (uiType conf) (f conf $ toSwagger proxy) :<|> api+ where go Jensoleg = jensolegSwaggerSchemaUIServer+ go _ = swaggerSchemaUIServer+ f SwaggerConfig{..} s = s+ & info.title .~ apiTitle+ & info.version .~ apiVersion+ & info.contact ?~ Contact contractName Nothing contractEmail++mkServeWithSwagger' :: (HasSwagger api, API api) => Vault -> [Middleware] -> SwaggerConfig -> Proxy api -> ServerT api App -> Application+mkServeWithSwagger' vault middlewares conf proxy server =+ if enabled conf+ then reifyGroup conf $ \p -> mkServe' (\(p0,s0) -> (p,swagger conf p p0 s0)) vault middlewares proxy server+ else mkServe' id vault middlewares proxy server++reifyGroup :: SwaggerConfig -> (forall d s. (KnownSymbol d ,KnownSymbol s)=> Proxy (SwaggerSchemaUI d s :<|> api) -> r) -> r+reifyGroup SwaggerConfig{..} f = reifySymbol uiPath $ \pd -> reifySymbol apiPath $ \ps -> f $ group pd ps++group :: Proxy dir -> Proxy schema -> Proxy (SwaggerSchemaUI dir schema :<|> api)+group _ _ = Proxy++data YamSettings = YamSettings+ { vault :: Vault+ , middlewares :: [Middleware]+ , swaggers :: SwaggerConfig+ }++defaultYamSettings :: IO YamSettings+defaultYamSettings = do+ lm <- stdLoggerMiddleware+ return $ YamSettings empty [lm] def++mkServeWithSwagger :: (HasSwagger api, API api) => YamSettings -> Proxy api -> ServerT api App -> Application+mkServeWithSwagger YamSettings{..} = mkServeWithSwagger' vault middlewares swaggers
+ yam-web.cabal view
@@ -0,0 +1,56 @@+-- This file has been generated from package.yaml by hpack version 0.28.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: d15cc9bf9d7ccbadc13a7dccd30b471542854ac6ffcbc74ae1953e8d3a7b8068++name: yam-web+version: 0.3.0+synopsis: Yam Web+description: base web module for yam+category: Project+homepage: https://github.com/leptonyu/yam#readme+bug-reports: https://github.com/leptonyu/yam/issues+maintainer: Daniel YU <leptonyu@gmail.com>+license: MIT+build-type: Simple+cabal-version: >= 1.10+extra-source-files:+ README.md++source-repository head+ type: git+ location: https://github.com/leptonyu/yam++library+ exposed-modules:+ Yam.Web.Swagger+ Yam.Web.Internal+ Yam.Web.Middleware+ other-modules:+ Yam.Web+ Paths_yam_web+ hs-source-dirs:+ src+ default-extensions: AutoDeriveTypeable BangPatterns BinaryLiterals ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DuplicateRecordFields DoAndIfThenElse EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns OverloadedStrings PartialTypeSignatures PatternGuards PolyKinds RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeOperators TypeSynonymInstances ViewPatterns+ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-orphans+ build-depends:+ aeson+ , base >=4.7 && <5+ , data-default+ , lens+ , mtl+ , reflection+ , servant-server+ , servant-swagger+ , servant-swagger-ui+ , string-conversions+ , swagger2+ , text+ , transformers+ , vault+ , wai+ , wai-extra+ , warp+ , yam-logger+ default-language: Haskell2010