packages feed

jml-web-service (empty) → 0.1.0

raw patch · 8 files changed

+505/−0 lines, 8 filesdep +basedep +bytestringdep +clock

Dependencies added: base, bytestring, clock, data-default, http-types, jml-web-service, monad-logger, optparse-applicative, prometheus-client, prometheus-metrics-ghc, protolude, tasty, text, wai, wai-extra, warp

Files

+ LICENSE view
@@ -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
+ jml-web-service.cabal view
@@ -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 <jml@mumak.net>+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
+ src/JmlSvc.hs view
@@ -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)
+ src/JmlSvc/Instrument.hs view
@@ -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")]
+ src/JmlSvc/Logging.hs view
@@ -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
+ src/JmlSvc/Metrics.hs view
@@ -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
+ src/JmlSvc/Web.hs view
@@ -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
+ tests/Tasty.hs view
@@ -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 = []