language-docker 5.0.1 → 6.0.0
raw patch · 15 files changed
+752/−605 lines, 15 filesdep +containersdep +megaparsecdep +prettyprinterdep −parsecdep −prettydep ~base
Dependencies added: containers, megaparsec, prettyprinter
Dependencies removed: parsec, pretty
Dependency ranges changed: base
Files
- README.md +11/−7
- language-docker.cabal +9/−9
- src/Language/Docker.hs +9/−7
- src/Language/Docker/EDSL.hs +75/−37
- src/Language/Docker/EDSL/Quasi.hs +6/−4
- src/Language/Docker/EDSL/Types.hs +17/−17
- src/Language/Docker/Lexer.hs +0/−70
- src/Language/Docker/Normalize.hs +42/−37
- src/Language/Docker/Parser.hs +265/−146
- src/Language/Docker/PrettyPrint.hs +114/−98
- src/Language/Docker/Syntax.hs +95/−88
- src/Language/Docker/Syntax/Lift.hs +8/−2
- test/Language/Docker/EDSL/QuasiSpec.hs +4/−4
- test/Language/Docker/EDSLSpec.hs +19/−10
- test/Language/Docker/ParserSpec.hs +78/−69
README.md view
@@ -48,11 +48,13 @@ ```haskell {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-} import Language.Docker-main = putStr $ toDockerfileStr $ do++main = putDockerfileStr $ do from "node" run "apt-get update"- runArgs ["apt-get", "install", "something"]+ run ["apt-get", "install", "something"] -- ... ``` @@ -62,7 +64,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} import Language.Docker-main = putStr $ toDockerfileStr $ do+main = putDockerfileStr $ do from "node" run "apt-get update" [edockerfile|@@ -81,6 +83,7 @@ import Control.Monad import Language.Docker import Data.String (fromString)+import qualified Data.Text.Lazy.IO as L tags = ["7.8", "7.10", "8"] cabalSandboxBuild packageName = do@@ -93,10 +96,10 @@ run "cabal build" main = forM_ tags $ \tag -> do- let df = toDockerfileStr $ do+ let df = toDockerfileText $ do from ("haskell" `tagged` tag) cabalSandboxBuild "mypackage"- writeFile ("./examples/templating-" ++ tag ++ ".dockerfile") df+ L.writeFile ("./examples/templating-" ++ tag ++ ".dockerfile") df ``` ## Using IO in the DSL@@ -111,9 +114,10 @@ import qualified System.FilePath as FilePath import qualified System.FilePath.Glob as Glob import Data.List.NonEmpty (fromList)+import qualified Data.Text.Lazy.IO as L main = do- str <- toDockerfileStrIO $ do+ str <- toDockerfileTextIO $ do fs <- liftIO $ do cwd <- Directory.getCurrentDirectory fs <- Glob.glob "./test/*.hs"@@ -121,7 +125,7 @@ return (fromList relativeFiles) from "ubuntu" copy $ (toSources fs) `to` "/app/"- putStr str+ L.putStr str ``` [hackage-img]: https://img.shields.io/hackage/v/language-docker.svg
language-docker.cabal view
@@ -1,11 +1,11 @@--- This file has been generated from package.yaml by hpack version 0.21.2.+-- This file has been generated from package.yaml by hpack version 0.28.2. -- -- see: https://github.com/sol/hpack ----- hash: d0f11ab2ffb465c506d226c3df99c060577332cb17f835976ff64a00b41eac02+-- hash: 1258a921f9de776fdbf9c4b99356869a65eeade549a9d206b7319c93bd5c4af8 name: language-docker-version: 5.0.1+version: 6.0.0 synopsis: Dockerfile parser, pretty-printer and embedded DSL description: All functions for parsing, printing and writting Dockerfiles are exported through @Language.Docker@. For more fine-grained operations look for specific modules that implement a certain functionality. See the <https://github.com/hadolint/language-docker GitHub project> for the source-code and examples.@@ -23,7 +23,6 @@ license-file: LICENSE build-type: Simple cabal-version: >= 1.10- extra-source-files: README.md @@ -38,7 +37,6 @@ Language.Docker.PrettyPrint Language.Docker.Normalize Language.Docker.Syntax- Language.Docker.Lexer Language.Docker.Syntax.Lift Language.Docker.EDSL Language.Docker.EDSL.Quasi@@ -51,10 +49,11 @@ build-depends: base >=4.8 && <5 , bytestring >=0.10+ , containers , free+ , megaparsec >=6.4 , mtl- , parsec >=3.1- , pretty+ , prettyprinter , split >=0.2 , template-haskell , text@@ -79,14 +78,15 @@ , QuickCheck , base >=4.8 && <5 , bytestring >=0.10+ , containers , directory , filepath , free , hspec , language-docker+ , megaparsec >=6.4 , mtl- , parsec >=3.1- , pretty+ , prettyprinter , process , split >=0.2 , template-haskell
src/Language/Docker.hs view
@@ -1,17 +1,21 @@ module Language.Docker ( Language.Docker.Syntax.Dockerfile -- * Parsing Dockerfiles (@Language.Docker.Syntax@ and @Language.Docker.Parser@)- , parseString+ , parseText , parseFile+ -- * Re-exports from @megaparsec@+ , Text.Megaparsec.parseErrorPretty -- * Pretty-printing Dockerfiles (@Language.Docker.PrettyPrint@) , prettyPrint , prettyPrintInstructionPos -- * Writting Dockerfiles (@Language.Docker.EDSL@)- , Language.Docker.EDSL.toDockerfileStr+ , Language.Docker.EDSL.toDockerfileText , Language.Docker.EDSL.toDockerfile- , Language.Docker.EDSL.toDockerfileStrIO+ , Language.Docker.EDSL.putDockerfileStr+ , Language.Docker.EDSL.writeDockerFile+ , Language.Docker.EDSL.toDockerfileTextIO , Language.Docker.EDSL.toDockerfileIO , Language.Docker.EDSL.runDockerfileIO- , Language.Docker.EDSL.runDockerfileStrIO+ , Language.Docker.EDSL.runDockerfileTextIO , Control.Monad.IO.Class.liftIO , Language.Docker.EDSL.from -- ** Constructing base images@@ -88,8 +92,6 @@ , Language.Docker.Syntax.Pairs , Language.Docker.Syntax.Filename , Language.Docker.Syntax.Linenumber- -- * Re-exports from @parsec@- , ParseError -- * Instruction and InstructionPos helpers , Language.Docker.EDSL.instructionPos ) where@@ -101,4 +103,4 @@ import Language.Docker.Parser import Language.Docker.PrettyPrint import qualified Language.Docker.Syntax-import Text.Parsec (ParseError)+import qualified Text.Megaparsec
src/Language/Docker/EDSL.hs view
@@ -11,9 +11,14 @@ import Control.Monad.Free.TH import Control.Monad.Trans.Free (FreeT, iterTM) import Control.Monad.Writer-import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as B8 import Data.List.NonEmpty (NonEmpty) import Data.String (fromString)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Lazy as L+import qualified Data.Text.Lazy.Encoding as E import qualified Language.Docker.PrettyPrint as PrettyPrint import qualified Language.Docker.Syntax as Syntax@@ -32,11 +37,11 @@ makeFree ''EInstruction -runDockerWriter :: (MonadWriter [Syntax.Instruction] m) => EDockerfileM a -> m a+runDockerWriter :: (MonadWriter [Syntax.Instruction Text] m) => EDockerfileM a -> m a runDockerWriter = iterM runD runDockerWriterIO ::- (Monad m, MonadTrans t, MonadWriter [Syntax.Instruction] (t m))+ (Monad m, MonadTrans t, MonadWriter [Syntax.Instruction Text] (t m)) => EDockerfileTM m a -> t m a runDockerWriterIO = iterTM runD@@ -47,7 +52,7 @@ runDef2 :: MonadWriter [t] m => (t1 -> t2 -> t) -> t1 -> t2 -> m b -> m b runDef2 f a b n = tell [f a b] >> n -runD :: MonadWriter [Syntax.Instruction] m => EInstruction (m b) -> m b+runD :: MonadWriter [Syntax.Instruction Text] m => EInstruction (m b) -> m b runD (From bi n) = case bi of EUntaggedImage bi' alias -> runDef Syntax.From (Syntax.UntaggedImage bi' alias) n@@ -75,7 +80,7 @@ tell (map Syntax.instruction is) n -instructionPos :: Syntax.Instruction -> Syntax.InstructionPos+instructionPos :: Syntax.Instruction args -> Syntax.InstructionPos args instructionPos i = Syntax.InstructionPos i "" 0 -- | Runs the Dockerfile EDSL and returns a 'Dockerfile' you can pretty print@@ -85,23 +90,56 @@ let (_, w) = runWriter (runDockerWriter e) in map instructionPos w --- | runs the Dockerfile EDSL and returns a 'String' using+-- | runs the Dockerfile EDSL and returns a 'Data.Text.Lazy' using -- 'Language.Docker.PrettyPrint' -- -- @ -- import Language.Docker -- -- main :: IO ()--- main = writeFile "something.dockerfile" $ toDockerfileStr $ do+-- main = print $ toDockerfileText $ do -- from (tagged "fpco/stack-build" "lts-6.9") -- add ["."] "/app/language-docker" -- workdir "/app/language-docker" -- run "stack build --test --only-dependencies" -- cmd "stack test" -- @-toDockerfileStr :: EDockerfileM a -> String-toDockerfileStr = PrettyPrint.prettyPrint . toDockerfile+toDockerfileText :: EDockerfileM a -> L.Text+toDockerfileText = PrettyPrint.prettyPrint . toDockerfile +-- | Writes the dockerfile to the given file path after pretty-printing it+--+-- @+-- import Language.Docker+--+-- main :: IO ()+-- main = writeDockerFile "build.Dockerfile" $ toDockerfile $ do+-- from (tagged "fpco/stack-build" "lts-6.9")+-- add ["."] "/app/language-docker"+-- workdir "/app/language-docker"+-- run "stack build --test --only-dependencies"+-- cmd "stack test"+-- @+writeDockerFile :: Text -> Syntax.Dockerfile -> IO ()+writeDockerFile filename =+ BL.writeFile (Text.unpack filename) . E.encodeUtf8 . PrettyPrint.prettyPrint++-- | Prints the dockerfile to stdout. Mainly used for debugging purposes+--+-- @+-- import Language.Docker+--+-- main :: IO ()+-- main = putDockerfileStr $ do+-- from (tagged "fpco/stack-build" "lts-6.9")+-- add ["."] "/app/language-docker"+-- workdir "/app/language-docker"+-- run "stack build --test --only-dependencies"+-- cmd "stack test"+-- @+putDockerfileStr :: EDockerfileM a -> IO ()+putDockerfileStr = B8.putStrLn . E.encodeUtf8 . PrettyPrint.prettyPrint . toDockerfile+ -- | Use a docker image in a FROM instruction without a tag -- -- The following two examples are equivalent@@ -115,8 +153,8 @@ -- @ -- from "fpco/stack-build" -- @-untagged :: String -> EBaseImage-untagged = flip EUntaggedImage Nothing . fromString+untagged :: Text -> EBaseImage+untagged = flip EUntaggedImage Nothing . fromString . Text.unpack -- | Use a specific tag for a docker image. This function is meant -- to be used as an infix operator.@@ -124,10 +162,10 @@ -- @ -- from $ "fpco/stack-build" `tagged` "lts-10.3" -- @-tagged :: Syntax.Image -> String -> EBaseImage+tagged :: Syntax.Image -> Syntax.Tag -> EBaseImage tagged imageName tag = ETaggedImage imageName tag Nothing -digested :: Syntax.Image -> ByteString -> EBaseImage+digested :: Syntax.Image -> Text -> EBaseImage digested imageName hash = EDigestedImage imageName hash Nothing -- | Alias a FROM instruction to be used as a build stage.@@ -136,7 +174,7 @@ -- @ -- from $ "fpco/stack-build" `aliased` "builder" -- @-aliased :: EBaseImage -> String -> EBaseImage+aliased :: EBaseImage -> Text -> EBaseImage aliased image alias = case image of EUntaggedImage n _ -> EUntaggedImage n (Just $ Syntax.ImageAlias alias)@@ -148,7 +186,7 @@ -- @ -- run "apt-get install wget" -- @-run :: MonadFree EInstruction m => Syntax.Arguments -> m ()+run :: MonadFree EInstruction m => Syntax.Arguments Text -> m () run = runArgs -- | Create an ENTRYPOINT instruction with the given arguments.@@ -156,7 +194,7 @@ -- @ -- entrypoint "/usr/local/bin/program --some-flag" -- @-entrypoint :: MonadFree EInstruction m => Syntax.Arguments -> m ()+entrypoint :: MonadFree EInstruction m => Syntax.Arguments Text -> m () entrypoint = entrypointArgs -- | Create a CMD instruction with the given arguments.@@ -164,7 +202,7 @@ -- @ -- cmd "my-program --some-flag" -- @-cmd :: MonadFree EInstruction m => Syntax.Arguments -> m ()+cmd :: MonadFree EInstruction m => Syntax.Arguments Text -> m () cmd = cmdArgs -- | Create a COPY instruction. This function is meant to be@@ -210,10 +248,10 @@ -- someFiles <- glob "*.js" -- copy $ (toSources someFiles) `to` "." -- @-toSources :: NonEmpty String -> NonEmpty Syntax.SourcePath+toSources :: NonEmpty Text -> NonEmpty Syntax.SourcePath toSources = fmap Syntax.SourcePath --- | Converts a String into a 'Syntax.TargetPath'+-- | Converts a Text into a 'Syntax.TargetPath' -- -- This is a convenience function when you need to pass a string variable -- as an argument for 'copy' or 'add'@@ -222,7 +260,7 @@ -- let destination = buildSomePath pwd -- add ["foo.js"] (toTarget destination) -- @-toTarget :: String -> Syntax.TargetPath+toTarget :: Text -> Syntax.TargetPath toTarget = Syntax.TargetPath -- | Adds the --from= option to a COPY instruction.@@ -258,22 +296,22 @@ ports :: [Syntax.Port] -> Syntax.Ports ports = Syntax.Ports -tcpPort :: Integer -> Syntax.Port+tcpPort :: Int -> Syntax.Port tcpPort = flip Syntax.Port Syntax.TCP -udpPort :: Integer -> Syntax.Port+udpPort :: Int -> Syntax.Port udpPort = flip Syntax.Port Syntax.UDP -variablePort :: String -> Syntax.Port-variablePort varName = Syntax.PortStr ('$' : varName)+variablePort :: Text -> Syntax.Port+variablePort varName = Syntax.PortStr ("$" <> varName) -portRange :: Integer -> Integer -> Syntax.Port+portRange :: Int -> Int -> Syntax.Port portRange a b = Syntax.PortRange a b Syntax.TCP -udpPortRange :: Integer -> Integer -> Syntax.Port+udpPortRange :: Int -> Int -> Syntax.Port udpPortRange a b = Syntax.PortRange a b Syntax.UDP -check :: Syntax.Arguments -> Syntax.Check+check :: Syntax.Arguments args -> Syntax.Check args check command = Syntax.Check Syntax.CheckArgs@@ -284,31 +322,31 @@ , Syntax.retries = Nothing } -interval :: Syntax.Check -> Integer -> Syntax.Check+interval :: Syntax.Check args -> Integer -> Syntax.Check args interval ch secs = case ch of Syntax.NoCheck -> Syntax.NoCheck Syntax.Check chArgs -> Syntax.Check chArgs {Syntax.interval = Just $ fromInteger secs} -timeout :: Syntax.Check -> Integer -> Syntax.Check+timeout :: Syntax.Check args -> Integer -> Syntax.Check args timeout ch secs = case ch of Syntax.NoCheck -> Syntax.NoCheck Syntax.Check chArgs -> Syntax.Check chArgs {Syntax.timeout = Just $ fromInteger secs} -startPeriod :: Syntax.Check -> Integer -> Syntax.Check+startPeriod :: Syntax.Check args -> Integer -> Syntax.Check args startPeriod ch secs = case ch of Syntax.NoCheck -> Syntax.NoCheck Syntax.Check chArgs -> Syntax.Check chArgs {Syntax.startPeriod = Just $ fromInteger secs} -retries :: Syntax.Check -> Integer -> Syntax.Check+retries :: Syntax.Check args -> Integer -> Syntax.Check args retries ch tries = case ch of Syntax.NoCheck -> Syntax.NoCheck Syntax.Check chArgs -> Syntax.Check chArgs {Syntax.retries = Just $ fromInteger tries} -noCheck :: Syntax.Check+noCheck :: Syntax.Check args noCheck = Syntax.NoCheck -- | ONBUILD Dockerfile instruction@@ -330,9 +368,9 @@ toDockerfileIO :: MonadIO m => EDockerfileTM m t -> m Syntax.Dockerfile toDockerfileIO e = fmap snd (runDockerfileIO e) --- | A version of 'toDockerfileStr' which allows IO actions-toDockerfileStrIO :: MonadIO m => EDockerfileTM m t -> m String-toDockerfileStrIO e = fmap snd (runDockerfileStrIO e)+-- | A version of 'toDockerfileText' which allows IO actions+toDockerfileTextIO :: MonadIO m => EDockerfileTM m t -> m L.Text+toDockerfileTextIO e = fmap snd (runDockerfileTextIO e) -- | Just runs the EDSL's writer monad runDockerfileIO :: MonadIO m => EDockerfileTM m t -> m (t, Syntax.Dockerfile)@@ -341,7 +379,7 @@ return (r, map instructionPos w) -- | Runs the EDSL's writer monad and pretty-prints the result-runDockerfileStrIO :: MonadIO m => EDockerfileTM m t -> m (t, String)-runDockerfileStrIO e = do+runDockerfileTextIO :: MonadIO m => EDockerfileTM m t -> m (t, L.Text)+runDockerfileTextIO e = do (r, w) <- runDockerfileIO e return (r, PrettyPrint.prettyPrint w)
src/Language/Docker/EDSL/Quasi.hs view
@@ -7,9 +7,11 @@ import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax +import qualified Data.Text as Text import Language.Docker.EDSL import qualified Language.Docker.Parser as Parser import Language.Docker.Syntax.Lift ()+import Text.Megaparsec (parseErrorPretty) -- | Quasiquoter for embedding dockerfiles on the EDSL --@@ -27,8 +29,8 @@ edockerfileE :: String -> ExpQ edockerfileE e =- case Parser.parseString e of- Left err -> fail (show err)+ case Parser.parseText (Text.pack e) of+ Left err -> fail (parseErrorPretty err) Right d -> [|embed d|] dockerfile :: QuasiQuoter@@ -42,6 +44,6 @@ dockerfileE :: String -> ExpQ dockerfileE e =- case Parser.parseString e of- Left err -> fail (show err)+ case Parser.parseText (Text.pack e) of+ Left err -> fail (parseErrorPretty err) Right d -> lift d
src/Language/Docker/EDSL/Types.hs view
@@ -2,19 +2,19 @@ module Language.Docker.EDSL.Types where -import Data.ByteString.Char8 (ByteString) import Data.List.NonEmpty (NonEmpty) import Data.String+import Data.Text (Text) import qualified Language.Docker.Syntax as Syntax data EBaseImage = EUntaggedImage Syntax.Image (Maybe Syntax.ImageAlias) | ETaggedImage Syntax.Image- String+ Syntax.Tag (Maybe Syntax.ImageAlias) | EDigestedImage Syntax.Image- ByteString+ Text (Maybe Syntax.ImageAlias) deriving (Show, Eq, Ord) @@ -28,44 +28,44 @@ Syntax.TargetPath Syntax.Chown next- | User String+ | User Text next | Label Syntax.Pairs next- | StopSignal String+ | StopSignal Text next | CopyArgs (NonEmpty Syntax.SourcePath) Syntax.TargetPath Syntax.Chown Syntax.CopySource next- | RunArgs Syntax.Arguments+ | RunArgs (Syntax.Arguments Text) next- | CmdArgs Syntax.Arguments+ | CmdArgs (Syntax.Arguments Text) next- | Shell Syntax.Arguments+ | Shell (Syntax.Arguments Text) next | Workdir Syntax.Directory next | Expose Syntax.Ports next- | Volume String+ | Volume Text next- | EntrypointArgs Syntax.Arguments+ | EntrypointArgs (Syntax.Arguments Text) next- | Maintainer String+ | Maintainer Text next | Env Syntax.Pairs next- | Arg String- (Maybe String)+ | Arg Text+ (Maybe Text) next- | Comment String+ | Comment Text next- | Healthcheck Syntax.Check+ | Healthcheck (Syntax.Check Text) next- | OnBuildRaw Syntax.Instruction+ | OnBuildRaw (Syntax.Instruction Text) next- | Embed [Syntax.InstructionPos]+ | Embed [Syntax.InstructionPos Text] next deriving (Functor)
− src/Language/Docker/Lexer.hs
@@ -1,70 +0,0 @@-module Language.Docker.Lexer where--import Control.Monad (void)-import Data.Char-import Text.Parsec hiding (spaces)-import Text.Parsec.Language (haskell)-import Text.Parsec.String (Parser)-import qualified Text.Parsec.Token as Token--reserved :: String -> Parser ()-reserved name =- void $ do- _ <- try (caseInsensitiveString name) <?> name- spaces1 <?> "at least one space after '" ++ name ++ "' followed by its arguments"--natural :: Parser Integer-natural = zeroNumber <|> Token.decimal haskell <?> "positive number"- where- zeroNumber = char '0' >> return 0--commaSep :: Parser a -> Parser [a]-commaSep p = sepBy p (symbol ",")--stringLiteral :: Parser String-stringLiteral = Token.stringLiteral haskell--brackets :: Parser a -> Parser a-brackets = between (symbol "[") (symbol "]")--whiteSpace :: Parser ()-whiteSpace = void (char ' ' <|> char '\t') <?> "space"--space :: Parser ()-space = whiteSpace--spaces1 :: Parser ()-spaces1 = void (many1 whiteSpace <?> "at least one space")--spaces :: Parser ()-spaces = void (many whiteSpace <?> "spaces")--symbol :: String -> Parser String-symbol name = lexeme (string name)--caseInsensitiveChar :: Char -> Parser Char-caseInsensitiveChar c = char (toUpper c) <|> char (toLower c)--caseInsensitiveString :: String -> Parser String-caseInsensitiveString s = mapM caseInsensitiveChar s <?> "\"" ++ s ++ "\""--charsWithEscapedSpaces :: String -> Parser String-charsWithEscapedSpaces stopChars = do- buf <- many1 $ noneOf ("\n\t\\ " ++ stopChars)- try (jumpEscapeSequence buf) <|> try (backslashFollowedByChars buf) <|> return buf- where- backslashFollowedByChars buf = do- backslashes <- many1 (char '\\')- notFollowedBy (char ' ')- rest <- charsWithEscapedSpaces stopChars- return $ buf ++ backslashes ++ rest- jumpEscapeSequence buf = do- void $ string "\\ "- rest <- charsWithEscapedSpaces stopChars- return $ buf ++ ' ' : rest--lexeme :: Parser a -> Parser a-lexeme p = do- x <- p- spaces- return x
src/Language/Docker/Normalize.hs view
@@ -2,26 +2,24 @@ ( normalizeEscapedLines ) where -import Data.List (dropWhileEnd, mapAccumL)+import Data.List (mapAccumL) import Data.Maybe (catMaybes)+import Data.Semigroup ((<>))+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Text.Lazy (toStrict)+import qualified Data.Text.Lazy.Builder as Builder data NormalizedLine = Continue- | Joined !String+ | Joined !Builder.Builder !Int -trimLines :: [String] -> [String]-trimLines = map strip- where- strip = lstrip . rstrip- lstrip = dropWhile (`elem` " \t\r")- rstrip = reverse . lstrip . reverse- -- Finds all lines ending with \ and joins them with the next line using -- a single space. If the next line is a comment, then the comment line is -- deleted. It finally adds the same amount of new lines for each of the -- lines it joined, in order to preserve the line count in the document.-normalize :: [String] -> [String]+normalize :: Text -> Text normalize allLines = let (lastState, res) -- mapAccumL is the idea of a for loop with a variable holding -- some state and another variable where we append the final result@@ -30,15 +28,15 @@ -- to append to the final result. The ending result of mapAccumL is the final -- state variale and the resulting list of values. We initialize the loop with -- the 'Continue' state, which means "no special action to do next"- = mapAccumL transform Continue allLines+ = mapAccumL transform Continue (Text.lines allLines) in case lastState of Continue -- The last line of the document is a normal line, cleanup and return- -> catMaybes res+ -> Text.unlines . catMaybes $ res Joined l times -- The last line contains a \, so we need to add the buffered -- line back to the result, pad with newlines and cleanup- -> catMaybes res ++ [l ++ padNewlines times]+ -> Text.unlines (catMaybes res <> [toText (l <> padNewlines times)]) where- normalizeLast = dropWhileEnd (== '\\')+ toText = toStrict . Builder.toLazyText -- | Checks the result of the previous operation in the loop (first argument) -- -- If the previous result is a 'Joined' operation, then we merge the previous@@ -51,35 +49,42 @@ -- 'Joined' state holding the concatenation of the Joined buffer and the previous line -- and we return 'Nothing' as an indication that this line does not form part of the -- final result.- transform :: NormalizedLine -> String -> (NormalizedLine, Maybe String)- -- If we are buffering lines, and the next line is a comment,- -- we simply ignore the comment and remember to add a newline- transform (Joined prev times) ('#':_) = (Joined prev (times + 1), Nothing)- -- We do the same if we are buffering lines and the next one is empty- transform (Joined prev times) "" = (Joined prev (times + 1), Nothing)- -- If we are buffering lines, then we check whether the current line end with \,- -- if it does, then we merged it into the buffered state, otherwise we just yield- -- the concatanation of the buffer and the current line as result, after padding with- -- newlines- transform (Joined prev times) l =- if endsWithEscape l- then (Joined (prev ++ ' ' : normalizeLast l) (times + 1), Nothing)- else (Continue, Just (prev ++ ' ' : l ++ padNewlines times))+ transform :: NormalizedLine -> Text -> (NormalizedLine, Maybe Text)+ transform (Joined prev times) line+ -- If we are buffering lines and the next one is empty or it starts with a comment+ -- we simply ignore the comment and remember to add a newline+ | Text.null line || isComment line = (Joined prev (times + 1), Nothing)+ -- If we are buffering lines, then we check whether the current line end with \,+ -- if it does, then we merged it into the buffered state+ | endsWithEscape line = (Joined (prev <> normalizeLast line) (times + 1), Nothing)+ -- otherwise we just yield+ -- the concatanation of the buffer and the current line as result, after padding with+ -- newlines+ | otherwise = (Continue, Just (toText (prev <> Builder.fromText line <> padNewlines times))) -- When not buffering lines, then we just check if we need to start doing it by checking -- whether or not the current line ends with \. If it does not, then we just yield the -- current line as part of the result- transform Continue l =- if endsWithEscape l- then (Joined (normalizeLast l) 1, Nothing)- else (Continue, Just l)+ transform Continue l+ | endsWithEscape l = (Joined (normalizeLast l) 1, Nothing)+ | otherwise = (Continue, Just l) --- endsWithEscape "" = False- endsWithEscape s = last s == '\\'+ endsWithEscape t+ | Text.null t = False+ | otherwise = Text.last t == '\\' --- padNewlines times = replicate times '\n'+ padNewlines times = Builder.fromText (Text.replicate times (Text.singleton '\n'))+ --+ normalizeLast = Builder.fromText . Text.dropWhileEnd (== '\\')+ --+ isComment line =+ case (Text.uncons . Text.stripStart) line of+ Just ('#', _) -> True+ _ -> False -- | Remove new line escapes and join escaped lines together on one line -- to simplify parsing later on. Escapes are replaced with line breaks -- to not alter the line numbers.-normalizeEscapedLines :: String -> String-normalizeEscapedLines = unlines . normalize . trimLines . lines+normalizeEscapedLines :: Text -> Text+normalizeEscapedLines = normalize++{-# INLINE normalizeEscapedLines #-}
src/Language/Docker/Parser.hs view
@@ -1,104 +1,220 @@ {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-} -module Language.Docker.Parser where+module Language.Docker.Parser+ ( parseText+ , parseFile+ ) where import Control.Monad (void)-import Data.ByteString.Char8 (pack)+import qualified Data.ByteString as B+import Data.Data import Data.List.NonEmpty (NonEmpty, fromList) import Data.Maybe (listToMaybe)+import qualified Data.Set as S+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as E+import qualified Data.Text.Encoding.Error as E import Data.Time.Clock (secondsToDiffTime)-import Text.Parsec hiding (label, space, spaces)-import Text.Parsec.String (Parser)+import Text.Megaparsec hiding (Label, label)+import Text.Megaparsec.Char hiding (eol)+import qualified Text.Megaparsec.Char.Lexer as L -import Language.Docker.Lexer import Language.Docker.Normalize import Language.Docker.Syntax +data DockerfileError+ = DuplicateFlagError String+ | NoValueFlagError String+ | InvalidFlagError String+ | FileListError String+ | QuoteError String+ String+ deriving (Eq, Data, Typeable, Ord, Read, Show)++type Parser = Parsec DockerfileError Text++type Error = ParseError Char DockerfileError++type Instr = Instruction Text+ data CopyFlag = FlagChown Chown | FlagSource CopySource- | FlagInvalid (String, String)+ | FlagInvalid (Text, Text) data CheckFlag = FlagInterval Duration | FlagTimeout Duration | FlagStartPeriod Duration | FlagRetries Retries- | CFlagInvalid (String, String)+ | CFlagInvalid (Text, Text) -comment :: Parser Instruction+instance ShowErrorComponent DockerfileError where+ showErrorComponent (DuplicateFlagError f) = "duplicate flag: " ++ f+ showErrorComponent (FileListError f) =+ "unexpected end of line. At least two arguments are required for " ++ f+ showErrorComponent (NoValueFlagError f) = "unexpected flag " ++ f ++ " with no value"+ showErrorComponent (InvalidFlagError f) = "invalid flag: " ++ f+ showErrorComponent (QuoteError t str) =+ "unexpected end of " ++ t ++ " quoted string " ++ str ++ " (unmatched quote)"++------------------------------------+-- Utilities+------------------------------------+-- | End parsing signaling a “conversion error”.+customError :: DockerfileError -> Parser a+customError = fancyFailure . S.singleton . ErrorCustom++eol :: Parser ()+eol = void $ takeWhile1P (Just "whitespace") isSpaceNl++reserved :: Text -> Parser ()+reserved name = void (lexeme (string' name) <?> T.unpack name)++natural :: Parser Integer+natural = L.decimal <?> "positive number"++commaSep :: Parser a -> Parser [a]+commaSep p = sepBy p (symbol ",")++stringLiteral :: Parser Text+stringLiteral = do+ void (char '"')+ lit <- manyTill L.charLiteral (char '"')+ return (T.pack lit)++brackets :: Parser a -> Parser a+brackets = between (symbol "[") (symbol "]")++spaces1 :: Parser ()+spaces1 = void (takeWhile1P (Just "at least one space") (\c -> c == ' ' || c == '\t'))++spaces :: Parser ()+spaces = void (takeWhileP (Just "at least one space") (\c -> c == ' ' || c == '\t'))++symbol :: Text -> Parser Text+symbol name = do+ x <- string name+ spaces+ return x++caseInsensitiveString :: Text -> Parser Text+caseInsensitiveString = string'++charsWithEscapedSpaces :: String -> Parser Text+charsWithEscapedSpaces stopChars = do+ buf <- takeWhile1P Nothing (`notElem` ("\n\t\\ " ++ stopChars))+ try (jumpEscapeSequence buf) <|> try (backslashFollowedByChars buf) <|> return buf+ where+ backslashFollowedByChars buf = do+ backslashes <- takeWhile1P Nothing (== '\\')+ notFollowedBy (char ' ')+ rest <- charsWithEscapedSpaces stopChars+ return $ T.concat [buf, backslashes, rest]+ jumpEscapeSequence buf = do+ void $ string "\\ "+ rest <- charsWithEscapedSpaces stopChars+ return $ T.concat [buf, " ", rest]++lexeme :: Parser a -> Parser a+lexeme p = do+ x <- p+ spaces1+ return x++isNl :: Char -> Bool+isNl c = c == '\n'++isSpaceNl :: Char -> Bool+isSpaceNl c = c == ' ' || c == '\t' || c == '\n'++anyUnless :: (Char -> Bool) -> Parser Text+anyUnless predicate = takeWhileP Nothing (\c -> not (isSpaceNl c || predicate c))++someUnless :: String -> (Char -> Bool) -> Parser Text+someUnless name predicate = takeWhile1P (Just name) (\c -> not (isSpaceNl c || predicate c))++------------------------------------+-- DOCKER INSTRUCTIONS PARSER+------------------------------------+comment :: Parser Instr comment = do void $ char '#'- text <- many (noneOf "\n")+ text <- takeWhileP Nothing (not . isNl) return $ Comment text -registry :: Parser Registry-registry = do- name <- many1 (noneOf "\t\n /")+parseRegistry :: Parser Registry+parseRegistry = do+ name <- someUnless "a registry name" (== '/') void $ char '/' return $ Registry name taggedImage :: Parser BaseImage taggedImage = do- registryName <- (Just <$> try registry) <|> return Nothing- name <- many (noneOf "\t\n: ")+ registryName <- (Just <$> try parseRegistry) <|> return Nothing+ name <- someUnless "the image name with a tag" (\c -> c == '@' || c == ':') void $ char ':'- tag <- many1 (noneOf "\t\n: ")+ tag <- someUnless "the image tag" (== ':') maybeAlias <- maybeImageAlias- return $ TaggedImage (Image registryName name) tag maybeAlias+ return $ TaggedImage (Image registryName name) (Tag tag) maybeAlias digestedImage :: Parser BaseImage digestedImage = do- name <- many (noneOf "\t\n@ ")+ name <- someUnless "the image name with a digest" (\c -> c == '@' || c == ':') void $ char '@'- digest <- many1 (noneOf "\t\n@ ")+ digest <- someUnless "the image digest" (== '@') maybeAlias <- maybeImageAlias- return $ DigestedImage (Image Nothing name) (pack digest) maybeAlias+ return $ DigestedImage (Image Nothing name) digest maybeAlias untaggedImage :: Parser BaseImage untaggedImage = do- registryName <- (Just <$> try registry) <|> return Nothing- name <- many (noneOf "\n\t:@ ")+ registryName <- (Just <$> try parseRegistry) <|> return Nothing+ name <- someUnless "just the image name" (\c -> c == '@' || c == ':') notInvalidTag name notInvalidDigest name maybeAlias <- maybeImageAlias return $ UntaggedImage (Image registryName name) maybeAlias where- notInvalidTag :: String -> Parser ()+ notInvalidTag :: Text -> Parser () notInvalidTag name =- try (notFollowedBy $ oneOf ":") <?> "no ':' or a valid image tag string (example: " ++- name ++ ":valid-tag)"- notInvalidDigest :: String -> Parser ()+ try (notFollowedBy $ string ":") <?> "no ':' or a valid image tag string (example: " +++ T.unpack name ++ ":valid-tag)"+ notInvalidDigest :: Text -> Parser () notInvalidDigest name =- try (notFollowedBy $ oneOf "@") <?> "no '@' or a valid digest hash (example: " ++- name ++ "@a3f42f2de)"+ try (notFollowedBy $ string "@") <?> "no '@' or a valid digest hash (example: " +++ T.unpack name ++ "@a3f42f2de)" maybeImageAlias :: Parser (Maybe ImageAlias)-maybeImageAlias = Just <$> try (spaces >> imageAlias) <|> return Nothing+maybeImageAlias = Just <$> (spaces1 >> imageAlias) <|> return Nothing imageAlias :: Parser ImageAlias imageAlias = do- void $ caseInsensitiveString "AS"- spaces1 <?> "a space followed by the image alias"- alias <- untilOccurrence "\t\n "+ void (try (reserved "AS") <?> "AS followed by the image alias")+ alias <- someUnless "the image alias" (== '\n') return $ ImageAlias alias baseImage :: Parser BaseImage-baseImage = try digestedImage <|> try taggedImage <|> untaggedImage+baseImage =+ try digestedImage <|> -- Let's try each version+ try taggedImage <|>+ untaggedImage -from :: Parser Instruction+from :: Parser Instr from = do reserved "FROM" image <- baseImage return $ From image -cmd :: Parser Instruction+cmd :: Parser Instr cmd = do reserved "CMD" args <- arguments return $ Cmd args -copy :: Parser Instruction+copy :: Parser Instr copy = do reserved "COPY" flags <- copyFlag `sepEndBy` spaces1@@ -108,8 +224,8 @@ -- Let's do some validation on the flags case (invalid, chownFlags, sourceFlags) of ((k, v):_, _, _) -> unexpectedFlag k v- (_, _:_:_, _) -> unexpected "duplicate flag: --chown"- (_, _, _:_:_) -> unexpected "duplicate flag: --from"+ (_, _:_:_, _) -> customError $ DuplicateFlagError "--chown"+ (_, _, _:_:_) -> customError $ DuplicateFlagError "--from" _ -> do let ch = case chownFlags of@@ -130,76 +246,79 @@ chown :: Parser Chown chown = do void $ string "--chown="- ch <- many1 (noneOf "\t\n ")+ ch <- someUnless "the user and group for chown" (== ' ') return $ Chown ch copySource :: Parser CopySource copySource = do void $ string "--from="- src <- many1 (noneOf "\t\n ")+ src <- someUnless "the copy source path" isNl return $ CopySource src -anyFlag :: Parser (String, String)+anyFlag :: Parser (Text, Text) anyFlag = do void $ string "--"- name <- many1 $ noneOf "\t\n= "+ name <- someUnless "the flag value" (== '=') void $ char '='- val <- many $ noneOf "\t\n "- return ("--" ++ name, val)+ val <- anyUnless (== ' ')+ return (T.append "--" name, val) -fileList :: String -> (NonEmpty SourcePath -> TargetPath -> Instruction) -> Parser Instruction+fileList :: Text -> (NonEmpty SourcePath -> TargetPath -> Instr) -> Parser Instr fileList name constr = do paths <- (try stringList <?> "an array of strings [\"src_file\", \"dest_file\"]") <|> (try spaceSeparated <?> "a space separated list of file paths") case paths of- [_] -> unexpected $ "end of line. At least two arguments are required for " ++ name+ [_] -> customError $ FileListError (T.unpack name) _ -> return $ constr (SourcePath <$> fromList (init paths)) (TargetPath $ last paths) where- spaceSeparated = many (noneOf "\t\n ") `sepBy1` (try spaces1 <?> "at least another file path")+ spaceSeparated = anyUnless (== ' ') `sepBy1` (try spaces1 <?> "at least another file path") stringList = brackets $ commaSep stringLiteral -unexpectedFlag :: String -> String -> Parser a-unexpectedFlag name "" = unexpected $ "flag " ++ name ++ " with no value"-unexpectedFlag name _ = unexpected $ "invalid flag " ++ name+unexpectedFlag :: Text -> Text -> Parser a+unexpectedFlag name "" = customFailure $ NoValueFlagError (T.unpack name)+unexpectedFlag name _ = customFailure $ InvalidFlagError (T.unpack name) -shell :: Parser Instruction+shell :: Parser Instr shell = do reserved "SHELL" args <- arguments return $ Shell args -stopsignal :: Parser Instruction+stopsignal :: Parser Instr stopsignal = do reserved "STOPSIGNAL"- args <- many1 (noneOf "\n")+ args <- untilEol "the stop signal" return $ Stopsignal args -- We cannot use string literal because it swallows space -- and therefore have to implement quoted values by ourselves-doubleQuotedValue :: Parser String-doubleQuotedValue = between (char '"') (char '"') (many $ noneOf "\n\"")+doubleQuotedValue :: Parser Text+doubleQuotedValue =+ between (string "\"") (string "\"") (takeWhileP Nothing (\c -> c /= '"' && c /= '\n')) -singleQuotedValue :: Parser String-singleQuotedValue = between (void $ char '\'') (void $ char '\'') (many $ noneOf "\n'")+singleQuotedValue :: Parser Text+singleQuotedValue =+ between (string "'") (string "'") (takeWhileP Nothing (\c -> c /= '\'' && c /= '\n')) -unquotedString :: String -> Parser String+unquotedString :: String -> Parser Text unquotedString stopChars = do str <- charsWithEscapedSpaces stopChars- case str of- '\'':_ -> unexpected $ errMsg "single" str- '"':_ -> unexpected $ errMsg "double" str- _ -> return str+ checkFaults str where- errMsg t str = "end of " ++ t ++ " quoted string " ++ str ++ " (unmatched quote)"+ checkFaults str+ | T.null str = return str+ | T.head str == '\'' = customError $ QuoteError "single" (T.unpack str)+ | T.head str == '\"' = customError $ QuoteError "double" (T.unpack str)+ | otherwise = return str -singleValue :: String -> Parser String+singleValue :: String -> Parser Text singleValue stopChars = try doubleQuotedValue <|> -- Quotes or no quotes are fine try singleQuotedValue <|> (try (unquotedString stopChars) <?> "a string with no quotes") -pair :: Parser (String, String)+pair :: Parser (Text, Text) pair = do key <- singleValue "=" void $ char '='@@ -209,24 +328,25 @@ pairsList :: Parser Pairs pairsList = pair `sepBy1` spaces1 -label :: Parser Instruction+label :: Parser Instr label = do reserved "LABEL" p <- pairs return $ Label p -arg :: Parser Instruction+arg :: Parser Instr arg = do reserved "ARG"- (try nameWithDefault <?> "the arg name") <|> Arg <$> untilEol <*> pure Nothing+ (try nameWithDefault <?> "the arg name") <|>+ Arg <$> untilEol "the argument name" <*> pure Nothing where nameWithDefault = do- name <- many1 $ noneOf "\t\n= "+ name <- someUnless "the argument name" (== '=') void $ char '='- def <- untilEol+ def <- untilEol "the argument value" return $ Arg name (Just def) -env :: Parser Instruction+env :: Parser Instr env = do reserved "ENV" p <- pairs@@ -237,28 +357,28 @@ singlePair :: Parser Pairs singlePair = do- key <- many (noneOf "\t\n= ")- spaces1 <?> "a space followed by the value for the variable '" ++ key ++ "'"- val <- untilEol+ key <- anyUnless (== '=')+ spaces1 <?> "a space followed by the value for the variable '" ++ T.unpack key ++ "'"+ val <- untilEol "the variable value" return [(key, val)] -user :: Parser Instruction+user :: Parser Instr user = do reserved "USER"- username <- untilEol+ username <- untilEol "the user" return $ User username -add :: Parser Instruction+add :: Parser Instr add = do reserved "ADD" flag <- lexeme copyFlag <|> return (FlagChown NoChown) notFollowedBy (string "--") <?> "only the --chown flag or the src and dest paths" case flag of FlagChown ch -> fileList "ADD" (\src dest -> Add (AddArgs src dest ch))- FlagSource _ -> unexpected "flag --from"+ FlagSource _ -> customError $ InvalidFlagError "--from" FlagInvalid (k, v) -> unexpectedFlag k v -expose :: Parser Instruction+expose :: Parser Instr expose = do reserved "EXPOSE" ps <- ports@@ -272,7 +392,7 @@ (try portInt <?> "a valid port number") ports :: Parser Ports-ports = Ports <$> port `sepEndBy1` space+ports = Ports <$> port `sepEndBy1` (char ' ' <|> char '\t') portRange :: Parser Port portRange = do@@ -280,7 +400,7 @@ void $ char '-' finish <- try natural proto <- try protocol <|> return TCP- return $ PortRange start finish proto+ return $ PortRange (fromIntegral start) (fromIntegral finish) proto protocol :: Parser Protocol protocol = do@@ -293,80 +413,77 @@ portInt :: Parser Port portInt = do portNumber <- natural- notFollowedBy (oneOf "/-")- return $ Port portNumber TCP+ notFollowedBy (string "/" <|> string "-")+ return $ Port (fromIntegral portNumber) TCP portWithProtocol :: Parser Port portWithProtocol = do portNumber <- natural proto <- protocol- return $ Port portNumber proto+ return $ Port (fromIntegral portNumber) proto portVariable :: Parser Port portVariable = do- void $ lookAhead (char '$')- variable <- untilOccurrence "\t\n- "- return $ PortStr variable+ void (char '$')+ variable <- someUnless "the variable name" (== '$')+ return $ PortStr (T.append "$" variable) -run :: Parser Instruction+run :: Parser Instr run = do reserved "RUN" c <- arguments return $ Run c -- Parse value until end of line is reached-untilEol :: Parser String-untilEol = many1 (noneOf "\n")--untilOccurrence :: String -> Parser String-untilOccurrence t = many $ noneOf t+untilEol :: String -> Parser Text+untilEol name = takeWhile1P (Just name) (not . isNl) -workdir :: Parser Instruction+workdir :: Parser Instr workdir = do reserved "WORKDIR"- directory <- untilEol+ directory <- untilEol "the workdir path" return $ Workdir directory -volume :: Parser Instruction+volume :: Parser Instr volume = do reserved "VOLUME"- directory <- untilEol+ directory <- untilEol "the volume path" return $ Volume directory -maintainer :: Parser Instruction+maintainer :: Parser Instr maintainer = do reserved "MAINTAINER"- name <- untilEol+ name <- untilEol "the maintainer name" return $ Maintainer name -- Parse arguments of a command in the exec form-argumentsExec :: Parser Arguments+argumentsExec :: Parser (Arguments Text) argumentsExec = do args <- brackets $ commaSep stringLiteral- return $ Arguments args+ return $ ArgumentsList (T.unwords args) -- Parse arguments of a command in the shell form-argumentsShell :: Parser Arguments-argumentsShell = do- args <- untilEol- return $ Arguments (words args)+argumentsShell :: Parser (Arguments Text)+argumentsShell = ArgumentsText <$> toEnd+ where+ toEnd = untilEol "the shell arguments" -arguments :: Parser Arguments+arguments :: Parser (Arguments Text) arguments = try argumentsExec <|> try argumentsShell -entrypoint :: Parser Instruction+entrypoint :: Parser Instr entrypoint = do reserved "ENTRYPOINT" args <- arguments return $ Entrypoint args -onbuild :: Parser Instruction+onbuild :: Parser Instr onbuild = do reserved "ONBUILD" i <- parseInstruction return $ OnBuild i -healthcheck :: Parser Instruction+healthcheck :: Parser Instr healthcheck = do reserved "HEALTHCHECK" Healthcheck <$> (fullCheck <|> noCheck)@@ -394,10 +511,10 @@ -- Let's do some validation on the flags case (invalid, intervals, timeouts, startPeriods, retriesD) of ((k, v):_, _, _, _, _) -> unexpectedFlag k v- (_, _:_:_, _, _, _) -> unexpected "duplicate flag: --interval"- (_, _, _:_:_, _, _) -> unexpected "duplicate flag: --timeout"- (_, _, _, _:_:_, _) -> unexpected "duplicate flag: --start-period"- (_, _, _, _, _:_:_) -> unexpected "duplicate flag: --retries"+ (_, _:_:_, _, _, _) -> customError $ DuplicateFlagError "--interval"+ (_, _, _:_:_, _, _) -> customError $ DuplicateFlagError "--timeout"+ (_, _, _, _:_:_, _) -> customError $ DuplicateFlagError "--start-period"+ (_, _, _, _, _:_:_) -> customError $ DuplicateFlagError "--retries" _ -> do Cmd checkCommand <- cmd let interval = listToMaybe intervals@@ -414,7 +531,7 @@ (FlagRetries <$> retriesFlag <?> "--retries") <|> (CFlagInvalid <$> anyFlag <?> "no flags") -durationFlag :: String -> Parser Duration+durationFlag :: Text -> Parser Duration durationFlag flagName = do void $ try (string flagName) scale <- natural@@ -422,7 +539,8 @@ case unit of 's' -> return $ Duration (secondsToDiffTime scale) 'm' -> return $ Duration (secondsToDiffTime (scale * 60))- _ -> return $ Duration (secondsToDiffTime (scale * 60 * 60))+ 'h' -> return $ Duration (secondsToDiffTime (scale * 60 * 60))+ _ -> fail "only 's', 'm' or 'h' are allowed as the duration" retriesFlag :: Parser Retries retriesFlag = do@@ -430,50 +548,51 @@ n <- try natural <?> "the number of retries" return $ Retries (fromIntegral n) -parseInstruction :: Parser Instruction+------------------------------------+-- Main Parser+------------------------------------+parseInstruction :: Parser Instr parseInstruction =- try onbuild <|> -- parse all main instructions- try from <|>- try copy <|>- try run <|>- try workdir <|>- try entrypoint <|>- try volume <|>- try expose <|>- try env <|>- try arg <|>- try user <|>- try label <|>- try stopsignal <|>- try cmd <|>- try shell <|>- try maintainer <|>- try add <|>- try comment <|>- try healthcheck+ onbuild <|> -- parse all main instructions+ from <|>+ copy <|>+ run <|>+ workdir <|>+ entrypoint <|>+ volume <|>+ expose <|>+ env <|>+ arg <|>+ user <|>+ label <|>+ stopsignal <|>+ cmd <|>+ shell <|>+ maintainer <|>+ add <|>+ comment <|>+ healthcheck contents :: Parser a -> Parser a contents p = do- void $ many (space <|> void (char '\n'))+ void $ takeWhileP Nothing isSpaceNl r <- p eof return r -eol :: Parser ()-eol = void $ char '\n' <|> (char '\r' >> option '\n' (char '\n'))- dockerfile :: Parser Dockerfile dockerfile = many $ do pos <- getPosition i <- parseInstruction- void (many1 eol) <|> eof <?> "a new line followed by the next instruction"- return $ InstructionPos i (sourceName pos) (sourceLine pos)+ eol <|> eof <?> "a new line followed by the next instruction"+ return $ InstructionPos i (T.pack . sourceName $ pos) (unPos . sourceLine $ pos) -parseString :: String -> Either ParseError Dockerfile-parseString s = parse (contents dockerfile) "<string>" $ normalizeEscapedLines s+parseText :: Text -> Either Error Dockerfile+parseText s = parse (contents dockerfile) "<string>" $ normalizeEscapedLines s -parseFile :: String -> IO (Either ParseError Dockerfile)-parseFile file = do- program <- readFile file- return $ parse (contents dockerfile) file $ normalizeEscapedLines program+parseFile :: FilePath -> IO (Either Error Dockerfile)+parseFile file = doParse <$> B.readFile file+ where+ doParse =+ parse (contents dockerfile) file . normalizeEscapedLines . E.decodeUtf8With E.lenientDecode
src/Language/Docker/PrettyPrint.hs view
@@ -3,54 +3,63 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-} module Language.Docker.PrettyPrint where -import qualified Data.ByteString.Char8 as ByteString (unpack)-import Data.List (foldl', intersperse) import Data.List.NonEmpty as NonEmpty (NonEmpty(..), toList)-import Data.String+import Data.Maybe (Maybe(..))+import Data.Semigroup ((<>))+import Data.String (fromString)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Lazy as L+import Data.Text.Prettyprint.Doc+import Data.Text.Prettyprint.Doc.Internal (Doc(Empty))+import Data.Text.Prettyprint.Doc.Render.Text (renderLazy) import Language.Docker.Syntax-import Prelude- (Bool(..), Maybe(..), ($), (++), (.), map, maybe, mempty, reverse,- show, snd)-import Text.PrettyPrint+import Prelude hiding ((<>), (>>), return) --- | Pretty print a 'Dockerfile' to a 'String'-prettyPrint :: Dockerfile -> String-prettyPrint =- unlines .- reverse .- snd . foldl' removeDoubleBlank (False, []) . lines . unlines . map prettyPrintInstructionPos+instance Pretty (Arguments Text) where+ pretty = prettyPrintArguments++-- | Pretty print a 'Dockerfile' to a 'Text'+prettyPrint :: Dockerfile -> L.Text+prettyPrint = renderLazy . layoutPretty opts . prettyPrintDockerfile where- removeDoubleBlank (True, m) "" = (True, m)- removeDoubleBlank (False, m) "" = (True, "" : m)- removeDoubleBlank (_, m) s = (False, s : m)+ opts = LayoutOptions Unbounded --- | Pretty print a 'InstructionPos' to a 'String'-prettyPrintInstructionPos :: InstructionPos -> String-prettyPrintInstructionPos (InstructionPos i _ _) = render (prettyPrintInstruction i)+prettyPrintDockerfile :: Pretty (Arguments args) => [InstructionPos args] -> Doc ann+prettyPrintDockerfile instr = doPrint instr <> "\n"+ where+ doPrint = vsep . fmap prettyPrintInstructionPos -prettyPrintImage :: Image -> Doc-prettyPrintImage (Image Nothing name) = text name-prettyPrintImage (Image (Just (Registry reg)) name) = text reg <> char '/' <> text name+-- | Pretty print a 'InstructionPos' to a 'Doc'+prettyPrintInstructionPos :: Pretty (Arguments args) => InstructionPos args -> Doc ann+prettyPrintInstructionPos (InstructionPos i _ _) = prettyPrintInstruction i -prettyPrintBaseImage :: BaseImage -> Doc+prettyPrintImage :: Image -> Doc ann+prettyPrintImage (Image Nothing name) = pretty name+prettyPrintImage (Image (Just (Registry reg)) name) = pretty reg <> "/" <> pretty name++prettyPrintBaseImage :: BaseImage -> Doc ann prettyPrintBaseImage b = case b of DigestedImage img digest alias -> do prettyPrintImage img- char '@'- text (ByteString.unpack digest)+ pretty '@'+ pretty digest prettyAlias alias UntaggedImage (Image _ name) alias -> do- text name+ pretty name prettyAlias alias- TaggedImage img tag alias -> do+ TaggedImage img (Tag tag) alias -> do prettyPrintImage img- char ':'- text tag+ pretty ':'+ pretty tag prettyAlias alias where (>>) = (<>)@@ -58,134 +67,141 @@ prettyAlias maybeAlias = case maybeAlias of Nothing -> mempty- Just (ImageAlias alias) -> text " AS " <> text alias+ Just (ImageAlias alias) -> " AS " <> pretty alias -prettyPrintPairs :: Pairs -> Doc-prettyPrintPairs ps = hsep $ map prettyPrintPair ps+prettyPrintPairs :: Pairs -> Doc ann+prettyPrintPairs ps = hsep $ fmap prettyPrintPair ps -prettyPrintPair :: (String, String) -> Doc-prettyPrintPair (k, v) = text k <> char '=' <> text (show v)+prettyPrintPair :: (Text, Text) -> Doc ann+prettyPrintPair (k, v) = pretty k <> pretty '=' <> pretty v -prettyPrintArguments :: Arguments -> Doc-prettyPrintArguments (Arguments as) = text (unwords (map helper as))+prettyPrintArguments :: Arguments Text -> Doc ann+prettyPrintArguments (ArgumentsList as) = prettyPrintJSON (Text.words as)+prettyPrintArguments (ArgumentsText as) = hsep (fmap helper (Text.words as)) where helper "&&" = "\\\n &&"- helper a = a+ helper a = pretty a -prettyPrintJSON :: Arguments -> Doc-prettyPrintJSON (Arguments as) = brackets $ hcat $ intersperse (comma <> space) $ map (doubleQuotes . text) as+prettyPrintJSON :: [Text] -> Doc ann+prettyPrintJSON args = list (fmap doubleQoute args)+ where+ doubleQoute w = enclose dquote dquote (pretty w) -prettyPrintPort :: Port -> Doc-prettyPrintPort (PortStr str) = text str-prettyPrintPort (PortRange start stop TCP) = integer start <> text "-" <> integer stop-prettyPrintPort (PortRange start stop UDP) =- integer start <> text "-" <> integer stop <> char '/' <> text "udp"-prettyPrintPort (Port num TCP) = integer num <> char '/' <> text "tcp"-prettyPrintPort (Port num UDP) = integer num <> char '/' <> text "udp"+prettyPrintPort :: Port -> Doc ann+prettyPrintPort (PortStr str) = pretty str+prettyPrintPort (PortRange start stop TCP) = pretty start <> "-" <> pretty stop+prettyPrintPort (PortRange start stop UDP) = pretty start <> "-" <> pretty stop <> "/udp"+prettyPrintPort (Port num TCP) = pretty num <> "/tcp"+prettyPrintPort (Port num UDP) = pretty num <> "/udp" -prettyPrintFileList :: NonEmpty SourcePath -> TargetPath -> Doc+prettyPrintFileList :: NonEmpty SourcePath -> TargetPath -> Doc ann prettyPrintFileList sources (TargetPath dest) = let ending =- case (reverse dest, sources) of- ('/':_, _) -> "" -- If the target ends with / then no extra ending is needed+ case (Text.isSuffixOf "/" dest, sources) of+ (True, _) -> "" -- If the target ends with / then no extra ending is needed (_, _fst :| _snd:_) -> "/" -- More than one source means that the target should end in / _ -> ""- in hsep $ [text s | SourcePath s <- toList sources] ++ [text dest <> text ending]+ in hsep $ [pretty s | SourcePath s <- toList sources] ++ [pretty dest <> ending] -prettyPrintChown :: Chown -> Doc+prettyPrintChown :: Chown -> Doc ann prettyPrintChown chown = case chown of- Chown c -> text "--chown=" <> text c+ Chown c -> "--chown=" <> pretty c NoChown -> mempty -prettyPrintCopySource :: CopySource -> Doc+prettyPrintCopySource :: CopySource -> Doc ann prettyPrintCopySource source = case source of- CopySource c -> text "--from=" <> text c+ CopySource c -> "--from=" <> pretty c NoSource -> mempty -prettyPrintDuration :: String -> Maybe Duration -> Doc+prettyPrintDuration :: Text -> Maybe Duration -> Doc ann prettyPrintDuration flagName = maybe mempty pp where- pp (Duration d) = text flagName <> text (show d)+ pp (Duration d) = pretty flagName <> pretty (show d) -prettyPrintRetries :: Maybe Retries -> Doc+prettyPrintRetries :: Maybe Retries -> Doc ann prettyPrintRetries = maybe mempty pp where- pp (Retries r) = text "--retries=" <> int r+ pp (Retries r) = "--retries=" <> pretty r -prettyPrintInstruction :: Instruction -> Doc+prettyPrintInstruction :: Pretty (Arguments args) => Instruction args -> Doc ann prettyPrintInstruction i = case i of Maintainer m -> do- text "MAINTAINER"- text m+ "MAINTAINER"+ pretty m Arg a Nothing -> do- text "ARG"- text a+ "ARG"+ pretty a Arg k (Just v) -> do- text "ARG"- text k <> text "=" <> text v+ "ARG"+ pretty k <> "=" <> pretty v Entrypoint e -> do- text "ENTRYPOINT"- prettyPrintJSON e+ "ENTRYPOINT"+ pretty e Stopsignal s -> do- text "STOPSIGNAL"- text s+ "STOPSIGNAL"+ pretty s Workdir w -> do- text "WORKDIR"- text w+ "WORKDIR"+ pretty w Expose (Ports ps) -> do- text "EXPOSE"- hsep (map prettyPrintPort ps)+ "EXPOSE"+ hsep (fmap prettyPrintPort ps) Volume dir -> do- text "VOLUME"- text dir+ "VOLUME"+ pretty dir Run c -> do- text "RUN"- prettyPrintArguments c+ "RUN"+ pretty c Copy CopyArgs {sourcePaths, targetPath, chownFlag, sourceFlag} -> do- text "COPY"+ "COPY" prettyPrintChown chownFlag prettyPrintCopySource sourceFlag prettyPrintFileList sourcePaths targetPath Cmd c -> do- text "CMD"- prettyPrintJSON c+ "CMD"+ pretty c Label l -> do- text "LABEL"+ "LABEL" prettyPrintPairs l Env ps -> do- text "ENV"+ "ENV" prettyPrintPairs ps User u -> do- text "USER"- text u+ "USER"+ pretty u Comment s -> do- char '#'- text s+ pretty '#'+ pretty s OnBuild i' -> do- text "ONBUILD"+ "ONBUILD" prettyPrintInstruction i' From b -> do- text "FROM"+ "FROM" prettyPrintBaseImage b Add AddArgs {sourcePaths, targetPath, chownFlag} -> do- text "ADD"+ "ADD" prettyPrintChown chownFlag prettyPrintFileList sourcePaths targetPath Shell args -> do- text "SHELL"- prettyPrintJSON args- Healthcheck NoCheck -> text "HEALTHCHECK NONE"+ "SHELL"+ pretty args+ Healthcheck NoCheck -> "HEALTHCHECK NONE" Healthcheck (Check CheckArgs {..}) -> do- text "HEALTHCHECK"+ "HEALTHCHECK" prettyPrintDuration "--interval=" interval prettyPrintDuration "--timeout=" timeout prettyPrintDuration "--start-period=" startPeriod prettyPrintRetries retries- text "CMD"- prettyPrintArguments checkCommand+ "CMD"+ pretty checkCommand where- (>>) = (<+>)- return = (mempty <>)+ (>>) = spaceCat+ return a = a++spaceCat :: Doc ann -> Doc ann -> Doc ann+spaceCat a Empty = a+spaceCat Empty b = b+spaceCat a b = a <+> b
src/Language/Docker/Syntax.hs view
@@ -1,19 +1,20 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies,- DuplicateRecordFields #-}+ DuplicateRecordFields, FlexibleInstances, DeriveFunctor #-} module Language.Docker.Syntax where -import Data.ByteString.Char8 (ByteString) import Data.List (intercalate, isInfixOf) import Data.List.NonEmpty (NonEmpty) import Data.List.Split (endBy) import Data.String (IsString(..))+import Data.Text (Text)+import qualified Data.Text as Text import Data.Time.Clock (DiffTime) import GHC.Exts (IsList(..)) data Image = Image- { registryName :: Maybe Registry- , imageName :: String+ { registryName :: !(Maybe Registry)+ , imageName :: !Text } deriving (Show, Eq, Ord) instance IsString Image where@@ -21,15 +22,20 @@ if "/" `isInfixOf` img then let parts = endBy "/" img in case parts of- registry:rest -> Image (Just (Registry registry)) (intercalate "/" rest)- _ -> Image Nothing img- else Image Nothing img+ reg:rest ->+ Image+ (Just (Registry (Text.pack reg)))+ (Text.pack . intercalate "/" $ rest)+ _ -> Image Nothing (Text.pack img)+ else Image Nothing (Text.pack img) -newtype Registry =- Registry String- deriving (Show, Eq, Ord, IsString)+newtype Registry = Registry+ { unRegistry :: Text+ } deriving (Show, Eq, Ord, IsString) -type Tag = String+newtype Tag = Tag+ { unTag :: Text+ } deriving (Show, Eq, Ord, IsString) data Protocol = TCP@@ -37,12 +43,12 @@ deriving (Show, Eq, Ord) data Port- = Port Integer- Protocol- | PortStr String- | PortRange Integer- Integer- Protocol+ = Port !Int+ !Protocol+ | PortStr !Text+ | PortRange !Int+ !Int+ !Protocol deriving (Show, Eq, Ord) newtype Ports = Ports@@ -54,36 +60,36 @@ fromList = Ports toList (Ports ps) = ps -type Directory = String+type Directory = Text newtype ImageAlias = ImageAlias- { unImageAlias :: String+ { unImageAlias :: Text } deriving (Show, Eq, Ord, IsString) data BaseImage- = UntaggedImage Image- (Maybe ImageAlias)- | TaggedImage Image- Tag- (Maybe ImageAlias)- | DigestedImage Image- ByteString- (Maybe ImageAlias)+ = UntaggedImage !Image+ !(Maybe ImageAlias)+ | TaggedImage !Image+ !Tag+ !(Maybe ImageAlias)+ | DigestedImage !Image+ !Text+ !(Maybe ImageAlias) deriving (Eq, Ord, Show) -- | Type of the Dockerfile AST-type Dockerfile = [InstructionPos]+type Dockerfile = [InstructionPos Text] newtype SourcePath = SourcePath- { unSourcePath :: String+ { unSourcePath :: Text } deriving (Show, Eq, Ord, IsString) newtype TargetPath = TargetPath- { unTargetPath :: String+ { unTargetPath :: Text } deriving (Show, Eq, Ord, IsString) data Chown- = Chown String+ = Chown !Text | NoChown deriving (Show, Eq, Ord) @@ -91,10 +97,10 @@ fromString ch = case ch of "" -> NoChown- _ -> Chown ch+ _ -> Chown (Text.pack ch) data CopySource- = CopySource String+ = CopySource !Text | NoSource deriving (Show, Eq, Ord) @@ -102,7 +108,7 @@ fromString src = case src of "" -> NoSource- _ -> CopySource src+ _ -> CopySource (Text.pack src) newtype Duration = Duration { durationTime :: DiffTime@@ -114,77 +120,78 @@ data CopyArgs = CopyArgs { sourcePaths :: NonEmpty SourcePath- , targetPath :: TargetPath- , chownFlag :: Chown- , sourceFlag :: CopySource+ , targetPath :: !TargetPath+ , chownFlag :: !Chown+ , sourceFlag :: !CopySource } deriving (Show, Eq, Ord) data AddArgs = AddArgs { sourcePaths :: NonEmpty SourcePath- , targetPath :: TargetPath- , chownFlag :: Chown+ , targetPath :: !TargetPath+ , chownFlag :: !Chown } deriving (Show, Eq, Ord) -data Check- = Check CheckArgs+data Check args+ = Check !(CheckArgs args) | NoCheck- deriving (Show, Eq, Ord)--newtype Arguments =- Arguments [String]- deriving (Show, Eq, Ord)+ deriving (Show, Eq, Ord, Functor) -instance IsString Arguments where- fromString = Arguments . words+data Arguments args+ = ArgumentsText args+ | ArgumentsList args+ deriving (Show, Eq, Ord, Functor) -instance IsList Arguments where- type Item Arguments = String- fromList = Arguments- toList (Arguments ps) = ps+instance IsString (Arguments Text) where+ fromString = ArgumentsText . Text.pack -data CheckArgs = CheckArgs- { checkCommand :: Arguments- , interval :: Maybe Duration- , timeout :: Maybe Duration- , startPeriod :: Maybe Duration- , retries :: Maybe Retries- } deriving (Show, Eq, Ord)+instance IsList (Arguments Text) where+ type Item (Arguments Text) = Text+ fromList = ArgumentsList . Text.unwords+ toList (ArgumentsText ps) = Text.words ps+ toList (ArgumentsList ps) = Text.words ps +data CheckArgs args = CheckArgs+ { checkCommand :: !(Arguments args)+ , interval :: !(Maybe Duration)+ , timeout :: !(Maybe Duration)+ , startPeriod :: !(Maybe Duration)+ , retries :: !(Maybe Retries)+ } deriving (Show, Eq, Ord, Functor) -type Pairs = [(String, String)]+type Pairs = [(Text, Text)] -- | All commands available in Dockerfiles-data Instruction- = From BaseImage- | Add AddArgs- | User String- | Label Pairs- | Stopsignal String- | Copy CopyArgs- | Run Arguments- | Cmd Arguments- | Shell Arguments- | Workdir Directory- | Expose Ports- | Volume String- | Entrypoint Arguments- | Maintainer String- | Env Pairs- | Arg String- (Maybe String)- | Healthcheck Check- | Comment String- | OnBuild Instruction- deriving (Eq, Ord, Show)+data Instruction args+ = From !BaseImage+ | Add !AddArgs+ | User !Text+ | Label !Pairs+ | Stopsignal !Text+ | Copy !CopyArgs+ | Run !(Arguments args)+ | Cmd !(Arguments args)+ | Shell !(Arguments args)+ | Workdir !Directory+ | Expose !Ports+ | Volume !Text+ | Entrypoint !(Arguments args)+ | Maintainer !Text+ | Env !Pairs+ | Arg !Text+ !(Maybe Text)+ | Healthcheck !(Check args)+ | Comment !Text+ | OnBuild !(Instruction args)+ deriving (Eq, Ord, Show, Functor) -type Filename = String+type Filename = Text type Linenumber = Int -- | 'Instruction' with additional location information required for creating -- good check messages-data InstructionPos = InstructionPos- { instruction :: Instruction- , sourcename :: Filename- , lineNumber :: Linenumber- } deriving (Eq, Ord, Show)+data InstructionPos args = InstructionPos+ { instruction :: !(Instruction args)+ , sourcename :: !Filename+ , lineNumber :: !Linenumber+ } deriving (Eq, Ord, Show, Functor)
src/Language/Docker/Syntax/Lift.hs view
@@ -2,18 +2,22 @@ module Language.Docker.Syntax.Lift where +import qualified Data.ByteString as ByteString import Data.Fixed (Fixed) import Data.List.NonEmpty (NonEmpty)+import qualified Data.Text as Text import Data.Time.Clock (DiffTime) import Language.Haskell.TH.Lift import Language.Haskell.TH.Syntax ()-import qualified Data.ByteString as ByteString import Language.Docker.Syntax instance Lift ByteString.ByteString where- lift b = [| ByteString.pack $(lift $ ByteString.unpack b) |]+ lift b = [|ByteString.pack $(lift $ ByteString.unpack b)|] +instance Lift Text.Text where+ lift b = [|Text.pack $(lift $ Text.unpack b)|]+ deriveLift ''NonEmpty deriveLift ''Fixed@@ -31,6 +35,8 @@ deriveLift ''Image deriveLift ''ImageAlias++deriveLift ''Tag deriveLift ''BaseImage
test/Language/Docker/EDSL/QuasiSpec.hs view
@@ -16,10 +16,10 @@ let df = map instruction [dockerfile| FROM node RUN apt-get update- CMD node something.js+ CMD ["node", "something.js"] |] df `shouldBe` [ From (UntaggedImage "node" Nothing)- , Run ["apt-get", "update"]+ , Run "apt-get update" , Cmd ["node", "something.js"] ] @@ -35,6 +35,6 @@ df = map instruction (toDockerfile d) df `shouldBe` [ From (UntaggedImage "node" (Just $ ImageAlias "node-build")) , Expose (Ports [Port 8080 TCP, PortStr "$PORT"])- , Run ["apt-get", "update"]- , Cmd ["node", "something.js"]+ , Run "apt-get update"+ , Cmd "node something.js" ]
test/Language/Docker/EDSLSpec.hs view
@@ -11,7 +11,13 @@ import System.FilePath import System.FilePath.Glob import Test.Hspec+import qualified Data.Text.Lazy as L+import qualified Data.Text as Text+import Data.Semigroup ((<>)) +printed :: [L.Text] -> L.Text+printed = L.unlines+ spec :: Spec spec = do describe "toDockerfile s" $@@ -19,7 +25,9 @@ let r = map Syntax.instruction $ toDockerfile (do from "node" cmdArgs ["node", "-e", "'console.log(\'hey\')'"])- r `shouldBe` [ Syntax.From $ (Syntax.UntaggedImage "node") Nothing+ r `shouldBe` [ Syntax.From $+ Syntax.UntaggedImage "node"+ Nothing , Syntax.Cmd ["node", "-e", "'console.log(\'hey\')'"] ] @@ -31,7 +39,7 @@ entrypoint ["/tini", "--"] cmdArgs ["node", "-e", "'console.log(\'hey\')'"] healthcheck $ check "curl -f http://localhost/ || exit 1" `interval` 300)- r `shouldBe` unlines [ "FROM node"+ r `shouldBe` printed [ "FROM node" , "SHELL [\"cmd\", \"/S\"]" , "ENTRYPOINT [\"/tini\", \"--\"]" , "CMD [\"node\", \"-e\", \"'console.log(\'hey\')'\"]"@@ -43,7 +51,7 @@ expose $ ports [variablePort "PORT", tcpPort 80, udpPort 51] expose $ ports [portRange 90 100] expose $ ports [udpPortRange 190 200])- r `shouldBe` unlines [ "FROM scratch"+ r `shouldBe` printed [ "FROM scratch" , "EXPOSE $PORT 80/tcp 51/udp" , "EXPOSE 90-100" , "EXPOSE 190-200/udp"@@ -56,7 +64,7 @@ onBuild $ do run "echo \"hello world\"" run "echo \"hello world2\""- r `shouldBe` unlines [ "FROM node"+ r `shouldBe` printed [ "FROM node" , "CMD [\"node\", \"-e\", \"'console.log(\'hey\')'\"]" , "ONBUILD RUN echo \"hello world\"" , "ONBUILD RUN echo \"hello world2\""@@ -66,7 +74,7 @@ let r = prettyPrint $ toDockerfile $ do from $ "node" `tagged` "10.1" `aliased` "node-build" run "echo foo"- r `shouldBe` unlines [ "FROM node:10.1 AS node-build"+ r `shouldBe` printed [ "FROM node:10.1 AS node-build" , "RUN echo foo" ] @@ -78,7 +86,7 @@ copy $ ["foo.js", "bar.js"] `to` "baz/" copy $ ["something"] `to` "crazy" `fromStage` "builder" copy $ ["this"] `to` "that" `fromStage` "builder" `ownedBy` "www-data"- r `shouldBe` unlines [ "FROM scratch"+ r `shouldBe` printed [ "FROM scratch" , "COPY foo.js bar.js" , "COPY foo.js bar.js ./" , "COPY foo.js bar.js baz/"@@ -86,17 +94,18 @@ , "COPY --chown=www-data --from=builder this that" ] - describe "toDockerfileStrIO" $+ describe "toDockerfileTextIO" $ it "let's us run in the IO monad" $ do -- TODO - "glob" is a really useful combinator- str <- toDockerfileStrIO $ do+ str <- toDockerfileTextIO $ do fs <- liftIO $ do cwd <- getCurrentDirectory fs <- glob "./test/Language/Docker/*.hs" return (map (makeRelative cwd) (sort fs)) from "ubuntu"- mapM_ (\f -> add [Syntax.SourcePath f] (Syntax.TargetPath $ "/app/" ++ takeFileName f)) fs- str `shouldBe` unlines [ "FROM ubuntu"+ let file = Text.pack . takeFileName+ mapM_ (\f -> add [Syntax.SourcePath (Text.pack f)] (Syntax.TargetPath $ "/app/" <> file f)) fs+ str `shouldBe` printed [ "FROM ubuntu" , "ADD ./test/Language/Docker/EDSLSpec.hs /app/EDSLSpec.hs" , "ADD ./test/Language/Docker/ExamplesSpec.hs /app/ExamplesSpec.hs" , "ADD ./test/Language/Docker/ParserSpec.hs /app/ParserSpec.hs"
test/Language/Docker/ParserSpec.hs view
@@ -9,7 +9,8 @@ import Test.HUnit hiding (Label) import Test.Hspec-import Text.Parsec+import Text.Megaparsec hiding (Label)+import qualified Data.Text as Text spec :: Spec spec = do@@ -52,7 +53,7 @@ it "parse space separated label" $ assertAst "LABEL foo bar baz" [Label[("foo", "bar baz")]] it "parse quoted labels" $ assertAst "LABEL \"foo bar\"=baz" [Label[("foo bar", "baz")]] it "parses multiline labels" $- let dockerfile = unlines [ "LABEL foo=bar \\", "hobo=mobo"]+ let dockerfile = Text.unlines [ "LABEL foo=bar \\", "hobo=mobo"] ast = [ Label [("foo", "bar"), ("hobo", "mobo")] ] in assertAst dockerfile ast @@ -76,16 +77,16 @@ let dockerfile = "ENV NODE_VERSION=v5.7.1 DEBIAN_FRONTEND=noninteractive" in assertAst dockerfile [Env[("NODE_VERSION", "v5.7.1"), ("DEBIAN_FRONTEND", "noninteractive")]] it "have envs on multiple lines" $- let dockerfile = unlines [ "FROM busybox"- , "ENV NODE_VERSION=v5.7.1 \\"- , "DEBIAN_FRONTEND=noninteractive"- ]+ let dockerfile = Text.unlines [ "FROM busybox"+ , "ENV NODE_VERSION=v5.7.1 \\"+ , "DEBIAN_FRONTEND=noninteractive"+ ] ast = [ From (UntaggedImage "busybox" Nothing) , Env[("NODE_VERSION", "v5.7.1"), ("DEBIAN_FRONTEND", "noninteractive")] ] in assertAst dockerfile ast it "parses long env over multiple lines" $- let dockerfile = unlines [ "ENV LD_LIBRARY_PATH=\"/usr/lib/\" \\"+ let dockerfile = Text.unlines [ "ENV LD_LIBRARY_PATH=\"/usr/lib/\" \\" , "APACHE_RUN_USER=\"www-data\" APACHE_RUN_GROUP=\"www-data\""] ast = [Env [("LD_LIBRARY_PATH", "/usr/lib/") ,("APACHE_RUN_USER", "www-data")@@ -96,17 +97,17 @@ it "parse single var list" $ assertAst "ENV foo val1 val2 val3 val4" [Env [("foo", "val1 val2 val3 val4")]] it "parses many env lines with an equal sign in the value" $- let dockerfile = unlines [ "ENV TOMCAT_VERSION 9.0.2"- , "ENV TOMCAT_URL foo.com?q=1"- ]+ let dockerfile = Text.unlines [ "ENV TOMCAT_VERSION 9.0.2"+ , "ENV TOMCAT_URL foo.com?q=1"+ ] ast = [ Env [("TOMCAT_VERSION", "9.0.2")] , Env [("TOMCAT_URL", "foo.com?q=1")] ] in assertAst dockerfile ast it "parses many env lines in mixed style" $- let dockerfile = unlines [ "ENV myName=\"John Doe\" myDog=Rex\\ The\\ Dog \\"- , " myCat=fluffy"- ]+ let dockerfile = Text.unlines [ "ENV myName=\"John Doe\" myDog=Rex\\ The\\ Dog \\"+ , " myCat=fluffy"+ ] ast = [ Env [("myName", "John Doe") ,("myDog", "Rex The Dog") ,("myCat", "fluffy")@@ -114,25 +115,31 @@ ] in assertAst dockerfile ast it "parses many env with backslashes" $- let dockerfile = unlines [ "ENV JAVA_HOME=C:\\\\jdk1.8.0_112"- ]+ let dockerfile = Text.unlines [ "ENV JAVA_HOME=C:\\\\jdk1.8.0_112"+ ] ast = [ Env [("JAVA_HOME", "C:\\\\jdk1.8.0_112")] ] in assertAst dockerfile ast describe "parse RUN" $ do it "escaped with space before" $- let dockerfile = unlines ["RUN yum install -y \\ ", "imagemagick \\ ", "mysql"]- in assertAst dockerfile [Run ["yum", "install", "-y", "imagemagick", "mysql"]]+ let dockerfile = Text.unlines ["RUN yum install -y \\", "imagemagick \\", "mysql"]+ in assertAst dockerfile [Run "yum install -y imagemagick mysql"] it "does not choke on unmatched brackets" $- let dockerfile = unlines ["RUN [foo"]- in assertAst dockerfile [Run ["[foo"]]+ let dockerfile = Text.unlines ["RUN [foo"]+ in assertAst dockerfile [Run "[foo"] + it "Distinguishes between text and a list" $+ let dockerfile = Text.unlines [ "RUN echo foo"+ , "RUN [\"echo\", \"foo\"]"+ ]+ in assertAst dockerfile [Run $ ArgumentsText "echo foo", Run $ ArgumentsList "echo foo"]+ describe "parse CMD" $ do- it "one line cmd" $ assertAst "CMD true" [Cmd ["true"]]+ it "one line cmd" $ assertAst "CMD true" [Cmd "true"] it "cmd over several lines" $- assertAst "CMD true \\\n && true" [Cmd ["true", "&&", "true"]]+ assertAst "CMD true \\\n && true" [Cmd "true && true"] it "quoted command params" $ assertAst "CMD [\"echo\", \"1\"]" [Cmd ["echo", "1"]] describe "parse SHELL" $ do@@ -206,34 +213,34 @@ in assertAst maintainerFromProg maintainerFromAst describe "parse # comment " $ do it "multiple comments before run" $- let dockerfile = unlines ["# line 1", "# line 2", "RUN apt-get update"]- in assertAst dockerfile [Comment " line 1", Comment " line 2", Run ["apt-get", "update"]]+ let dockerfile = Text.unlines ["# line 1", "# line 2", "RUN apt-get update"]+ in assertAst dockerfile [Comment " line 1", Comment " line 2", Run "apt-get update"] it "multiple comments after run" $- let dockerfile = unlines ["RUN apt-get update", "# line 1", "# line 2"]+ let dockerfile = Text.unlines ["RUN apt-get update", "# line 1", "# line 2"] in assertAst dockerfile- [Run ["apt-get", "update"], Comment " line 1", Comment " line 2"]+ [Run "apt-get update", Comment " line 1", Comment " line 2"] it "empty comment" $- let dockerfile = unlines ["#", "# Hello"]+ let dockerfile = Text.unlines ["#", "# Hello"] in assertAst dockerfile [Comment "", Comment " Hello"] describe "normalize lines" $ do it "join multiple ENV" $- let dockerfile = unlines [ "FROM busybox"- , "ENV NODE_VERSION=v5.7.1 \\"- , "DEBIAN_FRONTEND=noninteractive"- ]- normalizedDockerfile = unlines [ "FROM busybox"- , "ENV NODE_VERSION=v5.7.1 DEBIAN_FRONTEND=noninteractive\n"+ let dockerfile = Text.unlines [ "FROM busybox"+ , "ENV NODE_VERSION=v5.7.1 \\"+ , "DEBIAN_FRONTEND=noninteractive"+ ]+ normalizedDockerfile = Text.unlines [ "FROM busybox"+ , "ENV NODE_VERSION=v5.7.1 DEBIAN_FRONTEND=noninteractive\n" ] in normalizeEscapedLines dockerfile `shouldBe` normalizedDockerfile it "join escaped lines" $- let dockerfile = unlines ["ENV foo=bar \\", "baz=foz"]- normalizedDockerfile = unlines ["ENV foo=bar baz=foz", ""]+ let dockerfile = Text.unlines ["ENV foo=bar \\", "baz=foz"]+ normalizedDockerfile = Text.unlines ["ENV foo=bar baz=foz", ""] in normalizeEscapedLines dockerfile `shouldBe` normalizedDockerfile it "join long CMD" $ let longEscapedCmd =- unlines+ Text.unlines [ "RUN wget https://download.com/${version}.tar.gz -O /tmp/logstash.tar.gz && \\" , "(cd /tmp && tar zxf logstash.tar.gz && mv logstash-${version} /opt/logstash && \\" , "rm logstash.tar.gz) && \\"@@ -241,102 +248,104 @@ , "/opt/logstash/bin/plugin install contrib)" ] longEscapedCmdExpected =- concat- ([ "RUN wget https://download.com/${version}.tar.gz -O /tmp/logstash.tar.gz && "- , "(cd /tmp && tar zxf logstash.tar.gz && mv logstash-${version} /opt/logstash && "- , "rm logstash.tar.gz) && "- , "(cd /opt/logstash && "+ Text.concat+ [ "RUN wget https://download.com/${version}.tar.gz -O /tmp/logstash.tar.gz && "+ , "(cd /tmp && tar zxf logstash.tar.gz && mv logstash-${version} /opt/logstash && "+ , "rm logstash.tar.gz) && "+ , "(cd /opt/logstash && " , "/opt/logstash/bin/plugin install contrib)\n" , "\n" , "\n" , "\n" , "\n"- ] :: [String])+ ] in normalizeEscapedLines longEscapedCmd `shouldBe` longEscapedCmdExpected describe "expose" $ do- it "should handle number ports" $ do+ it "should handle number ports" $ let content = "EXPOSE 8080"- parse expose "" content `shouldBe` Right (Expose (Ports [Port 8080 TCP]))- it "should handle many number ports" $ do+ in assertAst content [Expose (Ports [Port 8080 TCP])]+ it "should handle many number ports" $ let content = "EXPOSE 8080 8081"- parse expose "" content `shouldBe` Right (Expose (Ports [Port 8080 TCP, Port 8081 TCP]))- it "should handle ports with protocol" $ do+ in assertAst content [Expose (Ports [Port 8080 TCP, Port 8081 TCP])]+ it "should handle ports with protocol" $ let content = "EXPOSE 8080/TCP 8081/UDP"- parse expose "" content `shouldBe` Right (Expose (Ports [Port 8080 TCP, Port 8081 UDP]))- it "should handle ports with protocol and variables" $ do+ in assertAst content [Expose (Ports [Port 8080 TCP, Port 8081 UDP])]+ it "should handle ports with protocol and variables" $ let content = "EXPOSE $PORT 8080 8081/UDP"- parse expose "" content `shouldBe` Right (Expose (Ports [PortStr "$PORT", Port 8080 TCP, Port 8081 UDP]))- it "should handle port ranges" $ do+ in assertAst content [Expose (Ports [PortStr "$PORT", Port 8080 TCP, Port 8081 UDP])]+ it "should handle port ranges" $ let content = "EXPOSE 80 81 8080-8085"- parse expose "" content `shouldBe` Right (Expose (Ports [Port 80 TCP, Port 81 TCP, PortRange 8080 8085 TCP]))- it "should handle udp port ranges" $ do+ in assertAst content [Expose (Ports [Port 80 TCP, Port 81 TCP, PortRange 8080 8085 TCP])]+ it "should handle udp port ranges" $ let content = "EXPOSE 80 81 8080-8085/udp"- parse expose "" content `shouldBe` Right (Expose (Ports [Port 80 TCP, Port 81 TCP, PortRange 8080 8085 UDP]))+ in assertAst content [Expose (Ports [Port 80 TCP, Port 81 TCP, PortRange 8080 8085 UDP])] describe "syntax" $ do- it "should handle lowercase instructions (#7 - https://github.com/beijaflor-io/haskell-language-dockerfile/issues/7)" $ do+ it "should handle lowercase instructions (#7 - https://github.com/beijaflor-io/haskell-language-dockerfile/issues/7)" $ let content = "from ubuntu"- parse dockerfile "" content `shouldBe` Right [InstructionPos (From (UntaggedImage "ubuntu" Nothing)) "" 1]+ in assertAst content [From (UntaggedImage "ubuntu" Nothing)] describe "ADD" $ do it "simple ADD" $- let file = unlines ["ADD . /app", "ADD http://foo.bar/baz ."]+ let file = Text.unlines ["ADD . /app", "ADD http://foo.bar/baz ."] in assertAst file [ Add $ AddArgs [SourcePath "."] (TargetPath "/app") NoChown , Add $ AddArgs [SourcePath "http://foo.bar/baz"] (TargetPath ".") NoChown ] it "multifiles ADD" $- let file = unlines ["ADD foo bar baz /app"]+ let file = Text.unlines ["ADD foo bar baz /app"] in assertAst file [ Add $ AddArgs (fmap SourcePath ["foo", "bar", "baz"]) (TargetPath "/app") NoChown ] it "list of quoted files" $- let file = unlines ["ADD [\"foo\", \"bar\", \"baz\", \"/app\"]"]+ let file = Text.unlines ["ADD [\"foo\", \"bar\", \"baz\", \"/app\"]"] in assertAst file [ Add $ AddArgs (fmap SourcePath ["foo", "bar", "baz"]) (TargetPath "/app") NoChown ] it "with chown flag" $- let file = unlines ["ADD --chown=root:root foo bar"]+ let file = Text.unlines ["ADD --chown=root:root foo bar"] in assertAst file [ Add $ AddArgs (fmap SourcePath ["foo"]) (TargetPath "bar") (Chown "root:root") ] it "list of quoted files and chown" $- let file = unlines ["ADD --chown=user:group [\"foo\", \"bar\", \"baz\", \"/app\"]"]+ let file = Text.unlines ["ADD --chown=user:group [\"foo\", \"bar\", \"baz\", \"/app\"]"] in assertAst file [ Add $ AddArgs (fmap SourcePath ["foo", "bar", "baz"]) (TargetPath "/app") (Chown "user:group") ] describe "COPY" $ do it "simple COPY" $- let file = unlines ["COPY . /app", "COPY baz /some/long/path"]+ let file = Text.unlines ["COPY . /app", "COPY baz /some/long/path"] in assertAst file [ Copy $ CopyArgs [SourcePath "."] (TargetPath "/app") NoChown NoSource , Copy $ CopyArgs [SourcePath "baz"] (TargetPath "/some/long/path") NoChown NoSource ] it "multifiles COPY" $- let file = unlines ["COPY foo bar baz /app"]+ let file = Text.unlines ["COPY foo bar baz /app"] in assertAst file [ Copy $ CopyArgs (fmap SourcePath ["foo", "bar", "baz"]) (TargetPath "/app") NoChown NoSource ] it "list of quoted files" $- let file = unlines ["COPY [\"foo\", \"bar\", \"baz\", \"/app\"]"]+ let file = Text.unlines ["COPY [\"foo\", \"bar\", \"baz\", \"/app\"]"] in assertAst file [ Copy $ CopyArgs (fmap SourcePath ["foo", "bar", "baz"]) (TargetPath "/app") NoChown NoSource ] it "with chown flag" $- let file = unlines ["COPY --chown=user:group foo bar"]+ let file = Text.unlines ["COPY --chown=user:group foo bar"] in assertAst file [ Copy $ CopyArgs (fmap SourcePath ["foo"]) (TargetPath "bar") (Chown "user:group") NoSource ] it "with from flag" $- let file = unlines ["COPY --from=node foo bar"]+ let file = Text.unlines ["COPY --from=node foo bar"] in assertAst file [ Copy $ CopyArgs (fmap SourcePath ["foo"]) (TargetPath "bar") NoChown (CopySource "node") ] it "with both flags" $- let file = unlines ["COPY --from=node --chown=user:group foo bar"]+ let file = Text.unlines ["COPY --from=node --chown=user:group foo bar"] in assertAst file [ Copy $ CopyArgs (fmap SourcePath ["foo"]) (TargetPath "bar") (Chown "user:group") (CopySource "node") ] it "with both flags in different order" $- let file = unlines ["COPY --chown=user:group --from=node foo bar"]+ let file = Text.unlines ["COPY --chown=user:group --from=node foo bar"] in assertAst file [ Copy $ CopyArgs (fmap SourcePath ["foo"]) (TargetPath "bar") (Chown "user:group") (CopySource "node") ]++assertAst :: HasCallStack => Text.Text -> [Instruction Text.Text] -> Assertion assertAst s ast =- case parseString (s ++ "\n") of- Left err -> assertFailure $ show err+ case parseText s of+ Left err -> assertFailure $ parseErrorPretty err Right dockerfile -> assertEqual "ASTs are not equal" ast $ map instruction dockerfile