{-# LANGUAGE OverloadedStrings #-}

module Language.Docker.Parser.Copy
  ( parseCopy,
    parseAdd,
  )
where

import Data.List.NonEmpty (NonEmpty, fromList)
import qualified Data.Text as T
import Language.Docker.Parser.Prelude
import Language.Docker.Syntax

data CopyFlag
  = FlagChown Chown
  | FlagSource CopySource
  | FlagInvalid (Text, Text)

parseCopy :: Parser (Instruction Text)
parseCopy :: Parser (Instruction Text)
parseCopy = do
  Text -> Parser ()
reserved "COPY"
  [CopyFlag]
flags <- Parser CopyFlag
copyFlag Parser CopyFlag
-> Parser () -> ParsecT DockerfileError Text Identity [CopyFlag]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepEndBy` Parser ()
requiredWhitespace
  let chownFlags :: [Chown]
chownFlags = [Chown
c | FlagChown c :: Chown
c <- [CopyFlag]
flags]
  let sourceFlags :: [CopySource]
sourceFlags = [CopySource
f | FlagSource f :: CopySource
f <- [CopyFlag]
flags]
  let invalid :: [(Text, Text)]
invalid = [(Text, Text)
i | FlagInvalid i :: (Text, Text)
i <- [CopyFlag]
flags]
  -- Let's do some validation on the flags
  case ([(Text, Text)]
invalid, [Chown]
chownFlags, [CopySource]
sourceFlags) of
    ((k :: Text
k, v :: Text
v) : _, _, _) -> Text -> Text -> Parser (Instruction Text)
forall a. Text -> Text -> Parser a
unexpectedFlag Text
k Text
v
    (_, _ : _ : _, _) -> DockerfileError -> Parser (Instruction Text)
forall a. DockerfileError -> Parser a
customError (DockerfileError -> Parser (Instruction Text))
-> DockerfileError -> Parser (Instruction Text)
forall a b. (a -> b) -> a -> b
$ String -> DockerfileError
DuplicateFlagError "--chown"
    (_, _, _ : _ : _) -> DockerfileError -> Parser (Instruction Text)
forall a. DockerfileError -> Parser a
customError (DockerfileError -> Parser (Instruction Text))
-> DockerfileError -> Parser (Instruction Text)
forall a b. (a -> b) -> a -> b
$ String -> DockerfileError
DuplicateFlagError "--from"
    _ -> do
      let ch :: Chown
ch =
            case [Chown]
chownFlags of
              [] -> Chown
NoChown
              c :: Chown
c : _ -> Chown
c
      let fr :: CopySource
fr =
            case [CopySource]
sourceFlags of
              [] -> CopySource
NoSource
              f :: CopySource
f : _ -> CopySource
f
      Text
-> (NonEmpty SourcePath -> TargetPath -> Instruction Text)
-> Parser (Instruction Text)
fileList "COPY" (\src :: NonEmpty SourcePath
src dest :: TargetPath
dest -> CopyArgs -> Instruction Text
forall args. CopyArgs -> Instruction args
Copy (NonEmpty SourcePath
-> TargetPath -> Chown -> CopySource -> CopyArgs
CopyArgs NonEmpty SourcePath
src TargetPath
dest Chown
ch CopySource
fr))

parseAdd :: Parser (Instruction Text)
parseAdd :: Parser (Instruction Text)
parseAdd = do
  Text -> Parser ()
reserved "ADD"
  CopyFlag
flag <- Parser CopyFlag -> Parser CopyFlag
forall a. Parser a -> Parser a
lexeme Parser CopyFlag
copyFlag Parser CopyFlag -> Parser CopyFlag -> Parser CopyFlag
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> CopyFlag -> Parser CopyFlag
forall (m :: * -> *) a. Monad m => a -> m a
return (Chown -> CopyFlag
FlagChown Chown
NoChown)
  ParsecT DockerfileError Text Identity Text -> Parser ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy (Tokens Text -> ParsecT DockerfileError Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string "--") Parser () -> String -> Parser ()
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> "only the --chown flag or the src and dest paths"
  case CopyFlag
flag of
    FlagChown ch :: Chown
ch -> Text
-> (NonEmpty SourcePath -> TargetPath -> Instruction Text)
-> Parser (Instruction Text)
fileList "ADD" (\src :: NonEmpty SourcePath
src dest :: TargetPath
dest -> AddArgs -> Instruction Text
forall args. AddArgs -> Instruction args
Add (NonEmpty SourcePath -> TargetPath -> Chown -> AddArgs
AddArgs NonEmpty SourcePath
src TargetPath
dest Chown
ch))
    FlagSource _ -> DockerfileError -> Parser (Instruction Text)
forall a. DockerfileError -> Parser a
customError (DockerfileError -> Parser (Instruction Text))
-> DockerfileError -> Parser (Instruction Text)
forall a b. (a -> b) -> a -> b
$ String -> DockerfileError
InvalidFlagError "--from"
    FlagInvalid (k :: Text
k, v :: Text
v) -> Text -> Text -> Parser (Instruction Text)
forall a. Text -> Text -> Parser a
unexpectedFlag Text
k Text
v

fileList :: Text -> (NonEmpty SourcePath -> TargetPath -> Instruction Text) -> Parser (Instruction Text)
fileList :: Text
-> (NonEmpty SourcePath -> TargetPath -> Instruction Text)
-> Parser (Instruction Text)
fileList name :: Text
name constr :: NonEmpty SourcePath -> TargetPath -> Instruction Text
constr = do
  [Text]
paths <-
    (ParsecT DockerfileError Text Identity [Text]
-> ParsecT DockerfileError Text Identity [Text]
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ParsecT DockerfileError Text Identity [Text]
stringList ParsecT DockerfileError Text Identity [Text]
-> String -> ParsecT DockerfileError Text Identity [Text]
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> "an array of strings [\"src_file\", \"dest_file\"]")
      ParsecT DockerfileError Text Identity [Text]
-> ParsecT DockerfileError Text Identity [Text]
-> ParsecT DockerfileError Text Identity [Text]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (ParsecT DockerfileError Text Identity [Text]
-> ParsecT DockerfileError Text Identity [Text]
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ParsecT DockerfileError Text Identity [Text]
spaceSeparated ParsecT DockerfileError Text Identity [Text]
-> String -> ParsecT DockerfileError Text Identity [Text]
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> "a space separated list of file paths")
  case [Text]
paths of
    [_] -> DockerfileError -> Parser (Instruction Text)
forall a. DockerfileError -> Parser a
customError (DockerfileError -> Parser (Instruction Text))
-> DockerfileError -> Parser (Instruction Text)
forall a b. (a -> b) -> a -> b
$ String -> DockerfileError
FileListError (Text -> String
T.unpack Text
name)
    _ -> Instruction Text -> Parser (Instruction Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Instruction Text -> Parser (Instruction Text))
-> Instruction Text -> Parser (Instruction Text)
forall a b. (a -> b) -> a -> b
$ NonEmpty SourcePath -> TargetPath -> Instruction Text
constr (Text -> SourcePath
SourcePath (Text -> SourcePath) -> NonEmpty Text -> NonEmpty SourcePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text] -> NonEmpty Text
forall a. [a] -> NonEmpty a
fromList ([Text] -> [Text]
forall a. [a] -> [a]
init [Text]
paths)) (Text -> TargetPath
TargetPath (Text -> TargetPath) -> Text -> TargetPath
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. [a] -> a
last [Text]
paths)
  where
    spaceSeparated :: ParsecT DockerfileError Text Identity [Text]
spaceSeparated =
      (Char -> Bool) -> ParsecT DockerfileError Text Identity Text
anyUnless (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ' ') ParsecT DockerfileError Text Identity Text
-> Parser () -> ParsecT DockerfileError Text Identity [Text]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepEndBy1` (Parser () -> Parser ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parser ()
requiredWhitespace Parser () -> String -> Parser ()
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> "at least another file path")
    stringList :: ParsecT DockerfileError Text Identity [Text]
stringList = ParsecT DockerfileError Text Identity [Text]
-> ParsecT DockerfileError Text Identity [Text]
forall a. Parser a -> Parser a
brackets (ParsecT DockerfileError Text Identity [Text]
 -> ParsecT DockerfileError Text Identity [Text])
-> ParsecT DockerfileError Text Identity [Text]
-> ParsecT DockerfileError Text Identity [Text]
forall a b. (a -> b) -> a -> b
$ ParsecT DockerfileError Text Identity Text
-> ParsecT DockerfileError Text Identity [Text]
forall a. Parser a -> Parser [a]
commaSep ParsecT DockerfileError Text Identity Text
stringLiteral

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)

copyFlag :: Parser CopyFlag
copyFlag :: Parser CopyFlag
copyFlag =
  (Chown -> CopyFlag
FlagChown (Chown -> CopyFlag)
-> ParsecT DockerfileError Text Identity Chown -> Parser CopyFlag
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT DockerfileError Text Identity Chown
-> ParsecT DockerfileError Text Identity Chown
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ParsecT DockerfileError Text Identity Chown
chown Parser CopyFlag -> String -> Parser CopyFlag
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> "only one --chown")
    Parser CopyFlag -> Parser CopyFlag -> Parser CopyFlag
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (CopySource -> CopyFlag
FlagSource (CopySource -> CopyFlag)
-> ParsecT DockerfileError Text Identity CopySource
-> Parser CopyFlag
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT DockerfileError Text Identity CopySource
-> ParsecT DockerfileError Text Identity CopySource
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ParsecT DockerfileError Text Identity CopySource
copySource Parser CopyFlag -> String -> Parser CopyFlag
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> "only one --from")
    Parser CopyFlag -> Parser CopyFlag -> Parser CopyFlag
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((Text, Text) -> CopyFlag
FlagInvalid ((Text, Text) -> CopyFlag)
-> ParsecT DockerfileError Text Identity (Text, Text)
-> Parser CopyFlag
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT DockerfileError Text Identity (Text, Text)
-> ParsecT DockerfileError Text Identity (Text, Text)
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ParsecT DockerfileError Text Identity (Text, Text)
anyFlag Parser CopyFlag -> String -> Parser CopyFlag
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> "no other flags")

chown :: Parser Chown
chown :: ParsecT DockerfileError Text Identity Chown
chown = 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 "--chown="
  Text
ch <- String
-> (Char -> Bool) -> ParsecT DockerfileError Text Identity Text
someUnless "the user and group for chown" (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ' ')
  Chown -> ParsecT DockerfileError Text Identity Chown
forall (m :: * -> *) a. Monad m => a -> m a
return (Chown -> ParsecT DockerfileError Text Identity Chown)
-> Chown -> ParsecT DockerfileError Text Identity Chown
forall a b. (a -> b) -> a -> b
$ Text -> Chown
Chown Text
ch

copySource :: Parser CopySource
copySource :: ParsecT DockerfileError Text Identity CopySource
copySource = 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 "--from="
  Text
src <- String
-> (Char -> Bool) -> ParsecT DockerfileError Text Identity Text
someUnless "the copy source path" Char -> Bool
isNl
  CopySource -> ParsecT DockerfileError Text Identity CopySource
forall (m :: * -> *) a. Monad m => a -> m a
return (CopySource -> ParsecT DockerfileError Text Identity CopySource)
-> CopySource -> ParsecT DockerfileError Text Identity CopySource
forall a b. (a -> b) -> a -> b
$ Text -> CopySource
CopySource Text
src

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)