yam-servant (empty) → 0.1.0.0
raw patch · 5 files changed
+214/−0 lines, 5 filesdep +aesondep +basedep +data-defaultsetup-changed
Dependencies added: aeson, base, data-default, lens, servant, servant-server, servant-swagger, servant-swagger-ui, swagger2, wai, wai-extra, warp, yam-app, yam-job
Files
- LICENSE +30/−0
- README.md +1/−0
- Setup.hs +2/−0
- src/Yam/Servant.hs +145/−0
- yam-servant.cabal +36/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Daniel YU (c) 2018++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Daniel YU nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,1 @@+# yam-servant
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Yam/Servant.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module Yam.Servant where++import Yam.App+import Yam.Job+import Yam.Logger.WaiLogger++import Control.Exception (SomeException, catch)+import Control.Lens hiding (Context)+import Data.Aeson+import Data.Default+import Data.Swagger hiding+ ( Header+ , HeaderName+ , port+ )+import Network.Wai+import Network.Wai.Handler.Warp+import Network.Wai.Middleware.AddHeaders (addHeaders)+import Servant+import Servant.Swagger+import Servant.Swagger.UI+import Servant.Utils.Enter++type App = AppM Handler++exceptionHandler ::(MonadIO m) => (Text -> m ())+ -> (m ResponseReceived -> IO ResponseReceived)+ -> SomeException+ -> Application+exceptionHandler = undefined++-- add Correlation-Id and exception convert+middleWare :: YamContext -> Middleware+middleWare context app req resH = do+ reqId <- randomHex 8+ let go a = addHeaders [("X-Correlation-Id",cs reqId)] a req resH+ run = runAppM context+ run $ withLoggerName (reqId <> " corn")+ $ liftIO+ $ go app `catch` (go . exceptionHandler errorLn run)++type API api = (Proxy api, YamContext -> Server api)+type MkApplication = YamContext -> Application+type ApiToApplication = forall s. (HasServer s '[YamContext], HasSwagger s) => API s -> MkApplication+type SwaggerAPI = SwaggerSchemaUI "swagger-ui" "swagger.json"++emptyApi :: API EmptyAPI+emptyApi = (Proxy, undefined)++emptyApplication :: MkApplication+emptyApplication = mkServe emptyApi++mkServe :: (HasServer api '[YamContext], HasSwagger api) => API api -> YamContext -> Application+mkServe ps c req resH = do+ enabled <- evalPropOrDefault True c "swagger.enable"+ swaggertp <- evalPropOrDefault Jensoleg c "swagger.type"+ if enabled+ then go (swagger swaggertp ps) c req resH+ else go ps c req resH+ where go :: (HasServer api '[YamContext]) => API api -> YamContext -> Application+ go (p,s) c = serveWithContext p (c :. EmptyContext) $ s c++toAPI :: (Enter (ServerT api App) App Handler (Server api)) => ServerT api App -> API api+toAPI api = let s c = runReaderTNat c :: ReaderT YamContext Handler :~> Handler+ in (Proxy :: Proxy api, \c -> enter (s c) api)++addApi :: (HasServer api '[YamContext], HasSwagger api, HasServer new '[YamContext], HasSwagger new)+ => API api -> Bool -> API new -> ApiToApplication -> MkApplication+addApi a ok b f c | ok = f (a `ap` b) c+ | otherwise = f a c+ where ap :: API a -> API b -> API (a :<|> b)+ ap (_,a) (_,b) = (Proxy, \c -> a c:<|>b c)++data SwaggerServiceType = Default | Jensoleg++instance FromJSON SwaggerServiceType where+ parseJSON v = go <$> parseJSON v+ where go :: Text -> SwaggerServiceType+ go "default" = Default+ go _ = Jensoleg++swagger :: (HasServer api '[YamContext], HasSwagger api) => SwaggerServiceType -> API api -> API (SwaggerAPI :<|> api)+swagger tp (proxy, api) = (Proxy, \c -> go tp (swaggerDocument proxy) :<|> api c)+ where go Jensoleg = jensolegSwaggerSchemaUIServer+ go _ = swaggerSchemaUIServer++swaggerDocument :: HasSwagger api => Proxy api -> Swagger+swaggerDocument proxy = toSwagger proxy+ & info.title .~ "Yam Servant API"+ & info.version .~ "2018.1"+ & info.contact ?~ Contact (Just "Daniel YU") Nothing (Just "i@icymint.me")+ & info.description ?~ "This is an API for Corn Project"++applicationInfo :: HasServer api '[YamContext] => Proxy api -> YamContext -> Text+applicationInfo proxy = layoutWithContext proxy . (:. EmptyContext)++data Config = Config+ { port :: Int+ , mode :: RunMode+ } deriving Show++instance FromJSON Config where+ parseJSON v = runProp v $ do+ scPort <- getPropOrDefault (port def) "port"+ scMode <- getPropOrDefault (mode def) "mode"+ return $ Config scPort scMode++instance Default Config where+ def = Config 8888 Development++startMain :: (YamContext -> IO YamContext)+ -> [DataSourceProvider (AppM IO) ()]+ -> AppM IO ()+ -> [YamJob]+ -> (YamContext -> Application)+ -> IO ()+startMain initialize providers migrateSql jobs application = do+ context <- defaultContext >>= initialize+ runAppM context $ do+ mds <- getProp "datasource"+ ds2nd<- getProp "datasource.secondary"+ conf <- getPropOrDefault def ""+ initDB providers mds ds2nd $ do+ mapM_ registerJob jobs+ lockExtenstion+ context <- ask+ logger <- toWaiLogger+ let pt = port (conf :: Config)+ settings = setPort pt+ $ setLogger logger defaultSettings+ liftIO $ runSettings settings+ $ middleWare context+ $ application context+ where initDB :: [DataSourceProvider (AppM IO) ()] -> Maybe DataSource -> Maybe DataSource -> AppM IO () -> AppM IO ()+ initDB _ Nothing _ action = action+ initDB p (Just v) ds2 action = initDataSource p v ds2 action+
+ yam-servant.cabal view
@@ -0,0 +1,36 @@+name: yam-servant+version: 0.1.0.0+description: Web Module for Yam+homepage: https://github.com/leptonyu/yam-servant#readme+license: BSD3+license-file: LICENSE+author: Daniel YU+maintainer: i@icymint.me+copyright: Copyright: (c) 2017 Daniel YU+category: Web+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++library+ hs-source-dirs: src+ exposed-modules: Yam.Servant+ build-depends: base >= 4.7 && < 5+ , yam-app+ , yam-job+ , servant+ , servant-server+ , servant-swagger+ , servant-swagger-ui+ , swagger2+ , wai+ , wai-extra+ , warp+ , aeson+ , lens+ , data-default+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/leptonyu/yam-servant