b9 0.5.69.0 → 1.0.0
raw patch · 60 files changed
+5444/−4070 lines, 60 filesdep +dhalldep ~basedep ~optparse-applicative
Dependencies added: dhall
Dependency ranges changed: base, optparse-applicative
Files
- .gitignore +10/−5
- .travis.yml +1/−1
- README.md +343/−191
- b9.cabal +33/−20
- src/cli/Main.hs +163/−119
- src/lib/B9.hs +213/−202
- src/lib/B9/Artifact.hs +4/−4
- src/lib/B9/Artifact/Content.hs +8/−8
- src/lib/B9/Artifact/Content/AST.hs +78/−76
- src/lib/B9/Artifact/Content/CloudConfigYaml.hs +35/−32
- src/lib/B9/Artifact/Content/ErlTerms.hs +221/−218
- src/lib/B9/Artifact/Content/ErlangPropList.hs +30/−31
- src/lib/B9/Artifact/Content/Readable.hs +51/−52
- src/lib/B9/Artifact/Content/StringTemplate.hs +110/−107
- src/lib/B9/Artifact/Content/YamlObject.hs +63/−62
- src/lib/B9/Artifact/Readable.hs +181/−167
- src/lib/B9/Artifact/Readable/Interpreter.hs +312/−293
- src/lib/B9/Artifact/Readable/Source.hs +50/−46
- src/lib/B9/B9Config.hs +180/−162
- src/lib/B9/B9Config/Container.hs +64/−0
- src/lib/B9/B9Config/Docker.hs +61/−0
- src/lib/B9/B9Config/LibVirtLXC.hs +49/−91
- src/lib/B9/B9Config/Podman.hs +61/−0
- src/lib/B9/B9Config/Repository.hs +56/−50
- src/lib/B9/B9Config/SystemdNspawn.hs +129/−0
- src/lib/B9/B9Error.hs +51/−28
- src/lib/B9/B9Exec.hs +229/−42
- src/lib/B9/B9Logging.hs +54/−46
- src/lib/B9/B9Monad.hs +32/−24
- src/lib/B9/BuildInfo.hs +94/−89
- src/lib/B9/Container.hs +38/−0
- src/lib/B9/DiskImageBuilder.hs +226/−197
- src/lib/B9/DiskImages.hs +244/−191
- src/lib/B9/Docker.hs +77/−0
- src/lib/B9/Environment.hs +132/−119
- src/lib/B9/ExecEnv.hs +75/−58
- src/lib/B9/LibVirtLXC.hs +158/−156
- src/lib/B9/MBR.hs +56/−51
- src/lib/B9/PartitionTable.hs +9/−9
- src/lib/B9/Podman.hs +52/−0
- src/lib/B9/QCUtil.hs +23/−22
- src/lib/B9/Repository.hs +76/−68
- src/lib/B9/RepositoryIO.hs +105/−100
- src/lib/B9/Shake.hs +3/−3
- src/lib/B9/Shake/Actions.hs +12/−12
- src/lib/B9/Shake/SharedImageRules.hs +20/−14
- src/lib/B9/ShellScript.hs +123/−101
- src/lib/B9/SystemdNspawn.hs +239/−0
- src/lib/B9/Text.hs +54/−51
- src/lib/B9/Vm.hs +43/−46
- src/lib/B9/VmBuilder.hs +120/−94
- src/lib/Data/ConfigFile/B9Extras.hs +51/−47
- src/lib/System/IO/B9Extras.hs +61/−56
- src/tests/B9/ArtifactGeneratorImplSpec.hs +95/−97
- src/tests/B9/Content/ErlTermsSpec.hs +156/−175
- src/tests/B9/Content/ErlangPropListSpec.hs +86/−86
- src/tests/B9/Content/YamlObjectSpec.hs +88/−99
- src/tests/B9/DiskImagesSpec.hs +29/−24
- src/tests/B9/EnvironmentSpec.hs +26/−27
- stack.yaml +1/−1
.gitignore view
@@ -3,10 +3,11 @@ TAGS *.log *.profile-/BUILD-*-/dist-/OUT-+BUILD*+dist+dist-newstyle+OUT+*.orig /.cabal-sandbox/ /cabal.sandbox.config /upload_doc.sh@@ -16,6 +17,10 @@ *.iml .stack-work-/result+result* *~ /out+*.raw+*.qcow2+*.tar+*.vmdk
.travis.yml view
@@ -1,2 +1,2 @@ language: nix-script: nix-build release.nix+script: nix-build
README.md view
@@ -1,11 +1,15 @@ # B9 - A Benign VM-Build Tool [](CHANGELOG.md) -[](https://travis-ci.org/sheyll/b9-vm-image-builder) [](http://stackage.org/lts/package/b9)[](http://hackage.haskell.org/package/b9)+[](https://travis-ci.org/sheyll/b9-vm-image-builder) [](http://hackage.haskell.org/package/b9) -**An algebraic data type to describe virtual machine images generation.**+**NOTE: The feature list is not completely implemented yet!** -### Overview+**When version 2 is released of b9, all features listed here can be expected to work.** +## Quick-Start++### Mission Statement+ **B9** is an executable and a Haskell library, that consumes a Haskell term describing the generation of VM-Images. @@ -13,90 +17,99 @@ Such a term can then be stored into a **text file** and is interpreted by a **command line invokation**. +### Installation + ### Installation on NixOS * As **command line utility** in current directory: - $ nix-build -E 'import ((fetchTarball https://github.com/sheyll/b9-vm-image-builder/archive/0.5.tar.gz) + "/release.nix") {}'+ $ nix-build -E 'import (fetchTarball https://github.com/sheyll/b9-vm-image-builder/archive/1.0.0.tar.gz) {}' Now the executable `b9c` is in `./result/bin/`: $ result/bin/b9c -### Installation as Hackage Library with Stack+### Runtime dependencies -**Add a dependency to `b9` in your `.cabal` file.** +To be able to use B9 install: -Update the `extra-deps` section in your `stack.yaml`:- - extra-deps:- - b9-0.5.68.2+* Linux+* qemu+* ext4 tools+* genisoimage+* mtools+* vfat tools+* ssh+* rsync+* bash+* wget+* sudo (optional) -### Installation of custom version as Library with Stack +#### `LibVirtLXC` support -**Instead** of adding to `extra-deps` one can use version **not on Hackage**.-Update the `packages` section in your `stack.yaml`:+* lxc+* libvirt with lxc support (libvirt-driver-lxc, libvirt-daemon-lxc,...)+* virsh - # Local packages, usually specified by relative directory name- packages:- - - location:- github: git@github.com:sheyll/b9-vm-image-builder.git- commit: 467c4bf8274a50a72a2a720f3c2710926fb845b2- extra-dep: true+B9 has been tested with libvirt version 1.2.12. -### Features+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. -* Disk image creation- * Growing shrinking of disk images and file systems- * File system creation- * Using existing Disk/File system as input- * Libvirt/LXC based shell script execution- * ISO/VFAT cloud-init images without Libvirt/LXC- * **Artifact Caching and Sharing**- * Shake rules- * (Source-) File Creation- * Example: Merge yaml config snippets, with template parameterers replaced into a text file- included on the output image. - * text-files- * structured text files with merging:- * raw- * yaml- * erlang- * Syntax trees for *objects* that can be converted to raw text, yaml or erlang- * base64 encoded binaries- * content fetched via HTTP- * simple template support with `${variableName}`-* Repetition and Reuse+If neccessary create a libvirt network configuration, e.g. by using+the GUI front-end`virt-manager`. -### Supported Formats+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: -Supported Disk Images and File system types:+* `virsh`+* `rm`+* `cat`+* `cp`+* `mv` - * Cloud-init - * ISOs- * VFAT floppys- * raw directories- * VMDK files- * QCOW images- * RAW images - * MBR partitioned disk images- * EXT-4+#### For `SystemdNspawn` support -### Old Readme+* systemd +#### For `Podman` support++* podman ++#### For `Docker` support++* docker +++After installing B9 (either from a binary package or by building from source)+all its glory is availbe through a single executable called `b9c`.++When `b9c` is started for the first time, it creates a configuration file in+the users home directory called `~/.b9/b9.conf`. The path to that file can be+changed using command line arguments. Execute:++ b9c -h++for a list of command line parameters and commands.++`b9c` command line arguments always follow this pattern:++ b9c <global-options> <command> <command-options> -- <build-script-extra-args>++To enable B9 to work correctly on your machine edit the config file and make+necessary adaptions.++## General Overview ++ 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@@ -104,7 +117,7 @@ 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,+systems that provide configuration through 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@@ -112,11 +125,13 @@ 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+eventually get there. The tool at hand works stable and reliable. ++All builds happen in isolation, i.e. by default in random build directories, and+are cleaned on failure. ++Also, B9 does not modify cached images. +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@@ -131,139 +146,53 @@ * 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--## Installation--### b9 executable and library--Install via `stack`:-- $ stack install b9--### Runtime dependencies--To be able to use B9 install:--* Linux-* 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`.+### Make VM Disk Images -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:+* Extract partitions from MRB Partitioned images+* Create, resuse, resize EXT-4 on Qcow2, vmdk or raw Images +* Run commands on images to create new image, similar to what docker build does, + * Using libvirt-lxc + * Using docker + * Using systemd-nspawn -* `virsh`-* `rm`-* `cat`-* `cp`-* `mv`+### Manage Disk Images -After installing B9 (either from a binary package or by building from source)-all its glory is availbe through a single executable called `b9c`.+* Cache images locally+* Distribute cached images via SCP -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:+### Assemble Cloud-init Configuration - b9c -h+* Merge YAML Expressions+* Merge Erlang Terms +* Load local files +* Load files from HTTP servers+* Support `${identifier}` variable interpolation +* Create cloud-init + * ISO images + * Floppy images + * yaml files -for a list of command line parameters and commands.+### Input files -`b9c` command line arguments always follow this pattern:+The input files can be in: - b9c <global-options> <command> <command-options> -- <build-script-extra-args>+* DHALL format+* Haskell values interpreted by the `Read` instances. -To enable B9 to work correctly on your machine edit the config file and make-necessary adaptions.+### Usage as Library -## B9 configuration file+* Use as a Haskell library -This is an example of a B9 configuration file, by default found in-`~/.b9/b9.conf`:+### Configuration - [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+B9 uses a *`.ini` - style* configuration file. - [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+### Incremental Builds -Some of the options can also be specified on the command line.+B9 uses `shake` so some degree of incremental build is available. -# Writing B9 build files+## B9 build files If you really need to write these file, you are basically f'ed. @@ -273,7 +202,7 @@ More documentation is comming soon! -## General Structure+### 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@@ -283,7 +212,7 @@ `ArtifactGenerator` literal, no matter how many `Let`, `Each`, `Artifacts`, etc... you see flying around there. -## Creating artifacts+### 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@@ -296,7 +225,7 @@ 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+#### 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:@@ -310,7 +239,7 @@ Artifact (IID "my_first_image") (VmImages [...] (...)) -#### ImageTargets+##### ImageTargets The first argument to `VmImages` is a list of `ImageTarget`. Each describes a single VM-disk-image. The syntax is:@@ -325,7 +254,7 @@ * A `MountPoint` specifies where to mount the image during the execution of an optional `VmBuild`-script. -### Parameterized artifact generators+#### Parameterized artifact generators B9 supports `$varnam` variable interpolation in all strings anywhere in an `ArtifactGenerator`:@@ -363,14 +292,14 @@ may also contain a variable reference. (Of course, only to variabled defined _before_) -## Anger-Management+### 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+#### Trick 1 Start with a working file and run @@ -384,7 +313,7 @@ NOTE: If your build file refers to any `${arg_...}` positional arguments pass them to `reformat` using `--` followed by the argument list. -### Trick 2+#### 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@@ -429,3 +358,226 @@ SharedDirectoryRO "../_common/upload" (MountPoint "/mnt/common")] (Begin [Run "dhclient" [],In "/mnt/build_root" [Run "./machine-" []],In "/mnt/common" [Run "./post_export.sh" []]])))++## B9 Config File Reference++This is an example of a B9 configuration file, by default found in+`~/.b9/b9.conf` and uses the **ini-file** format.++Some of the options can also be specified on the command line+and in environment variables.++A path to an alternative config file can given on the command lines.++When the default config file does not exist, `b9c` will create it from +default values.+++This example is the current default configuration:++ [global]+ build_dir_root: Nothing+ keep_temp_dirs: False+ log_file: Nothing+ max_cached_shared_images: Just 2+ repository: Nothing+ repository_cache: Just (InB9UserDir "repo-cache")+ unique_build_dirs: True+ verbosity: Just LogInfo++ [libvirt-lxc]+ connection: lxc:///+ emulator_path: Just "/usr/lib/libvirt/libvirt_lxc"+ guest_capabilities: [CAP_MKNOD,CAP_SYS_ADMIN,CAP_SYS_CHROOT,CAP_SETGID,CAP_SETUID,CAP_NET_BIND_SERVICE,CAP_SETPCAP,CAP_SYS_PTRACE,CAP_SYS_MODULE]+ guest_ram_size: RamSize 1 GB+ network: Nothing+ use_sudo: True++ [podman]+ guest_capabilities: [CAP_MKNOD,CAP_SYS_ADMIN,CAP_SYS_CHROOT,CAP_SETGID,CAP_SETUID,CAP_NET_BIND_SERVICE,CAP_SETPCAP,CAP_SYS_PTRACE,CAP_SYS_MODULE]+ network: Nothing++ [systemdNspawn]+ console: read-only+ executable: Nothing+ extra_args: Nothing+ guest_capabilities: [CAP_MKNOD,CAP_SYS_ADMIN,CAP_SYS_CHROOT,CAP_SETGID,CAP_SETUID,CAP_NET_BIND_SERVICE,CAP_SETPCAP,CAP_SYS_PTRACE,CAP_SYS_MODULE]+ max_lifetime_seconds: Just 14400+ use_sudo: True++ [docker]+ guest_capabilities: [CAP_MKNOD,CAP_SYS_ADMIN,CAP_SYS_CHROOT,CAP_SETGID,CAP_SETUID,CAP_NET_BIND_SERVICE,CAP_SETPCAP,CAP_SYS_PTRACE,CAP_SYS_MODULE]+ network: Nothing+++### The `[global]` Section+++#### `build_dir_root`: ++* Default: `Nothing`++_TODO document this option._++#### `keep_temp_dirs`: ++* Default: `False`++_TODO document this option._++#### `log_file`: ++* Default: `Nothing`++_TODO document this option._++#### `max_cached_shared_images`: ++* Default: `Just 2`++_TODO document this option._++#### `repository`: ++* Default: `Nothing`++_TODO document this option._++#### `repository_cache`: ++* Default: `Just (InB9UserDir "repo-cache")`++_TODO document this option._++#### `unique_build_dirs`: ++* Default: `True`++_TODO document this option._++#### `verbosity`: ++* Default: `Just LogInfo`++_TODO document this option._++### The `[libvirt-lxc]` Section++#### `connection`++* Default: `lxc:///`++_TODO document this option._++#### `emulator_path`++* Default: `Just "/usr/lib/libvirt/libvirt_lxc"`++_TODO document this option._++#### `guest_capabilities`++* Default: `[CAP_MKNOD,CAP_SYS_ADMIN,CAP_SYS_CHROOT,CAP_SETGID,CAP_SETUID,CAP_NET_BIND_SERVICE,CAP_SETPCAP,CAP_SYS_PTRACE,CAP_SYS_MODULE]`++_TODO document this option._++#### `guest_ram_size`++* Default: `RamSize 1 GB`++_TODO document this option._++#### `network`++* Default: `Nothing`++_TODO document this option._++#### `use_sudo`++* Default: `True`++_TODO document this option._++### The `[podman]` Section++**Since: 1.0.0**++#### `guest_capabilities`++* Default: `[CAP_MKNOD,CAP_SYS_ADMIN,CAP_SYS_CHROOT,CAP_SETGID,CAP_SETUID,CAP_NET_BIND_SERVICE,CAP_SETPCAP,CAP_SYS_PTRACE,CAP_SYS_MODULE]`++_TODO document this option._++#### `network`++* Default: `Nothing`++_TODO document this option._++### The `[systemdNspawn]` Section ++**Since: 1.0.0**++#### `console`++* Default: `read-only`+* Valid Values:+ * `read-only`+ * `interactive`+ * `passive`+ * `pipe`++This corresponds to the `--console=<...>` parameter to `systemd-nspawn`.++If the value is set to `interactive` the execution of +any `VmScript`s through `systemd-nspawn` will be _interactive_ +by using `stdin`, `stdout` and `stderr` of the `b9c` process.++#### `executable`++* Default: `Nothing`++_TODO document this option._++#### `extra_args`++* Default: `Nothing`++_TODO document this option._++#### `guest_capabilities`++* Default: `[CAP_MKNOD,CAP_SYS_ADMIN,CAP_SYS_CHROOT,CAP_SETGID,CAP_SETUID,CAP_NET_BIND_SERVICE,CAP_SETPCAP,CAP_SYS_PTRACE,CAP_SYS_MODULE]`++_TODO document this option._++#### `max_lifetime_seconds`++* Default: `Just 14400`++_TODO document this option._++#### `use_sudo`++* Default: `True`++_TODO document this option._++### The `[docker]` Section++**Since: 1.0.0**++#### `guest_capabilities`++* Default: `[CAP_MKNOD,CAP_SYS_ADMIN,CAP_SYS_CHROOT,CAP_SETGID,CAP_SETUID,CAP_NET_BIND_SERVICE,CAP_SETPCAP,CAP_SYS_PTRACE,CAP_SYS_MODULE]`++_TODO document this option._++#### `network`++* Default: `Nothing`++_TODO document this option._++
b9.cabal view
@@ -1,6 +1,6 @@-cabal-version: 2.2+cabal-version: 2.4 name: b9-version: 0.5.69.0+version: 1.0.0 synopsis: A tool and library for building virtual machine images. @@ -63,7 +63,7 @@ , CHANGELOG.md common b9Deps- build-depends: base >= 4.10 && < 5+ build-depends: base >= 4.12 && < 5 , bytestring >= 0.10.8 , directory >= 1.3 , extensible-effects >= 5 && < 6@@ -73,6 +73,7 @@ , text >= 1.2 common b9Extensions+ other-extensions: OverloadedStrings default-extensions: ConstraintKinds , CPP , DataKinds@@ -109,30 +110,36 @@ , B9.Artifact.Content , B9.Artifact.Content.AST , B9.Artifact.Content.CloudConfigYaml- , B9.Artifact.Content.ErlangPropList , B9.Artifact.Content.ErlTerms+ , B9.Artifact.Content.ErlangPropList , B9.Artifact.Content.Readable , B9.Artifact.Content.StringTemplate , B9.Artifact.Content.YamlObject , B9.Artifact.Readable , B9.Artifact.Readable.Interpreter , B9.Artifact.Readable.Source- , B9.BuildInfo , B9.B9Config+ , B9.B9Config.Container+ , B9.B9Config.Docker , B9.B9Config.LibVirtLXC+ , B9.B9Config.Podman , B9.B9Config.Repository+ , B9.B9Config.SystemdNspawn , B9.B9Error- , B9.B9Logging , B9.B9Exec- , B9.B9Monad+ , B9.B9Logging+ , B9.B9Monad + , B9.BuildInfo+ , B9.Container , B9.DiskImageBuilder , B9.DiskImages+ , B9.Docker , B9.Environment , B9.ExecEnv- , B9.Text , B9.LibVirtLXC , B9.MBR , B9.PartitionTable+ , B9.Podman , B9.QCUtil , B9.Repository , B9.RepositoryIO@@ -140,6 +147,8 @@ , B9.Shake.Actions , B9.Shake.SharedImageRules , B9.ShellScript+ , B9.SystemdNspawn+ , B9.Text , B9.Vm , B9.VmBuilder , Data.ConfigFile.B9Extras@@ -151,32 +160,34 @@ , aeson >= 1.0 , async >= 2.1 , base64-bytestring+ , bifunctors >= 5.4 , binary >= 0.8.3+ , boxes >= 0.1.4 , conduit >= 1.2 , conduit-extra >= 1.1+ , dhall >= 1 , exceptions >= 0.10 , filepath >= 1.4+ , free >= 4.12 , hashable >= 1.2 , monad-control >= 1.0 && < 1.1 , mtl >= 2.2- , time >= 1.6+ , optparse-applicative >= 0.14 , parallel >= 3.2 , parsec >= 3.1- , pretty-show >= 1.6 , pretty >= 1.1+ , pretty-show >= 1.6 , process >= 1.4 , random >= 1.1 , shake >= 0.17.6 && < 0.19 , syb >= 0.6 , tagged >= 0.8 && < 0.9 , template >= 0.2+ , time >= 1.6 , transformers >= 0.5 , unordered-containers >= 0.2.8 , vector >= 0.11 , yaml >= 0.8- , bifunctors >= 5.4- , free >= 4.12- , boxes >= 0.1.4 executable b9c import: b9Extensions, b9Deps@@ -187,27 +198,29 @@ , extensible-effects >= 5 && < 6 , optparse-applicative >= 0.13 hs-source-dirs: src/cli+ ghc-options: -Wall+ -fwarn-unused-binds -fno-warn-unused-do-bind -threaded test-suite spec import: b9Extensions, b9Deps type: exitcode-stdio-1.0- ghc-options: -Wall+ ghc-options: -Wall -threaded hs-source-dirs: src/tests main-is: Spec.hs autogen-modules: Paths_b9 other-modules: B9.Content.ErlTermsSpec+ , B9.ArtifactGeneratorImplSpec , B9.Content.ErlangPropListSpec , B9.Content.YamlObjectSpec- , B9.ArtifactGeneratorImplSpec , B9.DiskImagesSpec , B9.EnvironmentSpec , Paths_b9- build-depends: b9+ build-depends: QuickCheck >= 2.5+ , b9+ , aeson >= 1.0 , binary >= 0.8 && < 0.9 , hspec , hspec-expectations- , QuickCheck >= 2.5- , aeson >= 1.0- , yaml >= 0.8- , vector >= 0.11 , unordered-containers >= 0.2+ , vector >= 0.11+ , yaml >= 0.8
src/cli/Main.hs view
@@ -1,11 +1,12 @@ module Main- ( main- ) where+ ( main,+ )+where -import B9-import Control.Lens (set, (&), (.~), _Just)-import Options.Applicative hiding (action)-import Options.Applicative.Help.Pretty hiding ((</>))+import B9+import Control.Lens ((&), (.~), _Just, set)+import Options.Applicative hiding (action)+import Options.Applicative.Help.Pretty hiding ((</>)) main :: IO () main = do@@ -14,10 +15,11 @@ -- | A data structure that contains the `B9Invocation` -- as well as build parameters.-data B9RunParameters =- B9RunParameters B9ConfigOverride- (B9ConfigAction ())- Environment+data B9RunParameters+ = B9RunParameters+ B9ConfigOverride+ (B9ConfigAction ())+ Environment hostNetworkMagicValue :: String hostNetworkMagicValue = "host"@@ -30,140 +32,182 @@ parseCommandLine :: IO B9RunParameters parseCommandLine = execParser- (info- (helper <*> (B9RunParameters <$> globals <*> cmds <*> buildVars))- (fullDesc <>- progDesc- "Build and run VM-Images inside LXC containers. Custom arguments follow after '--' and are accessable in many strings in build files trough shell like variable references, i.e. '${arg_N}' referes to positional argument $N.\n\nRepository names passed to the command line are looked up in the B9 configuration file, which is per default located in: '~/.b9/b9.conf'. The current working directory is used as ${projectRoot} if not otherwise specified in the config file, or via the '-b' option." <>- headerDoc (Just b9HelpHeader)))+ ( info+ (helper <*> (B9RunParameters <$> globals <*> cmds <*> buildVars))+ ( fullDesc+ <> progDesc+ "Build and run VM-Images inside docker/system-nspawn/LXC containers. Custom arguments follow after '--' and are accessable in many strings in build files trough shell like variable references, i.e. '${arg_N}' referes to positional argument $N.\n\nRepository names passed to the command line are looked up in the B9 configuration file, which is per default located in: '~/.b9/b9.conf'. The current working directory is used as ${projectRoot} if not otherwise specified in the config file, or via the '-b' option."+ <> headerDoc (Just b9HelpHeader)+ )+ ) where b9HelpHeader = linebreak <> text ("B9 - a benign VM-Image build tool v. " ++ b9VersionString) globals :: Parser B9ConfigOverride globals =- toGlobalOpts <$>- optional- (strOption- (help "Path to user's b9-configuration (default: ~/.b9/b9.conf)" <> short 'c' <> long "configuration-file" <>- metavar "FILENAME")) <*>- switch (help "Log everything that happens to stdout" <> short 'v' <> long "verbose") <*>- switch (help "Suppress non-error output" <> short 'q' <> long "quiet") <*>- optional (strOption (help "Path to a logfile" <> short 'l' <> long "log-file" <> metavar "FILENAME")) <*>- optional- (strOption- (help- "Root directory for build directories. If not specified '.'. The path will be canonicalized and stored in ${projectRoot}." <>- short 'b' <>- long "build-root-dir" <>- metavar "DIRECTORY")) <*>- switch (help "Keep build directories after exit" <> short 'k' <> long "keep-build-dir") <*>- switch (help "Predictable build directory names" <> short 'u' <> long "predictable-build-dir") <*>- optional- (strOption- (help "Cache directory for shared images, default: '~/.b9/repo-cache'" <> long "repo-cache" <>- metavar "DIRECTORY")) <*>- optional- (strOption (help "Remote repository to share image to" <> short 'r' <> long "repo" <> metavar "REPOSITORY_ID")) <*>- optional- (strOption- (help- ("Override the libvirt-lxc network setting.\nThe special value '" ++- hostNetworkMagicValue ++ "' disables restricted container networking.") <>- long "network" <>- metavar "NETWORK_ID"))+ toGlobalOpts+ <$> optional+ ( strOption+ ( help "Path to user's b9-configuration (default: ~/.b9/b9.conf)" <> short 'c' <> long "configuration-file"+ <> metavar "FILENAME"+ )+ )+ <*> switch (help "Log everything that happens to stdout" <> short 'v' <> long "verbose")+ <*> switch (help "Suppress non-error output" <> short 'q' <> long "quiet")+ <*> optional (strOption (help "Path to a logfile" <> short 'l' <> long "log-file" <> metavar "FILENAME"))+ <*> optional+ ( strOption+ ( help+ "Root directory for build directories. If not specified '.'. The path will be canonicalized and stored in ${projectRoot}."+ <> short 'b'+ <> long "build-root-dir"+ <> metavar "DIRECTORY"+ )+ )+ <*> switch (help "Keep build directories after exit" <> short 'k' <> long "keep-build-dir")+ <*> switch (help "Predictable build directory names" <> short 'u' <> long "predictable-build-dir")+ <*> optional+ ( strOption+ ( help "Cache directory for shared images, default: '~/.b9/repo-cache'" <> long "repo-cache"+ <> metavar "DIRECTORY"+ )+ )+ <*> optional+ (strOption (help "Remote repository to share image to" <> short 'r' <> long "repo" <> metavar "REPOSITORY_ID"))+ <*> optional+ ( strOption+ ( help+ ( "Override the container network setting.\nThe special value '"+ ++ hostNetworkMagicValue+ ++ "' disables restricted container networking."+ )+ <> long "network"+ <> metavar "NETWORK_ID"+ )+ ) where toGlobalOpts ::- Maybe FilePath- -> Bool- -> Bool- -> Maybe FilePath- -> Maybe FilePath- -> Bool- -> Bool- -> Maybe FilePath- -> Maybe String- -> Maybe String- -> B9ConfigOverride- toGlobalOpts cfg verbose quiet logF buildRoot keep predictableBuildDir mRepoCache repo libvirtNet =+ Maybe FilePath ->+ Bool ->+ Bool ->+ Maybe FilePath ->+ Maybe FilePath ->+ Bool ->+ Bool ->+ Maybe FilePath ->+ Maybe String ->+ Maybe String ->+ B9ConfigOverride+ toGlobalOpts cfg verbose quiet logF buildRoot keep predictableBuildDir mRepoCache repo containerNetworking = let minLogLevel | verbose = Just LogTrace | quiet = Just LogError | otherwise = Nothing b9cfg =- Endo (verbosity .~ minLogLevel) <> Endo (logFile .~ logF) <> Endo (projectRoot .~ buildRoot) <>- Endo (keepTempDirs .~ keep) <>- Endo (uniqueBuildDirs .~ not predictableBuildDir) <>- Endo (repository .~ repo) <>- Endo (repositoryCache .~ (Path <$> mRepoCache)) <>- case libvirtNet of- Just n | n /= hostNetworkMagicValue -> Endo (set (libVirtLXCConfigs . _Just . networkId) (Just n))- Just n | n == hostNetworkMagicValue -> Endo (set (libVirtLXCConfigs . _Just . networkId) Nothing)- _ -> mempty- in B9ConfigOverride {_customB9ConfigPath = Path <$> cfg, _customB9Config = b9cfg, _customEnvironment = mempty}+ Endo (verbosity .~ minLogLevel) <> Endo (logFile .~ logF) <> Endo (projectRoot .~ buildRoot)+ <> Endo (keepTempDirs .~ keep)+ <> Endo (uniqueBuildDirs .~ not predictableBuildDir)+ <> Endo (repository .~ repo)+ <> Endo (repositoryCache .~ (Path <$> mRepoCache))+ <> case containerNetworking of+ Just n+ | n /= hostNetworkMagicValue ->+ Endo+ ( set (libVirtLXCConfigs . _Just . networkId) (Just n)+ . set (dockerConfigs . _Just . dockerNetworkId) (Just n)+ . set (podmanConfigs . _Just . podmanNetworkId) (Just n)+ )+ Just n+ | n == hostNetworkMagicValue ->+ Endo+ ( set (libVirtLXCConfigs . _Just . networkId) Nothing+ . set (dockerConfigs . _Just . dockerNetworkId) Nothing+ . set (podmanConfigs . _Just . podmanNetworkId) Nothing+ )+ _ -> mempty+ in B9ConfigOverride+ { _customB9ConfigPath = Path <$> cfg,+ _customB9Config = b9cfg,+ _customEnvironment = mempty+ } cmds :: Parser (B9ConfigAction ()) cmds = subparser- (command "version" (info (pure runShowVersion) (progDesc "Show program version and exit.")) <>- command- "build"- (info- (void . runBuildArtifacts <$> buildFileParser)- (progDesc "Merge all build file and generate all artifacts.")) <>- command- "run"- (info- ((\x y -> void (runRun x y)) <$> sharedImageNameParser <*> many (strArgument idm))- (progDesc "Run a command on the lastest version of the specified shared image.")) <>- command- "push"- (info- (runPush <$> sharedImageNameParser)- (progDesc "Push the lastest shared image from cache to the selected remote repository.")) <>- command- "pull"- (info- (runPull <$> optional sharedImageNameParser)- (progDesc- "Either pull shared image meta data from all repositories, or only from just a selected one. If additionally the name of a shared images was specified, pull the newest version from either the selected repo, or from the repo with the most recent version.")) <>- command- "clean-local"- (info (pure runGcLocalRepoCache) (progDesc "Remove old versions of shared images from the local cache.")) <>- command- "clean-remote"- (info- (pure runGcRemoteRepoCache)- (progDesc- "Remove cached meta-data of a remote repository. If no '-r' is given, clean the meta data of ALL remote repositories.")) <>- command "list" (info (pure (void runListSharedImages)) (progDesc "List shared images.")) <>- command "add-repo" (info (runAddRepo <$> remoteRepoParser) (progDesc "Add a remote repo.")) <>- command "reformat" (info (runFormatBuildFiles <$> buildFileParser) (progDesc "Re-Format all build files.")))+ ( command "version" (info (pure runShowVersion) (progDesc "Show program version and exit."))+ <> command+ "build"+ ( info+ (void . runBuildArtifacts <$> buildFileParser)+ (progDesc "Merge all build file and generate all artifacts.")+ )+ <> command+ "run"+ ( info+ ((\x y -> void (runRun x y)) <$> sharedImageNameParser <*> many (strArgument idm))+ (progDesc "Run a command on the lastest version of the specified shared image.")+ )+ <> command+ "push"+ ( info+ (runPush <$> sharedImageNameParser)+ (progDesc "Push the lastest shared image from cache to the selected remote repository.")+ )+ <> command+ "pull"+ ( info+ (runPull <$> optional sharedImageNameParser)+ ( progDesc+ "Either pull shared image meta data from all repositories, or only from just a selected one. If additionally the name of a shared images was specified, pull the newest version from either the selected repo, or from the repo with the most recent version."+ )+ )+ <> command+ "clean-local"+ (info (pure runGcLocalRepoCache) (progDesc "Remove old versions of shared images from the local cache."))+ <> command+ "clean-remote"+ ( info+ (pure runGcRemoteRepoCache)+ ( progDesc+ "Remove cached meta-data of a remote repository. If no '-r' is given, clean the meta data of ALL remote repositories."+ )+ )+ <> command "list" (info (pure (void runListSharedImages)) (progDesc "List shared images."))+ <> command "add-repo" (info (runAddRepo <$> remoteRepoParser) (progDesc "Add a remote repo."))+ <> command "reformat" (info (runFormatBuildFiles <$> buildFileParser) (progDesc "Re-Format all build files."))+ ) buildFileParser :: Parser [FilePath] buildFileParser =- helper <*>- some- (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!")))+ 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 Environment buildVars = flip addPositionalArguments mempty <$> many (strArgument idm) remoteRepoParser :: Parser RemoteRepo remoteRepoParser =- helper <*>- (RemoteRepo <$> strArgument (help "The name of the remmote repository." <> metavar "NAME") <*>- strArgument (help "The (remote) repository root path." <> metavar "REMOTE_DIRECTORY") <*>- (SshPrivKey <$>- strArgument (help "Path to the SSH private key file used for authorization." <> metavar "SSH_PRIV_KEY_FILE")) <*>- (SshRemoteHost <$>- ((,) <$> strArgument (help "Repo hostname or IP" <> metavar "HOST") <*>- argument auto (help "SSH-Port number" <> value 22 <> showDefault <> metavar "PORT"))) <*>- (SshRemoteUser <$> strArgument (help "SSH-User to login" <> metavar "USER")))+ helper+ <*> ( RemoteRepo <$> strArgument (help "The name of the remmote repository." <> metavar "NAME")+ <*> strArgument (help "The (remote) repository root path." <> metavar "REMOTE_DIRECTORY")+ <*> ( SshPrivKey+ <$> strArgument (help "Path to the SSH private key file used for authorization." <> metavar "SSH_PRIV_KEY_FILE")+ )+ <*> ( SshRemoteHost+ <$> ( (,) <$> strArgument (help "Repo hostname or IP" <> metavar "HOST")+ <*> argument auto (help "SSH-Port number" <> value 22 <> showDefault <> metavar "PORT")+ )+ )+ <*> (SshRemoteUser <$> strArgument (help "SSH-User to login" <> metavar "USER"))+ ) sharedImageNameParser :: Parser SharedImageName sharedImageNameParser = helper <*> (SharedImageName <$> strArgument (help "Shared image name" <> metavar "NAME"))
src/lib/B9.hs view
@@ -1,109 +1,105 @@-{-| B9 is a library and build tool with which one can create/convert different types- of VM images. Additionally installation steps - like installing software -- can be done in a LXC container, running on the disk images.-- B9 allows 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.-- "B9.Artifact.Generator" is the module containing the basic data structure- used to describe a B9 build.---}+-- | B9 is a library and build tool with which one can create/convert different types+-- of VM images. Additionally installation steps - like installing software -+-- can be done in a LXC container, running on the disk images.+--+-- B9 allows 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.+--+-- "B9.Artifact.Generator" is the module containing the basic data structure+-- used to describe a B9 build. module B9- ( b9Version- , b9VersionString- , runShowVersion- , runBuildArtifacts- , runFormatBuildFiles- , runPush- , runPull- , runRun- , runGcLocalRepoCache- , runGcRemoteRepoCache- , runListSharedImages- , runAddRepo- , runLookupLocalSharedImage- , module X+ ( b9Version,+ b9VersionString,+ runShowVersion,+ runBuildArtifacts,+ runFormatBuildFiles,+ runPush,+ runPull,+ runRun,+ runGcLocalRepoCache,+ runGcRemoteRepoCache,+ runListSharedImages,+ runAddRepo,+ runLookupLocalSharedImage,+ module X, ) where -import B9.Artifact.Content as X-import B9.Artifact.Content.AST as X-import B9.Artifact.Content.CloudConfigYaml- as X-import B9.Artifact.Content.ErlangPropList- as X-import B9.Artifact.Content.ErlTerms as X-import B9.Artifact.Content.Readable as X-import B9.Artifact.Content.StringTemplate- as X-import B9.Artifact.Content.YamlObject- as X-import B9.Artifact.Readable as X-import B9.Artifact.Readable.Interpreter- as X-import B9.B9Config as X-import B9.B9Error as X-import B9.B9Exec as X-import B9.B9Logging as X-import B9.B9Monad as X-import B9.BuildInfo as X-import B9.DiskImageBuilder as X-import B9.DiskImages as X-import B9.Environment as X-import B9.ExecEnv as X-import B9.Text as X-import B9.QCUtil as X-import B9.Repository as X-import B9.RepositoryIO as X-import B9.ShellScript as X-import B9.Vm as X-import B9.VmBuilder as X-import Control.Applicative as X-import Control.Exception ( catch- , throwIO- )-import Control.Lens as X- ( Lens- , (%~)- , (&)- , (.~)- , (^.)- )-import Control.Monad as X-import Control.Monad.IO.Class as X-import Control.Monad.Reader as X- ( ReaderT- , ask- , local- )-import Data.Function ( on )-import Data.List as X-import Data.Maybe as X-import Data.Monoid as X-import Data.Version as X-import Paths_b9 ( version )-import System.Directory ( removeFile )-import System.Exit as X- ( ExitCode(..)- , exitWith- )-import System.FilePath as X- ( replaceExtension- , takeDirectory- , takeFileName- , (<.>)- , (</>)- )-import System.IO.B9Extras as X-import System.IO.Error ( isDoesNotExistError )-import Text.Printf as X- ( printf )-import Text.Show.Pretty as X- ( ppShow )+import B9.Artifact.Content as X+import B9.Artifact.Content.AST as X+import B9.Artifact.Content.CloudConfigYaml as X+import B9.Artifact.Content.ErlTerms as X+import B9.Artifact.Content.ErlangPropList as X+import B9.Artifact.Content.Readable as X+import B9.Artifact.Content.StringTemplate as X+import B9.Artifact.Content.YamlObject as X+import B9.Artifact.Readable as X+import B9.Artifact.Readable.Interpreter as X+import B9.B9Config as X+import B9.B9Error as X+import B9.B9Exec as X+import B9.B9Logging as X+import B9.B9Monad as X+import B9.BuildInfo as X+import B9.DiskImageBuilder as X+import B9.DiskImages as X+import B9.Environment as X+import B9.ExecEnv as X+import B9.QCUtil as X+import B9.Repository as X+import B9.RepositoryIO as X+import B9.ShellScript as X+import B9.Text as X+import B9.Vm as X+import B9.VmBuilder as X+import Control.Applicative as X+import Control.Exception+ ( catch,+ throwIO,+ )+import Control.Lens as X+ ( (%~),+ (&),+ (.~),+ Lens,+ (^.),+ )+import Control.Monad as X+import Control.Monad.IO.Class as X+import Control.Monad.Reader as X+ ( ReaderT,+ ask,+ local,+ )+import Data.Function (on)+import Data.List as X+import Data.Maybe as X+import Data.Monoid as X+import Data.Version as X+import Paths_b9 (version)+import System.Directory (removeFile)+import System.Exit as X+ ( ExitCode (..),+ exitWith,+ )+import System.FilePath as X+ ( (<.>),+ (</>),+ replaceExtension,+ takeDirectory,+ takeFileName,+ )+import System.IO.B9Extras as X+import System.IO.Error (isDoesNotExistError)+import Text.Printf as X+ ( printf,+ )+import Text.Show.Pretty as X+ ( ppShow,+ ) -- | Return the cabal package version of the B9 library. b9Version :: Version@@ -133,7 +129,7 @@ runFormatBuildFiles buildFiles = liftIO $ do generators <- mapM consult buildFiles let generatorsFormatted = map ppShow (generators :: [ArtifactGenerator])- putStrLn `mapM` generatorsFormatted+ putStrLn `mapM_` generatorsFormatted zipWithM_ writeFile buildFiles generatorsFormatted -- | Upload a 'SharedImageName' to the default remote repository.@@ -142,8 +138,9 @@ runPush name = localB9Config (keepTempDirs .~ False) $ runB9 $ do conf <- getConfig if isNothing (conf ^. repository)- then errorExitL- "No repository specified! Use '-r' to specify a repo BEFORE 'push'."+ then+ errorExitL+ "No repository specified! Use '-r' to specify a repo BEFORE 'push'." else pushSharedImageLatestVersion name -- | Either pull a list of available 'SharedImageName's from the remote@@ -151,110 +148,123 @@ -- of the image from the remote repository. Note: The remote repository is -- specified in the 'B9Config'. runPull :: Maybe SharedImageName -> B9ConfigAction ()-runPull mName = localB9Config (keepTempDirs .~ False)- (runB9 (pullRemoteRepos >> maybePullImage))- where- maybePullImage = mapM_- (\name -> pullLatestImage name >>= maybe (failPull name) (const (return ()))- )- mName- failPull name = errorExitL (printf "failed to pull: %s" (show name))+runPull mName =+ localB9Config+ (keepTempDirs .~ False)+ (runB9 (pullRemoteRepos >> maybePullImage))+ where+ maybePullImage =+ mapM_+ ( \name -> pullLatestImage name >>= maybe (failPull name) (const (return ()))+ )+ mName+ failPull name = errorExitL (printf "failed to pull: %s" (show name)) -- | Execute an interactive root shell in a running container from a -- 'SharedImageName'. runRun :: SharedImageName -> [String] -> B9ConfigAction String-runRun (SharedImageName name) cmdAndArgs = localB9Config- ((keepTempDirs .~ False) . (interactive .~ True))- (runB9 (buildArtifacts runCmdAndArgs))- where- runCmdAndArgs = Artifact- (IID ("run-" ++ name))- (VmImages- [ImageTarget Transient (From name KeepSize) (MountPoint "/")]- (VmScript X86_64+runRun (SharedImageName name) cmdAndArgs =+ localB9Config+ ((keepTempDirs .~ False) . (interactive .~ True))+ (runB9 (buildArtifacts runCmdAndArgs))+ where+ runCmdAndArgs =+ Artifact+ (IID ("run-" ++ name))+ ( VmImages+ [ImageTarget Transient (From name KeepSize) (MountPoint "/")]+ ( VmScript+ X86_64 [SharedDirectory "." (MountPoint "/mnt/CWD")] (Run (head cmdAndArgs') (tail cmdAndArgs'))- )- )- where- cmdAndArgs' = if null cmdAndArgs then ["/usr/bin/zsh"] else cmdAndArgs+ )+ )+ where+ cmdAndArgs' = if null cmdAndArgs then ["/usr/bin/zsh"] else cmdAndArgs -- | Delete all obsolete versions of all 'SharedImageName's. runGcLocalRepoCache :: B9ConfigAction () runGcLocalRepoCache = localB9Config (keepTempDirs .~ False) (runB9 impl)- where- impl = do- toDelete <- obsoleteSharedmages . map snd <$> lookupSharedImages- (== Cache)- (const True)- imgDir <- getSharedImagesCacheDir- let filesToDelete = (imgDir </>) <$> (infoFiles ++ imgFiles)- infoFiles = sharedImageFileName <$> toDelete- imgFiles = imageFileName . sharedImageImage <$> toDelete- if null filesToDelete- then liftIO $ putStrLn "\n\nNO IMAGES TO DELETE\n"- else liftIO $ do- putStrLn "DELETING FILES:"- putStrLn (unlines filesToDelete)- mapM_ removeIfExists filesToDelete- where- obsoleteSharedmages :: [SharedImage] -> [SharedImage]- obsoleteSharedmages =- concatMap (tail . reverse) . filter ((> 1) . length) . groupBy- ((==) `on` sharedImageName)- removeIfExists :: FilePath -> IO ()- removeIfExists fileName = removeFile fileName `catch` handleExists- where- handleExists e | isDoesNotExistError e = return ()- | otherwise = throwIO e+ where+ impl = do+ toDelete <-+ obsoleteSharedmages . map snd+ <$> lookupSharedImages+ (== Cache)+ (const True)+ imgDir <- getSharedImagesCacheDir+ let filesToDelete = (imgDir </>) <$> (infoFiles ++ imgFiles)+ infoFiles = sharedImageFileName <$> toDelete+ imgFiles = imageFileName . sharedImageImage <$> toDelete+ if null filesToDelete+ then liftIO $ putStrLn "\n\nNO IMAGES TO DELETE\n"+ else liftIO $ do+ putStrLn "DELETING FILES:"+ putStrLn (unlines filesToDelete)+ mapM_ removeIfExists filesToDelete+ where+ obsoleteSharedmages :: [SharedImage] -> [SharedImage]+ obsoleteSharedmages =+ concatMap (tail . reverse) . filter ((> 1) . length)+ . groupBy+ ((==) `on` sharedImageName)+ removeIfExists :: FilePath -> IO ()+ removeIfExists fileName = removeFile fileName `catch` handleExists+ where+ handleExists e+ | isDoesNotExistError e = return ()+ | otherwise = throwIO e -- | Clear the shared image cache for a remote. Note: The remote repository is -- specified in the 'B9Config'. runGcRemoteRepoCache :: B9ConfigAction ()-runGcRemoteRepoCache = localB9Config- (keepTempDirs .~ False)- (runB9- (do- repos <- getSelectedRepos- cache <- getRepoCache- mapM_ (cleanRemoteRepo cache) repos+runGcRemoteRepoCache =+ localB9Config+ (keepTempDirs .~ False)+ ( runB9+ ( do+ repos <- getSelectedRepos+ cache <- getRepoCache+ mapM_ (cleanRemoteRepo cache) repos+ ) )- ) -- | Print a list of shared images cached locally or remotely, if a remote -- repository was selected. Note: The remote repository is -- specified in the 'B9Config'. runListSharedImages :: B9ConfigAction [SharedImage]-runListSharedImages = localB9Config- (keepTempDirs .~ False)- (runB9- (do- MkSelectedRemoteRepo remoteRepo <- getSelectedRemoteRepo-- let repoPred = maybe (== Cache) ((==) . toRemoteRepository) remoteRepo- allRepos <- getRemoteRepos- if isNothing remoteRepo- then liftIO $ do- putStrLn "Showing local shared images only.\n"- putStrLn "To view the contents of a remote repo add"- putStrLn "the '-r' switch with one of the remote"- putStrLn "repository ids."- else liftIO $ putStrLn- ( "Showing shared images on: "- ++ remoteRepoRepoId (fromJust remoteRepo)- )- unless (null allRepos) $ liftIO $ do- putStrLn "\nAvailable remote repositories:"- mapM_ (putStrLn . (" * " ++) . remoteRepoRepoId) allRepos- imgs <- lookupSharedImages repoPred (const True)- if null imgs- then liftIO $ putStrLn "\n\nNO SHARED IMAGES\n"- else liftIO $ do- putStrLn ""- putStrLn $ prettyPrintSharedImages $ map snd imgs- return (map snd imgs)+runListSharedImages =+ localB9Config+ (keepTempDirs .~ False)+ ( runB9+ ( do+ MkSelectedRemoteRepo remoteRepo <- getSelectedRemoteRepo+ let repoPred = maybe (== Cache) ((==) . toRemoteRepository) remoteRepo+ allRepos <- getRemoteRepos+ if isNothing remoteRepo+ then liftIO $ do+ putStrLn "Showing local shared images only.\n"+ putStrLn "To view the contents of a remote repo add"+ putStrLn "the '-r' switch with one of the remote"+ putStrLn "repository ids."+ else+ liftIO $+ putStrLn+ ( "Showing shared images on: "+ ++ remoteRepoRepoId (fromJust remoteRepo)+ )+ unless (null allRepos) $ liftIO $ do+ putStrLn "\nAvailable remote repositories:"+ mapM_ (putStrLn . (" * " ++) . remoteRepoRepoId) allRepos+ imgs <- lookupSharedImages repoPred (const True)+ if null imgs+ then liftIO $ putStrLn "\n\nNO SHARED IMAGES\n"+ else liftIO $ do+ putStrLn ""+ putStrLn $ prettyPrintSharedImages $ map snd imgs+ return (map snd imgs)+ ) )- ) -- | Check the SSH settings for a remote repository and add it to the user wide -- B9 configuration file.@@ -262,17 +272,17 @@ runAddRepo repo = do repo' <- remoteRepoCheckSshPrivKey repo modifyPermanentConfig- (Endo- ( remoteRepos- %~ ( mappend [repo']- . filter ((== remoteRepoRepoId repo') . remoteRepoRepoId)- )- )+ ( Endo+ ( remoteRepos+ %~ ( mappend [repo']+ . filter ((== remoteRepoRepoId repo') . remoteRepoRepoId)+ )+ ) ) -- | Find the most recent version of a 'SharedImageName' in the local image cache.-runLookupLocalSharedImage- :: SharedImageName -> B9ConfigAction (Maybe SharedImageBuildId)+runLookupLocalSharedImage ::+ SharedImageName -> B9ConfigAction (Maybe SharedImageBuildId) runLookupLocalSharedImage n = runB9 $ do traceL (printf "Searching for cached image: %s" (show n)) imgs <- lookupSharedImages isAvailableOnLocalHost hasTheDesiredName@@ -281,9 +291,10 @@ let res = extractNewestImageFromResults imgs traceL (printf "Returning result: %s" (show res)) return res- where- extractNewestImageFromResults =- listToMaybe . map toBuildId . take 1 . reverse . map snd- where toBuildId (SharedImage _ _ i _ _) = i- isAvailableOnLocalHost = (Cache ==)- hasTheDesiredName (SharedImage n' _ _ _ _) = n == n'+ where+ extractNewestImageFromResults =+ listToMaybe . map toBuildId . take 1 . reverse . map snd+ where+ toBuildId (SharedImage _ _ i _ _) = i+ isAvailableOnLocalHost = (Cache ==)+ hasTheDesiredName (SharedImage n' _ _ _ _) = n == n'
src/lib/B9/Artifact.hs view
@@ -5,8 +5,10 @@ -- TODO: do it. -- -- @since 1.0.0-module B9.Artifact () where-+module B9.Artifact+ (+ )+where ---- | Build Environment --disks = let@@ -21,5 +23,3 @@ -- unZipped (remoteBinary foo) -- fileAttributes (\_f -> UnixFilePermissions 0 7 5 5 "root" "root") ----
src/lib/B9/Artifact/Content.hs view
@@ -5,16 +5,16 @@ -- -- @since 0.5.62 module B9.Artifact.Content- ( ContentGenerator- , ToContentGenerator(..)- , Text+ ( ContentGenerator,+ ToContentGenerator (..),+ Text, ) where -import B9.B9Monad-import Control.Eff-import Data.Text ( Text )-import GHC.Stack+import B9.B9Monad+import Control.Eff+import Data.Text (Text)+import GHC.Stack -- | A 'B9' action that procuces a 'Text'. --@@ -26,4 +26,4 @@ -- -- @since 0.5.62 class ToContentGenerator c where- toContentGenerator :: (HasCallStack, IsB9 e) => c -> Eff e Text+ toContentGenerator :: (HasCallStack, IsB9 e) => c -> Eff e Text
src/lib/B9/Artifact/Content/AST.hs view
@@ -1,45 +1,42 @@-{-|--B9 produces not only VM-Images but also text documents such as configuration-files required by virtual machines. This module is about creating and merging-files containing parsable syntactic structures, such as most configuration files-do.--B9 can be used to create configuration files by assembling structured documents,-for example Yaml, JSON, Erlang Terms.--One example is creating a single cloud-init 'user-data' file from a set of-'user-data' snippets - all of which using yaml syntax to declare the same-object (e.g @"user-data"@).--The goal is, that b9 is able to merge these snippets into one, intelligently-merging fields as one would expect, e.g. when merging multiple snippets with-@writefiles@ fields, the output object's @writefiles@ field contains all the-@write_file@ objects.--Another example is the OTP/Erlang sys.config for configuring OTP/Erlang releases.--}-+-- |+--+-- B9 produces not only VM-Images but also text documents such as configuration+-- files required by virtual machines. This module is about creating and merging+-- files containing parsable syntactic structures, such as most configuration files+-- do.+--+-- B9 can be used to create configuration files by assembling structured documents,+-- for example Yaml, JSON, Erlang Terms.+--+-- One example is creating a single cloud-init 'user-data' file from a set of+-- 'user-data' snippets - all of which using yaml syntax to declare the same+-- object (e.g @"user-data"@).+--+-- The goal is, that b9 is able to merge these snippets into one, intelligently+-- merging fields as one would expect, e.g. when merging multiple snippets with+-- @writefiles@ fields, the output object's @writefiles@ field contains all the+-- @write_file@ objects.+--+-- Another example is the OTP/Erlang sys.config for configuring OTP/Erlang releases. module B9.Artifact.Content.AST- ( FromAST(..)- , AST(..)- , parseFromTextWithErrorMessage+ ( FromAST (..),+ AST (..),+ parseFromTextWithErrorMessage, ) where -import Control.Eff-import Control.Parallel.Strategies-import Data.Binary ( Binary )-import Data.Data-import Data.Hashable-import GHC.Generics ( Generic )-import Test.QuickCheck-import B9.B9Monad-import B9.Artifact.Content.StringTemplate-import B9.Artifact.Content-import B9.QCUtil-import B9.Text-+import B9.Artifact.Content+import B9.Artifact.Content.StringTemplate+import B9.B9Monad+import B9.QCUtil+import B9.Text+import Control.Eff+import Control.Parallel.Strategies+import Data.Binary (Binary)+import Data.Data+import Data.Hashable+import GHC.Generics (Generic)+import Test.QuickCheck -- | Describe how to create structured content that has a tree-like syntactic -- structure, e.g. yaml, JSON and erlang-proplists. The first parameter defines@@ -47,52 +44,57 @@ -- e.g. B9.Artifact.Content'. The second parameter defines a specifix -- syntax, e.g 'B9.Artifact.Content.ErlangPropList' that the 'AST' value generates. data AST c a- = ASTObj [(String, AST c a)] -- ^ Create an object similar to a- -- Json object.- | ASTArr [AST c a] -- ^ An array.- | ASTMerge [AST c a] -- ^ Merge the nested elements, this is a very- -- powerful tool that allows to combine- |- -- several inputs in a smart and safe way,- -- e.g. by merging the values of the same- -- fields in yaml objects.- ASTEmbed c -- Embed more impure content.- | ASTString String -- A string literal.- | ASTInt Int -- An Int literal.- | ASTParse SourceFile -- An 'AST' obtained from parsing a source- -- file that contains a string corresponding- |- -- to the type parameter @a@, e.g. 'YamlObject's- AST a -- Embed a literal @a@.- deriving (Read,Show,Typeable,Data,Eq,Generic)+ = -- | Create an object similar to a+ -- Json object.+ ASTObj [(String, AST c a)]+ | -- | An array.+ ASTArr [AST c a]+ | -- | Merge the nested elements, this is a very+ -- powerful tool that allows to combine+ ASTMerge [AST c a]+ | -- several inputs in a smart and safe way,+ -- e.g. by merging the values of the same+ -- fields in yaml objects.+ ASTEmbed c -- Embed more impure content.+ | ASTString String -- A string literal.+ | ASTInt Int -- An Int literal.+ | ASTParse SourceFile -- An 'AST' obtained from parsing a source+ -- file that contains a string corresponding+ -- to the type parameter @a@, e.g. 'YamlObject's+ | AST a -- Embed a literal @a@.+ deriving (Read, Show, Typeable, Data, Eq, Generic) instance Functor (AST c) where- fmap f (AST a) = AST (f a)- fmap f (ASTObj x) = ASTObj ((fmap . fmap . fmap) f x)- fmap f (ASTArr x) = ASTArr ((fmap . fmap) f x)- fmap f (ASTMerge x) = ASTMerge ((fmap . fmap) f x)- fmap _ (ASTEmbed x) = ASTEmbed x+ fmap f (AST a) = AST (f a)+ fmap f (ASTObj x) = ASTObj ((fmap . fmap . fmap) f x)+ fmap f (ASTArr x) = ASTArr ((fmap . fmap) f x)+ fmap f (ASTMerge x) = ASTMerge ((fmap . fmap) f x)+ fmap _ (ASTEmbed x) = ASTEmbed x fmap _ (ASTString x) = ASTString x- fmap _ (ASTInt x) = ASTInt x- fmap _ (ASTParse x) = ASTParse x+ fmap _ (ASTInt x) = ASTInt x+ fmap _ (ASTParse x) = ASTParse x instance (Hashable c, Hashable a) => Hashable (AST c a)+ instance (Binary c, Binary a) => Binary (AST c a)+ instance (NFData c, NFData a) => NFData (AST c a) -- | Types of values that describe content, that can be created from an 'AST'.-class FromAST a where- fromAST- :: (IsB9 e, ToContentGenerator c)- => AST c a -> Eff e a+class FromAST a where+ fromAST ::+ (IsB9 e, ToContentGenerator c) =>+ AST c a ->+ Eff e a instance (Arbitrary c, Arbitrary a) => Arbitrary (AST c a) where- arbitrary = oneof- [ ASTObj <$> smaller (listOf ((,) <$> arbitrary <*> arbitrary))- , ASTArr <$> smaller (listOf arbitrary)- , ASTMerge <$> sized (\s -> resize (max 2 s) (listOf (halfSize arbitrary)))- , ASTEmbed <$> smaller arbitrary- , ASTString <$> arbitrary- , ASTParse <$> smaller arbitrary- , AST <$> smaller arbitrary- ]+ arbitrary =+ oneof+ [ ASTObj <$> smaller (listOf ((,) <$> arbitrary <*> arbitrary)),+ ASTArr <$> smaller (listOf arbitrary),+ ASTMerge <$> sized (\s -> resize (max 2 s) (listOf (halfSize arbitrary))),+ ASTEmbed <$> smaller arbitrary,+ ASTString <$> arbitrary,+ ASTParse <$> smaller arbitrary,+ AST <$> smaller arbitrary+ ]
src/lib/B9/Artifact/Content/CloudConfigYaml.hs view
@@ -1,43 +1,45 @@ {-# LANGUAGE OverloadedStrings #-} -{-| This contains a 'YamlObject' for Canonicals @cloud-init@.--For some reason, cloud-config yaml documents __MUST__-contain @#cloud-config@ in the first line.--This is documented in the <https://cloudinit.readthedocs.io/en/latest/topics/format.html#cloud-config-data cloud config documentation>.--Otherwise, this is just a wrapper around 'YamlObject'.--@Since 0.5.62--}+-- | This contains a 'YamlObject' for Canonicals @cloud-init@.+--+-- For some reason, cloud-config yaml documents __MUST__+-- contain @#cloud-config@ in the first line.+--+-- This is documented in the <https://cloudinit.readthedocs.io/en/latest/topics/format.html#cloud-config-data cloud config documentation>.+--+-- Otherwise, this is just a wrapper around 'YamlObject'.+--+-- @Since 0.5.62 module B9.Artifact.Content.CloudConfigYaml- ( CloudConfigYaml(..)- , cloudConfigFileHeader+ ( CloudConfigYaml (..),+ cloudConfigFileHeader, ) where -import B9.Artifact.Content.AST-import B9.Artifact.Content.YamlObject-import B9.Text-import Control.Parallel.Strategies ( NFData )-import Data.Data ( Data- , Typeable- )-import Data.Text as Text-import Data.Hashable ( Hashable )-import GHC.Generics ( Generic )-import Test.QuickCheck ( Arbitrary )+import B9.Artifact.Content.AST+import B9.Artifact.Content.YamlObject+import B9.Text+import Control.Parallel.Strategies (NFData)+import Data.Data+ ( Data,+ Typeable,+ )+import Data.Hashable (Hashable)+import Data.Text as Text+import GHC.Generics (Generic)+import Test.QuickCheck (Arbitrary) -- | Cloud-init @meta-data@ configuration Yaml. -- -- @cloud-config@ yaml documents contain:- -- @#cloud-config@ as first line.+-- @#cloud-config@ as first line. -- -- @Since 0.5.62-newtype CloudConfigYaml = MkCloudConfigYaml- { fromCloudConfigYaml :: YamlObject- } deriving (Hashable, NFData, Eq, Data, Typeable, Generic, Arbitrary, Read, Show, Semigroup)+newtype CloudConfigYaml+ = MkCloudConfigYaml+ { fromCloudConfigYaml :: YamlObject+ }+ deriving (Hashable, NFData, Eq, Data, Typeable, Generic, Arbitrary, Read, Show, Semigroup) -- | The header line, which must be the first line in the -- text file containing the cloud-config Yaml document.@@ -51,11 +53,12 @@ instance Textual CloudConfigYaml where parseFromText txt = do--- skip the optional header line+ -- skip the optional header line let header = Text.take (Text.length cloudConfigFileHeader) txt- txt' = if header == cloudConfigFileHeader- then Text.drop (Text.length cloudConfigFileHeader) txt- else txt+ txt' =+ if header == cloudConfigFileHeader+ then Text.drop (Text.length cloudConfigFileHeader) txt+ else txt y <- parseFromText txt' return (MkCloudConfigYaml y)
src/lib/B9/Artifact/Content/ErlTerms.hs view
@@ -1,69 +1,70 @@-{-| Erlang term parser and pretty printer. -}+-- | Erlang term parser and pretty printer. module B9.Artifact.Content.ErlTerms- ( parseErlTerm- , erlTermParser- , renderErlTerm- , SimpleErlangTerm(..)- , arbitraryErlSimpleAtom- , arbitraryErlString- , arbitraryErlNumber- , arbitraryErlNatural- , arbitraryErlFloat- , arbitraryErlNameChar+ ( parseErlTerm,+ erlTermParser,+ renderErlTerm,+ SimpleErlangTerm (..),+ arbitraryErlSimpleAtom,+ arbitraryErlString,+ arbitraryErlNumber,+ arbitraryErlNatural,+ arbitraryErlFloat,+ arbitraryErlNameChar, ) where -import Control.Parallel.Strategies-import Data.Binary-import Data.Data-import Data.Function-import Data.Hashable-import GHC.Generics ( Generic )-import Test.QuickCheck-import Text.Parsec ( (<|>)- , many- , spaces- , char- , option- , between- , string- , choice- , octDigit- , hexDigit- , many1- , noneOf- , try- , digit- , anyChar- , alphaNum- , lower- , parse- )-import Text.Parsec.Text-import Text.Show.Pretty-import Control.Monad-import Text.Printf-import qualified Text.PrettyPrint as PP--import B9.QCUtil-import B9.Text+import B9.QCUtil+import B9.Text+import Control.Monad+import Control.Parallel.Strategies+import Data.Binary+import Data.Data+import Data.Function+import Data.Hashable+import GHC.Generics (Generic)+import Test.QuickCheck+import Text.Parsec+ ( (<|>),+ alphaNum,+ anyChar,+ between,+ char,+ choice,+ digit,+ hexDigit,+ lower,+ many,+ many1,+ noneOf,+ octDigit,+ option,+ parse,+ spaces,+ string,+ try,+ )+import Text.Parsec.Text+import qualified Text.PrettyPrint as PP+import Text.Printf+import Text.Show.Pretty -- | Simplified Erlang term representation. data SimpleErlangTerm- = ErlString String- | ErlFloat Double- | ErlNatural Integer- | ErlAtom String- | ErlChar Char- | ErlBinary String- | ErlList [SimpleErlangTerm]- | ErlTuple [SimpleErlangTerm]- deriving (Eq,Ord,Read,Show,Data,Typeable,Generic)+ = ErlString String+ | ErlFloat Double+ | ErlNatural Integer+ | ErlAtom String+ | ErlChar Char+ | ErlBinary String+ | ErlList [SimpleErlangTerm]+ | ErlTuple [SimpleErlangTerm]+ deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) instance Hashable SimpleErlangTerm+ instance Binary SimpleErlangTerm-instance NFData SimpleErlangTerm +instance NFData SimpleErlangTerm -- | Parse a subset of valid Erlang terms. It parses no maps and binaries are -- restricted to either empty binaries or binaries with a string. The input@@ -83,21 +84,20 @@ prettyPrintErlTerm (ErlString str) = PP.doubleQuotes (PP.text (toErlStringString str)) prettyPrintErlTerm (ErlNatural n) = PP.integer n-prettyPrintErlTerm (ErlFloat f) = PP.double f-prettyPrintErlTerm (ErlChar c) = PP.text ("$" ++ toErlAtomChar c)-prettyPrintErlTerm (ErlAtom a) = PP.text quotedAtom- where- quotedAtom = case toErlAtomString a of- "" -> "''"- a'@(firstChar : rest)- | firstChar- `elem` ['a' .. 'z']- && all (`elem` atomCharsThatDontNeedQuoting) rest- -> a'- a' -> "'" ++ a' ++ "'"- atomCharsThatDontNeedQuoting =- ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] ++ "@_"-+prettyPrintErlTerm (ErlFloat f) = PP.double f+prettyPrintErlTerm (ErlChar c) = PP.text ("$" ++ toErlAtomChar c)+prettyPrintErlTerm (ErlAtom a) = PP.text quotedAtom+ where+ quotedAtom = case toErlAtomString a of+ "" -> "''"+ a'@(firstChar : rest)+ | firstChar+ `elem` ['a' .. 'z']+ && all (`elem` atomCharsThatDontNeedQuoting) rest ->+ a'+ a' -> "'" ++ a' ++ "'"+ atomCharsThatDontNeedQuoting =+ ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] ++ "@_" prettyPrintErlTerm (ErlBinary []) = PP.text "<<>>" prettyPrintErlTerm (ErlBinary b) = PP.text ("<<\"" ++ toErlStringString b ++ "\">>")@@ -111,93 +111,93 @@ 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) ..] ]+ 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) ..] ]-+ where+ table =+ [printf "\\x{%x}" c | c <- [0 .. (31 :: Int)]]+ ++ (pure . toEnum <$> [32 .. 38])+ ++ ["\\'"]+ ++ (pure . toEnum <$> [40 .. 91])+ ++ ["\\\\"]+ ++ (pure . toEnum <$> [93 .. 126])+ ++ [printf "\\x{%x}" c | c <- [(127 :: Int) ..]] instance Arbitrary SimpleErlangTerm where- arbitrary = oneof- [ sized aErlString- , sized aErlNatural- , sized aErlFloat- , sized aErlChar- , sized aErlAtomUnquoted- , sized aErlAtomQuoted- , sized aErlBinary- , sized aErlList- , sized aErlTuple- ]- where- decrSize 0 = resize 0- decrSize n = resize (n - 1)- aErlString n =- ErlString <$> decrSize n (listOf (choose (toEnum 0, toEnum 255)))- aErlFloat n = do- f <- decrSize n arbitrary :: Gen Float- let d = fromRational (toRational f)- return (ErlFloat d)- aErlNatural n = ErlNatural <$> decrSize n arbitrary- aErlChar n = ErlChar <$> decrSize n (choose (toEnum 0, toEnum 255))- aErlAtomUnquoted n = do- f <- choose ('a', 'z')- rest <- decrSize n aErlNameString- return (ErlAtom (f : rest))- aErlAtomQuoted n = do- cs <- decrSize n aParsableErlString- return (ErlAtom ("'" ++ cs ++ "'"))- aErlBinary n =- ErlBinary <$> decrSize n (listOf (choose (toEnum 0, toEnum 255)))- aParsableErlString = oneof- [ aErlNameString- , aErlEscapedCharString- , aErlControlCharString- , aErlOctalCharString- , aErlHexCharString+ arbitrary =+ oneof+ [ sized aErlString,+ sized aErlNatural,+ sized aErlFloat,+ sized aErlChar,+ sized aErlAtomUnquoted,+ sized aErlAtomQuoted,+ sized aErlBinary,+ sized aErlList,+ sized aErlTuple ]- 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)-+ where+ decrSize 0 = resize 0+ decrSize n = resize (n - 1)+ aErlString n =+ ErlString <$> decrSize n (listOf (choose (toEnum 0, toEnum 255)))+ aErlFloat n = do+ f <- decrSize n arbitrary :: Gen Float+ let d = fromRational (toRational f)+ return (ErlFloat d)+ aErlNatural n = ErlNatural <$> decrSize n arbitrary+ aErlChar n = ErlChar <$> decrSize n (choose (toEnum 0, toEnum 255))+ aErlAtomUnquoted n = do+ f <- choose ('a', 'z')+ rest <- decrSize n aErlNameString+ return (ErlAtom (f : rest))+ aErlAtomQuoted n = do+ cs <- decrSize n aParsableErlString+ return (ErlAtom ("'" ++ cs ++ "'"))+ aErlBinary n =+ ErlBinary <$> decrSize n (listOf (choose (toEnum 0, toEnum 255)))+ aParsableErlString =+ oneof+ [ aErlNameString,+ aErlEscapedCharString,+ aErlControlCharString,+ aErlOctalCharString,+ aErlHexCharString+ ]+ aErlNameString =+ listOf (elements (['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] ++ "@_"))+ aErlEscapedCharString = elements (("\\" ++) . pure <$> "0bdefnrstv\\\"\'")+ aErlControlCharString =+ elements (("\\^" ++) . pure <$> (['a' .. 'z'] ++ ['A' .. 'Z']))+ aErlOctalCharString = do+ n <- choose (1, 3)+ os <- vectorOf n (choose (0, 7))+ return (join ("\\" : (show <$> (os :: [Int]))))+ aErlHexCharString = oneof [twoDigitHex, nDigitHex]+ where+ twoDigitHex = do+ d1 <- choose (0, 15) :: Gen Int+ d2 <- choose (0, 15) :: Gen Int+ return (printf "\\x%x%X" d1 d2)+ nDigitHex = do+ zs <- listOf (elements "0")+ v <- choose (0, 255) :: Gen Int+ return (printf "\\x{%s%x}" zs v)+ aErlList n = ErlList <$> resize (n `div` 2) (listOf arbitrary)+ aErlTuple n = ErlTuple <$> resize (n `div` 2) (listOf arbitrary) erlTermParser :: Parser SimpleErlangTerm erlTermParser = between spaces (char '.') erlExpressionParser@@ -216,8 +216,8 @@ erlAtomParser :: Parser SimpleErlangTerm erlAtomParser = ErlAtom- <$> (between (char '\'') (char '\'') (many (erlCharEscaped <|> noneOf "'"))- <|> ((:) <$> lower <*> many erlNameChar)+ <$> ( between (char '\'') (char '\'') (many (erlCharEscaped <|> noneOf "'"))+ <|> ((:) <$> lower <*> many erlNameChar) ) erlNameChar :: Parser Char@@ -232,108 +232,111 @@ -- point value. Calculating by hand is complicated because of precision -- issues. sign <- option "" ((char '-' >> return "-") <|> (char '+' >> return ""))- s1 <- many digit- char '.'+ s1 <- many digit+ _ <- char '.' s2 <- many1 digit- e <-+ e <- do- expSym <- choice [char 'e', char 'E']- expSign <- option+ expSym <- choice [char 'e', char 'E']+ expSign <-+ option "" ((char '-' >> return "-") <|> (char '+' >> return "+"))- expAbs <- many1 digit- return ([expSym] ++ expSign ++ expAbs)+ expAbs <- many1 digit+ return ([expSym] ++ expSign ++ expAbs) <|> return "" return (ErlFloat (read (sign ++ s1 ++ "." ++ s2 ++ e))) erlNaturalParser :: Parser SimpleErlangTerm erlNaturalParser = do sign <- signParser- dec <- decimalLiteral+ 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 ..]+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 '"'+ _ <- char '"' str <- many (erlCharEscaped <|> noneOf "\"")- char '"'+ _ <- char '"' return (ErlString str) erlCharEscaped :: Parser Char erlCharEscaped = char '\\'- >> ( do- char '^'+ >> ( do+ _ <- char '^' choice (zipWith escapedChar ccodes creplacements)-- <|> do- char 'x'+ <|> 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)+ 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+ 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))+ 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)+ <|> choice (zipWith escapedChar codes replacements) )- where- escapedChar code replacement = char code >> return replacement- codes = "0bdefnrstv\\\"'"- replacements = "\NUL\b\DEL\ESC\f\n\r \t\v\\\"'"- ccodes = ['a' .. 'z'] ++ ['A' .. 'Z']- creplacements = cycle ['\^A' .. '\^Z']- hexVal v | v `elem` ['a' .. 'z'] = 0xA + (fromEnum v - fromEnum 'a')- | v `elem` ['A' .. 'Z'] = 0xA + (fromEnum v - fromEnum 'A')- | otherwise = fromEnum v - fromEnum '0'- octVal = hexVal+ where+ escapedChar code replacement = char code >> return replacement+ codes = "0bdefnrstv\\\"'"+ replacements = "\NUL\b\DEL\ESC\f\n\r \t\v\\\"'"+ ccodes = ['a' .. 'z'] ++ ['A' .. 'Z']+ creplacements = cycle ['\^A' .. '\^Z']+ hexVal v+ | v `elem` ['a' .. 'z'] = 0xA + (fromEnum v - fromEnum 'a')+ | v `elem` ['A' .. 'Z'] = 0xA + (fromEnum v - fromEnum 'A')+ | otherwise = fromEnum v - fromEnum '0'+ octVal = hexVal erlBinaryParser :: Parser SimpleErlangTerm erlBinaryParser = do- string "<<"+ _ <- string "<<" spaces ErlString str <- option (ErlString "") erlStringParser- string ">>"+ _ <- string ">>" spaces return (ErlBinary str) @@ -350,10 +353,10 @@ commaSep :: Parser a -> Parser [a] commaSep p = do- r <- p- spaces- rest <- option [] (char ',' >> spaces >> commaSep p)- return (r : rest)+ r <- p+ spaces+ rest <- option [] (char ',' >> spaces >> commaSep p)+ return (r : rest) <|> return [] arbitraryErlSimpleAtom :: Gen SimpleErlangTerm
src/lib/B9/Artifact/Content/ErlangPropList.hs view
@@ -1,34 +1,31 @@-{-| Allow reading, merging and writing Erlang terms. -}+-- | Allow reading, merging and writing Erlang terms. module B9.Artifact.Content.ErlangPropList- ( ErlangPropList(..)- , textToErlangAst- , stringToErlangAst- ) where+ ( ErlangPropList (..),+ textToErlangAst,+ stringToErlangAst,+ )+where +import B9.Artifact.Content+import B9.Artifact.Content.AST+import B9.Artifact.Content.ErlTerms+import B9.Artifact.Content.StringTemplate+import B9.Text import Control.Parallel.Strategies import Data.Data import Data.Function import Data.Hashable import Data.List (partition, sortBy)-#if !MIN_VERSION_base(4,11,0)-import Data.Semigroup-#endif import qualified Data.Text as T import GHC.Generics (Generic)-import Text.Printf--import B9.Artifact.Content.AST-import B9.Artifact.Content.ErlTerms-import B9.Artifact.Content-import B9.Artifact.Content.StringTemplate-import B9.Text import Test.QuickCheck+import Text.Printf -- | A wrapper type around erlang terms with a Semigroup instance useful for -- combining sys.config files with OTP-application configurations in a list of -- the form of a proplist.-newtype ErlangPropList =- ErlangPropList SimpleErlangTerm+newtype ErlangPropList+ = ErlangPropList SimpleErlangTerm deriving (Read, Eq, Show, Data, Typeable, Generic) instance Hashable ErlangPropList@@ -55,7 +52,7 @@ 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)+ 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)@@ -64,7 +61,7 @@ sortByKey = sortBy (compare `on` getKey) keyLessThan = (<) `on` getKey equalKey = (==) `on` getKey- getKey (ErlTuple (x:_)) = x+ getKey (ErlTuple (x : _)) = x getKey x = x isPair (ErlTuple [_, _]) = True isPair _ = False@@ -87,12 +84,13 @@ (ErlangPropList second) <- fromAST ast return $ ErlTuple [ErlAtom k, second] fromAST (ASTArr xs) =- ErlangPropList . ErlList <$>- mapM- (\x -> do- (ErlangPropList x') <- fromAST x- return x')- xs+ ErlangPropList . ErlList+ <$> mapM+ ( \x -> do+ (ErlangPropList x') <- fromAST x+ return x'+ )+ xs fromAST (ASTString s) = pure $ ErlangPropList $ ErlString s fromAST (ASTInt i) = pure $ ErlangPropList $ ErlString (show i) fromAST (ASTEmbed c) = ErlangPropList . ErlString . T.unpack <$> toContentGenerator c@@ -104,21 +102,22 @@ Right s -> return s Left e -> error (printf "could not parse erlang source file: '%s'\n%s\n" srcPath e) - -- * Misc. utilities -- | Parse a text containing an @Erlang@ expression ending with a @.@ and Return -- an 'AST'. -- -- @since 0.5.67-textToErlangAst :: Text -> AST c ErlangPropList-textToErlangAst txt = either (error . ((unsafeParseFromText txt ++ "\n: ") ++))- AST- (parseFromTextWithErrorMessage "textToErlangAst" txt)+textToErlangAst :: Text -> AST c ErlangPropList+textToErlangAst txt =+ either+ (error . ((unsafeParseFromText txt ++ "\n: ") ++))+ AST+ (parseFromTextWithErrorMessage "textToErlangAst" txt) -- | Parse a string containing an @Erlang@ expression ending with a @.@ and Return -- an 'AST'. -- -- @since 0.5.67-stringToErlangAst :: String -> AST c ErlangPropList+stringToErlangAst :: String -> AST c ErlangPropList stringToErlangAst = textToErlangAst . unsafeRenderToText
src/lib/B9/Artifact/Content/Readable.hs view
@@ -1,66 +1,65 @@-{-| Content defined in text files (.b9 files), read with the 'Read' instances.---}+-- | Content defined in text files (.b9 files), read with the 'Read' instances. module B9.Artifact.Content.Readable where -import Control.Parallel.Strategies-import B9.Artifact.Content-import B9.Artifact.Content.AST-import B9.Artifact.Content.CloudConfigYaml-import B9.Artifact.Content.ErlangPropList-import B9.Artifact.Content.StringTemplate-import B9.Artifact.Content.YamlObject-import B9.B9Logging-import B9.QCUtil-import B9.Text-import Control.Monad.IO.Class-import qualified Data.ByteString as Strict-import qualified Data.ByteString.Lazy as Lazy-import qualified Data.ByteString.Base64 as B64-import Data.Data-import GHC.Generics ( Generic )-import System.Exit-import System.Process-import Test.QuickCheck-import GHC.Stack+import B9.Artifact.Content+import B9.Artifact.Content.AST+import B9.Artifact.Content.CloudConfigYaml+import B9.Artifact.Content.ErlangPropList+import B9.Artifact.Content.StringTemplate+import B9.Artifact.Content.YamlObject+import B9.B9Logging+import B9.QCUtil+import B9.Text+import Control.Monad.IO.Class+import Control.Parallel.Strategies+import qualified Data.ByteString as Strict+import qualified Data.ByteString.Base64 as B64+import qualified Data.ByteString.Lazy as Lazy+import Data.Data+import GHC.Generics (Generic)+import GHC.Stack+import System.Exit+import System.Process+import Test.QuickCheck -- | This is content that can be 'read' via the generated 'Read' instance. data Content = RenderErlang (AST Content ErlangPropList) | RenderYamlObject (AST Content YamlObject) | RenderCloudConfig (AST Content CloudConfigYaml)- -- | This data will be passed through unaltered.+ | -- | This data will be passed through unaltered. -- This is used during the transition phase from having B9 stuff read from -- files via 'Read' instances towards programatic use or the use of HOCON. -- -- @since 0.5.62- | FromByteString Lazy.ByteString- -- | Embed a literal string- | FromString String- -- | Embed the contents of the 'SourceFile' with template parameter substitution.- | FromTextFile SourceFile- -- | The data in the given file will be base64 encoded.- | RenderBase64BinaryFile FilePath- -- | This data will be base64 encoded.- | RenderBase64Binary Lazy.ByteString- -- | Download the contents of the URL- | FromURL String+ FromByteString Lazy.ByteString+ | -- | Embed a literal string+ FromString String+ | -- | Embed the contents of the 'SourceFile' with template parameter substitution.+ FromTextFile SourceFile+ | -- | The data in the given file will be base64 encoded.+ RenderBase64BinaryFile FilePath+ | -- | This data will be base64 encoded.+ RenderBase64Binary Lazy.ByteString+ | -- | Download the contents of the URL+ FromURL String deriving (Read, Show, Typeable, Eq, Data, Generic) instance NFData Content instance Arbitrary Content where- arbitrary = oneof- [ FromTextFile <$> smaller arbitrary- , RenderBase64BinaryFile <$> smaller arbitrary- , RenderErlang <$> smaller arbitrary- , RenderYamlObject <$> smaller arbitrary- , RenderCloudConfig <$> smaller arbitrary- , FromString <$> smaller arbitrary- , FromByteString . Lazy.pack <$> smaller arbitrary- , RenderBase64Binary . Lazy.pack <$> smaller arbitrary- , FromURL <$> smaller arbitrary- ]+ arbitrary =+ oneof+ [ FromTextFile <$> smaller arbitrary,+ RenderBase64BinaryFile <$> smaller arbitrary,+ RenderErlang <$> smaller arbitrary,+ RenderYamlObject <$> smaller arbitrary,+ RenderCloudConfig <$> smaller arbitrary,+ FromString <$> smaller arbitrary,+ FromByteString . Lazy.pack <$> smaller arbitrary,+ RenderBase64Binary . Lazy.pack <$> smaller arbitrary,+ FromURL <$> smaller arbitrary+ ] instance ToContentGenerator Content where toContentGenerator (RenderErlang ast) = unsafeRenderToText <$> fromAST ast@@ -68,12 +67,12 @@ unsafeRenderToText <$> fromAST ast toContentGenerator (RenderCloudConfig ast) = unsafeRenderToText <$> fromAST ast- toContentGenerator (FromTextFile s) = readTemplateFile s+ toContentGenerator (FromTextFile s) = readTemplateFile s toContentGenerator (RenderBase64BinaryFile s) = readBinaryFileAsBase64 s- where- readBinaryFileAsBase64 :: (HasCallStack, MonadIO m) => FilePath -> m Text- readBinaryFileAsBase64 f =- unsafeRenderToText . B64.encode <$> liftIO (Strict.readFile f)+ where+ readBinaryFileAsBase64 :: (HasCallStack, MonadIO m) => FilePath -> m Text+ readBinaryFileAsBase64 f =+ unsafeRenderToText . B64.encode <$> liftIO (Strict.readFile f) toContentGenerator (RenderBase64Binary b) = pure (unsafeRenderToText . B64.encode . Lazy.toStrict $ b) toContentGenerator (FromString str) = pure (unsafeRenderToText str)@@ -86,7 +85,7 @@ then do dbgL ("Download finished. Bytes read: " ++ show (length out)) traceL- ("Downloaded (truncated to first 4K): \n\n" ++ take 4096 out ++ "\n\n"+ ( "Downloaded (truncated to first 4K): \n\n" ++ take 4096 out ++ "\n\n" ) pure (unsafeRenderToText out) else do
src/lib/B9/Artifact/Content/StringTemplate.hs view
@@ -1,55 +1,58 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-| Utility functions based on 'Data.Text.Template' to offer @ $var @ variable- expansion in string throughout a B9 artifact.-- @deprecated-- TODO remove this in the move to Dhall- -}+-- | Utility functions based on 'Data.Text.Template' to offer @ $var @ variable+-- expansion in string throughout a B9 artifact.+--+-- @deprecated+--+-- TODO remove this in the move to Dhall module B9.Artifact.Content.StringTemplate- ( subst- , substStr- , substFile- , substPath- , readTemplateFile- , withSubstitutedStringBindings- , SourceFile(..)- , SourceFileConversion(..)+ ( subst,+ substStr,+ substFile,+ substPath,+ readTemplateFile,+ withSubstitutedStringBindings,+ SourceFile (..),+ SourceFileConversion (..), ) where-import B9.B9Error-import B9.Environment-import B9.QCUtil-import Control.Exception ( displayException )-import Control.Monad ( foldM )-import Control.Monad.IO.Class ( MonadIO(liftIO) )-import Control.Eff as Eff-import Control.Monad.Trans.Identity ( )-import Control.Parallel.Strategies-import Data.Binary-import Data.Data-import Data.Hashable-import Data.Text ( Text )-import qualified Data.Text.Lazy as LazyText- ( toStrict )-import qualified Data.Text as Text-import qualified Data.Text.IO as Text-import Data.Text.Template ( renderA- , templateSafe- , Template- )-import GHC.Generics ( Generic )-import System.IO.B9Extras-import Test.QuickCheck-import Text.Printf +import B9.B9Error+import B9.Environment+import B9.QCUtil+import Control.Eff as Eff+import Control.Exception (displayException)+import Control.Monad (foldM)+import Control.Monad.IO.Class (MonadIO (liftIO))+import Control.Monad.Trans.Identity ()+import Control.Parallel.Strategies+import Data.Binary+import Data.Data+import Data.Hashable+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import qualified Data.Text.Lazy as LazyText+ ( toStrict,+ )+import Data.Text.Template+ ( Template,+ renderA,+ templateSafe,+ )+import GHC.Generics (Generic)+import System.IO.B9Extras+import Test.QuickCheck+import Text.Printf+ -- | A wrapper around a file path and a flag indicating if template variable -- expansion should be performed when reading the file contents.-data SourceFile =- Source SourceFileConversion- FilePath+data SourceFile+ = Source+ SourceFileConversion+ FilePath deriving (Read, Show, Typeable, Data, Eq, Generic) instance Hashable SourceFile@@ -69,31 +72,32 @@ instance NFData SourceFileConversion -readTemplateFile- :: (MonadIO (Eff e), '[ExcB9, EnvironmentReader] <:: e)- => SourceFile- -> Eff e Text+readTemplateFile ::+ (MonadIO (Eff e), '[ExcB9, EnvironmentReader] <:: e) =>+ SourceFile ->+ Eff e Text readTemplateFile (Source conv f') = do- let- onErrorFileName e = error- (printf- "Failed to substitute templates in source \- \file name '%s'/\nError: %s\n"- f'- (displayException e)- )+ let onErrorFileName e =+ error+ ( printf+ "Failed to substitute templates in source \+ \file name '%s'/\nError: %s\n"+ f'+ (displayException e)+ ) f <- subst (Text.pack f') `catchB9Error` onErrorFileName c <- liftIO (Text.readFile (Text.unpack f)) case conv of NoConversion -> return c ExpandVariables -> let onErrorFile e =- error- (printf "readTemplateFile '%s' failed: \n%s\n"- f- (displayException e)- )- in subst c `catchB9Error` onErrorFile+ error+ ( printf+ "readTemplateFile '%s' failed: \n%s\n"+ f+ (displayException e)+ )+ in subst c `catchB9Error` onErrorFile -- | 'Text' template substitution. subst :: (Member ExcB9 e, Member EnvironmentReader e) => Text -> Eff e Text@@ -102,69 +106,69 @@ LazyText.toStrict <$> renderA t lookupOrThrow -- | 'String' template substitution-substStr- :: (Member ExcB9 e, Member EnvironmentReader e) => String -> Eff e String+substStr ::+ (Member ExcB9 e, Member EnvironmentReader e) => String -> Eff e String substStr templateStr = do t <- templateSafeExcB9 (Text.pack templateStr) Text.unpack . LazyText.toStrict <$> renderA t lookupOrThrow - templateSafeExcB9 :: Member ExcB9 e => Text -> Eff e Template templateSafeExcB9 templateStr = case templateSafe templateStr of- Left (row, col) -> throwB9Error- ( "Invalid template, error at row: "- ++ show row- ++ ", col: "- ++ show col- ++ " in: \""- ++ show templateStr- )+ Left (row, col) ->+ throwB9Error+ ( "Invalid template, error at row: "+ ++ show row+ ++ ", col: "+ ++ show col+ ++ " in: \""+ ++ show templateStr+ ) Right t -> return t --substFile- :: (Member EnvironmentReader e, Member ExcB9 e, MonadIO (Eff e))- => FilePath- -> FilePath- -> Eff e ()+substFile ::+ (Member EnvironmentReader e, Member ExcB9 e, MonadIO (Eff e)) =>+ FilePath ->+ FilePath ->+ Eff e () substFile src dest = do templatedText <- liftIO (Text.readFile src) let t = templateSafe templatedText case t of Left (r, c) ->- let badLine = Text.unlines (take r (Text.lines templatedText))+ let badLine = Text.unlines (take r (Text.lines templatedText)) colMarker = Text.replicate (c - 1) "-" <> "^"- in throwB9Error- (printf "Template error in file '%s' line %i:\n\n%s\n%s\n"- src- r- badLine- colMarker+ in throwB9Error+ ( printf+ "Template error in file '%s' line %i:\n\n%s\n%s\n"+ src+ r+ badLine+ colMarker ) Right template' -> do out <- renderA template' (templateEnvLookupSrcFile src) liftIO (Text.writeFile dest (LazyText.toStrict out)) -templateEnvLookupSrcFile- :: (Member EnvironmentReader e, Member ExcB9 e, MonadIO (Eff e))- => FilePath- -> Text- -> Eff e Text+templateEnvLookupSrcFile ::+ (Member EnvironmentReader e, Member ExcB9 e, MonadIO (Eff e)) =>+ FilePath ->+ Text ->+ Eff e Text templateEnvLookupSrcFile src x = do r <- catchB9ErrorAsEither (lookupOrThrow x) either err pure r- where err e = throwB9Error (show e ++ "\nIn file: \'" ++ src ++ "\'\n")-+ where+ err e = throwB9Error (show e ++ "\nIn file: \'" ++ src ++ "\'\n") -substPath- :: (Member EnvironmentReader e, Member ExcB9 e)- => SystemPath- -> Eff e SystemPath+substPath ::+ (Member EnvironmentReader e, Member ExcB9 e) =>+ SystemPath ->+ Eff e SystemPath substPath src = case src of- Path p -> Path <$> substStr p- InHomeDir p -> InHomeDir <$> substStr p+ Path p -> Path <$> substStr p+ InHomeDir p -> InHomeDir <$> substStr p InB9UserDir p -> InB9UserDir <$> substStr p- InTempDir p -> InTempDir <$> substStr p+ InTempDir p -> InTempDir <$> substStr p instance Arbitrary SourceFile where arbitrary =@@ -172,20 +176,19 @@ <$> elements [NoConversion, ExpandVariables] <*> smaller arbitraryFilePath - -- | Extend an 'Environment' with new bindings, where each value may contain -- string templates with like @"Hello $name, how is life on $planet these days?"@. -- -- @since 0.5.64-withSubstitutedStringBindings- :: (Member EnvironmentReader e, Member ExcB9 e)- => [(String, String)]- -> Eff e s- -> Eff e s+withSubstitutedStringBindings ::+ (Member EnvironmentReader e, Member ExcB9 e) =>+ [(String, String)] ->+ Eff e s ->+ Eff e s withSubstitutedStringBindings bs nested = do let extend env (k, v) = localEnvironment (const env) $ do- kv <- (Text.pack k, ) <$> subst (Text.pack v)+ kv <- (Text.pack k,) <$> subst (Text.pack v) addBinding kv env- env <- askEnvironment+ env <- askEnvironment envExt <- foldM extend env bs localEnvironment (const envExt) nested
src/lib/B9/Artifact/Content/YamlObject.hs view
@@ -1,78 +1,78 @@ -- | A wrapper around Yaml with 'Semigroup' and 'Monoid' instances for merging, reading and -- writing yaml files within B9. module B9.Artifact.Content.YamlObject- ( YamlObject(..)+ ( YamlObject (..), ) where -import B9.Text-import Control.Applicative-import Control.Parallel.Strategies-import Control.Exception-import Data.Bifunctor ( first )-import qualified Data.ByteString.Lazy as Lazy-import Data.Data-import Data.Function-import Data.Hashable-import Data.HashMap.Strict hiding ( singleton )-import Data.Semigroup-import Data.Vector as Vector- ( singleton- , (++)- )-import Data.Yaml as Yaml-import GHC.Generics ( Generic )-import Prelude hiding ( (++) )-import Text.Printf--import B9.Artifact.Content-import B9.Artifact.Content.AST-import B9.Artifact.Content.StringTemplate-import Test.QuickCheck+import B9.Artifact.Content+import B9.Artifact.Content.AST+import B9.Artifact.Content.StringTemplate+import B9.Text+import Control.Applicative+import Control.Exception+import Control.Parallel.Strategies+import Data.Bifunctor (first)+import qualified Data.ByteString.Lazy as Lazy+import Data.Data+import Data.Function+import Data.HashMap.Strict hiding (singleton)+import Data.Hashable+import Data.Semigroup+import Data.Vector as Vector+ ( (++),+ singleton,+ )+import Data.Yaml as Yaml+import GHC.Generics (Generic)+import Test.QuickCheck+import Text.Printf+import Prelude hiding ((++)) -- | A wrapper type around yaml values with a Semigroup instance useful for -- combining yaml documents describing system configuration like e.g. user-data.-newtype YamlObject = YamlObject- { _fromYamlObject :: Yaml.Value- } deriving (Hashable, NFData, Eq, Data, Typeable, Generic)+newtype YamlObject+ = YamlObject+ { _fromYamlObject :: Yaml.Value+ }+ deriving (Hashable, NFData, Eq, Data, Typeable, Generic) instance Textual YamlObject where renderToText = renderToText . encode . _fromYamlObject parseFromText t = do rb <- parseFromText t- y <- first displayException $ Yaml.decodeThrow (Lazy.toStrict rb)+ y <- first displayException $ Yaml.decodeThrow (Lazy.toStrict rb) return (YamlObject y) - 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- . parseFromTextWithErrorMessage "HERE-DOC"- . unsafeRenderToText+ 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+ . parseFromTextWithErrorMessage "HERE-DOC"+ . unsafeRenderToText instance Show YamlObject where show (YamlObject o) = "YamlObject " <> show (unsafeRenderToText $ encode o) instance Semigroup YamlObject where (YamlObject v1) <> (YamlObject v2) = YamlObject (combine v1 v2)- where- combine :: Yaml.Value -> Yaml.Value -> Yaml.Value- combine (Object o1) (Object o2) = Object (unionWith combine o1 o2)- combine (Array a1) (Array a2) = Array (a1 ++ a2)- combine (Array a1) t2 = Array (a1 ++ Vector.singleton t2)- combine t1 (Array a2) = Array (Vector.singleton t1 ++ a2)- combine (String s1) (String s2) = String (s1 <> s2)- combine t1 t2 = array [t1, t2]+ where+ combine :: Yaml.Value -> Yaml.Value -> Yaml.Value+ combine (Object o1) (Object o2) = Object (unionWith combine o1 o2)+ combine (Array a1) (Array a2) = Array (a1 ++ a2)+ combine (Array a1) t2 = Array (a1 ++ Vector.singleton t2)+ combine t1 (Array a2) = Array (Vector.singleton t1 ++ a2)+ combine (String s1) (String s2) = String (s1 <> s2)+ combine t1 t2 = array [t1, t2] instance FromAST YamlObject where fromAST ast = case ast of@@ -83,25 +83,26 @@ 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 [] -> error "ASTMerge MUST NOT be used with an empty list!" ASTMerge asts -> do ys <- mapM fromAST asts return (foldl1 (<>) ys) ASTEmbed c -> YamlObject . toJSON <$> toContentGenerator c- ASTString str -> return (YamlObject (toJSON str))- ASTInt int -> return (YamlObject (toJSON int))- ASTParse src@(Source _ srcPath) -> do+ ASTString str -> return (YamlObject (toJSON str))+ ASTInt int -> return (YamlObject (toJSON int))+ ASTParse src@(Source _ srcPath) -> do c <- readTemplateFile src case parseFromTextWithErrorMessage srcPath c of Right s -> return s- Left e -> error- (printf "could not parse yaml source file: '%s'\n%s\n" srcPath e)+ 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' = unsafeRenderToText key- return $ key' .= o+ where+ fromASTPair (key, value) = do+ (YamlObject o) <- fromAST value+ let key' = unsafeRenderToText key+ return $ key' .= o instance Arbitrary YamlObject where arbitrary = pure (YamlObject Null)
src/lib/B9/Artifact/Readable.hs view
@@ -1,131 +1,134 @@ {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilies #-} -{-|-Top-Level data types for B9 build artifacts.--}+-- |+-- Top-Level data types for B9 build artifacts. module B9.Artifact.Readable- ( ArtifactGenerator(..)- , InstanceId(..)- , ArtifactTarget(..)- , CloudInitType(..)- , ArtifactAssembly(..)- , AssembledArtifact(..)- , AssemblyOutput(..)- , instanceIdKey- , buildIdKey- , buildDateKey- , getAssemblyOutput- -- ** Re-exports- , ArtifactSource(..)- , getArtifactSourceFiles+ ( ArtifactGenerator (..),+ InstanceId (..),+ ArtifactTarget (..),+ CloudInitType (..),+ ArtifactAssembly (..),+ AssembledArtifact (..),+ AssemblyOutput (..),+ instanceIdKey,+ buildIdKey,+ buildDateKey,+ getAssemblyOutput,++ -- ** Re-exports+ ArtifactSource (..),+ getArtifactSourceFiles, ) where -import Control.Parallel.Strategies-import Data.Binary-import Data.Data-import Data.Hashable-import Data.Semigroup as Sem-import GHC.Generics ( Generic )-import System.FilePath ( (<.>) )--import B9.Artifact.Readable.Source-import B9.DiskImages-import B9.QCUtil-import B9.Vm--import Test.QuickCheck--{-| Artifacts represent the things B9 can build. A generator specifies howto-generate parameterized, multiple artifacts. The general structure is:--@- Let [ ... bindings ... ]- [ Sources- [ ... list all input files ... ]- [ Artifact ...- , Artifact ...- , Let [ ... ] [ ... ]- ]- ]-@--The reasons why 'Sources' takes a list of 'ArtifactGenerator's is that-- 1. this makes the value easier to read/write for humans-- 2. the sources are static files used in all children (e.g. company logo image)-- 3. the sources are parameterized by variables that bound to different values- for each artifact, e.g. a template network config file which contains- the host IP address.--To bind such variables use 'Let', 'Each', 'LetX' or 'EachT'.--String substitution of these variables is done by "B9.Artifact.Content.StringTemplate".-These variables can be used as value in nested 'Let's, in most file names/paths-and in source files added with 'B9.Artifact.Content.StringTemplate.SourceFile'+import B9.Artifact.Readable.Source+import B9.DiskImages+import B9.QCUtil+import B9.Vm+import Control.Parallel.Strategies+import Data.Binary+import Data.Data+import Data.Hashable+import Data.Semigroup as Sem+import GHC.Generics (Generic)+import System.FilePath ((<.>))+import Test.QuickCheck --- @deprecated TODO remove this when switching to Dhall--}+-- | Artifacts represent the things B9 can build. A generator specifies howto+-- generate parameterized, multiple artifacts. The general structure is:+--+-- @+-- Let [ ... bindings ... ]+-- [ Sources+-- [ ... list all input files ... ]+-- [ Artifact ...+-- , Artifact ...+-- , Let [ ... ] [ ... ]+-- ]+-- ]+-- @+--+-- The reasons why 'Sources' takes a list of 'ArtifactGenerator's is that+--+-- 1. this makes the value easier to read/write for humans+--+-- 2. the sources are static files used in all children (e.g. company logo image)+--+-- 3. the sources are parameterized by variables that bound to different values+-- for each artifact, e.g. a template network config file which contains+-- the host IP address.+--+-- To bind such variables use 'Let', 'Each', 'LetX' or 'EachT'.+--+-- String substitution of these variables is done by "B9.Artifact.Content.StringTemplate".+-- These variables can be used as value in nested 'Let's, in most file names/paths+-- and in source files added with 'B9.Artifact.Content.StringTemplate.SourceFile'+--+-- -- @deprecated TODO remove this when switching to Dhall data ArtifactGenerator- = Sources [ArtifactSource]- [ArtifactGenerator]- -- ^ Add sources available to 'ArtifactAssembly's in- -- nested artifact generators.- | Let [(String, String)]- [ArtifactGenerator]- -- ^ Bind variables, variables are available in nested- -- generators.- -- @deprecated TODO remove this when switching to Dhall- | LetX [(String, [String])]- [ArtifactGenerator]- -- ^ A 'Let' where each variable is assigned to each- -- value; the nested generator is executed for each- -- permutation.- --- -- @- -- LetX [("x", ["1","2","3"]), ("y", ["a","b"])] [..]- -- @- -- Is equal to:- --- -- @- -- Let [] [- -- Let [("x", "1"), ("y", "a")] [..]- -- Let [("x", "1"), ("y", "b")] [..]- -- Let [("x", "2"), ("y", "a")] [..]- -- Let [("x", "2"), ("y", "b")] [..]- -- Let [("x", "3"), ("y", "a")] [..]- -- Let [("x", "3"), ("y", "b")] [..]- -- ]- -- @- -- @deprecated TODO remove this when switching to Dhall- | Each [(String, [String])]- [ArtifactGenerator]- -- ^ Bind each variable to their first value, then each- -- variable to the second value, etc ... and execute the- -- nested generator in every step. 'LetX' represents a- -- product of all variables, whereas 'Each' represents a- -- sum of variable bindings - 'Each' is more like a /zip/- -- whereas 'LetX' is more like a list comprehension.- -- @deprecated TODO remove this when switching to Dhall- | EachT [String]- [[String]]- [ArtifactGenerator]- -- ^ The transposed version of 'Each': Bind the variables- -- in the first list to each a set of values from the- -- second argument; execute the nested generators for- -- each binding- -- @deprecated TODO remove this when switching to Dhall- | Artifact InstanceId- ArtifactAssembly- -- ^ Generate an artifact defined by an- -- 'ArtifactAssembly'; the assembly can access the files- -- created from the 'Sources' and variables bound by- -- 'Let'ish elements. An artifact has an instance id,- -- that is a unique, human readable string describing the- -- artifact to assemble.+ = -- | Add sources available to 'ArtifactAssembly's in+ -- nested artifact generators.+ Sources+ [ArtifactSource]+ [ArtifactGenerator]+ | -- | Bind variables, variables are available in nested+ -- generators.+ -- @deprecated TODO remove this when switching to Dhall+ Let+ [(String, String)]+ [ArtifactGenerator]+ | -- | A 'Let' where each variable is assigned to each+ -- value; the nested generator is executed for each+ -- permutation.+ --+ -- @+ -- LetX [("x", ["1","2","3"]), ("y", ["a","b"])] [..]+ -- @+ -- Is equal to:+ --+ -- @+ -- Let [] [+ -- Let [("x", "1"), ("y", "a")] [..]+ -- Let [("x", "1"), ("y", "b")] [..]+ -- Let [("x", "2"), ("y", "a")] [..]+ -- Let [("x", "2"), ("y", "b")] [..]+ -- Let [("x", "3"), ("y", "a")] [..]+ -- Let [("x", "3"), ("y", "b")] [..]+ -- ]+ -- @+ -- @deprecated TODO remove this when switching to Dhall+ LetX+ [(String, [String])]+ [ArtifactGenerator]+ | -- | Bind each variable to their first value, then each+ -- variable to the second value, etc ... and execute the+ -- nested generator in every step. 'LetX' represents a+ -- product of all variables, whereas 'Each' represents a+ -- sum of variable bindings - 'Each' is more like a /zip/+ -- whereas 'LetX' is more like a list comprehension.+ -- @deprecated TODO remove this when switching to Dhall+ Each+ [(String, [String])]+ [ArtifactGenerator]+ | -- | The transposed version of 'Each': Bind the variables+ -- in the first list to each a set of values from the+ -- second argument; execute the nested generators for+ -- each binding+ -- @deprecated TODO remove this when switching to Dhall+ EachT+ [String]+ [[String]]+ [ArtifactGenerator]+ | -- | Generate an artifact defined by an+ -- 'ArtifactAssembly'; the assembly can access the files+ -- created from the 'Sources' and variables bound by+ -- 'Let'ish elements. An artifact has an instance id,+ -- that is a unique, human readable string describing the+ -- artifact to assemble.+ Artifact+ InstanceId+ ArtifactAssembly | EmptyArtifact deriving (Read, Show, Eq, Data, Typeable, Generic) @@ -134,18 +137,18 @@ instance NFData ArtifactGenerator instance Sem.Semigroup ArtifactGenerator where- (Let [] []) <> x = x- x <> (Let [] []) = x- x <> y = Let [] [x, y]+ (Let [] []) <> x = x+ x <> (Let [] []) = x+ x <> y = Let [] [x, y] instance Monoid ArtifactGenerator where- mempty = Let [] []+ mempty = Let [] [] mappend = (Sem.<>) -- | Identify an artifact. __Deprecated__ TODO: B9 does not check if all -- instances IDs are unique.-newtype InstanceId =- IID String+newtype InstanceId+ = IID String deriving (Read, Show, Typeable, Data, Eq, NFData, Binary, Hashable) -- | The variable containing the instance id. __Deprecated__@@ -168,17 +171,19 @@ -- 'ArtifactGenerator's. They contain all the files defined by the 'Sources' -- they are nested into. data ArtifactAssembly- = CloudInit [CloudInitType]- FilePath- -- ^ Generate a __cloud-init__ compatible directory, ISO-- -- or VFAT image, as specified by the list of- -- 'CloudInitType's. Every item will use the second- -- argument to create an appropriate /file name/,- -- e.g. for the 'CI_ISO' type the output is @second_param.iso@.- | VmImages [ImageTarget]- VmScript- -- ^ a set of VM-images that were created by executing a+ = -- | Generate a __cloud-init__ compatible directory, ISO-+ -- or VFAT image, as specified by the list of+ -- 'CloudInitType's. Every item will use the second+ -- argument to create an appropriate /file name/,+ -- e.g. for the 'CI_ISO' type the output is @second_param.iso@.+ CloudInit+ [CloudInitType]+ FilePath+ | -- | a set of VM-images that were created by executing a -- build script on them.+ VmImages+ [ImageTarget]+ VmScript deriving (Read, Show, Typeable, Data, Eq, Generic) instance Hashable ArtifactAssembly@@ -191,9 +196,10 @@ -- 'B9.Artifact.Readable.Interpreter.assemble' from an 'ArtifactAssembly'. There is a -- list of 'ArtifactTarget's because e.g. a single 'CloudInit' can produce up to -- three output files, a directory, an ISO image and a VFAT image.-data AssembledArtifact =- AssembledArtifact InstanceId- [ArtifactTarget]+data AssembledArtifact+ = AssembledArtifact+ InstanceId+ [ArtifactTarget] deriving (Read, Show, Typeable, Data, Eq, Generic) instance Hashable AssembledArtifact@@ -203,8 +209,9 @@ instance NFData AssembledArtifact data ArtifactTarget- = CloudInitTarget CloudInitType- FilePath+ = CloudInitTarget+ CloudInitType+ FilePath | VmImagesTarget deriving (Read, Show, Typeable, Data, Eq, Generic) @@ -238,45 +245,52 @@ getAssemblyOutput (VmImages ts _) = AssemblyGeneratesOutputFiles . getImageDestinationOutputFiles <$> ts getAssemblyOutput (CloudInit ts o) = getCloudInitOutputFiles o <$> ts- where- getCloudInitOutputFiles baseName t = case t of- CI_ISO -> AssemblyGeneratesOutputFiles [baseName <.> "iso"]- CI_VFAT -> AssemblyGeneratesOutputFiles [baseName <.> "vfat"]- CI_DIR -> AssemblyCopiesSourcesToDirectory baseName+ where+ getCloudInitOutputFiles baseName t = case t of+ CI_ISO -> AssemblyGeneratesOutputFiles [baseName <.> "iso"]+ CI_VFAT -> AssemblyGeneratesOutputFiles [baseName <.> "vfat"]+ CI_DIR -> AssemblyCopiesSourcesToDirectory baseName -- * QuickCheck instances+ instance Arbitrary ArtifactGenerator where- arbitrary = oneof- [ Sources <$> halfSize arbitrary <*> halfSize arbitrary- , Let <$> halfSize arbitraryEnv <*> halfSize arbitrary- , halfSize arbitraryEachT <*> halfSize arbitrary- , halfSize arbitraryEach <*> halfSize arbitrary- , Artifact <$> smaller arbitrary <*> smaller arbitrary- , pure EmptyArtifact- ]+ 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))- ]+ 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'))))- )+arbitraryEach = sized $ \n ->+ Each+ <$> listOf+ ( (,) <$> listOf1 (choose ('a', 'z'))+ <*> vectorOf+ n+ (halfSize (listOf1 (choose ('a', 'z'))))+ ) instance Arbitrary InstanceId where arbitrary = IID <$> arbitraryFilePath instance Arbitrary ArtifactAssembly where- arbitrary = oneof- [ CloudInit <$> arbitrary <*> arbitraryFilePath- , VmImages <$> smaller arbitrary <*> pure NoVmScript- ]+ arbitrary =+ oneof+ [ CloudInit <$> arbitrary <*> arbitraryFilePath,+ VmImages <$> smaller arbitrary <*> pure NoVmScript+ ] instance Arbitrary CloudInitType where arbitrary = elements [CI_ISO, CI_VFAT, CI_DIR]
src/lib/B9/Artifact/Readable/Interpreter.hs view
@@ -1,54 +1,55 @@-{-|-Mostly effectful functions to assemble artifacts.--}+-- |+-- Mostly effectful functions to assemble artifacts. module B9.Artifact.Readable.Interpreter- ( buildArtifacts- , assemble- , getArtifactOutputFiles- , runArtifactGenerator- , runArtifactAssembly- , InstanceGenerator(..)- , runInstanceGenerator- , InstanceSources(..)+ ( buildArtifacts,+ assemble,+ getArtifactOutputFiles,+ runArtifactGenerator,+ runArtifactAssembly,+ InstanceGenerator (..),+ runInstanceGenerator,+ InstanceSources (..), ) where -import B9.Artifact.Content-import B9.Artifact.Content.Readable-import B9.Artifact.Content.StringTemplate-import B9.Artifact.Readable-import B9.B9Config-import B9.B9Error-import B9.B9Exec-import B9.Text-import B9.B9Logging-import B9.B9Monad-import B9.BuildInfo-import B9.DiskImageBuilder-import B9.Environment-import B9.Vm-import B9.VmBuilder-import Control.Arrow-import Control.Eff as Eff-import Control.Eff.Reader.Lazy as Eff-import Control.Eff.Writer.Lazy as Eff-import Control.Exception ( SomeException- , displayException- )-import Control.Monad-import Control.Monad.IO.Class-import Data.Data-import Data.Generics.Aliases-import Data.Generics.Schemes-import Data.List-import Data.String-import System.Directory-import System.FilePath-import System.IO.B9Extras ( ensureDir- , getDirectoryFiles- )-import Text.Printf-import Text.Show.Pretty ( ppShow )+import B9.Artifact.Content+import B9.Artifact.Content.Readable+import B9.Artifact.Content.StringTemplate+import B9.Artifact.Readable+import B9.B9Config+import B9.B9Error+import B9.B9Exec+import B9.B9Logging+import B9.B9Monad+import B9.BuildInfo+import B9.DiskImageBuilder+import B9.Environment+import B9.Text+import B9.Vm+import B9.VmBuilder+import Control.Arrow+import Control.Eff as Eff+import Control.Eff.Reader.Lazy as Eff+import Control.Eff.Writer.Lazy as Eff+import Control.Exception+ ( SomeException,+ displayException,+ )+import Control.Monad+import Control.Monad.IO.Class+import Data.Data+import Data.Generics.Aliases+import Data.Generics.Schemes+import Data.List+import Data.String+import System.Directory+import System.FilePath+import System.IO.B9Extras+ ( ensureDir,+ getDirectoryFiles,+ )+import Text.Printf+import Text.Show.Pretty (ppShow) -- | Execute an 'ArtifactGenerator' and return a 'B9Invocation' that returns -- the build id obtained by 'getBuildId'.@@ -57,7 +58,7 @@ traceL . ("CWD: " ++) =<< liftIO getCurrentDirectory infoL "BUILDING ARTIFACTS" getConfig >>= traceL . printf "USING BUILD CONFIGURATION: %v" . ppShow- assemble artifactGenerator+ _ <- assemble artifactGenerator getBuildId -- | Return a list of relative paths for the /local/ files to be generated@@ -66,20 +67,20 @@ getArtifactOutputFiles g = concatMap getOutputs <$> runArtifactGenerator mempty "no build-id" "no build-date" g- where- getOutputs (IG _ sgs a) =- let toOutFile (AssemblyGeneratesOutputFiles fs) = fs- toOutFile (AssemblyCopiesSourcesToDirectory pd) =+ where+ getOutputs (IG _ sgs a) =+ let toOutFile (AssemblyGeneratesOutputFiles fs) = fs+ toOutFile (AssemblyCopiesSourcesToDirectory pd) = let sourceFiles = textFileWriterOutputFile <$> sgs- in (pd </>) <$> sourceFiles- in getAssemblyOutput a >>= toOutFile+ in (pd </>) <$> sourceFiles+ in getAssemblyOutput a >>= toOutFile -- | Run an artifact generator to produce the artifacts. assemble :: ArtifactGenerator -> B9 [AssembledArtifact] assemble artGen = do b9cfgEnvVars <- askEnvironment- buildId <- getBuildId- buildDate <- getBuildDate+ buildId <- getBuildId+ buildDate <- getBuildDate runArtifactSourcesReader (InstanceSources b9cfgEnvVars mempty) $ do is <- evalArtifactGenerator buildId buildDate artGen createAssembledArtifacts is@@ -87,69 +88,70 @@ -- | Interpret an 'ArtifactGenerator' into a list of simple commands, i.e. 'InstanceGenerator's -- -- @since 0.5.65-runArtifactGenerator- :: Environment- -> String- -> String- -> ArtifactGenerator- -> Either SomeException [InstanceGenerator [TextFileWriter]]-runArtifactGenerator initialEnvironment buildId buildData generator = Eff.run- (runExcB9- (runEnvironmentReader- initialEnvironment- (runArtifactSourcesReader- (InstanceSources initialEnvironment mempty)- (evalArtifactGenerator buildId buildData generator)- )+runArtifactGenerator ::+ Environment ->+ String ->+ String ->+ ArtifactGenerator ->+ Either SomeException [InstanceGenerator [TextFileWriter]]+runArtifactGenerator initialEnvironment buildId buildData generator =+ Eff.run+ ( runExcB9+ ( runEnvironmentReader+ initialEnvironment+ ( runArtifactSourcesReader+ (InstanceSources initialEnvironment mempty)+ (evalArtifactGenerator buildId buildData generator)+ )+ ) )- ) -- | Evaluate an 'ArtifactGenerator' into a list of low-level build instructions -- that can be built with 'createAssembledArtifacts'.-evalArtifactGenerator- :: (Member ExcB9 e, Member EnvironmentReader e)- => String- -> String- -> ArtifactGenerator- -> Eff- (ArtifactSourcesReader ': e)- [InstanceGenerator [TextFileWriter]]+evalArtifactGenerator ::+ (Member ExcB9 e, Member EnvironmentReader e) =>+ String ->+ String ->+ ArtifactGenerator ->+ Eff+ (ArtifactSourcesReader ': e)+ [InstanceGenerator [TextFileWriter]] evalArtifactGenerator buildId buildDate artGen = withSubstitutedStringBindings- [(buildDateKey, buildDate), (buildIdKey, buildId)]- (runArtifactInterpreter (interpretGenerator artGen))+ [(buildDateKey, buildDate), (buildIdKey, buildId)]+ (runArtifactInterpreter (interpretGenerator artGen)) `catchB9Error` ( throwB9Error- . printf "Failed to eval:\n%s\nError: %s" (ppShow artGen)- . displayException+ . printf "Failed to eval:\n%s\nError: %s" (ppShow artGen)+ . displayException ) type ArtifactSourcesReader = Reader [ArtifactSource] -runArtifactSourcesReader- :: Member EnvironmentReader e- => InstanceSources- -> Eff (ArtifactSourcesReader ': e) a- -> Eff e a+runArtifactSourcesReader ::+ Member EnvironmentReader e =>+ InstanceSources ->+ Eff (ArtifactSourcesReader ': e) a ->+ Eff e a runArtifactSourcesReader x y = runReader (isSources x) (localEnvironment (const (isEnv x)) y) -- | Monad for creating Instance generators.-type ArtifactInterpreter e- = Writer [InstanceGenerator InstanceSources] : ArtifactSourcesReader : e+type ArtifactInterpreter e =+ Writer [InstanceGenerator InstanceSources] : ArtifactSourcesReader : e -runArtifactInterpreter- :: (Member ExcB9 e, Member EnvironmentReader e)- => Eff (ArtifactInterpreter e) ()- -> Eff (ArtifactSourcesReader : e) [InstanceGenerator [TextFileWriter]]+runArtifactInterpreter ::+ (Member ExcB9 e, Member EnvironmentReader e) =>+ Eff (ArtifactInterpreter e) () ->+ Eff (ArtifactSourcesReader : e) [InstanceGenerator [TextFileWriter]] runArtifactInterpreter ai = do ((), igs) <- runMonoidWriter ai traverse toFileInstanceGenerator igs -- | Parse an 'ArtifactGenerator' inside the 'ArtifactInterpreter' effect.-interpretGenerator- :: (Member ExcB9 e, Member EnvironmentReader e)- => ArtifactGenerator- -> Eff (ArtifactInterpreter e) ()+interpretGenerator ::+ (Member ExcB9 e, Member EnvironmentReader e) =>+ ArtifactGenerator ->+ Eff (ArtifactInterpreter e) () interpretGenerator generatorIn = case generatorIn of Sources sources generators -> withArtifactSources sources (mapM_ interpretGenerator generators)@@ -160,8 +162,8 @@ EachT keySet valueSets generators -> do allBindings <- eachBindingSetT generatorIn keySet valueSets sequence_- (flip withSubstitutedStringBindings (mapM_ interpretGenerator generators)- <$> allBindings+ ( flip withSubstitutedStringBindings (mapM_ interpretGenerator generators)+ <$> allBindings ) Each kvs generators -> do allBindings <- eachBindingSet generatorIn kvs@@ -170,111 +172,117 @@ return (withSubstitutedStringBindings b (mapM_ interpretGenerator generators)) Artifact iid assembly -> interpretAssembly iid assembly- EmptyArtifact -> return ()- where- withArtifactSources- :: (Member ExcB9 e, Member EnvironmentReader e)- => [ArtifactSource]- -> Eff (ArtifactInterpreter e) s- -> Eff (ArtifactInterpreter e) s- withArtifactSources sources = local (++ sources)- withXBindings- :: (Member ExcB9 e, Member EnvironmentReader e)- => [(String, [String])]- -> Eff (ArtifactInterpreter e) ()- -> Eff (ArtifactInterpreter e) ()- withXBindings bindings cp = (`withSubstitutedStringBindings` cp)- `mapM_` allXBindings bindings- where- allXBindings ((k, vs) : rest) =- [ (k, v) : c | v <- vs, c <- allXBindings rest ]- allXBindings [] = [[]]- eachBindingSetT- :: (Member ExcB9 e)- => ArtifactGenerator- -> [String]- -> [[String]]- -> Eff (ArtifactInterpreter e) [[(String, String)]]- eachBindingSetT g vars valueSets =- if all ((== length vars) . length) valueSets- then return (zip vars <$> valueSets)- else throwB9Error- (printf- "Error in 'Each' binding during artifact generation in:\n '%s'.\n\nThe variable list\n%s\n has %i entries, but this binding set\n%s\n\nhas a different number of entries!\n"- (ppShow g)- (ppShow vars)- (length vars)- (ppShow (head (dropWhile ((== length vars) . length) valueSets)))- )- eachBindingSet- :: (Member ExcB9 e)- => ArtifactGenerator- -> [(String, [String])]- -> Eff (ArtifactInterpreter e) [[(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))- (throwB9Error- (printf- "Error in 'Each' binding: \n%s\nAll value lists must have the same length!"- (ppShow g)- )- )+ EmptyArtifact -> return ()+ where+ withArtifactSources ::+ (Member ExcB9 e, Member EnvironmentReader e) =>+ [ArtifactSource] ->+ Eff (ArtifactInterpreter e) s ->+ Eff (ArtifactInterpreter e) s+ withArtifactSources sources = local (++ sources)+ withXBindings ::+ (Member ExcB9 e, Member EnvironmentReader e) =>+ [(String, [String])] ->+ Eff (ArtifactInterpreter e) () ->+ Eff (ArtifactInterpreter e) ()+ withXBindings bindings cp =+ (`withSubstitutedStringBindings` cp)+ `mapM_` allXBindings bindings+ where+ allXBindings ((k, vs) : rest) =+ [(k, v) : c | v <- vs, c <- allXBindings rest]+ allXBindings [] = [[]]+ eachBindingSetT ::+ (Member ExcB9 e) =>+ ArtifactGenerator ->+ [String] ->+ [[String]] ->+ Eff (ArtifactInterpreter e) [[(String, String)]]+ eachBindingSetT g vars valueSets =+ if all ((== length vars) . length) valueSets+ then return (zip vars <$> valueSets)+ else+ throwB9Error+ ( printf+ "Error in 'Each' binding during artifact generation in:\n '%s'.\n\nThe variable list\n%s\n has %i entries, but this binding set\n%s\n\nhas a different number of entries!\n"+ (ppShow g)+ (ppShow vars)+ (length vars)+ (ppShow (head (dropWhile ((== length vars) . length) valueSets)))+ )+ eachBindingSet ::+ (Member ExcB9 e) =>+ ArtifactGenerator ->+ [(String, [String])] ->+ Eff (ArtifactInterpreter e) [[(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))+ ( throwB9Error+ ( printf+ "Error in 'Each' binding: \n%s\nAll value lists must have the same length!"+ (ppShow g)+ )+ ) -interpretAssembly- :: (Member ExcB9 e, Member EnvironmentReader e)- => InstanceId- -> ArtifactAssembly- -> Eff (ArtifactInterpreter e) ()+interpretAssembly ::+ (Member ExcB9 e, Member EnvironmentReader e) =>+ InstanceId ->+ ArtifactAssembly ->+ Eff (ArtifactInterpreter e) () interpretAssembly (IID iidStrTemplate) assembly = do iid@(IID iidStr) <- IID <$> substStr iidStrTemplate- env <- InstanceSources <$> askEnvironment <*> ask+ env <- InstanceSources <$> askEnvironment <*> ask withSubstitutedStringBindings [(fromString instanceIdKey, fromString iidStr)] (tell [IG iid env assembly]) -- | Internal data structure. Only exposed for unit testing.-data InstanceSources = InstanceSources- { isEnv :: Environment- , isSources :: [ArtifactSource]- } deriving (Show, Eq)+data InstanceSources+ = InstanceSources+ { isEnv :: Environment,+ isSources :: [ArtifactSource]+ }+ deriving (Show, Eq) -data InstanceGenerator e =- IG InstanceId- e- ArtifactAssembly+data InstanceGenerator e+ = IG+ InstanceId+ e+ ArtifactAssembly deriving (Read, Show, Typeable, Data, Eq) -toFileInstanceGenerator- :: Member ExcB9 e- => InstanceGenerator InstanceSources- -> Eff e (InstanceGenerator [TextFileWriter])+toFileInstanceGenerator ::+ Member ExcB9 e =>+ InstanceGenerator InstanceSources ->+ Eff e (InstanceGenerator [TextFileWriter]) toFileInstanceGenerator (IG iid (InstanceSources env sources) assembly) = runEnvironmentReader env $ do- assembly' <- substAssembly assembly+ assembly' <- substAssembly assembly sourceGenerators <- join <$> traverse toSourceGen sources pure (IG iid sourceGenerators assembly') -substAssembly- :: forall e- . (Member ExcB9 e, Member EnvironmentReader e)- => ArtifactAssembly- -> Eff e ArtifactAssembly+substAssembly ::+ forall e.+ (Member ExcB9 e, Member EnvironmentReader e) =>+ ArtifactAssembly ->+ Eff e ArtifactAssembly substAssembly = everywhereM gsubst- where- gsubst :: Data a => a -> Eff e a- gsubst = mkM substAssembly_ `extM` substImageTarget `extM` substVmScript- substAssembly_ (CloudInit ts f) = CloudInit ts <$> substStr f- substAssembly_ vm = pure vm+ where+ gsubst :: Data a => a -> Eff e a+ gsubst = mkM substAssembly_ `extM` substImageTarget `extM` substVmScript+ substAssembly_ (CloudInit ts f) = CloudInit ts <$> substStr f+ substAssembly_ vm = pure vm -toSourceGen- :: (Member ExcB9 e, Member EnvironmentReader e)- => ArtifactSource- -> Eff e [TextFileWriter]+toSourceGen ::+ (Member ExcB9 e, Member EnvironmentReader e) =>+ ArtifactSource ->+ Eff e [TextFileWriter] toSourceGen src = do env <- askEnvironment case src of@@ -282,10 +290,11 @@ t' <- substStr t f' <- substStr f return- [ MkTextFileWriter env- (ExternalFiles [Source conv f'])- KeepPermissions- t'+ [ MkTextFileWriter+ env+ (ExternalFiles [Source conv f'])+ KeepPermissions+ t' ] FromContent t c -> do t' <- substStr t@@ -294,16 +303,16 @@ sgs <- join <$> mapM toSourceGen src' traverse (setFilePermissionAction o g a) sgs FromDirectory fromDir src' -> do- sgs <- join <$> mapM toSourceGen src'+ sgs <- join <$> mapM toSourceGen src' fromDir' <- substStr fromDir return (prefixExternalSourcesPaths fromDir' <$> sgs) IntoDirectory toDir src' -> do- sgs <- join <$> mapM toSourceGen src'+ sgs <- join <$> mapM toSourceGen src' toDir' <- substStr toDir return (prefixOutputFilePaths toDir' <$> sgs) -createAssembledArtifacts- :: IsB9 e => [InstanceGenerator [TextFileWriter]] -> Eff e [AssembledArtifact]+createAssembledArtifacts ::+ IsB9 e => [InstanceGenerator [TextFileWriter]] -> Eff e [AssembledArtifact] createAssembledArtifacts igs = do buildDir <- getBuildDir let outDir = buildDir </> "artifact-instances"@@ -311,11 +320,11 @@ generated <- generateSources outDir `mapM` igs runInstanceGenerator `mapM` generated -generateSources- :: IsB9 e- => FilePath- -> InstanceGenerator [TextFileWriter]- -> Eff e (InstanceGenerator FilePath)+generateSources ::+ IsB9 e =>+ FilePath ->+ InstanceGenerator [TextFileWriter] ->+ Eff e (InstanceGenerator FilePath) generateSources outDir (IG iid sgs assembly) = do uiid@(IID uiidStr) <- generateUniqueIID iid dbgL (printf "generating sources for %s" uiidStr)@@ -325,8 +334,8 @@ return (IG uiid instanceDir assembly) -- | Run an-runInstanceGenerator- :: IsB9 e => InstanceGenerator FilePath -> Eff e AssembledArtifact+runInstanceGenerator ::+ IsB9 e => InstanceGenerator FilePath -> Eff e AssembledArtifact runInstanceGenerator (IG uiid@(IID uiidStr) instanceDir assembly) = do targets <- runArtifactAssembly uiid instanceDir assembly dbgL (printf "assembled artifact %s" uiidStr)@@ -349,19 +358,20 @@ liftIO (writeTextFile toAbs result) runFilePermissionAction toAbs p -runFilePermissionAction- :: IsB9 e => FilePath -> FilePermissionAction -> Eff e ()+runFilePermissionAction ::+ IsB9 e => FilePath -> FilePermissionAction -> Eff e () runFilePermissionAction _ KeepPermissions = return () runFilePermissionAction f (ChangePermissions (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 -- boiling down 'ArtifactSource's to a flat list of uniform 'TextFileWriter's.-data TextFileWriter =- MkTextFileWriter Environment- TextFileWriterInput- FilePermissionAction- FilePath+data TextFileWriter+ = MkTextFileWriter+ Environment+ TextFileWriterInput+ FilePermissionAction+ FilePath deriving (Show, Eq) -- | Return the (internal-)output file of the source file that is generated.@@ -378,29 +388,34 @@ | KeepPermissions deriving (Read, Show, Typeable, Data, Eq) -setFilePermissionAction- :: Member ExcB9 e- => Int- -> Int- -> Int- -> TextFileWriter- -> Eff e TextFileWriter-setFilePermissionAction o g a (MkTextFileWriter env from KeepPermissions dest)- = pure (MkTextFileWriter env from (ChangePermissions (o, g, a)) dest)+setFilePermissionAction ::+ Member ExcB9 e =>+ Int ->+ Int ->+ Int ->+ TextFileWriter ->+ Eff e TextFileWriter+setFilePermissionAction o g a (MkTextFileWriter env from KeepPermissions dest) =+ pure (MkTextFileWriter env from (ChangePermissions (o, g, a)) dest) setFilePermissionAction o g a sg- | o < 0 || o > 7 = throwB9Error- (printf "Bad 'owner' permission %i in \n%s" o (ppShow sg))- | g < 0 || g > 7 = throwB9Error- (printf "Bad 'group' permission %i in \n%s" g (ppShow sg))- | a < 0 || a > 7 = throwB9Error- (printf "Bad 'all' permission %i in \n%s" a (ppShow sg))- | otherwise = throwB9Error- (printf "Permission for source already defined:\n %s" (ppShow sg))+ | o < 0 || o > 7 =+ throwB9Error+ (printf "Bad 'owner' permission %i in \n%s" o (ppShow sg))+ | g < 0 || g > 7 =+ throwB9Error+ (printf "Bad 'group' permission %i in \n%s" g (ppShow sg))+ | a < 0 || a > 7 =+ throwB9Error+ (printf "Bad 'all' permission %i in \n%s" a (ppShow sg))+ | otherwise =+ throwB9Error+ (printf "Permission for source already defined:\n %s" (ppShow sg)) prefixExternalSourcesPaths :: FilePath -> TextFileWriter -> TextFileWriter-prefixExternalSourcesPaths fromDir (MkTextFileWriter e (ExternalFiles fs) p d)- = MkTextFileWriter e (ExternalFiles (prefixExternalSourcePaths <$> fs)) p d- where prefixExternalSourcePaths (Source t f) = Source t (fromDir </> f)+prefixExternalSourcesPaths fromDir (MkTextFileWriter e (ExternalFiles fs) p d) =+ MkTextFileWriter e (ExternalFiles (prefixExternalSourcePaths <$> fs)) p d+ where+ prefixExternalSourcePaths (Source t f) = Source t (fromDir </> f) prefixExternalSourcesPaths _fromDir sg = sg prefixOutputFilePaths :: FilePath -> TextFileWriter -> TextFileWriter@@ -410,74 +425,78 @@ -- | Create the 'ArtifactTarget' from an 'ArtifactAssembly' in the directory @instanceDir@ -- -- @since 0.5.65-runArtifactAssembly- :: IsB9 e- => InstanceId- -> FilePath- -> ArtifactAssembly- -> Eff e [ArtifactTarget]+runArtifactAssembly ::+ IsB9 e =>+ InstanceId ->+ FilePath ->+ ArtifactAssembly ->+ Eff e [ArtifactTarget] runArtifactAssembly 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+ let err_msg = printf "Error creating 'VmImages' for instance '%s'" iidStr (IID iidStr) = iid unless success (errorL err_msg >> error err_msg) return [VmImagesTarget]-runArtifactAssembly _ instanceDir (CloudInit types outPath) = mapM create_- types- where- create_ CI_DIR = do- let ciDir = outPath- ensureDir (ciDir ++ "/")- dbgL (printf "creating directory '%s'" ciDir)- files <- getDirectoryFiles instanceDir- traceL (printf "copying files: %s" (show files))- liftIO- (mapM_- (\(f, t) -> do- ensureDir t- copyFile f t+runArtifactAssembly _ instanceDir (CloudInit types outPath) =+ mapM+ create_+ types+ where+ create_ CI_DIR = do+ let ciDir = outPath+ ensureDir (ciDir ++ "/")+ dbgL (printf "creating directory '%s'" ciDir)+ files <- getDirectoryFiles instanceDir+ traceL (printf "copying files: %s" (show files))+ liftIO+ ( mapM_+ ( \(f, t) -> do+ ensureDir t+ copyFile f t+ )+ (((instanceDir </>) &&& (ciDir </>)) <$> files) )- (((instanceDir </>) &&& (ciDir </>)) <$> files)- )- infoL (printf "CREATED CI_DIR: '%s'" (takeFileName ciDir))- return (CloudInitTarget CI_DIR ciDir)- create_ CI_ISO = do- buildDir <- getBuildDir- let isoFile = outPath <.> "iso"- tmpFile = buildDir </> takeFileName isoFile- ensureDir tmpFile- dbgL- (printf "creating cloud init iso temp image '%s', destination file: '%s"- tmpFile- isoFile- )- cmd- (printf "genisoimage -output '%s' -volid cidata -rock -d '%s' 2>&1"- tmpFile- instanceDir- )- dbgL (printf "moving iso image '%s' to '%s'" tmpFile isoFile)- ensureDir isoFile- liftIO (copyFile tmpFile isoFile)- infoL (printf "CREATED CI_ISO IMAGE: '%s'" (takeFileName isoFile))- return (CloudInitTarget CI_ISO isoFile)- create_ CI_VFAT = do- buildDir <- getBuildDir- let vfatFile = outPath <.> "vfat"- tmpFile = buildDir </> takeFileName vfatFile- ensureDir tmpFile- files <- map (instanceDir </>) <$> getDirectoryFiles instanceDir- dbgL (printf "creating cloud init vfat image '%s'" tmpFile)- traceL (printf "adding '%s'" (show files))- cmd (printf "truncate --size 2M '%s'" tmpFile)- cmd (printf "mkfs.vfat -n cidata '%s' 2>&1" tmpFile)- cmd- ( unwords (printf "mcopy -oi '%s' " tmpFile : (printf "'%s'" <$> files))- ++ " ::"- )- dbgL (printf "moving vfat image '%s' to '%s'" tmpFile vfatFile)- ensureDir vfatFile- liftIO (copyFile tmpFile vfatFile)- infoL (printf "CREATED CI_VFAT IMAGE: '%s'" (takeFileName vfatFile))- return (CloudInitTarget CI_ISO vfatFile)+ infoL (printf "CREATED CI_DIR: '%s'" (takeFileName ciDir))+ return (CloudInitTarget CI_DIR ciDir)+ create_ CI_ISO = do+ buildDir <- getBuildDir+ let isoFile = outPath <.> "iso"+ tmpFile = buildDir </> takeFileName isoFile+ ensureDir tmpFile+ dbgL+ ( printf+ "creating cloud init iso temp image '%s', destination file: '%s"+ tmpFile+ isoFile+ )+ cmd+ ( printf+ "genisoimage -output '%s' -volid cidata -rock -d '%s' 2>&1"+ tmpFile+ instanceDir+ )+ dbgL (printf "moving iso image '%s' to '%s'" tmpFile isoFile)+ ensureDir isoFile+ liftIO (copyFile tmpFile isoFile)+ infoL (printf "CREATED CI_ISO IMAGE: '%s'" (takeFileName isoFile))+ return (CloudInitTarget CI_ISO isoFile)+ create_ CI_VFAT = do+ buildDir <- getBuildDir+ let vfatFile = outPath <.> "vfat"+ tmpFile = buildDir </> takeFileName vfatFile+ ensureDir tmpFile+ files <- map (instanceDir </>) <$> getDirectoryFiles instanceDir+ dbgL (printf "creating cloud init vfat image '%s'" tmpFile)+ traceL (printf "adding '%s'" (show files))+ cmd (printf "truncate --size 2M '%s'" tmpFile)+ cmd (printf "mkfs.vfat -n cidata '%s' 2>&1" tmpFile)+ cmd+ ( unwords (printf "mcopy -oi '%s' " tmpFile : (printf "'%s'" <$> files))+ ++ " ::"+ )+ dbgL (printf "moving vfat image '%s' to '%s'" tmpFile vfatFile)+ ensureDir vfatFile+ liftIO (copyFile tmpFile vfatFile)+ infoL (printf "CREATED CI_VFAT IMAGE: '%s'" (takeFileName vfatFile))+ return (CloudInitTarget CI_ISO vfatFile)
src/lib/B9/Artifact/Readable/Source.hs view
@@ -2,47 +2,50 @@ -- -- @since 0.5.62 module B9.Artifact.Readable.Source- ( ArtifactSource(..)- , getArtifactSourceFiles+ ( ArtifactSource (..),+ getArtifactSourceFiles, ) where -import Control.Parallel.Strategies-import Data.Data-import GHC.Generics ( Generic )-import System.FilePath ( (</>) )--import B9.Artifact.Content.Readable-import B9.Artifact.Content.StringTemplate-import B9.QCUtil--import Test.QuickCheck+import B9.Artifact.Content.Readable+import B9.Artifact.Content.StringTemplate+import B9.QCUtil+import Control.Parallel.Strategies+import Data.Data+import GHC.Generics (Generic)+import System.FilePath ((</>))+import Test.QuickCheck -- | Describe how input files for artifacts to build are obtained. The general -- structure of each constructor is __FromXXX__ /destination/ /source/ data ArtifactSource- = FromFile FilePath- SourceFile- -- ^ Copy a 'B9.Artifact.Content.StringTemplate.SourceFile'- -- potentially replacing variable defined in 'Let'-like- -- parent elements.- | FromContent FilePath- Content- -- ^ Create a file from some 'Content'- | SetPermissions Int- Int- Int- [ArtifactSource]- -- ^ Set the unix /file permissions/ to all files generated- -- by the nested list of 'ArtifactSource's.- | FromDirectory FilePath- [ArtifactSource]- -- ^ Assume a local directory as starting point for all- -- relative source files in the nested 'ArtifactSource's.- | IntoDirectory FilePath- [ArtifactSource]- -- ^ Specify an output directory for all the files- -- generated by the nested 'ArtifactSource's+ = -- | Copy a 'B9.Artifact.Content.StringTemplate.SourceFile'+ -- potentially replacing variable defined in 'Let'-like+ -- parent elements.+ FromFile+ FilePath+ SourceFile+ | -- | Create a file from some 'Content'+ FromContent+ FilePath+ Content+ | -- | Set the unix /file permissions/ to all files generated+ -- by the nested list of 'ArtifactSource's.+ SetPermissions+ Int+ Int+ Int+ [ArtifactSource]+ | -- | Assume a local directory as starting point for all+ -- relative source files in the nested 'ArtifactSource's.+ FromDirectory+ FilePath+ [ArtifactSource]+ | -- | Specify an output directory for all the files+ -- generated by the nested 'ArtifactSource's+ IntoDirectory+ FilePath+ [ArtifactSource] deriving (Read, Show, Eq, Data, Typeable, Generic) instance NFData ArtifactSource@@ -50,7 +53,7 @@ -- | Return all source files generated by an 'ArtifactSource'. getArtifactSourceFiles :: ArtifactSource -> [FilePath] getArtifactSourceFiles (FromContent f _) = [f]-getArtifactSourceFiles (FromFile f _) = [f]+getArtifactSourceFiles (FromFile f _) = [f] getArtifactSourceFiles (IntoDirectory pd as) = (pd </>) <$> (as >>= getArtifactSourceFiles) getArtifactSourceFiles (FromDirectory _ as) = as >>= getArtifactSourceFiles@@ -58,14 +61,15 @@ as >>= getArtifactSourceFiles instance Arbitrary ArtifactSource where- arbitrary = oneof- [ FromFile <$> smaller arbitraryFilePath <*> smaller arbitrary- , FromContent <$> smaller arbitraryFilePath <*> smaller arbitrary- , SetPermissions- <$> choose (0, 7)- <*> choose (0, 7)- <*> choose (0, 7)- <*> smaller arbitrary- , FromDirectory <$> smaller arbitraryFilePath <*> smaller arbitrary- , IntoDirectory <$> smaller arbitraryFilePath <*> smaller arbitrary- ]+ arbitrary =+ oneof+ [ FromFile <$> smaller arbitraryFilePath <*> smaller arbitrary,+ FromContent <$> smaller arbitraryFilePath <*> smaller arbitrary,+ SetPermissions+ <$> choose (0, 7)+ <*> choose (0, 7)+ <*> choose (0, 7)+ <*> smaller arbitrary,+ FromDirectory <$> smaller arbitraryFilePath <*> smaller arbitrary,+ IntoDirectory <$> smaller arbitraryFilePath <*> smaller arbitrary+ ]
src/lib/B9/B9Config.hs view
@@ -1,102 +1,102 @@-{-|-Static B9 configuration. Read, write and merge configurable properties.-The properties are independent of specific build targets.--}+-- |+-- Static B9 configuration. Read, write and merge configurable properties.+-- The properties are independent of specific build targets. module B9.B9Config- ( B9Config(..)- , runB9ConfigReader- , B9ConfigReader- , getB9Config- , getExecEnvType- , getConfig- , getLogVerbosity- , getProjectRoot- , getRemoteRepos- , isInteractive- , B9ConfigWriter- , verbosity- , logFile- , projectRoot- , keepTempDirs- , execEnvType- , uniqueBuildDirs- , repositoryCache- , repository- , interactive- , libVirtLXCConfigs- , remoteRepos- , maxLocalSharedImageRevisions- , B9ConfigOverride(..)- , noB9ConfigOverride- , B9ConfigAction()- , runB9ConfigActionWithOverrides- , runB9ConfigAction- , localB9Config- , modifyPermanentConfig- , customB9Config- , customB9ConfigPath- , customEnvironment- , overrideB9ConfigPath- , overrideB9Config- , overrideWorkingDirectory- , overrideVerbosity- , overrideKeepBuildDirs- , defaultB9ConfigFile- , defaultRepositoryCache- , defaultB9Config- , openOrCreateB9Config- , writeB9CPDocument- , readB9Config- , parseB9Config- , modifyCPDocument- , b9ConfigToCPDocument- , LogLevel(..)- , ExecEnvType(..)- , Environment- , module X- ) where+ ( B9Config (..),+ runB9ConfigReader,+ B9ConfigReader,+ getB9Config,+ getConfig,+ getLogVerbosity,+ getProjectRoot,+ getRemoteRepos,+ isInteractive,+ B9ConfigWriter,+ verbosity,+ logFile,+ projectRoot,+ keepTempDirs,+ uniqueBuildDirs,+ repositoryCache,+ repository,+ interactive,+ libVirtLXCConfigs,+ dockerConfigs,+ podmanConfigs,+ systemdNspawnConfigs,+ remoteRepos,+ maxLocalSharedImageRevisions,+ B9ConfigOverride (..),+ noB9ConfigOverride,+ B9ConfigAction (),+ runB9ConfigActionWithOverrides,+ runB9ConfigAction,+ localB9Config,+ modifyPermanentConfig,+ customB9Config,+ customB9ConfigPath,+ customEnvironment,+ overrideB9ConfigPath,+ overrideB9Config,+ overrideWorkingDirectory,+ overrideVerbosity,+ overrideKeepBuildDirs,+ defaultB9ConfigFile,+ defaultRepositoryCache,+ defaultB9Config,+ openOrCreateB9Config,+ writeB9CPDocument,+ readB9Config,+ parseB9Config,+ modifyCPDocument,+ b9ConfigToCPDocument,+ LogLevel (..),+ Environment,+ module X,+ )+where +import B9.B9Config.Container as X+import B9.B9Config.Docker as X import B9.B9Config.LibVirtLXC as X+import B9.B9Config.Podman as X import B9.B9Config.Repository as X+import B9.B9Config.SystemdNspawn as X import B9.Environment import Control.Eff import Control.Eff.Reader.Lazy import Control.Eff.Writer.Lazy import Control.Exception-import Control.Lens as Lens ((?~), (^.), makeLenses, set, (<>~))+import Control.Lens as Lens ((<>~), (?~), (^.), makeLenses, set) import Control.Monad ((>=>), filterM) import Control.Monad.IO.Class import Data.ConfigFile.B9Extras- ( CPDocument- , CPError- , CPGet- , CPOptionSpec- , CPReadException(..)- , addSectionCP- , emptyCP- , mergeCP- , readCP- , readCPDocument- , setShowCP- , toStringCP+ ( CPDocument,+ CPError,+ CPGet,+ CPOptionSpec,+ CPReadException (..),+ addSectionCP,+ emptyCP,+ mergeCP,+ readCP,+ readCPDocument,+ setShowCP,+ toStringCP, ) import Data.Function (on) import Data.List (inits)-import Data.Maybe (fromMaybe, listToMaybe, maybeToList)+import Data.Maybe (fromMaybe) import Data.Monoid-import Data.Semigroup as Semigroup hiding (Last(..))+import Data.Semigroup as Semigroup hiding (Last (..)) import Data.Version+import GHC.Stack import qualified Paths_b9 as My import System.Directory import System.FilePath ((<.>))-import System.IO.B9Extras (SystemPath(..), ensureDir, resolve)+import System.IO.B9Extras (SystemPath (..), ensureDir, resolve) import Text.Printf (printf)-import GHC.Stack -data ExecEnvType =- LibVirtLXC- deriving (Eq, Show, Ord, Read)- data LogLevel = LogTrace | LogDebug@@ -105,41 +105,47 @@ | LogNothing deriving (Eq, Show, Ord, Read) -data B9Config = B9Config- { _verbosity :: Maybe LogLevel- , _logFile :: Maybe FilePath- , _projectRoot :: Maybe FilePath- , _keepTempDirs :: Bool- , _execEnvType :: ExecEnvType- , _uniqueBuildDirs :: Bool- , _repositoryCache :: Maybe SystemPath- , _repository :: Maybe String- , _interactive :: Bool- , _maxLocalSharedImageRevisions :: Maybe Int- , _libVirtLXCConfigs :: Maybe LibVirtLXCConfig- , _remoteRepos :: [RemoteRepo]- } deriving (Show, Eq)+data B9Config+ = B9Config+ { _verbosity :: Maybe LogLevel,+ _logFile :: Maybe FilePath,+ _projectRoot :: Maybe FilePath,+ _keepTempDirs :: Bool,+ _uniqueBuildDirs :: Bool,+ _repositoryCache :: Maybe SystemPath,+ _repository :: Maybe String,+ _interactive :: Bool,+ _maxLocalSharedImageRevisions :: Maybe Int,+ _systemdNspawnConfigs :: Maybe SystemdNspawnConfig,+ _podmanConfigs :: Maybe PodmanConfig,+ _dockerConfigs :: Maybe DockerConfig,+ _libVirtLXCConfigs :: Maybe LibVirtLXCConfig,+ _remoteRepos :: [RemoteRepo]+ }+ deriving (Show, Eq) instance Semigroup B9Config where c <> c' = B9Config- { _verbosity = getLast $ on mappend (Last . _verbosity) c c'- , _logFile = getLast $ on mappend (Last . _logFile) c c'- , _projectRoot = getLast $ on mappend (Last . _projectRoot) c c'- , _keepTempDirs = getAny $ on mappend (Any . _keepTempDirs) c c'- , _execEnvType = LibVirtLXC- , _uniqueBuildDirs = getAll ((mappend `on` (All . _uniqueBuildDirs)) c c')- , _repositoryCache = getLast $ on mappend (Last . _repositoryCache) c c'- , _repository = getLast ((mappend `on` (Last . _repository)) c c')- , _interactive = getAny ((mappend `on` (Any . _interactive)) c c')- , _maxLocalSharedImageRevisions = getLast ((mappend `on` (Last . _maxLocalSharedImageRevisions)) c c')- , _libVirtLXCConfigs = getLast ((mappend `on` (Last . _libVirtLXCConfigs)) c c')- , _remoteRepos = (mappend `on` _remoteRepos) c c'+ { _verbosity = getLast $ on mappend (Last . _verbosity) c c',+ _logFile = getLast $ on mappend (Last . _logFile) c c',+ _projectRoot = getLast $ on mappend (Last . _projectRoot) c c',+ _keepTempDirs = getAny $ on mappend (Any . _keepTempDirs) c c',+ _uniqueBuildDirs = getAll ((mappend `on` (All . _uniqueBuildDirs)) c c'),+ _repositoryCache = getLast $ on mappend (Last . _repositoryCache) c c',+ _repository = getLast ((mappend `on` (Last . _repository)) c c'),+ _interactive = getAny ((mappend `on` (Any . _interactive)) c c'),+ _maxLocalSharedImageRevisions = getLast ((mappend `on` (Last . _maxLocalSharedImageRevisions)) c c'),+ _systemdNspawnConfigs = getLast ((mappend `on` (Last . _systemdNspawnConfigs)) c c'),+ _podmanConfigs = getLast ((mappend `on` (Last . _podmanConfigs)) c c'),+ _dockerConfigs = getLast ((mappend `on` (Last . _dockerConfigs)) c c'),+ _libVirtLXCConfigs = getLast ((mappend `on` (Last . _libVirtLXCConfigs)) c c'),+ _remoteRepos = (mappend `on` _remoteRepos) c c' } instance Monoid B9Config where mappend = (<>)- mempty = B9Config Nothing Nothing Nothing False LibVirtLXC True Nothing Nothing False Nothing Nothing []+ mempty = B9Config Nothing Nothing Nothing False True Nothing Nothing False Nothing Nothing Nothing Nothing Nothing [] -- | Reader for 'B9Config'. See 'getB9Config' and 'localB9Config'. --@@ -181,12 +187,6 @@ isInteractive :: Member B9ConfigReader e => Eff e Bool isInteractive = _interactive <$> getB9Config --- | Ask for the 'ExecEnvType'.------ @since 0.5.65-getExecEnvType :: Member B9ConfigReader e => Eff e ExecEnvType-getExecEnvType = _execEnvType <$> getB9Config- -- | Ask for the 'RemoteRepo's. -- -- @since 0.5.65@@ -207,18 +207,19 @@ -- | Override b9 configuration items and/or the path of the b9 configuration file. -- This is useful, i.e. when dealing with command line parameters.-data B9ConfigOverride = B9ConfigOverride- { _customB9ConfigPath :: Maybe SystemPath- , _customB9Config :: Endo B9Config- , _customEnvironment :: Environment- }+data B9ConfigOverride+ = B9ConfigOverride+ { _customB9ConfigPath :: Maybe SystemPath,+ _customB9Config :: Endo B9Config,+ _customEnvironment :: Environment+ } instance Show B9ConfigOverride where show x = unlines- [ "config file path: " ++ show (_customB9ConfigPath x)- , "config modification: " ++ show (appEndo (_customB9Config x) mempty)- , "environment: " ++ show (_customEnvironment x)+ [ "config file path: " ++ show (_customB9ConfigPath x),+ "config modification: " ++ show (appEndo (_customB9Config x) mempty),+ "environment: " ++ show (_customEnvironment x) ] -- | An empty default 'B9ConfigOverride' value, that will neither apply any@@ -257,7 +258,7 @@ -- 'B9ConfigReader' and 'IO'. -- -- @since 0.5.65-type B9ConfigAction a = Eff '[ B9ConfigWriter, B9ConfigReader, EnvironmentReader, Lift IO] a+type B9ConfigAction a = Eff '[B9ConfigWriter, B9ConfigReader, EnvironmentReader, Lift IO] a -- | Accumulate 'B9Config' changes that go back to the config file. See -- 'B9ConfigAction' and 'modifyPermanentConfig'.@@ -285,18 +286,30 @@ -- @since 0.5.65 runB9ConfigActionWithOverrides :: HasCallStack => B9ConfigAction a -> B9ConfigOverride -> IO a runB9ConfigActionWithOverrides act cfg = do- configuredCfgPath <- traverse resolve (cfg ^. customB9ConfigPath)- fallbackCfgPath <- resolve defaultB9ConfigFile- let cfgPathCandidates =- case My.version of- Version v _ ->- concatMap- (\c -> (\v' -> c <.> showVersion (makeVersion v')) <$> reverse (inits v))- (maybeToList configuredCfgPath) ++- ((\v' -> fallbackCfgPath <.> showVersion (makeVersion v')) <$> reverse (inits v))- pathToCreate = fromMaybe fallbackCfgPath configuredCfgPath- existingCfgPaths <- filterM doesFileExist cfgPathCandidates- let cfgPath = fromMaybe pathToCreate (listToMaybe existingCfgPaths)+ configuredCfgPaths <- traverse resolve (cfg ^. customB9ConfigPath)+ defCfgPath <- resolve defaultB9ConfigFile+ let (Version myVer _) = My.version+ appendVersionVariations name =+ (\v' -> name <.> showVersion (makeVersion v')) <$> reverse (inits myVer)+ (pathsToTry, pathsToCreate) =+ case configuredCfgPaths of+ Just configuredCfgPath ->+ (appendVersionVariations configuredCfgPath, Nothing)+ Nothing ->+ (appendVersionVariations defCfgPath, Just defCfgPath)+ existingCfgPaths <- filterM doesFileExist pathsToTry+ cfgPath <-+ case existingCfgPaths of+ (cfgPath : _) ->+ return cfgPath+ [] -> do+ putStrLn ("B9 config file resolver: None of these files exists " ++ show pathsToTry)+ case pathsToCreate of+ Just c -> do+ putStrLn ("creating a new config file with defaults at: " ++ c)+ return c+ Nothing ->+ fail "Please provide a valid config file path." cp <- openOrCreateB9Config cfgPath case parseB9Config cp of Left e -> fail (printf "Internal configuration load error, please report this: %s\n" (show e))@@ -334,10 +347,11 @@ exists <- doesFileExist cfgFile if exists then readCPDocument (Path cfgFile)- else let res = b9ConfigToCPDocument defaultB9Config- in case res of- Left e -> throwIO (CPReadException cfgFile e)- Right cp -> writeFile cfgFile (toStringCP cp) >> return cp+ else+ let res = b9ConfigToCPDocument defaultB9Config+ in case res of+ Left e -> throwIO (CPReadException cfgFile e)+ Right cp -> writeFile cfgFile (toStringCP cp) >> return cp -- | Write the configuration in the 'CPDocument' to either the user supplied -- configuration file path or to 'defaultB9ConfigFile'.@@ -351,18 +365,20 @@ defaultB9Config :: B9Config defaultB9Config = B9Config- { _verbosity = Just LogInfo- , _logFile = Nothing- , _projectRoot = Nothing- , _keepTempDirs = False- , _execEnvType = LibVirtLXC- , _uniqueBuildDirs = True- , _repository = Nothing- , _repositoryCache = Just defaultRepositoryCache- , _interactive = False- , _maxLocalSharedImageRevisions = Just 2- , _libVirtLXCConfigs = Just defaultLibVirtLXCConfig- , _remoteRepos = []+ { _verbosity = Just LogInfo,+ _logFile = Nothing,+ _projectRoot = Nothing,+ _keepTempDirs = False,+ _uniqueBuildDirs = True,+ _repository = Nothing,+ _repositoryCache = Just defaultRepositoryCache,+ _interactive = False,+ _maxLocalSharedImageRevisions = Just 2,+ _systemdNspawnConfigs = Just defaultSystemdNspawnConfig,+ _podmanConfigs = Just defaultPodmanConfig,+ _libVirtLXCConfigs = Just defaultLibVirtLXCConfig,+ _dockerConfigs = Just defaultDockerConfig,+ _remoteRepos = [] } defaultRepositoryCache :: SystemPath@@ -383,9 +399,6 @@ keepTempDirsK :: String keepTempDirsK = "keep_temp_dirs" -execEnvTypeK :: String-execEnvTypeK = "exec_env"- uniqueBuildDirsK :: String uniqueBuildDirsK = "unique_build_dirs" @@ -416,12 +429,14 @@ cp3 <- setShowCP cp2 cfgFileSection logFileK (_logFile c) cp4 <- setShowCP cp3 cfgFileSection projectRootK (_projectRoot c) cp5 <- setShowCP cp4 cfgFileSection keepTempDirsK (_keepTempDirs c)- cp6 <- setShowCP cp5 cfgFileSection execEnvTypeK (_execEnvType c)- cp7 <- setShowCP cp6 cfgFileSection uniqueBuildDirsK (_uniqueBuildDirs c)+ cp7 <- setShowCP cp5 cfgFileSection uniqueBuildDirsK (_uniqueBuildDirs c) cp8 <- setShowCP cp7 cfgFileSection maxLocalSharedImageRevisionsK (_maxLocalSharedImageRevisions c) cp9 <- setShowCP cp8 cfgFileSection repositoryCacheK (_repositoryCache c)- cpA <- foldr (>=>) return (libVirtLXCConfigToCPDocument <$> _libVirtLXCConfigs c) cp9- cpFinal <- foldr (>=>) return (remoteRepoToCPDocument <$> _remoteRepos c) cpA+ cpA <- foldr (>=>) return (systemdNspawnConfigToCPDocument <$> _systemdNspawnConfigs c) cp9+ cpB <- foldr (>=>) return (podmanConfigToCPDocument <$> _podmanConfigs c) cpA+ cpC <- foldr (>=>) return (dockerConfigToCPDocument <$> _dockerConfigs c) cpB+ cpD <- foldr (>=>) return (libVirtLXCConfigToCPDocument <$> _libVirtLXCConfigs c) cpC+ cpFinal <- foldr (>=>) return (remoteRepoToCPDocument <$> _remoteRepos c) cpD setShowCP cpFinal cfgFileSection repositoryK (_repository c) readB9Config :: (HasCallStack, MonadIO m) => Maybe SystemPath -> m CPDocument@@ -431,11 +446,14 @@ parseB9Config cp = let getr :: (CPGet a) => CPOptionSpec -> Either CPError a getr = readCP cp cfgFileSection- in B9Config <$> getr verbosityK <*> getr logFileK <*> getr projectRootK <*> getr keepTempDirsK <*> getr execEnvTypeK <*>- getr uniqueBuildDirsK <*>- getr repositoryCacheK <*>- getr repositoryK <*>- pure False <*>- pure (either (const Nothing) id (getr maxLocalSharedImageRevisionsK)) <*>- pure (either (const Nothing) Just (parseLibVirtLXCConfig cp)) <*>- parseRemoteRepos cp+ in B9Config <$> getr verbosityK <*> getr logFileK <*> getr projectRootK <*> getr keepTempDirsK+ <*> getr uniqueBuildDirsK+ <*> getr repositoryCacheK+ <*> getr repositoryK+ <*> pure False+ <*> pure (either (const Nothing) id (getr maxLocalSharedImageRevisionsK))+ <*> pure (either (const Nothing) Just (parseSystemdNspawnConfig cp))+ <*> pure (either (const Nothing) Just (parsePodmanConfig cp))+ <*> pure (either (const Nothing) Just (parseDockerConfig cp))+ <*> pure (either (const Nothing) Just (parseLibVirtLXCConfig cp))+ <*> parseRemoteRepos cp
+ src/lib/B9/B9Config/Container.hs view
@@ -0,0 +1,64 @@+module B9.B9Config.Container+ ( parseContainerCapabilities,+ ContainerCapability (..),+ containerCapsToCPDocument,+ )+where++import Data.ConfigFile.B9Extras++-- | Available capabilities for Linux containers. This maps directly to the+-- capabilities defined in 'man 7 capabilities'.+data ContainerCapability+ = 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, Eq)++containerCapabilitiesK :: String+containerCapabilitiesK = "guest_capabilities"++containerCapsToCPDocument ::+ CPDocument -> CPSectionSpec -> [ContainerCapability] -> Either CPError CPDocument+containerCapsToCPDocument cp cfgFileSection c =+ setShowCP cp cfgFileSection containerCapabilitiesK c++parseContainerCapabilities :: CPDocument -> CPSectionSpec -> Either CPError [ContainerCapability]+parseContainerCapabilities cp cfgFileSection =+ readCP cp cfgFileSection containerCapabilitiesK+-- TODO make a generic container config data type
+ src/lib/B9/B9Config/Docker.hs view
@@ -0,0 +1,61 @@+module B9.B9Config.Docker+ ( dockerConfigToCPDocument,+ defaultDockerConfig,+ parseDockerConfig,+ DockerConfig (..),+ dockerNetworkId,+ dockerCapabilities,+ )+where++import B9.B9Config.Container+import Control.Lens (makeLenses)+import Data.ConfigFile.B9Extras++data DockerConfig+ = DockerConfig+ { _dockerNetworkId :: Maybe String,+ _dockerCapabilities :: [ContainerCapability]+ }+ deriving (Read, Show, Eq)++makeLenses ''DockerConfig++defaultDockerConfig :: DockerConfig+defaultDockerConfig =+ DockerConfig+ 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 = "docker"++networkIdK :: String+networkIdK = "network"++dockerConfigToCPDocument ::+ DockerConfig -> CPDocument -> Either CPError CPDocument+dockerConfigToCPDocument c cp = do+ cp1 <- addSectionCP cp cfgFileSection+ cp2 <-+ setShowCP cp1 cfgFileSection networkIdK $+ _dockerNetworkId c+ containerCapsToCPDocument cp2 cfgFileSection $+ _dockerCapabilities c++parseDockerConfig :: CPDocument -> Either CPError DockerConfig+parseDockerConfig cp =+ let getr :: (CPGet a) => CPOptionSpec -> Either CPError a+ getr = readCP cp cfgFileSection+ in DockerConfig+ <$> getr networkIdK+ <*> parseContainerCapabilities cp cfgFileSection
src/lib/B9/B9Config/LibVirtLXC.hs view
@@ -1,92 +1,53 @@ module B9.B9Config.LibVirtLXC- ( libVirtLXCConfigToCPDocument- , defaultLibVirtLXCConfig- , parseLibVirtLXCConfig- , LibVirtLXCConfig(..)- , networkId- , LXCGuestCapability(..)- , getEmulatorPath+ ( libVirtLXCConfigToCPDocument,+ defaultLibVirtLXCConfig,+ parseLibVirtLXCConfig,+ LibVirtLXCConfig (..),+ networkId,+ getEmulatorPath, ) where -import B9.DiskImages-import B9.ExecEnv-import Control.Lens ( makeLenses )-import Data.ConfigFile.B9Extras-import Control.Monad.IO.Class-import System.Environment.Blank as SysIO--data LibVirtLXCConfig = LibVirtLXCConfig- { useSudo :: Bool- , emulator :: Maybe FilePath- , virshURI :: FilePath- , _networkId :: Maybe String- , guestCapabilities :: [LXCGuestCapability]- , guestRamSize :: RamSize- } deriving (Read, Show, Eq)+import B9.B9Config.Container+import B9.DiskImages+import B9.ExecEnv+import Control.Lens (makeLenses)+import Control.Monad.IO.Class+import Data.ConfigFile.B9Extras+import Data.Maybe (fromMaybe)+import System.Environment.Blank as SysIO --- | Available linux capabilities for lxc containers. This maps directly to the--- capabilities defined in 'man 7 capabilities'.-data LXCGuestCapability- = CAP_MKNOD- | CAP_AUDIT_CONTROL- | CAP_AUDIT_READ- | CAP_AUDIT_WRITE- | CAP_BLOCK_SUSPEND- | CAP_CHOWN- | CAP_DAC_OVERRIDE- | CAP_DAC_READ_SEARCH- | CAP_FOWNER- | CAP_FSETID- | CAP_IPC_LOCK- | CAP_IPC_OWNER- | CAP_KILL- | CAP_LEASE- | CAP_LINUX_IMMUTABLE- | CAP_MAC_ADMIN- | CAP_MAC_OVERRIDE- | CAP_NET_ADMIN- | CAP_NET_BIND_SERVICE- | CAP_NET_BROADCAST- | CAP_NET_RAW- | CAP_SETGID- | CAP_SETFCAP- | CAP_SETPCAP- | CAP_SETUID- | CAP_SYS_ADMIN- | CAP_SYS_BOOT- | CAP_SYS_CHROOT- | CAP_SYS_MODULE- | CAP_SYS_NICE- | CAP_SYS_PACCT- | CAP_SYS_PTRACE- | CAP_SYS_RAWIO- | CAP_SYS_RESOURCE- | CAP_SYS_TIME- | CAP_SYS_TTY_CONFIG- | CAP_SYSLOG- | CAP_WAKE_ALARM+data LibVirtLXCConfig+ = LibVirtLXCConfig+ { useSudo :: Bool,+ emulator :: Maybe FilePath,+ virshURI :: FilePath,+ _networkId :: Maybe String,+ guestCapabilities :: [ContainerCapability],+ guestRamSize :: RamSize+ } deriving (Read, Show, Eq) makeLenses ''LibVirtLXCConfig defaultLibVirtLXCConfig :: LibVirtLXCConfig-defaultLibVirtLXCConfig = LibVirtLXCConfig- True- (Just "/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- ]- (RamSize 1 GB)+defaultLibVirtLXCConfig =+ LibVirtLXCConfig+ True+ (Just "/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+ ]+ (RamSize 1 GB) cfgFileSection :: String cfgFileSection = "libvirt-lxc"@@ -108,33 +69,30 @@ networkIdK :: String networkIdK = "network" -guestCapabilitiesK :: String-guestCapabilitiesK = "guest_capabilities"- guestRamSizeK :: String guestRamSizeK = "guest_ram_size" -libVirtLXCConfigToCPDocument- :: LibVirtLXCConfig -> CPDocument -> Either CPError CPDocument+libVirtLXCConfigToCPDocument ::+ LibVirtLXCConfig -> CPDocument -> Either CPError CPDocument libVirtLXCConfigToCPDocument c cp = do cp1 <- addSectionCP cp cfgFileSection cp2 <- setShowCP cp1 cfgFileSection useSudoK $ useSudo c cp3 <- setShowCP cp2 cfgFileSection emulatorK $ emulator c cp4 <- setCP cp3 cfgFileSection virshURIK $ virshURI c cp5 <- setShowCP cp4 cfgFileSection networkIdK $ _networkId c- cp6 <- setShowCP cp5 cfgFileSection guestCapabilitiesK $ guestCapabilities c+ cp6 <- containerCapsToCPDocument cp5 cfgFileSection $ guestCapabilities c setShowCP cp6 cfgFileSection guestRamSizeK $ guestRamSize c parseLibVirtLXCConfig :: CPDocument -> Either CPError LibVirtLXCConfig parseLibVirtLXCConfig cp = let getr :: (CPGet a) => CPOptionSpec -> Either CPError a getr = readCP cp cfgFileSection- in LibVirtLXCConfig+ in LibVirtLXCConfig <$> getr useSudoK <*> getr emulatorK <*> getr virshURIK <*> getr networkIdK- <*> getr guestCapabilitiesK+ <*> parseContainerCapabilities cp cfgFileSection <*> getr guestRamSizeK -- | Return the path to @/usr/lib/libvirt/libexec/libvirt_lxc@@@ -144,7 +102,7 @@ -- -- @since 0.5.66 getEmulatorPath :: MonadIO m => LibVirtLXCConfig -> m FilePath-getEmulatorPath cfg = maybe fromEnv return (emulator cfg)- where- fromEnv =- liftIO (SysIO.getEnvDefault emulatorEnvVar "/usr/lib/libexec/libvirt_lxc")+getEmulatorPath cfg =+ liftIO (SysIO.getEnvDefault emulatorEnvVar fromCfgOrDefault)+ where+ fromCfgOrDefault = fromMaybe "/usr/lib/libexec/libvirt_lxc" (emulator cfg)
+ src/lib/B9/B9Config/Podman.hs view
@@ -0,0 +1,61 @@+module B9.B9Config.Podman+ ( podmanConfigToCPDocument,+ defaultPodmanConfig,+ parsePodmanConfig,+ PodmanConfig (..),+ podmanNetworkId,+ podmanCapabilities,+ )+where++import B9.B9Config.Container+import Control.Lens (makeLenses)+import Data.ConfigFile.B9Extras++data PodmanConfig+ = PodmanConfig+ { _podmanNetworkId :: Maybe String,+ _podmanCapabilities :: [ContainerCapability]+ }+ deriving (Read, Show, Eq)++makeLenses ''PodmanConfig++defaultPodmanConfig :: PodmanConfig+defaultPodmanConfig =+ PodmanConfig+ 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 = "podman"++networkIdK :: String+networkIdK = "network"++podmanConfigToCPDocument ::+ PodmanConfig -> CPDocument -> Either CPError CPDocument+podmanConfigToCPDocument c cp = do+ cp1 <- addSectionCP cp cfgFileSection+ cp2 <-+ setShowCP cp1 cfgFileSection networkIdK $+ _podmanNetworkId c+ containerCapsToCPDocument cp2 cfgFileSection $+ _podmanCapabilities c++parsePodmanConfig :: CPDocument -> Either CPError PodmanConfig+parsePodmanConfig cp =+ let getr :: (CPGet a) => CPOptionSpec -> Either CPError a+ getr = readCP cp cfgFileSection+ in PodmanConfig+ <$> getr networkIdK+ <*> parseContainerCapabilities cp cfgFileSection
src/lib/B9/B9Config/Repository.hs view
@@ -1,27 +1,29 @@ module B9.B9Config.Repository- ( RemoteRepo(..)- , remoteRepoRepoId- , RepoCache(..)- , SshPrivKey(..)- , SshRemoteHost(..)- , SshRemoteUser(..)- , remoteRepoToCPDocument- , parseRemoteRepos+ ( RemoteRepo (..),+ remoteRepoRepoId,+ RepoCache (..),+ SshPrivKey (..),+ SshRemoteHost (..),+ SshRemoteUser (..),+ remoteRepoToCPDocument,+ parseRemoteRepos, ) where -import Data.Data-import Data.List ( isSuffixOf )-import Data.ConfigFile.B9Extras+import Data.ConfigFile.B9Extras+import Data.Data+import Data.List (isSuffixOf) newtype RepoCache = RepoCache FilePath deriving (Read, Show, Typeable, Data) -data RemoteRepo = RemoteRepo String- FilePath- SshPrivKey- SshRemoteHost- SshRemoteUser+data RemoteRepo+ = RemoteRepo+ String+ FilePath+ SshPrivKey+ SshRemoteHost+ SshRemoteUser deriving (Read, Show, Typeable, Data, Eq) remoteRepoRepoId :: RemoteRepo -> String@@ -30,64 +32,68 @@ newtype SshPrivKey = SshPrivKey FilePath deriving (Read, Show, Typeable, Data, Eq) -newtype SshRemoteHost = SshRemoteHost (String,Int)+newtype SshRemoteHost = SshRemoteHost (String, Int) deriving (Read, Show, Typeable, Data, Eq) newtype SshRemoteUser = SshRemoteUser String deriving (Read, Show, Typeable, Data, Eq) - -- | Persist a repo to a configuration file. remoteRepoToCPDocument :: RemoteRepo -> CPDocument -> Either CPError CPDocument remoteRepoToCPDocument repo cpIn = cpWithRepo- where- section = repoId ++ repoSectionSuffix- (RemoteRepo repoId remoteRootDir (SshPrivKey keyFile) (SshRemoteHost (host, port)) (SshRemoteUser user))- = repo- cpWithRepo = do- cp1 <- addSectionCP cpIn section- cp2 <- setCP cp1 section repoRemotePathK remoteRootDir- cp3 <- setCP cp2 section repoRemoteSshKeyK keyFile- cp4 <- setCP cp3 section repoRemoteSshHostK host- cp5 <- setShowCP cp4 section repoRemoteSshPortK port- setCP cp5 section repoRemoteSshUserK user+ where+ section = repoId ++ repoSectionSuffix+ (RemoteRepo repoId remoteRootDir (SshPrivKey keyFile) (SshRemoteHost (host, port)) (SshRemoteUser user)) =+ repo+ cpWithRepo = do+ cp1 <- addSectionCP cpIn section+ cp2 <- setCP cp1 section repoRemotePathK remoteRootDir+ cp3 <- setCP cp2 section repoRemoteSshKeyK keyFile+ cp4 <- setCP cp3 section repoRemoteSshHostK host+ cp5 <- setShowCP cp4 section repoRemoteSshPortK port+ setCP cp5 section repoRemoteSshUserK user -- | Load a repository from a configuration file that has been written by -- 'writeRepositoryToB9Config'. parseRemoteRepos :: CPDocument -> Either CPError [RemoteRepo] parseRemoteRepos cp = traverse parseRepoSection repoSections- where- repoSections = filter (repoSectionSuffix `isSuffixOf`) (sectionsCP cp)- parseRepoSection section = parseResult- where- getsec :: CPGet a => CPOptionSpec -> Either CPError a- getsec = readCP cp section- parseResult =- RemoteRepo repoId- <$> getsec repoRemotePathK- <*> (SshPrivKey <$> getsec repoRemoteSshKeyK)- <*> ( SshRemoteHost- <$> ( (,)- <$> getsec repoRemoteSshHostK- <*> getsec repoRemoteSshPortK+ where+ repoSections = filter (repoSectionSuffix `isSuffixOf`) (sectionsCP cp)+ parseRepoSection section = parseResult+ where+ getsec :: CPGet a => CPOptionSpec -> Either CPError a+ getsec = readCP cp section+ parseResult =+ 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+ <*> (SshRemoteUser <$> getsec repoRemoteSshUserK)+ where+ repoId =+ let prefixLen = length section - suffixLen+ suffixLen = length repoSectionSuffix+ in take prefixLen section repoSectionSuffix :: String repoSectionSuffix = "-repo"+ repoRemotePathK :: String repoRemotePathK = "remote_path"+ repoRemoteSshKeyK :: String repoRemoteSshKeyK = "ssh_priv_key_file"+ repoRemoteSshHostK :: String repoRemoteSshHostK = "ssh_remote_host"+ repoRemoteSshPortK :: String repoRemoteSshPortK = "ssh_remote_port"+ repoRemoteSshUserK :: String repoRemoteSshUserK = "ssh_remote_user"
+ src/lib/B9/B9Config/SystemdNspawn.hs view
@@ -0,0 +1,129 @@+module B9.B9Config.SystemdNspawn+ ( systemdNspawnConfigToCPDocument,+ defaultSystemdNspawnConfig,+ parseSystemdNspawnConfig,+ SystemdNspawnConfig (..),+ SystemdNspawnConsole (..),+ systemdNspawnCapabilities,+ systemdNspawnUseSudo,+ systemdNspawnMaxLifetimeSeconds,+ systemdNspawnExtraArgs,+ systemdNspawnExecutable,+ systemdNspawnConsole,+ )+where++import B9.B9Config.Container+import Control.Lens (makeLenses)+import Data.ConfigFile.B9Extras+import qualified Text.ParserCombinators.ReadP as ReadP+import qualified Text.ParserCombinators.ReadPrec as ReadPrec+import Text.Read++-- TODO document b9 config file+data SystemdNspawnConfig+ = SystemdNspawnConfig+ { _systemdNspawnCapabilities :: [ContainerCapability],+ _systemdNspawnUseSudo :: Bool,+ _systemdNspawnMaxLifetimeSeconds :: Maybe Int,+ _systemdNspawnExtraArgs :: Maybe String,+ _systemdNspawnExecutable :: Maybe FilePath,+ _systemdNspawnConsole :: SystemdNspawnConsole+ }+ deriving (Read, Show, Eq)++data SystemdNspawnConsole+ = SystemdNspawnInteractive+ | SystemdNspawnReadOnly+ | SystemdNspawnPassive+ | SystemdNspawnPipe+ deriving (Eq)++instance Show SystemdNspawnConsole where+ show x = case x of+ SystemdNspawnInteractive -> "interactive"+ SystemdNspawnReadOnly -> "read-only"+ SystemdNspawnPassive -> "passive"+ SystemdNspawnPipe -> "pipe"++instance Read SystemdNspawnConsole where+ readPrec =+ do+ Ident "interactive" <- lexP+ return SystemdNspawnInteractive+ +++ ReadPrec.lift+ ( do+ ReadP.skipSpaces+ _ <- ReadP.string "read-only"+ return SystemdNspawnReadOnly+ )+ +++ do+ Ident "passive" <- lexP+ return SystemdNspawnPassive+ +++ do+ Ident "pipe" <- lexP+ return SystemdNspawnReadOnly++makeLenses ''SystemdNspawnConfig++defaultSystemdNspawnConfig :: SystemdNspawnConfig+defaultSystemdNspawnConfig =+ SystemdNspawnConfig+ [ CAP_MKNOD,+ CAP_SYS_ADMIN,+ CAP_SYS_CHROOT,+ CAP_SETGID,+ CAP_SETUID,+ CAP_NET_BIND_SERVICE,+ CAP_SETPCAP,+ CAP_SYS_PTRACE,+ CAP_SYS_MODULE+ ]+ True+ (Just (4 * 3600))+ Nothing+ Nothing+ SystemdNspawnReadOnly++cfgFileSection :: String+cfgFileSection = "systemdNspawn"++useSudoK :: String+useSudoK = "use_sudo"++maxLifetimeSecondsK :: String+maxLifetimeSecondsK = "max_lifetime_seconds"++extraArgsK :: String+extraArgsK = "extra_args"++executableK :: String+executableK = "executable"++consoleK :: String+consoleK = "console"++systemdNspawnConfigToCPDocument ::+ SystemdNspawnConfig -> CPDocument -> Either CPError CPDocument+systemdNspawnConfigToCPDocument c cp = do+ cp1 <- addSectionCP cp cfgFileSection+ cp2 <-+ containerCapsToCPDocument cp1 cfgFileSection $+ _systemdNspawnCapabilities c+ cp3 <- setShowCP cp2 cfgFileSection useSudoK $ _systemdNspawnUseSudo c+ cp4 <- setShowCP cp3 cfgFileSection maxLifetimeSecondsK $ _systemdNspawnMaxLifetimeSeconds c+ cp5 <- setShowCP cp4 cfgFileSection extraArgsK $ _systemdNspawnExtraArgs c+ cp6 <- setShowCP cp5 cfgFileSection executableK $ _systemdNspawnExecutable c+ setShowCP cp6 cfgFileSection consoleK $ _systemdNspawnConsole c++parseSystemdNspawnConfig :: CPDocument -> Either CPError SystemdNspawnConfig+parseSystemdNspawnConfig cp =+ let getr :: (CPGet a) => CPOptionSpec -> Either CPError a+ getr = readCP cp cfgFileSection+ in SystemdNspawnConfig+ <$> parseContainerCapabilities cp cfgFileSection+ <*> getr useSudoK+ <*> getr maxLifetimeSecondsK+ <*> getr extraArgsK+ <*> getr executableK+ <*> getr consoleK
src/lib/B9/B9Error.hs view
@@ -3,29 +3,32 @@ -- -- @since 0.5.64 module B9.B9Error- ( throwSomeException- , throwSomeException_- , throwB9Error- , throwB9Error_- , errorOnException- , ExcB9- , runExcB9- , B9Error(MkB9Error)- , fromB9Error- , catchB9Error- , catchB9ErrorAsEither+ ( throwSomeException,+ throwSomeException_,+ throwB9Error,+ throwB9Error_,+ errorOnException,+ ExcB9,+ WithIoExceptions,+ runExcB9,+ B9Error (MkB9Error),+ fromB9Error,+ catchB9Error,+ catchB9ErrorAsEither,+ finallyB9, ) where -import Control.Exception ( toException- , SomeException- , Exception- , displayException- )-import Control.Eff as Eff-import Control.Eff.Exception as Eff-import Control.Monad-import Data.String ( IsString(..) )+import Control.Eff as Eff+import Control.Eff.Exception as Eff+import Control.Exception+ ( Exception,+ SomeException,+ displayException,+ toException,+ )+import Control.Monad+import Data.String (IsString (..)) -- | The exception effect used in most places in B9. -- This is `Exc` specialized with `SomeException`.@@ -33,13 +36,22 @@ -- @since 0.5.64 type ExcB9 = Exc SomeException +-- | Constraint alias for the exception effect that allows to+-- throw 'SomeException'.+--+-- @since 1.0.0+type WithIoExceptions e = SetMember Exc (Exc SomeException) e+ -- | This is a simple runtime exception to indicate that B9 code encountered -- some exceptional event. -- -- @since 0.5.64-newtype B9Error = MkB9Error { fromB9Error :: String }- deriving (Show, IsString)+newtype B9Error = MkB9Error {fromB9Error :: String}+ deriving (IsString) +instance Show B9Error where+ show (MkB9Error msg) = "B9 internal error: " ++ msg+ instance Exception B9Error -- | Run an `ExcB9`.@@ -66,7 +78,6 @@ throwSomeException_ :: (Member ExcB9 e, Exception x) => x -> Eff e () throwSomeException_ = throwError_ . toException - -- | 'SomeException' wrapped into 'Exc'ecption 'Eff'ects -- -- @since 0.5.64@@ -82,14 +93,26 @@ -- | Catch exceptions. -- -- @since 0.5.64-catchB9Error- :: Member ExcB9 e => Eff e a -> (SomeException -> Eff e a) -> Eff e a+catchB9Error ::+ Member ExcB9 e => Eff e a -> (SomeException -> Eff e a) -> Eff e a catchB9Error = catchError - -- | Catch exceptions and return them via 'Either'. -- -- @since 0.5.64-catchB9ErrorAsEither- :: Member ExcB9 e => Eff e a -> Eff e (Either SomeException a)+catchB9ErrorAsEither ::+ Member ExcB9 e => Eff e a -> Eff e (Either SomeException a) catchB9ErrorAsEither x = catchB9Error (Right <$> x) (pure . Left)++-- | Always execute an action and rethrow any exceptions caught.+--+-- @since 1.0.0+finallyB9 :: Member ExcB9 e => Eff e a -> Eff e () -> Eff e a+finallyB9 mainAction cleanupAction =+ catchB9Error+ ( do+ res <- mainAction+ cleanupAction+ return res+ )+ (\e -> cleanupAction >> throwSomeException e)
src/lib/B9/B9Exec.hs view
@@ -1,31 +1,48 @@+{-# LANGUAGE Strict #-}+ -- | This modules contains support for external command execution. -- -- @since 0.5.65 module B9.B9Exec- ( cmd+ ( cmd,+ hostCmdEither,+ hostCmd,+ hostCmdStdIn,+ CommandTimeout (..),+ HostCommandStdin (..), ) where -import B9.B9Config-import B9.B9Logging-import Control.Concurrent.Async ( Concurrently(..) )-import Control.Eff-import Control.Monad-import Control.Monad.IO.Class-import Control.Monad.Trans.Control ( embed_ )-import qualified Data.ByteString as Strict-import Data.Conduit ( (.|)- , runConduit- )-import qualified Data.Conduit.List as CL-import Data.Conduit.Process-import Data.Functor ( )-import qualified Data.Text as Text-import qualified Data.Text.Encoding as Text-import qualified Data.Text.Encoding.Error as Text-import System.Exit-import Text.Printf+import B9.B9Config+import B9.B9Error+import B9.B9Logging+-- import qualified Data.ByteString.Lazy as Lazy +import qualified Conduit as CL+import Control.Concurrent+import Control.Concurrent.Async (Concurrently (..), race)+import Control.Eff+import qualified Control.Exception as ExcIO+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Control (control, embed_, restoreM)+import qualified Data.ByteString as Strict+import Data.Conduit+ ( (.|),+ ConduitT,+ Void,+ runConduit,+ )+import qualified Data.Conduit.Binary as CB+import qualified Data.Conduit.List as CL+import Data.Conduit.Process+import Data.Functor ()+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified Data.Text.Encoding.Error as Text+import System.Exit+import Text.Printf+ -- | Execute the given shell command. -- -- If 'isInteractive' is true, the standard-in will be passed to the external command,@@ -43,39 +60,209 @@ inheritStdIn <- isInteractive if inheritStdIn then interactiveCmd str else nonInteractiveCmd str -interactiveCmd :: forall e . CommandIO e => String -> Eff e ()+interactiveCmd :: forall e. CommandIO e => String -> Eff e () interactiveCmd str = void (cmdWithStdIn True str :: Eff e Inherited) -nonInteractiveCmd :: forall e . CommandIO e => String -> Eff e ()+nonInteractiveCmd :: forall e. CommandIO e => String -> Eff e () -- TODO if we use 'ClosedStream' we get an error from 'virsh console' -- complaining about a missing controlling tty. Original source line: -- nonInteractiveCmd str = void (cmdWithStdIn False str :: B9 ClosedStream) nonInteractiveCmd str = void (cmdWithStdIn False str :: Eff e Inherited) -cmdWithStdIn- :: (CommandIO e, InputSource stdin) => Bool -> String -> Eff e stdin+cmdWithStdIn ::+ (CommandIO e, InputSource stdin) => Bool -> String -> Eff e stdin cmdWithStdIn toStdOut cmdStr = do traceL $ "COMMAND: " ++ cmdStr- traceLIO <- embed_- (traceL . Text.unpack . Text.decodeUtf8With Text.lenientDecode)- errorLIO <- embed_- (errorL . Text.unpack . Text.decodeUtf8With Text.lenientDecode)+ traceLIO <-+ embed_+ (traceL . Text.unpack . Text.decodeUtf8With Text.lenientDecode)+ errorLIO <-+ embed_+ (errorL . Text.unpack . Text.decodeUtf8With Text.lenientDecode) let errorLC = CL.mapM_ (liftIO . errorLIO)- let traceLC = if toStdOut- then CL.mapM_ Strict.putStr- else CL.mapM_ (liftIO . traceLIO)+ let traceLC =+ if toStdOut+ then CL.mapM_ Strict.putStr+ else CL.mapM_ (liftIO . traceLIO) (cpIn, cpOut, cpErr, cph) <- streamingProcess (shell cmdStr)- e <-+ e <- liftIO- $ runConcurrently- $ Concurrently (runConduit (cpOut .| traceLC))- *> Concurrently (runConduit (cpErr .| errorLC))- *> Concurrently (waitForStreamingProcess cph)+ $ runConcurrently+ $ Concurrently (runConduit (cpOut .| traceLC))+ *> Concurrently (runConduit (cpErr .| errorLC))+ *> Concurrently (waitForStreamingProcess cph)+ closeStreamingProcessHandle cph checkExitCode e return cpIn- where- checkExitCode ExitSuccess =- traceL $ printf "COMMAND '%s' exited with exit code: 0" cmdStr- checkExitCode ec@(ExitFailure e) = do- errorL $ printf "COMMAND '%s' exited with exit code: %i" cmdStr e- liftIO $ exitWith ec+ where+ checkExitCode ExitSuccess =+ traceL $ printf "COMMAND '%s' exited with exit code: 0" cmdStr+ checkExitCode ec@(ExitFailure e) = do+ errorL $ printf "COMMAND '%s' exited with exit code: %i" cmdStr e+ liftIO $ exitWith ec++-- | Run a shell command defined by a string and optionally interrupt the command+-- after a given time has elapsed.+-- If the shell command did not exit with 'ExitSuccess', or the timer elapsed,+-- a 'B9Error' is thrown.+--+-- This is only useful for non-interactive commands.+--+-- @since 1.0.0+hostCmd ::+ (CommandIO e, Member ExcB9 e) =>+ -- | The shell command to execute.+ String ->+ -- | An optional 'CommandTimeout'+ Maybe CommandTimeout ->+ -- | An action that performs the shell command and returns 'True' on success+ Eff e Bool+hostCmd cmdStr timeout = do+ res <- hostCmdEither HostCommandNoStdin cmdStr timeout+ case res of+ Left e ->+ throwB9Error ("Command timed out: " ++ show cmdStr ++ " " ++ show e)+ Right (ExitFailure ec) -> do+ errorL ("Command exited with error code: " ++ show cmdStr ++ " " ++ show ec)+ return False+ Right ExitSuccess ->+ return True++-- | Like 'hostCmd' but with std-input attached.+--+-- @since 1.0.0+hostCmdStdIn ::+ (CommandIO e, Member ExcB9 e) =>+ -- | A 'HostCommandStdin' to define standard input.+ -- If the value is 'HostCommandInheritStdin' then+ -- **also stdout and stderr** will be redirected to+ -- the 'Inherited' file descriptors.+ HostCommandStdin ->+ -- | The shell command to execute.+ String ->+ -- | An optional 'CommandTimeout'+ Maybe CommandTimeout ->+ -- | An action that performs the shell command and returns 'True' on success+ Eff e Bool+hostCmdStdIn hostStdIn cmdStr timeout = do+ res <- hostCmdEither hostStdIn cmdStr timeout+ case res of+ Left e ->+ throwB9Error ("Command timed out: " ++ show cmdStr ++ " " ++ show e)+ Right (ExitFailure ec) -> do+ errorL ("Command exited with error code: " ++ show cmdStr ++ " " ++ show ec)+ return False+ Right ExitSuccess ->+ return True++-- | Ways to process std-input.+--+-- @since 1.0.0+data HostCommandStdin+ = -- | Disbale std-in+ HostCommandNoStdin+ | -- | Inherit std-in+ HostCommandInheritStdin+ | -- | Produce std-in+ HostCommandStdInConduit (ConduitT () Strict.ByteString IO ())++-- | Run a shell command defined by a string and optionally interrupt the command+-- after a given time has elapsed.+-- This is only useful for non-interactive commands.+--+-- @since 1.0.0+hostCmdEither ::+ forall e.+ (CommandIO e) =>+ -- | A 'HostCommandStdin' to define standard input.+ -- If the value is 'HostCommandInheritStdin' then+ -- **also stdout and stderr** will be redirected to+ -- the 'Inherited' file descriptors.+ HostCommandStdin ->+ -- | The shell command to execute.+ String ->+ -- | An optional 'CommandTimeout'+ Maybe CommandTimeout ->+ Eff e (Either CommandTimeout ExitCode)+hostCmdEither inputSource cmdStr timeout = do+ let tag = "[" ++ printHash cmdStr ++ "]"+ traceL $ "COMMAND " ++ tag ++ ": " ++ cmdStr+ control $ \runInIO ->+ do+ ExcIO.catch+ (runInIO (go tag))+ ( \(e :: ExcIO.SomeException) -> do+ putStrLn ("COMMAND " ++ tag ++ " interrupted: " ++ show e)+ runInIO (return (Right (ExitFailure 126) :: Either CommandTimeout ExitCode))+ )+ >>= restoreM+ where+ go :: String -> Eff e (Either CommandTimeout ExitCode)+ go tag = do+ traceLC <- traceMsgProcessLogger tag+ errorLC <- errorMsgProcessLogger tag+ let timer t@(CommandTimeout micros) = do+ threadDelay micros+ return t+ (cph, runCmd) <- case inputSource of+ HostCommandNoStdin -> do+ (ClosedStream, cpOut, cpErr, cph) <- streamingProcess (shell cmdStr)+ let runCmd =+ runConcurrently+ ( Concurrently (runConduit (cpOut .| runProcessLogger traceLC))+ *> Concurrently (runConduit (cpErr .| runProcessLogger errorLC))+ *> Concurrently (waitForStreamingProcess cph)+ )+ return (cph, runCmd)+ HostCommandInheritStdin -> do+ (Inherited, Inherited, Inherited, cph) <- streamingProcess (shell cmdStr)+ let runCmd = waitForStreamingProcess cph+ return (cph, runCmd)+ HostCommandStdInConduit inputC -> do+ (stdIn, cpOut, cpErr, cph) <- streamingProcess (shell cmdStr)+ let runCmd =+ runConcurrently+ ( Concurrently (runConduit (cpOut .| runProcessLogger traceLC))+ *> Concurrently (runConduit (cpErr .| runProcessLogger errorLC))+ *> Concurrently (runConduit (inputC .| stdIn))+ *> Concurrently (waitForStreamingProcess cph)+ )+ return (cph, runCmd)+ e <- liftIO (maybe (fmap Right) (race . timer) timeout runCmd)+ closeStreamingProcessHandle cph+ case e of+ Left _ ->+ errorL $ "COMMAND TIMED OUT " ++ tag+ Right ExitSuccess ->+ traceL $ "COMMAND FINISHED " ++ tag+ Right (ExitFailure ec) ->+ errorL $ "COMMAND FAILED EXIT CODE: " ++ show ec ++ " " ++ tag+ return e++data CommandTimeout = CommandTimeout Int+ deriving (Show)++newtype ProcessLogger+ = MkProcessLogger+ {runProcessLogger :: ConduitT Strict.ByteString Void IO ()}++traceMsgProcessLogger :: (CommandIO e) => String -> Eff e ProcessLogger+traceMsgProcessLogger = mkMsgProcessLogger traceL++errorMsgProcessLogger :: (CommandIO e) => String -> Eff e ProcessLogger+errorMsgProcessLogger = mkMsgProcessLogger errorL++mkMsgProcessLogger :: (CommandIO e) => (String -> Eff e ()) -> String -> Eff e ProcessLogger+mkMsgProcessLogger logFun prefix = do+ logIO <-+ embed_+ ( \logBytes ->+ logFun (prefix ++ ": " ++ Text.unpack logBytes)+ )+ return+ ( MkProcessLogger+ ( CB.lines+ .| CL.decodeUtf8LenientC+ .| CL.mapM_ (liftIO . logIO)+ )+ )
src/lib/B9/B9Logging.hs view
@@ -2,41 +2,45 @@ -- -- @since 0.5.65 module B9.B9Logging- ( Logger(..)- , CommandIO- , LoggerReader- , withLogger- , b9Log- , traceL- , dbgL- , infoL- , errorL- , errorExitL+ ( Logger (..),+ CommandIO,+ LoggerReader,+ withLogger,+ b9Log,+ traceL,+ dbgL,+ infoL,+ errorL,+ errorExitL,+ printHash, ) where -import B9.B9Config-import B9.B9Error-import Control.Eff-import Control.Eff.Reader.Lazy-import Control.Monad-import Control.Monad.IO.Class-import Control.Monad.Trans.Control ( MonadBaseControl- , liftBaseWith- , restoreM- )-import Data.Maybe-import Data.Time.Clock-import Data.Time.Format-import qualified System.IO as SysIO-import Text.Printf+import B9.B9Config+import B9.B9Error+import Control.Eff+import Control.Eff.Reader.Lazy+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Control+ ( MonadBaseControl,+ liftBaseWith,+ restoreM,+ )+import Data.Hashable+import Data.Maybe+import Data.Time.Clock+import Data.Time.Format+import qualified System.IO as SysIO+import Text.Printf -- | The logger to write log messages to. -- -- @since 0.5.65-newtype Logger = MkLogger- { logFileHandle :: Maybe SysIO.Handle- }+newtype Logger+ = MkLogger+ { logFileHandle :: Maybe SysIO.Handle+ } -- | Effect that reads a 'Logger'. --@@ -49,27 +53,28 @@ -- Then run the given action; if the action crashes, the log file will be closed. -- -- @since 0.5.65-withLogger- :: (MonadBaseControl IO (Eff e), MonadIO (Eff e), Member B9ConfigReader e)- => Eff (LoggerReader ': e) a- -> Eff e a+withLogger ::+ (MonadBaseControl IO (Eff e), MonadIO (Eff e), Member B9ConfigReader e) =>+ Eff (LoggerReader ': e) a ->+ Eff e a withLogger action = do- lf <- _logFile <$> getB9Config+ lf <- _logFile <$> getB9Config effState <- liftBaseWith $ \runInIO -> let fInIO = runInIO . flip runReader action . MkLogger- in maybe (fInIO Nothing)- (\logf -> SysIO.withFile logf SysIO.AppendMode (fInIO . Just))- lf+ in maybe+ (fInIO Nothing)+ (\logf -> SysIO.withFile logf SysIO.AppendMode (fInIO . Just))+ lf restoreM effState -- | Convenience type alias for 'Eff'ects that have a 'B9Config', a 'Logger', 'MonadIO' and 'MonadBaseControl'. -- -- @since 0.5.65-type CommandIO e- = ( MonadBaseControl IO (Eff e)- , MonadIO (Eff e)- , Member LoggerReader e- , Member B9ConfigReader e+type CommandIO e =+ ( MonadBaseControl IO (Eff e),+ MonadIO (Eff e),+ Member LoggerReader e,+ Member B9ConfigReader e ) traceL :: CommandIO e => String -> Eff e ()@@ -89,7 +94,7 @@ b9Log :: CommandIO e => LogLevel -> String -> Eff e () b9Log level msg = do- lv <- getLogVerbosity+ lv <- getLogVerbosity lfh <- logFileHandle <$> ask liftIO $ logImpl lv lfh level msg @@ -112,7 +117,10 @@ printLevel :: LogLevel -> String printLevel l = case l of LogNothing -> "NOTHING"- LogError -> " ERROR "- LogInfo -> " INFO "- LogDebug -> " DEBUG "- LogTrace -> " TRACE "+ LogError -> " ERROR "+ LogInfo -> " INFO "+ LogDebug -> " DEBUG "+ LogTrace -> " TRACE "++printHash :: Hashable a => a -> String+printHash = printf "%x" . hash
src/lib/B9/B9Monad.hs view
@@ -1,20 +1,20 @@ module B9.B9Monad- ( runB9- , B9- , B9Eff- , IsB9+ ( runB9,+ B9,+ B9Eff,+ IsB9, ) where -import B9.B9Config-import B9.B9Error-import B9.B9Logging-import B9.BuildInfo-import B9.Environment-import B9.Repository-import Control.Eff-import Data.Functor ( )-import GHC.Stack+import B9.B9Config+import B9.B9Error+import B9.B9Logging+import B9.BuildInfo+import B9.Environment+import B9.Repository+import Control.Eff+import Data.Functor ()+import GHC.Stack -- | Definition of the B9 monad. See 'B9Eff'. --@@ -30,9 +30,17 @@ -- This monad is used by the _effectful_ functions in this library. -- -- @since 0.5.65-type B9Eff- = '[SelectedRemoteRepoReader, RepoCacheReader, BuildInfoReader, LoggerReader, B9ConfigReader, EnvironmentReader, ExcB9, Lift- IO]+type B9Eff =+ '[ SelectedRemoteRepoReader,+ RepoCacheReader,+ BuildInfoReader,+ LoggerReader,+ B9ConfigReader,+ EnvironmentReader,+ ExcB9,+ Lift+ IO+ ] -- | A constraint that contains all effects of 'B9Eff' --@@ -49,12 +57,12 @@ env <- askEnvironment lift ( runLift- . errorOnException- . runEnvironmentReader env- . runB9ConfigReader cfg- . withLogger- . withBuildInfo- . withRemoteRepos- . withSelectedRemoteRepo- $ action+ . errorOnException+ . runEnvironmentReader env+ . runB9ConfigReader cfg+ . withLogger+ . withBuildInfo+ . withRemoteRepos+ . withSelectedRemoteRepo+ $ action )
src/lib/B9/BuildInfo.hs view
@@ -5,46 +5,48 @@ -- -- @since 0.5.65 module B9.BuildInfo- ( getBuildId- , getBuildDate- , getBuildDir- , getExecEnvType- , withBuildInfo- , BuildInfoReader+ ( getBuildId,+ getBuildDate,+ getBuildDir,+ withBuildInfo,+ BuildInfoReader, ) where -import B9.B9Config-import B9.B9Error-import B9.B9Logging-import B9.Environment-import Control.Eff-import Control.Eff.Reader.Lazy-import Control.Exception ( bracket )-import Control.Lens ( (?~) )-import Control.Monad-import Control.Monad.IO.Class-import Control.Monad.Trans.Control ( MonadBaseControl- , control- )-import Data.Functor ( )-import Data.Hashable-import Data.Time.Clock-import Data.Time.Format-import System.Directory-import System.FilePath-import Text.Printf-import GHC.Stack+import B9.B9Config+import B9.B9Error+import B9.B9Logging+import B9.Environment+import Control.Eff+import Control.Eff.Reader.Lazy+import Control.Exception (bracket)+import Control.Lens ((?~))+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Control+ ( MonadBaseControl,+ control,+ )+import Data.Functor ()+import Data.Hashable+import Data.Time.Clock+import Data.Time.Format+import GHC.Stack+import System.Directory+import System.FilePath+import Text.Printf -- | Build meta information. -- -- @since 0.5.65-data BuildInfo = BuildInfo- { bsBuildId :: String- , bsBuildDate :: String- , bsBuildDir :: FilePath- , bsStartTime :: UTCTime- } deriving (Eq, Show)+data BuildInfo+ = BuildInfo+ { bsBuildId :: String,+ bsBuildDate :: String,+ bsBuildDir :: FilePath,+ bsStartTime :: UTCTime+ }+ deriving (Eq, Show) -- | Type alias for a 'BuildInfo' 'Reader' --@@ -62,67 +64,70 @@ -- returns - even if the action throws a runtime exception. -- -- @since 0.5.65-withBuildInfo- :: ( Lifted IO e- , MonadBaseControl IO (Eff e)- , Member B9ConfigReader e- , Member ExcB9 e- , Member EnvironmentReader e- , Member LoggerReader e- , HasCallStack- )- => Eff (BuildInfoReader ': e) a- -> Eff e a+withBuildInfo ::+ ( Lifted IO e,+ MonadBaseControl IO (Eff e),+ Member B9ConfigReader e,+ Member ExcB9 e,+ Member EnvironmentReader e,+ Member LoggerReader e,+ HasCallStack+ ) =>+ Eff (BuildInfoReader ': e) a ->+ Eff e a withBuildInfo action = withRootDir $ do now <- lift getCurrentTime let buildDate = formatTime undefined "%F-%T" now buildId <- generateBuildId buildDate withBuildDir buildId (runImpl buildId buildDate now)- where- withRootDir f = do- mRoot <- _projectRoot <$> getB9Config- root <- lift $ case mRoot of- Nothing -> getCurrentDirectory >>= canonicalizePath- Just rootIn -> do- createDirectoryIfMissing True rootIn- canonicalizePath rootIn- localB9Config (projectRoot ?~ root)- (addLocalStringBinding ("projectRoot", root) f)- generateBuildId buildDate = do- unqiueBuildDir <- _uniqueBuildDirs <$> getB9Config- cfgHash <- hash . show <$> getB9Config- if unqiueBuildDir- then return (printf "%08X-%08X" cfgHash (hash buildDate))- else return (printf "%08X" cfgHash)- withBuildDir buildId f = do- root <- _projectRoot <$> getB9Config- cfg <- getB9Config- control $ \runInIO ->- bracket (createBuildDir root) (removeBuildDir cfg) (runInIO . f)- where- createBuildDir root = do- let buildDir = case root of- Just r -> r </> "BUILD-" ++ buildId- Nothing -> "BUILD-" ++ buildId- createDirectoryIfMissing True buildDir- canonicalizePath buildDir- removeBuildDir cfg buildDir =- when (_uniqueBuildDirs cfg && not (_keepTempDirs cfg))- $ removeDirectoryRecursive buildDir- runImpl buildId buildDate startTime buildDir =- let ctx = BuildInfo buildId buildDate buildDir startTime- in runReader ctx wrappedAction- where- wrappedAction = do- rootD <- getProjectRoot- traceL (printf "Project Root Directory: %s" rootD)- buildD <- getBuildDir- traceL (printf "Build Directory: %s" buildD)- r <- addLocalStringBinding ("buildDir", buildD) action- tsAfter <- liftIO getCurrentTime- let duration = show (tsAfter `diffUTCTime` startTime)- infoL (printf "DURATION: %s" duration)- return r+ where+ withRootDir f = do+ mRoot <- _projectRoot <$> getB9Config+ root <- lift $ case mRoot of+ Nothing -> getCurrentDirectory >>= canonicalizePath+ Just rootIn -> do+ createDirectoryIfMissing True rootIn+ canonicalizePath rootIn+ localB9Config+ (projectRoot ?~ root)+ (addLocalStringBinding ("projectRoot", root) f)+ generateBuildId buildDate = do+ -- TODO generate a proper, reproducable build id!+ unqiueBuildDir <- _uniqueBuildDirs <$> getB9Config+ cfgHash <- hash . show <$> getB9Config+ if unqiueBuildDir+ then return (printf "%08X-%08X" cfgHash (hash buildDate))+ else return (printf "%08X" cfgHash)+ withBuildDir buildId f = do+ root <- _projectRoot <$> getB9Config+ cfg <- getB9Config+ control $ \runInIO ->+ bracket (createBuildDir root) (removeBuildDir cfg) (runInIO . f)+ where+ createBuildDir root = do+ -- TODO allow config option to enable build dirs outside of the projectRoot+ let buildDir = case root of+ Just r -> r </> "BUILD-" ++ buildId+ Nothing -> "BUILD-" ++ buildId+ createDirectoryIfMissing True buildDir+ canonicalizePath buildDir+ removeBuildDir cfg buildDir =+ when (_uniqueBuildDirs cfg && not (_keepTempDirs cfg)) $+ removeDirectoryRecursive buildDir+ runImpl buildId buildDate startTime buildDir =+ let ctx = BuildInfo buildId buildDate buildDir startTime+ in runReader ctx wrappedAction+ where+ wrappedAction = do+ rootD <- getProjectRoot+ traceL (printf "Project Root Directory: %s" rootD)+ buildD <- getBuildDir+ traceL (printf "Build Directory: %s" buildD)+ r <- addLocalStringBinding ("buildDir", buildD) action+ tsAfter <- liftIO getCurrentTime+ let duration = show (tsAfter `diffUTCTime` startTime)+ infoL (printf "DURATION: %s" duration)+ return r -- Run the action build action getBuildId :: Member BuildInfoReader e => Eff e String
+ src/lib/B9/Container.hs view
@@ -0,0 +1,38 @@+-- | An interface for container backends such as libvirt-lxc or docker+module B9.Container+ ( Backend (..),+ )+where++import B9.B9Error+import B9.B9Logging+import B9.BuildInfo+import B9.DiskImages+import B9.ExecEnv+import B9.ShellScript+import Control.Eff++-- | Class of backends that run a 'Script' in an 'ExecEnv' in an OS-level+-- container like docker or lxc.+class Backend config where+ -- | Return 'Nothing' if the configuration **disables** this container backend,+ -- and return 'Just ...' if the configuration **enables** this container backend.+ getBackendConfig ::+ forall proxy e.+ (Member BuildInfoReader e, CommandIO e) =>+ proxy config ->+ Eff e (Maybe config)++ -- | The input images, that a given container accepts+ supportedImageTypes :: proxy config -> [ImageType]+ supportedImageTypes _ = [Raw]++ -- | Run a 'Script' in an 'ExecEnv', and return 'True' if the script+ -- completed successfully.+ runInEnvironment ::+ forall e.+ (Member BuildInfoReader e, CommandIO e, Member ExcB9 e) =>+ config ->+ ExecEnv ->+ Script ->+ Eff e Bool
src/lib/B9/DiskImageBuilder.hs view
@@ -1,59 +1,63 @@ {-# LANGUAGE ScopedTypeVariables #-} -{-| Effectful functions that create and convert disk image files. -}+-- | 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- , getSharedImagesCacheDir- , getSelectedRepos- , pullRemoteRepos- , pullLatestImage- ) where+ ( materializeImageSource,+ substImageTarget,+ preferredDestImageTypes,+ preferredSourceImageTypes,+ resolveImageSource,+ createDestinationImage,+ resizeImage,+ importImage,+ exportImage,+ exportAndRemoveImage,+ convertImage,+ shareImage,+ ensureAbsoluteImageDirExists,+ pushSharedImageLatestVersion,+ lookupSharedImages,+ getSharedImages,+ getSharedImagesCacheDir,+ getSelectedRepos,+ pullRemoteRepos,+ pullLatestImage,+ )+where -import B9.Artifact.Content.StringTemplate-import B9.B9Config-import B9.B9Error-import B9.B9Exec-import B9.B9Logging-import B9.B9Monad-import B9.BuildInfo-import B9.DiskImages-import B9.Environment-import qualified B9.PartitionTable as P-import B9.Repository-import B9.RepositoryIO-import Control.Eff-import Control.Exception-import Control.Lens ((^.))-import Control.Monad-import Control.Monad.IO.Class-import Data.Function-import Data.Generics.Aliases-import Data.Generics.Schemes-import Data.List-import Data.Maybe-import GHC.Stack-import System.Directory-import System.FilePath-import System.IO.B9Extras (consult, ensureDir,- prettyPrintToFile)-import System.IO.Error (isDoesNotExistError)-import Text.Printf (printf)-import Text.Show.Pretty (ppShow)+import B9.Artifact.Content.StringTemplate+import B9.B9Config+import B9.B9Error+import B9.B9Exec+import B9.B9Logging+import B9.B9Monad+import B9.BuildInfo+import B9.DiskImages+import B9.Environment+import qualified B9.PartitionTable as P+import B9.Repository+import B9.RepositoryIO+import Control.Eff+import Control.Exception+import Control.Lens ((^.))+import Control.Monad+import Control.Monad.IO.Class+import Data.Function+import Data.Generics.Aliases+import Data.Generics.Schemes+import Data.List+import Data.Maybe+import GHC.Stack+import System.Directory+import System.FilePath+import System.IO.B9Extras+ ( consult,+ ensureDir,+ prettyPrintToFile,+ )+import System.IO.Error (isDoesNotExistError)+import Text.Printf (printf)+import Text.Show.Pretty (ppShow) -- -- | Convert relative file paths of images, sources and mounted host directories -- -- to absolute paths relative to '_projectRoot'.@@ -63,18 +67,20 @@ -- where -- go rootDir = everywhere mkAbs img -- where mkAbs = mkT+ -- | Replace $... variables inside an 'ImageTarget' substImageTarget ::- forall e. (HasCallStack, Member EnvironmentReader e, Member ExcB9 e)- => ImageTarget- -> Eff e ImageTarget+ forall e.+ (HasCallStack, Member EnvironmentReader e, Member ExcB9 e) =>+ ImageTarget ->+ Eff e ImageTarget substImageTarget = everywhereM gsubst where gsubst :: GenericM (Eff e) gsubst =- mkM substMountPoint `extM` substImage `extM` substImageSource `extM`- substDiskTarget- substMountPoint NotMounted = pure NotMounted+ mkM substMountPoint `extM` substImage `extM` substImageSource+ `extM` substDiskTarget+ substMountPoint NotMounted = pure NotMounted substMountPoint (MountPoint x) = MountPoint <$> substStr x substImage (Image fp t fs) = Image <$> substStr fp <*> pure t <*> pure fs substImageSource (From n s) = From <$> substStr n <*> pure s@@ -97,11 +103,12 @@ (SourceImage srcImg _part _resize) -> ensureAbsoluteImageDirExists srcImg (CopyOnWrite backingImg) -> ensureAbsoluteImageDirExists backingImg (From name _resize) ->- getLatestImageByName (SharedImageName name) >>=- maybe- (errorExitL- (printf "Nothing found for %s." (show (SharedImageName name))))- ensureAbsoluteImageDirExists+ getLatestImageByName (SharedImageName name)+ >>= maybe+ ( errorExitL+ (printf "Nothing found for %s." (show (SharedImageName name)))+ )+ ensureAbsoluteImageDirExists -- | Return all valid image types sorted by preference. preferredDestImageTypes :: IsB9 e => ImageSource -> Eff e [ImageType]@@ -114,15 +121,18 @@ (SourceImage _img (Partition _) _resize) -> return [Raw] (SourceImage (Image _file fmt _fs) _pt resize) -> return- (nub [fmt, Raw, QCow2, Vmdk] `intersect`- allowedImageTypesForResize resize)+ ( nub [fmt, Raw, QCow2, Vmdk]+ `intersect` allowedImageTypesForResize resize+ ) (From name resize) ->- getLatestImageByName (SharedImageName name) >>=- maybe- (errorExitL- (printf "Nothing found for %s." (show (SharedImageName name))))- (\sharedImg ->- preferredDestImageTypes (SourceImage sharedImg NoPT resize))+ getLatestImageByName (SharedImageName name)+ >>= maybe+ ( errorExitL+ (printf "Nothing found for %s." (show (SharedImageName name)))+ )+ ( \sharedImg ->+ preferredDestImageTypes (SourceImage sharedImg NoPT resize)+ ) -- | Return all supported source 'ImageType's compatible to a 'ImageDestinaion' -- in the preferred order.@@ -139,11 +149,11 @@ allowedImageTypesForResize :: HasCallStack => ImageResize -> [ImageType] allowedImageTypesForResize r = case r of- Resize _ -> [Raw]+ Resize _ -> [Raw] ShrinkToMinimumAndIncrease _ -> [Raw]- ShrinkToMinimum -> [Raw]- ResizeImage _ -> [Raw, QCow2, Vmdk]- KeepSize -> [Raw, QCow2, Vmdk]+ ShrinkToMinimum -> [Raw]+ ResizeImage _ -> [Raw, QCow2, Vmdk]+ KeepSize -> [Raw, QCow2, Vmdk] -- | Create the parent directories for the file that contains the 'Image'. -- If the path to the image file is relative, prepend '_projectRoot' from@@ -154,8 +164,9 @@ let dir = let dirRel = takeDirectory path in if isRelative dirRel- then let prefix = fromMaybe "." (b9cfg ^. projectRoot)- in prefix </> dirRel+ then+ let prefix = fromMaybe "." (b9cfg ^. projectRoot)+ in prefix </> dirRel else dirRel liftIO $ do createDirectoryIfMissing True dir@@ -175,15 +186,17 @@ createImageFromImage srcImg part resize dest (CopyOnWrite backingImg) -> createCOWImage backingImg dest (From name resize) ->- getLatestImageByName (SharedImageName name) >>=- maybe- (errorExitL- (printf "Nothing found for %s." (show (SharedImageName name))))- (\sharedImg ->- materializeImageSource (SourceImage sharedImg NoPT resize) dest)+ getLatestImageByName (SharedImageName name)+ >>= maybe+ ( errorExitL+ (printf "Nothing found for %s." (show (SharedImageName name)))+ )+ ( \sharedImg ->+ materializeImageSource (SourceImage sharedImg NoPT resize) dest+ ) createImageFromImage ::- IsB9 e => Image -> Partition -> ImageResize -> Image -> Eff e ()+ IsB9 e => Image -> Partition -> ImageResize -> Image -> Eff e () createImageFromImage src part size out = do importImage src out extractPartition part out@@ -196,21 +209,23 @@ 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)+ ( 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))+ ( printf+ "Extract partition %i from image '%s': Invalid format %s"+ partIndex+ outFile+ (imageFileExtension fmt)+ ) -- | Convert some 'Image', e.g. a temporary image used during the build phase -- to the final destination.@@ -237,52 +252,57 @@ 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)+ ( 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 ::- IsB9 e- => String- -> FileSystem- -> ImageType- -> ImageSize- -> Image- -> Eff e ()+ IsB9 e =>+ String ->+ FileSystem ->+ ImageType ->+ ImageSize ->+ Image ->+ Eff e () 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'))+ ( 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'))+ ( printf+ "Conflicting createEmptyImage parameters. Requested is image type %s but the destination image has type %s."+ (show imgType)+ (show imgType')+ ) | otherwise = do let (Image imgFile imgFmt imgFs) = dest qemuImgOpts = conversionOptions imgFmt dbgL- (printf- "Creating empty raw image '%s' with size %s and options %s"- imgFile- (toQemuSizeOptVal imgSize)- qemuImgOpts)+ ( printf+ "Creating empty raw image '%s' with size %s and options %s"+ imgFile+ (toQemuSizeOptVal imgSize)+ qemuImgOpts+ ) cmd- (printf- "qemu-img create -f %s %s '%s' '%s'"- (imageFileExtension imgFmt)- qemuImgOpts- imgFile- (toQemuSizeOptVal imgSize))+ ( printf+ "qemu-img create -f %s %s '%s' '%s'"+ (imageFileExtension imgFmt)+ qemuImgOpts+ imgFile+ (toQemuSizeOptVal imgSize)+ ) case (imgFmt, imgFs) of (Raw, Ext4_64) -> do let fsCmd = "mkfs.ext4"@@ -294,20 +314,22 @@ cmd (printf "%s -F -L '%s' -O ^64bit -q '%s'" fsCmd fsLabel imgFile) (imageType, fs) -> error- (printf- "Cannot create file system %s in image type %s"- (show fs)- (show imageType))+ ( printf+ "Cannot create file system %s in image type %s"+ (show fs)+ (show imageType)+ ) createCOWImage :: IsB9 e => Image -> Image -> Eff e () 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)+ ( printf+ "qemu-img create -f %s -o backing_file='%s' '%s'"+ (imageFileExtension imgFmt)+ backingFile+ imgOut+ ) resizeExtFS :: (IsB9 e) => ImageSize -> FilePath -> Eff e () resizeExtFS newSize img = do@@ -344,9 +366,10 @@ | fs == Ext4 || fs == Ext4_64 = shrinkToMinimumExtFS img resizeImage _ img = error- (printf- "Invalid image type or filesystem, cannot resize image: %s"- (show img))+ ( 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.@@ -382,36 +405,38 @@ | otherwise = do ensureDir imgOut dbgL- (printf- "Converting %s to %s: '%s' to '%s'"- (imageFileExtension fmtIn)- (imageFileExtension fmtOut)- imgIn- imgOut)+ ( printf+ "Converting %s to %s: '%s' to '%s'"+ (imageFileExtension fmtIn)+ (imageFileExtension fmtOut)+ imgIn+ imgOut+ ) cmd- (printf- "qemu-img convert -q -f %s -O %s %s '%s' '%s'"- (imageFileExtension fmtIn)- (imageFileExtension fmtOut)- (conversionOptions fmtOut)- imgIn- imgOut)+ ( printf+ "qemu-img convert -q -f %s -O %s %s '%s' '%s'"+ (imageFileExtension fmtIn)+ (imageFileExtension fmtOut)+ (conversionOptions fmtOut)+ imgIn+ imgOut+ ) when doMove $ do dbgL (printf "Removing '%s'" imgIn) liftIO (removeFile imgIn) conversionOptions :: ImageType -> String-conversionOptions Vmdk = " -o adapter_type=lsilogic "+conversionOptions Vmdk = " -o adapter_type=lsilogic " conversionOptions QCow2 = " -o compat=1.1,lazy_refcounts=on "-conversionOptions _ = " "+conversionOptions _ = " " toQemuSizeOptVal :: ImageSize -> String toQemuSizeOptVal (ImageSize amount u) =- show amount ++- case u of- GB -> "G"- MB -> "M"- KB -> "K"+ show amount+ ++ case u of+ GB -> "G"+ MB -> "M"+ KB -> "K" -- | Publish an sharedImage made from an image and image meta data to the -- configured repository@@ -425,23 +450,24 @@ -- | Return a 'SharedImage' with the current build data and build id from the -- name and disk image. getSharedImageFromImageInfo ::- IsB9 e => SharedImageName -> Image -> Eff e SharedImage+ IsB9 e => SharedImageName -> Image -> Eff e SharedImage getSharedImageFromImageInfo name (Image _ imgType imgFS) = do buildId <- getBuildId date <- getBuildDate return- (SharedImage- name- (SharedImageDate date)- (SharedImageBuildId buildId)- imgType- imgFS)+ ( SharedImage+ name+ (SharedImageDate date)+ (SharedImageBuildId buildId)+ imgType+ imgFS+ ) -- | Convert the disk image and serialize the base image data structure. -- If the 'maxLocalSharedImageRevisions' configuration is set to @Just n@ -- also delete all but the @n - 1@ newest images from the local cache. createSharedImageInCache ::- IsB9 e => Image -> SharedImageName -> Eff e SharedImage+ IsB9 e => Image -> SharedImageName -> Eff e SharedImage createSharedImageInCache img sname@(SharedImageName name) = do dbgL (printf "CREATING SHARED IMAGE: '%s' '%s'" (ppShow img) name) sharedImg <- getSharedImageFromImageInfo sname img@@ -456,13 +482,14 @@ -- selected repository from the cache. pushSharedImageLatestVersion :: IsB9 e => SharedImageName -> Eff e () pushSharedImageLatestVersion name@(SharedImageName imgName) =- getLatestSharedImageByNameFromCache name >>=- maybe- (errorExitL (printf "Nothing found for %s." (show imgName)))- (\sharedImage -> do- dbgL (printf "PUSHING '%s'" (ppShow sharedImage))- pushToSelectedRepo sharedImage- infoL (printf "PUSHED '%s'" imgName))+ getLatestSharedImageByNameFromCache name+ >>= maybe+ (errorExitL (printf "Nothing found for %s." (show imgName)))+ ( \sharedImage -> do+ dbgL (printf "PUSHING '%s'" (ppShow sharedImage))+ pushToSelectedRepo sharedImage+ infoL (printf "PUSHED '%s'" imgName)+ ) -- | Upload a shared image from the cache to a selected remote repository pushToSelectedRepo :: IsB9 e => SharedImage -> Eff e ()@@ -494,7 +521,7 @@ pullLatestImage :: IsB9 e => SharedImageName -> Eff e (Maybe SharedImageBuildId) pullLatestImage name@(SharedImageName dbgName) = do repos <- getSelectedRepos- let repoPredicate Cache = False+ let repoPredicate Cache = False repoPredicate (Remote repoId) = repoId `elem` repoIds repoIds = map remoteRepoRepoId repos hasName sharedImage = name == sharedImageName sharedImage@@ -503,10 +530,11 @@ if null candidates then do errorL- (printf- "No shared image named '%s' on these remote repositories: '%s'"- dbgName- (ppShow repoIds))+ ( printf+ "No shared image named '%s' on these remote repositories: '%s'"+ dbgName+ (ppShow repoIds)+ ) return Nothing else do dbgL (printf "PULLING SHARED IMAGE: '%s'" (ppShow image))@@ -531,17 +559,17 @@ cacheDir <- getSharedImagesCacheDir let image = changeImageDirectory cacheDir . sharedImageImage <$> sharedImage case image of- Just i -> dbgL (printf "USING SHARED SOURCE IMAGE '%s'" (show i))+ Just i -> dbgL (printf "USING SHARED SOURCE IMAGE '%s'" (show i)) Nothing -> errorL (printf "SOURCE IMAGE '%s' NOT FOUND" (show name)) return image -- | Return the latest version of a shared image named 'name' from the local cache. getLatestSharedImageByNameFromCache ::- IsB9 e => SharedImageName -> Eff e (Maybe SharedImage)+ IsB9 e => SharedImageName -> Eff e (Maybe SharedImage) getLatestSharedImageByNameFromCache name@(SharedImageName dbgName) = do imgs <- lookupSharedImages (== Cache) ((== name) . sharedImageName) case reverse imgs of- (Cache, sharedImage):_rest -> return (Just sharedImage)+ (Cache, sharedImage) : _rest -> return (Just sharedImage) _ -> do errorL (printf "No image(s) named '%s' found." dbgName) return Nothing@@ -554,7 +582,7 @@ sharedImagesRootDirectory (FileExtension sharedImageFileExtension) mapM- (\(repo, files) -> (repo, ) . catMaybes <$> mapM consult' files)+ (\(repo, files) -> (repo,) . catMaybes <$> mapM consult' files) reposAndFiles where consult' f = do@@ -562,10 +590,11 @@ case r of Left (e :: SomeException) -> do dbgL- (printf- "Failed to load shared image meta-data from '%s': '%s'"- (takeFileName f)- (show e))+ ( 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@@ -574,10 +603,10 @@ -- | Find shared images and the associated repos from two predicates. The result -- is the concatenated result of the sorted shared images satisfying 'imgPred'. lookupSharedImages ::- IsB9 e- => (Repository -> Bool)- -> (SharedImage -> Bool)- -> Eff e [(Repository, SharedImage)]+ IsB9 e =>+ (Repository -> Bool) ->+ (SharedImage -> Bool) ->+ Eff e [(Repository, SharedImage)] lookupSharedImages repoPred imgPred = do xs <- getSharedImages let rs = [(r, s) | (r, ss) <- xs, s <- ss]@@ -615,20 +644,20 @@ imgFiles = imageFileName . sharedImageImage <$> toDelete unless (null filesToDelete) $ do traceL- (printf- "DELETING %d OBSOLETE REVISIONS OF: %s"- (length filesToDelete)- (show sn))+ ( printf+ "DELETING %d OBSOLETE REVISIONS OF: %s"+ (length filesToDelete)+ (show sn)+ ) mapM_ traceL filesToDelete mapM_ removeIfExists filesToDelete where newestSharedImages :: IsB9 e => Eff e [SharedImage] newestSharedImages =- reverse . map snd <$>- lookupSharedImages (== Cache) ((sn ==) . sharedImageName)+ reverse . map snd+ <$> lookupSharedImages (== Cache) ((sn ==) . sharedImageName) removeIfExists fileName = liftIO $ removeFile fileName `catch` handleExists where handleExists e | isDoesNotExistError e = return () | otherwise = throwIO e-
src/lib/B9/DiskImages.hs view
@@ -1,20 +1,20 @@-{-| Data types that describe all B9 relevant elements of virtual machine disk-images.-}+-- | Data types that describe all B9 relevant elements of virtual machine disk+-- images. module B9.DiskImages where -import B9.QCUtil-import GHC.Generics ( Generic )-import Control.Parallel.Strategies-import Data.Binary-import Data.Data-import Data.Hashable-import Data.Maybe-import Data.Semigroup as Sem-import System.FilePath-import Test.QuickCheck-import qualified Text.PrettyPrint.Boxes as Boxes-import Text.Printf+import B9.QCUtil+import Control.Parallel.Strategies+import Data.Binary+import Data.Data+import Data.Hashable+import Data.Maybe+import Data.Semigroup as Sem+import GHC.Generics (Generic)+import System.FilePath import Test.Hspec (Spec, describe, it)+import Test.QuickCheck+import qualified Text.PrettyPrint.Boxes as Boxes+import Text.Printf -- * Data types for disk image description, e.g. 'ImageTarget', -- 'ImageDestination', 'Image', 'MountPoint', 'SharedImage'@@ -22,115 +22,140 @@ -- | Build target for disk images; the destination, format and size of the image -- to generate, as well as how to create or obtain the image before a -- 'B9.Vm.VmScript' is executed with the image mounted at a 'MountPoint'.-data ImageTarget = ImageTarget- ImageDestination- ImageSource- MountPoint- deriving (Read, Show, Typeable, Data, Eq,Generic)+data ImageTarget+ = ImageTarget+ ImageDestination+ ImageSource+ MountPoint+ deriving (Read, Show, Typeable, Data, Eq, Generic) instance Hashable ImageTarget+ instance Binary ImageTarget+ instance NFData ImageTarget -- | A mount point or 'NotMounted' data MountPoint = MountPoint FilePath | NotMounted- deriving (Show, Read, Typeable, Data, Eq,Generic)+ deriving (Show, Read, Typeable, Data, Eq, Generic) instance Hashable MountPoint+ instance Binary MountPoint+ instance NFData MountPoint -- | The destination of an image.-data ImageDestination = Share String ImageType ImageResize- -- ^ Create the image and some meta data so that other- -- builds can use them as 'ImageSource's via 'From'.- | LiveInstallerImage String FilePath ImageResize- -- ^ __DEPRECATED__ Export a raw image that can directly- -- be booted.- | LocalFile Image ImageResize- -- ^ Write an image file to the path in the first- -- argument., possible resizing it,- | Transient- -- ^ Do not export the image. Usefule if the main- -- objective of the b9 build is not an image file, but- -- rather some artifact produced by executing by a- -- containerize build.- deriving (Read, Show, Typeable, Data,Eq,Generic)+data ImageDestination+ = -- | Create the image and some meta data so that other+ -- builds can use them as 'ImageSource's via 'From'.+ Share String ImageType ImageResize+ | -- | __DEPRECATED__ Export a raw image that can directly+ -- be booted.+ LiveInstallerImage String FilePath ImageResize+ | -- | Write an image file to the path in the first+ -- argument., possible resizing it,+ LocalFile Image ImageResize+ | -- | Do not export the image. Usefule if the main+ -- objective of the b9 build is not an image file, but+ -- rather some artifact produced by executing by a+ -- containerize build.+ Transient+ deriving (Read, Show, Typeable, Data, Eq, Generic) instance Hashable ImageDestination+ instance Binary ImageDestination+ instance NFData ImageDestination -- | Specification of how the image to build is obtained.-data ImageSource = EmptyImage String FileSystem ImageType ImageSize- -- ^ Create an empty image file having a file system label- -- (first parameter), a file system type (e.g. 'Ext4') and an- -- 'ImageSize'- | CopyOnWrite Image- -- ^ __DEPRECATED__- | SourceImage Image Partition ImageResize- -- ^ Clone an existing image file; if the image file contains- -- partitions, select the partition to use, b9 will extract- -- that partition by reading the offset of the partition from- -- the partition table and extract it using @dd@.- | From String ImageResize- -- ^ Use an image previously shared by via 'Share'.- deriving (Show,Read,Typeable,Data,Eq,Generic)+data ImageSource+ = -- | Create an empty image file having a file system label+ -- (first parameter), a file system type (e.g. 'Ext4') and an+ -- 'ImageSize'+ EmptyImage String FileSystem ImageType ImageSize+ | -- | __DEPRECATED__+ CopyOnWrite Image+ | -- | Clone an existing image file; if the image file contains+ -- partitions, select the partition to use, b9 will extract+ -- that partition by reading the offset of the partition from+ -- the partition table and extract it using @dd@.+ SourceImage Image Partition ImageResize+ | -- | Use an image previously shared by via 'Share'.+ From String ImageResize+ deriving (Show, Read, Typeable, Data, Eq, Generic) instance Hashable ImageSource+ instance Binary ImageSource+ instance NFData ImageSource -- | The partition to extract.-data Partition = NoPT -- ^ There is no partition table on the image- | Partition Int -- ^ Extract partition @n@ @n@ must be in @0..3@- deriving (Eq, Show, Read, Typeable, Data,Generic)+data Partition+ = -- | There is no partition table on the image+ NoPT+ | -- | Extract partition @n@ @n@ must be in @0..3@+ Partition Int+ deriving (Eq, Show, Read, Typeable, Data, Generic) instance Hashable Partition+ instance Binary Partition+ instance NFData Partition -- | A vm disk image file consisting of a path to the image file, and the type -- and file system. data Image = Image FilePath ImageType FileSystem- deriving (Eq, Show, Read, Typeable, Data,Generic)+ deriving (Eq, Show, Read, Typeable, Data, Generic) instance Hashable Image+ instance Binary Image+ instance NFData Image -- | An image type defines the actual /file format/ of a file containing file -- systems. These are like /virtual harddrives/ data ImageType = Raw | QCow2 | Vmdk- deriving (Eq,Read,Typeable,Data,Show,Generic)+ deriving (Eq, Read, Typeable, Data, Show, Generic) instance Hashable ImageType+ instance Binary ImageType+ instance NFData ImageType -- | The file systems that b9 can use and convert. data FileSystem = NoFileSystem | Ext4 | Ext4_64 | ISO9660 | VFAT- deriving (Eq,Show,Read,Typeable,Data,Generic)+ deriving (Eq, Show, Read, Typeable, Data, Generic) instance Hashable FileSystem+ instance Binary FileSystem+ instance NFData FileSystem -- | A data type for image file or file system size; instead of passing 'Int's -- around this also captures a size unit so that the 'Int' can be kept small data ImageSize = ImageSize Int SizeUnit- deriving (Eq, Show, Read, Typeable, Data, Generic)+ deriving (Eq, Show, Read, Typeable, Data, Generic) instance Hashable ImageSize+ instance Binary ImageSize+ instance NFData ImageSize -- | Convert a size in bytes to an 'ImageSize' bytesToKiloBytes :: Int -> ImageSize-bytesToKiloBytes x = let kbRoundedDown = x `div` 1024- rest = x `mod` 1024- kbRoundedUp = if rest > 0 then kbRoundedDown + 1 else kbRoundedDown- in ImageSize kbRoundedUp KB+bytesToKiloBytes x =+ let kbRoundedDown = x `div` 1024+ rest = x `mod` 1024+ kbRoundedUp = if rest > 0 then kbRoundedDown + 1 else kbRoundedDown+ in ImageSize kbRoundedUp KB -- | Convert an 'ImageSize' to kibi bytes. imageSizeToKiB :: ImageSize -> Int@@ -158,37 +183,41 @@ normalizeSize (ImageSize (value * sizeUnitKiB unit + value' * sizeUnitKiB unit') KB) - -- | Enumeration of size multipliers. The exact semantics may vary depending on -- what external tools look at these. E.g. the size unit is convert to a size -- parameter of the @qemu-img@ command line tool. data SizeUnit = KB | MB | GB- deriving (Eq, Show, Read, Ord, Enum, Bounded, Typeable, Data, Generic)+ deriving (Eq, Show, Read, Ord, Enum, Bounded, Typeable, Data, Generic) instance Hashable SizeUnit+ instance Binary SizeUnit+ instance NFData SizeUnit -- | How to resize an image file.-data ImageResize = ResizeImage ImageSize- -- ^ Resize the image __but not the file system__. Note that- -- a file system contained in the image file might be- -- corrupted by this operation. To not only resize the image- -- file but also the fil system contained in it, use- -- 'Resize'.- | Resize ImageSize- -- ^ Resize an image and the contained file system.- | ShrinkToMinimumAndIncrease ImageSize- -- ^ Shrink to minimum size needed and increase by the amount given.- | ShrinkToMinimum- -- ^ Resize an image and the contained file system to the- -- smallest size to fit the contents of the file system.- | KeepSize- -- ^ Do not change the image size.- deriving (Eq, Show, Read, Typeable, Data, Generic)+data ImageResize+ = -- | Resize the image __but not the file system__. Note that+ -- a file system contained in the image file might be+ -- corrupted by this operation. To not only resize the image+ -- file but also the fil system contained in it, use+ -- 'Resize'.+ ResizeImage ImageSize+ | -- | Resize an image and the contained file system.+ Resize ImageSize+ | -- | Shrink to minimum size needed and increase by the amount given.+ ShrinkToMinimumAndIncrease ImageSize+ | -- | Resize an image and the contained file system to the+ -- smallest size to fit the contents of the file system.+ ShrinkToMinimum+ | -- | Do not change the image size.+ KeepSize+ deriving (Eq, Show, Read, Typeable, Data, Generic) instance Hashable ImageResize+ instance Binary ImageResize+ instance NFData ImageResize -- | A type alias that indicates that something of type @a@ is mount at a@@ -200,23 +229,26 @@ -- | 'SharedImage' holds all data necessary to describe an __instance__ of a shared -- image identified by a 'SharedImageName'. Shared images are stored in -- 'B9.Repository's.-data SharedImage =- SharedImage SharedImageName- SharedImageDate- SharedImageBuildId- ImageType- FileSystem- deriving (Eq,Read,Show,Typeable,Data,Generic)+data SharedImage+ = SharedImage+ SharedImageName+ SharedImageDate+ SharedImageBuildId+ ImageType+ FileSystem+ deriving (Eq, Read, Show, Typeable, Data, Generic) instance Hashable SharedImage+ instance Binary SharedImage+ instance NFData SharedImage -- | The name of the image is the de-facto identifier for push, pull, 'From' and -- 'Share'. B9 always selects the newest version the shared image identified -- by that name when using a shared image as an 'ImageSource'. This is a -- wrapper around a string that identifies a 'SharedImage'-newtype SharedImageName = SharedImageName String deriving (Eq,Ord,Read,Show,Typeable,Data,Hashable,Binary,NFData)+newtype SharedImageName = SharedImageName String deriving (Eq, Ord, Read, Show, Typeable, Data, Hashable, Binary, NFData) -- | Get the String representation of a 'SharedImageName'. fromSharedImageName :: SharedImageName -> String@@ -225,7 +257,7 @@ -- | The exact time that build job __started__. -- This is a wrapper around a string contains the build date of a -- 'SharedImage'; this is purely additional convenience and typesafety-newtype SharedImageDate = SharedImageDate String deriving (Eq,Ord,Read,Show,Typeable,Data,Hashable,Binary,NFData)+newtype SharedImageDate = SharedImageDate String deriving (Eq, Ord, Read, Show, Typeable, Data, Hashable, Binary, NFData) -- | Every B9 build running in a 'B9Monad' -- contains a random unique id that is generated once per build (no matter how@@ -233,7 +265,7 @@ -- of the build that created the shared image instance. This is A wrapper -- around a string contains the build id of a 'SharedImage'; this is purely -- additional convenience and typesafety-newtype SharedImageBuildId = SharedImageBuildId String deriving (Eq,Ord,Read,Show,Typeable,Data,Hashable,Binary,NFData)+newtype SharedImageBuildId = SharedImageBuildId String deriving (Eq, Ord, Read, Show, Typeable, Data, Hashable, Binary, NFData) -- | Get the String representation of a 'SharedImageBuildId'. fromSharedImageBuildId :: SharedImageBuildId -> String@@ -241,8 +273,8 @@ -- | Shared images are ordered by name, build date and build id instance Ord SharedImage where- compare (SharedImage n d b _ _) (SharedImage n' d' b' _ _) =- compare n n' Sem.<> compare d d' Sem.<> compare b b'+ compare (SharedImage n d b _ _) (SharedImage n' d' b' _ _) =+ compare n n' Sem.<> compare d d' Sem.<> compare b b' -- * Constructor and accessors for 'Image' 'ImageTarget' 'ImageSource' -- 'ImageDestination' and 'SharedImage'@@ -260,23 +292,23 @@ -- by B9. getImageDestinationOutputFiles :: ImageTarget -> [FilePath] getImageDestinationOutputFiles (ImageTarget d _ _) = case d of- LiveInstallerImage liName liPath _ ->- let path = liPath </> "machines" </> liName </> "disks" </> "raw"- in [path </> "0.raw", path </> "0.size", path </> "VERSION"]- LocalFile (Image lfPath _ _) _ -> [lfPath]- _ -> []+ LiveInstallerImage liName liPath _ ->+ let path = liPath </> "machines" </> liName </> "disks" </> "raw"+ in [path </> "0.raw", path </> "0.size", path </> "VERSION"]+ LocalFile (Image lfPath _ _) _ -> [lfPath]+ _ -> [] -- | Return the name of a shared image, if the 'ImageDestination' is a 'Share' -- destination imageDestinationSharedImageName :: ImageDestination -> Maybe SharedImageName imageDestinationSharedImageName (Share n _ _) = Just (SharedImageName n)-imageDestinationSharedImageName _ = Nothing+imageDestinationSharedImageName _ = Nothing -- | Return the name of a shared source image, if the 'ImageSource' is a 'From' -- source imageSourceSharedImageName :: ImageSource -> Maybe SharedImageName imageSourceSharedImageName (From n _) = Just (SharedImageName n)-imageSourceSharedImageName _ = Nothing+imageSourceSharedImageName _ = Nothing -- | Get the 'ImageDestination' of an 'ImageTarget' itImageDestination :: ImageTarget -> ImageDestination@@ -290,42 +322,45 @@ itImageMountPoint :: ImageTarget -> MountPoint itImageMountPoint (ImageTarget _ _ m) = m - -- | Return true if a 'Partition' parameter is actually referring to a partition, -- false if it is 'NoPT' isPartitioned :: Partition -> Bool-isPartitioned p | p == NoPT = False- | otherwise = True+isPartitioned p+ | p == NoPT = False+ | otherwise = True -- | Return the 'Partition' index or throw a runtime error if applied to 'NoPT' getPartition :: Partition -> Int getPartition (Partition p) = p-getPartition NoPT = error "No partitions!"+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 Raw = "raw" imageFileExtension QCow2 = "qcow2"-imageFileExtension Vmdk = "vmdk"+imageFileExtension Vmdk = "vmdk" -- | Change the image file format and also rename the image file name to -- have the appropriate file name extension. See 'imageFileExtension' and -- 'replaceExtension' changeImageFormat :: ImageType -> Image -> Image changeImageFormat fmt' (Image img _ fs) = Image img' fmt' fs- where img' = replaceExtension img (imageFileExtension fmt')+ 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+ where+ img' = dir </> takeFileName img -- * Constructors and accessors for 'ImageSource's+ getImageSourceImageType :: ImageSource -> Maybe ImageType getImageSourceImageType (EmptyImage _ _ t _) = Just t-getImageSourceImageType (CopyOnWrite i ) = Just $ imageImageType i-getImageSourceImageType (SourceImage i _ _ ) = Just $ imageImageType i-getImageSourceImageType (From _ _ ) = Nothing+getImageSourceImageType (CopyOnWrite i) = Just $ imageImageType i+getImageSourceImageType (SourceImage i _ _) = Just $ imageImageType i+getImageSourceImageType (From _ _) = Nothing -- * Constructors and accessors for 'SharedImage's @@ -351,24 +386,28 @@ where nameC = col "Name" ((\(SharedImageName n) -> n) . sharedImageName) dateC = col "Date" ((\(SharedImageDate n) -> n) . sharedImageDate)- idC = col "ID"- ((\(SharedImageBuildId n) -> n) . sharedImageBuildId)+ idC =+ col+ "ID"+ ((\(SharedImageBuildId n) -> n) . sharedImageBuildId) col title accessor =- Boxes.text title Boxes.// Boxes.vcat Boxes.left cells- where cells = Boxes.text . accessor <$> imgs+ Boxes.text title Boxes.// Boxes.vcat Boxes.left cells+ where+ cells = Boxes.text . accessor <$> imgs -- | 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+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+sharedImageFileName (SharedImage (SharedImageName n) _ (SharedImageBuildId bid) _ _) =+ n ++ "_" ++ bid <.> sharedImageFileExtension sharedImagesRootDirectory :: FilePath sharedImagesRootDirectory = "b9_shared_images"@@ -385,7 +424,8 @@ -- | Use a 'QCow2' image with an 'Ext4' file system transientCOWImage :: FilePath -> FilePath -> ImageTarget-transientCOWImage fileName mountPoint = ImageTarget+transientCOWImage fileName mountPoint =+ ImageTarget Transient (CopyOnWrite (Image fileName QCow2 Ext4)) (MountPoint mountPoint)@@ -393,39 +433,43 @@ -- | Use a shared image transientSharedImage :: SharedImageName -> FilePath -> ImageTarget transientSharedImage (SharedImageName name) mountPoint =- ImageTarget Transient (From name KeepSize) (MountPoint mountPoint)+ ImageTarget Transient (From name KeepSize) (MountPoint mountPoint) -- | Use a shared image transientLocalImage :: FilePath -> FilePath -> ImageTarget transientLocalImage name mountPoint =- ImageTarget Transient (From name KeepSize) (MountPoint mountPoint)+ ImageTarget Transient (From name KeepSize) (MountPoint mountPoint) -- | Share a 'QCow2' image with 'Ext4' fs shareCOWImage :: FilePath -> SharedImageName -> FilePath -> ImageTarget-shareCOWImage srcFilename (SharedImageName destName) mountPoint = ImageTarget+shareCOWImage srcFilename (SharedImageName destName) mountPoint =+ ImageTarget (Share destName QCow2 KeepSize) (CopyOnWrite (Image srcFilename QCow2 Ext4)) (MountPoint mountPoint) -- | Share an image based on a shared image-shareSharedImage- :: SharedImageName -> SharedImageName -> FilePath -> ImageTarget-shareSharedImage (SharedImageName srcName) (SharedImageName destName) mountPoint- = ImageTarget (Share destName QCow2 KeepSize)- (From srcName KeepSize)- (MountPoint mountPoint)+shareSharedImage ::+ SharedImageName -> SharedImageName -> FilePath -> ImageTarget+shareSharedImage (SharedImageName srcName) (SharedImageName destName) mountPoint =+ ImageTarget+ (Share destName QCow2 KeepSize)+ (From srcName KeepSize)+ (MountPoint mountPoint) -- | Share a 'QCow2' image with 'Ext4' fs shareLocalImage :: FilePath -> SharedImageName -> FilePath -> ImageTarget-shareLocalImage srcName (SharedImageName destName) mountPoint = ImageTarget+shareLocalImage srcName (SharedImageName destName) mountPoint =+ ImageTarget (Share destName QCow2 KeepSize) (SourceImage (Image srcName QCow2 Ext4) NoPT KeepSize) (MountPoint mountPoint) -- | Export a 'QCow2' image with 'Ext4' fs-cowToliveInstallerImage- :: String -> FilePath -> FilePath -> FilePath -> ImageTarget-cowToliveInstallerImage srcName destName outDir mountPoint = ImageTarget+cowToliveInstallerImage ::+ String -> FilePath -> FilePath -> FilePath -> ImageTarget+cowToliveInstallerImage srcName destName outDir mountPoint =+ ImageTarget (LiveInstallerImage destName outDir KeepSize) (CopyOnWrite (Image srcName QCow2 Ext4)) (MountPoint mountPoint)@@ -433,7 +477,8 @@ -- | Export a 'QCow2' image file with 'Ext4' fs as -- a local file cowToLocalImage :: FilePath -> FilePath -> FilePath -> ImageTarget-cowToLocalImage srcName destName mountPoint = ImageTarget+cowToLocalImage srcName destName mountPoint =+ ImageTarget (LocalFile (Image destName QCow2 Ext4) KeepSize) (CopyOnWrite (Image srcName QCow2 Ext4)) (MountPoint mountPoint)@@ -441,7 +486,8 @@ -- | Export a 'QCow2' image file with 'Ext4' fs as -- a local file localToLocalImage :: FilePath -> FilePath -> FilePath -> ImageTarget-localToLocalImage srcName destName mountPoint = ImageTarget+localToLocalImage srcName destName mountPoint =+ ImageTarget (LocalFile (Image destName QCow2 Ext4) KeepSize) (SourceImage (Image srcName QCow2 Ext4) NoPT KeepSize) (MountPoint mountPoint)@@ -449,7 +495,8 @@ -- | Create a local image file from the contents of the first partition -- of a local 'QCow2' image. partition1ToLocalImage :: FilePath -> FilePath -> FilePath -> ImageTarget-partition1ToLocalImage srcName destName mountPoint = ImageTarget+partition1ToLocalImage srcName destName mountPoint =+ ImageTarget (LocalFile (Image destName QCow2 Ext4) KeepSize) (SourceImage (Image srcName QCow2 Ext4) NoPT KeepSize) (MountPoint mountPoint)@@ -458,14 +505,15 @@ -- | Split any image target into two image targets, one for creating an intermediate shared image and one -- from the intermediate shared image to the output image.-splitToIntermediateSharedImage- :: ImageTarget -> SharedImageName -> (ImageTarget, ImageTarget)-splitToIntermediateSharedImage (ImageTarget dst src mnt) (SharedImageName intermediateName)- = (imgTargetShared, imgTargetExport)+splitToIntermediateSharedImage ::+ ImageTarget -> SharedImageName -> (ImageTarget, ImageTarget)+splitToIntermediateSharedImage (ImageTarget dst src mnt) (SharedImageName intermediateName) =+ (imgTargetShared, imgTargetExport) where imgTargetShared = ImageTarget intermediateTo src mnt imgTargetExport = ImageTarget dst intermediateFrom mnt- intermediateTo = Share+ intermediateTo =+ Share intermediateName (fromMaybe sharedImageDefaultImageType (getImageSourceImageType src)) KeepSize@@ -474,82 +522,87 @@ -- * 'Arbitrary' instances for quickcheck instance Arbitrary ImageTarget where- arbitrary =- ImageTarget- <$> smaller arbitrary- <*> smaller arbitrary- <*> smaller arbitrary+ arbitrary =+ ImageTarget+ <$> smaller arbitrary+ <*> smaller arbitrary+ <*> smaller arbitrary instance Arbitrary ImageSource where- arbitrary = oneof- [ EmptyImage "img-label"- <$> smaller arbitrary- <*> smaller arbitrary- <*> smaller arbitrary- , CopyOnWrite <$> smaller arbitrary- , SourceImage- <$> smaller arbitrary- <*> smaller arbitrary- <*> smaller arbitrary- , From <$> arbitrarySharedImageName <*> smaller arbitrary- ]+ arbitrary =+ oneof+ [ EmptyImage "img-label"+ <$> smaller arbitrary+ <*> smaller arbitrary+ <*> smaller arbitrary,+ CopyOnWrite <$> smaller arbitrary,+ SourceImage+ <$> smaller arbitrary+ <*> smaller arbitrary+ <*> smaller arbitrary,+ From <$> arbitrarySharedImageName <*> smaller arbitrary+ ] instance Arbitrary ImageDestination where- arbitrary = oneof- [ Share- <$> arbitrarySharedImageName- <*> smaller arbitrary- <*> smaller arbitrary- , LiveInstallerImage "live-installer" "output-path"- <$> smaller arbitrary- , pure Transient- ]+ arbitrary =+ oneof+ [ Share+ <$> arbitrarySharedImageName+ <*> smaller arbitrary+ <*> smaller arbitrary,+ LiveInstallerImage "live-installer" "output-path"+ <$> smaller arbitrary,+ pure Transient+ ] instance Arbitrary MountPoint where- arbitrary = elements [MountPoint "/mnt", NotMounted]+ arbitrary = elements [MountPoint "/mnt", NotMounted] instance Arbitrary ImageResize where- arbitrary = oneof- [ ResizeImage <$> smaller arbitrary- , Resize <$> smaller arbitrary- , ShrinkToMinimumAndIncrease <$> smaller arbitrary- , pure ShrinkToMinimum- , pure KeepSize- ]+ arbitrary =+ oneof+ [ ResizeImage <$> smaller arbitrary,+ Resize <$> smaller arbitrary,+ ShrinkToMinimumAndIncrease <$> smaller arbitrary,+ pure ShrinkToMinimum,+ pure KeepSize+ ] instance Arbitrary Partition where- arbitrary = oneof [Partition <$> elements [0, 1, 2], pure NoPT]+ arbitrary = oneof [Partition <$> elements [0, 1, 2], pure NoPT] instance Arbitrary Image where- arbitrary =- Image "img-file-name" <$> smaller arbitrary <*> smaller arbitrary+ arbitrary =+ Image "img-file-name" <$> smaller arbitrary <*> smaller arbitrary instance Arbitrary FileSystem where- arbitrary = elements [Ext4]+ arbitrary = elements [Ext4] instance Arbitrary ImageType where- arbitrary = elements [Raw, QCow2, Vmdk]+ arbitrary = elements [Raw, QCow2, Vmdk] instance Arbitrary ImageSize where- arbitrary = ImageSize <$> smaller arbitrary <*> smaller arbitrary+ arbitrary = ImageSize <$> smaller arbitrary <*> smaller arbitrary instance Arbitrary SizeUnit where- arbitrary = elements [KB, MB, GB]+ arbitrary = elements [KB, MB, GB] instance Arbitrary SharedImageName where- arbitrary = SharedImageName <$> arbitrarySharedImageName+ arbitrary = SharedImageName <$> arbitrarySharedImageName arbitrarySharedImageName :: Gen String arbitrarySharedImageName =- elements [ printf "arbitrary-shared-img-name-%d" x | x <- [0 :: Int .. 3] ]+ elements [printf "arbitrary-shared-img-name-%d" x | x <- [0 :: Int .. 3]] unitTests :: Spec unitTests =- describe "ImageSize" $- describe "bytesToKiloBytes" $ do- it "accepts maxBound" $- toInteger (imageSizeToKiB (bytesToKiloBytes maxBound)) * 1024 === toInteger (maxBound :: Int) + 1- it "doesn't decrease in size" $- property- (\(x :: Int) ->- x <= maxBound - 1024 ==> label "bytesToKiloBytes x >= x" (imageSizeToKiB (bytesToKiloBytes x) >= (x `div` 1024)))+ describe "ImageSize"+ $ describe "bytesToKiloBytes"+ $ do+ it "accepts maxBound" $+ toInteger (imageSizeToKiB (bytesToKiloBytes maxBound)) * 1024 === toInteger (maxBound :: Int) + 1+ it "doesn't decrease in size" $+ property+ ( \(x :: Int) ->+ x <= maxBound - 1024 ==> label "bytesToKiloBytes x >= x" (imageSizeToKiB (bytesToKiloBytes x) >= (x `div` 1024))+ )
+ src/lib/B9/Docker.hs view
@@ -0,0 +1,77 @@+-- | Implementation of an execution environment that uses /docker/.+module B9.Docker+ ( Docker (..),+ )+where++import B9.B9Config+ ( ContainerCapability,+ dockerConfigs,+ getB9Config,+ )+import B9.B9Config.Docker as X+import B9.B9Exec+import B9.BuildInfo+import B9.Container+import B9.DiskImages+import B9.ExecEnv+import B9.ShellScript+import Control.Lens (view)+import Control.Monad.IO.Class+ ( MonadIO,+ liftIO,+ )+import Data.Char (toLower)+import System.Directory+import System.FilePath+import System.IO.B9Extras+ ( UUID (),+ randomUUID,+ )+import Text.Printf (printf)++newtype Docker = Docker DockerConfig++instance Backend Docker where+ getBackendConfig _ =+ fmap Docker . view dockerConfigs <$> getB9Config++ -- supportedImageTypes :: proxy config -> [ImageType]+ supportedImageTypes _ = [Raw]++ -- runInEnvironment ::+ -- forall e.+ -- (Member BuildInfoReader e, CommandIO e) =>+ -- config ->+ -- ExecEnv ->+ -- Script ->+ -- Eff e Bool+ runInEnvironment (Docker dcfg) env scriptIn = do+ if emptyScript scriptIn+ then return True+ else do error "TODO"+-- where+-- setUp = do+-- buildId <- getBuildId+-- buildBaseDir <- getBuildDir+-- uuid <- randomUUID+-- let scriptDirHost = buildDir </> "init-script"+-- scriptDirGuest = "/" ++ buildId+-- domainFile = buildBaseDir </> uuid' <.> domainConfig+-- mkDomain =+-- createDomain cfgIn env buildId uuid' scriptDirHost scriptDirGuest+-- uuid' = printf "%U" uuid+-- setupEnv =+-- Begin+-- [ Run "export" ["HOME=/root"],+-- Run "export" ["USER=root"],+-- Run "source" ["/etc/profile"]+-- ]+-- script = Begin [setupEnv, scriptIn, successMarkerCmd scriptDirGuest]+-- buildDir = buildBaseDir </> uuid'+-- liftIO $ do+-- createDirectoryIfMissing True scriptDirHost+-- writeSh (scriptDirHost </> initScript) script+-- domain <- mkDomain+-- writeFile domainFile domain+-- return $ Context scriptDirHost uuid domainFile cfgIn
src/lib/B9/Environment.hs view
@@ -1,90 +1,95 @@-{-| An 'Environment' contains textual key value pairs, relavant for string template-substitution.--The variables are passed to the B9 build either via command line, OS environment-variables or configuration file.--@since 0.5.62- -}+-- | An 'Environment' contains textual key value pairs, relavant for string template+-- substitution.+--+-- The variables are passed to the B9 build either via command line, OS environment+-- variables or configuration file.+--+-- @since 0.5.62 module B9.Environment- ( Environment()- , fromStringPairs- , addBinding- , addStringBinding- , addLocalStringBinding- , addPositionalArguments- , addLocalPositionalArguments- , EnvironmentReader- , hasKey- , runEnvironmentReader- , askEnvironment- , localEnvironment- , lookupOrThrow- , lookupEither- , KeyNotFound(..)- , DuplicateKey(..)+ ( Environment (),+ fromStringPairs,+ addBinding,+ addStringBinding,+ addLocalStringBinding,+ addPositionalArguments,+ addLocalPositionalArguments,+ EnvironmentReader,+ hasKey,+ runEnvironmentReader,+ askEnvironment,+ localEnvironment,+ lookupOrThrow,+ lookupEither,+ KeyNotFound (..),+ DuplicateKey (..), ) where -import B9.B9Error-import B9.Text-import Control.Arrow ( (***) )-import Control.Exception ( Exception )-import Control.Eff as Eff-import Control.Eff.Reader.Lazy as Eff-import Control.Parallel.Strategies-import Data.Data-import Data.Foldable-import Data.HashMap.Strict ( HashMap )-import qualified Data.HashMap.Strict as HashMap-import Data.Maybe ( maybe- , isJust- )-import GHC.Generics ( Generic )+import B9.B9Error+import B9.Text+import Control.Arrow ((***))+import Control.Eff as Eff+import Control.Eff.Reader.Lazy as Eff+import Control.Exception (Exception)+import Control.Parallel.Strategies+import Data.Data+import Data.Foldable+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Data.Maybe+ ( isJust,+ maybe,+ )+import GHC.Generics (Generic) -- | A map of textual keys to textual values. -- -- @since 0.5.62-data Environment = MkEnvironment- { nextPosition :: Int- , fromEnvironment :: HashMap Text Text- } deriving (Show, Typeable, Data, Eq, Generic)+data Environment+ = MkEnvironment+ { nextPosition :: Int,+ fromEnvironment :: HashMap Text Text+ }+ deriving (Show, Typeable, Data, Eq, Generic) instance NFData Environment instance Semigroup Environment where- e1 <> e2 = MkEnvironment- { nextPosition = case (nextPosition e1, nextPosition e2) of- (1 , 1 ) -> 1- (1 , p2) -> p2- (p1, 1 ) -> p1- _ -> error- ( "Overlapping positional arguments (<>): ("- ++ show e1- ++ ") <> ("- ++ show e2- ++ ")"- )- , fromEnvironment = let i = HashMap.intersection h1 h2- h1 = fromEnvironment e1- h2 = fromEnvironment e2- in if HashMap.null i || all- (\k -> HashMap.lookup k h1 == HashMap.lookup k h2- )- (HashMap.keys i)- then- h1 <> h2- else- error- ( "Overlapping entries (<>): ("- ++ show e1- ++ ") <> ("- ++ show e2- ++ "): ("- ++ show i- ++ ")"- )- }+ e1 <> e2 =+ MkEnvironment+ { nextPosition = case (nextPosition e1, nextPosition e2) of+ (1, 1) -> 1+ (1, p2) -> p2+ (p1, 1) -> p1+ _ ->+ error+ ( "Overlapping positional arguments (<>): ("+ ++ show e1+ ++ ") <> ("+ ++ show e2+ ++ ")"+ ),+ fromEnvironment =+ let i = HashMap.intersection h1 h2+ h1 = fromEnvironment e1+ h2 = fromEnvironment e2+ in if HashMap.null i+ || all+ ( \k -> HashMap.lookup k h1 == HashMap.lookup k h2+ )+ (HashMap.keys i)+ then h1 <> h2+ else+ error+ ( "Overlapping entries (<>): ("+ ++ show e1+ ++ ") <> ("+ ++ show e2+ ++ "): ("+ ++ show i+ ++ ")"+ )+ } instance Monoid Environment where mempty = MkEnvironment 1 HashMap.empty@@ -97,31 +102,34 @@ -- -- @since 0.5.62 addPositionalArguments :: [Text] -> Environment -> Environment-addPositionalArguments = flip- (foldl'- (\(MkEnvironment i e) arg -> MkEnvironment- (i + 1)- (HashMap.insert (unsafeRenderToText ("arg_" ++ show i)) arg e)+addPositionalArguments =+ flip+ ( foldl'+ ( \(MkEnvironment i e) arg ->+ MkEnvironment+ (i + 1)+ (HashMap.insert (unsafeRenderToText ("arg_" ++ show i)) arg e)+ ) )- ) - -- | Convenient wrapper around 'addPositionalArguments' and 'localEnvironment'. -- -- @since 0.5.65-addLocalPositionalArguments- :: Member EnvironmentReader e => [String] -> Eff e a -> Eff e a+addLocalPositionalArguments ::+ Member EnvironmentReader e => [String] -> Eff e a -> Eff e a addLocalPositionalArguments extraPositional = localEnvironment appendVars- where- appendVars = addPositionalArguments (unsafeRenderToText <$> extraPositional)+ where+ appendVars = addPositionalArguments (unsafeRenderToText <$> extraPositional) -- | Create an 'Environment' from a list of pairs ('String's). -- Duplicated entries are ignored. -- -- @since 0.5.62 fromStringPairs :: [(String, String)] -> Environment-fromStringPairs = MkEnvironment 0 . HashMap.fromList . fmap- (unsafeRenderToText *** unsafeRenderToText)+fromStringPairs =+ MkEnvironment 0 . HashMap.fromList+ . fmap+ (unsafeRenderToText *** unsafeRenderToText) -- | Insert a key value binding to the 'Environment'. --@@ -132,29 +140,30 @@ addBinding :: Member ExcB9 e => (Text, Text) -> Environment -> Eff e Environment addBinding (k, vNew) env = let h = fromEnvironment env- in case HashMap.lookup k h of- Just vOld | vOld /= vNew ->- throwSomeException (MkDuplicateKey k vOld vNew)+ in case HashMap.lookup k h of+ Just vOld+ | vOld /= vNew ->+ throwSomeException (MkDuplicateKey k vOld vNew) _ -> pure (MkEnvironment (nextPosition env) (HashMap.insert k vNew h)) -- | Insert 'String's into the 'Environment', see 'addBinding'. -- -- @since 0.5.62-addStringBinding- :: Member ExcB9 e => (String, String) -> Environment -> Eff e Environment+addStringBinding ::+ Member ExcB9 e => (String, String) -> Environment -> Eff e Environment addStringBinding = addBinding . (unsafeRenderToText *** unsafeRenderToText) -- | Insert a value into an 'Environment' like 'addStringBinding', -- but add it to the environment of the given effect, as in 'localEnvironment'. -- -- @since 0.5.65-addLocalStringBinding- :: (Member EnvironmentReader e, Member ExcB9 e)- => (String, String)- -> Eff e a- -> Eff e a+addLocalStringBinding ::+ (Member EnvironmentReader e, Member ExcB9 e) =>+ (String, String) ->+ Eff e a ->+ Eff e a addLocalStringBinding binding action = do- e <- askEnvironment+ e <- askEnvironment e' <- addStringBinding binding e localEnvironment (const e') action @@ -178,11 +187,11 @@ -- | Run a computation with a modified 'Environment' -- -- @since 0.5.62-localEnvironment- :: Member EnvironmentReader e- => (Environment -> Environment)- -> Eff e a- -> Eff e a+localEnvironment ::+ Member EnvironmentReader e =>+ (Environment -> Environment) ->+ Eff e a ->+ Eff e a localEnvironment = local -- | Lookup a key for a value.@@ -194,9 +203,10 @@ lookupOrThrow :: ('[ExcB9, EnvironmentReader] <:: e) => Text -> Eff e Text lookupOrThrow key = do env <- askEnvironment- maybe (throwSomeException (MkKeyNotFound key env))- return- (HashMap.lookup key (fromEnvironment env))+ maybe+ (throwSomeException (MkKeyNotFound key env))+ return+ (HashMap.lookup key (fromEnvironment env)) -- | Lookup a key for a value. --@@ -204,8 +214,8 @@ -- in the 'Environment', or 'Right' the value. -- -- @Since 0.5.62-lookupEither- :: Member EnvironmentReader e => Text -> Eff e (Either KeyNotFound Text)+lookupEither ::+ Member EnvironmentReader e => Text -> Eff e (Either KeyNotFound Text) lookupEither key = do env <- askEnvironment (return . maybe (Left (MkKeyNotFound key env)) Right)@@ -214,20 +224,23 @@ -- | An 'Exception' thrown by 'addBinding' indicating that a key already exists. -- -- @Since 0.5.62-data DuplicateKey = MkDuplicateKey- { duplicateKey :: Text- , duplicateKeyOldValue :: Text- , duplicateKeyNewValue :: Text- } deriving (Typeable, Show, Eq)+data DuplicateKey+ = MkDuplicateKey+ { duplicateKey :: Text,+ duplicateKeyOldValue :: Text,+ duplicateKeyNewValue :: Text+ }+ deriving (Typeable, Show, Eq) instance Exception DuplicateKey -- | An 'Exception' thrown by 'lookupOrThrow' indicating that a key does not exist. -- -- @Since 0.5.62-data KeyNotFound =- MkKeyNotFound Text- Environment+data KeyNotFound+ = MkKeyNotFound+ Text+ Environment deriving (Typeable, Eq) instance Exception KeyNotFound@@ -235,8 +248,8 @@ instance Show KeyNotFound where showsPrec _ (MkKeyNotFound key env) = let keys =- unlines (unsafeParseFromText <$> HashMap.keys (fromEnvironment env))- in showString "Invalid template parameter: \""+ unlines (unsafeParseFromText <$> HashMap.keys (fromEnvironment env))+ in showString "Invalid template parameter: \"" . showString (unsafeParseFromText key) . showString "\".\nValid variables:\n" . showString keys
src/lib/B9/ExecEnv.hs view
@@ -1,105 +1,122 @@ {-# 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".- -}++-- | 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(..)- )+ ( ExecEnv (..),+ Resources (..),+ noResources,+ SharedDirectory (..),+ CPUArch (..),+ RamSize (..),+ ) where -import Control.Parallel.Strategies-import Data.Binary-import Data.Data-import Data.Hashable-import Data.Semigroup as Sem-import B9.DiskImages-import GHC.Generics ( Generic )+import B9.DiskImages+import Control.Parallel.Strategies+import Data.Binary+import Data.Data+import Data.Hashable+import Data.Semigroup as Sem+import GHC.Generics (Generic) -data ExecEnv = ExecEnv- { envName :: String- , envImageMounts :: [Mounted Image]- , envSharedDirectories :: [SharedDirectory]- , envResources :: Resources- }- deriving (Read,Show,Typeable,Data,Eq,Generic)+-- | The environment for the execution of 'Script's inside a 'Container'+data ExecEnv+ = ExecEnv+ { envName :: String,+ envImageMounts :: [Mounted Image],+ envSharedDirectories :: [SharedDirectory],+ envResources :: Resources+ }+ deriving (Read, Show, Typeable, Data, Eq, Generic) instance Hashable ExecEnv+ instance Binary ExecEnv+ instance NFData ExecEnv data SharedDirectory- = SharedDirectory FilePath- MountPoint- | SharedDirectoryRO FilePath- MountPoint- | SharedSources MountPoint- deriving (Read,Show,Typeable,Data,Eq,Generic)+ = SharedDirectory+ FilePath+ MountPoint+ | SharedDirectoryRO+ FilePath+ MountPoint+ | SharedSources MountPoint+ deriving (Read, Show, Typeable, Data, Eq, Generic) instance Hashable SharedDirectory+ instance Binary SharedDirectory+ instance NFData SharedDirectory -data Resources = Resources- { maxMemory :: RamSize- , cpuCount :: Int- , cpuArch :: CPUArch- } deriving (Eq,Read,Show,Typeable,Data,Generic)+data Resources+ = Resources+ { maxMemory :: RamSize,+ cpuCount :: Int,+ cpuArch :: CPUArch+ }+ deriving (Eq, Read, Show, Typeable, Data, Generic) instance Hashable Resources+ instance Binary Resources+ instance NFData Resources instance Sem.Semigroup Resources where- (<>) (Resources m c a) (Resources m' c' a') =- Resources (m <> m') (max c c') (a <> a')+ (<>) (Resources m c a) (Resources m' c' a') =+ Resources (m <> m') (max c c') (a <> a') instance Monoid Resources where- mempty = Resources mempty 1 mempty- mappend = (Sem.<>)+ mempty = Resources mempty 1 mempty+ mappend = (Sem.<>) noResources :: Resources noResources = mempty data CPUArch- = X86_64- | I386- deriving (Read,Show,Typeable,Data,Eq,Generic)+ = X86_64+ | I386+ deriving (Read, Show, Typeable, Data, Eq, Generic) instance Hashable CPUArch+ instance Binary CPUArch+ instance NFData CPUArch instance Sem.Semigroup CPUArch where- I386 <> x = x- X86_64 <> _ = X86_64+ I386 <> x = x+ X86_64 <> _ = X86_64 instance Monoid CPUArch where- mempty = I386- mappend = (Sem.<>)+ mempty = I386+ mappend = (Sem.<>) data RamSize- = RamSize Int- SizeUnit- | AutomaticRamSize- deriving (Eq,Read,Show,Ord,Typeable,Data,Generic)+ = RamSize+ Int+ SizeUnit+ | AutomaticRamSize+ deriving (Eq, Read, Show, Ord, Typeable, Data, Generic) instance Hashable RamSize+ instance Binary RamSize+ instance NFData RamSize instance Sem.Semigroup RamSize where- AutomaticRamSize <> x = x- x <> AutomaticRamSize = x- r <> r' = max r r'+ AutomaticRamSize <> x = x+ x <> AutomaticRamSize = x+ r <> r' = max r r' instance Monoid RamSize where- mempty = AutomaticRamSize- mappend = (Sem.<>)+ mempty = AutomaticRamSize+ mappend = (Sem.<>)
src/lib/B9/LibVirtLXC.hs view
@@ -1,97 +1,100 @@-{-| Implementation of an execution environment that uses "libvirt-lxc". -}+-- | Implementation of an execution environment that uses "libvirt-lxc". module B9.LibVirtLXC- ( runInEnvironment- , supportedImageTypes- , logLibVirtLXCConfig- , module X+ ( LibVirtLXC (..),+ module X, ) where -import B9.B9Config ( getB9Config- , libVirtLXCConfigs- )-import B9.B9Config.LibVirtLXC as X-import B9.B9Exec-import B9.B9Logging-import B9.BuildInfo-import B9.DiskImages-import B9.ExecEnv-import B9.ShellScript-import Control.Eff-import Control.Lens ( view )-import Control.Monad.IO.Class ( MonadIO- , liftIO- )-import Data.Char ( toLower )-import System.Directory-import System.FilePath-import System.IO.B9Extras ( UUID()- , randomUUID- )-import Text.Printf ( printf )+import B9.B9Config+ ( B9ConfigReader,+ ContainerCapability,+ getB9Config,+ libVirtLXCConfigs,+ )+import B9.B9Config.LibVirtLXC as X+import B9.B9Exec+import B9.B9Logging+import B9.BuildInfo+import B9.Container+import B9.DiskImages+import B9.ExecEnv+import B9.ShellScript+import Control.Eff+import Control.Lens (view)+import Control.Monad.IO.Class+ ( MonadIO,+ liftIO,+ )+import Data.Char (toLower)+import System.Directory+import System.FilePath+import System.IO.B9Extras+ ( UUID (),+ randomUUID,+ )+import Text.Printf (printf) -logLibVirtLXCConfig :: CommandIO e => LibVirtLXCConfig -> Eff e ()-logLibVirtLXCConfig c = traceL $ printf "USING LibVirtLXCConfig: %s" (show c)+newtype LibVirtLXC = LibVirtLXC LibVirtLXCConfig -supportedImageTypes :: [ImageType]-supportedImageTypes = [Raw]+instance Backend LibVirtLXC where+ getBackendConfig _ =+ fmap LibVirtLXC . view libVirtLXCConfigs <$> getB9Config+ supportedImageTypes _ = [Raw]+ runInEnvironment (LibVirtLXC cfgIn) env scriptIn =+ if emptyScript scriptIn+ then return True+ else setUp >>= execute+ where+ setUp = do+ buildId <- getBuildId+ buildBaseDir <- getBuildDir+ uuid <- randomUUID+ let scriptDirHost = buildDir </> "init-script"+ scriptDirGuest = "/" ++ buildId+ domainFile = buildBaseDir </> uuid' <.> domainConfig+ mkDomain =+ createDomain cfgIn env buildId uuid' scriptDirHost scriptDirGuest+ uuid' = printf "%U" uuid+ setupEnv =+ Begin+ [ Run "export" ["HOME=/root"],+ Run "export" ["USER=root"],+ Run "source" ["/etc/profile"]+ ]+ script = Begin [setupEnv, scriptIn, successMarkerCmd scriptDirGuest]+ buildDir = buildBaseDir </> uuid'+ liftIO $ do+ createDirectoryIfMissing True scriptDirHost+ writeSh (scriptDirHost </> initScript) script+ domain <- mkDomain+ writeFile domainFile domain+ return $ Context scriptDirHost uuid domainFile cfgIn -runInEnvironment- :: forall e- . (Member BuildInfoReader e, CommandIO e)- => ExecEnv- -> Script- -> Eff e Bool-runInEnvironment env scriptIn = if emptyScript scriptIn- then return True- else setUp >>= execute- where- setUp = do- mcfg <- view libVirtLXCConfigs <$> getB9Config- cfg <- maybe (fail "No LibVirtLXC Configuration!") return mcfg- buildId <- getBuildId- buildBaseDir <- getBuildDir- uuid <- randomUUID- let- scriptDirHost = buildDir </> "init-script"- scriptDirGuest = "/" ++ buildId- domainFile = buildBaseDir </> uuid' <.> domainConfig- mkDomain =- createDomain cfg env buildId uuid' scriptDirHost scriptDirGuest- uuid' = printf "%U" uuid- setupEnv = Begin- [ Run "export" ["HOME=/root"]- , Run "export" ["USER=root"]- , Run "source" ["/etc/profile"]- ]- script = Begin [setupEnv, scriptIn, successMarkerCmd scriptDirGuest]- buildDir = buildBaseDir </> uuid'- liftIO $ do- createDirectoryIfMissing True scriptDirHost- writeSh (scriptDirHost </> initScript) script- domain <- mkDomain- writeFile domainFile domain- return $ Context scriptDirHost uuid domainFile cfg- successMarkerCmd scriptDirGuest =- In scriptDirGuest [Run "touch" [successMarkerFile]]- execute :: Context -> Eff e Bool- execute (Context scriptDirHost _uuid domainFile cfg) = do- let virsh = virshCommand cfg- cmd $ printf "%s create '%s' --console --autodestroy" virsh domainFile+successMarkerCmd :: FilePath -> Script+successMarkerCmd scriptDirGuest =+ In scriptDirGuest [Run "touch" [successMarkerFile]]++successMarkerFile :: [Char]+successMarkerFile = "SUCCESS"++execute :: (CommandIO e, Member B9ConfigReader e) => Context -> Eff e Bool+execute (Context scriptDirHost _uuid domainFile cfg) = do+ cmd $ printf "%s create '%s' --console --autodestroy" virshCommand domainFile -- cmd $ printf "%s console %U" virsh uuid- liftIO (doesFileExist $ scriptDirHost </> successMarkerFile)- successMarkerFile = "SUCCESS"- virshCommand :: LibVirtLXCConfig -> String- virshCommand cfg = printf "%svirsh -c %s" useSudo' virshURI'- where- useSudo' = if useSudo cfg then "sudo " else ""- virshURI' = virshURI cfg+ liftIO (doesFileExist $ scriptDirHost </> successMarkerFile)+ where+ virshCommand :: String+ virshCommand = printf "%svirsh -c %s" useSudo' virshURI'+ where+ useSudo' = if useSudo cfg then "sudo " else ""+ virshURI' = virshURI cfg -data Context =- Context FilePath- UUID- FilePath- LibVirtLXCConfig+data Context+ = Context+ FilePath+ UUID+ FilePath+ LibVirtLXCConfig initScript :: String initScript = "init.sh"@@ -99,75 +102,74 @@ domainConfig :: String domainConfig = "domain.xml" -createDomain- :: MonadIO m- => LibVirtLXCConfig- -> ExecEnv- -> String- -> String- -> FilePath- -> FilePath- -> m String+createDomain ::+ MonadIO m =>+ LibVirtLXCConfig ->+ ExecEnv ->+ String ->+ String ->+ FilePath ->+ FilePath ->+ m String createDomain cfg e buildId uuid scriptDirHost scriptDirGuest = do emulatorPath <- getEmulatorPath cfg pure- ( "<domain type='lxc'>\n <name>"- ++ buildId- ++ "</name>\n <uuid>"- ++ uuid- ++ "</uuid>\n <memory unit='"- ++ memoryUnit cfg e- ++ "'>"- ++ memoryAmount cfg e- ++ "</memory>\n <currentMemory unit='"- ++ memoryUnit cfg e- ++ "'>"- ++ memoryAmount cfg e- ++ "</currentMemory>\n <vcpu placement='static'>"- ++ cpuCountStr e- ++ "</vcpu>\n <features>\n <capabilities policy='default'>\n "- ++ renderGuestCapabilityEntries cfg- ++ "\n </capabilities>\n </features>\n <os>\n <type arch='"- ++ osArch e- ++ "'>exe</type>\n <init>"- ++ scriptDirGuest- </> initScript- ++ "</init>\n </os>\n <clock offset='utc'/>\n <on_poweroff>destroy</on_poweroff>\n <on_reboot>restart</on_reboot>\n <on_crash>destroy</on_crash>\n <devices>\n <emulator>"- ++ emulatorPath- ++ "</emulator>\n"- ++ unlines- ( libVirtNetwork (_networkId cfg)- ++ (fsImage <$> envImageMounts e)- ++ (fsSharedDir <$> envSharedDirectories e)+ ( "<domain type='lxc'>\n <name>"+ ++ buildId+ ++ "</name>\n <uuid>"+ ++ uuid+ ++ "</uuid>\n <memory unit='"+ ++ memoryUnit cfg e+ ++ "'>"+ ++ memoryAmount cfg e+ ++ "</memory>\n <currentMemory unit='"+ ++ memoryUnit cfg e+ ++ "'>"+ ++ memoryAmount cfg e+ ++ "</currentMemory>\n <vcpu placement='static'>"+ ++ cpuCountStr e+ ++ "</vcpu>\n <features>\n <capabilities policy='default'>\n "+ ++ renderGuestCapabilityEntries cfg+ ++ "\n </capabilities>\n </features>\n <os>\n <type arch='"+ ++ osArch e+ ++ "'>exe</type>\n <init>"+ ++ scriptDirGuest+ </> initScript+ ++ "</init>\n </os>\n <clock offset='utc'/>\n <on_poweroff>destroy</on_poweroff>\n <on_reboot>restart</on_reboot>\n <on_crash>destroy</on_crash>\n <devices>\n <emulator>"+ ++ emulatorPath+ ++ "</emulator>\n"+ ++ unlines+ ( libVirtNetwork (_networkId cfg)+ ++ (fsImage <$> envImageMounts e)+ ++ (fsSharedDir <$> envSharedDirectories e) )- ++ "\n"- ++ " <filesystem type='mount'>\n <source dir='"- ++ scriptDirHost- ++ "'/>\n <target dir='"- ++ scriptDirGuest- ++ "'/>\n </filesystem>\n <console>\n <target type='lxc' port='0'/>\n </console>\n </devices>\n</domain>\n"+ ++ "\n"+ ++ " <filesystem type='mount'>\n <source dir='"+ ++ scriptDirHost+ ++ "'/>\n <target dir='"+ ++ scriptDirGuest+ ++ "'/>\n </filesystem>\n <console>\n <target type='lxc' port='0'/>\n </console>\n </devices>\n</domain>\n" ) - renderGuestCapabilityEntries :: LibVirtLXCConfig -> String renderGuestCapabilityEntries = unlines . map render . guestCapabilities- where- render :: LXCGuestCapability -> String- render cap =- let capStr = toLower <$> drop (length "CAP_") (show cap)- in printf "<%s state='on'/>" capStr+ where+ render :: ContainerCapability -> 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"+ I386 -> "i686" libVirtNetwork :: Maybe String -> [String] libVirtNetwork Nothing = [] libVirtNetwork (Just n) =- [ "<interface type='network'>"- , " <source network='" ++ n ++ "'/>"- , "</interface>"+ [ "<interface type='network'>",+ " <source network='" ++ n ++ "'/>",+ "</interface>" ] fsImage :: (Image, MountPoint) -> String@@ -181,14 +183,14 @@ ++ mntXml ++ "\n</filesystem>" Nothing -> ""- where- fsImgDriver (Image _img fmt _fs) = printf "<driver %s %s/>" driver fmt'- where- (driver, fmt') = case fmt of- Raw -> ("type='loop'", "format='raw'")- QCow2 -> ("type='nbd'", "format='qcow2'")- Vmdk -> ("type='nbd'", "format='vmdk'")- fsImgSource (Image src _fmt _fs) = "<source file='" ++ src ++ "'/>"+ where+ fsImgDriver (Image _img fmt _fs) = printf "<driver %s %s/>" driver fmt'+ where+ (driver, fmt') = case fmt of+ Raw -> ("type='loop'", "format='raw'")+ QCow2 -> ("type='nbd'", "format='qcow2'")+ Vmdk -> ("type='nbd'", "format='vmdk'")+ fsImgSource (Image src _fmt _fs) = "<source file='" ++ src ++ "'/>" fsSharedDir :: SharedDirectory -> String fsSharedDir (SharedDirectory hostDir mnt) = case fsTarget mnt of@@ -215,22 +217,22 @@ fsTarget :: MountPoint -> Maybe String fsTarget (MountPoint dir) = Just $ "<target dir='" ++ dir ++ "'/>"-fsTarget _ = Nothing+fsTarget _ = Nothing memoryUnit :: LibVirtLXCConfig -> ExecEnv -> String memoryUnit cfg = toUnit . maxMemory . envResources- where- toUnit AutomaticRamSize = toUnit (guestRamSize cfg)- toUnit (RamSize _ u) = case u of- GB -> "GiB"- MB -> "MiB"- KB -> "KiB"+ where+ toUnit AutomaticRamSize = toUnit (guestRamSize cfg)+ toUnit (RamSize _ u) = case u of+ GB -> "GiB"+ MB -> "MiB"+ KB -> "KiB" memoryAmount :: LibVirtLXCConfig -> ExecEnv -> String memoryAmount cfg = show . toAmount . maxMemory . envResources- where- toAmount AutomaticRamSize = toAmount (guestRamSize cfg)- toAmount (RamSize n _) = n+ where+ toAmount AutomaticRamSize = toAmount (guestRamSize cfg)+ toAmount (RamSize n _) = n cpuCountStr :: ExecEnv -> String cpuCountStr = show . cpuCount . envResources
src/lib/B9/MBR.hs view
@@ -1,42 +1,41 @@-{-| Utility module to extract a primary partition from an MBR partition on a- raw image file. -}+-- | Utility module to extract a primary partition from an MBR partition on a+-- raw image file. module B9.MBR- ( getPartition- , PrimaryPartition(..)- , MBR(..)- , CHS(..)+ ( getPartition,+ PrimaryPartition (..),+ MBR (..),+ CHS (..), ) where -import Data.Binary.Get-import Data.Word-import Text.Printf-import qualified Data.ByteString.Lazy as BL+import Data.Binary.Get+import qualified Data.ByteString.Lazy as BL+import Data.Word+import Text.Printf 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)+ 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@@ -44,27 +43,33 @@ bootCodeSize :: Int bootCodeSize = 446 -data MBR = MBR { mbrPart1 :: !PrimaryPartition- , mbrPart2 :: !PrimaryPartition- , mbrPart3 :: !PrimaryPartition- , mbrPart4 :: !PrimaryPartition- }- deriving Show+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 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+data CHS+ = CHS+ { chsH :: !Word8,+ chs_CUpper2_S :: !Word8,+ chs_CLower8 :: !Word8+ }+ deriving (Show) getMBR :: Get MBR getMBR =
src/lib/B9/PartitionTable.hs view
@@ -1,12 +1,12 @@-{-| Function to find the file offsets of primary partitions in raw disk- images. Currently only MBR partitions are supported. See 'B9.MBR' -}+-- | 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+ ( getPartition, ) where -import Data.Word ( Word64 )-import qualified B9.MBR as MBR+import qualified B9.MBR as MBR+import Data.Word (Word64) getPartition :: Int -> FilePath -> IO (Word64, Word64, Word64) getPartition partitionIndex diskImage =@@ -14,7 +14,7 @@ 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+ where+ gcd2 n x y =+ let next = 2 * n+ in if x `rem` next == 0 && y `rem` next == 0 then gcd2 next x y else n
+ src/lib/B9/Podman.hs view
@@ -0,0 +1,52 @@+-- | Implementation of an execution environment that uses /podman/.+module B9.Podman+ ( Podman (..),+ )+where++import B9.B9Config+ ( ContainerCapability,+ getB9Config,+ podmanConfigs,+ )+import B9.B9Config.Podman as X+import B9.B9Exec+import B9.BuildInfo+import B9.Container+import B9.DiskImages+import B9.ExecEnv+import B9.ShellScript+import Control.Lens (view)+import Control.Monad.IO.Class+ ( MonadIO,+ liftIO,+ )+import Data.Char (toLower)+import System.Directory+import System.FilePath+import System.IO.B9Extras+ ( UUID (),+ randomUUID,+ )+import Text.Printf (printf)++newtype Podman = Podman PodmanConfig++instance Backend Podman where+ getBackendConfig _ =+ fmap Podman . view podmanConfigs <$> getB9Config++ -- supportedImageTypes :: proxy config -> [ImageType]+ supportedImageTypes _ = [Raw]++ -- runInEnvironment ::+ -- forall e.+ -- (Member BuildInfoReader e, CommandIO e) =>+ -- config ->+ -- ExecEnv ->+ -- Script ->+ -- Eff e Bool+ runInEnvironment (Podman dcfg) env scriptIn = do+ if emptyScript scriptIn+ then return True+ else do error "TODO"
src/lib/B9/QCUtil.hs view
@@ -1,10 +1,9 @@-{-|-Some QuickCheck utility functions.--}+-- |+-- Some QuickCheck utility functions. module B9.QCUtil where -import Control.Monad-import Test.QuickCheck+import Control.Monad+import Test.QuickCheck arbitraryEnv :: Arbitrary a => Gen [(String, a)] arbitraryEnv = listOf ((,) <$> listOf1 (choose ('a', 'z')) <*> arbitrary)@@ -17,25 +16,27 @@ arbitraryFilePath :: Gen FilePath arbitraryFilePath = do- path <- join <$> listOf- (elements- [ "/"- , "../"- , "./"- , "etc/"- , "opt/"- , "user/"- , "var/"- , "tmp/"- , "doc/"- , "share/"- , "conf.d/"+ 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)+ 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]
src/lib/B9/Repository.hs view
@@ -1,54 +1,55 @@-{-| B9 has a concept of 'B9.DiskImages.SharedImaged'. Shared 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.-}+-- | B9 has a concept of 'B9.DiskImages.SharedImaged'. Shared 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- ( initRepoCache- , RepoCacheReader- , getRepoCache- , withRemoteRepos- , withSelectedRemoteRepo- , getSelectedRemoteRepo- , SelectedRemoteRepoReader- , SelectedRemoteRepo(..)- , initRemoteRepo- , cleanRemoteRepo- , remoteRepoCheckSshPrivKey- , remoteRepoCacheDir- , localRepoDir- , lookupRemoteRepo- , module X+ ( initRepoCache,+ RepoCacheReader,+ getRepoCache,+ withRemoteRepos,+ withSelectedRemoteRepo,+ getSelectedRemoteRepo,+ SelectedRemoteRepoReader,+ SelectedRemoteRepo (..),+ initRemoteRepo,+ cleanRemoteRepo,+ remoteRepoCheckSshPrivKey,+ remoteRepoCacheDir,+ localRepoDir,+ lookupRemoteRepo,+ module X, ) where -import B9.B9Config-import B9.B9Error-import Control.Monad-import Control.Eff-import Control.Eff.Reader.Lazy-import Control.Lens-import Control.Monad.IO.Class-import Data.Maybe-import Text.Printf-import System.FilePath-import System.Directory-import B9.B9Config.Repository as X-import System.IO.B9Extras+import B9.B9Config+import B9.B9Config.Repository as X+import B9.B9Error+import Control.Eff+import Control.Eff.Reader.Lazy+import Control.Lens+import Control.Monad+import Control.Monad.IO.Class+import Data.Maybe+import System.Directory+import System.FilePath+import System.IO.B9Extras+import Text.Printf -- | Initialize the local repository cache directory and the 'RemoteRepo's. -- Run the given action with a 'B9Config' that contains the initialized -- repositories in '_remoteRepos'. -- -- @since 0.5.65-withRemoteRepos- :: (Member B9ConfigReader e, Lifted IO e)- => Eff (RepoCacheReader ': e) a- -> Eff e a+withRemoteRepos ::+ (Member B9ConfigReader e, Lifted IO e) =>+ Eff (RepoCacheReader ': e) a ->+ Eff e a withRemoteRepos f = do- cfg <- getB9Config- repoCache <- lift- (initRepoCache (fromMaybe defaultRepositoryCache (_repositoryCache cfg)))+ cfg <- getB9Config+ repoCache <-+ lift+ (initRepoCache (fromMaybe defaultRepositoryCache (_repositoryCache cfg))) remoteRepos' <- mapM (initRemoteRepo repoCache) (_remoteRepos cfg) let setRemoteRepos = remoteRepos .~ remoteRepos' localB9Config setRemoteRepos (runReader repoCache f)@@ -70,30 +71,31 @@ -- If the selected repo does not exist, and exception is thrown. -- -- @since 0.5.65-withSelectedRemoteRepo- :: (Member B9ConfigReader e, Member ExcB9 e)- => Eff (SelectedRemoteRepoReader ': e) a- -> Eff e a+withSelectedRemoteRepo ::+ (Member B9ConfigReader e, Member ExcB9 e) =>+ Eff (SelectedRemoteRepoReader ': e) a ->+ Eff e a withSelectedRemoteRepo e = do- remoteRepos' <- _remoteRepos <$> getB9Config+ remoteRepos' <- _remoteRepos <$> getB9Config mSelectedRepoName <- _repository <$> getB9Config case mSelectedRepoName of Nothing -> runReader (MkSelectedRemoteRepo Nothing) e Just selectedRepoName -> case lookupRemoteRepo remoteRepos' selectedRepoName of- Nothing -> throwB9Error- (printf- "selected remote repo '%s' not configured, valid remote repos are: '%s'"- (show selectedRepoName)- (show remoteRepos')- )+ Nothing ->+ throwB9Error+ ( printf+ "selected remote repo '%s' not configured, valid remote repos are: '%s'"+ (show selectedRepoName)+ (show remoteRepos')+ ) Just r -> runReader (MkSelectedRemoteRepo (Just r)) e -- | Contains the 'Just' the 'RemoteRepo' selected by the 'B9Config' value '_repository', -- or 'Nothing' of no 'RemoteRepo' was selected in the 'B9Config'. -- -- @since 0.5.65-newtype SelectedRemoteRepo = MkSelectedRemoteRepo { fromSelectedRemoteRepo :: Maybe RemoteRepo }+newtype SelectedRemoteRepo = MkSelectedRemoteRepo {fromSelectedRemoteRepo :: Maybe RemoteRepo} -- | Alias for a 'Reader' 'Eff'ect that reads the 'RemoteRepo' -- selected by the 'B9Config' value '_repository'. See 'withSelectedRemoteRepo'.@@ -105,8 +107,8 @@ -- selected by the 'B9Config' value '_repository'. See 'withSelectedRemoteRepo'. -- -- @since 0.5.65-getSelectedRemoteRepo- :: Member SelectedRemoteRepoReader e => Eff e SelectedRemoteRepo+getSelectedRemoteRepo ::+ Member SelectedRemoteRepoReader e => Eff e SelectedRemoteRepo getSelectedRemoteRepo = ask -- | Initialize the local repository cache directory.@@ -119,12 +121,12 @@ -- | 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)+ exists <- liftIO (doesFileExist keyFile) keyFile' <- liftIO (canonicalizePath keyFile) unless exists- (error- (printf "SSH Key file '%s' for repository '%s' is missing." keyFile' rId)+ ( error+ (printf "SSH Key file '%s' for repository '%s' is missing." keyFile' rId) ) return (RemoteRepo rId rp (SshPrivKey keyFile') h u) @@ -144,7 +146,7 @@ -- directory. cleanRemoteRepo :: MonadIO m => RepoCache -> RemoteRepo -> m () cleanRemoteRepo cache repo = do- let repoId = remoteRepoRepoId repo+ let repoId = remoteRepoRepoId repo repoDir = remoteRepoCacheDir cache repoId ++ "/" -- TODO logging infoL $ printf "Cleaning remote repo: %s" repoId ensureDir repoDir@@ -154,22 +156,28 @@ -- | 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 ::+ -- | The repository cache directory+ RepoCache ->+ -- | Id of the repository+ String ->+ -- | The existing, absolute path to the+ -- cache directory+ FilePath 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 ::+ -- | The repository cache directory+ RepoCache ->+ -- | The existing, absolute path to the+ -- directory+ FilePath localRepoDir (RepoCache cacheDir) = cacheDir </> "local-repo" -- | Select the first 'RemoteRepo' with a given @repoId@. lookupRemoteRepo :: [RemoteRepo] -> String -> Maybe RemoteRepo lookupRemoteRepo repos repoId = lookup repoId repoIdRepoPairs- where repoIdRepoPairs = map (\r@(RemoteRepo rid _ _ _ _) -> (rid, r)) repos+ where+ repoIdRepoPairs = map (\r@(RemoteRepo rid _ _ _ _) -> (rid, r)) repos
src/lib/B9/RepositoryIO.hs view
@@ -1,27 +1,27 @@-{-| Effectful functions executing shared image respository operations.- See "B9.Repository" -}+-- | Effectful functions executing shared image respository operations.+-- See "B9.Repository" module B9.RepositoryIO- ( repoSearch- , pushToRepo- , pullFromRepo- , pullGlob- , Repository(..)- , toRemoteRepository- , FilePathGlob(..)+ ( repoSearch,+ pushToRepo,+ pullFromRepo,+ pullGlob,+ Repository (..),+ toRemoteRepository,+ FilePathGlob (..), ) where -import B9.B9Config ( getRemoteRepos )-import B9.B9Logging-import B9.B9Exec-import B9.Repository-import Control.Eff-import Control.Monad.IO.Class-import Data.List-import System.Directory-import System.FilePath-import System.IO.B9Extras ( ensureDir )-import Text.Printf ( printf )+import B9.B9Config (getRemoteRepos)+import B9.B9Exec+import B9.B9Logging+import B9.Repository+import Control.Eff+import Control.Monad.IO.Class+import Data.List+import System.Directory+import System.FilePath+import System.IO.B9Extras (ensureDir)+import Text.Printf (printf) data Repository = Cache@@ -35,36 +35,36 @@ -- | 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- :: forall e- . (CommandIO e, Member RepoCacheReader e)- => FilePath- -> FilePathGlob- -> Eff e [(Repository, [FilePath])]+repoSearch ::+ forall e.+ (CommandIO e, Member RepoCacheReader e) =>+ FilePath ->+ FilePathGlob ->+ Eff e [(Repository, [FilePath])] repoSearch subDir glob = (:) <$> localMatches <*> remoteRepoMatches- where- remoteRepoMatches = do- remoteRepos <- getRemoteRepos- mapM remoteRepoSearch remoteRepos- localMatches :: Eff e (Repository, [FilePath])- localMatches = do- cache <- getRepoCache- let dir = localRepoDir cache </> subDir- files <- findGlob dir- return (Cache, files)- remoteRepoSearch :: RemoteRepo -> Eff e (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 -> Eff e [FilePath]- findGlob dir = do- traceL (printf "reading contents of directory '%s'" dir)- ensureDir (dir ++ "/")- files <- liftIO (getDirectoryContents dir)- return ((dir </>) <$> filter (matchGlob glob) files)+ where+ remoteRepoMatches = do+ remoteRepos <- getRemoteRepos+ mapM remoteRepoSearch remoteRepos+ localMatches :: Eff e (Repository, [FilePath])+ localMatches = do+ cache <- getRepoCache+ let dir = localRepoDir cache </> subDir+ files <- findGlob dir+ return (Cache, files)+ remoteRepoSearch :: RemoteRepo -> Eff e (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 -> Eff e [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 :: (CommandIO e) => RemoteRepo -> FilePath -> FilePath -> Eff e ()@@ -75,48 +75,50 @@ -- | Pull a file from a remote repository to cache pullFromRepo :: (CommandIO e) => RemoteRepo -> FilePath -> FilePath -> Eff e ()-pullFromRepo repo@(RemoteRepo repoId rootDir _key (SshRemoteHost (host, _port)) (SshRemoteUser user)) src dest- = do+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+ ( 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- :: (CommandIO e, Member RepoCacheReader e)- => FilePath- -> FilePathGlob- -> RemoteRepo- -> Eff e ()-pullGlob subDir glob repo@(RemoteRepo repoId rootDir _key (SshRemoteHost (host, _port)) (SshRemoteUser user))- = do+pullGlob ::+ (CommandIO e, Member RepoCacheReader e) =>+ FilePath ->+ FilePathGlob ->+ RemoteRepo ->+ Eff e ()+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+ 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.-newtype FilePathGlob =- FileExtension String+newtype FilePathGlob+ = FileExtension String -- * Internals+ globToPattern :: FilePathGlob -> String globToPattern (FileExtension ext) = "*." ++ ext @@ -127,32 +129,35 @@ -- | 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+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)+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+sshOpts (RemoteRepo _repoId _rootDir (SshPrivKey key) (SshRemoteHost (_host, port)) _user) =+ unwords+ [ "-o",+ "StrictHostKeyChecking=no",+ "-o",+ "UserKnownHostsFile=/dev/null",+ "-o",+ printf "Port=%i" port,+ "-o",+ "IdentityFile=" ++ key ]
src/lib/B9/Shake.hs view
@@ -1,9 +1,9 @@ -- | A module that re-exports all B9 Shake integration. -- Which by the way is crude and preliminary... module B9.Shake- ( module X+ ( module X, ) where -import B9.Shake.Actions as X-import B9.Shake.SharedImageRules as X+import B9.Shake.Actions as X+import B9.Shake.SharedImageRules as X
src/lib/B9/Shake/Actions.hs view
@@ -1,19 +1,19 @@ -- | Convenient Shake 'Action's for 'B9' rules. module B9.Shake.Actions- ( b9InvocationAction- , buildB9File+ ( b9InvocationAction,+ buildB9File, ) where -import B9-import Control.Lens ( (?~) )-import Development.Shake-import GHC.Stack+import B9+import Control.Lens ((?~))+import Development.Shake+import GHC.Stack -- | Convert a 'B9ConfigAction' action into a Shake 'Action'. This is just -- an alias for 'runB9ConfigActionWithOverrides' since 'Action' is an instance of 'MonadIO' -- and 'runB9ConfigActionWithOverrides' work on any .-b9InvocationAction :: HasCallStack => B9ConfigAction a -> B9ConfigOverride -> Action a+b9InvocationAction :: HasCallStack => B9ConfigAction a -> B9ConfigOverride -> Action a b9InvocationAction x y = liftIO (runB9ConfigActionWithOverrides x y) -- | An action that does the equivalent of@@ -25,9 +25,9 @@ let f = b9Root </> b9File need [f] liftIO- (runB9ConfigAction- (addLocalPositionalArguments- args- (localB9Config (projectRoot ?~ b9Root) (runBuildArtifacts [f]))- )+ ( runB9ConfigAction+ ( addLocalPositionalArguments+ args+ (localB9Config (projectRoot ?~ b9Root) (runBuildArtifacts [f]))+ ) )
@@ -1,10 +1,11 @@ -- | A crude, unsafe and preliminary solution to building B9 'SharedImage's -- from Shake. module B9.Shake.SharedImageRules- ( customSharedImageAction- , needSharedImage- , enableSharedImageRules- ) where+ ( customSharedImageAction,+ needSharedImage,+ enableSharedImageRules,+ )+where import B9 import qualified Data.Binary as Binary@@ -25,12 +26,16 @@ mCurrentBId <- getImgBuildId let mCurrentBIdBinary = encodeBuildId <$> mCurrentBId putLoud $- "share image rule for: " ++- show nameQ ++- ". Deps: " ++- show dependenciesChanged ++- ", current BId: " ++- show mCurrentBId ++ " Binary: " ++ show mCurrentBIdBinary ++ ", old BId: " ++ show mOldBIdBinary+ "share image rule for: "+ ++ show nameQ+ ++ ". Deps: "+ ++ show dependenciesChanged+ ++ ", current BId: "+ ++ show mCurrentBId+ ++ " Binary: "+ ++ show mCurrentBIdBinary+ ++ ", old BId: "+ ++ show mOldBIdBinary case mCurrentBIdBinary of Just currentBIdBinary -> if dependenciesChanged == RunDependenciesSame && mOldBIdBinary == Just currentBIdBinary@@ -44,7 +49,7 @@ rebuild :: Maybe ByteString.ByteString -> Action (RunResult SharedImageBuildId) rebuild mCurrentBIdBinary = do (_, act) <- getUserRuleOne nameQ (const Nothing) imgMatch- act b9inv+ _ <- act b9inv mNewBId <- getImgBuildId newBId <- maybe@@ -83,9 +88,10 @@ type instance RuleResult SharedImageName = SharedImageBuildId -data SharedImageCustomActionRule =- SharedImageCustomActionRule SharedImageName- (B9ConfigOverride -> Action SharedImageBuildId)+data SharedImageCustomActionRule+ = SharedImageCustomActionRule+ SharedImageName+ (B9ConfigOverride -> Action SharedImageBuildId) deriving (Typeable) errorSharedImageNotFound :: (HasCallStack, Monad m) => SharedImageName -> m a
src/lib/B9/ShellScript.hs view
@@ -1,120 +1,142 @@ {-# LANGUAGE DeriveDataTypeable #-}-{-| Definition of 'Script' and functions to convert 'Script's to bash- scripts. -}++-- | Definition of 'Script' and functions to convert 'Script's to bash+-- scripts. module B9.ShellScript- ( writeSh- , renderScript- , emptyScript- , CmdVerbosity(..)- , Cwd(..)- , User(..)- , Script(..)- )+ ( writeSh,+ renderScript,+ emptyScript,+ CmdVerbosity (..),+ Cwd (..),+ User (..),+ Script (..),+ ) where -import Data.Data-import Data.Semigroup as Sem-import Control.Parallel.Strategies-import Data.Binary-import Data.Hashable-import GHC.Generics ( Generic )-import Control.Monad.Reader-import Data.List ( intercalate )-import System.Directory ( getPermissions- , setPermissions- , setOwnerExecutable- )+import Control.Monad.Reader+import Control.Parallel.Strategies+import Data.Binary+import Data.Data+import Data.Hashable+import Data.List (intercalate)+import Data.Semigroup as Sem+import GHC.Generics (Generic)+import System.Directory+ ( getPermissions,+ setOwnerExecutable,+ setPermissions,+ ) 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,Generic)+ = In+ FilePath+ [Script]+ | As+ String+ [Script]+ | IgnoreErrors+ Bool+ [Script]+ | Verbosity+ CmdVerbosity+ [Script]+ | Begin [Script]+ | Run+ FilePath+ [String]+ | NoOP+ deriving (Show, Read, Typeable, Data, Eq, Generic) instance Hashable Script+ instance Binary Script+ instance NFData Script instance Sem.Semigroup Script where- NoOP <> s = s- s <> NoOP = s- (Begin ss) <> (Begin ss') = Begin (ss ++ ss')- (Begin ss) <> s' = Begin (ss ++ [s'])- s <> (Begin ss') = Begin (s : ss')- s <> s' = Begin [s, s']+ NoOP <> s = s+ s <> NoOP = s+ (Begin ss) <> (Begin ss') = Begin (ss ++ ss')+ (Begin ss) <> s' = Begin (ss ++ [s'])+ s <> (Begin ss') = Begin (s : ss')+ s <> s' = Begin [s, s'] instance Monoid Script where- mempty = NoOP- mappend = (Sem.<>)+ mempty = NoOP+ mappend = (Sem.<>) -data Cmd =- Cmd String- [String]- User- Cwd- Bool- CmdVerbosity- deriving (Show,Read,Typeable,Data,Eq,Generic)+data Cmd+ = Cmd+ String+ [String]+ User+ Cwd+ Bool+ CmdVerbosity+ deriving (Show, Read, Typeable, Data, Eq, Generic) instance Hashable Cmd+ instance Binary Cmd+ instance NFData Cmd data CmdVerbosity- = Debug- | Verbose- | OnlyStdErr- | Quiet- deriving (Show,Read,Typeable,Data,Eq,Generic)+ = Debug+ | Verbose+ | OnlyStdErr+ | Quiet+ deriving (Show, Read, Typeable, Data, Eq, Generic) instance Hashable CmdVerbosity+ instance Binary CmdVerbosity+ instance NFData CmdVerbosity data Cwd- = Cwd FilePath- | NoCwd- deriving (Show,Read,Typeable,Data,Eq,Generic)+ = Cwd FilePath+ | NoCwd+ deriving (Show, Read, Typeable, Data, Eq, Generic) instance Hashable Cwd+ instance Binary Cwd+ instance NFData Cwd data User- = User String- | NoUser- deriving (Show,Read,Typeable,Data,Eq,Generic)+ = User String+ | NoUser+ deriving (Show, Read, Typeable, Data, Eq, Generic) instance Hashable User+ instance Binary User+ instance NFData User -data Ctx = Ctx- { ctxCwd :: Cwd- , ctxUser :: User- , ctxIgnoreErrors :: Bool- , ctxVerbosity :: CmdVerbosity- } deriving (Show,Read,Typeable,Data,Eq,Generic)+data Ctx+ = Ctx+ { ctxCwd :: Cwd,+ ctxUser :: User,+ ctxIgnoreErrors :: Bool,+ ctxVerbosity :: CmdVerbosity+ }+ deriving (Show, Read, Typeable, Data, Eq, Generic) instance Hashable Ctx+ instance Binary Ctx+ instance NFData Ctx -- | 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+ writeFile file (toBash $ toCmds script)+ getPermissions file >>= setPermissions file . setOwnerExecutable True -- | Check if a script has the same effect as 'NoOP' emptyScript :: Script -> Bool@@ -124,21 +146,21 @@ 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 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))+ local (\ctx -> ctx {ctxUser = User u}) (toLLC (Begin cs)) toLLC (IgnoreErrors b cs) =- local (\ctx -> ctx { ctxIgnoreErrors = b }) (toLLC (Begin 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+ 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]+ c <- reader ctxCwd+ u <- reader ctxUser+ i <- reader ctxIgnoreErrors+ v <- reader ctxVerbosity+ return [Cmd cmd args u c i v] renderScript :: Script -> String renderScript = toBash . toCmds@@ -151,31 +173,31 @@ cmdToBash :: Cmd -> String cmdToBash (Cmd cmd args user cwd ignoreErrors verbosity) =- intercalate "\n"- $ disableErrorChecking- ++ pushd cwdQ- ++ execCmd- ++ popd cwdQ- ++ reenableErrorChecking+ 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 = []+ 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 ++ "'")+ [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"]+ Debug -> []+ Verbose -> []+ OnlyStdErr -> [">", "/dev/null"]+ Quiet -> ["&>", "/dev/null"]
+ src/lib/B9/SystemdNspawn.hs view
@@ -0,0 +1,239 @@+-- | Implementation of an execution environment that uses /systemdNspawn/.+module B9.SystemdNspawn+ ( SystemdNspawn (..),+ )+where++import B9.B9Config+ ( getB9Config,+ systemdNspawnConfigs,+ )+import B9.B9Config.SystemdNspawn as X+import B9.B9Error+import B9.B9Exec+import B9.B9Logging+import B9.BuildInfo+import B9.Container+import B9.DiskImages+import B9.ExecEnv+import B9.ShellScript+import Control.Eff+import Control.Lens (view)+import Control.Monad (when)+import Control.Monad.IO.Class+ ( liftIO,+ )+import Data.Foldable (traverse_)+import Data.List (intercalate, partition)+import Data.Maybe (fromMaybe, maybe)+import System.Directory+import System.FilePath+import Text.Printf (printf)++newtype SystemdNspawn = SystemdNspawn SystemdNspawnConfig++type SudoPrepender = String -> String++instance Backend SystemdNspawn where+ getBackendConfig _ =+ fmap SystemdNspawn . view systemdNspawnConfigs <$> getB9Config++ supportedImageTypes _ = [Raw]++ runInEnvironment (SystemdNspawn dCfg) env scriptIn =+ if emptyScript scriptIn+ then return True+ else do+ let sudo = if _systemdNspawnUseSudo dCfg then ("sudo " ++) else id+ containerBuildDirs <- createContainerBuildRootDir+ containerMounts <- mountLoopbackImages sudo env containerBuildDirs+ finallyB9+ ( do+ bootScript <- prepareBootScript containerBuildDirs scriptIn+ execBuild sudo containerMounts (envSharedDirectories env) bootScript dCfg+ )+ ( do+ umountLoopbackImages sudo containerMounts+ removeContainerBuildRootDir sudo containerBuildDirs+ )++createContainerBuildRootDir ::+ (Member BuildInfoReader e, Member ExcB9 e, CommandIO e) => Eff e ContainerBuildDirectories+createContainerBuildRootDir = do+ buildD <- getBuildDir+ let loopbackMountDir = root </> "loopback_mounts"+ root = buildD </> "container_build_root"+ liftIO $ do+ createDirectoryIfMissing True root+ createDirectoryIfMissing True loopbackMountDir+ let res = ContainerBuildDirectories {containerBuildRoot = root, containerLoopbackMountRoot = loopbackMountDir}+ traceL ("Created container build directories: " ++ show res)+ return res++data ContainerBuildDirectories+ = ContainerBuildDirectories+ { containerBuildRoot :: FilePath,+ containerLoopbackMountRoot :: FilePath+ }+ deriving (Show)++mountLoopbackImages ::+ (Member BuildInfoReader e, Member ExcB9 e, CommandIO e) =>+ SudoPrepender ->+ ExecEnv ->+ ContainerBuildDirectories ->+ Eff e ContainerMounts+mountLoopbackImages sudo e containerDirs = do+ let imgMounts0 = [(img, mountPoint) | (img, MountPoint mountPoint) <- envImageMounts e]+ imgMounts = [(imgPath, mountPoint) | (Image imgPath _ _, mountPoint) <- imgMounts0]+ invalidImages = [x | x@(Image _ t _, _) <- imgMounts0, t /= Raw]+ when+ (not (null invalidImages))+ (throwB9Error ("Internal Error: Only 'raw' disk images can be used for container builds, and these images were supposed to be automatically converted: " ++ show invalidImages))+ case partition ((== "/") . snd) imgMounts of+ ([rootImg], otherImgs) -> do+ rootMount <- mountLoopback rootImg+ otherMounts <- traverse mountLoopback otherImgs+ return (ContainerMounts (Right rootMount) otherMounts)+ ([], _) ->+ throwB9Error "A containerized build requires that a disk image for the root-, i.e. the '/' directory is configured."+ (rootImgs, _) ->+ throwB9Error ("A containerized build requires that only one disk image for the root-, i.e. the '/' directory, instead these were given: " ++ show rootImgs)+ where+ mountLoopback (imgPath, containerMountPoint) = do+ let hostMountPoint =+ containerLoopbackMountRoot containerDirs+ </> printHash (imgPath, containerMountPoint)+ liftIO $ createDirectoryIfMissing True hostMountPoint+ hostCmd (sudo (printf "mount -o loop '%s' '%s'" imgPath hostMountPoint)) timeoutFastCmd+ return (LoopbackMount {loopbackHost = hostMountPoint, loopbackContainer = containerMountPoint})++newtype ContainerRootImage+ = ContainerRootImage FilePath+ deriving (Show)++data ContainerMounts+ = ContainerMounts+ { containerRootImage :: Either ContainerRootImage LoopbackMount,+ containerLoopbackMounts :: [LoopbackMount]+ }+ deriving (Show)++data LoopbackMount = LoopbackMount {loopbackHost :: FilePath, loopbackContainer :: FilePath}+ deriving (Show)++prepareBootScript ::+ (Member ExcB9 e, CommandIO e) =>+ ContainerBuildDirectories ->+ Script ->+ Eff e BootScript+prepareBootScript containerDirs script = do+ let bs =+ BootScript+ { bootScriptHostDir = containerBuildRoot containerDirs </> "boot_script",+ bootScriptContainerDir = "/mnt/boot_script",+ bootScriptContainerCommand = bootScriptContainerDir bs </> scriptFile+ }+ scriptFile = "run.sh"+ scriptEnv =+ Begin+ [ Run "export" ["HOME=/root"],+ Run "export" ["USER=root"],+ -- IgnoreErrors True [Run "source" ["/etc/profile"]],+ script+ ]+ liftIO $ do+ createDirectoryIfMissing True (bootScriptHostDir bs)+ writeSh (bootScriptHostDir bs </> scriptFile) scriptEnv+ traceL ("wrote script: \n" ++ show scriptEnv)+ traceL ("created boot-script: " ++ show bs)+ return bs++data BootScript+ = BootScript+ { bootScriptHostDir :: FilePath,+ bootScriptContainerDir :: FilePath,+ bootScriptContainerCommand :: String+ }+ deriving (Show)++execBuild ::+ (Member ExcB9 e, CommandIO e) =>+ SudoPrepender ->+ ContainerMounts ->+ [SharedDirectory] ->+ BootScript ->+ SystemdNspawnConfig ->+ Eff e Bool+execBuild sudo containerMounts sharedDirs bootScript dCfg = do+ let systemdCmd =+ unwords+ ( systemdNspawnExe+ ++ consoleOptions+ ++ rootImageOptions+ ++ capabilityOptions+ ++ bindMounts+ ++ extraArgs+ ++ execOptions+ )+ systemdNspawnExe =+ [fromMaybe "systemd-nspawn" (_systemdNspawnExecutable dCfg)]+ consoleOptions =+ ["--console=" ++ show (_systemdNspawnConsole dCfg)]+ rootImageOptions =+ case containerRootImage containerMounts of+ Left (ContainerRootImage imgPath) ->+ ["-i", imgPath]+ Right loopbackMounted ->+ ["-D", loopbackHost loopbackMounted]+ capabilityOptions =+ case _systemdNspawnCapabilities dCfg of+ [] -> []+ caps -> ["--capability=" ++ intercalate "," (map show caps)]+ bindMounts =+ map mkBind loopbackMounts+ ++ map mkBind sharedDirMounts+ ++ map mkBindRo sharedDirMountsRo+ ++ [mkBindRo (bootScriptHostDir bootScript, bootScriptContainerDir bootScript)]+ where+ mkBind (hostDir, containerDir) = "--bind=" ++ hostDir ++ ":" ++ containerDir+ mkBindRo (hostDir, containerDir) = "--bind-ro=" ++ hostDir ++ ":" ++ containerDir+ loopbackMounts =+ [ (h, c)+ | LoopbackMount {loopbackHost = h, loopbackContainer = c} <-+ containerLoopbackMounts containerMounts+ ]+ sharedDirMounts = [(h, c) | SharedDirectory h (MountPoint c) <- sharedDirs]+ sharedDirMountsRo = [(h, c) | SharedDirectoryRO h (MountPoint c) <- sharedDirs]+ extraArgs = maybe [] (: []) (_systemdNspawnExtraArgs dCfg)+ execOptions = ["/bin/sh", bootScriptContainerCommand bootScript]+ timeout = (CommandTimeout . (* 1000000)) <$> _systemdNspawnMaxLifetimeSeconds dCfg+ traceL ("executing systemd-nspawn container build")+ case _systemdNspawnConsole dCfg of+ SystemdNspawnInteractive ->+ hostCmdStdIn HostCommandInheritStdin (sudo systemdCmd) Nothing+ _ ->+ hostCmd (sudo systemdCmd) timeout++umountLoopbackImages :: forall e. (Member ExcB9 e, CommandIO e) => SudoPrepender -> ContainerMounts -> Eff e ()+umountLoopbackImages sudo c = do+ case containerRootImage c of+ Left _ -> return ()+ Right r -> umount r+ traverse_ umount (containerLoopbackMounts c)+ where+ umount :: LoopbackMount -> Eff e ()+ umount l = do+ traceL $ "unmounting: " ++ show l+ res <- hostCmd (sudo (printf "umount '%s'" (loopbackHost l))) timeoutFastCmd+ when (not res) (errorL ("failed to unmount: " ++ show l))++removeContainerBuildRootDir :: forall e. (Member ExcB9 e, CommandIO e) => SudoPrepender -> ContainerBuildDirectories -> Eff e ()+removeContainerBuildRootDir sudo containerBuildDirs = do+ let target = containerBuildRoot containerBuildDirs+ traceL $ "removing: " ++ target+ res <- hostCmd (sudo (printf "rm -rf '%s'" target)) timeoutFastCmd+ when (not res) (errorL ("failed to remove: " ++ target))++timeoutFastCmd :: Maybe CommandTimeout+timeoutFastCmd = Just (CommandTimeout 10000000)
src/lib/B9/Text.hs view
@@ -1,35 +1,38 @@-{-# LANGUAGE TypeSynonymInstances,FlexibleInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+ -- | This module enables debugging all 'ByteString' to 'Text' to 'String' conversions. -- This is an internal module. -- -- @since 0.5.67 module B9.Text- ( Text- , LazyText- , ByteString- , LazyByteString- , Textual(..)- , writeTextFile- , unsafeRenderToText- , unsafeParseFromText- , parseFromTextWithErrorMessage- , encodeAsUtf8LazyByteString+ ( Text,+ LazyText,+ ByteString,+ LazyByteString,+ Textual (..),+ writeTextFile,+ unsafeRenderToText,+ unsafeParseFromText,+ parseFromTextWithErrorMessage,+ encodeAsUtf8LazyByteString, ) where -import Data.ByteString ( ByteString )-import Control.Exception ( displayException )+import Control.Exception (displayException) -- import qualified Data.ByteString as Strict-import qualified Data.ByteString.Lazy as LazyByteString-import qualified Data.Text as Text-import Data.Text ( Text )-import qualified Data.Text.Encoding as Text-import qualified Data.Text.IO as Text-import qualified Data.Text.Lazy as LazyText-import qualified Data.Text.Lazy.Encoding as LazyText+ -- import qualified Data.Text.Encoding.Error as Text-import Control.Monad.IO.Class-import GHC.Stack+import Control.Monad.IO.Class+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as LazyByteString+import qualified Data.Text as Text+import Data.Text (Text)+import qualified Data.Text.Encoding as Text+import qualified Data.Text.IO as Text+import qualified Data.Text.Lazy as LazyText+import qualified Data.Text.Lazy.Encoding as LazyText+import GHC.Stack -- | Lazy byte strings. --@@ -55,20 +58,19 @@ -- If an error occured, return 'Left' with the error message. -- -- @since 0.5.67- renderToText :: HasCallStack => a -> Either String Text+ renderToText :: HasCallStack => a -> Either String Text+ -- | Convert a 'Text' to 'String' -- -- @since 0.5.67 parseFromText :: HasCallStack => Text -> Either String a -- instance Textual Text where- renderToText = Right+ renderToText = Right parseFromText = Right instance Textual String where- renderToText = Right . Text.pack+ renderToText = Right . Text.pack parseFromText = Right . Text.unpack -- | Convert a 'ByteString' with UTF-8 encoded string to 'Text'@@ -76,14 +78,15 @@ -- @since 0.5.67 instance Textual ByteString where renderToText x = case Text.decodeUtf8' x of- Left u -> Left- ( "renderToText of the ByteString failed: "- ++ displayException u- ++ " "- ++ show x- ++ "\nat:\n"- ++ prettyCallStack callStack- )+ Left u ->+ Left+ ( "renderToText of the ByteString failed: "+ ++ displayException u+ ++ " "+ ++ show x+ ++ "\nat:\n"+ ++ prettyCallStack callStack+ ) Right t -> Right t parseFromText = Right . Text.encodeUtf8 @@ -92,19 +95,18 @@ -- @since 0.5.67 instance Textual LazyByteString where renderToText x = case LazyText.decodeUtf8' x of- Left u -> Left- ( "renderToText of the LazyByteString failed: "- ++ displayException u- ++ " "- ++ show x- ++ "\nat:\n"- ++ prettyCallStack callStack- )+ Left u ->+ Left+ ( "renderToText of the LazyByteString failed: "+ ++ displayException u+ ++ " "+ ++ show x+ ++ "\nat:\n"+ ++ prettyCallStack callStack+ ) Right t -> Right (LazyText.toStrict t) parseFromText = Right . LazyByteString.fromStrict . Text.encodeUtf8 -- -- | Render a 'Text' to a file. -- -- @since 0.5.67@@ -136,11 +138,12 @@ -- error message. -- -- @since 0.5.67-parseFromTextWithErrorMessage- :: (HasCallStack, Textual a)- => String -- ^ An arbitrary string for error messages- -> Text- -> Either String a+parseFromTextWithErrorMessage ::+ (HasCallStack, Textual a) =>+ -- | An arbitrary string for error messages+ String ->+ Text ->+ Either String a parseFromTextWithErrorMessage errorMessage b = case parseFromText b of- Left e -> Left (unwords [errorMessage, e])+ Left e -> Left (unwords [errorMessage, e]) Right a -> Right a
src/lib/B9/Vm.hs view
@@ -1,35 +1,35 @@-{-| 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.Artifact.Generator.ArtifactGenerator'. -}+-- | 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.Artifact.Generator.ArtifactGenerator'. module B9.Vm- ( VmScript(..)- , substVmScript+ ( VmScript (..),+ substVmScript, ) where -import Control.Parallel.Strategies-import Control.Eff-import Data.Binary-import Data.Data-import Data.Generics.Aliases hiding ( Generic )-import Data.Generics.Schemes-import Data.Hashable-import GHC.Generics ( Generic )--import B9.Environment-import B9.B9Error-import B9.Artifact.Content.StringTemplate-import B9.DiskImages-import B9.ExecEnv-import B9.ShellScript+import B9.Artifact.Content.StringTemplate+import B9.B9Error+import B9.DiskImages+import B9.Environment+import B9.ExecEnv+import B9.ShellScript+import Control.Eff+import Control.Parallel.Strategies+import Data.Binary+import Data.Data+import Data.Generics.Aliases hiding (Generic)+import Data.Generics.Schemes+import Data.Hashable+import GHC.Generics (Generic) -- | 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+ = VmScript+ CPUArch+ [SharedDirectory]+ Script | NoVmScript deriving (Read, Show, Typeable, Data, Eq, Generic) @@ -39,26 +39,23 @@ instance NFData VmScript -substVmScript- :: forall e- . (Member EnvironmentReader e, Member ExcB9 e)- => VmScript- -> Eff e VmScript+substVmScript ::+ forall e.+ (Member EnvironmentReader e, Member ExcB9 e) =>+ VmScript ->+ Eff e VmScript substVmScript = everywhereM gsubst- where- gsubst :: GenericM (Eff e)- gsubst = mkM substMountPoint `extM` substSharedDir `extM` substScript-- substMountPoint NotMounted = pure NotMounted- substMountPoint (MountPoint x) = MountPoint <$> substStr x-- substSharedDir (SharedDirectory fp mp) =- SharedDirectory <$> substStr fp <*> pure mp- substSharedDir (SharedDirectoryRO fp mp) =- SharedDirectoryRO <$> substStr fp <*> pure mp- substSharedDir s = pure s-- substScript (In fp s ) = In <$> substStr fp <*> pure s- substScript (Run fp args) = Run <$> substStr fp <*> mapM substStr args- substScript (As fp s ) = As <$> substStr fp <*> pure s- substScript s = pure s+ where+ gsubst :: GenericM (Eff e)+ gsubst = mkM substMountPoint `extM` substSharedDir `extM` substScript+ substMountPoint NotMounted = pure NotMounted+ substMountPoint (MountPoint x) = MountPoint <$> substStr x+ substSharedDir (SharedDirectory fp mp) =+ SharedDirectory <$> substStr fp <*> pure mp+ substSharedDir (SharedDirectoryRO fp mp) =+ SharedDirectoryRO <$> substStr fp <*> pure mp+ substSharedDir s = pure s+ substScript (In fp s) = In <$> substStr fp <*> pure s+ substScript (Run fp args) = Run <$> substStr fp <*> mapM substStr args+ substScript (As fp s) = As <$> substStr fp <*> pure s+ substScript s = pure s
src/lib/B9/VmBuilder.hs view
@@ -1,48 +1,53 @@-{-| Effectful functions to execute and build virtual machine images using- an execution environment like e.g. libvirt-lxc. -}+-- | Effectful functions to execute and build virtual machine images using+-- an execution environment like e.g. libvirt-lxc. module B9.VmBuilder- ( buildWithVm+ ( buildWithVm, ) where -import Control.Eff-import Control.Monad-import Control.Monad.IO.Class-import Data.List-import System.Directory ( canonicalizePath- , createDirectoryIfMissing- )-import Text.Printf ( printf )-import Text.Show.Pretty ( ppShow )--import B9.Artifact.Readable-import B9.B9Config-import B9.B9Logging-import B9.B9Monad-import B9.BuildInfo-import B9.DiskImageBuilder-import B9.DiskImages-import B9.ExecEnv-import qualified B9.LibVirtLXC as LXC-import B9.ShellScript-import B9.Vm+import B9.Artifact.Readable+import B9.B9Error+import B9.B9Logging+import B9.B9Monad+import B9.BuildInfo+import B9.Container+import B9.DiskImageBuilder+import B9.DiskImages+import qualified B9.Docker as Docker+import B9.ExecEnv+import qualified B9.LibVirtLXC as LXC+import qualified B9.SystemdNspawn as SystemdNspawn+import B9.Vm+import Control.Eff+import Control.Monad+import Control.Monad.IO.Class+import Data.List+import Data.Proxy+import System.Directory+ ( canonicalizePath,+ createDirectoryIfMissing,+ )+import Text.Printf (printf)+import Text.Show.Pretty (ppShow) -buildWithVm- :: IsB9 e => InstanceId -> [ImageTarget] -> FilePath -> VmScript -> Eff e Bool+buildWithVm ::+ IsB9 e => InstanceId -> [ImageTarget] -> FilePath -> VmScript -> Eff e Bool buildWithVm iid imageTargets instanceDir vmScript = do- vmBuildSupportedImageTypes <- getVmScriptSupportedImageTypes vmScript+ res <- withBackend (buildWithBackend iid imageTargets instanceDir vmScript)+ case res of+ Nothing ->+ errorExitL "No container configured."+ Just success ->+ return success++buildWithBackend :: forall backendCfg e. (Backend backendCfg, IsB9 e) => InstanceId -> [ImageTarget] -> FilePath -> VmScript -> backendCfg -> Eff e Bool+buildWithBackend iid imageTargets instanceDir vmScript backendCfg = do+ let vmBuildSupportedImageTypes = supportedImageTypes (Proxy :: Proxy backendCfg) buildImages <- createBuildImages imageTargets vmBuildSupportedImageTypes- success <- runVmScript iid imageTargets buildImages instanceDir vmScript+ success <- runVmScript backendCfg iid imageTargets buildImages instanceDir vmScript when success (createDestinationImages buildImages imageTargets) return success -getVmScriptSupportedImageTypes :: IsB9 e => VmScript -> Eff e [ImageType]-getVmScriptSupportedImageTypes NoVmScript = return [QCow2, Raw, Vmdk]-getVmScriptSupportedImageTypes _ = supportedImageTypes <$> getExecEnvType--supportedImageTypes :: ExecEnvType -> [ImageType]-supportedImageTypes LibVirtLXC = LXC.supportedImageTypes- createBuildImages :: IsB9 e => [ImageTarget] -> [ImageType] -> Eff e [Image] createBuildImages imageTargets vmBuildSupportedImageTypes = do dbgL "creating build images"@@ -51,67 +56,75 @@ 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 <- ensureAbsoluteImageDirExists buildImg- materializeImageSource imageSource buildImg- return buildImgAbsolutePath+ 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 <- ensureAbsoluteImageDirExists buildImg+ materializeImageSource imageSource buildImg+ return buildImgAbsolutePath -runVmScript- :: forall e- . IsB9 e- => InstanceId- -> [ImageTarget]- -> [Image]- -> FilePath- -> VmScript- -> Eff e Bool-runVmScript _ _ _ _ NoVmScript = return True-runVmScript (IID iid) imageTargets buildImages instanceDir vmScript = do+runVmScript ::+ forall e backendCfg.+ (Backend backendCfg, IsB9 e) =>+ backendCfg ->+ InstanceId ->+ [ImageTarget] ->+ [Image] ->+ FilePath ->+ VmScript ->+ Eff e Bool+runVmScript _ _ _ _ _ NoVmScript = return True+runVmScript backendCfg (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 :: IsB9 e => Eff e 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))+ result <- runExcB9 $ runInEnvironment backendCfg execEnv script+ handleErrors (either (Left . show) Right result)+ where+ handleErrors :: IsB9 e => Either String Bool -> Eff e Bool+ handleErrors (Right False) = do+ errorL "The containerized build failed!"+ return False+ handleErrors (Right True) = do+ traceL "The containerized build was successful."+ return True+ handleErrors (Left err) =+ errorExitL ("Failed to complete the containerized build: " ++ show err)+ setUpExecEnv :: IsB9 e => Eff e 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- :: IsB9 e => FilePath -> [SharedDirectory] -> Eff e [SharedDirectory]+createSharedDirs ::+ IsB9 e => FilePath -> [SharedDirectory] -> Eff e [SharedDirectory] createSharedDirs instanceDir = mapM createSharedDir- 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+ 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 :: IsB9 e => [Image] -> [ImageTarget] -> Eff e () createDestinationImages buildImages imageTargets = do@@ -122,8 +135,21 @@ mapM_ (uncurry createDestinationImage) pairsToConvert infoL "CONVERTED BUILD- TO OUTPUT IMAGES" -runInEnvironment :: IsB9 e => ExecEnv -> Script -> Eff e Bool-runInEnvironment env script = do- t <- getExecEnvType- case t of- LibVirtLXC -> LXC.runInEnvironment env script+withBackend :: IsB9 e => (forall x. Backend x => x -> Eff e a) -> Eff e (Maybe a)+withBackend k = do+ lxcCfg <- getBackendConfig (Proxy :: Proxy LXC.LibVirtLXC)+ case lxcCfg of+ Just cfg ->+ Just <$> k cfg+ Nothing -> do+ dockerCfg <- getBackendConfig (Proxy :: Proxy Docker.Docker)+ case dockerCfg of+ Just cfg ->+ Just <$> k cfg+ Nothing -> do+ systemdNspawnCfg <- getBackendConfig (Proxy :: Proxy SystemdNspawn.SystemdNspawn)+ case systemdNspawnCfg of+ Just cfg ->+ Just <$> k cfg+ Nothing ->+ return Nothing
src/lib/Data/ConfigFile/B9Extras.hs view
@@ -1,30 +1,33 @@-{-# Language DeriveDataTypeable, ConstraintKinds, ExplicitNamespaces #-}-{-| Extensions to 'Data.ConfigFile' and utility functions for dealing with- configuration in general and reading/writing files. -}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ExplicitNamespaces #-}++-- | Extensions to 'Data.ConfigFile' and utility functions for dealing with+-- configuration in general and reading/writing files. module Data.ConfigFile.B9Extras- ( addSectionCP- , setShowCP- , setCP- , readCP- , mergeCP- , toStringCP- , sectionsCP- , emptyCP- , type CPGet- , type CPOptionSpec- , type CPSectionSpec- , type CPDocument- , CPError()- , readCPDocument- , CPReadException(..)+ ( addSectionCP,+ setShowCP,+ setCP,+ readCP,+ mergeCP,+ toStringCP,+ sectionsCP,+ emptyCP,+ type CPGet,+ type CPOptionSpec,+ type CPSectionSpec,+ type CPDocument,+ CPError (),+ readCPDocument,+ CPReadException (..), ) where -import Data.Typeable-import Data.ConfigFile-import Control.Exception-import Control.Monad.Except-import System.IO.B9Extras+import Control.Exception+import Control.Monad.Except+import Data.ConfigFile+import Data.Typeable+import System.IO.B9Extras -- * Aliases for functions and types from 'ConfigParser' in 'Data.ConfigFile' @@ -38,40 +41,40 @@ type CPOptionSpec = OptionSpec -- | An alias for 'setshow'.-setShowCP- :: (Show a, MonadError CPError m)- => CPDocument- -> CPSectionSpec- -> CPOptionSpec- -> a- -> m CPDocument+setShowCP ::+ (Show a, MonadError CPError m) =>+ CPDocument ->+ CPSectionSpec ->+ CPOptionSpec ->+ a ->+ m CPDocument setShowCP = setshow -- | An alias for 'set'.-setCP- :: (MonadError CPError m)- => CPDocument- -> CPSectionSpec- -> CPOptionSpec- -> String- -> m CPDocument+setCP ::+ (MonadError CPError m) =>+ CPDocument ->+ CPSectionSpec ->+ CPOptionSpec ->+ String ->+ m CPDocument setCP = set -- | An alias for 'get'.-readCP- :: (CPGet a, MonadError CPError m)- => CPDocument- -> CPSectionSpec- -> CPOptionSpec- -> m a+readCP ::+ (CPGet a, MonadError CPError m) =>+ CPDocument ->+ CPSectionSpec ->+ CPOptionSpec ->+ m a readCP = get -- | An alias for 'Get_C' type CPGet a = Get_C a -- | An alias for 'add_section'.-addSectionCP- :: MonadError CPError m => CPDocument -> CPSectionSpec -> m CPDocument+addSectionCP ::+ MonadError CPError m => CPDocument -> CPSectionSpec -> m CPDocument addSectionCP = add_section -- | An alias for 'merge'.@@ -96,10 +99,11 @@ liftIO $ do res <- readfile emptyCP cfgFilePath case res of- Left e -> throwIO (CPReadException cfgFilePath e)+ Left e -> throwIO (CPReadException cfgFilePath e) Right cp -> return cp -- | An exception thrown by 'readCPDocument'. data CPReadException = CPReadException FilePath CPError- deriving (Show, Typeable)+ deriving (Show, Typeable)+ instance Exception CPReadException
src/lib/System/IO/B9Extras.hs view
@@ -1,58 +1,62 @@ -- | Some utilities to deal with IO in B9. module System.IO.B9Extras- ( SystemPath(..)- , overSystemPath- , resolve- , ensureDir- , getDirectoryFiles- , prettyPrintToFile- , consult- , ConsultException(..)- , randomUUID- , UUID()+ ( SystemPath (..),+ overSystemPath,+ resolve,+ ensureDir,+ getDirectoryFiles,+ prettyPrintToFile,+ consult,+ ConsultException (..),+ randomUUID,+ UUID (), ) where -import Data.Typeable-import Control.Exception-import Control.Monad.Except-import System.Directory-import Text.Read ( readEither )-import System.Random ( randomIO )-import Data.Word ( Word16- , Word32- )-import System.FilePath-import Text.Printf-import Data.Data-import Text.Show.Pretty ( ppShow )+import Control.Exception+import Control.Monad.Except+import Data.Data+import Data.Word+ ( Word16,+ Word32,+ )+import System.Directory+import System.FilePath+import System.Random (randomIO)+import Text.Printf+import Text.Read (readEither)+import Text.Show.Pretty (ppShow) -- * Relative Paths -- | A data type encapsulating different kinds of relative or absolute paths.-data SystemPath = Path FilePath -- ^ A path that will just be passed through- | InHomeDir FilePath -- ^ A OS specific path relative to- -- the home directory of a user.- | InB9UserDir FilePath -- ^ A path relative to the @b9@ sub of- -- the users application configuration- -- directory 'getAppUserDataDirectory'- | InTempDir FilePath -- ^ A path relative to the systems- -- temporary directory.+data SystemPath+ = -- | A path that will just be passed through+ Path FilePath+ | -- | A OS specific path relative to+ -- the home directory of a user.+ InHomeDir FilePath+ | -- | A path relative to the @b9@ sub of+ -- the users application configuration+ -- directory 'getAppUserDataDirectory'+ InB9UserDir FilePath+ | -- | A path relative to the systems+ -- temporary directory.+ InTempDir FilePath deriving (Eq, Read, Show, Typeable, Data) -- | Transform a 'SystemPath' overSystemPath :: (FilePath -> FilePath) -> SystemPath -> SystemPath overSystemPath f sp = case sp of- Path p -> Path (f p)- InHomeDir p -> InHomeDir (f p)- InB9UserDir p -> InB9UserDir (f p)- InTempDir p -> InTempDir (f p)-+ Path p -> Path (f p)+ InHomeDir p -> InHomeDir (f p)+ InB9UserDir p -> InB9UserDir (f p)+ InTempDir p -> InTempDir (f p) -- | Convert a 'SystemPath' to a 'FilePath'. resolve :: MonadIO m => SystemPath -> m FilePath-resolve (Path p) = return p+resolve (Path p) = return p resolve (InHomeDir p) = liftIO $ do d <- getHomeDirectory return $ d </> p@@ -68,7 +72,7 @@ -- | 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)+ entries <- liftIO (getDirectoryContents dir) fileEntries <- mapM (liftIO . doesFileExist . (dir </>)) entries return (snd <$> filter fst (fileEntries `zip` entries)) @@ -93,7 +97,7 @@ consult f = liftIO $ do c <- readFile f case readEither c of- Left e -> throwIO $ ConsultException f e+ Left e -> throwIO $ ConsultException f e Right a -> return a -- | An 'Exception' thrown by 'consult' to indicate the file does not@@ -108,26 +112,27 @@ -- | A bunch of numbers, enough to make globally unique IDs. Create one of these -- using 'randomUUID'. newtype UUID = UUID (Word32, Word16, Word16, Word16, Word32, Word16)- deriving (Read, Show, Eq, Ord)+ 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+ | 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 -- | Generate a random 'UUID'. randomUUID :: MonadIO m => m UUID-randomUUID = liftIO- ( UUID- <$> ( (,,,,,)- <$> randomIO- <*> randomIO- <*> randomIO- <*> randomIO- <*> randomIO- <*> randomIO- )- )+randomUUID =+ liftIO+ ( UUID+ <$> ( (,,,,,)+ <$> randomIO+ <*> randomIO+ <*> randomIO+ <*> randomIO+ <*> randomIO+ <*> randomIO+ )+ )
src/tests/B9/ArtifactGeneratorImplSpec.hs view
@@ -1,140 +1,137 @@ module B9.ArtifactGeneratorImplSpec- ( spec+ ( spec, ) where -import B9.Artifact.Readable-import B9.Artifact.Readable.Interpreter-import B9.DiskImages-import B9.ExecEnv-import B9.ShellScript-import B9.Vm-import Data.Text ( )-import Test.Hspec+import B9.Artifact.Readable+import B9.Artifact.Readable.Interpreter+import B9.DiskImages+import B9.ExecEnv+import B9.ShellScript+import B9.Vm+import Data.Text ()+import Test.Hspec spec :: Spec spec = describe "assemble" $ do- it "replaces '$...' variables in SourceImage Image file paths"- $ let- src = Let- [("variable", "value")]- [vmImagesArtifact "" [transientCOW "${variable}" ""] NoVmScript]+ it "replaces '$...' variables in SourceImage Image file paths" $+ let src =+ Let+ [("variable", "value")]+ [vmImagesArtifact "" [transientCOW "${variable}" ""] NoVmScript] expected = transientCOW "value" "" (Right [IG _ _ (VmImages [actual] _)]) = runArtifactGenerator mempty "" "" src- in- actual `shouldBe` expected- it "replaces '$...' variables in SourceImage 'From' names"- $ let- src = Let- [("variable", "value")]- [vmImagesArtifact "" [transientShared "${variable}" ""] NoVmScript]+ in actual `shouldBe` expected+ it "replaces '$...' variables in SourceImage 'From' names" $+ let src =+ Let+ [("variable", "value")]+ [vmImagesArtifact "" [transientShared "${variable}" ""] NoVmScript] expected = transientShared "value" "" (Right [IG _ _ (VmImages [actual] _)]) = runArtifactGenerator mempty "" "" src- in- actual `shouldBe` expected- it "replaces '$...' variables in the name of a shared image"- $ let- src = Let- [("variable", "value")]- [vmImagesArtifact "" [shareCOW "${variable}" ""] NoVmScript]+ in actual `shouldBe` expected+ it "replaces '$...' variables in the name of a shared image" $+ let src =+ Let+ [("variable", "value")]+ [vmImagesArtifact "" [shareCOW "${variable}" ""] NoVmScript] expected = shareCOW "value" "" (Right [IG _ _ (VmImages [actual] _)]) = runArtifactGenerator mempty "" "" src- in- actual `shouldBe` expected- it "replaces '$...' variables in the name and path of a live installer image"- $ let- src = Let- [("variable", "value")]- [ vmImagesArtifact ""- [liveInstallerCOWImage "${variable}" ""]- NoVmScript- ]+ in actual `shouldBe` expected+ it "replaces '$...' variables in the name and path of a live installer image" $+ let src =+ Let+ [("variable", "value")]+ [ vmImagesArtifact+ ""+ [liveInstallerCOWImage "${variable}" ""]+ NoVmScript+ ] expected = liveInstallerCOWImage "value" "" (Right [IG _ _ (VmImages [actual] _)]) = runArtifactGenerator mempty "" "" src- in- actual `shouldBe` expected+ in actual `shouldBe` expected it- "replaces '$...' variables in the file name of an image exported as LocalFile"- $ let- src = Let- [("variable", "value")]- [vmImagesArtifact "" [localCOWImage "${variable}" ""] NoVmScript]- expected = localCOWImage "value" ""- (Right [IG _ _ (VmImages [actual] _)]) =- runArtifactGenerator mempty "" "" src- in- actual `shouldBe` expected- it "replaces '$...' variables in mount point of an image"- $ let- src = Let- [("variable", "value")]- [vmImagesArtifact "" [localCOWImage "" "${variable}"] NoVmScript]+ "replaces '$...' variables in the file name of an image exported as LocalFile"+ $ let src =+ Let+ [("variable", "value")]+ [vmImagesArtifact "" [localCOWImage "${variable}" ""] NoVmScript]+ expected = localCOWImage "value" ""+ (Right [IG _ _ (VmImages [actual] _)]) =+ runArtifactGenerator mempty "" "" src+ in actual `shouldBe` expected+ it "replaces '$...' variables in mount point of an image" $+ let src =+ Let+ [("variable", "value")]+ [vmImagesArtifact "" [localCOWImage "" "${variable}"] NoVmScript] expected = localCOWImage "" "value" (Right [IG _ _ (VmImages [actual] _)]) = runArtifactGenerator mempty "" "" src- in- actual `shouldBe` expected- it "replaces '$...' variables in shared directory source and mount point (RO)"- $ let- src = Let- [("variable", "value")]- [vmImagesArtifact "" [] (emptyScriptWithSharedDirRO "${variable}")]+ in actual `shouldBe` expected+ it "replaces '$...' variables in shared directory source and mount point (RO)" $+ let src =+ Let+ [("variable", "value")]+ [vmImagesArtifact "" [] (emptyScriptWithSharedDirRO "${variable}")] expected = emptyScriptWithSharedDirRO "value" (Right [IG _ _ (VmImages [] actual)]) = runArtifactGenerator mempty "" "" src- in- actual `shouldBe` expected- it "replaces '$...' variables in shared directory source and mount point (RW)"- $ let- src = Let- [("variable", "value")]- [vmImagesArtifact "" [] (emptyScriptWithSharedDirRW "${variable}")]+ in actual `shouldBe` expected+ it "replaces '$...' variables in shared directory source and mount point (RW)" $+ let src =+ Let+ [("variable", "value")]+ [vmImagesArtifact "" [] (emptyScriptWithSharedDirRW "${variable}")] expected = emptyScriptWithSharedDirRW "value" (Right [IG _ _ (VmImages [] actual)]) = runArtifactGenerator mempty "" "" src- in- actual `shouldBe` expected- it "replaces '$...' variables in VmImages build script instructions"- $ let- src = Let [("variable", "value")]- [vmImagesArtifact "" [] (buildScript "${variable}")]+ in actual `shouldBe` expected+ it "replaces '$...' variables in VmImages build script instructions" $+ let src =+ Let+ [("variable", "value")]+ [vmImagesArtifact "" [] (buildScript "${variable}")] expected = buildScript "value" (Right [IG _ _ (VmImages [] actual)]) = runArtifactGenerator mempty "" "" src- in- actual `shouldBe` expected+ in actual `shouldBe` expected transientCOW :: FilePath -> FilePath -> ImageTarget-transientCOW fileName mountPoint = ImageTarget- Transient- (CopyOnWrite (Image fileName QCow2 Ext4))- (MountPoint mountPoint)+transientCOW fileName mountPoint =+ ImageTarget+ Transient+ (CopyOnWrite (Image fileName QCow2 Ext4))+ (MountPoint mountPoint) transientShared :: FilePath -> FilePath -> ImageTarget transientShared name mountPoint = ImageTarget Transient (From name KeepSize) (MountPoint mountPoint) shareCOW :: FilePath -> FilePath -> ImageTarget-shareCOW destName mountPoint = ImageTarget- (Share destName QCow2 KeepSize)- (CopyOnWrite (Image "cowSource" QCow2 Ext4))- (MountPoint mountPoint)+shareCOW 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)+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)+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)@@ -148,7 +145,8 @@ 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]]])+buildScript arg =+ VmScript+ X86_64+ [SharedDirectory arg (MountPoint arg), SharedDirectoryRO arg NotMounted]+ (As arg [In arg [Run arg [arg]]])
src/tests/B9/Content/ErlTermsSpec.hs view
@@ -1,193 +1,174 @@ {-# LANGUAGE OverloadedStrings #-}+ module B9.Content.ErlTermsSpec- ( spec- )+ ( spec,+ ) where -import Data.List-import Test.Hspec-import Test.QuickCheck-import Data.Maybe-import B9.Artifact.Content.ErlTerms-import B9.Text+import B9.Artifact.Content.ErlTerms+import B9.Text+import Data.List+import Data.Maybe+import Test.Hspec+import Test.QuickCheck 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 =- unsafeRenderToText (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 = unsafeRenderToText (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 _ correctly as '_'"- (renderErlTerm (ErlAtom "_") `shouldBe` "'_'.")-- it "renders an empty string correctly as ''"- (renderErlTerm (ErlAtom "") `shouldBe` "''.")-- 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+ 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 =+ unsafeRenderToText (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 = unsafeRenderToText (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 _ correctly as '_'"+ (renderErlTerm (ErlAtom "_") `shouldBe` "'_'.")+ it+ "renders an empty string correctly as ''"+ (renderErlTerm (ErlAtom "") `shouldBe` "''.")+ 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))+ 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+ let hornersMethod acc d = acc * radixHighPrecision + digitCharToInteger d+ digitCharToInteger d = toInteger $ fromJust $ elemIndex d naturals+ radixHighPrecision = toInteger radix+ in foldl hornersMethod 0 digitChars
src/tests/B9/Content/ErlangPropListSpec.hs view
@@ -1,103 +1,103 @@ {-# LANGUAGE OverloadedStrings #-}+ module B9.Content.ErlangPropListSpec- ( spec- )+ ( spec,+ ) where -import Data.List-import Test.Hspec-import Test.QuickCheck-import Data.Text ( )-import B9.Text-import B9.Artifact.Content.ErlTerms-import B9.Artifact.Content.ErlangPropList+import B9.Artifact.Content.ErlTerms+import B9.Artifact.Content.ErlangPropList+import B9.Text+import Data.List+import Data.Text ()+import Test.Hspec+import Test.QuickCheck spec :: Spec spec = describe "ErlangPropList" $ do-- it "parseFromText"- $ let v = parseFromText "ok."- in v `shouldBe` Right (ErlangPropList (ErlAtom "ok"))-- it "renterToText"- $ let v = renderToText (ErlangPropList (ErlAtom "ok"))- in v `shouldBe` Right "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) =- parseFromText "[a,b,c]." :: Either String ErlangPropList- (Right p ) = parseFromText "{ok,value}."- (Right combined) = parseFromText "[a,b,c,{ok,value}]."- in l <> p `shouldBe` combined-- it "combines a primitve and a list by extending the list"- $ let (Right l) =- parseFromText "[a,b,c]." :: Either String ErlangPropList- (Right p ) = parseFromText "{ok,value}."- (Right combined) = parseFromText "[{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]]+ it "parseFromText" $+ let v = parseFromText "ok."+ in v `shouldBe` Right (ErlangPropList (ErlAtom "ok"))+ it "renterToText" $+ let v = renderToText (ErlangPropList (ErlAtom "ok"))+ in v `shouldBe` Right "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) =+ parseFromText "[a,b,c]." :: Either String ErlangPropList+ (Right p) = parseFromText "{ok,value}."+ (Right combined) = parseFromText "[a,b,c,{ok,value}]."+ in l <> p `shouldBe` combined+ it "combines a primitve and a list by extending the list" $+ let (Right l) =+ parseFromText "[a,b,c]." :: Either String ErlangPropList+ (Right p) = parseFromText "{ok,value}."+ (Right combined) = parseFromText "[{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)+ )+ 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)+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+ 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- }+ 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 =+ 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 =+ arbitraryTuple = ErlTuple <$> listOf arbitraryPlistValue+ arbitraryList = ErlList <$> listOf arbitraryPlistValue+ arbitraryLiteral = oneof [arbitraryPlistKey, arbitraryErlString, arbitraryErlNumber]
src/tests/B9/Content/YamlObjectSpec.hs view
@@ -1,110 +1,99 @@ {-# LANGUAGE OverloadedStrings #-}+ module B9.Content.YamlObjectSpec- ( spec- )+ ( spec,+ ) where -#if !MIN_VERSION_base(4,11,0)-import Data.Semigroup-#endif-import Test.Hspec-import Data.Text ( )-import Data.Yaml--import B9.Artifact.Content.YamlObject-import B9.Artifact.Content.CloudConfigYaml-import B9.Artifact.Content.AST+import B9.Artifact.Content.AST+import B9.Artifact.Content.CloudConfigYaml+import B9.Artifact.Content.YamlObject+import Data.Text ()+import Data.Yaml+import Test.Hspec 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-- describe "CloudConfigYaml" $ do- it- "combines 'write_files' and 'runcmd' from typical 'user-data' files by merging each"- $ let- ud1, ud2 :: CloudConfigYaml- (Right ud1) = parseFromTextWithErrorMessage- ""- "#cloud-config\n\nwrite_files:\n - contents: |\n hello world!\n\n path: /sdf/xyz/filename.cfg\n owner: root:root\n\nruncmd:\n - x y z\n"- (Right ud2) = parseFromTextWithErrorMessage- ""- "#cloud-config\n\nwrite_files:\n - contents: |\n hello world2!\n\n path: /sdf/xyz/filename.cfg\n owner: root:root\n\nruncmd:\n - a b c\n"-- ud = MkCloudConfigYaml $ 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)- ]- ]+ 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- ud1 <> ud2 `shouldBe` ud-- it "combines strings by appending them"- $ let- o1 = MkCloudConfigYaml- $ YamlObject (object ["k" .= toJSON ("Hello" :: String)])- o2 = MkCloudConfigYaml- $ YamlObject (object ["k" .= toJSON ("World" :: String)])- combined =- MkCloudConfigYaml $ YamlObject- (object ["k" .= toJSON ("HelloWorld" :: String)])- in- (o1 <> o2) `shouldBe` combined--+ )+ in (o1 <> o2) `shouldBe` combined+ describe "CloudConfigYaml" $ do+ it+ "combines 'write_files' and 'runcmd' from typical 'user-data' files by merging each"+ $ let ud1, ud2 :: CloudConfigYaml+ (Right ud1) =+ parseFromTextWithErrorMessage+ ""+ "#cloud-config\n\nwrite_files:\n - contents: |\n hello world!\n\n path: /sdf/xyz/filename.cfg\n owner: root:root\n\nruncmd:\n - x y z\n"+ (Right ud2) =+ parseFromTextWithErrorMessage+ ""+ "#cloud-config\n\nwrite_files:\n - contents: |\n hello world2!\n\n path: /sdf/xyz/filename.cfg\n owner: root:root\n\nruncmd:\n - a b c\n"+ ud =+ MkCloudConfigYaml $+ 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+ it "combines strings by appending them" $+ let o1 =+ MkCloudConfigYaml $+ YamlObject (object ["k" .= toJSON ("Hello" :: String)])+ o2 =+ MkCloudConfigYaml $+ YamlObject (object ["k" .= toJSON ("World" :: String)])+ combined =+ MkCloudConfigYaml $+ YamlObject+ (object ["k" .= toJSON ("HelloWorld" :: String)])+ in (o1 <> o2) `shouldBe` combined -- describe "fromAST YamlObject" $ do -- -- it "returns x from (AST x)" $
src/tests/B9/DiskImagesSpec.hs view
@@ -1,33 +1,38 @@ module B9.DiskImagesSpec (spec) where-import Test.Hspec-import Test.QuickCheck import B9.DiskImages+import Test.Hspec+import Test.QuickCheck spec :: Spec spec = describe "DiskImages" $ do describe "splitToIntermediateSharedImage" $- do it "puts the original source into the intermediate target" $- property- (\target name ->- itImageSource target ==- itImageSource- (fst (splitToIntermediateSharedImage target name)))- it "puts the original destination into the export target" $- property- (\target name ->- itImageDestination target ==- itImageDestination- (snd (splitToIntermediateSharedImage target name)))- it- "puts the intermediate shared image name into both the intermediate and the export target" $- property- (\target name ->- let (intermediateTarget,exportTarget) =- splitToIntermediateSharedImage target name- in imageDestinationSharedImageName- (itImageDestination intermediateTarget) ==- imageSourceSharedImageName (itImageSource exportTarget))- context "inline unit tests"+ do+ it "puts the original source into the intermediate target" $+ property+ ( \target name ->+ itImageSource target+ == itImageSource+ (fst (splitToIntermediateSharedImage target name))+ )+ it "puts the original destination into the export target" $+ property+ ( \target name ->+ itImageDestination target+ == itImageDestination+ (snd (splitToIntermediateSharedImage target name))+ )+ it+ "puts the intermediate shared image name into both the intermediate and the export target"+ $ property+ ( \target name ->+ let (intermediateTarget, exportTarget) =+ splitToIntermediateSharedImage target name+ in imageDestinationSharedImageName+ (itImageDestination intermediateTarget)+ == imageSourceSharedImageName (itImageSource exportTarget)+ )+ context+ "inline unit tests" unitTests
src/tests/B9/EnvironmentSpec.hs view
@@ -1,36 +1,35 @@ {-# LANGUAGE OverloadedStrings #-}-module B9.EnvironmentSpec (spec) where -import Test.Hspec-import Data.Text+module B9.EnvironmentSpec+ ( spec,+ )+where+ import B9.Environment import Control.Eff+import Data.Text+import Test.Hspec spec :: Spec spec =- describe "Environment" $- describe "addLocalPositionalArguments" $ do- let k = 13 :: Integer- j = 7 :: Integer- n = 13 :: Integer- args = [pack (show i) | i <- [1 .. n]]-- k_key = pack ("arg_" ++ show k)- j_key = pack ("arg_" ++ show j)-- k_value = pack (show k)- j_value = pack (show j)-- testEnv = addPositionalArguments args mempty- inEnv = run . runEnvironmentReader testEnv-- it "generates keys prefixed with arg_ followed by an ascending numeric index, starting with 1" $- let res = inEnv $ do- ej_value <- lookupEither j_key- ek_value <- lookupEither k_key- e_arg_0 <- lookupEither "arg_0"- return (ej_value, ek_value, e_arg_0)+ describe "Environment"+ $ describe "addLocalPositionalArguments"+ $ do+ let k = 13 :: Integer+ j = 7 :: Integer+ n = 13 :: Integer+ args = [pack (show i) | i <- [1 .. n]]+ k_key = pack ("arg_" ++ show k)+ j_key = pack ("arg_" ++ show j)+ k_value = pack (show k)+ j_value = pack (show j)+ testEnv = addPositionalArguments args mempty+ inEnv = run . runEnvironmentReader testEnv+ it "generates keys prefixed with arg_ followed by an ascending numeric index, starting with 1" $+ let res = inEnv $ do+ ej_value <- lookupEither j_key+ ek_value <- lookupEither k_key+ e_arg_0 <- lookupEither "arg_0"+ return (ej_value, ek_value, e_arg_0) in res `shouldBe` (Right j_value, Right k_value, Left (MkKeyNotFound "arg_0" testEnv))- -- run . runEnvironmentReader testEnv $ do-
stack.yaml view
@@ -6,5 +6,5 @@ - template-0.2.0.10 - extensible-effects-5.0.0.1 -resolver: lts-13.13+resolver: lts-14.7 require-stack-version: ">=1.6.5"