Merge pull request #25 from hadolint/improve-edsl

Improved the edsl for copy and entrypoint

README.md

@@ -110,15 +110,17 @@ import           Language.Docker
 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
 ```
 

src/Language/Docker.hs

@@ -25,6 +25,12 @@ module Language.Docker
     , 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

src/Language/Docker/EDSL.hs

@@ -1,6 +1,8 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE TemplateHaskell #-}
 
 module Language.Docker.EDSL where
@@ -87,35 +89,172 @@ toDockerfile e =
 -- '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 . fromString
 
-tagged :: String -> String -> EBaseImage
-tagged imageName tag = ETaggedImage (fromString imageName) tag Nothing
+-- | 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 imageName hash = EDigestedImage (fromString imageName) hash Nothing
+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
         EUntaggedImage n _ -> EUntaggedImage n (Just $ Syntax.ImageAlias alias)
         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
 
@@ -131,26 +270,11 @@ variablePort varName = Syntax.PortStr ('$' : varName)
 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

src/Language/Docker/Parser.hs

@@ -335,13 +335,15 @@ maintainer = do
 
 -- 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

src/Language/Docker/PrettyPrint.hs

@@ -8,7 +8,7 @@ module Language.Docker.PrettyPrint where
 
 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)
@@ -64,13 +64,13 @@ prettyPrintPair :: (String, String) -> Doc
 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
@@ -80,7 +80,12 @@ prettyPrintPort (Port num UDP) = integer num <> char '/' <> text "udp"
 
 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 =

src/Language/Docker/Syntax.hs

@@ -86,11 +86,23 @@ data Chown
     | 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)
@@ -117,6 +129,18 @@ data Check
     | 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
@@ -125,7 +149,6 @@ data CheckArgs = CheckArgs
     , retries :: Maybe Retries
     } deriving (Show, Eq, Ord)
 
-type Arguments = [String]
 
 type Pairs = [(String, String)]
 

src/Language/Docker/Syntax/Lift.hs

@@ -31,6 +31,8 @@ deriveLift ''ImageAlias
 
 deriveLift ''BaseImage
 
+deriveLift ''Arguments
+
 deriveLift ''Instruction
 
 deriveLift ''InstructionPos

test/Language/Docker/EDSL/QuasiSpec.hs

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