diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,163 @@ +Apache License + +Version 2.0, January 2004 + +http://www.apache.org/licenses/ + +TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + +1. Definitions. + +"License" shall mean the terms and conditions for use, reproduction, and +distribution as defined by Sections 1 through 9 of this document. + +"Licensor" shall mean the copyright owner or entity authorized by the +copyright owner that is granting the License. + +"Legal Entity" shall mean the union of the acting entity and all other +entities that control, are controlled by, or are under common control with +that entity. For the purposes of this definition, "control" means (i) the +power, direct or indirect, to cause the direction or management of such +entity, whether by contract or otherwise, or (ii) ownership of fifty percent +(50%) or more of the outstanding shares, or (iii) beneficial ownership of such +entity. + +"You" (or "Your") shall mean an individual or Legal Entity exercising +permissions granted by this License. + +"Source" form shall mean the preferred form for making modifications, +including but not limited to software source code, documentation source, and +configuration files. + +"Object" form shall mean any form resulting from mechanical transformation or +translation of a Source form, including but not limited to compiled object +code, generated documentation, and conversions to other media types. + +"Work" shall mean the work of authorship, whether in Source or Object form, +made available under the License, as indicated by a copyright notice that is +included in or attached to the work (an example is provided in the Appendix +below). + +"Derivative Works" shall mean any work, whether in Source or Object form, that +is based on (or derived from) the Work and for which the editorial revisions, +annotations, elaborations, or other modifications represent, as a whole, an +original work of authorship. For the purposes of this License, Derivative +Works shall not include works that remain separable from, or merely link (or +bind by name) to the interfaces of, the Work and Derivative Works thereof. + +"Contribution" shall mean any work of authorship, including the original +version of the Work and any modifications or additions to that Work or +Derivative Works thereof, that is intentionally submitted to Licensor for +inclusion in the Work by the copyright owner or by an individual or Legal +Entity authorized to submit on behalf of the copyright owner. For the purposes +of this definition, "submitted" means any form of electronic, verbal, or +written communication sent to the Licensor or its representatives, including +but not limited to communication on electronic mailing lists, source code +control systems, and issue tracking systems that are managed by, or on behalf +of, the Licensor for the purpose of discussing and improving the Work, but +excluding communication that is conspicuously marked or otherwise designated +in writing by the copyright owner as "Not a Contribution." + +"Contributor" shall mean Licensor and any individual or Legal Entity on behalf +of whom a Contribution has been received by Licensor and subsequently +incorporated within the Work. + +2. Grant of Copyright License. Subject to the terms and conditions of this +License, each Contributor hereby grants to You a perpetual, worldwide, +non-exclusive, no-charge, royalty-free, irrevocable copyright license to +reproduce, prepare Derivative Works of, publicly display, publicly perform, +sublicense, and distribute the Work and such Derivative Works in Source or +Object form. + +3. Grant of Patent License. Subject to the terms and conditions of this +License, each Contributor hereby grants to You a perpetual, worldwide, +non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this +section) patent license to make, have made, use, offer to sell, sell, import, +and otherwise transfer the Work, where such license applies only to those +patent claims licensable by such Contributor that are necessarily infringed by +their Contribution(s) alone or by combination of their Contribution(s) with +the Work to which such Contribution(s) was submitted. If You institute patent +litigation against any entity (including a cross-claim or counterclaim in a +lawsuit) alleging that the Work or a Contribution incorporated within the Work +constitutes direct or contributory patent infringement, then any patent +licenses granted to You under this License for that Work shall terminate as of +the date such litigation is filed. + +4. Redistribution. You may reproduce and distribute copies of the Work or +Derivative Works thereof in any medium, with or without modifications, and in +Source or Object form, provided that You meet the following conditions: + +You must give any other recipients of the Work or Derivative Works a copy of +this License; and + +You must cause any modified files to carry prominent notices stating that You +changed the files; and + +You must retain, in the Source form of any Derivative Works that You +distribute, all copyright, patent, trademark, and attribution notices from the +Source form of the Work, excluding those notices that do not pertain to any +part of the Derivative Works; and + +If the Work includes a "NOTICE" text file as part of its distribution, then +any Derivative Works that You distribute must include a readable copy of the +attribution notices contained within such NOTICE file, excluding those notices +that do not pertain to any part of the Derivative Works, in at least one of +the following places: within a NOTICE text file distributed as part of the +Derivative Works; within the Source form or documentation, if provided along +with the Derivative Works; or, within a display generated by the Derivative +Works, if and wherever such third-party notices normally appear. The contents +of the NOTICE file are for informational purposes only and do not modify the +License. You may add Your own attribution notices within Derivative Works that +You distribute, alongside or as an addendum to the NOTICE text from the Work, +provided that such additional attribution notices cannot be construed as +modifying the License. + +You may add Your own copyright statement to Your modifications and may provide +additional or different license terms and conditions for use, reproduction, or +distribution of Your modifications, or for any such Derivative Works as a +whole, provided Your use, reproduction, and distribution of the Work otherwise +complies with the conditions stated in this License. + +5. Submission of Contributions. Unless You explicitly state otherwise, any +Contribution intentionally submitted for inclusion in the Work by You to the +Licensor shall be under the terms and conditions of this License, without any +additional terms or conditions. Notwithstanding the above, nothing herein +shall supersede or modify the terms of any separate license agreement you may +have executed with Licensor regarding such Contributions. + +6. Trademarks. This License does not grant permission to use the trade names, +trademarks, service marks, or product names of the Licensor, except as +required for reasonable and customary use in describing the origin of the Work +and reproducing the content of the NOTICE file. + +7. Disclaimer of Warranty. Unless required by applicable law or agreed to in +writing, Licensor provides the Work (and each Contributor provides its +Contributions) on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY +KIND, either express or implied, including, without limitation, any warranties +or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A +PARTICULAR PURPOSE. You are solely responsible for determining the +appropriateness of using or redistributing the Work and assume any risks +associated with Your exercise of permissions under this License. + +8. Limitation of Liability. In no event and under no legal theory, whether in +tort (including negligence), contract, or otherwise, unless required by +applicable law (such as deliberate and grossly negligent acts) or agreed to in +writing, shall any Contributor be liable to You for damages, including any +direct, indirect, special, incidental, or consequential damages of any +character arising as a result of this License or out of the use or inability +to use the Work (including but not limited to damages for loss of goodwill, +work stoppage, computer failure or malfunction, or any and all other +commercial damages or losses), even if such Contributor has been advised of +the possibility of such damages. + +9. Accepting Warranty or Additional Liability. While redistributing the Work +or Derivative Works thereof, You may choose to offer, and charge a fee for, +acceptance of support, warranty, indemnity, or other liability obligations +and/or rights consistent with this License. However, in accepting such +obligations, You may act only on Your own behalf and on Your sole +responsibility, not on behalf of any other Contributor, and only if You agree +to indemnify, defend, and hold each Contributor harmless for any liability +incurred by, or claims asserted against, such Contributor by reason of your +accepting any such warranty or additional liability. + +END OF TERMS AND CONDITIONS diff --git a/jml-web-service.cabal b/jml-web-service.cabal new file mode 100644 --- /dev/null +++ b/jml-web-service.cabal @@ -0,0 +1,75 @@ +-- This file has been generated from package.yaml by hpack version 0.20.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 797d81a87d712077af6ca7831011f5a91155ba63ac6309462407444c50a25e2b + +name: jml-web-service +version: 0.1.0 +synopsis: Common utilities for running a web service +description: This is a personal set of helper functions used to create a web API service. + . + We assume that the service is intended to run in a container on a Kubernetes + cluster, but it\'s likely that these routines would be useful for other + services. + . + We provide command-line options for use with optparse-applicative, + Prometheus instrumentation, and some basic logging. +category: Web +homepage: https://github.com/jml/jml-web-service#readme +bug-reports: https://github.com/jml/jml-web-service/issues +maintainer: Jonathan M. Lange +license: Apache-2.0 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 + +source-repository head + type: git + location: https://github.com/jml/jml-web-service + +library + hs-source-dirs: + src + default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards TypeApplications + ghc-options: -Wall + build-depends: + base >=4.10 && <5 + , bytestring + , clock + , data-default + , http-types + , monad-logger + , optparse-applicative + , prometheus-client + , prometheus-metrics-ghc + , protolude >=0.2 + , text + , wai + , wai-extra + , warp + exposed-modules: + JmlSvc + JmlSvc.Instrument + JmlSvc.Logging + JmlSvc.Metrics + JmlSvc.Web + other-modules: + Paths_jml_web_service + default-language: Haskell2010 + +test-suite tasty + type: exitcode-stdio-1.0 + main-is: Tasty.hs + hs-source-dirs: + tests + default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards TypeApplications + ghc-options: -Wall + build-depends: + base >=4.10 && <5 + , jml-web-service + , protolude >=0.2 + , tasty + other-modules: + Paths_jml_web_service + default-language: Haskell2010 diff --git a/src/JmlSvc.hs b/src/JmlSvc.hs new file mode 100644 --- /dev/null +++ b/src/JmlSvc.hs @@ -0,0 +1,32 @@ +module JmlSvc + ( Config(..) + , flags + , run + ) where + +import Protolude + +import qualified Network.Wai as Wai +import qualified Options.Applicative as Options + +import qualified JmlSvc.Logging as Logging +import qualified JmlSvc.Metrics as Metrics +import qualified JmlSvc.Web as Web + +-- | Generic web server configuration. +data Config = Config + { loggingConfig :: Logging.Config + , metricsConfig :: Metrics.Config + , webConfig :: Web.Config + } deriving (Eq, Show) + +-- | Command-line flags for generating 'Config'. +flags :: Options.Parser Config +flags = Config <$> Logging.flags <*> Metrics.flags <*> Web.flags + +-- | Run a web server for 'app'. Blocks until the server is shut down. +run :: MonadIO io => Text -> Config -> Wai.Application -> io () +run appName Config {..} app = + Logging.run loggingConfig $ do + prometheus <- Metrics.prometheus appName metricsConfig + Web.run webConfig (prometheus app) diff --git a/src/JmlSvc/Instrument.hs b/src/JmlSvc/Instrument.hs new file mode 100644 --- /dev/null +++ b/src/JmlSvc/Instrument.hs @@ -0,0 +1,78 @@ +-- | This module provides "Network.Wai" middlware for exporting "Prometheus" +-- metrics and for instrumenting WAI applications. +module JmlSvc.Instrument + ( prometheus + , requestLatency + ) where + +import Protolude + +import qualified Data.ByteString.Builder as BS +import qualified Data.Default as Default +import Data.Ratio ((%)) +import Data.String (String) +import qualified Network.HTTP.Types as HTTP +import qualified Network.Wai as Wai +import qualified Prometheus as Prom +import System.Clock (Clock(..), diffTimeSpec, getTime, toNanoSecs) + +-- | Settings that control the behavior of the Prometheus middleware. +data PrometheusSettings = PrometheusSettings + { prometheusEndPoint :: [Text] + -- ^ The path that will be used for exporting metrics. The default value + -- is ["metrics"] which corresponds to the path /metrics. + , prometheusHandlerName :: Maybe Text + -- ^ The name of the handler used to record metrics about the Prometheus + -- endpoint. If Nothing, then we won't record any. + } + +instance Default.Default PrometheusSettings where + def = PrometheusSettings {prometheusEndPoint = ["metrics"], prometheusHandlerName = Just "metrics"} + +type RequestLatency = Prom.Metric (Prom.Vector Prom.Label3 Prom.Histogram) + +requestLatency :: IO RequestLatency +requestLatency = Prom.vector ("handler", "method", "status_code") $ Prom.histogram info Prom.defaultBuckets + where + info = Prom.Info "http_request_duration_seconds" "The HTTP request latencies in seconds." + +-- | Instrument a WAI app with the default WAI metrics. +-- +-- If you use this function you will likely want to override the default value +-- of 'prometheusInstrumentApp' to be false so that your app does not get double +-- instrumented. +instrumentApp :: + RequestLatency -- ^ Metric to record thingy on + -> Text -- ^ The label used to identify this app + -> Wai.Application -- ^ The app to instrument + -> Wai.Application -- ^ The instrumented app +instrumentApp metric handler app req respond = do + start <- getTime Monotonic + app req $ \res -> do + end <- getTime Monotonic + let method = toS (Wai.requestMethod req) + let status = show @Int @String (HTTP.statusCode (Wai.responseStatus res)) + let latency = fromRational $ toRational (toNanoSecs (end `diffTimeSpec` start) % 1000000000) + Prom.withLabel (toS handler, method, status) (Prom.observe latency) metric + respond res + +-- | Instrument an app with Prometheus and export metrics from the configured +-- handler. +prometheus :: + PrometheusSettings -- ^ How we're going to use Prometheus + -> RequestLatency -- ^ A metric to instrument with request information + -> Text -- ^ The label used to identify the app + -> Wai.Middleware +prometheus PrometheusSettings {..} duration appName app req respond = + if Wai.requestMethod req == HTTP.methodGet && Wai.pathInfo req == prometheusEndPoint + then case prometheusHandlerName of + Nothing -> respondWithMetrics respond + Just name -> instrumentApp duration name (const respondWithMetrics) req respond + else instrumentApp duration appName app req respond + +respondWithMetrics :: (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived +respondWithMetrics respond = do + metrics <- Prom.exportMetricsAsText + respond $ Wai.responseBuilder HTTP.status200 headers $ BS.byteString metrics + where + headers = [(HTTP.hContentType, "text/plain; version=0.0.4")] diff --git a/src/JmlSvc/Logging.hs b/src/JmlSvc/Logging.hs new file mode 100644 --- /dev/null +++ b/src/JmlSvc/Logging.hs @@ -0,0 +1,48 @@ +-- | Configuration for "Control.Monad.Logger". +module JmlSvc.Logging + ( flags + , Config + , run + ) where + +import Protolude + +import qualified Control.Monad.Logger as Logger +import qualified Options.Applicative as Options + +-- | Configuration for logging. +newtype Config = Config Logger.LogLevel deriving (Eq, Show) + +-- | Command-line flags controlling logging. +flags :: Options.Parser Config +flags = + Config <$> Options.option + (Options.eitherReader (pure . fromKeyword . toS)) + (fold + [ Options.long "log-level" + , Options.help "Minimum severity for log messages" + , Options.value Logger.LevelInfo + ]) + +-- | Run a logging action using the given config. +run :: MonadIO io => Config -> Logger.LoggingT io a -> io a +run (Config severity) action = + Logger.runStdoutLoggingT (Logger.filterLogger predicate action) + where + predicate _source level = level >= severity + +type Keyword = Text + +fromKeyword :: Keyword -> Logger.LogLevel +fromKeyword "error" = Logger.LevelError +fromKeyword "warn" = Logger.LevelWarn +fromKeyword "info" = Logger.LevelInfo +fromKeyword "debug" = Logger.LevelDebug +fromKeyword other = Logger.LevelOther other + +_toKeyword :: Logger.LogLevel -> Keyword +_toKeyword Logger.LevelError = "error" +_toKeyword Logger.LevelWarn = "warn" +_toKeyword Logger.LevelInfo = "info" +_toKeyword Logger.LevelDebug = "debug" +_toKeyword (Logger.LevelOther other) = other diff --git a/src/JmlSvc/Metrics.hs b/src/JmlSvc/Metrics.hs new file mode 100644 --- /dev/null +++ b/src/JmlSvc/Metrics.hs @@ -0,0 +1,34 @@ +module JmlSvc.Metrics (Config(..), flags, prometheus) where + +import Protolude + +import qualified Control.Monad.Logger as Logger +import qualified Data.Default as Default +import GHC.Stats (getRTSStatsEnabled) +import qualified Network.Wai as Wai +import qualified Options.Applicative as Options + +import qualified Prometheus as Prom +import qualified Prometheus.Metric.GHC as Prom + +import qualified JmlSvc.Instrument as Instrument + +-- | Generic web server configuration. +newtype Config = Config + { enableGhcMetrics :: Bool -- ^ Whether to include Prometheus metrics for GHC runtime stats + } deriving (Eq, Show) + +-- | Command-line flags for generating 'Config'. +flags :: Options.Parser Config +flags = + Config <$> Options.switch (fold [Options.long "ghc-metrics", Options.help "Export GHC metrics. Requires running with +RTS."]) + +-- | Run a web server for 'app'. Blocks until the server is shut down. +prometheus :: (Logger.MonadLogger m, MonadIO m) => Text -> Config -> m Wai.Middleware +prometheus appName Config {..} = do + requests <- liftIO $ Prom.registerIO Instrument.requestLatency + when enableGhcMetrics $ do + statsEnabled <- liftIO getRTSStatsEnabled + unless statsEnabled $ Logger.logWarnN "Exporting GHC metrics but GC stats not enabled. Re-run with +RTS -T." + void . liftIO $ Prom.register Prom.ghcMetrics + pure $ Instrument.prometheus Default.def requests appName diff --git a/src/JmlSvc/Web.hs b/src/JmlSvc/Web.hs new file mode 100644 --- /dev/null +++ b/src/JmlSvc/Web.hs @@ -0,0 +1,65 @@ +module JmlSvc.Web + ( Config(..) + , flags + , run + ) where + +import Protolude + +import qualified Network.Wai as Wai +import qualified Network.Wai.Handler.Warp as Warp +import qualified Network.Wai.Middleware.RequestLogger as RL +import qualified Options.Applicative as Options + +-- | Generic Warp configuration. +data Config = Config + { port :: Warp.Port -- ^ Port to listen on + , accessLogs :: AccessLogs -- ^ Level of access logs to display + , debugExceptions :: Bool -- ^ Whether to show detailed exception information on 500s + } deriving (Eq, Show) + +-- | Command-line flags for generating 'Config'. +flags :: Options.Parser Config +flags = + Config <$> + Options.option Options.auto (fold [Options.long "port", Options.metavar "PORT", Options.help "Port to listen on"]) <*> + Options.option + (Options.eitherReader parseAccessLogs) + (fold [Options.long "access-logs", Options.help "How to log HTTP access", Options.value Disabled]) <*> + Options.switch (fold [Options.long "debug-exceptions", Options.help "Show exceptions on 500."]) + where + parseAccessLogs "none" = pure Disabled + parseAccessLogs "basic" = pure Enabled + parseAccessLogs "dev" = pure DevMode + parseAccessLogs _ = throwError "One of 'none', 'basic', or 'dev'" + +-- | What level of access logs to show. +data AccessLogs + = Disabled -- ^ Don't show access logs. + | Enabled -- ^ Show Apache-style access logs. + | DevMode -- ^ Show detailed, colorful access logs. Not suitable in production. + deriving (Eq, Show) + +-- | Run a web server for 'app'. Blocks until the server is shut down. +run :: MonadIO io => Config -> Wai.Application -> io () +run config@Config {..} app = liftIO $ Warp.runSettings settings (logging app) + where + settings = warpSettings config + logging = + case accessLogs of + Disabled -> identity + Enabled -> RL.logStdout + DevMode -> RL.logStdoutDev + +-- | Generate warp settings from config +-- +-- Serve from a port and print out where we're serving from. +warpSettings :: Config -> Warp.Settings +warpSettings Config {..} = + Warp.setOnExceptionResponse exceptionHandler . Warp.setBeforeMainLoop printPort . Warp.setPort port $ + Warp.defaultSettings + where + printPort = putText $ "Listening on: " <> show port + exceptionHandler + | debugExceptions = Warp.exceptionResponseForDebug + | otherwise = Warp.defaultOnExceptionResponse diff --git a/tests/Tasty.hs b/tests/Tasty.hs new file mode 100644 --- /dev/null +++ b/tests/Tasty.hs @@ -0,0 +1,10 @@ +module Main (main) where + +import Protolude + +import Test.Tasty (defaultMain, testGroup) + +main :: IO () +main = sequence tests >>= defaultMain . testGroup "jml-web-service" + where + tests = []