diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# yam-servant diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Yam/Servant.hs b/src/Yam/Servant.hs new file mode 100644 --- /dev/null +++ b/src/Yam/Servant.hs @@ -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 + diff --git a/yam-servant.cabal b/yam-servant.cabal new file mode 100644 --- /dev/null +++ b/yam-servant.cabal @@ -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