yam-servant 0.1.5 → 0.1.6
raw patch · 2 files changed
+98/−21 lines, 2 filesdep +http-typesdep +text
Dependencies added: http-types, text
Files
- src/Yam/Servant.hs +93/−18
- yam-servant.cabal +5/−3
src/Yam/Servant.hs view
@@ -1,39 +1,79 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} -module Yam.Servant where+module Yam.Servant(+ App+ , ServantWrapException(..)+ , API(..)+ , MkApplication+ , ApiToApplication+ , emptyApi+ , emptyApplication+ , mkServe+ , toAPI+ , addApi+ , startSimpleJob+ , startMain+ , InitializeYamContext+ , DataSourceProviders+ , MigrateSQL+ , LoadYamJobs+ ) where import Yam.App import Yam.Job-import Yam.Logger.WaiLogger+import Yam.Logger+import Yam.Transaction.Sqlite -import Control.Exception (SomeException, catch)+import Control.Exception+ ( SomeException+ , catch+ , fromException+ ) import Control.Lens hiding (Context) import Data.Swagger hiding ( Header , HeaderName , port )+import qualified Data.Text as T+import Data.Typeable (cast)+import Network.HTTP.Types.Status import Network.Wai import Network.Wai.Handler.Warp import Network.Wai.Middleware.AddHeaders (addHeaders) import Servant+import Servant.Server.Internal (responseServantErr) import Servant.Swagger import Servant.Swagger.UI import Servant.Utils.Enter type App = AppM Handler +data ServantWrapException = forall e. Exception e => Wrap ServantErr e++instance Show ServantWrapException where+ show (Wrap _ e) = show e+instance Exception ServantWrapException+ exceptionHandler ::(MonadIO m) => (Text -> m ()) -> (m ResponseReceived -> IO ResponseReceived) -> SomeException -> Application-exceptionHandler = undefined+exceptionHandler log run e _ resH = run $ do+ log $ showText e+ liftIO $ resH $ responseServantErr $ go e+ where go :: SomeException -> ServantErr+ go e = case fromException e :: Maybe ServantWrapException of+ Just (Wrap err _) -> err+ _ -> err400 -- add Correlation-Id and exception convert middleWare :: YamContext -> Middleware@@ -114,17 +154,52 @@ instance Default Config where def = Config 8888 Development -startMain :: (YamContext -> IO YamContext)- -> [DataSourceProvider (AppM IO) ()]- -> AppM IO ()- -> AppM IO [YamJob]- -> (YamContext -> Application)+type InitializeYamContext = YamContext -> IO YamContext+type DataSourceProviders = [DataSourceProvider (AppM IO) ()]+type MigrateSQL = AppM IO ()+type LoadYamJobs = AppM IO [YamJob]++startSimpleJob :: InitializeYamContext -> MigrateSQL -> LoadYamJobs -> IO ()+startSimpleJob i m l = startMain i [sqliteProvider] m l emptyApplication++showConf :: AppM IO ()+showConf = do+ conf :: Config <- getPropOrDefault def ""+ rank :: LogRank <- getPropOrDefault DEBUG "log.level"+ ds :: DataSource <- getPropOrDefault def "datasource"+ ds2 :: Maybe DataSource <- getProp "datasource.secondary"+ let title = "---------- Run Alert In " <> showText (mode conf) <> " Mode ----------"+ url = "http://localhost:" <> showText (port conf)+ infoLn title+ infoLn $ " LogLevel : " <> showText rank+ infoLn $ " Database : " <> showText (dbtype ds)+ infoLn $ " ConnStr : " <> showText (conn ds)+ when (conn ds /= ":memory:") $+ infoLn $ " Thread : " <> showText (thread ds)+ forM_ ds2 $ \d2 -> do+ infoLn " Secondary DB : "+ infoLn $ " Database : " <> showText (dbtype d2)+ infoLn $ " ConnStr : " <> showText (conn d2)+ when (conn d2 /= ":memory:") $+ infoLn $ " Thread : " <> showText (thread d2)+ infoLn $ " URL : " <> url+ swagger <- getPropOrDefault True "swagger.enable"+ unless (swagger && mode conf /= Production) $+ infoLn $ " SwaggerURL : " <> url <> "/swagger-ui"+ infoLn $ T.replicate (T.length title) "-"++startMain :: InitializeYamContext+ -> DataSourceProviders+ -> MigrateSQL+ -> LoadYamJobs+ -> MkApplication -> IO () startMain initialize providers migrateSql jobs application = do context <- defaultContext >>= initialize- runAppM context $ go `finally` (cleanContext killJobs)+ runAppM context $ go `finally` cleanContext killJobs where go :: AppM IO ()- go = do mds <- getPropOrDefault def "datasource"+ go = do showConf+ mds <- getPropOrDefault def "datasource" ds2nd<- getProp "datasource.secondary" conf <- getPropOrDefault def "" initDataSource providers mds ds2nd $ do
yam-servant.cabal view
@@ -1,7 +1,7 @@ name: yam-servant-version: 0.1.5+version: 0.1.6 description: Web Module for Yam-homepage: https://github.com/leptonyu/yam/yam-servant#readme+homepage: https://github.com/leptonyu/yam/tree/master/yam-app#readme license: BSD3 license-file: LICENSE author: Daniel YU@@ -27,9 +27,11 @@ , wai-extra , warp , aeson+ , text , lens+ , http-types default-language: Haskell2010 source-repository head type: git- location: https://github.com/leptonyu/yam-servant+ location: https://github.com/leptonyu/yam