diff --git a/src/Yam.hs b/src/Yam.hs --- a/src/Yam.hs +++ b/src/Yam.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE NoPolyKinds #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NoPolyKinds #-} -- | -- Module: Yam -- Copyright: (c) 2019 Daniel YU @@ -53,6 +54,8 @@ , TryContextEntry(..) , getEntry , tryEntry + -- ** Configuration + , HasSalaks -- ** Swagger , SwaggerConfig(..) , serveWithContextAndSwagger @@ -77,7 +80,6 @@ , logError , logWarn , logDebug - , RunSalak(..) ) where import qualified Control.Category as C @@ -105,47 +107,46 @@ :: forall file api cxt . ( HasLoad file , HasLogger cxt + , HasSalaks cxt , HasServer api cxt , HasSwagger api) => String -- ^ File config name -> file -- ^ Config file format -> Version -- ^ Version - -> RunSalak (AppMiddleware Simple cxt) -- ^ Application Middleware + -> AppMiddleware Simple cxt -- ^ Application Middleware -> Proxy api -- ^ Application API Proxy - -> RunSalak (ServerT api (AppV cxt IO)) -- ^ Application API Server + -> ServerT api (AppV cxt IO) -- ^ Application API Server -> IO () -start cfg file = start' (loadSalakFile cfg file) +start cfg file = start' (loadSalakWith file cfg) -- | Standard Starter of Yam. start' :: forall api cxt .(HasLogger cxt + , HasSalaks cxt , HasServer api cxt , HasSwagger api) - => LoadSalakT IO () + => LoadSalak () -> Version - -> RunSalak (AppMiddleware Simple cxt) + -> AppMiddleware Simple cxt -> Proxy api - -> RunSalak (ServerT api (AppV cxt IO)) + -> ServerT api (AppV cxt IO) -> IO () -start' load ver mkAMD pSer mkSer = loadAndRunSalak load $ do - c <- requireD "logging" - app@AppConfig{..} <- require "application" - sw@SwaggerConfig{..} <- require "swagger" - withLogger name c $ \logger -> unSalak $ do +start' load ver amd pSer ser = loadAndRunSalak load $ do + app@AppConfig{..} <- require "application" + c <- require "logging" + withLogger name c $ \logger -> do + sw <- require "swagger" + ac <- require "actuator" + sp <- askSalak let portText = showText port - baseCxt = LF logger :. EmptyContext + baseCxt = sp :. LF logger :. EmptyContext logInfo $ "Start Service [" <> name <> "] ..." - amd <- mkAMD - ser <- mkSer - f <- askUnliftIO - liftX $ runAM amd baseCxt id emptyHealth $ \cxt middleware hr -> lift $ unliftIO f $ do - (en, aep) <- actuatorEndpoint hr - readLogs >>= mapM_ (logInfo . ("Parsing " <>)) - when enabled $ - logInfo $ "Swagger enabled: http://localhost:" <> portText <> "/" <> pack urlDir + liftX $ runAM amd baseCxt id emptyHealth $ \cxt middleware hr -> do + when (enabled (sw :: SwaggerConfig)) $ + logInfo $ "Swagger enabled: http://localhost:" <> portText <> "/" <> pack (urlDir sw) logInfo $ "Servant started on port(s): " <> portText - let go :: forall a. (HasSwagger a, HasServer a cxt) => Proxy a -> ServerT a (AppV cxt IO) -> RunSalak () + let go :: forall a. (HasSwagger a, HasServer a cxt) => Proxy a -> ServerT a (AppV cxt IO) -> LoggingT IO () go x y = liftIO $ serveWarp app $ traceMiddleware (\v -> runAppT (VH v :. cxt) . spanNoNotifier) @@ -153,8 +154,8 @@ $ errorMiddleware baseCxt $ serveWithContextAndSwagger sw (baseInfo hostname name ver port) (Proxy @(Vault :> a)) cxt $ \v -> hoistServerWithContext x (Proxy @cxt) (nt cxt v) y - if en - then go (Proxy @(api :<|> ActuatorEndpoint)) (ser :<|> aep) + if enabled (ac :: ActuatorConfig) + then go (Proxy @(api :<|> ActuatorEndpoint)) (ser :<|> actuatorEndpoint hr ac) else go pSer ser -- | default http server by warp. @@ -175,7 +176,7 @@ emptyAM = C.id -- | Simple Application context -type Simple = '[LogFuncHolder] +type Simple = '[SourcePack, LogFuncHolder] -- | Simple Application with logger context. type AppSimple = AppV Simple IO diff --git a/src/Yam/App.hs b/src/Yam/App.hs --- a/src/Yam/App.hs +++ b/src/Yam/App.hs @@ -1,6 +1,8 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE UndecidableInstances #-} module Yam.App where +import Control.Monad.Catch hiding (Handler) import Control.Monad.IO.Unlift import Control.Monad.Logger.CallStack import Control.Monad.Reader @@ -8,7 +10,7 @@ import Salak import Servant import Yam.Logger -import Yam.Prelude +import Yam.Prelude hiding (catch) -- | Application Context Monad. newtype AppT cxt m a = AppT { runAppT' :: ReaderT (Context cxt) m a } deriving (Functor, Applicative, Monad) @@ -22,6 +24,9 @@ -- | Application with 'SourcePack' type AppS cxt = AppV (SourcePack : cxt) +instance MonadThrow m => MonadThrow (AppT cxt m) where + throwM = AppT . lift . throwM + instance MonadTrans (AppT cxt) where lift = AppT . lift @@ -32,6 +37,11 @@ ask = AppT ask local f (AppT a) = AppT $ local f a +instance MonadCatch m => MonadCatch (AppT cxt m) where + catch (AppT m) f = do + c <- ask + lift $ runReaderT m c `catch` (\e -> runReaderT (runAppT' $ f e) c) + instance MonadUnliftIO m => MonadUnliftIO (AppT cxt m) where askUnliftIO = do cxt <- ask @@ -65,10 +75,10 @@ runAppT :: Context cxt -> AppT cxt m a -> m a runAppT c a = runReaderT (runAppT' a) c -instance (HasContextEntry cxt SourcePack, Monad m) => HasSourcePack (AppT cxt m) where - askSourcePack = getEntry +instance (HasContextEntry cxt SourcePack, Monad m) => MonadSalak (AppT cxt m) where + askSalak = getEntry -type HasSalak cxt = HasContextEntry cxt SourcePack +type HasSalaks cxt = HasContextEntry cxt SourcePack -- | Run Application with 'Vault'. runVault :: MonadIO m => Context cxt -> Vault -> AppV cxt IO a -> m a diff --git a/src/Yam/Config.hs b/src/Yam/Config.hs --- a/src/Yam/Config.hs +++ b/src/Yam/Config.hs @@ -18,7 +18,7 @@ instance Default AppConfig where def = AppConfig "application" "localhost" 8888 2048 -instance FromProp AppConfig where +instance MonadCatch m => FromProp m AppConfig where fromProp = AppConfig <$> "name" .?: name <*> "host" .?: hostname diff --git a/src/Yam/Logger.hs b/src/Yam/Logger.hs --- a/src/Yam/Logger.hs +++ b/src/Yam/Logger.hs @@ -4,6 +4,7 @@ withLogger , getLogger , extensionLogKey + , liftX , LogConfig(..) , HasLogger , LogFuncHolder(..) @@ -11,6 +12,7 @@ ) where import Control.Monad.IO.Unlift import Control.Monad.Logger.CallStack +import Data.Text (unpack) import qualified Data.Vault.Lazy as L import Data.Word import Salak @@ -18,12 +20,14 @@ import System.Log.FastLogger import Yam.Prelude -instance FromEnumProp LogLevel where - fromEnumProp "debug" = Right LevelDebug - fromEnumProp "info" = Right LevelInfo - fromEnumProp "warn" = Right LevelWarn - fromEnumProp "error" = Right LevelError - fromEnumProp _ = Right $ LevelOther "fatal" +instance MonadThrow m => FromProp m LogLevel where + fromProp = readEnum fromEnumProp + where + fromEnumProp "debug" = Right LevelDebug + fromEnumProp "info" = Right LevelInfo + fromEnumProp "warn" = Right LevelWarn + fromEnumProp "error" = Right LevelError + fromEnumProp u = Left $ "unknown level: " ++ unpack u {-# INLINE toStr #-} toStr :: LogLevel -> LogStr @@ -39,13 +43,12 @@ , file :: FilePath -- ^ Logger file path. , maxSize :: Word32 -- ^ Max logger file size. , rotateHistory :: Word16 -- ^ Max number of logger files should be reserved. - , level :: LogLevel -- ^ Log level to show. - } deriving (Eq, Show) - + , level :: IO LogLevel -- ^ Log level to show. + } instance Default LogConfig where - def = LogConfig 4096 "" 10485760 256 LevelInfo + def = LogConfig 4096 "" 10485760 256 (return LevelInfo) -instance FromProp LogConfig where +instance (MonadIO m, MonadCatch m) => FromProp m LogConfig where fromProp = LogConfig <$> "buffer-size" .?: bufferSize <*> "file" .?: file @@ -53,9 +56,8 @@ <*> "max-history" .?: rotateHistory <*> "level" .?: level -newLogger :: Text -> IO LogConfig -> IO (LogFunc, IO ()) -newLogger name lc = do - LogConfig{..} <- lc +newLogger :: Text -> LogConfig -> IO (LogFunc, IO ()) +newLogger name LogConfig{..} = do tc <- newTimeCache "%Y-%m-%d %T" let ft = if file == "" then LogStdout $ fromIntegral bufferSize @@ -65,12 +67,16 @@ return (toLogger ln l, close) where toLogger xn f Loc{..} _ ll s = do - c <- lc - when (level c <= ll) $ f $ \t -> + lc <- level + when (lc <= ll) $ f $ \t -> let locate = if ll /= LevelError then "" else " @" <> toLogStr loc_filename <> toLogStr (show loc_start) in toLogStr t <> " " <> toStr ll <> xn <> toLogStr loc_module <> locate <> " - " <> s <> "\n" -withLogger :: (MonadUnliftIO m) => Text -> IO LogConfig -> (LogFunc -> LoggingT m a) -> m a + +liftX :: MonadIO m => LoggingT IO () -> LoggingT m () +liftX f = askLoggerIO >>= liftIO . runLoggingT f + +withLogger :: (MonadUnliftIO m) => Text -> LogConfig -> (LogFunc -> LoggingT m a) -> m a withLogger n lc action = do f <- askRunInIO liftIO $ bracket (newLogger n lc) snd $ f . runLoggingT (askLoggerIO >>= action) . fst diff --git a/src/Yam/Middleware.hs b/src/Yam/Middleware.hs --- a/src/Yam/Middleware.hs +++ b/src/Yam/Middleware.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE IncoherentInstances #-} module Yam.Middleware where import qualified Control.Category as C @@ -22,11 +23,11 @@ simpleContext a = AppMiddleware $ \c m h f -> f (a :. c) m h -- | Simple Application Middleware, just provide a config to context. -simpleConfig' :: (HasSalak cxt, FromProp a) => Text -> (a -> AppT cxt (LoggingT IO) b) -> AppMiddleware cxt (b ': cxt) +simpleConfig' :: (HasSalaks cxt, FromProp (AppT cxt (LoggingT IO)) a) => Text -> (a -> AppT cxt (LoggingT IO) b) -> AppMiddleware cxt (b ': cxt) simpleConfig' key g = AppMiddleware $ \c m h f -> runAppT c (require key) >>= \a -> runAppT c (g a) >>= \b -> f (b :. c) m h -- | Simple Application Middleware, just provide a config to context. -simpleConfig :: (HasSalak cxt, FromProp a) => Text -> AppMiddleware cxt (a ': cxt) +simpleConfig :: (HasSalaks cxt, FromProp (AppT cxt (LoggingT IO)) a) => Text -> AppMiddleware cxt (a ': cxt) simpleConfig key = simpleConfig' key return -- | Simple Application Middleware, promote a 'Middleware' to 'AppMiddleware' diff --git a/src/Yam/Middleware/Client.hs b/src/Yam/Middleware/Client.hs --- a/src/Yam/Middleware/Client.hs +++ b/src/Yam/Middleware/Client.hs @@ -23,10 +23,10 @@ instance Default ManagerSettings where def = defaultManagerSettings -instance FromProp ResponseTimeout where +instance MonadThrow m => FromProp m ResponseTimeout where fromProp = responseTimeoutMicro <$> fromProp -instance FromProp ManagerSettings where +instance MonadCatch m => FromProp m ManagerSettings where fromProp = do connCount <- "max-conns" .?: managerConnCount timeout <- "timeout" .?: managerResponseTimeout @@ -52,10 +52,8 @@ hoistC :: forall cxt api. (HasHttpClient cxt, HasClient ClientM api) => Proxy cxt -> Proxy api -> BaseUrl -> Client (AppT cxt IO) api hoistC pc p url = hoistClient p (runClient pc url) (client p) -clientMiddleware :: RunSalak (AppMiddleware cxt (HttpClient : cxt)) +clientMiddleware :: HasSalaks cxt => AppMiddleware cxt (HttpClient : cxt) clientMiddleware = clientMiddleware' id -clientMiddleware' :: (ManagerSettings -> ManagerSettings) -> RunSalak (AppMiddleware cxt (HttpClient : cxt)) -clientMiddleware' f = do - ms <- require "client" >>= liftIO . newManager . f - return $ simpleContext $ HttpClient ms +clientMiddleware' :: HasSalaks cxt => (ManagerSettings -> ManagerSettings) -> AppMiddleware cxt (HttpClient : cxt) +clientMiddleware' f = simpleConfig' "client" $ \a -> HttpClient <$> (liftIO $ newManager $ f a) diff --git a/src/Yam/Middleware/Trace.hs b/src/Yam/Middleware/Trace.hs --- a/src/Yam/Middleware/Trace.hs +++ b/src/Yam/Middleware/Trace.hs @@ -33,10 +33,10 @@ = NoTracer deriving (Eq, Show) -instance FromEnumProp TraceNotifyType where - fromEnumProp _ = Right NoTracer +instance MonadCatch m => FromProp m TraceNotifyType where + fromProp = readEnum $ \_ -> Right NoTracer -instance FromProp TraceConfig where +instance MonadCatch m => FromProp m TraceConfig where fromProp = TraceConfig <$> "enabled" .?: enabled <*> "type" .?: method diff --git a/src/Yam/Prelude.hs b/src/Yam/Prelude.hs --- a/src/Yam/Prelude.hs +++ b/src/Yam/Prelude.hs @@ -41,9 +41,7 @@ , fromJust , Version , Middleware - , RunSalak(..) - , liftSalak - , liftX + , RunSalak ) where import Control.Exception hiding (Handler) @@ -72,36 +70,6 @@ import Servant.Server.Internal.ServerError import System.IO.Unsafe (unsafePerformIO) import System.Random.MWC - -newtype RunSalak a = RunSalak { unSalak :: LoggingT (RunSalakT IO) a } deriving (Functor, Applicative, Monad) - -instance HasSourcePack RunSalak where - askSourcePack = liftSalak askSourcePack - logSP = liftSalak . logSP - readLogs = liftSalak readLogs - -instance MonadIO RunSalak where - liftIO = RunSalak . liftIO - -instance MonadLogger RunSalak where - monadLoggerLog a b c d = RunSalak (monadLoggerLog a b c d) - -instance MonadLoggerIO RunSalak where - askLoggerIO = RunSalak askLoggerIO - -instance MonadUnliftIO RunSalak where - askUnliftIO = RunSalak $ do - f <- lift askUnliftIO - lf <- askLoggerIO - return $ UnliftIO $ \ma -> unliftIO f (runLoggingT (unSalak ma) lf) - -liftSalak :: RunSalakT IO a -> RunSalak a -liftSalak = RunSalak . lift - -liftX :: LoggingT IO a -> RunSalak a -liftX f = do - lf <- askLoggerIO - liftIO $ runLoggingT f lf type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO () diff --git a/src/Yam/Server.hs b/src/Yam/Server.hs --- a/src/Yam/Server.hs +++ b/src/Yam/Server.hs @@ -1,13 +1,13 @@ module Yam.Server( actuatorEndpoint , ActuatorEndpoint + , ActuatorConfig(..) ) where import Salak import Servant import Yam.App import Yam.Logger -import Yam.Prelude import Yam.Server.Health import Yam.Server.Refresh import Yam.Swagger @@ -18,7 +18,7 @@ , health :: Bool } -instance FromProp ActuatorConfig where +instance MonadCatch m => FromProp m ActuatorConfig where fromProp = ActuatorConfig <$> "enabled" .?= False <*> "refresh.enabled" .?= True @@ -29,10 +29,5 @@ :<|> HealthEndpoint ) -endpoint :: HasLogger cxt => ActuatorConfig -> IO HealthResult -> IO ReloadResult -> ServerT ActuatorEndpoint (AppV cxt IO) -endpoint ActuatorConfig{..} hr rr = refreshEndpoint rr refresh :<|> healthEndpoint hr health - -actuatorEndpoint :: HasLogger cxt => IO HealthResult -> RunSalak (Bool, ServerT ActuatorEndpoint (AppV cxt IO)) -actuatorEndpoint hr = do - ac@ActuatorConfig{..} <- require "actuator" - (enabled,) <$> liftSalak (exec $ return . endpoint ac hr) +actuatorEndpoint :: (HasSalaks cxt, HasLogger cxt) => IO HealthResult -> ActuatorConfig -> ServerT ActuatorEndpoint (AppV cxt IO) +actuatorEndpoint rr ActuatorConfig{..} = refreshEndpoint refresh :<|> healthEndpoint rr health diff --git a/src/Yam/Server/Refresh.hs b/src/Yam/Server/Refresh.hs --- a/src/Yam/Server/Refresh.hs +++ b/src/Yam/Server/Refresh.hs @@ -9,13 +9,14 @@ type RefreshEndpoint = "refresh" :> Post '[PlainText] Text -refreshEndpoint :: (HasLogger cxt, MonadIO m) => IO ReloadResult -> Bool -> AppT cxt m Text -refreshEndpoint io True = do +refreshEndpoint :: (HasSalaks cxt, HasLogger cxt, MonadIO m) => Bool -> AppT cxt m Text +refreshEndpoint True = do + io <- askReload ReloadResult{..} <- liftIO io - if isError - then throwS err400 $ showMsg msg - else return $ showMsg msg -refreshEndpoint _ _ = throwS err401 "Refresh not allowed" + if hasError + then throwS err400 $ showMsg msgs + else return $ showMsg msgs +refreshEndpoint _ = throwS err401 "Refresh not allowed" showMsg :: [String] -> Text showMsg = pack . unlines diff --git a/src/Yam/Swagger.hs b/src/Yam/Swagger.hs --- a/src/Yam/Swagger.hs +++ b/src/Yam/Swagger.hs @@ -25,7 +25,7 @@ , enabled :: Bool -- ^ If enable swagger. } deriving (Eq, Show) -instance FromProp SwaggerConfig where +instance MonadCatch m => FromProp m SwaggerConfig where fromProp = SwaggerConfig <$> "dir" .?= "swagger-ui" <*> "schema" .?= "swagger-ui.json" diff --git a/yam.cabal b/yam.cabal --- a/yam.cabal +++ b/yam.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 name: yam -version: 0.6.3 +version: 0.7 license: BSD3 license-file: LICENSE copyright: (c) 2018 Daniel YU @@ -50,16 +50,16 @@ RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeOperators TypeSynonymInstances ViewPatterns - ghc-options: -Wall + ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures build-depends: - aeson >=1.4.2.0 && <1.5, + aeson >=1.4.4.0 && <1.5, base >=4.10 && <5, base16-bytestring >=0.1.1.6 && <0.2, binary >=0.8.6.0 && <0.9, bytestring >=0.10.8.2 && <0.11, data-default >=0.7.1.1 && <0.8, exceptions >=0.10.2 && <0.11, - fast-logger >=2.4.15 && <2.5, + fast-logger >=2.4.16 && <2.5, http-client >=0.6.4 && <0.7, http-types >=0.12.3 && <0.13, lens >=4.17.1 && <4.18, @@ -68,21 +68,21 @@ mtl >=2.2.2 && <2.3, mwc-random >=0.14.0.0 && <0.15, reflection >=2.1.4 && <2.2, - salak >=0.2.9.3 && <0.3, + salak ==0.3.*, scientific >=0.3.6.2 && <0.4, servant-client ==0.16.*, servant-server ==0.16.*, servant-swagger >=1.1.7.1 && <1.2, - servant-swagger-ui >=0.3.3.3.22.2 && <0.4, + servant-swagger-ui >=0.3.4.3.22.2 && <0.4, swagger2 >=2.3.0.1 && <2.5, text >=1.2.3.1 && <1.3, transformers >=0.5.6.2 && <0.6, unliftio-core >=0.1.2.0 && <0.2, unordered-containers >=0.2.10.0 && <0.3, - vault >=0.3.1.2 && <0.4, + vault >=0.3.1.3 && <0.4, vector >=0.12.0.3 && <0.13, - wai >=3.2.2 && <3.3, - warp >=3.2.27 && <3.3 + wai >=3.2.2.1 && <3.3, + warp >=3.2.27 && <3.4 test-suite spec type: exitcode-stdio-1.0 @@ -120,17 +120,17 @@ RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeOperators TypeSynonymInstances ViewPatterns - ghc-options: -Wall + ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures build-depends: - QuickCheck >=2.13.1 && <2.14, - aeson >=1.4.2.0 && <1.5, + QuickCheck >=2.13.2 && <2.14, + aeson >=1.4.4.0 && <1.5, base >=4.10 && <5, base16-bytestring >=0.1.1.6 && <0.2, binary >=0.8.6.0 && <0.9, bytestring >=0.10.8.2 && <0.11, data-default >=0.7.1.1 && <0.8, exceptions >=0.10.2 && <0.11, - fast-logger >=2.4.15 && <2.5, + fast-logger >=2.4.16 && <2.5, hspec ==2.*, http-client >=0.6.4 && <0.7, http-types >=0.12.3 && <0.13, @@ -140,18 +140,18 @@ mtl >=2.2.2 && <2.3, mwc-random >=0.14.0.0 && <0.15, reflection >=2.1.4 && <2.2, - salak >=0.2.9.3 && <0.3, + salak ==0.3.*, scientific >=0.3.6.2 && <0.4, servant-client ==0.16.*, servant-server ==0.16.*, servant-swagger >=1.1.7.1 && <1.2, - servant-swagger-ui >=0.3.3.3.22.2 && <0.4, + servant-swagger-ui >=0.3.4.3.22.2 && <0.4, swagger2 >=2.3.0.1 && <2.5, text >=1.2.3.1 && <1.3, transformers >=0.5.6.2 && <0.6, unliftio-core >=0.1.2.0 && <0.2, unordered-containers >=0.2.10.0 && <0.3, - vault >=0.3.1.2 && <0.4, + vault >=0.3.1.3 && <0.4, vector >=0.12.0.3 && <0.13, - wai >=3.2.2 && <3.3, - warp >=3.2.27 && <3.3 + wai >=3.2.2.1 && <3.3, + warp >=3.2.27 && <3.4