{-# LANGUAGE OverloadedStrings #-}

module Language.Docker.Parser.Pairs
  ( parseEnv,
    parseLabel,
  )
where

import qualified Data.Text as T
import Language.Docker.Parser.Prelude
import Language.Docker.Syntax

-- We cannot use string literal because it swallows space
-- and therefore have to implement quoted values by ourselves
doubleQuotedValue :: Parser Text
doubleQuotedValue :: Parser Text
doubleQuotedValue = Parser Text -> Parser Text -> Parser Text -> Parser Text
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (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 (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string "\"") ([Char] -> Maybe (Char -> Bool) -> Parser Text
stringWithEscaped ['"'] Maybe (Char -> Bool)
forall a. Maybe a
Nothing)

singleQuotedValue :: Parser Text
singleQuotedValue :: Parser Text
singleQuotedValue = Parser Text -> Parser Text -> Parser Text -> Parser Text
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (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 (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string "'") ([Char] -> Maybe (Char -> Bool) -> Parser Text
stringWithEscaped ['\''] Maybe (Char -> Bool)
forall a. Maybe a
Nothing)

unquotedString :: (Char -> Bool) -> Parser Text
unquotedString :: (Char -> Bool) -> Parser Text
unquotedString acceptCondition :: Char -> Bool
acceptCondition = do
  Text
str <- [Char] -> Maybe (Char -> Bool) -> Parser Text
stringWithEscaped [' ', '\t'] ((Char -> Bool) -> Maybe (Char -> Bool)
forall a. a -> Maybe a
Just (\c :: Char
c -> Char -> Bool
acceptCondition Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '"' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '\''))
  Text -> Parser Text
checkFaults Text
str
  where
    checkFaults :: Text -> Parser Text
checkFaults str :: Text
str
      | Text -> Bool
T.null Text
str = [Char] -> Parser Text
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail "a non empty string"
      | Text -> Char
T.head Text
str Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\'' = DockerfileError -> Parser Text
forall a. DockerfileError -> Parser a
customError (DockerfileError -> Parser Text) -> DockerfileError -> Parser Text
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> DockerfileError
QuoteError "single" (Text -> [Char]
T.unpack Text
str)
      | Text -> Char
T.head Text
str Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\"' = DockerfileError -> Parser Text
forall a. DockerfileError -> Parser a
customError (DockerfileError -> Parser Text) -> DockerfileError -> Parser Text
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> DockerfileError
QuoteError "double" (Text -> [Char]
T.unpack Text
str)
      | Bool
otherwise = Text -> Parser Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
str

singleValue :: (Char -> Bool) -> Parser Text
singleValue :: (Char -> Bool) -> Parser Text
singleValue acceptCondition :: Char -> Bool
acceptCondition = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text)
-> ParsecT DockerfileError Text Identity [Text] -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT DockerfileError Text Identity [Text]
variants
  where
    variants :: ParsecT DockerfileError Text Identity [Text]
variants =
      Parser Text -> ParsecT DockerfileError Text Identity [Text]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (Parser Text -> ParsecT DockerfileError Text Identity [Text])
-> Parser Text -> ParsecT DockerfileError Text Identity [Text]
forall a b. (a -> b) -> a -> b
$
        [Parser Text] -> Parser Text
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
          [ Parser Text
doubleQuotedValue Parser Text -> [Char] -> Parser Text
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> "a string inside double quotes",
            Parser Text
singleQuotedValue Parser Text -> [Char] -> Parser Text
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> "a string inside single quotes",
            (Char -> Bool) -> Parser Text
unquotedString Char -> Bool
acceptCondition Parser Text -> [Char] -> Parser Text
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> "a string with no quotes"
          ]

pair :: Parser (Text, Text)
pair :: Parser (Text, Text)
pair = do
  Text
key <- (Char -> Bool) -> Parser Text
singleValue (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '=')
  Text
value <- Parser Text
withEqualSign Parser Text -> Parser Text -> Parser Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
withoutEqualSign
  (Text, Text) -> Parser (Text, Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
key, Text
value)
  where
    withEqualSign :: Parser Text
withEqualSign = do
      ParsecT DockerfileError Text Identity Char
-> ParsecT DockerfileError Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT DockerfileError Text Identity Char
 -> ParsecT DockerfileError Text Identity ())
-> ParsecT DockerfileError Text Identity Char
-> ParsecT DockerfileError Text Identity ()
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
'='
      (Char -> Bool) -> Parser Text
singleValue (\c :: Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= ' ' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '\t')
    withoutEqualSign :: Parser Text
withoutEqualSign = do
      ParsecT DockerfileError Text Identity ()
requiredWhitespace
      [Char] -> Parser Text
untilEol "value"

pairs :: Parser Pairs
pairs :: Parser Pairs
pairs = (Parser (Text, Text)
pair Parser (Text, Text) -> [Char] -> Parser (Text, Text)
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> "a key value pair (key=value)") Parser (Text, Text)
-> ParsecT DockerfileError Text Identity () -> Parser Pairs
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepEndBy1` ParsecT DockerfileError Text Identity ()
requiredWhitespace

parseLabel :: Parser (Instruction Text)
parseLabel :: Parser (Instruction Text)
parseLabel = do
  Text -> ParsecT DockerfileError Text Identity ()
reserved "LABEL"
  Pairs -> Instruction Text
forall args. Pairs -> Instruction args
Label (Pairs -> Instruction Text)
-> Parser Pairs -> Parser (Instruction Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Pairs
pairs

parseEnv :: Parser (Instruction Text)
parseEnv :: Parser (Instruction Text)
parseEnv = do
  Text -> ParsecT DockerfileError Text Identity ()
reserved "ENV"
  Pairs -> Instruction Text
forall args. Pairs -> Instruction args
Env (Pairs -> Instruction Text)
-> Parser Pairs -> Parser (Instruction Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Pairs
pairs