diff --git a/demo/Main.hs b/demo/Main.hs new file mode 100644 --- /dev/null +++ b/demo/Main.hs @@ -0,0 +1,43 @@ +module Main where + +import Yam.Logger +import Yam.Transaction +import Yam.Web + +import Control.Exception (throw) +import Data.Text (Text, pack) +import Servant + +type UserApi + = "users" :> Get '[JSON] Text + :<|> "users" :> "error" :> Get '[JSON] Text + :<|> "users" :> "servant" :> Get '[JSON] Text + :<|> "users" :> "db" :> Get '[JSON] Text + +userService :: Yam Text +userService = do + (r,_) <- ask + errorLn $ "Hello: " <> toLogStr (show r) + return "Hello" + +errorService :: Yam Text +errorService = error "No" + +servantService :: Yam Text +servantService = throw err401 + +dbService :: Yam Text +dbService = do + str <- runDb $ do + time <- selectNow + let timeStr = pack $ show time + warnLn timeStr + return timeStr + infoLn str + return str + +main :: IO () +main = do + ys <- defaultYamSettings + logger (loggers ys) INFO (toLogStr (show ys) <> "\n") + runServer ys (Proxy :: Proxy UserApi) (userService :<|> errorService :<|> servantService :<|> dbService) diff --git a/src/Yam/Web.hs b/src/Yam/Web.hs --- a/src/Yam/Web.hs +++ b/src/Yam/Web.hs @@ -1,19 +1,101 @@ +{-# LANGUAGE NoPolyKinds #-} + module Yam.Web( module Yam.Web.Internal , module Yam.Web.Swagger , module Yam.Web.Middleware - , runDemo + , YamSettings(..) + , Yam + , defaultYamSettings + , runDb + , runServer ) where -import Yam.Web.Internal hiding (API', mkServe') +import Yam.Config +import Yam.Config.Vault +import Yam.Logger +import Yam.Transaction +import Yam.Transaction.Postgresql +import Yam.Transaction.Sqlite +import Yam.Web.Internal import Yam.Web.Middleware import Yam.Web.Swagger +import Control.Exception (finally, throw) +import Control.Monad.IO.Unlift +import Control.Monad.Trans.Except (runExceptT) +import Data.Aeson +import Data.Default +import Data.Monoid ((<>)) import Data.Proxy -import Network.Wai.Handler.Warp (run) +import Network.Wai +import Network.Wai.Handler.Warp (run) import Servant +import Servant.Swagger -runDemo :: IO () -runDemo = do - ys <- defaultYamSettings - run 8080 $ mkServeWithSwagger ys (Proxy :: Proxy EmptyAPI) undefined +data YamSettings = YamSettings + { port :: Int + , middlewares :: [Middleware] + , loggers :: LoggerConfig + , swaggers :: SwaggerConfig + , dataSources :: Maybe DataSource + } + +instance Show YamSettings where + show YamSettings{..} + = "YAM Settings:" + <> "\n port=" <> show port + <> "\n swagger=" <> show swaggers + <> "\n swagger-url=http://localhost:" <> show port <> "/" <> uiPath swaggers + <> "\n datasource=" <> show dataSources + +defaultYamSettings :: IO YamSettings +defaultYamSettings = do + c <- defaultConfig + f <- getValueOrDef "app.yaml" "yam.conf" c + conf <- merge' [return c, fromFile f False] :: IO Value + swaggers <- getValueOrDef def "yam.swagger" conf :: IO SwaggerConfig + rk <- getValueOrDef INFO "yam.log.level" conf + port <- getValueOrDef 8080 "yam.port" conf + lc' <- stdoutLoggerConfig + gtc <- randomString + let loggers = lc' { rank = rk , logVault = addFirstVault ("[" <> gtc <> "]") "." (logKey lc') $ logVault lc'} + middlewares = [traceMiddleware $ traceKey loggers, apacheMiddleware loggers, servantErrorMiddleware loggers] + dsc <- getValueOrDef def "yam.datasource" conf :: IO DataSourceConfig + dataSources <- if Yam.Transaction.enabled dsc + then Just <$> dataSource loggers dsc [sqliteProvider,postgresqlProvider] + else return Nothing + logger loggers DEBUG $ "Load config file " <> toLogStr f <> "\n" + return YamSettings{..} + +type Yam = App YamSettings + +instance LoggerMonad Yam where + loggerConfig = do + (req,YamSettings{..}) <- ask + return loggers {logVault = vault req} + +instance MonadUnliftIO Handler where + askUnliftIO = return $ UnliftIO go + where + go (Handler rh) = do + result <- runExceptT rh + case result of + Left e -> throw e + Right r -> return r + +runDb :: Transaction Yam a -> Yam a +runDb r = do + (_,YamSettings{..}) <- ask + case dataSources of + Nothing -> error $ "Datasource disabled" + Just ds -> runTrans ds r + +runServer :: (HasSwagger api, HasServer api '[YamSettings]) => YamSettings -> Proxy api -> ServerT api Yam -> IO () +runServer ys@YamSettings{..} p a = run port (mkServeWithSwagger p Proxy (ys :. EmptyContext) Proxy ys middlewares swaggers a) `finally` go loggers dataSources + where + go l = \case + Nothing -> return () + Just d -> closeDataSource l d + + diff --git a/src/Yam/Web/Internal.hs b/src/Yam/Web/Internal.hs --- a/src/Yam/Web/Internal.hs +++ b/src/Yam/Web/Internal.hs @@ -1,40 +1,77 @@ {-# LANGUAGE NoPolyKinds #-} module Yam.Web.Internal( - prepareMiddleware - , errorMiddleware - , API - , API' - , mkServe + mkServe , mkServe' + , ask , AppM , App + , ReqApp ) where -import Yam.Web.Middleware - -import Control.Monad.Trans.Reader (ReaderT (..), runReaderT) -import Data.Foldable (foldr') -import Data.Vault.Lazy +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Reader +import Data.Foldable (foldr') import Network.Wai import Servant +import Servant.Server.Internal.Router +import Servant.Server.Internal.RoutingApplication -type API api = HasServer api '[Vault] -type AppM = ReaderT Vault -type App = AppM Handler +type AppM c = ReaderT (Request, c) +type App c = AppM c Handler +type ReqApp = ReaderT Request Handler -runAppM :: Vault -> AppM m a -> m a -runAppM = flip runReaderT +serveWithContext' :: HasServer api context => Proxy api -> Proxy context -> Context context -> (Request -> ServerT api ReqApp) -> Application +serveWithContext' p pc context server = toApplication (runRouter (route p context (go (go2 p pc) $ emptyDelayed (Route server)))) + where + go :: (Request -> a -> b) -> Delayed env a -> Delayed env b + go f Delayed{..} = Delayed + { serverD = \ c p' h a b req -> f req <$> serverD c p' h a b req + , .. + } + go2 :: HasServer api context => Proxy api -> Proxy context -> Request -> (Request -> ServerT api ReqApp) -> Server api + go2 p2 pc2 req sar = downR p2 pc2 req (sar req) -type API' api = (Proxy api, Server api) +mkServe' :: (HasServer api context, HasServer api' context) + => (Server api -> Server api') + -> Proxy api' + -> Proxy api + -> Proxy context + -> Context context + -> Proxy c + -> c + -> [Middleware] + -> ServerT api (App c) + -> Application +mkServe' f p' proxy pcxt cxt pc c middlewares server = + let server' = hoistServerWithContext proxy pcxt (tranR pc c) server + s = fix1 proxy p' pcxt f server' + app = serveWithContext' p' pcxt cxt s + in foldr' ($) app middlewares -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 :: HasServer api context + => Proxy api + -> Proxy context + -> Context context + -> Proxy c + -> c + -> [Middleware] + -> ServerT api (App c) + -> Application +mkServe p = mkServe' id p p -mkServe :: API api => Vault -> [Middleware] -> Proxy api -> ServerT api App -> Application -mkServe = mkServe' id +tranR :: Proxy c -> c -> App c m -> ReqApp m +tranR _ c = withReaderT (,c) + +fix1 :: (HasServer api context, HasServer api' context) => Proxy api -> Proxy api' -> Proxy context -> (Server api -> Server api') -> ServerT api ReqApp -> Request -> ServerT api' ReqApp +fix1 p p' pc f sar req = liftR p' pc $ f (downR p pc req sar) + + +downR :: HasServer api context => Proxy api -> Proxy context -> Request -> ServerT api ReqApp -> Server api +downR p2 pc2 req = hoistServerWithContext p2 pc2 (flip runReaderT req :: ReqApp m -> Handler m) + +liftR :: HasServer api context => Proxy api -> Proxy context -> Server api -> ServerT api ReqApp +liftR p pc = hoistServerWithContext p pc go + where + go :: Handler m -> ReqApp m + go = lift diff --git a/src/Yam/Web/Middleware.hs b/src/Yam/Web/Middleware.hs --- a/src/Yam/Web/Middleware.hs +++ b/src/Yam/Web/Middleware.hs @@ -1,18 +1,23 @@ module Yam.Web.Middleware where +import Yam.Config.Vault import Yam.Logger import Control.Exception ( SomeException , catch - , throw + , fromException ) -import Data.Default -import Data.String.Conversions (cs) +import Control.Monad ((>=>)) +import Data.Maybe +import Data.Monoid ((<>)) +import Data.String.Conversions (cs) +import Data.Text (Text) import Data.Vault.Lazy import Network.Wai -import Network.Wai.Middleware.RequestLogger +import Network.Wai.Header import Servant.Server +import Servant.Server.Internal.ServantErr (responseServantErr) prepareMiddleware :: (Vault -> IO Vault) -> Middleware prepareMiddleware pre app req resH = do @@ -20,13 +25,37 @@ 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) +errorMiddleware f app req resH = app req resH `catch` (f req >=> resH) -loggerMiddleware :: LoggerConfig -> IO Middleware -loggerMiddleware lc@LoggerConfig{..} = mkRequestLogger def {destination=Callback $ logger lc {names = "Request":names} INFO} +apacheMiddleware :: LoggerConfig -> Middleware +apacheMiddleware lc app req sendResponse = app req $ \res -> do + let msize = contentLength (responseHeaders res) + logstr = "\"" + <> toLogStr (requestMethod req) + <> " " + <> toLogStr (rawPathInfo req) + <> toLogStr (rawQueryString req) + <> " " + <> toLogStr (show $ httpVersion req) + <> "\" " + <> toLogStr (maybe "-" show msize) + <> " \"" + <> toLogStr (fromMaybe "" $ requestHeaderReferer req) + <> "\" \"" + <> toLogStr (fromMaybe "" $ requestHeaderUserAgent req) + <> "\"\n" + logger lc {logVault = vault req} INFO logstr + sendResponse res stdLoggerMiddleware :: IO Middleware -stdLoggerMiddleware = stdoutLoggerConfig >>= loggerMiddleware +stdLoggerMiddleware = apacheMiddleware <$> stdoutLoggerConfig -servantErrorMiddleware :: Middleware -servantErrorMiddleware = errorMiddleware $ \_ e -> throw err400 { errBody = cs $ show e} +servantErrorMiddleware :: LoggerConfig -> Middleware +servantErrorMiddleware lc = errorMiddleware $ \req e -> do + logger lc {logVault = vault req} ERROR (toLogStr $ show e) + return . responseServantErr $ fromMaybe err400 { errBody = cs $ show e } (fromException e :: Maybe ServantErr) + +traceMiddleware :: Key Text -> Middleware +traceMiddleware k = prepareMiddleware $ \vault -> do + traceId <- randomString + return $ insert k traceId vault diff --git a/src/Yam/Web/Swagger.hs b/src/Yam/Web/Swagger.hs --- a/src/Yam/Web/Swagger.hs +++ b/src/Yam/Web/Swagger.hs @@ -3,8 +3,6 @@ module Yam.Web.Swagger( SwaggerConfig(..) , mkServeWithSwagger - , YamSettings(..) - , defaultYamSettings ) where import Control.Lens hiding (Context) @@ -15,7 +13,6 @@ import Data.Reflection import Data.Swagger import Data.Text (Text) -import Data.Vault.Lazy import GHC.TypeLits import Network.Wai import Servant @@ -23,7 +20,6 @@ import Servant.Swagger.UI import Yam.Web.Internal -import Yam.Web.Middleware data SwaggerUIType = Classic | Jensoleg deriving Show data SwaggerConfig = SwaggerConfig @@ -45,14 +41,14 @@ 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" + <$> v .:? "type" .!= Classic + <*> v .:? "path" .!= "swagger-ui.html" + <*> v .:? "schema" .!= "swagger.json" + <*> v .:? "enabled" .!= True + <*> v .:? "title" .!= "" + <*> v .:? "version" .!= "1.0.0" + <*> v .:? "name" + <*> v .:? "email" parseJSON invalid = typeMismatch "SwaggerConfig" invalid instance Default SwaggerConfig where @@ -67,28 +63,24 @@ & 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 = +mkServeWithSwagger + :: (HasSwagger api, HasServer api context) + => Proxy api + -> Proxy context + -> Context context + -> Proxy c + -> c + -> [Middleware] + -> SwaggerConfig + -> ServerT api (App c) + -> Application +mkServeWithSwagger proxy pcxt cxt pc c middlewares conf 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 + then reifyGroup conf $ \p -> mkServe' (swagger conf p proxy) p proxy pcxt cxt pc c middlewares server + else mkServe proxy pcxt cxt pc c middlewares 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 diff --git a/yam-web.cabal b/yam-web.cabal --- a/yam-web.cabal +++ b/yam-web.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: d64cdd2846d745ae5445826c4d8187543234b27d35125751df4bf37e71376384 +-- hash: 0b72633679c8414dad55b9d67c58c29ccc14a7bcda4fb05be0e849f4163e17a0 name: yam-web -version: 0.3.1 +version: 0.3.2 synopsis: Yam Web description: base web module for yam category: Project @@ -38,7 +38,6 @@ , base >=4.7 && <5 , data-default , lens - , mtl , reflection , servant-server , servant-swagger @@ -47,9 +46,44 @@ , swagger2 , text , transformers + , unliftio-core , vault , wai , wai-extra , warp + , yam-config , yam-logger + , yam-transaction + default-language: Haskell2010 + +executable yam-web + main-is: Main.hs + other-modules: + Paths_yam_web + hs-source-dirs: + demo + 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 + , reflection + , servant-server + , servant-swagger + , servant-swagger-ui + , string-conversions + , swagger2 + , text + , transformers + , unliftio-core + , vault + , wai + , wai-extra + , warp + , yam-config + , yam-logger + , yam-transaction + , yam-web default-language: Haskell2010