├── .github └── workflows │ └── test.yml ├── .gitignore ├── .vscode ├── settings.json └── tasks.json ├── BACKLOG.md ├── CHANGELOG.md ├── CODE_OF_CONDUCT.md ├── CONTRIBUTING.md ├── CONTRIBUTORS ├── LICENSE ├── README.md ├── Setup.hs ├── TODO.md ├── b9.cabal ├── default.nix ├── examples ├── default.nix ├── libvirt-lxc.b9.conf ├── max.b9 ├── minimal-image-in.qcow2 ├── minimal-interactive.b9 ├── minimal-sleep-5.b9 ├── minimal.b9 ├── runExamples.sh ├── systemd-nspawn-bad-extra-args.b9.conf ├── systemd-nspawn-console-interactive.b9.conf ├── systemd-nspawn-console-passive.b9.conf ├── systemd-nspawn-console-pipe.b9.conf ├── systemd-nspawn-executable-non-existing.b9.conf ├── systemd-nspawn-no-sudo.b9.conf ├── systemd-nspawn-no-timeout.b9.conf ├── systemd-nspawn-short-timeout.b9.conf ├── systemd-nspawn.b9.conf ├── test-share-max │ └── hosts └── test-share-ro │ └── test ├── extract_layers ├── create-vm.sh └── vm_scripts │ └── install.sh ├── extract_layers_podman ├── create-vm.sh └── vm_scripts │ └── install.sh ├── extract_layers_systemd_nspawn ├── create-vm.sh └── vm_scripts │ └── install.sh ├── flake.lock ├── flake.nix ├── hie.yaml ├── nix └── materialization │ └── b9 │ ├── .plan.nix │ └── b9.nix │ └── default.nix ├── overlay.nix ├── reformat-code.sh ├── shell.nix └── src ├── cli └── Main.hs ├── lib ├── B9.hs ├── B9 │ ├── Artifact.hs │ ├── Artifact │ │ ├── Content.hs │ │ ├── Content │ │ │ ├── AST.hs │ │ │ ├── CloudConfigYaml.hs │ │ │ ├── ErlTerms.hs │ │ │ ├── ErlangPropList.hs │ │ │ ├── Readable.hs │ │ │ ├── StringTemplate.hs │ │ │ └── YamlObject.hs │ │ ├── Readable.hs │ │ └── Readable │ │ │ ├── Interpreter.hs │ │ │ └── Source.hs │ ├── B9Config.hs │ ├── B9Config │ │ ├── Container.hs │ │ ├── Docker.hs │ │ ├── LibVirtLXC.hs │ │ ├── Podman.hs │ │ ├── Repository.hs │ │ └── SystemdNspawn.hs │ ├── B9Error.hs │ ├── B9Exec.hs │ ├── B9Logging.hs │ ├── B9Monad.hs │ ├── BuildInfo.hs │ ├── Container.hs │ ├── DiskImageBuilder.hs │ ├── DiskImages.hs │ ├── Docker.hs │ ├── Environment.hs │ ├── ExecEnv.hs │ ├── LibVirtLXC.hs │ ├── MBR.hs │ ├── PartitionTable.hs │ ├── Podman.hs │ ├── QCUtil.hs │ ├── Repository.hs │ ├── RepositoryIO.hs │ ├── Shake.hs │ ├── Shake │ │ ├── Actions.hs │ │ └── SharedImageRules.hs │ ├── ShellScript.hs │ ├── SystemdNspawn.hs │ ├── Text.hs │ ├── Vm.hs │ └── VmBuilder.hs ├── Data │ └── ConfigFile │ │ └── B9Extras.hs └── System │ └── IO │ └── B9Extras.hs └── tests ├── B9 ├── ArtifactGeneratorImplSpec.hs ├── B9ConfigSpec.hs ├── B9ExecSpec.hs ├── Content │ ├── ErlTermsSpec.hs │ ├── ErlangPropListSpec.hs │ └── YamlObjectSpec.hs ├── DiskImageBuilderSpec.hs ├── DiskImagesSpec.hs ├── EnvironmentSpec.hs ├── RepositoryIOSpec.hs ├── RepositorySpec.hs └── Shake │ └── SharedImageRulesSpec.hs └── Spec.hs /.github/workflows/test.yml: -------------------------------------------------------------------------------- 1 | name: "QA Reports" 2 | on: 3 | push: 4 | pull_request: 5 | jobs: 6 | tests: 7 | runs-on: ubuntu-latest 8 | steps: 9 | - uses: actions/checkout@v2.3.4 10 | - uses: cachix/install-nix-action@v12 11 | with: 12 | extra_nix_config: | 13 | substituters = https://cache.nixos.org/ file://$HOME/nix.store https://hydra.iohk.io 14 | trusted-public-keys = hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= hydra.nixos.org-1:CNHJZBh9K4tP3EKF6FkkgeVYsS3ohTl+oS0Qa8bezVs= 15 | require-sigs = false 16 | - run: nix-build 17 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .shake 2 | *.hi 3 | *.ho 4 | TAGS 5 | *.log 6 | *.profile 7 | BUILD* 8 | OUT 9 | *.orig 10 | /.cabal-sandbox/ 11 | /cabal.sandbox.config 12 | /upload_doc.sh 13 | 14 | # Intellij IDEA 15 | /.idea/ 16 | *.iml 17 | 18 | .stack-work 19 | result* 20 | *~ 21 | /out 22 | *.raw 23 | *.qcow2 24 | *.tar 25 | *.vmdk 26 | dist* 27 | -------------------------------------------------------------------------------- /.vscode/settings.json: -------------------------------------------------------------------------------- 1 | { 2 | "editor.trimAutoWhitespace": true, 3 | "files.trimTrailingWhitespace": true, 4 | "files.insertFinalNewline": true, 5 | "files.trimFinalNewlines": true, 6 | "nixEnvSelector.nixShellConfig": "${workspaceRoot}/shell.nix" 7 | } 8 | -------------------------------------------------------------------------------- /.vscode/tasks.json: -------------------------------------------------------------------------------- 1 | { 2 | // See https://go.microsoft.com/fwlink/?LinkId=733558 3 | // for the documentation about the tasks.json format 4 | "version": "2.0.0", 5 | "tasks": [ 6 | { 7 | "label": "stack build", 8 | "type": "shell", 9 | "command": "stack build", 10 | "group": { 11 | "kind": "build", 12 | "isDefault": true 13 | } 14 | } 15 | ] 16 | } 17 | -------------------------------------------------------------------------------- /BACKLOG.md: -------------------------------------------------------------------------------- 1 | # B9 Backlog 2 | 3 | ## +0.1.0 4 | 5 | * Allow specifying the `systemd-nspawn` executable path by environment variable. 6 | 7 | ## +0.1.0 8 | 9 | * Allow lookup of every external executable via environment variable: 10 | `B9_PATH_xxxxx` where `xxxxx` the name of the tool reduced to alpha-numeric 11 | characters, e.g. for `systemd-nspawn` this will be `B9_PATH_systemdnspawn` 12 | 13 | * Add configuration options for __SystemdNspawn__: 14 | * `setenv`: A comma seperated list of `key=value` pairs 15 | with environment variable assignments passed to the container 16 | * `chdir`: An optional working directory to change to before 17 | running the script in the container. 18 | * `user`: An optional user to change to after entering the container. 19 | The user must exist in the container image, e.g. in `/etc/passwd`. 20 | * `hostname`: An optional hostname to use as the kernel hostname 21 | inside the container. 22 | 23 | ## +0.0.1 24 | 25 | * When `unique_build_dirs` __is disabled:__ 26 | Form the build-id by hashing a product of: 27 | * the command line parameters 28 | * the project directory 29 | * the `Environment` 30 | * the `B9Configuration` 31 | 32 | ## +0.1.0 33 | 34 | * Add support for rendering **nix-expressions** 35 | 36 | ## +0.1.0 37 | 38 | * Add support for `.dhall` for `.b9` content 39 | 40 | ## +0.1.0 41 | 42 | * Add TAR build-env 43 | * Add Tar VmScript alternative 44 | 45 | ## +0.1.0 46 | 47 | * Add docker/oci image import/export 48 | 49 | ## +0.1.0 50 | 51 | * Add CHROOT build-env 52 | 53 | # Release 1.0.0 Back-Log 54 | 55 | **DEPRECATED most of this was not in 1.0.0** 56 | 57 | * TODO What should go into 1.0.0? 58 | 59 | ## Feature Back-Log 60 | 61 | ### Introduce _eventually_ reproducable builds 62 | 63 | Make everything as pure as possible in the configuration phase 64 | and explicitely allow variations in items such as build date. By every command MUST be able to name its 65 | inputs. All input must be instances of Hashable. 66 | 67 | ### Increase User Experience 68 | 69 | * Switch to HOCON(initially thought of yaml, so examples below need rewriting) configuration; get rid of the ArtifactGenerator 70 | 71 | * Add dummy modes where possible, dummy mode should go down into every module and component 72 | 73 | * Answer "What are you doing?", "Why are you doing this?" 74 | using a query interface, that allows for **interactive introspection**, e.g. by using live monitoring and 75 | console. 76 | 77 | * Require every component to have it's own logging as part of a logging tree. For example: 78 | 79 | 1. **source 80 | 81 | ### Improve Code Maintainability 82 | 83 | * More modules; 84 | 85 | * Name: Never use abbrev. 86 | 87 | * Simplify Types, remove types that have almost identical names and semantics using polymorphism 88 | change B9Config to be polymorphic and a functor, e.g.: 89 | 90 | data B9ConfigF f = B9C { _b9cHostBuildDirectory :: f FilePath 91 | , _b9cLogLevel :: f LogLevel 92 | , ... 93 | } 94 | type B9Config = B9ConfigF Identity 95 | type B9ConfigMonoid = B9ConfigF Last 96 | 97 | * Introduce a clearly seperated set of core principles, namely: 98 | **executor**, **configuration**, **source**, **host**, **builder** and **target** 99 | 100 | * **executor** the code that holds together and connects the other parts 101 | 102 | * Has a `cli-tool` (i.e. a _Main_ module) 103 | 104 | * Provides a high-level API 105 | 106 | * Reads the **local** OS and platform 107 | 108 | * Calls **configuration** 109 | 110 | * **configuration** Framework 111 | 112 | * Either `type classes` or `records` for combining command line and 113 | file based configuration of all sub-components. 114 | 115 | * every component could provide a config data type that is parameterized over a functor, e.g.: 116 | 117 | data SystemDNSpawnConfig1 f = SNSConfig { _snsAddToSplice :: f (Maybe String) 118 | , ... 119 | } 120 | deriving (Generic1) 121 | 122 | type SystemDNSpawnConfig = SystemDNSpawnConfig1 Identity 123 | 124 | type SystemDNSpawnConfigMonoid = SystemDNSpawnConfig1 Maybe 125 | 126 | This way ... TODO 127 | 128 | * Parses command line configuration 129 | 130 | * Parses configuration files 131 | 132 | * every component must provide a list of configuration files to inspect 133 | 134 | * every component must provide a command line switch to overwrite the configuration file 135 | 136 | * **source**-components provide inputs used by **host** **build** and 137 | **target** 138 | 139 | Each input must specify a platform triple for compatibility with the other three components. 140 | 141 | E.g.: The `raw ext4 creator/transformer` **source** component needs to run _Linux commands_ on **host** 142 | e.g. `mkfs.ext4`, it also needs _Linux image mounting_ system during **build** and will most likely 143 | contain a Linux based **target** system. 144 | 145 | Source unpacking: 146 | 147 | How can we unify .tar.gz archives, MBR disk images with ext4 filesystems in them, and local directories 148 | in the light of building in them and generating output targets? 149 | 150 | Now suppose there is `Linux Container` **host** component, and a `Linux Shell` **build** component, 151 | then a B9 execution would be the orchestration of the sources, hosts and builds: 152 | 153 | inputs: 154 | - compressed-mrf-build-image: 155 | from-git-repo: 156 | repo-url: git://binary-repo.local/os-images 157 | file: mrf-build-image.qcow2.xz 158 | rev: 0.91.0 159 | 160 | - mrf-build-image: 161 | resized-ext4-filesystem: 162 | fs-label: root 163 | size: 12GiB 164 | from: 165 | qemu-converted-disk-image: 166 | format-out: raw 167 | format-in: qcow2 168 | from: compressed-mrf-build-image 169 | 170 | - rpm-build-script: 171 | local-files: 172 | required-files: 173 | - main.sh 174 | included-files: 175 | - src/rpm-build/*.sh 176 | 177 | outputs: 178 | - rpms-output-directory: 179 | local-directory: /tmp/mrf-rpms 180 | 181 | build: 182 | - mrf-rpm-build: 183 | linux-shell-script: 184 | host: default-host (optional, default value: 'host') 185 | main: main.sh 186 | source-directory: rpm-build-script 187 | output-directory: rpms-out 188 | 189 | hosts: 190 | - systemd-nspawn: 191 | label: host (optional with default value: 'host') 192 | root: mrf-build-image (optional with default value: 'root-image') 193 | output-bindings: 194 | - rpm-output-directory 195 | input-bindings: [] 196 | 197 | 198 | * **host** 199 | 200 | * **builder** 201 | 202 | * **target** 203 | 204 | ### **source** Examples 205 | 206 | 1. docker images 207 | 208 | 2. nix 209 | 210 | 3. specially crafted git repos 211 | 212 | 4. nexus binary repository access 213 | 214 | 5. multi-source 215 | 216 | 6. bind-mounts 217 | 218 | 7. ext4 image creator/transformer 219 | 220 | 8. fetch urls 221 | 222 | 9. local files 223 | 224 | 10. unpack local archive files 225 | 226 | ### **host** Examples: 227 | 228 | 1. systemd-nspawn 229 | 230 | 2. SSH remote 231 | 232 | 3. docker 233 | 234 | 4. nix 235 | 236 | 5. distributed kubernetes build 237 | 238 | ### **builder** Examples: 239 | 240 | 0. Static File Writing (ala Cloud-Init) 241 | 242 | 1. Yaml files 243 | 244 | 2. Shell/Python/Ruby scripts with template extrapolation 245 | 246 | 3. Classical B9 Haskell 247 | 248 | 4. Interpret Haskell Module using `hint` 249 | 250 | 5. Docker 251 | 252 | 6. nix expressions 253 | 254 | ### **target** Examples: 255 | 256 | 0. VMDK images generated by `qemu-img` 257 | 258 | 1. `NullTarget` 259 | 260 | 2. git repo for generated images 261 | 262 | 3. HTML rendering of the output 263 | 264 | 4. host directories 265 | 266 | 5. rsync target 267 | 268 | 6. zip archive 269 | -------------------------------------------------------------------------------- /CODE_OF_CONDUCT.md: -------------------------------------------------------------------------------- 1 | # Code of Conduct TL,DR; 2 | 3 | **All creatures are welcome.** 4 | 5 | **Be excellent to each other!** 6 | 7 | **Don't assume bad intention, there is always a part of the story you might not know...** 8 | 9 | **Behave as if children were reading everything, don't use bad language.** 10 | 11 | # Contributor Covenant Code of Conduct 12 | 13 | ## Our Pledge 14 | 15 | In the interest of fostering an open and welcoming environment, we as contributors and maintainers pledge to making participation in our project and our community a harassment-free experience for everyone, regardless of age, body size, disability, ethnicity, gender identity and expression, level of experience, nationality, personal appearance, race, religion, or sexual identity and orientation. 16 | 17 | ## Our Standards 18 | 19 | Examples of behavior that contributes to creating a positive environment include: 20 | 21 | * Using welcoming and inclusive language 22 | * Being respectful of differing viewpoints and experiences 23 | * Gracefully accepting constructive criticism 24 | * Focusing on what is best for the community 25 | * Showing empathy towards other community members 26 | 27 | Examples of unacceptable behavior by participants include: 28 | 29 | * The use of sexualized language or imagery and unwelcome sexual attention or advances 30 | * Trolling, insulting/derogatory comments, and personal or political attacks 31 | * Public or private harassment 32 | * Publishing others' private information, such as a physical or electronic address, without explicit permission 33 | * Other conduct which could reasonably be considered inappropriate in a professional setting 34 | 35 | ## Our Responsibilities 36 | 37 | Project maintainers are responsible for clarifying the standards of acceptable behavior and are expected to take appropriate and fair corrective action in response to any instances of unacceptable behavior. 38 | 39 | Project maintainers have the right and responsibility to remove, edit, or reject comments, commits, code, wiki edits, issues, and other contributions that are not aligned to this Code of Conduct, or to ban temporarily or permanently any contributor for other behaviors that they deem inappropriate, threatening, offensive, or harmful. 40 | 41 | ## Scope 42 | 43 | This Code of Conduct applies both within project spaces and in public spaces when an individual is representing the project or its community. Examples of representing a project or community include using an official project e-mail address, posting via an official social media account, or acting as an appointed representative at an online or offline event. Representation of a project may be further defined and clarified by project maintainers. 44 | 45 | ## Enforcement 46 | 47 | Instances of abusive, harassing, or otherwise unacceptable behavior may be reported by contacting the project team at svh@posteo.de. The project team will review and investigate all complaints, and will respond in a way that it deems appropriate to the circumstances. The project team is obligated to maintain confidentiality with regard to the reporter of an incident. Further details of specific enforcement policies may be posted separately. 48 | 49 | Project maintainers who do not follow or enforce the Code of Conduct in good faith may face temporary or permanent repercussions as determined by other members of the project's leadership. 50 | 51 | ## Attribution 52 | 53 | This Code of Conduct is adapted from the [Contributor Covenant][homepage], version 1.4, available at [http://contributor-covenant.org/version/1/4][version] 54 | 55 | [homepage]: http://contributor-covenant.org 56 | [version]: http://contributor-covenant.org/version/1/4/ 57 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contribute 2 | 3 | Let me make it clear: this project has no real community; I beleive in it's long term future, but that's just my opinion. 4 | 5 | So every contribution is welcome. 6 | 7 | If you contribute, you may show off your coding skills and I will praise you. 8 | 9 | If you want to take things into your own hands, I will step back and let you make it yours. 10 | If I don't agree, I will make a pull request or fork. 11 | 12 | If you want a small issue fixed, and you make a crappy pull request, I will be grateful and try to bring in the changes, 13 | and I will praise you a little less. 14 | 15 | # Strong Suggestions 16 | 17 | * Use the english language for identifiers and documentation 18 | * Use spaces and not tabs 19 | * Either reformat all modules with your favorite formatter, or adapt to the existing formatting 20 | * Make many small commits 21 | * Tag each release with the version number 22 | 23 | # General Suggestions 24 | 25 | ## Favor immediate failure over program endurance 26 | 27 | B9 is a **batch processing** tool, it will be run **once** to produce a single artifact. 28 | Let it crash, or let it fail during type checking rather than making the code defensively handle unexpected result. 29 | 30 | ## Favor easy to understand and to extend code over "correct" abstractions 31 | 32 | This project is part of the **waste** accumulated in software development. There is often little appreciation for code quality 33 | investments, also there is always the threat of immenant project death if other tools take of, therefore make your code friendly 34 | to the uninclined contributor. 35 | 36 | ## Favor mathematical and logical rigor over intuitive, spontanous models 37 | 38 | Prefer using functors, monads, profunctors and free algebras over concrete concepts found in the problem domain. 39 | 40 | ## Favor standard library type constructors like `Maybe` or `(a->)` over custom types 41 | 42 | ## Derive `Typeable`, `Eq`, `Hashable`, `Binary`, `NFData`, `Show` for user facing data types 43 | 44 | ## Favor easy and fast to understand names over short and fast to write names 45 | 46 | ## Good beats Perfect: Favor a mediocre contribution over _no contribution_, that would have been brilliant and elegant. 47 | 48 | If you don't have time to follow all the rules, contribute anyway. 49 | 50 | If it motivates you to make brilliant but hard to learn abstractions, then, please go ahead and do it. 51 | 52 | ## When in doubt, favor semantic versioning over small, continously increasing version values 53 | 54 | -------------------------------------------------------------------------------- /CONTRIBUTORS: -------------------------------------------------------------------------------- 1 | sheyll 2 | lti2000 3 | rusio 4 | sainth 5 | typetetris 6 | 7 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 Sven Heyll 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /TODO.md: -------------------------------------------------------------------------------- 1 | Add support for nspawn: 2 | 3 | 4 | sudo mkdir -p 882cd8da-249e-5b20-9bdc-fa0b65ee7ac6/data 5 | sudo mount -o loop data.raw 882cd8da-249e-5b20-9bdc-fa0b65ee7ac6/data 6 | 7 | sudo systemd-nspawn \ 8 | -i prod-el7.centos-20.1.0_77C1BAADE2ECB79D.raw \ 9 | --bind 882cd8da-249e-5b20-9bdc-fa0b65ee7ac6/data:/data \ 10 | --bind 882cd8da-249e-5b20-9bdc-fa0b65ee7ac6/init-script:/FB95BFBD59259EED-F0BCC04CCCD5489 \ 11 | --bind artifact-instances/talkflowd-FB95BFBD59259EED-F0BCC04CCCD5489:/b9mnt/GENERATED_SOURCES \ 12 | -E 'PATH=/bin:/sbin:/usr/bin' \ 13 | /FB95BFBD59259EED-F0BCC04CCCD5489/init.sh 14 | 15 | -------------------------------------------------------------------------------- /b9.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: b9 3 | version: 4.0.0 4 | 5 | synopsis: A tool and library for building virtual machine images. 6 | 7 | description: Build virtual machine images for vm-deployments; resize, 8 | un-partition, create from scratch or convert disk image 9 | files in a variety of formats; assemble and generate all 10 | associated files from templates and regular files. 11 | 12 | 13 | VM images can further be modifed through scripts, which are 14 | executed in LXC containers into which the vm-images as well 15 | as arbitrary directories from the host are mounted. 16 | 17 | 18 | All assembled files can also be accessed by vm build 19 | scripts through a special directory mounted in the build 20 | container, and/or can be written to directories, ISO- or 21 | VFAT-images. 22 | 23 | 24 | The ISO/VFAT images that B9 creates are compatible to 25 | 'cloud-init's 'NoCloud' data source; 26 | 27 | 28 | B9 is also very well suited for compiling in a 29 | containerized environment. For these applications, the 30 | images can be marked as 'Transient' to indicate no further 31 | interest in the VM-image itself, and B9 will discard them 32 | after the build. 33 | 34 | 35 | B9 will never over-write source files, not even large 36 | vm-image files - there is no intended way to modify a 37 | source vm-image file 'in-place'. 38 | 39 | 40 | B9 operates in random build directories, which are 41 | discarded when the build exists. 42 | 43 | license: MIT 44 | license-file: LICENSE 45 | author: Sven Heyll 46 | maintainer: svh@posteo.de 47 | homepage: https://github.com/sheyll/b9-vm-image-builder 48 | bug-reports: https://github.com/sheyll/b9-vm-image-builder/issues 49 | copyright: 2015, 2016, 2017, 2018, 2019, 2020 Sven Heyll 50 | category: Development 51 | build-type: Simple 52 | extra-source-files: README.md 53 | , .gitignore 54 | , CONTRIBUTORS 55 | , CONTRIBUTING.md 56 | , CODE_OF_CONDUCT.md 57 | , CHANGELOG.md 58 | 59 | common b9Deps 60 | build-depends: QuickCheck >= 2.5 && < 3 61 | , aeson == 1.4.* 62 | , base >= 4.12 && < 5 63 | , binary == 0.8.* 64 | , bytestring >= 0.10.8 && < 1 65 | , containers >= 0.6 && < 1 66 | , directory >= 1.3 && < 2 67 | , extensible-effects == 5.* 68 | , filepath == 1.4.* 69 | , hspec == 2.7.* 70 | , hspec-expectations == 0.8.* 71 | , lens == 4.* 72 | , neat-interpolation >= 0.3 && < 1 73 | , optparse-applicative >= 0.13 && < 1 74 | , process >= 1.4 && < 2 75 | , shake >= 0.17.6 && < 0.20 76 | , text == 1.2.* 77 | , unordered-containers >= 0.2 && < 1 78 | , vector >= 0.11 && < 1 79 | , yaml >= 0.8 && < 1 80 | 81 | common b9Extensions 82 | other-extensions: OverloadedStrings 83 | default-extensions: ConstraintKinds 84 | , CPP 85 | , DataKinds 86 | , DeriveDataTypeable 87 | , DeriveFunctor 88 | , DeriveGeneric 89 | , ExplicitNamespaces 90 | , FlexibleContexts 91 | , GADTs 92 | , GeneralizedNewtypeDeriving 93 | , KindSignatures 94 | , MonoLocalBinds 95 | , MultiParamTypeClasses 96 | , RankNTypes 97 | , ScopedTypeVariables 98 | , StandaloneDeriving 99 | , TemplateHaskell 100 | , TupleSections 101 | , TypeFamilies 102 | , TypeOperators 103 | default-language: Haskell2010 104 | ghc-options: -Wall 105 | -fwarn-unused-binds -fno-warn-unused-do-bind 106 | 107 | source-repository head 108 | type: git 109 | location: git://github.com/sheyll/b9-vm-image-builder.git 110 | 111 | library 112 | import: b9Extensions, b9Deps 113 | hs-source-dirs: src/lib 114 | exposed-modules: B9 115 | , B9.Artifact 116 | , B9.Artifact.Content 117 | , B9.Artifact.Content.AST 118 | , B9.Artifact.Content.CloudConfigYaml 119 | , B9.Artifact.Content.ErlTerms 120 | , B9.Artifact.Content.ErlangPropList 121 | , B9.Artifact.Content.Readable 122 | , B9.Artifact.Content.StringTemplate 123 | , B9.Artifact.Content.YamlObject 124 | , B9.Artifact.Readable 125 | , B9.Artifact.Readable.Interpreter 126 | , B9.Artifact.Readable.Source 127 | , B9.B9Config 128 | , B9.B9Config.Container 129 | , B9.B9Config.Docker 130 | , B9.B9Config.LibVirtLXC 131 | , B9.B9Config.Podman 132 | , B9.B9Config.Repository 133 | , B9.B9Config.SystemdNspawn 134 | , B9.B9Error 135 | , B9.B9Exec 136 | , B9.B9Logging 137 | , B9.B9Monad 138 | , B9.BuildInfo 139 | , B9.Container 140 | , B9.DiskImageBuilder 141 | , B9.DiskImages 142 | , B9.Docker 143 | , B9.Environment 144 | , B9.ExecEnv 145 | , B9.LibVirtLXC 146 | , B9.MBR 147 | , B9.PartitionTable 148 | , B9.Podman 149 | , B9.QCUtil 150 | , B9.Repository 151 | , B9.RepositoryIO 152 | , B9.Shake 153 | , B9.Shake.Actions 154 | , B9.Shake.SharedImageRules 155 | , B9.ShellScript 156 | , B9.SystemdNspawn 157 | , B9.Text 158 | , B9.Vm 159 | , B9.VmBuilder 160 | , Data.ConfigFile.B9Extras 161 | , System.IO.B9Extras 162 | other-modules: Paths_b9 163 | autogen-modules: Paths_b9 164 | build-depends: ConfigFile >= 1.1.4 && < 1.2 165 | 166 | , async == 2.* 167 | , base64-bytestring == 1.* 168 | , bifunctors == 5.* 169 | , boxes == 0.1.* 170 | , conduit == 1.* 171 | , conduit-extra == 1.* 172 | , exceptions == 0.10.* 173 | , free >= 4.12 && < 6 174 | , hashable >= 1.2 && < 2 175 | , monad-control == 1.* 176 | , mtl == 2.* 177 | , parallel >= 3.2 && < 4 178 | , parsec >= 3.1 && < 4 179 | , posix-pty >= 0.2 && < 1 180 | , pretty >= 1.1 && < 2 181 | , pretty-show >= 1.6 && < 2 182 | , random >= 1.1 && < 2 183 | , syb >= 0.6 && < 1 184 | , tagged >= 0.8 && < 0.9 185 | , template >= 0.2 && < 1 186 | , temporary >= 1.3 && < 1.4 187 | , time >= 1.6 && < 2 188 | , transformers >= 0.5 && < 1 189 | , unix >= 2.7 && < 3 190 | executable b9c 191 | import: b9Extensions, b9Deps 192 | main-is: Main.hs 193 | other-modules: Paths_b9 194 | autogen-modules: Paths_b9 195 | build-depends: b9, with-utf8 196 | hs-source-dirs: src/cli 197 | ghc-options: -Wall 198 | -fwarn-unused-binds -fno-warn-unused-do-bind -threaded 199 | 200 | test-suite spec 201 | import: b9Extensions, b9Deps 202 | type: exitcode-stdio-1.0 203 | ghc-options: -Wall -threaded 204 | hs-source-dirs: src/tests 205 | main-is: Spec.hs 206 | autogen-modules: Paths_b9 207 | other-modules: B9.ArtifactGeneratorImplSpec 208 | , B9.B9ConfigSpec 209 | , B9.B9ExecSpec 210 | , B9.Content.ErlTermsSpec 211 | , B9.Content.ErlangPropListSpec 212 | , B9.Content.YamlObjectSpec 213 | , B9.DiskImagesSpec 214 | , B9.DiskImageBuilderSpec 215 | , B9.EnvironmentSpec 216 | , B9.RepositoryIOSpec 217 | , B9.RepositorySpec 218 | , B9.Shake.SharedImageRulesSpec 219 | , Paths_b9 220 | build-depends: b9 221 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | (import 2 | ( 3 | let 4 | lock = builtins.fromJSON (builtins.readFile ./flake.lock); 5 | in 6 | fetchTarball { 7 | url = "https://github.com/edolstra/flake-compat/archive/${lock.nodes.flake-compat.locked.rev}.tar.gz"; 8 | sha256 = lock.nodes.flake-compat.locked.narHash; 9 | } 10 | ) 11 | { 12 | src = ./.; 13 | }).defaultNix 14 | -------------------------------------------------------------------------------- /examples/default.nix: -------------------------------------------------------------------------------- 1 | let 2 | b9c = (import ../default.nix {}).b9c; 3 | pkgs = import ../nix/pkgs.nix {}; 4 | exampleRunner = ./runExamples.sh; 5 | in 6 | pkgs.writeScriptBin "exampleRunner" '' 7 | #!/usr/bin/env bash 8 | set -ex 9 | 10 | ${exampleRunner} ${b9c}/bin/b9c 11 | '' 12 | -------------------------------------------------------------------------------- /examples/libvirt-lxc.b9.conf: -------------------------------------------------------------------------------- 1 | [global] 2 | build_dir_root: Nothing 3 | keep_temp_dirs: False 4 | log_file: Nothing 5 | max_cached_shared_images: Just 2 6 | repository: Nothing 7 | repository_cache: Just (InB9UserDir "repo-cache") 8 | unique_build_dirs: True 9 | verbosity: Just LogInfo 10 | 11 | [libvirt-lxc] 12 | connection: lxc:/// 13 | emulator_path: Nothing 14 | 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] 15 | guest_ram_size: RamSize 1 GB 16 | network: Nothing 17 | use_sudo: True 18 | 19 | [podman] 20 | 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] 21 | network: Nothing 22 | 23 | [systemdNspawn] 24 | 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] 25 | use_sudo: True 26 | -------------------------------------------------------------------------------- /examples/max.b9: -------------------------------------------------------------------------------- 1 | Artifact (IID "test-max") 2 | (VmImages 3 | [ImageTarget 4 | (LocalFile (Image "max-out.vmdk" Vmdk Ext4) KeepSize) 5 | (SourceImage (Image "max-in.qcow2" QCow2 Ext4) NoPT KeepSize) 6 | (MountPoint "/") 7 | , ImageTarget 8 | (LocalFile (Image "max-data-out.vmdk" Vmdk Ext4) KeepSize) 9 | (EmptyImage "data" Ext4 Raw (ImageSize 64 GB)) 10 | (MountPoint "/data") 11 | ] 12 | (VmScript 13 | X86_64 14 | [SharedDirectoryRO "test-share-max" (MountPoint "/mnt/test-share-max")] 15 | (Verbosity Debug [ 16 | Run "source /etc/profile" [] 17 | , Run "export PATH=$$PATH:/bin:/usr/bin:/sbin:/usr/sbin:/usr/local/bin" [] 18 | , Run "cp" ["/mnt/test-share-max/hosts", "/etc/hosts"] 19 | , Run "yum -y clean all" [] 20 | , IgnoreErrors True [Run "yum -y makecache" []] 21 | , Run "yum -y update" [] 22 | , Run "yum install -y docker" [] 23 | ] 24 | ))) 25 | 26 | -------------------------------------------------------------------------------- /examples/minimal-image-in.qcow2: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sheyll/b9-vm-image-builder/eb4b15f0ca264fd1e72190207cd63da1b41c4b9c/examples/minimal-image-in.qcow2 -------------------------------------------------------------------------------- /examples/minimal-interactive.b9: -------------------------------------------------------------------------------- 1 | Artifact (IID "test-libvirt") 2 | (VmImages 3 | [ImageTarget 4 | (LocalFile (Image "minimal-image-out.vmdk" Vmdk Ext4) KeepSize) 5 | (SourceImage (Image "minimal-image-in.qcow2" QCow2 Ext4) NoPT KeepSize) 6 | (MountPoint "/") 7 | ] 8 | (VmScript 9 | X86_64 10 | [SharedDirectoryRO "test-share-ro" (MountPoint "/mnt/test-share-ro")] 11 | (Verbosity Debug [ 12 | Run "echo \"Running interactive shell\"" [] 13 | , Run "/bin/sh" [] 14 | ]))) 15 | 16 | -------------------------------------------------------------------------------- /examples/minimal-sleep-5.b9: -------------------------------------------------------------------------------- 1 | Artifact (IID "test-libvirt") 2 | (VmImages 3 | [ImageTarget 4 | (LocalFile (Image "minimal-image-out.vmdk" Vmdk Ext4) KeepSize) 5 | (SourceImage (Image "minimal-image-in.qcow2" QCow2 Ext4) NoPT KeepSize) 6 | (MountPoint "/") 7 | ] 8 | (VmScript 9 | X86_64 10 | [SharedDirectoryRO "test-share-ro" (MountPoint "/mnt/test-share-ro")] 11 | (Verbosity Debug [ 12 | Run "/bin/cp" ["/mnt/test-share-ro/test", "/test-2-passed"] 13 | , Run "/bin/sleep 5" [] 14 | , Run "/bin/touch" ["/test-1-passed"]]))) 15 | 16 | -------------------------------------------------------------------------------- /examples/minimal.b9: -------------------------------------------------------------------------------- 1 | Artifact (IID "test-libvirt") 2 | (VmImagesWithFixup 3 | [ImageTarget 4 | (LocalFile (Image "minimal-image-out.vmdk" Vmdk Ext4) KeepSize) 5 | (SourceImage (Image "minimal-image-in.qcow2" QCow2 Ext4) NoPT KeepSize) 6 | (MountPoint "/") 7 | ] 8 | (VmScript 9 | X86_64 10 | [SharedDirectoryRO "test-share-ro" (MountPoint "/mnt/test-share-ro")] 11 | (Verbosity Debug [ 12 | Run "/bin/cp" ["/mnt/test-share-ro/test", "/test-2-passed"] 13 | , Run "/bin/touch" ["/test-1-passed"]])) 14 | (Verbosity Debug [ 15 | Run "echo" ["${1}"] 16 | ])) 17 | -------------------------------------------------------------------------------- /examples/runExamples.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -e 4 | 5 | b9c="${1? b9c path parameter missing}" 6 | 7 | declare SUCCESS 8 | 9 | echo 10 | echo "= Systemd-Nspawn TESTS =" 11 | echo 12 | 13 | echo "=== Systemd-Nspawn (minimalistic happy case) ===" 14 | $b9c -v -c systemd-nspawn.b9.conf build -f minimal.b9 15 | 16 | echo "=== Systemd-Nspawn Bad Extra Args ===" 17 | ( $b9c -v -c systemd-nspawn-bad-extra-args.b9.conf build -f minimal.b9 || echo "Error expected" ) | grep -q "systemd-nspawn: unrecognized option '--some'" 18 | 19 | echo "=== Systemd-Nspawn Console Interactive ===" 20 | $b9c -v -c systemd-nspawn-console-interactive.b9.conf build -f minimal-interactive.b9 | grep -q "TEST PaSsEd!!" < "$OUT_IMAGE_ID" 96 | 97 | mkdir -p "$OUT_LAYER_UNPACK_DIR" 98 | 99 | docker image save "$(cat "$OUT_IMAGE_ID")" | tar -C "$OUT_LAYER_UNPACK_DIR" -xf - 100 | 101 | OUT_LAYER_TAR="${OUT_LAYER_UNPACK_DIR}/$(jq '.[0].Layers[-1]' < "$OUT_LAYER_UNPACK_DIR/manifest.json" | tr -d '"')" 102 | 103 | tar -C "$STEP1MNT" -xf "$OUT_LAYER_TAR" 104 | qemu-img convert -q -f raw -O qcow2 "$STEP1" 0.qcow2 105 | 106 | 107 | 108 | -------------------------------------------------------------------------------- /extract_layers/vm_scripts/install.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -xe 4 | 5 | echo "Jo!" > /test.txt 6 | echo "Hello World!" > /data/test.txt 7 | 8 | 9 | -------------------------------------------------------------------------------- /extract_layers_podman/create-vm.sh: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env nix-shell 2 | #! nix-shell -i bash --pure 3 | #! nix-shell -p podman bash qemu gnutar e2fsprogs coreutils utillinux conmon runc 4 | 5 | set -ex 6 | 7 | BASE_IMG=${1?BASE_IMG parameter missing} 8 | 9 | BUILD_DIR_REL=$(mktemp -d /mnt/b9-podman-XXXXXXXXXXX) 10 | mkdir -p "$BUILD_DIR_REL" 11 | BUILD_DIR=$(realpath "$BUILD_DIR_REL") 12 | 13 | STEP1=$BUILD_DIR/step1.raw 14 | STEP1MNT=$BUILD_DIR/step1-mnt 15 | STEP1TAR=$BUILD_DIR/step1.tar 16 | CID=$BUILD_DIR/cid.txt 17 | DATA=$BUILD_DIR/data.raw 18 | DATAMNT=$BUILD_DIR/data 19 | OUT_IMAGE_ID=$BUILD_DIR/out_img_id.txt 20 | OUT_LAYER_UNPACK_DIR=$BUILD_DIR/out_layers 21 | STEP1_IMPORTED_IMAGE_ID= 22 | 23 | 24 | function cleanup() { 25 | set +ex 26 | trap - ERR 27 | umount "$STEP1MNT" || echo "umount-loopback of / failed" 28 | umount "$DATAMNT" || echo "umount-loopback of /data failed" 29 | 30 | if [[ -e "$CID" ]] 31 | then 32 | podman container rm "$(cat "$CID")" 33 | fi 34 | if [[ -e "$OUT_IMAGE_ID" ]] 35 | then 36 | podman image rm "$(cat "$OUT_IMAGE_ID")" 37 | fi 38 | rm -rf "$BUILD_DIR" 39 | } 40 | 41 | function cleanup_happy() { 42 | cleanup 43 | exit 0 44 | } 45 | 46 | function cleanup_unhappy() { 47 | cleanup 48 | exit 1 49 | } 50 | 51 | trap cleanup_happy EXIT 52 | trap cleanup_unhappy ERR 53 | 54 | qemu-img convert -q -f qcow2 -O raw "$BASE_IMG" "$STEP1" 55 | 56 | mkdir -p "$BUILD_DIR/step1-mnt" 57 | 58 | mount -o loop "$STEP1" "$STEP1MNT" 59 | mkdir -p "$STEP1MNT/mnt/vm_scripts" 60 | tar -cf "$STEP1TAR" -C "$STEP1MNT" . 61 | 62 | set +x 63 | STEP1_IMPORTED_IMAGE_ID=$(podman import "$STEP1TAR" | cut -d: -f2 | tr -c -d '0123456789abcdef') 64 | echo "Imported base image with podman as: $STEP1_IMPORTED_IMAGE_ID" 65 | if [[ -n "$STEP1_IMPORTED_IMAGE_ID" ]] 66 | then 67 | echo "podman import failed." 68 | umount "$STEP1MNT" 69 | exit 1 70 | fi 71 | set -x 72 | 73 | fallocate -l4000000000 "$DATA" 74 | mkfs.ext4 -Ldata "$DATA" 75 | 76 | mkdir -p "$DATAMNT" 77 | mount -o loop "$DATA" "$DATAMNT" 78 | 79 | podman run \ 80 | -v "$(realpath vm_scripts)":/mnt/vm_scripts \ 81 | -v "$DATAMNT":/data \ 82 | --network=host \ 83 | --tty=true \ 84 | --cidfile="$CID" \ 85 | --privileged=true \ 86 | --workdir=/mnt/vm_scripts \ 87 | "$STEP1_IMPORTED_IMAGE_ID" \ 88 | ./install.sh 89 | 90 | qemu-img convert -q -f raw -O qcow2 "$DATA" data.qcow2 91 | 92 | podman container commit "$(cat "$CID")" \ 93 | | cut -d: -f2 \ 94 | | tr -c -d '0123456789abcdef' \ 95 | > "$OUT_IMAGE_ID" 96 | 97 | mkdir -p "$OUT_LAYER_UNPACK_DIR" 98 | 99 | podman image save "$(cat "$OUT_IMAGE_ID")" | tar -C "$OUT_LAYER_UNPACK_DIR" -xf - 100 | 101 | OUT_LAYER_TAR="${OUT_LAYER_UNPACK_DIR}/$(jq '.[0].Layers[-1]' < "$OUT_LAYER_UNPACK_DIR/manifest.json" | tr -d '"')" 102 | 103 | tar -C "$STEP1MNT" -xf "$OUT_LAYER_TAR" 104 | qemu-img convert -q -f raw -O qcow2 "$STEP1" 0.qcow2 105 | 106 | 107 | 108 | -------------------------------------------------------------------------------- /extract_layers_podman/vm_scripts/install.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -xe 4 | 5 | echo "Jo!" > /test.txt 6 | echo "Hello World!" > /data/test.txt 7 | 8 | 9 | -------------------------------------------------------------------------------- /extract_layers_systemd_nspawn/create-vm.sh: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env nix-shell 2 | #! nix-shell -i bash --pure 3 | #! nix-shell -p systemd bash qemu gnutar e2fsprogs coreutils utillinux conmon runc 4 | 5 | set -ex 6 | 7 | BASE_IMG=${1?BASE_IMG parameter missing} 8 | 9 | BUILD_DIR_REL=$(mktemp -d /mnt/b9-nspawn-XXXXXXXXXXX) 10 | mkdir -p "$BUILD_DIR_REL" 11 | BUILD_DIR=$(realpath "$BUILD_DIR_REL") 12 | 13 | STEP1=$BUILD_DIR/step1.raw 14 | DATA=$BUILD_DIR/data.raw 15 | DATAMNT=$BUILD_DIR/data 16 | 17 | function cleanup() { 18 | set +ex 19 | trap - ERR 20 | umount "$DATAMNT" || echo "umount-loopback of /data failed" 21 | rm -rf "$BUILD_DIR" 22 | } 23 | 24 | function cleanup_happy() { 25 | cleanup 26 | exit 0 27 | } 28 | 29 | function cleanup_unhappy() { 30 | cleanup 31 | exit 1 32 | } 33 | 34 | trap cleanup_happy EXIT 35 | trap cleanup_unhappy ERR 36 | 37 | qemu-img convert -q -f qcow2 -O raw "$BASE_IMG" "$STEP1" 38 | 39 | fallocate -l4000000000 "$DATA" 40 | mkfs.ext4 -Ldata "$DATA" 41 | 42 | mkdir -p "$DATAMNT" 43 | mount -o loop "$DATA" "$DATAMNT" 44 | 45 | systemd-nspawn -i "$STEP1" \ 46 | --bind=$(pwd)/vm_scripts:/mnt/vm_scripts \ 47 | --bind=$DATAMNT:/data \ 48 | --chdir=/mnt/vm_scripts \ 49 | --console=pipe \ 50 | '/bin/bash' -i -c \ 51 | 'set -e 52 | export PATH=/usr/local/bin:/bin:/sbin:/usr/bin 53 | source /etc/profile 54 | source /etc/bashrc 55 | echo $PATH; 56 | ./install.sh' 57 | 58 | umount "$DATAMNT" 59 | 60 | qemu-img convert -q -f raw -O qcow2 "$DATA" data.qcow2 61 | qemu-img convert -q -f raw -O qcow2 "$STEP1" 0.qcow2 62 | 63 | 64 | -------------------------------------------------------------------------------- /extract_layers_systemd_nspawn/vm_scripts/install.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -xe 4 | 5 | echo "Jo!" > /test.txt 6 | echo "Hello World!" > /data/test.txt 7 | 8 | 9 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | description = "b9-vm-image-builder"; 3 | inputs.haskellNix.url = "github:input-output-hk/haskell.nix"; 4 | inputs.nixpkgs.follows = "haskellNix/nixpkgs-unstable"; 5 | inputs.flake-utils.url = "github:numtide/flake-utils"; 6 | inputs.flake-compat.url = "github:edolstra/flake-compat"; 7 | inputs.flake-compat.flake = false; 8 | outputs = { self, nixpkgs, flake-utils, haskellNix, ... }: 9 | flake-utils.lib.eachSystem [ "x86_64-linux" ] (system: 10 | let 11 | overlays = [ haskellNix.overlay (import ./overlay.nix) ]; 12 | pkgs = import nixpkgs { inherit system overlays; }; 13 | b9flake = pkgs.b9-haskell-project.flake { }; 14 | in 15 | b9flake // { 16 | lib = { 17 | inherit (pkgs) b9cOsRuntimeDeps b9cRuntimeDeps; 18 | }; 19 | inherit overlays; 20 | packages = b9flake.packages // rec { 21 | inherit (pkgs) b9c b9c-unwrapped; 22 | materializationUpdater = pkgs.runCommand "materializationUpdater" 23 | { 24 | nativeBuildInputs = [ pkgs.makeWrapper ]; 25 | } 26 | '' 27 | mkdir -p $out/bin 28 | cp ${"${pkgs.b9-haskell-project.plan-nix.passthru.generateMaterialized}"} $out/bin/materializationUpdater 29 | wrapProgram $out/bin/materializationUpdater --add-flags nix/materialization/b9 30 | ''; 31 | }; 32 | defaultPackage = self.packages."${system}".b9c; 33 | }); 34 | } 35 | -------------------------------------------------------------------------------- /hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: 2 | cabal: 3 | - path: "./" 4 | component: "lib:b9" 5 | -------------------------------------------------------------------------------- /overlay.nix: -------------------------------------------------------------------------------- 1 | final: prev: 2 | let 3 | b9cOsRuntimeDeps = with final; 4 | [ 5 | libvirt 6 | systemd 7 | rsync 8 | docker 9 | podman 10 | ]; 11 | b9cRuntimeDeps = with final; 12 | [ 13 | cdrkit 14 | openssh 15 | qemu 16 | e2fsprogs 17 | xorriso 18 | bash 19 | curl 20 | coreutils 21 | dosfstools 22 | mtools 23 | ]; 24 | b9-flake = final.b9-haskell-project.flake { }; 25 | b9c-unwrapped = b9-flake.packages."b9:exe:b9c"; 26 | b9-haskell-project = 27 | final.haskell-nix.cabalProject' { 28 | name = "b9-haskell-project"; 29 | src = ./.; 30 | compiler-nix-name = "ghc8107"; 31 | # This is used by `nix develop .` to open a shell for use with 32 | # `cabal`, `hlint` and `haskell-language-server` 33 | shell = { 34 | tools = { 35 | cabal = { }; 36 | hlint = { }; 37 | haskell-language-server = { }; 38 | }; 39 | exactDeps = true; 40 | NIX_SHELL_TAG = "b9"; 41 | shellHook = '' 42 | export LC_ALL=en_US.UTF-8 43 | export LANG=en_US.UTF-8 44 | export LANGUAGE=en_US.UTF-8 45 | echo 46 | echo "___________________________________________________" 47 | echo " " 48 | echo " B9 Development Environment " 49 | echo "___________________________________________________" 50 | echo " " 51 | echo " * use 'cabal' to build this software " 52 | echo " " 53 | echo "===================================================" 54 | echo 55 | ''; 56 | }; 57 | modules = [ 58 | { 59 | packages.b9.components.tests.spec.build-tools = [ 60 | b9-haskell-project.hsPkgs.hspec-discover 61 | ]; 62 | } 63 | ]; 64 | index-state = "2021-09-03T00:00:00Z"; 65 | checkMaterialization = false; 66 | materialized = ./nix/materialization/b9; 67 | }; 68 | 69 | in { 70 | inherit b9-haskell-project b9c-unwrapped b9cOsRuntimeDeps b9cRuntimeDeps; 71 | b9c = 72 | prev.stdenvNoCC.mkDerivation { 73 | name = "b9c"; 74 | buildInputs = [ prev.makeWrapper ]; 75 | depsHostHost = b9cRuntimeDeps ++ b9cOsRuntimeDeps; 76 | phases = [ "buildPhase" "installPhase" ]; 77 | buildPhase = '' 78 | mkdir -p $out/bin 79 | cp ${b9c-unwrapped}/bin/b9c $out/bin 80 | ''; 81 | installPhase = '' 82 | wrapProgram \ 83 | $out/bin/b9c \ 84 | --prefix PATH : "${prev.lib.makeBinPath b9cRuntimeDeps}:" \ 85 | --suffix PATH : "${prev.lib.makeBinPath b9cOsRuntimeDeps}:" \ 86 | --suffix PATH : "${prev.libvirt}/libexec" \ 87 | --set-default B9_LIBVIRT_LXC "${prev.libvirt}/libexec/libvirt_lxc" 88 | ''; 89 | meta = { 90 | homepage = final.b9c-unwrapped.meta.homepage; 91 | description = final.b9c-unwrapped.meta.description + " CLI-only version"; 92 | license = final.b9c-unwrapped.meta.license; 93 | platforms = final.b9c-unwrapped.meta.platforms; 94 | }; 95 | }; 96 | } 97 | -------------------------------------------------------------------------------- /reformat-code.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env nix-shell 2 | #!nix-shell --pure 3 | #!nix-shell -p haskellPackages.ormolu 4 | #!nix-shell -i bash 5 | 6 | 7 | find ./src -name '*.hs' -exec ormolu -o '-XBangPatterns' -m inplace '{}' \; 8 | 9 | 10 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | (import 2 | ( 3 | let 4 | lock = builtins.fromJSON (builtins.readFile ./flake.lock); 5 | in 6 | fetchTarball { 7 | url = "https://github.com/edolstra/flake-compat/archive/${lock.nodes.flake-compat.locked.rev}.tar.gz"; 8 | sha256 = lock.nodes.flake-compat.locked.narHash; 9 | } 10 | ) 11 | { 12 | src = ./.; 13 | }).shellNix 14 | -------------------------------------------------------------------------------- /src/lib/B9/Artifact.hs: -------------------------------------------------------------------------------- 1 | -- | Programmatic Interface to b9 artifact generation. 2 | -- 3 | -- An extensible approach to vm deployment configuration management. 4 | -- 5 | -- TODO: do it. 6 | -- 7 | -- @since 1.0.0 8 | module B9.Artifact 9 | ( 10 | ) 11 | where 12 | 13 | ---- | Build Environment 14 | --disks = let 15 | -- rootImg = loadSharedImage "prod-19.2" (Resize (GB 8)) 16 | -- 17 | -- dataImgWithContent = 18 | -- let foo = "http://test.localdomain/data-foo.zip" 19 | -- bar = "http://test.localdomain/data-bar.zip" 20 | -- emptyImg = emptyExt4FileSystem "data" (GB 4) 21 | -- in onFileSystem emptyImg $ 22 | -- directory "foo" $ do 23 | -- unZipped (remoteBinary foo) 24 | -- fileAttributes (\_f -> UnixFilePermissions 0 7 5 5 "root" "root") 25 | -- 26 | -------------------------------------------------------------------------------- /src/lib/B9/Artifact/Content.hs: -------------------------------------------------------------------------------- 1 | -- | Content is what is written to files in the generated VM images and cloud configuration. 2 | -- 3 | -- Contains the monadic actions that generate the content that 4 | -- is written to the generated artifacts. 5 | -- 6 | -- @since 0.5.62 7 | module B9.Artifact.Content 8 | ( ContentGenerator, 9 | ToContentGenerator (..), 10 | Text, 11 | ) 12 | where 13 | 14 | import B9.B9Monad 15 | import Control.Eff 16 | import Data.Text (Text) 17 | import GHC.Stack 18 | 19 | -- | A 'B9' action that procuces a 'Text'. 20 | -- 21 | -- @since 0.5.62 22 | type ContentGenerator = B9 Text 23 | 24 | -- | Types whose values can be turned into an 'Eff'ect that produces 25 | -- 'Text', e.g. 'ContentGenerator' 26 | -- 27 | -- @since 0.5.62 28 | class ToContentGenerator c where 29 | toContentGenerator :: (HasCallStack, IsB9 e) => c -> Eff e Text 30 | -------------------------------------------------------------------------------- /src/lib/B9/Artifact/Content/AST.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- 3 | -- B9 produces not only VM-Images but also text documents such as configuration 4 | -- files required by virtual machines. This module is about creating and merging 5 | -- files containing parsable syntactic structures, such as most configuration files 6 | -- do. 7 | -- 8 | -- B9 can be used to create configuration files by assembling structured documents, 9 | -- for example Yaml, JSON, Erlang Terms. 10 | -- 11 | -- One example is creating a single cloud-init 'user-data' file from a set of 12 | -- 'user-data' snippets - all of which using yaml syntax to declare the same 13 | -- object (e.g @"user-data"@). 14 | -- 15 | -- The goal is, that b9 is able to merge these snippets into one, intelligently 16 | -- merging fields as one would expect, e.g. when merging multiple snippets with 17 | -- @writefiles@ fields, the output object's @writefiles@ field contains all the 18 | -- @write_file@ objects. 19 | -- 20 | -- Another example is the OTP/Erlang sys.config for configuring OTP/Erlang releases. 21 | module B9.Artifact.Content.AST 22 | ( FromAST (..), 23 | AST (..), 24 | parseFromTextWithErrorMessage, 25 | ) 26 | where 27 | 28 | import B9.Artifact.Content 29 | import B9.Artifact.Content.StringTemplate 30 | import B9.B9Monad 31 | import B9.QCUtil 32 | import B9.Text 33 | import Control.Eff 34 | import Control.Parallel.Strategies 35 | import Data.Binary (Binary) 36 | import Data.Data 37 | import Data.Hashable 38 | import GHC.Generics (Generic) 39 | import Test.QuickCheck 40 | 41 | -- | Describe how to create structured content that has a tree-like syntactic 42 | -- structure, e.g. yaml, JSON and erlang-proplists. The first parameter defines 43 | -- a /context/ into which the 'AST' is embedded, 44 | -- e.g. B9.Artifact.Content'. The second parameter defines a specifix 45 | -- syntax, e.g 'B9.Artifact.Content.ErlangPropList' that the 'AST' value generates. 46 | data AST c a 47 | = -- | Create an object similar to a 48 | -- Json object. 49 | ASTObj [(String, AST c a)] 50 | | -- | An array. 51 | ASTArr [AST c a] 52 | | -- | Merge the nested elements, this is a very 53 | -- powerful tool that allows to combine 54 | ASTMerge [AST c a] 55 | | -- several inputs in a smart and safe way, 56 | -- e.g. by merging the values of the same 57 | -- fields in yaml objects. 58 | ASTEmbed c -- Embed more impure content. 59 | | ASTString String -- A string literal. 60 | | ASTInt Int -- An Int literal. 61 | | ASTParse SourceFile -- An 'AST' obtained from parsing a source 62 | -- file that contains a string corresponding 63 | -- to the type parameter @a@, e.g. 'YamlObject's 64 | | AST a -- Embed a literal @a@. 65 | deriving (Read, Show, Typeable, Data, Eq, Generic) 66 | 67 | instance Functor (AST c) where 68 | fmap f (AST a) = AST (f a) 69 | fmap f (ASTObj x) = ASTObj ((fmap . fmap . fmap) f x) 70 | fmap f (ASTArr x) = ASTArr ((fmap . fmap) f x) 71 | fmap f (ASTMerge x) = ASTMerge ((fmap . fmap) f x) 72 | fmap _ (ASTEmbed x) = ASTEmbed x 73 | fmap _ (ASTString x) = ASTString x 74 | fmap _ (ASTInt x) = ASTInt x 75 | fmap _ (ASTParse x) = ASTParse x 76 | 77 | instance (Hashable c, Hashable a) => Hashable (AST c a) 78 | 79 | instance (Binary c, Binary a) => Binary (AST c a) 80 | 81 | instance (NFData c, NFData a) => NFData (AST c a) 82 | 83 | -- | Types of values that describe content, that can be created from an 'AST'. 84 | class FromAST a where 85 | fromAST :: 86 | (IsB9 e, ToContentGenerator c) => 87 | AST c a -> 88 | Eff e a 89 | 90 | instance (Arbitrary c, Arbitrary a) => Arbitrary (AST c a) where 91 | arbitrary = 92 | oneof 93 | [ ASTObj <$> smaller (listOf ((,) <$> arbitrary <*> arbitrary)), 94 | ASTArr <$> smaller (listOf arbitrary), 95 | ASTMerge <$> sized (\s -> resize (max 2 s) (listOf (halfSize arbitrary))), 96 | ASTEmbed <$> smaller arbitrary, 97 | ASTString <$> arbitrary, 98 | ASTParse <$> smaller arbitrary, 99 | AST <$> smaller arbitrary 100 | ] 101 | -------------------------------------------------------------------------------- /src/lib/B9/Artifact/Content/CloudConfigYaml.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- | This contains a 'YamlObject' for Canonicals @cloud-init@. 4 | -- 5 | -- For some reason, cloud-config yaml documents __MUST__ 6 | -- contain @#cloud-config@ in the first line. 7 | -- 8 | -- This is documented in the . 9 | -- 10 | -- Otherwise, this is just a wrapper around 'YamlObject'. 11 | -- 12 | -- @Since 0.5.62 13 | module B9.Artifact.Content.CloudConfigYaml 14 | ( CloudConfigYaml (..), 15 | cloudConfigFileHeader, 16 | ) 17 | where 18 | 19 | import B9.Artifact.Content.AST 20 | import B9.Artifact.Content.YamlObject 21 | import B9.Text 22 | import Control.Parallel.Strategies (NFData) 23 | import Data.Data 24 | ( Data, 25 | Typeable, 26 | ) 27 | import Data.Hashable (Hashable) 28 | import Data.Text as Text 29 | import GHC.Generics (Generic) 30 | import Test.QuickCheck (Arbitrary) 31 | 32 | -- | Cloud-init @meta-data@ configuration Yaml. 33 | -- 34 | -- @cloud-config@ yaml documents contain: 35 | -- @#cloud-config@ as first line. 36 | -- 37 | -- @Since 0.5.62 38 | newtype CloudConfigYaml 39 | = MkCloudConfigYaml 40 | { fromCloudConfigYaml :: YamlObject 41 | } 42 | deriving (Hashable, NFData, Eq, Data, Typeable, Generic, Arbitrary, Read, Show, Semigroup) 43 | 44 | -- | The header line, which must be the first line in the 45 | -- text file containing the cloud-config Yaml document. 46 | -- 47 | -- @Since 0.5.62 48 | cloudConfigFileHeader :: Text 49 | cloudConfigFileHeader = "#cloud-config\n" 50 | 51 | instance FromAST CloudConfigYaml where 52 | fromAST ast = MkCloudConfigYaml <$> fromAST (fromCloudConfigYaml <$> ast) 53 | 54 | instance Textual CloudConfigYaml where 55 | parseFromText txt = do 56 | -- skip the optional header line 57 | let header = Text.take (Text.length cloudConfigFileHeader) txt 58 | txt' = 59 | if header == cloudConfigFileHeader 60 | then Text.drop (Text.length cloudConfigFileHeader) txt 61 | else txt 62 | y <- parseFromText txt' 63 | return (MkCloudConfigYaml y) 64 | 65 | renderToText (MkCloudConfigYaml y) = do 66 | txt <- renderToText y 67 | return (Text.unlines [cloudConfigFileHeader, txt]) 68 | -------------------------------------------------------------------------------- /src/lib/B9/Artifact/Content/ErlangPropList.hs: -------------------------------------------------------------------------------- 1 | -- | Allow reading, merging and writing Erlang terms. 2 | module B9.Artifact.Content.ErlangPropList 3 | ( ErlangPropList (..), 4 | textToErlangAst, 5 | stringToErlangAst, 6 | ) 7 | where 8 | 9 | import B9.Artifact.Content 10 | import B9.Artifact.Content.AST 11 | import B9.Artifact.Content.ErlTerms 12 | import B9.Artifact.Content.StringTemplate 13 | import B9.Text 14 | import Control.Parallel.Strategies 15 | import Data.Data 16 | import Data.Function 17 | import Data.Hashable 18 | import Data.List (partition, sortBy) 19 | import qualified Data.Text as T 20 | import GHC.Generics (Generic) 21 | import Test.QuickCheck 22 | import Text.Printf 23 | 24 | -- | A wrapper type around erlang terms with a Semigroup instance useful for 25 | -- combining sys.config files with OTP-application configurations in a list of 26 | -- the form of a proplist. 27 | newtype ErlangPropList 28 | = ErlangPropList SimpleErlangTerm 29 | deriving (Read, Eq, Show, Data, Typeable, Generic) 30 | 31 | instance Hashable ErlangPropList 32 | 33 | instance NFData ErlangPropList 34 | 35 | instance Arbitrary ErlangPropList where 36 | arbitrary = ErlangPropList <$> arbitrary 37 | 38 | instance Semigroup ErlangPropList where 39 | (ErlangPropList v1) <> (ErlangPropList v2) = ErlangPropList (combine v1 v2) 40 | where 41 | combine (ErlList l1) (ErlList l2) = ErlList (l1Only <> merged <> l2Only) 42 | where 43 | l1Only = l1NonPairs <> l1NotL2 44 | l2Only = l2NonPairs <> l2NotL1 45 | (l1Pairs, l1NonPairs) = partition isPair l1 46 | (l2Pairs, l2NonPairs) = partition isPair l2 47 | merged = zipWith merge il1 il2 48 | where 49 | merge (ErlTuple [_k, pv1]) (ErlTuple [k, pv2]) = ErlTuple [k, pv1 `combine` pv2] 50 | merge _ _ = error "unreachable" 51 | (l1NotL2, il1, il2, l2NotL1) = partitionByKey l1Sorted l2Sorted ([], [], [], []) 52 | where 53 | partitionByKey [] ys (exs, cxs, cys, eys) = (reverse exs, reverse cxs, reverse cys, reverse eys <> ys) 54 | partitionByKey xs [] (exs, cxs, cys, eys) = (reverse exs <> xs, reverse cxs, reverse cys, reverse eys) 55 | partitionByKey (x : xs) (y : ys) (exs, cxs, cys, eys) 56 | | equalKey x y = partitionByKey xs ys (exs, x : cxs, y : cys, eys) 57 | | x `keyLessThan` y = partitionByKey xs (y : ys) (x : exs, cxs, cys, eys) 58 | | otherwise = partitionByKey (x : xs) ys (exs, cxs, cys, y : eys) 59 | l1Sorted = sortByKey l1Pairs 60 | l2Sorted = sortByKey l2Pairs 61 | sortByKey = sortBy (compare `on` getKey) 62 | keyLessThan = (<) `on` getKey 63 | equalKey = (==) `on` getKey 64 | getKey (ErlTuple (x : _)) = x 65 | getKey x = x 66 | isPair (ErlTuple [_, _]) = True 67 | isPair _ = False 68 | combine (ErlList pl1) t2 = ErlList (pl1 <> [t2]) 69 | combine t1 (ErlList pl2) = ErlList ([t1] <> pl2) 70 | combine t1 t2 = ErlList [t1, t2] 71 | 72 | instance Textual ErlangPropList where 73 | parseFromText txt = do 74 | str <- parseFromText txt 75 | t <- parseErlTerm "" str 76 | return (ErlangPropList t) 77 | renderToText (ErlangPropList t) = renderToText (renderErlTerm t) 78 | 79 | instance FromAST ErlangPropList where 80 | fromAST (AST a) = pure a 81 | fromAST (ASTObj pairs) = ErlangPropList . ErlList <$> mapM makePair pairs 82 | where 83 | makePair (k, ast) = do 84 | (ErlangPropList second) <- fromAST ast 85 | return $ ErlTuple [ErlAtom k, second] 86 | fromAST (ASTArr xs) = 87 | ErlangPropList . ErlList 88 | <$> mapM 89 | ( \x -> do 90 | (ErlangPropList x') <- fromAST x 91 | return x' 92 | ) 93 | xs 94 | fromAST (ASTString s) = pure $ ErlangPropList $ ErlString s 95 | fromAST (ASTInt i) = pure $ ErlangPropList $ ErlString (show i) 96 | fromAST (ASTEmbed c) = ErlangPropList . ErlString . T.unpack <$> toContentGenerator c 97 | fromAST (ASTMerge []) = error "ASTMerge MUST NOT be used with an empty list!" 98 | fromAST (ASTMerge asts) = foldl1 (<>) <$> mapM fromAST asts 99 | fromAST (ASTParse src@(Source _ srcPath)) = do 100 | c <- readTemplateFile src 101 | case parseFromTextWithErrorMessage srcPath c of 102 | Right s -> return s 103 | Left e -> error (printf "could not parse erlang source file: '%s'\n%s\n" srcPath e) 104 | 105 | -- * Misc. utilities 106 | 107 | -- | Parse a text containing an @Erlang@ expression ending with a @.@ and Return 108 | -- an 'AST'. 109 | -- 110 | -- @since 0.5.67 111 | textToErlangAst :: Text -> AST c ErlangPropList 112 | textToErlangAst txt = 113 | either 114 | (error . ((unsafeParseFromText txt ++ "\n: ") ++)) 115 | AST 116 | (parseFromTextWithErrorMessage "textToErlangAst" txt) 117 | 118 | -- | Parse a string containing an @Erlang@ expression ending with a @.@ and Return 119 | -- an 'AST'. 120 | -- 121 | -- @since 0.5.67 122 | stringToErlangAst :: String -> AST c ErlangPropList 123 | stringToErlangAst = textToErlangAst . unsafeRenderToText 124 | -------------------------------------------------------------------------------- /src/lib/B9/Artifact/Content/Readable.hs: -------------------------------------------------------------------------------- 1 | -- | Content defined in text files (.b9 files), read with the 'Read' instances. 2 | module B9.Artifact.Content.Readable where 3 | 4 | import B9.Artifact.Content 5 | import B9.Artifact.Content.AST 6 | import B9.Artifact.Content.CloudConfigYaml 7 | import B9.Artifact.Content.ErlangPropList 8 | import B9.Artifact.Content.StringTemplate 9 | import B9.Artifact.Content.YamlObject 10 | import B9.B9Logging 11 | import B9.QCUtil 12 | import B9.Text 13 | import Control.Monad.IO.Class 14 | import Control.Parallel.Strategies 15 | import qualified Data.ByteString as Strict 16 | import qualified Data.ByteString.Base64 as B64 17 | import qualified Data.ByteString.Lazy as Lazy 18 | import Data.Data 19 | import GHC.Generics (Generic) 20 | import GHC.Stack 21 | import System.Exit 22 | import System.Process 23 | import Test.QuickCheck 24 | 25 | -- | This is content that can be 'read' via the generated 'Read' instance. 26 | data Content 27 | = RenderErlang (AST Content ErlangPropList) 28 | | RenderYamlObject (AST Content YamlObject) 29 | | RenderCloudConfig (AST Content CloudConfigYaml) 30 | | -- | This data will be passed through unaltered. 31 | -- This is used during the transition phase from having B9 stuff read from 32 | -- files via 'Read' instances towards programatic use or the use of HOCON. 33 | -- 34 | -- @since 0.5.62 35 | FromByteString Lazy.ByteString 36 | | -- | Embed a literal string 37 | FromString String 38 | | -- | Embed the contents of the 'SourceFile' with template parameter substitution. 39 | FromTextFile SourceFile 40 | | -- | The data in the given file will be base64 encoded. 41 | RenderBase64BinaryFile FilePath 42 | | -- | This data will be base64 encoded. 43 | RenderBase64Binary Lazy.ByteString 44 | | -- | Download the contents of the URL 45 | FromURL String 46 | deriving (Read, Show, Typeable, Eq, Data, Generic) 47 | 48 | instance NFData Content 49 | 50 | instance Arbitrary Content where 51 | arbitrary = 52 | oneof 53 | [ FromTextFile <$> smaller arbitrary, 54 | RenderBase64BinaryFile <$> smaller arbitrary, 55 | RenderErlang <$> smaller arbitrary, 56 | RenderYamlObject <$> smaller arbitrary, 57 | RenderCloudConfig <$> smaller arbitrary, 58 | FromString <$> smaller arbitrary, 59 | FromByteString . Lazy.pack <$> smaller arbitrary, 60 | RenderBase64Binary . Lazy.pack <$> smaller arbitrary, 61 | FromURL <$> smaller arbitrary 62 | ] 63 | 64 | instance ToContentGenerator Content where 65 | toContentGenerator (RenderErlang ast) = unsafeRenderToText <$> fromAST ast 66 | toContentGenerator (RenderYamlObject ast) = 67 | unsafeRenderToText <$> fromAST ast 68 | toContentGenerator (RenderCloudConfig ast) = 69 | unsafeRenderToText <$> fromAST ast 70 | toContentGenerator (FromTextFile s) = readTemplateFile s 71 | toContentGenerator (RenderBase64BinaryFile s) = readBinaryFileAsBase64 s 72 | where 73 | readBinaryFileAsBase64 :: (HasCallStack, MonadIO m) => FilePath -> m Text 74 | readBinaryFileAsBase64 f = 75 | unsafeRenderToText . B64.encode <$> liftIO (Strict.readFile f) 76 | toContentGenerator (RenderBase64Binary b) = 77 | pure (unsafeRenderToText . B64.encode . Lazy.toStrict $ b) 78 | toContentGenerator (FromString str) = pure (unsafeRenderToText str) 79 | toContentGenerator (FromByteString str) = 80 | pure (unsafeRenderToText . Lazy.toStrict $ str) 81 | toContentGenerator (FromURL url) = do 82 | dbgL ("Downloading: " ++ url) 83 | (exitCode, out, err) <- liftIO (readProcessWithExitCode "curl" [url] "") 84 | if exitCode == ExitSuccess 85 | then do 86 | dbgL ("Download finished. Bytes read: " ++ show (length out)) 87 | traceL 88 | ( "Downloaded (truncated to first 4K): \n\n" ++ take 4096 out ++ "\n\n" 89 | ) 90 | pure (unsafeRenderToText out) 91 | else do 92 | errorL ("Download failed: " ++ err) 93 | liftIO (exitWith exitCode) 94 | 95 | -- ** Convenient Aliases 96 | 97 | -- | An 'ErlangPropList' 'AST' with 'Content' 98 | -- 99 | -- @since 0.5.67 100 | type ErlangAst = AST Content ErlangPropList 101 | -------------------------------------------------------------------------------- /src/lib/B9/Artifact/Content/StringTemplate.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | -- | Utility functions based on 'Data.Text.Template' to offer @ $var @ variable 5 | -- expansion in string throughout a B9 artifact. 6 | -- 7 | -- @deprecated 8 | -- 9 | -- TODO remove this in the move to Dhall 10 | module B9.Artifact.Content.StringTemplate 11 | ( subst, 12 | substStr, 13 | substFile, 14 | substPath, 15 | readTemplateFile, 16 | withSubstitutedStringBindings, 17 | SourceFile (..), 18 | SourceFileConversion (..), 19 | ) 20 | where 21 | 22 | import B9.B9Error 23 | import B9.Environment 24 | import B9.QCUtil 25 | import Control.Eff as Eff 26 | import Control.Exception (displayException) 27 | import Control.Monad (foldM) 28 | import Control.Monad.IO.Class (MonadIO (liftIO)) 29 | import Control.Monad.Trans.Identity () 30 | import Control.Parallel.Strategies 31 | import Data.Binary 32 | import Data.Data 33 | import Data.Hashable 34 | import Data.Text (Text) 35 | import qualified Data.Text as Text 36 | import qualified Data.Text.IO as Text 37 | import qualified Data.Text.Lazy as LazyText 38 | ( toStrict, 39 | ) 40 | import Data.Text.Template 41 | ( Template, 42 | renderA, 43 | templateSafe, 44 | ) 45 | import GHC.Generics (Generic) 46 | import System.IO.B9Extras 47 | import Test.QuickCheck 48 | import Text.Printf 49 | 50 | -- | A wrapper around a file path and a flag indicating if template variable 51 | -- expansion should be performed when reading the file contents. 52 | data SourceFile 53 | = Source 54 | SourceFileConversion 55 | FilePath 56 | deriving (Read, Show, Typeable, Data, Eq, Generic) 57 | 58 | instance Hashable SourceFile 59 | 60 | instance Binary SourceFile 61 | 62 | instance NFData SourceFile 63 | 64 | data SourceFileConversion 65 | = NoConversion 66 | | ExpandVariables 67 | deriving (Read, Show, Typeable, Data, Eq, Generic) 68 | 69 | instance Hashable SourceFileConversion 70 | 71 | instance Binary SourceFileConversion 72 | 73 | instance NFData SourceFileConversion 74 | 75 | readTemplateFile :: 76 | (MonadIO (Eff e), '[ExcB9, EnvironmentReader] <:: e) => 77 | SourceFile -> 78 | Eff e Text 79 | readTemplateFile (Source conv f') = do 80 | let onErrorFileName e = 81 | error 82 | ( printf 83 | "Failed to substitute templates in source \ 84 | \file name '%s'/\nError: %s\n" 85 | f' 86 | (displayException e) 87 | ) 88 | f <- subst (Text.pack f') `catchB9Error` onErrorFileName 89 | c <- liftIO (Text.readFile (Text.unpack f)) 90 | case conv of 91 | NoConversion -> return c 92 | ExpandVariables -> 93 | let onErrorFile e = 94 | error 95 | ( printf 96 | "readTemplateFile '%s' failed: \n%s\n" 97 | f 98 | (displayException e) 99 | ) 100 | in subst c `catchB9Error` onErrorFile 101 | 102 | -- | 'Text' template substitution. 103 | subst :: (Member ExcB9 e, Member EnvironmentReader e) => Text -> Eff e Text 104 | subst templateStr = do 105 | t <- templateSafeExcB9 templateStr 106 | LazyText.toStrict <$> renderA t lookupOrThrow 107 | 108 | -- | 'String' template substitution 109 | substStr :: 110 | (Member ExcB9 e, Member EnvironmentReader e) => String -> Eff e String 111 | substStr templateStr = do 112 | t <- templateSafeExcB9 (Text.pack templateStr) 113 | Text.unpack . LazyText.toStrict <$> renderA t lookupOrThrow 114 | 115 | templateSafeExcB9 :: Member ExcB9 e => Text -> Eff e Template 116 | templateSafeExcB9 templateStr = case templateSafe templateStr of 117 | Left (row, col) -> 118 | throwB9Error 119 | ( "Invalid template, error at row: " 120 | ++ show row 121 | ++ ", col: " 122 | ++ show col 123 | ++ " in: \"" 124 | ++ show templateStr 125 | ) 126 | Right t -> return t 127 | 128 | substFile :: 129 | (Member EnvironmentReader e, Member ExcB9 e, MonadIO (Eff e)) => 130 | FilePath -> 131 | FilePath -> 132 | Eff e () 133 | substFile src dest = do 134 | templatedText <- liftIO (Text.readFile src) 135 | let t = templateSafe templatedText 136 | case t of 137 | Left (r, c) -> 138 | let badLine = Text.unlines (take r (Text.lines templatedText)) 139 | colMarker = Text.replicate (c - 1) "-" <> "^" 140 | in throwB9Error 141 | ( printf 142 | "Template error in file '%s' line %i:\n\n%s\n%s\n" 143 | src 144 | r 145 | badLine 146 | colMarker 147 | ) 148 | Right template' -> do 149 | out <- renderA template' (templateEnvLookupSrcFile src) 150 | liftIO (Text.writeFile dest (LazyText.toStrict out)) 151 | 152 | templateEnvLookupSrcFile :: 153 | (Member EnvironmentReader e, Member ExcB9 e, MonadIO (Eff e)) => 154 | FilePath -> 155 | Text -> 156 | Eff e Text 157 | templateEnvLookupSrcFile src x = do 158 | r <- catchB9ErrorAsEither (lookupOrThrow x) 159 | either err pure r 160 | where 161 | err e = throwB9Error (show e ++ "\nIn file: \'" ++ src ++ "\'\n") 162 | 163 | substPath :: 164 | (Member EnvironmentReader e, Member ExcB9 e) => 165 | SystemPath -> 166 | Eff e SystemPath 167 | substPath src = case src of 168 | Path p -> Path <$> substStr p 169 | InHomeDir p -> InHomeDir <$> substStr p 170 | InB9UserDir p -> InB9UserDir <$> substStr p 171 | InTempDir p -> InTempDir <$> substStr p 172 | 173 | instance Arbitrary SourceFile where 174 | arbitrary = 175 | Source 176 | <$> elements [NoConversion, ExpandVariables] 177 | <*> smaller arbitraryFilePath 178 | 179 | -- | Extend an 'Environment' with new bindings, where each value may contain 180 | -- string templates with like @"Hello $name, how is life on $planet these days?"@. 181 | -- 182 | -- @since 0.5.64 183 | withSubstitutedStringBindings :: 184 | (Member EnvironmentReader e, Member ExcB9 e) => 185 | [(String, String)] -> 186 | Eff e s -> 187 | Eff e s 188 | withSubstitutedStringBindings bs nested = do 189 | let extend env (k, v) = localEnvironment (const env) $ do 190 | kv <- (Text.pack k,) <$> subst (Text.pack v) 191 | addBinding kv env 192 | env <- askEnvironment 193 | envExt <- foldM extend env bs 194 | localEnvironment (const envExt) nested 195 | -------------------------------------------------------------------------------- /src/lib/B9/Artifact/Content/YamlObject.hs: -------------------------------------------------------------------------------- 1 | -- | A wrapper around Yaml with 'Semigroup' and 'Monoid' instances for merging, reading and 2 | -- writing yaml files within B9. 3 | module B9.Artifact.Content.YamlObject 4 | ( YamlObject (..), 5 | ) 6 | where 7 | 8 | import B9.Artifact.Content 9 | import B9.Artifact.Content.AST 10 | import B9.Artifact.Content.StringTemplate 11 | import B9.Text 12 | import Control.Applicative 13 | import Control.Exception 14 | import Control.Parallel.Strategies 15 | import Data.Bifunctor (first) 16 | import qualified Data.ByteString.Lazy as Lazy 17 | import Data.Data 18 | import Data.Function 19 | import Data.HashMap.Strict hiding (singleton) 20 | import Data.Hashable 21 | import Data.Semigroup 22 | import Data.Vector as Vector 23 | ( (++), 24 | singleton, 25 | ) 26 | import Data.Yaml as Yaml 27 | import GHC.Generics (Generic) 28 | import Test.QuickCheck 29 | import Text.Printf 30 | import Prelude hiding ((++)) 31 | 32 | -- | A wrapper type around yaml values with a Semigroup instance useful for 33 | -- combining yaml documents describing system configuration like e.g. user-data. 34 | newtype YamlObject 35 | = YamlObject 36 | { _fromYamlObject :: Yaml.Value 37 | } 38 | deriving (Hashable, NFData, Eq, Data, Typeable, Generic) 39 | 40 | instance Textual YamlObject where 41 | renderToText = renderToText . encode . _fromYamlObject 42 | parseFromText t = do 43 | rb <- parseFromText t 44 | y <- first displayException $ Yaml.decodeThrow (Lazy.toStrict rb) 45 | return (YamlObject y) 46 | 47 | instance Read YamlObject where 48 | readsPrec _ = readsYamlObject 49 | where 50 | readsYamlObject :: ReadS YamlObject 51 | readsYamlObject s = 52 | [ (yamlFromString y, r2) 53 | | ("YamlObject", r1) <- lex s, 54 | (y, r2) <- reads r1 55 | ] 56 | where 57 | yamlFromString :: String -> YamlObject 58 | yamlFromString = 59 | either error id 60 | . parseFromTextWithErrorMessage "HERE-DOC" 61 | . unsafeRenderToText 62 | 63 | instance Show YamlObject where 64 | show (YamlObject o) = "YamlObject " <> show (unsafeRenderToText $ encode o) 65 | 66 | instance Semigroup YamlObject where 67 | (YamlObject v1) <> (YamlObject v2) = YamlObject (combine v1 v2) 68 | where 69 | combine :: Yaml.Value -> Yaml.Value -> Yaml.Value 70 | combine (Object o1) (Object o2) = Object (unionWith combine o1 o2) 71 | combine (Array a1) (Array a2) = Array (a1 ++ a2) 72 | combine (Array a1) t2 = Array (a1 ++ Vector.singleton t2) 73 | combine t1 (Array a2) = Array (Vector.singleton t1 ++ a2) 74 | combine (String s1) (String s2) = String (s1 <> s2) 75 | combine t1 t2 = array [t1, t2] 76 | 77 | instance FromAST YamlObject where 78 | fromAST ast = case ast of 79 | ASTObj pairs -> do 80 | ys <- mapM fromASTPair pairs 81 | return (YamlObject (object ys)) 82 | ASTArr asts -> do 83 | ys <- mapM fromAST asts 84 | let ys' = (\(YamlObject o) -> o) <$> ys 85 | return (YamlObject (array ys')) 86 | ASTMerge [] -> error "ASTMerge MUST NOT be used with an empty list!" 87 | ASTMerge asts -> do 88 | ys <- mapM fromAST asts 89 | return (foldl1 (<>) ys) 90 | ASTEmbed c -> YamlObject . toJSON <$> toContentGenerator c 91 | ASTString str -> return (YamlObject (toJSON str)) 92 | ASTInt int -> return (YamlObject (toJSON int)) 93 | ASTParse src@(Source _ srcPath) -> do 94 | c <- readTemplateFile src 95 | case parseFromTextWithErrorMessage srcPath c of 96 | Right s -> return s 97 | Left e -> 98 | error 99 | (printf "could not parse yaml source file: '%s'\n%s\n" srcPath e) 100 | AST a -> pure a 101 | where 102 | fromASTPair (key, value) = do 103 | (YamlObject o) <- fromAST value 104 | let key' = unsafeRenderToText key 105 | return $ key' .= o 106 | 107 | instance Arbitrary YamlObject where 108 | arbitrary = pure (YamlObject Null) 109 | -------------------------------------------------------------------------------- /src/lib/B9/Artifact/Readable/Source.hs: -------------------------------------------------------------------------------- 1 | -- | Source files for 'B9.Artifact.Generator's. 2 | -- 3 | -- @since 0.5.62 4 | module B9.Artifact.Readable.Source 5 | ( ArtifactSource (..), 6 | getArtifactSourceFiles, 7 | ) 8 | where 9 | 10 | import B9.Artifact.Content.Readable 11 | import B9.Artifact.Content.StringTemplate 12 | import B9.QCUtil 13 | import Control.Parallel.Strategies 14 | import Data.Data 15 | import GHC.Generics (Generic) 16 | import System.FilePath (()) 17 | import Test.QuickCheck 18 | 19 | -- | Describe how input files for artifacts to build are obtained. The general 20 | -- structure of each constructor is __FromXXX__ /destination/ /source/ 21 | data ArtifactSource 22 | = -- | Copy a 'B9.Artifact.Content.StringTemplate.SourceFile' 23 | -- potentially replacing variable defined in 'Let'-like 24 | -- parent elements. 25 | FromFile 26 | FilePath 27 | SourceFile 28 | | -- | Create a file from some 'Content' 29 | FromContent 30 | FilePath 31 | Content 32 | | -- | Set the unix /file permissions/ to all files generated 33 | -- by the nested list of 'ArtifactSource's. 34 | SetPermissions 35 | Int 36 | Int 37 | Int 38 | [ArtifactSource] 39 | | -- | Assume a local directory as starting point for all 40 | -- relative source files in the nested 'ArtifactSource's. 41 | FromDirectory 42 | FilePath 43 | [ArtifactSource] 44 | | -- | Specify an output directory for all the files 45 | -- generated by the nested 'ArtifactSource's 46 | IntoDirectory 47 | FilePath 48 | [ArtifactSource] 49 | deriving (Read, Show, Eq, Data, Typeable, Generic) 50 | 51 | instance NFData ArtifactSource 52 | 53 | -- | Return all source files generated by an 'ArtifactSource'. 54 | getArtifactSourceFiles :: ArtifactSource -> [FilePath] 55 | getArtifactSourceFiles (FromContent f _) = [f] 56 | getArtifactSourceFiles (FromFile f _) = [f] 57 | getArtifactSourceFiles (IntoDirectory pd as) = 58 | (pd ) <$> (as >>= getArtifactSourceFiles) 59 | getArtifactSourceFiles (FromDirectory _ as) = as >>= getArtifactSourceFiles 60 | getArtifactSourceFiles (SetPermissions _ _ _ as) = 61 | as >>= getArtifactSourceFiles 62 | 63 | instance Arbitrary ArtifactSource where 64 | arbitrary = 65 | oneof 66 | [ FromFile <$> smaller arbitraryFilePath <*> smaller arbitrary, 67 | FromContent <$> smaller arbitraryFilePath <*> smaller arbitrary, 68 | SetPermissions 69 | <$> choose (0, 7) 70 | <*> choose (0, 7) 71 | <*> choose (0, 7) 72 | <*> smaller arbitrary, 73 | FromDirectory <$> smaller arbitraryFilePath <*> smaller arbitrary, 74 | IntoDirectory <$> smaller arbitraryFilePath <*> smaller arbitrary 75 | ] 76 | -------------------------------------------------------------------------------- /src/lib/B9/B9Config/Container.hs: -------------------------------------------------------------------------------- 1 | module B9.B9Config.Container 2 | ( parseContainerCapabilities, 3 | ContainerCapability (..), 4 | containerCapsToCPDocument, 5 | ) 6 | where 7 | 8 | import Data.ConfigFile.B9Extras 9 | import Test.QuickCheck (Arbitrary(arbitrary)) 10 | import qualified Test.QuickCheck as QuickCheck 11 | 12 | -- | Available capabilities for Linux containers. This maps directly to the 13 | -- capabilities defined in 'man 7 capabilities'. 14 | data ContainerCapability 15 | = CAP_MKNOD 16 | | CAP_AUDIT_CONTROL 17 | | CAP_AUDIT_READ 18 | | CAP_AUDIT_WRITE 19 | | CAP_BLOCK_SUSPEND 20 | | CAP_CHOWN 21 | | CAP_DAC_OVERRIDE 22 | | CAP_DAC_READ_SEARCH 23 | | CAP_FOWNER 24 | | CAP_FSETID 25 | | CAP_IPC_LOCK 26 | | CAP_IPC_OWNER 27 | | CAP_KILL 28 | | CAP_LEASE 29 | | CAP_LINUX_IMMUTABLE 30 | | CAP_MAC_ADMIN 31 | | CAP_MAC_OVERRIDE 32 | | CAP_NET_ADMIN 33 | | CAP_NET_BIND_SERVICE 34 | | CAP_NET_BROADCAST 35 | | CAP_NET_RAW 36 | | CAP_SETGID 37 | | CAP_SETFCAP 38 | | CAP_SETPCAP 39 | | CAP_SETUID 40 | | CAP_SYS_ADMIN 41 | | CAP_SYS_BOOT 42 | | CAP_SYS_CHROOT 43 | | CAP_SYS_MODULE 44 | | CAP_SYS_NICE 45 | | CAP_SYS_PACCT 46 | | CAP_SYS_PTRACE 47 | | CAP_SYS_RAWIO 48 | | CAP_SYS_RESOURCE 49 | | CAP_SYS_TIME 50 | | CAP_SYS_TTY_CONFIG 51 | | CAP_SYSLOG 52 | | CAP_WAKE_ALARM 53 | deriving (Read, Show, Eq, Enum, Bounded) 54 | 55 | instance Arbitrary ContainerCapability where 56 | arbitrary = 57 | QuickCheck.elements 58 | (enumFromTo minBound maxBound :: [ContainerCapability]) 59 | 60 | containerCapabilitiesK :: String 61 | containerCapabilitiesK = "guest_capabilities" 62 | 63 | containerCapsToCPDocument :: 64 | CPDocument -> CPSectionSpec -> [ContainerCapability] -> Either CPError CPDocument 65 | containerCapsToCPDocument cp cfgFileSection c = 66 | setShowCP cp cfgFileSection containerCapabilitiesK c 67 | 68 | parseContainerCapabilities :: CPDocument -> CPSectionSpec -> Either CPError [ContainerCapability] 69 | parseContainerCapabilities cp cfgFileSection = 70 | readCP cp cfgFileSection containerCapabilitiesK 71 | -- TODO make a generic container config data type 72 | -------------------------------------------------------------------------------- /src/lib/B9/B9Config/Docker.hs: -------------------------------------------------------------------------------- 1 | module B9.B9Config.Docker 2 | ( dockerConfigToCPDocument, 3 | defaultDockerConfig, 4 | parseDockerConfig, 5 | DockerConfig (..), 6 | dockerNetworkId, 7 | dockerCapabilities, 8 | ) 9 | where 10 | 11 | import B9.B9Config.Container 12 | import Control.Lens (makeLenses) 13 | import Data.ConfigFile.B9Extras 14 | 15 | data DockerConfig 16 | = DockerConfig 17 | { _dockerNetworkId :: Maybe String, 18 | _dockerCapabilities :: [ContainerCapability] 19 | } 20 | deriving (Read, Show, Eq) 21 | 22 | makeLenses ''DockerConfig 23 | 24 | defaultDockerConfig :: DockerConfig 25 | defaultDockerConfig = 26 | DockerConfig 27 | Nothing 28 | [ CAP_MKNOD, 29 | CAP_SYS_ADMIN, 30 | CAP_SYS_CHROOT, 31 | CAP_SETGID, 32 | CAP_SETUID, 33 | CAP_NET_BIND_SERVICE, 34 | CAP_SETPCAP, 35 | CAP_SYS_PTRACE, 36 | CAP_SYS_MODULE 37 | ] 38 | 39 | cfgFileSection :: String 40 | cfgFileSection = "docker" 41 | 42 | networkIdK :: String 43 | networkIdK = "network" 44 | 45 | dockerConfigToCPDocument :: 46 | DockerConfig -> CPDocument -> Either CPError CPDocument 47 | dockerConfigToCPDocument c cp = do 48 | cp1 <- addSectionCP cp cfgFileSection 49 | cp2 <- 50 | setShowCP cp1 cfgFileSection networkIdK $ 51 | _dockerNetworkId c 52 | containerCapsToCPDocument cp2 cfgFileSection $ 53 | _dockerCapabilities c 54 | 55 | parseDockerConfig :: CPDocument -> Either CPError DockerConfig 56 | parseDockerConfig cp = 57 | let getr :: (CPGet a) => CPOptionSpec -> Either CPError a 58 | getr = readCP cp cfgFileSection 59 | in DockerConfig 60 | <$> getr networkIdK 61 | <*> parseContainerCapabilities cp cfgFileSection 62 | -------------------------------------------------------------------------------- /src/lib/B9/B9Config/LibVirtLXC.hs: -------------------------------------------------------------------------------- 1 | module B9.B9Config.LibVirtLXC 2 | ( libVirtLXCConfigToCPDocument, 3 | defaultLibVirtLXCConfig, 4 | parseLibVirtLXCConfig, 5 | LibVirtLXCConfig (..), 6 | networkId, 7 | getEmulatorPath, 8 | ) 9 | where 10 | 11 | import B9.B9Config.Container 12 | import B9.DiskImages 13 | import B9.ExecEnv 14 | import Control.Lens (makeLenses) 15 | import Control.Monad.IO.Class 16 | import Data.ConfigFile.B9Extras 17 | import Data.Maybe (fromMaybe) 18 | import System.Environment.Blank as SysIO 19 | import Test.QuickCheck (Arbitrary(arbitrary),oneof,listOf1) 20 | import B9.QCUtil (smaller, arbitraryFilePath, arbitraryLetter) 21 | 22 | data LibVirtLXCConfig 23 | = LibVirtLXCConfig 24 | { useSudo :: Bool, 25 | emulator :: Maybe FilePath, 26 | virshURI :: FilePath, 27 | _networkId :: Maybe String, 28 | guestCapabilities :: [ContainerCapability], 29 | guestRamSize :: RamSize, 30 | imageFileNameShortenerBasePath :: Maybe FilePath 31 | } 32 | deriving (Read, Show, Eq) 33 | 34 | instance Arbitrary LibVirtLXCConfig where 35 | arbitrary = 36 | LibVirtLXCConfig <$> 37 | smaller arbitrary <*> 38 | smaller (oneof [pure Nothing, Just <$> arbitraryFilePath]) <*> 39 | smaller arbitraryFilePath <*> 40 | smaller (oneof [pure Nothing, Just <$> listOf1 arbitraryLetter]) <*> 41 | smaller arbitrary <*> 42 | pure (RamSize 4 GB) <*> 43 | smaller (oneof [pure Nothing, Just <$> arbitraryFilePath]) 44 | 45 | makeLenses ''LibVirtLXCConfig 46 | 47 | defaultLibVirtLXCConfig :: LibVirtLXCConfig 48 | defaultLibVirtLXCConfig = 49 | LibVirtLXCConfig 50 | True 51 | (Just "/usr/lib/libvirt/libvirt_lxc") 52 | "lxc:///" 53 | Nothing 54 | [ CAP_MKNOD, 55 | CAP_SYS_ADMIN, 56 | CAP_SYS_CHROOT, 57 | CAP_SETGID, 58 | CAP_SETUID, 59 | CAP_NET_BIND_SERVICE, 60 | CAP_SETPCAP, 61 | CAP_SYS_PTRACE, 62 | CAP_SYS_MODULE 63 | ] 64 | (RamSize 1 GB) 65 | Nothing 66 | 67 | cfgFileSection :: String 68 | cfgFileSection = "libvirt-lxc" 69 | 70 | useSudoK :: String 71 | useSudoK = "use_sudo" 72 | 73 | emulatorK :: String 74 | emulatorK = "emulator_path" 75 | 76 | -- NOTE: This variable name is also specified in the NIX build 77 | -- in @default.nix@. 78 | emulatorEnvVar :: String 79 | emulatorEnvVar = "B9_LIBVIRT_LXC" 80 | 81 | virshURIK :: String 82 | virshURIK = "connection" 83 | 84 | networkIdK :: String 85 | networkIdK = "network" 86 | 87 | guestRamSizeK :: String 88 | guestRamSizeK = "guest_ram_size" 89 | 90 | imageFileNamesShortenerBasePathK :: String 91 | imageFileNamesShortenerBasePathK = "image_file_names_shortener_base_path" 92 | 93 | libVirtLXCConfigToCPDocument :: 94 | LibVirtLXCConfig -> CPDocument -> Either CPError CPDocument 95 | libVirtLXCConfigToCPDocument c cp = do 96 | cp1 <- addSectionCP cp cfgFileSection 97 | cp2 <- setShowCP cp1 cfgFileSection useSudoK $ useSudo c 98 | cp3 <- setShowCP cp2 cfgFileSection emulatorK $ emulator c 99 | cp4 <- setCP cp3 cfgFileSection virshURIK $ virshURI c 100 | cp5 <- setShowCP cp4 cfgFileSection networkIdK $ _networkId c 101 | cp6 <- containerCapsToCPDocument cp5 cfgFileSection $ guestCapabilities c 102 | cp7 <- setShowCP cp6 cfgFileSection guestRamSizeK $ guestRamSize c 103 | cpFinal <- setShowCP cp7 cfgFileSection imageFileNamesShortenerBasePathK $ imageFileNameShortenerBasePath c 104 | return cpFinal 105 | 106 | parseLibVirtLXCConfig :: CPDocument -> Either CPError LibVirtLXCConfig 107 | parseLibVirtLXCConfig cp = 108 | let getr :: (CPGet a) => CPOptionSpec -> Either CPError a 109 | getr = readCP cp cfgFileSection 110 | in LibVirtLXCConfig 111 | <$> getr useSudoK 112 | <*> getr emulatorK 113 | <*> getr virshURIK 114 | <*> getr networkIdK 115 | <*> parseContainerCapabilities cp cfgFileSection 116 | <*> getr guestRamSizeK 117 | <*> getr imageFileNamesShortenerBasePathK 118 | 119 | -- | Return the path to @/usr/lib/libvirt/libexec/libvirt_lxc@ 120 | -- the 'emulatorK' field from the config file, or set the path 121 | -- in the environment variable named like the value in 'emulatorEnvVar' 122 | -- dictates. 123 | -- 124 | -- @since 0.5.66 125 | getEmulatorPath :: MonadIO m => LibVirtLXCConfig -> m FilePath 126 | getEmulatorPath cfg = 127 | liftIO (SysIO.getEnvDefault emulatorEnvVar fromCfgOrDefault) 128 | where 129 | fromCfgOrDefault = fromMaybe "/usr/lib/libexec/libvirt_lxc" (emulator cfg) 130 | -------------------------------------------------------------------------------- /src/lib/B9/B9Config/Podman.hs: -------------------------------------------------------------------------------- 1 | module B9.B9Config.Podman 2 | ( podmanConfigToCPDocument, 3 | defaultPodmanConfig, 4 | parsePodmanConfig, 5 | PodmanConfig (..), 6 | podmanNetworkId, 7 | podmanCapabilities, 8 | ) 9 | where 10 | 11 | import B9.B9Config.Container 12 | import Control.Lens (makeLenses) 13 | import Data.ConfigFile.B9Extras 14 | 15 | data PodmanConfig 16 | = PodmanConfig 17 | { _podmanNetworkId :: Maybe String, 18 | _podmanCapabilities :: [ContainerCapability] 19 | } 20 | deriving (Read, Show, Eq) 21 | 22 | makeLenses ''PodmanConfig 23 | 24 | defaultPodmanConfig :: PodmanConfig 25 | defaultPodmanConfig = 26 | PodmanConfig 27 | Nothing 28 | [ CAP_MKNOD, 29 | CAP_SYS_ADMIN, 30 | CAP_SYS_CHROOT, 31 | CAP_SETGID, 32 | CAP_SETUID, 33 | CAP_NET_BIND_SERVICE, 34 | CAP_SETPCAP, 35 | CAP_SYS_PTRACE, 36 | CAP_SYS_MODULE 37 | ] 38 | 39 | cfgFileSection :: String 40 | cfgFileSection = "podman" 41 | 42 | networkIdK :: String 43 | networkIdK = "network" 44 | 45 | podmanConfigToCPDocument :: 46 | PodmanConfig -> CPDocument -> Either CPError CPDocument 47 | podmanConfigToCPDocument c cp = do 48 | cp1 <- addSectionCP cp cfgFileSection 49 | cp2 <- 50 | setShowCP cp1 cfgFileSection networkIdK $ 51 | _podmanNetworkId c 52 | containerCapsToCPDocument cp2 cfgFileSection $ 53 | _podmanCapabilities c 54 | 55 | parsePodmanConfig :: CPDocument -> Either CPError PodmanConfig 56 | parsePodmanConfig cp = 57 | let getr :: (CPGet a) => CPOptionSpec -> Either CPError a 58 | getr = readCP cp cfgFileSection 59 | in PodmanConfig 60 | <$> getr networkIdK 61 | <*> parseContainerCapabilities cp cfgFileSection 62 | -------------------------------------------------------------------------------- /src/lib/B9/B9Config/Repository.hs: -------------------------------------------------------------------------------- 1 | module B9.B9Config.Repository 2 | ( RemoteRepo (..), 3 | remoteRepoRepoId, 4 | RepoCache (..), 5 | SshPrivKey (..), 6 | SshRemoteHost (..), 7 | SshRemoteUser (..), 8 | remoteRepoToCPDocument, 9 | parseRemoteRepos, 10 | ) 11 | where 12 | 13 | import Data.ConfigFile.B9Extras 14 | import Data.Data 15 | import Data.List (isSuffixOf, sort) 16 | import Test.QuickCheck (Positive(..), Arbitrary(arbitrary), listOf1) 17 | import B9.QCUtil (smaller, arbitraryFilePath, arbitraryLetter) 18 | 19 | newtype RepoCache = RepoCache FilePath 20 | deriving (Read, Show, Typeable, Data) 21 | 22 | data RemoteRepo 23 | = RemoteRepo 24 | String 25 | FilePath 26 | SshPrivKey 27 | SshRemoteHost 28 | SshRemoteUser 29 | deriving (Read, Show, Typeable, Data, Eq, Ord) 30 | 31 | instance Arbitrary RemoteRepo where 32 | arbitrary = RemoteRepo <$> 33 | smaller (listOf1 arbitraryLetter) <*> 34 | smaller arbitraryFilePath <*> 35 | smaller arbitrary <*> 36 | smaller arbitrary <*> 37 | smaller arbitrary 38 | 39 | 40 | remoteRepoRepoId :: RemoteRepo -> String 41 | remoteRepoRepoId (RemoteRepo repoId _ _ _ _) = repoId 42 | 43 | newtype SshPrivKey = SshPrivKey FilePath 44 | deriving (Read, Show, Typeable, Data, Eq, Ord) 45 | 46 | instance Arbitrary SshPrivKey where 47 | arbitrary = SshPrivKey <$> arbitraryFilePath 48 | 49 | newtype SshRemoteHost = SshRemoteHost (String, Int) 50 | deriving (Read, Show, Typeable, Data, Eq, Ord) 51 | 52 | instance Arbitrary SshRemoteHost where 53 | arbitrary = do 54 | h <- smaller (listOf1 arbitraryLetter) 55 | Positive p <- arbitrary 56 | pure (SshRemoteHost (h,p)) 57 | 58 | newtype SshRemoteUser = SshRemoteUser String 59 | deriving (Read, Show, Typeable, Data, Eq, Ord) 60 | 61 | instance Arbitrary SshRemoteUser where 62 | arbitrary = SshRemoteUser <$> smaller (listOf1 arbitraryLetter) 63 | 64 | -- | Persist a repo to a configuration file. 65 | remoteRepoToCPDocument :: RemoteRepo -> CPDocument -> Either CPError CPDocument 66 | remoteRepoToCPDocument repo cpIn = cpWithRepo 67 | where 68 | section = repoId ++ repoSectionSuffix 69 | (RemoteRepo repoId remoteRootDir (SshPrivKey keyFile) (SshRemoteHost (host, port)) (SshRemoteUser user)) = 70 | repo 71 | cpWithRepo = do 72 | cp1 <- addSectionCP cpIn section 73 | cp2 <- setCP cp1 section repoRemotePathK remoteRootDir 74 | cp3 <- setCP cp2 section repoRemoteSshKeyK keyFile 75 | cp4 <- setCP cp3 section repoRemoteSshHostK host 76 | cp5 <- setShowCP cp4 section repoRemoteSshPortK port 77 | setCP cp5 section repoRemoteSshUserK user 78 | 79 | -- | Load a repository from a configuration file that has been written by 80 | -- 'writeRepositoryToB9Config'. 81 | parseRemoteRepos :: CPDocument -> Either CPError [RemoteRepo] 82 | parseRemoteRepos cp = sort <$> traverse parseRepoSection repoSections 83 | where 84 | repoSections = filter (repoSectionSuffix `isSuffixOf`) (sectionsCP cp) 85 | parseRepoSection section = parseResult 86 | where 87 | getsec :: CPGet a => CPOptionSpec -> Either CPError a 88 | getsec = readCP cp section 89 | parseResult = 90 | RemoteRepo repoId 91 | <$> getsec repoRemotePathK 92 | <*> (SshPrivKey <$> getsec repoRemoteSshKeyK) 93 | <*> ( SshRemoteHost 94 | <$> ( (,) 95 | <$> getsec repoRemoteSshHostK 96 | <*> getsec repoRemoteSshPortK 97 | ) 98 | ) 99 | <*> (SshRemoteUser <$> getsec repoRemoteSshUserK) 100 | where 101 | repoId = 102 | let prefixLen = length section - suffixLen 103 | suffixLen = length repoSectionSuffix 104 | in take prefixLen section 105 | 106 | repoSectionSuffix :: String 107 | repoSectionSuffix = "-repo" 108 | 109 | repoRemotePathK :: String 110 | repoRemotePathK = "remote_path" 111 | 112 | repoRemoteSshKeyK :: String 113 | repoRemoteSshKeyK = "ssh_priv_key_file" 114 | 115 | repoRemoteSshHostK :: String 116 | repoRemoteSshHostK = "ssh_remote_host" 117 | 118 | repoRemoteSshPortK :: String 119 | repoRemoteSshPortK = "ssh_remote_port" 120 | 121 | repoRemoteSshUserK :: String 122 | repoRemoteSshUserK = "ssh_remote_user" 123 | -------------------------------------------------------------------------------- /src/lib/B9/B9Config/SystemdNspawn.hs: -------------------------------------------------------------------------------- 1 | module B9.B9Config.SystemdNspawn 2 | ( systemdNspawnConfigToCPDocument, 3 | defaultSystemdNspawnConfig, 4 | parseSystemdNspawnConfig, 5 | SystemdNspawnConfig (..), 6 | SystemdNspawnConsole (..), 7 | systemdNspawnCapabilities, 8 | systemdNspawnUseSudo, 9 | systemdNspawnMaxLifetimeSeconds, 10 | systemdNspawnExtraArgs, 11 | systemdNspawnExecutable, 12 | systemdNspawnConsole, 13 | ) 14 | where 15 | 16 | import B9.B9Config.Container 17 | import Control.Lens (makeLenses) 18 | import Data.ConfigFile.B9Extras 19 | import qualified Text.ParserCombinators.ReadP as ReadP 20 | import qualified Text.ParserCombinators.ReadPrec as ReadPrec 21 | import Text.Read 22 | import Test.QuickCheck (Arbitrary(arbitrary)) 23 | import qualified Test.QuickCheck as QuickCheck 24 | import B9.QCUtil (smaller, arbitraryFilePath) 25 | 26 | -- TODO document b9 config file 27 | data SystemdNspawnConfig 28 | = SystemdNspawnConfig 29 | { _systemdNspawnCapabilities :: [ContainerCapability], 30 | _systemdNspawnUseSudo :: Bool, 31 | _systemdNspawnMaxLifetimeSeconds :: Maybe Int, 32 | _systemdNspawnExtraArgs :: Maybe String, 33 | _systemdNspawnExecutable :: Maybe FilePath, 34 | _systemdNspawnConsole :: SystemdNspawnConsole 35 | } 36 | deriving (Read, Show, Eq) 37 | 38 | instance Arbitrary SystemdNspawnConfig where 39 | arbitrary = 40 | SystemdNspawnConfig 41 | <$> smaller arbitrary 42 | <*> smaller arbitrary 43 | <*> smaller arbitrary 44 | <*> smaller arbitrary 45 | <*> smaller (QuickCheck.oneof [pure Nothing, Just <$> arbitraryFilePath]) 46 | <*> smaller arbitrary 47 | 48 | data SystemdNspawnConsole 49 | = SystemdNspawnInteractive 50 | | SystemdNspawnReadOnly 51 | | SystemdNspawnPassive 52 | | SystemdNspawnPipe 53 | deriving (Eq) 54 | 55 | instance Arbitrary SystemdNspawnConsole where 56 | arbitrary = 57 | QuickCheck.elements 58 | [ SystemdNspawnInteractive 59 | , SystemdNspawnReadOnly 60 | , SystemdNspawnPassive 61 | , SystemdNspawnPipe 62 | ] 63 | 64 | instance Show SystemdNspawnConsole where 65 | show x = case x of 66 | SystemdNspawnInteractive -> "interactive" 67 | SystemdNspawnReadOnly -> "read-only" 68 | SystemdNspawnPassive -> "passive" 69 | SystemdNspawnPipe -> "pipe" 70 | 71 | instance Read SystemdNspawnConsole where 72 | readPrec = 73 | do 74 | Ident "interactive" <- lexP 75 | return SystemdNspawnInteractive 76 | +++ ReadPrec.lift 77 | ( do 78 | ReadP.skipSpaces 79 | _ <- ReadP.string "read-only" 80 | return SystemdNspawnReadOnly 81 | ) 82 | +++ do 83 | Ident "passive" <- lexP 84 | return SystemdNspawnPassive 85 | +++ do 86 | Ident "pipe" <- lexP 87 | return SystemdNspawnPipe 88 | 89 | makeLenses ''SystemdNspawnConfig 90 | 91 | defaultSystemdNspawnConfig :: SystemdNspawnConfig 92 | defaultSystemdNspawnConfig = 93 | SystemdNspawnConfig 94 | [ CAP_MKNOD, 95 | CAP_SYS_ADMIN, 96 | CAP_SYS_CHROOT, 97 | CAP_SETGID, 98 | CAP_SETUID, 99 | CAP_NET_BIND_SERVICE, 100 | CAP_SETPCAP, 101 | CAP_SYS_PTRACE, 102 | CAP_SYS_MODULE 103 | ] 104 | True 105 | (Just (4 * 3600)) 106 | Nothing 107 | Nothing 108 | SystemdNspawnReadOnly 109 | 110 | cfgFileSection :: String 111 | cfgFileSection = "systemdNspawn" 112 | 113 | useSudoK :: String 114 | useSudoK = "use_sudo" 115 | 116 | maxLifetimeSecondsK :: String 117 | maxLifetimeSecondsK = "max_lifetime_seconds" 118 | 119 | extraArgsK :: String 120 | extraArgsK = "extra_args" 121 | 122 | executableK :: String 123 | executableK = "executable" 124 | 125 | consoleK :: String 126 | consoleK = "console" 127 | 128 | systemdNspawnConfigToCPDocument :: 129 | SystemdNspawnConfig -> CPDocument -> Either CPError CPDocument 130 | systemdNspawnConfigToCPDocument c cp = do 131 | cp1 <- addSectionCP cp cfgFileSection 132 | cp2 <- 133 | containerCapsToCPDocument cp1 cfgFileSection $ 134 | _systemdNspawnCapabilities c 135 | cp3 <- setShowCP cp2 cfgFileSection useSudoK $ _systemdNspawnUseSudo c 136 | cp4 <- setShowCP cp3 cfgFileSection maxLifetimeSecondsK $ _systemdNspawnMaxLifetimeSeconds c 137 | cp5 <- setShowCP cp4 cfgFileSection extraArgsK $ _systemdNspawnExtraArgs c 138 | cp6 <- setShowCP cp5 cfgFileSection executableK $ _systemdNspawnExecutable c 139 | setShowCP cp6 cfgFileSection consoleK $ _systemdNspawnConsole c 140 | 141 | parseSystemdNspawnConfig :: CPDocument -> Either CPError SystemdNspawnConfig 142 | parseSystemdNspawnConfig cp = 143 | let getr :: (CPGet a) => CPOptionSpec -> Either CPError a 144 | getr = readCP cp cfgFileSection 145 | in SystemdNspawnConfig 146 | <$> parseContainerCapabilities cp cfgFileSection 147 | <*> getr useSudoK 148 | <*> getr maxLifetimeSecondsK 149 | <*> getr extraArgsK 150 | <*> getr executableK 151 | <*> getr consoleK 152 | -------------------------------------------------------------------------------- /src/lib/B9/B9Error.hs: -------------------------------------------------------------------------------- 1 | -- | Error handling in B9 via extensible effects. 2 | -- B9 wraps errors in `SomeException`. 3 | -- 4 | -- @since 0.5.64 5 | module B9.B9Error 6 | ( throwSomeException, 7 | throwSomeException_, 8 | throwB9Error, 9 | throwB9Error_, 10 | errorOnException, 11 | ExcB9, 12 | WithIoExceptions, 13 | runExcB9, 14 | B9Error (MkB9Error), 15 | fromB9Error, 16 | catchB9Error, 17 | catchB9ErrorAsEither, 18 | finallyB9, 19 | ) 20 | where 21 | 22 | import Control.Eff as Eff 23 | import Control.Eff.Exception as Eff 24 | import Control.Exception 25 | ( Exception, 26 | SomeException, 27 | toException, 28 | ) 29 | import qualified Control.Exception as IOExc 30 | import Control.Monad 31 | import Data.String (IsString (..)) 32 | 33 | -- | The exception effect used in most places in B9. 34 | -- This is `Exc` specialized with `SomeException`. 35 | -- 36 | -- @since 0.5.64 37 | type ExcB9 = Exc SomeException 38 | 39 | -- | Constraint alias for the exception effect that allows to 40 | -- throw 'SomeException'. 41 | -- 42 | -- @since 1.0.0 43 | type WithIoExceptions e = SetMember Exc (Exc SomeException) e 44 | 45 | -- | This is a simple runtime exception to indicate that B9 code encountered 46 | -- some exceptional event. 47 | -- 48 | -- @since 0.5.64 49 | newtype B9Error = MkB9Error {fromB9Error :: String} 50 | deriving (IsString) 51 | 52 | instance Show B9Error where 53 | show (MkB9Error msg) = "B9 internal error: " ++ msg 54 | 55 | instance Exception B9Error 56 | 57 | -- | Run an `ExcB9`. 58 | -- 59 | -- @since 0.5.64 60 | runExcB9 :: Eff (ExcB9 ': e) a -> Eff e (Either SomeException a) 61 | runExcB9 = runError 62 | 63 | -- | Run an `ExcB9` and rethrow the exception with `error`. 64 | -- 65 | -- @since 0.5.64 66 | errorOnException :: Lifted IO e => Eff (ExcB9 ': e) a -> Eff e a 67 | errorOnException = runError >=> either (lift . IOExc.throw) pure 68 | 69 | -- | 'SomeException' wrapped into 'Exc'ecption 'Eff'ects 70 | -- 71 | -- @since 0.5.64 72 | throwSomeException :: (Member ExcB9 e, Exception x) => x -> Eff e a 73 | throwSomeException = throwError . toException 74 | 75 | -- | 'SomeException' wrapped into 'Exc'ecption 'Eff'ects 76 | -- 77 | -- @since 0.5.64 78 | throwSomeException_ :: (Member ExcB9 e, Exception x) => x -> Eff e () 79 | throwSomeException_ = throwError_ . toException 80 | 81 | -- | 'SomeException' wrapped into 'Exc'ecption 'Eff'ects 82 | -- 83 | -- @since 0.5.64 84 | throwB9Error :: Member ExcB9 e => String -> Eff e a 85 | throwB9Error = throwSomeException . MkB9Error 86 | 87 | -- | 'SomeException' wrapped into 'Exc'ecption 'Eff'ects 88 | -- 89 | -- @since 0.5.64 90 | throwB9Error_ :: Member ExcB9 e => String -> Eff e () 91 | throwB9Error_ = throwSomeException_ . MkB9Error 92 | 93 | -- | Catch exceptions. 94 | -- 95 | -- @since 0.5.64 96 | catchB9Error :: 97 | Member ExcB9 e => Eff e a -> (SomeException -> Eff e a) -> Eff e a 98 | catchB9Error = catchError 99 | 100 | -- | Catch exceptions and return them via 'Either'. 101 | -- 102 | -- @since 0.5.64 103 | catchB9ErrorAsEither :: 104 | Member ExcB9 e => Eff e a -> Eff e (Either SomeException a) 105 | catchB9ErrorAsEither x = catchB9Error (Right <$> x) (pure . Left) 106 | 107 | -- | Always execute an action and rethrow any exceptions caught. 108 | -- 109 | -- @since 1.0.0 110 | finallyB9 :: Member ExcB9 e => Eff e a -> Eff e () -> Eff e a 111 | finallyB9 mainAction cleanupAction = 112 | catchB9Error 113 | ( do 114 | res <- mainAction 115 | cleanupAction 116 | return res 117 | ) 118 | (\e -> cleanupAction >> throwSomeException e) 119 | -------------------------------------------------------------------------------- /src/lib/B9/B9Logging.hs: -------------------------------------------------------------------------------- 1 | -- | This modules contains support for logging. 2 | -- 3 | -- @since 0.5.65 4 | module B9.B9Logging 5 | ( Logger (..), 6 | CommandIO, 7 | LoggerReader, 8 | withLogger, 9 | b9Log, 10 | traceL, 11 | dbgL, 12 | infoL, 13 | errorL, 14 | errorExitL, 15 | printHash, 16 | ) 17 | where 18 | 19 | import B9.B9Config 20 | import B9.B9Error 21 | import Control.Eff 22 | import Control.Eff.Reader.Lazy 23 | import Control.Monad 24 | import Control.Monad.IO.Class 25 | import Control.Monad.Trans.Control 26 | ( MonadBaseControl, 27 | liftBaseWith, 28 | restoreM, 29 | ) 30 | import Data.Hashable 31 | import Data.Maybe 32 | import Data.Time.Clock 33 | import Data.Time.Format 34 | import qualified System.IO as SysIO 35 | import Text.Printf 36 | 37 | -- | The logger to write log messages to. 38 | -- 39 | -- @since 0.5.65 40 | newtype Logger 41 | = MkLogger 42 | { logFileHandle :: Maybe SysIO.Handle 43 | } 44 | 45 | -- | Effect that reads a 'Logger'. 46 | -- 47 | -- @since 0.5.65 48 | type LoggerReader = Reader Logger 49 | 50 | -- | Lookup the selected 'getLogVerbosity' and '_logFile' from the 'B9Config' 51 | -- and open it. 52 | -- 53 | -- Then run the given action; if the action crashes, the log file will be closed. 54 | -- 55 | -- @since 0.5.65 56 | withLogger :: 57 | (MonadBaseControl IO (Eff e), MonadIO (Eff e), Member B9ConfigReader e) => 58 | Eff (LoggerReader ': e) a -> 59 | Eff e a 60 | withLogger action = do 61 | lf <- _logFile <$> getB9Config 62 | effState <- liftBaseWith $ \runInIO -> 63 | let fInIO = runInIO . flip runReader action . MkLogger 64 | in maybe 65 | (fInIO Nothing) 66 | (\logf -> SysIO.withFile logf SysIO.AppendMode (fInIO . Just)) 67 | lf 68 | restoreM effState 69 | 70 | -- | Convenience type alias for 'Eff'ects that have a 'B9Config', a 'Logger', 'MonadIO' and 'MonadBaseControl'. 71 | -- 72 | -- @since 0.5.65 73 | type CommandIO e = 74 | ( MonadBaseControl IO (Eff e), 75 | MonadIO (Eff e), 76 | Member LoggerReader e, 77 | Member B9ConfigReader e 78 | ) 79 | 80 | traceL :: CommandIO e => String -> Eff e () 81 | traceL = b9Log LogTrace 82 | 83 | dbgL :: CommandIO e => String -> Eff e () 84 | dbgL = b9Log LogDebug 85 | 86 | infoL :: CommandIO e => String -> Eff e () 87 | infoL = b9Log LogInfo 88 | 89 | errorL :: CommandIO e => String -> Eff e () 90 | errorL = b9Log LogError 91 | 92 | errorExitL :: (CommandIO e, Member ExcB9 e) => String -> Eff e a 93 | errorExitL e = b9Log LogError e >> throwB9Error e 94 | 95 | b9Log :: CommandIO e => LogLevel -> String -> Eff e () 96 | b9Log level msg = do 97 | lv <- getLogVerbosity 98 | lfh <- logFileHandle <$> ask 99 | liftIO $ logImpl lv lfh level msg 100 | 101 | logImpl :: Maybe LogLevel -> Maybe SysIO.Handle -> LogLevel -> String -> IO () 102 | logImpl minLevel mh level msg = do 103 | lm <- formatLogMsg level msg 104 | when (isJust minLevel && level >= fromJust minLevel) $ do 105 | putStr lm 106 | SysIO.hFlush SysIO.stdout 107 | when (isJust mh) $ do 108 | SysIO.hPutStr (fromJust mh) lm 109 | SysIO.hFlush (fromJust mh) 110 | 111 | formatLogMsg :: LogLevel -> String -> IO String 112 | formatLogMsg l msg = do 113 | u <- getCurrentTime 114 | let time = formatTime defaultTimeLocale "%H:%M:%S" u 115 | return $ unlines $ printf "[%s] %s - %s" (printLevel l) time <$> lines msg 116 | 117 | printLevel :: LogLevel -> String 118 | printLevel l = case l of 119 | LogNothing -> "NOTHING" 120 | LogError -> " ERROR " 121 | LogInfo -> " INFO " 122 | LogDebug -> " DEBUG " 123 | LogTrace -> " TRACE " 124 | 125 | printHash :: Hashable a => a -> String 126 | printHash = printf "%x" . hash 127 | -------------------------------------------------------------------------------- /src/lib/B9/B9Monad.hs: -------------------------------------------------------------------------------- 1 | module B9.B9Monad 2 | ( runB9, 3 | runB9Interactive, 4 | B9, 5 | B9Eff, 6 | IsB9, 7 | ) 8 | where 9 | 10 | import B9.B9Config 11 | import B9.B9Error 12 | import B9.B9Logging 13 | import B9.BuildInfo 14 | import B9.Environment 15 | import B9.Repository 16 | import B9.RepositoryIO 17 | import Control.Eff 18 | import Data.Functor () 19 | import GHC.Stack 20 | 21 | -- | Definition of the B9 monad. See 'B9Eff'. 22 | -- 23 | -- This module is used by the _effectful_ functions in this library. 24 | -- 25 | -- @since 0.5.65 26 | type B9 a = Eff B9Eff a 27 | 28 | -- | Definition of the B9 effect list. It encapsulates logging, 29 | -- a reader for the "B9.B9Config" and access to the 30 | -- current build id, the current build directory and the artifact to build. 31 | -- 32 | -- This monad is used by the _effectful_ functions in this library. 33 | -- 34 | -- @since 0.5.65 35 | type B9Eff = 36 | '[ SelectedRemoteRepoReader, 37 | RepoCacheReader, 38 | BuildInfoReader, 39 | LoggerReader, 40 | B9ConfigReader, 41 | EnvironmentReader, 42 | ExcB9, 43 | Lift 44 | IO 45 | ] 46 | 47 | -- | A constraint that contains all effects of 'B9Eff' 48 | -- 49 | -- @since 0.5.65 50 | type IsB9 e = (HasCallStack, Lifted IO e, CommandIO e, B9Eff <:: e) 51 | 52 | -- | Execute a 'B9' effect and return an action that needs 53 | -- the 'B9Config'. 54 | -- 55 | -- @since 0.5.65 56 | runB9 :: HasCallStack => B9 a -> B9ConfigAction a 57 | runB9 = runB9Full False 58 | 59 | -- | Execute a 'B9' effect like 'runB9' but run 60 | -- external commands, such as `systemd-nspawn`, 61 | -- /interactively/. 62 | -- 63 | -- When run /interactively/, the stdin/stdout of 64 | -- certain commands is inherited from the main process. 65 | -- 66 | -- @since 2.0.0 67 | runB9Interactive :: HasCallStack => B9 a -> B9ConfigAction a 68 | runB9Interactive = runB9Full True 69 | 70 | runB9Full :: HasCallStack => Bool -> B9 a -> B9ConfigAction a 71 | runB9Full interactive action = do 72 | cfg <- getB9Config 73 | env <- askEnvironment 74 | lift 75 | ( runLift 76 | . errorOnException 77 | . runEnvironmentReader env 78 | . runB9ConfigReader cfg 79 | . withLogger 80 | . withBuildInfo interactive 81 | . withRemoteRepos 82 | . withSelectedRemoteRepo 83 | $ action 84 | ) 85 | 86 | 87 | 88 | -------------------------------------------------------------------------------- /src/lib/B9/BuildInfo.hs: -------------------------------------------------------------------------------- 1 | -- | Provide information about the current build. 2 | -- 3 | -- This module provides build meta information like 4 | -- build directory, build-id and build-time. 5 | -- 6 | -- @since 0.5.65 7 | module B9.BuildInfo 8 | ( getBuildId, 9 | getBuildDate, 10 | getBuildDir, 11 | withBuildInfo, 12 | BuildInfoReader, 13 | isInteractive, 14 | ) 15 | where 16 | 17 | import B9.B9Config 18 | import B9.B9Error 19 | import B9.B9Logging 20 | import B9.Environment 21 | import Control.Eff 22 | import Control.Eff.Reader.Lazy 23 | import Control.Exception (bracket) 24 | import Control.Lens ((?~)) 25 | import Control.Monad 26 | import Control.Monad.IO.Class 27 | import Control.Monad.Trans.Control 28 | ( MonadBaseControl, 29 | control, 30 | ) 31 | import Data.Functor () 32 | import Data.Hashable 33 | import Data.Time.Clock 34 | import Data.Time.Format 35 | import GHC.Stack 36 | import System.Directory 37 | import System.FilePath 38 | import System.IO.B9Extras 39 | import Text.Printf 40 | 41 | -- | Build meta information. 42 | -- 43 | -- @since 0.5.65 44 | data BuildInfo 45 | = BuildInfo 46 | { bsBuildId :: String, 47 | bsBuildDate :: String, 48 | bsBuildDir :: FilePath, 49 | bsStartTime :: UTCTime, 50 | bsIsInteractive :: Bool 51 | } 52 | deriving (Eq, Show) 53 | 54 | -- | Type alias for a 'BuildInfo' 'Reader' 55 | -- 56 | -- @since 0.5.65 57 | type BuildInfoReader = Reader BuildInfo 58 | 59 | -- | Create the build directories, generate (hash) the build-id and execute the given action. 60 | -- 61 | -- Bindings added to the text template parameter environment: 62 | -- 63 | -- * @projectRoot@ the directory that contains the sources of the project to build 64 | -- * @buildDir@ the temporary directory used store the build artifacts passed into- or outof the build 65 | -- 66 | -- Unless '_keepTempDirs' is @True@ clean up the build directories after the actions 67 | -- returns - even if the action throws a runtime exception. 68 | -- 69 | -- @since 0.5.65 70 | withBuildInfo :: 71 | ( Lifted IO e, 72 | MonadBaseControl IO (Eff e), 73 | Member B9ConfigReader e, 74 | Member ExcB9 e, 75 | Member EnvironmentReader e, 76 | Member LoggerReader e, 77 | HasCallStack 78 | ) => 79 | Bool -> 80 | Eff (BuildInfoReader ': e) a -> 81 | Eff e a 82 | withBuildInfo interactive action = withRootDir $ do 83 | now <- lift getCurrentTime 84 | let buildDate = formatTime undefined "%F-%T" now -- TODO make configurable how the build date is formatted 85 | buildId <- generateBuildId 86 | withBuildDir buildId (runImpl buildId buildDate now) 87 | where 88 | withRootDir f = do 89 | mRoot <- _projectRoot <$> getB9Config 90 | root <- lift $ case mRoot of 91 | Nothing -> getCurrentDirectory >>= canonicalizePath 92 | Just rootIn -> do 93 | createDirectoryIfMissing True rootIn 94 | canonicalizePath rootIn 95 | localB9Config 96 | (projectRoot ?~ root) 97 | (addLocalStringBinding ("projectRoot", root) f) 98 | generateBuildId = do 99 | -- TODO generate a proper, reproducable build id! 100 | unqiueBuildDir <- _uniqueBuildDirs <$> getB9Config 101 | cfgHash <- hash . show <$> getB9Config 102 | actionHash <- hash . show <$> randomUUID -- TODO use the actual hash of the input 103 | if unqiueBuildDir 104 | then return (printf "%08X-%08X" cfgHash (hash actionHash)) 105 | else return (printf "%08X" cfgHash) 106 | withBuildDir buildId f = do 107 | root <- _projectRoot <$> getB9Config 108 | cfg <- getB9Config 109 | control $ \runInIO -> 110 | bracket (createBuildDir root) (removeBuildDir cfg) (runInIO . f) 111 | where 112 | createBuildDir root = do 113 | -- TODO allow config option to enable build dirs outside of the projectRoot 114 | let buildDir = case root of 115 | Just r -> r "BUILD-" ++ buildId 116 | Nothing -> "BUILD-" ++ buildId 117 | createDirectoryIfMissing True buildDir 118 | canonicalizePath buildDir 119 | removeBuildDir cfg buildDir = 120 | when (_uniqueBuildDirs cfg && not (_keepTempDirs cfg)) $ 121 | removeDirectoryRecursive buildDir 122 | runImpl buildId buildDate startTime buildDir = 123 | let ctx = BuildInfo buildId buildDate buildDir startTime interactive 124 | in runReader ctx wrappedAction 125 | where 126 | wrappedAction = do 127 | rootD <- getProjectRoot 128 | traceL (printf "Project Root Directory: %s" rootD) 129 | buildD <- getBuildDir 130 | traceL (printf "Build Directory: %s" buildD) 131 | r <- addLocalStringBinding ("buildDir", buildD) action 132 | tsAfter <- liftIO getCurrentTime 133 | let duration = show (tsAfter `diffUTCTime` startTime) 134 | infoL (printf "DURATION: %s" duration) 135 | return r 136 | 137 | -- Run the action build action 138 | getBuildId :: Member BuildInfoReader e => Eff e String 139 | getBuildId = bsBuildId <$> ask 140 | 141 | getBuildDate :: Member BuildInfoReader e => Eff e String 142 | getBuildDate = bsBuildDate <$> ask 143 | 144 | getBuildDir :: Member BuildInfoReader e => Eff e FilePath 145 | getBuildDir = bsBuildDir <$> ask 146 | 147 | -- | Ask whether @stdin@ of the @B9@ process should be redirected to the 148 | -- external commands executed during the build. 149 | -- 150 | -- @since 2.0.0 151 | isInteractive :: Member BuildInfoReader e => Eff e Bool 152 | isInteractive = bsIsInteractive <$> ask 153 | -------------------------------------------------------------------------------- /src/lib/B9/Container.hs: -------------------------------------------------------------------------------- 1 | -- | An interface for container backends such as libvirt-lxc or docker 2 | module B9.Container 3 | ( Backend (..), 4 | ) 5 | where 6 | 7 | import B9.B9Error 8 | import B9.B9Logging 9 | import B9.BuildInfo 10 | import B9.DiskImages 11 | import B9.ExecEnv 12 | import B9.ShellScript 13 | import Control.Eff 14 | 15 | -- | Class of backends that run a 'Script' in an 'ExecEnv' in an OS-level 16 | -- container like docker or lxc. 17 | class Backend config where 18 | -- | Return 'Nothing' if the configuration **disables** this container backend, 19 | -- and return 'Just ...' if the configuration **enables** this container backend. 20 | getBackendConfig :: 21 | forall proxy e. 22 | (Member BuildInfoReader e, CommandIO e) => 23 | proxy config -> 24 | Eff e (Maybe config) 25 | 26 | -- | The input images, that a given container accepts 27 | supportedImageTypes :: proxy config -> [ImageType] 28 | supportedImageTypes _ = [Raw] 29 | 30 | -- | Run a 'Script' in an 'ExecEnv', and return 'True' if the script 31 | -- completed successfully. 32 | runInEnvironment :: 33 | forall e. 34 | (Member BuildInfoReader e, CommandIO e, Member ExcB9 e) => 35 | config -> 36 | ExecEnv -> 37 | Script -> 38 | Eff e Bool 39 | -------------------------------------------------------------------------------- /src/lib/B9/Docker.hs: -------------------------------------------------------------------------------- 1 | -- | Implementation of an execution environment that uses /docker/. 2 | module B9.Docker 3 | ( Docker (..), 4 | ) 5 | where 6 | 7 | import B9.B9Config 8 | ( dockerConfigs, 9 | getB9Config, 10 | ) 11 | import B9.B9Config.Docker as X 12 | import B9.Container 13 | import B9.DiskImages 14 | import B9.ShellScript 15 | import Control.Lens (view) 16 | 17 | newtype Docker = Docker DockerConfig 18 | 19 | instance Backend Docker where 20 | getBackendConfig _ = 21 | fmap Docker . view dockerConfigs <$> getB9Config 22 | 23 | -- supportedImageTypes :: proxy config -> [ImageType] 24 | supportedImageTypes _ = [Raw] 25 | 26 | -- runInEnvironment :: 27 | -- forall e. 28 | -- (Member BuildInfoReader e, CommandIO e) => 29 | -- config -> 30 | -- ExecEnv -> 31 | -- Script -> 32 | -- Eff e Bool 33 | runInEnvironment (Docker _dcfg) _env scriptIn = do 34 | if emptyScript scriptIn 35 | then return True 36 | else do error "TODO" 37 | -- where 38 | -- setUp = do 39 | -- buildId <- getBuildId 40 | -- buildBaseDir <- getBuildDir 41 | -- uuid <- randomUUID 42 | -- let scriptDirHost = buildDir "init-script" 43 | -- scriptDirGuest = "/" ++ buildId 44 | -- domainFile = buildBaseDir uuid' <.> domainConfig 45 | -- mkDomain = 46 | -- createDomain cfgIn env buildId uuid' scriptDirHost scriptDirGuest 47 | -- uuid' = printf "%U" uuid 48 | -- setupEnv = 49 | -- Begin 50 | -- [ Run "export" ["HOME=/root"], 51 | -- Run "export" ["USER=root"], 52 | -- Run "source" ["/etc/profile"] 53 | -- ] 54 | -- script = Begin [setupEnv, scriptIn, successMarkerCmd scriptDirGuest] 55 | -- buildDir = buildBaseDir uuid' 56 | -- liftIO $ do 57 | -- createDirectoryIfMissing True scriptDirHost 58 | -- writeSh (scriptDirHost initScript) script 59 | -- domain <- mkDomain 60 | -- writeFile domainFile domain 61 | -- return $ Context scriptDirHost uuid domainFile cfgIn 62 | -------------------------------------------------------------------------------- /src/lib/B9/Environment.hs: -------------------------------------------------------------------------------- 1 | -- | An 'Environment' contains textual key value pairs, relavant for string template 2 | -- substitution. 3 | -- 4 | -- The variables are passed to the B9 build either via command line, OS environment 5 | -- variables or configuration file. 6 | -- 7 | -- @since 0.5.62 8 | module B9.Environment 9 | ( Environment (), 10 | fromStringPairs, 11 | addBinding, 12 | addStringBinding, 13 | addLocalStringBinding, 14 | addPositionalArguments, 15 | addLocalPositionalArguments, 16 | EnvironmentReader, 17 | hasKey, 18 | runEnvironmentReader, 19 | askEnvironment, 20 | localEnvironment, 21 | lookupOrThrow, 22 | lookupEither, 23 | KeyNotFound (..), 24 | DuplicateKey (..), 25 | ) 26 | where 27 | 28 | import B9.B9Error 29 | import B9.Text 30 | import Control.Arrow ((***)) 31 | import Control.Eff as Eff 32 | import Control.Eff.Reader.Lazy as Eff 33 | import Control.Exception (Exception) 34 | import Control.Parallel.Strategies 35 | import Data.Data 36 | import Data.Foldable 37 | import Data.HashMap.Strict (HashMap) 38 | import qualified Data.HashMap.Strict as HashMap 39 | import Data.Maybe 40 | ( isJust, 41 | maybe, 42 | ) 43 | import GHC.Generics (Generic) 44 | 45 | -- | A map of textual keys to textual values. 46 | -- 47 | -- @since 0.5.62 48 | data Environment 49 | = MkEnvironment 50 | { nextPosition :: Int, 51 | fromEnvironment :: HashMap Text Text 52 | } 53 | deriving (Show, Typeable, Data, Eq, Generic) 54 | 55 | instance NFData Environment 56 | 57 | instance Semigroup Environment where 58 | e1 <> e2 = 59 | MkEnvironment 60 | { nextPosition = case (nextPosition e1, nextPosition e2) of 61 | (1, 1) -> 1 62 | (1, p2) -> p2 63 | (p1, 1) -> p1 64 | _ -> 65 | error 66 | ( "Overlapping positional arguments (<>): (" 67 | ++ show e1 68 | ++ ") <> (" 69 | ++ show e2 70 | ++ ")" 71 | ), 72 | fromEnvironment = 73 | let i = HashMap.intersection h1 h2 74 | h1 = fromEnvironment e1 75 | h2 = fromEnvironment e2 76 | in if HashMap.null i 77 | || all 78 | ( \k -> HashMap.lookup k h1 == HashMap.lookup k h2 79 | ) 80 | (HashMap.keys i) 81 | then h1 <> h2 82 | else 83 | error 84 | ( "Overlapping entries (<>): (" 85 | ++ show e1 86 | ++ ") <> (" 87 | ++ show e2 88 | ++ "): (" 89 | ++ show i 90 | ++ ")" 91 | ) 92 | } 93 | 94 | instance Monoid Environment where 95 | mempty = MkEnvironment 1 HashMap.empty 96 | 97 | -- | If environment variables @arg_1 .. arg_n@ are bound 98 | -- and a list of @k@ additional values are passed to this function, 99 | -- store them with keys @arg_(n+1) .. arg_(n+k)@. 100 | -- 101 | -- Note that the Environment contains an index of the next position. 102 | -- 103 | -- @since 0.5.62 104 | addPositionalArguments :: [Text] -> Environment -> Environment 105 | addPositionalArguments = 106 | flip 107 | ( foldl' 108 | ( \(MkEnvironment i e) arg -> 109 | MkEnvironment 110 | (i + 1) 111 | (HashMap.insert (unsafeRenderToText ("arg_" ++ show i)) arg e) 112 | ) 113 | ) 114 | 115 | -- | Convenient wrapper around 'addPositionalArguments' and 'localEnvironment'. 116 | -- 117 | -- @since 0.5.65 118 | addLocalPositionalArguments :: 119 | Member EnvironmentReader e => [String] -> Eff e a -> Eff e a 120 | addLocalPositionalArguments extraPositional = localEnvironment appendVars 121 | where 122 | appendVars = addPositionalArguments (unsafeRenderToText <$> extraPositional) 123 | 124 | -- | Create an 'Environment' from a list of pairs ('String's). 125 | -- Duplicated entries are ignored. 126 | -- 127 | -- @since 0.5.62 128 | fromStringPairs :: [(String, String)] -> Environment 129 | fromStringPairs = 130 | MkEnvironment 0 . HashMap.fromList 131 | . fmap 132 | (unsafeRenderToText *** unsafeRenderToText) 133 | 134 | -- | Insert a key value binding to the 'Environment'. 135 | -- 136 | -- Throw 'DuplicateKey' if the key already exists, but 137 | -- the value is not equal to the given value. 138 | -- 139 | -- @since 0.5.67 140 | addBinding :: Member ExcB9 e => (Text, Text) -> Environment -> Eff e Environment 141 | addBinding (k, vNew) env = 142 | let h = fromEnvironment env 143 | in case HashMap.lookup k h of 144 | Just vOld 145 | | vOld /= vNew -> 146 | throwSomeException (MkDuplicateKey k vOld vNew) 147 | _ -> pure (MkEnvironment (nextPosition env) (HashMap.insert k vNew h)) 148 | 149 | -- | Insert 'String's into the 'Environment', see 'addBinding'. 150 | -- 151 | -- @since 0.5.62 152 | addStringBinding :: 153 | Member ExcB9 e => (String, String) -> Environment -> Eff e Environment 154 | addStringBinding = addBinding . (unsafeRenderToText *** unsafeRenderToText) 155 | 156 | -- | Insert a value into an 'Environment' like 'addStringBinding', 157 | -- but add it to the environment of the given effect, as in 'localEnvironment'. 158 | -- 159 | -- @since 0.5.65 160 | addLocalStringBinding :: 161 | (Member EnvironmentReader e, Member ExcB9 e) => 162 | (String, String) -> 163 | Eff e a -> 164 | Eff e a 165 | addLocalStringBinding binding action = do 166 | e <- askEnvironment 167 | e' <- addStringBinding binding e 168 | localEnvironment (const e') action 169 | 170 | -- | A monad transformer providing a 'MonadReader' instance for 'Environment' 171 | -- 172 | -- @since 0.5.62 173 | type EnvironmentReader = Reader Environment 174 | 175 | -- | Run a 'ReaderT' of 'Environment'. 176 | -- 177 | -- @since 0.5.62 178 | runEnvironmentReader :: Environment -> Eff (EnvironmentReader ': e) a -> Eff e a 179 | runEnvironmentReader = runReader 180 | 181 | -- | Get the current 'Environment' 182 | -- 183 | -- @since 0.5.62 184 | askEnvironment :: Member EnvironmentReader e => Eff e Environment 185 | askEnvironment = ask 186 | 187 | -- | Run a computation with a modified 'Environment' 188 | -- 189 | -- @since 0.5.62 190 | localEnvironment :: 191 | Member EnvironmentReader e => 192 | (Environment -> Environment) -> 193 | Eff e a -> 194 | Eff e a 195 | localEnvironment = local 196 | 197 | -- | Lookup a key for a value. 198 | -- 199 | -- 'throwM' a 'KeyNotFound' 'Exception' if no value with the given key exists 200 | -- in the 'Environment'. 201 | -- 202 | -- @Since 0.5.62 203 | lookupOrThrow :: ('[ExcB9, EnvironmentReader] <:: e) => Text -> Eff e Text 204 | lookupOrThrow key = do 205 | env <- askEnvironment 206 | maybe 207 | (throwSomeException (MkKeyNotFound key env)) 208 | return 209 | (HashMap.lookup key (fromEnvironment env)) 210 | 211 | -- | Lookup a key for a value. 212 | -- 213 | -- Return 'Either' 'Left' 'KeyNotFound', if no value with the given key exists 214 | -- in the 'Environment', or 'Right' the value. 215 | -- 216 | -- @Since 0.5.62 217 | lookupEither :: 218 | Member EnvironmentReader e => Text -> Eff e (Either KeyNotFound Text) 219 | lookupEither key = do 220 | env <- askEnvironment 221 | (return . maybe (Left (MkKeyNotFound key env)) Right) 222 | (HashMap.lookup key (fromEnvironment env)) 223 | 224 | -- | An 'Exception' thrown by 'addBinding' indicating that a key already exists. 225 | -- 226 | -- @Since 0.5.62 227 | data DuplicateKey 228 | = MkDuplicateKey 229 | { duplicateKey :: Text, 230 | duplicateKeyOldValue :: Text, 231 | duplicateKeyNewValue :: Text 232 | } 233 | deriving (Typeable, Show, Eq) 234 | 235 | instance Exception DuplicateKey 236 | 237 | -- | An 'Exception' thrown by 'lookupOrThrow' indicating that a key does not exist. 238 | -- 239 | -- @Since 0.5.62 240 | data KeyNotFound 241 | = MkKeyNotFound 242 | Text 243 | Environment 244 | deriving (Typeable, Eq) 245 | 246 | instance Exception KeyNotFound 247 | 248 | instance Show KeyNotFound where 249 | showsPrec _ (MkKeyNotFound key env) = 250 | let keys = 251 | unlines (unsafeParseFromText <$> HashMap.keys (fromEnvironment env)) 252 | in showString "Invalid template parameter: \"" 253 | . showString (unsafeParseFromText key) 254 | . showString "\".\nValid variables:\n" 255 | . showString keys 256 | 257 | -- | A predicate that is satisfied when a key exists in the environment. 258 | -- 259 | -- @since 0.5.64 260 | hasKey :: Member EnvironmentReader e => Text -> Eff e Bool 261 | hasKey k = isJust . HashMap.lookup k . fromEnvironment <$> askEnvironment 262 | -------------------------------------------------------------------------------- /src/lib/B9/ExecEnv.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | 3 | -- | Data types describing the execution environment 4 | -- of virtual machine builds. 5 | -- 'ExecEnv', 'Resources' and 'SharedDirectory' describe how 6 | -- "B9.LibVirtLXC" should configure and execute 7 | -- build scripts, as defined in "B9.ShellScript" and "B9.Vm". 8 | module B9.ExecEnv 9 | ( ExecEnv (..), 10 | Resources (..), 11 | noResources, 12 | SharedDirectory (..), 13 | CPUArch (..), 14 | RamSize (..), 15 | ) 16 | where 17 | 18 | import B9.DiskImages 19 | import Control.Parallel.Strategies 20 | import Data.Binary 21 | import Data.Data 22 | import Data.Hashable 23 | import Data.Semigroup as Sem 24 | import GHC.Generics (Generic) 25 | 26 | -- | The environment for the execution of 'Script's inside a 'Container' 27 | data ExecEnv 28 | = ExecEnv 29 | { envName :: String, 30 | envImageMounts :: [Mounted Image], 31 | envSharedDirectories :: [SharedDirectory], 32 | envResources :: Resources 33 | } 34 | deriving (Read, Show, Typeable, Data, Eq, Generic) 35 | 36 | instance Hashable ExecEnv 37 | 38 | instance Binary ExecEnv 39 | 40 | instance NFData ExecEnv 41 | 42 | data SharedDirectory 43 | = SharedDirectory 44 | FilePath 45 | MountPoint 46 | | SharedDirectoryRO 47 | FilePath 48 | MountPoint 49 | | SharedSources MountPoint 50 | deriving (Read, Show, Typeable, Data, Eq, Generic) 51 | 52 | instance Hashable SharedDirectory 53 | 54 | instance Binary SharedDirectory 55 | 56 | instance NFData SharedDirectory 57 | 58 | data Resources 59 | = Resources 60 | { maxMemory :: RamSize, 61 | cpuCount :: Int, 62 | cpuArch :: CPUArch 63 | } 64 | deriving (Eq, Read, Show, Typeable, Data, Generic) 65 | 66 | instance Hashable Resources 67 | 68 | instance Binary Resources 69 | 70 | instance NFData Resources 71 | 72 | instance Sem.Semigroup Resources where 73 | (<>) (Resources m c a) (Resources m' c' a') = 74 | Resources (m <> m') (max c c') (a <> a') 75 | 76 | instance Monoid Resources where 77 | mempty = Resources mempty 1 mempty 78 | mappend = (Sem.<>) 79 | 80 | noResources :: Resources 81 | noResources = mempty 82 | 83 | data CPUArch 84 | = X86_64 85 | | I386 86 | deriving (Read, Show, Typeable, Data, Eq, Generic) 87 | 88 | instance Hashable CPUArch 89 | 90 | instance Binary CPUArch 91 | 92 | instance NFData CPUArch 93 | 94 | instance Sem.Semigroup CPUArch where 95 | I386 <> x = x 96 | X86_64 <> _ = X86_64 97 | 98 | instance Monoid CPUArch where 99 | mempty = I386 100 | mappend = (Sem.<>) 101 | 102 | data RamSize 103 | = RamSize 104 | Int 105 | SizeUnit 106 | | AutomaticRamSize 107 | deriving (Eq, Read, Show, Ord, Typeable, Data, Generic) 108 | 109 | instance Hashable RamSize 110 | 111 | instance Binary RamSize 112 | 113 | instance NFData RamSize 114 | 115 | instance Sem.Semigroup RamSize where 116 | AutomaticRamSize <> x = x 117 | x <> AutomaticRamSize = x 118 | r <> r' = max r r' 119 | 120 | instance Monoid RamSize where 121 | mempty = AutomaticRamSize 122 | mappend = (Sem.<>) 123 | -------------------------------------------------------------------------------- /src/lib/B9/MBR.hs: -------------------------------------------------------------------------------- 1 | -- | Utility module to extract a primary partition from an MBR partition on a 2 | -- raw image file. 3 | module B9.MBR 4 | ( getPartition, 5 | PrimaryPartition (..), 6 | MBR (..), 7 | CHS (..), 8 | ) 9 | where 10 | 11 | import Data.Binary.Get 12 | import qualified Data.ByteString.Lazy as BL 13 | import Data.Word 14 | import Text.Printf 15 | 16 | getPartition :: Int -> FilePath -> IO (Word64, Word64) 17 | getPartition n f = decodeMBR <$> BL.readFile f 18 | where 19 | decodeMBR input = 20 | let mbr = runGet getMBR input 21 | part = 22 | ( case n of 23 | 1 -> mbrPart1 24 | 2 -> mbrPart2 25 | 3 -> mbrPart3 26 | 4 -> mbrPart4 27 | b -> 28 | error 29 | ( printf 30 | "Error: Invalid partition index %i only partitions 1-4 are allowed. Image file: '%s'" 31 | b 32 | f 33 | ) 34 | ) 35 | mbr 36 | start = fromIntegral (primPartLbaStart part) 37 | len = fromIntegral (primPartSectors part) 38 | in (start * sectorSize, len * sectorSize) 39 | 40 | sectorSize :: Word64 41 | sectorSize = 512 42 | 43 | bootCodeSize :: Int 44 | bootCodeSize = 446 45 | 46 | data MBR 47 | = MBR 48 | { mbrPart1 :: !PrimaryPartition, 49 | mbrPart2 :: !PrimaryPartition, 50 | mbrPart3 :: !PrimaryPartition, 51 | mbrPart4 :: !PrimaryPartition 52 | } 53 | deriving (Show) 54 | 55 | data PrimaryPartition 56 | = PrimaryPartition 57 | { primPartStatus :: !Word8, 58 | primPartChsStart :: !CHS, 59 | primPartPartType :: !Word8, 60 | primPartChsEnd :: !CHS, 61 | primPartLbaStart :: !Word32, 62 | primPartSectors :: !Word32 63 | } 64 | deriving (Show) 65 | 66 | data CHS 67 | = CHS 68 | { chsH :: !Word8, 69 | chs_CUpper2_S :: !Word8, 70 | chs_CLower8 :: !Word8 71 | } 72 | deriving (Show) 73 | 74 | getMBR :: Get MBR 75 | getMBR = 76 | skip bootCodeSize >> MBR <$> getPart <*> getPart <*> getPart <*> getPart 77 | 78 | getPart :: Get PrimaryPartition 79 | getPart = 80 | PrimaryPartition 81 | <$> getWord8 82 | <*> getCHS 83 | <*> getWord8 84 | <*> getCHS 85 | <*> getWord32le 86 | <*> getWord32le 87 | 88 | getCHS :: Get CHS 89 | getCHS = CHS <$> getWord8 <*> getWord8 <*> getWord8 90 | -------------------------------------------------------------------------------- /src/lib/B9/PartitionTable.hs: -------------------------------------------------------------------------------- 1 | -- | Function to find the file offsets of primary partitions in raw disk 2 | -- images. Currently only MBR partitions are supported. See 'B9.MBR' 3 | module B9.PartitionTable 4 | ( getPartition, 5 | ) 6 | where 7 | 8 | import qualified B9.MBR as MBR 9 | import Data.Word (Word64) 10 | 11 | getPartition :: Int -> FilePath -> IO (Word64, Word64, Word64) 12 | getPartition partitionIndex diskImage = 13 | blockSized <$> MBR.getPartition partitionIndex diskImage 14 | 15 | blockSized :: (Integral a) => (a, a) -> (a, a, a) 16 | blockSized (s, l) = let bs = gcd2 1 s l in (s `div` bs, l `div` bs, bs) 17 | where 18 | gcd2 n x y = 19 | let next = 2 * n 20 | in if x `rem` next == 0 && y `rem` next == 0 then gcd2 next x y else n 21 | -------------------------------------------------------------------------------- /src/lib/B9/Podman.hs: -------------------------------------------------------------------------------- 1 | -- | Implementation of an execution environment that uses /podman/. 2 | module B9.Podman 3 | ( Podman (..), 4 | ) 5 | where 6 | 7 | import B9.B9Config 8 | ( getB9Config, 9 | podmanConfigs, 10 | ) 11 | import B9.B9Config.Podman as X 12 | import B9.Container 13 | import B9.DiskImages 14 | import B9.ShellScript 15 | import Control.Lens (view) 16 | 17 | newtype Podman = Podman PodmanConfig 18 | 19 | instance Backend Podman where 20 | getBackendConfig _ = 21 | fmap Podman . view podmanConfigs <$> getB9Config 22 | 23 | -- supportedImageTypes :: proxy config -> [ImageType] 24 | supportedImageTypes _ = [Raw] 25 | 26 | -- runInEnvironment :: 27 | -- forall e. 28 | -- (Member BuildInfoReader e, CommandIO e) => 29 | -- config -> 30 | -- ExecEnv -> 31 | -- Script -> 32 | -- Eff e Bool 33 | runInEnvironment (Podman _dcfg) _env scriptIn = do 34 | if emptyScript scriptIn 35 | then return True 36 | else do error "TODO" 37 | -------------------------------------------------------------------------------- /src/lib/B9/QCUtil.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Some QuickCheck utility functions. 3 | module B9.QCUtil where 4 | 5 | import Control.Monad 6 | import Test.QuickCheck 7 | 8 | arbitraryEnv :: Arbitrary a => Gen [(String, a)] 9 | arbitraryEnv = listOf ((,) <$> listOf1 (choose ('a', 'z')) <*> arbitrary) 10 | 11 | halfSize :: Gen a -> Gen a 12 | halfSize g = sized (flip resize g . flip div 2) 13 | 14 | smaller :: Gen a -> Gen a 15 | smaller g = sized (flip resize g . max 0 . flip (-) 1) 16 | 17 | arbitraryFilePath :: Gen FilePath 18 | arbitraryFilePath = do 19 | path <- 20 | join 21 | <$> listOf 22 | ( elements 23 | [ "/", 24 | "../", 25 | "./", 26 | "etc/", 27 | "opt/", 28 | "user/", 29 | "var/", 30 | "tmp/", 31 | "doc/", 32 | "share/", 33 | "conf.d/" 34 | ] 35 | ) 36 | prefix <- elements ["foo_", "", "alt_", "ssh-", ""] 37 | body <- elements ["www", "passwd", "cert", "opnsfe", "runtime"] 38 | extension <- elements [".txt", ".png", ".ps", ".erl", ""] 39 | return (path ++ prefix ++ body ++ extension) 40 | 41 | arbitraryLetter :: Gen Char 42 | arbitraryLetter = oneof [arbitraryLetterUpper, arbitraryLetterLower] 43 | 44 | arbitraryLetterUpper :: Gen Char 45 | arbitraryLetterUpper = elements ['A' .. 'Z'] 46 | 47 | arbitraryLetterLower :: Gen Char 48 | arbitraryLetterLower = elements ['a' .. 'z'] 49 | 50 | arbitraryDigit :: Gen Char 51 | arbitraryDigit = elements ['0' .. '9'] 52 | -------------------------------------------------------------------------------- /src/lib/B9/Shake.hs: -------------------------------------------------------------------------------- 1 | -- | A module that re-exports all B9 Shake integration. 2 | -- Which by the way is crude and preliminary... 3 | module B9.Shake 4 | ( module X, 5 | ) 6 | where 7 | 8 | import B9.Shake.Actions as X 9 | import B9.Shake.SharedImageRules as X 10 | -------------------------------------------------------------------------------- /src/lib/B9/Shake/Actions.hs: -------------------------------------------------------------------------------- 1 | -- | Convenient Shake 'Action's for 'B9' rules. 2 | module B9.Shake.Actions 3 | ( b9InvocationAction, 4 | buildB9File, 5 | ) 6 | where 7 | 8 | import B9 9 | import Control.Lens ((?~)) 10 | import Development.Shake 11 | import GHC.Stack 12 | 13 | -- | Convert a 'B9ConfigAction' action into a Shake 'Action'. This is just 14 | -- an alias for 'runB9ConfigActionWithOverrides' since 'Action' is an instance of 'MonadIO' 15 | -- and 'runB9ConfigActionWithOverrides' work on any . 16 | b9InvocationAction :: HasCallStack => B9ConfigAction a -> B9ConfigOverride -> Action a 17 | b9InvocationAction x y = liftIO (runB9ConfigActionWithOverrides x y) 18 | 19 | -- | An action that does the equivalent of 20 | -- @b9c build -f -- (args !! 0) (args !! 1) ... (args !! (length args - 1))@ 21 | -- with the current working directory changed to @b9Root@. 22 | -- The return value is the buildid, see 'getBuildId' 23 | buildB9File :: HasCallStack => FilePath -> FilePath -> [String] -> Action String 24 | buildB9File b9Root b9File args = do 25 | let f = b9Root b9File 26 | need [f] 27 | liftIO 28 | ( runB9ConfigAction 29 | ( addLocalPositionalArguments 30 | args 31 | (localB9Config (projectRoot ?~ b9Root) (runBuildArtifacts [f])) 32 | ) 33 | ) 34 | -------------------------------------------------------------------------------- /src/lib/B9/Shake/SharedImageRules.hs: -------------------------------------------------------------------------------- 1 | -- | A crude, unsafe and preliminary solution to building B9 'SharedImage's 2 | -- from Shake. 3 | module B9.Shake.SharedImageRules 4 | ( customSharedImageAction, 5 | needSharedImage, 6 | enableSharedImageRules, 7 | ) 8 | where 9 | 10 | import B9 11 | import qualified Data.Binary as Binary 12 | import qualified Data.ByteString.Char8 as ByteString 13 | import qualified Data.ByteString.Lazy.Char8 as LazyByteString 14 | import Development.Shake 15 | import Development.Shake.Classes 16 | import Development.Shake.Rule 17 | import GHC.Stack 18 | 19 | -- | In order to use 'needSharedImage' and 'customSharedImageAction' you need to 20 | -- call this action before using any of the aforementioned 'Rules'. 21 | enableSharedImageRules :: HasCallStack => B9ConfigOverride -> Rules () 22 | enableSharedImageRules b9inv = addBuiltinRule noLint noIdentity go 23 | where 24 | go :: BuiltinRun SharedImageName SharedImageBuildId 25 | go nameQ mOldBIdBinary dependenciesChanged = do 26 | mCurrentBId <- getImgBuildId 27 | let mCurrentBIdBinary = encodeBuildId <$> mCurrentBId 28 | putLoud $ 29 | "share image rule for: " 30 | ++ show nameQ 31 | ++ ". Deps: " 32 | ++ show dependenciesChanged 33 | ++ ", current BId: " 34 | ++ show mCurrentBId 35 | ++ " Binary: " 36 | ++ show mCurrentBIdBinary 37 | ++ ", old BId: " 38 | ++ show mOldBIdBinary 39 | case mCurrentBIdBinary of 40 | Just currentBIdBinary -> 41 | if dependenciesChanged == RunDependenciesSame && mOldBIdBinary == Just currentBIdBinary 42 | then return $ RunResult ChangedNothing currentBIdBinary (fromJust mCurrentBId) 43 | else rebuild (Just currentBIdBinary) 44 | Nothing -> rebuild Nothing 45 | where 46 | getImgBuildId = liftIO (runB9ConfigActionWithOverrides (runLookupLocalSharedImage nameQ) b9inv) 47 | encodeBuildId :: SharedImageBuildId -> ByteString.ByteString 48 | encodeBuildId = LazyByteString.toStrict . Binary.encode 49 | rebuild :: Maybe ByteString.ByteString -> Action (RunResult SharedImageBuildId) 50 | rebuild mCurrentBIdBinary = do 51 | (_, act) <- getUserRuleOne nameQ (const Nothing) imgMatch 52 | _ <- act b9inv 53 | mNewBId <- getImgBuildId 54 | newBId <- 55 | maybe 56 | (error ("failed to get SharedImageBuildId for " ++ show nameQ ++ " in context of " ++ show b9inv)) 57 | return 58 | mNewBId 59 | let newBIdBinary = encodeBuildId newBId 60 | let change = 61 | if Just newBIdBinary == mCurrentBIdBinary 62 | then ChangedRecomputeSame 63 | else ChangedRecomputeDiff 64 | return $ RunResult change newBIdBinary newBId 65 | where 66 | imgMatch (SharedImageCustomActionRule name mkImage) = 67 | if name == nameQ 68 | then Just mkImage 69 | else Nothing 70 | 71 | -- | Add a dependency to the creation of a 'SharedImage'. The build action 72 | -- for the shared image must have been supplied by e.g. 'customSharedImageAction'. 73 | -- NOTE: You must call 'enableSharedImageRules' before this action works. 74 | needSharedImage :: HasCallStack => SharedImageName -> Action SharedImageBuildId 75 | needSharedImage = apply1 76 | 77 | -- | Specify an arbitrary action that is supposed to build the given shared 78 | -- image identified by a 'SharedImageName'. 79 | -- NOTE: You must call 'enableSharedImageRules' before this action works. 80 | customSharedImageAction :: HasCallStack => SharedImageName -> Action () -> Rules () 81 | customSharedImageAction b9img customAction = addUserRule (SharedImageCustomActionRule b9img customAction') 82 | where 83 | customAction' b9inv = do 84 | customAction 85 | mCurrentBuildId <- liftIO (runB9ConfigActionWithOverrides (runLookupLocalSharedImage b9img) b9inv) 86 | putLoud (printf "Finished custom action, for %s, build-id is: %s" (show b9img) (show mCurrentBuildId)) 87 | maybe (errorSharedImageNotFound b9img) return mCurrentBuildId 88 | 89 | type instance RuleResult SharedImageName = SharedImageBuildId 90 | 91 | data SharedImageCustomActionRule 92 | = SharedImageCustomActionRule 93 | SharedImageName 94 | (B9ConfigOverride -> Action SharedImageBuildId) 95 | deriving (Typeable) 96 | 97 | errorSharedImageNotFound :: (HasCallStack, Monad m) => SharedImageName -> m a 98 | errorSharedImageNotFound = error . printf "Error: %s not found." . show 99 | -------------------------------------------------------------------------------- /src/lib/B9/ShellScript.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | 3 | -- | Definition of 'Script' and functions to convert 'Script's to bash 4 | -- scripts. 5 | module B9.ShellScript 6 | ( writeSh, 7 | renderScript, 8 | emptyScript, 9 | CmdVerbosity (..), 10 | Cwd (..), 11 | User (..), 12 | Script (..), 13 | ) 14 | where 15 | 16 | import Control.Monad.Reader 17 | import Control.Parallel.Strategies 18 | import Data.Binary 19 | import Data.Data 20 | import Data.Hashable 21 | import Data.List (intercalate) 22 | import Data.Semigroup as Sem 23 | import GHC.Generics (Generic) 24 | import System.Directory 25 | ( getPermissions, 26 | setOwnerExecutable, 27 | setPermissions, 28 | ) 29 | 30 | data Script 31 | = In 32 | FilePath 33 | [Script] 34 | | As 35 | String 36 | [Script] 37 | | IgnoreErrors 38 | Bool 39 | [Script] 40 | | Verbosity 41 | CmdVerbosity 42 | [Script] 43 | | Begin [Script] 44 | | Run 45 | FilePath 46 | [String] 47 | | NoOP 48 | deriving (Show, Read, Typeable, Data, Eq, Generic) 49 | 50 | instance Hashable Script 51 | 52 | instance Binary Script 53 | 54 | instance NFData Script 55 | 56 | instance Sem.Semigroup Script where 57 | NoOP <> s = s 58 | s <> NoOP = s 59 | (Begin ss) <> (Begin ss') = Begin (ss ++ ss') 60 | (Begin ss) <> s' = Begin (ss ++ [s']) 61 | s <> (Begin ss') = Begin (s : ss') 62 | s <> s' = Begin [s, s'] 63 | 64 | instance Monoid Script where 65 | mempty = NoOP 66 | mappend = (Sem.<>) 67 | 68 | data Cmd 69 | = Cmd 70 | String 71 | [String] 72 | User 73 | Cwd 74 | Bool 75 | CmdVerbosity 76 | deriving (Show, Read, Typeable, Data, Eq, Generic) 77 | 78 | instance Hashable Cmd 79 | 80 | instance Binary Cmd 81 | 82 | instance NFData Cmd 83 | 84 | data CmdVerbosity 85 | = Debug 86 | | Verbose 87 | | OnlyStdErr 88 | | Quiet 89 | deriving (Show, Read, Typeable, Data, Eq, Generic) 90 | 91 | instance Hashable CmdVerbosity 92 | 93 | instance Binary CmdVerbosity 94 | 95 | instance NFData CmdVerbosity 96 | 97 | data Cwd 98 | = Cwd FilePath 99 | | NoCwd 100 | deriving (Show, Read, Typeable, Data, Eq, Generic) 101 | 102 | instance Hashable Cwd 103 | 104 | instance Binary Cwd 105 | 106 | instance NFData Cwd 107 | 108 | data User 109 | = User String 110 | | NoUser 111 | deriving (Show, Read, Typeable, Data, Eq, Generic) 112 | 113 | instance Hashable User 114 | 115 | instance Binary User 116 | 117 | instance NFData User 118 | 119 | data Ctx 120 | = Ctx 121 | { ctxCwd :: Cwd, 122 | ctxUser :: User, 123 | ctxIgnoreErrors :: Bool, 124 | ctxVerbosity :: CmdVerbosity 125 | } 126 | deriving (Show, Read, Typeable, Data, Eq, Generic) 127 | 128 | instance Hashable Ctx 129 | 130 | instance Binary Ctx 131 | 132 | instance NFData Ctx 133 | 134 | -- | Convert 'script' to bash-shell-script written to 'file' and make 'file' 135 | -- executable. 136 | writeSh :: FilePath -> Script -> IO () 137 | writeSh file script = do 138 | writeFile file (renderScript script) 139 | getPermissions file >>= setPermissions file . setOwnerExecutable True 140 | 141 | -- | Check if a script has the same effect as 'NoOP' 142 | emptyScript :: Script -> Bool 143 | emptyScript = null . toCmds 144 | 145 | toCmds :: Script -> [Cmd] 146 | toCmds s = runReader (toLLC s) (Ctx NoCwd NoUser False Debug) 147 | where 148 | toLLC :: Script -> Reader Ctx [Cmd] 149 | toLLC NoOP = return [] 150 | toLLC (In d cs) = local (\ctx -> ctx {ctxCwd = Cwd d}) (toLLC (Begin cs)) 151 | toLLC (As u cs) = 152 | local (\ctx -> ctx {ctxUser = User u}) (toLLC (Begin cs)) 153 | toLLC (IgnoreErrors b cs) = 154 | local (\ctx -> ctx {ctxIgnoreErrors = b}) (toLLC (Begin cs)) 155 | toLLC (Verbosity v cs) = 156 | local (\ctx -> ctx {ctxVerbosity = v}) (toLLC (Begin cs)) 157 | toLLC (Begin cs) = concat <$> mapM toLLC cs 158 | toLLC (Run cmd args) = do 159 | c <- reader ctxCwd 160 | u <- reader ctxUser 161 | i <- reader ctxIgnoreErrors 162 | v <- reader ctxVerbosity 163 | return [Cmd cmd args u c i v] 164 | 165 | renderScript :: Script -> String 166 | renderScript = toBash . toCmds 167 | 168 | toBash :: [Cmd] -> String 169 | toBash cmds = intercalate "\n\n" $ bashHeader ++ (cmdToBash <$> cmds) 170 | 171 | bashHeader :: [String] 172 | bashHeader = ["#!/usr/bin/env bash", "set -e"] 173 | 174 | cmdToBash :: Cmd -> String 175 | cmdToBash (Cmd cmd args user cwd ignoreErrors verbosity) = 176 | intercalate "\n" $ 177 | disableErrorChecking 178 | ++ pushd cwdQ 179 | ++ execCmd 180 | ++ popd cwdQ 181 | ++ reenableErrorChecking 182 | where 183 | execCmd = [unwords (runuser ++ [cmd] ++ args ++ redirectOutput)] 184 | where 185 | runuser = case user of 186 | NoUser -> [] 187 | User "root" -> [] 188 | User u -> ["runuser", "-p", "-u", u, "--"] 189 | pushd NoCwd = [] 190 | pushd (Cwd cwdPath) = [unwords (["pushd", cwdPath] ++ redirectOutput)] 191 | popd NoCwd = [] 192 | popd (Cwd cwdPath) = 193 | [unwords (["popd"] ++ redirectOutput ++ ["#", cwdPath])] 194 | disableErrorChecking = ["set +e" | ignoreErrors] 195 | reenableErrorChecking = ["set -e" | ignoreErrors] 196 | cwdQ = case cwd of 197 | NoCwd -> NoCwd 198 | Cwd d -> Cwd ("'" ++ d ++ "'") 199 | redirectOutput = case verbosity of 200 | Debug -> [] 201 | Verbose -> [] 202 | OnlyStdErr -> [">", "/dev/null"] 203 | Quiet -> ["&>", "/dev/null"] 204 | -------------------------------------------------------------------------------- /src/lib/B9/Text.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE TypeSynonymInstances #-} 3 | 4 | -- | This module enables debugging all 'ByteString' to 'Text' to 'String' conversions. 5 | -- This is an internal module. 6 | -- 7 | -- @since 0.5.67 8 | module B9.Text 9 | ( Text, 10 | LazyText, 11 | ByteString, 12 | LazyByteString, 13 | Textual (..), 14 | writeTextFile, 15 | unsafeRenderToText, 16 | unsafeParseFromText, 17 | parseFromTextWithErrorMessage, 18 | encodeAsUtf8LazyByteString, 19 | ) 20 | where 21 | 22 | import Control.Exception (displayException) 23 | -- import qualified Data.ByteString as Strict 24 | 25 | -- import qualified Data.Text.Encoding.Error as Text 26 | import Control.Monad.IO.Class 27 | import Data.ByteString (ByteString) 28 | import qualified Data.ByteString.Lazy as LazyByteString 29 | import qualified Data.Text as Text 30 | import Data.Text (Text) 31 | import qualified Data.Text.Encoding as Text 32 | import qualified Data.Text.IO as Text 33 | import qualified Data.Text.Lazy as LazyText 34 | import qualified Data.Text.Lazy.Encoding as LazyText 35 | import GHC.Stack 36 | 37 | -- | Lazy byte strings. 38 | -- 39 | -- A type alias to 'Lazy.ByteString' that can be used everywhere such that 40 | -- references don't need to be qualified with the complete module name everywere. 41 | -- 42 | -- @since 0.5.67 43 | type LazyByteString = LazyByteString.ByteString 44 | 45 | -- | Lazy texts. 46 | -- 47 | -- A type alias to 'LazyText.Text' that can be used everywhere such that 48 | -- references don't need to be qualified with the complete module name everywere. 49 | -- 50 | -- @since 0.5.67 51 | type LazyText = LazyText.Text 52 | 53 | -- | A class for values that can be converted to/from 'Text'. 54 | -- 55 | -- @since 0.5.67 56 | class Textual a where 57 | -- | Convert a 'String' to 'Text' 58 | -- If an error occured, return 'Left' with the error message. 59 | -- 60 | -- @since 0.5.67 61 | renderToText :: HasCallStack => a -> Either String Text 62 | 63 | -- | Convert a 'Text' to 'String' 64 | -- 65 | -- @since 0.5.67 66 | parseFromText :: HasCallStack => Text -> Either String a 67 | 68 | instance Textual Text where 69 | renderToText = Right 70 | parseFromText = Right 71 | 72 | instance Textual String where 73 | renderToText = Right . Text.pack 74 | parseFromText = Right . Text.unpack 75 | 76 | -- | Convert a 'ByteString' with UTF-8 encoded string to 'Text' 77 | -- 78 | -- @since 0.5.67 79 | instance Textual ByteString where 80 | renderToText x = case Text.decodeUtf8' x of 81 | Left u -> 82 | Left 83 | ( "renderToText of the ByteString failed: " 84 | ++ displayException u 85 | ++ " " 86 | ++ show x 87 | ++ "\nat:\n" 88 | ++ prettyCallStack callStack 89 | ) 90 | Right t -> Right t 91 | parseFromText = Right . Text.encodeUtf8 92 | 93 | -- | Convert a 'LazyByteString' with UTF-8 encoded string to 'Text' 94 | -- 95 | -- @since 0.5.67 96 | instance Textual LazyByteString where 97 | renderToText x = case LazyText.decodeUtf8' x of 98 | Left u -> 99 | Left 100 | ( "renderToText of the LazyByteString failed: " 101 | ++ displayException u 102 | ++ " " 103 | ++ show x 104 | ++ "\nat:\n" 105 | ++ prettyCallStack callStack 106 | ) 107 | Right t -> Right (LazyText.toStrict t) 108 | parseFromText = Right . LazyByteString.fromStrict . Text.encodeUtf8 109 | 110 | -- | Render a 'Text' to a file. 111 | -- 112 | -- @since 0.5.67 113 | writeTextFile :: (HasCallStack, MonadIO m) => FilePath -> Text -> m () 114 | writeTextFile f = liftIO . Text.writeFile f 115 | 116 | -- | Render a 'Text' via 'renderToText' and throw a runtime exception when rendering fails. 117 | -- 118 | -- @since 0.5.67 119 | unsafeRenderToText :: (Textual a, HasCallStack) => a -> Text 120 | unsafeRenderToText = either error id . renderToText 121 | 122 | -- | Parse a 'Text' via 'parseFromText' and throw a runtime exception when parsing fails. 123 | -- 124 | -- @since 0.5.67 125 | unsafeParseFromText :: (Textual a, HasCallStack) => Text -> a 126 | unsafeParseFromText = either error id . parseFromText 127 | 128 | -- | Encode a 'String' as UTF-8 encoded into a 'LazyByteString'. 129 | -- 130 | -- @since 0.5.67 131 | encodeAsUtf8LazyByteString :: HasCallStack => String -> LazyByteString 132 | encodeAsUtf8LazyByteString = 133 | LazyByteString.fromStrict . Text.encodeUtf8 . Text.pack 134 | 135 | -- | Parse the given 'Text'. \ 136 | -- Return @Left errorMessage@ or @Right a@. 137 | -- 138 | -- error message. 139 | -- 140 | -- @since 0.5.67 141 | parseFromTextWithErrorMessage :: 142 | (HasCallStack, Textual a) => 143 | -- | An arbitrary string for error messages 144 | String -> 145 | Text -> 146 | Either String a 147 | parseFromTextWithErrorMessage errorMessage b = case parseFromText b of 148 | Left e -> Left (unwords [errorMessage, e]) 149 | Right a -> Right a 150 | -------------------------------------------------------------------------------- /src/lib/B9/Vm.hs: -------------------------------------------------------------------------------- 1 | -- | Definition of 'VmScript' an artifact encapsulating several virtual machines 2 | -- disk images that can be mounted in an execution environment like 3 | -- "B9.LibVirtLXC". A 'VmScript' is embedded by in an 4 | -- 'B9.Artifact.Generator.ArtifactGenerator'. 5 | module B9.Vm 6 | ( VmScript (..), 7 | substVmScript, 8 | ) 9 | where 10 | 11 | import B9.Artifact.Content.StringTemplate 12 | import B9.B9Error 13 | import B9.DiskImages 14 | import B9.Environment 15 | import B9.ExecEnv 16 | import B9.ShellScript 17 | import Control.Eff 18 | import Control.Parallel.Strategies 19 | import Data.Binary 20 | import Data.Data 21 | import Data.Generics.Aliases hiding (Generic) 22 | import Data.Generics.Schemes 23 | import Data.Hashable 24 | import GHC.Generics (Generic) 25 | 26 | -- | Describe a virtual machine, i.e. a set up disk images to create and a shell 27 | -- script to put things together. 28 | data VmScript 29 | = VmScript 30 | CPUArch 31 | [SharedDirectory] 32 | Script 33 | | NoVmScript 34 | deriving (Read, Show, Typeable, Data, Eq, Generic) 35 | 36 | instance Hashable VmScript 37 | 38 | instance Binary VmScript 39 | 40 | instance NFData VmScript 41 | 42 | substVmScript :: 43 | forall e. 44 | (Member EnvironmentReader e, Member ExcB9 e) => 45 | VmScript -> 46 | Eff e VmScript 47 | substVmScript = everywhereM gsubst 48 | where 49 | gsubst :: GenericM (Eff e) 50 | gsubst = mkM substMountPoint `extM` substSharedDir `extM` substScript 51 | substMountPoint NotMounted = pure NotMounted 52 | substMountPoint (MountPoint x) = MountPoint <$> substStr x 53 | substSharedDir (SharedDirectory fp mp) = 54 | SharedDirectory <$> substStr fp <*> pure mp 55 | substSharedDir (SharedDirectoryRO fp mp) = 56 | SharedDirectoryRO <$> substStr fp <*> pure mp 57 | substSharedDir s = pure s 58 | substScript (In fp s) = In <$> substStr fp <*> pure s 59 | substScript (Run fp args) = Run <$> substStr fp <*> mapM substStr args 60 | substScript (As fp s) = As <$> substStr fp <*> pure s 61 | substScript s = pure s 62 | -------------------------------------------------------------------------------- /src/lib/B9/VmBuilder.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-unused-matches #-} 2 | -- | Effectful functions to execute and build virtual machine images using 3 | -- an execution environment like e.g. libvirt-lxc. 4 | module B9.VmBuilder 5 | ( buildWithVm, 6 | buildWithVmPostFix 7 | ) 8 | where 9 | 10 | import B9.Artifact.Readable 11 | import B9.B9Error 12 | import B9.B9Logging 13 | import B9.B9Monad 14 | import B9.BuildInfo 15 | import B9.Container 16 | import B9.DiskImageBuilder 17 | import B9.DiskImages 18 | import qualified B9.Docker as Docker 19 | import B9.ExecEnv 20 | import qualified B9.LibVirtLXC as LXC 21 | import qualified B9.SystemdNspawn as SystemdNspawn 22 | import B9.Vm 23 | import Control.Eff 24 | import Control.Monad 25 | import Control.Monad.IO.Class 26 | import Data.List 27 | import Data.Proxy 28 | import System.Directory 29 | ( canonicalizePath, 30 | createDirectoryIfMissing, 31 | ) 32 | import System.FilePath (()) 33 | import Text.Printf (printf) 34 | import Text.Show.Pretty (ppShow) 35 | import qualified B9.B9Exec as B9.Exec 36 | import B9.B9Exec (HostCommandStdin(HostCommandNoStdin)) 37 | import qualified System.Exit 38 | import B9.ShellScript ( writeSh, renderScript, Script (NoOP) ) 39 | 40 | buildWithVm :: 41 | IsB9 e => InstanceId -> [ImageTarget] -> FilePath -> VmScript -> Eff e Bool 42 | buildWithVm iid imageTargets instanceDir vmScript = buildWithVmImpl iid imageTargets instanceDir vmScript NoOP 43 | 44 | buildWithVmPostFix :: 45 | IsB9 e => InstanceId -> [ImageTarget] -> FilePath -> VmScript -> Script -> Eff e Bool 46 | buildWithVmPostFix = buildWithVmImpl 47 | 48 | buildWithVmImpl :: 49 | IsB9 e => InstanceId -> [ImageTarget] -> FilePath -> VmScript -> Script -> Eff e Bool 50 | buildWithVmImpl iid imageTargets instanceDir vmScript postFix = do 51 | res <- withBackend (buildWithBackend iid imageTargets instanceDir vmScript postFix) 52 | case res of 53 | Nothing -> 54 | errorExitL "No container configured." 55 | Just success -> 56 | return success 57 | 58 | buildWithBackend 59 | :: forall backendCfg e. (Backend backendCfg, IsB9 e) 60 | => InstanceId 61 | -> [ImageTarget] 62 | -> FilePath 63 | -> VmScript 64 | -> Script 65 | -> backendCfg 66 | -> Eff e Bool 67 | buildWithBackend iid imageTargets instanceDir vmScript postFix backendCfg = do 68 | let vmBuildSupportedImageTypes = supportedImageTypes (Proxy :: Proxy backendCfg) 69 | buildImages <- createBuildImages imageTargets vmBuildSupportedImageTypes 70 | success1 <- runVmScript backendCfg iid imageTargets buildImages instanceDir vmScript 71 | when success1 (resizeDestinationImages buildImages imageTargets) 72 | buildBaseDir <- getBuildDir 73 | success2 <- case postFix of 74 | NoOP -> return True 75 | _ -> do 76 | let postFixArgs = [fp | (Image fp _ _) <- buildImages] 77 | postFixScriptFile = buildBaseDir "post-fix.sh" 78 | infoL ("WRITING POSTFIX: \n" ++ renderScript postFix) 79 | liftIO $ do 80 | writeSh postFixScriptFile postFix 81 | res <- B9.Exec.hostCmdEither HostCommandNoStdin (printf "%s %s" postFixScriptFile (unwords postFixArgs)) Nothing 82 | case res of 83 | Left _ -> return False 84 | Right e -> return (e == System.Exit.ExitSuccess) 85 | when success2 (exportDestinationImages buildImages imageTargets) 86 | return (success1 && success2) 87 | 88 | createBuildImages :: IsB9 e => [ImageTarget] -> [ImageType] -> Eff e [Image] 89 | createBuildImages imageTargets vmBuildSupportedImageTypes = do 90 | dbgL "creating build images" 91 | traceL (ppShow imageTargets) 92 | buildImages <- mapM createBuildImage imageTargets 93 | infoL "CREATED BUILD IMAGES" 94 | traceL (ppShow buildImages) 95 | return buildImages 96 | where 97 | createBuildImage (ImageTarget dest imageSource _mnt) = do 98 | buildDir <- getBuildDir 99 | destTypes <- preferredDestImageTypes imageSource 100 | let buildImgType = 101 | head 102 | ( destTypes 103 | `intersect` preferredSourceImageTypes dest 104 | `intersect` vmBuildSupportedImageTypes 105 | ) 106 | srcImg <- resolveImageSource imageSource 107 | let buildImg = 108 | changeImageFormat buildImgType (changeImageDirectory buildDir srcImg) 109 | buildImgAbsolutePath <- ensureAbsoluteImageDirExists buildImg 110 | materializeImageSource imageSource buildImg 111 | return buildImgAbsolutePath 112 | 113 | runVmScript :: 114 | forall e backendCfg. 115 | (Backend backendCfg, IsB9 e) => 116 | backendCfg -> 117 | InstanceId -> 118 | [ImageTarget] -> 119 | [Image] -> 120 | FilePath -> 121 | VmScript -> 122 | Eff e Bool 123 | runVmScript _ _ _ _ _ NoVmScript = return True 124 | runVmScript backendCfg (IID iid) imageTargets buildImages instanceDir vmScript = do 125 | dbgL (printf "starting vm script with instanceDir '%s'" instanceDir) 126 | traceL (ppShow vmScript) 127 | execEnv <- setUpExecEnv 128 | let (VmScript _ _ script) = vmScript 129 | result <- runExcB9 $ runInEnvironment backendCfg execEnv script 130 | handleErrors (either (Left . show) Right result) 131 | where 132 | handleErrors :: IsB9 e => Either String Bool -> Eff e Bool 133 | handleErrors (Right False) = do 134 | errorL "The containerized build failed!" 135 | return False 136 | handleErrors (Right True) = do 137 | traceL "The containerized build was successful." 138 | return True 139 | handleErrors (Left err) = 140 | errorExitL ("Failed to complete the containerized build: " ++ show err) 141 | 142 | setUpExecEnv :: IsB9 e => Eff e ExecEnv 143 | setUpExecEnv = do 144 | let (VmScript cpu shares _) = vmScript 145 | let mountedImages = buildImages `zip` (itImageMountPoint <$> imageTargets) 146 | sharesAbs <- createSharedDirs instanceDir shares 147 | return 148 | (ExecEnv iid mountedImages sharesAbs (Resources AutomaticRamSize 8 cpu)) 149 | 150 | createSharedDirs :: 151 | IsB9 e => FilePath -> [SharedDirectory] -> Eff e [SharedDirectory] 152 | createSharedDirs instanceDir = mapM createSharedDir 153 | where 154 | createSharedDir (SharedDirectoryRO d m) = do 155 | d' <- createAndCanonicalize d 156 | return $ SharedDirectoryRO d' m 157 | createSharedDir (SharedDirectory d m) = do 158 | d' <- createAndCanonicalize d 159 | return $ SharedDirectory d' m 160 | createSharedDir (SharedSources mp) = do 161 | d' <- createAndCanonicalize instanceDir 162 | return $ SharedDirectoryRO d' mp 163 | createAndCanonicalize d = liftIO $ do 164 | createDirectoryIfMissing True d 165 | canonicalizePath d 166 | 167 | resizeDestinationImages :: IsB9 e => [Image] -> [ImageTarget] -> Eff e () 168 | resizeDestinationImages buildImages imageTargets = do 169 | dbgL "resizing build images to the output images sizes" 170 | let pairsToConvert = 171 | buildImages `zip` (itImageDestination `map` imageTargets) 172 | traceL (ppShow pairsToConvert) 173 | mapM_ (uncurry resizeDestinationImage) pairsToConvert 174 | infoL "RESIZED BUILD- TO OUTPUT IMAGES" 175 | 176 | exportDestinationImages :: IsB9 e => [Image] -> [ImageTarget] -> Eff e () 177 | exportDestinationImages buildImages imageTargets = do 178 | dbgL "converting build- to output images" 179 | let pairsToConvert = 180 | buildImages `zip` (itImageDestination `map` imageTargets) 181 | traceL (ppShow pairsToConvert) 182 | mapM_ (uncurry exportDestinationImage) pairsToConvert 183 | infoL "CONVERTED BUILD- TO OUTPUT IMAGES" 184 | 185 | withBackend :: IsB9 e => (forall x. Backend x => x -> Eff e a) -> Eff e (Maybe a) 186 | withBackend k = do 187 | lxcCfg <- getBackendConfig (Proxy :: Proxy LXC.LibVirtLXC) 188 | case lxcCfg of 189 | Just cfg -> 190 | Just <$> k cfg 191 | Nothing -> do 192 | dockerCfg <- getBackendConfig (Proxy :: Proxy Docker.Docker) 193 | case dockerCfg of 194 | Just cfg -> 195 | Just <$> k cfg 196 | Nothing -> do 197 | systemdNspawnCfg <- getBackendConfig (Proxy :: Proxy SystemdNspawn.SystemdNspawn) 198 | case systemdNspawnCfg of 199 | Just cfg -> 200 | Just <$> k cfg 201 | Nothing -> 202 | return Nothing 203 | -------------------------------------------------------------------------------- /src/lib/Data/ConfigFile/B9Extras.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE ExplicitNamespaces #-} 4 | 5 | -- | Extensions to 'Data.ConfigFile' and utility functions for dealing with 6 | -- configuration in general and reading/writing files. 7 | module Data.ConfigFile.B9Extras 8 | ( addSectionCP, 9 | setShowCP, 10 | setCP, 11 | readCP, 12 | mergeCP, 13 | toStringCP, 14 | sectionsCP, 15 | emptyCP, 16 | type CPGet, 17 | type CPOptionSpec, 18 | type CPSectionSpec, 19 | type CPDocument, 20 | CPError (), 21 | readCPDocument, 22 | CPReadException (..), 23 | ) 24 | where 25 | 26 | import Control.Exception 27 | import Control.Monad.Except 28 | import Data.ConfigFile 29 | import Data.Typeable 30 | import System.IO.B9Extras 31 | 32 | -- * Aliases for functions and types from 'ConfigParser' in 'Data.ConfigFile' 33 | 34 | -- | An alias for 'ConfigParser' 35 | type CPDocument = ConfigParser 36 | 37 | -- | An alias for 'SectionSpec'. 38 | type CPSectionSpec = SectionSpec 39 | 40 | -- | An alias for 'OptionSpec' 41 | type CPOptionSpec = OptionSpec 42 | 43 | -- | An alias for 'setshow'. 44 | setShowCP :: 45 | (Show a, MonadError CPError m) => 46 | CPDocument -> 47 | CPSectionSpec -> 48 | CPOptionSpec -> 49 | a -> 50 | m CPDocument 51 | setShowCP = setshow 52 | 53 | -- | An alias for 'set'. 54 | setCP :: 55 | (MonadError CPError m) => 56 | CPDocument -> 57 | CPSectionSpec -> 58 | CPOptionSpec -> 59 | String -> 60 | m CPDocument 61 | setCP = set 62 | 63 | -- | An alias for 'get'. 64 | readCP :: 65 | (CPGet a, MonadError CPError m) => 66 | CPDocument -> 67 | CPSectionSpec -> 68 | CPOptionSpec -> 69 | m a 70 | readCP = get 71 | 72 | -- | An alias for 'Get_C' 73 | type CPGet a = Get_C a 74 | 75 | -- | An alias for 'add_section'. 76 | addSectionCP :: 77 | MonadError CPError m => CPDocument -> CPSectionSpec -> m CPDocument 78 | addSectionCP = add_section 79 | 80 | -- | An alias for 'merge'. 81 | mergeCP :: CPDocument -> CPDocument -> CPDocument 82 | mergeCP = merge 83 | 84 | -- | An alias for 'to_string' 85 | toStringCP :: CPDocument -> String 86 | toStringCP = to_string 87 | 88 | -- | An alias for 'sections'. 89 | sectionsCP :: CPDocument -> [SectionSpec] 90 | sectionsCP = sections 91 | 92 | -- * Reading a 'CPDocument' from a 'SystemPath' 93 | 94 | -- | Read a file and try to parse the contents as a 'CPDocument', if something 95 | -- goes wrong throw a 'CPReadException' 96 | readCPDocument :: MonadIO m => SystemPath -> m CPDocument 97 | readCPDocument cfgFile' = do 98 | cfgFilePath <- resolve cfgFile' 99 | liftIO $ do 100 | res <- readfile emptyCP cfgFilePath 101 | case res of 102 | Left e -> throwIO (CPReadException cfgFilePath e) 103 | Right cp -> return cp 104 | 105 | -- | An exception thrown by 'readCPDocument'. 106 | data CPReadException = CPReadException FilePath CPError 107 | deriving (Show, Typeable) 108 | 109 | instance Exception CPReadException 110 | -------------------------------------------------------------------------------- /src/lib/System/IO/B9Extras.hs: -------------------------------------------------------------------------------- 1 | -- | Some utilities to deal with IO in B9. 2 | module System.IO.B9Extras 3 | ( SystemPath (..), 4 | overSystemPath, 5 | resolve, 6 | ensureSystemPath, 7 | ensureDir, 8 | getDirectoryFiles, 9 | prettyPrintToFile, 10 | consult, 11 | ConsultException (..), 12 | randomUUID, 13 | UUID (), 14 | removeIfExists, 15 | ) 16 | where 17 | 18 | import Control.Exception 19 | import Control.Monad.Except 20 | import Data.Data 21 | import Data.Word 22 | ( Word16, 23 | Word32, 24 | ) 25 | import System.Directory 26 | import System.FilePath 27 | import System.IO.Error 28 | import System.Random (randomIO) 29 | import Text.Printf 30 | import Text.Read (readEither) 31 | import Text.Show.Pretty (ppShow) 32 | 33 | -- * Relative Paths 34 | 35 | -- | A data type encapsulating different kinds of relative or absolute paths. 36 | data SystemPath 37 | = -- | A path that will just be passed through 38 | Path FilePath 39 | | -- | A OS specific path relative to 40 | -- the home directory of a user. 41 | InHomeDir FilePath 42 | | -- | A path relative to the @b9@ sub of 43 | -- the users application configuration 44 | -- directory 'getAppUserDataDirectory' 45 | InB9UserDir FilePath 46 | | -- | A path relative to the systems 47 | -- temporary directory. 48 | InTempDir FilePath 49 | deriving (Eq, Read, Show, Typeable, Data) 50 | 51 | -- | Transform a 'SystemPath' 52 | overSystemPath :: (FilePath -> FilePath) -> SystemPath -> SystemPath 53 | overSystemPath f sp = 54 | case sp of 55 | Path p -> Path (f p) 56 | InHomeDir p -> InHomeDir (f p) 57 | InB9UserDir p -> InB9UserDir (f p) 58 | InTempDir p -> InTempDir (f p) 59 | 60 | -- | Convert a 'SystemPath' to a 'FilePath'. 61 | resolve :: MonadIO m => SystemPath -> m FilePath 62 | resolve (Path p) = return p 63 | resolve (InHomeDir p) = liftIO $ do 64 | d <- getHomeDirectory 65 | return $ d p 66 | resolve (InB9UserDir p) = liftIO $ do 67 | d <- getAppUserDataDirectory "b9" 68 | return $ d p 69 | resolve (InTempDir p) = liftIO $ do 70 | d <- getTemporaryDirectory 71 | return $ d p 72 | 73 | -- * File System Directory Utilities 74 | 75 | -- | Get all files from 'dir' that is get ONLY files not directories 76 | getDirectoryFiles :: MonadIO m => FilePath -> m [FilePath] 77 | getDirectoryFiles dir = do 78 | entries <- liftIO (getDirectoryContents dir) 79 | fileEntries <- mapM (liftIO . doesFileExist . (dir )) entries 80 | return (snd <$> filter fst (fileEntries `zip` entries)) 81 | 82 | -- | Create all missing parent directories of a file path. 83 | -- 84 | -- @since 1.1.0 85 | ensureSystemPath :: MonadIO m => SystemPath -> m () 86 | ensureSystemPath = 87 | resolve >=> liftIO . createDirectoryIfMissing True 88 | 89 | -- | Create all missing parent directories of a file path. 90 | -- Note that the file path is assumed to be of a regular file, and 91 | -- 'takeDirectory' is applied before creating the directory. 92 | ensureDir :: MonadIO m => FilePath -> m () 93 | ensureDir p = liftIO (createDirectoryIfMissing True $ takeDirectory p) 94 | 95 | -- * Reading and Writing from/to Files 96 | 97 | -- | Write a value of a type that is an instance of 'Show' to file. 98 | -- This function uses 'ppShow' instead of the given 'Show' instance. 99 | prettyPrintToFile :: (MonadIO m, Show a) => FilePath -> a -> m () 100 | prettyPrintToFile f x = do 101 | ensureDir f 102 | liftIO (writeFile f (ppShow x)) 103 | 104 | -- | Read a value of a type that is an instance of 'Read' from a file. 105 | -- This function throws a 'ConsultException' when the read the file failed. 106 | consult :: (MonadIO m, Read a) => FilePath -> m a 107 | consult f = liftIO $ do 108 | c <- readFile f 109 | case readEither c of 110 | Left e -> throwIO $ ConsultException f e 111 | Right a -> return a 112 | 113 | -- | An 'Exception' thrown by 'consult' to indicate the file does not 114 | -- contain a 'read'able String 115 | data ConsultException = ConsultException FilePath String 116 | deriving (Show, Typeable) 117 | 118 | instance Exception ConsultException 119 | 120 | -- * Unique Random IDs 121 | 122 | -- | A bunch of numbers, enough to make globally unique IDs. Create one of these 123 | -- using 'randomUUID'. 124 | newtype UUID = UUID (Word32, Word16, Word16, Word16, Word32, Word16) 125 | deriving (Read, Show, Eq, Ord) 126 | 127 | instance PrintfArg UUID where 128 | formatArg (UUID (a, b, c, d, e, f)) fmt 129 | | fmtChar (vFmt 'U' fmt) == 'U' = 130 | let str = (printf "%08x-%04x-%04x-%04x-%08x%04x" a b c d e f :: String) 131 | in formatString str (fmt {fmtChar = 's', fmtPrecision = Nothing}) 132 | | otherwise = 133 | errorBadFormat $ fmtChar fmt 134 | 135 | -- | Generate a random 'UUID'. 136 | randomUUID :: MonadIO m => m UUID 137 | randomUUID = 138 | liftIO 139 | ( UUID 140 | <$> ( (,,,,,) 141 | <$> randomIO 142 | <*> randomIO 143 | <*> randomIO 144 | <*> randomIO 145 | <*> randomIO 146 | <*> randomIO 147 | ) 148 | ) 149 | 150 | removeIfExists :: FilePath -> IO () 151 | removeIfExists fileName = removeFile fileName `catch` handleExists 152 | where 153 | handleExists e 154 | | isDoesNotExistError e = return () 155 | | otherwise = throwIO e 156 | -------------------------------------------------------------------------------- /src/tests/B9/ArtifactGeneratorImplSpec.hs: -------------------------------------------------------------------------------- 1 | module B9.ArtifactGeneratorImplSpec 2 | ( spec, 3 | ) 4 | where 5 | 6 | import B9.Artifact.Readable 7 | import B9.Artifact.Readable.Interpreter 8 | import B9.DiskImages 9 | import B9.ExecEnv 10 | import B9.ShellScript 11 | import B9.Vm 12 | import Data.Text () 13 | import Test.Hspec 14 | 15 | spec :: Spec 16 | spec = describe "assemble" $ do 17 | it "replaces '${variable}' in SourceImage Image file paths" $ 18 | let src = 19 | Let 20 | [("variable", "value")] 21 | [vmImagesArtifact "" [transientCOW "${variable}" ""] NoVmScript] 22 | expected = transientCOW "value" "" 23 | (Right [IG _ _ (VmImages [actual] _)]) = 24 | runArtifactGenerator mempty "" "" src 25 | in actual `shouldBe` expected 26 | it "replaces '${variable}' in SourceImage 'From' names" $ 27 | let src = 28 | Let 29 | [("variable", "value")] 30 | [vmImagesArtifact "" [transientShared "${variable}" ""] NoVmScript] 31 | expected = transientShared "value" "" 32 | (Right [IG _ _ (VmImages [actual] _)]) = 33 | runArtifactGenerator mempty "" "" src 34 | in actual `shouldBe` expected 35 | it "replaces '${variable}' in the name of a shared image" $ 36 | let src = 37 | Let 38 | [("variable", "value")] 39 | [vmImagesArtifact "" [shareCOW "${variable}" ""] NoVmScript] 40 | expected = shareCOW "value" "" 41 | (Right [IG _ _ (VmImages [actual] _)]) = 42 | runArtifactGenerator mempty "" "" src 43 | in actual `shouldBe` expected 44 | it "replaces '${variable}' in the name and path of a live installer image" $ 45 | let src = 46 | Let 47 | [("variable", "value")] 48 | [ vmImagesArtifact 49 | "" 50 | [liveInstallerCOWImage "${variable}" ""] 51 | NoVmScript 52 | ] 53 | expected = liveInstallerCOWImage "value" "" 54 | (Right [IG _ _ (VmImages [actual] _)]) = 55 | runArtifactGenerator mempty "" "" src 56 | in actual `shouldBe` expected 57 | it 58 | "replaces '${variable}' in the file name of an image exported as LocalFile" 59 | $ let src = 60 | Let 61 | [("variable", "value")] 62 | [vmImagesArtifact "" [localCOWImage "${variable}" ""] NoVmScript] 63 | expected = localCOWImage "value" "" 64 | (Right [IG _ _ (VmImages [actual] _)]) = 65 | runArtifactGenerator mempty "" "" src 66 | in actual `shouldBe` expected 67 | it "replaces '${variable}' in mount point of an image" $ 68 | let src = 69 | Let 70 | [("variable", "value")] 71 | [vmImagesArtifact "" [localCOWImage "" "${variable}"] NoVmScript] 72 | expected = localCOWImage "" "value" 73 | (Right [IG _ _ (VmImages [actual] _)]) = 74 | runArtifactGenerator mempty "" "" src 75 | in actual `shouldBe` expected 76 | it "replaces '${variable}' in shared directory source and mount point (RO)" $ 77 | let src = 78 | Let 79 | [("variable", "value")] 80 | [vmImagesArtifact "" [] (emptyScriptWithSharedDirRO "${variable}")] 81 | expected = emptyScriptWithSharedDirRO "value" 82 | (Right [IG _ _ (VmImages [] actual)]) = 83 | runArtifactGenerator mempty "" "" src 84 | in actual `shouldBe` expected 85 | it "replaces '${variable}' in shared directory source and mount point (RW)" $ 86 | let src = 87 | Let 88 | [("variable", "value")] 89 | [vmImagesArtifact "" [] (emptyScriptWithSharedDirRW "${variable}")] 90 | expected = emptyScriptWithSharedDirRW "value" 91 | (Right [IG _ _ (VmImages [] actual)]) = 92 | runArtifactGenerator mempty "" "" src 93 | in actual `shouldBe` expected 94 | it "replaces '${variable}' in VmImages build script instructions" $ 95 | let src = 96 | Let 97 | [("variable", "value")] 98 | [vmImagesArtifact "" [] (buildVmScript "${variable}")] 99 | expected = buildVmScript "value" 100 | (Right [IG _ _ (VmImages [] actual)]) = 101 | runArtifactGenerator mempty "" "" src 102 | in actual `shouldBe` expected 103 | 104 | it "keeps '$variable' VmImages postFix script instructions" $ 105 | let src = 106 | Let 107 | [("variable", "value")] 108 | [vmImagesArtifactWithFixup "" [] NoVmScript (buildScript "$variable")] 109 | expected = buildScript "$variable" 110 | (Right [IG _ _ (VmImagesWithFixup [] NoVmScript actual)]) = 111 | runArtifactGenerator mempty "" "" src 112 | in actual `shouldBe` expected 113 | 114 | transientCOW :: FilePath -> FilePath -> ImageTarget 115 | transientCOW fileName mountPoint = 116 | ImageTarget 117 | Transient 118 | (CopyOnWrite (Image fileName QCow2 Ext4)) 119 | (MountPoint mountPoint) 120 | 121 | transientShared :: FilePath -> FilePath -> ImageTarget 122 | transientShared name mountPoint = 123 | ImageTarget Transient (From name KeepSize) (MountPoint mountPoint) 124 | 125 | shareCOW :: FilePath -> FilePath -> ImageTarget 126 | shareCOW destName mountPoint = 127 | ImageTarget 128 | (Share destName QCow2 KeepSize) 129 | (CopyOnWrite (Image "cowSource" QCow2 Ext4)) 130 | (MountPoint mountPoint) 131 | 132 | liveInstallerCOWImage :: FilePath -> FilePath -> ImageTarget 133 | liveInstallerCOWImage destName mountPoint = 134 | ImageTarget 135 | (LiveInstallerImage destName destName KeepSize) 136 | (CopyOnWrite (Image "cowSource" QCow2 Ext4)) 137 | (MountPoint mountPoint) 138 | 139 | localCOWImage :: FilePath -> FilePath -> ImageTarget 140 | localCOWImage destName mountPoint = 141 | ImageTarget 142 | (LocalFile (Image destName QCow2 Ext4) KeepSize) 143 | (CopyOnWrite (Image "cowSource" QCow2 Ext4)) 144 | (MountPoint mountPoint) 145 | 146 | vmImagesArtifact :: String -> [ImageTarget] -> VmScript -> ArtifactGenerator 147 | vmImagesArtifact iid imgs script = Artifact (IID iid) (VmImages imgs script) 148 | 149 | vmImagesArtifactWithFixup :: String -> [ImageTarget] -> VmScript -> Script -> ArtifactGenerator 150 | vmImagesArtifactWithFixup iid imgs script postFix = Artifact (IID iid) (VmImagesWithFixup imgs script postFix) 151 | 152 | emptyScriptWithSharedDirRO :: String -> VmScript 153 | emptyScriptWithSharedDirRO arg = 154 | VmScript X86_64 [SharedDirectoryRO arg (MountPoint arg)] (Run "" []) 155 | 156 | emptyScriptWithSharedDirRW :: String -> VmScript 157 | emptyScriptWithSharedDirRW arg = 158 | VmScript X86_64 [SharedDirectory arg (MountPoint arg)] (Run "" []) 159 | 160 | buildVmScript :: String -> VmScript 161 | buildVmScript arg = 162 | VmScript 163 | X86_64 164 | [SharedDirectory arg (MountPoint arg), SharedDirectoryRO arg NotMounted] 165 | (buildScript arg) 166 | 167 | buildScript :: String -> Script 168 | buildScript arg = As arg [In arg [Run arg [arg]]] 169 | -------------------------------------------------------------------------------- /src/tests/B9/B9ConfigSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NumericUnderscores #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | 4 | module B9.B9ConfigSpec 5 | ( spec, 6 | ) 7 | where 8 | 9 | import Data.Maybe (fromMaybe) 10 | import Control.Lens ((^.)) 11 | import B9.B9Config 12 | import B9.B9Monad 13 | import Control.Exception 14 | import Control.Monad 15 | import System.Directory 16 | import System.Environment 17 | import System.FilePath 18 | import System.IO.B9Extras 19 | import Test.Hspec(Spec, it, shouldBe, HasCallStack, describe) 20 | import Test.QuickCheck (property, (===), (==>)) 21 | import Text.Printf 22 | import qualified Data.Text as Text 23 | import Data.ConfigFile.B9Extras 24 | ( 25 | CPError 26 | ) 27 | import NeatInterpolation as Neat 28 | import Data.Either (isRight) 29 | 30 | spec :: HasCallStack => Spec 31 | spec = do 32 | it "forall valid configs: parse . render == id" $ property $ 33 | \cfg -> 34 | let actual = renderThenParseB9Config cfg 35 | in isRight actual ==> (Right cfg === actual) 36 | 37 | describe "parse textual configuration" $ do 38 | let 39 | exampleConfig = Text.unpack [Neat.text| 40 | [global] 41 | build_dir_root: Nothing 42 | keep_temp_dirs: False 43 | log_file: Nothing 44 | max_cached_shared_images: Just 2 45 | repository: Nothing 46 | repository_cache: Just (InB9UserDir "repo-cache") 47 | unique_build_dirs: True 48 | verbosity: Just LogNothing 49 | timeout_factor: 3 50 | default_timeout_seconds: 10 51 | ext4_attributes: ["attr1", "attr2"] 52 | |] 53 | it "correctly parses verbosity" $ do 54 | cfg <- withConfig exampleConfig getB9Config 55 | _verbosity cfg `shouldBe` Just LogNothing 56 | 57 | it "correctly parses timeout_factor" $ do 58 | cfg <- withConfig exampleConfig getB9Config 59 | _timeoutFactor cfg `shouldBe` Just 3 60 | 61 | it "correctly parses default_timeout" $ do 62 | cfg <- withConfig exampleConfig getB9Config 63 | _defaultTimeout cfg `shouldBe` Just (TimeoutMicros 10_000_000) 64 | 65 | it "correctly parses ext4_attributes" $ do 66 | cfg <- withConfig exampleConfig getB9Config 67 | _ext4Attributes cfg `shouldBe` ["attr1", "attr2"] 68 | 69 | it "correctly parses missing ext4_attributes" $ do 70 | let exampleConfigNoExt4 = Text.unpack [Neat.text| 71 | [global] 72 | build_dir_root: Nothing 73 | keep_temp_dirs: False 74 | log_file: Nothing 75 | max_cached_shared_images: Just 2 76 | repository: Nothing 77 | repository_cache: Just (InB9UserDir "repo-cache") 78 | unique_build_dirs: True 79 | verbosity: Just LogNothing 80 | timeout_factor: 3 81 | default_timeout_seconds: 10 82 | |] 83 | cfg <- withConfig exampleConfigNoExt4 getB9Config 84 | _ext4Attributes cfg `shouldBe` ["^64bit"] 85 | 86 | 87 | renderThenParseB9Config :: B9Config -> Either CPError B9Config 88 | renderThenParseB9Config = b9ConfigToCPDocument >=> parseB9Config 89 | 90 | withConfig :: String -> B9 a -> IO a 91 | withConfig cfgFileContents testAction = 92 | withTempBuildDirs $ \cfg -> do 93 | let cfgFileName = 94 | fromMaybe 95 | (error "Internal Error") 96 | (cfg ^. customDefaulB9ConfigPath) 97 | cfgFilePath <- resolve cfgFileName 98 | writeFile cfgFilePath cfgFileContents 99 | runB9ConfigActionWithOverrides (runB9 testAction) cfg 100 | 101 | withTempBuildDirs :: HasCallStack => (B9ConfigOverride -> IO a) -> IO a 102 | withTempBuildDirs k = 103 | bracket acquire release use 104 | where 105 | acquire = do 106 | nixOutDirEnv <- lookupEnv "NIX_BUILD_TOP" 107 | let rootDir = maybe InTempDir (((.) . (.)) Path ()) nixOutDirEnv 108 | repoRelPath <- printf "testsRepositoryIOSpec-test-repo-%U" <$> randomUUID 109 | buildRelPath <- printf "RepositoryIOSpec-root-%U" <$> randomUUID 110 | cfgRelPath <- printf "RepositoryIOSpec-b9cfg-%U" <$> randomUUID 111 | let tmpRepoPath = rootDir ("tests" repoRelPath) 112 | tmpBuildPath = rootDir ("tests" buildRelPath) 113 | tmpCfgPath = rootDir ("tests" cfgRelPath) 114 | ensureSystemPath tmpRepoPath 115 | ensureSystemPath tmpBuildPath 116 | tmpBuildPathFileName <- resolve tmpBuildPath 117 | return (tmpRepoPath, tmpBuildPathFileName, tmpCfgPath) 118 | release (tmpRepoPath, tmpBuildPathFileName, tmpCfgPath) = do 119 | let cleanupTmpPath = removePathForcibly <=< resolve 120 | cleanupTmpPath tmpRepoPath 121 | cleanupTmpPath tmpCfgPath 122 | removePathForcibly tmpBuildPathFileName 123 | use (tmpRepoPath, tmpBuildPathFileName, tmpCfgPath) = 124 | let mkCfg cfgIn = 125 | cfgIn 126 | { _repositoryCache = Just tmpRepoPath, 127 | _projectRoot = Just tmpBuildPathFileName 128 | } 129 | oCfg = 130 | overrideB9Config 131 | mkCfg 132 | ( overrideWorkingDirectory 133 | tmpBuildPathFileName 134 | ( overrideDefaultB9ConfigPath 135 | tmpCfgPath 136 | noB9ConfigOverride 137 | ) 138 | ) 139 | in k oCfg 140 | -------------------------------------------------------------------------------- /src/tests/B9/Content/ErlTermsSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module B9.Content.ErlTermsSpec 4 | ( spec, 5 | ) 6 | where 7 | 8 | import B9.Artifact.Content.ErlTerms 9 | import B9.Text 10 | import Data.List 11 | import Data.Maybe 12 | import Test.Hspec 13 | import Test.QuickCheck 14 | 15 | spec :: Spec 16 | spec = do 17 | describe "parseErlTerm" $ do 18 | it 19 | "parses a non-empty string" 20 | ( parseErlTerm "test" "\"hello world\"." 21 | `shouldBe` Right (ErlString "hello world") 22 | ) 23 | it 24 | "parses a string with escaped characters" 25 | ( parseErlTerm "test" "\"\\b\\^A\"." 26 | `shouldBe` Right (ErlString "\b\^A") 27 | ) 28 | it 29 | "parses a string with escaped octals: \\X" 30 | (parseErlTerm "test" "\"\\7\"." `shouldBe` Right (ErlString "\o7")) 31 | it 32 | "parses a string with escaped octals: \\XY" 33 | (parseErlTerm "test" "\"\\73\"." `shouldBe` Right (ErlString "\o73")) 34 | it 35 | "parses a string with escaped octals: \\XYZ" 36 | (parseErlTerm "test" "\"\\431\"." `shouldBe` Right (ErlString "\o431")) 37 | it 38 | "parses a string with escaped hex: \\xNN" 39 | (parseErlTerm "test" "\"\\xbE\"." `shouldBe` Right (ErlString "\xbe")) 40 | it 41 | "parses a string with escaped hex: \\x{N} (1)" 42 | (parseErlTerm "test" "\"\\x{a}\"." `shouldBe` Right (ErlString "\xa")) 43 | it 44 | "parses a string with escaped hex: \\x{N} (2)" 45 | (parseErlTerm "test" "\"\\x{2}\"." `shouldBe` Right (ErlString "\x2")) 46 | it 47 | "parses a two digit octal followed by a non-octal digit" 48 | ( parseErlTerm "test" "\"\\779\"." 49 | `shouldBe` Right (ErlString "\o77\&9") 50 | ) 51 | it 52 | "parses a string with escaped hex: \\x{NNNNNN...}" 53 | ( parseErlTerm "test" "\"\\x{000000Fa}\"." 54 | `shouldBe` Right (ErlString "\xfa") 55 | ) 56 | it 57 | "parses decimal literals" 58 | ( property 59 | ( do 60 | decimal <- arbitrary `suchThat` (>= 0) 61 | let decimalStr = 62 | unsafeRenderToText (show (decimal :: Integer) ++ ".") 63 | parsedTerm <- case parseErlTerm "test" decimalStr of 64 | Left e -> error e 65 | Right parsedTerm -> return parsedTerm 66 | return (ErlNatural decimal == parsedTerm) 67 | ) 68 | ) 69 | it 70 | "parses a negative signed decimal" 71 | (parseErlTerm "test" "-1." `shouldBe` Right (ErlNatural (-1))) 72 | it 73 | "parses a positive signed decimal" 74 | (parseErlTerm "test" "+1." `shouldBe` Right (ErlNatural 1)) 75 | it 76 | "parses decimal literals with radix notation" 77 | ( property 78 | ( do 79 | radix <- choose (2, 36) 80 | digitsInRadix <- listOf1 (choose (0, radix - 1)) 81 | let (Right parsedTerm) = parseErlTerm "test" erlNumber 82 | erlNumber = unsafeRenderToText (show radix ++ "#" ++ digitChars ++ ".") 83 | expected = convertStrToDecimal radix digitChars 84 | digitChars = (naturals !!) <$> digitsInRadix 85 | return (ErlNatural expected == parsedTerm) 86 | ) 87 | ) 88 | it 89 | "parses a floating point literal with exponent and sign" 90 | ( parseErlTerm "test" "-10.40E02." `shouldBe` Right (ErlFloat (-10.4e2)) 91 | ) 92 | it 93 | "parses a simple erlang character literal" 94 | (parseErlTerm "test" "$ ." `shouldBe` Right (ErlChar (toEnum 32))) 95 | it 96 | "parses an erlang character literal with escape sequence" 97 | ( parseErlTerm "test" "$\\x{Fe}." 98 | `shouldBe` Right (ErlChar (toEnum 254)) 99 | ) 100 | it 101 | "parses an unquoted atom with @ and _" 102 | (parseErlTerm "test" "a@0_T." `shouldBe` Right (ErlAtom "a@0_T")) 103 | it 104 | "parses a quoted atom with letters, spaces and special characters" 105 | ( parseErlTerm "test" "' $s<\\\\.0_=@\\e\\''." 106 | `shouldBe` Right (ErlAtom " $s<\\.0_=@\ESC'") 107 | ) 108 | it 109 | "parses a binary literal containing a string" 110 | ( parseErlTerm "test" "<<\"1 ok!\">>." 111 | `shouldBe` Right (ErlBinary "1 ok!") 112 | ) 113 | it 114 | "parses an empty binary" 115 | (parseErlTerm "test" "<<>>." `shouldBe` Right (ErlBinary "")) 116 | it 117 | "parses an empty list" 118 | (parseErlTerm "test" "[]." `shouldBe` Right (ErlList [])) 119 | it 120 | "parses a list of atoms" 121 | ( parseErlTerm "test" " [ hello, 'world' ] ." 122 | `shouldBe` Right (ErlList [ErlAtom "hello", ErlAtom "world"]) 123 | ) 124 | it 125 | "parses an empty tuple" 126 | (parseErlTerm "test" " { } ." `shouldBe` Right (ErlTuple [])) 127 | it 128 | "parses a tuple of atoms" 129 | ( parseErlTerm "test" " { hello, 'world' } ." 130 | `shouldBe` Right (ErlTuple [ErlAtom "hello", ErlAtom "world"]) 131 | ) 132 | describe "renderErlTerm" $ do 133 | it 134 | "renders an empty binary as \"<<>>\"." 135 | (renderErlTerm (ErlBinary "") `shouldBe` "<<>>.") 136 | it 137 | "renders an erlang character" 138 | (renderErlTerm (ErlChar 'a') `shouldBe` "$a.") 139 | it 140 | "renders a quoted atom and escapes special characters" 141 | ( renderErlTerm (ErlAtom " $s\"<\\.0_=@\ESC'") 142 | `shouldBe` "' $s\"<\\\\.0_=@\\x{1b}\\''." 143 | ) 144 | it 145 | "renders _ correctly as '_'" 146 | (renderErlTerm (ErlAtom "_") `shouldBe` "'_'.") 147 | it 148 | "renders an empty string correctly as ''" 149 | (renderErlTerm (ErlAtom "") `shouldBe` "''.") 150 | it 151 | "renders a string and escapes special characters" 152 | ( renderErlTerm (ErlString "' $s\"<\\.0_=@\ESC''") 153 | `shouldBe` "\"' $s\\\"<\\\\.0_=@\\x{1b}''\"." 154 | ) 155 | it "renders an empty list" (renderErlTerm (ErlList []) `shouldBe` "[].") 156 | it "renders an empty tuple" (renderErlTerm (ErlTuple []) `shouldBe` "{}.") 157 | describe "renderErlTerm and parseErlTerm" $ 158 | it 159 | "parseErlTerm parses all terms rendered by renderErlTerm" 160 | (property parsesRenderedTerms) 161 | 162 | parsesRenderedTerms :: SimpleErlangTerm -> Bool 163 | parsesRenderedTerms term = 164 | either error (term ==) (parseErlTerm "test" (renderErlTerm term)) 165 | 166 | naturals :: String 167 | naturals = ['0' .. '9'] ++ ['a' .. 'z'] 168 | 169 | convertStrToDecimal :: Int -> String -> Integer 170 | convertStrToDecimal radix digitChars = 171 | let hornersMethod acc d = acc * radixHighPrecision + digitCharToInteger d 172 | digitCharToInteger d = toInteger $ fromJust $ elemIndex d naturals 173 | radixHighPrecision = toInteger radix 174 | in foldl hornersMethod 0 digitChars 175 | -------------------------------------------------------------------------------- /src/tests/B9/Content/ErlangPropListSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module B9.Content.ErlangPropListSpec 4 | ( spec, 5 | ) 6 | where 7 | 8 | import B9.Artifact.Content.ErlTerms 9 | import B9.Artifact.Content.ErlangPropList 10 | import B9.Text 11 | import Data.List 12 | import Data.Text () 13 | import Test.Hspec 14 | import Test.QuickCheck 15 | 16 | spec :: Spec 17 | spec = describe "ErlangPropList" $ do 18 | it "parseFromText" $ 19 | let v = parseFromText "ok." 20 | in v `shouldBe` Right (ErlangPropList (ErlAtom "ok")) 21 | it "renterToText" $ 22 | let v = renderToText (ErlangPropList (ErlAtom "ok")) 23 | in v `shouldBe` Right "ok." 24 | it "combines primitives by putting them in a list" $ 25 | let p1 = ErlangPropList (ErlList [ErlAtom "a"]) 26 | p2 = ErlangPropList (ErlList [ErlNatural 123]) 27 | combined = ErlangPropList (ErlList [ErlAtom "a", ErlNatural 123]) 28 | in (p1 <> p2) `shouldBe` combined 29 | it "combines a list and a primitve by extending the list" $ 30 | let (Right l) = 31 | parseFromText "[a,b,c]." :: Either String ErlangPropList 32 | (Right p) = parseFromText "{ok,value}." 33 | (Right combined) = parseFromText "[a,b,c,{ok,value}]." 34 | in l <> p `shouldBe` combined 35 | it "combines a primitve and a list by extending the list" $ 36 | let (Right l) = 37 | parseFromText "[a,b,c]." :: Either String ErlangPropList 38 | (Right p) = parseFromText "{ok,value}." 39 | (Right combined) = parseFromText "[{ok,value},a,b,c]." 40 | in p <> l `shouldBe` combined 41 | it 42 | "merges lists with distinct elements to lists containing the elements of both lists" 43 | $ let p1 = 44 | ErlangPropList 45 | (ErlList [ErlTuple [ErlAtom "k_p1", ErlList [ErlNatural 1]]]) 46 | p2 = 47 | ErlangPropList 48 | (ErlList [ErlTuple [ErlAtom "k_p2", ErlList [ErlNatural 1]]]) 49 | expected = 50 | ErlangPropList 51 | ( ErlList 52 | [ ErlTuple [ErlAtom "k_p1", ErlList [ErlNatural 1]], 53 | ErlTuple [ErlAtom "k_p2", ErlList [ErlNatural 1]] 54 | ] 55 | ) 56 | in p1 <> p2 `shouldBe` expected 57 | it 58 | "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" 59 | (property mergedPropListsHaveCorrectLength) 60 | 61 | data ErlPropListTestData 62 | = ErlPropListTestData 63 | { plistLeft :: [SimpleErlangTerm], 64 | plistRight :: [SimpleErlangTerm], 65 | commonKeys :: [SimpleErlangTerm] 66 | } 67 | deriving (Eq, Ord, Show) 68 | 69 | mergedPropListsHaveCorrectLength :: ErlPropListTestData -> Bool 70 | mergedPropListsHaveCorrectLength (ErlPropListTestData l r common) = 71 | let (ErlangPropList (ErlList merged)) = 72 | ErlangPropList (ErlList l) <> ErlangPropList (ErlList r) 73 | expectedLen = length l + length r - length common 74 | in length merged == expectedLen 75 | 76 | instance Arbitrary ErlPropListTestData where 77 | arbitrary = do 78 | someKeys <- nub <$> listOf arbitraryPlistKey 79 | numLeftOnly <- choose (0, length someKeys - 1) 80 | let keysLeftOnly = take numLeftOnly someKeys 81 | numCommon <- choose (0, length someKeys - numLeftOnly - 1) 82 | let keysCommon = take numCommon (drop numLeftOnly someKeys) 83 | let keysRightOnly = drop (numLeftOnly + numCommon) someKeys 84 | let numRightOnly = length someKeys - numLeftOnly - numCommon 85 | valuesLeft <- vectorOf (numLeftOnly + numCommon) arbitraryPlistValue 86 | valuesRight <- vectorOf (numRightOnly + numCommon) arbitraryPlistValue 87 | return 88 | ErlPropListTestData 89 | { plistLeft = zipWith toPair (keysLeftOnly <> keysCommon) valuesLeft, 90 | plistRight = zipWith toPair (keysRightOnly <> keysCommon) valuesRight, 91 | commonKeys = keysCommon 92 | } 93 | where 94 | toPair a b = ErlTuple [a, b] 95 | arbitraryPlist = ErlList <$> listOf arbitraryPlistEntry 96 | arbitraryPlistEntry = toPair <$> arbitraryPlistKey <*> arbitraryPlistValue 97 | arbitraryPlistKey = arbitraryErlSimpleAtom 98 | arbitraryPlistValue = 99 | oneof [arbitraryLiteral, arbitraryList, arbitraryPlist, arbitraryTuple] 100 | arbitraryTuple = ErlTuple <$> listOf arbitraryPlistValue 101 | arbitraryList = ErlList <$> listOf arbitraryPlistValue 102 | arbitraryLiteral = 103 | oneof [arbitraryPlistKey, arbitraryErlString, arbitraryErlNumber] 104 | -------------------------------------------------------------------------------- /src/tests/B9/Content/YamlObjectSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module B9.Content.YamlObjectSpec 4 | ( spec, 5 | ) 6 | where 7 | 8 | import B9.Artifact.Content.AST 9 | import B9.Artifact.Content.CloudConfigYaml 10 | import B9.Artifact.Content.YamlObject 11 | import Data.Text () 12 | import Data.Yaml 13 | import Test.Hspec 14 | 15 | spec :: Spec 16 | spec = do 17 | describe "YamlObject" $ do 18 | it "combines primitives by putting them in an array" $ 19 | let v1 = YamlObject (toJSON True) 20 | v2 = YamlObject (toJSON (123 :: Int)) 21 | combined = YamlObject (array [toJSON True, toJSON (123 :: Int)]) 22 | in (v1 <> v2) `shouldBe` combined 23 | it 24 | "combines objects with disjunct keys to an object containing all properties" 25 | $ let plist1 = YamlObject (object ["k1" .= Number 1]) 26 | plist2 = YamlObject (object ["k2" .= Number 2]) 27 | combined = 28 | YamlObject (object ["k1" .= Number 1, "k2" .= Number 2]) 29 | in (plist1 <> plist2) `shouldBe` combined 30 | it "combines arrays by concatenating them" $ 31 | let v1 = YamlObject (array [toJSON ("x" :: String)]) 32 | v2 = YamlObject (array [toJSON ("y" :: String)]) 33 | combined = 34 | YamlObject 35 | (array [toJSON ("x" :: String), toJSON ("y" :: String)]) 36 | in (v1 <> v2) `shouldBe` combined 37 | it 38 | "combines objects to a an object containing all disjunct entries and combined entries with the same keys" 39 | $ let o1 = YamlObject (object ["k1" .= Number 1, "k" .= Number 2]) 40 | o2 = YamlObject (object ["k2" .= Number 3, "k" .= Number 4]) 41 | combined = 42 | YamlObject 43 | ( object 44 | [ "k1" .= Number 1, 45 | "k2" .= Number 3, 46 | "k" .= array [Number 2, Number 4] 47 | ] 48 | ) 49 | in (o1 <> o2) `shouldBe` combined 50 | describe "CloudConfigYaml" $ do 51 | it 52 | "combines 'write_files' and 'runcmd' from typical 'user-data' files by merging each" 53 | $ let ud1, ud2 :: CloudConfigYaml 54 | (Right ud1) = 55 | parseFromTextWithErrorMessage 56 | "" 57 | "#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" 58 | (Right ud2) = 59 | parseFromTextWithErrorMessage 60 | "" 61 | "#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" 62 | ud = 63 | MkCloudConfigYaml $ 64 | YamlObject 65 | ( object 66 | [ "runcmd" 67 | .= array 68 | [toJSON ("x y z" :: String), toJSON ("a b c" :: String)], 69 | "write_files" 70 | .= array 71 | [ object 72 | [ "contents" .= toJSON ("hello world!\n" :: String), 73 | "path" .= toJSON ("/sdf/xyz/filename.cfg" :: String), 74 | "owner" .= toJSON ("root:root" :: String) 75 | ], 76 | object 77 | [ "contents" .= toJSON ("hello world2!\n" :: String), 78 | "path" .= toJSON ("/sdf/xyz/filename.cfg" :: String), 79 | "owner" .= toJSON ("root:root" :: String) 80 | ] 81 | ] 82 | ] 83 | ) 84 | in ud1 <> ud2 `shouldBe` ud 85 | it "combines strings by appending them" $ 86 | let o1 = 87 | MkCloudConfigYaml $ 88 | YamlObject (object ["k" .= toJSON ("Hello" :: String)]) 89 | o2 = 90 | MkCloudConfigYaml $ 91 | YamlObject (object ["k" .= toJSON ("World" :: String)]) 92 | combined = 93 | MkCloudConfigYaml $ 94 | YamlObject 95 | (object ["k" .= toJSON ("HelloWorld" :: String)]) 96 | in (o1 <> o2) `shouldBe` combined 97 | -- describe "fromAST YamlObject" $ do 98 | -- 99 | -- it "returns x from (AST x)" $ 100 | -- let x = (object []) 101 | -- lift :: a -> ReaderT Environment IO a 102 | -------------------------------------------------------------------------------- /src/tests/B9/DiskImageBuilderSpec.hs: -------------------------------------------------------------------------------- 1 | module B9.DiskImageBuilderSpec (spec) where 2 | 3 | import Test.Hspec 4 | import B9 5 | import Control.Exception 6 | import Control.Eff 7 | import System.Directory 8 | import System.Environment 9 | import System.Process 10 | import Control.Arrow ((>>>)) 11 | 12 | spec :: Spec 13 | spec = do 14 | it "can extract the virtual size from qemu-img info output" $ do 15 | e <- b9Wrapper [] $ do 16 | d <- getBuildDir 17 | let outFile = d "test.raw" 18 | materializeImageSource 19 | (EmptyImage "test" Ext4 Raw (ImageSize 10 MB)) 20 | (Image outFile Raw Ext4) 21 | getVirtualSizeForRawImage outFile 22 | e `shouldBe` Right (10 * 1024 * 1024) 23 | 24 | it "passes the mkfs.ext4 options defined in the B9Config" $ do 25 | let expectedOptions = ["^metadata_csum", "64bit"] 26 | actual <- b9Wrapper expectedOptions $ do 27 | d <- getBuildDir 28 | let outFile = d "test.raw" 29 | materializeImageSource 30 | (EmptyImage "test" Ext4 Raw (ImageSize 10 MB)) 31 | (Image outFile Raw Ext4) 32 | lift (readProcess "tune2fs" ["-l", outFile] "") 33 | let fsOptions = lines >>> map (stripPrefix "Filesystem features:") >>> catMaybes >>> mconcat >>> words $ actual 34 | fsOptions `shouldContain` ["64bit"] 35 | fsOptions `shouldNotContain` ["metadata_csum"] 36 | 37 | b9Wrapper :: HasCallStack => [String] -> B9 a -> IO a 38 | b9Wrapper ext4TestAttributes effect = 39 | withTempBuildDirs $ \cfgOverride -> 40 | let cfg = overrideExt4Attributes ext4TestAttributes cfgOverride 41 | in runB9ConfigActionWithOverrides (runB9 effect) cfg 42 | 43 | withTempBuildDirs :: HasCallStack => (B9ConfigOverride -> IO a) -> IO a 44 | withTempBuildDirs k = 45 | bracket acquire release use 46 | where 47 | acquire = do 48 | nixOutDirEnv <- lookupEnv "NIX_BUILD_TOP" 49 | let rootDir = maybe InTempDir (((.) . (.)) Path ()) nixOutDirEnv 50 | repoRelPath <- printf "testsDiskImageBuilderSpec-test-repo-%U" <$> randomUUID 51 | buildRelPath <- printf "DiskImageBuilderSpec-root-%U" <$> randomUUID 52 | cfgRelPath <- printf "DiskImageBuilderSpec-b9cfg-%U" <$> randomUUID 53 | let tmpRepoPath = rootDir ("tests" repoRelPath) 54 | tmpBuildPath = rootDir ("tests" buildRelPath) 55 | tmpCfgPath = rootDir ("tests" cfgRelPath) 56 | ensureSystemPath tmpRepoPath 57 | ensureSystemPath tmpBuildPath 58 | tmpBuildPathFileName <- resolve tmpBuildPath 59 | return (tmpRepoPath, tmpBuildPathFileName, tmpCfgPath) 60 | release (tmpRepoPath, tmpBuildPathFileName, tmpCfgPath) = do 61 | let cleanupTmpPath = removePathForcibly <=< resolve 62 | cleanupTmpPath tmpRepoPath 63 | cleanupTmpPath tmpCfgPath 64 | removePathForcibly tmpBuildPathFileName 65 | use (tmpRepoPath, tmpBuildPathFileName, tmpCfgPath) = 66 | let mkCfg cfgIn = 67 | cfgIn 68 | { _repositoryCache = Just tmpRepoPath, 69 | _projectRoot = Just tmpBuildPathFileName 70 | } 71 | oCfg = 72 | overrideB9Config 73 | mkCfg 74 | ( overrideWorkingDirectory 75 | tmpBuildPathFileName 76 | ( overrideDefaultB9ConfigPath 77 | tmpCfgPath 78 | noB9ConfigOverride 79 | ) 80 | ) 81 | in k oCfg 82 | -------------------------------------------------------------------------------- /src/tests/B9/DiskImagesSpec.hs: -------------------------------------------------------------------------------- 1 | module B9.DiskImagesSpec (spec) where 2 | 3 | import B9.DiskImages 4 | import Test.Hspec 5 | import Test.QuickCheck 6 | 7 | spec :: Spec 8 | spec = 9 | describe "DiskImages" $ do 10 | describe "splitToIntermediateSharedImage" $ 11 | do 12 | it "puts the original source into the intermediate target" $ 13 | property 14 | ( \target name -> 15 | itImageSource target 16 | == itImageSource 17 | (fst (splitToIntermediateSharedImage target name)) 18 | ) 19 | it "puts the original destination into the export target" $ 20 | property 21 | ( \target name -> 22 | itImageDestination target 23 | == itImageDestination 24 | (snd (splitToIntermediateSharedImage target name)) 25 | ) 26 | it 27 | "puts the intermediate shared image name into both the intermediate and the export target" 28 | $ property 29 | ( \target name -> 30 | let (intermediateTarget, exportTarget) = 31 | splitToIntermediateSharedImage target name 32 | in imageDestinationSharedImageName 33 | (itImageDestination intermediateTarget) 34 | == imageSourceSharedImageName (itImageSource exportTarget) 35 | ) 36 | context 37 | "inline unit tests" 38 | unitTests 39 | -------------------------------------------------------------------------------- /src/tests/B9/EnvironmentSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module B9.EnvironmentSpec 4 | ( spec, 5 | ) 6 | where 7 | 8 | import B9.Environment 9 | import Control.Eff 10 | import Data.Text 11 | import Test.Hspec 12 | 13 | spec :: Spec 14 | spec = 15 | describe "Environment" 16 | $ describe "addLocalPositionalArguments" 17 | $ do 18 | let k = 13 :: Integer 19 | j = 7 :: Integer 20 | n = 13 :: Integer 21 | args = [pack (show i) | i <- [1 .. n]] 22 | k_key = pack ("arg_" ++ show k) 23 | j_key = pack ("arg_" ++ show j) 24 | k_value = pack (show k) 25 | j_value = pack (show j) 26 | testEnv = addPositionalArguments args mempty 27 | inEnv = run . runEnvironmentReader testEnv 28 | it "generates keys prefixed with arg_ followed by an ascending numeric index, starting with 1" $ 29 | let res = inEnv $ do 30 | ej_value <- lookupEither j_key 31 | ek_value <- lookupEither k_key 32 | e_arg_0 <- lookupEither "arg_0" 33 | return (ej_value, ek_value, e_arg_0) 34 | in res `shouldBe` (Right j_value, Right k_value, Left (MkKeyNotFound "arg_0" testEnv)) 35 | -- run . runEnvironmentReader testEnv $ do 36 | -------------------------------------------------------------------------------- /src/tests/B9/RepositoryIOSpec.hs: -------------------------------------------------------------------------------- 1 | module B9.RepositoryIOSpec 2 | ( spec, 3 | ) 4 | where 5 | 6 | import B9 (ppShow) 7 | import B9.Artifact.Readable 8 | import B9.Artifact.Readable.Interpreter (assemble) 9 | import B9.B9Config 10 | import B9.B9Error 11 | import B9.B9Logging 12 | import B9.B9Monad 13 | import B9.BuildInfo 14 | import B9.DiskImages 15 | import B9.Repository 16 | import B9.RepositoryIO 17 | import B9.Vm 18 | import Control.Concurrent (threadDelay) 19 | import Control.Exception 20 | import Control.Monad 21 | import Data.Foldable 22 | import qualified Data.Map as Map 23 | import qualified Data.Set as Set 24 | import System.Directory 25 | import System.Environment 26 | import System.FilePath 27 | import System.IO.B9Extras 28 | import Test.Hspec 29 | import Text.Printf 30 | 31 | spec :: HasCallStack => Spec 32 | spec = do 33 | let cleanCacheAndLookupImages mkCfg buildAction = 34 | withTempBuildDirs $ \cfgWithRepo -> do 35 | let cfg = overrideB9Config mkCfg cfgWithRepo 36 | buildCfg = overrideB9Config noCleanupCfg cfgWithRepo 37 | x <- buildAction buildCfg 38 | y <- 39 | allCachedSharedImages 40 | <$> b9Build 41 | cfg 42 | ( cleanLocalRepoCache 43 | *> infoL "SEARCHING FOR SHARED IMAGES" 44 | *> getSharedImages 45 | ) 46 | return (x, y) 47 | shareAndLookupTestImages mkCfg = 48 | withTempBuildDirs $ \cfgWithRepo -> do 49 | let cfg = overrideB9Config mkCfg cfgWithRepo 50 | putStrLn (ppShow cfg) 51 | sharedImagesExpected <- shareTestImages cfg 52 | sharedImagesActual <- 53 | allCachedSharedImages 54 | <$> b9Build cfg getSharedImages 55 | return (sharedImagesExpected, sharedImagesActual) 56 | testBuilds3X2 = 57 | replicate 58 | 3 59 | [ ( t, 60 | ImageTarget 61 | (Share t Raw KeepSize) 62 | (EmptyImage t Ext4 Raw (ImageSize 10 MB)) 63 | NotMounted 64 | ) 65 | | t <- ["testImg0", "testImg1"] 66 | ] 67 | shareTestImages cfg = fmap concat 68 | <$> forM testBuilds3X2 69 | $ \testTargets -> 70 | do 71 | threadDelay 1200000 72 | forM testTargets $ \(t, dest) -> 73 | b9Build 74 | cfg 75 | ( assemble 76 | (Artifact (IID t) (VmImages [dest] NoVmScript)) 77 | *> ( SharedImage (SharedImageName t) 78 | <$> (SharedImageDate <$> getBuildDate) 79 | <*> (SharedImageBuildId <$> getBuildId) 80 | <*> pure Raw 81 | <*> pure Ext4 82 | ) 83 | ) 84 | describe "shared_image_cache_cleanup" $ do 85 | context "_maxLocalSharedImageRevisions == Nothing" $ do 86 | context "no images in cache" $ do 87 | it "does nothing and returns no error" $ 88 | cleanCacheAndLookupImages noCleanupCfg (const (return ())) 89 | >>= (`shouldBe` mempty) . snd 90 | context "two images names with each three versions" $ do 91 | it "removes ALL images" $ 92 | cleanCacheAndLookupImages noCleanupCfg shareTestImages 93 | >>= (`shouldBe` mempty) . snd 94 | context "_maxLocalSharedImageRevisions == Just 1" $ do 95 | context "no images in cache" $ do 96 | it "does nothing and returns no error" $ 97 | cleanCacheAndLookupImages 98 | (cleanupAfterBuildCfg 1) 99 | (const (return ())) 100 | >>= (`shouldBe` mempty) . snd 101 | context "two images names with each three versions" $ do 102 | it "retains the latest image of each subset with the same name (somehow they must procreate, right? ;)" $ do 103 | (generatedImages, actual) <- 104 | cleanCacheAndLookupImages 105 | (cleanupAfterBuildCfg 1) 106 | ( \c -> 107 | shareTestImages c 108 | *> (b9Build c (allCachedSharedImages <$> getSharedImages)) 109 | ) 110 | let expected = 111 | fold 112 | ( Map.map 113 | (Set.drop 2) 114 | (groupBySharedImageName generatedImages) 115 | ) 116 | actual `shouldBe` expected 117 | -- TODO describe "pull shared images" $ do 118 | describe "create & share images" $ do 119 | describe "Without autmatic cleanup" 120 | $ it "returns all shared images that were built" 121 | $ do 122 | (sharedImagesExpected, sharedImagesActual) <- 123 | shareAndLookupTestImages noCleanupCfg 124 | sharedImagesActual `shouldBe` Set.fromList sharedImagesExpected 125 | describe "with automatic cleanup after build enabled in _maxLocalSharedImageRevisions" $ do 126 | describe "with an invalid parameter _maxLocalSharedImageRevisions == Just 0" $ do 127 | it "does nothing and exits with error" $ 128 | shareAndLookupTestImages (cleanupAfterBuildCfg (-1)) 129 | `shouldThrow` (const True :: Selector SomeException) 130 | describe "with an invalid parameter _maxLocalSharedImageRevisions == Just -1" $ do 131 | it "does nothing and exits with error" $ 132 | shareAndLookupTestImages (cleanupAfterBuildCfg 0) 133 | `shouldThrow` (const True :: Selector B9Error) 134 | describe "with a valid parameter _maxLocalSharedImageRevisions == Just 1" $ do 135 | it "returns the latest of all shared images that were built" $ do 136 | (sharedImagesExpected, sharedImagesActual) <- 137 | shareAndLookupTestImages (cleanupAfterBuildCfg 1) 138 | sharedImagesActual `shouldBe` keepNLatestSharedImages 1 (Set.fromList sharedImagesExpected) 139 | describe "with a valid parameter _maxLocalSharedImageRevisions == Just 2" $ do 140 | it "returns the latest two of all shared images that were built" $ do 141 | (sharedImagesExpected, sharedImagesActual) <- 142 | shareAndLookupTestImages (cleanupAfterBuildCfg 2) 143 | sharedImagesActual `shouldBe` keepNLatestSharedImages 2 (Set.fromList sharedImagesExpected) 144 | describe "with a valid parameter _maxLocalSharedImageRevisions == Just 3000" $ do 145 | it "returns the latest 3000 of all shared images that were built" $ do 146 | (sharedImagesExpected, sharedImagesActual) <- 147 | shareAndLookupTestImages (cleanupAfterBuildCfg 3000) 148 | sharedImagesActual `shouldBe` Set.fromList sharedImagesExpected 149 | 150 | noCleanupCfg :: B9Config -> B9Config 151 | noCleanupCfg c = 152 | c {_maxLocalSharedImageRevisions = Nothing} 153 | 154 | cleanupAfterBuildCfg :: Int -> B9Config -> B9Config 155 | cleanupAfterBuildCfg n c = 156 | c {_maxLocalSharedImageRevisions = Just n} 157 | 158 | b9Build :: HasCallStack => B9ConfigOverride -> B9 a -> IO a 159 | b9Build cfg effect = 160 | runB9ConfigActionWithOverrides 161 | (runB9 effect) 162 | cfg 163 | 164 | withTempBuildDirs :: HasCallStack => (B9ConfigOverride -> IO a) -> IO a 165 | withTempBuildDirs k = 166 | bracket acquire release use 167 | where 168 | acquire = do 169 | nixOutDirEnv <- lookupEnv "NIX_BUILD_TOP" 170 | let rootDir = maybe InTempDir (((.) . (.)) Path ()) nixOutDirEnv 171 | repoRelPath <- printf "testsRepositoryIOSpec-test-repo-%U" <$> randomUUID 172 | buildRelPath <- printf "RepositoryIOSpec-root-%U" <$> randomUUID 173 | cfgRelPath <- printf "RepositoryIOSpec-b9cfg-%U" <$> randomUUID 174 | let tmpRepoPath = rootDir ("tests" repoRelPath) 175 | tmpBuildPath = rootDir ("tests" buildRelPath) 176 | tmpCfgPath = rootDir ("tests" cfgRelPath) 177 | ensureSystemPath tmpRepoPath 178 | ensureSystemPath tmpBuildPath 179 | tmpBuildPathFileName <- resolve tmpBuildPath 180 | return (tmpRepoPath, tmpBuildPathFileName, tmpCfgPath) 181 | release (tmpRepoPath, tmpBuildPathFileName, tmpCfgPath) = do 182 | let cleanupTmpPath = removePathForcibly <=< resolve 183 | cleanupTmpPath tmpRepoPath 184 | cleanupTmpPath tmpCfgPath 185 | removePathForcibly tmpBuildPathFileName 186 | use (tmpRepoPath, tmpBuildPathFileName, tmpCfgPath) = 187 | let mkCfg cfgIn = 188 | cfgIn 189 | { _repositoryCache = Just tmpRepoPath, 190 | _projectRoot = Just tmpBuildPathFileName 191 | } 192 | oCfg = 193 | overrideB9Config 194 | mkCfg 195 | ( overrideWorkingDirectory 196 | tmpBuildPathFileName 197 | ( overrideDefaultB9ConfigPath 198 | tmpCfgPath 199 | noB9ConfigOverride 200 | ) 201 | ) 202 | in k oCfg 203 | -------------------------------------------------------------------------------- /src/tests/B9/Shake/SharedImageRulesSpec.hs: -------------------------------------------------------------------------------- 1 | module B9.Shake.SharedImageRulesSpec 2 | ( spec, 3 | ) 4 | where 5 | 6 | import B9.Artifact.Readable 7 | import B9.Artifact.Readable.Interpreter (assemble) 8 | import B9.B9Config 9 | import B9.B9Monad 10 | import B9.DiskImages 11 | import B9.Repository 12 | import B9.RepositoryIO 13 | import B9.Shake.SharedImageRules 14 | import B9.Vm 15 | import Control.Exception 16 | import Control.Monad 17 | import qualified Data.Set as Set 18 | import Development.Shake as Shake 19 | import System.Directory 20 | import System.Environment 21 | import System.FilePath 22 | import System.IO.B9Extras 23 | import Test.Hspec 24 | import Text.Printf 25 | 26 | testShakeBuild :: B9ConfigOverride -> IO () 27 | testShakeBuild cfg = shake shakeOptions $ do 28 | enableSharedImageRules cfg 29 | customSharedImageAction (SharedImageName "test") $ 30 | liftIO 31 | ( b9Build 32 | cfg 33 | ( void 34 | ( assemble 35 | ( Artifact 36 | (IID "test-image") 37 | ( VmImages 38 | [ ImageTarget 39 | (Share "test" Raw KeepSize) 40 | (EmptyImage "test" Ext4 Raw (ImageSize 10 MB)) 41 | NotMounted 42 | ] 43 | NoVmScript 44 | ) 45 | ) 46 | ) 47 | ) 48 | ) 49 | action (needSharedImage (SharedImageName "test")) 50 | 51 | spec :: HasCallStack => Spec 52 | spec = do 53 | context "missing shared image" $ do 54 | it "builds a missing image" $ do 55 | withTempBuildDirs $ \cfg -> do 56 | testShakeBuild cfg 57 | actualImages <- b9Build cfg (allCachedSharedImages <$> getSharedImages) 58 | Set.size actualImages `shouldBe` 1 59 | 60 | b9Build :: HasCallStack => B9ConfigOverride -> B9 a -> IO a 61 | b9Build cfg effect = 62 | runB9ConfigActionWithOverrides 63 | (runB9 effect) 64 | cfg 65 | 66 | withTempBuildDirs :: HasCallStack => (B9ConfigOverride -> IO a) -> IO a 67 | withTempBuildDirs k = 68 | bracket acquire release use 69 | where 70 | acquire = do 71 | nixOutDirEnv <- lookupEnv "NIX_BUILD_TOP" 72 | let rootDir = maybe InTempDir (((.) . (.)) Path ()) nixOutDirEnv 73 | repoRelPath <- printf "testsRepositoryIOSpec-test-repo-%U" <$> randomUUID 74 | buildRelPath <- printf "RepositoryIOSpec-root-%U" <$> randomUUID 75 | cfgRelPath <- printf "RepositoryIOSpec-b9cfg-%U" <$> randomUUID 76 | let tmpRepoPath = rootDir ("tests" repoRelPath) 77 | tmpBuildPath = rootDir ("tests" buildRelPath) 78 | tmpCfgPath = rootDir ("tests" cfgRelPath) 79 | ensureSystemPath tmpRepoPath 80 | ensureSystemPath tmpBuildPath 81 | tmpBuildPathFileName <- resolve tmpBuildPath 82 | return (tmpRepoPath, tmpBuildPathFileName, tmpCfgPath) 83 | release (tmpRepoPath, tmpBuildPathFileName, tmpCfgPath) = do 84 | let cleanupTmpPath = removePathForcibly <=< resolve 85 | cleanupTmpPath tmpRepoPath 86 | cleanupTmpPath tmpCfgPath 87 | removePathForcibly tmpBuildPathFileName 88 | use (tmpRepoPath, tmpBuildPathFileName, tmpCfgPath) = 89 | let mkCfg cfgIn = 90 | cfgIn 91 | { _repositoryCache = Just tmpRepoPath, 92 | _projectRoot = Just tmpBuildPathFileName 93 | } 94 | oCfg = 95 | overrideB9Config 96 | mkCfg 97 | ( overrideWorkingDirectory 98 | tmpBuildPathFileName 99 | ( overrideDefaultB9ConfigPath 100 | tmpCfgPath 101 | noB9ConfigOverride 102 | ) 103 | ) 104 | in k oCfg 105 | -------------------------------------------------------------------------------- /src/tests/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | --------------------------------------------------------------------------------