{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}

-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

-- | Given a servant API type, this module gives you a 'Paths' for 'withPathTemplate'.
module Data.Metrics.Servant where

import Data.ByteString.UTF8 qualified as UTF8
import Data.Metrics.Types
import Data.Metrics.Types qualified as Metrics
import Data.Proxy
import Data.Text.Encoding
import Data.Text.Encoding.Error
import Data.Tree
import GHC.TypeLits
import Imports
import Network.Wai qualified as Wai
import Network.Wai.Middleware.Prometheus
import Network.Wai.Middleware.Prometheus qualified as Promth
import Servant.API
import Servant.Multipart

-- | This does not catch errors, so it must be called outside of 'WU.catchErrors'.
servantPrometheusMiddleware :: forall proxy api. (RoutesToPaths api) => proxy api -> Wai.Middleware
servantPrometheusMiddleware :: forall {k} (proxy :: k -> *) (api :: k).
RoutesToPaths api =>
proxy api -> Middleware
servantPrometheusMiddleware proxy api
_ = PrometheusSettings -> Middleware
Promth.prometheus PrometheusSettings
conf Middleware -> Middleware -> Middleware
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Request -> Text) -> Middleware
instrument Request -> Text
promthNormalize
  where
    promthNormalize :: Wai.Request -> Text
    promthNormalize :: Request -> Text
promthNormalize Request
req = Text
pathInfo
      where
        mPathInfo :: Maybe ByteString
mPathInfo = Paths -> [ByteString] -> Maybe ByteString
Metrics.treeLookup (forall (routes :: k). RoutesToPaths routes => Paths
forall {k} (routes :: k). RoutesToPaths routes => Paths
routesToPaths @api) ([ByteString] -> Maybe ByteString)
-> [ByteString] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 (Text -> ByteString) -> [Text] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Request -> [Text]
Wai.pathInfo Request
req
        pathInfo :: Text
pathInfo = OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"N/A" Maybe ByteString
mPathInfo

    -- See Note [Raw Response]
    instrument :: (Request -> Text) -> Middleware
instrument = (Response -> Maybe Response) -> (Request -> Text) -> Middleware
Promth.instrumentHandlerValueWithFilter Response -> Maybe Response
Promth.ignoreRawResponses

conf :: PrometheusSettings
conf :: PrometheusSettings
conf =
  PrometheusSettings
forall a. Default a => a
Promth.def
    { Promth.prometheusEndPoint = ["i", "metrics"],
      -- We provide our own instrumentation so we can normalize routes
      Promth.prometheusInstrumentApp = False
    }

routesToPaths :: forall routes. (RoutesToPaths routes) => Paths
routesToPaths :: forall {k} (routes :: k). RoutesToPaths routes => Paths
routesToPaths = Forest PathSegment -> Paths
Paths (Forest PathSegment -> Forest PathSegment
meltTree (forall (routes :: k). RoutesToPaths routes => Forest PathSegment
forall {k} (routes :: k).
RoutesToPaths routes =>
Forest PathSegment
getRoutes @routes))

class RoutesToPaths routes where
  getRoutes :: Forest PathSegment

-- "seg" :> routes
instance
  (KnownSymbol seg, RoutesToPaths segs) =>
  RoutesToPaths (seg :> segs)
  where
  getRoutes :: Forest PathSegment
getRoutes = [PathSegment -> Forest PathSegment -> Tree PathSegment
forall a. a -> [Tree a] -> Tree a
Node (ByteString -> PathSegment
forall a b. b -> Either a b
Right (ByteString -> PathSegment)
-> (String -> ByteString) -> String -> PathSegment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
UTF8.fromString (String -> PathSegment) -> String -> PathSegment
forall a b. (a -> b) -> a -> b
$ Proxy seg -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @seg)) (forall routes. RoutesToPaths routes => Forest PathSegment
forall {k} (routes :: k).
RoutesToPaths routes =>
Forest PathSegment
getRoutes @segs)]

-- <capture> :> routes
instance
  (KnownSymbol capture, RoutesToPaths segs) =>
  RoutesToPaths (Capture' mods capture a :> segs)
  where
  getRoutes :: Forest PathSegment
getRoutes = [PathSegment -> Forest PathSegment -> Tree PathSegment
forall a. a -> [Tree a] -> Tree a
Node (ByteString -> PathSegment
forall a b. a -> Either a b
Left (String -> ByteString
UTF8.fromString (String
":" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Proxy capture -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @capture)))) (forall routes. RoutesToPaths routes => Forest PathSegment
forall {k} (routes :: k).
RoutesToPaths routes =>
Forest PathSegment
getRoutes @segs)]

instance
  (RoutesToPaths rest) =>
  RoutesToPaths (Header' mods name a :> rest)
  where
  getRoutes :: Forest PathSegment
getRoutes = forall routes. RoutesToPaths routes => Forest PathSegment
forall {k} (routes :: k).
RoutesToPaths routes =>
Forest PathSegment
getRoutes @rest

instance
  (RoutesToPaths rest) =>
  RoutesToPaths (ReqBody' mods cts a :> rest)
  where
  getRoutes :: Forest PathSegment
getRoutes = forall routes. RoutesToPaths routes => Forest PathSegment
forall {k} (routes :: k).
RoutesToPaths routes =>
Forest PathSegment
getRoutes @rest

instance
  (RoutesToPaths rest) =>
  RoutesToPaths (StreamBody' opts framing ct a :> rest)
  where
  getRoutes :: Forest PathSegment
getRoutes = forall routes. RoutesToPaths routes => Forest PathSegment
forall {k} (routes :: k).
RoutesToPaths routes =>
Forest PathSegment
getRoutes @rest

instance
  (RoutesToPaths rest) =>
  RoutesToPaths (Summary summary :> rest)
  where
  getRoutes :: Forest PathSegment
getRoutes = forall routes. RoutesToPaths routes => Forest PathSegment
forall {k} (routes :: k).
RoutesToPaths routes =>
Forest PathSegment
getRoutes @rest

instance
  (RoutesToPaths rest) =>
  RoutesToPaths (QueryParam' mods name a :> rest)
  where
  getRoutes :: Forest PathSegment
getRoutes = forall routes. RoutesToPaths routes => Forest PathSegment
forall {k} (routes :: k).
RoutesToPaths routes =>
Forest PathSegment
getRoutes @rest

instance (RoutesToPaths rest) => RoutesToPaths (MultipartForm tag a :> rest) where
  getRoutes :: Forest PathSegment
getRoutes = forall routes. RoutesToPaths routes => Forest PathSegment
forall {k} (routes :: k).
RoutesToPaths routes =>
Forest PathSegment
getRoutes @rest

instance (RoutesToPaths api) => RoutesToPaths (QueryFlag a :> api) where
  getRoutes :: Forest PathSegment
getRoutes = forall routes. RoutesToPaths routes => Forest PathSegment
forall {k} (routes :: k).
RoutesToPaths routes =>
Forest PathSegment
getRoutes @api

instance
  (RoutesToPaths rest) =>
  RoutesToPaths (Description desc :> rest)
  where
  getRoutes :: Forest PathSegment
getRoutes = forall routes. RoutesToPaths routes => Forest PathSegment
forall {k} (routes :: k).
RoutesToPaths routes =>
Forest PathSegment
getRoutes @rest

instance RoutesToPaths (Verb method status cts a) where
  getRoutes :: Forest PathSegment
getRoutes = []

instance RoutesToPaths (NoContentVerb method) where
  getRoutes :: Forest PathSegment
getRoutes = []

instance RoutesToPaths (Stream method status framing ct a) where
  getRoutes :: Forest PathSegment
getRoutes = []

-- route :<|> routes
instance
  ( RoutesToPaths route,
    RoutesToPaths routes
  ) =>
  RoutesToPaths (route :<|> routes)
  where
  getRoutes :: Forest PathSegment
getRoutes = forall routes. RoutesToPaths routes => Forest PathSegment
forall {k} (routes :: k).
RoutesToPaths routes =>
Forest PathSegment
getRoutes @route Forest PathSegment -> Forest PathSegment -> Forest PathSegment
forall a. Semigroup a => a -> a -> a
<> forall routes. RoutesToPaths routes => Forest PathSegment
forall {k} (routes :: k).
RoutesToPaths routes =>
Forest PathSegment
getRoutes @routes

instance RoutesToPaths EmptyAPI where
  getRoutes :: Forest PathSegment
getRoutes = Forest PathSegment
forall a. Monoid a => a
mempty

instance RoutesToPaths Raw where
  getRoutes :: Forest PathSegment
getRoutes = []