{-# 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 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
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
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