diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,1 +1,19 @@ # yam + +Servant based Web Wrapper for Production in Haskell. + + +```Haskell + +import qualified Data.Salak as S +import Yam + +type API = "hello" :> Get '[PlainText] Text + +service :: ServerT API App +service = return "world" + +main = start S.empty [] (Proxy :: Proxy API) service + + +``` diff --git a/demo/Main.hs b/demo/Main.hs --- a/demo/Main.hs +++ b/demo/Main.hs @@ -1,42 +1,35 @@ -{-# 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 qualified Data.Salak as S 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" :> Get '[JSON] Text + :<|> "users" :> "error" :> Get '[JSON] Text :<|> "users" :> "servant" :> Get '[JSON] Text - :<|> "users" :> "db" :> Get '[JSON] Text + :<|> "users" :> "db" :> Get '[JSON] Text +service :: ServerT UserApi App +service = userService :<|> errorService :<|> servantService :<|> dbService + userService :: App Text userService = do - (r,_) <- ask - logInfo $ "Hello: " <> showText r + logInfo $ "Hello: " return "Hello" errorService :: App Text errorService = logError "No" >> return "No" servantService :: App Text -servantService = throwServant err401 +servantService = throwS err401 "Servant" dbService :: App Text dbService = do - str <- runDb $ do + str <- runTrans $ do (time:_) :: [UTCTime] <- selectValue "SELECT CURRENT_TIMESTAMP" let timeStr = showText time logWarn timeStr @@ -45,12 +38,9 @@ return str db :: DataSourceProvider -db DataSourceConfig{..} = createSqlitePool url maxThreads +db = createSqlitePool ":memory:" 10 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" + start p [primaryDatasourceMiddleware db] (Proxy :: Proxy UserApi) service diff --git a/src/Yam.hs b/src/Yam.hs --- a/src/Yam.hs +++ b/src/Yam.hs @@ -1,75 +1,7 @@ -{-# 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 + module Yam.Internal + , module Yam.DataSource ) 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 +import Yam.Internal diff --git a/src/Yam/Config.hs b/src/Yam/Config.hs deleted file mode 100644 --- a/src/Yam/Config.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# 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 - diff --git a/src/Yam/DataSource.hs b/src/Yam/DataSource.hs --- a/src/Yam/DataSource.hs +++ b/src/Yam/DataSource.hs @@ -1,46 +1,39 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -module Yam.DataSource where +module Yam.DataSource( + -- * DataSource Types + DataSourceProvider + , DataSource + , DB + -- * Primary DataSource Functions + , runTrans + , primaryDatasourceMiddleware + -- * Secondary DataSource Functions + , runTransWith + , datasourceMiddleware + -- * Sql Functions + , query + , selectValue + ) where -import Control.Exception (bracket) +import Control.Exception (bracket) import Control.Monad.IO.Unlift -import Control.Monad.Logger.CallStack -import Data.Acquire (withAcquire) -import Data.Aeson +import Data.Acquire (withAcquire) import Data.Conduit -import qualified Data.Conduit.List as CL +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 - } +import Database.Persist.Sql hiding (Key) +import System.IO.Unsafe (unsafePerformIO) +import Yam.Types hiding (LogFunc) -type DataSourceProvider = DataSourceConfig -> LoggingT IO ConnectionPool +type DataSource = ConnectionPool -runInDB :: LogFunc -> DataSourceProvider -> DataSourceConfig -> (DataSource -> IO a) -> IO a -runInDB logfunc f config g = bracket (runLoggingT (f config) logfunc) destroyAllResources (\pool -> g DataSource{..}) +{-# NOINLINE dataSourceKey #-} +dataSourceKey :: Key DataSource +dataSourceKey = unsafePerformIO newKey +type DataSourceProvider = LoggingT IO 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 @@ -52,3 +45,27 @@ selectValue :: (PersistField a, MonadUnliftIO m) => Text -> DB m [a] selectValue sql = fmap unSingle <$> rawSql sql [] + +runTransWith :: (MonadUnliftIO m) => Key DataSource -> DB (AppM m) a -> AppM m a +runTransWith k a = requireAttr k >>= (`runDB` a) + +runTrans :: (MonadUnliftIO m) => DB (AppM m) a -> AppM m a +runTrans = runTransWith dataSourceKey + +{-# INLINE runDB #-} +runDB :: (MonadLoggerIO m, MonadUnliftIO m) => DataSource -> DB m a -> m a +runDB pool db = do + logger <- askLoggerIO + withRunInIO $ \run -> withResource pool $ run . \c -> runSqlConn db c { connLogFunc = logger } + +{-# INLINE runInDB #-} +runInDB :: LogFunc -> DataSourceProvider -> (DataSource -> IO a) -> IO a +runInDB logfunc f g = bracket (runLoggingT f logfunc) destroyAllResources g + +datasourceMiddleware :: Key DataSource -> DataSourceProvider -> AppMiddleware +datasourceMiddleware k dsp = AppMiddleware $ \env f -> do + lf <- askLoggerIO + logInfo "Datasource Initialized..." + liftIO $ runInDB lf dsp $ \ds -> runLoggingT (f (setAttr k ds env, id)) lf + +primaryDatasourceMiddleware = datasourceMiddleware dataSourceKey diff --git a/src/Yam/Internal.hs b/src/Yam/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Yam/Internal.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE NoPolyKinds #-} +module Yam.Internal( + -- * Application Functions + startYam + , start + , App + , module Yam.Logger + , module Yam.Types + , SwaggerConfig(..) + -- * Utilities + , throwS + , readConf + ) where + +import Control.Exception hiding (Handler) +import qualified Data.ByteString.Lazy.Char8 as B +import qualified Data.Salak as S +import qualified Data.Vault.Lazy as L +import GHC.Stack +import Network.Wai.Handler.Warp (run) +import Servant.Swagger +import Yam.Logger +import Yam.Swagger +import Yam.Trace +import Yam.Types + +type App = AppM IO + +runApp :: LogFunc -> Env -> App a -> Handler a +runApp a b c = do + res :: Either SomeException a <- liftIO $ try (runAppM a b c) + case res of + Left e -> throwError $ fromMaybe err400 { errBody = B.pack $ show e } (fromException e :: Maybe ServantErr) + Right r -> return r + +throwS :: (HasCallStack, MonadIO m) => ServantErr -> Text -> AppM m a +throwS e msg = do + logErrorCS ?callStack msg + lift $ throw e + +startYam + :: forall api. (HasSwagger api, HasServer api '[Env]) + => AppConfig + -> SwaggerConfig + -> LogConfig + -> Bool + -> [AppMiddleware] + -> Proxy api + -> ServerT api App + -> IO () +startYam ac@AppConfig{..} sw@SwaggerConfig{..} logConfig enableTrace middlewares proxy server + = withLogger name logConfig $ do + logInfo $ "Start Service [" <> name <> "] ..." + logger <- askLoggerIO + (runAM $ foldr1 (<>) (traceMiddleware enableTrace : middlewares)) (Env L.empty Nothing ac) $ \(env, middleware) -> do + let cxt = env :. EmptyContext + pCxt = Proxy :: Proxy '[Env] + portText = showText port + proxy' = Proxy :: Proxy (Vault :> api) + server' = runRequest proxy pCxt server + when enabled $ + logInfo $ "Swagger enabled: http://localhost:" <> portText <> "/" <> pack urlDir + logInfo $ "Servant started on port(s): " <> portText + lift $ run port + $ middleware + $ serveWithContextAndSwagger sw proxy' cxt + $ hoistServerWithContext proxy' pCxt (runApp logger env) server' + +runRequest :: (HasServer api context) => Proxy api -> Proxy context -> ServerT api App -> Vault -> ServerT api App +runRequest p pc a v = hoistServerWithContext p pc go a + where + {-# INLINE go #-} + go :: App a -> App a + go b = do + let trace :: Maybe TraceLog = L.lookup traceKey v + withAppM (\(env,lf) -> (env { reqAttributes = Just v}, nlf lf trace)) b + {-# INLINE nlf #-} + nlf x (Just t) = addTrace x t + nlf x _ = x + +readConf :: (Default a, S.FromProperties a) => Text -> S.Properties -> a +readConf k p = fromMaybe def $ S.lookup k p + +start + :: forall api. (HasSwagger api, HasServer api '[Env]) + => S.Properties + -> [AppMiddleware] + -> Proxy api + -> ServerT api App + -> IO () +start p middlewares proxy service = startYam + (readConf "yam.application" p) + (readConf "yam.swagger" p) + (readConf "yam.logging" p) + (fromMaybe True $ S.lookup "yam.trace.enabled" p) + middlewares proxy service diff --git a/src/Yam/Logger.hs b/src/Yam/Logger.hs new file mode 100644 --- /dev/null +++ b/src/Yam/Logger.hs @@ -0,0 +1,68 @@ +module Yam.Logger( + -- * Logger Function + withLogger + , addTrace + , LogConfig(..) + ) where + +import Control.Exception (bracket) +import Control.Monad (when) +import qualified Data.Text as T +import System.Log.FastLogger +import Yam.Types + +instance FromJSON LogLevel where + parseJSON v = go . T.toLower <$> parseJSON v + where + go :: Text -> LogLevel + go "debug" = LevelDebug + go "info" = LevelInfo + go "warn" = LevelWarn + go "error" = LevelError + go level = LevelOther level + +{-# INLINE toStr #-} +toStr :: LogLevel -> LogStr +toStr LevelDebug = "DEBUG" +toStr LevelInfo = " INFO" +toStr LevelWarn = " WARN" +toStr LevelError = "ERROR" +toStr (LevelOther l) = toLogStr l + +data LogConfig = LogConfig + { bufferSize :: Word16 + , file :: FilePath + , maxSize :: Word32 + , rotateHistory :: Word16 + , level :: LogLevel + } deriving (Eq, Show) + +instance Default LogConfig where + def = defJson + +instance FromJSON LogConfig where + parseJSON = withObject "LogConfig" $ \v -> LogConfig + <$> v .:? "buffer-size" .!= 4096 + <*> v .:? "file" .!= "" + <*> v .:? "max-size" .!= 10485760 + <*> v .:? "max-history" .!= 256 + <*> v .:? "level" .!= LevelInfo + +newLogger :: Text -> LogConfig -> IO (LogFunc, IO ()) +newLogger name LogConfig{..} = do + tc <- newTimeCache "%Y-%m-%d %T" + let ft = if file == "" + then LogStdout $ fromIntegral bufferSize + else LogFile (FileLogSpec file (toInteger maxSize) (fromIntegral rotateHistory)) $ fromIntegral bufferSize + (l,close) <- newTimedFastLogger tc ft + return (toLogger l, close) + where + toLogger f Loc{..} _ ll s = when (level <= ll) $ f $ \t -> + let locate = if ll /= LevelError then "" else "@" <> toLogStr loc_filename <> toLogStr (show loc_start) + in toLogStr t <> " " <> toStr ll <> " [" <> toLogStr name <> "] " <> toLogStr loc_module <> " " <> locate <> " - " <> s <> "\n" + +withLogger :: Text -> LogConfig -> LoggingT IO a -> IO a +withLogger n lc action = bracket (newLogger n lc) snd $ \(f,_) -> runLoggingT action f + +addTrace :: LogFunc -> Text -> LogFunc +addTrace f tid a b c d = f a b c ("[" <> toLogStr tid <> "] " <> d) diff --git a/src/Yam/Swagger.hs b/src/Yam/Swagger.hs new file mode 100644 --- /dev/null +++ b/src/Yam/Swagger.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE NoPolyKinds #-} +module Yam.Swagger where + +import Data.Reflection +import GHC.TypeLits +import Servant.Swagger +import Servant.Swagger.UI +import Yam.Types + +data SwaggerConfig = SwaggerConfig + { urlDir :: String + , urlSchema :: String + , enabled :: Bool + } deriving (Eq, Show) + +instance Default SwaggerConfig where + def = defJson + +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 diff --git a/src/Yam/Trace.hs b/src/Yam/Trace.hs new file mode 100644 --- /dev/null +++ b/src/Yam/Trace.hs @@ -0,0 +1,21 @@ +module Yam.Trace where + +import qualified Data.Vault.Lazy as L +import Network.Wai +import System.IO.Unsafe (unsafePerformIO) +import Yam.Types + +type TraceLog = Text + +{-# NOINLINE traceKey #-} +traceKey :: Key TraceLog +traceKey = unsafePerformIO newKey + +traceMw :: Middleware +traceMw app req resH = do + traceId <- randomString 12 + let h = ("X-TRACE-ID",encodeUtf8 traceId) + app req {vault = L.insert traceKey traceId (vault req)} (resH . mapResponseHeaders (h:)) + +traceMiddleware :: Bool -> AppMiddleware +traceMiddleware enabled = simpleWebMiddleware (enabled, "Trace") traceMw diff --git a/src/Yam/Types.hs b/src/Yam/Types.hs new file mode 100644 --- /dev/null +++ b/src/Yam/Types.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE ImplicitParams #-} +module Yam.Types( + -- * Environment + AppConfig(..) + , Env(..) + , AppEnv + , getAttr + , setAttr + , reqAttr + -- * AppM Monad + , AppM + , runAppM + , withAppM + , askApp + , askAttr + , withAttr + , requireAttr + -- * Application Middleware + , AppMiddleware(..) + , simpleAppMiddleware + , simpleWebMiddleware + -- * Utilities + , LogFunc + , randomString + , showText + , defJson + -- * Reexport Functions + , Key + , newKey + , Middleware + , Request(..) + , lift + , when + , Default(..) + , Text + , pack + , encodeUtf8 + , MonadIO + , liftIO + , withReaderT + , module Control.Monad.Logger.CallStack + , module Data.Maybe + , module Servant + , module Data.Aeson + , module Data.Word + ) where + +import Control.Monad.Logger.CallStack +import Control.Monad.Reader +import Data.Aeson +import Data.Default +import Data.Maybe +import Data.Text (Text, justifyRight, pack) +import Data.Text.Encoding (encodeUtf8) +import Data.Vault.Lazy (Key, newKey) +import qualified Data.Vault.Lazy as L +import Data.Word +import GHC.Stack +import Network.Wai +import Numeric +import Servant +import System.Random + +data AppConfig = AppConfig + { name :: Text + , port :: Int + } deriving (Eq, Show) + +instance FromJSON AppConfig where + parseJSON = withObject "AppConfig" $ \v -> AppConfig + <$> v .:? "name" .!= "application" + <*> v .:? "port" .!= 8888 + +defJson :: FromJSON a => a +defJson = fromJust $ decode "{}" + +instance Default AppConfig where + def = defJson + +data Env = Env + { attributes :: Vault + , reqAttributes :: Maybe Vault + , application :: AppConfig + } + +instance Default Env where + def = Env L.empty Nothing def + +getAttr :: Key a -> Env -> Maybe a +getAttr k Env{..} = listToMaybe $ catMaybes $ L.lookup k <$> catMaybes [reqAttributes, Just attributes] + +reqAttr :: Default a => Key a -> Env -> a +reqAttr k = fromMaybe def . getAttr k + +setAttr :: Key a -> a -> Env -> Env +setAttr k v Env{..} = case reqAttributes of + Just av -> Env attributes (Just $ L.insert k v av) application + _ -> Env (L.insert k v attributes) reqAttributes application + +type AppM m = LoggingT (ReaderT Env m) +type AppEnv = (Env, LogFunc) +type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO () + +runAppM :: LogFunc -> Env -> AppM m a -> m a +runAppM lf env a = runReaderT (runLoggingT a lf) env + +withAppM :: MonadIO m => (AppEnv -> AppEnv) -> AppM m a -> AppM m a +withAppM f a = do + lf <- askLoggerIO + env <- ask + let (e,l) = f (env,lf) + lift . lift $ runAppM l e a + +askApp :: Monad m => AppM m AppConfig +askApp = asks application + +requireAttr :: MonadIO m => Key a -> AppM m a +requireAttr k = fromJust <$> askAttr k + +askAttr :: MonadIO m => Key a -> AppM m (Maybe a) +askAttr = asks . getAttr + +withAttr :: MonadIO m => Key a -> a -> AppM m b -> AppM m b +withAttr k v = withAppM (\(env,lf) -> (setAttr k v env, lf)) + +-- | Application Middleware +newtype AppMiddleware = AppMiddleware {runAM :: Env -> ((Env, Middleware)-> LoggingT IO ()) -> LoggingT IO ()} + +instance Semigroup AppMiddleware where + (AppMiddleware am) <> (AppMiddleware bm) = AppMiddleware $ \e f -> am e $ \(e', mw) -> bm e' $ \(e'',mw') -> f (e'', mw . mw') + +instance Monoid AppMiddleware where + mempty = AppMiddleware $ \a f -> f (a,id) + +-- | Simple AppMiddleware +simpleAppMiddleware :: HasCallStack => (Bool, Text) -> Key a -> a -> AppMiddleware +simpleAppMiddleware (enabled,amname) k v = + if enabled + then AppMiddleware $ \e f -> do + logInfoCS ?callStack $ amname <> " enabled" + f (setAttr k v e, id) + else mempty + +simpleWebMiddleware :: HasCallStack => (Bool, Text) -> Middleware -> AppMiddleware +simpleWebMiddleware (enabled,amname) m = + if enabled + then AppMiddleware $ \e f -> do + logInfoCS ?callStack $ amname <> " enabled" + f (e,m) + else mempty + +-- | Utility +{-# INLINE randomString #-} +randomString :: Int -> IO Text +randomString n = do + c <- randomIO :: IO Word64 + return $ justifyRight n '0' $ pack $ take n $ showHex c "" + +{-# INLINE showText #-} +showText :: Show a => a -> Text +showText = pack . show diff --git a/src/Yam/Util.hs b/src/Yam/Util.hs deleted file mode 100644 --- a/src/Yam/Util.hs +++ /dev/null @@ -1,18 +0,0 @@ -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 () diff --git a/src/Yam/Web/Middleware.hs b/src/Yam/Web/Middleware.hs deleted file mode 100644 --- a/src/Yam/Web/Middleware.hs +++ /dev/null @@ -1,33 +0,0 @@ -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) diff --git a/src/Yam/Web/Swagger.hs b/src/Yam/Web/Swagger.hs deleted file mode 100644 --- a/src/Yam/Web/Swagger.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# 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 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -8,12 +8,13 @@ import Control.Monad.IO.Class import Data.Aeson import Data.Maybe -import qualified Data.Salak as S -import Data.Text (Text) +import qualified Data.Salak as S +import Data.Text (Text) +import qualified Data.Text as T import Test.Hspec import Test.QuickCheck -import Yam.Config -import Yam.DataSource +import Test.QuickCheck.Monadic +import Yam main = hspec spec @@ -27,8 +28,13 @@ 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 + -- let dsf = get "yam.datasource" :: Maybe DataSourceConfig + -- shouldSatisfy dsf isJust + let conf = get "yam.application" :: Maybe AppConfig shouldSatisfy conf isJust - datasource <$> conf `shouldBe` dsf + -- datasource <$> conf `shouldBe` dsf + context "randomTest" $ do + it "random" $ do + monadicIO $ do + s <- run $ randomString 14 + assert (T.length s == 14) diff --git a/yam.cabal b/yam.cabal --- a/yam.cabal +++ b/yam.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: c2763c742d9115cc6b3b693cfab16de4ee30c9a27302cffd5a229e58c698da3a +-- hash: f9fe2bcda9477157917b0e18eb2cc0dedfe7d1737dda59d00077e97f6f8b0882 name: yam -version: 0.4.0 +version: 0.5.0 synopsis: Yam Web category: Web homepage: https://github.com/leptonyu/yam#readme @@ -24,21 +24,24 @@ library exposed-modules: Yam - Yam.Config Yam.DataSource - Yam.Web.Middleware - Yam.Web.Swagger + Yam.Internal other-modules: - Yam.Util + Yam.Types + Yam.Logger + Yam.Swagger + Yam.Trace hs-source-dirs: src - ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-orphans -fno-warn-missing-signatures + 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 -optP-Wno-nonportable-include-path -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 + , fast-logger , monad-logger , mtl , persistent @@ -63,13 +66,15 @@ 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 + 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 -optP-Wno-nonportable-include-path -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 + , fast-logger , monad-logger , mtl , persistent @@ -97,16 +102,18 @@ main-is: Spec.hs other-modules: Yam - Yam.Config Yam.DataSource - Yam.Util - Yam.Web.Middleware - Yam.Web.Swagger + Yam.Internal + Yam.Logger + Yam.Swagger + Yam.Trace + Yam.Types 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 + 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 -optP-Wno-nonportable-include-path -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-orphans -fno-warn-missing-signatures build-depends: QuickCheck , aeson @@ -114,6 +121,7 @@ , bytestring , conduit , data-default + , fast-logger , hspec ==2.* , monad-logger , mtl diff --git a/yam_test.yml b/yam_test.yml --- a/yam_test.yml +++ b/yam_test.yml @@ -1,4 +1,5 @@ yam: - application: yam - datasource: - url: ':memory:' + application: + name: yam + logging: + # file: .stack-work/1.log