packages feed

prodapi-web (empty) → 0.1.0.0

raw patch · 13 files changed

+1233/−0 lines, 13 filesdep +aesondep +asyncdep +base

Dependencies added: aeson, async, base, bytestring, containers, contravariant, directory, http-api-data, http-client, http-media, lucid, process-extras, prodapi-core, prometheus-client, prometheus-metrics-ghc, servant, servant-client, servant-server, text, time, unbounded-delays, unix-time, uuid, wai

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for prodapi++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Lucas DiCioccio (c) 2021++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Author name here nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ prodapi-web.cabal view
@@ -0,0 +1,65 @@+cabal-version:       2.0+name:                prodapi-web+version:             0.1.0.0+synopsis:            Web components for building Haskell services with Servant and Prometheus.+description:         Web-oriented components for building production Haskell services.+                     Includes health endpoints, Prometheus metrics, service discovery,+                     health checks, and application bootstrapping. Depends on Servant and Prometheus.+                     Re-exports prodapi-core modules for convenience.+license:             BSD3+license-file:        LICENSE+author:              Lucas DiCioccio+maintainer:          lucas@dicioccio.fr+category:            System+build-type:          Simple+extra-source-files:  CHANGELOG.md++library+  exposed-modules:+      Prod.App+      Prod.Discovery+      Prod.Echo+      Prod.Health+      Prod.Healthcheck+      Prod.MimeTypes+      Prod.Prometheus+      Prod.Reports+      Prod.Status+      Prod.Watchdog+      Paths_prodapi_web+  autogen-modules:+      Paths_prodapi_web+  reexported-modules:+      Prod.Tracer as Prod.Tracer,+      Prod.Background as Prod.Background,+      Prod.Stepper as Prod.Stepper+  hs-source-dirs:+      src+  default-extensions: OverloadedStrings DataKinds TypeApplications TypeOperators+  build-depends:+    base >= 4.7 && <5,+    aeson >= 2.2.1 && < 2.3,+    containers >= 0.6.8 && < 0.7,+    bytestring >= 0.12.1 && < 0.13,+    text >= 2.1.1 && < 2.2,+    contravariant >= 1.5.5 && < 1.6,+    time >= 1.12.2 && < 1.13,+    async >= 2.2.5 && < 2.3,+    directory >= 1.3.8 && < 1.4,+    http-api-data >= 0.6 && < 0.7,+    http-client >= 0.7.17 && < 0.8,+    http-media >= 0.8.1 && < 0.9,+    lucid >= 2.11.20230408 && < 2.12,+    process-extras >= 0.7.4 && < 0.8,+    prometheus-client >= 1.1.1 && < 1.2,+    prometheus-metrics-ghc >= 1.0.1 && < 1.1,+    servant >= 0.20.1 && < 0.21,+    servant-client >= 0.20 && < 0.21,+    servant-server >= 0.20 && < 0.21,+    wai >= 3.2.4 && < 3.3,+    unix-time >= 0.4.16 && < 0.5,+    unbounded-delays >= 0.1.1.1 && < 0.2,+    uuid >= 1.3.15 && < 1.4,+    prodapi-core >= 0.1.0 && < 0.2+  default-language:    Haskell2010+
+ src/Prod/App.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE FlexibleContexts #-}++module Prod.App (+    app,+    appWithContext,+    initialize,+    Init,+    Runtime (..),+    alwaysReadyRuntime,+)+where++import Data.Aeson (ToJSON)+import Data.Proxy (Proxy (..))+import Prod.Health+import Prod.Prometheus+import Prod.Status+import Servant+import Servant.Server++-- | Run a full API, with raw-serving.+type AppApi status api =+    HealthApi+        :<|> StatusApi status+        :<|> PrometheusApi+        :<|> api+        :<|> Raw++-- | Opaque proof of initialization.+data Init = Init Runtime++-- | Initializes internal data.+initialize :: Runtime -> IO Init+initialize runtime =+    initPrometheus >> pure (Init runtime)++-- | Application.+app ::+    ( HasServer api '[]+    , ToJSON status+    ) =>+    Init ->+    IO status ->+    RenderStatus status ->+    Server api ->+    Proxy api ->+    Application+app (Init runtime) getStatus renderStatus appHandler proxy0 =+    serve+        (proxy proxy0)+        ( handleHealth runtime+            :<|> handleStatus runtime getStatus renderStatus+            :<|> handlePrometheus (CORSAllowOrigin "*")+            :<|> appHandler+            :<|> serveDirectoryFileServer "www"+        )+  where+    proxy :: Proxy y -> Proxy (AppApi status y)+    proxy _ = Proxy++-- | Application.+appWithContext ::+    ( HasServer api context+    , HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters+    , ToJSON status+    ) =>+    Init ->+    IO status ->+    RenderStatus status ->+    Server api ->+    Proxy api ->+    Context context ->+    Application+appWithContext (Init runtime) getStatus renderStatus appHandler proxy0 context =+    serveWithContext+        (proxy proxy0)+        context+        ( handleHealth runtime+            :<|> handleStatus runtime getStatus renderStatus+            :<|> handlePrometheus (CORSAllowOrigin "*")+            :<|> appHandler+            :<|> serveDirectoryFileServer "www"+        )+  where+    proxy :: Proxy x -> Proxy (AppApi status x)+    proxy _ = Proxy+
+ src/Prod/Discovery.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Module for performing service (endpoints) discovery.+module Prod.Discovery where++import Control.Concurrent (threadDelay)+import Data.ByteString (ByteString)+import qualified Data.ByteString as ByteString+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import Data.Time.Clock (UTCTime, getCurrentTime)++import Prod.Background (BackgroundVal, MicroSeconds, background, readBackgroundVal)+import qualified Prod.Background+import Prod.Tracer (Tracer (..), contramap)+import Prometheus (Counter, Gauge, Label3, Vector)+import qualified Prometheus as Prometheus+import System.Process.ByteString (readProcessWithExitCode)++data Track a = BackgroundTrack (Prod.Background.Track (Result a))+    deriving (Show, Functor)++data Result a+    = NotAsked+    | Asked UTCTime+    | Found UTCTime a+    deriving (Show, Functor)++toMaybe :: Result a -> Maybe a+toMaybe (Found _ a) = Just a+toMaybe _ = Nothing++data Discovery a = Discovery (BackgroundVal (Result a))+    deriving (Functor)++readCurrent :: Discovery a -> IO (Result a)+readCurrent (Discovery b) = readBackgroundVal b++type Host = Text++data DNSTrack a = DNSTrack Text Host (Track a)+    deriving (Show, Functor)++dnsA :: Tracer IO (DNSTrack [Host]) -> Host -> IO (Discovery [Host])+dnsA tracer hostname = dig (contramap (DNSTrack hostname "A") tracer) "A" $ Text.unpack hostname++dnsAAAA :: Tracer IO (DNSTrack [Host]) -> Host -> IO (Discovery [Host])+dnsAAAA tracer hostname = dig (contramap (DNSTrack hostname "AAAA") tracer) "AAAA" $ Text.unpack hostname++dig :: Tracer IO (Track [Host]) -> String -> String -> IO (Discovery [Host])+dig tracer typ target = cmdOut tracer "dig" ["+short", typ, target] "" tenSecs [] replaceHosts trigger+  where+    replaceHosts :: [Host] -> ByteString -> [Host]+    replaceHosts _ = parseHosts++    trigger :: [Host] -> [Host] -> IO ()+    trigger _ xs = do+        Prometheus.withLabel+            dnsDiscoveryCounter+            promLabels+            Prometheus.incCounter+        Prometheus.withLabel+            dnsDiscoveryGauge+            promLabels+            (flip Prometheus.setGauge (fromIntegral $ length xs))++    promLabels :: Label3+    promLabels = ("dig", Text.pack typ, Text.pack target)++    parseHosts :: ByteString -> [Host]+    parseHosts = Text.lines . Text.decodeUtf8++    tenSecs :: Maybe (MicroSeconds Int)+    tenSecs = Just 10_000_000++{-# NOINLINE dnsDiscoveryGauge #-}+dnsDiscoveryGauge :: Vector Label3 Gauge+dnsDiscoveryGauge =+    Prometheus.unsafeRegister $+        Prometheus.vector ("m", "type", "host") $+            Prometheus.gauge (Prometheus.Info "prodapi_dns_discovery_results" "")++{-# NOINLINE dnsDiscoveryCounter #-}+dnsDiscoveryCounter :: Vector Label3 Counter+dnsDiscoveryCounter =+    Prometheus.unsafeRegister $+        Prometheus.vector ("m", "type", "host") $+            Prometheus.counter (Prometheus.Info "prodapi_dns_discoveries" "")++cmdOut ::+    forall a.+    Tracer IO (Track a) ->+    String -> -- program to run+    [String] -> -- arguments to the program to run+    ByteString -> -- input submitted to the program+    Maybe (MicroSeconds Int) -> -- delay between invocations+    a ->+    (a -> ByteString -> a) ->+    (a -> a -> IO ()) ->+    IO (Discovery a)+cmdOut tracer cmd args input ms st0 update trigger =+    Discovery <$> background (contramap BackgroundTrack tracer) st0 NotAsked run+  where+    run :: a -> IO (Result a, a)+    run st0 = do+        maybe (pure ()) threadDelay ms+        out <- runCmd+        let st1 = update st0 out+        now <- getCurrentTime+        seq st1 $ trigger st0 st1+        pure $ (Found now st1, st1)++    runCmd :: IO ByteString+    runCmd = (\(_, x, _) -> x) <$> readProcessWithExitCode cmd args input+
+ src/Prod/Echo.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE KindSignatures #-}++module Prod.Echo (+    EchoApi,+    handleEcho,+)+where++import Data.Aeson (FromJSON, ToJSON)+import GHC.TypeLits (Symbol)+import Servant (JSON, Post, ReqBody, Summary, (:>))+import Servant.Server (Handler)++type EchoApi (segment :: Symbol) a =+    Summary "returns the input"+        :> "echo"+        :> segment+        :> ReqBody '[JSON] a+        :> Post '[JSON] a++handleEcho :: (FromJSON a, ToJSON a) => a -> Handler a+handleEcho = pure+
+ src/Prod/Health.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE StandaloneDeriving #-}++module Prod.Health (+    HealthApi,+    GetReadinessApi,+    handleHealth,+    Liveness (..),+    Reason (..),+    Readiness (..),+    completeReadiness,+    Runtime (..),+    alwaysReadyRuntime,+    withLiveness,+    withReadiness,+    Track (..),+)+where++import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Aeson (FromJSON, ToJSON (..), Value (String))+import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import GHC.Generics (Generic)+import GHC.Stack (CallStack, HasCallStack, callStack)+import Prod.Tracer+import Servant++data Runtime+    = Runtime+    { liveness :: IO Liveness+    , readiness :: IO Readiness+    , conditions :: IORef (Set Reason)+    , tracer :: Tracer IO Track+    }++alwaysReadyRuntime :: Tracer IO Track -> IO Runtime+alwaysReadyRuntime tracer = Runtime (pure Alive) (pure Ready) <$> (newIORef mempty) <*> pure tracer++withReadiness :: IO Readiness -> Runtime -> Runtime+withReadiness io rt = rt{readiness = io}++withLiveness :: IO Liveness -> Runtime -> Runtime+withLiveness io rt = rt{liveness = io}++data Liveness = Alive++instance ToJSON Liveness where+    toJSON = const $ String "alive"++newtype Reason = Reason Text+    deriving stock (Eq, Ord, Show)+    deriving+        (ToJSON, FromJSON)+        via Text++data Readiness = Ready | Ill (Set Reason)+    deriving stock (Eq, Ord, Show)+    deriving (Generic)++instance ToJSON Readiness+instance FromJSON Readiness++data Track = Afflict CallStack Reason | Cure CallStack Reason+    deriving (Show)++trace :: (HasCallStack, MonadIO m) => Runtime -> Track -> m ()+trace rt = liftIO . runTracer (tracer rt)++combineReasons :: Readiness -> Set Reason -> Readiness+combineReasons Ready rs+    | Set.null rs = Ready+    | otherwise = Ill rs+combineReasons (Ill rs1) rs2 = Ill (rs1 <> rs2)++completeReadiness :: Runtime -> IO Readiness+completeReadiness rt =+    combineReasons <$> readiness rt <*> readIORef (conditions rt)++-- | Add some illness reason.+afflict :: (MonadIO m, HasCallStack) => Runtime -> Reason -> m ()+afflict rt r = do+    trace rt $ Afflict callStack r+    liftIO $ atomicModifyIORef' (conditions rt) (\rs -> (Set.insert r rs, ()))++-- | Remove some illness reason.+cure :: (MonadIO m, HasCallStack) => Runtime -> Reason -> m ()+cure rt r = do+    trace rt $ Cure callStack r+    liftIO $ atomicModifyIORef' (conditions rt) (\rs -> (Set.delete r rs, ()))++type GetLivenessApi =+    Summary "Health liveness probe."+        :> "health"+        :> "alive"+        :> Get '[JSON] Liveness++type GetReadinessApi =+    Summary "Health readiness probe."+        :> "health"+        :> "ready"+        :> Get '[JSON] Readiness++type DrainApi =+    Summary "Set a specific 'drained' condition."+        :> "health"+        :> "drain"+        :> Post '[JSON] Readiness++type HealthApi =+    GetLivenessApi+        :<|> GetReadinessApi+        :<|> DrainApi++handleHealth :: Runtime -> Server HealthApi+handleHealth runtime =+    handleLiveness runtime+        :<|> handleReadiness runtime+        :<|> handleDrain runtime+  where+    handleLiveness :: Runtime -> Handler Liveness+    handleLiveness = liftIO . liveness+    handleReadiness :: Runtime -> Handler Readiness+    handleReadiness rt = liftIO $ do+        completeReadiness rt+    handleDrain :: Runtime -> Handler Readiness+    handleDrain rt = do+        afflict rt (Reason "drained")+        handleReadiness rt+
+ src/Prod/Healthcheck.hs view
@@ -0,0 +1,325 @@+{-# LANGUAGE DeriveGeneric #-}++module Prod.Healthcheck where++import Control.Concurrent (threadDelay)+import Control.Monad (void, (>=>))+import Data.Aeson (FromJSON (..), ToJSON (..))+import qualified Data.Either as Either+import Data.Foldable (traverse_)+import Data.IORef+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Proxy (Proxy (..))+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Time.Clock+import GHC.Generics (Generic)++import Prod.Background (BackgroundVal)+import qualified Prod.Background as Background+import qualified Prod.Discovery as Discovery+import Prod.Health (GetReadinessApi, Readiness (..))+import Prod.Tracer (Tracer, contramap)+import qualified Prometheus as Prometheus++import Network.HTTP.Client (Manager, defaultManagerSettings, newManager)+import qualified Servant.Client as ServantClient++type Host = Text+type Port = Int+type Error = Text++data Track+    = HealthCheckStarted Host Port+    | HealthCheckFinished Host Port Check+    | BackgroundTrack Host Port (Background.Track CheckSummary)+    deriving (Show)++data Check+    = Success UTCTime Readiness+    | Failed UTCTime Error+    deriving (Show, Generic)+instance ToJSON Check+instance FromJSON Check++resultTime :: Check -> UTCTime+resultTime (Success t _) = t+resultTime (Failed t _) = t++isSuccess :: Check -> Bool+isSuccess (Success _ Ready) = True+isSuccess _ = False++getReadiness :: ServantClient.ClientM Readiness+getReadiness = ServantClient.client (Proxy @GetReadinessApi)++check :: Manager -> Host -> Port -> IO (Either Error Check)+check httpManager host port = do+    now <- getCurrentTime+    let env = ServantClient.mkClientEnv httpManager (ServantClient.BaseUrl ServantClient.Http (Text.unpack host) port "")+    r <- ServantClient.runClientM getReadiness env+    case r of+        Left err -> pure $ Left $ Text.pack $ show err+        Right v -> pure $ Right (Success now v)++data CheckSummary+    = CheckSummary+    { lastReady :: Maybe Check+    , recentChecks :: [Either Error Check]+    }+    deriving (Show, Generic)+instance ToJSON CheckSummary+instance FromJSON CheckSummary++-- | Predicate to tell if a Summary contains a long-enough check history to be considered.+healthChecked :: CheckSummary -> Bool+healthChecked c =+    length (recentChecks c) >= 3++-- | Predicate to tell if a Summary contains no recent successful healthcheck.+neverHealthy :: CheckSummary -> Bool+neverHealthy c =+    not $+        any isSuccess $+            Either.rights $+                recentChecks c++-- | Predicate to tell if the most recent summary exists and is successful.+recentlyHealthy :: CheckSummary -> Bool+recentlyHealthy c =+    maybe False isSuccess $+        safeHead $+            Either.rights $+                recentChecks c++emptyCheckSummary :: CheckSummary+emptyCheckSummary = CheckSummary Nothing []++updateSummary :: Either Error Check -> CheckSummary -> CheckSummary+updateSummary v@(Right c) s+    | isSuccess c = CheckSummary (Just c) (v : (take 2 (recentChecks s)))+    | otherwise = CheckSummary (lastReady s) (v : (take 2 (recentChecks s)))+updateSummary v@(Left _) s =+    CheckSummary (lastReady s) (v : (take 2 (recentChecks s)))++type CheckMap = Map (Host, Port) (BackgroundVal CheckSummary)++emptyCheckMap :: CheckMap+emptyCheckMap = Map.empty++initBackgroundCheck ::+    SpaceCounters ->+    Manager ->+    Tracer IO (Background.Track CheckSummary) ->+    (Host, Port) ->+    IO (BackgroundVal CheckSummary)+initBackgroundCheck cntrs manager tracer (h, p) =+    Background.background tracer emptyCheckSummary emptyCheckSummary step+  where+    step :: CheckSummary -> IO (CheckSummary, CheckSummary)+    step st0 = do+        ns_healthcheck_count cntrs $ Prometheus.incCounter+        res <- check manager h p+        threadDelay 5000000+        let st1 = updateSummary res st0+        pure (st1, st1)++terminateBackgroundCheck :: BackgroundVal CheckSummary -> IO ()+terminateBackgroundCheck = Background.kill++data Space+    = Space+    { spacehttpManager :: Manager+    , backgroundChecks :: IORef CheckMap+    , requestCheck :: (Host, Port) -> IO (BackgroundVal CheckSummary)+    , cancelCheck :: (Host, Port) -> IO ()+    }++clearSpace :: Space -> IO ()+clearSpace sp = do+    v <- atomicModifyIORef' (backgroundChecks sp) (\old -> (Map.empty, old))+    traverse_ terminateBackgroundCheck v++data Counters+    = Counters+    { healthcheck_added :: !(Prometheus.Vector Text Prometheus.Counter)+    , healthcheck_removed :: !(Prometheus.Vector Text Prometheus.Counter)+    , healthcheck_count :: !(Prometheus.Vector Text Prometheus.Counter)+    }++newCounters :: IO Counters+newCounters =+    Counters+        <$> counts "healthcheck_added"+        <*> counts "healthcheck_removed"+        <*> counts "healthchecks"+  where+    counts k =+        Prometheus.register $+            Prometheus.vector "ns" $+                Prometheus.counter (Prometheus.Info k "")++type WithSpaceCounter = (Prometheus.Counter -> IO ()) -> IO ()++data SpaceCounters+    = SpaceCounters+    { ns_healthcheck_added :: WithSpaceCounter+    , ns_healthcheck_removed :: WithSpaceCounter+    , ns_healthcheck_count :: WithSpaceCounter+    }++namespaceCounters :: Namespace -> Counters -> SpaceCounters+namespaceCounters ns cntrs =+    SpaceCounters+        (withNamespace (healthcheck_added cntrs))+        (withNamespace (healthcheck_removed cntrs))+        (withNamespace (healthcheck_count cntrs))+  where+    withNamespace v f = Prometheus.withLabel v ns f++initSpace :: SpaceCounters -> Manager -> Tracer IO Track -> IO Space+initSpace cntrs manager tracer = do+    r <- newIORef emptyCheckMap+    pure $ Space manager r (add cntrs r manager) (del cntrs r)+  where+    add :: SpaceCounters -> IORef CheckMap -> Manager -> (Host, Port) -> IO (BackgroundVal CheckSummary)+    add cntrs r manager = \hp -> do+        c <- Map.lookup hp <$> readIORef r+        case c of+            Nothing -> doadd cntrs r manager hp+            Just v -> pure v++    doadd :: SpaceCounters -> IORef CheckMap -> Manager -> (Host, Port) -> IO (BackgroundVal CheckSummary)+    doadd cntrs r manager = \hp@(h, p) -> do+        ns_healthcheck_added cntrs $ Prometheus.incCounter+        c <- initBackgroundCheck cntrs manager (contramap (BackgroundTrack h p) tracer) hp+        concurrentlyAdded <- atomicModifyIORef' r (\st0 -> (Map.insertWith (\_ old -> old) hp c st0, Map.lookup hp st0))+        case concurrentlyAdded of+            Nothing -> pure c+            Just leader -> terminateBackgroundCheck c >> pure leader++    del :: SpaceCounters -> IORef CheckMap -> (Host, Port) -> IO ()+    del cntrs r = \hp -> do+        print ("removing", hp)+        ns_healthcheck_removed cntrs $ Prometheus.incCounter+        c <- atomicModifyIORef' r (\st0 -> (Map.delete hp st0, Map.lookup hp st0))+        case c of+            Nothing -> pure ()+            Just b -> terminateBackgroundCheck b++setChecks :: Space -> [(Host, Port)] -> IO ()+setChecks space hps = do+    let wantedSet = Set.fromList hps+    currentSet <- Map.keysSet <$> readIORef (backgroundChecks space)+    let spurious = currentSet `Set.difference` wantedSet+    let missing = wantedSet `Set.difference` currentSet+    traverse_ (cancelCheck space) spurious+    traverse_ (requestCheck space) missing++cancelDeadChecks :: Space -> IO ()+cancelDeadChecks space = do+    summary <- readBackgroundChecks space+    traverse_ (cancelCheck space) (deadKeys summary)++{- | Helper to build a Tracer to update hosts to check based on DNS-discovered answers.+Note that the DNSTrack only gives Host, so you need to fmap the port.+-}+setChecksFromDNSDiscovery :: Space -> Discovery.DNSTrack [(Host, Port)] -> IO ()+setChecksFromDNSDiscovery space (Discovery.DNSTrack _ _ (Discovery.BackgroundTrack (Background.RunDone _ newDNSResult))) =+    case Discovery.toMaybe newDNSResult of+        Just xs -> traverse_ (requestCheck space) xs+        Nothing -> pure ()+setChecksFromDNSDiscovery hcrt _ = pure ()++{- | Same as 'setChecksFromDNSDiscovery' but only adding new checks.+You should clear checks of permanently invalid backends.+-}+addChecksFromDNSDiscovery :: Space -> Discovery.DNSTrack [(Host, Port)] -> IO ()+addChecksFromDNSDiscovery space (Discovery.DNSTrack _ _ (Discovery.BackgroundTrack (Background.RunDone _ newDNSResult))) =+    case Discovery.toMaybe newDNSResult of+        Just xs -> setChecks space xs+        Nothing -> pure ()+addChecksFromDNSDiscovery hcrt _ = pure ()++type SummaryMap = Map (Host, Port) CheckSummary++readCheckMap :: CheckMap -> IO SummaryMap+readCheckMap = traverse Background.readBackgroundVal++readBackgroundChecks :: Space -> IO SummaryMap+readBackgroundChecks = readIORef . backgroundChecks >=> readCheckMap++{- | Returns the set of (Host,Port) that are healthy in a given SummaryMap.++Healthiness consists in having the latest healthcheck as healthy.+-}+healthyKeys :: SummaryMap -> [(Host, Port)]+healthyKeys m =+    fmap fst $+        filter (recentlyHealthy . snd) $+            Map.toList m++{- | Returns the set of (Host,Port) that have no recent successful activity+provided there is enough health-checking history.+-}+deadKeys :: SummaryMap -> [(Host, Port)]+deadKeys m =+    fmap fst $+        filter (\(_, x) -> neverHealthy x && healthChecked x) $+            Map.toList m++safeHead :: [a] -> Maybe a+safeHead (x : _) = Just x+safeHead _ = Nothing++type Namespace = Text++type Namespaced a = (Namespace, a)++data Runtime+    = Runtime+    { counters :: Counters+    , httpManager :: Manager+    , tracer :: Tracer IO (Namespaced Track)+    , -- todo: split globals env values and dynamic-space storage+      spaces :: IORef (Map Namespace Space)+    }++initRuntime :: Tracer IO (Namespaced Track) -> IO Runtime+initRuntime tracer = do+    r <- newIORef Map.empty+    manager <- newManager defaultManagerSettings+    cntrs <- newCounters+    pure $ Runtime cntrs manager tracer r++readSpaces :: Runtime -> IO (Map Namespace SummaryMap)+readSpaces rt = do+    r <- readIORef . spaces $ rt+    traverse readBackgroundChecks r++registerSpace :: Runtime -> Namespace -> IO Space+registerSpace rt ns = withSpace rt ns pure++withSpace :: Runtime -> Namespace -> (Space -> IO a) -> IO a+withSpace rt ns run = do+    let r = spaces rt+    sp <- Map.lookup ns <$> readIORef r+    case sp of+        Just s -> run s+        Nothing -> do+            s <- initRuntimeSpace rt ns+            concurrentlyAdded <- atomicModifyIORef' r (\st0 -> (Map.insertWith (\_ old -> old) ns s st0, Map.lookup ns st0))+            case concurrentlyAdded of+                Nothing -> run s+                Just leader -> clearSpace s >> run leader++-- | Only create a space (no registration).+initRuntimeSpace :: Runtime -> Namespace -> IO Space+initRuntimeSpace rt ns =+    initSpace+        (namespaceCounters ns $ counters rt)+        (httpManager rt)+        (contramap (\x -> (ns, x)) (tracer rt))+
+ src/Prod/MimeTypes.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}++module Prod.MimeTypes where++import Data.ByteString (ByteString)+import Data.ByteString.Lazy (fromStrict)+import qualified Network.HTTP.Media as M+import Servant+import System.IO.Unsafe++data HTML++data PNG++data SVG++data GraphPictureData+    = GraphPictureData+    { graphvizInput :: !ByteString+    , serializedPng :: (IO ByteString)+    , serializedSvg :: (IO ByteString)+    }++instance Accept HTML where+    contentType _ = "text" M.// "html" M./: ("charset", "utf-8")++instance Accept PNG where+    contentType _ = "image" M.// "png"++instance MimeRender PNG GraphPictureData where+    mimeRender _ = fromStrict . unsafePerformIO . serializedPng++instance MimeRender PlainText GraphPictureData where+    mimeRender _ = fromStrict . graphvizInput++instance Accept SVG where+    contentType _ = "image" M.// "svg"++instance MimeRender SVG GraphPictureData where+    mimeRender _ = fromStrict . unsafePerformIO . serializedSvg+
+ src/Prod/Prometheus.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Prod.Prometheus (+    handlePrometheus,+    PrometheusApi,+    CORSAllowOrigin (..),+    PrometheusResult (..),+    initPrometheus,+    inc,+    obs,+    timeIt,+)+where++import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.ByteString.Lazy (ByteString)+import Data.Coerce (coerce)+import Data.Text (Text)+import Data.Time.Clock (diffUTCTime, getCurrentTime)+import qualified Network.HTTP.Media as M+import Prometheus (Counter, Vector, exportMetricsAsText, register)+import qualified Prometheus as Prometheus+import Prometheus.Metric.GHC (GHCMetrics, ghcMetrics)+import Servant+import Servant.Server (Handler, Server)++newtype PrometheusResult = PrometheusResult {toLBS :: ByteString}++instance MimeRender PlainText PrometheusResult where+    mimeRender _ = toLBS++type PrometheusApi =+    Summary "Prometheus metrics"+        :> "metrics"+        :> Get '[PlainText] (Headers '[Header "Access-Control-Allow-Origin" CORSAllowOrigin] PrometheusResult)++newtype CORSAllowOrigin = CORSAllowOrigin Text+    deriving (ToHttpApiData)++handlePrometheus :: CORSAllowOrigin -> Server PrometheusApi+handlePrometheus corsAllow = handleMetrics+  where+    handleMetrics :: Handler (Headers '[Header "Access-Control-Allow-Origin" CORSAllowOrigin] PrometheusResult)+    handleMetrics = do+        metrics <- liftIO $ exportMetricsAsText+        pure $ addHeader (coerce corsAllow) $ PrometheusResult metrics++initPrometheus :: IO GHCMetrics+initPrometheus = register ghcMetrics++inc ::+    (MonadIO m) =>+    (a -> Vector Text Counter) ->+    Text ->+    a ->+    m ()+inc f s cnts =+    liftIO $ Prometheus.withLabel (f cnts) s Prometheus.incCounter++obs ::+    (MonadIO m) =>+    (a -> Prometheus.Summary) ->+    Double ->+    a ->+    m ()+obs f v cnts =+    liftIO $ Prometheus.observe (f cnts) v++timeIt ::+    (MonadIO m) =>+    (a -> Prometheus.Summary) ->+    a ->+    m b ->+    m b+timeIt f cnts action = do+    t0 <- liftIO $ getCurrentTime+    !ret <- action+    t1 <- liftIO $ getCurrentTime+    obs f (fromRational $ toRational $ diffUTCTime t1 t0) cnts+    pure ret+
+ src/Prod/Reports.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE KindSignatures #-}++module Prod.Reports (+    ReportsApi,+    Report (..),+    countReports,+    Runtime,+    initRuntime,+)+where++import Control.Monad.IO.Class (liftIO)+import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.=))+import GHC.TypeLits (Symbol)+import Prod.Tracer+import qualified Prometheus as Prometheus+import Servant (JSON, Post, ReqBody, Summary, (:>))+import Servant.Server (Handler)++{- | Some minimal report wrapper.+Has low expectations on the client.+-}+data Report a = Report {posixTime :: Int, backoff :: Int, events :: [a]}++instance (FromJSON a) => FromJSON (Report a) where+    parseJSON = withObject "Report" $ \o ->+        Report <$> o .: "t" <*> o .: "b" <*> o .: "es"+instance (ToJSON a) => ToJSON (Report a) where+    toJSON (Report t b es) = object ["t" .= t, "b" .= b, "es" .= es]++type ReportsApi a =+    Summary "receives and acknowledge some reports"+        :> "reports"+        :> ReqBody '[JSON] (Report a)+        :> Post '[JSON] Int++-- | A set of counters tracking .+data Counters+    = Counters+    { reports_count :: !Prometheus.Counter+    , reported_events :: !Prometheus.Counter+    , reported_sizes :: !Prometheus.Summary+    , reported_backoffs :: !Prometheus.Summary+    }++newCounters :: IO Counters+newCounters =+    Counters+        <$> counts "reports"+        <*> counts "report_events"+        <*> summary "report_sizes"+        <*> summary "report_backoffs"+  where+    counts k =+        Prometheus.register $+            Prometheus.counter (Prometheus.Info k "")+    summary k =+        Prometheus.register $+            Prometheus.summary (Prometheus.Info k "") Prometheus.defaultQuantiles++-- | A default runtime for the `dropReports` route.+data Runtime a = Runtime {counters :: !Counters, tracer :: !(Tracer IO (Report a))}++initRuntime :: Tracer IO (Report a) -> IO (Runtime a)+initRuntime tracer = Runtime <$> newCounters <*> pure tracer++-- | Count and drop reports.+countReports :: Runtime a -> Report a -> Handler Int+countReports (Runtime counters tracer) report = do+    let size = length (events report)+    let dsize = fromIntegral size+    liftIO $ do+        runTracer tracer $ report+        Prometheus.incCounter (reports_count counters)+        Prometheus.addCounter (reported_events counters) dsize+        Prometheus.observe (reported_sizes counters) dsize+        Prometheus.observe (reported_backoffs counters) (fromIntegral $ backoff report)+    pure size+
+ src/Prod/Status.hs view
@@ -0,0 +1,149 @@+{-# 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+        (ToJSON)+        via Text++-- | Type to render a status page.+type RenderStatus a = Status a -> Html ()++data Status a+    = Status+    { identification :: !Identification+    , liveness :: !Liveness+    , readiness :: !Readiness+    , appStatus :: !a+    , renderer :: RenderStatus a+    }++instance (ToJSON a) => ToJSON (Status a) where+    toJSON (Status i l r st _) =+        Aeson.object+            [ "id" .= i+            , "liveness" .= l+            , "readiness" .= r+            , "status" .= toJSON st+            ]++handleStatus :: Runtime -> IO a -> RenderStatus a -> Handler (Status a)+handleStatus runtime getAppStatus render =+    liftIO $+        Status this+            <$> Health.liveness runtime+            <*> Health.completeReadiness runtime+            <*> getAppStatus+            <*> (pure render)++{-# NOINLINE this #-}+this :: Identification+this = unsafePerformIO $ fmap (Identification . Text.pack . show) nextRandom++instance {-# OVERLAPPABLE #-} MimeRender HTML (Status a) where+    mimeRender _ st = renderBS $ render st+      where+        render = renderer st++defaultStatusPage :: forall a. (a -> Html ()) -> RenderStatus a+defaultStatusPage renderAppStatus = go+  where+    go :: Status a -> Html ()+    go (Status (Identification uuid) liveness readiness appStatus _) =+        html_ $ do+            head_ $ do+                title_ "status page"+                link_ [rel_ "stylesheet", type_ "text/css", href_ "status.css"]+            body_ $ do+                section_ $ do+                    h1_ "identification"+                    p_ $ toHtml uuid+                section_ $ do+                    h1_ "general status"+                    renderLiveness liveness+                    renderReadiness readiness+                    with form_ [action_ "/health/drain", method_ "post"] $+                        input_ [type_ "submit", value_ "drain me"]+                section_ $ do+                    h1_ "app status"+                    renderAppStatus appStatus+    renderLiveness :: Liveness -> Html ()+    renderLiveness Alive = p_ $ with a_ [href_ "/health/alive"] "alive"++    renderReadiness :: Readiness -> Html ()+    renderReadiness Ready = p_ $ with a_ [href_ "/health/ready"] "ready"+    renderReadiness (Ill reasons) = do+        p_ $ with a_ [href_ "/health/ready"] "not-ready"+        ul_ $ do+            traverse_ renderReason reasons++    renderReason :: Reason -> Html ()+    renderReason (Reason r) =+        li_ $ toHtml r++{- | Like defaultStatusPage but uses a type-class-defined to pass the+application-status rendering.+-}+statusPage :: (ToHtml a) => RenderStatus a+statusPage = defaultStatusPage toHtml++type MetricsJSurl = Text++-- | Section with metrics.+metricsSection :: MetricsJSurl -> RenderStatus a+metricsSection metrics_js = const $+    section_ $ do+        h1_ "metrics"+        with div_ [id_ "metrics"] $ pure ()+        toHtmlRaw @Text $ "<script async type=\"text/javascript\" src=\"" <> metrics_js <> "\"></script>"++versionsSection :: [(String, Version)] -> RenderStatus a+versionsSection pkgs = const $+    section_ $ do+        h1_ "versions"+        ul_ $+            traverse_ renderVersion pkgs+  where+    renderVersion :: (String, Version) -> Html ()+    renderVersion (pkg, ver) =+        li_ $ p_ $ toHtml $ pkg <> ":" <> showVersion ver+
+ src/Prod/Watchdog.hs view
@@ -0,0 +1,94 @@+module Prod.Watchdog where++import Control.Exception.Base (IOException, catch)+import Control.Monad (when)+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Time.Clock (UTCTime, getCurrentTime)+import Prod.Background (BackgroundVal, MicroSeconds, backgroundLoop)+import qualified Prod.Background+import Prod.Tracer (Tracer (..), contramap)+import Prometheus (Counter, Label1, Label2, Vector)+import qualified Prometheus as Prometheus+import System.Directory (doesFileExist, setModificationTime)++data Track r = BackgroundTrack (Prod.Background.Track (WatchdogResult r))+    deriving (Show)++data WatchdogResult a+    = Skipped+    | Success a+    | Failed+    deriving (Show, Ord, Eq)++data Watchdog a = Watchdog+    { backgroundVal :: BackgroundVal (WatchdogResult a)+    , tracer :: Tracer IO (Track a)+    }++watchdog ::+    (Prometheus.Label label) =>+    Vector label Counter ->+    Tracer IO (Track a) ->+    (WatchdogResult a -> label) ->+    MicroSeconds Int ->+    IO (WatchdogResult a) ->+    IO (Watchdog a)+watchdog counters tracer mkLabel delay action =+    Watchdog <$> backgroundLoop (contramap BackgroundTrack tracer) Skipped go delay <*> pure tracer+  where+    go = do+        res <- action+        Prometheus.withLabel counters (mkLabel res) Prometheus.incCounter+        pure res++{- | Basic watchdog with a vector metric.+The input vector label is set with success|failed|skipped depending on the WatchdogResult.+-}+basicWatchdog ::+    Vector Label1 Counter ->+    Tracer IO (Track a) ->+    MicroSeconds Int ->+    IO (WatchdogResult a) ->+    IO (Watchdog a)+basicWatchdog counters tracer delay action =+    watchdog counters tracer basicLabel delay action++basicLabel :: WatchdogResult a -> Label1+basicLabel res = case res of+    Success _ -> "success"+    Failed -> "failed"+    Skipped -> "skipped"++data FileTouchTrack r = FileTouchTrack FilePath (Track r)+    deriving (Show)++{- | Touches a file periodically, using setModificationTime.+If the file does not exists when the watchdog is initialized, then it is+created empty.+-}+fileTouchWatchdog ::+    FilePath ->+    Tracer IO (FileTouchTrack UTCTime) ->+    MicroSeconds Int ->+    IO (Watchdog UTCTime)+fileTouchWatchdog path tracer delay = do+    let mkLabel res = (basicLabel res, Text.pack path)+    shouldCreate <- not <$> doesFileExist path+    when shouldCreate $ writeFile path ""+    watchdog fileTouchWatchdogCounter (contramap (FileTouchTrack path) tracer) mkLabel delay io+  where+    handleIOException :: IOException -> IO (WatchdogResult UTCTime)+    handleIOException _ = pure $ Failed+    io = do+        now <- getCurrentTime+        let touchFile = setModificationTime path now *> pure (Success now)+        touchFile `catch` handleIOException++{-# NOINLINE fileTouchWatchdogCounter #-}+fileTouchWatchdogCounter :: Vector Label2 Counter+fileTouchWatchdogCounter =+    Prometheus.unsafeRegister $+        Prometheus.vector ("status", "path") $+            Prometheus.counter (Prometheus.Info "prodapi_watchdog_filetouch" "")+