{-# LANGUAGE PackageImports #-}

{-# OPTIONS_GHC -Wno-partial-fields #-}

-- | Run a simple Prometheus TCP server, responding *only* to the '/metrics' URL with current Node metrics
module Cardano.Logging.Prometheus.TCPServer
       ( runPrometheusSimple
       , runPrometheusSimpleSilent

       , TracePrometheusSimple (..)
       ) where

import           Cardano.Logging.Prometheus.Exposition (renderExpositionFromSample)
import           Cardano.Logging.Prometheus.NetworkRun
import           Cardano.Logging.Types
import           Cardano.Logging.Utils (runInLoop, showT)

import           Control.Concurrent.Async (Async, async)
import qualified Control.Exception as E
import           Control.Monad (join, when)
import           "contra-tracer" Control.Tracer
import           Data.Aeson.Types as AE (Value (String), (.=))
import           Data.ByteString (ByteString)
import           Data.ByteString.Builder
import qualified Data.ByteString.Char8 as BC
import           Data.Int (Int64)
import           Data.List (find, intersperse)
import           Data.Text as TS (pack)
import           Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as T
import qualified Data.Text.Lazy.Encoding as T (encodeUtf8Builder)
import           Data.Word (Word16)
import           Network.HTTP.Date (epochTimeToHTTPDate, formatHTTPDate)
import           Network.Socket (HostName, PortNumber)
import qualified Network.Socket.ByteString as Strict (recv)
import qualified Network.Socket.ByteString.Lazy as Lazy (sendAll)
import           System.Metrics as EKG (Store, sampleAll)
import           System.Posix.Types (EpochTime)
import           System.PosixCompat.Time (epochTime)


data TracePrometheusSimple =
    TracePrometheusSimpleStart { TracePrometheusSimple -> Word16
port :: Word16 }
  | TracePrometheusSimpleStop  { TracePrometheusSimple -> String
message :: String }
  deriving Int -> TracePrometheusSimple -> ShowS
[TracePrometheusSimple] -> ShowS
TracePrometheusSimple -> String
(Int -> TracePrometheusSimple -> ShowS)
-> (TracePrometheusSimple -> String)
-> ([TracePrometheusSimple] -> ShowS)
-> Show TracePrometheusSimple
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TracePrometheusSimple -> ShowS
showsPrec :: Int -> TracePrometheusSimple -> ShowS
$cshow :: TracePrometheusSimple -> String
show :: TracePrometheusSimple -> String
$cshowList :: [TracePrometheusSimple] -> ShowS
showList :: [TracePrometheusSimple] -> ShowS
Show

instance LogFormatting TracePrometheusSimple where
  forMachine :: DetailLevel -> TracePrometheusSimple -> Object
forMachine DetailLevel
_ = \case
    TracePrometheusSimpleStart Word16
portNo -> [Object] -> Object
forall a. Monoid a => [a] -> a
mconcat
      [ Key
"kind"        Key -> Value -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
AE.String Text
"PrometheusSimpleStart"
      , Key
"port"        Key -> Word16 -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Word16
portNo
      ]
    TracePrometheusSimpleStop String
message -> [Object] -> Object
forall a. Monoid a => [a] -> a
mconcat
      [ Key
"kind"        Key -> Value -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
AE.String Text
"TracePrometheusSimpleStop"
      , Key
"message"     Key -> String -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
message
      ]

  forHuman :: TracePrometheusSimple -> Text
forHuman = \case
    TracePrometheusSimpleStart Word16
portNo -> Text
"PrometheusSimple backend starting on port " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word16 -> Text
forall a. Show a => a -> Text
showT Word16
portNo
    TracePrometheusSimpleStop String
message -> Text
"PrometheusSimple backend stop: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
TS.pack String
message


-- Same as below, but will not trace anything
runPrometheusSimpleSilent :: EKG.Store -> (Bool, Maybe HostName, PortNumber) -> IO (Async ())
runPrometheusSimpleSilent :: Store -> (Bool, Maybe String, PortNumber) -> IO (Async ())
runPrometheusSimpleSilent = Tracer IO TracePrometheusSimple
-> Store -> (Bool, Maybe String, PortNumber) -> IO (Async ())
runPrometheusSimple Tracer IO TracePrometheusSimple
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer

-- Will retry / restart Prometheus server when an exception occurs, in increasing intervals
runPrometheusSimple :: Tracer IO TracePrometheusSimple -> EKG.Store -> (Bool, Maybe HostName, PortNumber) -> IO (Async ())
runPrometheusSimple :: Tracer IO TracePrometheusSimple
-> Store -> (Bool, Maybe String, PortNumber) -> IO (Async ())
runPrometheusSimple Tracer IO TracePrometheusSimple
tr Store
ekgStore (Bool
noSuffixes, Maybe String
mHost, PortNumber
portNo) =
    IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ IO () -> (SomeException -> IO ()) -> Word -> Word -> IO ()
runInLoop IO ()
fromScratchThrowing SomeException -> IO ()
traceInterruption Word
1 Word
60
  where
    traceInterruption :: SomeException -> IO ()
traceInterruption (E.SomeException e
e) =
      Tracer IO TracePrometheusSimple -> TracePrometheusSimple -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO TracePrometheusSimple
tr (TracePrometheusSimple -> IO ()) -> TracePrometheusSimple -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> TracePrometheusSimple
TracePrometheusSimpleStop (e -> String
forall e. Exception e => e -> String
E.displayException e
e)

    fromScratchThrowing :: IO ()
fromScratchThrowing  = Tracer IO TracePrometheusSimple -> TracePrometheusSimple -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO TracePrometheusSimple
tr (Word16 -> TracePrometheusSimple
TracePrometheusSimpleStart (Word16 -> TracePrometheusSimple)
-> Word16 -> TracePrometheusSimple
forall a b. (a -> b) -> a -> b
$ PortNumber -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
portNo) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join IO (IO ())
createRunner

    getCurrentExposition :: IO Text
getCurrentExposition = Bool -> Sample -> Text
renderExpositionFromSample Bool
noSuffixes (Sample -> Text) -> IO Sample -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Store -> IO Sample
sampleAll Store
ekgStore
    createRunner :: IO (IO ())
createRunner         = NetworkRunParams
-> Maybe String -> PortNumber -> TimeoutServer () -> IO (IO ())
mkTCPServerRunner (String -> NetworkRunParams
defaultRunParams String
"PrometheusSimple") Maybe String
mHost PortNumber
portNo (IO Text -> TimeoutServer ()
serveAccepted IO Text
getCurrentExposition)

-- serves an incoming connection; will release socket upon remote close, inactivity timeout or runRecvMaxSize bytes received
serveAccepted :: IO Text -> TimeoutServer ()
serveAccepted :: IO Text -> TimeoutServer ()
serveAccepted IO Text
getCurrentExposition NetworkRunParams{Int
runRecvMaxSize :: Int
runRecvMaxSize :: NetworkRunParams -> Int
runRecvMaxSize} IO ()
resetTimeout Socket
sock = IO ()
go
  where
    go :: IO ()
go = do
      ByteString
msg <- Socket -> Int -> IO ByteString
Strict.recv Socket
sock Int
runRecvMaxSize
      let len :: Int
len = ByteString -> Int
BC.length ByteString
msg
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
len Bool -> Bool -> Bool
&& Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
runRecvMaxSize) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Builder
response <- IO Text -> Maybe (ByteString, Method, Accept) -> IO Builder
buildResponse IO Text
getCurrentExposition (Maybe (ByteString, Method, Accept) -> IO Builder)
-> Maybe (ByteString, Method, Accept) -> IO Builder
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe (ByteString, Method, Accept)
pseudoParse ByteString
msg
        Socket -> ByteString -> IO ()
Lazy.sendAll Socket
sock (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString Builder
response
        IO ()
resetTimeout
        IO ()
go


data Method = GET | HEAD | UNSUPPORTED deriving Method -> Method -> Bool
(Method -> Method -> Bool)
-> (Method -> Method -> Bool) -> Eq Method
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Method -> Method -> Bool
== :: Method -> Method -> Bool
$c/= :: Method -> Method -> Bool
/= :: Method -> Method -> Bool
Eq

data Accept = TextLike | OpenMetrics | All | Unsupported deriving Accept -> Accept -> Bool
(Accept -> Accept -> Bool)
-> (Accept -> Accept -> Bool) -> Eq Accept
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Accept -> Accept -> Bool
== :: Accept -> Accept -> Bool
$c/= :: Accept -> Accept -> Bool
/= :: Accept -> Accept -> Bool
Eq

-- "parses" a buffer read via TCP into a minimal viable HTTP request (TM): route, HTTP verb, Accept: header
pseudoParse :: ByteString -> Maybe (ByteString, Method, Accept)
pseudoParse :: ByteString -> Maybe (ByteString, Method, Accept)
pseudoParse ByteString
request =
  case ByteString -> [ByteString]
BC.lines ByteString
request of
    ByteString
requestLine : [ByteString]
headers
      | ByteString
method : ByteString
route : [ByteString]
_ <- ByteString -> [ByteString]
BC.words ByteString
requestLine
        -> (ByteString, Method, Accept) -> Maybe (ByteString, Method, Accept)
forall a. a -> Maybe a
Just (ByteString
route, ByteString -> Method
readMethod ByteString
method, [ByteString] -> Accept
readAccept [ByteString]
headers)
    [ByteString]
_ -> Maybe (ByteString, Method, Accept)
forall a. Maybe a
Nothing
  where
    readMethod :: ByteString -> Method
    readMethod :: ByteString -> Method
readMethod ByteString
"GET"  = Method
GET
    readMethod ByteString
"HEAD" = Method
HEAD
    readMethod ByteString
_      = Method
UNSUPPORTED

    readAccept :: [ByteString] -> Accept
    readAccept :: [ByteString] -> Accept
readAccept [ByteString]
headers =
      case (ByteString -> Bool) -> [ByteString] -> Maybe ByteString
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\ByteString
h -> (ByteString -> Bool) -> [ByteString] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ByteString -> ByteString -> Bool
`BC.isPrefixOf` ByteString
h) [ByteString]
caseInsensitive) [ByteString]
headers of
        Maybe ByteString
Nothing -> Accept
All
        Just ByteString
accept
          | ByteString
"application/openmetrics-text" ByteString -> ByteString -> Bool
`BC.isInfixOf` ByteString
accept  -> Accept
OpenMetrics
          | ByteString
"text/" ByteString -> ByteString -> Bool
`BC.isInfixOf`                        ByteString
accept  -> Accept
TextLike
          | ByteString
"*/*" ByteString -> ByteString -> Bool
`BC.isInfixOf`                          ByteString
accept  -> Accept
All
          | Bool
otherwise                                             -> Accept
Unsupported
      where
        caseInsensitive :: [ByteString]
caseInsensitive = [ByteString
"Accept:", ByteString
"accept:", ByteString
"ACCEPT:"]

-- builds a minimal complete HTTP response based on route, HTTP verb and requested content type
buildResponse :: IO Text -> Maybe (ByteString, Method, Accept) -> IO Builder
buildResponse :: IO Text -> Maybe (ByteString, Method, Accept) -> IO Builder
buildResponse IO Text
getCurrentExposition = \case
  Maybe (ByteString, Method, Accept)
Nothing -> Builder -> IO Builder
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Builder -> IO Builder) -> Builder -> IO Builder
forall a b. (a -> b) -> a -> b
$ Bool -> (ByteString, ByteString) -> Builder
responseError Bool
False (ByteString, ByteString)
errorBadRequest
  Just (ByteString
route, Method
method, Accept
accept)
    | ByteString
route ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"/metrics"   -> Builder -> IO Builder
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Builder -> IO Builder) -> Builder -> IO Builder
forall a b. (a -> b) -> a -> b
$ Bool -> (ByteString, ByteString) -> Builder
responseError Bool
withBody (ByteString, ByteString)
errorNotFound
    | Method
method Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
== Method
UNSUPPORTED -> Builder -> IO Builder
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Builder -> IO Builder) -> Builder -> IO Builder
forall a b. (a -> b) -> a -> b
$ Bool -> (ByteString, ByteString) -> Builder
responseError Bool
withBody (ByteString, ByteString)
errorBadMethod
    | Accept
accept Accept -> Accept -> Bool
forall a. Eq a => a -> a -> Bool
== Accept
Unsupported -> Builder -> IO Builder
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Builder -> IO Builder) -> Builder -> IO Builder
forall a b. (a -> b) -> a -> b
$ Bool -> (ByteString, ByteString) -> Builder
responseError Bool
withBody (ByteString, ByteString)
errorBadContent
    | Bool
otherwise ->
        let content :: Builder
content = if Accept
accept Accept -> Accept -> Bool
forall a. Eq a => a -> a -> Bool
== Accept
OpenMetrics then Builder
hdrContentTypeOpenMetrics else Builder
hdrContentTypePrometheus
        in Bool -> Builder -> Text -> EpochTime -> Builder
responseMessage Bool
withBody Builder
content (Text -> EpochTime -> Builder)
-> IO Text -> IO (EpochTime -> Builder)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Text
getCurrentExposition IO (EpochTime -> Builder) -> IO EpochTime -> IO Builder
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO EpochTime
epochTime
    where withBody :: Bool
withBody = Method
method Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
== Method
GET

hdrContentTypeText, hdrContentTypePrometheus, hdrContentTypeOpenMetrics :: Builder
hdrContentTypeText :: Builder
hdrContentTypeText        = Builder
"Content-Type: text/plain;charset=utf-8"
hdrContentTypePrometheus :: Builder
hdrContentTypePrometheus  = Builder
"Content-Type: text/plain;version=0.0.4;charset=utf-8"
hdrContentTypeOpenMetrics :: Builder
hdrContentTypeOpenMetrics = Builder
"Content-Type: application/openmetrics-text;version=1.0.0;charset=utf-8"

hdrContentLength :: Int64 -> Builder
hdrContentLength :: Int64 -> Builder
hdrContentLength Int64
len = Builder
"Content-Length: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int64 -> Builder
int64Dec Int64
len

errorBadRequest, errorNotFound, errorBadMethod, errorBadContent :: (ByteString, ByteString)
errorBadRequest :: (ByteString, ByteString)
errorBadRequest = (ByteString
"400", ByteString
"Bad Request")
errorNotFound :: (ByteString, ByteString)
errorNotFound   = (ByteString
"404", ByteString
"Not Found")
errorBadMethod :: (ByteString, ByteString)
errorBadMethod  = (ByteString
"405", ByteString
"Method Not Allowed")
errorBadContent :: (ByteString, ByteString)
errorBadContent = (ByteString
"415", ByteString
"Unsupported Media Type")

-- HTTP header line break
nl :: Builder
nl :: Builder
nl = Char -> Builder
char8 Char
'\r' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
char8 Char
'\n'

responseError :: Bool -> (ByteString, ByteString) -> Builder
responseError :: Bool -> (ByteString, ByteString) -> Builder
responseError Bool
withBody (ByteString
errCode, ByteString
errMsg) =
  [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperse Builder
nl ([Builder] -> [Builder]) -> [Builder] -> [Builder]
forall a b. (a -> b) -> a -> b
$
    Builder
"HTTP/1.1 " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteString ByteString
errCode Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
:
    if Bool
withBody
      then  [ Int64 -> Builder
hdrContentLength (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int64) -> Int -> Int64
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BC.length ByteString
msg)
            , Builder
hdrContentTypeText
            , Builder
""
            , ByteString -> Builder
byteString ByteString
msg
            ]
      else  [ Int64 -> Builder
hdrContentLength Int64
0
            , Builder
nl
            ]
  where
    msg :: ByteString
msg = ByteString
errCode ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
errMsg

responseMessage :: Bool -> Builder -> Text -> EpochTime -> Builder
responseMessage :: Bool -> Builder -> Text -> EpochTime -> Builder
responseMessage Bool
withBody Builder
contentType Text
msg EpochTime
now =
  [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperse Builder
nl
    [ Builder
"HTTP/1.1 200 OK"
    , Int64 -> Builder
hdrContentLength (Text -> Int64
T.length Text
msg)
    , Builder
contentType
    , Builder
"Date: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteString ByteString
httpDate
    , Builder
""
    , if Bool
withBody then Text -> Builder
T.encodeUtf8Builder Text
msg else Builder
""
    ]
    where
      httpDate :: ByteString
httpDate = HTTPDate -> ByteString
formatHTTPDate (HTTPDate -> ByteString) -> HTTPDate -> ByteString
forall a b. (a -> b) -> a -> b
$ EpochTime -> HTTPDate
epochTimeToHTTPDate EpochTime
now