diff --git a/.gitignore b/.gitignore new file mode 100644 --- /dev/null +++ b/.gitignore @@ -0,0 +1,14 @@ +*.hi +*.ho +TAGS +*.log +*.profile +/BUILD-* +/dist +/OUT +/cabal.config + +/.cabal-sandbox/ +/cabal.sandbox.config +/upload_doc.sh + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 -- + + +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 + +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" []]]))) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/TODO.org b/TODO.org new file mode 100644 --- /dev/null +++ b/TODO.org @@ -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 diff --git a/b9.cabal b/b9.cabal new file mode 100644 --- /dev/null +++ b/b9.cabal @@ -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 +maintainer: svh@posteo.de +copyright: 2015 Sven Heyll +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 diff --git a/build_and_run.sh b/build_and_run.sh new file mode 100644 --- /dev/null +++ b/build_and_run.sh @@ -0,0 +1,8 @@ +#!/bin/sh + +# Execute 'b9', if necessary compile it. + +set -e + +cabal install +./run.sh $@ diff --git a/build_and_test.sh b/build_and_test.sh new file mode 100644 --- /dev/null +++ b/build_and_test.sh @@ -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 diff --git a/build_haddock.sh b/build_haddock.sh new file mode 100644 --- /dev/null +++ b/build_haddock.sh @@ -0,0 +1,7 @@ +#!/bin/bash +# +# Create a HTML version of B9 code documentation using haddock. +# +set -xeu + +cabal haddock diff --git a/installDeps.sh b/installDeps.sh new file mode 100644 --- /dev/null +++ b/installDeps.sh @@ -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 diff --git a/prepare_release.sh b/prepare_release.sh new file mode 100644 --- /dev/null +++ b/prepare_release.sh @@ -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 diff --git a/run.sh b/run.sh new file mode 100644 --- /dev/null +++ b/run.sh @@ -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 $@ diff --git a/src/cli/Main.hs b/src/cli/Main.hs new file mode 100644 --- /dev/null +++ b/src/cli/Main.hs @@ -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 diff --git a/src/lib/B9.hs b/src/lib/B9.hs new file mode 100644 --- /dev/null +++ b/src/lib/B9.hs @@ -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 diff --git a/src/lib/B9/ArtifactGenerator.hs b/src/lib/B9/ArtifactGenerator.hs new file mode 100644 --- /dev/null +++ b/src/lib/B9/ArtifactGenerator.hs @@ -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] diff --git a/src/lib/B9/ArtifactGeneratorImpl.hs b/src/lib/B9/ArtifactGeneratorImpl.hs new file mode 100644 --- /dev/null +++ b/src/lib/B9/ArtifactGeneratorImpl.hs @@ -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) diff --git a/src/lib/B9/B9Config.hs b/src/lib/B9/B9Config.hs new file mode 100644 --- /dev/null +++ b/src/lib/B9/B9Config.hs @@ -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 diff --git a/src/lib/B9/B9Monad.hs b/src/lib/B9/B9Monad.hs new file mode 100644 --- /dev/null +++ b/src/lib/B9/B9Monad.hs @@ -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 diff --git a/src/lib/B9/Builder.hs b/src/lib/B9/Builder.hs new file mode 100644 --- /dev/null +++ b/src/lib/B9/Builder.hs @@ -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}") + ] + ]] +-} diff --git a/src/lib/B9/ConfigUtils.hs b/src/lib/B9/ConfigUtils.hs new file mode 100644 --- /dev/null +++ b/src/lib/B9/ConfigUtils.hs @@ -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)) diff --git a/src/lib/B9/Content/AST.hs b/src/lib/B9/Content/AST.hs new file mode 100644 --- /dev/null +++ b/src/lib/B9/Content/AST.hs @@ -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 + ] diff --git a/src/lib/B9/Content/ErlTerms.hs b/src/lib/B9/Content/ErlTerms.hs new file mode 100644 --- /dev/null +++ b/src/lib/B9/Content/ErlTerms.hs @@ -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 '@'] diff --git a/src/lib/B9/Content/ErlangPropList.hs b/src/lib/B9/Content/ErlangPropList.hs new file mode 100644 --- /dev/null +++ b/src/lib/B9/Content/ErlangPropList.hs @@ -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) diff --git a/src/lib/B9/Content/Generator.hs b/src/lib/B9/Content/Generator.hs new file mode 100644 --- /dev/null +++ b/src/lib/B9/Content/Generator.hs @@ -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 diff --git a/src/lib/B9/Content/StringTemplate.hs b/src/lib/B9/Content/StringTemplate.hs new file mode 100644 --- /dev/null +++ b/src/lib/B9/Content/StringTemplate.hs @@ -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 diff --git a/src/lib/B9/Content/YamlObject.hs b/src/lib/B9/Content/YamlObject.hs new file mode 100644 --- /dev/null +++ b/src/lib/B9/Content/YamlObject.hs @@ -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 diff --git a/src/lib/B9/DiskImageBuilder.hs b/src/lib/B9/DiskImageBuilder.hs new file mode 100644 --- /dev/null +++ b/src/lib/B9/DiskImageBuilder.hs @@ -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) diff --git a/src/lib/B9/DiskImages.hs b/src/lib/B9/DiskImages.hs new file mode 100644 --- /dev/null +++ b/src/lib/B9/DiskImages.hs @@ -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" diff --git a/src/lib/B9/ExecEnv.hs b/src/lib/B9/ExecEnv.hs new file mode 100644 --- /dev/null +++ b/src/lib/B9/ExecEnv.hs @@ -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' diff --git a/src/lib/B9/LibVirtLXC.hs b/src/lib/B9/LibVirtLXC.hs new file mode 100644 --- /dev/null +++ b/src/lib/B9/LibVirtLXC.hs @@ -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 = + "\n\ + \ " ++ buildId ++ "\n\ + \ " ++ uuid ++ "\n\ + \ " ++ memoryAmount e ++ "\n\ + \ " ++ memoryAmount e ++ "\n\ + \ " ++ cpuCountStr e ++ "\n\ + \ \n\ + \ \n\ + \ "++ renderGuestCapabilityEntries cfg ++"\n\ + \ \n\ + \ \n\ + \ \n\ + \ exe\n\ + \ " ++ scriptDirGuest initScript ++ "\n\ + \ \n\ + \ \n\ + \ destroy\n\ + \ restart\n\ + \ destroy\n\ + \ \n\ + \ " ++ emulator cfg ++ "\n" + ++ unlines (libVirtNetwork (networkId cfg) ++ + (fsImage <$> (envImageMounts e)) ++ + (fsSharedDir <$> (envSharedDirectories e))) ++ "\n" ++ + " \n\ + \ \n\ + \ \n\ + \ \n\ + \ \n\ + \ \n\ + \ \n\ + \ \n\ + \\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) = + [ "" + , " " + , "" ] + +fsImage :: (Image, MountPoint) -> String +fsImage (img, mnt) = + case fsTarget mnt of + Just mntXml -> + "\n " ++ + fsImgDriver img ++ "\n " ++ fsImgSource img ++ "\n " ++ mntXml ++ + "\n" + Nothing -> + "" + where + fsImgDriver (Image _img fmt _fs) = + printf "" 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) = "" + +fsSharedDir :: SharedDirectory -> String +fsSharedDir (SharedDirectory hostDir mnt) = + case fsTarget mnt of + Just mntXml -> + "\n " ++ + "" ++ "\n " ++ mntXml ++ + "\n" + Nothing -> + "" +fsSharedDir (SharedDirectoryRO hostDir mnt) = + case fsTarget mnt of + Just mntXml -> + "\n " ++ + "" ++ "\n " ++ mntXml ++ + "\n \n" + Nothing -> + "" +fsSharedDir (SharedSources _) = + error "Unreachable code reached!" + +fsTarget :: MountPoint -> Maybe String +fsTarget (MountPoint dir) = Just $ "" +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 diff --git a/src/lib/B9/MBR.hs b/src/lib/B9/MBR.hs new file mode 100644 --- /dev/null +++ b/src/lib/B9/MBR.hs @@ -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 diff --git a/src/lib/B9/PartitionTable.hs b/src/lib/B9/PartitionTable.hs new file mode 100644 --- /dev/null +++ b/src/lib/B9/PartitionTable.hs @@ -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 diff --git a/src/lib/B9/QCUtil.hs b/src/lib/B9/QCUtil.hs new file mode 100644 --- /dev/null +++ b/src/lib/B9/QCUtil.hs @@ -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'] diff --git a/src/lib/B9/Repository.hs b/src/lib/B9/Repository.hs new file mode 100644 --- /dev/null +++ b/src/lib/B9/Repository.hs @@ -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" diff --git a/src/lib/B9/RepositoryIO.hs b/src/lib/B9/RepositoryIO.hs new file mode 100644 --- /dev/null +++ b/src/lib/B9/RepositoryIO.hs @@ -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] diff --git a/src/lib/B9/ShellScript.hs b/src/lib/B9/ShellScript.hs new file mode 100644 --- /dev/null +++ b/src/lib/B9/ShellScript.hs @@ -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"] diff --git a/src/lib/B9/Vm.hs b/src/lib/B9/Vm.hs new file mode 100644 --- /dev/null +++ b/src/lib/B9/Vm.hs @@ -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 diff --git a/src/lib/B9/VmBuilder.hs b/src/lib/B9/VmBuilder.hs new file mode 100644 --- /dev/null +++ b/src/lib/B9/VmBuilder.hs @@ -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 diff --git a/src/tests/B9/ArtifactGeneratorImplSpec.hs b/src/tests/B9/ArtifactGeneratorImplSpec.hs new file mode 100644 --- /dev/null +++ b/src/tests/B9/ArtifactGeneratorImplSpec.hs @@ -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]]]) diff --git a/src/tests/B9/Content/ErlTermsSpec.hs b/src/tests/B9/Content/ErlTermsSpec.hs new file mode 100644 --- /dev/null +++ b/src/tests/B9/Content/ErlTermsSpec.hs @@ -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 diff --git a/src/tests/B9/Content/ErlangPropListSpec.hs b/src/tests/B9/Content/ErlangPropListSpec.hs new file mode 100644 --- /dev/null +++ b/src/tests/B9/Content/ErlangPropListSpec.hs @@ -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] diff --git a/src/tests/B9/Content/YamlObjectSpec.hs b/src/tests/B9/Content/YamlObjectSpec.hs new file mode 100644 --- /dev/null +++ b/src/tests/B9/Content/YamlObjectSpec.hs @@ -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 diff --git a/src/tests/Spec.hs b/src/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/src/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}