yam 0.6.3 → 0.7
raw patch · 12 files changed
+109/−129 lines, 12 filesdep ~QuickCheckdep ~aesondep ~fast-logger
Dependency ranges changed: QuickCheck, aeson, fast-logger, salak, servant-swagger-ui, vault, wai, warp
Files
- src/Yam.hs +28/−27
- src/Yam/App.hs +15/−5
- src/Yam/Config.hs +1/−1
- src/Yam/Logger.hs +23/−17
- src/Yam/Middleware.hs +3/−2
- src/Yam/Middleware/Client.hs +5/−7
- src/Yam/Middleware/Trace.hs +3/−3
- src/Yam/Prelude.hs +1/−33
- src/Yam/Server.hs +4/−9
- src/Yam/Server/Refresh.hs +7/−6
- src/Yam/Swagger.hs +1/−1
- yam.cabal +18/−18
src/Yam.hs view
@@ -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
src/Yam/App.hs view
@@ -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
src/Yam/Config.hs view
@@ -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
src/Yam/Logger.hs view
@@ -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
src/Yam/Middleware.hs view
@@ -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'
src/Yam/Middleware/Client.hs view
@@ -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)
src/Yam/Middleware/Trace.hs view
@@ -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
src/Yam/Prelude.hs view
@@ -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 ()
src/Yam/Server.hs view
@@ -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
src/Yam/Server/Refresh.hs view
@@ -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
src/Yam/Swagger.hs view
@@ -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"
yam.cabal view
@@ -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