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 (Int -> Track r -> ShowS
[Track r] -> ShowS
Track r -> String
(Int -> Track r -> ShowS)
-> (Track r -> String) -> ([Track r] -> ShowS) -> Show (Track r)
forall r. Show r => Int -> Track r -> ShowS
forall r. Show r => [Track r] -> ShowS
forall r. Show r => Track r -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall r. Show r => Int -> Track r -> ShowS
showsPrec :: Int -> Track r -> ShowS
$cshow :: forall r. Show r => Track r -> String
show :: Track r -> String
$cshowList :: forall r. Show r => [Track r] -> ShowS
showList :: [Track r] -> ShowS
Show)

data WatchdogResult a
    = Skipped
    | Success a
    | Failed
    deriving (Int -> WatchdogResult a -> ShowS
[WatchdogResult a] -> ShowS
WatchdogResult a -> String
(Int -> WatchdogResult a -> ShowS)
-> (WatchdogResult a -> String)
-> ([WatchdogResult a] -> ShowS)
-> Show (WatchdogResult a)
forall a. Show a => Int -> WatchdogResult a -> ShowS
forall a. Show a => [WatchdogResult a] -> ShowS
forall a. Show a => WatchdogResult a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> WatchdogResult a -> ShowS
showsPrec :: Int -> WatchdogResult a -> ShowS
$cshow :: forall a. Show a => WatchdogResult a -> String
show :: WatchdogResult a -> String
$cshowList :: forall a. Show a => [WatchdogResult a] -> ShowS
showList :: [WatchdogResult a] -> ShowS
Show, Eq (WatchdogResult a)
Eq (WatchdogResult a) =>
(WatchdogResult a -> WatchdogResult a -> Ordering)
-> (WatchdogResult a -> WatchdogResult a -> Bool)
-> (WatchdogResult a -> WatchdogResult a -> Bool)
-> (WatchdogResult a -> WatchdogResult a -> Bool)
-> (WatchdogResult a -> WatchdogResult a -> Bool)
-> (WatchdogResult a -> WatchdogResult a -> WatchdogResult a)
-> (WatchdogResult a -> WatchdogResult a -> WatchdogResult a)
-> Ord (WatchdogResult a)
WatchdogResult a -> WatchdogResult a -> Bool
WatchdogResult a -> WatchdogResult a -> Ordering
WatchdogResult a -> WatchdogResult a -> WatchdogResult a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (WatchdogResult a)
forall a. Ord a => WatchdogResult a -> WatchdogResult a -> Bool
forall a. Ord a => WatchdogResult a -> WatchdogResult a -> Ordering
forall a.
Ord a =>
WatchdogResult a -> WatchdogResult a -> WatchdogResult a
$ccompare :: forall a. Ord a => WatchdogResult a -> WatchdogResult a -> Ordering
compare :: WatchdogResult a -> WatchdogResult a -> Ordering
$c< :: forall a. Ord a => WatchdogResult a -> WatchdogResult a -> Bool
< :: WatchdogResult a -> WatchdogResult a -> Bool
$c<= :: forall a. Ord a => WatchdogResult a -> WatchdogResult a -> Bool
<= :: WatchdogResult a -> WatchdogResult a -> Bool
$c> :: forall a. Ord a => WatchdogResult a -> WatchdogResult a -> Bool
> :: WatchdogResult a -> WatchdogResult a -> Bool
$c>= :: forall a. Ord a => WatchdogResult a -> WatchdogResult a -> Bool
>= :: WatchdogResult a -> WatchdogResult a -> Bool
$cmax :: forall a.
Ord a =>
WatchdogResult a -> WatchdogResult a -> WatchdogResult a
max :: WatchdogResult a -> WatchdogResult a -> WatchdogResult a
$cmin :: forall a.
Ord a =>
WatchdogResult a -> WatchdogResult a -> WatchdogResult a
min :: WatchdogResult a -> WatchdogResult a -> WatchdogResult a
Ord, WatchdogResult a -> WatchdogResult a -> Bool
(WatchdogResult a -> WatchdogResult a -> Bool)
-> (WatchdogResult a -> WatchdogResult a -> Bool)
-> Eq (WatchdogResult a)
forall a. Eq a => WatchdogResult a -> WatchdogResult a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => WatchdogResult a -> WatchdogResult a -> Bool
== :: WatchdogResult a -> WatchdogResult a -> Bool
$c/= :: forall a. Eq a => WatchdogResult a -> WatchdogResult a -> Bool
/= :: WatchdogResult a -> WatchdogResult a -> Bool
Eq)

data Watchdog a = Watchdog
    { forall a. Watchdog a -> BackgroundVal (WatchdogResult a)
backgroundVal :: BackgroundVal (WatchdogResult a)
    , forall a. Watchdog a -> Tracer IO (Track 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 :: forall label a.
Label label =>
Vector label Counter
-> Tracer IO (Track a)
-> (WatchdogResult a -> label)
-> Int
-> IO (WatchdogResult a)
-> IO (Watchdog a)
watchdog Vector label Counter
counters Tracer IO (Track a)
tracer WatchdogResult a -> label
mkLabel Int
delay IO (WatchdogResult a)
action =
    BackgroundVal (WatchdogResult a)
-> Tracer IO (Track a) -> Watchdog a
forall a.
BackgroundVal (WatchdogResult a)
-> Tracer IO (Track a) -> Watchdog a
Watchdog (BackgroundVal (WatchdogResult a)
 -> Tracer IO (Track a) -> Watchdog a)
-> IO (BackgroundVal (WatchdogResult a))
-> IO (Tracer IO (Track a) -> Watchdog a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tracer IO (Track (WatchdogResult a))
-> WatchdogResult a
-> IO (WatchdogResult a)
-> Int
-> IO (BackgroundVal (WatchdogResult a))
forall a.
Tracer IO (Track a) -> a -> IO a -> Int -> IO (BackgroundVal a)
backgroundLoop ((Track (WatchdogResult a) -> Track a)
-> Tracer IO (Track a) -> Tracer IO (Track (WatchdogResult a))
forall a' a. (a' -> a) -> Tracer IO a -> Tracer IO a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap Track (WatchdogResult a) -> Track a
forall r. Track (WatchdogResult r) -> Track r
BackgroundTrack Tracer IO (Track a)
tracer) WatchdogResult a
forall a. WatchdogResult a
Skipped IO (WatchdogResult a)
go Int
delay IO (Tracer IO (Track a) -> Watchdog a)
-> IO (Tracer IO (Track a)) -> IO (Watchdog a)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Tracer IO (Track a) -> IO (Tracer IO (Track a))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tracer IO (Track a)
tracer
  where
    go :: IO (WatchdogResult a)
go = do
        WatchdogResult a
res <- IO (WatchdogResult a)
action
        Vector label Counter -> label -> (Counter -> IO ()) -> IO ()
forall label (m :: * -> *) metric.
(Label label, MonadMonitor m) =>
Vector label metric -> label -> (metric -> IO ()) -> m ()
Prometheus.withLabel Vector label Counter
counters (WatchdogResult a -> label
mkLabel WatchdogResult a
res) Counter -> IO ()
forall (m :: * -> *). MonadMonitor m => Counter -> m ()
Prometheus.incCounter
        WatchdogResult a -> IO (WatchdogResult a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure WatchdogResult a
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 :: forall a.
Vector Text Counter
-> Tracer IO (Track a)
-> Int
-> IO (WatchdogResult a)
-> IO (Watchdog a)
basicWatchdog Vector Text Counter
counters Tracer IO (Track a)
tracer Int
delay IO (WatchdogResult a)
action =
    Vector Text Counter
-> Tracer IO (Track a)
-> (WatchdogResult a -> Text)
-> Int
-> IO (WatchdogResult a)
-> IO (Watchdog a)
forall label a.
Label label =>
Vector label Counter
-> Tracer IO (Track a)
-> (WatchdogResult a -> label)
-> Int
-> IO (WatchdogResult a)
-> IO (Watchdog a)
watchdog Vector Text Counter
counters Tracer IO (Track a)
tracer WatchdogResult a -> Text
forall a. WatchdogResult a -> Text
basicLabel Int
delay IO (WatchdogResult a)
action

basicLabel :: WatchdogResult a -> Label1
basicLabel :: forall a. WatchdogResult a -> Text
basicLabel WatchdogResult a
res = case WatchdogResult a
res of
    Success a
_ -> Text
"success"
    WatchdogResult a
Failed -> Text
"failed"
    WatchdogResult a
Skipped -> Text
"skipped"

data FileTouchTrack r = FileTouchTrack FilePath (Track r)
    deriving (Int -> FileTouchTrack r -> ShowS
[FileTouchTrack r] -> ShowS
FileTouchTrack r -> String
(Int -> FileTouchTrack r -> ShowS)
-> (FileTouchTrack r -> String)
-> ([FileTouchTrack r] -> ShowS)
-> Show (FileTouchTrack r)
forall r. Show r => Int -> FileTouchTrack r -> ShowS
forall r. Show r => [FileTouchTrack r] -> ShowS
forall r. Show r => FileTouchTrack r -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall r. Show r => Int -> FileTouchTrack r -> ShowS
showsPrec :: Int -> FileTouchTrack r -> ShowS
$cshow :: forall r. Show r => FileTouchTrack r -> String
show :: FileTouchTrack r -> String
$cshowList :: forall r. Show r => [FileTouchTrack r] -> ShowS
showList :: [FileTouchTrack r] -> ShowS
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 :: String
-> Tracer IO (FileTouchTrack UTCTime)
-> Int
-> IO (Watchdog UTCTime)
fileTouchWatchdog String
path Tracer IO (FileTouchTrack UTCTime)
tracer Int
delay = do
    let mkLabel :: WatchdogResult a -> Label2
mkLabel WatchdogResult a
res = (WatchdogResult a -> Text
forall a. WatchdogResult a -> Text
basicLabel WatchdogResult a
res, String -> Text
Text.pack String
path)
    Bool
shouldCreate <- Bool -> Bool
not (Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Bool
doesFileExist String
path
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldCreate (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
writeFile String
path String
""
    Vector Label2 Counter
-> Tracer IO (Track UTCTime)
-> (WatchdogResult UTCTime -> Label2)
-> Int
-> IO (WatchdogResult UTCTime)
-> IO (Watchdog UTCTime)
forall label a.
Label label =>
Vector label Counter
-> Tracer IO (Track a)
-> (WatchdogResult a -> label)
-> Int
-> IO (WatchdogResult a)
-> IO (Watchdog a)
watchdog Vector Label2 Counter
fileTouchWatchdogCounter ((Track UTCTime -> FileTouchTrack UTCTime)
-> Tracer IO (FileTouchTrack UTCTime) -> Tracer IO (Track UTCTime)
forall a' a. (a' -> a) -> Tracer IO a -> Tracer IO a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (String -> Track UTCTime -> FileTouchTrack UTCTime
forall r. String -> Track r -> FileTouchTrack r
FileTouchTrack String
path) Tracer IO (FileTouchTrack UTCTime)
tracer) WatchdogResult UTCTime -> Label2
forall {a}. WatchdogResult a -> Label2
mkLabel Int
delay IO (WatchdogResult UTCTime)
io
  where
    handleIOException :: IOException -> IO (WatchdogResult UTCTime)
    handleIOException :: IOException -> IO (WatchdogResult UTCTime)
handleIOException IOException
_ = WatchdogResult UTCTime -> IO (WatchdogResult UTCTime)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WatchdogResult UTCTime -> IO (WatchdogResult UTCTime))
-> WatchdogResult UTCTime -> IO (WatchdogResult UTCTime)
forall a b. (a -> b) -> a -> b
$ WatchdogResult UTCTime
forall a. WatchdogResult a
Failed
    io :: IO (WatchdogResult UTCTime)
io = do
        UTCTime
now <- IO UTCTime
getCurrentTime
        let touchFile :: IO (WatchdogResult UTCTime)
touchFile = String -> UTCTime -> IO ()
setModificationTime String
path UTCTime
now IO () -> IO (WatchdogResult UTCTime) -> IO (WatchdogResult UTCTime)
forall a b. IO a -> IO b -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> WatchdogResult UTCTime -> IO (WatchdogResult UTCTime)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTCTime -> WatchdogResult UTCTime
forall a. a -> WatchdogResult a
Success UTCTime
now)
        IO (WatchdogResult UTCTime)
touchFile IO (WatchdogResult UTCTime)
-> (IOException -> IO (WatchdogResult UTCTime))
-> IO (WatchdogResult UTCTime)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` IOException -> IO (WatchdogResult UTCTime)
handleIOException

{-# NOINLINE fileTouchWatchdogCounter #-}
fileTouchWatchdogCounter :: Vector Label2 Counter
fileTouchWatchdogCounter :: Vector Label2 Counter
fileTouchWatchdogCounter =
    Metric (Vector Label2 Counter) -> Vector Label2 Counter
forall s. Metric s -> s
Prometheus.unsafeRegister (Metric (Vector Label2 Counter) -> Vector Label2 Counter)
-> Metric (Vector Label2 Counter) -> Vector Label2 Counter
forall a b. (a -> b) -> a -> b
$
        Label2 -> Metric Counter -> Metric (Vector Label2 Counter)
forall l m. Label l => l -> Metric m -> Metric (Vector l m)
Prometheus.vector (Text
"status", Text
"path") (Metric Counter -> Metric (Vector Label2 Counter))
-> Metric Counter -> Metric (Vector Label2 Counter)
forall a b. (a -> b) -> a -> b
$
            Info -> Metric Counter
Prometheus.counter (Text -> Text -> Info
Prometheus.Info Text
"prodapi_watchdog_filetouch" Text
"")