Add Prometheus middleware for gundeck, cannon, cargohold, brig, proxy (…

…#672)

* Add prometheus middleware to remaining services (all except galley)

REFACTOR: refactor tests to use TestSetup module
REFACTOR: refactor services to use 'Run' module

libs/metrics-wai/src/Data/Metrics/Middleware/Prometheus.hs

@@ -7,15 +7,17 @@ import qualified Network.Wai.Middleware.Prometheus as Promth
 import qualified Data.Text.Encoding                as T
 
 import Data.Metrics.WaiRoute (treeToPaths)
+import Data.Metrics.Types (Paths)
 import Data.Metrics.Types (treeLookup)
 
 -- | Adds a prometheus metrics endpoint at @/i/metrics@
 -- This middleware requires your servers 'Routes' because it does some normalization
 -- (e.g. removing params from calls)
 waiPrometheusMiddleware :: Monad m => Routes a m b -> Wai.Middleware
 waiPrometheusMiddleware routes =
-    Promth.prometheus conf . Promth.instrumentHandlerValue (normalizeWaiRequestRoute routes)
+    Promth.prometheus conf . Promth.instrumentHandlerValue (normalizeWaiRequestRoute paths)
   where
+    paths = treeToPaths $ prepare routes
     conf = Promth.def
         { Promth.prometheusEndPoint      = ["i", "metrics"]
           -- We provide our own instrumentation so we can normalize routes
@@ -25,11 +27,11 @@ waiPrometheusMiddleware routes =
 -- | Compute a normalized route for a given request.
 -- Normalized routes have route parameters replaced with their identifier
 -- e.g. @/user/1234@ might become @/user/userid@
-normalizeWaiRequestRoute :: Monad m => Routes a m b -> Wai.Request -> Text
-normalizeWaiRequestRoute routes req = pathInfo
+normalizeWaiRequestRoute :: Paths -> Wai.Request -> Text
+normalizeWaiRequestRoute paths req = pathInfo
   where
     mPathInfo :: Maybe ByteString
-    mPathInfo = treeLookup (treeToPaths $ prepare routes) (T.encodeUtf8 <$> Wai.pathInfo req)
+    mPathInfo = treeLookup paths (T.encodeUtf8 <$> Wai.pathInfo req)
 
     -- Use the normalized path info if available; otherwise dump the raw path info for
     -- debugging purposes

libs/wai-utilities/src/Network/Wai/Utilities/Server.hs

@@ -173,7 +173,8 @@ route rt rq k = Route.routeWith (Route.Config $ errorRs' noEndpoint) rt rq (lift
 --------------------------------------------------------------------------------
 -- Middlewares
 
--- | Create a middleware that tracks detailed request / response
+-- | DEPRECATED; use 'waiPrometheusMiddleware' instead.
+-- Create a middleware that tracks detailed request / response
 -- statistics, including timing information, for every path in the
 -- given routing tree.
 --

services/brig/package.yaml

@@ -47,6 +47,7 @@ library:
   - Brig.Options
   - Brig.Provider.DB
   - Brig.RPC
+  - Brig.Run
   - Brig.User.Auth.Cookie.Limit
   - Brig.User.Search.Index
   - Brig.ZAuth

services/brig/src/Brig/API.hs

@@ -1,10 +1,9 @@
 {-# LANGUAGE RecordWildCards   #-}
 
-module Brig.API (runServer) where
+module Brig.API (sitemap) where
 
 import Imports hiding (head)
 import Brig.App
-import Brig.AWS (sesQueue)
 import Brig.API.Error
 import Brig.API.Handler
 import Brig.API.Types
@@ -17,15 +16,12 @@ import Brig.User.Email
 import Brig.User.Phone
 import Control.Error hiding (bool)
 import Control.Lens (view, (^.))
-import Control.Monad.Catch (finally)
 import Data.Aeson hiding (json)
 import Data.ByteString.Conversion
 import Data.Id
 import Data.Metrics.Middleware hiding (metrics)
-import Data.Metrics.WaiRoute (treeToPaths)
 import Data.Misc (IpAddr (..))
 import Data.Range
-import Data.Text (unpack)
 import Data.Text.Encoding (decodeLatin1)
 import Data.Text.Lazy (pack)
 import Galley.Types (UserClients (..))
@@ -34,37 +30,27 @@ import Network.Wai (Request, Response, responseLBS, lazyRequestBody)
 import Network.Wai.Predicate hiding (setStatus, result)
 import Network.Wai.Routing
 import Network.Wai.Utilities
-import Network.Wai.Utilities.Server
 import Network.Wai.Utilities.Swagger (document, mkSwaggerApi)
-import Util.Options
 
 import qualified Data.Text.Ascii               as Ascii
 import qualified Data.List1                    as List1
-import qualified Control.Concurrent.Async      as Async
 import qualified Brig.API.Client               as API
 import qualified Brig.API.Connection           as API
 import qualified Brig.API.Properties           as API
 import qualified Brig.API.User                 as API
 import qualified Brig.Data.User                as Data
-import qualified Brig.Queue                    as Queue
 import qualified Brig.Team.Util                as Team
 import qualified Brig.User.API.Auth            as Auth
 import qualified Brig.User.API.Search          as Search
 import qualified Brig.User.Auth.Cookie         as Auth
-import qualified Brig.AWS                      as AWS
-import qualified Brig.AWS.SesNotification      as SesNotification
-import qualified Brig.InternalEvent.Process    as Internal
 import qualified Brig.Types.Swagger            as Doc
 import qualified Network.Wai.Utilities.Swagger as Doc
 import qualified Data.Swagger.Build.Api        as Doc
 import qualified Galley.Types.Swagger          as Doc
 import qualified Galley.Types.Teams            as Team
-import qualified Network.Wai.Middleware.Gzip   as GZip
-import qualified Network.Wai.Middleware.Gunzip as GZip
 import qualified Network.Wai.Utilities         as Utilities
 import qualified Data.ByteString.Lazy          as Lazy
 import qualified Data.Map.Strict               as Map
-import qualified Network.Wai.Utilities.Server  as Server
 import qualified Data.Set                      as Set
 import qualified Data.Text                     as Text
 import qualified Brig.Provider.API             as Provider
@@ -73,31 +59,6 @@ import qualified Brig.Team.Email               as Team
 import qualified Brig.TURN.API                 as TURN
 import qualified System.Logger.Class           as Log
 
-runServer :: Opts -> IO ()
-runServer o = do
-    e <- newEnv o
-    s <- Server.newSettings (server e)
-    emailListener <- for (e^.awsEnv.sesQueue) $ \q ->
-        Async.async $
-        AWS.execute (e^.awsEnv) $
-        AWS.listen q (runAppT e . SesNotification.onEvent)
-    internalEventListener <- Async.async $
-        runAppT e $ Queue.listen (e^.internalEvents) Internal.onEvent
-    runSettingsWithShutdown s (pipeline e) 5 `finally` do
-        mapM_ Async.cancel emailListener
-        Async.cancel internalEventListener
-        closeEnv e
-  where
-    rtree      = compile (sitemap o)
-    endpoint   = brig o
-    server   e = defaultServer (unpack $ endpoint^.epHost) (endpoint^.epPort) (e^.applog) (e^.metrics)
-    pipeline e = measureRequests (e^.metrics) (treeToPaths rtree)
-               . catchErrors (e^.applog) (e^.metrics)
-               . GZip.gunzip . GZip.gzip GZip.def
-               $ serve e
-
-    serve e r k = runHandler e r (Server.route rtree r k) k
-
 ---------------------------------------------------------------------------
 -- Sitemap
 

services/brig/src/Brig/Run.hs

@@ -0,0 +1,54 @@
+module Brig.Run (run) where
+
+import           Imports                      hiding (head)
+import           Brig.App
+import           Brig.API                     (sitemap)
+import           Brig.AWS                     (sesQueue)
+import           Brig.API.Handler
+import           Brig.Options                 hiding (internalEvents, sesQueue)
+import           Control.Monad.Catch          (finally)
+import           Control.Lens                 ((^.))
+import           Data.Metrics.WaiRoute        (treeToPaths)
+import           Data.Text                    (unpack)
+import           Network.Wai.Utilities.Server
+import           Util.Options
+
+import qualified Control.Concurrent.Async           as Async
+import qualified Brig.Queue                         as Queue
+import qualified Brig.AWS                           as AWS
+import qualified Brig.AWS.SesNotification           as SesNotification
+import qualified Brig.InternalEvent.Process         as Internal
+import qualified Network.Wai                        as Wai
+import qualified Network.Wai.Middleware.Gzip        as GZip
+import qualified Network.Wai.Middleware.Gunzip      as GZip
+import qualified Data.Metrics.Middleware.Prometheus as Metrics
+import qualified Network.Wai.Utilities.Server       as Server
+
+
+run :: Opts -> IO ()
+run o = do
+    e <- newEnv o
+    s <- Server.newSettings (server e)
+    emailListener <- for (e^.awsEnv.sesQueue) $ \q ->
+        Async.async $
+        AWS.execute (e^.awsEnv) $
+        AWS.listen q (runAppT e . SesNotification.onEvent)
+    internalEventListener <- Async.async $
+        runAppT e $ Queue.listen (e^.internalEvents) Internal.onEvent
+    runSettingsWithShutdown s (middleware e $ serve e) 5 `finally` do
+        mapM_ Async.cancel emailListener
+        Async.cancel internalEventListener
+        closeEnv e
+  where
+    rtree      = compile (sitemap o)
+    endpoint   = brig o
+    server   e = defaultServer (unpack $ endpoint^.epHost) (endpoint^.epPort) (e^.applog) (e^.metrics)
+    middleware :: Env -> Wai.Middleware
+    middleware e = Metrics.waiPrometheusMiddleware (sitemap o)
+                 . measureRequests (e^.metrics) (treeToPaths rtree)
+                 . catchErrors (e^.applog) (e^.metrics)
+                 . GZip.gunzip . GZip.gzip GZip.def
+    serve e r k = runHandler e r (Server.route rtree r k) k
+
+
+

services/brig/src/Main.hs

@@ -1,7 +1,7 @@
 module Main (main) where
 
 import Imports
-import Brig.API
+import Brig.Run (run)
 import OpenSSL (withOpenSSL)
 
 import Util.Options
@@ -11,4 +11,4 @@ main = withOpenSSL $ do
   let desc = "Brig - User Service"
       defaultPath = "/etc/wire/brig/conf/brig.yaml"
   options <- getOptions desc Nothing defaultPath
-  runServer options
+  run options

services/brig/test/integration/API/Metrics.hs

@@ -9,6 +9,7 @@ module API.Metrics (tests) where
 
 import Imports
 import Bilge
+import Bilge.Assert
 import Brig.Types.User
 import Control.Lens
 import Data.ByteString.Conversion
@@ -24,11 +25,19 @@ import Util
 tests :: Manager -> Brig -> IO TestTree
 tests manager brig = do
     return $ testGroup "metrics"
-        [ testCase "work" . void $ runHttpT manager (testMetricsWaiRoute brig)
+        [ testCase "prometheus" . void $ runHttpT manager (testPrometheusMetrics brig)
+        , testCase "work" . void $ runHttpT manager (testMonitoringEndpoint brig)
         ]
 
-testMetricsWaiRoute :: Brig -> Http ()
-testMetricsWaiRoute brig = do
+testPrometheusMetrics :: Brig -> Http ()
+testPrometheusMetrics brig = do
+    get (brig . path "/i/metrics") !!! do
+        const 200 === statusCode
+        -- Should contain the request duration metric in its output
+        const (Just "TYPE http_request_duration_seconds histogram") =~= responseBody
+
+testMonitoringEndpoint :: Brig -> Http ()
+testMonitoringEndpoint brig = do
     let p1 = "/self"
         p2 uid = "/users/" <> uid <> "/clients"
 

services/cannon/package.yaml

@@ -17,9 +17,10 @@ library:
   exposed-modules:
   - Cannon.API
   - Cannon.Dict
+  - Cannon.Options
+  - Cannon.Run
   - Cannon.Types
   - Cannon.WS
-  - Cannon.Options
   dependencies:
   - base >=4.6 && <5
   - aeson >=0.11

services/cannon/src/Cannon/API.hs

@@ -1,20 +1,14 @@
-module Cannon.API (run) where
+module Cannon.API (sitemap) where
 
 import Imports hiding (head)
-import Bilge (newManager, defaultManagerSettings, ManagerSettings (..))
 import Cannon.App
 import Cannon.Types
-import Cannon.Options
 import Cannon.WS hiding (env)
-import Control.Lens ((^.))
 import Control.Monad.Catch
 import Data.Aeson (encode)
 import Data.Id (ClientId, UserId, ConnId)
 import Data.Metrics.Middleware
-import Data.Metrics.WaiRoute (treeToPaths)
 import Data.Swagger.Build.Api hiding (def, Response)
-import Data.Text (strip, pack)
-import Data.Text.Encoding (encodeUtf8)
 import Network.HTTP.Types
 import Gundeck.Types
 import Gundeck.Types.BulkPush
@@ -23,55 +17,15 @@ import Network.Wai.Predicate hiding (Error, (#))
 import Network.Wai.Routing hiding (route, path)
 import Network.Wai.Utilities hiding (message)
 import Network.Wai.Utilities.Request (parseBody')
-import Network.Wai.Utilities.Server
 import Network.Wai.Utilities.Swagger
-import Network.Wai.Handler.Warp hiding (run)
 import Network.Wai.Handler.WebSockets
 import System.Logger (msg, val)
-import System.Random.MWC (createSystemRandom)
 
 import qualified Cannon.Dict                 as D
 import qualified Data.ByteString.Lazy        as L
 import qualified Data.Metrics.Middleware     as Metrics
-import qualified Network.Wai.Middleware.Gzip as Gzip
 import qualified Network.WebSockets          as Ws
-import qualified System.Logger               as L
-import qualified System.Logger.Extended      as L
 import qualified System.Logger.Class         as LC
-import qualified System.IO.Strict            as Strict
-
-run :: Opts -> IO ()
-run o = do
-    ext <- loadExternal
-    m <- metrics
-    g <- L.mkLogger (o ^. logLevel) (o ^. logNetStrings)
-    e <- mkEnv <$> pure m
-               <*> pure ext
-               <*> pure o
-               <*> pure g
-               <*> D.empty 128
-               <*> newManager defaultManagerSettings { managerConnCount = 128 }
-               <*> createSystemRandom
-               <*> mkClock
-    s <- newSettings $ Server (o^.cannon.host) (o^.cannon.port) (applog e) m (Just idleTimeout) [] []
-    let rtree    = compile sitemap
-        measured = measureRequests m (treeToPaths rtree)
-        app  r k = runCannon e (route rtree r k) r
-        start    = measured . catchErrors g m $ Gzip.gzip Gzip.def app
-    runSettings s start `finally` L.close (applog e)
-  where
-    idleTimeout = fromIntegral $ maxPingInterval + 3
-
-    -- Each cannon instance advertises its own location (ip or dns name) to gundeck.
-    -- Either externalHost or externalHostFile must be set (externalHost takes precedence if both are defined)
-    loadExternal :: IO ByteString
-    loadExternal = do
-      let extFile = fromMaybe (error "One of externalHost or externalHostFile must be defined") (o^.cannon.externalHostFile)
-      fromMaybe (readExternal extFile) (return . encodeUtf8 <$> o^.cannon.externalHost)
-
-    readExternal :: FilePath -> IO ByteString
-    readExternal f = encodeUtf8 . strip . pack <$> Strict.readFile f
-
 
 sitemap :: Routes ApiBuilder Cannon ()
 sitemap = do