{-# 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 "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 "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
<?> "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 "--") 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 x :: Duration
x <- [CheckFlag]
flags]
let timeouts :: [Duration]
timeouts = [Duration
x | FlagTimeout x :: Duration
x <- [CheckFlag]
flags]
let startPeriods :: [Duration]
startPeriods = [Duration
x | FlagStartPeriod x :: Duration
x <- [CheckFlag]
flags]
let retriesD :: [Retries]
retriesD = [Retries
x | FlagRetries x :: Retries
x <- [CheckFlag]
flags]
let invalid :: [(Text, Text)]
invalid = [(Text, Text)
x | CFlagInvalid x :: (Text, Text)
x <- [CheckFlag]
flags]
case ([(Text, Text)]
invalid, [Duration]
intervals, [Duration]
timeouts, [Duration]
startPeriods, [Retries]
retriesD) of
((k :: Text
k, v :: Text
v) : _, _, _, _, _) -> Text -> Text -> ParsecT DockerfileError Text Identity (Check Text)
forall a. Text -> Text -> Parser a
unexpectedFlag Text
k Text
v
(_, _ : _ : _, _, _, _) -> 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 "--interval"
(_, _, _ : _ : _, _, _) -> 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 "--timeout"
(_, _, _, _ : _ : _, _) -> 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 "--start-period"
(_, _, _, _, _ : _ : _) -> 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 "--retries"
_ -> do
Cmd checkCommand :: 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 $WCheckArgs :: forall args.
Arguments args
-> Maybe Duration
-> Maybe Duration
-> Maybe Duration
-> Maybe Retries
-> CheckArgs args
CheckArgs {..}
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 "--interval=" Parser CheckFlag -> String -> Parser CheckFlag
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> "--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 "--timeout=" Parser CheckFlag -> String -> Parser CheckFlag
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> "--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 "--start-period=" Parser CheckFlag -> String -> Parser CheckFlag
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> "--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
<?> "--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
<?> "no flags")
durationFlag :: Text -> Parser Duration
durationFlag :: Text -> ParsecT DockerfileError Text Identity Duration
durationFlag flagName :: 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 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 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 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
<?> "either 's', 'm' or 'h' as the unit"
case Char
unit of
'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)
'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
* 60))
'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
* 60 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* 60))
_ -> String -> ParsecT DockerfileError Text Identity Duration
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "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 "--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
<?> "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 "--"
Text
name <- String
-> (Char -> Bool) -> ParsecT DockerfileError Text Identity Text
someUnless "the flag value" (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '=')
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 Token Text
'='
Text
val <- (Char -> Bool) -> ParsecT DockerfileError Text Identity Text
anyUnless (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ' ')
(Text, Text) -> ParsecT DockerfileError Text Identity (Text, Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Text -> Text
T.append "--" Text
name, Text
val)
unexpectedFlag :: Text -> Text -> Parser a
unexpectedFlag :: Text -> Text -> Parser a
unexpectedFlag name :: Text
name "" = 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 name :: Text
name _ = 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)