b9 (empty) → 0.2.0
raw patch · 43 files changed
+5263/−0 lines, 43 filesdep +ConfigFiledep +QuickCheckdep +aesonsetup-changed
Dependencies added: ConfigFile, QuickCheck, aeson, async, b9, base, bifunctors, binary, bytestring, conduit, conduit-extra, directory, filepath, hspec, hspec-expectations, mtl, old-locale, optparse-applicative, parsec, pretty, pretty-show, process, random, semigroups, syb, template, text, time, transformers, unordered-containers, vector, yaml
Files
- .gitignore +14/−0
- LICENSE +20/−0
- README.md +365/−0
- Setup.hs +2/−0
- TODO.org +89/−0
- b9.cabal +121/−0
- build_and_run.sh +8/−0
- build_and_test.sh +7/−0
- build_haddock.sh +7/−0
- installDeps.sh +14/−0
- prepare_release.sh +15/−0
- run.sh +11/−0
- src/cli/Main.hs +274/−0
- src/lib/B9.hs +60/−0
- src/lib/B9/ArtifactGenerator.hs +137/−0
- src/lib/B9/ArtifactGeneratorImpl.hs +379/−0
- src/lib/B9/B9Config.hs +175/−0
- src/lib/B9/B9Monad.hs +239/−0
- src/lib/B9/Builder.hs +139/−0
- src/lib/B9/ConfigUtils.hs +148/−0
- src/lib/B9/Content/AST.hs +86/−0
- src/lib/B9/Content/ErlTerms.hs +333/−0
- src/lib/B9/Content/ErlangPropList.hs +106/−0
- src/lib/B9/Content/Generator.hs +29/−0
- src/lib/B9/Content/StringTemplate.hs +145/−0
- src/lib/B9/Content/YamlObject.hs +108/−0
- src/lib/B9/DiskImageBuilder.hs +481/−0
- src/lib/B9/DiskImages.hs +136/−0
- src/lib/B9/ExecEnv.hs +60/−0
- src/lib/B9/LibVirtLXC.hs +316/−0
- src/lib/B9/MBR.hs +77/−0
- src/lib/B9/PartitionTable.hs +21/−0
- src/lib/B9/QCUtil.hs +37/−0
- src/lib/B9/Repository.hs +162/−0
- src/lib/B9/RepositoryIO.hs +149/−0
- src/lib/B9/ShellScript.hs +126/−0
- src/lib/B9/Vm.hs +43/−0
- src/lib/B9/VmBuilder.hs +121/−0
- src/tests/B9/ArtifactGeneratorImplSpec.hs +134/−0
- src/tests/B9/Content/ErlTermsSpec.hs +152/−0
- src/tests/B9/Content/ErlangPropListSpec.hs +111/−0
- src/tests/B9/Content/YamlObjectSpec.hs +105/−0
- src/tests/Spec.hs +1/−0
+ .gitignore view
@@ -0,0 +1,14 @@+*.hi+*.ho+TAGS+*.log+*.profile+/BUILD-*+/dist+/OUT+/cabal.config++/.cabal-sandbox/+/cabal.sandbox.config+/upload_doc.sh+
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2015 Sven Heyll++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,365 @@+# B9 - A Benign VM-Build Tool++Use B9 to compile your software into a deployable set of Linux-VM- or+configuration images, from a set of scripts and input files and templates++The main goal of this tool is to provide a build tool to increase automation and+reduce redundancy when creating configured, ready-to-run VM-images.++It is designed to help implementing what's buzz-worded as _immutable_+infrastructure, by making whole-VM-deployments as safe and a fast as possible.++B9 does not bring infrastructure to run and connect any VM-image in production,+it is merely a build tool to assemble deployable artifacts.++One big thing is that it can produce many machines and cloud-configs from a+single build file, because build files can describe concrete as well as+parameterized generators. It can create parameterized VM-Images by uploading+(e.g. system-)files assembled by syntax aware template application and+combination, all statically checked by during the build.++This sets B9 apart from e.g. cloud-init or other configuration management+systems that provide configuration via user provided dynamic script-programs,+which rely on the user to contain correct error handling.++The general idea is the same as in statically type programming languages: catch+errors as early as possible without relying on the user to create a covering set+of tests/error checks.++Certain sacrifies were made; there might be a steep laerning curve, but you will+eventually get there. The tool at hand works stable and reliable. The build+files are check rigorously, all builds happen in a random build directory and+failure leaves no stale LXC-containers running or multiple GiB of temporary disk+image files around. Also, there is no way modify an existing image in+place. Work on VM-Images is always done on a copy of an image, and to speed+things up, it is possible to explicitly use copy-on-write images.++B9 creates bootable virtual machine images, without necessarily using+virtualization itself.++In essence B9 is a tool for *creation*, *configuration* and *sharing* of VM images and+all peripheral artifacts, it creates:++* VMDK/QCOW2/Raw VM images+* Converted, extracted and resized copies of existing vm images+* Empty VM images with extended 4 file system+* Cloud-Config Images+* Text files from template files with variable interpolation+* Erlang OTP sys.config files+* beqemu-life-installer compatible VM images++B9 creates/converts/assembles virtual disk images as well as any number of+config-input files and executes scripts in LXC containers into which these+images are mounted.++The input is in both cases a single, text-based configuration file wich can be+put along side with other build files (e.g. Makefiles, maven poms, ...).++## Some Random Features:++* Tailored for both software compilation environments and VM image creation+* Creation of cloud-init (NoCloud) ISO images, VFAT images and directories+* Assembly and creation of arbitrary files with safe variable interpolation+* Creation of multiple images/machines/cloud-configs based on creation rules+* Syntax-checked merging of several cloud-config yaml user-data files with+ variable expansion+* Syntax-checked parsing and recombination of Erlang/OTP sys.config files with+ variable expansion+* Reusing and Sharing of vm-images, e.g. via The Internet using 'push' and 'pull'+* Arbitrary command execution inside a guest container+* Execution of interactive commands inside guest containers+* Create empty VM Images with file system+* Builtin config file formatter+* Create CopyOnWrite-Images backed by existing QCow2 or Raw images+* Create disk images from other disk image+* Derive disk images from a partition inside of an existing disk image+* Transparent support for QCOW2, VMDK and Raw (intermediate images will have the appropriate formats)+* Resize images and optionally also file systems inside disk images+* Support for 64-bit and 32-bit guests+* Share directories with the host+* Haskell library for parsing the config files and running builds+* Speed: Smart disk image conversion, raw image preference, flexible configuration, simple profiling+* Configurable Logging+* Automatic build clean-up+* Configurable LibVirtLXC parameters+* Configurable remote (ssh with pubkey auth + rsync) image shareing+* Local caching of shared images++## Compilation from Source++To build B9 first install:++* `ghc` version 7.6 or higher+* `cabal-install` version 1.16 or higher++B9 uses stackage and cabal sandboxes. The build result can be found in+`.cabal-sandbox/bin/`. To run a complete fresh build, execute:++ ./installDeps.sh+ cabal install++To launch b9c run:++ ./build_and_run.sh++To execute a ghci-repl run:++ cabal repl++To execute unit tests run:++ ./build_and_test.sh+++## Installation++To be able to use B9 install++* lxc+* libvirt with lxc support (libvirt-driver-lxc, libvirt-daemon-lxc,...)+* virsh+* qemu+* ext4 tools+* genisoimage+* mtools+* vfat tools+* ssh+* rsync+* bash+* wget+* sudo++B9 has been tested with libvirt version 1.2.12.++Make sure that all neccessary daemons, e.g. `libvirtd.service`, `lxc.service`,..+are active, that SELinux is configured correctly and that the `nbd` kernel+module is loaded.++If neccessary create a libvirt network configuration, e.g. by using+the GUI front-end`virt-manager`.++Depending upon the libvirt and lxc configuration of the system it might be+nessary to allow the user, that will execute `b9c`, password-less `sudo` for+these commands:++* `virsh`+* `rm`+* `cat`+* `cp`+* `mv`++After installing B9 (either from a binary package or by building from source)+all its glory is availbe through a single executable called `b9c`.++When `b9c` is started for the first time, it creates a configuration file in+the users home directory called `~/.b9/b9.conf`. The path to that file can be+changed using command line arguments. Execute:++ b9c -h++for a list of command line parameters and commands.++`b9c` command line arguments always follow this pattern:++ b9c <global-options> <command> <command-options> -- <build-script-extra-args>+++To enable B9 to work correctly on your machine edit the config file and make+necessary adaptions.++## B9 configuration file++This is an example of a B9 configuration file, by default found in+`~/.b9/b9.conf`:++ [global]+ # optional alternative directory for temporary build files. If 'Nothing'+ # the current directory is used.+ build_dir_root: Just "/home/sven/tmp"+ environment_vars: []+ exec_env: LibVirtLXC+ keep_temp_dirs: False+ # if set to 'Just "filename"+ log_file: Nothing+ profile_file: Nothing+ unique_build_dirs: True+ verbosity: Just LogInfo++ [libvirt-lxc]+ connection: lxc:///+ emulator_path: /usr/lib/libvirt/libvirt_lxc+ # contains `Just "libvirt-network-name"` or `Nothing` for your libvirt+ # default network settings+ network: Nothing+ use_sudo: True+ virsh_path: /usr/bin/virsh++Some of the options can also be specified on the command line.++# Writing B9 build files++If you really need to write these file, you are basically f'ed.++For now, look at existing config files and read the sources, if anything,+make sure to read at least the chapter _Anger-Management_ before throwing stuff+around.++More documentation is comming soon!++## General Structure++A B9 configuration describes a single `ArtifactGenerator`. It generates files+belonging to a VM, such as qcow2/raw/vmdk-image file(s) and e.g. cloud-init ISO+image files.++Just to recap: a `something.b9` build file _is_ always ever only a mere+`ArtifactGenerator` literal, no matter how many `Let`, `Each`, `Artifacts`,+etc... you see flying around there.++## Creating artifacts++To get any _real_ artifact out of an artifact generator use the `Artifact`+constructor. It takes *2* parameters an arbitrary id and a describtion of what+the artifact consists of:++ Artifact (IID "some_instance_id")+ (VmImages ... | CloudInit ...)++An artifact can either be a (set of) VM-disk-image(s) likely in combination+with some shell script to install software, etc *or* a static collection of+files put on a cloud-init image(VFAT or ISO or directory).++### Defining artifact generators that produce vm image files++To produce vm image files, e.g. with some software installed use the `VmImages`+artifact generator. It has only *2* parameters:+++ VmImages+ [ ... disk image targets ... ]+ ( ... installation script ...)++Of course it must be wrapped in an `Artifact` definition, so we get this structure:++ Artifact (IID "my_first_image")+ (VmImages [...] (...))++#### ImageTargets++The first argument to `VmImages` is a list of `ImageTarget`. Each describes+a single VM-disk-image. The syntax is:++ ImageTarget+ ImageDestination+ ImageSource+ MountPoint++* An `ImageDestination` specifies if/where to put the output image.+* An `ImageSource` specifies how the image is created or from where it is taken.+* A `MountPoint` specifies where to mount the image during the execution of an+ optional `VmBuild`-script.++### Parameterized artifact generators++B9 supports `$varnam` variable interpolation in all strings anywhere in an+`ArtifactGenerator`:+* All filenames and paths+* All id strings and names+* Template files included via e.g. `Template`+* In every string in `VmScript`s (e.g. in `Run "${cmd}" ["${world}"]`)+* Also in all included template files (e.g. included via `Template`)++Parameters can be defined using `Let`, `Each` and special command line+arguments.++To pass parameters via the command line, append them after the argument delimiter+option `--` which ends the list of regular b9c arguments:++ b9c -v build -f file1.b9 .. -- arg_1 arg_2 ...++The parameters are bound to `${arg_1}`, `${arg_2}`, that is variables indicating+the corresponding *position* on the command line.++To define variables using `Let`, write:++ Let [key-value-pairs, ...]+ [artifactgenerators, ...]++All key-value bindings defined in the first list are available in every artifact+generator contained in the second list (_body_).++A key-value binding, e.g. `("hostname", "www.acme.org")`, consist of two strings+on parens seperated by a `,` (comma). The left string is the key, and the right+string is the value.++This `("webserver", "www.${domainname}")` is an example to show that the *value*+may also contain a variable reference. (Of course, only to variabled defined+*before*)++## Anger-Management++B9 build files contain a single literal `ArtifactGenerator` value+in Haskell syntax. B9 currently 'parses' the config file without any+error checking, so writing config files is VERY frustrating without+some tricks:++### Trick 1++Start with a working file and run++ b9c reformat -f <filename>++after each modification. The `reformat` command only parses and - hence the+name - (re-) formats/pretty-prints the files passed with `-f` options.++You will immediately know if a modification broke the file.++NOTE: If your build file refers to any `${arg_...}` positional arguments pass+them to `reformat` using `--` followed by the argument list.++### Trick 2++Obtain and build the sources of B9, start an interactive haskell shell with the+B9 code loaded and try to paste the contents of the config file to see if ghci+accepts it. Use the ghci macros `:{` and `:}` to begin and end a multi-line input+and paste the raw contents of the config file in question in between.+++ $ cabal install+ $ cabal repl++ ... (many lines omitted) ...++ *B9> :{+ *B9| Artifact (IID "filer")+ *B9| (VmImages [ ImageTarget+ *B9| (LocalFile (Image "EXPORT/machines/filer/disks/0.vmdk" Vmdk Ext4)+ *B9| KeepSize)+ *B9| (From "fedora-20-prod" KeepSize)+ *B9| (MountPoint "/")+ *B9| , ImageTarget+ *B9| (LocalFile (Image "EXPORT/machines/filer/disks/1.vmdk" Vmdk Ext4)+ *B9| KeepSize)+ *B9| (EmptyImage "audio_files" Ext4 Raw (ImageSize 64 GB))+ *B9| (MountPoint "/export/lb/audio")+ *B9| ]+ *B9| (VmScript X86_64+ *B9| [ SharedDirectoryRO "./filer" (MountPoint "/mnt/build_root")+ *B9| , SharedDirectoryRO "../_common/upload" (MountPoint "/mnt/common")]+ *B9| (Begin+ *B9| [ Run "dhclient" []+ *B9| , In "/mnt/build_root" [ Run "./machine-" [] ]+ *B9| , In "/mnt/common" [ Run "./post_export.sh" [] ]+ *B9| ])))+ *B9| :}++ Artifact (IID "filer") (VmImages+ [ImageTarget (LocalFile (Image "EXPORT/machines/filer/disks/0.vmdk" Vmdk Ext4) KeepSize)+ (From "fedora-20-prod" KeepSize) (MountPoint "/"),ImageTarget+ (LocalFile (Image "EXPORT/machines/filer/disks/1.vmdk" Vmdk Ext4) KeepSize)+ (EmptyImage "audio_files" Ext4 Raw (ImageSize 64 GB)) (MountPoint "/export/lb/audio")]+ (VmScript X86_64+ [SharedDirectoryRO "./filer" (MountPoint "/mnt/build_root"),+ SharedDirectoryRO "../_common/upload" (MountPoint "/mnt/common")]+ (Begin [Run "dhclient" [],In "/mnt/build_root" [Run "./machine-" []],In+ "/mnt/common" [Run "./post_export.sh" []]])))
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ TODO.org view
@@ -0,0 +1,89 @@+* 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+* Add building of RPMs and ARCHLINUX packages
+ b9.cabal view
@@ -0,0 +1,121 @@+name: b9+version: 0.2.0+synopsis: A build tool for virtual machines.+description: A tool for creating, modifying, running and sharing VM Images.+license: MIT+license-file: LICENSE+author: Sven Heyll <svh@posteo.de>+maintainer: svh@posteo.de+copyright: 2015 Sven Heyll <svh@posteo.de>+category: Development+build-type: Simple+extra-source-files: README.md, build_and_run.sh, build_and_test.sh, build_haddock.sh, installDeps.sh,+ run.sh, LICENSE, TODO.org, Setup.hs, b9.cabal, .gitignore, prepare_release.sh+cabal-version: >=1.10++source-repository head+ type: git+ location: git://github.com/sheyll/b9-vm-image-builder.git++library+ exposed-modules: B9+ , B9.B9Monad+ , B9.B9Config+ , B9.Builder+ , B9.ConfigUtils+ , B9.ExecEnv+ , B9.DiskImages+ , B9.DiskImageBuilder+ , B9.ShellScript+ , B9.PartitionTable+ , B9.MBR+ , B9.LibVirtLXC+ , B9.Repository+ , B9.RepositoryIO+ , B9.ArtifactGenerator+ , B9.ArtifactGeneratorImpl+ , B9.Vm+ , B9.VmBuilder+ , B9.Content.ErlTerms+ , B9.Content.ErlangPropList+ , B9.Content.YamlObject+ , B9.Content.AST+ , B9.Content.Generator+ , B9.Content.StringTemplate+ , B9.QCUtil+ other-modules: Paths_b9+ -- other-extensions:+ build-depends: ConfigFile >= 1.1.3 && <1.2+ , QuickCheck+ , aeson+ , async >=2.0.1 && <2.1+ , base >=4.7 && <4.8+ , binary >=0.7 && <0.8+ , bytestring >=0.10 && <0.11+ , conduit >=1.2 && <1.3+ , conduit-extra >=1.1 && <1.2+ , directory >=1.2 && <1.3+ , filepath >=1.3 && <1.4+ , mtl >=2.1 && <2.2+ , old-locale >=1.0 && <1.1+ , parsec >= 3.1.8+ , pretty-show+ , pretty+ , process >=1.2 && <1.3+ , random >=1.0 && <1.2+ , semigroups+ , syb >= 0.4.4 && <0.5+ , template+ , text >= 1.2.0.4+ , time >=1.4 && <1.5+ , transformers >=0.3 && <0.4+ , unordered-containers+ , vector >= 0.10.12.2+ , yaml+ , bifunctors+ default-extensions: TupleSections+ , GeneralizedNewtypeDeriving+ , DeriveDataTypeable+ , RankNTypes+ , FlexibleContexts+ , GADTs+ hs-source-dirs: src/lib+ default-language: Haskell2010+ ghc-options: -O3 -with-rtsopts=-N -Wall+ -fwarn-unused-binds -fno-warn-unused-do-bind++executable b9c+ main-is: Main.hs+ -- other-modules:+ -- other-extensions:+ build-depends: b9+ , base >=4.7 && <4.8+ , bytestring >=0.10 && <0.11+ , optparse-applicative >= 0.11.0.1+ hs-source-dirs: src/cli+ default-language: Haskell2010+ ghc-options: -O3 -threaded -with-rtsopts=-N -Wall -Wall+ -fwarn-unused-binds -fno-warn-unused-do-bind++test-suite spec+ type: exitcode-stdio-1.0+ ghc-options: -Wall+ hs-source-dirs: src/tests+ default-language: Haskell2010+ main-is: Spec.hs+ other-modules: B9.Content.ErlTermsSpec+ , B9.Content.ErlangPropListSpec+ , B9.Content.YamlObjectSpec+ , B9.ArtifactGeneratorImplSpec+ build-depends: base >=4.7 && <4.8+ , b9+ , hspec+ , hspec-expectations+ , QuickCheck+ , aeson+ , yaml+ , vector+ , unordered-containers+ , bytestring+ , text+ , semigroups
+ build_and_run.sh view
@@ -0,0 +1,8 @@+#!/bin/sh++# Execute 'b9', if necessary compile it.++set -e++cabal install+./run.sh $@
+ build_and_test.sh view
@@ -0,0 +1,7 @@+#!/bin/bash+# Install dependencies and enable test compilation, then rebuild the sources and+# run all tests.+set -exu+cabal configure --enable-tests --disable-optimization+cabal build+./dist/build/spec/spec
+ build_haddock.sh view
@@ -0,0 +1,7 @@+#!/bin/bash+#+# Create a HTML version of B9 code documentation using haddock.+#+set -xeu++cabal haddock
+ installDeps.sh view
@@ -0,0 +1,14 @@+#!/bin/bash+#+# Install the latest stackage lts snapshot, run cabal clean/update and+# initialize the cabal sandbox.++set -e++cabal clean -v+cabal sandbox delete -v || echo "IGNORING"+rm -f cabal.config+wget http://www.stackage.org/lts/cabal.config+cabal update -v+cabal sandbox -v init+cabal install -v --only-dependencies --enable-tests -j
+ prepare_release.sh view
@@ -0,0 +1,15 @@+#!/bin/bash+#+# Prepare B9 for release:+# * clean the workspace+# * install the dependencies+# * check that the project compiles+# * run all tests+# * build documentation+#+set -eu++./installDeps.sh+./build_and_test.sh+./build_haddock.sh+cabal check
+ run.sh view
@@ -0,0 +1,11 @@+#!/bin/sh++# Execute 'b9', if necessary compile it.++set -e++if [[ ! -x .cabal-sandbox/bin/b9c ]]; then+ cabal install+fi++.cabal-sandbox/bin/b9c $@
+ src/cli/Main.hs view
@@ -0,0 +1,274 @@+module Main where++import Options.Applicative hiding (action)+import Options.Applicative.Help.Pretty++import Paths_b9+import Data.Version++import B9++main :: IO ()+main = do+ b9Opts <- parseCommandLine+ result <- runB9 b9Opts+ exit result+ where+ exit success = when (not success) (exitWith (ExitFailure 128))++parseCommandLine :: IO B9Options+parseCommandLine =+ execParser (info (helper <*> (B9Options <$> 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\+ \\n\+ \Repository names passed to the command line are\+ \ looked up in the B9 configuration file, which is\+ \ on Un*x like system per default located in: \+ \ '~/.b9/b9.config'"+ <> headerDoc (Just helpHeader)))+ where+ helpHeader = linebreak <> text ("B9 - a benign VM-Image build tool v. "+ ++ b9Version)++data B9Options = B9Options GlobalOpts+ BuildAction+ BuildVariables++data GlobalOpts = GlobalOpts { configFile :: Maybe SystemPath+ , cliB9Config :: B9Config }++type BuildAction = Maybe SystemPath -> ConfigParser -> B9Config -> IO Bool++runB9 :: B9Options -> IO Bool+runB9 (B9Options globalOpts action vars) = do+ let cfgWithArgs = cfgCli { envVars = envVars cfgCli ++ vars }+ cfgCli = cliB9Config globalOpts+ cfgFile = configFile globalOpts+ cp <- configure cfgFile cfgCli+ action cfgFile cp cfgWithArgs++runShowVersion :: BuildAction+runShowVersion _cfgFile _cp _conf = do+ putStrLn b9Version+ return True++runBuildArtifacts :: [FilePath] -> BuildAction+runBuildArtifacts buildFiles _cfgFile cp conf = do+ generators <- mapM consult buildFiles+ buildArtifacts (mconcat generators) cp conf++runFormatBuildFiles :: [FilePath] -> BuildAction+runFormatBuildFiles buildFiles _cfgFile _cp _conf = do+ generators <- mapM consult buildFiles+ let generatorsFormatted = map ppShow (generators :: [ArtifactGenerator])+ putStrLn `mapM` (generatorsFormatted)+ (uncurry writeFile) `mapM` (buildFiles `zip` generatorsFormatted)+ return True++runPush :: SharedImageName -> BuildAction+runPush name _cfgFile cp conf = impl+ where+ conf' = conf { keepTempDirs = False }+ impl = run cp conf'+ (if not (isJust (repository conf'))+ then do+ errorL "No repository specified! \+ \ Use '-r' to specify a repo BEFORE 'push'."+ return False+ else do+ pushSharedImageLatestVersion name+ return True)++runPull :: Maybe SharedImageName -> BuildAction+runPull mName _cfgFile cp conf =+ run cp conf' (pullRemoteRepos >> maybePullImage)+ where+ conf' = conf { keepTempDirs = False }+ maybePullImage = maybe (return True) pullLatestImage mName++runListSharedImages :: BuildAction+runListSharedImages _cfgFile cp conf = impl+ where+ conf' = conf { keepTempDirs = False }+ impl = do+ imgs <- run cp conf' getSharedImages+ if null imgs+ then putStrLn "\n\nNO SHAREABLE IMAGES\n"+ else putStrLn "SHAREABLE IMAGES:"+ mapM_ (putStrLn . ppShow) imgs+ return True++runAddRepo :: RemoteRepo -> BuildAction+runAddRepo repo cfgFile cp _conf = do+ repo' <- remoteRepoCheckSshPrivKey repo+ case writeRemoteRepoConfig repo' cp of+ Left er ->+ error (printf "Failed to add remote repo '%s'\+ \ to b9 configuration. The \+ \error was: \"%s\"."+ (show repo) (show er))++ Right cpWithRepo ->+ writeB9Config cfgFile cpWithRepo+ return True++globals :: Parser GlobalOpts+globals = toGlobalOpts+ <$> optional (strOption+ (help "Path to users b9-configuration"+ <> 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"+ <> 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"))++ where+ toGlobalOpts :: Maybe FilePath+ -> Bool+ -> Bool+ -> Maybe FilePath+ -> Maybe FilePath+ -> Maybe FilePath+ -> Bool+ -> Bool+ -> Maybe FilePath+ -> Maybe String+ -> GlobalOpts+ toGlobalOpts cfg verbose quiet logF profF buildRoot keep notUnique+ mRepoCache repo =+ let minLogLevel = if verbose then Just LogTrace else+ if quiet then Just LogError else Nothing+ b9cfg' = let b9cfg = mempty { verbosity = minLogLevel+ , logFile = logF+ , profileFile = profF+ , buildDirRoot = buildRoot+ , keepTempDirs = keep+ , uniqueBuildDirs = not notUnique+ , repository = repo+ }+ in case mRepoCache of+ Nothing -> b9cfg+ Just repoCache ->+ let rc = Path repoCache+ in b9cfg { repositoryCache = rc }+ in GlobalOpts { configFile = (Path <$> cfg) <|> pure defaultB9ConfigFile+ , cliB9Config = b9cfg' }++cmds :: Parser BuildAction+cmds = subparser ( command "version"+ (info (pure runShowVersion)+ (progDesc "Show program version and exit."))+ <> command "build"+ (info (runBuildArtifacts <$> buildFileParser)+ (progDesc "Merge all build file and\+ \ generate all artifacts."))+ <> 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 "list"+ (info (pure 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 (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!")))++buildVars :: Parser BuildVariables+buildVars = zip (("arg_"++) . show <$> ([1..] :: [Int]))+ <$> 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")))++sharedImageNameParser :: Parser SharedImageName+sharedImageNameParser =+ helper <*>+ (SharedImageName <$> strArgument+ (help "Shared image name"+ <> metavar "NAME"))++b9Version :: String+b9Version = showVersion version
+ src/lib/B9.hs view
@@ -0,0 +1,60 @@+{-| B9 is a library and build tool with primitive operations to run a+ build script inside a virtual machine and to create and convert+ virtual machine image files as well as related ISO and VFAT disk images+ for e.g. cloud-init configuration sources.++ This module re-exports the modules needed to build a tool around the+ library, e.g. see @src\/cli\/Main.hs@ as an example.+ -}++module B9+ ( module B9.Builder+ , module System.Exit+ , module System.FilePath+ , module Control.Applicative+ , module Control.Monad+ , module Control.Monad.IO.Class+ , module Data.Monoid+ , module Data.List+ , module Data.Maybe+ , module Text.Printf+ , module Text.Show.Pretty+ , module Data.Version+ , configure+ , b9_version+ ) where++import Control.Applicative+import Control.Monad+import Control.Monad.IO.Class+import Data.Monoid+import Data.List+import Data.Maybe+import Text.Show.Pretty (ppShow)+import System.Exit ( exitWith+ , ExitCode (..) )+import System.FilePath ( takeDirectory+ , takeFileName+ , replaceExtension+ , (</>)+ , (<.>) )+import Text.Printf ( printf )+import Paths_b9 (version)+import Data.Version++import B9.Builder+import qualified B9.LibVirtLXC as LibVirtLXC++-- | Merge 'existingConfig' with the configuration from the main b9 config+-- file. If the file does not exists, a new config file with the given+-- configuration will be written. The return value is a parser for the config+-- file. Returning the raw config file parser allows modules unkown to+-- 'B9.B9Config' to add their own values to the shared config file.+configure :: MonadIO m => Maybe SystemPath -> B9Config -> m ConfigParser+configure b9ConfigPath existingConfig = do+ writeInitialB9Config b9ConfigPath existingConfig LibVirtLXC.setDefaultConfig+ readB9Config b9ConfigPath++-- | Return the cabal package version of the B9 library.+b9_version :: Version+b9_version = version
+ src/lib/B9/ArtifactGenerator.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-|+Top-Level data types for B9 build artifacts.+-}+module B9.ArtifactGenerator+ (ArtifactGenerator(..)+ ,ArtifactSource(..)+ ,InstanceId(..)+ ,ArtifactTarget(..)+ ,CloudInitType(..)+ ,ArtifactAssembly(..)+ ,AssembledArtifact(..)+ --,YamlValue (..)+ ,instanceIdKey+ ,buildIdKey+ ,buildDateKey+ ) where+++import Data.Data+import Data.Monoid -- hiding ((<>))+import Control.Applicative++import B9.DiskImages+import B9.Vm+import B9.Content.StringTemplate+import B9.Content.Generator+import B9.QCUtil++import Test.QuickCheck++-- | A single config generator specifies howto generate multiple output+-- files/directories. It consists of a netsted set of variable bindings that are+-- replaced inside the text files+data ArtifactGenerator = Sources [ArtifactSource] [ArtifactGenerator]+ | Let [(String, String)] [ArtifactGenerator]+ | LetX [(String, [String])] [ArtifactGenerator]+ | EachT [String] [[String]] [ArtifactGenerator]+ | Each [(String,[String])] [ArtifactGenerator]+ | Artifact InstanceId ArtifactAssembly+ | EmptyArtifact+ deriving (Read, Show, Eq)++instance Monoid ArtifactGenerator where+ mempty = Let [] []+ (Let [] []) `mappend` x = x+ x `mappend` (Let [] []) = x+ x `mappend` y = Let [] [x, y]++-- | Explicit is better than implicit: Only files that have explicitly been+-- listed will be included in any generated configuration. That's right: There's+-- no "inlcude *.*". B9 will check that *all* files in the directory specified with 'FromDir' are referred to by nested 'ArtifactSource's.+data ArtifactSource = FromFile FilePath SourceFile+ | FromContent FilePath Content+ | SetPermissions Int Int Int [ArtifactSource]+ | FromDirectory FilePath [ArtifactSource]+ | IntoDirectory FilePath [ArtifactSource]+ | Concatenation FilePath [ArtifactSource]+ deriving (Read, Show, Eq)++newtype InstanceId = IID String+ deriving (Read, Show, Typeable, Data, Eq)++instanceIdKey :: String+instanceIdKey = "instance_id"++buildIdKey :: String+buildIdKey = "build_id"++buildDateKey :: String+buildDateKey = "build_date"++data ArtifactAssembly = CloudInit [CloudInitType] FilePath+ | VmImages [ImageTarget] VmScript+ deriving (Read, Show, Typeable, Data, Eq)++data AssembledArtifact = AssembledArtifact InstanceId [ArtifactTarget]+ deriving (Read, Show, Typeable, Data, Eq)++data ArtifactTarget = CloudInitTarget CloudInitType FilePath+ | VmImagesTarget+ deriving (Read, Show, Typeable, Data, Eq)++data CloudInitType = CI_ISO | CI_VFAT | CI_DIR+ deriving (Read, Show, Typeable, Data, Eq)++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+ , pure (VmImages [] NoVmScript)+ ]++instance Arbitrary CloudInitType where+ arbitrary = elements [CI_ISO,CI_VFAT,CI_DIR]
+ src/lib/B9/ArtifactGeneratorImpl.hs view
@@ -0,0 +1,379 @@+{-|+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 B9.ConfigUtils hiding (tell)+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 Data.Data+import Data.Generics.Schemes+import Data.Generics.Aliases+import Data.List+import Data.Function+import Control.Arrow+import Control.Applicative+import Control.Monad.IO.Class+import Control.Monad.Reader+import Control.Monad.Writer+import Control.Monad.Error+import System.FilePath+import System.Directory+import Text.Printf+import Text.Show.Pretty (ppShow)++-- | Run an artifact generator to produce the artifacts.+assemble :: ArtifactGenerator -> B9 [AssembledArtifact]+assemble artGen = do+ b9cfgEnvVars <- envVars <$> getConfig+ buildId <- getBuildId+ buildDate <- getBuildDate+ let ag = parseArtifactGenerator artGen+ e = CGEnv+ ((buildDateKey, buildDate):(buildIdKey, buildId):b9cfgEnvVars)+ []+ case execCGParser ag e of+ Left (CGError err) ->+ error (printf "error parsing: %s: %s" (ppShow artGen) err)+ Right igs ->+ case execIGEnv `mapM` igs of+ Left err ->+ error (printf "Failed to parse:\n%s\nError: %s"+ (ppShow artGen)+ err)+ Right is ->+ createAssembledArtifacts is++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+ mapM_ ($ mapM_ parseArtifactGenerator gs)+ (withBindings <$> allBindings)+ Each kvs gs -> do+ allBindings <- eachBindingSet g kvs+ mapM_ ($ mapM_ parseArtifactGenerator gs)+ (withBindings <$> allBindings)+ Artifact iid assembly ->+ writeInstanceGenerator iid assembly+ EmptyArtifact ->+ return ()++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 = do+ (flip 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\n\+ \has 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\n\+ \All 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, Error)++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) = do+ IG iid <$> sourceGens <*> pure (substAssembly env assembly)+ where+ sourceGens = join <$> mapM (toSourceGen env) sources++substAssembly :: [(String,String)] -> ArtifactAssembly -> ArtifactAssembly+substAssembly env p = everywhere gsubst p+ where gsubst :: forall a. 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 [SGConcat env (SGFiles [Source conv f']) KeepPerm t']+ FromContent t c -> do+ t' <- substE env t+ return [SGConcat 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 [SGConcat 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 (SGConcat 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 -> do+ 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 = SGConcat [(String,String)] SGSource SGPerm FilePath+ deriving (Read, Show, Eq)++data SGSource = SGFiles [SourceFile] | SGContent Content+ deriving (Read, Show, Eq)++data SGType = SGT | SGF+ deriving (Read, Show, Typeable, Data, Eq)++data SGPerm = SGSetPerm (Int,Int,Int) | KeepPerm+ deriving (Read, Show, Typeable, Data, Eq)+++sgGetFroms :: SourceGenerator -> [SourceFile]+sgGetFroms (SGConcat _ (SGFiles fs) _ _) = fs+sgGetFroms _ = []++setSGPerm :: Int -> Int -> Int -> SourceGenerator+ -> Either String SourceGenerator+setSGPerm o g a (SGConcat env from KeepPerm dest) =+ Right (SGConcat 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 (SGConcat e (SGFiles fs) p d) =+ SGConcat 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 (SGConcat e fs p d) =+ SGConcat 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) = do+ 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 (intercalate " " ((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
@@ -0,0 +1,175 @@+{-# Language DeriveDataTypeable #-}+{-|+Static B9 configuration. Read, write and merge configurable properties.+The properties are independent of specific build targets.+-}+module B9.B9Config ( B9Config(..)+ , defaultB9ConfigFile+ , defaultB9Config+ , getB9ConfigFile+ , writeB9Config+ , writeInitialB9Config+ , readB9Config+ , parseB9Config+ , LogLevel(..)+ , ExecEnvType (..)+ , BuildVariables+ ) where++import Data.Monoid+import Control.Monad+import Control.Exception+import Data.Function (on)+import Control.Monad.IO.Class+import System.Directory+import Text.Printf+import Control.Applicative++import B9.ConfigUtils++type BuildVariables = [(String,String)]++data ExecEnvType = LibVirtLXC 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 :: SystemPath+ , repository :: Maybe String+ } deriving (Show)++instance Monoid B9Config where+ mempty = B9Config Nothing Nothing Nothing False LibVirtLXC Nothing [] True+ defaultRepositoryCache Nothing+ mappend 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 = repositoryCache c'+ , repository = getLast ((mappend `on` (Last . repository)) c c')+ }++defaultB9Config :: B9Config+defaultB9Config = B9Config { verbosity = Just LogInfo+ , logFile = Nothing+ , buildDirRoot = Nothing+ , keepTempDirs = False+ , execEnvType = LibVirtLXC+ , profileFile = Nothing+ , envVars = []+ , uniqueBuildDirs = True+ , repository = Nothing+ , repositoryCache = defaultRepositoryCache+ }++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"+repositoryK :: String+repositoryK = "repository"+cfgFileSection :: String+cfgFileSection = "global"++getB9ConfigFile :: MonadIO m => Maybe SystemPath -> m FilePath+getB9ConfigFile mCfgFile = do+ cfgFile <- resolve (maybe defaultB9ConfigFile id mCfgFile)+ ensureDir cfgFile+ return cfgFile++writeB9Config :: MonadIO m+ => (Maybe SystemPath)+ -> ConfigParser+ -> m ()+writeB9Config cfgFileIn cp = do+ cfgFile <- getB9ConfigFile cfgFileIn+ liftIO (writeFile cfgFile (to_string cp))++writeInitialB9Config :: MonadIO m+ => (Maybe SystemPath)+ -> B9Config+ -> ConfigParser+ -> m ()+writeInitialB9Config Nothing cliCfg cpNonGlobal = writeInitialB9Config+ (Just defaultB9ConfigFile)+ cliCfg+ cpNonGlobal+writeInitialB9Config (Just cfgPath) cliCfg cpNonGlobal = do+ cfgFile <- resolve cfgPath+ ensureDir cfgFile+ exists <- liftIO $ doesFileExist cfgFile+ when (not exists) $+ let res = do+ let cp = emptyCP+ c = defaultB9Config <> cliCfg+ cp1 <- add_section cp cfgFileSection+ cp2 <- setshow cp1 cfgFileSection verbosityK (verbosity c)+ cp3 <- setshow cp2 cfgFileSection logFileK (logFile c)+ cp4 <- setshow cp3 cfgFileSection buildDirRootK (buildDirRoot c)+ cp5 <- setshow cp4 cfgFileSection keepTempDirsK (keepTempDirs c)+ cp6 <- setshow cp5 cfgFileSection execEnvTypeK (execEnvType c)+ cp7 <- setshow cp6 cfgFileSection profileFileK (profileFile c)+ cp8 <- setshow cp7 cfgFileSection envVarsK (envVars c)+ cp9 <- setshow cp8 cfgFileSection uniqueBuildDirsK (uniqueBuildDirs c)+ cpA <- setshow cp9 cfgFileSection repositoryCacheK (repositoryCache c)+ cpB <- setshow cpA cfgFileSection repositoryK (repository c)+ return $ merge cpB cpNonGlobal+ in case res of+ Left e -> liftIO (throwIO (IniFileException cfgFile e))+ Right cp -> liftIO (writeFile cfgFile (to_string cp))++readB9Config :: MonadIO m => (Maybe SystemPath) -> m ConfigParser+readB9Config Nothing = readB9Config (Just defaultB9ConfigFile)+readB9Config (Just cfgFile) = readIniFile cfgFile++parseB9Config :: ConfigParser -> Either String B9Config+parseB9Config cp =+ let getr :: (Get_C a, Read a) => OptionSpec -> Either CPError a+ getr = get cp cfgFileSection+ getB9Config =+ B9Config <$> getr verbosityK+ <*> getr logFileK+ <*> getr buildDirRootK+ <*> getr keepTempDirsK+ <*> getr execEnvTypeK+ <*> getr profileFileK+ <*> getr envVarsK+ <*> getr uniqueBuildDirsK+ <*> getr repositoryCacheK+ <*> getr repositoryK+ in case getB9Config of+ Left err ->+ Left (printf "Failed to parse B9 configuration file: '%s'" (show err))+ Right x ->+ Right x
+ src/lib/B9/B9Monad.hs view
@@ -0,0 +1,239 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-| Definition of the B9 monad. It encapsulates logging, very basic command+execution profiling, a reader for the "B9.B9Config" and access to the+current build id, the current build directory and the artifact to build.++This module is used by the _effectful_ functions in this library.+-}+module B9.B9Monad ( B9 , run , traceL , dbgL , infoL , errorL , getConfigParser+, getConfig , getBuildId , getBuildDate , getBuildDir , getExecEnvType ,+getSelectedRemoteRepo , getRemoteRepos , getRepoCache , cmd ) where++import B9.B9Config+import B9.ConfigUtils+import B9.Repository+import Control.Applicative+import Control.Exception ( bracket )+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.State++import qualified Data.ByteString.Char8 as B+import Data.Functor ()+import Data.Maybe+import Data.Time.Clock+import Data.Time.Format+import Data.Word ( Word32 )+import System.Directory+import System.Exit+import System.FilePath+import System.Locale ( defaultTimeLocale )+import System.Random ( randomIO )+import Text.Printf+import Control.Concurrent.Async (Concurrently (..))+import Data.Conduit (($$))+import qualified Data.Conduit.List as CL+import Data.Conduit.Process++data BuildState = BuildState { bsBuildId :: String+ , bsBuildDate :: String+ , bsCfgParser :: ConfigParser+ , bsCfg :: B9Config+ , bsBuildDir :: FilePath+ , bsSelectedRemoteRepo :: Maybe RemoteRepo+ , bsRemoteRepos :: [RemoteRepo]+ , bsRepoCache :: RepoCache+ , bsProf :: [ProfilingEntry]+ , bsStartTime :: UTCTime+ , bsInheritStdIn :: Bool+ }++data ProfilingEntry = IoActionDuration NominalDiffTime+ | LogEvent LogLevel String+ deriving (Eq, Show)++run :: ConfigParser -> B9Config -> B9 a -> IO a+run cfgParser cfg action = do+ buildId <- generateBuildId+ now <- getCurrentTime+ bracket (createBuildDir buildId) removeBuildDir (run' buildId now)+ where+ run' buildId now buildDir = do+ -- Check repositories+ repoCache <- initRepoCache (repositoryCache cfg)+ let remoteRepos = getConfiguredRemoteRepos cfgParser+ remoteRepos' <- mapM (initRemoteRepo repoCache) remoteRepos+ let ctx = BuildState buildId buildDate cfgParser cfg buildDir+ selectedRemoteRepo remoteRepos' repoCache+ [] now True+ buildDate = formatTime undefined "%F-%T" now+ 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 buildId = do+ if uniqueBuildDirs cfg then do+ let subDir = "BUILD-" ++ buildId+ buildDir <- resolveBuildDir subDir+ createDirectory buildDir+ canonicalizePath buildDir+ else do+ let subDir = "BUILD-" ++ buildId+ buildDir <- resolveBuildDir subDir+ createDirectoryIfMissing True buildDir+ canonicalizePath buildDir+ where+ resolveBuildDir f = do+ case buildDirRoot cfg of+ Nothing ->+ return f+ Just root' -> do+ createDirectoryIfMissing True root'+ root <- canonicalizePath root'+ return $ root </> f++ removeBuildDir buildDir =+ when (uniqueBuildDirs cfg && not (keepTempDirs cfg))+ $ removeDirectoryRecursive buildDir++ generateBuildId = printf "%08X" <$> (randomIO :: IO Word32)++ -- Run the action build action+ wrappedAction = do+ startTime <- gets bsStartTime+ r <- action+ now <- liftIO getCurrentTime+ let duration = show (now `diffUTCTime` startTime)+ infoL (printf "DURATION: %s" duration)+ return r+++getBuildId :: B9 FilePath+getBuildId = gets bsBuildId++getBuildDate :: B9 String+getBuildDate = gets bsBuildDate++getBuildDir :: B9 FilePath+getBuildDir = gets bsBuildDir++getConfigParser :: B9 ConfigParser+getConfigParser = gets bsCfgParser++getConfig :: B9 B9Config+getConfig = gets bsCfg++getExecEnvType :: B9 ExecEnvType+getExecEnvType = gets (execEnvType . bsCfg)++getSelectedRemoteRepo :: B9 (Maybe RemoteRepo)+getSelectedRemoteRepo = gets bsSelectedRemoteRepo++getRemoteRepos :: B9 [RemoteRepo]+getRemoteRepos = gets bsRemoteRepos++getRepoCache :: B9 RepoCache+getRepoCache = gets bsRepoCache++cmd :: String -> B9 ()+cmd str = do+ inheritStdIn <- gets bsInheritStdIn+ if inheritStdIn+ then interactive str+ else nonInteractive str++interactive :: String -> B9 ()+interactive str = void (cmdWithStdIn str :: B9 Inherited)++nonInteractive :: String -> B9 ()+nonInteractive str = void (cmdWithStdIn str :: B9 ClosedStream)++cmdWithStdIn :: (InputSource stdin) => String -> B9 stdin+cmdWithStdIn cmdStr = do+ traceL $ "COMMAND: " ++ cmdStr+ (cpIn, cpOut, cpErr, cph) <- streamingProcess (shell cmdStr)+ cmdLogger <- getCmdLogger+ e <- liftIO $ runConcurrently $+ Concurrently (cpOut $$ cmdLogger LogTrace) *>+ Concurrently (cpErr $$ cmdLogger LogInfo) *>+ Concurrently (waitForStreamingProcess cph)+ checkExitCode e+ return cpIn+ where+ getCmdLogger = do+ lv <- gets $ verbosity . bsCfg+ lf <- gets $ logFile . bsCfg+ return $ \ level -> (CL.mapM_ (logImpl lv lf level . B.unpack))++ checkExitCode ExitSuccess =+ traceL $ "COMMAND SUCCESS"+ checkExitCode ec@(ExitFailure e) = do+ errorL $ printf "COMMAND '%s' FAILED: %i!" cmdStr e+ liftIO $ exitWith ec++traceL :: String -> B9 ()+traceL = b9Log LogTrace++dbgL :: String -> B9 ()+dbgL = b9Log LogDebug++infoL :: String -> B9 ()+infoL = b9Log LogInfo++errorL :: String -> B9 ()+errorL = b9Log LogError++b9Log :: LogLevel -> String -> B9 ()+b9Log level msg = do+ lv <- gets $ verbosity . bsCfg+ lf <- gets $ logFile . bsCfg+ modify $ \ ctx -> ctx { bsProf = LogEvent level msg : bsProf ctx }+ B9 $ liftIO $ logImpl lv lf level msg++logImpl :: Maybe LogLevel -> Maybe FilePath -> LogLevel -> String -> IO ()+logImpl minLevel mf level msg = do+ lm <- formatLogMsg level msg+ when (isJust minLevel && level >= fromJust minLevel) (putStr lm)+ when (isJust mf) (appendFile (fromJust mf) lm)++formatLogMsg :: LogLevel -> String -> IO String+formatLogMsg l msg = do+ utct <- getCurrentTime+ let time = formatTime defaultTimeLocale "%H:%M:%S" utct+ 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 "++newtype B9 a = B9 { runB9 :: StateT BuildState IO a }+ deriving ( Functor+ , Applicative+ , Monad+ , MonadState BuildState+ )++instance MonadIO B9 where+ liftIO m = do+ start <- B9 $ liftIO getCurrentTime+ res <- B9 $ liftIO m+ stop <- B9 $ liftIO getCurrentTime+ let durMS = IoActionDuration (stop `diffUTCTime` start)+ modify $+ \ ctx ->+ ctx { bsProf = durMS : bsProf ctx }+ return res
+ src/lib/B9/Builder.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE GADTs #-}+{-|+Highest-level build functions and and B9-re-exports.+-}+module B9.Builder ( module B9.B9Monad+ , module B9.ConfigUtils+ , module B9.B9Config+ , module B9.ExecEnv+ , module B9.DiskImages+ , module B9.DiskImageBuilder+ , module B9.ShellScript+ , module B9.Repository+ , module B9.RepositoryIO+ , module B9.ArtifactGenerator+ , module B9.ArtifactGeneratorImpl+ , module B9.Vm+ , module B9.VmBuilder+ , module B9.Content.AST+ , module B9.Content.StringTemplate+ , module B9.Content.ErlTerms+ , module B9.Content.ErlangPropList+ , module B9.Content.YamlObject+ , module B9.Content.Generator+ , module B9.QCUtil+ , buildArtifacts+ ) where++import Data.Monoid+import Text.Printf ( printf )+import Text.Show.Pretty (ppShow)++import B9.B9Monad+import B9.ConfigUtils+import B9.B9Config+import B9.ExecEnv+import B9.DiskImages+import B9.DiskImageBuilder+import B9.ShellScript+import B9.Repository+import B9.RepositoryIO+import B9.ArtifactGenerator+import B9.ArtifactGeneratorImpl+import B9.Vm+import B9.VmBuilder+import B9.QCUtil++import B9.Content.AST+import B9.Content.StringTemplate+import B9.Content.ErlTerms+import B9.Content.ErlangPropList+import B9.Content.YamlObject+import B9.Content.Generator++buildArtifacts :: ArtifactGenerator -> ConfigParser -> B9Config -> IO Bool+buildArtifacts artifactGenerator cfgParser cliCfg =+ withB9Config cfgParser cliCfg $ \cfg ->+ run cfgParser cfg $ do+ infoL "BUILDING ARTIFACTS"+ getConfig >>= traceL . printf "USING BUILD CONFIGURATION: %v" . ppShow+ assemble artifactGenerator+ return True++withB9Config :: ConfigParser+ -> B9Config+ -> (B9Config -> IO Bool)+ -> IO Bool+withB9Config cfgParser cliCfg f = do+ let parsedCfg' = parseB9Config cfgParser+ case parsedCfg' of+ Left e -> do+ putStrLn (printf "B9 Failed to start: %s" e)+ return False+ Right parsedCfg ->+ let cfg = defaultB9Config <> parsedCfg <> cliCfg+ in f cfg++{-+xxx :: ArtifactGenerator+xxx =+ Each+ [("domain", ["tec.lbaum.eu"+ ,"test.meetyoo.de"])+ ,("altdomain", ["tec.lbaum.eu"+ ,"testyoo.de"])+ ,("ip_prefix", ["10.1.40"+ ,"192.168.111"])+ ,("ip_prefix_erl", ["10,1,40"+ ,"192,168,111"])+ ,("chassis_config", ["COMMON/chassis/switchraumOG4-motorola"+ ,"COMMON/chassis/meetyoo-test"])+ ,("sipstack_config", ["COMMON/sipstack/lbm-QSC"+ ,"COMMON/sipstack/meetyoo-test"])+ ,("outbound_proxies_config", ["COMMON/outbound_proxies/lbm-QSC"+ ,"COMMON/outbound_proxies/meetyoo-test"])+ ]+ [Let+ [("dns","ns1.${domain}")+ ,("dns_ip", "${ip_prefix}.10")+ ,("gw", "lb-gw1.${domain}")+ ,("gw_ip","${ip_prefix}.254")+ ,("syslog","lb-log1.${domain}")+ ,("syslog_ip", "${ip_prefix}.110")+ ,("mail", "mail.${altdomain}")+ ,("mail_ip", "${ip_prefix}.11")+ ,("file_server", "lb-ds1.${domain}")+ ,("file_server_ip", "${ip_prefix}.111")+ ,("tts", "lb-tts1.${domain}")+ ,("tts_ip", "${ip_prefix}.102")+ ,("mrfc", "lb-mrfc1.${domain}")+ ,("mrfc_ip", "${ip_prefix}.103")+ ,("sipproxy", "lb-sipproxy1.${domain}")+ ,("db", "lb-db1.${domain}")+ ,("db_ip", "${ip_prefix}.101")+ ,("app", "lb-app1.${domain}")+ ,("app_ip", "${ip_prefix}.100")+ ,("freeswitch", "lb-fs1.${domain}")+ ,("freeswitch_ip", "${ip_prefix}.113")+ ,("mp1", "lb-mp1.${domain}")+ ,("mp1_ip", "${ip_prefix}.112")+ ,("mrfp1", "lb-mrfp1.${domain}")+ ,("mrfp1_ip", "${ip_prefix}.106")+ ,("display1", "lb-dp1.${domain}")+ ,("display1_ip", "${ip_prefix}.105")+ ,("rtpproxy1", "lb-rp1.${domain}")+ ,("rtpproxy1_ip", "${ip_prefix}.120")]+ [Sources [YamlLiteral+ "user-data"+ (YamlDict+ [("write_files"+ ,YamlEmbedString+ (ErlangTerms+ "runtime.config"+ [Template "${chassis_config}", Template "${sipstack_config}"]))])+ ]+ [Artifact (IID "$hostname")+ (CloudInit [CI_DIR,CI_ISO] "${out_dir}/mrfp/cloud-init/${instance_id}")+ ]+ ]]+-}
+ src/lib/B9/ConfigUtils.hs view
@@ -0,0 +1,148 @@+{-# Language DeriveDataTypeable #-}+{-| Extensions to 'Data.ConfigFile' and utility functions for dealing with+ configuration in general and reading/writing files. -}+module B9.ConfigUtils ( allOn+ , lastOn+ , SystemPath (..)+ , resolve+ , ensureDir+ , readIniFile+ , getOptionM+ , getOption+ , getOptionOr+ , IniFileException(..)+ , module Data.ConfigFile+ , UUID (..)+ , randomUUID+ , tell+ , consult+ , getDirectoryFiles+ , maybeConsult+ , maybeConsultSystemPath+ ) where++import Data.Monoid+import Data.Function ( on )+import Data.Typeable+import Control.Applicative+import Control.Exception+import Control.Monad.IO.Class+import System.Directory+import Text.Read ( readEither )+import System.Random ( randomIO )+import Data.Word ( Word16, Word32 )+import System.FilePath+import Text.Printf+import Data.ConfigFile+import Data.Data+import Text.Show.Pretty (ppShow)++allOn :: (a -> Maybe Bool) -> a -> a -> Maybe Bool+allOn getter x y = getAll <$> on mappend (fmap All . getter) x y++lastOn :: (a -> Maybe b) -> a -> a -> Maybe b+lastOn getter x y = getLast $ on mappend (Last . getter) x y++data SystemPath = Path FilePath+ | InHomeDir FilePath+ | InB9UserDir FilePath+ | InTempDir FilePath+ deriving (Eq, Read, Show, Typeable, Data)++resolve :: MonadIO m => SystemPath -> m FilePath+resolve (Path p) = return p+resolve (InHomeDir p) = liftIO $ do+ d <- getHomeDirectory+ return $ d </> p+resolve (InB9UserDir p) = liftIO $ do+ d <- getAppUserDataDirectory "b9"+ return $ d </> p+resolve (InTempDir p) = liftIO $ do+ d <- getTemporaryDirectory+ return $ d </> p++-- | Get all files from 'dir' that is get ONLY files not directories+getDirectoryFiles :: MonadIO m => FilePath -> m [FilePath]+getDirectoryFiles dir = do+ entries <- liftIO (getDirectoryContents dir)+ fileEntries <- mapM (liftIO . doesFileExist . (dir </>)) entries+ return (snd <$> filter fst (fileEntries `zip` entries))++ensureDir :: MonadIO m => FilePath -> m ()+ensureDir p = liftIO (createDirectoryIfMissing True $ takeDirectory p)++data ReaderException = ReaderException FilePath String+ deriving (Show, Typeable)+instance Exception ReaderException++tell :: (MonadIO m, Show a) => FilePath -> a -> m ()+tell f x = do+ ensureDir f+ liftIO (writeFile f (ppShow x))++consult :: (MonadIO m, Read a) => FilePath -> m a+consult f = liftIO $ do+ c <- readFile f+ case readEither c of+ Left e ->+ throwIO $ ReaderException f e+ Right a ->+ return a++maybeConsult :: (MonadIO m, Read a) => Maybe FilePath -> a -> m a+maybeConsult Nothing defaultArg = return defaultArg+maybeConsult (Just f) defaultArg = liftIO $ do+ exists <- doesFileExist f+ if exists+ then do consult f+ else return defaultArg++maybeConsultSystemPath :: (MonadIO m, Read a) => Maybe SystemPath -> a -> m a+maybeConsultSystemPath Nothing defaultArg = return defaultArg+maybeConsultSystemPath (Just f) defaultArg = liftIO $ do+ f' <- resolve f+ exists <- doesFileExist f'+ if exists+ then do consult f'+ else return defaultArg++data IniFileException = IniFileException FilePath CPError+ deriving (Show, Typeable)+instance Exception IniFileException++readIniFile :: MonadIO m => SystemPath -> m ConfigParser+readIniFile cfgFile' = do+ cfgFile <- resolve cfgFile'+ cp' <- liftIO $ readfile emptyCP cfgFile+ case cp' of+ Left e -> liftIO $ throwIO (IniFileException cfgFile e)+ Right cp -> return cp++getOption :: (Get_C a, Monoid a) => ConfigParser -> SectionSpec -> OptionSpec -> a+getOption cp sec key = either (const mempty) id $ get cp sec key++getOptionM :: (Get_C a, Read a) => ConfigParser -> SectionSpec -> OptionSpec -> Maybe a+getOptionM cp sec key = either (const Nothing) id $ get cp sec key++getOptionOr :: (Get_C a, Read a) => ConfigParser -> SectionSpec -> OptionSpec -> a -> a+getOptionOr cp sec key dv = either (const dv) id $ get cp sec key++newtype UUID = UUID (Word32, Word16, Word16, Word16, Word32, Word16)+ deriving (Read, Show, Eq, Ord)++instance PrintfArg UUID where+ formatArg (UUID (a, b, c, d, e, f)) fmt+ | fmtChar (vFmt 'U' fmt) == 'U' =+ let str = (printf "%08x-%04x-%04x-%04x-%08x%04x" a b c d e f :: String)+ in formatString str (fmt { fmtChar = 's', fmtPrecision = Nothing })+ | otherwise = errorBadFormat $ fmtChar fmt+++randomUUID :: MonadIO m => m UUID+randomUUID = liftIO (UUID <$> ((,,,,,)+ <$> randomIO+ <*> randomIO+ <*> randomIO+ <*> randomIO+ <*> randomIO+ <*> randomIO))
+ src/lib/B9/Content/AST.hs view
@@ -0,0 +1,86 @@+{-|++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 'writefiles' 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 qualified Data.ByteString as B+import Data.Semigroup+import Data.Data+import Control.Applicative+import Control.Monad.IO.Class+import Control.Monad.Reader++import B9.Content.StringTemplate++import Test.QuickCheck+import B9.QCUtil++class (Semigroup a) => ConcatableSyntax a where+ decodeSyntax :: FilePath -> B.ByteString -> Either String a+ encodeSyntax :: a -> B.ByteString++instance ConcatableSyntax B.ByteString where+ decodeSyntax _ = Right+ encodeSyntax = id++-- | A simple AST wrapper for merging embeded ASTs+data AST c a = ASTObj [(String, AST c a)]+ | ASTArr [AST c a]+ | ASTMerge [AST c a]+ | ASTEmbed c+ | ASTString String+ | ASTParse SourceFile+ | AST a+ deriving (Read, Show, Typeable, Data, Eq)++-- | Structure data into an abstract syntax tree+class (ConcatableSyntax a) => ASTish a where+ fromAST :: (CanRender c+ ,Applicative m+ ,Monad m+ ,MonadIO m+ ,MonadReader Environment m)+ => AST c a+ -> m a++-- | Things that produce byte strings.+class CanRender c where+ render :: (Functor m+ ,Applicative m+ ,MonadIO m+ ,MonadReader Environment m)+ => c+ -> m 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 view
@@ -0,0 +1,333 @@+{-| Erlang term parser and pretty printer. -}+module B9.Content.ErlTerms (parseErlTerm+ ,renderErlTerm+ ,SimpleErlangTerm(..)+ ,arbitraryErlSimpleAtom+ ,arbitraryErlString+ ,arbitraryErlNumber+ ,arbitraryErlNatural+ ,arbitraryErlFloat+ ,arbitraryErlNameChar) where++import Data.Data+import Data.Function+import qualified Data.ByteString.Char8 as B+import Text.Parsec.ByteString+import Text.Parsec+import Test.QuickCheck+import Control.Applicative ((<$>), pure, (<*>))+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)++-- | 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 =+ if all (`elem` (['a'..'z']++['A'..'Z']++['0'..'9']++"@_")) a'+ then a'+ else "'"++a'++"'"+ a' = toErlAtomString a++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+ aErlString n =+ ErlString <$> resize (n-1) (listOf (choose (toEnum 0,toEnum 255)))+ aErlFloat n = do+ f <- resize (n-1) arbitrary :: Gen Float+ let d = fromRational (toRational f)+ return (ErlFloat d)+ aErlNatural n =+ ErlNatural <$> resize (n-1) arbitrary+ aErlChar n =+ ErlChar <$> resize (n-1) (choose (toEnum 0, toEnum 255))+ aErlAtomUnquoted n = do+ f <- choose ('a','z')+ rest <- resize (n-1) aErlNameString+ return (ErlAtom (f:rest))+ aErlAtomQuoted n = do+ cs <- resize (n-1) aParsableErlString+ return (ErlAtom ("'" ++ cs ++ "'"))+ aErlBinary n =+ ErlBinary <$> resize (n-1) (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 =+ ['0' , 'b' , 'd' , 'e' , 'f' , 'n' , 'r' , 's' , 't' , 'v' ,'\\','\"','\'']+ replacements =+ ['\NUL', '\BS','\DEL','\ESC','\FF','\LF','\CR','\SP','\HT','\VT','\\','\"','\'']+ 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 view
@@ -0,0 +1,106 @@+{-| A wrapper around erlang and yaml syntax with a proplist-like behaviour in the+ ConcatableSyntax instances -}+module B9.Content.ErlangPropList ( ErlangPropList (..)+ ) where++import Data.Data+import qualified Data.Text as T+import qualified Data.Text.Encoding as E+import Data.Function+import Data.List (partition,sortBy)+import Data.Semigroup+import Control.Applicative+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)++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 (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 view
@@ -0,0 +1,29 @@+{-| The basic data structure that ties together syntax trees making them+ composable and addressable in B9 artifacts. -}+module B9.Content.Generator where++import Data.Data+import Control.Applicative++import B9.Content.AST+import B9.Content.ErlangPropList+import B9.Content.YamlObject+import B9.Content.StringTemplate++import Test.QuickCheck+import B9.QCUtil++data Content = RenderErlang (AST Content ErlangPropList)+ | RenderYaml (AST Content YamlObject)+ | FromTextFile SourceFile+ deriving (Read, Show, Typeable, Eq)++instance Arbitrary Content where+ arbitrary = oneof [FromTextFile <$> smaller arbitrary+ ,RenderErlang <$> smaller arbitrary+ ,RenderYaml <$> smaller arbitrary]++instance CanRender Content where+ render (RenderErlang ast) = encodeSyntax <$> fromAST ast+ render (RenderYaml ast) = encodeSyntax <$> fromAST ast+ render (FromTextFile s) = readTemplateFile s
+ src/lib/B9/Content/StringTemplate.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE FlexibleContexts #-}+{-| Utility functions bnased 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++import Data.Text.Template (render,templateSafe,renderA)+import Data.Data+import Data.Maybe+import Control.Monad.Reader+import qualified Data.Text as T+import qualified Data.ByteString.Lazy as LB+import qualified Data.ByteString as B+import Data.Text.Encoding as E+import Data.Text.Lazy.Encoding as LE+import Control.Arrow hiding (second)+import Control.Applicative+import Data.Bifunctor+import Text.Show.Pretty (ppShow)+import Test.QuickCheck+import Text.Printf++import B9.ConfigUtils+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)++data SourceFileConversion = NoConversion | ExpandVariables+ deriving (Read, Show, Typeable, Data, Eq)++data Environment = Environment [(String,String)]++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'\n\+ \In 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 view
@@ -0,0 +1,108 @@+{-| A wrapper around erlang and yaml syntax with a proplist-like behaviour in+ the ConcatableSyntax instances -}+module B9.Content.YamlObject ( YamlObject (..)+ ) where++import qualified Data.Text as T+import qualified Data.Text.Encoding as E+import Data.Yaml+import Data.Function+import Data.HashMap.Strict hiding (singleton)+import Data.Vector ((++), singleton)+import Prelude hiding ((++))+import Data.Semigroup+import Control.Applicative+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 Data.Yaml.Value+ deriving (Eq)++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 t1 t2 =+ array [t1,t2]++instance ConcatableSyntax YamlObject where+ decodeSyntax src str = do+ 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 -> do+ return (YamlObject (toJSON str))+ 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
+ src/lib/B9/DiskImageBuilder.hs view
@@ -0,0 +1,481 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-| Effectful functions that create and convert disk image files. -}+module B9.DiskImageBuilder (materializeImageSource+ ,substImageTarget+ ,preferredDestImageTypes+ ,preferredSourceImageTypes+ ,resolveImageSource+ ,createDestinationImage+ ,resizeImage+ ,importImage+ ,exportImage+ ,exportAndRemoveImage+ ,convertImage+ ,shareImage+ ,ensureAbsoluteImageDirExists+ ,pushSharedImageLatestVersion+ ,lookupSharedImages+ ,getSharedImages+ ,pullRemoteRepos+ ,pullLatestImage+ ,) where++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.Monoid+import Data.Function+import Control.Applicative+import Text.Show.Pretty (ppShow)+import Data.List+import Data.Data+import Data.Generics.Schemes+import Data.Generics.Aliases++import B9.B9Monad+import B9.Repository+import B9.RepositoryIO+import B9.DiskImages+import qualified B9.PartitionTable as P+import B9.ConfigUtils+import B9.Content.StringTemplate+++-- | Replace $... variables inside an 'ImageTarget'+substImageTarget :: [(String,String)] -> ImageTarget -> ImageTarget+substImageTarget env p = everywhere gsubst p+ where gsubst :: forall a. 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'. Note however that this source will+-- may not exist as is the case for 'EmptyImage'.+resolveImageSource :: ImageSource -> B9 Image+resolveImageSource src = do+ case src of+ (EmptyImage fsLabel fsType imgType _size) ->+ let img = Image fsLabel imgType fsType+ in return (changeImageFormat imgType img)+ (SourceImage srcImg _part _resize) ->+ liftIO (ensureAbsoluteImageDirExists srcImg)+ (CopyOnWrite backingImg) ->+ liftIO (ensureAbsoluteImageDirExists backingImg)+ (From name _resize) -> do+ latestImage <- getLatestImageByName name+ liftIO (ensureAbsoluteImageDirExists latestImage)++-- | 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) -> do+ sharedImg <- getLatestImageByName name+ preferredDestImageTypes (SourceImage sharedImg NoPT resize)++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]++allowedImageTypesForResize :: ImageResize -> [ImageType]+allowedImageTypesForResize r =+ case r of+ Resize _ -> [Raw]+ ShrinkToMinimum -> [Raw]+ _ -> [Raw, QCow2, Vmdk]++ensureAbsoluteImageDirExists :: Image -> IO Image+ensureAbsoluteImageDirExists img@(Image path _ _) = do+ let dir = takeDirectory path+ createDirectoryIfMissing True dir+ dirAbs <- canonicalizePath dir+ return $ changeImageDirectory dirAbs img++-- | Create an image from an image source. The destination image must have a+-- compatible image type and filesyste. 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) -> do+ sharedImg <- getLatestImageByName name+ 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))++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 ()++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'))+ | otherwise = do+ let (Image imgFile imgFmt imgFs) = dest+ dbgL (printf "Creating empty raw image '%s' with size %s" imgFile+ (toQemuSizeOptVal imgSize))+ cmd (printf "qemu-img create -f %s '%s' '%s'"+ (imageFileExtension imgFmt)+ imgFile+ (toQemuSizeOptVal imgSize))+ case (imgFmt, imgFs) of+ (Raw, Ext4) -> do+ let fsCmd = "mkfs.ext4"+ dbgL (printf "Creating file system %s" (show imgFs))+ cmd (printf "%s -L '%s' -q '%s'" fsCmd fsLabel imgFile)+ (it, fs) -> do+ 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)++-- | Resize an image, including the file system inside the image.+resizeImage :: ImageResize -> Image -> B9 ()+resizeImage KeepSize _ = return ()+resizeImage (Resize newSize) (Image img Raw Ext4) = 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 Ext4) = 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))+++-- | Import a disk image from some external source into the build directory+-- if necessary convert the image.+importImage :: Image -> Image -> B9 ()+importImage = convert False++-- | Export a disk image from the build directory; if necessary convert the image.+exportImage :: Image -> Image -> B9 ()+exportImage = convert False++-- | Export a disk image from the build directory; if necessary convert the image.+exportAndRemoveImage :: Image -> Image -> B9 ()+exportAndRemoveImage = convert True++-- | Convert an image in the build directory to another format and return the new image.+convertImage :: Image -> Image -> B9 ()+convertImage imgIn imgOut = convert True imgIn imgOut++-- | Convert/Copy/Move images+convert :: Bool -> Image -> Image -> B9 ()+convert doMove (Image imgIn fmtIn _) (Image imgOut fmtOut _)+ | imgIn == imgOut = do+ ensureDir imgOut+ dbgL (printf "No need to convert: '%s'" imgIn)++ | doMove && fmtIn == fmtOut = do+ ensureDir imgOut+ dbgL (printf "Moving '%s' to '%s'" imgIn imgOut)+ liftIO (renameFile imgIn imgOut)++ | otherwise = do+ ensureDir imgOut+ dbgL (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'"+ (imageFileExtension fmtIn) (imageFileExtension fmtOut)+ imgIn imgOut)+ when doMove $ do+ dbgL (printf "Removing '%s'" imgIn)+ liftIO (removeFile imgIn)++toQemuSizeOptVal :: ImageSize -> String+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+shareImage :: Image -> SharedImageName -> B9 SharedImage+shareImage buildImg sname@(SharedImageName name) = do+ sharedImage <- createSharedImageInCache buildImg sname+ infoL (printf "SHARED '%s'" name)+ pushToSelectedRepo sharedImage+ return sharedImage++-- | Return a 'SharedImage' with the current build data and build id from the+-- name and disk image.+getSharedImageFromImageInfo :: SharedImageName -> Image -> B9 SharedImage+getSharedImageFromImageInfo name (Image _ imgType imgFS) = do+ buildId <- getBuildId+ date <- getBuildDate+ return (SharedImage name+ (SharedImageDate date)+ (SharedImageBuildId buildId)+ imgType+ imgFS)++-- | Convert the disk image and serialize the base image data structure.+createSharedImageInCache :: Image -> SharedImageName -> B9 SharedImage+createSharedImageInCache img sname@(SharedImageName name) = do+ dbgL (printf "CREATING SHARED IMAGE: '%s' '%s'" (ppShow img) name)+ sharedImg <- getSharedImageFromImageInfo sname img+ dir <- getSharedImagesCacheDir+ convertImage img (changeImageDirectory dir (sharedImageImage sharedImg))+ tell (dir </> sharedImageFileName sharedImg) sharedImg+ dbgL (printf "CREATED SHARED IMAGE IN CAHCE '%s'" (ppShow sharedImg))+ return sharedImg+++-- | Publish the latest version of a shared image identified by name to the+-- selected repository from the cache.+pushSharedImageLatestVersion :: SharedImageName -> B9 ()+pushSharedImageLatestVersion (SharedImageName imgName) = do+ sharedImage <- getLatestSharedImageByNameFromCache 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 ()+pushToSelectedRepo i = do+ c <- getSharedImagesCacheDir+ r <- getSelectedRemoteRepo+ when (isJust r) $ do+ let (Image imgFile' _imgType _imgFS) = sharedImageImage i+ cachedImgFile = c </> imgFile'+ cachedInfoFile = c </> sharedImageFileName i+ repoImgFile = sharedImagesRootDirectory </> imgFile'+ repoInfoFile = sharedImagesRootDirectory </> sharedImageFileName i+ pushToRepo (fromJust r) cachedImgFile repoImgFile+ pushToRepo (fromJust r) cachedInfoFile repoInfoFile++-- | Pull metadata files from all remote repositories.+pullRemoteRepos :: B9 ()+pullRemoteRepos = do+ repos <- getSelectedRepos+ mapM_ dl repos+ 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 Bool+pullLatestImage (SharedImageName name) = do+ repos <- getSelectedRepos+ let repoPredicate Cache = False+ repoPredicate (Remote repoId) = repoId `elem` repoIds+ repoIds = map remoteRepoRepoId repos+ hasName sharedImage = name == siName sharedImage+ candidates <- lookupSharedImages repoPredicate hasName+ let (Remote repoId, image) = head (reverse candidates)+ if null candidates+ then do errorL (printf "No shared image named '%s'\+ \ on these remote repositories: '%s'"+ name+ (ppShow repoIds))+ return False+ 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+ pullFromRepo repo repoInfoFile cachedInfoFile+ infoL (printf "PULLED '%s' FROM '%s'"+ name+ repoId)+ return True+++-- | Return the 'Image' of the latest version of a shared image named 'name'+-- from the local cache.+getLatestImageByName :: String -> B9 Image+getLatestImageByName name = do+ sharedImage <- getLatestSharedImageByNameFromCache name+ cacheDir <- getSharedImagesCacheDir+ let image = changeImageDirectory cacheDir (sharedImageImage sharedImage)+ dbgL (printf "USING SHARED SOURCE IMAGE '%s'" (show image))+ return image++-- | Return the latest version of a shared image named 'name' from the local cache.+getLatestSharedImageByNameFromCache :: String -> B9 SharedImage+getLatestSharedImageByNameFromCache name = do+ imgs <- lookupSharedImages (== Cache) ((== name) . siName)+ case reverse imgs of+ (Cache, sharedImage):_rest ->+ return sharedImage+ _ ->+ error (printf "No image(s) named '%s' found." name)++-- | 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)++-- | 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 repoPred imgPred = do+ xs <- getSharedImages+ 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+ return (mconcat (pure <$> sorted))++-- | Return either all remote repos or just the single selected repo.+getSelectedRepos :: B9 [RemoteRepo]+getSelectedRepos = do+ allRepos <- getRemoteRepos+ selectedRepo <- getSelectedRemoteRepo+ let repos = maybe allRepos -- user has not selected a repo+ return -- user has selected a repo, return it as+ -- singleton list+ selectedRepo -- 'Maybe' a repo+ return repos++-- | Return the path to the sub directory in the cache that contains files of+-- shared images.+getSharedImagesCacheDir :: B9 FilePath+getSharedImagesCacheDir = do+ cacheDir <- localRepoDir <$> getRepoCache+ return (cacheDir </> sharedImagesRootDirectory)
+ src/lib/B9/DiskImages.hs view
@@ -0,0 +1,136 @@+{-| Data types that describe all B9 relevant elements of virtual machine disk+ images. -}+module B9.DiskImages where++import Data.Semigroup+import Data.Data+import System.FilePath++-- | Build target for disk images.+data ImageTarget = ImageTarget+ ImageDestination+ ImageSource+ MountPoint+ deriving (Read, Show, Typeable, Data, Eq)++-- | A mount point or `NotMounted`+data MountPoint = MountPoint FilePath | NotMounted+ deriving (Show, Read, Typeable, Data, Eq)++-- | The destination of an image.+data ImageDestination = Share String ImageType ImageResize+ | LiveInstallerImage String FilePath ImageResize+ | LocalFile Image ImageResize+ | Transient+ deriving (Read, Show, Typeable, Data,Eq)++-- | Specification of how the image to build is obtained.+data ImageSource = EmptyImage String FileSystem ImageType ImageSize+ | CopyOnWrite Image+ | SourceImage Image Partition ImageResize+ | From String ImageResize+ deriving (Show,Read,Typeable,Data,Eq)++data Partition = NoPT | Partition Int+ deriving (Eq, Show, Read, Typeable, Data)+++data Image = Image FilePath ImageType FileSystem+ deriving (Eq, Show, Read, Typeable, Data)++data ImageType = Raw | QCow2 | Vmdk+ deriving (Eq,Read,Typeable,Data,Show)++data FileSystem = NoFileSystem | Ext4 | ISO9660 | VFAT+ deriving (Eq,Show,Read,Typeable,Data)++data ImageSize = ImageSize Int SizeUnit+ deriving (Eq, Show, Read, Typeable, Data)++data SizeUnit = B | KB | MB | GB+ deriving (Eq, Show, Read, Ord, Typeable, Data)++data ImageResize = ResizeImage ImageSize+ | Resize ImageSize+ | ShrinkToMinimum+ | KeepSize+ deriving (Eq, Show, Read, Typeable, Data)++type Mounted a = (a, MountPoint)++itImageDestination :: ImageTarget -> ImageDestination+itImageDestination (ImageTarget d _ _) = d++itImageMountPoint :: ImageTarget -> MountPoint+itImageMountPoint (ImageTarget _ _ m) = m+isPartitioned :: Partition -> Bool+isPartitioned p | p == NoPT = False+ | otherwise = True++getPartition :: Partition -> Int+getPartition (Partition p) = p+getPartition NoPT = error "No partitions!"+++-- | Return the file name extension of an image file with a specific image+-- format.+imageFileExtension :: ImageType -> String+imageFileExtension Raw = "raw"+imageFileExtension QCow2 = "qcow2"+imageFileExtension Vmdk = "vmdk"++changeImageFormat :: ImageType -> Image -> Image+changeImageFormat fmt' (Image img _ fs) = Image img' fmt' fs+ where img' = replaceExtension img (imageFileExtension fmt')++changeImageDirectory :: FilePath -> Image -> Image+changeImageDirectory dir (Image img fmt fs) = Image img' fmt fs+ where img' = dir </> takeFileName img++-- | 'SharedImage' holds all data necessary to identify an image shared.+data SharedImage = SharedImage SharedImageName+ SharedImageDate+ SharedImageBuildId+ ImageType+ FileSystem+ deriving (Eq,Read,Show)++-- | Return the name of a shared image.+siName :: SharedImage -> String+siName (SharedImage (SharedImageName n) _ _ _ _) = n++-- | Shared images are orderd by name, build date and build id+instance Ord SharedImage where+ compare (SharedImage n d b _ _) (SharedImage n' d' b' _ _) =+ (compare n n') <> (compare d d') <> (compare b b')++newtype SharedImageName = SharedImageName String deriving (Eq,Ord,Read,Show)+newtype SharedImageDate = SharedImageDate String deriving (Eq,Ord,Read,Show)+newtype SharedImageBuildId = SharedImageBuildId String deriving (Eq,Ord,Read,Show)++-- | Return the disk image of an sharedImage+sharedImageImage :: SharedImage -> Image+sharedImageImage (SharedImage (SharedImageName n)+ _+ (SharedImageBuildId bid)+ sharedImageType+ sharedImageFileSystem) =+ Image (n ++ "_" ++ bid <.> imageFileExtension sharedImageType)+ sharedImageType+ sharedImageFileSystem++-- | Calculate the path to the text file holding the serialized 'SharedImage'+-- relative to the directory of shared images in a repository.+sharedImageFileName :: SharedImage -> FilePath+sharedImageFileName (SharedImage (SharedImageName n)+ _+ (SharedImageBuildId bid)+ _+ _) =+ n ++ "_" ++ bid <.> sharedImageFileExtension++sharedImagesRootDirectory :: FilePath+sharedImagesRootDirectory = "b9_shared_images"++sharedImageFileExtension :: String+sharedImageFileExtension = "b9si"
+ src/lib/B9/ExecEnv.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-| Data types describing the execution environment+ of virtual machine builds.+ 'ExecEnv', 'Resources' and 'SharedDirectory' describe how+ "B9.LibVirtLXC" should configure and execute+ build scripts, as defined in "B9.ShellScript" and "B9.Vm".+ -}+module B9.ExecEnv+ ( ExecEnv (..)+ , Resources (..)+ , noResources+ , SharedDirectory (..)+ , CPUArch (..)+ , RamSize (..)+ ) where++import Data.Data+import Data.Monoid++import B9.DiskImages++data ExecEnv = ExecEnv { envName :: String+ , envImageMounts :: [Mounted Image]+ , envSharedDirectories :: [SharedDirectory]+ , envResources :: Resources+ }++data SharedDirectory = SharedDirectory FilePath MountPoint+ | SharedDirectoryRO FilePath MountPoint+ | SharedSources MountPoint+ deriving (Read, Show, Typeable, Data,Eq)++data Resources = Resources { maxMemory :: RamSize+ , cpuCount :: Int+ , cpuArch :: CPUArch+ } deriving (Read, Show, Typeable, Data)++instance Monoid Resources where+ mempty = Resources mempty 1 mempty+ mappend (Resources m c a) (Resources m' c' a') =+ Resources (m <> m') (max c c') (a <> a')++noResources :: Resources+noResources = mempty++data CPUArch = X86_64 | I386 deriving (Read, Show, Typeable, Data,Eq)++instance Monoid CPUArch where+ mempty = I386+ I386 `mappend` x = x+ X86_64 `mappend` _ = X86_64++data RamSize = RamSize Int SizeUnit+ | AutomaticRamSize deriving (Eq, Read, Show, Ord, Typeable, Data)++instance Monoid RamSize where+ mempty = AutomaticRamSize+ AutomaticRamSize `mappend` x = x+ x `mappend` AutomaticRamSize = x+ r `mappend` r' = max r r'
+ src/lib/B9/LibVirtLXC.hs view
@@ -0,0 +1,316 @@+{-| Implementation of an execution environment that uses "libvirt-lxc". -}+module B9.LibVirtLXC ( runInEnvironment+ , supportedImageTypes+ , setDefaultConfig+ ) where++import Control.Applicative+import Control.Monad.IO.Class ( liftIO )+import System.Directory+import System.FilePath+import Text.Printf ( printf )+import Data.Char (toLower)++import B9.ShellScript+import B9.B9Monad+import B9.DiskImages+import B9.ExecEnv+import B9.ConfigUtils++lxcDefaultRamSize :: RamSize+lxcDefaultRamSize = RamSize 1 GB++supportedImageTypes :: [ImageType]+supportedImageTypes = [Raw]++runInEnvironment :: ExecEnv -> Script -> B9 Bool+runInEnvironment env scriptIn =+ if emptyScript scriptIn+ then return True+ else setUp >>= execute+ where+ setUp = do+ cfg <- configureLibVirtLXC+ buildId <- getBuildId+ buildDir <- getBuildDir+ uuid <- randomUUID+ let scriptDirHost = buildDir </> "init-script"+ scriptDirGuest = "/" ++ buildId+ domain = createDomain cfg env buildId uuid' scriptDirHost+ scriptDirGuest+ uuid' = printf "%U" uuid+ script = Begin [scriptIn, successMarkerCmd scriptDirGuest]+ domainFile <- (</> domainConfig) <$> getBuildDir+ liftIO $ do createDirectoryIfMissing True scriptDirHost+ writeSh (scriptDirHost </> initScript) script+ writeFile domainFile domain+ return $ Context scriptDirHost uuid domainFile cfg++ successMarkerCmd scriptDirGuest =+ As "root" [In scriptDirGuest [Run "touch" [successMarkerFile]]]++ execute (Context scriptDirHost uuid domainFile cfg) = do+ let virsh = virshCommand cfg+ cmd $ printf "%s create '%s'" virsh domainFile+ cmd $ printf "%s console %U" virsh uuid+ checkSuccessMarker scriptDirHost++ checkSuccessMarker scriptDirHost =+ liftIO (doesFileExist $ scriptDirHost </> successMarkerFile)++ successMarkerFile = "SUCCESS"++ virshCommand :: LibVirtLXCConfig -> String+ virshCommand cfg = printf "%s%s -c %s" useSudo' virshPath' virshURI'+ where useSudo' = if useSudo cfg then "sudo " else ""+ virshPath' = virshPath cfg+ virshURI' = virshURI cfg++data Context = Context FilePath UUID FilePath LibVirtLXCConfig++data LibVirtLXCConfig = LibVirtLXCConfig { useSudo :: Bool+ , virshPath :: FilePath+ , emulator :: FilePath+ , virshURI :: FilePath+ , networkId :: Maybe String+ , guestCapabilities :: [LXCGuestCapability]+ } 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+ deriving (Read, Show)++defaultLibVirtLXCConfig :: LibVirtLXCConfig+defaultLibVirtLXCConfig = LibVirtLXCConfig+ True+ "/usr/bin/virsh"+ "/usr/lib/libvirt/libvirt_lxc"+ "lxc:///"+ Nothing+ [CAP_MKNOD+ ,CAP_SYS_ADMIN+ ,CAP_SYS_CHROOT+ ,CAP_SETGID+ ,CAP_SETUID+ ,CAP_NET_BIND_SERVICE+ ,CAP_SETPCAP+ ,CAP_SYS_PTRACE+ ,CAP_SYS_MODULE]++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"++configureLibVirtLXC :: B9 LibVirtLXCConfig+configureLibVirtLXC = do+ c <- readLibVirtConfig+ traceL $ printf "USING LibVirtLXCConfig: %s" (show c)+ return c++setDefaultConfig :: ConfigParser+setDefaultConfig = either (error . show) id eitherCp+ where+ eitherCp = do+ let cp = emptyCP+ c = defaultLibVirtLXCConfig+ cp1 <- add_section cp cfgFileSection+ cp2 <- setshow cp1 cfgFileSection useSudoK $ useSudo c+ cp3 <- set cp2 cfgFileSection virshPathK $ virshPath c+ cp4 <- set cp3 cfgFileSection emulatorK $ emulator c+ cp5 <- set cp4 cfgFileSection virshURIK $ virshURI c+ cp6 <- setshow cp5 cfgFileSection networkIdK $ networkId c+ setshow cp6 cfgFileSection guestCapabilitiesK $ guestCapabilities c++readLibVirtConfig :: B9 LibVirtLXCConfig+readLibVirtConfig = do+ cp <- getConfigParser+ let geto :: (Get_C a, Read a) => OptionSpec -> a -> a+ geto = getOptionOr cp cfgFileSection+ return $ LibVirtLXCConfig {+ useSudo = geto useSudoK $ useSudo defaultLibVirtLXCConfig+ , virshPath = geto virshPathK $ virshPath defaultLibVirtLXCConfig+ , emulator = geto emulatorK $ emulator defaultLibVirtLXCConfig+ , virshURI = geto virshURIK $ virshURI defaultLibVirtLXCConfig+ , networkId = geto networkIdK $ networkId defaultLibVirtLXCConfig+ , guestCapabilities = geto guestCapabilitiesK $+ guestCapabilities defaultLibVirtLXCConfig+ }++initScript :: String+initScript = "init.sh"++domainConfig :: String+domainConfig = "domain.xml"++createDomain :: LibVirtLXCConfig+ -> ExecEnv+ -> String+ -> String+ -> FilePath+ -> FilePath+ -> String+createDomain cfg e buildId uuid scriptDirHost scriptDirGuest =+ "<domain type='lxc'>\n\+ \ <name>" ++ buildId ++ "</name>\n\+ \ <uuid>" ++ uuid ++ "</uuid>\n\+ \ <memory unit='" ++ memoryUnit e ++ "'>" ++ memoryAmount e ++ "</memory>\n\+ \ <currentMemory unit='" ++ memoryUnit e ++ "'>" ++ memoryAmount e ++ "</currentMemory>\n\+ \ <vcpu placement='static'>" ++ cpuCountStr e ++ "</vcpu>\n\+ \ <features>\n\+ \ <capabilities policy='default'>\n\+ \ "++ renderGuestCapabilityEntries cfg ++"\n\+ \ </capabilities>\n\+ \ </features>\n\+ \ <os>\n\+ \ <type arch='" ++ osArch e ++ "'>exe</type>\n\+ \ <init>" ++ scriptDirGuest </> initScript ++ "</init>\n\+ \ </os>\n\+ \ <clock offset='utc'/>\n\+ \ <on_poweroff>destroy</on_poweroff>\n\+ \ <on_reboot>restart</on_reboot>\n\+ \ <on_crash>destroy</on_crash>\n\+ \ <devices>\n\+ \ <emulator>" ++ emulator cfg ++ "</emulator>\n"+ ++ unlines (libVirtNetwork (networkId cfg) +++ (fsImage <$> (envImageMounts e)) +++ (fsSharedDir <$> (envSharedDirectories e))) ++ "\n" +++ " <filesystem type='mount'>\n\+ \ <source dir='" ++ scriptDirHost ++ "'/>\n\+ \ <target dir='" ++ scriptDirGuest ++ "'/>\n\+ \ </filesystem>\n\+ \ <console>\n\+ \ <target type='lxc' port='0'/>\n\+ \ </console>\n\+ \ </devices>\n\+ \</domain>\n"++renderGuestCapabilityEntries :: LibVirtLXCConfig -> String+renderGuestCapabilityEntries = unlines . map render . guestCapabilities+ where+ render :: LXCGuestCapability -> String+ render cap = let capStr = toLower <$> drop (length "CAP_") (show cap)+ in printf "<%s state='on'/>" capStr++osArch :: ExecEnv -> String+osArch e = case cpuArch (envResources e) of+ X86_64 -> "x86_64"+ I386 -> "i686"++libVirtNetwork :: Maybe String -> [String]+libVirtNetwork Nothing = []+libVirtNetwork (Just n) =+ [ "<interface type='network'>"+ , " <source network='" ++ n ++ "'/>"+ , "</interface>" ]++fsImage :: (Image, MountPoint) -> String+fsImage (img, mnt) =+ case fsTarget mnt of+ Just mntXml ->+ "<filesystem type='file' accessmode='passthrough'>\n " +++ fsImgDriver img ++ "\n " ++ fsImgSource img ++ "\n " ++ mntXml +++ "\n</filesystem>"+ Nothing ->+ ""+ where+ fsImgDriver (Image _img fmt _fs) =+ printf "<driver %s %s/>" driver fmt'+ where+ (driver, fmt') = case fmt of+ Raw -> ("type='loop'", "format='raw'")+ QCow2 -> ("type='nbd'", "format='qcow2'")+ Vmdk -> ("type='nbd'", "format='vmdk'")++ fsImgSource (Image src _fmt _fs) = "<source file='" ++ src ++ "'/>"++fsSharedDir :: SharedDirectory -> String+fsSharedDir (SharedDirectory hostDir mnt) =+ case fsTarget mnt of+ Just mntXml ->+ "<filesystem type='mount'>\n " +++ "<source dir='" ++ hostDir ++ "'/>" ++ "\n " ++ mntXml +++ "\n</filesystem>"+ Nothing ->+ ""+fsSharedDir (SharedDirectoryRO hostDir mnt) =+ case fsTarget mnt of+ Just mntXml ->+ "<filesystem type='mount'>\n " +++ "<source dir='" ++ hostDir ++ "'/>" ++ "\n " ++ mntXml +++ "\n <readonly />\n</filesystem>"+ Nothing ->+ ""+fsSharedDir (SharedSources _) =+ error "Unreachable code reached!"++fsTarget :: MountPoint -> Maybe String+fsTarget (MountPoint dir) = Just $ "<target dir='" ++ dir ++ "'/>"+fsTarget _ = Nothing++memoryUnit :: ExecEnv -> String+memoryUnit = toUnit . maxMemory . envResources+ where+ toUnit AutomaticRamSize = toUnit lxcDefaultRamSize+ toUnit (RamSize _ u) = case u of+ GB -> "GiB"+ MB -> "MiB"+ KB -> "KiB"+ B -> "B"+memoryAmount :: ExecEnv -> String+memoryAmount = show . toAmount . maxMemory . envResources+ where+ toAmount AutomaticRamSize = toAmount lxcDefaultRamSize+ toAmount (RamSize n _) = n++cpuCountStr :: ExecEnv -> String+cpuCountStr = show . cpuCount . envResources
+ src/lib/B9/MBR.hs view
@@ -0,0 +1,77 @@+{-| Utility module to extract a primary partition from an MBR partition on a+ raw image file. -}+module B9.MBR ( getPartition+ , PrimaryPartition (..)+ , MBR(..)+ , CHS(..)) where++import Control.Applicative+import Data.Binary.Get+import Data.Word+import Text.Printf+import qualified Data.ByteString.Lazy as BL++getPartition :: Int -> FilePath -> IO (Word64, Word64)+getPartition n f = decodeMBR <$> BL.readFile f+ where+ decodeMBR input =+ let mbr = runGet getMBR input+ part = (case n of+ 1 -> mbrPart1+ 2 -> mbrPart2+ 3 -> mbrPart3+ 4 -> mbrPart4+ b -> error (printf "Error: Invalid partition index %i\+ \ only partitions 1-4 are allowed.\+ \ Image file: '%s'"+ b+ f))+ mbr+ start = fromIntegral (primPartLbaStart part)+ len = fromIntegral (primPartSectors part)+ in (start * sectorSize, len * sectorSize)++sectorSize :: Word64+sectorSize = 512++bootCodeSize :: Int+bootCodeSize = 446++data MBR = MBR { mbrPart1 :: !PrimaryPartition+ , mbrPart2 :: !PrimaryPartition+ , mbrPart3 :: !PrimaryPartition+ , mbrPart4 :: !PrimaryPartition+ } deriving Show++data PrimaryPartition = PrimaryPartition { primPartStatus :: !Word8+ , primPartChsStart :: !CHS+ , primPartPartType :: !Word8+ , primPartChsEnd :: !CHS+ , primPartLbaStart :: !Word32+ , primPartSectors :: !Word32+ } deriving Show++data CHS = CHS { chsH :: !Word8+ , chs_CUpper2_S :: !Word8+ , chs_CLower8 :: !Word8+ } deriving Show++getMBR :: Get MBR+getMBR = skip bootCodeSize >>+ MBR <$> getPart+ <*> getPart+ <*> getPart+ <*> getPart++getPart :: Get PrimaryPartition+getPart = PrimaryPartition <$> getWord8+ <*> getCHS+ <*> getWord8+ <*> getCHS+ <*> getWord32le+ <*> getWord32le++getCHS :: Get CHS+getCHS = CHS <$> getWord8+ <*> getWord8+ <*> getWord8
+ src/lib/B9/PartitionTable.hs view
@@ -0,0 +1,21 @@+{-| Function to find the file offsets of primary partitions in raw disk+ images. Currently only MBR partitions are supported. See 'B9.MBR' -}+module B9.PartitionTable ( getPartition ) where++import Control.Applicative+import Data.Word ( Word64 )++import qualified B9.MBR as MBR++getPartition :: Int -> FilePath -> IO (Word64, Word64, Word64)+getPartition partitionIndex diskImage =+ blockSized <$> MBR.getPartition partitionIndex diskImage++blockSized :: (Integral a) => (a, a) -> (a, a, a)+blockSized (s, l) = let bs = gcd2 1 s l+ in (s `div` bs, l `div` bs, bs)+ where+ gcd2 n x y = let next = 2 * n in+ if x `rem` next == 0 && y `rem` next == 0+ then gcd2 next x y+ else n
+ src/lib/B9/QCUtil.hs view
@@ -0,0 +1,37 @@+{-|+Some QuickCheck utility functions.+-}+module B9.QCUtil where++import Control.Applicative+import Control.Monad+import Test.QuickCheck++arbitraryEnv :: Arbitrary a => Gen [(String,a)]+arbitraryEnv = listOf ((,) <$> listOf1 (choose ('a', 'z')) <*> arbitrary)++halfSize :: Gen a -> Gen a+halfSize g = sized (flip resize g . flip div 2)++smaller :: Gen a -> Gen a+smaller g = sized (flip resize g . flip (-) 1 )++arbitraryFilePath :: Gen FilePath+arbitraryFilePath = do+ path <-join <$> listOf (elements ["/", "../", "./","etc/", "opt/","user/","var/","tmp/","doc/","share/","conf.d/"])+ prefix <- elements ["foo_", "", "alt_", "ssh-",""]+ body <- elements ["www","passwd","cert","opnsfe","runtime"]+ extension <- elements [".txt",".png",".ps",".erl",""]+ return (path ++ prefix ++ body ++ extension)++arbitraryLetter :: Gen Char+arbitraryLetter = oneof [arbitraryLetterUpper,arbitraryLetterLower]++arbitraryLetterUpper :: Gen Char+arbitraryLetterUpper = elements ['A' .. 'Z']++arbitraryLetterLower :: Gen Char+arbitraryLetterLower = elements ['a' .. 'z']++arbitraryDigit :: Gen Char+arbitraryDigit = elements ['0' .. '9']
+ src/lib/B9/Repository.hs view
@@ -0,0 +1,162 @@+{-| B9 has a concept of shared images. Images can be pulled and pushed to/from+ remote locations via rsync+ssh. B9 also maintains a local cache; the whole+ thing is supposed to be build-server-safe, that means no two builds shall+ interfere with each other. This is accomplished by refraining from+ automatic cache updates from/to remote repositories.+ -}+module B9.Repository (RemoteRepo(..)+ ,remoteRepoRepoId+ ,RepoCache(..)+ ,SshPrivKey(..)+ ,SshRemoteHost(..)+ ,SshRemoteUser(..)+ ,initRepoCache+ ,initRemoteRepo+ ,remoteRepoCheckSshPrivKey+ ,remoteRepoCacheDir+ ,localRepoDir+ ,writeRemoteRepoConfig+ ,getConfiguredRemoteRepos+ ,lookupRemoteRepo) where++import Control.Monad+import Control.Monad.IO.Class+import Control.Applicative+import Data.Data+import Data.List+import Data.ConfigFile+import Text.Printf+import System.FilePath+import System.Directory+import B9.ConfigUtils++newtype RepoCache = RepoCache FilePath+ deriving (Read, Show, Typeable, Data)++data RemoteRepo = RemoteRepo String+ FilePath+ SshPrivKey+ SshRemoteHost+ SshRemoteUser+ deriving (Read, Show, Typeable, Data)++remoteRepoRepoId :: RemoteRepo -> String+remoteRepoRepoId (RemoteRepo repoId _ _ _ _) = repoId++newtype SshPrivKey = SshPrivKey FilePath+ deriving (Read, Show, Typeable, Data)++newtype SshRemoteHost = SshRemoteHost (String,Int)+ deriving (Read, Show, Typeable, Data)++newtype SshRemoteUser = SshRemoteUser String+ deriving (Read, Show, Typeable, Data)++-- | Initialize the local repository cache directory.+initRepoCache :: MonadIO m => SystemPath -> m RepoCache+initRepoCache repoDirSystemPath = do+ repoDir <- resolve repoDirSystemPath+ ensureDir (repoDir ++ "/")+ return (RepoCache repoDir)++-- | Check for existance of priv-key and make it an absolute path.+remoteRepoCheckSshPrivKey :: MonadIO m => RemoteRepo -> m RemoteRepo+remoteRepoCheckSshPrivKey (RemoteRepo rId rp (SshPrivKey keyFile) h u) = do+ exists <- liftIO (doesFileExist keyFile)+ keyFile' <- liftIO (canonicalizePath keyFile)+ when (not exists)+ (error (printf "SSH Key file '%s' for repository '%s' is missing."+ keyFile'+ rId))+ return (RemoteRepo rId rp (SshPrivKey keyFile') h u)++-- | Initialize the repository; load the corresponding settings from the config+-- file, check that the priv key exists and create the correspondig cache+-- directory.+initRemoteRepo :: MonadIO m+ => RepoCache+ -> RemoteRepo+ -> m RemoteRepo+initRemoteRepo cache repo = do+ repo' <- remoteRepoCheckSshPrivKey repo+ let (RemoteRepo repoId _ _ _ _) = repo'+ ensureDir (remoteRepoCacheDir cache repoId ++ "/")+ return repo'++-- | Return the cache directory for a remote repository relative to the root+-- cache dir.+remoteRepoCacheDir :: RepoCache -- ^ The repository cache directory+ -> String -- ^ Id of the repository+ -> FilePath -- ^ The existing, absolute path to the+ -- cache directory+remoteRepoCacheDir (RepoCache cacheDir) repoId =+ cacheDir </> "remote-repos" </> repoId++-- | Return the local repository directory.+localRepoDir :: RepoCache -- ^ The repository cache directory+ -> FilePath -- ^ The existing, absolute path to the+ -- directory+localRepoDir (RepoCache cacheDir) =+ cacheDir </> "local-repo"++-- | Persist a repo to a configuration file.+writeRemoteRepoConfig :: RemoteRepo+ -> ConfigParser+ -> Either CPError ConfigParser+writeRemoteRepoConfig repo cpIn = cpWithRepo+ where section = repoId ++ repoSectionSuffix+ (RemoteRepo repoId+ remoteRootDir+ (SshPrivKey keyFile)+ (SshRemoteHost (host,port))+ (SshRemoteUser user)) = repo+ cpWithRepo = do cp1 <- add_section cpIn section+ cp2 <- set cp1 section repoRemotePathK remoteRootDir+ cp3 <- set cp2 section repoRemoteSshKeyK keyFile+ cp4 <- set cp3 section repoRemoteSshHostK host+ cp5 <- setshow cp4 section repoRemoteSshPortK port+ set cp5 section repoRemoteSshUserK user++-- | Load a repository from a configuration file that has been written by+-- 'writeRepositoryToB9Config'.+lookupRemoteRepo :: [RemoteRepo] -> String -> Maybe RemoteRepo+lookupRemoteRepo repos repoId = lookup repoId repoIdRepoPairs+ where repoIdRepoPairs = map (\r@(RemoteRepo rid _ _ _ _) -> (rid,r)) repos++getConfiguredRemoteRepos :: ConfigParser -> [RemoteRepo]+getConfiguredRemoteRepos cp = map parseRepoSection repoSections+ where+ repoSections =+ filter (repoSectionSuffix `isSuffixOf`) (sections cp)+ parseRepoSection section =+ case parseResult of+ Left e -> error ("Error while parsing repo section \""+ ++ section ++ "\": " ++ show e)+ Right r -> r+ where+ getsec :: Get_C a => OptionSpec -> Either CPError a+ getsec = get cp section+ parseResult = do+ RemoteRepo repoId+ <$> getsec repoRemotePathK+ <*> (SshPrivKey <$> getsec repoRemoteSshKeyK)+ <*> (SshRemoteHost <$> ((,) <$> (getsec repoRemoteSshHostK)+ <*> (getsec repoRemoteSshPortK)))+ <*> (SshRemoteUser <$> getsec repoRemoteSshUserK)+ where+ repoId = let prefixLen = length section - suffixLen+ suffixLen = length repoSectionSuffix+ in take prefixLen section++repoSectionSuffix :: String+repoSectionSuffix = "-repo"+repoRemotePathK :: String+repoRemotePathK = "remote_path"+repoRemoteSshKeyK :: String+repoRemoteSshKeyK = "ssh_priv_key_file"+repoRemoteSshHostK :: String+repoRemoteSshHostK = "ssh_remote_host"+repoRemoteSshPortK :: String+repoRemoteSshPortK = "ssh_remote_port"+repoRemoteSshUserK :: String+repoRemoteSshUserK = "ssh_remote_user"
+ src/lib/B9/RepositoryIO.hs view
@@ -0,0 +1,149 @@+{-| Effectful functions executing shared image respository operations.+ See "B9.Repository" -}+module B9.RepositoryIO (repoSearch+ ,pushToRepo+ ,pullFromRepo+ ,pullGlob+ ,Repository(..)+ ,FilePathGlob(..)) where++import B9.Repository+import B9.B9Monad+import B9.ConfigUtils++import Control.Applicative+import Data.List+import Control.Monad.IO.Class+import System.Directory+import System.FilePath+import Text.Printf (printf)++data Repository = Cache | Remote String+ deriving (Eq, Ord, Read, Show)++-- | Find files which are in 'subDir' and match 'glob' in the repository+-- cache. NOTE: This operates on the repository cache, but does not enforce a+-- repository cache update.+repoSearch :: FilePath -> FilePathGlob -> B9 [(Repository, [FilePath])]+repoSearch subDir glob = (:) <$> localMatches <*> remoteRepoMatches+ where remoteRepoMatches = do+ remoteRepos <- getRemoteRepos+ mapM remoteRepoSearch remoteRepos++ localMatches :: B9 (Repository, [FilePath])+ localMatches = do+ cache <- getRepoCache+ let dir = localRepoDir cache </> subDir+ files <- findGlob dir+ return (Cache, files)++ remoteRepoSearch :: RemoteRepo -> B9 (Repository, [FilePath])+ remoteRepoSearch repo = do+ cache <- getRepoCache+ let dir = remoteRepoCacheDir cache repoId </> subDir+ (RemoteRepo repoId _ _ _ _) = repo+ files <- findGlob dir+ return (Remote repoId, files)++ findGlob :: FilePath -> B9 [FilePath]+ findGlob dir = do+ traceL (printf "reading contents of directory '%s'" dir)+ ensureDir (dir ++ "/")+ files <- liftIO (getDirectoryContents dir)+ return ((dir </>) <$> (filter (matchGlob glob) files))++-- | Push a file from the cache to a remote repository+pushToRepo :: RemoteRepo -> FilePath -> FilePath -> B9 ()+pushToRepo repo@(RemoteRepo repoId _ _ _ _) src dest = do+ dbgL (printf "PUSHING '%s' TO REPO '%s'" (takeFileName src) repoId)+ cmd (repoEnsureDirCmd repo dest)+ cmd (pushCmd repo src dest)++-- | Pull a file from a remote repository to cache+pullFromRepo :: RemoteRepo -> FilePath -> FilePath -> B9 ()+pullFromRepo repo@(RemoteRepo repoId+ rootDir+ _key+ (SshRemoteHost (host, _port))+ (SshRemoteUser user)) src dest = do+ dbgL (printf "PULLING '%s' FROM REPO '%s'" (takeFileName src) repoId)+ cmd (printf "rsync -rtv -e 'ssh %s' '%s@%s:%s' '%s'"+ (sshOpts repo)+ user+ host+ (rootDir </> src)+ dest)++-- | Push a file from the cache to a remote repository+pullGlob :: FilePath -> FilePathGlob -> RemoteRepo -> B9 ()+pullGlob subDir glob repo@(RemoteRepo repoId+ rootDir+ _key+ (SshRemoteHost (host, _port))+ (SshRemoteUser user)) = do+ cache <- getRepoCache+ infoL (printf "SYNCING REPO METADATA '%s'" repoId)+ let c = printf "rsync -rtv\+ \ --include '%s'\+ \ --exclude '*.*'\+ \ -e 'ssh %s'\+ \ '%s@%s:%s/' '%s/'"+ (globToPattern glob)+ (sshOpts repo)+ user+ host+ (rootDir </> subDir)+ destDir+ destDir = repoCacheDir </> subDir+ repoCacheDir = remoteRepoCacheDir cache repoId+ ensureDir destDir+ cmd c++-- | Express a pattern for file paths, used when searching repositories.+data FilePathGlob = FileExtension String++-- * Internals++globToPattern :: FilePathGlob -> String+globToPattern (FileExtension ext) = "*." ++ ext++-- | A predicate that is satisfied if a file path matches a glob.+matchGlob :: FilePathGlob -> FilePath -> Bool+matchGlob (FileExtension ext) = isSuffixOf ("." ++ ext)++-- | A shell command string for invoking rsync to push a path to a remote host+-- via ssh.+pushCmd :: RemoteRepo -> FilePath -> FilePath -> String+pushCmd repo@(RemoteRepo _repoId+ rootDir+ _key+ (SshRemoteHost (host, _port))+ (SshRemoteUser user)) src dest =+ printf "rsync -rtv --inplace --ignore-existing -e 'ssh %s' '%s' '%s'"+ (sshOpts repo) src sshDest+ where sshDest = printf "%s@%s:%s/%s" user host rootDir dest :: String++-- | A shell command string for invoking rsync to create the directories for a+-- file push.+repoEnsureDirCmd :: RemoteRepo -> FilePath -> String+repoEnsureDirCmd repo@(RemoteRepo _repoId+ rootDir+ _key+ (SshRemoteHost (host, _port))+ (SshRemoteUser user)) dest =+ printf "ssh %s %s@%s mkdir -p '%s'"+ (sshOpts repo)+ user+ host+ (rootDir </> takeDirectory dest)++sshOpts :: RemoteRepo -> String+sshOpts (RemoteRepo _repoId+ _rootDir+ (SshPrivKey key)+ (SshRemoteHost (_host, port))+ _user) =+ unwords ["-o","StrictHostKeyChecking=no"+ ,"-o","UserKnownHostsFile=/dev/null"+ ,"-o",printf "Port=%i" port+ ,"-o","IdentityFile=" ++ key]
+ src/lib/B9/ShellScript.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-| Definition of 'Script' and functions to convert 'Script's to bash+ scripts. -}+module B9.ShellScript ( writeSh+ , emptyScript+ , CmdVerbosity (..)+ , Cwd (..)+ , User (..)+ , Script (..)+ ) where++import Data.Data+import Data.Monoid+import Control.Monad.Reader+import Control.Applicative ( (<$>) )+import Data.List ( intercalate )+import System.Directory ( getPermissions+ , setPermissions+ , setOwnerExecutable )++data Script = In FilePath [Script]+ | As String [Script]+ | IgnoreErrors Bool [Script]+ | Verbosity CmdVerbosity [Script]+ | Begin [Script]+ | Run FilePath [String]+ | NoOP+ deriving (Show, Read, Typeable, Data,Eq)++instance Monoid Script where+ mempty = NoOP+ NoOP `mappend` s = s+ s `mappend` NoOP = s+ (Begin ss) `mappend` (Begin ss') = Begin (ss ++ ss')+ (Begin ss) `mappend` s' = Begin (ss ++ [s'])+ s `mappend` (Begin ss') = Begin (s : ss')+ s `mappend` s' = Begin [s, s']++data Cmd = Cmd String+ [String]+ User+ Cwd+ Bool+ CmdVerbosity+ deriving (Show, Read)++data CmdVerbosity = Debug | Verbose | OnlyStdErr | Quiet+ deriving (Show, Read, Typeable, Data,Eq)++data Cwd = Cwd FilePath | NoCwd deriving (Show, Read)++data User = User String | NoUser deriving (Show, Read)++data Ctx = Ctx { ctxCwd :: Cwd+ , ctxUser :: User+ , ctxIgnoreErrors :: Bool+ , ctxVerbosity :: CmdVerbosity }++-- | Convert 'script' to bash-shell-script written to 'file' and make 'file'+-- executable.+writeSh :: FilePath -> Script -> IO ()+writeSh file script = do+ writeFile file (toBash $ toCmds script)+ getPermissions file >>= setPermissions file . setOwnerExecutable True++-- | Check if a script has the same effect as 'NoOP'+emptyScript :: Script -> Bool+emptyScript = null . toCmds++toCmds :: Script -> [Cmd]+toCmds s = runReader (toLLC s) (Ctx NoCwd NoUser False Debug)+ where+ toLLC :: Script -> Reader Ctx [Cmd]+ toLLC NoOP = return []+ toLLC (In d cs) = local (\ ctx -> ctx { ctxCwd = (Cwd d) })+ (toLLC (Begin cs))+ toLLC (As u cs) = local (\ ctx -> ctx { ctxUser = (User u) })+ (toLLC (Begin cs))+ toLLC (IgnoreErrors b cs) = local (\ ctx -> ctx { ctxIgnoreErrors = b })+ (toLLC (Begin cs))+ toLLC (Verbosity v cs) = local (\ ctx -> ctx { ctxVerbosity = v})+ (toLLC (Begin cs))+ toLLC (Begin cs) = concat <$> mapM toLLC cs+ toLLC (Run cmd args) = do+ c <- reader ctxCwd+ u <- reader ctxUser+ i <- reader ctxIgnoreErrors+ v <- reader ctxVerbosity+ return [Cmd cmd args u c i v]++toBash :: [Cmd] -> String+toBash cmds =+ intercalate "\n\n" $+ bashHeader ++ (cmdToBash <$> cmds)++bashHeader :: [String]+bashHeader = [ "#!/bin/bash"+ , "set -e" ]++cmdToBash :: Cmd -> String+cmdToBash (Cmd cmd args user cwd ignoreErrors verbosity) =+ intercalate "\n" $ disableErrorChecking+ ++ pushd cwdQ+ ++ execCmd+ ++ popd cwdQ+ ++ reenableErrorChecking+ where+ execCmd = [ unwords (runuser ++ [cmd] ++ args ++ redirectOutput) ]+ where runuser = case user of+ NoUser -> []+ User "root" -> []+ User u -> ["runuser", "-p", "-u", u, "--"]+ pushd NoCwd = [ ]+ pushd (Cwd cwdPath) = [ unwords (["pushd", cwdPath] ++ redirectOutput) ]+ popd NoCwd = [ ]+ popd (Cwd cwdPath) = [ unwords (["popd"] ++ redirectOutput ++ ["#", cwdPath]) ]+ disableErrorChecking = ["set +e" | ignoreErrors]+ reenableErrorChecking = ["set -e" | ignoreErrors]+ cwdQ = case cwd of+ NoCwd -> NoCwd+ Cwd d -> Cwd ("'" ++ d ++ "'")+ redirectOutput = case verbosity of+ Debug -> []+ Verbose -> []+ OnlyStdErr -> [">", "/dev/null"]+ Quiet -> ["&>", "/dev/null"]
+ src/lib/B9/Vm.hs view
@@ -0,0 +1,43 @@+{-| 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++import Data.Data+import Data.Generics.Schemes+import Data.Generics.Aliases++import B9.ShellScript+import B9.DiskImages+import B9.ExecEnv+import B9.Content.StringTemplate++-- | 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)++substVmScript :: [(String,String)] -> VmScript -> VmScript+substVmScript env p = everywhere gsubst p+ where gsubst :: forall a. Data a => a -> a+ gsubst = mkT substMountPoint+ `extT` substSharedDir+ `extT` substScript++ substMountPoint NotMounted = NotMounted+ substMountPoint (MountPoint x) = MountPoint (sub x)++ 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+ substScript (Run fp args) = Run (sub fp) (map sub args)+ substScript (As fp s) = As (sub fp) s+ substScript s = s++ sub = subst env
+ src/lib/B9/VmBuilder.hs view
@@ -0,0 +1,121 @@+{-| Effectful functions to execute and build virtual machine images using+ an execution environment like e.g. libvirt-lxc. -}+module B9.VmBuilder (buildWithVm) where++import Data.List+import Control.Monad+import Control.Applicative+import Control.Monad.IO.Class+import System.Directory (createDirectoryIfMissing, canonicalizePath)+import Text.Printf ( printf )+import Text.Show.Pretty (ppShow)++import B9.B9Monad+import B9.DiskImages+import B9.DiskImageBuilder+import B9.ExecEnv+import B9.B9Config+import B9.Vm+import B9.ArtifactGenerator+import B9.ShellScript+import qualified B9.LibVirtLXC as LXC+++buildWithVm :: InstanceId -> [ImageTarget] -> FilePath -> VmScript -> B9 Bool+buildWithVm iid imageTargets instanceDir vmScript = do+ vmBuildSupportedImageTypes <- getVmScriptSupportedImageTypes vmScript+ buildImages <- createBuildImages imageTargets vmBuildSupportedImageTypes+ success <- runVmScript iid imageTargets buildImages instanceDir vmScript+ when success (createDestinationImages buildImages imageTargets)+ return success++getVmScriptSupportedImageTypes :: VmScript -> B9 [ImageType]+getVmScriptSupportedImageTypes NoVmScript =+ return [QCow2, Raw, Vmdk]+getVmScriptSupportedImageTypes _ = do+ envType <- getExecEnvType+ return (supportedImageTypes envType)++supportedImageTypes :: ExecEnvType -> [ImageType]+supportedImageTypes LibVirtLXC = LXC.supportedImageTypes++createBuildImages :: [ImageTarget] -> [ImageType] -> B9 [Image]+createBuildImages imageTargets vmBuildSupportedImageTypes = do+ dbgL "creating build images"+ traceL (ppShow imageTargets)+ buildImages <- mapM createBuildImage imageTargets+ infoL "CREATED BUILD IMAGES"+ traceL (ppShow buildImages)+ return buildImages+ where+ createBuildImage (ImageTarget dest imageSource _mnt) = do+ buildDir <- getBuildDir+ destTypes <- preferredDestImageTypes imageSource+ let buildImgType = head (destTypes+ `intersect`+ preferredSourceImageTypes dest+ `intersect`+ vmBuildSupportedImageTypes)+ srcImg <- resolveImageSource imageSource+ let buildImg = changeImageFormat buildImgType+ (changeImageDirectory buildDir srcImg)+ buildImgAbsolutePath <- liftIO (ensureAbsoluteImageDirExists buildImg)+ materializeImageSource imageSource buildImg+ return buildImgAbsolutePath++runVmScript :: InstanceId+ -> [ImageTarget]+ -> [Image]+ -> FilePath+ -> VmScript+ -> B9 Bool+runVmScript (IID iid) imageTargets buildImages instanceDir vmScript = do+ dbgL (printf "starting vm script with instanceDir '%s'" instanceDir)+ traceL (ppShow vmScript)+ execEnv <- setUpExecEnv+ let (VmScript _ _ script) = vmScript+ success <- runInEnvironment execEnv script+ if success+ then infoL "EXECUTED BUILD SCRIPT"+ else errorL "BUILD SCRIPT FAILED"+ return success+ where+ setUpExecEnv :: B9 ExecEnv+ setUpExecEnv = do+ let (VmScript cpu shares _) = vmScript+ let mountedImages = buildImages `zip` (itImageMountPoint <$> imageTargets)+ sharesAbs <- createSharedDirs instanceDir shares+ return (ExecEnv iid+ mountedImages+ sharesAbs+ (Resources AutomaticRamSize 8 cpu))++createSharedDirs :: FilePath -> [SharedDirectory] -> B9 [SharedDirectory]+createSharedDirs instanceDir sharedDirsIn = mapM createSharedDir sharedDirsIn+ where+ createSharedDir (SharedDirectoryRO d m) = do+ d' <- createAndCanonicalize d+ return $ SharedDirectoryRO d' m+ createSharedDir (SharedDirectory d m) = do+ d' <- createAndCanonicalize d+ return $ SharedDirectory d' m+ createSharedDir (SharedSources mp) = do+ d' <- createAndCanonicalize instanceDir+ return $ SharedDirectoryRO d' mp+ createAndCanonicalize d = liftIO $ do+ createDirectoryIfMissing True d+ canonicalizePath d++createDestinationImages :: [Image] -> [ImageTarget] -> B9 ()+createDestinationImages buildImages imageTargets = do+ dbgL "converting build- to output images"+ let pairsToConvert = buildImages `zip` (itImageDestination `map` imageTargets)+ traceL (ppShow pairsToConvert)+ mapM_ (uncurry createDestinationImage) pairsToConvert+ infoL "CONVERTED BUILD- TO OUTPUT IMAGES"++runInEnvironment :: ExecEnv -> Script -> B9 Bool+runInEnvironment env script = do+ t <- getExecEnvType+ case t of+ LibVirtLXC -> LXC.runInEnvironment env script
+ src/tests/B9/ArtifactGeneratorImplSpec.hs view
@@ -0,0 +1,134 @@+module B9.ArtifactGeneratorImplSpec (spec) where+import Test.Hspec+import Data.Text ()++import B9.ArtifactGenerator+import B9.ArtifactGeneratorImpl+import B9.DiskImages+import B9.ExecEnv+import B9.Vm+import B9.ShellScript++spec :: Spec+spec =+ describe "assemble" $ do++ it "replaces '$...' variables in SourceImage Image file paths" $+ let e = CGEnv [("variable","value")] []+ src = vmImagesArtifact "" [transientCOWImage "${variable}" ""] NoVmScript+ expected = transientCOWImage "value" ""+ (Right [igEnv]) = execCGParser (parseArtifactGenerator src) e+ (Right (IG _ _ (VmImages [actual] _))) = execIGEnv igEnv+ in actual `shouldBe` expected++ it "replaces '$...' variables in SourceImage 'From' names" $+ let e = CGEnv [("variable","value")] []+ src = vmImagesArtifact "" [transientSharedImage "${variable}" ""] NoVmScript+ expected = transientSharedImage "value" ""+ (Right [igEnv]) = execCGParser (parseArtifactGenerator src) e+ (Right (IG _ _ (VmImages [actual] _))) = execIGEnv igEnv+ in actual `shouldBe` expected++ it "replaces '$...' variables in the name of a shared image" $+ let e = CGEnv [("variable","value")] []+ src = vmImagesArtifact "" [shareCOWImage "${variable}" ""] NoVmScript+ expected = shareCOWImage "value" ""+ (Right [igEnv]) = execCGParser (parseArtifactGenerator src) e+ (Right (IG _ _ (VmImages [actual] _))) = execIGEnv igEnv+ in actual `shouldBe` expected++ it "replaces '$...' variables in the name and path of a live installer image" $+ let e = CGEnv [("variable","value")] []+ src = vmImagesArtifact "" [liveInstallerCOWImage "${variable}" ""] NoVmScript+ expected = liveInstallerCOWImage "value" ""+ (Right [igEnv]) = execCGParser (parseArtifactGenerator src) e+ (Right (IG _ _ (VmImages [actual] _))) = execIGEnv igEnv+ in actual `shouldBe` expected++ it "replaces '$...' variables in the file name of an image exported as LocalFile" $+ let e = CGEnv [("variable","value")] []+ src = vmImagesArtifact "" [localCOWImage "${variable}" ""] NoVmScript+ expected = localCOWImage "value" ""+ (Right [igEnv]) = execCGParser (parseArtifactGenerator src) e+ (Right (IG _ _ (VmImages [actual] _))) = execIGEnv igEnv+ in actual `shouldBe` expected++ it "replaces '$...' variables in mount point of an image" $+ let e = CGEnv [("variable","value")] []+ src = vmImagesArtifact "" [localCOWImage "" "${variable}"] NoVmScript+ expected = localCOWImage "" "value"+ (Right [igEnv]) = execCGParser (parseArtifactGenerator src) e+ (Right (IG _ _ (VmImages [actual] _))) = execIGEnv igEnv+ in actual `shouldBe` expected++ it "replaces '$...' variables in shared directory source and mount point (RO)" $+ let e = CGEnv [("variable","value")] []+ src = vmImagesArtifact "" [] (emptyScriptWithSharedDirRO "${variable}")+ expected = emptyScriptWithSharedDirRO "value"+ (Right [igEnv]) = execCGParser (parseArtifactGenerator src) e+ (Right (IG _ _ (VmImages [] actual))) = execIGEnv igEnv+ in actual `shouldBe` expected++ it "replaces '$...' variables in shared directory source and mount point (RW)" $+ let e = CGEnv [("variable","value")] []+ src = vmImagesArtifact "" [] (emptyScriptWithSharedDirRW "${variable}")+ expected = emptyScriptWithSharedDirRW "value"+ (Right [igEnv]) = execCGParser (parseArtifactGenerator src) e+ (Right (IG _ _ (VmImages [] actual))) = execIGEnv igEnv+ in actual `shouldBe` expected++ it "replaces '$...' variables in VmImages build script instructions" $+ let e = CGEnv [("variable","value")] []+ src = vmImagesArtifact "" [] (buildScript "${variable}")+ expected = buildScript "value"+ (Right [igEnv]) = execCGParser (parseArtifactGenerator src) e+ (Right (IG _ _ (VmImages [] actual))) = execIGEnv igEnv+ in actual `shouldBe` expected++transientCOWImage :: FilePath -> FilePath -> ImageTarget+transientCOWImage fileName mountPoint =+ ImageTarget Transient+ (CopyOnWrite (Image fileName QCow2 Ext4))+ (MountPoint mountPoint)++transientSharedImage :: FilePath -> FilePath -> ImageTarget+transientSharedImage name mountPoint =+ ImageTarget Transient+ (From name KeepSize)+ (MountPoint mountPoint)++shareCOWImage :: FilePath -> FilePath -> ImageTarget+shareCOWImage destName mountPoint =+ ImageTarget (Share destName QCow2 KeepSize)+ (CopyOnWrite (Image "cowSource" QCow2 Ext4))+ (MountPoint mountPoint)++liveInstallerCOWImage :: FilePath -> FilePath -> ImageTarget+liveInstallerCOWImage destName mountPoint =+ ImageTarget (LiveInstallerImage destName destName KeepSize)+ (CopyOnWrite (Image "cowSource" QCow2 Ext4))+ (MountPoint mountPoint)++localCOWImage :: FilePath -> FilePath -> ImageTarget+localCOWImage destName mountPoint =+ ImageTarget (LocalFile (Image destName QCow2 Ext4) KeepSize)+ (CopyOnWrite (Image "cowSource" QCow2 Ext4))+ (MountPoint mountPoint)++vmImagesArtifact :: String -> [ImageTarget] -> VmScript -> ArtifactGenerator+vmImagesArtifact iid imgs script =+ Artifact (IID iid) (VmImages imgs script)++emptyScriptWithSharedDirRO :: String -> VmScript+emptyScriptWithSharedDirRO arg =+ VmScript X86_64 [SharedDirectoryRO arg (MountPoint arg) ] (Run "" [])++emptyScriptWithSharedDirRW :: String -> VmScript+emptyScriptWithSharedDirRW arg =+ VmScript X86_64 [SharedDirectory arg (MountPoint arg) ] (Run "" [])++buildScript :: String -> VmScript+buildScript arg =+ VmScript X86_64 [SharedDirectory arg (MountPoint arg),+ SharedDirectoryRO arg NotMounted]+ (As arg [In arg [Run arg [arg]]])
+ src/tests/B9/Content/ErlTermsSpec.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE OverloadedStrings #-}+module B9.Content.ErlTermsSpec (spec) where++import Control.Applicative+import Data.List+import Test.Hspec+import Test.QuickCheck+import Data.Maybe+import B9.Content.ErlTerms+import qualified Data.ByteString.Char8 as B++spec :: Spec+spec = do+ describe "parseErlTerm" $ do+ it "parses a non-empty string"+ (parseErlTerm "test" "\"hello world\"."+ `shouldBe` Right (ErlString "hello world"))++ it "parses a string with escaped characters"+ (parseErlTerm "test" "\"\\b\\^A\"."+ `shouldBe` Right (ErlString "\b\^A"))++ it "parses a string with escaped octals: \\X"+ (parseErlTerm "test" "\"\\7\"."+ `shouldBe` Right (ErlString "\o7"))++ it "parses a string with escaped octals: \\XY"+ (parseErlTerm "test" "\"\\73\"."+ `shouldBe` Right (ErlString "\o73"))++ it "parses a string with escaped octals: \\XYZ"+ (parseErlTerm "test" "\"\\431\"."+ `shouldBe` Right (ErlString "\o431"))++ it "parses a string with escaped hex: \\xNN"+ (parseErlTerm "test" "\"\\xbE\"."+ `shouldBe` Right (ErlString "\xbe"))++ it "parses a string with escaped hex: \\x{N} (1)"+ (parseErlTerm "test" "\"\\x{a}\"."+ `shouldBe` Right (ErlString "\xa"))++ it "parses a string with escaped hex: \\x{N} (2)"+ (parseErlTerm "test" "\"\\x{2}\"."+ `shouldBe` Right (ErlString "\x2"))++ it "parses a two digit octal followed by a non-octal digit"+ (parseErlTerm "test" "\"\\779\"."+ `shouldBe` Right (ErlString "\o77\&9"))++ it "parses a string with escaped hex: \\x{NNNNNN...}"+ (parseErlTerm "test" "\"\\x{000000Fa}\"."+ `shouldBe` Right (ErlString "\xfa"))++ it "parses decimal literals"+ (property+ (do decimal <- arbitrary `suchThat` (>= 0)+ let decimalStr = B.pack (show (decimal :: Integer) ++ ".")+ parsedTerm <- case parseErlTerm "test" decimalStr of+ (Left e) -> fail e+ (Right parsedTerm) -> return parsedTerm+ return (ErlNatural decimal == parsedTerm)))++ it "parses a negative signed decimal"+ (parseErlTerm "test" "-1." `shouldBe` Right (ErlNatural (-1)))++ it "parses a positive signed decimal"+ (parseErlTerm "test" "+1." `shouldBe` Right (ErlNatural 1))++ it "parses decimal literals with radix notation"+ (property+ (do radix <- choose (2, 36)+ digitsInRadix <- listOf1 (choose (0, radix - 1))+ let (Right parsedTerm) = parseErlTerm "test" erlNumber+ erlNumber = B.pack (show radix ++ "#" ++ digitChars ++ ".")+ expected = convertStrToDecimal radix digitChars+ digitChars = (naturals !!) <$> digitsInRadix+ return (ErlNatural expected == parsedTerm)))++ it "parses a floating point literal with exponent and sign"+ (parseErlTerm "test" "-10.40E02." `shouldBe` Right (ErlFloat (-10.4e2)))++ it "parses a simple erlang character literal"+ (parseErlTerm "test" "$ ." `shouldBe` Right (ErlChar (toEnum 32)))++ it "parses an erlang character literal with escape sequence"+ (parseErlTerm "test" "$\\x{Fe}." `shouldBe` Right (ErlChar (toEnum 254)))++ it "parses an unquoted atom with @ and _"+ (parseErlTerm "test" "a@0_T." `shouldBe` Right (ErlAtom "a@0_T"))++ it "parses a quoted atom with letters, spaces and special characters"+ (parseErlTerm "test" "' $s<\\\\.0_=@\\e\\''."+ `shouldBe` Right (ErlAtom " $s<\\.0_=@\ESC'"))++ it "parses a binary literal containing a string"+ (parseErlTerm "test" "<<\"1 ok!\">>." `shouldBe` Right (ErlBinary "1 ok!"))++ it "parses an empty binary"+ (parseErlTerm "test" "<<>>." `shouldBe` Right (ErlBinary ""))++ it "parses an empty list"+ (parseErlTerm "test" "[]." `shouldBe` Right (ErlList []))++ it "parses a list of atoms"+ (parseErlTerm "test" " [ hello, 'world' ] ." `shouldBe` Right (ErlList [ErlAtom "hello", ErlAtom "world"]))++ it "parses an empty tuple"+ (parseErlTerm "test" " { } ." `shouldBe` Right (ErlTuple []))++ it "parses a tuple of atoms"+ (parseErlTerm "test" " { hello, 'world' } ." `shouldBe` Right (ErlTuple [ErlAtom "hello", ErlAtom "world"]))++ describe "renderErlTerm" $ do+ it "renders an empty binary as \"<<>>\"."+ (renderErlTerm (ErlBinary "") `shouldBe` "<<>>.")++ it "renders an erlang character"+ (renderErlTerm (ErlChar 'a') `shouldBe` "$a.")++ it "renders a quoted atom and escapes special characters"+ (renderErlTerm (ErlAtom " $s\"<\\.0_=@\ESC'")+ `shouldBe` "' $s\"<\\\\.0_=@\\x{1b}\\''.")++ it "renders a string and escapes special characters"+ (renderErlTerm (ErlString "' $s\"<\\.0_=@\ESC''")+ `shouldBe` "\"' $s\\\"<\\\\.0_=@\\x{1b}''\".")++ it "renders an empty list"+ (renderErlTerm (ErlList []) `shouldBe` "[].")++ it "renders an empty tuple"+ (renderErlTerm (ErlTuple []) `shouldBe` "{}.")++ describe "renderErlTerm and parseErlTerm" $++ it "parseErlTerm parses all terms rendered by renderErlTerm"+ (property parsesRenderedTerms)++parsesRenderedTerms :: SimpleErlangTerm -> Bool+parsesRenderedTerms term =+ either error (term ==) (parseErlTerm "test" (renderErlTerm term))++naturals :: String+naturals = ['0'..'9'] ++ ['a' .. 'z']++convertStrToDecimal :: Int -> String -> Integer+convertStrToDecimal radix digitChars =+ let hornersMethod acc d = acc * radixHighPrecision + digitCharToInteger d+ digitCharToInteger d = toInteger $ fromJust $ elemIndex d naturals+ radixHighPrecision = toInteger radix+ in foldl hornersMethod 0 digitChars
+ src/tests/B9/Content/ErlangPropListSpec.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE OverloadedStrings #-}+module B9.Content.ErlangPropListSpec (spec) where++import Control.Applicative+import Data.List+import Test.Hspec+import Test.QuickCheck+import Data.Semigroup+import Data.Text ()++import B9.Content.ErlTerms+import B9.Content.ErlangPropList+import B9.Content.AST++spec :: Spec+spec = do++ describe "ErlangPropList" $ do++ it "implements ConcatableSyntax method decodeSyntax" $+ let v = decodeSyntax "" "ok."+ in v `shouldBe` Right (ErlangPropList (ErlAtom "ok"))++ it "implements ConcatableSyntax method encodeSyntax" $+ let v = encodeSyntax (ErlangPropList (ErlAtom "ok"))+ in v `shouldBe` "ok."++ it "combines primitives by putting them in a list" $+ let p1 = ErlangPropList (ErlList [ErlAtom "a"])+ p2 = ErlangPropList (ErlList [ErlNatural 123])+ combined = ErlangPropList+ (ErlList [ErlAtom "a"+ ,ErlNatural 123])+ 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}]."+ 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]."+ in p <> l `shouldBe` combined++ it "merges lists with distinct elements to lists containing the elements of both lists" $+ let p1 = ErlangPropList+ (ErlList+ [ErlTuple [ErlAtom "k_p1"+ ,ErlList [ErlNatural 1]]])+ p2 = ErlangPropList+ (ErlList+ [ErlTuple [ErlAtom "k_p2"+ ,ErlList [ErlNatural 1]]])+ expected = ErlangPropList+ (ErlList+ [ErlTuple [ErlAtom "k_p1"+ ,ErlList [ErlNatural 1]]+ ,ErlTuple [ErlAtom "k_p2"+ ,ErlList [ErlNatural 1]]])+ in p1 <> p2 `shouldBe` expected++ it "merges two property lists into a prop list that has the lenght\+ \ of the left + the right proplist - the number of entries sharing\+ \ the same key" (property mergedPropListsHaveCorrectLength)++data ErlPropListTestData =+ ErlPropListTestData { plistLeft :: [SimpleErlangTerm]+ , plistRight :: [SimpleErlangTerm]+ , commonKeys :: [SimpleErlangTerm]+ } deriving (Eq,Ord,Show)++mergedPropListsHaveCorrectLength :: ErlPropListTestData -> Bool+mergedPropListsHaveCorrectLength (ErlPropListTestData l r common) =+ let (ErlangPropList (ErlList merged)) =+ ErlangPropList (ErlList l) <> ErlangPropList (ErlList r)+ expectedLen = length l + length r - length common+ in length merged == expectedLen++instance Arbitrary ErlPropListTestData where+ arbitrary = do+ someKeys <- nub <$> listOf arbitraryPlistKey+ numLeftOnly <- choose (0, length someKeys - 1)+ let keysLeftOnly = take numLeftOnly someKeys+ numCommon <- choose (0, length someKeys - numLeftOnly - 1)+ let keysCommon = take numCommon (drop numLeftOnly someKeys)+ let keysRightOnly = drop (numLeftOnly + numCommon) someKeys+ let numRightOnly = length someKeys - numLeftOnly - numCommon+ valuesLeft <- vectorOf (numLeftOnly + numCommon) arbitraryPlistValue+ valuesRight <- vectorOf (numRightOnly + numCommon) arbitraryPlistValue+ return ErlPropListTestData {+ plistLeft = zipWith toPair (keysLeftOnly <> keysCommon) valuesLeft+ , plistRight = zipWith toPair (keysRightOnly <> keysCommon) valuesRight+ , commonKeys = keysCommon+ }+ where+ toPair a b = ErlTuple [a,b]+ arbitraryPlist = ErlList <$> listOf arbitraryPlistEntry+ arbitraryPlistEntry = toPair <$> arbitraryPlistKey+ <*> arbitraryPlistValue+ arbitraryPlistKey = arbitraryErlSimpleAtom+ arbitraryPlistValue = oneof [arbitraryLiteral+ ,arbitraryList+ ,arbitraryPlist+ ,arbitraryTuple]+ arbitraryTuple = ErlTuple <$> listOf arbitraryPlistValue+ arbitraryList = ErlList <$> listOf arbitraryPlistValue+ arbitraryLiteral =+ oneof [arbitraryPlistKey,arbitraryErlString,arbitraryErlNumber]
+ src/tests/B9/Content/YamlObjectSpec.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE OverloadedStrings #-}+module B9.Content.YamlObjectSpec (spec) where++import Test.Hspec+import Data.Semigroup+import Data.Text ()+import Data.Yaml++import B9.Content.YamlObject+import B9.Content.AST++spec :: Spec+spec = do+ describe "YamlObject" $ do++ it "combines primitives by putting them in an array" $+ let v1 = YamlObject (toJSON True)+ v2 = YamlObject (toJSON (123::Int))+ combined = YamlObject (array [toJSON True+ ,toJSON (123::Int)])+ in (v1 <> v2) `shouldBe` combined++ it "combines objects with disjunct keys to an object \+ \containing all properties" $+ let plist1 = YamlObject (object ["k1" .= Number 1])+ plist2 = YamlObject (object ["k2" .= Number 2])+ combined = YamlObject (object ["k1" .= Number 1+ ,"k2" .= Number 2])+ in (plist1 <> plist2) `shouldBe` combined++ it "combines arrays by concatenating them" $+ let v1 = YamlObject (array [toJSON ("x"::String)])+ v2 = YamlObject (array [toJSON ("y"::String)])+ combined = YamlObject (array [toJSON ("x"::String)+ ,toJSON ("y"::String)])+ in (v1 <> v2) `shouldBe` combined++ it "combines objects to a an object containing\+ \ all disjunct entries and combined entries\+ \ with the same keys" $+ let o1 = YamlObject (object ["k1" .= Number 1+ ,"k" .= Number 2])+ o2 = YamlObject (object ["k2" .= Number 3+ ,"k" .= Number 4])+ combined =+ YamlObject (object ["k1" .= Number 1+ ,"k2" .= Number 3+ ,"k" .= array [Number 2+ ,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\+ \\n\+ \write_files:\n\+ \ - contents: |\n\+ \ hello world!\n\+ \\n\+ \ path: /sdf/xyz/filename.cfg\n\+ \ owner: root:root\n\+ \\n\+ \runcmd:\n\+ \ - x y z\n"++ (Right ud2) = decodeSyntax "" "#user-data\n\+ \\n\+ \write_files:\n\+ \ - contents: |\n\+ \ hello world2!\n\+ \\n\+ \ path: /sdf/xyz/filename.cfg\n\+ \ owner: root:root\n\+ \\n\+ \runcmd:\n\+ \ - a b c\n"++ ud = YamlObject+ (object+ ["runcmd" .=+ array [toJSON ("x y z"::String)+ ,toJSON ("a b c"::String)]+ ,"write_files" .=+ array [object+ ["contents" .=+ toJSON ("hello world!\n"::String)+ ,"path" .=+ toJSON ("/sdf/xyz/filename.cfg"::String)+ ,"owner" .=+ toJSON ("root:root"::String)]+ ,object+ ["contents" .=+ toJSON ("hello world2!\n"::String)+ ,"path" .=+ toJSON ("/sdf/xyz/filename.cfg"::String)+ ,"owner" .=+ toJSON ("root:root"::String)]]])+ in ud1 <> ud2 `shouldBe` ud+++-- describe "fromAST YamlObject" $ do+--+-- it "returns x from (AST x)" $+-- let x = (object [])+-- lift :: a -> ReaderT Environment IO a
+ src/tests/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}