packages feed

b9 0.5.61 → 0.5.62

raw patch · 49 files changed

+2997/−3365 lines, 49 filesdep +exceptionsdep +extensible-effectsdep +taggeddep ~binary

Dependencies added: exceptions, extensible-effects, tagged

Dependency ranges changed: binary

Files

.gitignore view
@@ -18,3 +18,4 @@ .stack-work /result *~+/out
+ CHANGELOG.md view
@@ -0,0 +1,62 @@+# Changelog for B9++## 0.5.62++* Rewrite `B9.Shake.SharedImageRules` in line with +  Shake's example for custom rules  ++* Replace `ConcatableSyntax` by using `Binary` instances, and also++    * Remove/Inline `encodeSyntax` by using `Binary.encode`+    +    * Rename `decodeSyntax` to `decodeOrFail'` and delegate+      to `Binary.decodeOrFail`. +    ++* Add a newtype wrapper around `YamlObject` for **cloud-init** yaml documents+  `CloudConfigYaml`+  +  This new type serves the purpose of add the `#cloud-config`+  line to the top of the generated yaml document, +  as [required by cloud-init](https://cloudinit.readthedocs.io/en/latest/topics/format.html#cloud-config-data).+  +  The `Binary` instance adds this **header line** and +  delegates the rendering of the yaml document to +  `YamlObject`.+  +* Remove the rendering of this header line in the `YamlObject` +  `Binary` instance.++* Rename `RenderYaml` to `RenderYamlObject` In order to prevent unexpected +  runtime behaviour in code that uses this library.+  +* Introduce the type `Environment` that replaces the ubiquotus `[(String, String)]`+  by a lazy `Text` based `HashMap`.+  +     * Add `appendPositionalArguments`+  +* Rename the previous `B9.Artifact.Content` to `B9.Artifact.Content`++* Introduce `ContentGenerator` as an open, extensible alternative+  to `Content`, `AST` and `CanRender` in the module+  `B9.Artifact.Content`+* Rename-and-Split refactor `B9.ArtifactSource{Impl}` to `B9.Artifact.Generator.{..}`++* Move `CanRender` from `B9.Artifact.Content.AST` to `B9.Artifact.Content`    ++* Switch to lazy `Text`s and `ByteString`s where possible, since B9 might+  read/generate large files. +  +* Rename `CanRender` to `ToContentGenerator` +  and change the method signatur to return the new `ContentGenerator` type  ++* Fix spelling: Rename B9Invokation to B9Invocation+  +* Rename `FromAST` to `FromAST`++* Rearrange modules for content generation:+   - Introduce `Content.FromByteString` ++* Remove deprecated `Concatenation`+   +
+ CODE_OF_CONDUCT.md view
@@ -0,0 +1,56 @@+# Code of Conduct TL,DR;++**All creatures are welcome.**++**Be excellent to each other!**++**Don't assume bad intention, there is always a part of the story you might not know...**++**Behave as if children were reading everything, don't use bad language.**++# Contributor Covenant Code of Conduct++## Our Pledge++In the interest of fostering an open and welcoming environment, we as contributors and maintainers pledge to making participation in our project and our community a harassment-free experience for everyone, regardless of age, body size, disability, ethnicity, gender identity and expression, level of experience, nationality, personal appearance, race, religion, or sexual identity and orientation.++## Our Standards++Examples of behavior that contributes to creating a positive environment include:++* Using welcoming and inclusive language+* Being respectful of differing viewpoints and experiences+* Gracefully accepting constructive criticism+* Focusing on what is best for the community+* Showing empathy towards other community members++Examples of unacceptable behavior by participants include:++* The use of sexualized language or imagery and unwelcome sexual attention or advances+* Trolling, insulting/derogatory comments, and personal or political attacks+* Public or private harassment+* Publishing others' private information, such as a physical or electronic address, without explicit permission+* Other conduct which could reasonably be considered inappropriate in a professional setting++## Our Responsibilities++Project maintainers are responsible for clarifying the standards of acceptable behavior and are expected to take appropriate and fair corrective action in response to any instances of unacceptable behavior.++Project maintainers have the right and responsibility to remove, edit, or reject comments, commits, code, wiki edits, issues, and other contributions that are not aligned to this Code of Conduct, or to ban temporarily or permanently any contributor for other behaviors that they deem inappropriate, threatening, offensive, or harmful.++## Scope++This Code of Conduct applies both within project spaces and in public spaces when an individual is representing the project or its community. Examples of representing a project or community include using an official project e-mail address, posting via an official social media account, or acting as an appointed representative at an online or offline event. Representation of a project may be further defined and clarified by project maintainers.++## Enforcement++Instances of abusive, harassing, or otherwise unacceptable behavior may be reported by contacting the project team at svh@posteo.de. The project team will review and investigate all complaints, and will respond in a way that it deems appropriate to the circumstances. The project team is obligated to maintain confidentiality with regard to the reporter of an incident. Further details of specific enforcement policies may be posted separately.++Project maintainers who do not follow or enforce the Code of Conduct in good faith may face temporary or permanent repercussions as determined by other members of the project's leadership.++## Attribution++This Code of Conduct is adapted from the [Contributor Covenant][homepage], version 1.4, available at [http://contributor-covenant.org/version/1/4][version]++[homepage]: http://contributor-covenant.org+[version]: http://contributor-covenant.org/version/1/4/
+ CONTRIBUTING.md view
@@ -0,0 +1,53 @@+# Contribute++Let me make it clear: this project has no real community; I beleive in it's long term future, but that's just my opinion.++So every contribution is welcome. ++If you contribute, you may show off your coding skills and I will praise you.++If you want to take things into your own hands, I will step back and let you make it yours. +If I don't agree, I will make a pull request or fork.++If you want a small issue fixed, and you make a crappy pull request, I will be grateful and try to bring in the changes,+and I will praise you a little less.++# Strong Suggestions++* Use the english language for identifiers and documentation+* Use spaces and not tabs+* Either reformat all modules with your favorite formatter, or adapt to the existing formatting +* Make many small commits+* Tag each release with the version number++# General Suggestions++## Favor immediate failure over program endurance++B9 is a **batch processing** tool, it will be run **once** to produce a single artifact.+Let it crash, or let it fail during type checking rather than making the code defensively handle unexpected result.++## Favor easy to understand and to extend code over "correct" abstractions++This project is part of the **waste** accumulated in software development. There is often little appreciation for code quality+investments, also there is always the threat of immenant project death if other tools take of, therefore make your code friendly+to the uninclined contributor. ++## Favor mathematical and logical rigor over intuitive, spontanous models++Prefer using functors, monads, profunctors and free algebras over concrete concepts found in the problem domain. ++## Favor standard library type constructors like `Maybe` or `(a->)` over custom types++## Derive `Typeable`, `Eq`, `Hashable`, `Binary`, `NFData`, `Show` for user facing data types ++## Favor easy and fast to understand names over short and fast to write names++## Good beats Perfect: Favor a mediocre contribution over _no contribution_, that would have been brilliant and elegant.++If you don't have time to follow all the rules, contribute anyway.++If it motivates you to make brilliant but hard to learn abstractions, then, please go ahead and do it. ++## When in doubt, favor semantic versioning over small, continously increasing version values+
− TODO.org 
@@ -1,94 +0,0 @@-* Refactor from Prototype to Product:-** DONE Write License Header-** DONE Rename project to b9 (benign)-** DONE Rename Common to B9Monad-** DONE Rename BeqemuCfg to B9Config-** DONE Move every module to sub namespace Development.B9-** DONE Add .cabal file-*** DONE Use stackage-** DONE Create git repo-** DONE Create B9-Library-*** DONE Split Main.hs -> (Main.hs, B9.hs)-*** DONE Reexport everything in B9 for easy scripting-** DONE Cleanup/Refactor Project and B9Config-** DONE Add LibVirtLXCConfig with:-*** DONE virsh command path-*** DONE default network-*** DONE sudo flag-*** DONE connection URI-*** DONE Read LibVirtLXC Config from .b9/libvirt_lxc.config-** DONE Add B9Config reader:-*** DONE Add merging of B9Configs/Resources-*** DONE Use Data.ConfigFile http://hackage.haskell.org/package/ConfigFile-1.1.3/docs/Data-ConfigFile.html-** DONE Add a project file reader-** DONE Add command line handling-*** DONE [#B] Allow setting alternative B9Config path-*** DONE [#B] Allow overwriting B9Config items-*** DONE Allow setting of alternative Project path-*** DONE Pass parameters for the project script-*** DONE Allow passing several 'Project's that are then merged-**** DONE Make Project's composable (a Monoid)-*** DONE Use string templates for 'Project' to cli Args and Environment Vars-** DONE Add Example Projects-** TODO Write a nice documentation-** TODO Publish-*** Create github repo-*** Create git01 repo-* DONE Add a check mode that tells what would happen if a project file executed-* Add a 'beq_run' pendant-** Add --shell param-** Add to Project projectPersistentEnvInit (Maybe Script)-** Do not remove the build directory-** Do not export any images-* TODO Add support for sharing 'Image's-** DONE Define ImageInfo currently only a name, later: version, type author, ...-** DONE Add importing share images from cache-** DONE Add importing share images from external repo-** DONE Move/Rename B9.BaseImageBuilder-** DONE Add share images export-** DONE Define Repository for shared-images'-** DONE Add to B9Config items for shared image repositories-** DONE Add to B9Config 'baseImageCacheDir'-** DONE Use optparse commands-** TODO Add 'ClearCache' action-** TODO Add 'show repos' action-** DONE Add 'list repo contents' action-** DONE Add 'refresh repos action-** Add 'add remote repo' with sshkey generation-* Add 'system-setup' helper action-** Check for nbd-** Check that libvirt is running-** Check that all important tools are installed-* Add support for the beqemu repo directory layout-** Introduce 'ExportToLiveRepo'-*** Add Root directory parameter-*** Use projectName as machine name-*** Use buildId for versions?-*** Restrict to raw images with no partitions-*** What a 'disk' means:-**** CloudConfig directory-***** Generate instance id from hash of files-**** Disk with:-***** disk size-***** disk index-***** kexec infos-***** disk version?-***** Maybe SshLogin-* Improve Commands-** Use Shell-Escaping: http://hackage.haskell.org/package/shell-escape-0.1.2-** Split/Move 'ShellScripting' dependency into the exec env, thereby making the project independent of 'Bash'- scripting-** Add 'list-artifacts' command-** Allow building of only a single artifact-* More Backends-** Add VM based backend: VirtualBox-* Improve test coverage-** Add test coverage profiling tool-* Make B9 a real library-** Restrict exposed modules-** Add pure library functions for munging Artifacts-** Move SharedImage functions from DiskImageBuilder to a better place-** Refactor the B9Monad.run function to not need a ConfigParser-** Move 'Repository' from B9.RepositoryIO to B9.Repository-* Add building of RPMs and ARCHLINUX packages-* Use unique ids for vm image builds-* TODO Fix repo-cache configfile ignoration
b9.cabal view
@@ -1,5 +1,5 @@ name:                b9-version:             0.5.61+version:             0.5.62  synopsis:            A tool and library for building virtual machine images. @@ -45,22 +45,21 @@ maintainer:          svh@posteo.de homepage:            https://github.com/sheyll/b9-vm-image-builder bug-reports:         https://github.com/sheyll/b9-vm-image-builder/issues-copyright:           2015, 2016, 2017, 2018 Sven Heyll <svh@posteo.de>+copyright:           2015, 2016, 2017, 2018, 2019 Sven Heyll <svh@posteo.de> category:            Development build-type:          Simple extra-source-files:  README.md                    , LICENSE-                   , TODO.org                    , Setup.hs                    , b9.cabal                    , .gitignore                    , prepare_release.sh                    , stack.yaml-                   , stack-lts-9.4.yaml-                   , stack-lts-11.0.yaml-                   , stack-nightly-2018-03-16.yaml                    , .travis.yml                    , CONTRIBUTORS+                   , CONTRIBUTING.md+                   , CODE_OF_CONDUCT.md+                   , CHANGELOG.md cabal-version:       >=1.22  source-repository head@@ -69,21 +68,25 @@  library   exposed-modules:   B9-                   , B9.ArtifactGenerator-                   , B9.ArtifactGeneratorImpl+                   , B9.Artifact+                   , B9.Artifact.Content+                   , B9.Artifact.Content.AST+                   , B9.Artifact.Content.CloudConfigYaml+                   , B9.Artifact.Content.ErlangPropList+                   , B9.Artifact.Content.ErlTerms+                   , B9.Artifact.Content.Readable+                   , B9.Artifact.Content.StringTemplate+                   , B9.Artifact.Content.YamlObject+                   , B9.Artifact.Readable+                   , B9.Artifact.Readable.Interpreter+                   , B9.Artifact.Readable.Source                    , B9.B9Config                    , B9.B9Config.LibVirtLXC                    , B9.B9Config.Repository                    , B9.B9Monad-                   , B9.Content.AST-                   , B9.Content.ErlangPropList-                   , B9.Content.ErlTerms-                   , B9.Content.Generator-                   , B9.Content.StringTemplate-                   , B9.Content.YamlObject                    , B9.DiskImageBuilder                    , B9.DiskImages-                   , B9.DSL+                   , B9.Environment                    , B9.ExecEnv                    , B9.LibVirtLXC                    , B9.MBR@@ -112,6 +115,8 @@                    , conduit >= 1.2                    , conduit-extra >= 1.1                    , directory >= 1.3+                   , exceptions >= 0.10+                   , extensible-effects >= 5 && < 6                    , filepath >= 1.4                    , hashable >= 1.2                    , lens >= 4@@ -125,6 +130,7 @@                    , random >= 1.1                    , shake >= 0.17 && < 0.18                    , syb >= 0.6+                   , tagged >= 0.8 && < 0.9                    , template >= 0.2                    , text >= 1.2                    , transformers >= 0.5@@ -139,6 +145,7 @@    default-extensions: TupleSections                     , GeneralizedNewtypeDeriving+                    , ConstraintKinds                     , DeriveDataTypeable                     , DeriveGeneric                     , RankNTypes@@ -150,6 +157,10 @@                     , DeriveFunctor                     , TemplateHaskell                     , StandaloneDeriving+                    , ScopedTypeVariables+                    , TypeOperators+                    , MonoLocalBinds+                    , MultiParamTypeClasses                     , CPP   hs-source-dirs:    src/lib   default-language:  Haskell2010@@ -166,18 +177,20 @@                    , bytestring >= 0.10                    , optparse-applicative >= 0.13                    , lens >= 4+                   , text >= 1.2   hs-source-dirs:    src/cli   default-language:  Haskell2010   default-extensions: TupleSections                     , GeneralizedNewtypeDeriving                     , DeriveDataTypeable+                    , DeriveFunctor+                    , DeriveGeneric                     , RankNTypes                     , FlexibleContexts                     , GADTs                     , DataKinds                     , KindSignatures                     , TypeFamilies-                    , DeriveFunctor                     , TemplateHaskell                     , CPP   ghc-options:       -threaded -with-rtsopts=-N -Wall@@ -197,6 +210,7 @@                    , Paths_b9   build-depends:     base >= 4.8 && < 5                    , b9+                   , binary >= 0.8 && < 0.9                    , hspec                    , hspec-expectations                    , QuickCheck >= 2.5
prepare_release.sh view
@@ -1,4 +1,4 @@-#!/bin/bash+#!/usr/bin/env bash # # Prepare B9 for release: # * clean the workspace
src/cli/Main.hs view
@@ -1,31 +1,24 @@ module Main-    ( main-    )-where+  ( main+  ) where -import           Options.Applicative     hiding ( action )-import           Options.Applicative.Help.Pretty-                                         hiding ( (</>) ) import           B9-import           Control.Lens                   ( (.~)-                                                , (&)-                                                , over-                                                , (^.)-                                                )+import           Control.Lens                    (over, (&), (.~), (^.))+import qualified Data.Text.Lazy                  as LazyT+import           Options.Applicative             hiding (action)+import           Options.Applicative.Help.Pretty hiding ((</>))  main :: IO () main = do-    b9Opts <- parseCommandLine-    applyB9RunParameters b9Opts-+  b9Opts <- parseCommandLine+  applyB9RunParameters b9Opts --- | A data structure that contains the `B9Invokation`+-- | A data structure that contains the `B9Invocation` -- as well as build parameters. data B9RunParameters =-  B9RunParameters-            B9ConfigOverride-            Cmd-            BuildVariables+  B9RunParameters B9ConfigOverride+                  Cmd+                  Environment  type Cmd = B9ConfigAction IO () @@ -34,290 +27,156 @@  applyB9RunParameters :: B9RunParameters -> IO () applyB9RunParameters (B9RunParameters overrides act vars) =-    let cfg =-            noB9ConfigOverride-                &  customB9Config-                %~ (over envVars (++ vars) . const (overrides ^. customB9Config)-                   )-                &  customLibVirtNetwork-                .~ (overrides ^. customLibVirtNetwork)-                &  maybe id-                         overrideB9ConfigPath-                         (overrides ^. customB9ConfigPath)-    in  execB9ConfigAction act cfg+  let cfg =+        noB9ConfigOverride & customB9Config %~ (over envVars (`mappend` vars) . const (overrides ^. customB9Config)) &+        customLibVirtNetwork .~ (overrides ^. customLibVirtNetwork) &+        maybe id overrideB9ConfigPath (overrides ^. customB9ConfigPath)+   in execB9ConfigAction act cfg  parseCommandLine :: IO B9RunParameters-parseCommandLine = execParser+parseCommandLine =+  execParser     (info-        (helper <*> (B9RunParameters <$> globals <*> cmds <*> buildVars))-        (  fullDesc-        <> progDesc-               "Build and run VM-Images inside LXC containers. Custom arguments follow after '--' and are accessable in many strings in build files  trough shell like variable references, i.e. '${arg_N}' referes to positional argument $N.\n\nRepository names passed to the command line are looked up in the B9 configuration file, which is per default located in: '~/.b9/b9.conf'. The current working directory is used as ${buildDirRoot} if not otherwise specified in the config file, or via the '-b' option."-        <> headerDoc (Just b9HelpHeader)-        )-    )+       (helper <*> (B9RunParameters <$> globals <*> cmds <*> buildVars))+       (fullDesc <>+        progDesc+          "Build and run VM-Images inside LXC containers. Custom arguments follow after '--' and are accessable in many strings in build files  trough shell like variable references, i.e. '${arg_N}' referes to positional argument $N.\n\nRepository names passed to the command line are looked up in the B9 configuration file, which is per default located in: '~/.b9/b9.conf'. The current working directory is used as ${buildDirRoot} if not otherwise specified in the config file, or via the '-b' option." <>+        headerDoc (Just b9HelpHeader)))   where-    b9HelpHeader = linebreak-        <> text ("B9 - a benign VM-Image build tool v. " ++ b9VersionString)-+    b9HelpHeader = linebreak <> text ("B9 - a benign VM-Image build tool v. " ++ b9VersionString)  globals :: Parser B9ConfigOverride globals =-    toGlobalOpts-        <$> optional-                (strOption-                    (  help-                          "Path to user's b9-configuration (default: ~/.b9/b9.conf)"-                    <> short 'c'-                    <> long "configuration-file"-                    <> metavar "FILENAME"-                    )-                )-        <*> switch-                (  help "Log everything that happens to stdout"-                <> short 'v'-                <> long "verbose"-                )-        <*> switch-                (help "Suppress non-error output" <> short 'q' <> long "quiet")-        <*> optional-                (strOption-                    (  help "Path to a logfile"-                    <> short 'l'-                    <> long "log-file"-                    <> metavar "FILENAME"-                    )-                )-        <*> optional-                (strOption-                    (  help "Output file for a command/timing profile"-                    <> long "profile-file"-                    <> metavar "FILENAME"-                    )-                )-        <*> optional-                (strOption-                    (  help-                          "Root directory for build directories. If not specified '.'. The path will be canonicalized and stored in ${buildDirRoot}."-                    <> short 'b'-                    <> long "build-root-dir"-                    <> metavar "DIRECTORY"-                    )-                )-        <*> switch-                (help "Keep build directories after exit" <> short 'k' <> long-                    "keep-build-dir"-                )-        <*> switch-                (help "Predictable build directory names" <> short 'u' <> long-                    "predictable-build-dir"-                )-        <*> optional-                (strOption-                    (  help-                          "Cache directory for shared images, default: '~/.b9/repo-cache'"-                    <> long "repo-cache"-                    <> metavar "DIRECTORY"-                    )-                )-        <*> optional-                (strOption-                    (  help "Remote repository to share image to"-                    <> short 'r'-                    <> long "repo"-                    <> metavar "REPOSITORY_ID"-                    )-                )-        <*> optional-                (strOption-                    (  help-                          ("Override the libvirt-lxc network setting.\nThe special value '"-                          ++ hostNetworkMagicValue-                          ++ "' disables restricted container networking."-                          )-                    <> long "network"-                    <> metavar "NETWORK_ID"-                    )-                )+  toGlobalOpts <$>+  optional+    (strOption+       (help "Path to user's b9-configuration (default: ~/.b9/b9.conf)" <> short 'c' <> long "configuration-file" <>+        metavar "FILENAME")) <*>+  switch (help "Log everything that happens to stdout" <> short 'v' <> long "verbose") <*>+  switch (help "Suppress non-error output" <> short 'q' <> long "quiet") <*>+  optional (strOption (help "Path to a logfile" <> short 'l' <> long "log-file" <> metavar "FILENAME")) <*>+  optional (strOption (help "Output file for a command/timing profile" <> long "profile-file" <> metavar "FILENAME")) <*>+  optional+    (strOption+       (help+          "Root directory for build directories. If not specified '.'. The path will be canonicalized and stored in ${buildDirRoot}." <>+        short 'b' <>+        long "build-root-dir" <>+        metavar "DIRECTORY")) <*>+  switch (help "Keep build directories after exit" <> short 'k' <> long "keep-build-dir") <*>+  switch (help "Predictable build directory names" <> short 'u' <> long "predictable-build-dir") <*>+  optional+    (strOption+       (help "Cache directory for shared images, default: '~/.b9/repo-cache'" <> long "repo-cache" <>+        metavar "DIRECTORY")) <*>+  optional+    (strOption (help "Remote repository to share image to" <> short 'r' <> long "repo" <> metavar "REPOSITORY_ID")) <*>+  optional+    (strOption+       (help+          ("Override the libvirt-lxc network setting.\nThe special value '" +++           hostNetworkMagicValue ++ "' disables restricted container networking.") <>+        long "network" <>+        metavar "NETWORK_ID"))   where-    toGlobalOpts-        :: Maybe FilePath-        -> Bool-        -> Bool-        -> Maybe FilePath-        -> Maybe FilePath-        -> Maybe FilePath-        -> Bool-        -> Bool-        -> Maybe FilePath-        -> Maybe String-        -> Maybe String-        -> B9ConfigOverride-    toGlobalOpts cfg verbose quiet logF profF buildRoot keep predictableBuildDir mRepoCache repo libvirtNet-        = let-              minLogLevel = if verbose-                  then Just LogTrace-                  else if quiet then Just LogError else Nothing-              b9cfg =-                  mempty-                      &  verbosity-                      .~ minLogLevel-                      &  logFile-                      .~ logF-                      &  profileFile-                      .~ profF-                      &  buildDirRoot-                      .~ buildRoot-                      &  keepTempDirs-                      .~ keep-                      &  uniqueBuildDirs-                      .~ not predictableBuildDir-                      &  repository-                      .~ repo-                      &  repositoryCache-                      .~ (Path <$> mRepoCache)-          in-              B9ConfigOverride-                  { _customB9ConfigPath   = Path <$> cfg-                  , _customB9Config       = b9cfg-                  , _customLibVirtNetwork =-                      (\n -> if n == hostNetworkMagicValue-                              then Nothing-                              else Just n-                          )-                          <$> libvirtNet-                  }+    toGlobalOpts ::+         Maybe FilePath+      -> Bool+      -> Bool+      -> Maybe FilePath+      -> Maybe FilePath+      -> Maybe FilePath+      -> Bool+      -> Bool+      -> Maybe FilePath+      -> Maybe String+      -> Maybe String+      -> B9ConfigOverride+    toGlobalOpts cfg verbose quiet logF profF buildRoot keep predictableBuildDir mRepoCache repo libvirtNet =+      let minLogLevel+            | verbose = Just LogTrace+            | quiet = Just LogError+            | otherwise = Nothing+          b9cfg =+            mempty & verbosity .~ minLogLevel & logFile .~ logF & profileFile .~ profF & buildDirRoot .~ buildRoot &+            keepTempDirs .~ keep &+            uniqueBuildDirs .~ not predictableBuildDir &+            repository .~ repo &+            repositoryCache .~ (Path <$> mRepoCache)+       in B9ConfigOverride+            { _customB9ConfigPath = Path <$> cfg+            , _customB9Config = b9cfg+            , _customLibVirtNetwork =+                (\n ->+                   if n == hostNetworkMagicValue+                     then Nothing+                     else Just n) <$>+                libvirtNet+            }  cmds :: Parser Cmd-cmds = subparser-    (  command-          "version"-          (info (pure runShowVersion)-                (progDesc "Show program version and exit.")-          )-    <> command-           "build"-           (info-               (void . runBuildArtifacts <$> buildFileParser)--               (progDesc "Merge all build file and generate all artifacts.")-           )-    <> command-           "run"-           (info-               ((\x y -> void (runRun x y)) <$> sharedImageNameParser <*> many-                   (strArgument idm)-               )-               (progDesc-                   "Run a command on the lastest version of the specified shared image."-               )-           )-    <> command-           "push"-           (info-               (runPush <$> sharedImageNameParser)-               (progDesc-                   "Push the lastest shared image from cache to the selected  remote repository."-               )-           )-    <> command-           "pull"-           (info-               (runPull <$> optional sharedImageNameParser)-               (progDesc-                   "Either pull shared image meta data from all repositories, or only from just a selected one. If additionally the name of a shared images was specified, pull the newest version from either the selected repo, or from the repo with the most recent version."-               )-           )-    <> command-           "clean-local"-           (info-               (pure runGcLocalRepoCache)-               (progDesc-                   "Remove old versions of shared images from the local cache."-               )-           )-    <> command-           "clean-remote"-           (info-               (pure runGcRemoteRepoCache)-               (progDesc-                   "Remove cached meta-data of a remote repository. If no '-r' is given, clean the meta data of ALL remote repositories."-               )-           )-    <> command-           "list"-           (info (pure (void runListSharedImages))-                 (progDesc "List shared images.")-           )-    <> command-           "add-repo"-           (info (runAddRepo <$> remoteRepoParser)-                 (progDesc "Add a remote repo.")-           )-    <> command-           "reformat"-           (info (runFormatBuildFiles <$> buildFileParser)-                 (progDesc "Re-Format all build files.")-           )-    )+cmds =+  subparser+    (command "version" (info (pure runShowVersion) (progDesc "Show program version and exit.")) <>+     command+       "build"+       (info+          (void . runBuildArtifacts <$> buildFileParser)+          (progDesc "Merge all build file and generate all artifacts.")) <>+     command+       "run"+       (info+          ((\x y -> void (runRun x y)) <$> sharedImageNameParser <*> many (strArgument idm))+          (progDesc "Run a command on the lastest version of the specified shared image.")) <>+     command+       "push"+       (info+          (runPush <$> sharedImageNameParser)+          (progDesc "Push the lastest shared image from cache to the selected  remote repository.")) <>+     command+       "pull"+       (info+          (runPull <$> optional sharedImageNameParser)+          (progDesc+             "Either pull shared image meta data from all repositories, or only from just a selected one. If additionally the name of a shared images was specified, pull the newest version from either the selected repo, or from the repo with the most recent version.")) <>+     command+       "clean-local"+       (info (pure runGcLocalRepoCache) (progDesc "Remove old versions of shared images from the local cache.")) <>+     command+       "clean-remote"+       (info+          (pure runGcRemoteRepoCache)+          (progDesc+             "Remove cached meta-data of a remote repository. If no '-r' is given, clean the meta data of ALL remote repositories.")) <>+     command "list" (info (pure (void runListSharedImages)) (progDesc "List shared images.")) <>+     command "add-repo" (info (runAddRepo <$> remoteRepoParser) (progDesc "Add a remote repo.")) <>+     command "reformat" (info (runFormatBuildFiles <$> buildFileParser) (progDesc "Re-Format all build files.")))  buildFileParser :: Parser [FilePath]-buildFileParser = helper <*> some+buildFileParser =+  helper <*>+  some     (strOption-        (  help-              "Build file to load, specify multiple build files (each witch '-f') to build them all in a single run."-        <> short 'f'-        <> long "project-file"-        <> metavar "FILENAME"-        <> noArgError (ErrorMsg "No build file specified!")-        )-    )+       (help "Build file to load, specify multiple build files (each witch '-f') to build them all in a single run." <>+        short 'f' <>+        long "project-file" <>+        metavar "FILENAME" <>+        noArgError (ErrorMsg "No build file specified!"))) -buildVars :: Parser BuildVariables-buildVars =-    zip (("arg_" ++) . show <$> ([1 ..] :: [Int])) <$> many (strArgument idm)+buildVars :: Parser Environment+buildVars = flip insertPositionalArguments mempty . fmap LazyT.pack <$> many (strArgument idm)  remoteRepoParser :: Parser RemoteRepo remoteRepoParser =-    helper-        <*> (   RemoteRepo-            <$> strArgument-                    (  help "The name of the remmote repository."-                    <> metavar "NAME"-                    )-            <*> strArgument-                    (  help "The (remote) repository root path."-                    <> metavar "REMOTE_DIRECTORY"-                    )-            <*> (SshPrivKey <$> strArgument-                    (  help-                            "Path to the SSH private key file used for  authorization."-                    <> metavar "SSH_PRIV_KEY_FILE"-                    )-                )-            <*> (   SshRemoteHost-                <$> (   (,)-                    <$> strArgument-                            (  help "Repo hostname or IP"-                            <> metavar "HOST"-                            )-                    <*> argument-                            auto-                            (  help "SSH-Port number"-                            <> value 22-                            <> showDefault-                            <> metavar "PORT"-                            )-                    )-                )-            <*> (SshRemoteUser <$> strArgument-                    (help "SSH-User to login" <> metavar "USER")-                )-            )+  helper <*>+  (RemoteRepo <$> strArgument (help "The name of the remmote repository." <> metavar "NAME") <*>+   strArgument (help "The (remote) repository root path." <> metavar "REMOTE_DIRECTORY") <*>+   (SshPrivKey <$>+    strArgument (help "Path to the SSH private key file used for  authorization." <> metavar "SSH_PRIV_KEY_FILE")) <*>+   (SshRemoteHost <$>+    ((,) <$> strArgument (help "Repo hostname or IP" <> metavar "HOST") <*>+     argument auto (help "SSH-Port number" <> value 22 <> showDefault <> metavar "PORT"))) <*>+   (SshRemoteUser <$> strArgument (help "SSH-User to login" <> metavar "USER")))  sharedImageNameParser :: Parser SharedImageName-sharedImageNameParser =-    helper-        <*> (   SharedImageName-            <$> strArgument (help "Shared image name" <> metavar "NAME")-            )+sharedImageNameParser = helper <*> (SharedImageName <$> strArgument (help "Shared image name" <> metavar "NAME"))
src/lib/B9.hs view
@@ -6,7 +6,7 @@     This module re-exports the modules needed to build a tool around the     library, e.g. see @src\/cli\/Main.hs@ as an example. -    "B9.ArtifactGenerator" is the module containing the basic data structure+    "B9.Artifact.Generator" is the module containing the basic data structure     used to describe a B9 build.  -}@@ -42,8 +42,20 @@         (takeDirectory, takeFileName, replaceExtension, (</>), (<.>)) import Text.Printf as X (printf) import Data.Version as X-import B9.B9Monad as X import System.IO.B9Extras as X+import B9.Artifact as X+import B9.Artifact.Readable as X+import B9.Artifact.Content as X+import B9.Artifact.Content.AST as X+import B9.Artifact.Content.CloudConfigYaml as X+import B9.Artifact.Content.ErlTerms as X+import B9.Artifact.Content.ErlangPropList as X+import B9.Artifact.Content.Readable as X+import B9.Artifact.Content.StringTemplate as X+import B9.Artifact.Content.YamlObject as X+import B9.Artifact.Readable.Source as X+import B9.Artifact.Readable.Interpreter as X+import B9.B9Monad as X import B9.B9Config as X import B9.ExecEnv as X import B9.DiskImages as X@@ -51,17 +63,10 @@ import B9.ShellScript as X import B9.Repository as X import B9.RepositoryIO as X-import B9.ArtifactGenerator as X-import B9.ArtifactGeneratorImpl as X import B9.Vm as X import B9.VmBuilder as X import B9.QCUtil as X-import B9.Content.AST as X-import B9.Content.StringTemplate as X-import B9.Content.ErlTerms as X-import B9.Content.ErlangPropList as X-import B9.Content.YamlObject as X-import B9.Content.Generator as X+import B9.Environment as X import Paths_b9 (version)  -- | Return the cabal package version of the B9 library.
+ src/lib/B9/Artifact.hs view
@@ -0,0 +1,8 @@+-- | Programmatic Interaface to b9 artifact generation.+--+-- An extensible approach to vm deployment configuration management.+--+-- @since 1.0.0+{-# LANGUAGE FlexibleInstances #-}+module B9.Artifact where+
+ src/lib/B9/Artifact/Content.hs view
@@ -0,0 +1,60 @@+-- | Content is what is written to files in the generated VM images and cloud configuration.+--+-- Contains the monadic actions that generate the content that+-- is written to the generated artifacts.+--+-- @since 0.5.62+module B9.Artifact.Content+  ( ContentGeneratorT(MkContentGeneratorT)+  , ContentGenerator+  , ByteStringGenerator+  , renderContentGenerator+  , ToContentGenerator (..)+  ) where++import B9.B9Monad (B9)+import B9.Environment+import Control.Applicative (Alternative)+import Control.Monad.Reader+import Data.ByteString.Lazy as Lazy++-- | A monadic action that generates content by using the 'Environment'+-- as additional input, e.g. when interpolating string templates.+--+-- Most intersting is the fact the 'Semigroup' and 'Monoid' instances+-- are available.+--+-- @since 0.5.62+newtype ContentGeneratorT m a = MkContentGeneratorT+  { getContentGenerator :: EnvironmentReaderT m a+  } deriving (MonadTrans, Alternative, MonadReader Environment, MonadIO, Monad, Applicative, Functor)++-- | A 'B9' action that generates content by using the 'Environment'+-- as additional input, e.g. when interpolating string templates.+--+-- @since 0.5.62+type ContentGenerator a = ContentGeneratorT B9 a++-- | A 'B9' action that procuces a 'Lazy.ByteString'.+--+-- @since 0.5.62+type ByteStringGenerator = ContentGenerator Lazy.ByteString++instance (Monad m, Semigroup a) => Semigroup (ContentGeneratorT m a) where+  l <> r = (<>) <$> l <*> r++instance (Monad m, Monoid a) => Monoid (ContentGeneratorT m a) where+  mempty = pure mempty++-- | Types whose values can be turned into a 'ContentGenerator'+--+-- @since 0.5.62+class ToContentGenerator c where+    toContentGenerator :: c -> ByteStringGenerator++-- | Execute a 'ContentGenerator'.+-- The 'Environment' contains the bindings of any string template variables.+--+-- @since 0.5.62+renderContentGenerator :: Environment -> ContentGenerator a -> B9 a+renderContentGenerator e = runEnvironmentReaderT e . getContentGenerator
+ src/lib/B9/Artifact/Content/AST.hs view
@@ -0,0 +1,111 @@+{-|++B9 produces not only VM-Images but also text documents such as configuration+files required by virtual machines. This module is about creating and merging+files containing parsable syntactic structures, such as most configuration files+do.++B9 can be used to create configuration files by assembling structured documents,+for example Yaml, JSON, Erlang Terms.++One example is creating a single cloud-init 'user-data' file from a set of+'user-data' snippets - all of which using yaml syntax to declare the same+object (e.g @"user-data"@).++The goal is, that b9 is able to merge these snippets into one, intelligently+merging fields as one would expect, e.g. when merging multiple snippets with+@writefiles@ fields, the output object's @writefiles@ field contains all the+@write_file@ objects.++Another example is the OTP/Erlang sys.config for configuring OTP/Erlang releases.+-}++module B9.Artifact.Content.AST ( FromAST(..)+                      , AST(..)+                      , decodeOrFail'+                      ) where++import           Control.Parallel.Strategies+import           Data.Binary (Binary)+import qualified Data.Binary as Binary+import qualified Data.ByteString.Lazy.Char8 as Lazy+import           Data.Data+import           Data.Hashable+import           GHC.Generics (Generic)+import           Test.QuickCheck++import           B9.Artifact.Content.StringTemplate+import           B9.Artifact.Content+import           B9.QCUtil++-- | Parse a bytestring into an 'a', and return @Left errorMessage@ or @Right a@+-- This is like 'Binary.decodeOrFail' exception that it allows to add and extra+-- error message+decodeOrFail'+    :: Binary a+    => String -- ^ An arbitrary string for error messages+    -> Lazy.ByteString+    -> Either String a+decodeOrFail' errorMessage b =+  case Binary.decodeOrFail b of+    Left (_,_,e) -> Left (unwords [errorMessage, e])+    Right (_,_,a) -> Right a++-- | Describe how to create structured content that has a tree-like syntactic+-- structure, e.g. yaml, JSON and erlang-proplists. The first parameter defines+-- a /context/ into which the 'AST' is embedded,+-- e.g. B9.Artifact.Content'. The second parameter defines a specifix+-- syntax, e.g 'B9.Artifact.Content.ErlangPropList' that the 'AST' value generates.+data AST c a+    = ASTObj [(String, AST c a)] -- ^ Create an object similar to a+                                 -- Json object.+    | ASTArr [AST c a] -- ^ An array.+    | ASTMerge [AST c a] -- ^ Merge the nested elements, this is a very+                         -- powerful tool that allows to combine+    |+      -- several inputs in a smart and safe way,+      -- e.g. by merging the values of the same+      -- fields in yaml objects.+      ASTEmbed c -- Embed more impure content.+    | ASTString String -- A string literal.+    | ASTInt Int -- An Int literal.+    | ASTParse SourceFile -- An 'AST' obtained from parsing a source+                          -- file that contains a string corresponding+    |+                -- to the type parameter @a@, e.g. 'YamlObject's+      AST a -- Embed a literal @a@.+    deriving (Read,Show,Typeable,Data,Eq,Generic)++instance Functor (AST c) where+  fmap f (AST a)          = AST (f a)+  fmap f (ASTObj x)       = ASTObj ((fmap . fmap . fmap) f x)+  fmap f (ASTArr x)       = ASTArr ((fmap . fmap) f x)+  fmap f (ASTMerge x)     = ASTMerge ((fmap . fmap) f x)+  fmap _ (ASTEmbed x)     = ASTEmbed x+  fmap _ (ASTString x)    = ASTString x+  fmap _ (ASTInt x)       = ASTInt x+  fmap _ (ASTParse x)     = ASTParse x++instance (Hashable c, Hashable a) => Hashable (AST c a)+instance (Binary c, Binary a) => Binary (AST c a)+instance (NFData c, NFData a) => NFData (AST c a)++-- | Types of values that describe content, that can be created from an 'AST'.+class FromAST a  where+    fromAST+        :: (ToContentGenerator c)+        => AST c a -> ContentGenerator a++instance (Arbitrary c, Arbitrary a) => Arbitrary (AST c a) where+    arbitrary =+        oneof+            [ ASTObj <$> smaller (listOf ((,) <$> arbitrary <*> arbitrary))+            , ASTArr <$> smaller (listOf arbitrary)+            , ASTMerge <$>+              sized+                  (\s ->+                        resize (max 2 s) (listOf (halfSize arbitrary)))+            , ASTEmbed <$> smaller arbitrary+            , ASTString <$> arbitrary+            , ASTParse <$> smaller arbitrary+            , AST <$> smaller arbitrary]
+ src/lib/B9/Artifact/Content/CloudConfigYaml.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE OverloadedStrings #-}++{-| This contains a 'YamlObject' for Canonicals @cloud-init@.++For some reason, cloud-config yaml documents __MUST__+contain @#cloud-config@ in the first line.++This is documented in the <https://cloudinit.readthedocs.io/en/latest/topics/format.html#cloud-config-data cloud config documentation>.++Otherwise, this is just a wrapper around 'YamlObject'.++@Since 0.5.62+-}+module B9.Artifact.Content.CloudConfigYaml+  ( CloudConfigYaml(..)+  , cloudConfigFileHeader+  ) where++import           B9.Artifact.Content.AST+import           B9.Artifact.Content.YamlObject++import           Control.Parallel.Strategies (NFData)+import           Data.Binary                 (Binary)+import qualified Data.Binary                 as Binary+import qualified Data.Binary.Get             as Binary+import qualified Data.ByteString.Lazy.Char8  as Lazy+import           Data.Data                   (Data, Typeable)+import           Data.Hashable               (Hashable)+import           GHC.Generics                (Generic)+import           Test.QuickCheck             (Arbitrary)++-- | Cloud-init @meta-data@ configuration Yaml.+--+-- @cloud-config@ yaml documents contain:+ -- @#cloud-config@ as first line.+--+-- @Since 0.5.62+newtype CloudConfigYaml = MkCloudConfigYaml+  { fromCloudConfigYaml :: YamlObject+  } deriving (Hashable, NFData, Eq, Data, Typeable, Generic, Arbitrary, Read, Show, Semigroup)++-- | The header line, which must be the first line in the+-- text file containing the cloud-config Yaml document.+--+-- @Since 0.5.62+cloudConfigFileHeader :: Lazy.ByteString+cloudConfigFileHeader = "#cloud-config\n"++instance FromAST CloudConfigYaml where+  fromAST ast = MkCloudConfigYaml <$> fromAST (fromCloudConfigYaml <$> ast)++instance Binary CloudConfigYaml where+  get+    -- skip the optional header line+   = do+    Binary.lookAheadM+      (do completeDocument <- Binary.lookAhead Binary.getRemainingLazyByteString+          if Lazy.length completeDocument >= Lazy.length cloudConfigFileHeader &&+                Lazy.take (Lazy.length cloudConfigFileHeader) completeDocument == cloudConfigFileHeader+               then do Binary.skip (fromIntegral (Lazy.length cloudConfigFileHeader))+                       return (Just ())+               else return Nothing)+    MkCloudConfigYaml <$> Binary.get+  put (MkCloudConfigYaml y) = do+    Binary.put cloudConfigFileHeader+    Binary.put y
+ src/lib/B9/Artifact/Content/ErlTerms.hs view
@@ -0,0 +1,350 @@+{-| Erlang term parser and pretty printer. -}+module B9.Artifact.Content.ErlTerms (parseErlTerm+                           ,erlTermParser+                           ,renderErlTerm+                           ,SimpleErlangTerm(..)+                           ,arbitraryErlSimpleAtom+                           ,arbitraryErlString+                           ,arbitraryErlNumber+                           ,arbitraryErlNatural+                           ,arbitraryErlFloat+                           ,arbitraryErlNameChar) where++import           Control.Parallel.Strategies+import           Data.Binary+import qualified Data.ByteString.Lazy.Char8 as Lazy+import           Data.Data+import           Data.Function+import           Data.Hashable+import           GHC.Generics (Generic)+import           Test.QuickCheck+import           Text.Parsec+       ((<|>), many, spaces, char, option, between, string, choice,+        octDigit, hexDigit, many1, noneOf, try, digit, anyChar, alphaNum,+        lower, parse)+import           Text.Parsec.ByteString.Lazy+import           Text.Show.Pretty+import           Control.Monad+import           Text.Printf+import qualified Text.PrettyPrint as PP++import           B9.QCUtil++-- | Simplified Erlang term representation.+data SimpleErlangTerm+    = ErlString String+    | ErlFloat Double+    | ErlNatural Integer+    | ErlAtom String+    | ErlChar Char+    | ErlBinary String+    | ErlList [SimpleErlangTerm]+    | ErlTuple [SimpleErlangTerm]+    deriving (Eq,Ord,Read,Show,Data,Typeable,Generic)++instance Hashable SimpleErlangTerm+instance Binary SimpleErlangTerm+instance NFData SimpleErlangTerm+++-- | Parse a subset of valid Erlang terms. It parses no maps and binaries are+-- restricted to either empty binaries or binaries with a string. The input+-- encoding must be restricted to ascii compatible 8-bit characters+-- (e.g. latin-1 or UTF8).+parseErlTerm :: String -> Lazy.ByteString -> Either String SimpleErlangTerm+parseErlTerm src content =+  either (Left . ppShow) Right (parse erlTermParser src content)++-- | Convert an abstract Erlang term to a pretty byte string preserving the+-- encoding.+renderErlTerm :: SimpleErlangTerm -> Lazy.ByteString+renderErlTerm s = Lazy.pack (PP.render (prettyPrintErlTerm s PP.<> PP.char '.'))++prettyPrintErlTerm :: SimpleErlangTerm -> PP.Doc+prettyPrintErlTerm (ErlString str) = PP.doubleQuotes (PP.text (toErlStringString str))+prettyPrintErlTerm (ErlNatural n) = PP.integer n+prettyPrintErlTerm (ErlFloat f) = PP.double f+prettyPrintErlTerm (ErlChar c) = PP.text ("$" ++ toErlAtomChar c)+prettyPrintErlTerm (ErlAtom a) = PP.text quotedAtom+  where+    quotedAtom =+      case toErlAtomString a of+        "" -> "''"+        a'@(firstChar:rest)+          | firstChar `elem` ['a' .. 'z'] &&+              all (`elem` atomCharsThatDontNeedQuoting) rest -> a'+        a' -> "'" ++ a' ++ "'"+    atomCharsThatDontNeedQuoting =+      ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] ++ "@_"++prettyPrintErlTerm (ErlBinary []) = PP.text "<<>>"+prettyPrintErlTerm (ErlBinary b) = PP.text ("<<\"" ++ toErlStringString b ++ "\">>")+prettyPrintErlTerm (ErlList xs) =+  PP.brackets (PP.sep (PP.punctuate PP.comma (prettyPrintErlTerm <$> xs)))+prettyPrintErlTerm (ErlTuple xs) =+  PP.braces (PP.sep (PP.punctuate PP.comma (prettyPrintErlTerm <$> xs)))++toErlStringString :: String -> String+toErlStringString = join . map toErlStringChar++toErlStringChar :: Char -> String+toErlStringChar = (table !!) . fromEnum+  where+    table =+      [printf "\\x{%x}" c | c <- [0 .. (31 :: Int)]] +++      (pure . toEnum <$> [32 .. 33]) +++      ["\\\""] +++      (pure . toEnum <$> [35 .. 91]) +++      ["\\\\"] ++ (pure . toEnum <$> [93 .. 126]) ++ [printf "\\x{%x}" c | c <- [(127 :: Int) ..]]++toErlAtomString :: String -> String+toErlAtomString = join . map toErlAtomChar++toErlAtomChar :: Char -> String+toErlAtomChar = (table !!) . fromEnum+  where+    table =+      [printf "\\x{%x}" c | c <- [0 .. (31 :: Int)]] +++      (pure . toEnum <$> [32 .. 38]) +++      ["\\'"] +++      (pure . toEnum <$> [40 .. 91]) +++      ["\\\\"] ++ (pure . toEnum <$> [93 .. 126]) ++ [printf "\\x{%x}" c | c <- [(127 :: Int) ..]]+++instance Arbitrary SimpleErlangTerm where+  arbitrary = oneof [sized aErlString+                    ,sized aErlNatural+                    ,sized aErlFloat+                    ,sized aErlChar+                    ,sized aErlAtomUnquoted+                    ,sized aErlAtomQuoted+                    ,sized aErlBinary+                    ,sized aErlList+                    ,sized aErlTuple+                    ]+    where+      decrSize 0 = resize 0+      decrSize n = resize (n - 1)+      aErlString n =+        ErlString <$> decrSize n (listOf (choose (toEnum 0,toEnum 255)))+      aErlFloat n = do+        f <- decrSize n arbitrary :: Gen Float+        let d = fromRational (toRational f)+        return (ErlFloat d)+      aErlNatural n =+        ErlNatural <$> decrSize n arbitrary+      aErlChar n =+        ErlChar <$> decrSize n (choose (toEnum 0, toEnum 255))+      aErlAtomUnquoted n = do+        f <- choose ('a','z')+        rest <- decrSize n aErlNameString+        return (ErlAtom (f:rest))+      aErlAtomQuoted n = do+        cs <- decrSize n aParsableErlString+        return (ErlAtom ("'" ++ cs ++ "'"))+      aErlBinary n =+        ErlBinary <$> decrSize n (listOf (choose (toEnum 0,toEnum 255)))+      aParsableErlString = oneof [aErlNameString+                                 ,aErlEscapedCharString+                                 ,aErlControlCharString+                                 ,aErlOctalCharString+                                 ,aErlHexCharString]+      aErlNameString = listOf (elements (['a'..'z'] ++ ['A'..'Z']++ ['0'..'9']++"@_"))+      aErlEscapedCharString = elements (("\\"++) . pure <$> "0bdefnrstv\\\"\'")+      aErlControlCharString = elements (("\\^"++) . pure <$> (['a'..'z'] ++ ['A'..'Z']))+      aErlOctalCharString = do+        n <- choose (1,3)+        os <- vectorOf n (choose (0,7))+        return (join ("\\":(show <$> (os::[Int]))))+      aErlHexCharString =+        oneof [twoDigitHex,nDigitHex]+        where+          twoDigitHex = do+            d1 <- choose (0,15) :: Gen Int+            d2 <- choose (0,15) :: Gen Int+            return (printf "\\x%x%X" d1 d2)+          nDigitHex = do+            zs <- listOf (elements "0")+            v <- choose (0,255) :: Gen Int+            return (printf "\\x{%s%x}" zs v)+      aErlList n =+        ErlList <$> resize (n `div` 2) (listOf arbitrary)+      aErlTuple n =+        ErlTuple <$> resize (n `div` 2) (listOf arbitrary)+++erlTermParser :: Parser SimpleErlangTerm+erlTermParser = between spaces (char '.') erlExpressionParser++erlExpressionParser :: Parser SimpleErlangTerm+erlExpressionParser = erlAtomParser+                 <|> erlCharParser+                 <|> erlStringParser+                 <|> erlBinaryParser+                 <|> erlListParser+                 <|> erlTupleParser+                 <|> try erlFloatParser+                 <|> erlNaturalParser++erlAtomParser :: Parser SimpleErlangTerm+erlAtomParser =+  ErlAtom <$>+  (between (char '\'')+           (char '\'')+           (many (erlCharEscaped <|> noneOf "'"))+   <|>+   ((:) <$> lower <*> many erlNameChar))++erlNameChar :: Parser Char+erlNameChar = alphaNum <|> char '@' <|> char '_'++erlCharParser :: Parser SimpleErlangTerm+erlCharParser = ErlChar <$> (char '$' >> (erlCharEscaped <|> anyChar))++erlFloatParser :: Parser SimpleErlangTerm+erlFloatParser = do+  -- Parse a float as string, then use read :: Double to 'parse' the floating+  -- point value. Calculating by hand is complicated because of precision+  -- issues.+  sign <- option "" ((char '-' >> return "-") <|> (char '+' >> return ""))+  s1 <- many digit+  char '.'+  s2 <- many1 digit+  e <- do expSym <- choice [char 'e', char 'E']+          expSign <- option "" ((char '-' >> return "-") <|> (char '+' >> return "+"))+          expAbs <- many1 digit+          return ([expSym] ++ expSign ++ expAbs)+      <|> return ""+  return (ErlFloat (read (sign ++ s1 ++ "." ++ s2 ++ e)))++erlNaturalParser :: Parser SimpleErlangTerm+erlNaturalParser = do+  sign <- signParser+  dec <- decimalLiteral+  return $ ErlNatural $ sign * dec++signParser :: Parser Integer+signParser =+  (char '-' >> return (-1))+  <|> (char '+' >> return 1)+  <|> return 1++decimalLiteral :: Parser Integer+decimalLiteral =+   foldr (\radix acc ->+            (try (string (show radix ++ "#"))+             >> calcBE (toInteger radix) <$> many1 (erlDigits radix))+            <|> acc)+         (calcBE 10 <$> many1 (erlDigits 10))+         [2..36]+  where+    calcBE a = foldl (\acc d -> a * acc + d) 0+    erlDigits k = choice (take k digitParsers)+    digitParsers =+      -- create parsers that consume/match '0' .. '9' and "aA" .. "zZ" and return 0 .. 35+      map (\(cs,v) -> choice (char <$> cs) >> return v)+          (((pure <$> ['0' .. '9']) ++ zipWith ((++) `on` pure)+                                               ['a' .. 'z']+                                               ['A' .. 'Z'])+           `zip` [0..])++erlStringParser :: Parser SimpleErlangTerm+erlStringParser = do+  char '"'+  str <- many (erlCharEscaped <|> noneOf "\"")+  char '"'+  return (ErlString str)++erlCharEscaped :: Parser Char+erlCharEscaped =+  char '\\'+  >> (do char '^'+         choice (zipWith escapedChar ccodes creplacements)++      <|>+      do char 'x'+         do ds <- between (char '{') (char '}') (fmap hexVal <$> many1 hexDigit)+            let val = foldl (\acc v -> acc * 16 + v) 0 ds+            return (toEnum val)+          <|>+          do x1 <- hexVal <$> hexDigit+             x2 <- hexVal <$> hexDigit;+             return (toEnum ((x1*16)+x2))++      <|>+      do o1 <- octVal <$> octDigit+         do o2 <- octVal <$> octDigit+            do o3 <- octVal <$> octDigit+               return (toEnum ((((o1*8)+o2)*8)+o3))+              <|> return (toEnum ((o1*8)+o2))+          <|> return (toEnum o1)++      <|>+      choice (zipWith escapedChar codes replacements))+  where+    escapedChar code replacement = char code >> return replacement+    codes =+      "0bdefnrstv\\\"'"+    replacements =+      "\NUL\b\DEL\ESC\f\n\r \t\v\\\"'"+    ccodes =+      ['a' .. 'z'] ++ ['A' .. 'Z']+    creplacements =+      cycle ['\^A' .. '\^Z']+    hexVal v | v `elem` ['a' .. 'z'] = 0xA + (fromEnum v - fromEnum 'a')+             | v `elem` ['A' .. 'Z'] = 0xA + (fromEnum v - fromEnum 'A')+             | otherwise = fromEnum v - fromEnum '0'+    octVal = hexVal++erlBinaryParser :: Parser SimpleErlangTerm+erlBinaryParser =+  do string "<<"+     spaces+     ErlString str <- option (ErlString "") erlStringParser+     string ">>"+     spaces+     return (ErlBinary str)++erlListParser :: Parser SimpleErlangTerm+erlListParser = ErlList <$> erlNestedParser (char '[') (char ']')++erlTupleParser :: Parser SimpleErlangTerm+erlTupleParser = ErlTuple <$> erlNestedParser (char '{') (char '}')++erlNestedParser :: Parser a -> Parser b -> Parser [SimpleErlangTerm]+erlNestedParser open close =+  between+    (open >> spaces)+    (close >> spaces)+    (commaSep erlExpressionParser)++commaSep :: Parser a -> Parser [a]+commaSep p = do r <- p+                spaces+                rest <- option [] (char ',' >> spaces >> commaSep p)+                return (r:rest)+            <|> return []++arbitraryErlSimpleAtom :: Gen SimpleErlangTerm+arbitraryErlSimpleAtom = ErlAtom <$> ((:)+                                      <$> arbitraryLetterLower+                                      <*> listOf arbitraryErlNameChar)++arbitraryErlString :: Gen SimpleErlangTerm+arbitraryErlString = ErlString <$> listOf (oneof [arbitraryLetter+                                                 ,arbitraryDigit])++arbitraryErlNumber :: Gen SimpleErlangTerm+arbitraryErlNumber = oneof [arbitraryErlNatural, arbitraryErlFloat]++arbitraryErlNatural :: Gen SimpleErlangTerm+arbitraryErlNatural = ErlNatural <$> arbitrary++arbitraryErlFloat :: Gen SimpleErlangTerm+arbitraryErlFloat = ErlFloat <$> arbitrary++arbitraryErlNameChar :: Gen Char+arbitraryErlNameChar = oneof [arbitraryLetter+                             ,arbitraryDigit+                             ,pure '_'+                             ,pure '@']
+ src/lib/B9/Artifact/Content/ErlangPropList.hs view
@@ -0,0 +1,108 @@+{-| Allow reading, merging and writing Erlang terms. -}+module B9.Artifact.Content.ErlangPropList+  ( ErlangPropList(..)+  ) where++import Control.Parallel.Strategies+import Data.Binary as Binary+import Data.Binary.Get as Binary+import Data.Data+import Data.Function+import Data.Hashable+import Data.List (partition, sortBy)+#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup+#endif+import qualified Data.Text.Lazy as T+import qualified Data.Text.Lazy.Encoding as E+import GHC.Generics (Generic)+import Text.Printf++import B9.Artifact.Content.AST+import B9.Artifact.Content.ErlTerms+import           B9.Artifact.Content+import B9.Artifact.Content.StringTemplate++import Data.Binary.Put (putLazyByteString)+import Test.QuickCheck++-- | A wrapper type around erlang terms with a Semigroup instance useful for+-- combining sys.config files with OTP-application configurations in a list of+-- the form of a proplist.+newtype ErlangPropList =+  ErlangPropList SimpleErlangTerm+  deriving (Read, Eq, Show, Data, Typeable, Generic)++instance Hashable ErlangPropList++instance NFData ErlangPropList++instance Arbitrary ErlangPropList where+  arbitrary = ErlangPropList <$> arbitrary++instance Semigroup ErlangPropList where+  (ErlangPropList v1) <> (ErlangPropList v2) = ErlangPropList (combine v1 v2)+    where+      combine (ErlList l1) (ErlList l2) = ErlList (l1Only <> merged <> l2Only)+        where+          l1Only = l1NonPairs <> l1NotL2+          l2Only = l2NonPairs <> l2NotL1+          (l1Pairs, l1NonPairs) = partition isPair l1+          (l2Pairs, l2NonPairs) = partition isPair l2+          merged = zipWith merge il1 il2+            where+              merge (ErlTuple [_k, pv1]) (ErlTuple [k, pv2]) = ErlTuple [k, pv1 `combine` pv2]+              merge _ _ = error "unreachable"+          (l1NotL2, il1, il2, l2NotL1) = partitionByKey l1Sorted l2Sorted ([], [], [], [])+            where+              partitionByKey [] ys (exs, cxs, cys, eys) = (reverse exs, reverse cxs, reverse cys, reverse eys <> ys)+              partitionByKey xs [] (exs, cxs, cys, eys) = (reverse exs <> xs, reverse cxs, reverse cys, reverse eys)+              partitionByKey (x:xs) (y:ys) (exs, cxs, cys, eys)+                | equalKey x y = partitionByKey xs ys (exs, x : cxs, y : cys, eys)+                | x `keyLessThan` y = partitionByKey xs (y : ys) (x : exs, cxs, cys, eys)+                | otherwise = partitionByKey (x : xs) ys (exs, cxs, cys, y : eys)+              l1Sorted = sortByKey l1Pairs+              l2Sorted = sortByKey l2Pairs+          sortByKey = sortBy (compare `on` getKey)+          keyLessThan = (<) `on` getKey+          equalKey = (==) `on` getKey+          getKey (ErlTuple (x:_)) = x+          getKey x = x+          isPair (ErlTuple [_, _]) = True+          isPair _ = False+      combine (ErlList pl1) t2 = ErlList (pl1 <> [t2])+      combine t1 (ErlList pl2) = ErlList ([t1] <> pl2)+      combine t1 t2 = ErlList [t1, t2]++instance Binary ErlangPropList where+  get = do+    str <- Binary.getRemainingLazyByteString+    case parseErlTerm "" str of+      Right t -> return (ErlangPropList t)+      Left e -> fail e+  put (ErlangPropList t) = putLazyByteString (renderErlTerm t)++instance FromAST ErlangPropList where+  fromAST (AST a) = pure a+  fromAST (ASTObj pairs) = ErlangPropList . ErlList <$> mapM makePair pairs+    where+      makePair (k, ast) = do+        (ErlangPropList second) <- fromAST ast+        return $ ErlTuple [ErlAtom k, second]+  fromAST (ASTArr xs) =+    ErlangPropList . ErlList <$>+    mapM+      (\x -> do+         (ErlangPropList x') <- fromAST x+         return x')+      xs+  fromAST (ASTString s) = pure $ ErlangPropList $ ErlString s+  fromAST (ASTInt i) = pure $ ErlangPropList $ ErlString (show i)+  fromAST (ASTEmbed c) = ErlangPropList . ErlString . T.unpack . E.decodeUtf8 <$> toContentGenerator c+  fromAST (ASTMerge []) = error "ASTMerge MUST NOT be used with an empty list!"+  fromAST (ASTMerge asts) = foldl1 (<>) <$> mapM fromAST asts+  fromAST (ASTParse src@(Source _ srcPath)) = do+    c <- readTemplateFile src+    case decodeOrFail' srcPath c of+      Right s -> return s+      Left e -> error (printf "could not parse erlang source file: '%s'\n%s\n" srcPath e)
+ src/lib/B9/Artifact/Content/Readable.hs view
@@ -0,0 +1,93 @@+{-| Content defined in text files (.b9 files), read with the 'Read' instances.++-}+module B9.Artifact.Content.Readable where++import Control.Monad.Trans (lift)+import Control.Parallel.Strategies+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif+import Control.Monad.IO.Class+import Data.Binary as Binary+import qualified Data.ByteString as Strict+import qualified Data.ByteString.Base64 as B64+import qualified Data.ByteString.Lazy.Char8 as Lazy+import Data.Data+import GHC.Generics (Generic)+import System.Exit+import System.Process+import Test.QuickCheck++import B9.B9Monad+import B9.Artifact.Content+import B9.Artifact.Content.AST+import B9.Artifact.Content.CloudConfigYaml+import B9.Artifact.Content.ErlangPropList+import B9.Artifact.Content.StringTemplate+import B9.Artifact.Content.YamlObject+import B9.QCUtil++-- | This is content that can be 'read' via the generated 'Read' instance.+data Content+  = RenderErlang (AST Content ErlangPropList)+  | RenderYamlObject (AST Content YamlObject)+  | RenderCloudConfig (AST Content CloudConfigYaml)+    -- | This data will be passed through unaltered.+    -- This is used during the transition phase from having B9 stuff read from+    -- files via 'Read' instances towards programatic use or the use of HOCON.+    --+    -- @since 0.5.62+  | FromByteString Lazy.ByteString+    -- | Embed a literal string+  | FromString String+    -- | Embed the contents of the 'SourceFile' with template parameter substitution.+  | FromTextFile SourceFile+    -- | The data in the given file will be base64 encoded.+  | RenderBase64BinaryFile FilePath+    -- | This data will be base64 encoded.+  | RenderBase64Binary Lazy.ByteString+    -- | Download the contents of the URL+  | FromURL String+  deriving (Read, Show, Typeable, Eq, Data, Generic)++instance NFData Content++instance Arbitrary Content where+  arbitrary =+    oneof+      [ FromTextFile <$> smaller arbitrary+      , RenderBase64BinaryFile <$> smaller arbitrary+      , RenderErlang <$> smaller arbitrary+      , RenderYamlObject <$> smaller arbitrary+      , RenderCloudConfig <$> smaller arbitrary+      , FromString <$> smaller arbitrary+      , FromByteString . Lazy.pack <$> smaller arbitrary+      , RenderBase64Binary . Lazy.pack <$> smaller arbitrary+      , FromURL <$> smaller arbitrary+      ]++instance ToContentGenerator Content where+  toContentGenerator (RenderErlang ast) = Binary.encode <$> fromAST ast+  toContentGenerator (RenderYamlObject ast) = Binary.encode <$> fromAST ast+  toContentGenerator (RenderCloudConfig ast) = Binary.encode <$> fromAST ast+  toContentGenerator (FromTextFile s) = readTemplateFile s+  toContentGenerator (RenderBase64BinaryFile s) = readBinaryFileAsBase64 s+    where+      readBinaryFileAsBase64 :: MonadIO m => FilePath -> m Lazy.ByteString+      readBinaryFileAsBase64 f = Lazy.fromStrict . B64.encode <$> liftIO (Strict.readFile f)+  toContentGenerator (RenderBase64Binary b) = pure (Lazy.fromStrict $ B64.encode $ Lazy.toStrict b)+  toContentGenerator (FromString str) = pure (Lazy.pack str)+  toContentGenerator (FromByteString str) = pure str+  toContentGenerator (FromURL url) =+    lift $ do+      dbgL $ "Downloading: " ++ url+      (exitCode, out, err) <- liftIO $ readProcessWithExitCode "curl" [url] ""+      if exitCode == ExitSuccess+        then do+          dbgL $ "Download finished. Bytes read: " ++ show (length out)+          traceL $ "Downloaded (truncated to first 4K): \n\n" ++ take 4096 out ++ "\n\n"+          pure $ Lazy.pack out+        else do+          errorL $ "Download failed: " ++ err+          liftIO $ exitWith exitCode
+ src/lib/B9/Artifact/Content/StringTemplate.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE FlexibleContexts #-}++{-| Utility functions based on 'Data.Text.Template' to offer @ $var @ variable+    expansion in string throughout a B9 artifact. -}+module B9.Artifact.Content.StringTemplate+  ( subst+  , substE+  , substEB+  , substFile+  , substPath+  , readTemplateFile+  , SourceFile(..)+  , SourceFileConversion(..)+  ) where+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif+import B9.Environment+import B9.QCUtil+import Control.Exception (SomeException)+import Control.Monad.IO.Class (MonadIO(liftIO))+import Control.Monad.Reader (runReaderT)+import Control.Monad.Trans.Identity ()+import Control.Parallel.Strategies+import Data.Bifunctor+import Data.Binary+import qualified Data.ByteString as Strict+import qualified Data.ByteString.Lazy as Lazy+import Data.Data+import Data.Hashable+import qualified Data.Text.Lazy as LazyT+import qualified Data.Text      as StrictT+import qualified Data.Text.Encoding       as StrictE+import qualified Data.Text.Lazy.Encoding  as LazyE+import Data.Text.Template (render, renderA, templateSafe)+import GHC.Generics (Generic)+import System.IO.B9Extras+import Test.QuickCheck+import Text.Printf++-- | A wrapper around a file path and a flag indicating if template variable+-- expansion should be performed when reading the file contents.+data SourceFile =+  Source SourceFileConversion+         FilePath+  deriving (Read, Show, Typeable, Data, Eq, Generic)++instance Hashable SourceFile++instance Binary SourceFile++instance NFData SourceFile++data SourceFileConversion+  = NoConversion+  | ExpandVariables+  deriving (Read, Show, Typeable, Data, Eq, Generic)++instance Hashable SourceFileConversion++instance Binary SourceFileConversion++instance NFData SourceFileConversion++readTemplateFile :: (MonadIO m, MonadEnvironment m) => SourceFile -> m Lazy.ByteString+readTemplateFile (Source conv f') = do+  env <- askEnvironment+  case substE env f' of+    Left e ->+      error+        (printf+           "Failed to substitute templates in source \+                    \file name '%s'/\nError: %s\n"+           f'+           e)+    Right f -> do+      c <- liftIO (Lazy.readFile f)+      convert f c+  where+    convert f c =+      case conv of+        NoConversion -> return c+        ExpandVariables -> do+          env <- askEnvironment+          case substEB env c of+            Left e -> error (printf "readTemplateFile '%s' failed: \n%s\n" f e)+            Right c' -> return c'++-- String template substitution via dollar+subst :: Environment -> String -> String+subst env templateStr =+  case substE env templateStr of+    Left e -> error e+    Right r -> r++-- String template substitution via dollar+substE :: Environment -> String -> Either String String+substE env templateStr = second (LazyT.unpack . LazyE.decodeUtf8) (substEB env (LazyE.encodeUtf8 (LazyT.pack templateStr)))++-- String template substitution via dollar+substEB :: Environment -> Lazy.ByteString -> Either String Lazy.ByteString+substEB env templateStr = do+  t <- template'+  res <- renderA t env'+  return (LazyE.encodeUtf8 res)+  where+    env' t =+      case lookupEither (LazyT.fromStrict t) env of+        Right v -> Right (LazyT.toStrict v)+        Left e -> Left (show e ++ "\nIn template: \"" ++ show templateStr ++ "\"\n")+    template' =+      case templateSafe (LazyT.toStrict (LazyE.decodeUtf8 templateStr)) of+        Left (row, col) ->+          Left+            ("Invalid template, error at row: " ++ show row ++ ", col: " ++ show col ++ " in: \"" ++ show templateStr)+        Right t -> Right t++substFile :: MonadIO m => Environment -> FilePath -> FilePath -> m ()+substFile env src dest = do+  templateBs <- liftIO (Strict.readFile src)+  let t = templateSafe (StrictE.decodeUtf8 templateBs)+  case t of+    Left (r, c) ->+      let badLine = unlines (take r (lines (StrictT.unpack (StrictE.decodeUtf8 templateBs))))+          colMarker = replicate (c - 1) '-' ++ "^"+       in error (printf "Template error in file '%s' line %i:\n\n%s\n%s\n" src r badLine colMarker)+    Right template' -> do+      let out = LazyE.encodeUtf8 (render template' envLookup)+      liftIO (Lazy.writeFile dest out)+      return ()+  where+    envLookup :: StrictT.Text -> StrictT.Text+    envLookup x = either err LazyT.toStrict (runReaderT (lookupOrThrow (LazyT.fromStrict x)) env)+      where+        err :: SomeException -> a+        err e = error (show e ++ "\nIn file: \'" ++ src ++ "\'\n")++substPath :: Environment -> SystemPath -> SystemPath+substPath env src =+  case src of+    Path p -> Path (subst env p)+    InHomeDir p -> InHomeDir (subst env p)+    InB9UserDir p -> InB9UserDir (subst env p)+    InTempDir p -> InTempDir (subst env p)++instance Arbitrary SourceFile where+  arbitrary = Source <$> elements [NoConversion, ExpandVariables] <*> smaller arbitraryFilePath
+ src/lib/B9/Artifact/Content/YamlObject.hs view
@@ -0,0 +1,96 @@+-- | A wrapper around Yaml with 'Semigroup' and 'Monoid' instances for merging, reading and+-- writing yaml files within B9.+module B9.Artifact.Content.YamlObject+  ( YamlObject(..)+  ) where++import           Control.Applicative+import           Control.Parallel.Strategies+import           Data.Binary                 (Binary (..))+import qualified Data.Binary.Get             as Binary+import qualified Data.ByteString.Lazy.Char8  as Lazy+import           Data.Data+import           Data.Function+import           Data.Hashable+import           Data.HashMap.Strict         hiding (singleton)+import           Data.Semigroup+import qualified Data.Text                   as StrictT+import qualified Data.Text.Encoding          as StrictE+import qualified Data.Text.Lazy              as LazyT+import qualified Data.Text.Lazy.Encoding     as LazyE+import           Data.Vector                 as Vector (singleton, (++))+import           Data.Yaml                   as Yaml+import           GHC.Generics                (Generic)+import           Prelude                     hiding ((++))+import           Text.Printf++import           B9.Artifact.Content+import           B9.Artifact.Content.AST+import           B9.Artifact.Content.StringTemplate++import           Test.QuickCheck++-- | A wrapper type around yaml values with a Semigroup instance useful for+-- combining yaml documents describing system configuration like e.g. user-data.+newtype YamlObject = YamlObject+  { _fromYamlObject :: Yaml.Value+  } deriving (Hashable, NFData, Eq, Data, Typeable, Generic)++instance Binary YamlObject where+  put = put . encode . _fromYamlObject+  get = YamlObject . either (error . show) id . Yaml.decodeThrow . Lazy.toStrict <$> Binary.getRemainingLazyByteString++instance Read YamlObject where+  readsPrec _ = readsYamlObject+    where+      readsYamlObject :: ReadS YamlObject+      readsYamlObject s = [(yamlFromString y, r2) | ("YamlObject", r1) <- lex s, (y, r2) <- reads r1]+        where+          yamlFromString :: String -> YamlObject+          yamlFromString = either error id . decodeOrFail' "HERE-DOC" . LazyE.encodeUtf8 . LazyT.pack++instance Show YamlObject where+  show (YamlObject o) = "YamlObject " <> show (StrictT.unpack $ StrictE.decodeUtf8 $ encode o)++instance Semigroup YamlObject where+  (YamlObject v1) <> (YamlObject v2) = YamlObject (combine v1 v2)+    where+      combine :: Yaml.Value -> Yaml.Value -> Yaml.Value+      combine (Object o1) (Object o2) = Object (unionWith combine o1 o2)+      combine (Array a1) (Array a2)   = Array (a1 ++ a2)+      combine (Array a1) t2           = Array (a1 ++ Vector.singleton t2)+      combine t1 (Array a2)           = Array (Vector.singleton t1 ++ a2)+      combine (String s1) (String s2) = String (s1 <> s2)+      combine t1 t2                   = array [t1, t2]++instance FromAST YamlObject where+  fromAST ast =+    case ast of+      ASTObj pairs -> do+        ys <- mapM fromASTPair pairs+        return (YamlObject (object ys))+      ASTArr asts -> do+        ys <- mapM fromAST asts+        let ys' = (\(YamlObject o) -> o) <$> ys+        return (YamlObject (array ys'))+      ASTMerge [] -> error "ASTMerge MUST NOT be used with an empty list!"+      ASTMerge asts -> do+        ys <- mapM fromAST asts+        return (foldl1 (<>) ys)+      ASTEmbed c -> YamlObject . toJSON . StrictT.unpack . StrictE.decodeUtf8 . Lazy.toStrict <$> toContentGenerator c+      ASTString str -> return (YamlObject (toJSON str))+      ASTInt int -> return (YamlObject (toJSON int))+      ASTParse src@(Source _ srcPath) -> do+        c <- readTemplateFile src+        case decodeOrFail' srcPath c of+          Right s -> return s+          Left e -> error (printf "could not parse yaml source file: '%s'\n%s\n" srcPath e)+      AST a -> pure a+    where+      fromASTPair (key, value) = do+        (YamlObject o) <- fromAST value+        let key' = StrictT.pack key+        return $ key' .= o++instance Arbitrary YamlObject where+  arbitrary = pure (YamlObject Null)
+ src/lib/B9/Artifact/Readable.hs view
@@ -0,0 +1,273 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies     #-}++{-|+Top-Level data types for B9 build artifacts.+-}+module B9.Artifact.Readable+  ( ArtifactGenerator(..)+  , InstanceId(..)+  , ArtifactTarget(..)+  , CloudInitType(..)+  , ArtifactAssembly(..)+  , AssembledArtifact(..)+  , AssemblyOutput(..)+  , instanceIdKey+  , buildIdKey+  , buildDateKey+  , getAssemblyOutput+  -- ** Re-exports+  , ArtifactSource(..)+  , getArtifactSourceFiles+  ) where++import           Control.Parallel.Strategies+import           Data.Binary+import           Data.Data+import           Data.Hashable+import           Data.Semigroup              as Sem+import           GHC.Generics                (Generic)+import           System.FilePath             ((<.>))++import           B9.Artifact.Readable.Source+import           B9.Artifact.Content.Readable+import           B9.Artifact.Content.StringTemplate+import           B9.DiskImages+import           B9.QCUtil+import           B9.Vm++import           Test.QuickCheck++{-| Artifacts represent the things B9 can build. A generator specifies howto+generate parameterized, multiple artifacts. The general structure is:++@+   Let [ ... bindings ... ]+       [ Sources+           [ ... list all input files ... ]+           [ Artifact ...+           , Artifact ...+           , Let [ ... ] [ ... ]+           ]+       ]+@++The reasons why 'Sources' takes a list of 'ArtifactGenerator's is that++   1. this makes the value easier to read/write for humans++   2. the sources are static files used in all children (e.g. company logo image)++   3. the sources are parameterized by variables that bound to different values+      for each artifact, e.g. a template network config file which contains+      the host IP address.++To bind such variables use 'Let', 'Each', 'LetX' or 'EachT'.++String substitution of these variables is done by "B9.Artifact.Content.StringTemplate".+These variables can be used as value in nested 'Let's, in most file names/paths+and in source files added with 'B9.Artifact.Content.StringTemplate.SourceFile'++-}+data ArtifactGenerator+  = Sources [ArtifactSource]+            [ArtifactGenerator]+      -- ^ Add sources available to 'ArtifactAssembly's in+      -- nested artifact generators.+  | Let [(String, String)]+        [ArtifactGenerator]+      -- ^ Bind variables, variables are available in nested+      -- generators.+  | LetX [(String, [String])]+         [ArtifactGenerator]+      -- ^ A 'Let' where each variable is assigned to each+      -- value; the nested generator is executed for each+      -- permutation.+      --+      -- @+      --     LetX [("x", ["1","2","3"]), ("y", ["a","b"])] [..]+      -- @+      -- Is equal to:+      --+      -- @+      --     Let [] [+      --       Let [("x", "1"), ("y", "a")] [..]+      --       Let [("x", "1"), ("y", "b")] [..]+      --       Let [("x", "2"), ("y", "a")] [..]+      --       Let [("x", "2"), ("y", "b")] [..]+      --       Let [("x", "3"), ("y", "a")] [..]+      --       Let [("x", "3"), ("y", "b")] [..]+      --     ]+      -- @+  | Each [(String, [String])]+         [ArtifactGenerator]+      -- ^ Bind each variable to their first value, then each+      -- variable to the second value, etc ... and execute the+      -- nested generator in every step. 'LetX' represents a+      -- product of all variables, whereas 'Each' represents a+      -- sum of variable bindings - 'Each' is more like a /zip/+      -- whereas 'LetX' is more like a list comprehension.+  | EachT [String]+          [[String]]+          [ArtifactGenerator]+      -- ^ The transposed version of 'Each': Bind the variables+      -- in the first list to each a set of values from the+      -- second argument; execute the nested generators for+      -- each binding+  | Artifact InstanceId+             ArtifactAssembly+      -- ^ Generate an artifact defined by an+      -- 'ArtifactAssembly'; the assembly can access the files+      -- created from the 'Sources' and variables bound by+      -- 'Let'ish elements. An artifact has an instance id,+      -- that is a unique, human readable string describing the+      -- artifact to assemble.+  | EmptyArtifact+  deriving (Read, Show, Eq, Data, Typeable, Generic)++--instance Hashable ArtifactGenerator+--instance Binary ArtifactGenerator+instance NFData ArtifactGenerator++instance Sem.Semigroup ArtifactGenerator where+  (Let [] []) <> x = x+  x <> (Let [] []) = x+  x <> y = Let [] [x, y]++instance Monoid ArtifactGenerator where+  mempty = Let [] []+  mappend = (Sem.<>)++-- | Identify an artifact. __Deprecated__ TODO: B9 does not check if all+-- instances IDs are unique.+newtype InstanceId =+  IID String+  deriving (Read, Show, Typeable, Data, Eq, NFData, Binary, Hashable)++-- | The variable containing the instance id. __Deprecated__+instanceIdKey :: String+instanceIdKey = "instance_id"++-- | The variable containing the buildId that identifies each execution of+-- B9. For more info about variable substitution in source files see+-- 'B9.Artifact.Content.StringTemplate'+buildIdKey :: String+buildIdKey = "build_id"++-- | The variable containing the date and time a build was started. For more+-- info about variable substitution in source files see+-- 'B9.Artifact.Content.StringTemplate'+buildDateKey :: String+buildDateKey = "build_date"++-- | Define an __output__ of a build. Assemblies are nested into+-- 'ArtifactGenerator's. They contain all the files defined by the 'Sources'+-- they are nested into.+data ArtifactAssembly+  = CloudInit [CloudInitType]+              FilePath+      -- ^ Generate a __cloud-init__ compatible directory, ISO-+      -- or VFAT image, as specified by the list of+      -- 'CloudInitType's. Every item will use the second+      -- argument to create an appropriate /file name/,+      -- e.g. for the 'CI_ISO' type the output is @second_param.iso@.+  | VmImages [ImageTarget]+             VmScript+    -- ^ a set of VM-images that were created by executing a+    -- build script on them.+  deriving (Read, Show, Typeable, Data, Eq, Generic)++instance Hashable ArtifactAssembly++instance Binary ArtifactAssembly++instance NFData ArtifactAssembly++-- | A type representing the targets assembled by+-- 'B9.Artifact.Readable.Interpreter.assemble' from an 'ArtifactAssembly'. There is a+-- list of 'ArtifactTarget's because e.g. a single 'CloudInit' can produce up to+-- three output files, a directory, an ISO image and a VFAT image.+data AssembledArtifact =+  AssembledArtifact InstanceId+                    [ArtifactTarget]+  deriving (Read, Show, Typeable, Data, Eq, Generic)++instance Hashable AssembledArtifact++instance Binary AssembledArtifact++instance NFData AssembledArtifact++data ArtifactTarget+  = CloudInitTarget CloudInitType+                    FilePath+  | VmImagesTarget+  deriving (Read, Show, Typeable, Data, Eq, Generic)++instance Hashable ArtifactTarget++instance Binary ArtifactTarget++instance NFData ArtifactTarget++data CloudInitType+  = CI_ISO+  | CI_VFAT+  | CI_DIR+  deriving (Read, Show, Typeable, Data, Eq, Generic)++instance Hashable CloudInitType++instance Binary CloudInitType++instance NFData CloudInitType++-- | The output of an 'ArtifactAssembly' is either a set of generated files,+--  or it might be a directory that contains the artifacts sources.+data AssemblyOutput+  = AssemblyGeneratesOutputFiles [FilePath]+  | AssemblyCopiesSourcesToDirectory FilePath+  deriving (Read, Show, Typeable, Data, Eq, Generic)++-- | Return the files that the artifact assembly consist of.+getAssemblyOutput :: ArtifactAssembly -> [AssemblyOutput]+getAssemblyOutput (VmImages ts _) = AssemblyGeneratesOutputFiles . getImageDestinationOutputFiles <$> ts+getAssemblyOutput (CloudInit ts o) = getCloudInitOutputFiles o <$> ts+  where+    getCloudInitOutputFiles baseName t =+      case t of+        CI_ISO  -> AssemblyGeneratesOutputFiles [baseName <.> "iso"]+        CI_VFAT -> AssemblyGeneratesOutputFiles [baseName <.> "vfat"]+        CI_DIR  -> AssemblyCopiesSourcesToDirectory baseName++-- * QuickCheck instances+instance Arbitrary ArtifactGenerator where+  arbitrary =+    oneof+      [ Sources <$> halfSize arbitrary <*> halfSize arbitrary+      , Let <$> halfSize arbitraryEnv <*> halfSize arbitrary+      , halfSize arbitraryEachT <*> halfSize arbitrary+      , halfSize arbitraryEach <*> halfSize arbitrary+      , Artifact <$> smaller arbitrary <*> smaller arbitrary+      , pure EmptyArtifact+      ]++arbitraryEachT :: Gen ([ArtifactGenerator] -> ArtifactGenerator)+arbitraryEachT =+  sized $ \n ->+    EachT <$> vectorOf n (halfSize (listOf1 (choose ('a', 'z')))) <*>+    oneof [listOf (vectorOf n (halfSize arbitrary)), listOf1 (listOf (halfSize arbitrary))]++arbitraryEach :: Gen ([ArtifactGenerator] -> ArtifactGenerator)+arbitraryEach =+  sized $ \n ->+    Each <$> listOf ((,) <$> listOf1 (choose ('a', 'z')) <*> vectorOf n (halfSize (listOf1 (choose ('a', 'z')))))++instance Arbitrary InstanceId where+  arbitrary = IID <$> arbitraryFilePath++instance Arbitrary ArtifactAssembly where+  arbitrary = oneof [CloudInit <$> arbitrary <*> arbitraryFilePath, VmImages <$> smaller arbitrary <*> pure NoVmScript]++instance Arbitrary CloudInitType where+  arbitrary = elements [CI_ISO, CI_VFAT, CI_DIR]
+ src/lib/B9/Artifact/Readable/Interpreter.hs view
@@ -0,0 +1,364 @@+{-|+Mostly effectful functions to assemble artifacts.+-}+module B9.Artifact.Readable.Interpreter where++import           Control.Arrow+import           Control.Exception         (Exception, SomeException)+import           Control.Lens              (view)+import           Control.Monad.Catch+import           Control.Monad.Except+import           Control.Monad.Reader+import           Control.Monad.Writer+import qualified Data.ByteString.Lazy      as Lazy+import           Data.Data+import           Data.Generics.Aliases+import           Data.Generics.Schemes+import           Data.List+import           Data.Maybe+import qualified Data.Text.Lazy            as LazyT+import qualified Data.Text.Lazy.Encoding   as LazyE+import           System.Directory+import           System.FilePath+import           System.IO.B9Extras        (ensureDir, getDirectoryFiles)+import           Text.Printf+import           Text.Show.Pretty          (ppShow)++import           B9.Artifact.Readable+import           B9.B9Config+import           B9.B9Monad+import           B9.Artifact.Content+import           B9.Artifact.Content.Readable+import           B9.Artifact.Content.StringTemplate+import           B9.DiskImageBuilder+import           B9.Environment+import           B9.Vm+import           B9.VmBuilder++-- | Execute an 'ArtifactGenerator' and return a 'B9Invocation' that returns+-- the build id obtained by 'getBuildId'.+buildArtifacts :: ArtifactGenerator -> B9 String+buildArtifacts artifactGenerator = do+  traceL . ("CWD: " ++) =<< liftIO getCurrentDirectory+  infoL "BUILDING ARTIFACTS"+  getConfig >>= traceL . printf "USING BUILD CONFIGURATION: %v" . ppShow+  assemble artifactGenerator+  getBuildId++-- | Return a list of relative paths for the /local/ files to be generated+-- by the ArtifactGenerator. This excludes 'Shared' and Transient image targets.+getArtifactOutputFiles :: ArtifactGenerator -> Either String [FilePath]+getArtifactOutputFiles g = concatMap getOutputs <$> evalArtifactGenerator undefined undefined mempty g+  where+    getOutputs (IG _ sgs a) =+      let toOutFile (AssemblyGeneratesOutputFiles fs) = fs+          toOutFile (AssemblyCopiesSourcesToDirectory pd) =+            let sourceFiles = sourceGeneratorOutputFile <$> sgs+             in (pd </>) <$> sourceFiles+       in getAssemblyOutput a >>= toOutFile++-- | Run an artifact generator to produce the artifacts.+assemble :: ArtifactGenerator -> B9 [AssembledArtifact]+assemble artGen = do+  b9cfgEnvVars <- view envVars <$> getConfig+  buildId <- getBuildId+  buildDate <- getBuildDate+  case evalArtifactGenerator buildId buildDate b9cfgEnvVars artGen of+    Left err -> error err+    Right is -> createAssembledArtifacts is++-- | Evaluate an 'ArtifactGenerator' into a list of low-level build instructions+-- that can be built with 'createAssembledArtifacts'.+evalArtifactGenerator ::+     String -> String -> Environment -> ArtifactGenerator -> Either String [InstanceGenerator [SourceGenerator]]+evalArtifactGenerator buildId buildDate b9cfgEnvVars artGen =+  let ag = parseArtifactGenerator artGen+      ee = addBindings [(buildDateKey, buildDate), (buildIdKey, buildId)] $ CGEnv b9cfgEnvVars []+   in case ee of+        Left err -> Left (printf "error parsing: %s: %s" (ppShow artGen) (show err))+        Right e ->+          case execCGParser ag e of+            Left err -> Left (printf "error parsing: %s: %s" (ppShow artGen) (show err))+            Right igs ->+              case execIGEnv `mapM` igs of+                Left err -> Left (printf "Failed to parse:\n%s\nError: %s" (ppShow artGen) err)+                Right is -> Right is++-- | Parse an artifacto generator inside a 'CGParser' monad.+parseArtifactGenerator :: ArtifactGenerator -> CGParser ()+parseArtifactGenerator g =+  case g of+    Sources srcs gs -> withArtifactSources srcs (mapM_ parseArtifactGenerator gs)+    Let bs gs -> withBindings bs (mapM_ parseArtifactGenerator gs)+    LetX bs gs -> withXBindings bs (mapM_ parseArtifactGenerator gs)+    EachT keySet valueSets gs -> do+      allBindings <- eachBindingSetT g keySet valueSets+      sequence_ (flip withBindings (mapM_ parseArtifactGenerator gs) <$> allBindings)+    Each kvs gs -> do+      allBindings <- eachBindingSet g kvs+      sequence_ $ do+        b <- allBindings+        return (withBindings b (mapM_ parseArtifactGenerator gs))+    Artifact iid assembly -> writeInstanceGenerator iid assembly+    EmptyArtifact -> return ()++-- | Execute a 'CGParser' action in an environment that contains a list of+-- 'ArtifactSource's.+withArtifactSources :: [ArtifactSource] -> CGParser () -> CGParser ()+withArtifactSources srcs = local (\ce -> ce {agSources = agSources ce ++ srcs})++withBindings :: [(String, String)] -> CGParser () -> CGParser ()+withBindings bs = local (fromJust . addBindings bs)++addBindings :: MonadThrow m => [(String, String)] -> CGEnv -> m CGEnv+addBindings bs ce = do+  let addBinding env (k, v) = addStringBinding (k, subst env v) env+  newEnv <- foldM addBinding (agEnv ce) bs+  return ce {agEnv = newEnv}++withXBindings :: [(String, [String])] -> CGParser () -> CGParser ()+withXBindings bs cp = (`local` cp) `mapM_` (((.) . (.)) fromJust addBindings <$> allXBindings bs)+  where+    allXBindings ((k, vs):rest) = [(k, v) : c | v <- vs, c <- allXBindings rest]+    allXBindings [] = [[]]++eachBindingSetT :: ArtifactGenerator -> [String] -> [[String]] -> CGParser [[(String, String)]]+eachBindingSetT g vars valueSets =+  if all ((== length vars) . length) valueSets+    then return (zip vars <$> valueSets)+    else cgError+           (printf+              "Error in 'Each' binding during artifact generation in:\n '%s'.\n\nThe variable list\n%s\n has %i entries, but this binding set\n%s\n\nhas a different number of entries!\n"+              (ppShow g)+              (ppShow vars)+              (length vars)+              (ppShow (head (dropWhile ((== length vars) . length) valueSets))))++eachBindingSet :: ArtifactGenerator -> [(String, [String])] -> CGParser [[(String, String)]]+eachBindingSet g kvs = do+  checkInput+  return bindingSets+  where+    bindingSets = transpose [repeat k `zip` vs | (k, vs) <- kvs]+    checkInput =+      when+        (1 /= length (nub $ length . snd <$> kvs))+        (cgError (printf "Error in 'Each' binding: \n%s\nAll value lists must have the same length!" (ppShow g)))++writeInstanceGenerator :: InstanceId -> ArtifactAssembly -> CGParser ()+writeInstanceGenerator (IID iidStrT) assembly = do+  env@(CGEnv bindings _) <- ask+  iid <- either (throwM . CGError) (return . IID) (substE bindings iidStrT)+  let IID iidStr = iid+  env' <- addBindings [(instanceIdKey, iidStr)] env+  tell [IG iid env' assembly]++-- | Monad for creating Instance generators.+newtype CGParser a = CGParser+  { runCGParser :: WriterT [InstanceGenerator CGEnv] (ReaderT CGEnv (Either SomeException)) a+  } deriving (MonadThrow, Functor, Applicative, Monad, MonadReader CGEnv, MonadWriter [InstanceGenerator CGEnv])++data CGEnv = CGEnv+  { agEnv     :: Environment+  , agSources :: [ArtifactSource]+  } deriving (Show, Eq)++data InstanceGenerator e =+  IG InstanceId+     e+     ArtifactAssembly+  deriving (Read, Show, Typeable, Data, Eq)++newtype CGError =+  CGError String+  deriving (Read, Show, Typeable, Data, Eq)++instance Exception CGError++cgError :: String -> CGParser a+cgError msg = throwM (CGError msg)++execCGParser :: CGParser () -> CGEnv -> Either SomeException [InstanceGenerator CGEnv]+execCGParser = runReaderT . execWriterT . runCGParser++execIGEnv :: InstanceGenerator CGEnv -> Either String (InstanceGenerator [SourceGenerator])+execIGEnv (IG iid (CGEnv env sources) assembly) = IG iid <$> sourceGens <*> pure (substAssembly env assembly)+  where+    sourceGens = join <$> mapM (toSourceGen env) sources++substAssembly :: Environment -> ArtifactAssembly -> ArtifactAssembly+substAssembly env = everywhere gsubst+  where+    gsubst :: Data a => a -> a+    gsubst = mkT substAssembly_ `extT` substImageTarget env `extT` substVmScript env+    substAssembly_ (CloudInit ts f) = CloudInit ts (sub f)+    substAssembly_ vm               = vm+    sub = subst env++toSourceGen :: Environment -> ArtifactSource -> Either String [SourceGenerator]+toSourceGen env src =+  case src of+    FromFile t (Source conv f) -> do+      t' <- substE env t+      f' <- substE env f+      return [SG env (SGFiles [Source conv f']) KeepPerm t']+    FromContent t c -> do+      t' <- substE env t+      return [SG env (SGContent c) KeepPerm t']+    SetPermissions o g a src' -> do+      sgs <- join <$> mapM (toSourceGen env) src'+      mapM (setSGPerm o g a) sgs+    FromDirectory fromDir src' -> do+      sgs <- join <$> mapM (toSourceGen env) src'+      fromDir' <- substE env fromDir+      return (setSGFromDirectory fromDir' <$> sgs)+    IntoDirectory toDir src' -> do+      sgs <- join <$> mapM (toSourceGen env) src'+      toDir' <- substE env toDir+      return (setSGToDirectory toDir' <$> sgs)++createAssembledArtifacts :: [InstanceGenerator [SourceGenerator]] -> B9 [AssembledArtifact]+createAssembledArtifacts igs = do+  buildDir <- getBuildDir+  let outDir = buildDir </> "artifact-instances"+  ensureDir (outDir ++ "/")+  generated <- generateSources outDir `mapM` igs+  createTargets `mapM` generated++generateSources :: FilePath -> InstanceGenerator [SourceGenerator] -> B9 (InstanceGenerator FilePath)+generateSources outDir (IG iid sgs assembly) = do+  uiid@(IID uiidStr) <- generateUniqueIID iid+  dbgL (printf "generating sources for %s" uiidStr)+  let instanceDir = outDir </> uiidStr+  traceL (printf "generating sources for %s:\n%s\n" uiidStr (ppShow sgs))+  generateSourceTo instanceDir `mapM_` sgs+  return (IG uiid instanceDir assembly)++createTargets :: InstanceGenerator FilePath -> B9 AssembledArtifact+createTargets (IG uiid@(IID uiidStr) instanceDir assembly) = do+  targets <- createTarget uiid instanceDir assembly+  dbgL (printf "assembled artifact %s" uiidStr)+  return (AssembledArtifact uiid targets)++generateUniqueIID :: InstanceId -> B9 InstanceId+generateUniqueIID (IID iid) = IID . printf "%s-%s" iid <$> getBuildId++generateSourceTo :: FilePath -> SourceGenerator -> B9 ()+generateSourceTo instanceDir (SG env sgSource p to) = do+  let toAbs = instanceDir </> to+  ensureDir toAbs+  result <-+    case sgSource of+      SGFiles froms -> do+        sources <- mapM (sgReadSourceFile env) froms+        return (mconcat sources)+      SGContent c -> renderContentGenerator env (toContentGenerator c)+  traceL (printf "rendered: \n%s\n" (LazyT.unpack (LazyE.decodeUtf8 result)))+  liftIO (Lazy.writeFile toAbs result)+  sgChangePerm toAbs p++sgReadSourceFile :: Environment -> SourceFile -> B9 Lazy.ByteString+sgReadSourceFile env = renderContentGenerator env . readTemplateFile++sgChangePerm :: FilePath -> SGPerm -> B9 ()+sgChangePerm _ KeepPerm = return ()+sgChangePerm f (SGSetPerm (o, g, a)) = cmd (printf "chmod 0%i%i%i '%s'" o g a f)++-- | Internal data type simplifying the rather complex source generation by+--   bioling down 'ArtifactSource's to a flat list of uniform 'SourceGenerator's.+data SourceGenerator =+  SG Environment+     SGSource+     SGPerm+     FilePath+  deriving (Show, Eq)++-- | Return the (internal-)output file of the source file that is generated.+sourceGeneratorOutputFile :: SourceGenerator -> FilePath+sourceGeneratorOutputFile (SG _ _ _ f) = f++data SGSource+  = SGFiles [SourceFile]+  | SGContent Content+  deriving (Read, Show, Eq)++data SGPerm+  = SGSetPerm (Int, Int, Int)+  | KeepPerm+  deriving (Read, Show, Typeable, Data, Eq)++sgGetFroms :: SourceGenerator -> [SourceFile]+sgGetFroms (SG _ (SGFiles fs) _ _) = fs+sgGetFroms _                       = []++setSGPerm :: Int -> Int -> Int -> SourceGenerator -> Either String SourceGenerator+setSGPerm o g a (SG env from KeepPerm dest) = Right (SG env from (SGSetPerm (o, g, a)) dest)+setSGPerm o g a sg+  | o < 0 || o > 7 = Left (printf "Bad 'owner' permission %i in \n%s" o (ppShow sg))+  | g < 0 || g > 7 = Left (printf "Bad 'group' permission %i in \n%s" g (ppShow sg))+  | a < 0 || a > 7 = Left (printf "Bad 'all' permission %i in \n%s" a (ppShow sg))+  | otherwise = Left (printf "Permission for source already defined:\n %s" (ppShow sg))++setSGFromDirectory :: FilePath -> SourceGenerator -> SourceGenerator+setSGFromDirectory fromDir (SG e (SGFiles fs) p d) = SG e (SGFiles (setSGFrom <$> fs)) p d+  where+    setSGFrom (Source t f) = Source t (fromDir </> f)+setSGFromDirectory _fromDir sg = sg++setSGToDirectory :: FilePath -> SourceGenerator -> SourceGenerator+setSGToDirectory toDir (SG e fs p d) = SG e fs p (toDir </> d)++-- | Create the actual target, either just a mountpoint, or an ISO or VFAT+-- image.+createTarget :: InstanceId -> FilePath -> ArtifactAssembly -> B9 [ArtifactTarget]+createTarget iid instanceDir (VmImages imageTargets vmScript) = do+  dbgL (printf "Creating VM-Images in '%s'" instanceDir)+  success <- buildWithVm iid imageTargets instanceDir vmScript+  let err_msg = printf "Error creating 'VmImages' for instance '%s'" iidStr+      (IID iidStr) = iid+  unless success (errorL err_msg >> error err_msg)+  return [VmImagesTarget]+createTarget _ instanceDir (CloudInit types outPath) = mapM create_ types+  where+    create_ CI_DIR = do+      let ciDir = outPath+      ensureDir (ciDir ++ "/")+      dbgL (printf "creating directory '%s'" ciDir)+      files <- getDirectoryFiles instanceDir+      traceL (printf "copying files: %s" (show files))+      liftIO+        (mapM_+           (\(f, t) -> do+              ensureDir t+              copyFile f t)+           (((instanceDir </>) &&& (ciDir </>)) <$> files))+      infoL (printf "CREATED CI_DIR: '%s'" (takeFileName ciDir))+      return (CloudInitTarget CI_DIR ciDir)+    create_ CI_ISO = do+      buildDir <- getBuildDir+      let isoFile = outPath <.> "iso"+          tmpFile = buildDir </> takeFileName isoFile+      ensureDir tmpFile+      dbgL (printf "creating cloud init iso temp image '%s', destination file: '%s" tmpFile isoFile)+      cmd (printf "genisoimage -output '%s' -volid cidata -rock -d '%s' 2>&1" tmpFile instanceDir)+      dbgL (printf "moving iso image '%s' to '%s'" tmpFile isoFile)+      ensureDir isoFile+      liftIO (copyFile tmpFile isoFile)+      infoL (printf "CREATED CI_ISO IMAGE: '%s'" (takeFileName isoFile))+      return (CloudInitTarget CI_ISO isoFile)+    create_ CI_VFAT = do+      buildDir <- getBuildDir+      let vfatFile = outPath <.> "vfat"+          tmpFile = buildDir </> takeFileName vfatFile+      ensureDir tmpFile+      files <- map (instanceDir </>) <$> getDirectoryFiles instanceDir+      dbgL (printf "creating cloud init vfat image '%s'" tmpFile)+      traceL (printf "adding '%s'" (show files))+      cmd (printf "truncate --size 2M '%s'" tmpFile)+      cmd (printf "mkfs.vfat -n cidata '%s' 2>&1" tmpFile)+      cmd (unwords (printf "mcopy -oi '%s' " tmpFile : (printf "'%s'" <$> files)) ++ " ::")+      dbgL (printf "moving vfat image '%s' to '%s'" tmpFile vfatFile)+      ensureDir vfatFile+      liftIO (copyFile tmpFile vfatFile)+      infoL (printf "CREATED CI_VFAT IMAGE: '%s'" (takeFileName vfatFile))+      return (CloudInitTarget CI_ISO vfatFile)
+ src/lib/B9/Artifact/Readable/Source.hs view
@@ -0,0 +1,71 @@+-- | Source files for 'B9.Artifact.Generator's.+--+-- @since 0.5.62+module B9.Artifact.Readable.Source+  ( ArtifactSource(..)+  , getArtifactSourceFiles+  ) where++import           Control.Eff+import           Control.Eff.Extend+import           Control.Eff.Writer.Lazy+import           Control.Parallel.Strategies+import           Data.Data+import           Data.Tagged+import           GHC.Generics                       (Generic)+import           System.FilePath                    ((</>))+import           Text.Read++import           B9.Artifact.Content+import           B9.Artifact.Content.Readable+import           B9.Artifact.Content.StringTemplate+import           B9.QCUtil++import           Test.QuickCheck++-- | Describe how input files for artifacts to build are obtained.  The general+--   structure of each constructor is __FromXXX__ /destination/ /source/+data ArtifactSource+  = FromFile FilePath+             SourceFile+      -- ^ Copy a 'B9.Artifact.Content.StringTemplate.SourceFile'+      -- potentially replacing variable defined in 'Let'-like+      -- parent elements.+  | FromContent FilePath+                Content+      -- ^ Create a file from some 'Content'+  | SetPermissions Int+                   Int+                   Int+                   [ArtifactSource]+      -- ^ Set the unix /file permissions/ to all files generated+      -- by the nested list of 'ArtifactSource's.+  | FromDirectory FilePath+                  [ArtifactSource]+      -- ^ Assume a local directory as starting point for all+      -- relative source files in the nested 'ArtifactSource's.+  | IntoDirectory FilePath+                  [ArtifactSource]+      -- ^ Specify an output directory for all the files+      -- generated by the nested 'ArtifactSource's+  deriving (Read, Show, Eq, Data, Typeable, Generic)++instance NFData ArtifactSource++-- | Return all source files generated by an 'ArtifactSource'.+getArtifactSourceFiles :: ArtifactSource -> [FilePath]+getArtifactSourceFiles (FromContent f _) = [f]+getArtifactSourceFiles (FromFile f _) = [f]+getArtifactSourceFiles (IntoDirectory pd as) = (pd </>) <$> (as >>= getArtifactSourceFiles)+getArtifactSourceFiles (FromDirectory _ as) = as >>= getArtifactSourceFiles+getArtifactSourceFiles (SetPermissions _ _ _ as) = as >>= getArtifactSourceFiles++instance Arbitrary ArtifactSource where+  arbitrary =+    oneof+      [ FromFile <$> smaller arbitraryFilePath <*> smaller arbitrary+      , FromContent <$> smaller arbitraryFilePath <*> smaller arbitrary+      , SetPermissions <$> choose (0, 7) <*> choose (0, 7) <*> choose (0, 7) <*> smaller arbitrary+      , FromDirectory <$> smaller arbitraryFilePath <*> smaller arbitrary+      , IntoDirectory <$> smaller arbitraryFilePath <*> smaller arbitrary+      ]
− src/lib/B9/ArtifactGenerator.hs 
@@ -1,338 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-|-Top-Level data types for B9 build artifacts.--}-module B9.ArtifactGenerator-       (ArtifactGenerator(..), ArtifactSource(..), InstanceId(..),-        ArtifactTarget(..), CloudInitType(..), ArtifactAssembly(..),-        AssembledArtifact(..), AssemblyOutput(..), instanceIdKey, buildIdKey, buildDateKey,-        getAssemblyOutput, getArtifactSourceFiles)-       where--import Control.Parallel.Strategies-import Data.Binary-import Data.Data-import Data.Hashable-import GHC.Generics (Generic)-import Data.Semigroup as Sem-import System.FilePath ((<.>), (</>))--import B9.DiskImages-import B9.Vm-import B9.Content.StringTemplate-import B9.Content.Generator-import B9.QCUtil--import Test.QuickCheck--{-| Artifacts represent the things B9 can build. A generator specifies howto-generate parameterized, multiple artifacts. The general structure is:--@-   Let [ ... bindings ... ]-       [ Sources-           [ ... list all input files ... ]-           [ Artifact ...-           , Artifact ...-           , Let [ ... ] [ ... ]-           ]-       ]-@--The reasons why 'Sources' takes a list of 'ArtifactGenerator's is that--   1. this makes the value easier to read/write for humans--   2. the sources are static files used in all children (e.g. company logo image)--   3. the sources are parameterized by variables that bound to different values-      for each artifact, e.g. a template network config file which contains-      the host IP address.--To bind such variables use 'Let', 'Each', 'LetX' or 'EachT'.--String subtitution of these variables is done by "B9.Content.StringTemplate".-These variables can be used as value in nested 'Let's, in most file names/paths-and in source files added with 'B9.Content.StringTemplate.SourceFile'---}-data ArtifactGenerator-    = Sources [ArtifactSource]-              [ArtifactGenerator]-    |-      -- ^ Add sources available to 'ArtifactAssembly's in-      -- nested artifact generators.-      Let [(String, String)]-          [ArtifactGenerator]-    |-      -- ^ Bind variables, variables are avaible in nested-      -- generators.-      LetX [(String, [String])]-           [ArtifactGenerator]-    |-      -- ^ A 'Let' where each variable is assigned to each-      -- value; the nested generator is executed for each-      -- permutation.-      ---      -- @-      --     LetX [("x", ["1","2","3"]), ("y", ["a","b"])] [..]-      -- @-      -- Is equal to:-      ---      -- @-      --     Let [] [-      --       Let [("x", "1"), ("y", "a")] [..]-      --       Let [("x", "1"), ("y", "b")] [..]-      --       Let [("x", "2"), ("y", "a")] [..]-      --       Let [("x", "2"), ("y", "b")] [..]-      --       Let [("x", "3"), ("y", "a")] [..]-      --       Let [("x", "3"), ("y", "b")] [..]-      --     ]-      -- @-      Each [(String, [String])]-           [ArtifactGenerator]-    |-      -- ^ Bind each variable to their first value, then each-      -- variable to the second value, etc ... and execute the-      -- nested generator in every step. 'LetX' represents a-      -- product of all variables, whereas 'Each' represents a-      -- sum of variable bindings - 'Each' is more like a /zip/-      -- whereas 'LetX' is more like a list comprehension.-      EachT [String]-            [[String]]-            [ArtifactGenerator]-    |-      -- ^ The transposed verison of 'Each': Bind the variables-      -- in the first list to each a set of values from the-      -- second argument; execute the nested generators for-      -- each binding-      Artifact InstanceId-               ArtifactAssembly-    |-      -- ^ Generate an artifact defined by an-      -- 'ArtifactAssembly'; the assembly can access the files-      -- created from the 'Sources' and variables bound by-      -- 'Let'ish elements. An artifact has an instance id,-      -- that is a unique, human readable string describing the-      -- artifact to assemble.-      EmptyArtifact-    deriving (Read,Show,Eq,Data,Typeable,Generic)--instance Hashable ArtifactGenerator-instance Binary ArtifactGenerator-instance NFData ArtifactGenerator--instance Sem.Semigroup ArtifactGenerator where-    (Let [] []) <> x = x-    x <> (Let [] []) = x-    x <> y = Let [] [x, y]--instance Monoid ArtifactGenerator where-    mempty = Let [] []-    mappend = (Sem.<>)---- | Describe how input files for artifacts to build are obtained.  The general---   structure of each constructor is __FromXXX__ /destination/ /source/-data ArtifactSource-    = FromFile FilePath-               SourceFile-    |-      -- ^ Copy a 'B9.Content.StringTemplate.SourceFile'-      -- potentially replacing variabled defined in 'Let'-like-      -- parent elements.-      FromContent FilePath-                  Content-    |-      -- ^ Create a file from some 'Content'-      SetPermissions Int-                     Int-                     Int-                     [ArtifactSource]-    |-      -- ^ Set the unix /file permissions/ to all files generated-      -- by the nested list of 'ArtifactSource's.-      FromDirectory FilePath-                    [ArtifactSource]-    |-      -- ^ Assume a local directory as starting point for all-      -- relative source files in the nested 'ArtifactSource's.-      IntoDirectory FilePath-                    [ArtifactSource]-    |-      -- ^ Specify an output directory for all the files-      -- generated by the nested 'ArtifactSource's-      Concatenation FilePath-                    [ArtifactSource]-    -- ^ __Deprecated__ Concatenate the files generated by the-    -- nested 'ArtifactSource's. The nested, generated files-    -- are not written when they are concatenated.-    deriving (Read,Show,Eq,Data,Typeable,Generic)--instance Hashable ArtifactSource-instance Binary ArtifactSource-instance NFData ArtifactSource---- | Return all source files generated by an 'ArtifactSource'.-getArtifactSourceFiles :: ArtifactSource -> [FilePath]-getArtifactSourceFiles (Concatenation f _) = [f]-getArtifactSourceFiles (FromContent   f _) = [f]-getArtifactSourceFiles (FromFile      f _) = [f]-getArtifactSourceFiles (IntoDirectory pd as) =-    (pd</>) <$> (as >>= getArtifactSourceFiles)-getArtifactSourceFiles (FromDirectory _ as) = as >>= getArtifactSourceFiles-getArtifactSourceFiles (SetPermissions _ _ _ as) =-    as >>= getArtifactSourceFiles------ | Identify an artifact. __Deprecated__ TODO: B9 does not check if all--- instances IDs are unique.-newtype InstanceId =-    IID String-    deriving (Read,Show,Typeable,Data,Eq,NFData,Binary,Hashable)---- | The variable containing the instance id. __Deprecated__-instanceIdKey :: String-instanceIdKey = "instance_id"---- | The variable containing the buildId that identifies each execution of--- B9. For more info about variable substitution in source files see--- 'B9.Content.StringTemplate'-buildIdKey :: String-buildIdKey = "build_id"---- | The variable containing the date and time a build was started. For more--- info about variable substitution in source files see--- 'B9.Content.StringTemplate'-buildDateKey :: String-buildDateKey = "build_date"---- | Define an __output__ of a build. Assemblies are nested into--- 'ArtifactGenerator's. They contain all the files defined by the 'Sources'--- they are nested into.-data ArtifactAssembly-    = CloudInit [CloudInitType]-                FilePath-    |-      -- ^ Generate a __cloud-init__ compatible directory, ISO--      -- or VFAT image, as specified by the list of-      -- 'CloudInitType's. Every item will use the second-      -- argument to create an appropriate /file name/,-      -- e.g. for the 'CI_ISO' type the output is @second_param.iso@.-      VmImages [ImageTarget]-               VmScript-    -- ^ a set of VM-images that were created by executing a-    -- build script on them.-    deriving (Read,Show,Typeable,Data,Eq,Generic)--instance Hashable ArtifactAssembly-instance Binary ArtifactAssembly-instance NFData ArtifactAssembly---- | A type representing the targets assembled by--- 'B9.ArtifactGeneratorImpl.assemble' from an 'ArtifactAssembly'. There is a--- list of 'ArtifactTarget's because e.g. a single 'CloudInit' can produce upto--- three output files, a directory, an ISO image and a VFAT image.-data AssembledArtifact =-    AssembledArtifact InstanceId-                      [ArtifactTarget]-    deriving (Read,Show,Typeable,Data,Eq,Generic)--instance Hashable AssembledArtifact-instance Binary AssembledArtifact-instance NFData AssembledArtifact--data ArtifactTarget-    = CloudInitTarget CloudInitType-                      FilePath-    | VmImagesTarget-    deriving (Read,Show,Typeable,Data,Eq,Generic)--instance Hashable ArtifactTarget-instance Binary ArtifactTarget-instance NFData ArtifactTarget--data CloudInitType-    = CI_ISO-    | CI_VFAT-    | CI_DIR-    deriving (Read,Show,Typeable,Data,Eq,Generic)--instance Hashable CloudInitType-instance Binary CloudInitType-instance NFData CloudInitType---- | The output of an 'ArtifactAssembly' is either a set of generated files,---  or it might be a directory that contains the artifacts sources.-data AssemblyOutput =-    AssemblyGeneratesOutputFiles [FilePath]-   | AssemblyCopiesSourcesToDirectory FilePath-   deriving (Read,Show,Typeable,Data,Eq,Generic)---- | Return the files that the artifact assembly consist of.-getAssemblyOutput :: ArtifactAssembly -> [AssemblyOutput]-getAssemblyOutput (VmImages ts _) =-    AssemblyGeneratesOutputFiles . getImageDestinationOutputFiles <$> ts-getAssemblyOutput (CloudInit ts o) = getCloudInitOutputFiles o <$> ts- where-  getCloudInitOutputFiles baseName t = case t of-      CI_ISO  -> AssemblyGeneratesOutputFiles [baseName <.> "iso"]-      CI_VFAT -> AssemblyGeneratesOutputFiles [baseName <.> "vfat"]-      CI_DIR  -> AssemblyCopiesSourcesToDirectory baseName----- * QuickCheck instances--instance Arbitrary ArtifactGenerator where-    arbitrary =-        oneof-            [ Sources <$> halfSize arbitrary <*> halfSize arbitrary-            , Let <$> halfSize arbitraryEnv <*> halfSize arbitrary-            , halfSize arbitraryEachT <*> halfSize arbitrary-            , halfSize arbitraryEach <*> halfSize arbitrary-            , Artifact <$> smaller arbitrary <*> smaller arbitrary-            , pure EmptyArtifact]---arbitraryEachT :: Gen ([ArtifactGenerator] -> ArtifactGenerator)-arbitraryEachT =-    sized $-    \n ->-         EachT <$> vectorOf n (halfSize (listOf1 (choose ('a', 'z')))) <*>-         oneof-             [ listOf (vectorOf n (halfSize arbitrary))-             , listOf1 (listOf (halfSize arbitrary))]--arbitraryEach :: Gen ([ArtifactGenerator] -> ArtifactGenerator)-arbitraryEach =-    sized $-    \n ->-         Each <$>-         listOf-             ((,) <$> listOf1 (choose ('a', 'z')) <*>-              vectorOf n (halfSize (listOf1 (choose ('a', 'z')))))---instance Arbitrary ArtifactSource where-    arbitrary =-        oneof-            [ FromFile <$> smaller arbitraryFilePath <*> smaller arbitrary-            , FromContent <$> smaller arbitraryFilePath <*> smaller arbitrary-            , SetPermissions <$> choose (0, 7) <*> choose (0, 7) <*>-              choose (0, 7) <*>-              smaller arbitrary-            , FromDirectory <$> smaller arbitraryFilePath <*> smaller arbitrary-            , IntoDirectory <$> smaller arbitraryFilePath <*> smaller arbitrary]--instance Arbitrary InstanceId where-    arbitrary = IID <$> arbitraryFilePath--instance Arbitrary ArtifactAssembly where-    arbitrary =-        oneof-            [ CloudInit <$> arbitrary <*> arbitraryFilePath-            , VmImages <$> smaller arbitrary <*> pure NoVmScript]--instance Arbitrary CloudInitType where-    arbitrary = elements [CI_ISO, CI_VFAT, CI_DIR]
− src/lib/B9/ArtifactGeneratorImpl.hs 
@@ -1,409 +0,0 @@-{-|-Mostly effectful functions to assemble artifacts.--}-module B9.ArtifactGeneratorImpl where--import B9.ArtifactGenerator-import B9.B9Monad-import B9.B9Config-import B9.VmBuilder-import B9.Vm-import B9.DiskImageBuilder-import System.IO.B9Extras (ensureDir, getDirectoryFiles)-import B9.Content.StringTemplate-import B9.Content.Generator-import B9.Content.AST-import qualified Data.ByteString as B-import qualified Data.Text as T-import qualified Data.Text.Encoding as E-import Control.Lens (view)-import Data.Data-import Data.Generics.Schemes-import Data.Generics.Aliases-import Data.List-import Data.Function-import Control.Arrow-import Control.Monad.IO.Class-import Control.Monad.Reader-import Control.Monad.Writer-import Control.Monad.Except-import System.FilePath-import System.Directory-import Text.Printf-import Text.Show.Pretty (ppShow)---- | Execute an 'ArtifactGenerator' and return a 'B9Invokation' that returns--- the build id obtained by 'getBuildId'.-buildArtifacts :: ArtifactGenerator -> B9 String-buildArtifacts artifactGenerator = do-  traceL . ("CWD: " ++) =<< liftIO getCurrentDirectory-  infoL "BUILDING ARTIFACTS"-  getConfig >>= traceL . printf "USING BUILD CONFIGURATION: %v" . ppShow-  assemble artifactGenerator-  getBuildId---- | Return a list of relative paths for the /local/ files to be generated--- by the ArtifactGenerator. This excludes 'Shared' and Transient image targets.-getArtifactOutputFiles :: ArtifactGenerator -> Either String [FilePath]-getArtifactOutputFiles g =-  concatMap getOutputs <$> evalArtifactGenerator undefined undefined [] g- where-  getOutputs (IG _ sgs a) =-    let toOutFile (AssemblyGeneratesOutputFiles fs) = fs-        toOutFile (AssemblyCopiesSourcesToDirectory pd) =-          let sourceFiles = sourceGeneratorOutputFile <$> sgs-          in  (pd </>) <$> sourceFiles-    in  getAssemblyOutput a >>= toOutFile---- | Run an artifact generator to produce the artifacts.-assemble :: ArtifactGenerator -> B9 [AssembledArtifact]-assemble artGen = do-  b9cfgEnvVars <- view envVars <$> getConfig-  buildId      <- getBuildId-  buildDate    <- getBuildDate-  case evalArtifactGenerator buildId buildDate b9cfgEnvVars artGen of-    Left  err -> error err-    Right is  -> createAssembledArtifacts is---- | Evaluate an 'ArtifactGenerator' into a list of low-level build instructions--- that can be built with 'createAssembledArtifacts'.-evalArtifactGenerator-  :: String-  -> String-  -> BuildVariables-  -> ArtifactGenerator-  -> Either String [InstanceGenerator [SourceGenerator]]-evalArtifactGenerator buildId buildDate b9cfgEnvVars artGen =-  let-    ag = parseArtifactGenerator artGen-    e  = CGEnv-      ((buildDateKey, buildDate) : (buildIdKey, buildId) : b9cfgEnvVars)-      []-  in-    case execCGParser ag e of-      Left (CGError err) ->-        Left (printf "error parsing: %s: %s" (ppShow artGen) err)-      Right igs -> case execIGEnv `mapM` igs of-        Left err ->-          Left (printf "Failed to parse:\n%s\nError: %s" (ppShow artGen) err)-        Right is -> Right is---- | Parse an artifacto generator inside a 'CGParser' monad.-parseArtifactGenerator :: ArtifactGenerator -> CGParser ()-parseArtifactGenerator g = case g of-  Sources srcs gs -> withArtifactSources srcs (mapM_ parseArtifactGenerator gs)-  Let bs gs -> withBindings bs (mapM_ parseArtifactGenerator gs)-  LetX bs gs -> withXBindings bs (mapM_ parseArtifactGenerator gs)-  EachT keySet valueSets gs -> do-    allBindings <- eachBindingSetT g keySet valueSets-    sequence_-      (flip withBindings (mapM_ parseArtifactGenerator gs) <$> allBindings)-  Each kvs gs -> do-    allBindings <- eachBindingSet g kvs-    sequence_ $ do-      b <- allBindings-      return (withBindings b (mapM_ parseArtifactGenerator gs))-  Artifact iid assembly -> writeInstanceGenerator iid assembly-  EmptyArtifact         -> return ()---- | Execute a 'CGParser' action in an environment that contains a list of--- 'ArtifactSource's.-withArtifactSources :: [ArtifactSource] -> CGParser () -> CGParser ()-withArtifactSources srcs =-  local (\ce -> ce { agSources = agSources ce ++ srcs })--withBindings :: [(String, String)] -> CGParser () -> CGParser ()-withBindings bs = local (addBindings bs)--addBindings :: [(String, String)] -> CGEnv -> CGEnv-addBindings bs ce =-  let addBinding env (k, v) = nubBy ((==) `on` fst) ((k, subst env v) : env)-      newEnv = foldl addBinding (agEnv ce) bs-  in  ce { agEnv = newEnv }--withXBindings :: [(String, [String])] -> CGParser () -> CGParser ()-withXBindings bs cp = (`local` cp) `mapM_` (addBindings <$> allXBindings bs)- where-  allXBindings ((k, vs):rest) =-    [ (k, v) : c | v <- vs, c <- allXBindings rest ]-  allXBindings [] = [[]]--eachBindingSetT-  :: ArtifactGenerator-  -> [String]-  -> [[String]]-  -> CGParser [[(String, String)]]-eachBindingSetT g vars valueSets = if all ((== length vars) . length) valueSets-  then return (zip vars <$> valueSets)-  else cgError-    ( printf-      "Error in 'Each' binding during artifact generation in:\n '%s'.\n\nThe variable list\n%s\n has %i entries, but this binding set\n%s\n\nhas a different number of entries!\n"-      (ppShow g)-      (ppShow vars)-      (length vars)-      (ppShow (head (dropWhile ((== length vars) . length) valueSets)))-    )--eachBindingSet-  :: ArtifactGenerator -> [(String, [String])] -> CGParser [[(String, String)]]-eachBindingSet g kvs = do-  checkInput-  return bindingSets- where-  bindingSets = transpose [ repeat k `zip` vs | (k, vs) <- kvs ]-  checkInput  = when-    (1 /= length (nub $ length . snd <$> kvs))-    ( cgError-      ( printf-        "Error in 'Each' binding: \n%s\nAll value lists must have the same length!"-        (ppShow g)-      )-    )---writeInstanceGenerator :: InstanceId -> ArtifactAssembly -> CGParser ()-writeInstanceGenerator (IID iidStrT) assembly = do-  env@(CGEnv bindings _) <- ask-  iid <- either (throwError . CGError) (return . IID) (substE bindings iidStrT)-  let env'       = addBindings [(instanceIdKey, iidStr)] env-      IID iidStr = iid-  tell [IG iid env' assembly]---- | Monad for creating Instance generators.-newtype CGParser a =-          CGParser-            { runCGParser :: WriterT [InstanceGenerator CGEnv] (ReaderT CGEnv (Either CGError)) a }-  deriving (Functor, Applicative, Monad, MonadReader CGEnv, MonadWriter [InstanceGenerator CGEnv], MonadError CGError)--data CGEnv = CGEnv { agEnv :: [(String, String)], agSources :: [ArtifactSource] }-  deriving (Read, Show, Eq)--data InstanceGenerator e = IG InstanceId e ArtifactAssembly-  deriving (Read, Show, Typeable, Data, Eq)--newtype CGError = CGError String-  deriving (Read, Show, Typeable, Data, Eq)--cgError :: String -> CGParser a-cgError msg = throwError (CGError msg)--execCGParser :: CGParser () -> CGEnv -> Either CGError [InstanceGenerator CGEnv]-execCGParser = runReaderT . execWriterT . runCGParser--execIGEnv-  :: InstanceGenerator CGEnv-  -> Either String (InstanceGenerator [SourceGenerator])-execIGEnv (IG iid (CGEnv env sources) assembly) =-  IG iid <$> sourceGens <*> pure (substAssembly env assembly)-  where sourceGens = join <$> mapM (toSourceGen env) sources--substAssembly :: [(String, String)] -> ArtifactAssembly -> ArtifactAssembly-substAssembly env = everywhere gsubst- where-  gsubst :: Data a => a -> a-  gsubst =-    mkT substAssembly_ `extT` substImageTarget env `extT` substVmScript env--  substAssembly_ (CloudInit ts f) = CloudInit ts (sub f)-  substAssembly_ vm               = vm--  sub = subst env--toSourceGen-  :: [(String, String)] -> ArtifactSource -> Either String [SourceGenerator]-toSourceGen env src = case src of-  FromFile t (Source conv f) -> do-    t' <- substE env t-    f' <- substE env f-    return [SG env (SGFiles [Source conv f']) KeepPerm t']-  FromContent t c -> do-    t' <- substE env t-    return [SG env (SGContent c) KeepPerm t']-  Concatenation t src' -> do-    sgs <- join <$> mapM (toSourceGen env) src'-    t'  <- substE env t-    let froms = join (sgGetFroms <$> sgs)-    return [SG env (SGFiles froms) KeepPerm t']-  SetPermissions o g a src' -> do-    sgs <- join <$> mapM (toSourceGen env) src'-    mapM (setSGPerm o g a) sgs-  FromDirectory fromDir src' -> do-    sgs      <- join <$> mapM (toSourceGen env) src'-    fromDir' <- substE env fromDir-    return (setSGFromDirectory fromDir' <$> sgs)-  IntoDirectory toDir src' -> do-    sgs    <- join <$> mapM (toSourceGen env) src'-    toDir' <- substE env toDir-    return (setSGToDirectory toDir' <$> sgs)--createAssembledArtifacts-  :: [InstanceGenerator [SourceGenerator]] -> B9 [AssembledArtifact]-createAssembledArtifacts igs = do-  buildDir <- getBuildDir-  let outDir = buildDir </> "artifact-instances"-  ensureDir (outDir ++ "/")-  generated <- generateSources outDir `mapM` igs-  createTargets `mapM` generated--generateSources-  :: FilePath-  -> InstanceGenerator [SourceGenerator]-  -> B9 (InstanceGenerator FilePath)-generateSources outDir (IG iid sgs assembly) = do-  uiid@(IID uiidStr) <- generateUniqueIID iid-  dbgL (printf "generating sources for %s" uiidStr)-  let instanceDir = outDir </> uiidStr-  traceL (printf "generating sources for %s:\n%s\n" uiidStr (ppShow sgs))-  generateSourceTo instanceDir `mapM_` sgs-  return (IG uiid instanceDir assembly)--createTargets :: InstanceGenerator FilePath -> B9 AssembledArtifact-createTargets (IG uiid@(IID uiidStr) instanceDir assembly) = do-  targets <- createTarget uiid instanceDir assembly-  dbgL (printf "assembled artifact %s" uiidStr)-  return (AssembledArtifact uiid targets)--generateUniqueIID :: InstanceId -> B9 InstanceId-generateUniqueIID (IID iid) = do-  buildId <- getBuildId-  return (IID (printf "%s-%s" iid buildId))--generateSourceTo :: FilePath -> SourceGenerator -> B9 ()-generateSourceTo instanceDir (SG env sgSource p to) = do-  let toAbs = instanceDir </> to-  ensureDir toAbs-  result <- case sgSource of-    SGFiles froms -> do-      sources <- mapM (sgReadSourceFile env) froms-      return (mconcat sources)-    SGContent c -> withEnvironment env (render c)-  traceL (printf "rendered: \n%s\n" (T.unpack (E.decodeUtf8 result)))-  liftIO (B.writeFile toAbs result)-  sgChangePerm toAbs p--sgReadSourceFile :: [(String, String)] -> SourceFile -> B9 B.ByteString-sgReadSourceFile env = withEnvironment env . readTemplateFile--sgChangePerm :: FilePath -> SGPerm -> B9 ()-sgChangePerm _ KeepPerm = return ()-sgChangePerm f (SGSetPerm (o, g, a)) =-  cmd (printf "chmod 0%i%i%i '%s'" o g a f)---- | Internal data type simplifying the rather complex source generation by---   bioling down 'ArtifactSource's to a flat list of uniform 'SourceGenerator's.-data SourceGenerator = SG [(String, String)] SGSource SGPerm FilePath-  deriving (Read, Show, Eq)---- | Return the (internal-)output file of the source file that is generated.-sourceGeneratorOutputFile :: SourceGenerator -> FilePath-sourceGeneratorOutputFile (SG _ _ _ f) = f--data SGSource = SGFiles [SourceFile]-              | SGContent Content-  deriving (Read, Show, Eq)--data SGPerm = SGSetPerm (Int, Int, Int)-            | KeepPerm-  deriving (Read, Show, Typeable, Data, Eq)--sgGetFroms :: SourceGenerator -> [SourceFile]-sgGetFroms (SG _ (SGFiles fs) _ _) = fs-sgGetFroms _                       = []--setSGPerm-  :: Int -> Int -> Int -> SourceGenerator -> Either String SourceGenerator-setSGPerm o g a (SG env from KeepPerm dest) =-  Right (SG env from (SGSetPerm (o, g, a)) dest)-setSGPerm o g a sg-  | o < 0 || o > 7 = Left-    (printf "Bad 'owner' permission %i in \n%s" o (ppShow sg))-  | g < 0 || g > 7 = Left-    (printf "Bad 'group' permission %i in \n%s" g (ppShow sg))-  | a < 0 || a > 7 = Left-    (printf "Bad 'all' permission %i in \n%s" a (ppShow sg))-  | otherwise = Left-    (printf "Permission for source already defined:\n %s" (ppShow sg))--setSGFromDirectory :: FilePath -> SourceGenerator -> SourceGenerator-setSGFromDirectory fromDir (SG e (SGFiles fs) p d) = SG-  e-  (SGFiles (setSGFrom <$> fs))-  p-  d-  where setSGFrom (Source t f) = Source t (fromDir </> f)-setSGFromDirectory _fromDir sg = sg--setSGToDirectory :: FilePath -> SourceGenerator -> SourceGenerator-setSGToDirectory toDir (SG e fs p d) = SG e fs p (toDir </> d)---- | Create the actual target, either just a mountpoint, or an ISO or VFAT--- image.-createTarget-  :: InstanceId -> FilePath -> ArtifactAssembly -> B9 [ArtifactTarget]-createTarget iid instanceDir (VmImages imageTargets vmScript) = do-  dbgL (printf "Creating VM-Images in '%s'" instanceDir)-  success <- buildWithVm iid imageTargets instanceDir vmScript-  let err_msg      = printf "Error creating 'VmImages' for instance '%s'" iidStr-      (IID iidStr) = iid-  unless success (errorL err_msg >> error err_msg)-  return [VmImagesTarget]-createTarget _ instanceDir (CloudInit types outPath) = mapM create_ types- where-  create_ CI_DIR = do-    let ciDir = outPath-    ensureDir (ciDir ++ "/")-    dbgL (printf "creating directory '%s'" ciDir)-    files <- getDirectoryFiles instanceDir-    traceL (printf "copying files: %s" (show files))-    liftIO-      ( mapM_-        ( \(f, t) -> do-          ensureDir t-          copyFile f t-        )-        (((instanceDir </>) &&& (ciDir </>)) <$> files)-      )-    infoL (printf "CREATED CI_DIR: '%s'" (takeFileName ciDir))-    return (CloudInitTarget CI_DIR ciDir)--  create_ CI_ISO = do-    buildDir <- getBuildDir-    let isoFile = outPath <.> "iso"-        tmpFile = buildDir </> takeFileName isoFile-    ensureDir tmpFile-    dbgL-      ( printf-        "creating cloud init iso temp image '%s', destination file: '%s"-        tmpFile-        isoFile-      )-    cmd-      ( printf "genisoimage -output '%s' -volid cidata -rock -d '%s' 2>&1"-               tmpFile-               instanceDir-      )-    dbgL (printf "moving iso image '%s' to '%s'" tmpFile isoFile)-    ensureDir isoFile-    liftIO (copyFile tmpFile isoFile)-    infoL (printf "CREATED CI_ISO IMAGE: '%s'" (takeFileName isoFile))-    return (CloudInitTarget CI_ISO isoFile)--  create_ CI_VFAT = do-    buildDir <- getBuildDir-    let vfatFile = outPath <.> "vfat"-        tmpFile  = buildDir </> takeFileName vfatFile-    ensureDir tmpFile-    files <- map (instanceDir </>) <$> getDirectoryFiles instanceDir-    dbgL (printf "creating cloud init vfat image '%s'" tmpFile)-    traceL (printf "adding '%s'" (show files))-    cmd (printf "truncate --size 2M '%s'" tmpFile)-    cmd (printf "mkfs.vfat -n cidata '%s' 2>&1" tmpFile)-    cmd-      (  unwords (printf "mcopy -oi '%s' " tmpFile : (printf "'%s'" <$> files))-      ++ " ::"-      )-    dbgL (printf "moving vfat image '%s' to '%s'" tmpFile vfatFile)-    ensureDir vfatFile-    liftIO (copyFile tmpFile vfatFile)-    infoL (printf "CREATED CI_VFAT IMAGE: '%s'" (takeFileName vfatFile))-    return (CloudInitTarget CI_ISO vfatFile)
src/lib/B9/B9Config.hs view
@@ -46,121 +46,102 @@   , b9ConfigToCPDocument   , LogLevel(..)   , ExecEnvType(..)-  , BuildVariables+  , Environment   , module X-  )-where+  ) where -import           Data.Maybe                     ( fromMaybe )-import           Control.Exception-import           Data.Function                  ( on )-import           Control.Lens                  as Lens-                                                ( makeLenses-                                                , (^.)-                                                , (?~)-                                                , (.~)-                                                , (&)-                                                , over-                                                , set-                                                , _Just-                                                )-import           Control.Monad                  ( (>=>) )-import           Control.Monad.IO.Class-import           Control.Monad.Reader-import           Control.Monad.Writer-import           System.Directory-import           System.IO.B9Extras             ( SystemPath(..)-                                                , resolve-                                                , ensureDir-                                                )-import qualified Data.Semigroup                as Sem-import           Data.List                      ( partition-                                                , sortBy-                                                )-import           Data.ConfigFile.B9Extras       ( CPDocument-                                                , CPError-                                                , CPGet-                                                , CPOptionSpec-                                                , readCPDocument-                                                , CPReadException(..)-                                                , mergeCP-                                                , toStringCP-                                                , addSectionCP-                                                , emptyCP-                                                , setShowCP-                                                , readCP-                                                )-import           B9.B9Config.LibVirtLXC        as X-import           B9.B9Config.Repository        as X-import           Text.Printf                    ( printf )+import B9.B9Config.LibVirtLXC as X+import B9.B9Config.Repository as X+import Control.Exception+import Control.Lens as Lens ((&), (.~), (?~), (^.), _Just, makeLenses, over, set)+import Control.Monad ((>=>))+import Control.Monad.IO.Class+import Control.Monad.Reader+import Control.Monad.Writer+import Data.ConfigFile.B9Extras+  ( CPDocument+  , CPError+  , CPGet+  , CPOptionSpec+  , CPReadException(..)+  , addSectionCP+  , emptyCP+  , mergeCP+  , readCP+  , readCPDocument+  , setShowCP+  , toStringCP+  )+import Data.Function (on)+import Data.Maybe (fromMaybe)+import qualified Data.Semigroup as Sem+import qualified Data.Text.Lazy as LazyT+import System.Directory+import System.IO.B9Extras (SystemPath(..), ensureDir, resolve)+import Text.Printf (printf) -type BuildVariables = [(String, String)]+import B9.Environment -data ExecEnvType = LibVirtLXC deriving (Eq, Show, Ord, Read)+data ExecEnvType =+  LibVirtLXC+  deriving (Eq, Show, Ord, Read) -data LogLevel = LogTrace | LogDebug | LogInfo | LogError | LogNothing-              deriving (Eq, Show, Ord, Read)+data LogLevel+  = LogTrace+  | LogDebug+  | LogInfo+  | LogError+  | LogNothing+  deriving (Eq, Show, Ord, Read) -data B9Config = B9Config { _verbosity :: Maybe LogLevel-                         , _logFile :: Maybe FilePath-                         , _buildDirRoot :: Maybe FilePath-                         , _keepTempDirs :: Bool-                         , _execEnvType :: ExecEnvType-                         , _profileFile :: Maybe FilePath-                         , _envVars :: BuildVariables-                         , _uniqueBuildDirs :: Bool-                         , _repositoryCache :: Maybe SystemPath-                         , _repository :: Maybe String-                         , _interactive :: Bool-                         , _maxLocalSharedImageRevisions :: Maybe Int-                         , _libVirtLXCConfigs :: Maybe LibVirtLXCConfig-                         , _remoteRepos :: [RemoteRepo]-                         } deriving (Show)+data B9Config = B9Config+  { _verbosity :: Maybe LogLevel+  , _logFile :: Maybe FilePath+  , _buildDirRoot :: Maybe FilePath+  , _keepTempDirs :: Bool+  , _execEnvType :: ExecEnvType+  , _profileFile :: Maybe FilePath+  , _envVars :: Environment+  , _uniqueBuildDirs :: Bool+  , _repositoryCache :: Maybe SystemPath+  , _repository :: Maybe String+  , _interactive :: Bool+  , _maxLocalSharedImageRevisions :: Maybe Int+  , _libVirtLXCConfigs :: Maybe LibVirtLXCConfig+  , _remoteRepos :: [RemoteRepo]+  } deriving (Show)  instance Sem.Semigroup B9Config where-  c <> c' = B9Config-    { _verbosity = getLast $ on mappend (Last . _verbosity) c c'-    , _logFile = getLast $ on mappend (Last . _logFile) c c'-    , _buildDirRoot = getLast $ on mappend (Last . _buildDirRoot) c c'-    , _keepTempDirs = getAny $ on mappend (Any . _keepTempDirs) c c'-    , _execEnvType = LibVirtLXC-    , _profileFile = getLast $ on mappend (Last . _profileFile) c c'-    , _envVars = on mappend _envVars c c'-    , _uniqueBuildDirs = getAll ((mappend `on` (All . _uniqueBuildDirs)) c c')-    , _repositoryCache = getLast $ on mappend (Last . _repositoryCache) c c'-    , _repository = getLast ((mappend `on` (Last . _repository)) c c')-    , _interactive = getAny ((mappend `on` (Any . _interactive)) c c')-    , _maxLocalSharedImageRevisions =-      getLast ((mappend `on` (Last . _maxLocalSharedImageRevisions)) c c')-    , _libVirtLXCConfigs = getLast-                             ((mappend `on` (Last . _libVirtLXCConfigs)) c c')-    , _remoteRepos = (mappend `on` _remoteRepos) c c'-    }+  c <> c' =+    B9Config+      { _verbosity = getLast $ on mappend (Last . _verbosity) c c'+      , _logFile = getLast $ on mappend (Last . _logFile) c c'+      , _buildDirRoot = getLast $ on mappend (Last . _buildDirRoot) c c'+      , _keepTempDirs = getAny $ on mappend (Any . _keepTempDirs) c c'+      , _execEnvType = LibVirtLXC+      , _profileFile = getLast $ on mappend (Last . _profileFile) c c'+      , _envVars = on mappend _envVars c c'+      , _uniqueBuildDirs = getAll ((mappend `on` (All . _uniqueBuildDirs)) c c')+      , _repositoryCache = getLast $ on mappend (Last . _repositoryCache) c c'+      , _repository = getLast ((mappend `on` (Last . _repository)) c c')+      , _interactive = getAny ((mappend `on` (Any . _interactive)) c c')+      , _maxLocalSharedImageRevisions = getLast ((mappend `on` (Last . _maxLocalSharedImageRevisions)) c c')+      , _libVirtLXCConfigs = getLast ((mappend `on` (Last . _libVirtLXCConfigs)) c c')+      , _remoteRepos = (mappend `on` _remoteRepos) c c'+      }  instance Monoid B9Config where   mappend = (Sem.<>)-  mempty  = B9Config Nothing-                     Nothing-                     Nothing-                     False-                     LibVirtLXC-                     Nothing-                     []-                     True-                     Nothing-                     Nothing-                     False-                     Nothing-                     Nothing-                     []+  mempty =+    B9Config Nothing Nothing Nothing False LibVirtLXC Nothing mempty True Nothing Nothing False Nothing Nothing []  -- | Override b9 configuration items and/or the path of the b9 configuration file. -- This is useful, i.e. when dealing with command line parameters. data B9ConfigOverride = B9ConfigOverride-  { _customB9ConfigPath   :: Maybe SystemPath-  , _customB9Config       :: B9Config+  { _customB9ConfigPath :: Maybe SystemPath+  , _customB9Config :: B9Config   , _customLibVirtNetwork :: Maybe (Maybe String)-  } deriving Show+  } deriving (Show)  -- | An empty default 'B9ConfigOverride' value, that will neither apply any -- additional 'B9Config' nor change the path of the configuration file.@@ -168,6 +149,7 @@ noB9ConfigOverride = B9ConfigOverride Nothing mempty mempty  makeLenses ''B9Config+ makeLenses ''B9ConfigOverride  -- | Convenience utility to override the B9 configuration file path.@@ -175,15 +157,13 @@ overrideB9ConfigPath p = customB9ConfigPath ?~ p  -- | Modify the runtime configuration.-overrideB9Config-  :: (B9Config -> B9Config) -> B9ConfigOverride -> B9ConfigOverride+overrideB9Config :: (B9Config -> B9Config) -> B9ConfigOverride -> B9ConfigOverride overrideB9Config = over customB9Config  -- | Define the current working directory to be used when building. overrideWorkingDirectory :: FilePath -> B9ConfigOverride -> B9ConfigOverride overrideWorkingDirectory p = customB9Config . buildDirRoot ?~ p - -- | Overwrite the 'verbosity' settings in the configuration with those given. overrideVerbosity :: LogLevel -> B9ConfigOverride -> B9ConfigOverride overrideVerbosity = overrideB9Config . Lens.set verbosity . Just@@ -192,14 +172,14 @@ overrideKeepBuildDirs :: Bool -> B9ConfigOverride -> B9ConfigOverride overrideKeepBuildDirs = overrideB9Config . Lens.set keepTempDirs --- | A monad that gives access to the (transient) 'B9Config' to be used to+-- | A monad that gives access to the (transient) 'B9Config' to be used at -- _runtime_ with 'askRuntimeConfig' or 'localRuntimeConfig', and that allows -- to write permanent 'B9Config' changes back to the configuration file using -- 'modifyPermanentConfig'. Execute a 'B9ConfigAction' by invoking -- either 'invokeB9' (which is simple) or 'execB9ConfigAction'. newtype B9ConfigAction m a = B9ConfigAction-  { runB9ConfigAction :: ReaderT B9Config (WriterT [Endo B9Config] m) a}-  deriving ( Functor, Applicative, Monad, MonadIO )+  { runB9ConfigAction :: ReaderT B9Config (WriterT [Endo B9Config] m) a+  } deriving (Functor, Applicative, Monad, MonadIO)  -- | Return the runtime configuration, that should be the configuration merged -- from all configuration sources. This is the configuration to be used during@@ -208,11 +188,7 @@ askRuntimeConfig = B9ConfigAction ask  -- | Run an action with an updated runtime configuration.-localRuntimeConfig-  :: Monad m-  => (B9Config -> B9Config)-  -> B9ConfigAction m a-  -> B9ConfigAction m a+localRuntimeConfig :: Monad m => (B9Config -> B9Config) -> B9ConfigAction m a -> B9ConfigAction m a localRuntimeConfig f = B9ConfigAction . local f . runB9ConfigAction  -- | Add a modification to the permanent configuration file.@@ -235,45 +211,28 @@ execB9ConfigAction act cfg = do   let cfgPath = cfg ^. customB9ConfigPath   cp <- openOrCreateB9Config cfgPath-   case parseB9Config cp of-    Left e -> fail-      (printf "Internal configuration load error, please report this: %s\n"-              (show e)-      )-+    Left e -> fail (printf "Internal configuration load error, please report this: %s\n" (show e))     Right permanentConfig -> do       let runtimeCfg =             let rc = permanentConfig Sem.<> (cfg ^. customB9Config)-            in  case cfg ^. customLibVirtNetwork of-                  Just overridenNetwork ->-                    rc-                      &  libVirtLXCConfigs-                      .  _Just-                      .  networkId-                      .~ overridenNetwork+             in case cfg ^. customLibVirtNetwork of+                  Just overridenNetwork -> rc & libVirtLXCConfigs . _Just . networkId .~ overridenNetwork                   Nothing -> rc--      (res, permanentB9ConfigUpdates) <- runWriterT-        (runReaderT (runB9ConfigAction act) runtimeCfg)-+      (res, permanentB9ConfigUpdates) <- runWriterT (runReaderT (runB9ConfigAction act) runtimeCfg)       let cpExtErr = modifyCPDocument cp <$> permanentB9ConfigUpdate-          permanentB9ConfigUpdate = if null permanentB9ConfigUpdates-            then Nothing-            else Just (mconcat permanentB9ConfigUpdates)-      cpExt <- maybe-        (return Nothing)-        (either-          ( fail-          . printf-              "Internal configuration update error! Please report this: %s\n"-          . show-          )-          (return . Just)-        )-        cpExtErr+          permanentB9ConfigUpdate =+            if null permanentB9ConfigUpdates+              then Nothing+              else Just (mconcat permanentB9ConfigUpdates)+      cpExt <-+        maybe+          (return Nothing)+          (either (fail . printf "Internal configuration update error! Please report this: %s\n" . show) (return . Just))+          cpExtErr       mapM_ (writeB9CPDocument (cfg ^. customB9ConfigPath)) cpExt       return res+ -- | Run a 'B9ConfigAction' using 'noB9ConfigOverride'. -- See 'execB9ConfigAction' for more details. invokeB9 :: MonadIO m => B9ConfigAction m a -> m a@@ -290,11 +249,10 @@     exists <- doesFileExist cfgFile     if exists       then readCPDocument (Path cfgFile)-      else-        let res = b9ConfigToCPDocument defaultB9Config-        in  case res of-              Left  e  -> throwIO (CPReadException cfgFile e)-              Right cp -> writeFile cfgFile (toStringCP cp) >> return cp+      else let res = b9ConfigToCPDocument defaultB9Config+            in case res of+                 Left e -> throwIO (CPReadException cfgFile e)+                 Right cp -> writeFile cfgFile (toStringCP cp) >> return cp  -- | Write the configuration in the 'CPDocument' to either the user supplied -- configuration file path or to 'defaultB9ConfigFile'.@@ -305,50 +263,64 @@   ensureDir cfgFile   liftIO (writeFile cfgFile (toStringCP cp)) - defaultB9Config :: B9Config-defaultB9Config = B9Config { _verbosity                    = Just LogInfo-                           , _logFile                      = Nothing-                           , _buildDirRoot                 = Nothing-                           , _keepTempDirs                 = False-                           , _execEnvType                  = LibVirtLXC-                           , _profileFile                  = Nothing-                           , _envVars                      = []-                           , _uniqueBuildDirs              = True-                           , _repository                   = Nothing-                           , _repositoryCache = Just defaultRepositoryCache-                           , _interactive                  = False-                           , _maxLocalSharedImageRevisions = Just 2-                           , _libVirtLXCConfigs = Just defaultLibVirtLXCConfig-                           , _remoteRepos                  = []-                           }+defaultB9Config =+  B9Config+    { _verbosity = Just LogInfo+    , _logFile = Nothing+    , _buildDirRoot = Nothing+    , _keepTempDirs = False+    , _execEnvType = LibVirtLXC+    , _profileFile = Nothing+    , _envVars = mempty+    , _uniqueBuildDirs = True+    , _repository = Nothing+    , _repositoryCache = Just defaultRepositoryCache+    , _interactive = False+    , _maxLocalSharedImageRevisions = Just 2+    , _libVirtLXCConfigs = Just defaultLibVirtLXCConfig+    , _remoteRepos = []+    }  defaultRepositoryCache :: SystemPath defaultRepositoryCache = InB9UserDir "repo-cache"+ defaultB9ConfigFile :: SystemPath defaultB9ConfigFile = InB9UserDir "b9.conf"+ verbosityK :: String verbosityK = "verbosity"+ logFileK :: String logFileK = "log_file"+ buildDirRootK :: String buildDirRootK = "build_dir_root"+ keepTempDirsK :: String keepTempDirsK = "keep_temp_dirs"+ execEnvTypeK :: String execEnvTypeK = "exec_env"+ profileFileK :: String profileFileK = "profile_file"+ envVarsK :: String envVarsK = "environment_vars"+ uniqueBuildDirsK :: String uniqueBuildDirsK = "unique_build_dirs"+ repositoryCacheK :: String repositoryCacheK = "repository_cache"+ maxLocalSharedImageRevisionsK :: String maxLocalSharedImageRevisionsK = "max_cached_shared_images"+ repositoryK :: String repositoryK = "repository"+ cfgFileSection :: String cfgFileSection = "global" @@ -371,19 +343,10 @@   cp7 <- setShowCP cp6 cfgFileSection profileFileK (_profileFile c)   cp8 <- setShowCP cp7 cfgFileSection envVarsK (_envVars c)   cp9 <- setShowCP cp8 cfgFileSection uniqueBuildDirsK (_uniqueBuildDirs c)-  cpA <- setShowCP cp9-                   cfgFileSection-                   maxLocalSharedImageRevisionsK-                   (_maxLocalSharedImageRevisions c)+  cpA <- setShowCP cp9 cfgFileSection maxLocalSharedImageRevisionsK (_maxLocalSharedImageRevisions c)   cpB <- setShowCP cpA cfgFileSection repositoryCacheK (_repositoryCache c)-  cpC <--    (foldr (>=>)-           return-           (libVirtLXCConfigToCPDocument <$> (_libVirtLXCConfigs c))-      )-      cpB-  cpFinal <- (foldr (>=>) return (remoteRepoToCPDocument <$> _remoteRepos c))-    cpC+  cpC <- foldr (>=>) return (libVirtLXCConfigToCPDocument <$> _libVirtLXCConfigs c) cpB+  cpFinal <- foldr (>=>) return (remoteRepoToCPDocument <$> _remoteRepos c) cpC   setShowCP cpFinal cfgFileSection repositoryK (_repository c)  readB9Config :: MonadIO m => Maybe SystemPath -> m CPDocument@@ -391,47 +354,27 @@  parseB9Config :: CPDocument -> Either CPError B9Config parseB9Config cp =-  let-    getr :: (CPGet a) => CPOptionSpec -> Either CPError a-    getr = readCP cp cfgFileSection-    getB9Config =-      B9Config-        <$> getr verbosityK-        <*> getr logFileK-        <*> getr buildDirRootK-        <*> getr keepTempDirsK-        <*> getr execEnvTypeK-        <*> getr profileFileK-        <*> getr envVarsK-        <*> getr uniqueBuildDirsK-        <*> getr repositoryCacheK-        <*> getr repositoryK-        <*> pure False-        <*> pure-              (either (const Nothing) id (getr maxLocalSharedImageRevisionsK))-        <*> pure (either (const Nothing) Just (parseLibVirtLXCConfig cp))-        <*> parseRemoteRepos cp-  in-    getB9Config-+  let getr :: (CPGet a) => CPOptionSpec -> Either CPError a+      getr = readCP cp cfgFileSection+      getB9Config =+        B9Config <$> getr verbosityK <*> getr logFileK <*> getr buildDirRootK <*> getr keepTempDirsK <*>+        getr execEnvTypeK <*>+        getr profileFileK <*>+        (fromStringPairs <$> getr envVarsK)+         <*>+        getr uniqueBuildDirsK <*>+        getr repositoryCacheK <*>+        getr repositoryK <*>+        pure False <*>+        pure (either (const Nothing) id (getr maxLocalSharedImageRevisionsK)) <*>+        pure (either (const Nothing) Just (parseLibVirtLXCConfig cp)) <*>+        parseRemoteRepos cp+   in getB9Config  -- | If environment variables @arg_1 .. arg_n@ are bound -- and a list of @k@ additional values are passed to this function, -- store them with keys @arg_(n+1) .. arg_(n+k)@. appendPositionalArguments :: [String] -> B9Config -> B9Config-appendPositionalArguments extraPositional c = c-  { _envVars = appendVars (_envVars c)-  }- where-  appendVars argsOld =-    let (oldPositional, oldOther) =-          partition (("arg_" ==) . take 4 . fst) argsOld-        oldPositionalSortedByPosition =-          map snd-            $ sortBy (compare `on` fst)-            $ map (\(x, y) -> ((read :: String -> Int) $ drop 4 $ x, y))-            $ oldPositional-        newPositional =-          let xs = oldPositionalSortedByPosition ++ extraPositional-          in  [ ("arg_" ++ show i, a) | (i, a) <- zip [1 :: Int ..] xs ]-    in  newPositional ++ oldOther+appendPositionalArguments extraPositional c = c {_envVars = appendVars (_envVars c)}+  where+    appendVars = insertPositionalArguments (LazyT.pack <$> extraPositional)
src/lib/B9/B9Config/LibVirtLXC.hs view
@@ -1,74 +1,75 @@ module B9.B9Config.LibVirtLXC-    ( libVirtLXCConfigToCPDocument-    , defaultLibVirtLXCConfig-    , parseLibVirtLXCConfig-    , LibVirtLXCConfig(..)-    , networkId-    , LXCGuestCapability(..)-    )-where--import           B9.DiskImages-import           B9.ExecEnv-import           Data.ConfigFile.B9Extras-import           Control.Lens                   ( makeLenses )+  ( libVirtLXCConfigToCPDocument+  , defaultLibVirtLXCConfig+  , parseLibVirtLXCConfig+  , LibVirtLXCConfig(..)+  , networkId+  , LXCGuestCapability(..)+  ) where +import B9.DiskImages+import B9.ExecEnv+import Control.Lens (makeLenses)+import Data.ConfigFile.B9Extras -data LibVirtLXCConfig = LibVirtLXCConfig { useSudo :: Bool-                                         , virshPath :: FilePath-                                         , emulator :: FilePath-                                         , virshURI :: FilePath-                                         , _networkId :: Maybe String-                                         , guestCapabilities :: [LXCGuestCapability]-                                         , guestRamSize :: RamSize-                                         } deriving (Read, Show)+data LibVirtLXCConfig = LibVirtLXCConfig+  { useSudo :: Bool+  , virshPath :: FilePath+  , emulator :: FilePath+  , virshURI :: FilePath+  , _networkId :: Maybe String+  , guestCapabilities :: [LXCGuestCapability]+  , guestRamSize :: RamSize+  } deriving (Read, Show)  -- | Available linux capabilities for lxc containers. This maps directly to the -- capabilities defined in 'man 7 capabilities'.-data LXCGuestCapability = CAP_MKNOD-                        | CAP_AUDIT_CONTROL-                        | CAP_AUDIT_READ-                        | CAP_AUDIT_WRITE-                        | CAP_BLOCK_SUSPEND-                        | CAP_CHOWN-                        | CAP_DAC_OVERRIDE-                        | CAP_DAC_READ_SEARCH-                        | CAP_FOWNER-                        | CAP_FSETID-                        | CAP_IPC_LOCK-                        | CAP_IPC_OWNER-                        | CAP_KILL-                        | CAP_LEASE-                        | CAP_LINUX_IMMUTABLE-                        | CAP_MAC_ADMIN-                        | CAP_MAC_OVERRIDE-                        | CAP_NET_ADMIN-                        | CAP_NET_BIND_SERVICE-                        | CAP_NET_BROADCAST-                        | CAP_NET_RAW-                        | CAP_SETGID-                        | CAP_SETFCAP-                        | CAP_SETPCAP-                        | CAP_SETUID-                        | CAP_SYS_ADMIN-                        | CAP_SYS_BOOT-                        | CAP_SYS_CHROOT-                        | CAP_SYS_MODULE-                        | CAP_SYS_NICE-                        | CAP_SYS_PACCT-                        | CAP_SYS_PTRACE-                        | CAP_SYS_RAWIO-                        | CAP_SYS_RESOURCE-                        | CAP_SYS_TIME-                        | CAP_SYS_TTY_CONFIG-                        | CAP_SYSLOG-                        | CAP_WAKE_ALARM+data LXCGuestCapability+  = CAP_MKNOD+  | CAP_AUDIT_CONTROL+  | CAP_AUDIT_READ+  | CAP_AUDIT_WRITE+  | CAP_BLOCK_SUSPEND+  | CAP_CHOWN+  | CAP_DAC_OVERRIDE+  | CAP_DAC_READ_SEARCH+  | CAP_FOWNER+  | CAP_FSETID+  | CAP_IPC_LOCK+  | CAP_IPC_OWNER+  | CAP_KILL+  | CAP_LEASE+  | CAP_LINUX_IMMUTABLE+  | CAP_MAC_ADMIN+  | CAP_MAC_OVERRIDE+  | CAP_NET_ADMIN+  | CAP_NET_BIND_SERVICE+  | CAP_NET_BROADCAST+  | CAP_NET_RAW+  | CAP_SETGID+  | CAP_SETFCAP+  | CAP_SETPCAP+  | CAP_SETUID+  | CAP_SYS_ADMIN+  | CAP_SYS_BOOT+  | CAP_SYS_CHROOT+  | CAP_SYS_MODULE+  | CAP_SYS_NICE+  | CAP_SYS_PACCT+  | CAP_SYS_PTRACE+  | CAP_SYS_RAWIO+  | CAP_SYS_RESOURCE+  | CAP_SYS_TIME+  | CAP_SYS_TTY_CONFIG+  | CAP_SYSLOG+  | CAP_WAKE_ALARM   deriving (Read, Show)  makeLenses ''LibVirtLXCConfig  defaultLibVirtLXCConfig :: LibVirtLXCConfig-defaultLibVirtLXCConfig = LibVirtLXCConfig+defaultLibVirtLXCConfig =+  LibVirtLXCConfig     True     "/usr/bin/virsh"     "/usr/lib/libvirt/libvirt_lxc"@@ -88,42 +89,43 @@  cfgFileSection :: String cfgFileSection = "libvirt-lxc"+ useSudoK :: String useSudoK = "use_sudo"+ virshPathK :: String virshPathK = "virsh_path"+ emulatorK :: String emulatorK = "emulator_path"+ virshURIK :: String virshURIK = "connection"+ networkIdK :: String networkIdK = "network"+ guestCapabilitiesK :: String guestCapabilitiesK = "guest_capabilities"+ guestRamSizeK :: String guestRamSizeK = "guest_ram_size" -libVirtLXCConfigToCPDocument-    :: LibVirtLXCConfig -> CPDocument -> Either CPError CPDocument+libVirtLXCConfigToCPDocument :: LibVirtLXCConfig -> CPDocument -> Either CPError CPDocument libVirtLXCConfigToCPDocument c cp = do-    cp1 <- addSectionCP cp cfgFileSection-    cp2 <- setShowCP cp1 cfgFileSection useSudoK $ useSudo c-    cp3 <- setCP cp2 cfgFileSection virshPathK $ virshPath c-    cp4 <- setCP cp3 cfgFileSection emulatorK $ emulator c-    cp5 <- setCP cp4 cfgFileSection virshURIK $ virshURI c-    cp6 <- setShowCP cp5 cfgFileSection networkIdK $ _networkId c-    cp7 <- setShowCP cp6 cfgFileSection guestCapabilitiesK $ guestCapabilities c-    setShowCP cp7 cfgFileSection guestRamSizeK $ guestRamSize c+  cp1 <- addSectionCP cp cfgFileSection+  cp2 <- setShowCP cp1 cfgFileSection useSudoK $ useSudo c+  cp3 <- setCP cp2 cfgFileSection virshPathK $ virshPath c+  cp4 <- setCP cp3 cfgFileSection emulatorK $ emulator c+  cp5 <- setCP cp4 cfgFileSection virshURIK $ virshURI c+  cp6 <- setShowCP cp5 cfgFileSection networkIdK $ _networkId c+  cp7 <- setShowCP cp6 cfgFileSection guestCapabilitiesK $ guestCapabilities c+  setShowCP cp7 cfgFileSection guestRamSizeK $ guestRamSize c  parseLibVirtLXCConfig :: CPDocument -> Either CPError LibVirtLXCConfig parseLibVirtLXCConfig cp =-    let getr :: (CPGet a) => CPOptionSpec -> Either CPError a-        getr = readCP cp cfgFileSection-    in  LibVirtLXCConfig-        <$> (getr useSudoK)-        <*> (getr virshPathK)-        <*> (getr emulatorK)-        <*> (getr virshURIK)-        <*> (getr networkIdK)-        <*> (getr guestCapabilitiesK)-        <*> (getr guestRamSizeK)+  let getr :: (CPGet a) => CPOptionSpec -> Either CPError a+      getr = readCP cp cfgFileSection+   in LibVirtLXCConfig <$> getr useSudoK <*> getr virshPathK <*> getr emulatorK <*> getr virshURIK <*> getr networkIdK <*>+      getr guestCapabilitiesK <*>+      getr guestRamSizeK
src/lib/B9/B9Monad.hs view
@@ -23,153 +23,130 @@   , getRemoteRepos   , getRepoCache   , cmd-  )-where+  ) where  import           B9.B9Config+import           B9.Environment import           B9.Repository import           Control.Applicative-import           Control.Exception              ( bracket )+import           Control.Concurrent.Async (Concurrently (..))+import           Control.Exception        (bracket)+import           Control.Lens             ((%~), (&), (.~), (?~), (^.)) import           Control.Monad import           Control.Monad.IO.Class import           Control.Monad.State-import           Control.Lens                   ( (&)-                                                , (.~)-                                                , (^.)-                                                , (%~)-                                                , (?~)-                                                )-import qualified Data.ByteString.Char8         as B-import           Data.Functor                   ( )+import qualified Data.ByteString.Char8    as Strict+import           Data.Conduit             (runConduit, (.|))+import qualified Data.Conduit.List        as CL+import           Data.Conduit.Process+import           Data.Foldable+import           Data.Functor             () import           Data.Hashable import           Data.Maybe import           Data.Time.Clock import           Data.Time.Format-import           Data.Word                      ( Word32 )+import           Data.Word                (Word32) import           System.Directory import           System.Exit import           System.FilePath-import           System.Random                  ( randomIO )-import qualified System.IO                     as SysIO+import qualified System.IO                as SysIO+import           System.Random            (randomIO) import           Text.Printf-import           Control.Concurrent.Async       ( Concurrently(..) )-import           Data.Conduit                   ( (.|)-                                                , runConduit-                                                )-import qualified Data.Conduit.List             as CL-import           Data.Foldable-import           Data.Conduit.Process -data BuildState =-  BuildState {bsBuildId :: String-             ,bsBuildDate :: String-             ,bsCfg :: B9Config-             ,bsBuildDir :: FilePath-             ,bsLogFileHandle :: Maybe SysIO.Handle-             ,bsSelectedRemoteRepo :: Maybe RemoteRepo-             ,bsRepoCache :: RepoCache-             ,bsProf :: [ProfilingEntry]-             ,bsStartTime :: UTCTime-             ,bsInheritStdIn :: Bool}+data BuildState = BuildState+  { bsBuildId            :: String+  , bsBuildDate          :: String+  , bsCfg                :: B9Config+  , bsBuildDir           :: FilePath+  , bsLogFileHandle      :: Maybe SysIO.Handle+  , bsSelectedRemoteRepo :: Maybe RemoteRepo+  , bsRepoCache          :: RepoCache+  , bsProf               :: [ProfilingEntry]+  , bsStartTime          :: UTCTime+  , bsInheritStdIn       :: Bool+  }  data ProfilingEntry   = IoActionDuration NominalDiffTime   | LogEvent LogLevel              String-  deriving (Eq,Show)-+  deriving (Eq, Show)  run :: MonadIO m => B9 a -> B9ConfigAction m a run action = do   cfg <- askRuntimeConfig   liftIO $ do     buildId <- liftIO $ generateBuildId cfg-    now     <- liftIO $ getCurrentTime-    liftIO-      $ withBuildDir cfg buildId (withLogFile cfg . runImpl cfg buildId now)- where-  resolveBuildDirRoot cfg = case _buildDirRoot cfg of-    Nothing    -> getCurrentDirectory >>= canonicalizePath-    Just root' -> do-      createDirectoryIfMissing True root'-      canonicalizePath root'-  withLogFile cfg f = maybe-    (f Nothing)-    (\logf -> SysIO.withFile logf SysIO.AppendMode (f . Just))-    (_logFile cfg)-  withBuildDir cfg buildId =-    bracket (createBuildDir cfg buildId) (removeBuildDir cfg)-  runImpl cfg buildId now buildDir logFileHandle = do-      -- Check repositories-    repoCache <- initRepoCache-      (fromMaybe defaultRepositoryCache (_repositoryCache cfg))-    let buildDate = formatTime undefined "%F-%T" now-    remoteRepos'    <- mapM (initRemoteRepo repoCache) (_remoteRepos cfg)-    buildDirRootAbs <- resolveBuildDirRoot cfg-    let finalCfg =-          (  cfg-          &  remoteRepos-          .~ remoteRepos'-          &  (buildDirRoot ?~ buildDirRootAbs)-          &  envVars-          %~ mappend [("buildDirRoot", buildDirRootAbs)]-          )-    let-      ctx = BuildState buildId-                       buildDate-                       finalCfg-                       buildDir-                       logFileHandle-                       selectedRemoteRepo-                       repoCache-                       []-                       now-                       (_interactive finalCfg)-      selectedRemoteRepo = do-        sel <- _repository cfg-        lookupRemoteRepo remoteRepos' sel <|> error-          (printf-            "selected remote repo '%s' not configured, valid remote repos are: '%s'"-            sel-            (show remoteRepos')-          )-    (r, ctxOut) <- runStateT (runB9 wrappedAction) ctx-    -- Write a profiling report-    when (isJust (_profileFile cfg)) $ writeFile-      (fromJust (_profileFile cfg))-      (unlines $ show <$> reverse (bsProf ctxOut))-    return r-  createBuildDir cfg buildId = do+    now <- liftIO getCurrentTime+    liftIO $ withBuildDir cfg buildId (withLogFile cfg . runImpl cfg buildId now)+  where+    resolveBuildDirRoot cfg =+      case _buildDirRoot cfg of+        Nothing -> getCurrentDirectory >>= canonicalizePath+        Just root' -> do+          createDirectoryIfMissing True root'+          canonicalizePath root'+    withLogFile cfg f = maybe (f Nothing) (\logf -> SysIO.withFile logf SysIO.AppendMode (f . Just)) (_logFile cfg)+    withBuildDir cfg buildId = bracket (createBuildDir cfg buildId) (removeBuildDir cfg)+    runImpl cfg buildId now buildDir logFileHandle = do+      repoCache <- initRepoCache (fromMaybe defaultRepositoryCache (_repositoryCache cfg))+      let buildDate = formatTime undefined "%F-%T" now+      remoteRepos' <- mapM (initRemoteRepo repoCache) (_remoteRepos cfg)+      buildDirRootAbs <- resolveBuildDirRoot cfg+      let finalCfg =+            cfg & remoteRepos .~ remoteRepos' & (buildDirRoot ?~ buildDirRootAbs) & envVars %~ fromJust .+            addStringBinding ("buildDirRoot", buildDirRootAbs)+          ctx =+            BuildState+              buildId+              buildDate+              finalCfg+              buildDir+              logFileHandle+              selectedRemoteRepo+              repoCache+              []+              now+              (_interactive finalCfg)+          selectedRemoteRepo = do+            sel <- _repository cfg+            lookupRemoteRepo remoteRepos' sel <|>+              error+                (printf "selected remote repo '%s' not configured, valid remote repos are: '%s'" sel (show remoteRepos'))+      (r, ctxOut) <- runStateT (runB9 wrappedAction) ctx+      when (isJust (_profileFile cfg)) $+        writeFile (fromJust (_profileFile cfg)) (unlines $ show <$> reverse (bsProf ctxOut))+      return r+            -- Check repositories+    createBuildDir cfg buildId = do       let subDir = "BUILD-" ++ buildId       buildDir <- resolveBuildDir subDir       createDirectoryIfMissing True buildDir       canonicalizePath buildDir-   where-    resolveBuildDir f = do-      root <- resolveBuildDirRoot cfg-      return $ root </> f-  removeBuildDir cfg buildDir =-    when (_uniqueBuildDirs cfg && not (_keepTempDirs cfg))-      $ removeDirectoryRecursive buildDir-  generateBuildId cfg =-    let cfgHash = hash (show cfg) in-       if _uniqueBuildDirs cfg then-        do salt <- randomIO :: IO Word32-           return (printf "%08X-%08X" cfgHash salt)-        else-           return (printf "%08X" cfgHash)-  -- Run the action build action-  wrappedAction   = do-    b9cfg <- getConfig-    traverse_ (traceL . printf "Root Build Directory: %s")-              (b9cfg ^. buildDirRoot)-    startTime <- gets bsStartTime-    r         <- action-    now       <- liftIO getCurrentTime-    let duration = show (now `diffUTCTime` startTime)-    infoL (printf "DURATION: %s" duration)-    return r+      where+        resolveBuildDir f = do+          root <- resolveBuildDirRoot cfg+          return $ root </> f+    removeBuildDir cfg buildDir =+      when (_uniqueBuildDirs cfg && not (_keepTempDirs cfg)) $ removeDirectoryRecursive buildDir+    generateBuildId cfg =+      let cfgHash = hash (show cfg)+       in if _uniqueBuildDirs cfg+            then do+              salt <- randomIO :: IO Word32+              return (printf "%08X-%08X" cfgHash salt)+            else return (printf "%08X" cfgHash)+    wrappedAction = do+      b9cfg <- getConfig+      traverse_ (traceL . printf "Root Build Directory: %s") (b9cfg ^. buildDirRoot)+      startTime <- gets bsStartTime+      r <- action+      now <- liftIO getCurrentTime+      let duration = show (now `diffUTCTime` startTime)+      infoL (printf "DURATION: %s" duration)+      return r +-- Run the action build action getBuildId :: B9 String getBuildId = gets bsBuildId @@ -206,14 +183,15 @@ --              ,downloaderArgsAfterUrl :: [String]} --   deriving (Read,Show,Eq,Ord,Typeable,Generic) ----- readContentFromUrl :: String -> B9 B.ByteString+-- readContentFromUrl :: String -> B9 Strict.ByteString -- readContentFromUrl url = do --   return expression- cmd :: String -> B9 () cmd str = do   inheritStdIn <- gets bsInheritStdIn-  if inheritStdIn then interactiveCmd str else nonInteractiveCmd str+  if inheritStdIn+    then interactiveCmd str+    else nonInteractiveCmd str  interactiveCmd :: String -> B9 () interactiveCmd str = void (cmdWithStdIn True str :: B9 Inherited)@@ -228,26 +206,26 @@ cmdWithStdIn toStdOut cmdStr = do   traceL $ "COMMAND: " ++ cmdStr   cmdLogger <- getCmdLogger-  let outPipe = if toStdOut then CL.mapM_ B.putStr else cmdLogger LogTrace+  let outPipe =+        if toStdOut+          then CL.mapM_ Strict.putStr+          else cmdLogger LogTrace   (cpIn, cpOut, cpErr, cph) <- streamingProcess (shell cmdStr)-  e                         <--    liftIO-    $  runConcurrently-    $  Concurrently (runConduit (cpOut .| outPipe))-    *> Concurrently (runConduit (cpErr .| cmdLogger LogInfo))-    *> Concurrently (waitForStreamingProcess cph)+  e <-+    liftIO $ runConcurrently $ Concurrently (runConduit (cpOut .| outPipe)) *>+    Concurrently (runConduit (cpErr .| cmdLogger LogInfo)) *>+    Concurrently (waitForStreamingProcess cph)   checkExitCode e   return cpIn- where-  getCmdLogger = do-    lv  <- gets $ _verbosity . bsCfg-    lfh <- gets bsLogFileHandle-    return $ \level -> CL.mapM_ (logImpl lv lfh level . B.unpack)-  checkExitCode ExitSuccess =-    traceL $ printf "COMMAND '%s' exited with exit code: 0" cmdStr-  checkExitCode ec@(ExitFailure e) = do-    errorL $ printf "COMMAND '%s' exited with exit code: %i" cmdStr e-    liftIO $ exitWith ec+  where+    getCmdLogger = do+      lv <- gets $ _verbosity . bsCfg+      lfh <- gets bsLogFileHandle+      return $ \level -> CL.mapM_ (logImpl lv lfh level . Strict.unpack)+    checkExitCode ExitSuccess = traceL $ printf "COMMAND '%s' exited with exit code: 0" cmdStr+    checkExitCode ec@(ExitFailure e) = do+      errorL $ printf "COMMAND '%s' exited with exit code: %i" cmdStr e+      liftIO $ exitWith ec  traceL :: String -> B9 () traceL = b9Log LogTrace@@ -266,9 +244,9 @@  b9Log :: LogLevel -> String -> B9 () b9Log level msg = do-  lv  <- gets $ _verbosity . bsCfg+  lv <- gets $ _verbosity . bsCfg   lfh <- gets bsLogFileHandle-  modify $ \ctx -> ctx { bsProf = LogEvent level msg : bsProf ctx }+  modify $ \ctx -> ctx {bsProf = LogEvent level msg : bsProf ctx}   B9 $ liftIO $ logImpl lv lfh level msg  logImpl :: Maybe LogLevel -> Maybe SysIO.Handle -> LogLevel -> String -> IO ()@@ -286,22 +264,23 @@   return $ unlines $ printf "[%s] %s - %s" (printLevel l) time <$> lines msg  printLevel :: LogLevel -> String-printLevel l = case l of-  LogNothing -> "NOTHING"-  LogError   -> " ERROR "-  LogInfo    -> " INFO  "-  LogDebug   -> " DEBUG "-  LogTrace   -> " TRACE "+printLevel l =+  case l of+    LogNothing -> "NOTHING"+    LogError   -> " ERROR "+    LogInfo    -> " INFO  "+    LogDebug   -> " DEBUG "+    LogTrace   -> " TRACE " -newtype B9 a =-  B9 {runB9 :: StateT BuildState IO a}-  deriving (Functor,Applicative,Monad,MonadState BuildState)+newtype B9 a = B9+  { runB9 :: StateT BuildState IO a+  } deriving (Functor, Applicative, Monad, MonadState BuildState, Alternative)  instance MonadIO B9 where   liftIO m = do     start <- B9 $ liftIO getCurrentTime-    res   <- B9 $ liftIO m-    stop  <- B9 $ liftIO getCurrentTime+    res <- B9 $ liftIO m+    stop <- B9 $ liftIO getCurrentTime     let durMS = IoActionDuration (stop `diffUTCTime` start)-    modify $ \ctx -> ctx { bsProf = durMS : bsProf ctx }+    modify $ \ctx -> ctx {bsProf = durMS : bsProf ctx}     return res
− src/lib/B9/Content/AST.hs 
@@ -1,107 +0,0 @@-{-|--B9 produces not only VM-Images but also text documents such as configuration-files required by virtual machines. This module is about creating and merging-files containing parsable syntactic structures, such as most configuration files-do.--Imagine you would want to create a cloud-init 'user-data' file from a set of-'user-data' snippets which each are valid 'user-data' files in yaml syntax and-e.g. a 'write_files' section. Now the goal is, for b9 to be able to merge these-snippets into one, such that all writefiles sections are combined into a single-writefile section. Another example is OTP/Erlang sys.config files.  This type-class is the greatest commonon denominator of types describing a syntax that can-be parsed, concatenated e.g. like in the above example and rendered. The actual-concatenation operation is the append from Monoid, i.e. like monoid but without-the need for an empty element.--}--module B9.Content.AST ( ConcatableSyntax (..)-                      , ASTish(..)-                      , AST(..)-                      , CanRender(..)-                      ) where--import           Control.Parallel.Strategies-import           Data.Binary-import qualified Data.ByteString as B-import           Data.Data-import           Data.Hashable-import           Data.Semigroup as Sem-import           GHC.Generics (Generic)-import           Control.Monad.Reader-import           B9.Content.StringTemplate-import           B9.B9Monad(B9)-import           Test.QuickCheck-import           B9.QCUtil---- | Types of values that can be parsed/rendered from/to 'ByteString's. This--- class is used as basis for the 'ASTish' class.-class (Sem.Semigroup a) => ConcatableSyntax a  where-    -- Parse a bytestring into an 'a', and return @Left errorMessage@ or @Right a@-    decodeSyntax-        :: FilePath -- ^ An arbitrary string for error messages that-        -> B.ByteString -- ^ The raw input to parse-        -> Either String a-    -- Generate a string representation of @a@-    encodeSyntax-        :: a -> B.ByteString--instance ConcatableSyntax B.ByteString where-    decodeSyntax _ = Right-    encodeSyntax = id---- | Describe how to create structured content that has a tree-like syntactic--- structure, e.g. yaml, JSON and erlang-proplists. The first parameter defines--- a /context/ into which the 'AST' is embeded,--- e.g. B9.Content.Generator.Content'. The second parameter defines a specifix--- syntax, e.g 'B9.Content.ErlangPropList' that the 'AST' value generates.-data AST c a-    = ASTObj [(String, AST c a)] -- ^ Create an object similar to a-                                 -- Json object.-    | ASTArr [AST c a] -- ^ An array.-    | ASTMerge [AST c a] -- ^ Merge the nested elements, this is a very-                         -- powerful tool that allows to combine-    |-      -- several inputs in a smart and safe way,-      -- e.g. by merging the values of the same-      -- fields in yaml objects.-      ASTEmbed c -- Embed some pure content.-    | ASTString String -- A string literal.-    | ASTInt Int -- An Int literal.-    | ASTParse SourceFile -- An 'AST' obtained from parsing a source-                          -- file that contains a string corresponding-    |-                -- to the type parameter @a@, e.g. 'YamlObject's-      AST a -- Embed a literal @a@.-    deriving (Read,Show,Typeable,Data,Eq,Generic)--instance (Hashable c, Hashable a) => Hashable (AST c a)-instance (Binary c, Binary a) => Binary (AST c a)-instance (NFData c, NFData a) => NFData (AST c a)----- | Types of values that describe content, that can be created from an 'AST'.-class (ConcatableSyntax a) => ASTish a  where-    fromAST-        :: (CanRender c)-        => AST c a -> ReaderT Environment B9  a---- | Types of values that can be /rendered/ into a 'ByteString'-class CanRender c  where-    render-        :: c -> ReaderT Environment B9 B.ByteString--instance (Arbitrary c, Arbitrary a) => Arbitrary (AST c a) where-    arbitrary =-        oneof-            [ ASTObj <$> smaller (listOf ((,) <$> arbitrary <*> arbitrary))-            , ASTArr <$> smaller (listOf arbitrary)-            , ASTMerge <$>-              sized-                  (\s ->-                        resize (max 2 s) (listOf (halfSize arbitrary)))-            , ASTEmbed <$> smaller arbitrary-            , ASTString <$> arbitrary-            , ASTParse <$> smaller arbitrary-            , AST <$> smaller arbitrary]
− src/lib/B9/Content/ErlTerms.hs 
@@ -1,349 +0,0 @@-{-| Erlang term parser and pretty printer. -}-module B9.Content.ErlTerms (parseErlTerm-                           ,renderErlTerm-                           ,SimpleErlangTerm(..)-                           ,arbitraryErlSimpleAtom-                           ,arbitraryErlString-                           ,arbitraryErlNumber-                           ,arbitraryErlNatural-                           ,arbitraryErlFloat-                           ,arbitraryErlNameChar) where--import           Control.Parallel.Strategies-import           Data.Binary-import qualified Data.ByteString.Char8 as B-import           Data.Data-import           Data.Function-import           Data.Hashable-import           GHC.Generics (Generic)-import           Test.QuickCheck-import           Text.Parsec-       ((<|>), many, spaces, char, option, between, string, choice,-        octDigit, hexDigit, many1, noneOf, try, digit, anyChar, alphaNum,-        lower, parse)-import           Text.Parsec.ByteString-import           Text.Show.Pretty-import           Control.Monad-import           Text.Printf-import qualified Text.PrettyPrint as PP--import           B9.QCUtil---- | Simplified Erlang term representation.-data SimpleErlangTerm-    = ErlString String-    | ErlFloat Double-    | ErlNatural Integer-    | ErlAtom String-    | ErlChar Char-    | ErlBinary String-    | ErlList [SimpleErlangTerm]-    | ErlTuple [SimpleErlangTerm]-    deriving (Eq,Ord,Read,Show,Data,Typeable,Generic)--instance Hashable SimpleErlangTerm-instance Binary SimpleErlangTerm-instance NFData SimpleErlangTerm----- | Parse a subset of valid Erlang terms. It parses no maps and binaries are--- restricted to either empty binaries or binaries with a string. The input--- encoding must be restricted to ascii compatible 8-bit characters--- (e.g. latin-1 or UTF8).-parseErlTerm :: String -> B.ByteString -> Either String SimpleErlangTerm-parseErlTerm src content =-  either (Left . ppShow) Right (parse erlTermParser src content)---- | Convert an abstract Erlang term to a pretty byte string preserving the--- encoding.-renderErlTerm :: SimpleErlangTerm -> B.ByteString-renderErlTerm s = B.pack (PP.render (prettyPrintErlTerm s PP.<> PP.char '.'))--prettyPrintErlTerm :: SimpleErlangTerm -> PP.Doc-prettyPrintErlTerm (ErlString str) = PP.doubleQuotes (PP.text (toErlStringString str))-prettyPrintErlTerm (ErlNatural n) = PP.integer n-prettyPrintErlTerm (ErlFloat f) = PP.double f-prettyPrintErlTerm (ErlChar c) = PP.text ("$" ++ toErlAtomChar c)-prettyPrintErlTerm (ErlAtom a) = PP.text quotedAtom-  where-    quotedAtom =-      case toErlAtomString a of-        "" -> "''"-        a'@(firstChar:rest)-          | firstChar `elem` ['a' .. 'z'] &&-              all (`elem` atomCharsThatDontNeedQuoting) rest -> a'-        a' -> "'" ++ a' ++ "'"-    atomCharsThatDontNeedQuoting =-      ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] ++ "@_"--prettyPrintErlTerm (ErlBinary []) = PP.text "<<>>"-prettyPrintErlTerm (ErlBinary b) = PP.text ("<<\"" ++ toErlStringString b ++ "\">>")-prettyPrintErlTerm (ErlList xs) =-  PP.brackets (PP.sep (PP.punctuate PP.comma (prettyPrintErlTerm <$> xs)))-prettyPrintErlTerm (ErlTuple xs) =-  PP.braces (PP.sep (PP.punctuate PP.comma (prettyPrintErlTerm <$> xs)))--toErlStringString :: String -> String-toErlStringString = join . map toErlStringChar--toErlStringChar :: Char -> String-toErlStringChar = (table !!) . fromEnum-  where-    table = [printf "\\x{%x}" c | c <- [0..(31::Int)]] ++-            (pure <$> toEnum <$> [32 .. 33]) ++-            ["\\\""] ++-            (pure <$> toEnum <$> [35 .. 91]) ++-            ["\\\\"] ++(pure <$> toEnum <$> [93 .. 126]) ++-            [printf "\\x{%x}" c | c <- [(127::Int)..]]--toErlAtomString :: String -> String-toErlAtomString = join . map toErlAtomChar--toErlAtomChar :: Char -> String-toErlAtomChar = (table !!) . fromEnum-  where-    table = [printf "\\x{%x}" c | c <- [0..(31::Int)]] ++-            (pure <$> toEnum <$> [32 .. 38]) ++-            ["\\'"] ++-            (pure <$> toEnum <$> [40 .. 91]) ++-            ["\\\\"] ++(pure <$> toEnum <$> [93 .. 126]) ++-            [printf "\\x{%x}" c | c <- [(127::Int)..]]---instance Arbitrary SimpleErlangTerm where-  arbitrary = oneof [sized aErlString-                    ,sized aErlNatural-                    ,sized aErlFloat-                    ,sized aErlChar-                    ,sized aErlAtomUnquoted-                    ,sized aErlAtomQuoted-                    ,sized aErlBinary-                    ,sized aErlList-                    ,sized aErlTuple-                    ]-    where-      decrSize 0 = resize 0-      decrSize n = resize (n - 1)-      aErlString n =-        ErlString <$> decrSize n (listOf (choose (toEnum 0,toEnum 255)))-      aErlFloat n = do-        f <- decrSize n arbitrary :: Gen Float-        let d = fromRational (toRational f)-        return (ErlFloat d)-      aErlNatural n =-        ErlNatural <$> decrSize n arbitrary-      aErlChar n =-        ErlChar <$> decrSize n (choose (toEnum 0, toEnum 255))-      aErlAtomUnquoted n = do-        f <- choose ('a','z')-        rest <- decrSize n aErlNameString-        return (ErlAtom (f:rest))-      aErlAtomQuoted n = do-        cs <- decrSize n aParsableErlString-        return (ErlAtom ("'" ++ cs ++ "'"))-      aErlBinary n =-        ErlBinary <$> decrSize n (listOf (choose (toEnum 0,toEnum 255)))-      aParsableErlString = oneof [aErlNameString-                                 ,aErlEscapedCharString-                                 ,aErlControlCharString-                                 ,aErlOctalCharString-                                 ,aErlHexCharString]-      aErlNameString = listOf (elements (['a'..'z'] ++ ['A'..'Z']++ ['0'..'9']++"@_"))-      aErlEscapedCharString = elements (("\\"++) . pure <$> "0bdefnrstv\\\"\'")-      aErlControlCharString = elements (("\\^"++) . pure <$> (['a'..'z'] ++ ['A'..'Z']))-      aErlOctalCharString = do-        n <- choose (1,3)-        os <- vectorOf n (choose (0,7))-        return (join ("\\":(show <$> (os::[Int]))))-      aErlHexCharString =-        oneof [twoDigitHex,nDigitHex]-        where-          twoDigitHex = do-            d1 <- choose (0,15) :: Gen Int-            d2 <- choose (0,15) :: Gen Int-            return (printf "\\x%x%X" d1 d2)-          nDigitHex = do-            zs <- listOf (elements "0")-            v <- choose (0,255) :: Gen Int-            return (printf "\\x{%s%x}" zs v)-      aErlList n =-        ErlList <$> resize (n `div` 2) (listOf arbitrary)-      aErlTuple n =-        ErlTuple <$> resize (n `div` 2) (listOf arbitrary)---erlTermParser :: Parser SimpleErlangTerm-erlTermParser = between spaces (char '.') erlTermParser_--erlTermParser_ :: Parser SimpleErlangTerm-erlTermParser_ = erlAtomParser-                 <|> erlCharParser-                 <|> erlStringParser-                 <|> erlBinaryParser-                 <|> erlListParser-                 <|> erlTupleParser-                 <|> try erlFloatParser-                 <|> erlNaturalParser--erlAtomParser :: Parser SimpleErlangTerm-erlAtomParser =-  ErlAtom <$>-  (between (char '\'')-           (char '\'')-           (many (erlCharEscaped <|> noneOf "'"))-   <|>-   ((:) <$> lower <*> many erlNameChar))--erlNameChar :: Parser Char-erlNameChar = alphaNum <|> char '@' <|> char '_'--erlCharParser :: Parser SimpleErlangTerm-erlCharParser = ErlChar <$> (char '$' >> (erlCharEscaped <|> anyChar))--erlFloatParser :: Parser SimpleErlangTerm-erlFloatParser = do-  -- Parse a float as string, then use read :: Double to 'parse' the floating-  -- point value. Calculating by hand is complicated because of precision-  -- issues.-  sign <- option "" ((char '-' >> return "-") <|> (char '+' >> return ""))-  s1 <- many digit-  char '.'-  s2 <- many1 digit-  e <- do expSym <- choice [char 'e', char 'E']-          expSign <- option "" ((char '-' >> return "-") <|> (char '+' >> return "+"))-          expAbs <- many1 digit-          return ([expSym] ++ expSign ++ expAbs)-      <|> return ""-  return (ErlFloat (read (sign ++ s1 ++ "." ++ s2 ++ e)))--erlNaturalParser :: Parser SimpleErlangTerm-erlNaturalParser = do-  sign <- signParser-  dec <- decimalLiteral-  return $ ErlNatural $ sign * dec--signParser :: Parser Integer-signParser =-  (char '-' >> return (-1))-  <|> (char '+' >> return 1)-  <|> return 1--decimalLiteral :: Parser Integer-decimalLiteral =-   foldr (\radix acc ->-            (try (string (show radix ++ "#"))-             >> calcBE (toInteger radix) <$> many1 (erlDigits radix))-            <|> acc)-         (calcBE 10 <$> many1 (erlDigits 10))-         [2..36]-  where-    calcBE a = foldl (\acc d -> a * acc + d) 0-    erlDigits k = choice (take k digitParsers)-    digitParsers =-      -- create parsers that consume/match '0' .. '9' and "aA" .. "zZ" and return 0 .. 35-      map (\(cs,v) -> choice (char <$> cs) >> return v)-          (((pure <$> ['0' .. '9']) ++ zipWith ((++) `on` pure)-                                               ['a' .. 'z']-                                               ['A' .. 'Z'])-           `zip` [0..])--erlStringParser :: Parser SimpleErlangTerm-erlStringParser = do-  char '"'-  str <- many (erlCharEscaped <|> noneOf "\"")-  char '"'-  return (ErlString str)--erlCharEscaped :: Parser Char-erlCharEscaped =-  char '\\'-  >> (do char '^'-         choice (zipWith escapedChar ccodes creplacements)--      <|>-      do char 'x'-         do ds <- between (char '{') (char '}') (fmap hexVal <$> many1 hexDigit)-            let val = foldl (\acc v -> acc * 16 + v) 0 ds-            return (toEnum val)-          <|>-          do x1 <- hexVal <$> hexDigit-             x2 <- hexVal <$> hexDigit;-             return (toEnum ((x1*16)+x2))--      <|>-      do o1 <- octVal <$> octDigit-         do o2 <- octVal <$> octDigit-            do o3 <- octVal <$> octDigit-               return (toEnum ((((o1*8)+o2)*8)+o3))-              <|> return (toEnum ((o1*8)+o2))-          <|> return (toEnum o1)--      <|>-      choice (zipWith escapedChar codes replacements))-  where-    escapedChar code replacement = char code >> return replacement-    codes =-      "0bdefnrstv\\\"'"-    replacements =-      "\NUL\b\DEL\ESC\f\n\r \t\v\\\"'"-    ccodes =-      ['a' .. 'z'] ++ ['A' .. 'Z']-    creplacements =-      cycle ['\^A' .. '\^Z']-    hexVal v | v `elem` ['a' .. 'z'] = 0xA + (fromEnum v - fromEnum 'a')-             | v `elem` ['A' .. 'Z'] = 0xA + (fromEnum v - fromEnum 'A')-             | otherwise = fromEnum v - fromEnum '0'-    octVal = hexVal--erlBinaryParser :: Parser SimpleErlangTerm-erlBinaryParser =-  do string "<<"-     spaces-     ErlString str <- option (ErlString "") erlStringParser-     string ">>"-     spaces-     return (ErlBinary str)--erlListParser :: Parser SimpleErlangTerm-erlListParser = ErlList <$> erlNestedParser (char '[') (char ']')--erlTupleParser :: Parser SimpleErlangTerm-erlTupleParser = ErlTuple <$> erlNestedParser (char '{') (char '}')--erlNestedParser :: Parser a -> Parser b -> Parser [SimpleErlangTerm]-erlNestedParser open close =-  between-    (open >> spaces)-    (close >> spaces)-    (commaSep erlTermParser_)--commaSep :: Parser a -> Parser [a]-commaSep p = do r <- p-                spaces-                rest <- option [] (char ',' >> spaces >> commaSep p)-                return (r:rest)-            <|> return []--arbitraryErlSimpleAtom :: Gen SimpleErlangTerm-arbitraryErlSimpleAtom = ErlAtom <$> ((:)-                                      <$> arbitraryLetterLower-                                      <*> listOf arbitraryErlNameChar)--arbitraryErlString :: Gen SimpleErlangTerm-arbitraryErlString = ErlString <$> listOf (oneof [arbitraryLetter-                                                 ,arbitraryDigit])--arbitraryErlNumber :: Gen SimpleErlangTerm-arbitraryErlNumber = oneof [arbitraryErlNatural, arbitraryErlFloat]--arbitraryErlNatural :: Gen SimpleErlangTerm-arbitraryErlNatural = ErlNatural <$> arbitrary--arbitraryErlFloat :: Gen SimpleErlangTerm-arbitraryErlFloat = ErlFloat <$> arbitrary--arbitraryErlNameChar :: Gen Char-arbitraryErlNameChar = oneof [arbitraryLetter-                             ,arbitraryDigit-                             ,pure '_'-                             ,pure '@']
− src/lib/B9/Content/ErlangPropList.hs 
@@ -1,121 +0,0 @@-{-| A wrapper around erlang and yaml syntax with a proplist-like behaviour in the-    ConcatableSyntax instances -}-module B9.Content.ErlangPropList ( ErlangPropList (..)-                                 ) where--import           Control.Parallel.Strategies-import           Data.Binary-import           Data.Data-import           Data.Function-import           Data.Hashable-import           Data.List (partition,sortBy)-#if !MIN_VERSION_base(4,11,0)-import           Data.Semigroup-#endif-import qualified Data.Text as T-import qualified Data.Text.Encoding as E-import           GHC.Generics (Generic)-import           Text.Printf--import           B9.Content.ErlTerms-import           B9.Content.AST-import           B9.Content.StringTemplate--import           Test.QuickCheck---- | A wrapper type around erlang terms with a Semigroup instance useful for--- combining sys.config files with OTP-application configurations in a list of--- the form of a proplist.-data ErlangPropList =-    ErlangPropList SimpleErlangTerm-    deriving (Read,Eq,Show,Data,Typeable,Generic)--instance Hashable ErlangPropList-instance Binary ErlangPropList-instance NFData ErlangPropList--instance Arbitrary ErlangPropList where-  arbitrary = ErlangPropList <$> arbitrary--instance Semigroup ErlangPropList where-  (ErlangPropList v1) <> (ErlangPropList v2) = ErlangPropList (combine v1 v2)-    where-      combine (ErlList l1) (ErlList l2) =-        ErlList (l1Only <> merged <> l2Only)-        where-          l1Only = l1NonPairs <> l1NotL2-          l2Only = l2NonPairs <> l2NotL1-          (l1Pairs,l1NonPairs) = partition isPair l1-          (l2Pairs,l2NonPairs) = partition isPair l2-          merged = zipWith merge il1 il2-            where-              merge (ErlTuple [_k,pv1]) (ErlTuple [k,pv2]) =-                ErlTuple [k, pv1 `combine` pv2]-              merge _ _ = error "unreachable"-          (l1NotL2, il1, il2, l2NotL1) =-            partitionByKey l1Sorted l2Sorted ([],[],[],[])-            where-              partitionByKey [] ys  (exs,cxs,cys,eys) =-                (reverse exs,reverse cxs,reverse cys,reverse eys <> ys)--              partitionByKey xs []  (exs,cxs,cys,eys) =-                (reverse exs <> xs,reverse cxs,reverse cys,reverse eys)--              partitionByKey (x:xs) (y:ys) (exs,cxs,cys,eys)-                | equalKey x y = partitionByKey xs ys (exs,x:cxs,y:cys,eys)-                | x `keyLessThan` y = partitionByKey xs (y:ys) (x:exs,cxs,cys,eys)-                | otherwise = partitionByKey (x:xs) ys (exs,cxs,cys,y:eys)--              l1Sorted = sortByKey l1Pairs-              l2Sorted = sortByKey l2Pairs--          sortByKey = sortBy (compare `on` getKey)-          keyLessThan = (<) `on` getKey-          equalKey = (==) `on` getKey-          getKey (ErlTuple (x:_)) = x-          getKey x = x-          isPair (ErlTuple [_,_]) = True-          isPair _ = False--      combine (ErlList pl1) t2 = ErlList (pl1 <> [t2])-      combine t1 (ErlList pl2) = ErlList ([t1] <> pl2)-      combine t1 t2 = ErlList [t1,t2]--instance ConcatableSyntax ErlangPropList where-  decodeSyntax src str = do-    t <- parseErlTerm src str-    return (ErlangPropList t)--  encodeSyntax (ErlangPropList t)  = renderErlTerm t--instance ASTish ErlangPropList where-    fromAST (AST a) = pure a-    fromAST (ASTObj pairs) = ErlangPropList . ErlList <$> mapM makePair pairs-      where-        makePair (k,ast) = do-            (ErlangPropList second) <- fromAST ast-            return $ ErlTuple [ErlAtom k, second]-    fromAST (ASTArr xs) =-        ErlangPropList . ErlList <$>-        mapM-            (\x ->-                  do (ErlangPropList x') <- fromAST x-                     return x')-            xs-    fromAST (ASTString s) = pure $ ErlangPropList $ ErlString s-    fromAST (ASTInt i) = pure $ ErlangPropList $ ErlString (show i)-    fromAST (ASTEmbed c) =-        ErlangPropList . ErlString . T.unpack . E.decodeUtf8 <$> render c-    fromAST (ASTMerge []) =-        error "ASTMerge MUST NOT be used with an empty list!"-    fromAST (ASTMerge asts) = foldl1 (<>) <$> mapM fromAST asts-    fromAST (ASTParse src@(Source _ srcPath)) = do-        c <- readTemplateFile src-        case decodeSyntax srcPath c of-            Right s -> return s-            Left e ->-                error-                    (printf-                         "could not parse erlang source file: '%s'\n%s\n"-                         srcPath-                         e)
− src/lib/B9/Content/Generator.hs 
@@ -1,77 +0,0 @@-{-| The basic data structure that ties together syntax trees making them-    composable and addressable in B9 artifacts. -}-module B9.Content.Generator where--import           Control.Parallel.Strategies-import           Data.Binary-import           Data.Data-import           Data.Hashable-import           Control.Monad.Trans (lift)-import           GHC.Generics (Generic)-#if !MIN_VERSION_base(4,8,0)-import           Control.Applicative-#endif--import           B9.B9Monad-import           Control.Monad.IO.Class-import           System.Exit-import           B9.Content.AST-import           B9.Content.ErlangPropList-import           B9.Content.StringTemplate-import           B9.Content.YamlObject-import qualified Data.ByteString.Base64 as B64-import qualified Data.ByteString.Char8 as B-import qualified Data.ByteString as BS--import           Test.QuickCheck-import           B9.QCUtil--import           System.Process--data Content-    = RenderErlang (AST Content ErlangPropList)-    | RenderYaml (AST Content YamlObject)-    | FromString String-    | FromTextFile SourceFile-    -- | The data in the given file will be base64 encoded.-    | RenderBase64BinaryFile FilePath-    -- | This data will be base64 encoded.-    | RenderBase64Binary B.ByteString-    | FromURL String-    deriving (Read,Show,Typeable,Eq,Data,Generic)--instance Hashable Content-instance Binary Content-instance NFData Content--instance Arbitrary Content where-  arbitrary = oneof [FromTextFile <$> smaller arbitrary-                    ,RenderBase64BinaryFile <$> smaller arbitrary-                    ,RenderErlang <$> smaller arbitrary-                    ,RenderYaml <$> smaller arbitrary-                    ,FromString <$> smaller arbitrary-                    ,RenderBase64Binary . BS.pack <$> smaller arbitrary-                    ,FromURL <$> smaller arbitrary]--instance CanRender Content where-  render (RenderErlang ast) = encodeSyntax <$> fromAST ast-  render (RenderYaml ast) = encodeSyntax <$> fromAST ast-  render (FromTextFile s) = readTemplateFile s-  render (RenderBase64BinaryFile s) = readBinaryFileAsBase64 s-    where-      -- | Read a binary file and encode it as base64-      readBinaryFileAsBase64 :: MonadIO m => FilePath -> m B.ByteString-      readBinaryFileAsBase64 f = B64.encode <$> liftIO (B.readFile f)--  render (RenderBase64Binary b) = return (B64.encode b)-  render (FromString str) = return (B.pack str)-  render (FromURL url) = lift $ do-     dbgL $ "Downloading: " ++ url-     (exitcode,out,err) <- liftIO $ readProcessWithExitCode "curl" [url] ""-     if exitcode == ExitSuccess then-       do dbgL $ "Download finished. Bytes read: " ++ show (length out)-          traceL $ "Downloaded (truncated to first 4K): \n\n" ++ take 4096 out ++ "\n\n"-          return $ B.pack out-      else-        do errorL $ "Download failed: " ++ err-           liftIO $ exitWith exitcode
− src/lib/B9/Content/StringTemplate.hs 
@@ -1,166 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-| Utility functions based on 'Data.Text.Template' to offer @ $var @ variable-    expansion in string throughout a B9 artifact. -}-module B9.Content.StringTemplate-       (subst, substE, substEB, substFile, substPath, readTemplateFile,-        SourceFile(..), SourceFileConversion(..), Environment(..),-        withEnvironment)-       where--#if !MIN_VERSION_base(4,8,0)-import           Control.Applicative-#endif-import           Control.Arrow hiding (second)-import           Control.Monad.Reader-import           Data.Bifunctor-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as LB-import           Control.Parallel.Strategies-import           GHC.Generics (Generic)-import           Data.Binary-import           Data.Data-import           Data.Hashable-import           Data.Maybe-import qualified Data.Text as T-import           Data.Text.Encoding as E-import           Data.Text.Lazy.Encoding as LE-import           Data.Text.Template (render,templateSafe,renderA)-import           System.IO.B9Extras-import           Test.QuickCheck-import           Text.Printf-import           Text.Show.Pretty (ppShow)-import           B9.QCUtil--- | A wrapper around a file path and a flag indicating if template variable--- expansion should be performed when reading the file contents.-data SourceFile =-    Source SourceFileConversion-           FilePath-    deriving (Read,Show,Typeable,Data,Eq,Generic)--instance Hashable SourceFile-instance Binary SourceFile-instance NFData SourceFile--data SourceFileConversion-    = NoConversion-    | ExpandVariables-    deriving (Read,Show,Typeable,Data,Eq,Generic)--instance Hashable SourceFileConversion-instance Binary SourceFileConversion-instance NFData SourceFileConversion--newtype Environment =-    Environment [(String, String)]-    deriving (Read,Show,Typeable,Data,Eq,NFData,Hashable,Binary)--withEnvironment :: [(String,String)] -> ReaderT Environment m a -> m a-withEnvironment env action = runReaderT action (Environment env)--readTemplateFile :: (MonadIO m, MonadReader Environment m)-                 => SourceFile -> m B.ByteString-readTemplateFile (Source conv f') = do-  Environment env <- ask-  case substE env f' of-    Left e ->-      error (printf "Failed to substitute templates in source \-                    \file name '%s'/\nError: %s\n"-                    f' e)-    Right f -> do-      c <- liftIO (B.readFile f)-      convert f c--  where-    convert f c = case conv of-                    NoConversion -> return c-                    ExpandVariables -> do-                      Environment env <- ask-                      case substEB env c of-                        Left e ->-                          error (printf "readTemplateFile '%s' failed: \n%s\n"-                                         f-                                         e)-                        Right c' ->-                          return c'----- String template substitution via dollar-subst :: [(String,String)] -> String -> String-subst env templateStr =-  case substE env templateStr of-    Left e -> error e-    Right r -> r---- String template substitution via dollar-substE :: [(String,String)] -> String -> Either String String-substE env templateStr =-  second (T.unpack . E.decodeUtf8)-         (substEB env (E.encodeUtf8 (T.pack templateStr)))---- String template substitution via dollar-substEB :: [(String,String)] -> B.ByteString -> Either String B.ByteString-substEB env templateStr = do-  t <- template'-  res <- renderA t env'-  return (LB.toStrict (LE.encodeUtf8 res))-  where-    env' t = case lookup (T.unpack t) env of-               Just v -> Right (T.pack v)-               Nothing -> Left ("Invalid template parameter: \""-                                ++ T.unpack t ++ "\" in: \""-                                ++ show templateStr-                                ++ "\".\nValid variables:\n" ++ ppShow env)--    template' = case templateSafe (E.decodeUtf8 templateStr) of-      Left (row,col) -> Left ("Invalid template, error at row: "-                             ++ show row ++ ", col: " ++ show col-                             ++ " in: \"" ++ show templateStr)-      Right t -> Right t---substFile :: MonadIO m => [(String, String)] -> FilePath -> FilePath -> m ()-substFile assocs src dest = do-    templateBs <- liftIO (B.readFile src)-    let t = templateSafe (E.decodeUtf8 templateBs)-    case t of-        Left (r,c) ->-            let badLine =-                    unlines-                        (take r (lines (T.unpack (E.decodeUtf8 templateBs))))-                colMarker = replicate (c - 1) '-' ++ "^"-            in error-                   (printf-                        "Template error in file '%s' line %i:\n\n%s\n%s\n"-                        src-                        r-                        badLine-                        colMarker)-        Right template' -> do-            let out = LE.encodeUtf8 (render template' envLookup)-            liftIO (LB.writeFile dest out)-            return ()-  where-    envT :: [(T.Text, T.Text)]-    envT = (T.pack *** T.pack) <$> assocs-    envLookup :: T.Text -> T.Text-    envLookup x = fromMaybe (err x) (lookup x envT)-    err x =-        error-            (printf-                 "Invalid template parameter: '%s'\nIn file: '%s'\n Valid variables:\n%s\n"-                 (T.unpack x)-                 src-                 (ppShow assocs))--substPath :: [(String, String)] -> SystemPath -> SystemPath-substPath assocs src =-          case src of-            Path p -> Path (subst assocs p)-            InHomeDir p -> InHomeDir (subst assocs p)-            InB9UserDir p -> InB9UserDir (subst assocs p)-            InTempDir p -> InTempDir (subst assocs p)---instance Arbitrary SourceFile where-  arbitrary = Source <$> elements [NoConversion, ExpandVariables]-                     <*> smaller arbitraryFilePath
− src/lib/B9/Content/YamlObject.hs 
@@ -1,132 +0,0 @@-{-| A wrapper around erlang and yaml syntax with a proplist-like behaviour in-    the ConcatableSyntax instances -}-module B9.Content.YamlObject ( YamlObject (..)-                             ) where--import           Control.Applicative-import           Control.Parallel.Strategies-import           Data.Binary (Binary(..))-import           Data.Data-import           Data.Function-import           Data.HashMap.Strict hiding (singleton)-import           Data.Hashable-import           Data.Maybe-import           Data.Semigroup-import qualified Data.Text as T-import qualified Data.Text.Encoding as E-import           Data.Vector ((++), singleton)-import           Data.Yaml-import           GHC.Generics (Generic)-import           Prelude hiding ((++))-import           Text.Printf--import           B9.Content.AST-import           B9.Content.StringTemplate--import           Test.QuickCheck---- | A wrapper type around yaml values with a Semigroup instance useful for--- combining yaml documents describing system configuration like e.g. user-data.-data YamlObject =-    YamlObject {_fromYamlObject :: Data.Yaml.Value}-    deriving (Eq,Data,Typeable,Generic)--instance Hashable YamlObject-instance NFData YamlObject--instance Binary YamlObject where-  put = put . encode . _fromYamlObject-  get = do-    v <- get-    return $ YamlObject $ fromJust $ decodeThrow v--instance Read YamlObject where-  readsPrec _ = readsYamlObject-    where-      readsYamlObject :: ReadS YamlObject-      readsYamlObject s =-        [ (yamlFromString y, r2) | ("YamlObject", r1) <- lex s,-                                   (y,r2)             <- reads r1]-        where-          yamlFromString :: String -> YamlObject-          yamlFromString =-            either error id . decodeSyntax "HERE-DOC" . E.encodeUtf8 . T.pack--instance Show YamlObject where-  show (YamlObject o) =-    "YamlObject " <> show (T.unpack $ E.decodeUtf8 $ encode o)--instance Semigroup YamlObject where--  (YamlObject v1) <> (YamlObject v2) = YamlObject (combine v1 v2)-    where-      combine :: Data.Yaml.Value-              -> Data.Yaml.Value-              -> Data.Yaml.Value-      combine (Object o1) (Object o2) =-        Object (unionWith combine o1 o2)-      combine (Array a1) (Array a2) =-        Array (a1 ++ a2)-      combine (Array a1) t2 =-        Array (a1 ++ singleton t2)-      combine t1 (Array a2) =-        Array (singleton t1 ++ a2)-      combine (String s1) (String s2) = String (s1 <> s2)-      combine t1 t2 =-        array [t1,t2]--instance ConcatableSyntax YamlObject where-  decodeSyntax src str =-    case decodeEither str of-      Left e ->-        Left (printf "YamlObject parse error in file '%s':\n%s\n"-                      src-                      e)-      Right o ->-        return (YamlObject o)--  encodeSyntax (YamlObject o) =-    E.encodeUtf8 (T.pack "#cloud-config\n") <> encode o--instance ASTish YamlObject where-    fromAST ast =-        case ast of-            ASTObj pairs -> do-                ys <- mapM fromASTPair pairs-                return (YamlObject (object ys))-            ASTArr asts -> do-                ys <- mapM fromAST asts-                let ys' =-                        (\(YamlObject o) ->-                              o) <$>-                        ys-                return (YamlObject (array ys'))-            ASTMerge [] ->-                error "ASTMerge MUST NOT be used with an empty list!"-            ASTMerge asts -> do-                ys <- mapM fromAST asts-                return (foldl1 (<>) ys)-            ASTEmbed c ->-                YamlObject . toJSON . T.unpack . E.decodeUtf8 <$> render c-            ASTString str -> return (YamlObject (toJSON str))-            ASTInt int -> return (YamlObject (toJSON int))-            ASTParse src@(Source _ srcPath) -> do-                c <- readTemplateFile src-                case decodeSyntax srcPath c of-                    Right s -> return s-                    Left e ->-                        error-                            (printf-                                 "could not parse yaml source file: '%s'\n%s\n"-                                 srcPath-                                 e)-            AST a -> pure a-      where-        fromASTPair (key,value) = do-            (YamlObject o) <- fromAST value-            let key' = T.pack key-            return $ key' .= o---instance Arbitrary YamlObject where-  arbitrary = pure (YamlObject Null)
− src/lib/B9/DSL.hs 
@@ -1,348 +0,0 @@--- | Experimental new, hopefully typesafe. domain specific language for---   description of VM-builds.-{-# LANGUAGE FlexibleInstances #-}-module B9.DSL-       (B9DSL, doc, doc', (#), Documentation(..), ($=), include, includeTemplate, writeContent,-        exportCloudInit, imageSource, createImage, importImage, from,-        fromResized, imageDestination, share, exportLiveInstallerImage,-        exportImage, mount, lxc, lxc32, boot, exec, sh, rootImage,-        dataImage, mountAndShareSharedImage, mountAndShareNewImage, runDSL,-        printDSL, printBuildStep, dslExample)-       where--import B9.ArtifactGenerator (ArtifactSource(..), CloudInitType(..))-import B9.B9Config (ExecEnvType(..))-import B9.Content.Generator(Content)-import B9.Content.StringTemplate-       (SourceFile(..), SourceFileConversion(..))-import B9.DiskImages-       (Image(..), ImageSource(..), ImageDestination(..), FileSystem(..),-        Partition(..), ImageResize(..), ImageSize(..), ImageType(..),-        SizeUnit(..))-import B9.ExecEnv (CPUArch(..))-import B9.ShellScript (Script(..))-#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-import Data.Monoid-import Control.Monad-#endif-import Control.Monad.Free (Free(..), liftF, foldFree)-import Data.Functor (void)-import Text.Printf (printf)--data BuildStep next :: * where-        Let :: String -> String -> next -> BuildStep next-        Import ::-          SArtifact a -> Source a -> (Imported a -> next) -> BuildStep next-        Export :: SArtifact a -> Target a -> next -> BuildStep next-        DefineExecEnv ::-          String ->-            ExecEnvType -> CPUArch -> (ExecEnv -> next) -> BuildStep next-        Exec :: ExecEnv -> Script -> next -> BuildStep next--instance Functor BuildStep where-    fmap f (Let k v next) = Let k v (f next)-    fmap f (Import sa src k) = Import sa src (f . k)-    fmap f (Export sa dst next) = Export sa dst (f next)-    fmap f (DefineExecEnv n et a k) = DefineExecEnv n et a (f . k)-    fmap f (Exec et s next) = Exec et s (f next)--type B9DSL a = Free BuildStep a--data Tagged a b =-    Tagged b--instance Show b => Show (Tagged a b) where-    show (Tagged s) = show s--data Documentation-    = Doc String-    | DocIncluded Content--data ExecEnv =-    ExecEnv String-            ExecEnvType-            CPUArch-    deriving (Show)--type family Source (a :: Artifact) :: * where-        Source 'StaticContent = ArtifactSource-        Source 'VmImage = ImageSource-        Source 'MountedImage = (ExecEnv, Tagged ImageSource String, FilePath)-        Source 'MountedHostDirectory = (ExecEnv, FilePath, FilePath, MountOpts String)-        Source 'SelfDocumentation = Documentation--type family Imported (a :: Artifact) :: * where-        Imported 'VmImage = Tagged ImageSource String-        Imported a = ()--type family Target (a :: Artifact) :: * where-        Target 'VmImage = (Tagged ImageSource String, ImageDestination)-        Target 'CloudInit = ([CloudInitType], FilePath)--data Artifact-    = StaticContent-    | VmImage-    | MountedImage-    | CloudInit-    | MountedHostDirectory-    | SelfDocumentation--data SArtifact (k :: Artifact) where-        SStaticContent :: SArtifact 'StaticContent-        SVmImage :: SArtifact 'VmImage-        SMountedImage :: SArtifact 'MountedImage-        SCloudInit :: SArtifact 'CloudInit-        SMountedHostDirectory :: SArtifact 'MountedHostDirectory-        SSelfDocumentation :: SArtifact 'SelfDocumentation---- * For documentation of the actual build/deployment itself either embed a---   string or a file, template parameters e.g. ${xxx} can be also used.--doc :: String -> B9DSL ()-doc str = liftF $ Import SSelfDocumentation (Doc str) id--doc' :: Content -> B9DSL ()-doc' c = liftF $ Import SSelfDocumentation (DocIncluded c) id--(#) :: B9DSL a -> String -> B9DSL a-m # str = do-  doc str-  m---- * Content generation and static file inclusion--($=) :: String -> String -> B9DSL ()-var $= val = liftF $ Let var val ()---- TODO split file inclusion from file content generation. i.e. add newFile--- ... and then add an 'appendFile' function. new file should be typed according--- to its contents so that only compatible content can be appended--include :: FilePath -> FilePath -> B9DSL ()-include dest src = liftF $ Import SStaticContent (FromFile dest (Source NoConversion src)) id--includeTemplate :: FilePath -> FilePath -> B9DSL ()-includeTemplate dest src = liftF $ Import SStaticContent (FromFile dest (Source ExpandVariables src)) id--writeContent :: FilePath -> Content -> B9DSL ()-writeContent dst src = liftF $ Import SStaticContent (FromContent dst src) id---- * cloud init--exportCloudInit :: FilePath -> B9DSL ()-exportCloudInit dst = liftF $ Export SCloudInit ([CI_ISO, CI_DIR], dst) ()---- * Image import--imageSource :: ImageSource -> B9DSL (Imported 'VmImage)-imageSource src = liftF $ Import SVmImage src id--createImage :: String-           -> FileSystem-           -> ImageType-           -> ImageSize-           -> B9DSL (Imported 'VmImage)-createImage s fs it is = imageSource $ EmptyImage s fs it is--importImage :: FilePath-             -> ImageType-             -> FileSystem-             -> Partition-             -> ImageResize-             -> B9DSL (Imported 'VmImage)-importImage f it fs pt is = imageSource $ SourceImage (Image f it fs) pt is--from :: String -> B9DSL (Imported 'VmImage)-from = fromResized KeepSize--fromResized :: ImageResize -> String -> B9DSL (Imported 'VmImage)-fromResized r s = imageSource $ From s r---- * Image export--imageDestination :: Imported 'VmImage-                 -> ImageDestination-                 -> B9DSL ()-imageDestination img dst = liftF $ Export SVmImage (img, dst) ()--share :: Imported 'VmImage -> String -> B9DSL ()-share img name = imageDestination img $ Share name QCow2 KeepSize--exportLiveInstallerImage :: Imported 'VmImage-                         -> String-                         -> FilePath-                         -> ImageResize-                         -> B9DSL ()-exportLiveInstallerImage img imgName outDir resize =-    imageDestination img $ LiveInstallerImage imgName outDir resize--exportImage :: Imported 'VmImage-            -> FilePath-            -> ImageType-            -> FileSystem-            -> ImageResize-            -> B9DSL ()-exportImage img name it fs resize =-    imageDestination img $ LocalFile (Image name it fs) resize---- * Mounting--class DSLCanMount a  where-    type MountArtifact a :: Artifact-    data MountOpts a-    defaultMountOpts :: a -> MountOpts a-    mountArtifactS :: a -> SArtifact (MountArtifact a)-    mountArtifact :: MountOpts a-                  -> ExecEnv-                  -> a-                  -> FilePath-                  -> Source (MountArtifact a)---- * Host directory-instance DSLCanMount String where-  type MountArtifact String = 'MountedHostDirectory-  data MountOpts String = ReadOnly | ReadWrite deriving Show-  defaultMountOpts _ = ReadOnly-  mountArtifactS _ = SMountedHostDirectory-  mountArtifact opts e src dest = (e, src, dest, opts)--instance DSLCanMount (Tagged ImageSource String) where-  type MountArtifact (Tagged ImageSource String) = 'MountedImage-  data MountOpts (Tagged ImageSource String) = MountImgNoOptions deriving Show-  defaultMountOpts _ = MountImgNoOptions-  mountArtifactS _ = SMountedImage-  mountArtifact _opts e src dest = (e, src, dest)--mount-    :: DSLCanMount src-    => ExecEnv -> src -> FilePath -> B9DSL (Imported (MountArtifact src))-mount = mount' (defaultMountOpts undefined)--mount'-    :: DSLCanMount src-    => MountOpts src-    -> ExecEnv-    -> src-    -> FilePath-    -> B9DSL (Imported (MountArtifact src))-mount' mopts e src dest =-    liftF $-    Import-        (mountArtifactS src)-        (mountArtifact mopts e src dest)-        id---- * Execution environment--lxc :: String -> B9DSL ExecEnv-lxc name = boot name LibVirtLXC X86_64--lxc32 :: String -> B9DSL ExecEnv-lxc32 name = boot name LibVirtLXC I386--boot :: String -> ExecEnvType -> CPUArch -> B9DSL ExecEnv-boot name et arch = liftF $ DefineExecEnv name et arch id---- * Script Execution (inside a container)--exec :: Script -> ExecEnv -> B9DSL ()-exec script e = liftF $ Exec e script ()--sh :: String -> ExecEnv -> B9DSL ()-sh s = exec (Run s [])---- TODO generalize exec to work with 'includedFiles'---- * Some utility vm builder lego--rootImage :: String -> String -> ExecEnv -> B9DSL ()-rootImage nameFrom nameExport env =-    void $ mountAndShareSharedImage nameFrom nameExport "/" env--dataImage :: String -> ExecEnv -> B9DSL ()-dataImage nameExport env =-    void $ mountAndShareNewImage "data" 64 nameExport "/data" env--mountAndShareSharedImage :: String -> String -> String -> ExecEnv -> B9DSL (Imported 'VmImage)-mountAndShareSharedImage nameFrom nameExport mountPoint env = do-    img <- from nameFrom-    share img nameExport-    mount env img mountPoint-    return img--mountAndShareNewImage :: String -> Int -> String -> FilePath -> ExecEnv -> B9DSL (Imported 'VmImage)-mountAndShareNewImage fsLabel sizeGB nameExport mountPoint env = do-    img <- createImage fsLabel Ext4 QCow2 (ImageSize sizeGB GB)-    share img nameExport-    mount env img mountPoint-    return img---- * DSL Interpreter--#if MIN_VERSION_base(4,8,0)-runDSL-    :: Monad m-    => (forall a. BuildStep a -> m a) -> B9DSL b -> m b-#else-runDSL-    :: (Monad m, Functor m)-    => (forall a. BuildStep a -> m a) -> B9DSL b -> m b-#endif-runDSL = foldFree---- | Print the DSL to IO-printDSL :: B9DSL a -> IO ()-printDSL = void . runDSL printBuildStep--printBuildStep :: BuildStep a -> IO a-printBuildStep (Let k v next) = do-    printf "%s := %s\n" k v-    return next-printBuildStep (Import SStaticContent src k) = do-    printf "import static %s\n" (show src)-    return $ k ()-printBuildStep (Import SVmImage src k) = do-    printf "import image %s\n" (show src)-    return (k (Tagged (show src)))-printBuildStep (Import SMountedImage src k) = do-    printf "mount image %s\n" (show src)-    return (k ())-printBuildStep (Import SMountedHostDirectory src k) = do-    printf "mount host directory %s\n" (show src)-    return (k ())-printBuildStep (Import SSelfDocumentation (Doc str) k) = do-    printf "-- %s\n" str-    return (k ())-printBuildStep (Import SSelfDocumentation (DocIncluded c) k) = do-    printf "-- %s\n" (show c)-    return (k ())-printBuildStep (Export SVmImage dst next) = do-    printf "export image %s\n" (show dst)-    return next-printBuildStep (Export SCloudInit dst next) = do-    printf "export cloud-init %s\n" (show dst)-    return next-printBuildStep (DefineExecEnv n et a k) = do-    printf "define env: %s %s %s\n" n (show et) (show a)-    return (k (ExecEnv n et a))-printBuildStep (Exec (ExecEnv n _ _) s next) = do-    printf "exec in %s: %s\n" n (show s)-    return next-printBuildStep _other = do-    printf "???\n"-    return undefined---- * Tests and experiments--dslExample :: B9DSL ()-dslExample = do-    "x" $= "3"-    includeTemplate "httpd.conf" "httpd.conf.in" # "overwrite all of httpd!"-    exportCloudInit "blah-ci"                    # "export the cloud-init stuff"-    e <- lxc "container-id"-    doc "From here there be dragons:"-    mount e "/tmp" "/mnt/HOST_TMP"-    rootImage "fedora" "testv1-root" e-    dataImage "testv1-data" e-    sh "ls -la" e
src/lib/B9/DiskImageBuilder.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-}+ {-| Effectful functions that create and convert disk image files. -} module B9.DiskImageBuilder   ( materializeImageSource@@ -21,36 +22,31 @@   , getSelectedRepos   , pullRemoteRepos   , pullLatestImage-  )-where+  ) where -import           System.IO.Error                ( isDoesNotExistError )-import           System.Directory               ( removeFile )-import           System.IO.B9Extras             ( ensureDir-                                                , prettyPrintToFile-                                                , consult-                                                )-import           Control.Lens                   ( (^.) )-import           Control.Exception-import           Control.Monad-import           Control.Monad.IO.Class-import           System.Directory-import           System.FilePath-import           Text.Printf                    ( printf )-import           Data.Maybe-import           Data.Function-import           Text.Show.Pretty               ( ppShow )-import           Data.List-import           Data.Data-import           Data.Generics.Schemes-import           Data.Generics.Aliases-import           B9.B9Monad-import           B9.B9Config-import           B9.Repository-import           B9.RepositoryIO-import           B9.DiskImages-import qualified B9.PartitionTable             as P-import           B9.Content.StringTemplate+import B9.B9Config+import B9.B9Monad+import B9.Artifact.Content.StringTemplate+import B9.DiskImages+import qualified B9.PartitionTable as P+import B9.Repository+import B9.RepositoryIO+import Control.Exception+import Control.Lens ((^.))+import Control.Monad+import Control.Monad.IO.Class+import Data.Data+import Data.Function+import Data.Generics.Aliases+import Data.Generics.Schemes+import Data.List+import Data.Maybe+import System.Directory+import System.FilePath+import System.IO.B9Extras (consult, ensureDir, prettyPrintToFile)+import System.IO.Error (isDoesNotExistError)+import Text.Printf (printf)+import Text.Show.Pretty (ppShow)  -- -- | Convert relative file paths of images, sources and mounted host directories -- -- to absolute paths relative to '_buildDirRoot'.@@ -60,81 +56,69 @@ --   where --     go rootDir = everywhere mkAbs img --       where mkAbs = mkT- -- | Replace $... variables inside an 'ImageTarget'-substImageTarget :: [(String, String)] -> ImageTarget -> ImageTarget+substImageTarget :: Environment -> ImageTarget -> ImageTarget substImageTarget env = everywhere gsubst- where-  gsubst :: Data a => a -> a-  gsubst =-    mkT substMountPoint-      `extT` substImage-      `extT` substImageSource-      `extT` substDiskTarget--  substMountPoint NotMounted     = NotMounted-  substMountPoint (MountPoint x) = MountPoint (sub x)--  substImage (Image fp t fs) = Image (sub fp) t fs--  substImageSource (From n s          ) = From (sub n) s-  substImageSource (EmptyImage l f t s) = EmptyImage (sub l) f t s-  substImageSource s                    = s--  substDiskTarget (Share n t s) = Share (sub n) t s-  substDiskTarget (LiveInstallerImage name outDir resize) =-    LiveInstallerImage (sub name) (sub outDir) resize-  substDiskTarget s = s--  sub = subst env+  where+    gsubst :: Data a => a -> a+    gsubst = mkT substMountPoint `extT` substImage `extT` substImageSource `extT` substDiskTarget+    substMountPoint NotMounted = NotMounted+    substMountPoint (MountPoint x) = MountPoint (sub x)+    substImage (Image fp t fs) = Image (sub fp) t fs+    substImageSource (From n s) = From (sub n) s+    substImageSource (EmptyImage l f t s) = EmptyImage (sub l) f t s+    substImageSource s = s+    substDiskTarget (Share n t s) = Share (sub n) t s+    substDiskTarget (LiveInstallerImage name outDir resize) = LiveInstallerImage (sub name) (sub outDir) resize+    substDiskTarget s = s+    sub = subst env  -- | Resolve an ImageSource to an 'Image'. The ImageSource might -- not exist, as is the case for 'EmptyImage'. resolveImageSource :: ImageSource -> B9 Image-resolveImageSource src = case src of-  (EmptyImage fsLabel fsType imgType _size) ->-    let img = Image fsLabel imgType fsType-    in  return (changeImageFormat imgType img)-  (SourceImage srcImg _part _resize) -> ensureAbsoluteImageDirExists srcImg-  (CopyOnWrite backingImg          ) -> ensureAbsoluteImageDirExists backingImg-  (From name _resize) ->-    getLatestImageByName (SharedImageName name)-      >>= maybe-            (errorExitL-              (printf "Nothing found for %s." (show (SharedImageName name)))-            )-            ensureAbsoluteImageDirExists+resolveImageSource src =+  case src of+    (EmptyImage fsLabel fsType imgType _size) ->+      let img = Image fsLabel imgType fsType+       in return (changeImageFormat imgType img)+    (SourceImage srcImg _part _resize) -> ensureAbsoluteImageDirExists srcImg+    (CopyOnWrite backingImg) -> ensureAbsoluteImageDirExists backingImg+    (From name _resize) ->+      getLatestImageByName (SharedImageName name) >>=+      maybe (errorExitL (printf "Nothing found for %s." (show (SharedImageName name)))) ensureAbsoluteImageDirExists  -- | Return all valid image types sorted by preference. preferredDestImageTypes :: ImageSource -> B9 [ImageType]-preferredDestImageTypes src = case src of-  (CopyOnWrite (Image _file fmt _fs)) -> return [fmt]-  (EmptyImage _label NoFileSystem fmt _size) ->-    return (nub [fmt, Raw, QCow2, Vmdk])-  (EmptyImage _label _fs _fmt _size                       ) -> return [Raw]-  (SourceImage _img                  (Partition _) _resize) -> return [Raw]-  (SourceImage (Image _file fmt _fs) _pt           resize ) -> return-    (nub [fmt, Raw, QCow2, Vmdk] `intersect` allowedImageTypesForResize resize)-  (From name resize) -> getLatestImageByName (SharedImageName name) >>= maybe-    (errorExitL (printf "Nothing found for %s." (show (SharedImageName name))))-    (\sharedImg -> preferredDestImageTypes (SourceImage sharedImg NoPT resize))+preferredDestImageTypes src =+  case src of+    (CopyOnWrite (Image _file fmt _fs)) -> return [fmt]+    (EmptyImage _label NoFileSystem fmt _size) -> return (nub [fmt, Raw, QCow2, Vmdk])+    (EmptyImage _label _fs _fmt _size) -> return [Raw]+    (SourceImage _img (Partition _) _resize) -> return [Raw]+    (SourceImage (Image _file fmt _fs) _pt resize) ->+      return (nub [fmt, Raw, QCow2, Vmdk] `intersect` allowedImageTypesForResize resize)+    (From name resize) ->+      getLatestImageByName (SharedImageName name) >>=+      maybe+        (errorExitL (printf "Nothing found for %s." (show (SharedImageName name))))+        (\sharedImg -> preferredDestImageTypes (SourceImage sharedImg NoPT resize))  -- | Return all supported source 'ImageType's compatible to a 'ImageDestinaion' -- in the preferred order. preferredSourceImageTypes :: ImageDestination -> [ImageType]-preferredSourceImageTypes dest = case dest of-  (Share _ fmt resize) ->-    nub [fmt, Raw, QCow2, Vmdk] `intersect` allowedImageTypesForResize resize-  (LocalFile (Image _ fmt _) resize) ->-    nub [fmt, Raw, QCow2, Vmdk] `intersect` allowedImageTypesForResize resize-  Transient -> [Raw, QCow2, Vmdk]-  (LiveInstallerImage _name _repo _imgResize) -> [Raw]+preferredSourceImageTypes dest =+  case dest of+    (Share _ fmt resize) -> nub [fmt, Raw, QCow2, Vmdk] `intersect` allowedImageTypesForResize resize+    (LocalFile (Image _ fmt _) resize) -> nub [fmt, Raw, QCow2, Vmdk] `intersect` allowedImageTypesForResize resize+    Transient -> [Raw, QCow2, Vmdk]+    (LiveInstallerImage _name _repo _imgResize) -> [Raw]  allowedImageTypesForResize :: ImageResize -> [ImageType]-allowedImageTypesForResize r = case r of-  Resize _        -> [Raw]-  ShrinkToMinimum -> [Raw]-  _               -> [Raw, QCow2, Vmdk]+allowedImageTypesForResize r =+  case r of+    Resize _ -> [Raw]+    ShrinkToMinimum -> [Raw]+    _ -> [Raw, QCow2, Vmdk]  -- | Create the parent directories for the file that contains the 'Image'. -- If the path to the image file is relative, prepend '_buildDirRoot' from@@ -144,12 +128,10 @@   b9cfg <- getConfig   let dir =         let dirRel = takeDirectory path-        in  if isRelative dirRel-              then-                let prefix = fromMaybe "." (b9cfg ^. buildDirRoot)-                in  prefix </> dirRel+         in if isRelative dirRel+              then let prefix = fromMaybe "." (b9cfg ^. buildDirRoot)+                    in prefix </> dirRel               else dirRel-   liftIO $ do     createDirectoryIfMissing True dir     dirAbs <- canonicalizePath dir@@ -159,112 +141,94 @@ -- compatible image type and filesystem. The directory of the image MUST be -- present and the image file itself MUST NOT alredy exist. materializeImageSource :: ImageSource -> Image -> B9 ()-materializeImageSource src dest = case src of-  (EmptyImage fsLabel fsType _imgType size) ->-    let (Image _ imgType _) = dest-    in  createEmptyImage fsLabel fsType imgType size dest-  (SourceImage srcImg part resize) ->-    createImageFromImage srcImg part resize dest-  (CopyOnWrite backingImg) -> createCOWImage backingImg dest-  (From name resize) -> getLatestImageByName (SharedImageName name) >>= maybe-    (errorExitL (printf "Nothing found for %s." (show (SharedImageName name))))-    (\sharedImg ->-      materializeImageSource (SourceImage sharedImg NoPT resize) dest-    )+materializeImageSource src dest =+  case src of+    (EmptyImage fsLabel fsType _imgType size) ->+      let (Image _ imgType _) = dest+       in createEmptyImage fsLabel fsType imgType size dest+    (SourceImage srcImg part resize) -> createImageFromImage srcImg part resize dest+    (CopyOnWrite backingImg) -> createCOWImage backingImg dest+    (From name resize) ->+      getLatestImageByName (SharedImageName name) >>=+      maybe+        (errorExitL (printf "Nothing found for %s." (show (SharedImageName name))))+        (\sharedImg -> materializeImageSource (SourceImage sharedImg NoPT resize) dest)  createImageFromImage :: Image -> Partition -> ImageResize -> Image -> B9 () createImageFromImage src part size out = do   importImage src out   extractPartition part out   resizeImage size out- where-  extractPartition :: Partition -> Image -> B9 ()-  extractPartition NoPT                  _                     = return ()-  extractPartition (Partition partIndex) (Image outFile Raw _) = do-    (start, len, blockSize) <- liftIO (P.getPartition partIndex outFile)-    let tmpFile = outFile <.> "extracted"-    dbgL (printf "Extracting partition %i from '%s'" partIndex outFile)-    cmd-      (printf "dd if='%s' of='%s' bs=%i skip=%i count=%i &> /dev/null"-              outFile-              tmpFile-              blockSize-              start-              len-      )-    cmd (printf "mv '%s' '%s'" tmpFile outFile)-  extractPartition (Partition partIndex) (Image outFile fmt _) = error-    (printf "Extract partition %i from image '%s': Invalid format %s"-            partIndex-            outFile-            (imageFileExtension fmt)-    )+  where+    extractPartition :: Partition -> Image -> B9 ()+    extractPartition NoPT _ = return ()+    extractPartition (Partition partIndex) (Image outFile Raw _) = do+      (start, len, blockSize) <- liftIO (P.getPartition partIndex outFile)+      let tmpFile = outFile <.> "extracted"+      dbgL (printf "Extracting partition %i from '%s'" partIndex outFile)+      cmd (printf "dd if='%s' of='%s' bs=%i skip=%i count=%i &> /dev/null" outFile tmpFile blockSize start len)+      cmd (printf "mv '%s' '%s'" tmpFile outFile)+    extractPartition (Partition partIndex) (Image outFile fmt _) =+      error+        (printf "Extract partition %i from image '%s': Invalid format %s" partIndex outFile (imageFileExtension fmt))  -- | Convert some 'Image', e.g. a temporary image used during the build phase -- to the final destination. createDestinationImage :: Image -> ImageDestination -> B9 ()-createDestinationImage buildImg dest = case dest of-  (Share name imgType imgResize) -> do-    resizeImage imgResize buildImg-    let shareableImg = changeImageFormat imgType buildImg-    exportAndRemoveImage buildImg shareableImg-    void (shareImage shareableImg (SharedImageName name))-  (LocalFile destImg imgResize) -> do-    resizeImage imgResize buildImg-    exportAndRemoveImage buildImg destImg-  (LiveInstallerImage name repo imgResize) -> do-    resizeImage imgResize buildImg-    let-      destImg = Image destFile Raw buildImgFs-      (Image _ _ buildImgFs) = buildImg-      destFile = repo </> "machines" </> name </> "disks" </> "raw" </> "0.raw"-      sizeFile =-        repo </> "machines" </> name </> "disks" </> "raw" </> "0.size"-      versFile =-        repo </> "machines" </> name </> "disks" </> "raw" </> "VERSION"-    exportAndRemoveImage buildImg destImg-    cmd-      (printf-        "echo $(qemu-img info -f raw '%s' | gawk -e '/virtual size/ {print $4}' | tr -d '(') > '%s'"-        destFile-        sizeFile-      )-    buildDate <- getBuildDate-    buildId   <- getBuildId-    liftIO (writeFile versFile (buildId ++ "-" ++ buildDate))-  Transient -> return ()+createDestinationImage buildImg dest =+  case dest of+    (Share name imgType imgResize) -> do+      resizeImage imgResize buildImg+      let shareableImg = changeImageFormat imgType buildImg+      exportAndRemoveImage buildImg shareableImg+      void (shareImage shareableImg (SharedImageName name))+    (LocalFile destImg imgResize) -> do+      resizeImage imgResize buildImg+      exportAndRemoveImage buildImg destImg+    (LiveInstallerImage name repo imgResize) -> do+      resizeImage imgResize buildImg+      let destImg = Image destFile Raw buildImgFs+          (Image _ _ buildImgFs) = buildImg+          destFile = repo </> "machines" </> name </> "disks" </> "raw" </> "0.raw"+          sizeFile = repo </> "machines" </> name </> "disks" </> "raw" </> "0.size"+          versFile = repo </> "machines" </> name </> "disks" </> "raw" </> "VERSION"+      exportAndRemoveImage buildImg destImg+      cmd+        (printf+           "echo $(qemu-img info -f raw '%s' | gawk -e '/virtual size/ {print $4}' | tr -d '(') > '%s'"+           destFile+           sizeFile)+      buildDate <- getBuildDate+      buildId <- getBuildId+      liftIO (writeFile versFile (buildId ++ "-" ++ buildDate))+    Transient -> return () -createEmptyImage-  :: String -> FileSystem -> ImageType -> ImageSize -> Image -> B9 ()+createEmptyImage :: String -> FileSystem -> ImageType -> ImageSize -> Image -> B9 () createEmptyImage fsLabel fsType imgType imgSize dest@(Image _ imgType' fsType')-  | fsType /= fsType' = error-    (printf-      "Conflicting createEmptyImage parameters. Requested is file system %s but the destination image has %s."-      (show fsType)-      (show fsType')-    )-  | imgType /= imgType' = error-    (printf-      "Conflicting createEmptyImage parameters. Requested is image type %s but the destination image has type %s."-      (show imgType)-      (show imgType')-    )+  | fsType /= fsType' =+    error+      (printf+         "Conflicting createEmptyImage parameters. Requested is file system %s but the destination image has %s."+         (show fsType)+         (show fsType'))+  | imgType /= imgType' =+    error+      (printf+         "Conflicting createEmptyImage parameters. Requested is image type %s but the destination image has type %s."+         (show imgType)+         (show imgType'))   | otherwise = do     let (Image imgFile imgFmt imgFs) = dest-        qemuImgOpts                  = conversionOptions imgFmt+        qemuImgOpts = conversionOptions imgFmt     dbgL-      (printf "Creating empty raw image '%s' with size %s and options %s"-              imgFile-              (toQemuSizeOptVal imgSize)-              qemuImgOpts-      )+      (printf "Creating empty raw image '%s' with size %s and options %s" imgFile (toQemuSizeOptVal imgSize) qemuImgOpts)     cmd-      (printf "qemu-img create -f %s %s '%s' '%s'"-              (imageFileExtension imgFmt)-              qemuImgOpts-              imgFile-              (toQemuSizeOptVal imgSize)-      )+      (printf+         "qemu-img create -f %s %s '%s' '%s'"+         (imageFileExtension imgFmt)+         qemuImgOpts+         imgFile+         (toQemuSizeOptVal imgSize))     case (imgFmt, imgFs) of       (Raw, Ext4_64) -> do         let fsCmd = "mkfs.ext4"@@ -274,48 +238,32 @@         let fsCmd = "mkfs.ext4"         dbgL (printf "Creating file system %s" (show imgFs))         cmd (printf "%s -F -L '%s' -O ^64bit -q '%s'" fsCmd fsLabel imgFile)-      (it, fs) -> error-        (printf "Cannot create file system %s in image type %s"-                (show fs)-                (show it)-        )-+      (it, fs) -> error (printf "Cannot create file system %s in image type %s" (show fs) (show it))  createCOWImage :: Image -> Image -> B9 () createCOWImage (Image backingFile _ _) (Image imgOut imgFmt _) = do   dbgL (printf "Creating COW image '%s' backed by '%s'" imgOut backingFile)-  cmd-    (printf "qemu-img create -f %s -o backing_file='%s' '%s'"-            (imageFileExtension imgFmt)-            backingFile-            imgOut-    )+  cmd (printf "qemu-img create -f %s -o backing_file='%s' '%s'" (imageFileExtension imgFmt) backingFile imgOut)  -- | Resize an image, including the file system inside the image. resizeImage :: ImageResize -> Image -> B9 () resizeImage KeepSize _ = return ()-resizeImage (Resize newSize) (Image img Raw fs) | fs == Ext4 || fs == Ext4_64 =-  do+resizeImage (Resize newSize) (Image img Raw fs)+  | fs == Ext4 || fs == Ext4_64 = do     let sizeOpt = toQemuSizeOptVal newSize     dbgL (printf "Resizing ext4 filesystem on raw image to %s" sizeOpt)     cmd (printf "e2fsck -p '%s'" img)     cmd (printf "resize2fs -f '%s' %s" img sizeOpt)- resizeImage (ResizeImage newSize) (Image img _ _) = do   let sizeOpt = toQemuSizeOptVal newSize   dbgL (printf "Resizing image to %s" sizeOpt)   cmd (printf "qemu-img resize -q '%s' %s" img sizeOpt)--resizeImage ShrinkToMinimum (Image img Raw fs) | fs == Ext4 || fs == Ext4_64 =-  do+resizeImage ShrinkToMinimum (Image img Raw fs)+  | fs == Ext4 || fs == Ext4_64 = do     dbgL "Shrinking image to minimum size"     cmd (printf "e2fsck -p '%s'" img)     cmd (printf "resize2fs -f -M '%s'" img)--resizeImage _ img = error-  (printf "Invalid image type or filesystem, cannot resize image: %s" (show img)-  )-+resizeImage _ img = error (printf "Invalid image type or filesystem, cannot resize image: %s" (show img))  -- | Import a disk image from some external source into the build directory -- if necessary convert the image.@@ -351,35 +299,32 @@   | otherwise = do     ensureDir imgOut     dbgL-      (printf "Converting %s to %s: '%s' to '%s'"-              (imageFileExtension fmtIn)-              (imageFileExtension fmtOut)-              imgIn-              imgOut-      )+      (printf "Converting %s to %s: '%s' to '%s'" (imageFileExtension fmtIn) (imageFileExtension fmtOut) imgIn imgOut)     cmd-      (printf "qemu-img convert -q -f %s -O %s %s '%s' '%s'"-              (imageFileExtension fmtIn)-              (imageFileExtension fmtOut)-              (conversionOptions fmtOut)-              imgIn-              imgOut-      )+      (printf+         "qemu-img convert -q -f %s -O %s %s '%s' '%s'"+         (imageFileExtension fmtIn)+         (imageFileExtension fmtOut)+         (conversionOptions fmtOut)+         imgIn+         imgOut)     when doMove $ do       dbgL (printf "Removing '%s'" imgIn)       liftIO (removeFile imgIn)  conversionOptions :: ImageType -> String-conversionOptions Vmdk  = " -o adapter_type=lsilogic "+conversionOptions Vmdk = " -o adapter_type=lsilogic " conversionOptions QCow2 = " -o compat=1.1,lazy_refcounts=on "-conversionOptions _     = " "+conversionOptions _ = " "  toQemuSizeOptVal :: ImageSize -> String-toQemuSizeOptVal (ImageSize amount u) = show amount ++ case u of-  GB -> "G"-  MB -> "M"-  KB -> "K"-  B  -> ""+toQemuSizeOptVal (ImageSize amount u) =+  show amount +++  case u of+    GB -> "G"+    MB -> "M"+    KB -> "K"+    B -> ""  -- | Publish an sharedImage made from an image and image meta data to the -- configured repository@@ -395,14 +340,8 @@ getSharedImageFromImageInfo :: SharedImageName -> Image -> B9 SharedImage getSharedImageFromImageInfo name (Image _ imgType imgFS) = do   buildId <- getBuildId-  date    <- getBuildDate-  return-    (SharedImage name-                 (SharedImageDate date)-                 (SharedImageBuildId buildId)-                 imgType-                 imgFS-    )+  date <- getBuildDate+  return (SharedImage name (SharedImageDate date) (SharedImageBuildId buildId) imgType imgFS)  -- | Convert the disk image and serialize the base image data structure. -- If the 'maxLocalSharedImageRevisions' configuration is set to @Just n@@@ -411,7 +350,7 @@ createSharedImageInCache img sname@(SharedImageName name) = do   dbgL (printf "CREATING SHARED IMAGE: '%s' '%s'" (ppShow img) name)   sharedImg <- getSharedImageFromImageInfo sname img-  dir       <- getSharedImagesCacheDir+  dir <- getSharedImagesCacheDir   convertImage img (changeImageDirectory dir (sharedImageImage sharedImg))   prettyPrintToFile (dir </> sharedImageFileName sharedImg) sharedImg   dbgL (printf "CREATED SHARED IMAGE IN CACHE '%s'" (ppShow sharedImg))@@ -422,13 +361,13 @@ -- selected repository from the cache. pushSharedImageLatestVersion :: SharedImageName -> B9 () pushSharedImageLatestVersion name@(SharedImageName imgName) =-  getLatestSharedImageByNameFromCache name >>= maybe+  getLatestSharedImageByNameFromCache name >>=+  maybe     (errorExitL (printf "Nothing found for %s." (show imgName)))     (\sharedImage -> do-      dbgL (printf "PUSHING '%s'" (ppShow sharedImage))-      pushToSelectedRepo sharedImage-      infoL (printf "PUSHED '%s'" imgName)-    )+       dbgL (printf "PUSHING '%s'" (ppShow sharedImage))+       pushToSelectedRepo sharedImage+       infoL (printf "PUSHED '%s'" imgName))  -- | Upload a shared image from the cache to a selected remote repository pushToSelectedRepo :: SharedImage -> B9 ()@@ -441,7 +380,7 @@         cachedInfoFile = c </> sharedImageFileName i         repoImgFile = sharedImagesRootDirectory </> imgFile'         repoInfoFile = sharedImagesRootDirectory </> sharedImageFileName i-    pushToRepo (fromJust r) cachedImgFile  repoImgFile+    pushToRepo (fromJust r) cachedImgFile repoImgFile     pushToRepo (fromJust r) cachedInfoFile repoInfoFile  -- | Pull metadata files from all remote repositories.@@ -449,17 +388,15 @@ pullRemoteRepos = do   repos <- getSelectedRepos   mapM_ dl repos-- where-  dl =-    pullGlob sharedImagesRootDirectory (FileExtension sharedImageFileExtension)+  where+    dl = pullGlob sharedImagesRootDirectory (FileExtension sharedImageFileExtension)  -- | Pull the latest version of an image, either from the selected remote -- repo or from the repo that has the latest version. pullLatestImage :: SharedImageName -> B9 (Maybe SharedImageBuildId) pullLatestImage name@(SharedImageName dbgName) = do   repos <- getSelectedRepos-  let repoPredicate Cache           = False+  let repoPredicate Cache = False       repoPredicate (Remote repoId) = repoId `elem` repoIds       repoIds = map remoteRepoRepoId repos       hasName sharedImage = name == sharedImageName sharedImage@@ -467,24 +404,18 @@   let (Remote repoId, image) = last candidates   if null candidates     then do-      errorL-        (printf-          "No shared image named '%s' on these remote repositories: '%s'"-          dbgName-          (ppShow repoIds)-        )+      errorL (printf "No shared image named '%s' on these remote repositories: '%s'" dbgName (ppShow repoIds))       return Nothing     else do       dbgL (printf "PULLING SHARED IMAGE: '%s'" (ppShow image))       cacheDir <- getSharedImagesCacheDir-      let-        (Image imgFile' _imgType _fs) = sharedImageImage image-        cachedImgFile                 = cacheDir </> imgFile'-        cachedInfoFile                = cacheDir </> sharedImageFileName image-        repoImgFile                   = sharedImagesRootDirectory </> imgFile'-        repoInfoFile = sharedImagesRootDirectory </> sharedImageFileName image-        repo                          = fromJust (lookupRemoteRepo repos repoId)-      pullFromRepo repo repoImgFile  cachedImgFile+      let (Image imgFile' _imgType _fs) = sharedImageImage image+          cachedImgFile = cacheDir </> imgFile'+          cachedInfoFile = cacheDir </> sharedImageFileName image+          repoImgFile = sharedImagesRootDirectory </> imgFile'+          repoInfoFile = sharedImagesRootDirectory </> sharedImageFileName image+          repo = fromJust (lookupRemoteRepo repos repoId)+      pullFromRepo repo repoImgFile cachedImgFile       pullFromRepo repo repoInfoFile cachedInfoFile       infoL (printf "PULLED '%s' FROM '%s'" dbgName repoId)       cleanOldSharedImageRevisionsFromCache name@@ -495,10 +426,10 @@ getLatestImageByName :: SharedImageName -> B9 (Maybe Image) getLatestImageByName name = do   sharedImage <- getLatestSharedImageByNameFromCache name-  cacheDir    <- getSharedImagesCacheDir+  cacheDir <- getSharedImagesCacheDir   let image = changeImageDirectory cacheDir . sharedImageImage <$> sharedImage   case image of-    Just i  -> dbgL (printf "USING SHARED SOURCE IMAGE '%s'" (show i))+    Just i -> dbgL (printf "USING SHARED SOURCE IMAGE '%s'" (show i))     Nothing -> errorL (printf "SOURCE IMAGE '%s' NOT FOUND" (show name))   return image @@ -507,52 +438,42 @@ getLatestSharedImageByNameFromCache name@(SharedImageName dbgName) = do   imgs <- lookupSharedImages (== Cache) ((== name) . sharedImageName)   case reverse imgs of-    (Cache, sharedImage) : _rest -> return (Just sharedImage)-    _                            -> do+    (Cache, sharedImage):_rest -> return (Just sharedImage)+    _ -> do       errorL (printf "No image(s) named '%s' found." dbgName)       return Nothing  -- | Return a list of all existing sharedImages from cached repositories. getSharedImages :: B9 [(Repository, [SharedImage])] getSharedImages = do-  reposAndFiles <- repoSearch sharedImagesRootDirectory-                              (FileExtension sharedImageFileExtension)-  mapM (\(repo, files) -> ((repo, ) . catMaybes) <$> mapM consult' files)-       reposAndFiles-- where-  consult' f = do-    r <- liftIO (try (consult f))-    case r of-      Left (e :: SomeException) -> do-        dbgL-          (printf "Failed to load shared image meta-data from '%s': '%s'"-                  (takeFileName f)-                  (show e)-          )-        dbgL (printf "Removing bad meta-data file '%s'" f)-        liftIO (removeFile f)-        return Nothing-      Right c -> return (Just c)+  reposAndFiles <- repoSearch sharedImagesRootDirectory (FileExtension sharedImageFileExtension)+  mapM (\(repo, files) -> (repo, ) . catMaybes <$> mapM consult' files) reposAndFiles+  where+    consult' f = do+      r <- liftIO (try (consult f))+      case r of+        Left (e :: SomeException) -> do+          dbgL (printf "Failed to load shared image meta-data from '%s': '%s'" (takeFileName f) (show e))+          dbgL (printf "Removing bad meta-data file '%s'" f)+          liftIO (removeFile f)+          return Nothing+        Right c -> return (Just c)  -- | Find shared images and the associated repos from two predicates. The result -- is the concatenated result of the sorted shared images satisfying 'imgPred'.-lookupSharedImages-  :: (Repository -> Bool)-  -> (SharedImage -> Bool)-  -> B9 [(Repository, SharedImage)]+lookupSharedImages :: (Repository -> Bool) -> (SharedImage -> Bool) -> B9 [(Repository, SharedImage)] lookupSharedImages repoPred imgPred = do   xs <- getSharedImages-  let rs           = [ (r, s) | (r, ss) <- xs, s <- ss ]+  let rs = [(r, s) | (r, ss) <- xs, s <- ss]       matchingRepo = filter (repoPred . fst) rs-      matchingImg  = filter (imgPred . snd) matchingRepo-      sorted       = sortBy (compare `on` snd) matchingImg+      matchingImg = filter (imgPred . snd) matchingRepo+      sorted = sortBy (compare `on` snd) matchingImg   return (mconcat (pure <$> sorted))  -- | Return either all remote repos or just the single selected repo. getSelectedRepos :: B9 [RemoteRepo] getSelectedRepos = do-  allRepos     <- getRemoteRepos+  allRepos <- getRemoteRepos   selectedRepo <- getSelectedRemoteRepo   let repos = maybe allRepos return selectedRepo -- 'Maybe' a repo   return repos@@ -572,25 +493,19 @@   b9Cfg <- getConfig   forM_ (b9Cfg ^. maxLocalSharedImageRevisions) $ \maxRevisions -> do     toDelete <- take maxRevisions <$> newestSharedImages-    imgDir   <- getSharedImagesCacheDir+    imgDir <- getSharedImagesCacheDir     let filesToDelete = (imgDir </>) <$> (infoFiles ++ imgFiles)-        infoFiles     = sharedImageFileName <$> toDelete-        imgFiles      = imageFileName . sharedImageImage <$> toDelete+        infoFiles = sharedImageFileName <$> toDelete+        imgFiles = imageFileName . sharedImageImage <$> toDelete     unless (null filesToDelete) $ do-      traceL-        (printf "DELETING %d OBSOLETE REVISIONS OF: %s"-                (length filesToDelete)-                (show sn)-        )-      mapM_ traceL         filesToDelete+      traceL (printf "DELETING %d OBSOLETE REVISIONS OF: %s" (length filesToDelete) (show sn))+      mapM_ traceL filesToDelete       mapM_ removeIfExists filesToDelete- where-  newestSharedImages :: B9 [SharedImage]-  newestSharedImages = reverse . map snd <$> lookupSharedImages-    (== Cache)-    ((sn ==) . sharedImageName)--  removeIfExists fileName = liftIO $ removeFile fileName `catch` handleExists-   where-    handleExists e | isDoesNotExistError e = return ()-                   | otherwise             = throwIO e+  where+    newestSharedImages :: B9 [SharedImage]+    newestSharedImages = reverse . map snd <$> lookupSharedImages (== Cache) ((sn ==) . sharedImageName)+    removeIfExists fileName = liftIO $ removeFile fileName `catch` handleExists+      where+        handleExists e+          | isDoesNotExistError e = return ()+          | otherwise = throwIO e
src/lib/B9/DiskImages.hs view
@@ -317,10 +317,9 @@             nameC = col "Name" ((\(SharedImageName n) -> n) . sharedImageName)             dateC = col "Date" ((\(SharedImageDate n) -> n) . sharedImageDate)             idC = col "ID" ((\(SharedImageBuildId n) -> n) . sharedImageBuildId)-            col title accessor =-              (Boxes.text title) Boxes.// (Boxes.vcat Boxes.left cells)+            col title accessor = Boxes.text title Boxes.// Boxes.vcat Boxes.left cells               where-                cells = Boxes.text <$> accessor <$> imgs+                cells = Boxes.text . accessor <$> imgs  -- | Return the disk image of an sharedImage sharedImageImage :: SharedImage -> Image
+ src/lib/B9/Environment.hs view
@@ -0,0 +1,169 @@+{-| An 'Environment' contains textual key value pairs, relavant for string template+substitution.++The variables are passed to the B9 build either via command line, OS environment+variables or configuration file.++@since 0.5.62+ -}+module B9.Environment+  ( Environment()+  , fromStringPairs+  , addStringBinding+  , insertPositionalArguments+  , EnvironmentReaderT+  , MonadEnvironment+  , runEnvironmentReaderT+  , askEnvironment+  , localEnvironment+  , lookupOrThrow+  , lookupEither+  , KeyNotFound(..)+  , DuplicateKey(..)+  ) where++import           Control.Arrow               ((***))+import           Control.Exception           (Exception)+import           Control.Monad.Catch         (MonadThrow, throwM)+import           Control.Monad.Reader+import           Control.Parallel.Strategies+import           Data.Data+import           Data.HashMap.Strict         (HashMap)+import qualified Data.HashMap.Strict         as HashMap+import           Data.Maybe                  (maybe)+import           Data.Text.Lazy              (Text)+import qualified Data.Text.Lazy              as Text+import           GHC.Generics                (Generic)++-- | A map of textual keys to textual values.+--+-- @since 0.5.62+data Environment = MkEnvironment+  { nextPosition    :: Int+  , fromEnvironment :: HashMap Text Text+  } deriving (Show, Typeable, Data, Eq, Generic)++instance NFData Environment++instance Semigroup Environment where+  e1 <> e2 =+    MkEnvironment+      { nextPosition =+          case (nextPosition e1, nextPosition e2) of+            (0, 0) -> 0+            (0, p2) -> p2+            (p1, 0) -> p1+            _ -> error ("Overlapping positional arguments (<>): (" ++ show e1 ++ ") <> (" ++ show e2 ++ ")")+      , fromEnvironment =+          let i = HashMap.intersection (fromEnvironment e1) (fromEnvironment e2)+           in if HashMap.null i+                then fromEnvironment e1 <> fromEnvironment e2+                else error ("Overlapping entries (<>): (" ++ show e1 ++ ") <> (" ++ show e2 ++ "): (" ++ show i ++ ")")+      }++instance Monoid Environment where+  mempty = MkEnvironment 0 HashMap.empty++-- | If environment variables @arg_1 .. arg_n@ are bound+-- and a list of @k@ additional values are passed to this function,+-- store them with keys @arg_(n+1) .. arg_(n+k)@.+--+-- Note that the Environment contains an index of the next position.+--+-- @since 0.5.62+insertPositionalArguments :: [Text] -> Environment -> Environment+insertPositionalArguments =+  flip (foldr (\arg (MkEnvironment i e) -> MkEnvironment (i + 1) (HashMap.insert (Text.pack ("arg_" ++ show i)) arg e)))++-- | Create an 'Environment' from a list of pairs ('String's)+--+-- @since 0.5.62+fromStringPairs :: [(String, String)] -> Environment+fromStringPairs = MkEnvironment 0 . HashMap.fromList . fmap (Text.pack *** Text.pack)++-- | Insert a value into an 'Environment'.+--+-- @since 0.5.62+addStringBinding :: MonadThrow m => (String, String) -> Environment -> m Environment+addStringBinding (k, vNew) env =+  case HashMap.lookup (Text.pack k) (fromEnvironment env) of+    Just vOld -> throwM (MkDuplicateKey (Text.pack k) vOld (Text.pack vNew))+    Nothing ->+      pure (MkEnvironment (nextPosition env) (HashMap.insert (Text.pack k) (Text.pack vNew) (fromEnvironment env)))++-- | A monad transformer providing a 'MonadReader' instance for 'Environment'+--+-- @since 0.5.62+type EnvironmentReaderT m a = ReaderT Environment m a++-- | A constraint on a monad @m@ ensuring (read-only) access to an 'Environment'+--+-- @since 0.5.62+type MonadEnvironment m = MonadReader Environment m++-- | Run a 'ReaderT' of 'Environment'.+--+-- @since 0.5.62+runEnvironmentReaderT :: Environment -> EnvironmentReaderT m a -> m a+runEnvironmentReaderT = flip runReaderT++-- | Get the current 'Environment'+--+-- @since 0.5.62+askEnvironment :: MonadEnvironment m => m Environment+askEnvironment = ask++-- | Run a computation with a modified 'Environment'+--+-- @since 0.5.62+localEnvironment :: MonadEnvironment m => (Environment -> Environment) -> m a -> m a+localEnvironment = local++-- | Lookup a key for a value.+--+-- 'throwM' a 'KeyNotFound' 'Exception' if no value with the given key exists+-- in the 'Environment'.+--+-- @Since 0.5.62+lookupOrThrow :: (MonadThrow m, MonadEnvironment m) => Text -> m Text+lookupOrThrow key = do+  env <- askEnvironment+  maybe (throwM (MkKeyNotFound key env)) return (HashMap.lookup key (fromEnvironment env))++-- | Lookup a key for a value.+--+-- Return 'Either' 'Left' 'KeyNotFound', if no value with the given key exists+-- in the 'Environment', or 'Right' the value.+--+-- @Since 0.5.62+lookupEither :: MonadEnvironment m => Text -> m (Either KeyNotFound Text)+lookupEither key = do+  env <- askEnvironment+  (return . maybe (Left (MkKeyNotFound key env)) Right) (HashMap.lookup key (fromEnvironment env))++-- | An 'Exception' thrown by 'addBinding' indicating that a key already exists.+--+-- @Since 0.5.62+data DuplicateKey = MkDuplicateKey+  { duplicateKey         :: Text+  , duplicateKeyOldValue :: Text+  , duplicateKeyNewValue :: Text+  } deriving (Typeable, Show)++instance Exception DuplicateKey++-- | An 'Exception' thrown by 'lookupOrThrow' indicating that a key does not exist.+--+-- @Since 0.5.62+data KeyNotFound =+  MkKeyNotFound Text+                Environment+  deriving (Typeable)++instance Exception KeyNotFound++instance Show KeyNotFound where+  showsPrec _ (MkKeyNotFound key env) =+    let keys = unlines (Text.unpack <$> HashMap.keys (fromEnvironment env))+     in showString "Invalid template parameter: \"" .+        showString (Text.unpack key) . showString "\".\nValid variables:\n" . showString keys
src/lib/B9/RepositoryIO.hs view
@@ -97,7 +97,7 @@     cmd c  -- | Express a pattern for file paths, used when searching repositories.-data FilePathGlob = FileExtension String+newtype FilePathGlob = FileExtension String  -- * Internals
src/lib/B9/Shake/Actions.hs view
@@ -1,15 +1,15 @@ -- | Convenient Shake 'Action's for 'B9' rules.-module B9.Shake.Actions (b9InvokationAction, buildB9File) where+module B9.Shake.Actions (b9InvocationAction, buildB9File) where  import Development.Shake import Development.Shake.FilePath import B9 --- | Convert a 'B9Invokation' action into a Shake 'Action'. This is just+-- | Convert a 'B9Invocation' action into a Shake 'Action'. This is just -- an alias for 'execB9ConfigAction' since 'Action' is an instance of 'MonadIO' -- and 'execB9ConfigAction' work on any .-b9InvokationAction :: B9ConfigAction Action a -> B9ConfigOverride -> Action a-b9InvokationAction = execB9ConfigAction+b9InvocationAction :: B9ConfigAction Action a -> B9ConfigOverride -> Action a+b9InvocationAction = execB9ConfigAction  -- | An action that does the equivalent of -- @b9c build -f <b9file> -- (args !! 0) (args !! 1) ... (args !! (length args - 1))@@@ -17,10 +17,6 @@ -- The return value is the buildid, see 'getBuildId' buildB9File :: FilePath -> FilePath -> [String] -> Action String buildB9File b9Root b9File args = do-    let f = b9Root </> b9File-    need [f]-    invokeB9-        ( localRuntimeConfig-            (appendPositionalArguments args . (buildDirRoot .~ Just b9Root))-            (runBuildArtifacts [f])-        )+  let f = b9Root </> b9File+  need [f]+  invokeB9 (localRuntimeConfig (appendPositionalArguments args . (buildDirRoot .~ Just b9Root)) (runBuildArtifacts [f]))
src/lib/B9/Shake/SharedImageRules.hs view
@@ -15,11 +15,10 @@ import           Data.ByteString.Builder        ( stringUtf8 ) import qualified Data.ByteString.Lazy          as LazyByteString import qualified Data.Binary                   as Binary-import           Data.Function import           B9  -- | In order to use 'needSharedImage' and 'customSharedImageAction' you need to--- call this action before using any of the afore mentioned.+-- call this action before using any of the aforementioned 'Rules'. enableSharedImageRules :: B9ConfigOverride -> Rules () enableSharedImageRules b9inv = addBuiltinRule noLint sharedImageIdentity go  where@@ -29,54 +28,46 @@       (Builder.toLazyByteString (stringUtf8 k <> stringUtf8 v))    go :: BuiltinRun SharedImageName SharedImageBuildId-  go nameQ mSerlializedBuildId dependenciesChanged =-    let mOld = decodeBuildId <$> mSerlializedBuildId-    in  do-          (rebuilt, newBuildId) <--            if dependenciesChanged == RunDependenciesChanged-              then (True, ) <$> rebuild-              else do-                mNewBuildId <- getImgBuildId-                maybe ((True, ) <$> rebuild) (return . (False, )) mNewBuildId-          let newBuildIdBin = encodeBuildId newBuildId-              change        = if rebuilt-                then maybe-                  ChangedRecomputeDiff-                  (\buildIdChanged -> if buildIdChanged-                    then ChangedRecomputeDiff-                    else ChangedRecomputeSame-                  )-                  ((/= newBuildId) <$> mOld)-                else maybe-                  ChangedStore-                  (\buildIdChanged -> if buildIdChanged-                    then ChangedRecomputeDiff-                    else ChangedRecomputeSame-                  )-                  ((/= newBuildId) <$> mOld)-              result = RunResult change newBuildIdBin newBuildId-          return result+  go nameQ mOldBIdBinary dependenciesChanged = do+    mCurrentBId <- getImgBuildId+    case mCurrentBId of+      Just currentBId ->+        let currentBIdBinary = encodeBuildId currentBId++        in  if dependenciesChanged+                 == RunDependenciesChanged+                 && mOldBIdBinary+                 == Just currentBIdBinary+              then return $ RunResult ChangedNothing currentBIdBinary currentBId+              else rebuild (Just currentBIdBinary)+      _ -> rebuild Nothing    where     getImgBuildId = execB9ConfigAction (runLookupLocalSharedImage nameQ) b9inv -    decodeBuildId :: ByteString.ByteString -> SharedImageBuildId-    decodeBuildId = Binary.decode . LazyByteString.fromStrict-     encodeBuildId :: SharedImageBuildId -> ByteString.ByteString     encodeBuildId = LazyByteString.toStrict . Binary.encode -    rebuild :: Action SharedImageBuildId-    rebuild = do-      rules <- getUserRuleList imgMatch-      case sortBy (compare `on` fst) rules of-        [] ->-          fail $ "No rules to build B9 shared image " ++ show nameQ ++ " found"-        [(_, act)] -> act b9inv-        _rs ->-          fail-            $  "Multiple rules for the B9 shared image "-            ++ show nameQ-            ++ " found"+    rebuild+      :: Maybe ByteString.ByteString -> Action (RunResult SharedImageBuildId)+    rebuild mCurrentBIdBinary = do+      (_, act) <- getUserRuleOne nameQ (const Nothing) imgMatch+      act b9inv+      mNewBId <- getImgBuildId+      newBId  <- maybe+        (error+          (  "failed to get SharedImageBuildId for "+          ++ show nameQ+          ++ " in context of "+          ++ show b9inv+          )+        )+        return+        mNewBId+      let newBIdBinary = encodeBuildId newBId+      let change = if Just newBIdBinary == mCurrentBIdBinary+            then ChangedRecomputeSame+            else ChangedRecomputeDiff+      return $ RunResult change newBIdBinary newBId      where       imgMatch (SharedImageCustomActionRule name mkImage) =         if name == nameQ then Just mkImage else Nothing@@ -104,7 +95,6 @@               (show mCurrentBuildId)       )     maybe (errorSharedImageNotFound b9img) return mCurrentBuildId-  type instance RuleResult SharedImageName = SharedImageBuildId
src/lib/B9/Vm.hs view
@@ -1,50 +1,53 @@ {-| Definition of 'VmScript' an artifact encapsulating several virtual machines     disk images that can be mounted in an execution environment like     "B9.LibVirtLXC". A 'VmScript' is embedded by in an-    'B9.ArtifactGenerator.ArtifactGenerator'. -}-module B9.Vm (VmScript (..)-             ,substVmScript) where+    'B9.Artifact.Generator.ArtifactGenerator'. -}+module B9.Vm+  ( VmScript(..)+  , substVmScript+  ) where -import Control.Parallel.Strategies-import Data.Binary-import Data.Data-import Data.Generics.Aliases hiding (Generic)-import Data.Generics.Schemes-import Data.Hashable-import GHC.Generics (Generic)+import           Control.Parallel.Strategies+import           Data.Binary+import           Data.Data+import           Data.Generics.Aliases       hiding (Generic)+import           Data.Generics.Schemes+import           Data.Hashable+import           GHC.Generics                (Generic) -import B9.ShellScript-import B9.DiskImages-import B9.ExecEnv-import B9.Content.StringTemplate+import           B9.Environment+import           B9.Artifact.Content.StringTemplate+import           B9.DiskImages+import           B9.ExecEnv+import           B9.ShellScript  -- | Describe a virtual machine, i.e. a set up disk images to create and a shell -- script to put things together. data VmScript-    = VmScript CPUArch-               [SharedDirectory]-               Script-    | NoVmScript-    deriving (Read,Show,Typeable,Data,Eq,Generic)+  = VmScript CPUArch+             [SharedDirectory]+             Script+  | NoVmScript+  deriving (Read, Show, Typeable, Data, Eq, Generic)  instance Hashable VmScript+ instance Binary VmScript+ instance NFData VmScript -substVmScript :: [(String,String)] -> VmScript -> VmScript+substVmScript :: Environment -> VmScript -> VmScript substVmScript env = everywhere gsubst   where-    gsubst-        :: Data a-        => a -> a+    gsubst :: Data a => a -> a     gsubst = mkT substMountPoint `extT` substSharedDir `extT` substScript-    substMountPoint NotMounted = NotMounted+    substMountPoint NotMounted     = NotMounted     substMountPoint (MountPoint x) = MountPoint (sub x)-    substSharedDir (SharedDirectory fp mp) = SharedDirectory (sub fp) mp+    substSharedDir (SharedDirectory fp mp)   = SharedDirectory (sub fp) mp     substSharedDir (SharedDirectoryRO fp mp) = SharedDirectoryRO (sub fp) mp-    substSharedDir s = s-    substScript (In fp s) = In (sub fp) s+    substSharedDir s                         = s+    substScript (In fp s)     = In (sub fp) s     substScript (Run fp args) = Run (sub fp) (map sub args)-    substScript (As fp s) = As (sub fp) s-    substScript s = s+    substScript (As fp s)     = As (sub fp) s+    substScript s             = s     sub = subst env
src/lib/B9/VmBuilder.hs view
@@ -15,7 +15,7 @@ import B9.ExecEnv import B9.B9Config import B9.Vm-import B9.ArtifactGenerator+import B9.Artifact.Readable import B9.ShellScript import qualified B9.LibVirtLXC as LXC @@ -31,9 +31,7 @@ getVmScriptSupportedImageTypes :: VmScript -> B9 [ImageType] getVmScriptSupportedImageTypes NoVmScript =   return [QCow2, Raw, Vmdk]-getVmScriptSupportedImageTypes _ = do-  envType <- getExecEnvType-  return (supportedImageTypes envType)+getVmScriptSupportedImageTypes _ = supportedImageTypes <$> getExecEnvType  supportedImageTypes :: ExecEnvType -> [ImageType] supportedImageTypes LibVirtLXC = LXC.supportedImageTypes
src/tests/B9/ArtifactGeneratorImplSpec.hs view
@@ -2,8 +2,9 @@ import Test.Hspec import Data.Text () -import B9.ArtifactGenerator-import B9.ArtifactGeneratorImpl+import B9.Artifact.Readable+import B9.Artifact.Readable.Interpreter+import B9.Environment as Env import B9.DiskImages import B9.ExecEnv import B9.Vm@@ -14,7 +15,7 @@   describe "assemble" $ do       it "replaces '$...' variables in SourceImage Image file paths" $-       let e = CGEnv [("variable","value")] []+       let e = CGEnv (Env.fromStringPairs [("variable","value")]) []            src = vmImagesArtifact "" [transientCOW "${variable}" ""] NoVmScript            expected = transientCOW "value" ""            (Right [igEnv]) = execCGParser (parseArtifactGenerator src) e@@ -22,7 +23,7 @@        in actual `shouldBe` expected       it "replaces '$...' variables in SourceImage 'From' names" $-       let e = CGEnv [("variable","value")] []+       let e = CGEnv (Env.fromStringPairs [("variable","value")]) []            src = vmImagesArtifact "" [transientShared "${variable}" ""] NoVmScript            expected = transientShared "value" ""            (Right [igEnv]) = execCGParser (parseArtifactGenerator src) e@@ -30,7 +31,7 @@        in actual `shouldBe` expected       it "replaces '$...' variables in the name of a shared image" $-       let e = CGEnv [("variable","value")] []+       let e = CGEnv (Env.fromStringPairs [("variable","value")]) []            src = vmImagesArtifact "" [shareCOW "${variable}" ""] NoVmScript            expected = shareCOW "value" ""            (Right [igEnv]) = execCGParser (parseArtifactGenerator src) e@@ -38,7 +39,7 @@        in actual `shouldBe` expected       it "replaces '$...' variables in the name and path of a live installer image" $-       let e = CGEnv [("variable","value")] []+       let e = CGEnv (Env.fromStringPairs [("variable","value")]) []            src = vmImagesArtifact "" [liveInstallerCOWImage "${variable}" ""] NoVmScript            expected = liveInstallerCOWImage "value" ""            (Right [igEnv]) = execCGParser (parseArtifactGenerator src) e@@ -46,7 +47,7 @@        in actual `shouldBe` expected       it "replaces '$...' variables in the file name of an image exported as LocalFile" $-       let e = CGEnv [("variable","value")] []+       let e = CGEnv (Env.fromStringPairs [("variable","value")]) []            src = vmImagesArtifact "" [localCOWImage "${variable}" ""] NoVmScript            expected = localCOWImage "value" ""            (Right [igEnv]) = execCGParser (parseArtifactGenerator src) e@@ -54,7 +55,7 @@        in actual `shouldBe` expected       it "replaces '$...' variables in mount point of an image" $-       let e = CGEnv [("variable","value")] []+       let e = CGEnv (Env.fromStringPairs [("variable","value")]) []            src = vmImagesArtifact "" [localCOWImage "" "${variable}"] NoVmScript            expected = localCOWImage "" "value"            (Right [igEnv]) = execCGParser (parseArtifactGenerator src) e@@ -62,7 +63,7 @@        in actual `shouldBe` expected       it "replaces '$...' variables in shared directory source and mount point (RO)" $-       let e = CGEnv [("variable","value")] []+       let e = CGEnv (Env.fromStringPairs [("variable","value")]) []            src = vmImagesArtifact "" [] (emptyScriptWithSharedDirRO "${variable}")            expected = emptyScriptWithSharedDirRO "value"            (Right [igEnv]) = execCGParser (parseArtifactGenerator src) e@@ -70,7 +71,7 @@        in actual `shouldBe` expected       it "replaces '$...' variables in shared directory source and mount point (RW)" $-       let e = CGEnv [("variable","value")] []+       let e = CGEnv (Env.fromStringPairs [("variable","value")]) []            src = vmImagesArtifact "" [] (emptyScriptWithSharedDirRW "${variable}")            expected = emptyScriptWithSharedDirRW "value"            (Right [igEnv]) = execCGParser (parseArtifactGenerator src) e@@ -78,7 +79,7 @@        in actual `shouldBe` expected       it "replaces '$...' variables in VmImages build script instructions" $-       let e = CGEnv [("variable","value")] []+       let e = CGEnv (Env.fromStringPairs [("variable","value")]) []            src = vmImagesArtifact "" [] (buildScript "${variable}")            expected = buildScript "value"            (Right [igEnv]) = execCGParser (parseArtifactGenerator src) e
src/tests/B9/Content/ErlTermsSpec.hs view
@@ -5,8 +5,8 @@ import Test.Hspec import Test.QuickCheck import Data.Maybe-import B9.Content.ErlTerms-import qualified Data.ByteString.Char8 as B+import B9.Artifact.Content.ErlTerms+import qualified Data.ByteString.Lazy.Char8 as Lazy  spec :: Spec spec = do@@ -54,7 +54,7 @@     it "parses decimal literals"        (property           (do decimal <- arbitrary `suchThat` (>= 0)-              let decimalStr = B.pack (show (decimal :: Integer) ++ ".")+              let decimalStr = Lazy.pack (show (decimal :: Integer) ++ ".")               parsedTerm <- case parseErlTerm "test" decimalStr of                                  (Left e) -> fail e                                  (Right parsedTerm) -> return parsedTerm@@ -71,7 +71,7 @@           (do radix <- choose (2, 36)               digitsInRadix <- listOf1 (choose (0, radix - 1))               let (Right parsedTerm) = parseErlTerm "test" erlNumber-                  erlNumber = B.pack (show radix ++ "#" ++ digitChars ++ ".")+                  erlNumber = Lazy.pack (show radix ++ "#" ++ digitChars ++ ".")                   expected = convertStrToDecimal radix digitChars                   digitChars = (naturals !!) <$> digitsInRadix               return (ErlNatural expected == parsedTerm)))
src/tests/B9/Content/ErlangPropListSpec.hs view
@@ -8,21 +8,22 @@ import Data.Semigroup #endif import Data.Text ()+import qualified Data.Binary as Binary -import B9.Content.ErlTerms-import B9.Content.ErlangPropList-import B9.Content.AST+import B9.Artifact.Content.ErlTerms+import B9.Artifact.Content.ErlangPropList+import B9.Artifact.Content.AST  spec :: Spec spec =   describe "ErlangPropList" $ do -    it "implements ConcatableSyntax method decodeSyntax" $-       let v = decodeSyntax "" "ok."+    it "decodeOrFail'" $+       let v = decodeOrFail' "" "ok."        in v `shouldBe` Right (ErlangPropList (ErlAtom "ok")) -    it "implements ConcatableSyntax method encodeSyntax" $-       let v = encodeSyntax (ErlangPropList (ErlAtom "ok"))+    it "Binary.encode" $+       let v = Binary.encode (ErlangPropList (ErlAtom "ok"))        in v `shouldBe` "ok."      it "combines primitives by putting them in a list" $@@ -34,15 +35,15 @@        in (p1 <> p2) `shouldBe` combined      it "combines a list and a primitve by extending the list" $-       let (Right l) = decodeSyntax "" "[a,b,c]." :: Either String ErlangPropList-           (Right p) = decodeSyntax "" "{ok,value}."-           (Right combined) = decodeSyntax "" "[a,b,c,{ok,value}]."+       let (Right l) = decodeOrFail' "" "[a,b,c]." :: Either String ErlangPropList+           (Right p) = decodeOrFail' "" "{ok,value}."+           (Right combined) = decodeOrFail' "" "[a,b,c,{ok,value}]."        in l <> p `shouldBe` combined      it "combines a primitve and a list by extending the list" $-       let (Right l) = decodeSyntax "" "[a,b,c]." :: Either String ErlangPropList-           (Right p) = decodeSyntax "" "{ok,value}."-           (Right combined) = decodeSyntax "" "[{ok,value},a,b,c]."+       let (Right l) = decodeOrFail' "" "[a,b,c]." :: Either String ErlangPropList+           (Right p) = decodeOrFail' "" "{ok,value}."+           (Right combined) = decodeOrFail' "" "[{ok,value},a,b,c]."        in p <> l `shouldBe` combined      it "merges lists with distinct elements to lists containing the elements of both lists" $
src/tests/B9/Content/YamlObjectSpec.hs view
@@ -8,11 +8,12 @@ import Data.Text () import Data.Yaml -import B9.Content.YamlObject-import B9.Content.AST+import B9.Artifact.Content.YamlObject+import B9.Artifact.Content.CloudConfigYaml+import B9.Artifact.Content.AST  spec :: Spec-spec =+spec = do   describe "YamlObject" $ do      it "combines primitives by putting them in an array" $@@ -48,12 +49,13 @@                                               ,Number 4]])        in (o1 <> o2) `shouldBe` combined -    it "combines 'write_files' and 'runcmd' from typical 'user-data' files by merging each" $-     let (Right ud1) = decodeSyntax "" "#user-data\n\nwrite_files:\n  - contents: |\n      hello world!\n\n    path: /sdf/xyz/filename.cfg\n    owner: root:root\n\nruncmd:\n - x y z\n"--         (Right ud2) = decodeSyntax "" "#user-data\n\nwrite_files:\n  - contents: |\n      hello world2!\n\n    path: /sdf/xyz/filename.cfg\n    owner: root:root\n\nruncmd:\n - a b c\n"+  describe "CloudConfigYaml" $ do+   it "combines 'write_files' and 'runcmd' from typical 'user-data' files by merging each" $+     let ud1, ud2 :: CloudConfigYaml+         (Right ud1) = decodeOrFail' "" "#cloud-config\n\nwrite_files:\n  - contents: |\n      hello world!\n\n    path: /sdf/xyz/filename.cfg\n    owner: root:root\n\nruncmd:\n - x y z\n"+         (Right ud2) = decodeOrFail' "" "#cloud-config\n\nwrite_files:\n  - contents: |\n      hello world2!\n\n    path: /sdf/xyz/filename.cfg\n    owner: root:root\n\nruncmd:\n - a b c\n" -         ud = YamlObject+         ud = MkCloudConfigYaml $ YamlObject                 (object                    ["runcmd" .=                     array [toJSON ("x y z"::String)@@ -74,11 +76,12 @@                             ,"owner" .=                              toJSON ("root:root"::String)]]])       in ud1 <> ud2 `shouldBe` ud-    it "combines strings by appending them" $-       let o1 = YamlObject (object ["k" .= toJSON ("Hello"::String)])-           o2 = YamlObject (object ["k" .= toJSON ("World"::String)])++   it "combines strings by appending them" $+       let o1 = MkCloudConfigYaml $ YamlObject (object ["k" .= toJSON ("Hello"::String)])+           o2 = MkCloudConfigYaml $ YamlObject (object ["k" .= toJSON ("World"::String)])            combined =-             YamlObject (object ["k" .= toJSON ("HelloWorld"::String)])+             MkCloudConfigYaml $ YamlObject (object ["k" .= toJSON ("HelloWorld"::String)])        in (o1 <> o2) `shouldBe` combined
− stack-lts-11.0.yaml 
@@ -1,7 +0,0 @@-flags: {}-packages:-- '.'-extra-deps: []-resolver: lts-11.0-allow-newer: true-# pvp-bounds: lower
− stack-lts-9.4.yaml 
@@ -1,7 +0,0 @@-flags: {}-packages:-- '.'-extra-deps:-- shake-0.16.3-resolver: lts-9.4-# pvp-bounds: lower
− stack-nightly-2018-03-16.yaml 
@@ -1,10 +0,0 @@-flags: {}-packages:-- '.'-extra-deps:-- ConfigFile-1.1.4-- template-0.2.0.10--resolver: nightly-2018-03-16-allow-newer: true-# pvp-bounds: lower
stack.yaml view
@@ -4,6 +4,7 @@ extra-deps: - ConfigFile-1.1.4 - template-0.2.0.10+- extensible-effects-5.0.0.1  resolver: lts-13.3 require-stack-version: ">=1.6.5"