{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}

module Prod.Status (
    StatusApi,
    RenderStatus,
    defaultStatusPage,
    metricsSection,
    versionsSection,
    statusPage,
    handleStatus,
    Status (..),
    Identification (..),
    this,
)
where

import Control.Monad.IO.Class (liftIO)
import Data.Aeson (ToJSON (..), (.=))
import qualified Data.Aeson as Aeson
import Data.Foldable (traverse_)
import Data.Text (Text)
import qualified Data.Text as Text
import Data.UUID (UUID)
import Data.UUID.V4 (nextRandom)
import Data.Version (Version, showVersion)
import GHC.Generics (Generic)
import Prod.Health as Health
import Prod.MimeTypes (HTML)
import Servant (Get, JSON, MimeRender (..), (:>))
import Servant.Server (Handler)
import System.IO.Unsafe (unsafePerformIO)

import Lucid

type StatusApi a =
    "status"
        :> Get '[HTML, JSON] (Status a)

newtype Identification = Identification Text
    deriving
        ([Identification] -> Value
[Identification] -> Encoding
Identification -> Bool
Identification -> Value
Identification -> Encoding
(Identification -> Value)
-> (Identification -> Encoding)
-> ([Identification] -> Value)
-> ([Identification] -> Encoding)
-> (Identification -> Bool)
-> ToJSON Identification
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: Identification -> Value
toJSON :: Identification -> Value
$ctoEncoding :: Identification -> Encoding
toEncoding :: Identification -> Encoding
$ctoJSONList :: [Identification] -> Value
toJSONList :: [Identification] -> Value
$ctoEncodingList :: [Identification] -> Encoding
toEncodingList :: [Identification] -> Encoding
$comitField :: Identification -> Bool
omitField :: Identification -> Bool
ToJSON)
        via Text

-- | Type to render a status page.
type RenderStatus a = Status a -> Html ()

data Status a
    = Status
    { forall a. Status a -> Identification
identification :: !Identification
    , forall a. Status a -> Liveness
liveness :: !Liveness
    , forall a. Status a -> Readiness
readiness :: !Readiness
    , forall a. Status a -> a
appStatus :: !a
    , forall a. Status a -> RenderStatus a
renderer :: RenderStatus a
    }

instance (ToJSON a) => ToJSON (Status a) where
    toJSON :: Status a -> Value
toJSON (Status Identification
i Liveness
l Readiness
r a
st RenderStatus a
_) =
        [Pair] -> Value
Aeson.object
            [ Key
"id" Key -> Identification -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Identification
i
            , Key
"liveness" Key -> Liveness -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Liveness
l
            , Key
"readiness" Key -> Readiness -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Readiness
r
            , Key
"status" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= a -> Value
forall a. ToJSON a => a -> Value
toJSON a
st
            ]

handleStatus :: Runtime -> IO a -> RenderStatus a -> Handler (Status a)
handleStatus :: forall a. Runtime -> IO a -> RenderStatus a -> Handler (Status a)
handleStatus Runtime
runtime IO a
getAppStatus RenderStatus a
render =
    IO (Status a) -> Handler (Status a)
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Status a) -> Handler (Status a))
-> IO (Status a) -> Handler (Status a)
forall a b. (a -> b) -> a -> b
$
        Identification
-> Liveness -> Readiness -> a -> RenderStatus a -> Status a
forall a.
Identification
-> Liveness -> Readiness -> a -> RenderStatus a -> Status a
Status Identification
this
            (Liveness -> Readiness -> a -> RenderStatus a -> Status a)
-> IO Liveness -> IO (Readiness -> a -> RenderStatus a -> Status a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Runtime -> IO Liveness
Health.liveness Runtime
runtime
            IO (Readiness -> a -> RenderStatus a -> Status a)
-> IO Readiness -> IO (a -> RenderStatus a -> Status a)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Runtime -> IO Readiness
Health.completeReadiness Runtime
runtime
            IO (a -> RenderStatus a -> Status a)
-> IO a -> IO (RenderStatus a -> Status a)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO a
getAppStatus
            IO (RenderStatus a -> Status a)
-> IO (RenderStatus a) -> IO (Status a)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (RenderStatus a -> IO (RenderStatus a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RenderStatus a
render)

{-# NOINLINE this #-}
this :: Identification
this :: Identification
this = IO Identification -> Identification
forall a. IO a -> a
unsafePerformIO (IO Identification -> Identification)
-> IO Identification -> Identification
forall a b. (a -> b) -> a -> b
$ (UUID -> Identification) -> IO UUID -> IO Identification
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Identification
Identification (Text -> Identification)
-> (UUID -> Text) -> UUID -> Identification
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Text) -> (UUID -> String) -> UUID -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UUID -> String
forall a. Show a => a -> String
show) IO UUID
nextRandom

instance {-# OVERLAPPABLE #-} MimeRender HTML (Status a) where
    mimeRender :: Proxy HTML -> Status a -> ByteString
mimeRender Proxy HTML
_ Status a
st = Html () -> ByteString
forall a. Html a -> ByteString
renderBS (Html () -> ByteString) -> Html () -> ByteString
forall a b. (a -> b) -> a -> b
$ RenderStatus a
render Status a
st
      where
        render :: RenderStatus a
render = Status a -> RenderStatus a
forall a. Status a -> RenderStatus a
renderer Status a
st

defaultStatusPage :: forall a. (a -> Html ()) -> RenderStatus a
defaultStatusPage :: forall a. (a -> Html ()) -> RenderStatus a
defaultStatusPage a -> Html ()
renderAppStatus = Status a -> Html ()
go
  where
    go :: Status a -> Html ()
    go :: Status a -> Html ()
go (Status (Identification Text
uuid) Liveness
liveness Readiness
readiness a
appStatus Status a -> Html ()
_) =
        Html () -> Html ()
forall arg result. Term arg result => arg -> result
html_ (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ do
            Html () -> Html ()
forall arg result. Term arg result => arg -> result
head_ (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ do
                Html () -> Html ()
forall arg result. Term arg result => arg -> result
title_ Html ()
"status page"
                [Attribute] -> Html ()
forall (m :: * -> *). Applicative m => [Attribute] -> HtmlT m ()
link_ [Text -> Attribute
rel_ Text
"stylesheet", Text -> Attribute
type_ Text
"text/css", Text -> Attribute
href_ Text
"status.css"]
            Html () -> Html ()
forall arg result. Term arg result => arg -> result
body_ (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ do
                Html () -> Html ()
forall arg result. Term arg result => arg -> result
section_ (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ do
                    Html () -> Html ()
forall arg result. Term arg result => arg -> result
h1_ Html ()
"identification"
                    Html () -> Html ()
forall arg result. Term arg result => arg -> result
p_ (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ Text -> Html ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
forall (m :: * -> *). Monad m => Text -> HtmlT m ()
toHtml Text
uuid
                Html () -> Html ()
forall arg result. Term arg result => arg -> result
section_ (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ do
                    Html () -> Html ()
forall arg result. Term arg result => arg -> result
h1_ Html ()
"general status"
                    Liveness -> Html ()
renderLiveness Liveness
liveness
                    Readiness -> Html ()
renderReadiness Readiness
readiness
                    (Html () -> Html ()) -> [Attribute] -> Html () -> Html ()
forall a. With a => a -> [Attribute] -> a
with Html () -> Html ()
forall arg result. Term arg result => arg -> result
form_ [Text -> Attribute
action_ Text
"/health/drain", Text -> Attribute
method_ Text
"post"] (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$
                        [Attribute] -> Html ()
forall (m :: * -> *). Applicative m => [Attribute] -> HtmlT m ()
input_ [Text -> Attribute
type_ Text
"submit", Text -> Attribute
value_ Text
"drain me"]
                Html () -> Html ()
forall arg result. Term arg result => arg -> result
section_ (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ do
                    Html () -> Html ()
forall arg result. Term arg result => arg -> result
h1_ Html ()
"app status"
                    a -> Html ()
renderAppStatus a
appStatus
    renderLiveness :: Liveness -> Html ()
    renderLiveness :: Liveness -> Html ()
renderLiveness Liveness
Alive = Html () -> Html ()
forall arg result. Term arg result => arg -> result
p_ (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ (Html () -> Html ()) -> [Attribute] -> Html () -> Html ()
forall a. With a => a -> [Attribute] -> a
with Html () -> Html ()
forall arg result. Term arg result => arg -> result
a_ [Text -> Attribute
href_ Text
"/health/alive"] Html ()
"alive"

    renderReadiness :: Readiness -> Html ()
    renderReadiness :: Readiness -> Html ()
renderReadiness Readiness
Ready = Html () -> Html ()
forall arg result. Term arg result => arg -> result
p_ (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ (Html () -> Html ()) -> [Attribute] -> Html () -> Html ()
forall a. With a => a -> [Attribute] -> a
with Html () -> Html ()
forall arg result. Term arg result => arg -> result
a_ [Text -> Attribute
href_ Text
"/health/ready"] Html ()
"ready"
    renderReadiness (Ill Set Reason
reasons) = do
        Html () -> Html ()
forall arg result. Term arg result => arg -> result
p_ (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ (Html () -> Html ()) -> [Attribute] -> Html () -> Html ()
forall a. With a => a -> [Attribute] -> a
with Html () -> Html ()
forall arg result. Term arg result => arg -> result
a_ [Text -> Attribute
href_ Text
"/health/ready"] Html ()
"not-ready"
        Html () -> Html ()
forall arg result. Term arg result => arg -> result
ul_ (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ do
            (Reason -> Html ()) -> Set Reason -> Html ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Reason -> Html ()
renderReason Set Reason
reasons

    renderReason :: Reason -> Html ()
    renderReason :: Reason -> Html ()
renderReason (Reason Text
r) =
        Html () -> Html ()
forall arg result. Term arg result => arg -> result
li_ (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ Text -> Html ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
forall (m :: * -> *). Monad m => Text -> HtmlT m ()
toHtml Text
r

{- | Like defaultStatusPage but uses a type-class-defined to pass the
application-status rendering.
-}
statusPage :: (ToHtml a) => RenderStatus a
statusPage :: forall a. ToHtml a => RenderStatus a
statusPage = (a -> Html ()) -> RenderStatus a
forall a. (a -> Html ()) -> RenderStatus a
defaultStatusPage a -> Html ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
forall (m :: * -> *). Monad m => a -> HtmlT m ()
toHtml

type MetricsJSurl = Text

-- | Section with metrics.
metricsSection :: MetricsJSurl -> RenderStatus a
metricsSection :: forall a. Text -> RenderStatus a
metricsSection Text
metrics_js = Html () -> Status a -> Html ()
forall a b. a -> b -> a
const (Html () -> Status a -> Html ()) -> Html () -> Status a -> Html ()
forall a b. (a -> b) -> a -> b
$
    Html () -> Html ()
forall arg result. Term arg result => arg -> result
section_ (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ do
        Html () -> Html ()
forall arg result. Term arg result => arg -> result
h1_ Html ()
"metrics"
        (Html () -> Html ()) -> [Attribute] -> Html () -> Html ()
forall a. With a => a -> [Attribute] -> a
with Html () -> Html ()
forall arg result. Term arg result => arg -> result
div_ [Text -> Attribute
id_ Text
"metrics"] (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ () -> Html ()
forall a. a -> HtmlT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtmlRaw @Text (Text -> Html ()) -> Text -> Html ()
forall a b. (a -> b) -> a -> b
$ Text
"<script async type=\"text/javascript\" src=\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
metrics_js Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\"></script>"

versionsSection :: [(String, Version)] -> RenderStatus a
versionsSection :: forall a. [(String, Version)] -> RenderStatus a
versionsSection [(String, Version)]
pkgs = Html () -> Status a -> Html ()
forall a b. a -> b -> a
const (Html () -> Status a -> Html ()) -> Html () -> Status a -> Html ()
forall a b. (a -> b) -> a -> b
$
    Html () -> Html ()
forall arg result. Term arg result => arg -> result
section_ (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ do
        Html () -> Html ()
forall arg result. Term arg result => arg -> result
h1_ Html ()
"versions"
        Html () -> Html ()
forall arg result. Term arg result => arg -> result
ul_ (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$
            ((String, Version) -> Html ()) -> [(String, Version)] -> Html ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (String, Version) -> Html ()
renderVersion [(String, Version)]
pkgs
  where
    renderVersion :: (String, Version) -> Html ()
    renderVersion :: (String, Version) -> Html ()
renderVersion (String
pkg, Version
ver) =
        Html () -> Html ()
forall arg result. Term arg result => arg -> result
li_ (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ Html () -> Html ()
forall arg result. Term arg result => arg -> result
p_ (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ String -> Html ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
forall (m :: * -> *). Monad m => String -> HtmlT m ()
toHtml (String -> Html ()) -> String -> Html ()
forall a b. (a -> b) -> a -> b
$ String
pkg String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
":" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Version -> String
showVersion Version
ver