packages feed

buffet (empty) → 0.2.0

raw patch · 52 files changed

+2460/−0 lines, 52 filesdep +aesondep +aeson-prettydep +basesetup-changed

Dependencies added: aeson, aeson-pretty, base, buffet, bytestring, cassava, containers, directory, filepath, language-docker, mustache, optparse-applicative, parsec, random, split, tasty, tasty-hunit, text, typed-process, unordered-containers, vector, yaml

Files

+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2019 Benjamin Fischer++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,101 @@+# Buffet 🍜++[![Build](https://img.shields.io/travis/evolutics/buffet)](https://travis-ci.org/evolutics/buffet)+[![License](https://img.shields.io/github/license/evolutics/buffet)](LICENSE)+[![Package](https://img.shields.io/hackage/v/buffet)](https://hackage.haskell.org/package/buffet)++Assemble many Dockerfiles in a single Dockerfile. This gives you the convenience of one Docker image with your favorite tools while keeping the modularity of a separate Dockerfile per tool.++See [Code Cleaner Buffet](https://github.com/evolutics/code-cleaner-buffet) for an application of this.++## Installation++Run++```bash+stack install buffet+```++or++```bash+cabal install buffet+```++You are ready when++```bash+buffet --help+```++works.++## Usage example++Say we work on a simple website with HTML code that we would like to format, clean up, and validate. For this purpose, we choose the tools Prettier and HTML Tidy, which we plan use in continuous integration via a Docker image.++For the following, we assume you first run++```bash+git clone https://github.com/evolutics/buffet.git+cd buffet+```++### Building++In the subfolders of the [`example`](example) folder, you see a [Dockerfile for Prettier](example/prettier/Dockerfile) and another [Dockerfile for HTML Tidy](example/tidy/Dockerfile). These Dockerfiles (called "dishes") are the modular toy blocks, which we now automatically combine to one Dockerfile (called "buffet") by running++```bash+buffet build example+```++This prints a Dockerfile based on the subfolders of `example`. From this, we can then build a Docker image `mona_linta` with++```bash+buffet build example | docker build \+  --build-arg prettier=1.19.1 --build-arg tidy=1 --tag mona_linta -+```++Note how we pass a `--build-arg` per tool, assigning each a nonempty value. In case of Prettier, we use this to parameterize the tool version. If we do not mention a tool in a `--build-arg`, it is not available in the image.++### Testing++As a demo that our Docker image works as expected, run++```bash+docker run -it --rm mona_linta+prettier --version+tidy --version+```++To integrate a check like `prettier --version` as a test of the tool installation, add a `HEALTHCHECK` instruction as you see in the [Dockerfile for Prettier](example/prettier/Dockerfile). The exit status of such a command is then reported when you run our example test suite with++```bash+buffet test --arguments example/test_arguments.yaml example+```++The file [`test_arguments.yaml`](example/test_arguments.yaml) provides the `--build-arg` configuration for this test run.++If you like, try adding a test for HTML Tidy.++### Documenting++You can generate documentation with++```bash+buffet document --template example/document_template.md.mustache example+```++This renders the template [`document_template.md.mustache`](example/document_template.md.mustache). To print the raw template context, omit this option as in++```bash+buffet document example+```++Among others, data from `LABEL` instructions is integrated in the template context.++## Terminology++- **Buffet:** A Dockerfile automatically assembled based on many dishes.+- **Dish:** A Dockerfile, usually providing a specific command-line tool.+- **Menu:** Configuration with a list of dishes to be assembled in a buffet.
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,9 @@+module Main+  ( main+  ) where++import qualified Buffet+import Prelude (IO)++main :: IO ()+main = Buffet.main
+ buffet.cabal view
@@ -0,0 +1,144 @@+cabal-version: 2.0++-- This file has been generated from package.yaml by hpack version 0.31.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: 319ef9951348de1ea9c86ff2b630f3782648058a27081eead89bb848f9b51822++name:           buffet+version:        0.2.0+synopsis:       Assembles many Dockerfiles in one.+description:    See https://github.com/evolutics/buffet+category:       Development+homepage:       https://github.com/evolutics/buffet#readme+bug-reports:    https://github.com/evolutics/buffet/issues+author:         Benjamin Fischer+maintainer:     benjamin.fischer@evolutics.info+copyright:      2019 Benjamin Fischer+license:        MIT+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md++source-repository head+  type: git+  location: https://github.com/evolutics/buffet++library buffet-internal+  exposed-modules:+      Buffet+      Buffet.Build.BeforeFirstBuildStage+      Buffet.Build.Build+      Buffet.Build.BuildInternal+      Buffet.Build.ConditionInstructions+      Buffet.Build.GlobalBuildStage+      Buffet.Build.InsertOptionArgInstructionUnlessPresent+      Buffet.Build.JoinConsecutiveRunInstructions+      Buffet.Build.LocalBuildStages+      Buffet.Build.ScheduleParallelInstructions+      Buffet.Document.Configuration+      Buffet.Document.Document+      Buffet.Document.DocumentInternal+      Buffet.Document.TemplateBuffet+      Buffet.Document.TemplateContext+      Buffet.Document.TemplateDishes+      Buffet.Document.TemplateTagGroups+      Buffet.Facade+      Buffet.Ir.Ir+      Buffet.Parse.Menu+      Buffet.Parse.Parse+      Buffet.Parse.ParseDish+      Buffet.Parse.ParseGlobalBuildStage+      Buffet.Parse.ParseHealthCheck+      Buffet.Parse.ParseInternal+      Buffet.Parse.ParseMenu+      Buffet.Parse.ParseMenuFromFile+      Buffet.Parse.ParseMenuFromFolder+      Buffet.Parse.ParseMetadata+      Buffet.Parse.PartitionByBuildStage+      Buffet.Parse.Print+      Buffet.Test.Configuration+      Buffet.Test.ParseArguments+      Buffet.Test.Test+      Buffet.Test.TestDish+      Buffet.Test.TestInternal+      Buffet.Test.TestResult+      Buffet.Test.TestSetup+      Buffet.Test.UsingDockerImage+      Buffet.Toolbox.DockerTools+      Buffet.Toolbox.ExceptionTools+      Buffet.Toolbox.TextTools+  other-modules:+      Paths_buffet+  autogen-modules:+      Paths_buffet+  hs-source-dirs:+      src+  ghc-options: -Weverything -Wno-unsafe -Wno-safe -Wno-missing-local-signatures+  build-depends:+      aeson+    , aeson-pretty+    , base >=4.7 && <5+    , bytestring+    , cassava+    , containers+    , directory+    , filepath+    , language-docker+    , mustache+    , optparse-applicative+    , parsec+    , random+    , split+    , text+    , typed-process+    , unordered-containers+    , vector+    , yaml+  default-language: Haskell2010++executable buffet+  main-is: Main.hs+  other-modules:+      Paths_buffet+  autogen-modules:+      Paths_buffet+  hs-source-dirs:+      app+  ghc-options: -threaded -rtsopts -with-rtsopts=-N -Weverything -Wno-unsafe -Wno-safe -Wno-missing-local-signatures+  build-depends:+      base >=4.7 && <5+    , buffet-internal+  default-language: Haskell2010++test-suite buffet-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Buffet.Toolbox.TestHelp+      Buffet.Toolbox.TestTools+      Buffet.Toolbox.TestUtility+      Buffet.Toolbox.TestVersion+      Paths_buffet+  autogen-modules:+      Paths_buffet+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N -Weverything -Wno-unsafe -Wno-safe -Wno-missing-local-signatures+  build-depends:+      aeson+    , base >=4.7 && <5+    , buffet-internal+    , bytestring+    , directory+    , filepath+    , tasty+    , tasty-hunit+    , text+    , typed-process+    , unordered-containers+    , vector+    , yaml+  default-language: Haskell2010
+ src/Buffet.hs view
@@ -0,0 +1,173 @@+module Buffet+  ( main+  ) where++import qualified Buffet.Facade as Facade+import qualified Control.Applicative as Applicative+import qualified Data.Foldable as Foldable+import qualified Options.Applicative as Options+import qualified Options.Applicative.Help.Pretty as Pretty+import Prelude+  ( FilePath+  , IO+  , Maybe(Just)+  , String+  , ($)+  , (.)+  , (<$>)+  , (<*>)+  , (>>=)+  , concatMap+  , fmap+  , mconcat+  , words+  )++main :: IO ()+main = Options.execParser root >>= Facade.get++root :: Options.ParserInfo Facade.Command+root =+  Options.info parser $ Options.progDesc "Assembles many Dockerfiles in one."+  where+    parser = versionOption <*> Options.helper <*> raw+    raw =+      Options.hsubparser $+      mconcat+        [ Options.command "build" build+        , Options.command "document" document+        , Options.command "parse" parse+        , Options.command "test" test+        ]++versionOption :: Options.Parser (a -> a)+versionOption =+  Options.infoOption "Buffet 0.2.0" $+  mconcat+    [Options.long "version", Options.helpDoc $ Just versionHelp, Options.hidden]+  where+    versionHelp =+      paragraph+        [ "Prints the program name with version on stdout"+        , "and exits successfully"+        , "according to the GNU coding standards."+        ]++build :: Options.ParserInfo Facade.Command+build =+  Options.info parser $+  Options.progDesc "Assembles a Dockerfile from a list of Dockerfiles."+  where+    parser = fmap Facade.Build $ Facade.BuildArguments <$> menuOperand++menuOperand :: Options.Parser FilePath+menuOperand =+  Options.argument Options.str $+  mconcat [Options.metavar "menu_path", Options.helpDoc $ Just menuHelp]++menuHelp :: Pretty.Doc+menuHelp =+  paragraphs+    [ paragraph+        [ "File or folder that"+        , "lists the input Dockerfiles and"+        , "configures the output Dockerfile."+        ]+    , paragraph+        [ "If the path is a file,"+        , "then it is a JSON or YAML file"+        , "with the following entries:"+        ]+    , list+        [ paragraphs+            [ paragraph ["`copy_dummy_source_path`:"]+            , paragraph+                [ "File or folder"+                , "that is added as a source path"+                , "to `COPY` instructions"+                , "because at least one source must exist."+                , "Default: \"/var/empty\""+                ]+            ]+        , paragraphs+            [ paragraph ["`option_to_dish`:"]+            , paragraph+                [ "Map from `ARG` variable name to Dockerfile path."+                , "These Dockerfiles are assembled,"+                , "with their instructions conditioned"+                , "on the respective variable being nonempty."+                , "Default: {}"+                ]+            ]+        ]+    , paragraph+        [ "If the path is a folder,"+        , "then the behavior is as if a file is given"+        , "with above defaults except for the following."+        , "`option_to_dish` is a map based on the path subfolders:"+        , "for each subfolder `x`, the map has an entry"+        , "with key `x` and value `x/Dockerfile`."+        ]+    ]++paragraphs :: [Pretty.Doc] -> Pretty.Doc+paragraphs = Pretty.vsep++paragraph :: [String] -> Pretty.Doc+paragraph =+  Foldable.foldr (Pretty.</>) Pretty.line . fmap Pretty.text . concatMap words++list :: [Pretty.Doc] -> Pretty.Doc+list =+  paragraphs .+  fmap (\element -> Pretty.char '-' Pretty.<+> Pretty.align element)++document :: Options.ParserInfo Facade.Command+document = Options.info parser $ Options.progDesc "Generates documentation."+  where+    parser =+      fmap Facade.Document $+      Facade.DocumentArguments <$> templateOption <*> menuOperand+    templateOption :: Options.Parser (Maybe FilePath)+    templateOption =+      Applicative.optional+        (Options.strOption $+         mconcat+           [ Options.long "template"+           , Options.metavar "mustache_file"+           , Options.helpDoc $ Just templateHelp+           ])+    templateHelp =+      paragraph+        [ "Mustache template to render (see https://mustache.github.io)."+        , "To print the template context instead, omit this option."+        ]++parse :: Options.ParserInfo Facade.Command+parse =+  Options.info parser $+  Options.progDesc "Prints an intermediate representation for API usage."+  where+    parser = fmap Facade.Parse $ Facade.ParseArguments <$> menuOperand++test :: Options.ParserInfo Facade.Command+test = Options.info parser $ Options.progDesc "Performs health checks."+  where+    parser =+      fmap Facade.Test $+      Facade.TestArguments <$> argumentsOption <*> menuOperand+    argumentsOption :: Options.Parser (Maybe FilePath)+    argumentsOption =+      Applicative.optional+        (Options.strOption $+         mconcat+           [ Options.long "arguments"+           , Options.metavar "yaml_file"+           , Options.helpDoc $ Just argumentsHelp+           ])+    argumentsHelp =+      paragraph+        [ "JSON or YAML file with a map that"+        , "sets the Docker build arguments."+        , "Health checks are only done for dishes in this map."+        ]
+ src/Buffet/Build/BeforeFirstBuildStage.hs view
@@ -0,0 +1,14 @@+module Buffet.Build.BeforeFirstBuildStage+  ( get+  ) where++import qualified Buffet.Build.ScheduleParallelInstructions as ScheduleParallelInstructions+import qualified Buffet.Ir.Ir as Ir+import qualified Data.Map.Strict as Map+import Prelude ((.), fmap)++get :: Ir.Buffet -> [Ir.DockerfilePart]+get = ScheduleParallelInstructions.get . dishesInstructions++dishesInstructions :: Ir.Buffet -> [Ir.DockerfilePart]+dishesInstructions = fmap Ir.beforeFirstBuildStage . Map.elems . Ir.optionToDish
+ src/Buffet/Build/Build.hs view
@@ -0,0 +1,11 @@+module Buffet.Build.Build+  ( get+  ) where++import qualified Buffet.Build.BuildInternal as BuildInternal+import qualified Buffet.Parse.ParseInternal as ParseInternal+import qualified Data.Text as T+import Prelude (FilePath, IO, (.), fmap)++get :: FilePath -> IO T.Text+get = fmap BuildInternal.get . ParseInternal.get
+ src/Buffet/Build/BuildInternal.hs view
@@ -0,0 +1,27 @@+module Buffet.Build.BuildInternal+  ( get+  ) where++import qualified Buffet.Build.BeforeFirstBuildStage as BeforeFirstBuildStage+import qualified Buffet.Build.GlobalBuildStage as GlobalBuildStage+import qualified Buffet.Build.LocalBuildStages as LocalBuildStages+import qualified Buffet.Ir.Ir as Ir+import qualified Buffet.Toolbox.DockerTools as DockerTools+import qualified Buffet.Toolbox.TextTools as TextTools+import qualified Data.Text as T+import Prelude (($), (.), fmap, mconcat)++get :: Ir.Buffet -> T.Text+get buffet =+  printDockerfileParts $+  mconcat+    [ BeforeFirstBuildStage.get buffet+    , LocalBuildStages.get buffet+    , GlobalBuildStage.get buffet+    ]++printDockerfileParts :: [Ir.DockerfilePart] -> T.Text+printDockerfileParts = TextTools.intercalateNewline . fmap printInstructions++printInstructions :: Ir.DockerfilePart -> T.Text+printInstructions = mconcat . fmap DockerTools.printInstruction
+ src/Buffet/Build/ConditionInstructions.hs view
@@ -0,0 +1,66 @@+module Buffet.Build.ConditionInstructions+  ( get+  ) where++import qualified Buffet.Build.InsertOptionArgInstructionUnlessPresent as InsertOptionArgInstructionUnlessPresent+import qualified Buffet.Ir.Ir as Ir+import qualified Buffet.Toolbox.TextTools as TextTools+import qualified Data.Text as T+import qualified Language.Docker as Docker hiding (sourcePaths)+import qualified Language.Docker.Syntax as Syntax+import Prelude (($), (.), (<>), fmap, mconcat, pure)++get :: Ir.Buffet -> Ir.Option -> Ir.DockerfilePart -> Ir.DockerfilePart+get buffet option =+  fmap (conditionInstruction buffet option) .+  InsertOptionArgInstructionUnlessPresent.get option++conditionInstruction ::+     Ir.Buffet+  -> Ir.Option+  -> Docker.Instruction T.Text+  -> Docker.Instruction T.Text+conditionInstruction buffet option = condition+  where+    condition (Docker.Copy arguments) =+      conditionalCopyInstruction buffet arguments+    condition (Docker.Run (Syntax.ArgumentsText command)) =+      optionConditionalRunInstruction option command+    condition instruction = instruction++conditionalCopyInstruction ::+     Ir.Buffet -> Docker.CopyArgs -> Docker.Instruction T.Text+conditionalCopyInstruction buffet arguments =+  Docker.Copy arguments {Docker.sourcePaths = conditionalSources}+  where+    conditionalSources = fmap makePattern originalSources <> pure dummy+    makePattern path =+      Docker.SourcePath+        {Docker.unSourcePath = T.snoc (Docker.unSourcePath path) '*'}+    originalSources = Docker.sourcePaths arguments+    dummy =+      Docker.SourcePath {Docker.unSourcePath = Ir.copyDummySourcePath buffet}++optionConditionalRunInstruction ::+     Ir.Option -> T.Text -> Docker.Instruction T.Text+optionConditionalRunInstruction option = conditionalRunInstruction condition+  where+    condition = mconcat [T.pack "[ -n \"${", Ir.option option, T.pack "}\" ]"]++conditionalRunInstruction :: T.Text -> T.Text -> Docker.Instruction T.Text+conditionalRunInstruction condition thenPart =+  Docker.Run $ Syntax.ArgumentsText command+  where+    command =+      TextTools.intercalateNewline $+      mconcat [[conditionLine], indentLines thenLines, [indentLine endLine]]+    conditionLine = mconcat [T.pack "if ", condition, T.pack "; then \\"]+    thenLines = T.lines embeddedThen+    embeddedThen = mconcat [indentLine thenPart, T.pack " \\"]+    endLine = T.pack "; fi"++indentLines :: [T.Text] -> [T.Text]+indentLines = fmap indentLine++indentLine :: T.Text -> T.Text+indentLine = T.append $ T.pack "  "
+ src/Buffet/Build/GlobalBuildStage.hs view
@@ -0,0 +1,21 @@+module Buffet.Build.GlobalBuildStage+  ( get+  ) where++import qualified Buffet.Build.ConditionInstructions as ConditionInstructions+import qualified Buffet.Build.ScheduleParallelInstructions as ScheduleParallelInstructions+import qualified Buffet.Ir.Ir as Ir+import qualified Data.Map.Strict as Map+import Prelude (($), (.), fmap, uncurry)++get :: Ir.Buffet -> [Ir.DockerfilePart]+get = ScheduleParallelInstructions.get . dishesInstructions++dishesInstructions :: Ir.Buffet -> [Ir.DockerfilePart]+dishesInstructions buffet =+  fmap (uncurry $ dishInstructions buffet) . Map.toAscList $+  Ir.optionToDish buffet++dishInstructions :: Ir.Buffet -> Ir.Option -> Ir.Dish -> Ir.DockerfilePart+dishInstructions buffet option =+  ConditionInstructions.get buffet option . Ir.globalBuildStage
+ src/Buffet/Build/InsertOptionArgInstructionUnlessPresent.hs view
@@ -0,0 +1,34 @@+module Buffet.Build.InsertOptionArgInstructionUnlessPresent+  ( get+  ) where++import qualified Buffet.Ir.Ir as Ir+import qualified Data.List as List+import qualified Language.Docker as Docker+import Prelude (Bool(False, True), Maybe(Nothing), (<>), (==), any, span)++get :: Ir.Option -> Ir.DockerfilePart -> Ir.DockerfilePart+get option stage = firstFroms <> preparedAfterFirstFroms+  where+    (firstFroms, afterFirstFroms) = span isFrom stage+    preparedAfterFirstFroms =+      if hasArgWithName option afterFirstFroms+        then afterFirstFroms+        else List.insert arg firstArgs <> afterFirstArgs+    arg = Docker.Arg (Ir.option option) Nothing+    (firstArgs, afterFirstArgs) = span isArg afterFirstFroms++isFrom :: Docker.Instruction a -> Bool+isFrom (Docker.From _) = True+isFrom _ = False++hasArgWithName :: Ir.Option -> Ir.DockerfilePart -> Bool+hasArgWithName option = any isArgWithName+  where+    isArgWithName (Docker.Arg name _) = name == optionName+    isArgWithName _ = False+    optionName = Ir.option option++isArg :: Docker.Instruction a -> Bool+isArg (Docker.Arg _ _) = True+isArg _ = False
+ src/Buffet/Build/JoinConsecutiveRunInstructions.hs view
@@ -0,0 +1,27 @@+module Buffet.Build.JoinConsecutiveRunInstructions+  ( get+  ) where++import qualified Buffet.Ir.Ir as Ir+import qualified Data.Text as T+import qualified Language.Docker as Docker+import qualified Language.Docker.Syntax as Syntax+import Prelude (($), foldr, mconcat)++get :: Ir.DockerfilePart -> Ir.DockerfilePart+get = foldr process []+  where+    process (Docker.Run first) (Docker.Run second:rest) =+      Docker.Run (joinRuns first second) : rest+    process first rest = first : rest++joinRuns ::+     Docker.Arguments T.Text+  -> Docker.Arguments T.Text+  -> Docker.Arguments T.Text+joinRuns first second =+  Syntax.ArgumentsText $+  mconcat [command first, T.pack " \\\n  && ", command second]+  where+    command (Syntax.ArgumentsText shell) = shell+    command (Syntax.ArgumentsList exec) = exec
+ src/Buffet/Build/LocalBuildStages.hs view
@@ -0,0 +1,17 @@+module Buffet.Build.LocalBuildStages+  ( get+  ) where++import qualified Buffet.Build.ConditionInstructions as ConditionInstructions+import qualified Buffet.Ir.Ir as Ir+import qualified Data.Map.Strict as Map+import Prelude (($), (.), concatMap, fmap, uncurry)++get :: Ir.Buffet -> [Ir.DockerfilePart]+get buffet =+  concatMap (uncurry $ dishBuildStages buffet) . Map.toAscList $+  Ir.optionToDish buffet++dishBuildStages :: Ir.Buffet -> Ir.Option -> Ir.Dish -> [Ir.DockerfilePart]+dishBuildStages buffet option =+  fmap (ConditionInstructions.get buffet option) . Ir.localBuildStages
+ src/Buffet/Build/ScheduleParallelInstructions.hs view
@@ -0,0 +1,122 @@+module Buffet.Build.ScheduleParallelInstructions+  ( get+  ) where++import qualified Buffet.Build.JoinConsecutiveRunInstructions as JoinConsecutiveRunInstructions+import qualified Buffet.Ir.Ir as Ir+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Text as T+import qualified Language.Docker as Docker+import Prelude+  ( Bool(False, True)+  , Maybe(Just, Nothing)+  , ($)+  , (.)+  , (/=)+  , (<>)+  , (==)+  , all+  , concatMap+  , dropWhile+  , filter+  , fmap+  , mconcat+  , minimum+  , null+  , span+  , splitAt+  , take+  , unzip+  )++type ScheduleStep+   = [Ir.DockerfilePart] -> (Ir.DockerfilePart, [Ir.DockerfilePart])++get :: [Ir.DockerfilePart] -> [Ir.DockerfilePart]+get = wrap . schedule []+  where+    wrap [] = []+    wrap timetable = [timetable]+    schedule timetable queues =+      if all null queues+        then timetable+        else schedule timetable' queues'+      where+        timetable' = timetable <> step+        (step, queues') = scheduleStep queues++scheduleStep :: ScheduleStep+scheduleStep queues =+  case filter (\(_, queues') -> queues' /= queues) results of+    [] -> ([], queues)+    result:_ -> result+  where+    results = fmap ($ queues) strategies+    strategies =+      [ scheduleFromInstructions+      , scheduleArgInstructions+      , scheduleShellInstructions+      , scheduleCopyInstructions+      , scheduleRunInstructions+      , scheduleWorkdirInstructions+      , scheduleNextInstructionEach+      ]++scheduleFromInstructions :: ScheduleStep+scheduleFromInstructions = unifyInstructions isFrom+  where+    isFrom (Docker.From _) = True+    isFrom _ = False++unifyInstructions :: (Docker.Instruction T.Text -> Bool) -> ScheduleStep+unifyInstructions isRelevant queues =+  case minimumInstruction of+    Nothing -> ([], queues)+    Just instruction ->+      ([instruction], fmap (dropWhile (== instruction)) queues)+  where+    minimumInstruction =+      fmap minimum . NonEmpty.nonEmpty $ nextInstructionsIfRelevant+    nextInstructionsIfRelevant = concatMap (filter isRelevant . take 1) queues++scheduleArgInstructions :: ScheduleStep+scheduleArgInstructions = unifyInstructions isArg+  where+    isArg (Docker.Arg _ _) = True+    isArg _ = False++scheduleShellInstructions :: ScheduleStep+scheduleShellInstructions = unifyInstructions isShell+  where+    isShell (Docker.Shell _) = True+    isShell _ = False++scheduleCopyInstructions :: ScheduleStep+scheduleCopyInstructions = spanInstructions isCopy+  where+    isCopy (Docker.Copy _) = True+    isCopy _ = False++spanInstructions :: (Docker.Instruction T.Text -> Bool) -> ScheduleStep+spanInstructions isRelevant queues = (mconcat spans, queues')+  where+    (spans, queues') = unzip $ fmap (span isRelevant) queues++scheduleRunInstructions :: ScheduleStep+scheduleRunInstructions queues =+  (JoinConsecutiveRunInstructions.get runs, queues')+  where+    (runs, queues') = spanInstructions isRun queues+    isRun (Docker.Run _) = True+    isRun _ = False++scheduleWorkdirInstructions :: ScheduleStep+scheduleWorkdirInstructions = unifyInstructions isWorkdir+  where+    isWorkdir (Docker.Workdir _) = True+    isWorkdir _ = False++scheduleNextInstructionEach :: ScheduleStep+scheduleNextInstructionEach queues = (mconcat nexts, queues')+  where+    (nexts, queues') = unzip $ fmap (splitAt 1) queues
+ src/Buffet/Document/Configuration.hs view
@@ -0,0 +1,11 @@+module Buffet.Document.Configuration+  ( Configuration(..)+  ) where++import Prelude (Eq, FilePath, Maybe, Ord, Show)++newtype Configuration =+  Configuration+    { template :: Maybe FilePath+    }+  deriving (Eq, Ord, Show)
+ src/Buffet/Document/Document.hs view
@@ -0,0 +1,14 @@+module Buffet.Document.Document+  ( get+  ) where++import qualified Buffet.Document.Configuration as Configuration+import qualified Buffet.Document.DocumentInternal as DocumentInternal+import qualified Buffet.Parse.ParseInternal as ParseInternal+import qualified Control.Monad as Monad+import qualified Data.Text as T+import Prelude (FilePath, IO)++get :: Configuration.Configuration -> FilePath -> IO T.Text+get configuration =+  ParseInternal.get Monad.>=> DocumentInternal.get configuration
+ src/Buffet/Document/DocumentInternal.hs view
@@ -0,0 +1,80 @@+module Buffet.Document.DocumentInternal+  ( get+  ) where++import qualified Buffet.Document.Configuration as Configuration+import qualified Buffet.Document.TemplateContext as TemplateContext+import qualified Buffet.Ir.Ir as Ir+import qualified Buffet.Toolbox.ExceptionTools as ExceptionTools+import qualified Buffet.Toolbox.TextTools as TextTools+import qualified Control.Exception as Exception+import qualified Data.Aeson as Aeson+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Text as T+import Prelude+  ( FilePath+  , IO+  , Show+  , ($)+  , (.)+  , (<>)+  , fmap+  , maybe+  , pure+  , show+  , unlines+  )+import qualified System.FilePath as FilePath+import qualified Text.Mustache as Mustache+import qualified Text.Mustache.Render as Render+import qualified Text.Mustache.Types as Types+import qualified Text.Parsec as Parsec++data Exception+  = CompileException Parsec.ParseError+  | SubstituteException FilePath (NonEmpty.NonEmpty Render.SubstitutionError)++instance Show Exception where+  show (CompileException error) = show error+  show (SubstituteException path errors) =+    unlines . NonEmpty.toList . NonEmpty.cons (path <> ":") $ fmap show' errors+    where+      show' (Render.VariableNotFound name) =+        "Variable not found: " <> showName name+      show' (Render.InvalidImplicitSectionContextType valueType) =+        "Invalid implicit section context type: " <> valueType+      show' Render.InvertedImplicitSection = "Inverted implicit section"+      show' (Render.SectionTargetNotFound name) =+        "Section target not found: " <> showName name+      show' (Render.PartialNotFound path') = "Partial not found: " <> path'+      show' (Render.DirectlyRenderedValue value) =+        "Directly rendered value: " <> show value+      showName = T.unpack . T.intercalate (T.pack ".")++instance Exception.Exception Exception++get :: Configuration.Configuration -> Ir.Buffet -> IO T.Text+get configuration =+  maybe+    (pure . printTemplateContext)+    renderTemplate+    (Configuration.template configuration) .+  TemplateContext.get++printTemplateContext :: Aeson.Value -> T.Text+printTemplateContext = TextTools.prettyPrintJson++renderTemplate :: FilePath -> Aeson.Value -> IO T.Text+renderTemplate templatePath templateContext = do+  template <- getTemplate templatePath+  let (errors, result) =+        Mustache.checkedSubstitute template $ Types.mFromJSON templateContext+  maybe (pure result) (Exception.throwIO . SubstituteException templatePath) $+    NonEmpty.nonEmpty errors++getTemplate :: FilePath -> IO Mustache.Template+getTemplate templatePath =+  ExceptionTools.eitherThrow CompileException $+  Mustache.automaticCompile searchSpace templatePath+  where+    searchSpace = [".", FilePath.takeDirectory templatePath]
+ src/Buffet/Document/TemplateBuffet.hs view
@@ -0,0 +1,32 @@+{- HLINT ignore "Avoid restricted extensions" -}+{-# LANGUAGE DeriveGeneric #-}++module Buffet.Document.TemplateBuffet+  ( get+  ) where++import qualified Buffet.Document.TemplateDishes as TemplateDishes+import qualified Buffet.Document.TemplateTagGroups as TemplateTagGroups+import qualified Buffet.Ir.Ir as Ir+import qualified Buffet.Toolbox.TextTools as TextTools+import qualified Data.Aeson as Aeson+import qualified Data.Map.Strict as Map+import qualified GHC.Generics as Generics+import Prelude (Eq, Ord, Show)++data Buffet =+  Buffet+    { dishes :: [TemplateDishes.Dish]+    , tagGroups :: Map.Map Ir.TagKey [TemplateTagGroups.TagGroup]+    }+  deriving (Eq, Generics.Generic, Ord, Show)++instance Aeson.ToJSON Buffet where+  toJSON = Aeson.genericToJSON TextTools.defaultJsonOptions++get :: Ir.Buffet -> Buffet+get buffet =+  Buffet+    { dishes = TemplateDishes.get buffet+    , tagGroups = TemplateTagGroups.get buffet+    }
+ src/Buffet/Document/TemplateContext.hs view
@@ -0,0 +1,26 @@+module Buffet.Document.TemplateContext+  ( get+  ) where++import qualified Buffet.Document.TemplateBuffet as TemplateBuffet+import qualified Buffet.Ir.Ir as Ir+import qualified Data.Aeson as Aeson+import qualified Data.Bifunctor as Bifunctor+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Text as T+import Prelude (($), (.), fmap)++get :: Ir.Buffet -> Aeson.Value+get = escapeKeysForMustache . Aeson.toJSON . TemplateBuffet.get++escapeKeysForMustache :: Aeson.Value -> Aeson.Value+escapeKeysForMustache = mapKeys $ T.replace (T.pack ".") (T.pack "_")++mapKeys :: (T.Text -> T.Text) -> Aeson.Value -> Aeson.Value+mapKeys function (Aeson.Array array) =+  Aeson.Array $ fmap (mapKeys function) array+mapKeys function (Aeson.Object object) =+  Aeson.Object .+  HashMap.fromList . fmap (Bifunctor.bimap function $ mapKeys function) $+  HashMap.toList object+mapKeys _ value = value
+ src/Buffet/Document/TemplateDishes.hs view
@@ -0,0 +1,58 @@+{- HLINT ignore "Avoid restricted extensions" -}+{-# LANGUAGE DeriveGeneric #-}++module Buffet.Document.TemplateDishes+  ( Dish+  , get+  ) where++import qualified Buffet.Ir.Ir as Ir+import qualified Buffet.Toolbox.TextTools as TextTools+import qualified Data.Aeson as Aeson+import qualified Data.Map.Strict as Map+import qualified Data.Text as T+import qualified GHC.Generics as Generics+import Prelude (Eq, FilePath, Maybe, Ord, Show, ($), (.), fmap, uncurry)++data Dish =+  Dish+    { option :: Ir.Option+    , dockerfilePath :: FilePath+    , metadata :: Metadata+    , healthCheck :: Maybe T.Text+    }+  deriving (Eq, Generics.Generic, Ord, Show)++instance Aeson.ToJSON Dish where+  toJSON = Aeson.genericToJSON TextTools.defaultJsonOptions++data Metadata =+  Metadata+    { title :: T.Text+    , url :: T.Text+    , tags :: Map.Map Ir.TagKey [Ir.TagValue]+    }+  deriving (Eq, Generics.Generic, Ord, Show)++instance Aeson.ToJSON Metadata where+  toJSON = Aeson.genericToJSON TextTools.defaultJsonOptions++get :: Ir.Buffet -> [Dish]+get = fmap (uncurry transformDish) . Map.toAscList . Ir.optionToDish++transformDish :: Ir.Option -> Ir.Dish -> Dish+transformDish option' dish =+  Dish+    { option = option'+    , dockerfilePath = Ir.dockerfilePath dish+    , metadata = transformMetadata $ Ir.metadata dish+    , healthCheck = Ir.healthCheck dish+    }++transformMetadata :: Ir.Metadata -> Metadata+transformMetadata metadata' =+  Metadata+    { title = Ir.title metadata'+    , url = Ir.url metadata'+    , tags = Ir.tags metadata'+    }
+ src/Buffet/Document/TemplateTagGroups.hs view
@@ -0,0 +1,54 @@+{- HLINT ignore "Avoid restricted extensions" -}+{-# LANGUAGE DeriveGeneric #-}++module Buffet.Document.TemplateTagGroups+  ( TagGroup+  , get+  ) where++import qualified Buffet.Ir.Ir as Ir+import qualified Buffet.Toolbox.TextTools as TextTools+import qualified Data.Aeson as Aeson+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import qualified GHC.Generics as Generics+import Prelude (Eq, Ord, Show, ($), (.), concatMap, fmap)++data TagGroup =+  TagGroup+    { value :: Ir.TagValue+    , dishes :: [Ir.Option]+    }+  deriving (Eq, Generics.Generic, Ord, Show)++instance Aeson.ToJSON TagGroup where+  toJSON = Aeson.genericToJSON TextTools.defaultJsonOptions++get :: Ir.Buffet -> Map.Map Ir.TagKey [TagGroup]+get = fmap getTagGroup . keyToValueToOption++getTagGroup :: Map.Map Ir.TagValue (Set.Set Ir.Option) -> [TagGroup]+getTagGroup =+  fmap+    (\(value', options) ->+       TagGroup {value = value', dishes = Set.toAscList options}) .+  Map.toAscList++keyToValueToOption ::+     Ir.Buffet -> Map.Map Ir.TagKey (Map.Map Ir.TagValue (Set.Set Ir.Option))+keyToValueToOption buffet = Map.unionsWith (Map.unionWith Set.union) singletons+  where+    singletons =+      concatMap+        (\(option, dish) ->+           concatMap+             (\(key, values) ->+                fmap+                  (\value' ->+                     Map.singleton key . Map.singleton value' $+                     Set.singleton option)+                  values) .+           Map.toList . Ir.tags $+           Ir.metadata dish) $+      Map.toList optionToDish+    optionToDish = Ir.optionToDish buffet
+ src/Buffet/Facade.hs view
@@ -0,0 +1,87 @@+module Buffet.Facade+  ( BuildArguments(..)+  , Command(..)+  , DocumentArguments(..)+  , ParseArguments(..)+  , TestArguments(..)+  , get+  ) where++import qualified Buffet.Build.Build as Build+import qualified Buffet.Document.Configuration as Document+import qualified Buffet.Document.Document as Document+import qualified Buffet.Parse.Parse as Parse+import qualified Buffet.Test.Configuration as Test+import qualified Buffet.Test.Test as Test+import qualified Data.Text as T+import qualified Data.Text.IO as T.IO+import Prelude (Bool, Eq, FilePath, IO, Maybe, Ord, Show, (>>=), uncurry)+import qualified System.Exit as Exit++data Command+  = Build BuildArguments+  | Document DocumentArguments+  | Parse ParseArguments+  | Test TestArguments+  deriving (Eq, Ord, Show)++newtype BuildArguments =+  BuildArguments+    { buildMenu :: FilePath+    }+  deriving (Eq, Ord, Show)++data DocumentArguments =+  DocumentArguments+    { documentTemplate :: Maybe FilePath+    , documentMenu :: FilePath+    }+  deriving (Eq, Ord, Show)++newtype ParseArguments =+  ParseArguments+    { parseMenu :: FilePath+    }+  deriving (Eq, Ord, Show)++data TestArguments =+  TestArguments+    { testArguments :: Maybe FilePath+    , testMenu :: FilePath+    }+  deriving (Eq, Ord, Show)++get :: Command -> IO ()+get command =+  case command of+    Build arguments -> build arguments+    Document arguments -> document arguments+    Parse arguments -> parse arguments+    Test arguments -> test arguments++build :: BuildArguments -> IO ()+build arguments = Build.get (buildMenu arguments) >>= T.IO.putStr++document :: DocumentArguments -> IO ()+document arguments =+  Document.get configuration (documentMenu arguments) >>= T.IO.putStr+  where+    configuration =+      Document.Configuration {Document.template = documentTemplate arguments}++parse :: ParseArguments -> IO ()+parse arguments = Parse.get (parseMenu arguments) >>= T.IO.putStr++test :: TestArguments -> IO ()+test arguments =+  Test.get configuration (testMenu arguments) >>= uncurry exitPrintingStdout+  where+    configuration =+      Test.Configuration {Test.arguments = testArguments arguments}++exitPrintingStdout :: Bool -> T.Text -> IO a+exitPrintingStdout isSuccess result = do+  T.IO.putStr result+  if isSuccess+    then Exit.exitSuccess+    else Exit.exitFailure
+ src/Buffet/Ir/Ir.hs view
@@ -0,0 +1,99 @@+module Buffet.Ir.Ir+  ( Buffet(..)+  , Dish(..)+  , DockerfilePart+  , Metadata(..)+  , Option(..)+  , TagKey(..)+  , TagValue(..)+  ) where++import qualified Buffet.Toolbox.TextTools as TextTools+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Types as Types+import qualified Data.Function as Function+import qualified Data.Map.Strict as Map+import qualified Data.Ord as Ord+import qualified Data.Text as T+import qualified Data.Yaml as Yaml+import qualified Language.Docker as Docker+import Prelude (Eq, FilePath, Maybe, Ord, Show, (.), fmap)++data Buffet =+  Buffet+    { copyDummySourcePath :: T.Text+    , optionToDish :: Map.Map Option Dish+    }+  deriving (Eq, Ord, Show)++newtype Option =+  Option+    { option :: T.Text+    }+  deriving (Eq, Show)++instance Ord Option where+  compare = Function.on TextTools.lexicographicalCompare option++instance Aeson.ToJSON Option where+  toJSON = Aeson.toJSON . option++instance Aeson.ToJSONKey Option where+  toJSONKey = Types.toJSONKeyText option++instance Yaml.FromJSON Option where+  parseJSON = fmap Option . Yaml.parseJSON++instance Types.FromJSONKey Option where+  fromJSONKey = Aeson.FromJSONKeyText Option++data Dish =+  Dish+    { dockerfilePath :: FilePath+    , metadata :: Metadata+    , beforeFirstBuildStage :: DockerfilePart+    , localBuildStages :: [DockerfilePart]+    , globalBuildStage :: DockerfilePart+    , healthCheck :: Maybe T.Text+    }+  deriving (Eq, Ord, Show)++data Metadata =+  Metadata+    { title :: T.Text+    , url :: T.Text+    , tags :: Map.Map TagKey [TagValue]+    }+  deriving (Eq, Ord, Show)++newtype TagKey =+  TagKey+    { tagKey :: T.Text+    }+  deriving (Eq, Show)++instance Ord TagKey where+  compare = Function.on TextTools.lexicographicalCompare tagKey++instance Aeson.ToJSON TagKey where+  toJSON = Aeson.toJSON . tagKey++instance Aeson.ToJSONKey TagKey where+  toJSONKey = Types.toJSONKeyText tagKey++newtype TagValue =+  TagValue+    { tagValue :: T.Text+    }+  deriving (Eq, Show)++instance Ord TagValue where+  compare = Function.on TextTools.lexicographicalCompare tagValue++instance Aeson.ToJSON TagValue where+  toJSON = Aeson.toJSON . tagValue++instance Aeson.ToJSONKey TagValue where+  toJSONKey = Types.toJSONKeyText tagValue++type DockerfilePart = [Docker.Instruction T.Text]
+ src/Buffet/Parse/Menu.hs view
@@ -0,0 +1,20 @@+module Buffet.Parse.Menu+  ( Menu(..)+  , defaultMenu+  ) where++import qualified Buffet.Ir.Ir as Ir+import qualified Data.Map.Strict as Map+import qualified Data.Text as T+import Prelude (Eq, FilePath, Ord, Show)++data Menu =+  Menu+    { copyDummySourcePath :: T.Text+    , optionToDish :: Map.Map Ir.Option FilePath+    }+  deriving (Eq, Ord, Show)++defaultMenu :: Menu+defaultMenu =+  Menu {copyDummySourcePath = T.pack "/var/empty", optionToDish = Map.empty}
+ src/Buffet/Parse/Parse.hs view
@@ -0,0 +1,11 @@+module Buffet.Parse.Parse+  ( get+  ) where++import qualified Buffet.Parse.ParseInternal as ParseInternal+import qualified Buffet.Parse.Print as Print+import qualified Data.Text as T+import Prelude (FilePath, IO, (.), fmap)++get :: FilePath -> IO T.Text+get = fmap Print.get . ParseInternal.get
+ src/Buffet/Parse/ParseDish.hs view
@@ -0,0 +1,47 @@+module Buffet.Parse.ParseDish+  ( get+  ) where++import qualified Buffet.Ir.Ir as Ir+import qualified Buffet.Parse.ParseGlobalBuildStage as ParseGlobalBuildStage+import qualified Buffet.Parse.ParseHealthCheck as ParseHealthCheck+import qualified Buffet.Parse.ParseMetadata as ParseMetadata+import qualified Buffet.Parse.PartitionByBuildStage as PartitionByBuildStage+import qualified Buffet.Toolbox.ExceptionTools as ExceptionTools+import qualified Control.Exception as Exception+import qualified Language.Docker as Docker+import qualified Language.Docker.Parser as Parser+import Prelude (FilePath, IO, Show, ($), (.), fmap, pure, show)++newtype Exception =+  Exception Parser.Error++instance Show Exception where+  show (Exception error) = Docker.errorBundlePretty error++instance Exception.Exception Exception++get :: FilePath -> IO Ir.Dish+get dockerfilePath = do+  dockerfile <- parseDockerfile dockerfilePath+  pure $ parseDish dockerfilePath dockerfile++parseDockerfile :: FilePath -> IO Docker.Dockerfile+parseDockerfile = ExceptionTools.eitherThrow Exception . Docker.parseFile++parseDish :: FilePath -> Docker.Dockerfile -> Ir.Dish+parseDish dockerfilePath dockerfile =+  Ir.Dish+    { Ir.dockerfilePath = dockerfilePath+    , Ir.metadata = ParseMetadata.get globalStage+    , Ir.beforeFirstBuildStage = dropPositions beforeFirstStage+    , Ir.localBuildStages = fmap dropPositions localStages+    , Ir.globalBuildStage = ParseGlobalBuildStage.get globalStage+    , Ir.healthCheck = ParseHealthCheck.get globalStage+    }+  where+    (beforeFirstStage, localStages, globalStage) =+      PartitionByBuildStage.get dockerfile++dropPositions :: Docker.Dockerfile -> Ir.DockerfilePart+dropPositions = fmap Docker.instruction
+ src/Buffet/Parse/ParseGlobalBuildStage.hs view
@@ -0,0 +1,14 @@+module Buffet.Parse.ParseGlobalBuildStage+  ( get+  ) where++import qualified Buffet.Ir.Ir as Ir+import qualified Language.Docker as Docker+import Prelude (Bool(False, True), (.), filter, fmap)++get :: Docker.Dockerfile -> Ir.DockerfilePart+get = fmap Docker.instruction . filter isTaken+  where+    isTaken (Docker.InstructionPos (Docker.Healthcheck _) _ _) = False+    isTaken (Docker.InstructionPos (Docker.Label _) _ _) = False+    isTaken _ = True
+ src/Buffet/Parse/ParseHealthCheck.hs view
@@ -0,0 +1,33 @@+module Buffet.Parse.ParseHealthCheck+  ( get+  ) where++import qualified Data.Maybe as Maybe+import qualified Data.Text as T+import qualified Language.Docker as Docker+import qualified Language.Docker.Syntax as Syntax+import Prelude (Maybe(Just, Nothing), ($), (.), reverse)++get :: Docker.Dockerfile -> Maybe T.Text+get stage =+  case lastHealthcheck stage of+    Just (Docker.Check checkArguments) ->+      Just . reviveCommandStyle . argumentsText $+      Docker.checkCommand checkArguments+    _ -> Nothing++reviveCommandStyle :: T.Text -> T.Text+reviveCommandStyle = reviveLineBreaks+  where+    reviveLineBreaks = T.replace (T.pack "   ") $ T.pack " \\\n  "++lastHealthcheck :: Docker.Dockerfile -> Maybe (Docker.Check T.Text)+lastHealthcheck = Maybe.listToMaybe . reverse . Maybe.mapMaybe maybeHealthcheck+  where+    maybeHealthcheck (Docker.InstructionPos (Docker.Healthcheck check) _ _) =+      Just check+    maybeHealthcheck _ = Nothing++argumentsText :: Docker.Arguments T.Text -> T.Text+argumentsText (Syntax.ArgumentsText text) = text+argumentsText (Syntax.ArgumentsList list) = list
+ src/Buffet/Parse/ParseInternal.hs view
@@ -0,0 +1,36 @@+module Buffet.Parse.ParseInternal+  ( get+  ) where++import qualified Buffet.Ir.Ir as Ir+import qualified Buffet.Parse.Menu as Menu+import qualified Buffet.Parse.ParseDish as ParseDish+import qualified Buffet.Parse.ParseMenu as ParseMenu+import qualified Buffet.Toolbox.ExceptionTools as ExceptionTools+import qualified Control.Exception as Exception+import qualified Control.Monad as Monad+import qualified Language.Docker as Docker+import qualified Language.Docker.Parser as Parser+import Prelude (FilePath, IO, Show, ($), (.), fmap, pure, show)++newtype Exception =+  Exception Parser.Error++instance Show Exception where+  show (Exception error) = Docker.errorBundlePretty error++instance Exception.Exception Exception++get :: FilePath -> IO Ir.Buffet+get = ParseMenu.get Monad.>=> parseBuffet++parseBuffet :: Menu.Menu -> IO Ir.Buffet+parseBuffet menu = do+  optionToDish <-+    ExceptionTools.sequenceAccumulatingExceptions . fmap ParseDish.get $+    Menu.optionToDish menu+  pure+    Ir.Buffet+      { Ir.copyDummySourcePath = Menu.copyDummySourcePath menu+      , Ir.optionToDish = optionToDish+      }
+ src/Buffet/Parse/ParseMenu.hs view
@@ -0,0 +1,29 @@+module Buffet.Parse.ParseMenu+  ( get+  ) where++import qualified Buffet.Parse.Menu as Menu+import qualified Buffet.Parse.ParseMenuFromFile as ParseMenuFromFile+import qualified Buffet.Parse.ParseMenuFromFolder as ParseMenuFromFolder+import qualified Control.Exception as Exception+import Prelude (FilePath, IO, Show, ($), (<>), show)+import qualified System.Directory as Directory++newtype Exception =+  Exception FilePath++instance Show Exception where+  show (Exception path) = "No such menu file or folder: " <> path++instance Exception.Exception Exception++get :: FilePath -> IO Menu.Menu+get menu = do+  isAvailable <- Directory.doesPathExist menu+  if isAvailable+    then do+      isFolder <- Directory.doesDirectoryExist menu+      if isFolder+        then ParseMenuFromFolder.get menu+        else ParseMenuFromFile.get menu+    else Exception.throwIO $ Exception menu
+ src/Buffet/Parse/ParseMenuFromFile.hs view
@@ -0,0 +1,73 @@+{- HLINT ignore "Avoid restricted extensions" -}+{-# LANGUAGE DeriveGeneric #-}++module Buffet.Parse.ParseMenuFromFile+  ( get+  ) where++import qualified Buffet.Ir.Ir as Ir+import qualified Buffet.Parse.Menu as Menu+import qualified Buffet.Toolbox.ExceptionTools as ExceptionTools+import qualified Buffet.Toolbox.TextTools as TextTools+import qualified Control.Exception as Exception+import qualified Data.Aeson as Aeson+import qualified Data.Map.Strict as Map+import qualified Data.Maybe as Maybe+import qualified Data.Text as T+import qualified Data.Yaml as Yaml+import qualified GHC.Generics as Generics+import Prelude+  ( Eq+  , FilePath+  , IO+  , Maybe+  , Ord+  , Show+  , ($)+  , fmap+  , maybe+  , mconcat+  , pure+  , show+  )+import qualified System.FilePath as FilePath++data Exception =+  Exception FilePath Yaml.ParseException++instance Show Exception where+  show (Exception path exception) =+    mconcat [path, ":\n", Yaml.prettyPrintParseException exception]++instance Exception.Exception Exception++data RawMenu =+  RawMenu+    { copyDummySourcePath :: Maybe T.Text+    , optionToDish :: Maybe (Map.Map Ir.Option FilePath)+    }+  deriving (Eq, Generics.Generic, Ord, Show)++instance Yaml.FromJSON RawMenu where+  parseJSON = Aeson.genericParseJSON TextTools.defaultJsonOptions++get :: FilePath -> IO Menu.Menu+get menu = do+  raw <- getRaw menu+  pure+    Menu.Menu+      { Menu.copyDummySourcePath =+          Maybe.fromMaybe (Menu.copyDummySourcePath Menu.defaultMenu) $+          copyDummySourcePath raw+      , Menu.optionToDish =+          maybe+            (Menu.optionToDish Menu.defaultMenu)+            (fmap $ FilePath.combine folder) $+          optionToDish raw+      }+  where+    folder = FilePath.takeDirectory menu++getRaw :: FilePath -> IO RawMenu+getRaw menu =+  ExceptionTools.eitherThrow (Exception menu) $ Yaml.decodeFileEither menu
+ src/Buffet/Parse/ParseMenuFromFolder.hs view
@@ -0,0 +1,30 @@+module Buffet.Parse.ParseMenuFromFolder+  ( get+  ) where++import qualified Buffet.Ir.Ir as Ir+import qualified Buffet.Parse.Menu as Menu+import qualified Control.Monad as Monad+import qualified Data.Map.Strict as Map+import qualified Data.Text as T+import Prelude (FilePath, IO, ($), (.), fmap, pure)+import qualified System.Directory as Directory+import qualified System.FilePath as FilePath++get :: FilePath -> IO Menu.Menu+get menu = do+  folderEntries <- Directory.listDirectory menu+  options <-+    Monad.filterM+      (Directory.doesDirectoryExist . FilePath.combine menu)+      folderEntries+  pure+    Menu.defaultMenu+      { Menu.optionToDish =+          Map.fromList $+          fmap+            (\option ->+               ( Ir.Option $ T.pack option+               , FilePath.joinPath [menu, option, "Dockerfile"]))+            options+      }
+ src/Buffet/Parse/ParseMetadata.hs view
@@ -0,0 +1,54 @@+module Buffet.Parse.ParseMetadata+  ( get+  ) where++import qualified Buffet.Ir.Ir as Ir+import qualified Buffet.Toolbox.TextTools as TextTools+import qualified Data.Csv as Csv+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import qualified Data.Text as T+import qualified Data.Vector as Vector+import qualified Language.Docker as Docker+import Prelude+  ( Maybe(Just, Nothing)+  , ($)+  , (.)+  , concatMap+  , const+  , either+  , fmap+  , maybe+  , mconcat+  , mempty+  )++get :: Docker.Dockerfile -> Ir.Metadata+get stage =+  Ir.Metadata+    { Ir.title = Map.findWithDefault mempty titleKey labels+    , Ir.url = Map.findWithDefault mempty urlKey labels+    , Ir.tags = parseTags tagLabels+    }+  where+    titleKey = T.pack "org.opencontainers.image.title"+    labels = parseLabels stage+    urlKey = T.pack "org.opencontainers.image.url"+    tagLabels = Map.withoutKeys labels $ Set.fromList [titleKey, urlKey]++parseLabels :: Docker.Dockerfile -> Map.Map T.Text T.Text+parseLabels = Map.fromList . concatMap labelBindings+  where+    labelBindings (Docker.InstructionPos (Docker.Label pairs) _ _) = pairs+    labelBindings _ = []++parseTags :: Map.Map T.Text T.Text -> Map.Map Ir.TagKey [Ir.TagValue]+parseTags = fmap parseTagValues . Map.mapKeys Ir.TagKey++parseTagValues :: T.Text -> [Ir.TagValue]+parseTagValues raw = fmap Ir.TagValue . maybe [raw] mconcat $ parseCsv raw++parseCsv :: T.Text -> Maybe [[T.Text]]+parseCsv =+  either (const Nothing) (Just . Vector.toList) .+  Csv.decode Csv.NoHeader . TextTools.encodeUtf8
+ src/Buffet/Parse/PartitionByBuildStage.hs view
@@ -0,0 +1,26 @@+module Buffet.Parse.PartitionByBuildStage+  ( get+  ) where++import qualified Data.List.Split as Split+import qualified Language.Docker as Docker+import Prelude (Bool(False, True), ($), length, mconcat, pred, splitAt)++get ::+     Docker.Dockerfile+  -> (Docker.Dockerfile, [Docker.Dockerfile], Docker.Dockerfile)+get dockerfile = (beforeFirstStage, localStages, globalStage)+  where+    (beforeFirstStage, stages) =+      case parts of+        [] -> ([], [])+        (first:rest) -> (first, rest)+    parts = Split.split splitter dockerfile+    splitter = Split.keepDelimsL $ Split.whenElt isFrom+    (localStages, globalStageInstructions) =+      splitAt (pred $ length stages) stages+    globalStage = mconcat globalStageInstructions++isFrom :: Docker.InstructionPos a -> Bool+isFrom (Docker.InstructionPos (Docker.From _) _ _) = True+isFrom _ = False
+ src/Buffet/Parse/Print.hs view
@@ -0,0 +1,85 @@+{- HLINT ignore "Avoid restricted extensions" -}+{-# LANGUAGE DeriveGeneric #-}++module Buffet.Parse.Print+  ( get+  ) where++import qualified Buffet.Ir.Ir as Ir+import qualified Buffet.Toolbox.DockerTools as DockerTools+import qualified Buffet.Toolbox.TextTools as TextTools+import qualified Data.Aeson as Aeson+import qualified Data.Map.Strict as Map+import qualified Data.Text as T+import qualified GHC.Generics as Generics+import qualified Language.Docker as Docker+import Prelude (Eq, FilePath, Maybe, Ord, Show, ($), (.), (<$>), fmap)++data Buffet =+  Buffet+    { copyDummySourcePath :: T.Text+    , optionToDish :: Map.Map Ir.Option Dish+    }+  deriving (Eq, Generics.Generic, Ord, Show)++instance Aeson.ToJSON Buffet where+  toJSON = Aeson.genericToJSON TextTools.defaultJsonOptions++data Dish =+  Dish+    { dockerfilePath :: FilePath+    , metadata :: Metadata+    , beforeFirstBuildStage :: DockerfilePart+    , localBuildStages :: [DockerfilePart]+    , globalBuildStage :: DockerfilePart+    , healthCheck :: Maybe T.Text+    }+  deriving (Eq, Generics.Generic, Ord, Show)++instance Aeson.ToJSON Dish where+  toJSON = Aeson.genericToJSON TextTools.defaultJsonOptions++data Metadata =+  Metadata+    { title :: T.Text+    , url :: T.Text+    , tags :: Map.Map Ir.TagKey [Ir.TagValue]+    }+  deriving (Eq, Generics.Generic, Ord, Show)++instance Aeson.ToJSON Metadata where+  toJSON = Aeson.genericToJSON TextTools.defaultJsonOptions++type DockerfilePart = [T.Text]++get :: Ir.Buffet -> T.Text+get = TextTools.prettyPrintJson . transformBuffet++transformBuffet :: Ir.Buffet -> Buffet+transformBuffet buffet =+  Buffet+    { copyDummySourcePath = Ir.copyDummySourcePath buffet+    , optionToDish = transformDish <$> Ir.optionToDish buffet+    }++transformDish :: Ir.Dish -> Dish+transformDish dish =+  Dish+    { dockerfilePath = Ir.dockerfilePath dish+    , metadata = transformMetadata $ Ir.metadata dish+    , beforeFirstBuildStage =+        transformDockerfilePart $ Ir.beforeFirstBuildStage dish+    , localBuildStages = transformDockerfilePart <$> Ir.localBuildStages dish+    , globalBuildStage = transformDockerfilePart $ Ir.globalBuildStage dish+    , healthCheck = Ir.healthCheck dish+    }++transformMetadata :: Ir.Metadata -> Metadata+transformMetadata meta =+  Metadata {title = Ir.title meta, url = Ir.url meta, tags = Ir.tags meta}++transformDockerfilePart :: Ir.DockerfilePart -> DockerfilePart+transformDockerfilePart = fmap transformInstruction++transformInstruction :: Docker.Instruction T.Text -> T.Text+transformInstruction = T.stripEnd . DockerTools.printInstruction
+ src/Buffet/Test/Configuration.hs view
@@ -0,0 +1,11 @@+module Buffet.Test.Configuration+  ( Configuration(..)+  ) where++import Prelude (Eq, FilePath, Maybe, Ord, Show)++newtype Configuration =+  Configuration+    { arguments :: Maybe FilePath+    }+  deriving (Eq, Ord, Show)
+ src/Buffet/Test/ParseArguments.hs view
@@ -0,0 +1,29 @@+module Buffet.Test.ParseArguments+  ( get+  ) where++import qualified Buffet.Ir.Ir as Ir+import qualified Buffet.Test.Configuration as Configuration+import qualified Buffet.Toolbox.ExceptionTools as ExceptionTools+import qualified Control.Exception as Exception+import qualified Data.Map.Strict as Map+import qualified Data.Text as T+import qualified Data.Yaml as Yaml+import Prelude (FilePath, IO, Show, ($), (.), maybe, mconcat, pure, show)++data Exception =+  Exception FilePath Yaml.ParseException++instance Show Exception where+  show (Exception path exception) =+    mconcat [path, ":\n", Yaml.prettyPrintParseException exception]++instance Exception.Exception Exception++get :: Configuration.Configuration -> IO (Map.Map Ir.Option T.Text)+get =+  maybe+    (pure Map.empty)+    (\file ->+       ExceptionTools.eitherThrow (Exception file) $ Yaml.decodeFileEither file) .+  Configuration.arguments
+ src/Buffet/Test/Test.hs view
@@ -0,0 +1,13 @@+module Buffet.Test.Test+  ( get+  ) where++import qualified Buffet.Parse.ParseInternal as ParseInternal+import qualified Buffet.Test.Configuration as Configuration+import qualified Buffet.Test.TestInternal as TestInternal+import qualified Control.Monad as Monad+import qualified Data.Text as T+import Prelude (Bool, FilePath, IO)++get :: Configuration.Configuration -> FilePath -> IO (Bool, T.Text)+get configuration = ParseInternal.get Monad.>=> TestInternal.get configuration
+ src/Buffet/Test/TestDish.hs view
@@ -0,0 +1,46 @@+module Buffet.Test.TestDish+  ( get+  ) where++import qualified Buffet.Ir.Ir as Ir+import qualified Buffet.Test.TestResult as TestResult+import qualified Buffet.Test.TestSetup as TestSetup+import qualified Data.Foldable as Foldable+import qualified Data.Text as T+import Prelude (Bool, IO, Maybe(Nothing), ($), (.), (==), pure, traverse)+import qualified System.Exit as Exit+import qualified System.Process.Typed as Process++get :: TestSetup.TestSetup -> IO TestResult.TestResult+get testSetup = do+  healthCheckPassed' <-+    if T.null optionValue'+      then pure Nothing+      else checkHealth testSetup+  pure+    TestResult.TestResult+      { TestResult.optionValue = optionValue'+      , TestResult.healthCheckPassed = healthCheckPassed'+      }+  where+    optionValue' = Foldable.fold $ TestSetup.optionValue testSetup++checkHealth :: TestSetup.TestSetup -> IO (Maybe Bool)+checkHealth testSetup = traverse run . Ir.healthCheck $ TestSetup.dish testSetup+  where+    run command = do+      exitCode <-+        Process.runProcess .+        Process.setStderr (Process.useHandleOpen log) .+        Process.setStdout (Process.useHandleOpen log) $+        Process.proc+          "docker"+          [ "run"+          , "--rm"+          , T.unpack $ TestSetup.image testSetup+          , "sh"+          , "-c"+          , T.unpack command+          ]+      pure $ exitCode == Exit.ExitSuccess+    log = TestSetup.log testSetup
+ src/Buffet/Test/TestInternal.hs view
@@ -0,0 +1,55 @@+module Buffet.Test.TestInternal+  ( get+  ) where++import qualified Buffet.Build.BuildInternal as BuildInternal+import qualified Buffet.Ir.Ir as Ir+import qualified Buffet.Test.Configuration as Configuration+import qualified Buffet.Test.ParseArguments as ParseArguments+import qualified Buffet.Test.TestDish as TestDish+import qualified Buffet.Test.TestResult as TestResult+import qualified Buffet.Test.TestSetup as TestSetup+import qualified Buffet.Test.UsingDockerImage as UsingDockerImage+import qualified Buffet.Toolbox.TextTools as TextTools+import qualified Data.Map.Strict as Map+import qualified Data.Maybe as Maybe+import qualified Data.Text as T+import Prelude (Bool(True), IO, ($), (.), (<$>), and, fmap, sequenceA)+import qualified System.IO as IO++type TestResults = Map.Map Ir.Option TestResult.TestResult++get :: Configuration.Configuration -> Ir.Buffet -> IO (Bool, T.Text)+get configuration buffet = do+  arguments <- ParseArguments.get configuration+  let use image = evaluateTestResults <$> sequenceA tests+        where+          tests = Map.mapWithKey test $ Ir.optionToDish buffet+          test option dish =+            TestDish.get+              TestSetup.TestSetup+                { TestSetup.log = log+                , TestSetup.image = image+                , TestSetup.option = option+                , TestSetup.optionValue = Map.lookup option arguments+                , TestSetup.dish = dish+                }+      imageConfiguration =+        UsingDockerImage.Configuration+          { UsingDockerImage.log = log+          , UsingDockerImage.dockerBuild =+              UsingDockerImage.DockerBuild+                { UsingDockerImage.dockerfile = BuildInternal.get buffet+                , UsingDockerImage.arguments = arguments+                }+          }+  UsingDockerImage.get use imageConfiguration+  where+    log = IO.stderr++evaluateTestResults :: TestResults -> (Bool, T.Text)+evaluateTestResults testResults =+  (and $ fmap isSuccess testResults, TextTools.prettyPrintJson testResults)++isSuccess :: TestResult.TestResult -> Bool+isSuccess = Maybe.fromMaybe True . TestResult.healthCheckPassed
+ src/Buffet/Test/TestResult.hs view
@@ -0,0 +1,22 @@+{- HLINT ignore "Avoid restricted extensions" -}+{-# LANGUAGE DeriveGeneric #-}++module Buffet.Test.TestResult+  ( TestResult(..)+  ) where++import qualified Buffet.Toolbox.TextTools as TextTools+import qualified Data.Aeson as Aeson+import qualified Data.Text as T+import qualified GHC.Generics as Generics+import Prelude (Bool, Eq, Maybe, Ord, Show)++data TestResult =+  TestResult+    { optionValue :: T.Text+    , healthCheckPassed :: Maybe Bool+    }+  deriving (Eq, Generics.Generic, Ord, Show)++instance Aeson.ToJSON TestResult where+  toJSON = Aeson.genericToJSON TextTools.defaultJsonOptions
+ src/Buffet/Test/TestSetup.hs view
@@ -0,0 +1,18 @@+module Buffet.Test.TestSetup+  ( TestSetup(..)+  ) where++import qualified Buffet.Ir.Ir as Ir+import qualified Data.Text as T+import Prelude (Eq, Maybe, Show)+import qualified System.IO as IO++data TestSetup =+  TestSetup+    { log :: IO.Handle+    , image :: T.Text+    , option :: Ir.Option+    , optionValue :: Maybe T.Text+    , dish :: Ir.Dish+    }+  deriving (Eq, Show)
+ src/Buffet/Test/UsingDockerImage.hs view
@@ -0,0 +1,80 @@+module Buffet.Test.UsingDockerImage+  ( Configuration(..)+  , DockerBuild(..)+  , get+  ) where++import qualified Buffet.Ir.Ir as Ir+import qualified Buffet.Toolbox.TextTools as TextTools+import qualified Control.Exception as Exception+import qualified Data.Map.Strict as Map+import qualified Data.Text as T+import qualified Data.Word as Word+import qualified Numeric+import Prelude (Eq, IO, Ord, Show, ($), (.), concatMap, mconcat, pure)+import qualified System.IO as IO+import qualified System.Process.Typed as Process+import qualified System.Random as Random++data Configuration =+  Configuration+    { log :: IO.Handle+    , dockerBuild :: DockerBuild+    }+  deriving (Eq, Show)++data DockerBuild =+  DockerBuild+    { dockerfile :: T.Text+    , arguments :: Map.Map Ir.Option T.Text+    }+  deriving (Eq, Ord, Show)++get :: (T.Text -> IO a) -> Configuration -> IO a+get useImage configuration =+  Exception.bracket+    (buildImage configuration)+    (removeImage configuration)+    useImage++buildImage :: Configuration -> IO T.Text+buildImage configuration = do+  image <- randomImage+  let processBase =+        Process.proc "docker" $+        mconcat [["build", "--tag", T.unpack image], buildArgs, ["-"]]+  Process.runProcess_ .+    Process.setStderr (Process.useHandleOpen log') .+    Process.setStdout (Process.useHandleOpen log') $+    Process.setStdin (textInput dockerfile') processBase+  pure image+  where+    buildArgs =+      concatMap+        (\(key, value) ->+           [ "--build-arg"+           , mconcat [T.unpack $ Ir.option key, "=", T.unpack value]+           ]) $+      Map.toAscList arguments'+    arguments' = arguments $ dockerBuild configuration+    log' = log configuration+    textInput = Process.byteStringInput . TextTools.encodeUtf8+    dockerfile' = dockerfile $ dockerBuild configuration++randomImage :: IO T.Text+randomImage = do+  tagNumber <- Random.randomIO+  let _ = tagNumber :: Word.Word64+      tag = T.pack $ Numeric.showHex tagNumber ""+  pure $ mconcat [name, T.pack ":", tag]+  where+    name = T.pack "buffet-tmp"++removeImage :: Configuration -> T.Text -> IO ()+removeImage configuration image =+  Process.runProcess_ .+  Process.setStderr (Process.useHandleOpen log') .+  Process.setStdout (Process.useHandleOpen log') $+  Process.proc "docker" ["rmi", T.unpack image]+  where+    log' = log configuration
+ src/Buffet/Toolbox/DockerTools.hs view
@@ -0,0 +1,15 @@+module Buffet.Toolbox.DockerTools+  ( printInstruction+  ) where++import qualified Data.Text as T+import qualified Data.Text.Lazy as Lazy+import qualified Language.Docker as Docker+import qualified Language.Docker.Syntax as Syntax+import Prelude (($), mconcat)++printInstruction :: Docker.Instruction T.Text -> T.Text+printInstruction (Docker.Run (Syntax.ArgumentsText command)) =+  T.unlines [mconcat [T.pack "RUN ", command]]+printInstruction instruction =+  Lazy.toStrict $ Docker.prettyPrint [Docker.instructionPos instruction]
+ src/Buffet/Toolbox/ExceptionTools.hs view
@@ -0,0 +1,46 @@+module Buffet.Toolbox.ExceptionTools+  ( eitherThrow+  , sequenceAccumulatingExceptions+  ) where++import qualified Control.Exception as Exception+import qualified Data.Either as Either+import qualified Data.Foldable as Foldable+import qualified Data.List.NonEmpty as NonEmpty+import Prelude+  ( Either+  , IO+  , Show+  , Traversable+  , ($)+  , (.)+  , (>>=)+  , either+  , fmap+  , maybe+  , pure+  , show+  , traverse+  , undefined+  , unlines+  )++newtype ExceptionList =+  ExceptionList (NonEmpty.NonEmpty Exception.SomeException)++instance Show ExceptionList where+  show (ExceptionList exceptions) =+    unlines . NonEmpty.toList $ fmap show exceptions++instance Exception.Exception ExceptionList++eitherThrow :: Exception.Exception e => (a -> e) -> IO (Either a b) -> IO b+eitherThrow toException = (>>= either (Exception.throwIO . toException) pure)++sequenceAccumulatingExceptions :: Traversable t => t (IO a) -> IO (t a)+sequenceAccumulatingExceptions actions = do+  results <- traverse Exception.try actions+  let successes = fmap (Either.fromRight undefined) results+      failures = Either.lefts $ Foldable.toList results+  maybe (pure successes) (Exception.throwIO . ExceptionList) $+    NonEmpty.nonEmpty failures
+ src/Buffet/Toolbox/TextTools.hs view
@@ -0,0 +1,47 @@+module Buffet.Toolbox.TextTools+  ( decodeUtf8+  , defaultJsonOptions+  , encodeUtf8+  , intercalateNewline+  , lexicographicalCompare+  , prettyPrintJson+  ) where++import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Encode.Pretty as Pretty+import qualified Data.ByteString.Lazy as ByteString+import qualified Data.Ord as Ord+import qualified Data.Text as T+import qualified Data.Text.Lazy as Lazy+import qualified Data.Text.Lazy.Encoding as Encoding+import Prelude (Bool(True), Ordering, (.))++decodeUtf8 :: ByteString.ByteString -> T.Text+decodeUtf8 = Lazy.toStrict . Encoding.decodeUtf8++defaultJsonOptions :: Aeson.Options+defaultJsonOptions =+  Aeson.defaultOptions {Aeson.fieldLabelModifier = Aeson.camelTo2 '_'}++encodeUtf8 :: T.Text -> ByteString.ByteString+encodeUtf8 = Encoding.encodeUtf8 . Lazy.fromStrict++intercalateNewline :: [T.Text] -> T.Text+intercalateNewline = T.intercalate newline+  where+    newline = T.pack "\n"++lexicographicalCompare :: T.Text -> T.Text -> Ordering+lexicographicalCompare = Ord.comparing sortKey+  where+    sortKey text = (T.toCaseFold text, text)++prettyPrintJson :: Aeson.ToJSON a => a -> T.Text+prettyPrintJson = decodeUtf8 . Pretty.encodePretty' configuration . Aeson.toJSON+  where+    configuration =+      Pretty.defConfig+        { Pretty.confIndent = Pretty.Spaces 2+        , Pretty.confCompare = lexicographicalCompare+        , Pretty.confTrailingNewline = True+        }
+ test/Buffet/Toolbox/TestHelp.hs view
@@ -0,0 +1,34 @@+{- HLINT ignore "Avoid restricted extensions" -}+{-# LANGUAGE DeriveGeneric #-}++module Buffet.Toolbox.TestHelp+  ( get+  ) where++import qualified Data.Text as T+import qualified Data.Text.Encoding as Encoding+import qualified Data.Yaml as Yaml+import qualified GHC.Generics as Generics+import Prelude (Eq, IO, Maybe(Just, Nothing), Ord, Show, ($), (.), fmap)+import qualified Test.Tasty.HUnit as HUnit++newtype Package =+  Package+    { synopsis :: T.Text+    }+  deriving (Eq, Generics.Generic, Ord, Show)++instance Yaml.FromJSON Package++get :: T.Text -> T.Text -> HUnit.Assertion+get package commandOutput = do+  expectedSynopsis <- getPackageSynopsis package+  HUnit.assertEqual "" (Just expectedSynopsis) actualSynopsis+  where+    actualSynopsis =+      case T.lines commandOutput of+        _:secondLine:_ -> Just $ T.stripStart secondLine+        _ -> Nothing++getPackageSynopsis :: T.Text -> IO T.Text+getPackageSynopsis = fmap synopsis . Yaml.decodeThrow . Encoding.encodeUtf8
+ test/Buffet/Toolbox/TestTools.hs view
@@ -0,0 +1,92 @@+module Buffet.Toolbox.TestTools+  ( assertJsonIsSubstructure+  , folderBasedTests+  ) where++import qualified Buffet.Toolbox.TextTools as TextTools+import qualified Control.Monad as Monad+import qualified Data.Aeson as Aeson+import qualified Data.Function as Function+import qualified Data.HashMap.Strict as HashMap+import qualified Data.HashSet as Set+import qualified Data.List as List+import qualified Data.Text as T+import qualified Data.Text.Encoding as Encoding+import qualified Data.Vector as Vector+import Prelude+  ( FilePath+  , IO+  , String+  , ($)+  , (.)+  , (<)+  , (<>)+  , either+  , error+  , fmap+  , fst+  , id+  , length+  , pure+  , sequence_+  , show+  , snd+  , traverse+  )+import qualified System.Directory as Directory+import qualified System.FilePath as FilePath+import qualified Test.Tasty as Tasty+import qualified Test.Tasty.HUnit as HUnit++assertJsonIsSubstructure :: T.Text -> T.Text -> HUnit.Assertion+assertJsonIsSubstructure = Function.on (assert []) getJson+  where+    assert path (Aeson.Object expected) (Aeson.Object actual) = do+      let missingKeys =+            List.sort . Set.toList $+            Function.on Set.difference HashMap.keysSet expected actual+      HUnit.assertEqual (message path) [] missingKeys+      let asserts =+            fmap snd . List.sortOn fst . HashMap.toList $+            HashMap.intersectionWithKey+              (\key -> assert $ path <> [key])+              expected+              actual+      sequence_ asserts+    assert path (Aeson.Array expected) (Aeson.Array actual) = do+      Function.on+        (HUnit.assertEqual $ message path)+        Vector.length+        expected+        actual+      sequence_ $+        Vector.izipWith+          (\index -> assert (path <> [T.pack $ show index]))+          expected+          actual+    assert path expected actual =+      HUnit.assertEqual (message path) expected actual+    message :: [T.Text] -> String+    message = T.unpack . TextTools.decodeUtf8 . Aeson.encode+    getJson :: T.Text -> Aeson.Value+    getJson = either error id . Aeson.eitherDecodeStrict . Encoding.encodeUtf8++folderBasedTests ::+     (Tasty.TestName -> FilePath -> Tasty.TestTree)+  -> FilePath+  -> IO Tasty.TestTree+folderBasedTests assert folder = do+  folderEntries <- Directory.listDirectory folder+  subfolders <-+    Monad.filterM+      (Directory.doesDirectoryExist . FilePath.combine folder)+      folderEntries+  let hasMoreThanJustFolders = length subfolders < length folderEntries+  if hasMoreThanJustFolders+    then pure $ assert name folder+    else do+      tests <- traverse assertSubfolder $ List.sort subfolders+      pure $ Tasty.testGroup name tests+  where+    name = FilePath.takeFileName $ FilePath.dropTrailingPathSeparator folder+    assertSubfolder = folderBasedTests assert . FilePath.combine folder
+ test/Buffet/Toolbox/TestUtility.hs view
@@ -0,0 +1,139 @@+{- HLINT ignore "Avoid restricted extensions" -}+{-# LANGUAGE DeriveGeneric #-}++module Buffet.Toolbox.TestUtility+  ( Configuration(..)+  , defaultConfiguration+  , get+  ) where++import qualified Buffet.Toolbox.TextTools as TextTools+import qualified Control.Monad as Monad+import qualified Data.Aeson as Aeson+import qualified Data.ByteString as ByteString+import qualified Data.Foldable as Foldable+import qualified Data.Text as T+import qualified Data.Text.Encoding as Encoding+import qualified Data.Yaml as Yaml+import qualified GHC.Generics as Generics+import Prelude+  ( Bool+  , Eq+  , FilePath+  , IO+  , Maybe+  , Ord+  , Show+  , ($)+  , (.)+  , (==)+  , flip+  , fmap+  , maybe+  , pure+  , traverse+  )+import qualified System.Exit as Exit+import qualified System.FilePath as FilePath+import qualified System.Process.Typed as Process+import qualified Test.Tasty.HUnit as HUnit++data Configuration =+  Configuration+    { utility :: FilePath+    , assertIsExitStatusSuccess :: Bool -> Bool -> HUnit.Assertion+    , assertStdout :: T.Text -> T.Text -> HUnit.Assertion+    , assertStderr :: T.Text -> T.Text -> HUnit.Assertion+    }++data RawTest =+  RawTest+    { arguments :: Maybe [Source]+    , stdin :: Maybe Source+    , isExitStatusSuccess :: Maybe Bool+    , stdout :: Maybe Source+    , stderr :: Maybe Source+    }+  deriving (Eq, Generics.Generic, Ord, Show)++instance Yaml.FromJSON RawTest where+  parseJSON = Aeson.genericParseJSON TextTools.defaultJsonOptions++data Source+  = Literal T.Text+  | Path [T.Text]+  deriving (Eq, Generics.Generic, Ord, Show)++instance Yaml.FromJSON Source where+  parseJSON =+    Aeson.genericParseJSON+      TextTools.defaultJsonOptions {Aeson.sumEncoding = Aeson.UntaggedValue}++data Test =+  Test+    { givenArguments :: [T.Text]+    , givenStdin :: Maybe T.Text+    , isExpectedExitStatusSuccess :: Maybe Bool+    , expectedStdout :: Maybe T.Text+    , expectedStderr :: Maybe T.Text+    }+  deriving (Eq, Ord, Show)++defaultConfiguration :: FilePath -> Configuration+defaultConfiguration utility' =+  Configuration+    { utility = utility'+    , assertIsExitStatusSuccess = HUnit.assertEqual "Is exit status success"+    , assertStdout = HUnit.assertEqual "Stdout"+    , assertStderr = HUnit.assertEqual "Stderr"+    }++get :: Configuration -> FilePath -> HUnit.Assertion+get configuration = parse Monad.>=> assert configuration++parse :: FilePath -> IO Test+parse test = do+  raw <- Yaml.decodeFileThrow test+  stdin' <- traverse getStream $ stdin raw+  stdout' <- traverse getStream $ stdout raw+  stderr' <- traverse getStream $ stderr raw+  pure+    Test+      { givenArguments = fmap getArgument . Foldable.fold $ arguments raw+      , givenStdin = stdin'+      , isExpectedExitStatusSuccess = isExitStatusSuccess raw+      , expectedStdout = stdout'+      , expectedStderr = stderr'+      }+  where+    getStream (Literal literal) = pure literal+    getStream (Path path) = readFileUtf8 $ resolvePath path+    readFileUtf8 = fmap Encoding.decodeUtf8 . ByteString.readFile+    resolvePath path = FilePath.joinPath $ folder : fmap T.unpack path+    folder = FilePath.takeDirectory test+    getArgument (Literal literal) = literal+    getArgument (Path path) = T.pack $ resolvePath path++assert :: Configuration -> Test -> HUnit.Assertion+assert configuration test = do+  (exitCode, rawStdout, rawStderr) <- Process.readProcess process+  let isActualExitStatusSuccess = exitCode == Exit.ExitSuccess+      actualStdout = TextTools.decodeUtf8 rawStdout+      actualStderr = TextTools.decodeUtf8 rawStderr+  whenJust (isExpectedExitStatusSuccess test) $ \expected ->+    assertIsExitStatusSuccess configuration expected isActualExitStatusSuccess+  whenJust (expectedStdout test) $ \expected ->+    assertStdout configuration expected actualStdout+  whenJust (expectedStderr test) $ \expected ->+    assertStderr configuration expected actualStderr+  where+    process =+      maybe+        processBase+        (\stdin' -> Process.setStdin (textInput stdin') processBase) $+      givenStdin test+    processBase =+      Process.proc (utility configuration) . fmap T.unpack $ givenArguments test+    textInput = Process.byteStringInput . TextTools.encodeUtf8+    whenJust :: Maybe a -> (a -> IO ()) -> IO ()+    whenJust = flip . maybe $ pure ()
+ test/Buffet/Toolbox/TestVersion.hs view
@@ -0,0 +1,39 @@+{- HLINT ignore "Avoid restricted extensions" -}+{-# LANGUAGE DeriveGeneric #-}++module Buffet.Toolbox.TestVersion+  ( get+  ) where++import qualified Control.Monad as Monad+import qualified Data.Maybe as Maybe+import qualified Data.Text as T+import qualified Data.Text.Encoding as Encoding+import qualified Data.Yaml as Yaml+import qualified GHC.Generics as Generics+import Prelude (Eq, IO, Maybe(Just), Ord, Show, (.), fmap, reverse)+import qualified Test.Tasty.HUnit as HUnit++newtype Package =+  Package+    { version :: T.Text+    }+  deriving (Eq, Generics.Generic, Ord, Show)++instance Yaml.FromJSON Package++get :: T.Text -> T.Text -> HUnit.Assertion+get package commandOutput = do+  expectedVersion <- getPackageVersion package+  HUnit.assertEqual "" (Just expectedVersion) actualVersion+  where+    actualVersion = versionFromGnuCodingStandards commandOutput++getPackageVersion :: T.Text -> IO T.Text+getPackageVersion = fmap version . Yaml.decodeThrow . Encoding.encodeUtf8++versionFromGnuCodingStandards :: T.Text -> Maybe T.Text+versionFromGnuCodingStandards = firstLine Monad.>=> lastWord+  where+    firstLine = Maybe.listToMaybe . T.lines+    lastWord = Maybe.listToMaybe . reverse . T.words
+ test/Spec.hs view
@@ -0,0 +1,65 @@+import qualified Buffet.Toolbox.TestHelp as TestHelp+import qualified Buffet.Toolbox.TestTools as TestTools+import qualified Buffet.Toolbox.TestUtility as TestUtility+import qualified Buffet.Toolbox.TestVersion as TestVersion+import Prelude (FilePath, IO, ($), (.), (<$>), (>>=), flip, sequenceA)+import qualified System.FilePath as FilePath+import qualified Test.Tasty as Tasty+import qualified Test.Tasty.HUnit as HUnit++main :: IO ()+main = tests >>= Tasty.defaultMain++tests :: IO Tasty.TestTree+tests =+  Tasty.testGroup "Tests" <$>+  sequenceA+    [ helpTests "test/data/help"+    , versionTests "test/data/version"+    , buildTests "test/data/build"+    , documentTests "test/data/document"+    , parseTests "test/data/parse"+    , testTests "test/data/test"+    , exampleTests "test/data/example"+    ]++helpTests :: FilePath -> IO Tasty.TestTree+helpTests = TestTools.folderBasedTests $ assert configuration+  where+    configuration =+      defaultConfiguration {TestUtility.assertStdout = TestHelp.get}++assert ::+     TestUtility.Configuration -> Tasty.TestName -> FilePath -> Tasty.TestTree+assert configuration name =+  HUnit.testCase name . TestUtility.get configuration . testSource+  where+    testSource = flip FilePath.combine "test.yaml"++defaultConfiguration :: TestUtility.Configuration+defaultConfiguration = TestUtility.defaultConfiguration "buffet"++versionTests :: FilePath -> IO Tasty.TestTree+versionTests = TestTools.folderBasedTests $ assert configuration+  where+    configuration =+      defaultConfiguration {TestUtility.assertStdout = TestVersion.get}++buildTests :: FilePath -> IO Tasty.TestTree+buildTests = TestTools.folderBasedTests $ assert defaultConfiguration++documentTests :: FilePath -> IO Tasty.TestTree+documentTests = TestTools.folderBasedTests $ assert defaultConfiguration++parseTests :: FilePath -> IO Tasty.TestTree+parseTests = TestTools.folderBasedTests $ assert configuration+  where+    configuration =+      defaultConfiguration+        {TestUtility.assertStdout = TestTools.assertJsonIsSubstructure}++testTests :: FilePath -> IO Tasty.TestTree+testTests = TestTools.folderBasedTests $ assert defaultConfiguration++exampleTests :: FilePath -> IO Tasty.TestTree+exampleTests = TestTools.folderBasedTests $ assert defaultConfiguration