diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for prodapi + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/prodapi.cabal b/prodapi.cabal new file mode 100644 --- /dev/null +++ b/prodapi.cabal @@ -0,0 +1,57 @@ +cabal-version: >=1.10 +name: prodapi +version: 0.1.0.0 +synopsis: Some curated and opinionated packages for building Haskell services. +description: A library of curated and opinionated packages for building Haskell serivces, with some preferred pattern. Services expose metrics using prometheus and log events via contravariant logging. +-- bug-reports: +license: BSD3 +license-file: LICENSE +author: Lucas DiCioccio +maintainer: lucas@dicioccio.fr +-- copyright: +category: System +build-type: Simple +extra-source-files: CHANGELOG.md + +library + exposed-modules: + Prod.App + Prod.Background + Prod.Discovery + Prod.Echo + Prod.Health + Prod.Healthcheck + Prod.MimeTypes + Prod.Prometheus + Prod.Reports + Prod.Status + Prod.Tracer + Prod.Watchdog + Paths_prodapi + -- other-modules: + 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, + uuid >= 1.3.15 && < 1.4 + default-language: Haskell2010 diff --git a/src/Prod/App.hs b/src/Prod/App.hs new file mode 100644 --- /dev/null +++ b/src/Prod/App.hs @@ -0,0 +1,86 @@ +{-# 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 diff --git a/src/Prod/Background.hs b/src/Prod/Background.hs new file mode 100644 --- /dev/null +++ b/src/Prod/Background.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE NumericUnderscores #-} + +module Prod.Background ( + BackgroundVal, + MicroSeconds, + background, + backgroundLoop, + kill, + link, + readBackgroundVal, + Track (..), +) +where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (Async, async, cancel) +import qualified Control.Concurrent.Async as Async +import Control.Monad (forever) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef) +import Prod.Tracer (Tracer (..)) + +import GHC.Stack (CallStack, HasCallStack, callStack) + +data Track r + = Init r + | RunStart + | RunDone r r + | Kill CallStack + deriving (Show, Functor) + +-- | A value that is coupled to an async in charge of updating the value. +data BackgroundVal a + = forall r. + BackgroundVal + { transform :: r -> a + -- ^ a transformation to apply to the background val, allows to turn the IORef into a functor + , currentValue :: IORef r + -- ^ a mutable reference for the latest value + , backgroundTask :: Async () + -- ^ a background task responsible for updating the value, implementations should guarantee that once the Aync () is cancelled, currentValue is never updated + , tracer :: Tracer IO (Track r) + } + +instance Functor BackgroundVal where + fmap g (BackgroundVal f ioref task tracer) = + BackgroundVal (g . f) ioref task tracer + +-- | Starts a background task continuously updating a value. +background :: + Tracer IO (Track a) -> + -- | initial state + b -> + -- | initial value + a -> + -- | state-influenced task + (b -> IO (a, b)) -> + IO (BackgroundVal a) +background tracer initState defaultValue task = do + trace (Init defaultValue) + ref <- newIORef defaultValue + BackgroundVal id ref <$> async (loop ref initState) <*> pure tracer + where + trace = runTracer tracer + loop ref st0 = do + trace (RunStart) + (newVal, st1) <- task st0 + oldVal <- seq newVal $ atomicModifyIORef' ref (\old -> (newVal, old)) + trace (RunDone oldVal newVal) + seq st1 $ loop ref st1 + +-- | Fantom type for annotating Int. +type MicroSeconds n = n + +{- | Starts a background task continuously updating a value at a periodic interval. +This is implemented by interspersing a threadDelay before the task and calling background and hiding the 'state-passing' arguments. +-} +backgroundLoop :: + Tracer IO (Track a) -> + -- | initial value + a -> + -- | periodic task + IO a -> + -- | wait period between two executions + MicroSeconds Int -> + IO (BackgroundVal a) +backgroundLoop tracer defaultValue task usecs = do + background tracer () defaultValue (\_ -> threadDelay usecs >> fmap adapt task) + where + adapt x = (x, ()) + +-- | Kills the watchdog by killing the underlying async. +readBackgroundVal :: (MonadIO m) => BackgroundVal a -> m a +readBackgroundVal (BackgroundVal f ioref _ _) = + fmap f $ liftIO $ readIORef ioref + +-- | Kills the watchdog by killing the underlying async. +kill :: (HasCallStack, MonadIO m) => BackgroundVal a -> m () +kill bkg@(BackgroundVal _ _ _ tracer) = liftIO $ do + runTracer tracer (Kill callStack) + liftIO $ cancel . backgroundTask $ bkg + +link :: BackgroundVal a -> BackgroundVal b -> IO () +link b1 b2 = Async.link2 (backgroundTask b1) (backgroundTask b2) diff --git a/src/Prod/Discovery.hs b/src/Prod/Discovery.hs new file mode 100644 --- /dev/null +++ b/src/Prod/Discovery.hs @@ -0,0 +1,117 @@ +{-# 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 diff --git a/src/Prod/Echo.hs b/src/Prod/Echo.hs new file mode 100644 --- /dev/null +++ b/src/Prod/Echo.hs @@ -0,0 +1,22 @@ +{-# 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 diff --git a/src/Prod/Health.hs b/src/Prod/Health.hs new file mode 100644 --- /dev/null +++ b/src/Prod/Health.hs @@ -0,0 +1,132 @@ +{-# 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 diff --git a/src/Prod/Healthcheck.hs b/src/Prod/Healthcheck.hs new file mode 100644 --- /dev/null +++ b/src/Prod/Healthcheck.hs @@ -0,0 +1,324 @@ +{-# 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)) diff --git a/src/Prod/MimeTypes.hs b/src/Prod/MimeTypes.hs new file mode 100644 --- /dev/null +++ b/src/Prod/MimeTypes.hs @@ -0,0 +1,41 @@ +{-# 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 diff --git a/src/Prod/Prometheus.hs b/src/Prod/Prometheus.hs new file mode 100644 --- /dev/null +++ b/src/Prod/Prometheus.hs @@ -0,0 +1,82 @@ +{-# 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 diff --git a/src/Prod/Reports.hs b/src/Prod/Reports.hs new file mode 100644 --- /dev/null +++ b/src/Prod/Reports.hs @@ -0,0 +1,78 @@ +{-# 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 diff --git a/src/Prod/Status.hs b/src/Prod/Status.hs new file mode 100644 --- /dev/null +++ b/src/Prod/Status.hs @@ -0,0 +1,148 @@ +{-# 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 $ "" + +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 diff --git a/src/Prod/Tracer.hs b/src/Prod/Tracer.hs new file mode 100644 --- /dev/null +++ b/src/Prod/Tracer.hs @@ -0,0 +1,112 @@ +-- https://www.youtube.com/watch?v=qzOQOmmkKEM&feature=emb_logo + +module Prod.Tracer ( + Tracer (..), + silent, + traceIf, + traceBoth, + + -- * common utilities + tracePrint, + traceHPrint, + traceHPut, + encodeJSON, + pulls, + + -- * re-exports + Contravariant (..), + Divisible (..), + Decidable (..), +) where + +import Control.Monad ((>=>)) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Aeson (ToJSON, encode) +import Data.ByteString.Lazy (ByteString, hPut) +import Data.Functor.Contravariant +import Data.Functor.Contravariant.Divisible +import System.IO (Handle, hPrint) + +newtype Tracer m a = Tracer {runTracer :: (a -> m ())} + +instance Contravariant (Tracer m) where + contramap f (Tracer g) = Tracer (g . f) + +instance (Applicative m) => Divisible (Tracer m) where + conquer = silent + divide = traceSplit + +instance (Applicative m) => Decidable (Tracer m) where + lose _ = silent + choose = tracePick + +-- | Disable Tracing. +{-# INLINE silent #-} +silent :: (Applicative m) => Tracer m a +silent = Tracer (const $ pure ()) + +{- | Splits a tracer into two chunks that are run sequentially. + +This name can be confusing but it has to be thought backwards for Contravariant logging: +We compose a target tracer from two tracers but we split the content of the trace. + +Note that the split function may actually duplicate inputs (that's how traceBoth works). +-} +{-# INLINEABLE traceSplit #-} +traceSplit :: (Applicative m) => (c -> (a, b)) -> Tracer m a -> Tracer m b -> Tracer m c +traceSplit split (Tracer f1) (Tracer f2) = Tracer (go . split) + where + go (b, c) = f1 b *> f2 c + +{- | If you are given two tracers and want to pass both. +Composition occurs in sequence. +-} +{-# INLINEABLE traceBoth #-} +traceBoth :: (Applicative m) => Tracer m a -> Tracer m a -> Tracer m a +traceBoth t1 t2 = traceSplit (\x -> (x, x)) t1 t2 + +{- | Picks a tracer based on the emitted object. +Example logic that can be built is traceIf that silent messages. +-} +{-# INLINEABLE tracePick #-} +tracePick :: (Applicative m) => (c -> Either a b) -> Tracer m a -> Tracer m b -> Tracer m c +tracePick split (Tracer f1) (Tracer f2) = Tracer $ \a -> + let e = split a + in either f1 f2 e + +-- | Filter by dynamically testing values. +{-# INLINEABLE traceIf #-} +traceIf :: (Applicative m) => (a -> Bool) -> Tracer m a -> Tracer m a +traceIf predicate t = tracePick (\x -> if predicate x then Left () else Right x) silent t + +-- | A tracer that prints emitted events. +tracePrint :: (MonadIO m, Show a) => Tracer m a +tracePrint = Tracer (liftIO . print) + +-- | A tracer that prints emitted to some handle. +traceHPrint :: (MonadIO m, Show a) => Handle -> Tracer m a +traceHPrint handle = Tracer (liftIO . hPrint handle) + +-- | A tracer that puts some ByteString to some handle. +traceHPut :: (MonadIO m) => Handle -> Tracer m ByteString +traceHPut handle = Tracer (liftIO . hPut handle) + +-- | A conversion encoding values to JSON. +{-# INLINE encodeJSON #-} +encodeJSON :: (ToJSON a) => Tracer m ByteString -> Tracer m a +encodeJSON = contramap encode + +{- | Pulls a value to complete a trace when a trace occurs. + +This function allows to combines pushed values with pulled values. Hence, +performing some scheduling between behaviours. +Typical usage would be to annotate a trace with a background value, or perform +data augmentation in a pipelines of traces. + +Note that if you rely on this function you need to pay attention of the +blocking effect of 'pulls': the traced value c is not forwarded until a +value b is available. +-} +{-# INLINE pulls #-} +pulls :: (Monad m) => (c -> m b) -> Tracer m b -> Tracer m c +pulls act (Tracer f1) = Tracer $ act >=> f1 diff --git a/src/Prod/Watchdog.hs b/src/Prod/Watchdog.hs new file mode 100644 --- /dev/null +++ b/src/Prod/Watchdog.hs @@ -0,0 +1,93 @@ +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" "")