language-docker 2.0.1 → 3.0.0

raw patch · 12 files changed

+289/−62 lines, 12 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• README.md +5/−3
• language-docker.cabal +2/−2
• src/Language/Docker.hs +8/−1
• src/Language/Docker/EDSL.hs +149/−23
• src/Language/Docker/EDSL/Types.hs +6/−5
• src/Language/Docker/Parser.hs +15/−5
• src/Language/Docker/PrettyPrint.hs +18/−9
• src/Language/Docker/Syntax.hs +44/−3
• src/Language/Docker/Syntax/Lift.hs +6/−0
• test/Language/Docker/EDSL/QuasiSpec.hs +2/−1
• test/Language/Docker/EDSLSpec.hs +17/−1
• test/Language/Docker/ParserSpec.hs +17/−9

@@ -110,15 +110,17 @@ import qualified System.Directory     as Directory import qualified System.FilePath      as FilePath import qualified System.FilePath.Glob as Glob-import Data.String (fromString)+import Data.List.NonEmpty (fromList)+ main = do     str <- toDockerfileStrIO $ do         fs <- liftIO $ do             cwd <- Directory.getCurrentDirectory             fs <- Glob.glob "./test/*.hs"-            return (map (FilePath.makeRelative cwd) fs)+	    let relativeFiles = map (FilePath.makeRelative cwd) fs+            return (fromList relativeFiles)         from "ubuntu"-	mapM_ (\f -> add [fromString f] (fromString $ "/app/" ++ takeFileName f)) fs+	copy $ (toSources fs) `to` "/app/"     putStr str ``` 

@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: fb162f741f166683adaef8b45dca1eb857c508babbbb8de4977c9634b0e85e8f+-- hash: e8cfea2aac29c979db723d52ddb6f2d6db1d5fdb3166ddc8f77daeab9c1142e0  name:           language-docker-version:        2.0.1+version:        3.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.

@@ -25,6 +25,12 @@     , Language.Docker.EDSL.label     , Language.Docker.EDSL.stopSignal     , Language.Docker.EDSL.copy+    , Language.Docker.EDSL.copyFromStage+    , Language.Docker.EDSL.to+    , Language.Docker.EDSL.fromStage+    , Language.Docker.EDSL.ownedBy+    , Language.Docker.EDSL.toSources+    , Language.Docker.EDSL.toTarget     , Language.Docker.EDSL.run     , Language.Docker.EDSL.runArgs     , Language.Docker.EDSL.cmd@@ -70,7 +76,8 @@     , Language.Docker.Syntax.AddArgs(..)     , Language.Docker.Syntax.Check(..)     , Language.Docker.Syntax.CheckArgs(..)-    , Language.Docker.Syntax.Image+    , Language.Docker.Syntax.Image(..)+    , Language.Docker.Syntax.Registry(..)     , Language.Docker.Syntax.ImageAlias(..)     , Language.Docker.Syntax.Tag     , Language.Docker.Syntax.Ports

@@ -1,5 +1,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE TemplateHaskell #-}  module Language.Docker.EDSL where@@ -10,6 +13,7 @@ import Control.Monad.Writer import Data.ByteString (ByteString) import Data.List.NonEmpty (NonEmpty)+import Data.String (fromString)  import qualified Language.Docker.PrettyPrint as PrettyPrint import qualified Language.Docker.Syntax as Syntax@@ -85,28 +89,53 @@ -- 'Language.Docker.PrettyPrint' -- -- @--- import           Language.Docker+-- import Language.Docker -- -- main :: IO () -- main = writeFile "something.dockerfile" $ toDockerfileStr $ do --     from (tagged "fpco/stack-build" "lts-6.9") --     add ["."] "/app/language-docker" --     workdir "/app/language-docker"---     run (words "stack build --test --only-dependencies")---     cmd (words "stack test")+--     run "stack build --test --only-dependencies"+--     cmd "stack test" -- @ toDockerfileStr :: EDockerfileM a -> String toDockerfileStr = PrettyPrint.prettyPrint . toDockerfile +-- | Use a docker image in a FROM instruction without a tag+--+-- The following two examples are equivalent+--+-- @+-- from $ untagged "fpco/stack-build"+-- @+--+-- Is equivalent to, when having OverloadedStrings:+--+-- @+-- from "fpco/stack-build"+-- @ untagged :: String -> EBaseImage-untagged = flip EUntaggedImage Nothing+untagged = flip EUntaggedImage Nothing . fromString -tagged :: String -> String -> EBaseImage+-- | Use a specific tag for a docker image. This function is meant+-- to be used as an infix operator.+--+-- @+-- from $ "fpco/stack-build" `tagged` "lts-10.3"+-- @+tagged :: Syntax.Image -> String -> EBaseImage tagged imageName tag = ETaggedImage imageName tag Nothing -digested :: String -> ByteString -> EBaseImage+digested :: Syntax.Image -> ByteString -> EBaseImage digested imageName hash = EDigestedImage imageName hash Nothing +-- | Alias a FROM instruction to be used as a build stage.+-- This function is meant to be used as an infix operator.+--+-- @+-- from $ "fpco/stack-build" `aliased` "builder"+-- @ aliased :: EBaseImage -> String -> EBaseImage aliased image alias =     case image of@@ -114,6 +143,118 @@         ETaggedImage n t _ -> ETaggedImage n t (Just $ Syntax.ImageAlias alias)         EDigestedImage n h _ -> EDigestedImage n h (Just $ Syntax.ImageAlias alias) +-- | Create a RUN instruction with the given arguments.+--+-- @+-- run "apt-get install wget"+-- @+run :: MonadFree EInstruction m => Syntax.Arguments -> m ()+run = runArgs++-- | Create an ENTRYPOINT instruction with the given arguments.+--+-- @+-- entrypoint "/usr/local/bin/program --some-flag"+-- @+entrypoint :: MonadFree EInstruction m => Syntax.Arguments -> m ()+entrypoint = entrypointArgs++-- | Create a CMD instruction with the given arguments.+--+-- @+-- cmd "my-program --some-flag"+-- @+cmd :: MonadFree EInstruction m => Syntax.Arguments -> m ()+cmd = cmdArgs++-- | Create a COPY instruction. This function is meant to be+-- used with the compinators 'to', 'fromStage' and 'ownedBy'+--+-- @+-- copy $ ["foo.js", "bar.js"] `to` "."+-- copy $ ["some_file"] `to` "/some/path" `fromStage` "builder"+-- @+copy :: MonadFree EInstruction m => Syntax.CopyArgs -> m ()+copy (Syntax.CopyArgs sources dest ch src) = copyArgs sources dest ch src++-- | Create a COPY instruction from a given build stage.+-- This is a shorthand version of using 'copy' with combinators.+--+-- @+-- copyFromStage "builder" ["foo.js", "bar.js"] "."+-- @+copyFromStage ::+       MonadFree EInstruction m+    => Syntax.CopySource+    -> NonEmpty Syntax.SourcePath+    -> Syntax.TargetPath+    -> m ()+copyFromStage stage source dest = copy $ Syntax.CopyArgs source dest Syntax.NoChown stage++-- | Create an ADD instruction. This is often used as a shorthand version+-- of copy when no extra options are needed. Currently there is no way to+-- pass extra options to ADD, so you are encouraged to use 'copy' instead.+--+-- @+-- add ["foo.js", "bar.js"] "."+-- @+add :: MonadFree EInstruction m => NonEmpty Syntax.SourcePath -> Syntax.TargetPath -> m ()+add sources dest = addArgs sources dest Syntax.NoChown++-- | Converts a NonEmpty list of strings to a NonEmpty list of 'Syntax.SourcePath'+--+-- This is a convenience function when you need to pass a non-static list of+-- strings that you build somewhere as an argument for 'copy' or 'add'+--+-- @+-- someFiles <- glob "*.js"+-- copy $ (toSources someFiles) `to` "."+-- @+toSources :: NonEmpty String -> NonEmpty Syntax.SourcePath+toSources = fmap Syntax.SourcePath++-- | Converts a String into a 'Syntax.TargetPath'+--+-- This is a convenience function when you need to pass a string variable+-- as an argument for 'copy' or 'add'+--+-- @+-- let destination = buildSomePath pwd+-- add ["foo.js"] (toTarget destination)+-- @+toTarget :: String -> Syntax.TargetPath+toTarget = Syntax.TargetPath++-- | Adds the --from= option to a COPY instruction.+--+-- This function is meant to be used as an infix operator:+--+-- @+-- copy $ ["foo.js"] `to` "." `fromStage` "builder"+-- @+fromStage :: Syntax.CopyArgs -> Syntax.CopySource -> Syntax.CopyArgs+fromStage args src = args {Syntax.sourceFlag = src}++-- | Adds the --chown= option to a COPY instruction.+--+-- This function is meant to be used as an infix operator:+--+-- @+-- copy $ ["foo.js"] `to` "." `ownedBy` "www-data:www-data"+-- @+ownedBy :: Syntax.CopyArgs -> Syntax.Chown -> Syntax.CopyArgs+ownedBy args owner = args {Syntax.chownFlag = owner}++-- | Usedto join source paths with atarget path as an arguments for 'copy'+--+-- This function is meant to be used as an infix operator:+--+-- @+-- copy $ ["foo.js"] `to` "." `ownedBy`+-- @+to :: NonEmpty Syntax.SourcePath -> Syntax.TargetPath -> Syntax.CopyArgs+to sources dest = Syntax.CopyArgs sources dest Syntax.NoChown Syntax.NoSource+ ports :: [Syntax.Port] -> Syntax.Ports ports = Syntax.Ports @@ -129,26 +270,11 @@ portRange :: Integer -> Integer -> Syntax.Port portRange = Syntax.PortRange -run :: MonadFree EInstruction m => String -> m ()-run = runArgs . words--entrypoint :: MonadFree EInstruction m => String -> m ()-entrypoint = entrypointArgs . words--cmd :: MonadFree EInstruction m => String -> m ()-cmd = cmdArgs . words--copy :: MonadFree EInstruction m => NonEmpty Syntax.SourcePath -> Syntax.TargetPath -> m ()-copy sources dest = copyArgs sources dest Syntax.NoChown Syntax.NoSource--add :: MonadFree EInstruction m => NonEmpty Syntax.SourcePath -> Syntax.TargetPath -> m ()-add sources dest = addArgs sources dest Syntax.NoChown--check :: String -> Syntax.Check+check :: Syntax.Arguments -> Syntax.Check check command =     Syntax.Check         Syntax.CheckArgs-        { Syntax.checkCommand = words command+        { Syntax.checkCommand = command         , Syntax.interval = Nothing         , Syntax.timeout = Nothing         , Syntax.startPeriod = Nothing

@@ -8,18 +8,18 @@ import qualified Language.Docker.Syntax as Syntax  data EBaseImage-    = EUntaggedImage String+    = EUntaggedImage Syntax.Image                      (Maybe Syntax.ImageAlias)-    | ETaggedImage String+    | ETaggedImage Syntax.Image                    String                    (Maybe Syntax.ImageAlias)-    | EDigestedImage String+    | EDigestedImage Syntax.Image                      ByteString                      (Maybe Syntax.ImageAlias)     deriving (Show, Eq, Ord)  instance IsString EBaseImage where-    fromString = flip EUntaggedImage Nothing+    fromString = flip EUntaggedImage Nothing . fromString  data EInstruction next     = From EBaseImage@@ -57,7 +57,8 @@                  next     | Env Syntax.Pairs           next-    | Arg String (Maybe String)+    | Arg String+          (Maybe String)           next     | Comment String               next

@@ -32,13 +32,20 @@     text <- many (noneOf "\n")     return $ Comment text +registry :: Parser Registry+registry = do+    name <- many1 (noneOf "\t\n /")+    void $ char '/'+    return $ Registry name+ taggedImage :: Parser BaseImage taggedImage = do+    registryName <- (Just <$> try registry) <|> return Nothing     name <- many (noneOf "\t\n: ")     void $ char ':'     tag <- many1 (noneOf "\t\n: ")     maybeAlias <- maybeImageAlias-    return $ TaggedImage name tag maybeAlias+    return $ TaggedImage (Image registryName name) tag maybeAlias  digestedImage :: Parser BaseImage digestedImage = do@@ -46,15 +53,16 @@     void $ char '@'     digest <- many1 (noneOf "\t\n@ ")     maybeAlias <- maybeImageAlias-    return $ DigestedImage name (pack digest) maybeAlias+    return $ DigestedImage (Image Nothing name) (pack digest) maybeAlias  untaggedImage :: Parser BaseImage untaggedImage = do+    registryName <- (Just <$> try registry) <|> return Nothing     name <- many (noneOf "\n\t:@ ")     notInvalidTag name     notInvalidDigest name     maybeAlias <- maybeImageAlias-    return $ UntaggedImage name maybeAlias+    return $ UntaggedImage (Image registryName name) maybeAlias   where     notInvalidTag :: String -> Parser ()     notInvalidTag name =@@ -327,13 +335,15 @@  -- Parse arguments of a command in the exec form argumentsExec :: Parser Arguments-argumentsExec = brackets $ commaSep stringLiteral+argumentsExec = do+  args <- brackets $ commaSep stringLiteral+  return $ Arguments args  -- Parse arguments of a command in the shell form argumentsShell :: Parser Arguments argumentsShell = do     args <- untilEol-    return $ words args+    return $ Arguments (words args)  arguments :: Parser Arguments arguments = try argumentsExec <|> try argumentsShell

@@ -8,7 +8,7 @@  import qualified Data.ByteString.Char8 as ByteString (unpack) import Data.List (foldl', intersperse)-import Data.List.NonEmpty (NonEmpty, toList)+import Data.List.NonEmpty as NonEmpty (NonEmpty(..), toList) import Data.String import Language.Docker.Syntax import Prelude hiding ((>>), (>>=), return)@@ -29,19 +29,23 @@ prettyPrintInstructionPos :: InstructionPos -> String prettyPrintInstructionPos (InstructionPos i _ _) = render (prettyPrintInstruction i) +prettyPrintImage :: Image -> Doc+prettyPrintImage (Image Nothing name) = text name+prettyPrintImage (Image (Just (Registry reg)) name) = text reg <> char '/' <> text name+ prettyPrintBaseImage :: BaseImage -> Doc prettyPrintBaseImage b =     case b of-        DigestedImage name digest alias -> do-            text name+        DigestedImage img digest alias -> do+            prettyPrintImage img             char '@'             text (ByteString.unpack digest)             prettyAlias alias-        UntaggedImage name alias -> do+        UntaggedImage (Image _ name) alias -> do             text name             prettyAlias alias-        TaggedImage name tag alias -> do-            text name+        TaggedImage img tag alias -> do+            prettyPrintImage img             char ':'             text tag             prettyAlias alias@@ -60,13 +64,13 @@ prettyPrintPair (k, v) = text k <> char '=' <> text (show v)  prettyPrintArguments :: Arguments -> Doc-prettyPrintArguments as = text (unwords (map helper as))+prettyPrintArguments (Arguments as) = text (unwords (map helper as))   where     helper "&&" = "\\\n &&"     helper a = a  prettyPrintJSON :: Arguments -> Doc-prettyPrintJSON as = brackets $ hsep $ intersperse comma $ map (doubleQuotes . text) as+prettyPrintJSON (Arguments as) = brackets $ hsep $ intersperse comma $ map (doubleQuotes . text) as  prettyPrintPort :: Port -> Doc prettyPrintPort (PortStr str) = text str@@ -76,7 +80,12 @@  prettyPrintFileList :: NonEmpty SourcePath -> TargetPath -> Doc prettyPrintFileList sources (TargetPath dest) =-    hsep $ [text s | SourcePath s <- toList sources] ++ [text dest]+    let ending =+            case (reverse dest, sources) of+                ('/':_, _) -> "" -- 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]  prettyPrintChown :: Chown -> Doc prettyPrintChown chown =

@@ -4,13 +4,31 @@ module Language.Docker.Syntax where  import Data.ByteString.Char8 (ByteString)+import Data.List (intercalate, isInfixOf) import Data.List.NonEmpty (NonEmpty)-import Data.String (IsString)+import Data.List.Split (endBy)+import Data.String (IsString(..)) import Data.Time.Clock (DiffTime) import GHC.Exts (IsList(..)) -type Image = String+data Image = Image+    { registryName :: Maybe Registry+    , imageName :: String+    } deriving (Show, Eq, Ord) +instance IsString Image where+    fromString img =+        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++newtype Registry =+    Registry String+    deriving (Show, Eq, Ord, IsString)+ type Tag = String  data Protocol@@ -68,11 +86,23 @@     | NoChown     deriving (Show, Eq, Ord) +instance IsString Chown where+    fromString ch =+        case ch of+            "" -> NoChown+            _ -> Chown ch+ data CopySource     = CopySource String     | NoSource     deriving (Show, Eq, Ord) +instance IsString CopySource where+    fromString src =+        case src of+            "" -> NoSource+            _ -> CopySource src+ newtype Duration = Duration     { durationTime :: DiffTime     } deriving (Show, Eq, Ord, Num)@@ -99,6 +129,18 @@     | NoCheck     deriving (Show, Eq, Ord) +newtype Arguments =+    Arguments [String]+    deriving (Show, Eq, Ord)++instance IsString Arguments where+  fromString = Arguments . words++instance IsList Arguments where+    type Item Arguments = String+    fromList = Arguments+    toList (Arguments ps) = ps+ data CheckArgs = CheckArgs     { checkCommand :: Arguments     , interval :: Maybe Duration@@ -107,7 +149,6 @@     , retries :: Maybe Retries     } deriving (Show, Eq, Ord) -type Arguments = [String]  type Pairs = [(String, String)] 

@@ -23,9 +23,15 @@  deriveLift ''Ports +deriveLift ''Registry++deriveLift ''Image+ deriveLift ''ImageAlias  deriveLift ''BaseImage++deriveLift ''Arguments  deriveLift ''Instruction 

@@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes       #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE QuasiQuotes #-} module Language.Docker.EDSL.QuasiSpec   where 

@@ -60,10 +60,26 @@          it "parses and prints from aliases correctly" $ do             let r = prettyPrint $ toDockerfile $ do-                        from ("node" `tagged` "10.1" `aliased` "node-build")+                        from $ "node" `tagged` "10.1" `aliased` "node-build"                         run "echo foo"             r `shouldBe` unlines [ "FROM node:10.1 AS node-build"                                  , "RUN echo foo"+                                 ]++        it "parses and prints copy instructions" $ do+            let r = prettyPrint $ toDockerfile $ do+                        from "scratch"+                        copy $ ["foo.js"] `to` "bar.js"+                        copy $ ["foo.js", "bar.js"] `to` "."+                        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"+                                 , "COPY foo.js bar.js"+                                 , "COPY foo.js bar.js ./"+                                 , "COPY foo.js bar.js baz/"+                                 , "COPY --from=builder something crazy"+                                 , "COPY --chown=www-data --from=builder this that"                                  ]      describe "toDockerfileStrIO" $

@@ -39,6 +39,14 @@             it "parse diggested image" $                 assertAst "FROM ubuntu@sha256:0ef2e08ed3fab AS foo" [From (DigestedImage "ubuntu" "sha256:0ef2e08ed3fab" (Just $ ImageAlias "foo"))] +        describe "parse FROM with registry" $ do+            it "registry without port" $+                assertAst "FROM foo.com/node" [From (UntaggedImage (Image (Just "foo.com") "node") Nothing)]+            it "parse with port and tag" $+                assertAst+                "FROM myregistry.com:5000/imagename:5.12-dev"+                [From (TaggedImage (Image (Just "myregistry.com:5000") "imagename") "5.12-dev" Nothing)]+         describe "parse LABEL" $ do             it "parse label" $ assertAst "LABEL foo=bar" [Label[("foo", "bar")]]             it "parse space separated label" $ assertAst "LABEL foo bar baz" [Label[("foo", "bar baz")]]@@ -137,7 +145,7 @@                 "HEALTHCHECK --interval=5m \\\nCMD curl -f http://localhost/"                 [Healthcheck $                     Check $-                      CheckArgs (words "curl -f http://localhost/") (Just $ fromInteger 300) Nothing Nothing Nothing+                      CheckArgs "curl -f http://localhost/" (Just 300) Nothing Nothing Nothing                 ]              it "parse healthcheck with retries" $@@ -145,7 +153,7 @@                 "HEALTHCHECK --retries=10 CMD curl -f http://localhost/"                 [Healthcheck $                     Check $-                      CheckArgs (words "curl -f http://localhost/") Nothing Nothing Nothing (Just $ Retries 10)+                      CheckArgs "curl -f http://localhost/" Nothing Nothing Nothing (Just $ Retries 10)                 ]              it "parse healthcheck with timeout" $@@ -153,7 +161,7 @@                 "HEALTHCHECK --timeout=10s CMD curl -f http://localhost/"                 [Healthcheck $                     Check $-                      CheckArgs (words "curl -f http://localhost/") Nothing (Just $ fromInteger 10) Nothing Nothing+                      CheckArgs "curl -f http://localhost/" Nothing (Just 10) Nothing Nothing                 ]              it "parse healthcheck with start-period" $@@ -161,7 +169,7 @@                 "HEALTHCHECK --start-period=2m CMD curl -f http://localhost/"                 [Healthcheck $                     Check $-                      CheckArgs (words "curl -f http://localhost/") Nothing Nothing (Just $ fromInteger 120) Nothing+                      CheckArgs "curl -f http://localhost/" Nothing Nothing (Just 120) Nothing                 ]              it "parse healthcheck with all flags" $@@ -170,10 +178,10 @@                 [Healthcheck $                     Check $                       CheckArgs-                        (words "curl -f http://localhost/")-                        (Just $ fromInteger 5)-                        (Just $ fromInteger 60)-                        (Just $ fromInteger 2)+                        "curl -f http://localhost/"+                        (Just 5)+                        (Just 60)+                        (Just 2)                         (Just $ Retries 3)                 ] @@ -182,7 +190,7 @@                 "HEALTHCHECK CMD curl -f http://localhost/"                 [Healthcheck $                     Check $-                      CheckArgs (words "curl -f http://localhost/") Nothing Nothing Nothing Nothing+                      CheckArgs "curl -f http://localhost/" Nothing Nothing Nothing Nothing                 ]          describe "parse MAINTAINER" $ do