dockerfile-creator (empty) → 0.1.0.0
raw patch · 13 files changed
+1096/−0 lines, 13 filesdep +Globdep +basedep +bytestringsetup-changed
Dependencies added: Glob, base, bytestring, data-default-class, directory, dockerfile-creator, filepath, free, hspec, language-docker, megaparsec, mtl, process, template-haskell, text, th-lift, th-lift-instances, time
Files
- LICENSE +30/−0
- README.md +101/−0
- Setup.hs +2/−0
- dockerfile-creator.cabal +83/−0
- src/Language/Docker/Creator.hs +78/−0
- src/Language/Docker/EDSL.hs +382/−0
- src/Language/Docker/EDSL/Quasi.hs +48/−0
- src/Language/Docker/EDSL/Types.hs +90/−0
- src/Language/Docker/Syntax/Lift.hs +80/−0
- test/Language/Docker/EDSL/QuasiSpec.hs +46/−0
- test/Language/Docker/EDSLSpec.hs +135/−0
- test/Language/Docker/ExamplesSpec.hs +20/−0
- test/Spec.hs +1/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright José Lorenzo Rodríguez (c) 2020++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,101 @@+# dockerfile-composer++Build Dockerfiles using Haskell with an embedded DSL.++- [Writing Dockerfiles in Haskell](#writing-dockerfiles-in-haskell)+- [Using the QuasiQuoter](#using-the-quasiquoter)+- [Templating Dockerfiles in Haskell](#templating-dockerfiles-in-haskell)+- [Using IO in the DSL](#using-io-in-the-dsl)++## Pretty-printing files++```haskell+import Language.Docker+main = do+ Right d <- parseFile "./Dockerfile"+ putStr (prettyPrint d)+```++## Writing Dockerfiles in Haskell++```haskell+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-}+import Language.Docker++main = putDockerfileStr $ do+ from "node"+ run "apt-get update"+ run ["apt-get", "install", "something"]+ -- ...+```++## Using the QuasiQuoter++```haskell+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+import Language.Docker+main = putDockerfileStr $ do+ from "node"+ run "apt-get update"+ [edockerfile|+ RUN apt-get update+ CMD node something.js+ |]+ -- ...+```++## Templating Dockerfiles in Haskell++```haskell+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-}+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+ let cabalFile = packageName ++ ".cabal"+ run "cabal sandbox init"+ run "cabal update"+ add [fromString cabalFile] (fromString $ "/app/" ++ cabalFile)+ run "cabal install --only-dep -j"+ add "." "/app/"+ run "cabal build"+main =+ forM_ tags $ \tag -> do+ let df = toDockerfileText $ do+ from ("haskell" `tagged` tag)+ cabalSandboxBuild "mypackage"+ L.writeFile ("./examples/templating-" ++ tag ++ ".dockerfile") df+```++## Using IO in the DSL+By default the DSL runs in the `Identity` monad. By running in IO we can+support more features like file globbing:++```haskell+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-}+import Language.Docker+import qualified System.Directory as Directory+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 <- toDockerfileTextIO $ do+ fs <- liftIO $ do+ cwd <- Directory.getCurrentDirectory+ fs <- Glob.glob "./test/*.hs"+ let relativeFiles = map (FilePath.makeRelative cwd) fs+ return (fromList relativeFiles)+ from "ubuntu"+ copy $ (toSources fs) `to` "/app/"+ L.putStr str+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ dockerfile-creator.cabal view
@@ -0,0 +1,83 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: 301ffca16b19023e556f9590e046688e1b2da2f00506cf1f5f353972eb71ff45++name: dockerfile-creator+version: 0.1.0.0+description: Embedded DSL to create Dockerfiles using Haskell. Please see the README on GitHub at <https://github.com/hadolint/dockerfile-creator#readme>+homepage: https://github.com/hadolint/dockerfile-creator#readme+bug-reports: https://github.com/hadolint/dockerfile-creator/issues+author: José Loreno Rodríguez+maintainer: jose.zap@gmail.com+copyright: 2020 José Lorenzo Rodríguez+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md++source-repository head+ type: git+ location: https://github.com/hadolint/dockerfile-creator++library+ exposed-modules:+ Language.Docker.Creator+ Language.Docker.EDSL+ Language.Docker.EDSL.Quasi+ other-modules:+ Language.Docker.EDSL.Types+ Language.Docker.Syntax.Lift+ Paths_dockerfile_creator+ hs-source-dirs:+ src+ build-depends:+ base >=4.7 && <5+ , bytestring >=0.10+ , data-default-class+ , free+ , language-docker >=8.1+ , megaparsec >=8.0+ , mtl+ , template-haskell+ , text+ , th-lift+ , th-lift-instances+ , time+ default-language: Haskell2010++test-suite dockerfile-composer-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Language.Docker.EDSL.QuasiSpec+ Language.Docker.EDSLSpec+ Language.Docker.ExamplesSpec+ Paths_dockerfile_creator+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ Glob+ , base >=4.7 && <5+ , bytestring >=0.10+ , data-default-class+ , directory+ , dockerfile-creator+ , filepath+ , free+ , hspec+ , language-docker >=8.1+ , megaparsec >=8.0+ , mtl+ , process+ , template-haskell+ , text+ , th-lift+ , th-lift-instances+ , time+ default-language: Haskell2010
+ src/Language/Docker/Creator.hs view
@@ -0,0 +1,78 @@+module Language.Docker.Creator+ (+ -- * Writting Dockerfiles (@Language.Docker.EDSL@)+ Language.Docker.EDSL.toDockerfileText,+ Language.Docker.EDSL.toDockerfile,+ Language.Docker.EDSL.putDockerfileStr,+ Language.Docker.EDSL.writeDockerFile,+ Language.Docker.EDSL.toDockerfileTextIO,+ Language.Docker.EDSL.toDockerfileIO,+ Language.Docker.EDSL.runDockerfileIO,+ Language.Docker.EDSL.runDockerfileTextIO,+ Control.Monad.IO.Class.liftIO,+ Language.Docker.EDSL.from,++ -- ** Constructing base images+ Language.Docker.EDSL.tagged,+ Language.Docker.EDSL.untagged,+ Language.Docker.EDSL.digested,+ Language.Docker.EDSL.aliased,++ -- ** Syntax+ Language.Docker.EDSL.add,+ Language.Docker.EDSL.user,+ 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,+ Language.Docker.EDSL.cmdArgs,+ Language.Docker.EDSL.healthcheck,+ Language.Docker.EDSL.check,+ Language.Docker.EDSL.interval,+ Language.Docker.EDSL.timeout,+ Language.Docker.EDSL.startPeriod,+ Language.Docker.EDSL.retries,+ Language.Docker.EDSL.workdir,+ Language.Docker.EDSL.expose,+ Language.Docker.EDSL.ports,+ Language.Docker.EDSL.tcpPort,+ Language.Docker.EDSL.udpPort,+ Language.Docker.EDSL.variablePort,+ Language.Docker.EDSL.portRange,+ Language.Docker.EDSL.udpPortRange,+ Language.Docker.EDSL.volume,+ Language.Docker.EDSL.entrypoint,+ Language.Docker.EDSL.entrypointArgs,+ Language.Docker.EDSL.maintainer,+ Language.Docker.EDSL.env,+ Language.Docker.EDSL.arg,+ Language.Docker.EDSL.comment,+ Language.Docker.EDSL.onBuild,+ Language.Docker.EDSL.onBuildRaw,+ Language.Docker.EDSL.embed,+ Language.Docker.EDSL.Quasi.edockerfile,++ -- ** Support types for the EDSL+ Language.Docker.EDSL.EDockerfileM,+ Language.Docker.EDSL.EDockerfileTM,+ Language.Docker.EDSL.Types.EBaseImage (..),++ -- * QuasiQuoter (@Language.Docker.EDSL.Quasi@)+ Language.Docker.EDSL.Quasi.dockerfile,++ -- * Instruction and InstructionPos helpers+ Language.Docker.EDSL.instructionPos,+) where++import qualified Control.Monad.IO.Class+import qualified Language.Docker.EDSL+import qualified Language.Docker.EDSL.Quasi+import qualified Language.Docker.EDSL.Types
+ src/Language/Docker/EDSL.hs view
@@ -0,0 +1,382 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Language.Docker.EDSL where++import Control.Monad.Free+import Control.Monad.Free.TH+import Control.Monad.Trans.Free (FreeT, iterTM)+import Control.Monad.Writer+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as B8+import Data.Default.Class (def)+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 Language.Docker.EDSL.Types+import qualified Language.Docker.PrettyPrint as PrettyPrint+import qualified Language.Docker.Syntax as Syntax++-- | The type of 'Identity' based EDSL blocks+type EDockerfileM = Free EInstruction++-- | The type of free monad EDSL blocks+type EDockerfileTM = FreeT EInstruction++type EInstructionM = Free EInstruction++type EInstructionTM = FreeT EInstruction++makeFree ''EInstruction++runDockerWriter :: (MonadWriter [Syntax.Instruction Text] m) => EDockerfileM a -> m a+runDockerWriter = iterM runD++runDockerWriterIO ::+ (Monad m, MonadTrans t, MonadWriter [Syntax.Instruction Text] (t m)) =>+ EDockerfileTM m a ->+ t m a+runDockerWriterIO = iterTM runD++runDef :: MonadWriter [t] m => (t1 -> t) -> t1 -> m b -> m b+runDef f a n = tell [f a] >> n++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 Text] m => EInstruction (m b) -> m b+runD (From (EBaseImage name t d a p) n) = runDef Syntax.From (Syntax.BaseImage name t d a p) n+runD (CmdArgs as n) = runDef Syntax.Cmd as n+runD (Shell as n) = runDef Syntax.Shell as n+runD (AddArgs s d c n) = runDef Syntax.Add (Syntax.AddArgs s d c) n+runD (User u n) = runDef Syntax.User u n+runD (Label ps n) = runDef Syntax.Label ps n+runD (StopSignal s n) = runDef Syntax.Stopsignal s n+runD (CopyArgs s d c f n) = runDef Syntax.Copy (Syntax.CopyArgs s d c f) n+runD (RunArgs as fs n) = runDef Syntax.Run (Syntax.RunArgs as fs) n+runD (Workdir d n) = runDef Syntax.Workdir d n+runD (Expose ps n) = runDef Syntax.Expose ps n+runD (Volume v n) = runDef Syntax.Volume v n+runD (EntrypointArgs e n) = runDef Syntax.Entrypoint e n+runD (Maintainer m n) = runDef Syntax.Maintainer m n+runD (Env ps n) = runDef Syntax.Env ps n+runD (Arg k v n) = runDef2 Syntax.Arg k v n+runD (Comment c n) = runDef Syntax.Comment c n+runD (Healthcheck c n) = runDef Syntax.Healthcheck c n+runD (OnBuildRaw i n) = runDef Syntax.OnBuild i n+runD (Embed is n) = do+ tell (map Syntax.instruction is)+ n++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+-- or manipulate+toDockerfile :: EDockerfileM a -> Syntax.Dockerfile+toDockerfile e =+ let (_, w) = runWriter (runDockerWriter e)+ in map instructionPos w++-- | runs the Dockerfile EDSL and returns a 'Data.Text.Lazy' using+-- 'Language.Docker.PrettyPrint'+--+-- @+-- import Language.Docker+--+-- main :: IO ()+-- 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"+-- @+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+--+-- @+-- from $ untagged "fpco/stack-build"+-- @+--+-- Is equivalent to, when having OverloadedStrings:+--+-- @+-- from "fpco/stack-build"+-- @+untagged :: Text -> EBaseImage+untagged s = EBaseImage (fromString . Text.unpack $ s) Nothing Nothing Nothing 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 -> Syntax.Tag -> EBaseImage+tagged imageName tag = EBaseImage imageName (Just tag) Nothing Nothing Nothing++-- | Adds a digest checksum so a FROM instruction+-- This function is meant to be used as an infix operator.+--+-- @+-- from $ "fpco/stack-build" `digested` "sha256:abcdef123"+-- @+digested :: EBaseImage -> Syntax.Digest -> EBaseImage+digested (EBaseImage n t _ a p) d = EBaseImage n t (Just d) a p++-- | 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 -> Syntax.ImageAlias -> EBaseImage+aliased (EBaseImage n t d _ p) a = EBaseImage n t d (Just a) p++-- | Create a RUN instruction with the given arguments.+--+-- @+-- run "apt-get install wget"+-- @+run :: MonadFree EInstruction m => Syntax.Arguments Text -> m ()+run as = runArgs as def++-- | Create an ENTRYPOINT instruction with the given arguments.+--+-- @+-- entrypoint "/usr/local/bin/program --some-flag"+-- @+entrypoint :: MonadFree EInstruction m => Syntax.Arguments Text -> m ()+entrypoint = entrypointArgs++-- | Create a CMD instruction with the given arguments.+--+-- @+-- cmd "my-program --some-flag"+-- @+cmd :: MonadFree EInstruction m => Syntax.Arguments Text -> 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 Text -> NonEmpty Syntax.SourcePath+toSources = fmap Syntax.SourcePath++-- | 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'+--+-- @+-- let destination = buildSomePath pwd+-- add ["foo.js"] (toTarget destination)+-- @+toTarget :: Text -> 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++tcpPort :: Int -> Syntax.Port+tcpPort = flip Syntax.Port Syntax.TCP++udpPort :: Int -> Syntax.Port+udpPort = flip Syntax.Port Syntax.UDP++variablePort :: Text -> Syntax.Port+variablePort varName = Syntax.PortStr ("$" <> varName)++portRange :: Int -> Int -> Syntax.Port+portRange a b = Syntax.PortRange a b Syntax.TCP++udpPortRange :: Int -> Int -> Syntax.Port+udpPortRange a b = Syntax.PortRange a b Syntax.UDP++check :: Syntax.Arguments args -> Syntax.Check args+check command =+ Syntax.Check+ Syntax.CheckArgs+ { Syntax.checkCommand = command,+ Syntax.interval = Nothing,+ Syntax.timeout = Nothing,+ Syntax.startPeriod = Nothing,+ Syntax.retries = Nothing+ }++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 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 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 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 args+noCheck = Syntax.NoCheck++-- | ONBUILD Dockerfile instruction+--+-- Each nested instruction gets emitted as a separate @ONBUILD@ block+--+-- @+-- 'toDockerfile' $ do+-- from "node"+-- run "apt-get update"+-- onBuild $ do+-- run "echo more-stuff"+-- run "echo here"+-- @+onBuild :: MonadFree EInstruction m => EDockerfileM a -> m ()+onBuild b = mapM_ (onBuildRaw . Syntax.instruction) (toDockerfile b)++-- | A version of 'toDockerfile' which allows IO actions+toDockerfileIO :: MonadIO m => EDockerfileTM m t -> m Syntax.Dockerfile+toDockerfileIO e = fmap snd (runDockerfileIO 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)+runDockerfileIO e = do+ (r, w) <- runWriterT (runDockerWriterIO e)+ return (r, map instructionPos w)++-- | Runs the EDSL's writer monad and pretty-prints the result+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
@@ -0,0 +1,48 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++module Language.Docker.EDSL.Quasi where++import qualified Data.Text as Text+import Language.Docker.EDSL+import qualified Language.Docker.Parser as Parser+import Language.Docker.Syntax.Lift ()+import Language.Haskell.TH+import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax+import Text.Megaparsec (errorBundlePretty)++-- | Quasiquoter for embedding dockerfiles on the EDSL+--+-- @+-- putStr $ 'toDockerfile' $ do+-- from "node"+-- run "apt-get update"+-- [edockerfile|+-- RUN apt-get update+-- CMD node something.js+-- |]+-- @+edockerfile :: QuasiQuoter+edockerfile = dockerfile {quoteExp = edockerfileE}++edockerfileE :: String -> ExpQ+edockerfileE e =+ case Parser.parseText (Text.pack e) of+ Left err -> fail (errorBundlePretty err)+ Right d -> [|embed d|]++dockerfile :: QuasiQuoter+dockerfile =+ QuasiQuoter+ { quoteExp = dockerfileE,+ quoteDec = error "Can't use Dockerfile as a declaration",+ quotePat = error "Can't use Dockerfile as a pattern",+ quoteType = error "Can't use Dockerfile as a type"+ }++dockerfileE :: String -> ExpQ+dockerfileE e =+ case Parser.parseText (Text.pack e) of+ Left err -> fail (errorBundlePretty err)+ Right d -> lift d
+ src/Language/Docker/EDSL/Types.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE DeriveFunctor #-}++module Language.Docker.EDSL.Types where++import Data.List.NonEmpty (NonEmpty)+import Data.String+import Data.Text (Text)+import qualified Language.Docker.Syntax as Syntax++data EBaseImage+ = EBaseImage+ Syntax.Image+ (Maybe Syntax.Tag)+ (Maybe Syntax.Digest)+ (Maybe Syntax.ImageAlias)+ (Maybe Syntax.Platform)+ deriving (Show, Eq, Ord)++instance IsString EBaseImage where+ fromString s = EBaseImage (fromString s) Nothing Nothing Nothing Nothing++data EInstruction next+ = From+ EBaseImage+ next+ | AddArgs+ (NonEmpty Syntax.SourcePath)+ Syntax.TargetPath+ Syntax.Chown+ next+ | User+ Text+ next+ | Label+ Syntax.Pairs+ next+ | StopSignal+ Text+ next+ | CopyArgs+ (NonEmpty Syntax.SourcePath)+ Syntax.TargetPath+ Syntax.Chown+ Syntax.CopySource+ next+ | RunArgs+ (Syntax.Arguments Text)+ Syntax.RunFlags+ next+ | CmdArgs+ (Syntax.Arguments Text)+ next+ | Shell+ (Syntax.Arguments Text)+ next+ | Workdir+ Syntax.Directory+ next+ | Expose+ Syntax.Ports+ next+ | Volume+ Text+ next+ | EntrypointArgs+ (Syntax.Arguments Text)+ next+ | Maintainer+ Text+ next+ | Env+ Syntax.Pairs+ next+ | Arg+ Text+ (Maybe Text)+ next+ | Comment+ Text+ next+ | Healthcheck+ (Syntax.Check Text)+ next+ | OnBuildRaw+ (Syntax.Instruction Text)+ next+ | Embed+ [Syntax.InstructionPos Text]+ next+ deriving (Functor)
+ src/Language/Docker/Syntax/Lift.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TemplateHaskell #-}++module Language.Docker.Syntax.Lift where++import Data.Fixed (Fixed)+import Data.Time.Clock (DiffTime)+import Instances.TH.Lift () -- Defines Lift instances for ByteString and Text++import Language.Docker.Syntax+import Language.Haskell.TH.Lift+import Language.Haskell.TH.Syntax ()++deriveLift ''Fixed++deriveLift ''DiffTime++deriveLift ''Protocol++deriveLift ''Port++deriveLift ''Ports++deriveLift ''Registry++deriveLift ''Image++deriveLift ''ImageAlias++deriveLift ''Tag++deriveLift ''Digest++deriveLift ''BaseImage++deriveLift ''Arguments++deriveLift ''Instruction++deriveLift ''InstructionPos++deriveLift ''SourcePath++deriveLift ''TargetPath++deriveLift ''Chown++deriveLift ''CopySource++deriveLift ''CopyArgs++deriveLift ''AddArgs++deriveLift ''Duration++deriveLift ''Retries++deriveLift ''CheckArgs++deriveLift ''Check++deriveLift ''BindOpts++deriveLift ''CacheSharing++deriveLift ''CacheOpts++deriveLift ''TmpOpts++deriveLift ''SecretOpts++deriveLift ''RunMount++deriveLift ''RunSecurity++deriveLift ''RunNetwork++deriveLift ''RunFlags++deriveLift ''RunArgs
+ test/Language/Docker/EDSL/QuasiSpec.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE QuasiQuotes #-}+module Language.Docker.EDSL.QuasiSpec+ where++import Language.Docker.EDSL+import Language.Docker.EDSL.Quasi+import Language.Docker.Syntax+import Test.Hspec++spec :: Spec+spec = do+ describe "dockerfile" $+ it "parses a dockerfile and returns its ast" $ do+ let df = map instruction [dockerfile|+ FROM node+ RUN apt-get update+ CMD ["node", "something.js"]+ |]+ df `shouldBe` [ From (BaseImage "node" Nothing Nothing Nothing Nothing)+ , Run "apt-get update"+ , Cmd ["node", "something.js"]+ ]++ describe "edockerfile" $+ it "lets us use parsed dockerfiles seamlessly in our DSL" $ do+ let d = do+ from ("node" `aliased` "node-build")+ expose (ports [tcpPort 8080, variablePort "PORT"])+ [edockerfile|+ RUN apt-get update+ CMD node something.js+ |]+ df = map instruction (toDockerfile d)+ df `shouldBe` [ From (BaseImage+ { image = "node"+ , alias = Just "node-build"+ , tag = Nothing+ , digest = Nothing+ , platform = Nothing}+ )+ , Expose (Ports [Port 8080 TCP, PortStr "$PORT"])+ , Run "apt-get update"+ , Cmd "node something.js"+ ]
+ test/Language/Docker/EDSLSpec.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-}+module Language.Docker.EDSLSpec where++import Control.Monad.IO.Class+import Data.List (sort)+import Language.Docker.EDSL+import Language.Docker.PrettyPrint+import qualified Language.Docker.Syntax as Syntax+import System.Directory+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" $+ it "allows us to write haskell code that represents Dockerfiles" $ do+ let r = map Syntax.instruction $ toDockerfile (do+ from "node"+ cmdArgs ["node", "-e", "'console.log(\'hey\')'"])+ r `shouldBe` [ Syntax.From $+ Syntax.BaseImage "node"+ Nothing+ Nothing+ Nothing+ Nothing+ , Syntax.Cmd ["node", "-e", "'console.log(\'hey\')'"]+ ]++ describe "prettyPrint $ toDockerfile s" $ do+ it "allows us to write haskell code that represents Dockerfiles" $ do+ let r = prettyPrint $ toDockerfile (do+ from "node"+ shell ["cmd", "/S"]+ entrypoint ["/tini", "--"]+ cmdArgs ["node", "-e", "'console.log(\'hey\')'"]+ healthcheck $ check "curl -f http://localhost/ || exit 1" `interval` 300)+ r `shouldBe` printed [ "FROM node"+ , "SHELL [\"cmd\", \"/S\"]"+ , "ENTRYPOINT [\"/tini\", \"--\"]"+ , "CMD [\"node\", \"-e\", \"'console.log(\'hey\')'\"]"+ , "HEALTHCHECK --interval=300s CMD curl -f http://localhost/ || exit 1"+ ]+ it "print expose instructions correctly" $ do+ let r = prettyPrint $ toDockerfile (do+ from "scratch"+ expose $ ports [variablePort "PORT", tcpPort 80, udpPort 51]+ expose $ ports [portRange 90 100]+ expose $ ports [udpPortRange 190 200])+ r `shouldBe` printed [ "FROM scratch"+ , "EXPOSE $PORT 80/tcp 51/udp"+ , "EXPOSE 90-100"+ , "EXPOSE 190-200/udp"+ ]++ it "onBuild let's us nest statements" $ do+ let r = prettyPrint $ toDockerfile $ do+ from "node"+ cmdArgs ["node", "-e", "'console.log(\'hey\')'"]+ onBuild $ do+ run "echo \"hello world\""+ run "echo \"hello world2\""+ r `shouldBe` printed [ "FROM node"+ , "CMD [\"node\", \"-e\", \"'console.log(\'hey\')'\"]"+ , "ONBUILD RUN echo \"hello world\""+ , "ONBUILD RUN echo \"hello world2\""+ ]++ it "parses and prints from aliases correctly" $ do+ let r = prettyPrint $ toDockerfile $ do+ from $ "node" `tagged` "10.1" `aliased` "node-build"+ run "echo foo"+ r `shouldBe` printed [ "FROM node:10.1 AS node-build"+ , "RUN echo foo"+ ]++ it "parses and prints from with a registry" $ do+ let r = prettyPrint $ toDockerfile $ do+ from "opensuse/tumbleweed"+ run "echo foo"+ r `shouldBe` printed [ "FROM opensuse/tumbleweed"+ , "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` printed [ "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"+ ]+ it "quotes label and env correctly" $ do+ let r = prettyPrint $ toDockerfile $ do+ from "scratch"+ label [("email", "Example <example@example.com>")]+ label [("escape", "Escape this\" thing")]+ env [("foo", "bar baz")]+ env [("double_escape", "escape this \\\"")]+ r `shouldBe` printed [ "FROM scratch"+ , "LABEL email=\"Example <example@example.com>\""+ , "LABEL escape=\"Escape this\\\" thing\""+ , "ENV foo=\"bar baz\""+ , "ENV double_escape=\"escape this \\\"\""+ ]++ describe "toDockerfileTextIO" $+ it "let's us run in the IO monad" $ do+ -- TODO - "glob" is a really useful combinator+ str <- toDockerfileTextIO $ do+ fs <- liftIO $ do+ cwd <- getCurrentDirectory+ fs <- glob "./test/Language/Docker/*.hs"+ return (map (makeRelative cwd) (sort fs))+ 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"+ ]
+ test/Language/Docker/ExamplesSpec.hs view
@@ -0,0 +1,20 @@+module Language.Docker.ExamplesSpec where++import Control.Monad+import Data.Monoid+import System.Directory+import System.FilePath+import System.FilePath.Glob+import System.Process+import Test.Hspec++stackRunGhc e = callProcess "stack" ["runghc", "--package", "language-docker", e]++spec :: Spec+spec = do+ cwd <- runIO getCurrentDirectory+ exampleSources <- runIO $ glob "./examples/*.hs"+ forM_ exampleSources $ \exampleSource -> do+ let exampleSource' = makeRelative cwd exampleSource+ describe exampleSource $ it ("stack runghc " <> exampleSource') $+ stackRunGhc exampleSource
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}