yam (empty) → 0.4.0
raw patch · 13 files changed
+525/−0 lines, 13 filesdep +QuickCheckdep +aesondep +basesetup-changed
Dependencies added: QuickCheck, aeson, base, bytestring, conduit, data-default, hspec, monad-logger, mtl, persistent, persistent-sqlite, random, reflection, resource-pool, resourcet, salak, servant-server, servant-swagger, servant-swagger-ui, text, time, unliftio-core, vault, wai, wai-extra, warp, yam
Files
- LICENSE +30/−0
- README.md +1/−0
- Setup.hs +2/−0
- demo/Main.hs +56/−0
- src/Yam.hs +75/−0
- src/Yam/Config.hs +23/−0
- src/Yam/DataSource.hs +54/−0
- src/Yam/Util.hs +18/−0
- src/Yam/Web/Middleware.hs +33/−0
- src/Yam/Web/Swagger.hs +61/−0
- test/Spec.hs +34/−0
- yam.cabal +134/−0
- yam_test.yml +4/−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
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ demo/Main.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}++module Main where++import Control.Monad.Logger.CallStack+import Control.Monad.Reader+import qualified Data.Salak as S+import Data.Text (Text)+import Data.Time+import Database.Persist.Sqlite+import Network.Wai.Middleware.RequestLogger+import Servant+import Yam++type UserApi+ = "users" :> Get '[JSON] Text+ :<|> "users" :> "error" :> Get '[JSON] Text+ :<|> "users" :> "servant" :> Get '[JSON] Text+ :<|> "users" :> "db" :> Get '[JSON] Text++userService :: App Text+userService = do+ (r,_) <- ask+ logInfo $ "Hello: " <> showText r+ return "Hello"++errorService :: App Text+errorService = logError "No" >> return "No"++servantService :: App Text+servantService = throwServant err401++dbService :: App Text+dbService = do+ str <- runDb $ do+ (time:_) :: [UTCTime] <- selectValue "SELECT CURRENT_TIMESTAMP"+ let timeStr = showText time+ logWarn timeStr+ return timeStr+ logInfo str+ return str++db :: DataSourceProvider+db DataSourceConfig{..} = createSqlitePool url maxThreads++main :: IO ()+main = do+ p <- S.defaultPropertiesWithFile "yam_test.yml"+ let config :: Maybe YamConfig = S.lookup "yam" p+ runStdoutLoggingT $ case config of+ Just c -> start c (Proxy :: Proxy UserApi) (userService :<|> errorService :<|> servantService :<|> dbService) [logStdoutDev] (Just db) (return ())+ Nothing -> logError "Yam Config not found"
+ src/Yam.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Yam(+ start+ , App+ , YamConfig(..)+ , DataSourceProvider+ , DataSourceConfig(..)+ , showText+ , throwServant+ , runDb+ , selectValue+ ) where++import Control.Exception (throw)+import Control.Monad.Except+import Control.Monad.Logger.CallStack+import Control.Monad.Reader+import Network.Wai+import Network.Wai.Handler.Warp (run)+import Yam.Config+import Yam.DataSource+import Yam.Util+import Yam.Web.Swagger++type AppM m = ReaderT (YamConfig, Maybe DataSource) (LoggingT m)++type App = AppM IO++throwServant :: ServantErr -> App a+throwServant = lift . throw++runDb :: DB App a -> App a+runDb a = do+ (_, ds) <- ask+ case ds of+ Nothing -> do+ logError "DataSource not found"+ throwServant err401+ Just d -> runDB d a++start+ :: (HasSwagger api, HasServer api '[YamConfig])+ => YamConfig+ -> Proxy api+ -> ServerT api App+ -> [Middleware]+ -> Maybe DataSourceProvider+ -> App a+ -> LoggingT IO ()+start conf@YamConfig{..} proxy server middleWares newDs appa+ = let cxt = (conf :. EmptyContext)+ in do+ logInfo "Start Service..."+ runLogger <- askLoggerIO+ tryRunDb newDs datasource runLogger+ $ \ds -> do+ _ <- runLoggingT (runReaderT appa (conf,ds)) runLogger+ run port+ $ foldr (.) id middleWares+ $ serveWithContextAndSwagger swagger proxy cxt+ $ hoistServerWithContext proxy (Proxy :: Proxy '[YamConfig]) (go runLogger ds) server+ where+ go :: LogFunc -> Maybe DataSource -> App a -> Handler a+ go r ds a = liftIO $ (`runLoggingT` r) $ runReaderT a (conf, ds)+ tryRunDb (Just d) ds r a = do+ logInfo "Initialize Datasource..."+ liftIO $ runInDB r d ds (a.Just)+ tryRunDb _ _ _ a = liftIO $ a Nothing
+ src/Yam/Config.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE OverloadedStrings #-}+module Yam.Config where++import Data.Aeson+import Data.Default+import Data.Text+import Yam.DataSource+import Yam.Web.Swagger++data YamConfig = YamConfig+ { datasource :: DataSourceConfig+ , swagger :: SwaggerConfig+ , appName :: Text+ , port :: Int+ } deriving (Eq, Show)++instance FromJSON YamConfig where+ parseJSON = withObject "YamConfig" $ \v -> YamConfig+ <$> v .: "datasource"+ <*> v .:? "swagger" .!= def+ <*> v .: "application"+ <*> v .:? "port" .!= 8888+
+ src/Yam/DataSource.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+module Yam.DataSource where++import Control.Exception (bracket)+import Control.Monad.IO.Unlift+import Control.Monad.Logger.CallStack+import Data.Acquire (withAcquire)+import Data.Aeson+import Data.Conduit+import qualified Data.Conduit.List as CL+import Data.Pool+import Data.Text (Text)+import Database.Persist.Sql++data DataSourceConfig = DataSourceConfig+ { url :: Text+ , maxThreads :: Int+ } deriving (Eq, Show)++instance FromJSON DataSourceConfig where+ parseJSON = withObject "DataSourceConfig" $ \v -> DataSourceConfig+ <$> v .: "url"+ <*> v .:? "max-threads" .!= 10++data DataSource = DataSource+ { config :: DataSourceConfig+ , pool :: ConnectionPool+ }++type DataSourceProvider = DataSourceConfig -> LoggingT IO ConnectionPool++runInDB :: LogFunc -> DataSourceProvider -> DataSourceConfig -> (DataSource -> IO a) -> IO a+runInDB logfunc f config g = bracket (runLoggingT (f config) logfunc) destroyAllResources (\pool -> g DataSource{..})++-- SqlPersistT ~ ReaderT SqlBackend+type DB = SqlPersistT++runDB :: (MonadLoggerIO m, MonadUnliftIO m) => DataSource -> DB m a -> m a+runDB DataSource{..} db = do+ logger <- askLoggerIO+ withRunInIO $ \run -> withResource pool $ run . \c -> runSqlConn db c { connLogFunc = logger }++query+ :: (MonadUnliftIO m)+ => Text+ -> [PersistValue]+ -> DB m [[PersistValue]]+query sql params = do+ res <- rawQueryRes sql params+ withAcquire res (\a -> runConduit $ a .| CL.fold (flip (:)) [])++selectValue :: (PersistField a, MonadUnliftIO m) => Text -> DB m [a]+selectValue sql = fmap unSingle <$> rawSql sql []
+ src/Yam/Util.hs view
@@ -0,0 +1,18 @@+module Yam.Util where++import Control.Monad.Logger.CallStack+import Data.Text (Text, justifyRight, pack)+import Data.Word+import Numeric+import System.Random++randomString :: Int -> IO Text+randomString n = do+ c <- randomIO :: IO Word64+ return $ justifyRight n '0' $ pack $ showHex c ""+++showText :: Show a => a -> Text+showText = pack . show++type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO ()
+ src/Yam/Web/Middleware.hs view
@@ -0,0 +1,33 @@+module Yam.Web.Middleware where++import Control.Exception+import Control.Monad+import Control.Monad.Logger.CallStack+import qualified Data.ByteString.Lazy.Char8 as B+import Data.Maybe+import Data.Text (Text, pack)+import Data.Vault.Lazy+import Network.Wai+import Servant+import Servant.Server.Internal.ServantErr (responseServantErr)+import Yam.Util++prepareMiddleware :: IO Vault -> Middleware+prepareMiddleware pre app req resH = do+ v <- pre+ app req { vault = vault req `union` v } resH++errorMiddleware :: (Request -> SomeException -> IO Response) -> Middleware+errorMiddleware f app req resH = app req resH `catch` (f req >=> resH)++traceMiddleware :: Key Text -> Middleware+traceMiddleware k = prepareMiddleware $ do+ traceId <- randomString 16+ return $ insert k traceId empty++servantErrorMiddleware :: (LoggingT IO Response -> IO Response) -> Middleware+servantErrorMiddleware lc = errorMiddleware $ \_ e -> lc $ do+ logError (pack $ show e)+ return . responseServantErr $ fromMaybe+ err400 { errBody = B.pack $ show e }+ (fromException e :: Maybe ServantErr)
+ src/Yam/Web/Swagger.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+module Yam.Web.Swagger(+ HasSwagger+ , SwaggerConfig(..)+ , serveWithContextAndSwagger+ , module Servant+ ) where++import Data.Aeson+import Data.Default+import Data.Maybe+import Data.Reflection+import GHC.TypeLits+import Servant+import Servant.Swagger+import Servant.Swagger.UI++data SwaggerConfig = SwaggerConfig+ { urlDir :: String+ , urlSchema :: String+ , enabled :: Bool+ } deriving (Eq, Show)++instance Default SwaggerConfig where+ def = fromJust $ decode "{}"++instance FromJSON SwaggerConfig where+ parseJSON = withObject "SwaggerConfig" $ \v -> SwaggerConfig+ <$> v .:? "dir" .!= "swagger-ui"+ <*> v .:? "schema" .!= "swagger-ui.json"+ <*> v .:? "enabled" .!= True++type SAPI dir schema api = SwaggerSchemaUI dir schema :<|> api++serveWithContextAndSwagger+ :: (HasSwagger api, HasServer api context)+ => SwaggerConfig+ -> Proxy api+ -> Context context+ -> ServerT api Handler+ -> Application+serveWithContextAndSwagger SwaggerConfig{..} proxy cxt api =+ if enabled+ then reifySymbol urlDir $ \pd -> reifySymbol urlSchema $ \ps -> go (pd,ps) proxy cxt api+ else serveWithContext proxy cxt api+ where+ go :: (HasSwagger api, HasServer api context, KnownSymbol d, KnownSymbol s)+ => (Proxy d, Proxy s)+ -> Proxy api+ -> Context context+ -> ServerT api Handler+ -> Application+ go pds p c api' = let p' = g2 pds in serveWithContext p' c (g3 p api' p')+ g2 :: (Proxy d, Proxy s) -> Proxy (SAPI d s api)+ g2 _ = Proxy+ g3 :: HasSwagger api => Proxy api -> Server api -> Proxy (SAPI d s api) -> Server (SAPI d s api)+ g3 p a _ = swaggerSchemaUIServer (toSwagger p) :<|> a
+ test/Spec.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Main where+++import Control.Monad.IO.Class+import Data.Aeson+import Data.Maybe+import qualified Data.Salak as S+import Data.Text (Text)+import Test.Hspec+import Test.QuickCheck+import Yam.Config+import Yam.DataSource++main = hspec spec++spec :: Spec+spec = do+ describe "Yam.Config" specConfig++specConfig = do+ context "configuration" $ do+ it "load" $ do+ p <- S.defaultPropertiesWithFile "yam_test.yml"+ let get :: S.FromProperties a => Text -> Maybe a+ get = flip S.lookup p+ let dsf = get "yam.datasource" :: Maybe DataSourceConfig+ shouldSatisfy dsf isJust+ let conf = get "yam" :: Maybe YamConfig+ shouldSatisfy conf isJust+ datasource <$> conf `shouldBe` dsf
+ yam.cabal view
@@ -0,0 +1,134 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.1.+--+-- see: https://github.com/sol/hpack+--+-- hash: c2763c742d9115cc6b3b693cfab16de4ee30c9a27302cffd5a229e58c698da3a++name: yam+version: 0.4.0+synopsis: Yam Web+category: Web+homepage: https://github.com/leptonyu/yam#readme+author: Daniel YU+maintainer: Daniel YU <leptonyu@gmail.com>+copyright: (c) 2018 Daniel YU+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ yam_test.yml++library+ exposed-modules:+ Yam+ Yam.Config+ Yam.DataSource+ Yam.Web.Middleware+ Yam.Web.Swagger+ other-modules:+ Yam.Util+ hs-source-dirs:+ src+ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-orphans -fno-warn-missing-signatures+ build-depends:+ aeson+ , base >=4.7 && <5+ , bytestring+ , conduit+ , data-default+ , monad-logger+ , mtl+ , persistent+ , random+ , reflection+ , resource-pool+ , resourcet+ , salak+ , servant-server+ , servant-swagger+ , servant-swagger-ui+ , text+ , unliftio-core+ , vault+ , wai+ , warp+ default-language: Haskell2010++executable yam+ main-is: Main.hs+ other-modules:+ Paths_yam+ hs-source-dirs:+ demo+ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-orphans -fno-warn-missing-signatures+ build-depends:+ aeson+ , base >=4.7 && <5+ , bytestring+ , conduit+ , data-default+ , monad-logger+ , mtl+ , persistent+ , persistent-sqlite+ , random+ , reflection+ , resource-pool+ , resourcet+ , salak+ , servant-server+ , servant-swagger+ , servant-swagger-ui+ , text+ , time+ , unliftio-core+ , vault+ , wai+ , wai-extra+ , warp+ , yam+ default-language: Haskell2010++test-suite spec+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Yam+ Yam.Config+ Yam.DataSource+ Yam.Util+ Yam.Web.Middleware+ Yam.Web.Swagger+ Paths_yam+ hs-source-dirs:+ test+ src+ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-orphans -fno-warn-missing-signatures+ build-depends:+ QuickCheck+ , aeson+ , base >=4.7 && <5+ , bytestring+ , conduit+ , data-default+ , hspec ==2.*+ , monad-logger+ , mtl+ , persistent+ , random+ , reflection+ , resource-pool+ , resourcet+ , salak+ , servant-server+ , servant-swagger+ , servant-swagger-ui+ , text+ , unliftio-core+ , vault+ , wai+ , warp+ default-language: Haskell2010
+ yam_test.yml view
@@ -0,0 +1,4 @@+yam:+ application: yam+ datasource:+ url: ':memory:'