{-# LANGUAGE RecordWildCards #-}

module Language.Docker.Parser.Healthcheck
  ( parseHealthcheck,
  )
where

import Data.Maybe (listToMaybe)
import qualified Data.Text as T
import Data.Time.Clock (secondsToDiffTime)
import Language.Docker.Parser.Cmd (parseCmd)
import Language.Docker.Parser.Prelude
import Language.Docker.Syntax

data CheckFlag
  = FlagInterval Duration
  | FlagTimeout Duration
  | FlagStartPeriod Duration
  | FlagRetries Retries
  | CFlagInvalid (Text, Text)

parseHealthcheck :: (?esc :: Char) => Parser (Instruction Text)
parseHealthcheck :: (?esc::Char) => Parser (Instruction Text)
parseHealthcheck = do
  (?esc::Char) => Text -> Parser ()
reserved Text
"HEALTHCHECK"
  forall args. Check args -> Instruction args
Healthcheck forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT DockerfileError Text Identity (Check Text)
fullCheck forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {args}. ParsecT DockerfileError Text Identity (Check args)
noCheck)
  where
    noCheck :: ParsecT DockerfileError Text Identity (Check args)
noCheck = forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"NONE" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall args. Check args
NoCheck
    allFlags :: ParsecT DockerfileError Text Identity [CheckFlag]
allFlags = do
      [CheckFlag]
flags <- ParsecT DockerfileError Text Identity [CheckFlag]
someFlags
      (?esc::Char) => Parser ()
requiredWhitespace forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"another flag"
      forall (m :: * -> *) a. Monad m => a -> m a
return [CheckFlag]
flags
    someFlags :: ParsecT DockerfileError Text Identity [CheckFlag]
someFlags = do
      CheckFlag
x <- (?esc::Char) => Parser CheckFlag
checkFlag
      Bool
cont <- forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ((?esc::Char) => Parser ()
requiredWhitespace forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead (forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"--") forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      if Bool
cont
        then do
          [CheckFlag]
xs <- ParsecT DockerfileError Text Identity [CheckFlag]
someFlags
          forall (m :: * -> *) a. Monad m => a -> m a
return (CheckFlag
x forall a. a -> [a] -> [a]
: [CheckFlag]
xs)
        else forall (m :: * -> *) a. Monad m => a -> m a
return [CheckFlag
x]
    fullCheck :: ParsecT DockerfileError Text Identity (Check Text)
fullCheck = do
      [CheckFlag]
flags <- ParsecT DockerfileError Text Identity [CheckFlag]
allFlags forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return []
      let intervals :: [Duration]
intervals = [Duration
x | FlagInterval Duration
x <- [CheckFlag]
flags]
      let timeouts :: [Duration]
timeouts = [Duration
x | FlagTimeout Duration
x <- [CheckFlag]
flags]
      let startPeriods :: [Duration]
startPeriods = [Duration
x | FlagStartPeriod Duration
x <- [CheckFlag]
flags]
      let retriesD :: [Retries]
retriesD = [Retries
x | FlagRetries Retries
x <- [CheckFlag]
flags]
      let invalid :: [(Text, Text)]
invalid = [(Text, Text)
x | CFlagInvalid (Text, Text)
x <- [CheckFlag]
flags]
      -- Let's do some validation on the flags
      case ([(Text, Text)]
invalid, [Duration]
intervals, [Duration]
timeouts, [Duration]
startPeriods, [Retries]
retriesD) of
        ((Text
k, Text
v) : [(Text, Text)]
_, [Duration]
_, [Duration]
_, [Duration]
_, [Retries]
_) -> forall a. Text -> Text -> Parser a
unexpectedFlag Text
k Text
v
        ([(Text, Text)]
_, Duration
_ : Duration
_ : [Duration]
_, [Duration]
_, [Duration]
_, [Retries]
_) -> forall a. DockerfileError -> Parser a
customError forall a b. (a -> b) -> a -> b
$ String -> DockerfileError
DuplicateFlagError String
"--interval"
        ([(Text, Text)]
_, [Duration]
_, Duration
_ : Duration
_ : [Duration]
_, [Duration]
_, [Retries]
_) -> forall a. DockerfileError -> Parser a
customError forall a b. (a -> b) -> a -> b
$ String -> DockerfileError
DuplicateFlagError String
"--timeout"
        ([(Text, Text)]
_, [Duration]
_, [Duration]
_, Duration
_ : Duration
_ : [Duration]
_, [Retries]
_) -> forall a. DockerfileError -> Parser a
customError forall a b. (a -> b) -> a -> b
$ String -> DockerfileError
DuplicateFlagError String
"--start-period"
        ([(Text, Text)]
_, [Duration]
_, [Duration]
_, [Duration]
_, Retries
_ : Retries
_ : [Retries]
_) -> forall a. DockerfileError -> Parser a
customError forall a b. (a -> b) -> a -> b
$ String -> DockerfileError
DuplicateFlagError String
"--retries"
        ([(Text, Text)], [Duration], [Duration], [Duration], [Retries])
_ -> do
          Cmd Arguments Text
checkCommand <- (?esc::Char) => Parser (Instruction Text)
parseCmd
          let interval :: Maybe Duration
interval = forall a. [a] -> Maybe a
listToMaybe [Duration]
intervals
          let timeout :: Maybe Duration
timeout = forall a. [a] -> Maybe a
listToMaybe [Duration]
timeouts
          let startPeriod :: Maybe Duration
startPeriod = forall a. [a] -> Maybe a
listToMaybe [Duration]
startPeriods
          let retries :: Maybe Retries
retries = forall a. [a] -> Maybe a
listToMaybe [Retries]
retriesD
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall args. CheckArgs args -> Check args
Check CheckArgs {Maybe Retries
Maybe Duration
Arguments Text
$sel:retries:CheckArgs :: Maybe Retries
$sel:startPeriod:CheckArgs :: Maybe Duration
$sel:timeout:CheckArgs :: Maybe Duration
$sel:interval:CheckArgs :: Maybe Duration
$sel:checkCommand:CheckArgs :: Arguments Text
retries :: Maybe Retries
startPeriod :: Maybe Duration
timeout :: Maybe Duration
interval :: Maybe Duration
checkCommand :: Arguments Text
..}

checkFlag :: (?esc :: Char) => Parser CheckFlag
checkFlag :: (?esc::Char) => Parser CheckFlag
checkFlag =
  (Duration -> CheckFlag
FlagInterval forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Parser Duration
durationFlag Text
"--interval=" forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"--interval")
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Duration -> CheckFlag
FlagTimeout forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Parser Duration
durationFlag Text
"--timeout=" forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"--timeout")
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Duration -> CheckFlag
FlagStartPeriod forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Parser Duration
durationFlag Text
"--start-period=" forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"--start-period")
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Retries -> CheckFlag
FlagRetries forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Retries
retriesFlag forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"--retries")
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((Text, Text) -> CheckFlag
CFlagInvalid forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (?esc::Char) => Parser (Text, Text)
anyFlag forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"no flags")

durationFlag :: Text -> Parser Duration
durationFlag :: Text -> Parser Duration
durationFlag Text
flagName = do
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Text
flagName)
  DiffTime
value <- forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ( forall a. Fractional a => Rational -> a
fromRational forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Real a, Fractional b) => a -> b
realToFrac forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Float
fractional )
              forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ( Integer -> DiffTime
secondsToDiffTime forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => Integer -> a
fromInteger forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Integer
natural )
              forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"a natural or fractional number"
  Char
unit <- forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
's' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'm' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'h' forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"either 's', 'm' or 'h' as the unit"
  case Char
unit of
    Char
's' -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DiffTime -> Duration
Duration DiffTime
value
    Char
'm' -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DiffTime -> Duration
Duration (DiffTime
value forall a. Num a => a -> a -> a
* DiffTime
60)
    Char
'h' -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DiffTime -> Duration
Duration (DiffTime
value forall a. Num a => a -> a -> a
* DiffTime
60 forall a. Num a => a -> a -> a
* DiffTime
60)
    Char
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"only 's', 'm' or 'h' are allowed as the duration"

retriesFlag :: Parser Retries
retriesFlag :: Parser Retries
retriesFlag = do
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"--retries=")
  Integer
n <- forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parser Integer
natural forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"the number of retries"
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int -> Retries
Retries (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n)

anyFlag :: (?esc :: Char) => Parser (Text, Text)
anyFlag :: (?esc::Char) => Parser (Text, Text)
anyFlag = do
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"--"
  Text
name <- (?esc::Char) => String -> (Char -> Bool) -> Parser Text
someUnless String
"the flag value" (forall a. Eq a => a -> a -> Bool
== Char
'=')
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'='
  Text
val <- (?esc::Char) => (Char -> Bool) -> Parser Text
anyUnless (forall a. Eq a => a -> a -> Bool
== Char
' ')
  forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Text -> Text
T.append Text
"--" Text
name, Text
val)

unexpectedFlag :: Text -> Text -> Parser a
unexpectedFlag :: forall a. Text -> Text -> Parser a
unexpectedFlag Text
name Text
"" = forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
customFailure forall a b. (a -> b) -> a -> b
$ String -> DockerfileError
NoValueFlagError (Text -> String
T.unpack Text
name)
unexpectedFlag Text
name Text
_ = forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
customFailure forall a b. (a -> b) -> a -> b
$ String -> DockerfileError
InvalidFlagError (Text -> String
T.unpack Text
name)