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

durationFlag :: Text -> Parser Duration
durationFlag :: Text -> ParsecT DockerfileError Text Identity Duration
durationFlag Text
flagName = do
  ParsecT DockerfileError Text Identity Text -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT DockerfileError Text Identity Text -> Parser ())
-> ParsecT DockerfileError Text Identity Text -> Parser ()
forall a b. (a -> b) -> a -> b
$ ParsecT DockerfileError Text Identity Text
-> ParsecT DockerfileError Text Identity Text
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Tokens Text -> ParsecT DockerfileError Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Text
Tokens Text
flagName)
  Integer
scale <- Parser Integer
natural
  Char
unit <- Token Text -> ParsecT DockerfileError Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
's' ParsecT DockerfileError Text Identity Char
-> ParsecT DockerfileError Text Identity Char
-> ParsecT DockerfileError Text Identity Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token Text -> ParsecT DockerfileError Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'm' ParsecT DockerfileError Text Identity Char
-> ParsecT DockerfileError Text Identity Char
-> ParsecT DockerfileError Text Identity Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token Text -> ParsecT DockerfileError Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'h' ParsecT DockerfileError Text Identity Char
-> String -> ParsecT DockerfileError Text Identity Char
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' -> Duration -> ParsecT DockerfileError Text Identity Duration
forall (m :: * -> *) a. Monad m => a -> m a
return (Duration -> ParsecT DockerfileError Text Identity Duration)
-> Duration -> ParsecT DockerfileError Text Identity Duration
forall a b. (a -> b) -> a -> b
$ DiffTime -> Duration
Duration (Integer -> DiffTime
secondsToDiffTime Integer
scale)
    Char
'm' -> Duration -> ParsecT DockerfileError Text Identity Duration
forall (m :: * -> *) a. Monad m => a -> m a
return (Duration -> ParsecT DockerfileError Text Identity Duration)
-> Duration -> ParsecT DockerfileError Text Identity Duration
forall a b. (a -> b) -> a -> b
$ DiffTime -> Duration
Duration (Integer -> DiffTime
secondsToDiffTime (Integer
scale Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
60))
    Char
'h' -> Duration -> ParsecT DockerfileError Text Identity Duration
forall (m :: * -> *) a. Monad m => a -> m a
return (Duration -> ParsecT DockerfileError Text Identity Duration)
-> Duration -> ParsecT DockerfileError Text Identity Duration
forall a b. (a -> b) -> a -> b
$ DiffTime -> Duration
Duration (Integer -> DiffTime
secondsToDiffTime (Integer
scale Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
60 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
60))
    Char
_ -> String -> ParsecT DockerfileError Text Identity Duration
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"only 's', 'm' or 'h' are allowed as the duration"

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

anyFlag :: Parser (Text, Text)
anyFlag :: ParsecT DockerfileError Text Identity (Text, Text)
anyFlag = do
  ParsecT DockerfileError Text Identity Text -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT DockerfileError Text Identity Text -> Parser ())
-> ParsecT DockerfileError Text Identity Text -> Parser ()
forall a b. (a -> b) -> a -> b
$ Tokens Text -> ParsecT DockerfileError Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"--"
  Text
name <- String
-> (Char -> Bool) -> ParsecT DockerfileError Text Identity Text
someUnless String
"the flag value" (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'=')
  ParsecT DockerfileError Text Identity Char -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT DockerfileError Text Identity Char -> Parser ())
-> ParsecT DockerfileError Text Identity Char -> Parser ()
forall a b. (a -> b) -> a -> b
$ Token Text -> ParsecT DockerfileError Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'='
  Text
val <- (Char -> Bool) -> ParsecT DockerfileError Text Identity Text
anyUnless (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ')
  (Text, Text) -> ParsecT DockerfileError Text Identity (Text, Text)
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 :: Text -> Text -> Parser a
unexpectedFlag Text
name Text
"" = DockerfileError -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
customFailure (DockerfileError -> Parser a) -> DockerfileError -> Parser a
forall a b. (a -> b) -> a -> b
$ String -> DockerfileError
NoValueFlagError (Text -> String
T.unpack Text
name)
unexpectedFlag Text
name Text
_ = DockerfileError -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
customFailure (DockerfileError -> Parser a) -> DockerfileError -> Parser a
forall a b. (a -> b) -> a -> b
$ String -> DockerfileError
InvalidFlagError (Text -> String
T.unpack Text
name)