{-# 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 (MicroSeconds Int -> Track a -> ShowS
[Track a] -> ShowS
Track a -> String
(MicroSeconds Int -> Track a -> ShowS)
-> (Track a -> String) -> ([Track a] -> ShowS) -> Show (Track a)
forall a. Show a => MicroSeconds Int -> Track a -> ShowS
forall a. Show a => [Track a] -> ShowS
forall a. Show a => Track a -> String
forall a.
(MicroSeconds Int -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => MicroSeconds Int -> Track a -> ShowS
showsPrec :: MicroSeconds Int -> Track a -> ShowS
$cshow :: forall a. Show a => Track a -> String
show :: Track a -> String
$cshowList :: forall a. Show a => [Track a] -> ShowS
showList :: [Track a] -> ShowS
Show, (forall a b. (a -> b) -> Track a -> Track b)
-> (forall a b. a -> Track b -> Track a) -> Functor Track
forall a b. a -> Track b -> Track a
forall a b. (a -> b) -> Track a -> Track b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Track a -> Track b
fmap :: forall a b. (a -> b) -> Track a -> Track b
$c<$ :: forall a b. a -> Track b -> Track a
<$ :: forall a b. a -> Track b -> Track a
Functor)

data Result a
    = NotAsked
    | Asked UTCTime
    | Found UTCTime a
    deriving (MicroSeconds Int -> Result a -> ShowS
[Result a] -> ShowS
Result a -> String
(MicroSeconds Int -> Result a -> ShowS)
-> (Result a -> String) -> ([Result a] -> ShowS) -> Show (Result a)
forall a. Show a => MicroSeconds Int -> Result a -> ShowS
forall a. Show a => [Result a] -> ShowS
forall a. Show a => Result a -> String
forall a.
(MicroSeconds Int -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => MicroSeconds Int -> Result a -> ShowS
showsPrec :: MicroSeconds Int -> Result a -> ShowS
$cshow :: forall a. Show a => Result a -> String
show :: Result a -> String
$cshowList :: forall a. Show a => [Result a] -> ShowS
showList :: [Result a] -> ShowS
Show, (forall a b. (a -> b) -> Result a -> Result b)
-> (forall a b. a -> Result b -> Result a) -> Functor Result
forall a b. a -> Result b -> Result a
forall a b. (a -> b) -> Result a -> Result b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Result a -> Result b
fmap :: forall a b. (a -> b) -> Result a -> Result b
$c<$ :: forall a b. a -> Result b -> Result a
<$ :: forall a b. a -> Result b -> Result a
Functor)

toMaybe :: Result a -> Maybe a
toMaybe :: forall a. Result a -> Maybe a
toMaybe (Found UTCTime
_ a
a) = a -> Maybe a
forall a. a -> Maybe a
Just a
a
toMaybe Result a
_ = Maybe a
forall a. Maybe a
Nothing

data Discovery a = Discovery (BackgroundVal (Result a))
    deriving ((forall a b. (a -> b) -> Discovery a -> Discovery b)
-> (forall a b. a -> Discovery b -> Discovery a)
-> Functor Discovery
forall a b. a -> Discovery b -> Discovery a
forall a b. (a -> b) -> Discovery a -> Discovery b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Discovery a -> Discovery b
fmap :: forall a b. (a -> b) -> Discovery a -> Discovery b
$c<$ :: forall a b. a -> Discovery b -> Discovery a
<$ :: forall a b. a -> Discovery b -> Discovery a
Functor)

readCurrent :: Discovery a -> IO (Result a)
readCurrent :: forall a. Discovery a -> IO (Result a)
readCurrent (Discovery BackgroundVal (Result a)
b) = BackgroundVal (Result a) -> IO (Result a)
forall (m :: * -> *) a. MonadIO m => BackgroundVal a -> m a
readBackgroundVal BackgroundVal (Result a)
b

type Host = Text

data DNSTrack a = DNSTrack Text Host (Track a)
    deriving (MicroSeconds Int -> DNSTrack a -> ShowS
[DNSTrack a] -> ShowS
DNSTrack a -> String
(MicroSeconds Int -> DNSTrack a -> ShowS)
-> (DNSTrack a -> String)
-> ([DNSTrack a] -> ShowS)
-> Show (DNSTrack a)
forall a. Show a => MicroSeconds Int -> DNSTrack a -> ShowS
forall a. Show a => [DNSTrack a] -> ShowS
forall a. Show a => DNSTrack a -> String
forall a.
(MicroSeconds Int -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => MicroSeconds Int -> DNSTrack a -> ShowS
showsPrec :: MicroSeconds Int -> DNSTrack a -> ShowS
$cshow :: forall a. Show a => DNSTrack a -> String
show :: DNSTrack a -> String
$cshowList :: forall a. Show a => [DNSTrack a] -> ShowS
showList :: [DNSTrack a] -> ShowS
Show, (forall a b. (a -> b) -> DNSTrack a -> DNSTrack b)
-> (forall a b. a -> DNSTrack b -> DNSTrack a) -> Functor DNSTrack
forall a b. a -> DNSTrack b -> DNSTrack a
forall a b. (a -> b) -> DNSTrack a -> DNSTrack b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> DNSTrack a -> DNSTrack b
fmap :: forall a b. (a -> b) -> DNSTrack a -> DNSTrack b
$c<$ :: forall a b. a -> DNSTrack b -> DNSTrack a
<$ :: forall a b. a -> DNSTrack b -> DNSTrack a
Functor)

dnsA :: Tracer IO (DNSTrack [Host]) -> Host -> IO (Discovery [Host])
dnsA :: Tracer IO (DNSTrack [Text]) -> Text -> IO (Discovery [Text])
dnsA Tracer IO (DNSTrack [Text])
tracer Text
hostname = Tracer IO (Track [Text])
-> String -> String -> IO (Discovery [Text])
dig ((Track [Text] -> DNSTrack [Text])
-> Tracer IO (DNSTrack [Text]) -> Tracer IO (Track [Text])
forall a' a. (a' -> a) -> Tracer IO a -> Tracer IO a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (Text -> Text -> Track [Text] -> DNSTrack [Text]
forall a. Text -> Text -> Track a -> DNSTrack a
DNSTrack Text
hostname Text
"A") Tracer IO (DNSTrack [Text])
tracer) String
"A" (String -> IO (Discovery [Text]))
-> String -> IO (Discovery [Text])
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack Text
hostname

dnsAAAA :: Tracer IO (DNSTrack [Host]) -> Host -> IO (Discovery [Host])
dnsAAAA :: Tracer IO (DNSTrack [Text]) -> Text -> IO (Discovery [Text])
dnsAAAA Tracer IO (DNSTrack [Text])
tracer Text
hostname = Tracer IO (Track [Text])
-> String -> String -> IO (Discovery [Text])
dig ((Track [Text] -> DNSTrack [Text])
-> Tracer IO (DNSTrack [Text]) -> Tracer IO (Track [Text])
forall a' a. (a' -> a) -> Tracer IO a -> Tracer IO a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (Text -> Text -> Track [Text] -> DNSTrack [Text]
forall a. Text -> Text -> Track a -> DNSTrack a
DNSTrack Text
hostname Text
"AAAA") Tracer IO (DNSTrack [Text])
tracer) String
"AAAA" (String -> IO (Discovery [Text]))
-> String -> IO (Discovery [Text])
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack Text
hostname

dig :: Tracer IO (Track [Host]) -> String -> String -> IO (Discovery [Host])
dig :: Tracer IO (Track [Text])
-> String -> String -> IO (Discovery [Text])
dig Tracer IO (Track [Text])
tracer String
typ String
target = Tracer IO (Track [Text])
-> String
-> [String]
-> ByteString
-> Maybe (MicroSeconds Int)
-> [Text]
-> ([Text] -> ByteString -> [Text])
-> ([Text] -> [Text] -> IO ())
-> IO (Discovery [Text])
forall a.
Tracer IO (Track a)
-> String
-> [String]
-> ByteString
-> Maybe (MicroSeconds Int)
-> a
-> (a -> ByteString -> a)
-> (a -> a -> IO ())
-> IO (Discovery a)
cmdOut Tracer IO (Track [Text])
tracer String
"dig" [String
"+short", String
typ, String
target] ByteString
"" Maybe (MicroSeconds Int)
tenSecs [] [Text] -> ByteString -> [Text]
replaceHosts [Text] -> [Text] -> IO ()
trigger
  where
    replaceHosts :: [Host] -> ByteString -> [Host]
    replaceHosts :: [Text] -> ByteString -> [Text]
replaceHosts [Text]
_ = ByteString -> [Text]
parseHosts

    trigger :: [Host] -> [Host] -> IO ()
    trigger :: [Text] -> [Text] -> IO ()
trigger [Text]
_ [Text]
xs = do
        Vector Label3 Counter -> Label3 -> (Counter -> IO ()) -> IO ()
forall label (m :: * -> *) metric.
(Label label, MonadMonitor m) =>
Vector label metric -> label -> (metric -> IO ()) -> m ()
Prometheus.withLabel
            Vector Label3 Counter
dnsDiscoveryCounter
            Label3
promLabels
            Counter -> IO ()
forall (m :: * -> *). MonadMonitor m => Counter -> m ()
Prometheus.incCounter
        Vector Label3 Gauge -> Label3 -> (Gauge -> IO ()) -> IO ()
forall label (m :: * -> *) metric.
(Label label, MonadMonitor m) =>
Vector label metric -> label -> (metric -> IO ()) -> m ()
Prometheus.withLabel
            Vector Label3 Gauge
dnsDiscoveryGauge
            Label3
promLabels
            ((Gauge -> Double -> IO ()) -> Double -> Gauge -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Gauge -> Double -> IO ()
forall (m :: * -> *). MonadMonitor m => Gauge -> Double -> m ()
Prometheus.setGauge (MicroSeconds Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (MicroSeconds Int -> Double) -> MicroSeconds Int -> Double
forall a b. (a -> b) -> a -> b
$ [Text] -> MicroSeconds Int
forall a. [a] -> MicroSeconds Int
forall (t :: * -> *) a. Foldable t => t a -> MicroSeconds Int
length [Text]
xs))

    promLabels :: Label3
    promLabels :: Label3
promLabels = (Text
"dig", String -> Text
Text.pack String
typ, String -> Text
Text.pack String
target)

    parseHosts :: ByteString -> [Host]
    parseHosts :: ByteString -> [Text]
parseHosts = Text -> [Text]
Text.lines (Text -> [Text]) -> (ByteString -> Text) -> ByteString -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
Text.decodeUtf8

    tenSecs :: Maybe (MicroSeconds Int)
    tenSecs :: Maybe (MicroSeconds Int)
tenSecs = MicroSeconds Int -> Maybe (MicroSeconds Int)
forall a. a -> Maybe a
Just MicroSeconds Int
10_000_000

{-# NOINLINE dnsDiscoveryGauge #-}
dnsDiscoveryGauge :: Vector Label3 Gauge
dnsDiscoveryGauge :: Vector Label3 Gauge
dnsDiscoveryGauge =
    Metric (Vector Label3 Gauge) -> Vector Label3 Gauge
forall s. Metric s -> s
Prometheus.unsafeRegister (Metric (Vector Label3 Gauge) -> Vector Label3 Gauge)
-> Metric (Vector Label3 Gauge) -> Vector Label3 Gauge
forall a b. (a -> b) -> a -> b
$
        Label3 -> Metric Gauge -> Metric (Vector Label3 Gauge)
forall l m. Label l => l -> Metric m -> Metric (Vector l m)
Prometheus.vector (Text
"m", Text
"type", Text
"host") (Metric Gauge -> Metric (Vector Label3 Gauge))
-> Metric Gauge -> Metric (Vector Label3 Gauge)
forall a b. (a -> b) -> a -> b
$
            Info -> Metric Gauge
Prometheus.gauge (Text -> Text -> Info
Prometheus.Info Text
"prodapi_dns_discovery_results" Text
"")

{-# NOINLINE dnsDiscoveryCounter #-}
dnsDiscoveryCounter :: Vector Label3 Counter
dnsDiscoveryCounter :: Vector Label3 Counter
dnsDiscoveryCounter =
    Metric (Vector Label3 Counter) -> Vector Label3 Counter
forall s. Metric s -> s
Prometheus.unsafeRegister (Metric (Vector Label3 Counter) -> Vector Label3 Counter)
-> Metric (Vector Label3 Counter) -> Vector Label3 Counter
forall a b. (a -> b) -> a -> b
$
        Label3 -> Metric Counter -> Metric (Vector Label3 Counter)
forall l m. Label l => l -> Metric m -> Metric (Vector l m)
Prometheus.vector (Text
"m", Text
"type", Text
"host") (Metric Counter -> Metric (Vector Label3 Counter))
-> Metric Counter -> Metric (Vector Label3 Counter)
forall a b. (a -> b) -> a -> b
$
            Info -> Metric Counter
Prometheus.counter (Text -> Text -> Info
Prometheus.Info Text
"prodapi_dns_discoveries" Text
"")

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 :: forall a.
Tracer IO (Track a)
-> String
-> [String]
-> ByteString
-> Maybe (MicroSeconds Int)
-> a
-> (a -> ByteString -> a)
-> (a -> a -> IO ())
-> IO (Discovery a)
cmdOut Tracer IO (Track a)
tracer String
cmd [String]
args ByteString
input Maybe (MicroSeconds Int)
ms a
st0 a -> ByteString -> a
update a -> a -> IO ()
trigger =
    BackgroundVal (Result a) -> Discovery a
forall a. BackgroundVal (Result a) -> Discovery a
Discovery (BackgroundVal (Result a) -> Discovery a)
-> IO (BackgroundVal (Result a)) -> IO (Discovery a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tracer IO (Track (Result a))
-> a
-> Result a
-> (a -> IO (Result a, a))
-> IO (BackgroundVal (Result a))
forall a b.
Tracer IO (Track a)
-> b -> a -> (b -> IO (a, b)) -> IO (BackgroundVal a)
background ((Track (Result a) -> Track a)
-> Tracer IO (Track a) -> Tracer IO (Track (Result 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 (Result a) -> Track a
forall a. Track (Result a) -> Track a
BackgroundTrack Tracer IO (Track a)
tracer) a
st0 Result a
forall a. Result a
NotAsked a -> IO (Result a, a)
run
  where
    run :: a -> IO (Result a, a)
    run :: a -> IO (Result a, a)
run a
st0 = do
        IO ()
-> (MicroSeconds Int -> IO ()) -> Maybe (MicroSeconds Int) -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) MicroSeconds Int -> IO ()
threadDelay Maybe (MicroSeconds Int)
ms
        ByteString
out <- IO ByteString
runCmd
        let st1 :: a
st1 = a -> ByteString -> a
update a
st0 ByteString
out
        UTCTime
now <- IO UTCTime
getCurrentTime
        a -> IO () -> IO ()
forall a b. a -> b -> b
seq a
st1 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> a -> IO ()
trigger a
st0 a
st1
        (Result a, a) -> IO (Result a, a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Result a, a) -> IO (Result a, a))
-> (Result a, a) -> IO (Result a, a)
forall a b. (a -> b) -> a -> b
$ (UTCTime -> a -> Result a
forall a. UTCTime -> a -> Result a
Found UTCTime
now a
st1, a
st1)

    runCmd :: IO ByteString
    runCmd :: IO ByteString
runCmd = (\(ExitCode
_, ByteString
x, ByteString
_) -> ByteString
x) ((ExitCode, ByteString, ByteString) -> ByteString)
-> IO (ExitCode, ByteString, ByteString) -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> [String] -> ByteString -> IO (ExitCode, ByteString, ByteString)
readProcessWithExitCode String
cmd [String]
args ByteString
input