├── lib ├── qemu_snapshot.mli ├── archive_extract.mli ├── log.ml ├── btrfs_store.mli ├── overlayfs_store.mli ├── qemu_store.mli ├── zfs_clone.mli ├── docker_store.mli ├── qemu_snapshot.ml ├── zfs_store.mli ├── escape.ml ├── qemu_sandbox.mli ├── sandbox.mli ├── manifest.mli ├── rsync_store.mli ├── archive_extract.ml ├── xfs_store.mli ├── dune ├── config.ml ├── obuilder.ml ├── build.mli ├── db_store.mli ├── zfs_clone.ml ├── build_log.mli ├── tar_transfer.mli ├── db.ml ├── docker_sandbox.mli ├── macos.ml ├── docker.mli ├── manifest.ml ├── build_log.ml ├── store_spec.ml ├── xfs_store.ml ├── dao.ml ├── sandbox.macos.ml ├── qemu_store.ml ├── rsync_store.ml ├── sandbox.jail.ml ├── db_store.ml ├── btrfs_store.ml ├── docker_store.ml └── qemu_sandbox.ml ├── .gitignore ├── Makefile ├── qemu ├── id_ed25519.pub ├── disklabel ├── busybox.yaml ├── install.conf ├── user-data.yaml.m4 ├── install.site.m4 └── Makefile ├── .gitattributes ├── lib_spec ├── obuilder_spec.ml ├── dune ├── cache.mli ├── secret.mli ├── cache.ml ├── docker.mli ├── secret.ml ├── spec.mli ├── docker.ml └── spec.ml ├── test ├── macos │ ├── specs │ │ ├── opam.macos.spec │ │ └── simple.macos.spec │ ├── dune │ ├── macos.sh │ └── simple.expected ├── dummy.ml ├── mock_sandbox.mli ├── dune ├── mock_store.mli ├── mock_sandbox.ml ├── log.ml ├── mock_store.ml └── mock_exec.ml ├── stress ├── dune └── stress.ml ├── doc ├── index.mld ├── macOS.md └── macOS.mld ├── stress.sh ├── dune ├── static ├── extract.cmd └── manifest.bash ├── obuilder-spec.opam ├── dune-project ├── obuilder.opam ├── example.spec ├── example.windows.spec ├── .github └── workflows │ ├── main.yml │ └── main.sh ├── CHANGES.md └── main.ml /lib/qemu_snapshot.mli: -------------------------------------------------------------------------------- 1 | include S.FETCHER 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .merlin 2 | _build 3 | _opam 4 | .vscode 5 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all 2 | 3 | all: 4 | dune build @install @runtest ./stress/stress.exe 5 | -------------------------------------------------------------------------------- /lib/archive_extract.mli: -------------------------------------------------------------------------------- 1 | (** Fetching of base images as .tar.gz archives *) 2 | 3 | include S.FETCHER 4 | -------------------------------------------------------------------------------- /qemu/id_ed25519.pub: -------------------------------------------------------------------------------- 1 | ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIA09mqKPpMJ4tyOpl4l+KTTl1DqjFT2mRD29HW8VwnmB root@alpha 2 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | *.cmd text eol=crlf 2 | *.bash text eol=lf 3 | *.sh text eol=lf 4 | test/test.ml text eol=lf 5 | -------------------------------------------------------------------------------- /lib/log.ml: -------------------------------------------------------------------------------- 1 | let src = Logs.Src.create "obuilder" ~doc:"OBuilder build system" 2 | include (val Logs.src_log src : Logs.LOG) 3 | -------------------------------------------------------------------------------- /lib_spec/obuilder_spec.ml: -------------------------------------------------------------------------------- 1 | include Spec 2 | 3 | module Cache = Cache 4 | module Secret = Secret 5 | module Docker = Docker 6 | -------------------------------------------------------------------------------- /test/macos/specs/opam.macos.spec: -------------------------------------------------------------------------------- 1 | ((from patricoferris/macos-opam:macos-homebrew-ocaml-4.12) 2 | (run (shell "./local/bin/opam --version"))) 3 | -------------------------------------------------------------------------------- /lib_spec/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name obuilder_spec) 3 | (public_name obuilder-spec) 4 | (preprocess (pps ppx_sexp_conv)) 5 | (libraries astring sexplib fmt)) 6 | -------------------------------------------------------------------------------- /stress/dune: -------------------------------------------------------------------------------- 1 | ; No-op test to attach stress.exe to the obuilder package 2 | (test 3 | (name stress) 4 | (libraries obuilder cmdliner fmt.tty) 5 | (package obuilder) 6 | (action (progn))) 7 | -------------------------------------------------------------------------------- /lib/btrfs_store.mli: -------------------------------------------------------------------------------- 1 | (** Store build results as Btrfs subvolumes. *) 2 | 3 | include S.STORE 4 | 5 | val create : string -> t Lwt.t 6 | (** [create path] is a new store in btrfs directory [path]. *) 7 | -------------------------------------------------------------------------------- /qemu/disklabel: -------------------------------------------------------------------------------- 1 | / 2G 2 | swap 2G 3 | /tmp 1G 4 | /var 1G 5 | /usr 2G 6 | /usr/X11R6 500M 7 | /usr/local 4G 8 | /usr/src 1M 9 | /usr/obj 1M 10 | /home 10G 11 | -------------------------------------------------------------------------------- /lib/overlayfs_store.mli: -------------------------------------------------------------------------------- 1 | (** Store build results using rsync. *) 2 | 3 | include S.STORE 4 | 5 | val create : path:string -> t Lwt.t 6 | (** [create ~path] creates a new overlayfs store where everything will 7 | be stored under [path]. *) 8 | -------------------------------------------------------------------------------- /lib/qemu_store.mli: -------------------------------------------------------------------------------- 1 | (** Store build results using qemu-img. *) 2 | 3 | include S.STORE 4 | 5 | val create : root:string -> t Lwt.t 6 | (** [create ~root] creates a new QEMU store directory where everything will 7 | be stored under [root]. *) 8 | -------------------------------------------------------------------------------- /lib/zfs_clone.mli: -------------------------------------------------------------------------------- 1 | include S.FETCHER 2 | (** The ZFS Clone fetcher assumes given some [base] "image" that 3 | there is a corresponding ZFS volume [obuilder/base-image/] 4 | and [zfs clones] this directory over to the provided [rootfs]. *) 5 | -------------------------------------------------------------------------------- /lib/docker_store.mli: -------------------------------------------------------------------------------- 1 | (** Store build results as Docker images. *) 2 | 3 | include S.STORE 4 | 5 | val create : string -> t Lwt.t 6 | (** [create root] is a new store using Docker images and [root] to store 7 | ancillary state. *) 8 | 9 | val cache_stats : t -> int * int 10 | -------------------------------------------------------------------------------- /test/dummy.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Printexc.record_backtrace true; 3 | let str = "the quick brown fox jumps over the lazy dog" in 4 | match Sys.argv.(1) with 5 | | "stdin" -> if read_line () <> str then exit 1 6 | | "stdout" -> print_string str 7 | | "stderr" -> prerr_string str 8 | | _ -> invalid_arg "Sys.argv" 9 | -------------------------------------------------------------------------------- /lib/qemu_snapshot.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | let ( / ) = Filename.concat 4 | 5 | let fetch ~log:_ ~root ~rootfs base = 6 | Os.sudo [ "qemu-img"; "create"; 7 | "-f"; "qcow2"; "-b"; root / "base-image" / (base ^ ".qcow2"); 8 | "-F"; "qcow2"; rootfs / "image.qcow2" ] >>= fun () -> 9 | Lwt.return [] 10 | 11 | -------------------------------------------------------------------------------- /test/macos/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (alias macos) 3 | (enabled_if (= %{system} macos)) 4 | (deps (source_tree specs)) 5 | (targets ./simple.out) 6 | (action 7 | (with-stdout-to ./simple.out (run ./macos.sh)))) 8 | 9 | (rule 10 | (alias macos) 11 | (enabled_if (= %{system} macos)) 12 | (action (diff simple.expected simple.out))) 13 | -------------------------------------------------------------------------------- /lib/zfs_store.mli: -------------------------------------------------------------------------------- 1 | (** Store build results as ZFS snapshots. *) 2 | 3 | include S.STORE 4 | 5 | val create : path:string -> t Lwt.t 6 | (** [create ~path] creates a new zfs store in a pool mounted at [path]. 7 | The pool name is [Filename.basename path]. If only a poolname is passed 8 | such as [tank] the path is inferred as [/tank].*) 9 | -------------------------------------------------------------------------------- /lib_spec/cache.mli: -------------------------------------------------------------------------------- 1 | type t = { 2 | id : string; 3 | target : string; 4 | buildkit_options : (string * string) list; (* Only used when converting to Docker BuildKit format. *) 5 | } [@@deriving sexp] 6 | 7 | val v : ?buildkit_options:(string * string) list -> target:string -> string -> t 8 | (** [v ~target id] mounts cache [id] at [target]. *) 9 | -------------------------------------------------------------------------------- /lib_spec/secret.mli: -------------------------------------------------------------------------------- 1 | type t = { 2 | id : string; 3 | target : string; 4 | buildkit_options : (string * string) list; (* Only used when converting to Docker BuildKit format. *) 5 | } [@@deriving sexp] 6 | 7 | val v : ?buildkit_options:(string * string) list -> ?target:string -> string -> t 8 | (** [v ~target id] mounts secret [id] at [target]. Default target is /run/secrets/[id]. *) 9 | -------------------------------------------------------------------------------- /test/mock_sandbox.mli: -------------------------------------------------------------------------------- 1 | include Obuilder.S.SANDBOX 2 | 3 | val create : unit -> t 4 | val expect : 5 | t -> (cancelled:unit Lwt.t -> 6 | ?stdin:Obuilder.Os.unix_fd -> 7 | log:Obuilder.Build_log.t -> 8 | Obuilder.Config.t -> 9 | string -> 10 | (unit, [`Msg of string | `Cancelled]) Lwt_result.t) -> 11 | unit 12 | val finished : unit -> unit Lwt.t 13 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (copy_files ../static/manifest.bash) 2 | 3 | (executable 4 | (name dummy) 5 | (public_name dummy) 6 | (package obuilder) 7 | (modules dummy)) 8 | 9 | (test 10 | (name test) 11 | (package obuilder) 12 | (deps base.tar manifest.bash %{bin:dummy}) 13 | (libraries alcotest-lwt obuilder str logs.fmt) 14 | (modules log mock_exec mock_sandbox mock_store test)) 15 | 16 | (dirs :standard \ test1) 17 | -------------------------------------------------------------------------------- /qemu/busybox.yaml: -------------------------------------------------------------------------------- 1 | #cloud-config 2 | users: 3 | - name: opam 4 | groups: [sudo] 5 | sudo: ALL=(ALL) NOPASSWD:ALL 6 | shell: /bin/bash 7 | ssh_authorized_keys: 8 | - ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIA09mqKPpMJ4tyOpl4l+KTTl1DqjFT2mRD29HW8VwnmB root@alpha 9 | runcmd: 10 | - echo "AcceptEnv=*" > /etc/ssh/sshd_config.d/acceptenv.conf 11 | - apt update 12 | - apt upgrade -y 13 | - poweroff 14 | -------------------------------------------------------------------------------- /test/macos/specs/simple.macos.spec: -------------------------------------------------------------------------------- 1 | ; Tests a bug where some directories/file from previous steps that were 2 | ; deleted where still hanging around. 3 | 4 | ((from patricoferris/empty@sha256:b95ca2b377dd736f609f0a10d63318c9f627a817823cf416402a29bfe9202bb9) 5 | (run (shell "mkdir hello")) 6 | (run (shell "echo 'hello world' > ./hello/hello.txt")) 7 | (run (shell "cat ./hello/hello.txt")) 8 | (run (shell "rm -rf hello")) 9 | (run (shell "ls"))) -------------------------------------------------------------------------------- /doc/index.mld: -------------------------------------------------------------------------------- 1 | {0 obuilder index} 2 | {1 Library obuilder} 3 | The entry point of this library is the module: 4 | {!module-Obuilder}. 5 | 6 | {1 Design and implementation of OBuilder} 7 | - {{!page-README}OBuilder's manual}. 8 | - {{!page-macOS}macOS implementation documentation}. 9 | - {{!page-freebsd}FreeBSD implementation documentation}. 10 | - {{!page-windows}Windows implementation documentation}. 11 | - {{!page-qemu}QEMU implementation documentation}. 12 | -------------------------------------------------------------------------------- /test/macos/macos.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | TMP_SCOREBOARD=$(mktemp -d 2>/dev/null || mktemp -d -t 'scoreboard') 3 | TMP_RSYNC=$(mktemp -d 2>/dev/null || mktemp -d -t 'rsync') 4 | dune exec -- obuilder build . -f ./specs/simple.macos.spec --uid=705 --store=rsync:$TMP_RSYNC --fallback=/ --scoreboard=$TMP_SCOREBOARD --no-fuse 5 | dune exec -- obuilder build . -f ./specs/simple.macos.spec --uid=705 --store=rsync:$TMP_RSYNC --fallback=/ --scoreboard=$TMP_SCOREBOARD --no-fuse 6 | rm -rf $TMP_SCOREBOARD $TMP_RSYNC -------------------------------------------------------------------------------- /lib/escape.ml: -------------------------------------------------------------------------------- 1 | (* Make a cache name safe to use as a filename. 2 | Different inputs must always produce different outputs. 3 | The output string will match /[-._A-Za-z0-9%]+/. *) 4 | let cache x = 5 | let b = Buffer.create (String.length x * 2) in 6 | Buffer.add_string b "c-"; 7 | x |> String.iter (function 8 | | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '.' | '_' | '-' as c -> Buffer.add_char b c 9 | | c -> Buffer.add_string b (Printf.sprintf "%%%x" (Char.code c)) 10 | ); 11 | Buffer.contents b 12 | -------------------------------------------------------------------------------- /lib/qemu_sandbox.mli: -------------------------------------------------------------------------------- 1 | (** Sandbox builds using QEMU. *) 2 | 3 | include S.SANDBOX 4 | 5 | type config [@@deriving sexp] 6 | (** The type of sandbox configurations *) 7 | 8 | val cmdliner : config Cmdliner.Term.t 9 | (** [cmdliner] is used for command-line interfaces to generate the 10 | necessary flags and parameters to setup a specific sandbox's 11 | configuration. *) 12 | 13 | val create : config -> t Lwt.t 14 | (** [create config] is a Docker sandboxing system that is configured 15 | using [config]. *) 16 | -------------------------------------------------------------------------------- /stress.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -eu 3 | if [ "$#" -lt 1 ]; then 4 | echo "usage: $0 STORE…" 5 | echo "e.g. $0 btrfs:/btrfs/stress zfs:stress" 6 | exit 1; 7 | fi; 8 | stores="$*" 9 | echo "Remove everything that depends on busybox…" 10 | for store in $stores; do 11 | echo Clean $store 12 | dune exec -- obuilder delete 9d75f0d7c398df565d7ac04c6819b62d6d8f9560f5eb4672596ecd8f7e96ae91 --store=$store 13 | done; 14 | for store in $stores; do 15 | echo Test $store 16 | dune exec ./stress/stress.exe --store=$store 17 | done; 18 | echo PASS 19 | -------------------------------------------------------------------------------- /test/mock_store.mli: -------------------------------------------------------------------------------- 1 | include Obuilder.S.STORE 2 | 3 | val with_store : (t -> 'a Lwt.t) -> 'a Lwt.t 4 | (** [with_store t fn] runs [fn] with a fresh store, which is deleted when [fn] returns. *) 5 | 6 | val path : t -> Obuilder.S.id -> string 7 | (** [path t id] is the path that [id] is or would be stored at. *) 8 | 9 | val find : output:string -> t -> Obuilder.S.id option Lwt.t 10 | (** [find ~output t] returns the ID of a build whose "rootfs/output" file contains [output], if any. *) 11 | 12 | val delay_store : (unit Lwt.t) ref 13 | (** Wait for this to resolve after a build function finishes, but before handling the result. *) 14 | -------------------------------------------------------------------------------- /lib_spec/cache.ml: -------------------------------------------------------------------------------- 1 | open Sexplib.Std 2 | open Sexplib.Sexp 3 | 4 | type t = { 5 | id : string; 6 | target : string; 7 | buildkit_options : (string * string) list [@sexp.list]; 8 | } [@@deriving sexp] 9 | 10 | let t_of_sexp x = 11 | match x with 12 | | List (Atom id :: fields) -> t_of_sexp (List (List [Atom "id"; Atom id] :: fields)) 13 | | x -> Fmt.failwith "Invalid cache: %a" Sexplib.Sexp.pp_hum x 14 | 15 | let sexp_of_t x = 16 | match sexp_of_t x with 17 | | List (List [Atom "id"; Atom id] :: fields) -> List (Atom id :: fields) 18 | | x -> Fmt.failwith "Invalid cache: %a" Sexplib.Sexp.pp_hum x 19 | 20 | let v ?(buildkit_options=[]) ~target id = { id; target; buildkit_options } 21 | -------------------------------------------------------------------------------- /lib/sandbox.mli: -------------------------------------------------------------------------------- 1 | (** Sandbox builds. *) 2 | 3 | include S.SANDBOX 4 | 5 | type config [@@deriving sexp] 6 | (** The type of sandbox configurations *) 7 | 8 | val cmdliner : config Cmdliner.Term.t 9 | (** [cmdliner] is used for command-line interfaces to generate the necessary flags 10 | and parameters to setup a specific sandbox's configuration. *) 11 | 12 | val create : state_dir:string -> config -> t Lwt.t 13 | (** [create ~state_dir config] is a sandboxing system that keeps state in [state_dir] 14 | and is configured using [config]. *) 15 | 16 | val finished : unit -> unit Lwt.t 17 | (** [finished] is a call back to the sandbox which is triggered when the current job 18 | is finished. The sandbox may choose do nothing. *) 19 | -------------------------------------------------------------------------------- /lib_spec/docker.mli: -------------------------------------------------------------------------------- 1 | val dockerfile_of_spec : buildkit:bool -> os:[`Unix | `Windows] -> Spec.t -> string 2 | (** [dockerfile_of_spec ~buildkit ~os x] produces a Dockerfile 3 | that aims to be equivalent to [x]. 4 | 5 | However, note that: 6 | 7 | - In "(copy (excludes …) …)" the excludes part is ignored. You will need to ensure 8 | you have a suitable ".dockerignore" file. 9 | - The conversion is not robust against malicious input, as the escaping rules are unclear. 10 | 11 | @param buildkit If true, the extended BuildKit syntax is used to 12 | support caches. If false, caches are ignored. BuildKit syntax 13 | isn't supported on Windows. 14 | @param os Use UNIX or Windows syntax and idiosyncrasies. *) 15 | -------------------------------------------------------------------------------- /qemu/install.conf: -------------------------------------------------------------------------------- 1 | Change the default console to com0 = no 2 | Which speed should com0 use = 115200 3 | System hostname = openbsd 4 | Password for root = ************* 5 | Allow root ssh login = no 6 | Setup a user = opam 7 | Password for user = ************* 8 | Public ssh key for user = ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIA09mqKPpMJ4tyOpl4l+KTTl1DqjFT2mRD29HW8VwnmB root@alpha 9 | What timezone are you in = UTC 10 | Location of sets = http 11 | HTTP Server = 10.0.2.2 12 | Unable to connect using https. Use http instead = yes 13 | URL to autopartitioning template for disklabel = http://10.0.2.2/disklabel 14 | Set name(s) = site77.tgz 15 | Checksum test for site77.tgz failed. Continue anyway = yes 16 | Unverified sets: site77.tgz. Continue without verification = yes 17 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (public_name obuilder) 3 | (name main) 4 | (package obuilder) 5 | (preprocess (pps ppx_deriving.show)) 6 | (libraries lwt lwt.unix fmt fmt.cli fmt.tty tar-unix obuilder cmdliner logs.fmt logs.cli)) 7 | 8 | 9 | ; (rule 10 | ; (targets README.mld macOS.mld windows.mld freebsd.mld) 11 | ; (deps README.md doc/macOS.md doc/windows.md doc/freebsd.md) 12 | ; (action 13 | ; (progn 14 | ; (with-stdout-to README.mld (run md2mld README.md)) 15 | ; (with-stdout-to macOS.mld (run md2mld doc/macOS.md)) 16 | ; (with-stdout-to freebsd.mld (run md2mld doc/freebsd.md)) 17 | ; (with-stdout-to windows.mld (run md2mld doc/windows.md))))) 18 | 19 | (copy_files doc/*.mld) 20 | 21 | (documentation 22 | (package obuilder) 23 | (mld_files :standard)) 24 | -------------------------------------------------------------------------------- /lib/manifest.mli: -------------------------------------------------------------------------------- 1 | type t = [ 2 | | `File of (string * Sha256.t) 3 | | `Symlink of (string * string) 4 | | `Dir of (string * t list) 5 | ] [@@deriving sexp] 6 | 7 | val generate : exclude:string list -> src_dir:string -> string -> (t, [> `Msg of string]) result 8 | (** [generate ~exclude ~src_dir src] returns a manifest of the subtree at [src_dir/src]. 9 | Note that [src_dir] is a native platform path, but [src] is always Unix-style. 10 | Files with basenames in [exclude] are ignored. 11 | Returns an error if [src] is not under [src_dir] or does not exist. *) 12 | 13 | val to_from_files : ?null:bool -> t -> string 14 | (** [to_from_files t] returns a buffer containing the list of files, 15 | separated by ASCII LF (the default) or NUL if [null] is true. *) 16 | -------------------------------------------------------------------------------- /lib_spec/secret.ml: -------------------------------------------------------------------------------- 1 | open Sexplib.Std 2 | open Sexplib.Sexp 3 | 4 | type t = { 5 | id : string; 6 | target : string; 7 | buildkit_options : (string * string) list [@sexp.list]; 8 | } [@@deriving sexp] 9 | 10 | let t_of_sexp x = 11 | match x with 12 | | List (Atom id :: fields) -> t_of_sexp (List (List [Atom "id"; Atom id] :: fields)) 13 | | x -> Fmt.failwith "Invalid secret: %a" Sexplib.Sexp.pp_hum x 14 | 15 | let sexp_of_t x = 16 | match sexp_of_t x with 17 | | List (List [Atom "id"; Atom id] :: fields) -> List (Atom id :: fields) 18 | | x -> Fmt.failwith "Invalid secret: %a" Sexplib.Sexp.pp_hum x 19 | 20 | let v ?(buildkit_options=[]) ?target id = 21 | let target = Option.value target ~default:("/run/secrets/"^id) in 22 | { id; target; buildkit_options } 23 | -------------------------------------------------------------------------------- /static/extract.cmd: -------------------------------------------------------------------------------- 1 | @echo off 2 | 3 | echo Copying to "%DESTINATION%" 4 | copy /v /b C:\manifest.bash "%DESTINATION%" 5 | copy /v /b C:\cygwin64\bin\basename.exe "%DESTINATION%" 6 | copy /v /b C:\cygwin64\bin\bash.exe "%DESTINATION%" 7 | copy /v /b C:\cygwin64\bin\cygpath.exe "%DESTINATION%" 8 | copy /v /b C:\cygwin64\bin\readlink.exe "%DESTINATION%" 9 | copy /v /b C:\cygwin64\bin\tar.exe "%DESTINATION%" 10 | copy /v /b C:\cygwin64\bin\sha256sum.exe "%DESTINATION%" 11 | 12 | for /f "usebackq delims=" %%f in (`C:\cygwin64\bin\bash.exe -lc "ldd -- /bin/basename.exe /bin/bash.exe /bin/cygpath.exe /bin/readlink.exe /bin/tar.exe /bin/sha256sum.exe | sed -ne 's|.* => \(/usr/bin/.*\) ([^)]*)$|\1|p' | sort -u | xargs cygpath -w"`) do ( 13 | copy /v /b "%%f" "%DESTINATION%" 14 | ) 15 | -------------------------------------------------------------------------------- /lib/rsync_store.mli: -------------------------------------------------------------------------------- 1 | (** Store build results using rsync. *) 2 | 3 | include S.STORE 4 | 5 | type mode = 6 | | Copy (** Fast but uses more disk space. *) 7 | | Hardlink (** Slow but consumes less disk space. *) 8 | | Hardlink_unsafe (** Reasonably fast and uses less disk space, but no 9 | checksum verification. Only for testing during 10 | development, do not use in production. *) 11 | 12 | val create : path:string -> ?mode:mode -> unit -> t Lwt.t 13 | (** [create ~path ?mode ()] creates a new rsync store where everything will 14 | be stored under [path]. The [mode] defaults to [Copy] and defines how 15 | the caches are reused: [Copy] copies all the files, while [Hardlink] tries 16 | to save disk space by sharing identical files. *) 17 | -------------------------------------------------------------------------------- /lib/archive_extract.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | let invoke_fetcher base destdir = 4 | Os.with_pipe_between_children @@ fun ~r ~w -> 5 | let stdin = `FD_move_safely r in 6 | let stdout = `FD_move_safely w in 7 | let stderr = stdout in 8 | let fetcher = 9 | Os.exec ~stdout ~stderr ["fetch"; "-q" ; "-o" ; "-" ; base ] 10 | in 11 | let extracter = 12 | Os.sudo ~stdin [ "tar" ; "-C"; destdir ; "-xzpf"; "-" ] 13 | in 14 | fetcher >>= fun () -> 15 | extracter 16 | 17 | let fetch ~log:_ ~root:_ ~rootfs base = 18 | Lwt.catch 19 | (fun () -> 20 | invoke_fetcher base rootfs >>= fun () -> 21 | let env = [] in 22 | Lwt.return env) 23 | (function 24 | | Sys_error s -> 25 | Fmt.failwith "Archive fetcher encountered a system error: %s" s 26 | | ex -> Lwt.reraise ex) 27 | -------------------------------------------------------------------------------- /lib/xfs_store.mli: -------------------------------------------------------------------------------- 1 | (** Store builds results using {b XFS} with the reflink feature. 2 | 3 | XFS is intended to behave consistently as it scales to large storage and many files, modern-day XFS was originally from SGI Irix. This store uses the {b reflink} feature in XFS to share blocks between files, to support fast snapshots of directory trees and deduplicate file data for more efficient use of storage hardware. 4 | 5 | For more details on the XFS implementation see {{: https://blogs.oracle.com/linux/post/xfs-data-block-sharing-reflink} XFS - Data Block Sharing (Reflink)} and {{: https://blogs.oracle.com/linux/post/upcoming-xfs-work-in-linux-v48-v49-and-v410-by-darrick-wong} Upcoming XFS Work in Linux v4.8 v4.9 and v4.10+}. *) 6 | 7 | include S.STORE 8 | 9 | val create : path:string -> t Lwt.t 10 | (** [create ~path] creates a new XFS store where everything will 11 | be stored under [path]. *) 12 | -------------------------------------------------------------------------------- /lib/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (deps sandbox.macos.ml) 3 | (target sandbox.ml) 4 | (enabled_if (= %{system} macosx)) 5 | (action (copy %{deps} %{target}))) 6 | 7 | (rule 8 | (deps sandbox.jail.ml) 9 | (target sandbox.ml) 10 | (enabled_if (= %{system} freebsd)) 11 | (action (copy %{deps} %{target}))) 12 | 13 | (rule 14 | (deps sandbox.runc.ml) 15 | (target sandbox.ml) 16 | (enabled_if (and (<> %{system} macosx) (<> %{system} freebsd))) 17 | (action (copy %{deps} %{target}))) 18 | 19 | (rule 20 | (target Static_files.ml) 21 | (deps 22 | (source_tree ../static)) 23 | (action 24 | (run %{bin:ocaml-crunch} ../static --mode=plain -o %{target}))) 25 | 26 | (library 27 | (name obuilder) 28 | (public_name obuilder) 29 | (preprocess (pps ppx_sexp_conv)) 30 | (flags (:standard -w -69)) 31 | (libraries fpath lwt lwt.unix fmt yojson tar-unix sexplib sqlite3 astring logs sha obuilder-spec cmdliner extunix)) 32 | -------------------------------------------------------------------------------- /test/mock_sandbox.ml: -------------------------------------------------------------------------------- 1 | 2 | include Obuilder.S.Sandbox_default 3 | 4 | type t = { 5 | expect : 6 | (cancelled:unit Lwt.t -> 7 | ?stdin:Obuilder.Os.unix_fd -> 8 | log:Obuilder.Build_log.t -> 9 | Obuilder.Config.t -> 10 | string -> 11 | (unit, [`Msg of string | `Cancelled]) Lwt_result.t) Queue.t; 12 | } 13 | 14 | let expect t x = Queue.add x t.expect 15 | 16 | let run ~cancelled ?stdin ~log t (config:Obuilder.Config.t) dir = 17 | match Queue.take_opt t.expect with 18 | | None -> Fmt.failwith "Unexpected sandbox execution: %a" Fmt.(Dump.list string) config.argv 19 | | Some fn -> 20 | Lwt.catch 21 | (fun () -> fn ~cancelled ?stdin ~log config dir) 22 | (function 23 | | Failure ex -> Lwt_result.fail (`Msg ex) 24 | | ex -> Lwt_result.fail (`Msg (Printexc.to_string ex)) 25 | ) 26 | 27 | let create () = { expect = Queue.create () } 28 | 29 | let finished () = Lwt.return () 30 | -------------------------------------------------------------------------------- /lib/config.ml: -------------------------------------------------------------------------------- 1 | (** Configuration for a single sandboxed build step. 2 | This is passed by the builder to the sandbox. *) 3 | 4 | open Sexplib.Std 5 | 6 | type env = (string * string) list [@@deriving sexp] 7 | 8 | module Mount = struct 9 | type t = { 10 | ty : [ `Bind | `Volume ]; 11 | src : string; (* In host namespace *) 12 | dst : string; (* In container namespace *) 13 | readonly : bool; 14 | } 15 | end 16 | 17 | module Secret = struct 18 | type t = { 19 | value: string; 20 | target: string; 21 | } [@@deriving sexp] 22 | end 23 | 24 | type t = { 25 | cwd : string; 26 | entrypoint : string option; 27 | argv : string list; 28 | hostname : string; 29 | user : Obuilder_spec.user; 30 | env : env; 31 | mounts : Mount.t list; 32 | network : string list; 33 | mount_secrets : Secret.t list; 34 | } 35 | 36 | let v ~cwd ~argv ~hostname ~user ~env ~mounts ~network ~mount_secrets ?entrypoint () = 37 | { cwd; argv; hostname; user; env; mounts; network; mount_secrets; entrypoint; } 38 | -------------------------------------------------------------------------------- /lib/obuilder.ml: -------------------------------------------------------------------------------- 1 | let log_src = Log.src 2 | 3 | (** {2 Types} *) 4 | 5 | module S = S 6 | module Spec = Obuilder_spec 7 | module Context = Build.Context 8 | module Docker = Docker 9 | 10 | (** {2 Stores} *) 11 | 12 | module Btrfs_store = Btrfs_store 13 | module Zfs_store = Zfs_store 14 | module Rsync_store = Rsync_store 15 | module Xfs_store = Xfs_store 16 | module Store_spec = Store_spec 17 | module Docker_store = Docker_store 18 | module Qemu_store = Qemu_store 19 | 20 | (** {2 Fetchers} *) 21 | module Zfs_clone = Zfs_clone 22 | module Qemu_snapshot = Qemu_snapshot 23 | module Docker_extract = Docker.Extract 24 | module Archive_extract = Archive_extract 25 | 26 | (** {2 Sandboxes} *) 27 | 28 | module Config = Config 29 | module Native_sandbox = Sandbox 30 | module Docker_sandbox = Docker_sandbox 31 | module Qemu_sandbox = Qemu_sandbox 32 | 33 | (** {2 Builders} *) 34 | 35 | module type BUILDER = S.BUILDER with type context := Build.Context.t 36 | module Builder = Build.Make 37 | module Docker_builder = Build.Make_Docker 38 | module Build_log = Build_log 39 | 40 | (**/**) 41 | 42 | (* For unit-tests *) 43 | module Manifest = Manifest 44 | module Escape = Escape 45 | module Os = Os 46 | module Db = Db 47 | module Tar_transfer = Tar_transfer 48 | -------------------------------------------------------------------------------- /lib/build.mli: -------------------------------------------------------------------------------- 1 | module Context : sig 2 | type t 3 | 4 | val v : 5 | ?switch:Lwt_switch.t -> 6 | ?env:Config.env -> 7 | ?user:Obuilder_spec.user -> 8 | ?workdir:string -> 9 | ?secrets:(string * string) list -> 10 | shell:string list -> 11 | log:S.logger -> 12 | src_dir:string -> 13 | unit -> t 14 | (** [context ~log ~src_dir] is a build context where copy operations read from the (host) directory [src_dir]. 15 | @param switch Turn this off to cancel the build. 16 | @param env Environment in which to run commands. 17 | @param user Container user to run as. 18 | @param workdir Directory in the container namespace for cwd. 19 | @param shell The command used to run shell commands (default [["/usr/bin/env"; "bash"; "-c"]]). 20 | @param secrets Provided key-value pairs for secrets. 21 | @param log Function to receive log data. 22 | *) 23 | end 24 | 25 | module Make (Store : S.STORE) (Sandbox : S.SANDBOX) (_ : S.FETCHER) : sig 26 | include S.BUILDER with type context := Context.t 27 | 28 | val v : store:Store.t -> sandbox:Sandbox.t -> t 29 | end 30 | 31 | module Make_Docker (Store : S.STORE) : sig 32 | include S.BUILDER with type context := Context.t 33 | 34 | val v : store:Store.t -> sandbox:Docker_sandbox.t -> t 35 | end 36 | -------------------------------------------------------------------------------- /lib/db_store.mli: -------------------------------------------------------------------------------- 1 | module Make (Raw : S.STORE) : sig 2 | type t 3 | 4 | val build : 5 | ?switch:Lwt_switch.t -> 6 | t -> ?base:S.id -> 7 | id:S.id -> 8 | log:S.logger -> 9 | (cancelled:unit Lwt.t -> log:Build_log.t -> string -> (unit, [`Cancelled | `Msg of string]) Lwt_result.t) -> 10 | (S.id, [`Cancelled | `Msg of string]) Lwt_result.t 11 | (** [build t ~id ~log fn] ensures that [id] is cached, using [fn ~cancelled ~log dir] to build it if not. 12 | If [cancelled] resolves, the build should be cancelled. 13 | If [id] is already in the process of being built, this just attaches to the existing build. 14 | @param switch Turn this off if you no longer need the result. The build 15 | will be cancelled if no-one else is waiting for it. *) 16 | 17 | val delete : ?log:(S.id -> unit) -> t -> S.id -> unit Lwt.t 18 | 19 | val prune : ?log:(S.id -> unit) -> t -> before:Unix.tm -> int -> int Lwt.t 20 | 21 | val result : t -> S.id -> string option Lwt.t 22 | 23 | val count : t -> int64 24 | 25 | val df : t -> float Lwt.t 26 | 27 | val root : t -> string 28 | 29 | val cache_stats : t -> int * int 30 | 31 | val cache : 32 | user : Obuilder_spec.user -> 33 | t -> 34 | string -> 35 | (string * (unit -> unit Lwt.t)) Lwt.t 36 | 37 | val wrap : Raw.t -> t 38 | 39 | val unwrap : t -> unit 40 | end 41 | -------------------------------------------------------------------------------- /qemu/user-data.yaml.m4: -------------------------------------------------------------------------------- 1 | #cloud-config 2 | users: 3 | - name: opam 4 | groups: [sudo] 5 | sudo: ALL=(ALL) NOPASSWD:ALL 6 | shell: /bin/bash 7 | ssh_authorized_keys: 8 | - ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIA09mqKPpMJ4tyOpl4l+KTTl1DqjFT2mRD29HW8VwnmB root@alpha 9 | runcmd: 10 | - echo "AcceptEnv=*" > /etc/ssh/sshd_config.d/acceptenv.conf 11 | - mkdir /tmp/opam 12 | - curl -L https://opam.ocaml.org/install.sh -o /tmp/opam/install.sh 13 | - chmod +x /tmp/opam/install.sh 14 | - (cd /tmp/opam && for version in 2.2.1 2.3.0 dev ; do if [ "$version" = "dev" ] ; then ./install.sh --dev --download-only ; else ./install.sh --version $version --download-only ; fi ; chmod a+x opam-* ; mv opam-* /usr/bin/opam-"${version%.*}" ; done && rm install.sh) 15 | - ln -s /usr/bin/opam-2.2 /usr/bin/opam 16 | - apt update 17 | - apt upgrade -y 18 | - apt install build-essential unzip bubblewrap -y 19 | - su - opam -c "git clone https://github.com/ocaml/opam-repository" 20 | - su - opam -c "opam init -k local -a /home/opam/opam-repository --bare --disable-sandboxing" 21 | - su - opam -c "rm -rf .opam/repo/default/.git" 22 | - su - opam -c "echo export OPAMYES=1 OPAMCONFIRMLEVEL=unsafe-yes OPAMERRLOGLEN=0 OPAMPRECISETRACKING=1 >> .bashrc" 23 | - su - opam -c "opam switch create VERSION --packages=ocaml-base-compiler.VERSION" 24 | - su - opam -c "opam pin add -k version ocaml-base-compiler VERSION" 25 | - su - opam -c "opam install -y opam-depext" 26 | - su - opam -c "mkdir ~/src" 27 | - poweroff 28 | -------------------------------------------------------------------------------- /lib/zfs_clone.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | let ( / ) = Filename.concat 4 | 5 | (* On FreeBSD the input is 6 | rootfs = "/obuilder/result/522fb2a0e81ba278bc1ae7314bd754201505e6493f4f2f40a166c416624a4005/rootfs" 7 | with base = "busybox", or base = "freebsd-ocaml-4.14" -> just clone rootfs 8 | 9 | On macOS the input is 10 | rootfs = "/Volumes/obuilder/result/522fb2a0e81ba278bc1ae7314bd754201505e6493f4f2f40a166c416624a4005/rootfs" 11 | with base = "busybox", or base = "macos-homebrew-ocaml-4.14" -> clone home and brew subvolumes *) 12 | 13 | let fetch ~log:_ ~root:_ ~rootfs base = 14 | let path = 15 | let remove_on_match s lst = if List.hd lst = s then List.tl lst else lst in 16 | String.split_on_char '/' rootfs 17 | |> List.filter (fun x -> String.length x > 0) 18 | |> remove_on_match "Volumes" |> List.rev 19 | |> remove_on_match "rootfs" |> List.rev in 20 | let zfs_rootfs = String.concat "/" path in 21 | let base_image = (List.hd path) / "base-image" / base in 22 | Lwt_process.pread ("", [| "zfs"; "list"; "-H"; "-r"; "-o"; "name"; base_image |]) >>= fun output -> 23 | let len = String.length base_image in 24 | String.split_on_char '\n' output |> List.map (fun s -> (s, String.length s)) |> 25 | List.filter (fun (_, l) -> l > len) |> List.map (fun (s, l) -> String.sub s (len + 1) (l - len - 1)) |> 26 | Lwt_list.iter_s (fun subvolume -> 27 | Os.sudo ["zfs"; "clone"; base_image / subvolume ^ "@snap"; zfs_rootfs / subvolume ]) >>= fun () -> 28 | Lwt.return [] 29 | 30 | -------------------------------------------------------------------------------- /obuilder-spec.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Build specification format" 4 | description: 5 | "A library for constructing, reading and writing OBuilder build specification files." 6 | maintainer: [ 7 | "Tim McGilchrist " 8 | "Antonin Décimo " 9 | ] 10 | authors: [ 11 | "Antonin Décimo " 12 | "Arthur Wendling " 13 | "David Allsopp " 14 | "Kate " 15 | "Lucas Pluvinage " 16 | "Mark Elvers " 17 | "Patrick Ferris " 18 | "Thomas Gazagnaire " 19 | "Thomas Leonard " 20 | "Tim McGilchrist " 21 | ] 22 | license: "Apache-2.0" 23 | homepage: "https://github.com/ocurrent/obuilder" 24 | doc: "https://ocurrent.github.io/obuilder/" 25 | bug-reports: "https://github.com/ocurrent/obuilder/issues" 26 | depends: [ 27 | "dune" {>= "3.16"} 28 | "fmt" {>= "0.8.9"} 29 | "sexplib" 30 | "astring" 31 | "ppx_deriving" 32 | "ppx_sexp_conv" 33 | "ocaml" {>= "4.14.2"} 34 | "odoc" {with-doc} 35 | ] 36 | build: [ 37 | ["dune" "subst"] {dev} 38 | [ 39 | "dune" 40 | "build" 41 | "-p" 42 | name 43 | "-j" 44 | jobs 45 | "@install" 46 | "@runtest" {with-test} 47 | "@doc" {with-doc} 48 | ] 49 | ] 50 | dev-repo: "git+https://github.com/ocurrent/obuilder.git" 51 | -------------------------------------------------------------------------------- /lib/build_log.mli: -------------------------------------------------------------------------------- 1 | type t 2 | (** The log for a single build step. *) 3 | 4 | (** {2 Creating logs} *) 5 | 6 | val create : string -> t Lwt.t 7 | (** [create path] creates a new log file at temporary location [path]. 8 | Call [finish] when done to release the file descriptor. *) 9 | 10 | val finish : t -> unit Lwt.t 11 | (** [finish t] marks log [t] as finished. 12 | If it was open for writing, this closes the file descriptor. 13 | It cannot be used after this (for reading or writing), although existing 14 | background operations (e.g. [tail]) can continue successfully. *) 15 | 16 | val write : t -> string -> unit Lwt.t 17 | (** [write t data] appends [data] to the log. *) 18 | 19 | val printf : t -> ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a 20 | (** [printf t fmt] is a wrapper for [write t] that takes a format string. *) 21 | 22 | (** {2 Reading logs} *) 23 | 24 | val empty : t 25 | (** [empty] is a read-only log with no content. *) 26 | 27 | val of_saved : string -> t Lwt.t 28 | (** [of_saved path] is a read-only log which reads from [path]. *) 29 | 30 | val tail : ?switch:Lwt_switch.t -> t -> (string -> unit) -> (unit, [> `Cancelled]) Lwt_result.t 31 | (** [tail t dst] streams data from the log to [dst]. 32 | This can be called at any time before [finish] is called. 33 | @param switch Abort if this is turned off. *) 34 | 35 | (* {2 Copying to logs} *) 36 | 37 | val copy : src:Lwt_unix.file_descr -> dst:t -> unit Lwt.t 38 | (** [copy ~src ~dst] reads bytes from the [src] file descriptor and 39 | writes them to the build log [dst]. *) 40 | -------------------------------------------------------------------------------- /test/log.ml: -------------------------------------------------------------------------------- 1 | (* Collect log data from builds, for unit-tests. *) 2 | 3 | open Lwt.Infix 4 | 5 | type t = { 6 | label : string; 7 | buf : Buffer.t; 8 | cond : unit Lwt_condition.t; 9 | } 10 | 11 | let create label = 12 | let buf = Buffer.create 1024 in 13 | let cond = Lwt_condition.create () in 14 | { label; buf; cond } 15 | 16 | let add t tag x = 17 | Logs.info (fun f -> f "%s: %S" t.label x); 18 | begin match tag with 19 | | `Heading -> Buffer.add_string t.buf (x ^ "\n") 20 | | `Note -> Buffer.add_string t.buf (";" ^ x ^ "\n") 21 | | `Output -> Buffer.add_string t.buf x 22 | end; 23 | Lwt_condition.broadcast t.cond () 24 | 25 | let contents t = 26 | Buffer.contents t.buf 27 | 28 | let clear t = 29 | Buffer.clear t.buf 30 | 31 | let remove_notes x = 32 | x 33 | |> String.split_on_char '\n' 34 | |> List.filter (fun x -> not (Astring.String.is_prefix ~affix:";" x)) 35 | |> String.concat "\n" 36 | 37 | let rec await t expect = 38 | let got = Buffer.contents t.buf |> remove_notes in 39 | if got = expect then Lwt.return_unit 40 | else if String.length got > String.length expect then ( 41 | Fmt.failwith "Log expected %S but got %S" expect got 42 | ) else ( 43 | let common = min (String.length expect) (String.length got) in 44 | if String.sub got 0 common = String.sub expect 0 common then ( 45 | Lwt_condition.wait t.cond >>= fun () -> 46 | await t expect 47 | ) else ( 48 | Fmt.failwith "Log expected %S but got %S" expect got 49 | ) 50 | ) 51 | 52 | let check name pattern t = 53 | let pattern = String.split_on_char '\n' pattern |> List.map String.trim |> String.concat "\n" in 54 | let re = Str.regexp pattern in 55 | let got = contents t in 56 | if not (Str.string_match re got 0) then 57 | Alcotest.(check string) name pattern got 58 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.16) 2 | (name obuilder) 3 | 4 | (formatting disabled) 5 | (generate_opam_files true) 6 | (source (github ocurrent/obuilder)) 7 | (authors 8 | "Antonin Décimo " 9 | "Arthur Wendling " 10 | "David Allsopp " 11 | "Kate " 12 | "Lucas Pluvinage " 13 | "Mark Elvers " 14 | "Patrick Ferris " 15 | "Thomas Gazagnaire " 16 | "Thomas Leonard " 17 | "Tim McGilchrist ") 18 | (maintainers "Tim McGilchrist " "Antonin Décimo ") 19 | (license "Apache-2.0") 20 | (documentation "https://ocurrent.github.io/obuilder/") 21 | 22 | (package 23 | (name obuilder) 24 | (synopsis "Run build scripts for CI") 25 | (description 26 | "OBuilder takes a build script (similar to a Dockerfile) and performs the steps in it in a sandboxed environment.") 27 | (depends 28 | (lwt (>= 5.7.0)) 29 | astring 30 | (fmt (>= 0.8.9)) 31 | logs 32 | (cmdliner (>= 1.3.0)) 33 | (tar-unix (and (>= 2.6.0) (< 3.0.0))) 34 | (yojson (>= 1.6.0)) 35 | sexplib 36 | ppx_deriving 37 | ppx_sexp_conv 38 | (sha (>= 1.15.4)) 39 | (sqlite3 (>= 5.2.0)) 40 | (crunch (and (>= 3.3.1) :build)) 41 | (obuilder-spec (= :version)) 42 | fpath 43 | (extunix (>= 0.4.2)) 44 | (ocaml (>= 4.14.2)) 45 | (alcotest-lwt (and (>= 1.7.0) :with-test)))) 46 | 47 | (package 48 | (name obuilder-spec) 49 | (synopsis "Build specification format") 50 | (description 51 | "A library for constructing, reading and writing OBuilder build specification files.") 52 | (depends 53 | (fmt (>= 0.8.9)) 54 | sexplib 55 | astring 56 | ppx_deriving 57 | ppx_sexp_conv 58 | (ocaml (>= 4.14.2)))) 59 | -------------------------------------------------------------------------------- /qemu/install.site.m4: -------------------------------------------------------------------------------- 1 | #!/bin/ksh 2 | set -o errexit 3 | echo "https://cdn.openbsd.org/pub/OpenBSD" > /etc/installurl 4 | echo "permit nopass keepenv :wheel" >> /etc/doas.conf 5 | 6 | cat <> /etc/rc.firsttime 7 | syspatch 8 | usermod -G staff opam 9 | sed -i'' '/^staff:/a\\ 10 | :stacksize-cur=32M:\\\\ 11 | ' /etc/login.conf 12 | sed -i"" -e 's/rw,/rw,softdep,noatime,/g' /etc/fstab 13 | mount -o update,noatime,softdep /home 14 | echo "AcceptEnv=*" >> /etc/ssh/sshd_config 15 | echo "PermitUserEnvironment=yes" >> /etc/ssh/sshd_config 16 | pkg_add curl-- gmake gtar-- gpatch unzip-- rsync-- git bash 17 | /usr/local/bin/curl -L https://github.com/ocaml/opam/releases/download/2.3.0/opam-2.3.0-x86_64-openbsd -o /usr/bin/opam-2.3 18 | /usr/local/bin/curl -L https://github.com/ocaml/opam/releases/download/2.4.1/opam-2.4.1-x86_64-openbsd -o /usr/bin/opam-2.4 19 | chmod +x /usr/bin/opam-2.3 20 | chmod +x /usr/bin/opam-2.4 21 | ln -s /usr/bin/opam-2.4 /usr/bin/opam 22 | su - opam -c "echo OPAMYES=1 >> .ssh/environment" 23 | su - opam -c "echo OPAMCONFIRMLEVEL=unsafe-yes >> .ssh/environment" 24 | su - opam -c "echo OPAMERRLOGLEN=0 >> .ssh/environment" 25 | su - opam -c "echo OPAMPRECISETRACKING=1 >> .ssh/environment" 26 | su - opam -c "git clone https://github.com/ocaml/opam-repository" 27 | su - opam -c "opam init -k local -a /home/opam/opam-repository --bare" 28 | su - opam -c "rm -rf .opam/repo/default/.git" 29 | su - opam -c "opam switch create VERSION --packages=ocaml-base-compiler.VERSION" 30 | su - opam -c "opam pin add -k version ocaml-base-compiler VERSION" 31 | su - opam -c "opam install -y opam-depext" 32 | su - opam -c "mkdir src" 33 | echo '/ * 100%' > /tmp/sd1 34 | disklabel -Aw -T /tmp/sd1 sd1 35 | newfs sd1a 36 | mount /dev/sd1a /home/opam/.opam/download-cache 37 | chown opam:opam /home/opam/.opam/download-cache 38 | umount /home/opam/.opam/download-cache 39 | shutdown -p +1 40 | EOF 41 | 42 | -------------------------------------------------------------------------------- /obuilder.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Run build scripts for CI" 4 | description: 5 | "OBuilder takes a build script (similar to a Dockerfile) and performs the steps in it in a sandboxed environment." 6 | maintainer: [ 7 | "Tim McGilchrist " 8 | "Antonin Décimo " 9 | ] 10 | authors: [ 11 | "Antonin Décimo " 12 | "Arthur Wendling " 13 | "David Allsopp " 14 | "Kate " 15 | "Lucas Pluvinage " 16 | "Mark Elvers " 17 | "Patrick Ferris " 18 | "Thomas Gazagnaire " 19 | "Thomas Leonard " 20 | "Tim McGilchrist " 21 | ] 22 | license: "Apache-2.0" 23 | homepage: "https://github.com/ocurrent/obuilder" 24 | doc: "https://ocurrent.github.io/obuilder/" 25 | bug-reports: "https://github.com/ocurrent/obuilder/issues" 26 | depends: [ 27 | "dune" {>= "3.16"} 28 | "lwt" {>= "5.7.0"} 29 | "astring" 30 | "fmt" {>= "0.8.9"} 31 | "logs" 32 | "cmdliner" {>= "1.3.0"} 33 | "tar-unix" {>= "2.6.0" & < "3.0.0"} 34 | "yojson" {>= "1.6.0"} 35 | "sexplib" 36 | "ppx_deriving" 37 | "ppx_sexp_conv" 38 | "sha" {>= "1.15.4"} 39 | "sqlite3" {>= "5.2.0"} 40 | "crunch" {>= "3.3.1" & build} 41 | "obuilder-spec" {= version} 42 | "fpath" 43 | "extunix" {>= "0.4.2"} 44 | "ocaml" {>= "4.14.2"} 45 | "alcotest-lwt" {>= "1.7.0" & with-test} 46 | "odoc" {with-doc} 47 | ] 48 | build: [ 49 | ["dune" "subst"] {dev} 50 | [ 51 | "dune" 52 | "build" 53 | "-p" 54 | name 55 | "-j" 56 | jobs 57 | "@install" 58 | "@runtest" {with-test} 59 | "@doc" {with-doc} 60 | ] 61 | ] 62 | dev-repo: "git+https://github.com/ocurrent/obuilder.git" 63 | -------------------------------------------------------------------------------- /lib_spec/spec.mli: -------------------------------------------------------------------------------- 1 | type copy = { 2 | from : [`Context | `Build of string]; 3 | src : string list; 4 | dst : string; 5 | exclude : string list; 6 | } [@@deriving sexp] 7 | 8 | type unix_user = { 9 | uid : int; 10 | gid : int; 11 | } [@@deriving sexp] 12 | 13 | type windows_user = { 14 | name : string; 15 | } [@@deriving sexp] 16 | 17 | type user = [ 18 | | `Unix of unix_user 19 | | `Windows of windows_user 20 | ] [@@deriving sexp] 21 | 22 | type run = { 23 | cache : Cache.t list; 24 | network : string list; 25 | secrets : Secret.t list; 26 | shell : string; 27 | } [@@deriving sexp] 28 | 29 | type op = [ 30 | | `Comment of string 31 | | `Workdir of string 32 | | `Shell of string list 33 | | `Run of run 34 | | `Copy of copy 35 | | `User of user 36 | | `Env of (string * string) 37 | ] [@@deriving sexp] 38 | 39 | type t = private { 40 | child_builds : (string * t) list; 41 | from : string; 42 | ops : op list; 43 | } [@@deriving sexp] 44 | 45 | val stage : ?child_builds:(string * t) list -> from:string -> op list -> t 46 | 47 | val comment : ('a, unit, string, op) format4 -> 'a 48 | val workdir : string -> op 49 | val shell : string list -> op 50 | val run : ?cache:Cache.t list -> ?network:string list -> ?secrets:Secret.t list -> ('a, unit, string, op) format4 -> 'a 51 | val copy : ?from:[`Context | `Build of string] -> ?exclude:string list -> string list -> dst:string -> op 52 | val env : string -> string -> op 53 | val user_unix : uid:int -> gid:int -> op 54 | val user_windows : name:string -> op 55 | 56 | val root_unix : [`Unix of unix_user] 57 | val root_windows : [`Windows of windows_user] 58 | val root : user 59 | 60 | val pp : t Fmt.t 61 | (** [pp f s] is similar to [Sexplib.Sexp.pp_hum f (sexp_of_t s)], but 62 | attempts to improve the layout slightly by putting each operation on its 63 | own line. *) 64 | 65 | val pp_op : op Fmt.t 66 | (** [pp_op] formats [op] as an S-expression. *) 67 | -------------------------------------------------------------------------------- /test/macos/simple.expected: -------------------------------------------------------------------------------- 1 | (from patricoferris/empty@sha256:b95ca2b377dd736f609f0a10d63318c9f627a817823cf416402a29bfe9202bb9) 2 | ---> saved as "1e8a7b908b7883f051110a922dc647791b81e0d658f5c1bdd8242d9ab898f8ae" 3 | /: (run (shell "mkdir hello")) 4 | ---> saved as "ba0dc81067c02a45ad4a8cdbbca046aa1e59a37deca612c6a4f8698ae67e200f" 5 | /: (run (shell "echo 'hello world' > ./hello/hello.txt")) 6 | ---> saved as "ee3328c16f05527e80a95b87c110aac986495aef607f14b9ef4371398a8659d8" 7 | /: (run (shell "cat ./hello/hello.txt")) 8 | hello world 9 | ---> saved as "c97a5a234cc9bfcc601b2f7a98975bf294fa7552301c182358fc32ceb21308d8" 10 | /: (run (shell "rm -rf hello")) 11 | ---> saved as "de2d77926d7e89828a3578ef5173bbce6050e2a7e39488b1de54dcffa864a600" 12 | /: (run (shell ls)) 13 | dev 14 | etc 15 | local 16 | proc 17 | sys 18 | ---> saved as "0b38a347b26152e1115a76902af06ff34a4f38aa2182e3af04e2867801fce841" 19 | Got: "0b38a347b26152e1115a76902af06ff34a4f38aa2182e3af04e2867801fce841" 20 | (from patricoferris/empty@sha256:b95ca2b377dd736f609f0a10d63318c9f627a817823cf416402a29bfe9202bb9) 21 | ---> using "1e8a7b908b7883f051110a922dc647791b81e0d658f5c1bdd8242d9ab898f8ae" from cache 22 | /: (run (shell "mkdir hello")) 23 | ---> using "ba0dc81067c02a45ad4a8cdbbca046aa1e59a37deca612c6a4f8698ae67e200f" from cache 24 | /: (run (shell "echo 'hello world' > ./hello/hello.txt")) 25 | ---> using "ee3328c16f05527e80a95b87c110aac986495aef607f14b9ef4371398a8659d8" from cache 26 | /: (run (shell "cat ./hello/hello.txt")) 27 | hello world 28 | ---> using "c97a5a234cc9bfcc601b2f7a98975bf294fa7552301c182358fc32ceb21308d8" from cache 29 | /: (run (shell "rm -rf hello")) 30 | ---> using "de2d77926d7e89828a3578ef5173bbce6050e2a7e39488b1de54dcffa864a600" from cache 31 | /: (run (shell ls)) 32 | dev 33 | etc 34 | local 35 | proc 36 | sys 37 | ---> using "0b38a347b26152e1115a76902af06ff34a4f38aa2182e3af04e2867801fce841" from cache 38 | Got: "0b38a347b26152e1115a76902af06ff34a4f38aa2182e3af04e2867801fce841" 39 | -------------------------------------------------------------------------------- /lib/tar_transfer.mli: -------------------------------------------------------------------------------- 1 | val send_files : 2 | src_dir:string -> 3 | src_manifest:Manifest.t list -> 4 | dst_dir:string -> 5 | user:Obuilder_spec.user -> 6 | to_untar:Lwt_unix.file_descr -> 7 | unit Lwt.t 8 | (** [send_files ~src_dir ~src_manifest ~dst_dir ~user ~to_untar] writes a tar-format stream 9 | to [to_untar] containing all the files listed in [src_manifest], which are 10 | loaded from [src_dir]. The file names in the stream are prefixed with [dst_dir]. 11 | All files are listed as being owned by [user]. *) 12 | 13 | val send_file : 14 | src_dir:string -> 15 | src_manifest:Manifest.t -> 16 | dst:string -> 17 | user:Obuilder_spec.user -> 18 | to_untar:Lwt_unix.file_descr -> 19 | unit Lwt.t 20 | (** [send_files ~src_dir ~src_manifest ~dst ~user ~to_untar] writes a tar-format stream 21 | to [to_untar] containing the item [src_manifest], which is loaded from 22 | [src_dir]. The item will be copied as [dst]. 23 | All files are listed as being owned by [user]. *) 24 | 25 | val transform_files : 26 | from_tar:Lwt_unix.file_descr -> 27 | src_manifest:Manifest.t list -> 28 | dst_dir:string -> 29 | user:Obuilder_spec.user -> 30 | to_untar:Lwt_unix.file_descr -> 31 | unit Lwt.t 32 | (** [transform_files ~src_dir ~from_tar ~src_manifest ~dst_dir ~user ~to_untar] 33 | prefixes the files names of all the files found in [from_tar], a tar archive 34 | streamed in input, with [dst_dir], and writes the resulting tar-format 35 | stream to [to_untar]. All files are listed as being owned by [user]. *) 36 | 37 | val transform_file : 38 | from_tar:Lwt_unix.file_descr -> 39 | src_manifest:Manifest.t -> 40 | dst:string -> 41 | user:Obuilder_spec.user -> 42 | to_untar:Lwt_unix.file_descr -> 43 | unit Lwt.t 44 | (** [transform_files ~src_dir ~from_tar ~src_manifest ~dst ~user ~to_untar] 45 | renames the _unique_ file found in [from_tar], a tar archive streamed in 46 | input, to [dst], and writes the resulting tar-format stream to 47 | [to_untar]. All files are listed as being owned by [user]. *) 48 | -------------------------------------------------------------------------------- /lib/db.ml: -------------------------------------------------------------------------------- 1 | type t = Sqlite3.db 2 | 3 | let or_fail db ~cmd x = 4 | match x with 5 | | Sqlite3.Rc.OK -> () 6 | | err -> Fmt.failwith "Sqlite3: [%s] %s (executing %S)" (Sqlite3.Rc.to_string err) (Sqlite3.errmsg db) cmd 7 | 8 | let no_callback _ = failwith "[exec] used with a query!" 9 | 10 | let exec_stmt db ?(cb=no_callback) stmt = 11 | let rec loop () = 12 | match Sqlite3.step stmt with 13 | | Sqlite3.Rc.DONE -> () 14 | | Sqlite3.Rc.ROW -> 15 | let cols = Sqlite3.data_count stmt in 16 | cb @@ List.init cols (fun i -> Sqlite3.column stmt i); 17 | loop () 18 | | x -> Fmt.failwith "Sqlite3 exec error: [%s] %s" (Sqlite3.Rc.to_string x) (Sqlite3.errmsg db) 19 | in 20 | loop () 21 | 22 | let exec_literal db sql = 23 | Sqlite3.exec db sql |> or_fail db ~cmd:sql 24 | 25 | let bind db stmt values = 26 | Sqlite3.reset stmt |> or_fail db ~cmd:"reset"; 27 | List.iteri (fun i v -> Sqlite3.bind stmt (i + 1) v |> or_fail db ~cmd:"bind") values 28 | 29 | let exec db stmt values = 30 | bind db stmt values; 31 | exec_stmt db stmt 32 | 33 | let query db stmt values = 34 | bind db stmt values; 35 | let results = ref [] in 36 | let cb row = 37 | results := row :: !results 38 | in 39 | exec_stmt db ~cb stmt; 40 | List.rev !results 41 | 42 | let query_one db stmt values = 43 | match query db stmt values with 44 | | [row] -> row 45 | | [] -> failwith "No results from SQL query!" 46 | | _ -> failwith "Multiple results from SQL query!" 47 | 48 | let query_some db stmt values = 49 | match query db stmt values with 50 | | [] -> None 51 | | [row] -> Some row 52 | | _ -> failwith "Multiple results from SQL query!" 53 | 54 | let of_dir path = 55 | let db = Sqlite3.db_open path in 56 | Sqlite3.busy_timeout db 1000; 57 | exec_literal db "PRAGMA journal_mode=WAL"; 58 | exec_literal db "PRAGMA synchronous=NORMAL"; 59 | db 60 | 61 | let dump_item = Fmt.of_to_string Sqlite3.Data.to_string_debug 62 | let dump_row = Fmt.(Dump.list dump_item) 63 | 64 | let close db = 65 | if not (Sqlite3.db_close db) then 66 | Fmt.failwith "Could not close database! It is busy." 67 | -------------------------------------------------------------------------------- /lib/docker_sandbox.mli: -------------------------------------------------------------------------------- 1 | (** Sandbox builds using Docker. *) 2 | 3 | include S.SANDBOX 4 | 5 | val teardown : log:Build_log.t -> commit:bool -> S.id -> unit Lwt.t 6 | 7 | val manifest_from_build : 8 | t -> 9 | base:S.id -> 10 | exclude:string list -> string list -> string -> Obuilder_spec.user -> 11 | (Manifest.t list, [> `Msg of string ]) Lwt_result.t 12 | 13 | val copy_from_context : 14 | t -> 15 | cancelled:unit Lwt.t -> 16 | log:Build_log.t -> 17 | [< `Copy_item of Manifest.t * string 18 | | `Copy_items of Manifest.t list * string ] -> 19 | user:Obuilder_spec.user -> 20 | src_dir:string -> 21 | ?dst_dir:string -> 22 | string -> (unit, [ `Cancelled | `Msg of string ]) result Lwt.t 23 | 24 | val copy_from_build : 25 | t -> 26 | cancelled:'a Lwt.t -> 27 | log:Build_log.t -> 28 | [< `Copy_item of Manifest.t * string 29 | | `Copy_items of Manifest.t list * string ] -> 30 | user:Obuilder_spec.user -> 31 | workdir:string -> 32 | ?dst_dir:string -> 33 | from_id:S.id -> 34 | S.id -> 35 | (unit, [ `Cancelled | `Msg of string ]) result Lwt.t 36 | 37 | val servercore : unit -> ([ `Docker_image of string ]) Lwt.t 38 | (** Get the Windows ServerCore image based on the same version as the 39 | host. *) 40 | 41 | module Docker_config : sig 42 | val make : Config.t -> ?config_dir:string -> t -> string list * string list 43 | (** [make obuilder_config ~config_dir sandbox_config] returns 44 | [docker_argv, argv] where [docker_argv] is the list of arguments 45 | to give to the Docker command-line client, and [argv] the command 46 | to execute in the container. *) 47 | end 48 | (** Derive Docker command-line client parameters from an OBuilder 49 | configuration. *) 50 | 51 | type config [@@deriving sexp] 52 | (** The type of sandbox configurations *) 53 | 54 | val cmdliner : config Cmdliner.Term.t 55 | (** [cmdliner] is used for command-line interfaces to generate the 56 | necessary flags and parameters to setup a specific sandbox's 57 | configuration. *) 58 | 59 | val create : config -> t Lwt.t 60 | (** [create config] is a Docker sandboxing system that is configured 61 | using [config]. *) 62 | -------------------------------------------------------------------------------- /example.spec: -------------------------------------------------------------------------------- 1 | ; This script builds OBuilder itself using a snapshot of the ocaml/opam:debian-12-ocaml-4.14 base image. 2 | ; 3 | ; Run it from the top-level of the OBuilder source tree, e.g. 4 | ; 5 | ; dune exec -- obuilder build --store=zfs:tank -f example.spec . 6 | ; 7 | ; The result can then be found in /tank/HASH/rootfs/ (where HASH is displayed at the end of the build). 8 | 9 | ((build dev 10 | ((from ocaml/opam@sha256:02f01da51f1ed2ae4191f143a46a508e2a34652c11ad2715e2bbe8e0d36fc30d) 11 | (workdir /src) 12 | (user (uid 1000) (gid 1000)) ; Build as the "opam" user 13 | (run (shell "sudo chown opam /src")) 14 | (env OPAM_HASH "8187cd8d3681d53f5042b5da316fa3f5e005a247") 15 | (run 16 | (network host) 17 | (shell "sudo apt-get --allow-releaseinfo-change update")) 18 | (run 19 | (network host) 20 | (shell 21 | "cd ~/opam-repository \ 22 | && (git cat-file -e $OPAM_HASH || git fetch origin master) \ 23 | && git reset -q --hard $OPAM_HASH \ 24 | && git --no-pager log --no-decorate -n1 --oneline \ 25 | && opam update -u")) 26 | ; Copy just the opam file first (helps caching) 27 | (copy (src obuilder-spec.opam obuilder.opam) (dst ./)) 28 | (run (shell "opam pin add -yn .")) 29 | ; Install OS package dependencies 30 | (run 31 | (network host) 32 | (cache (opam-archives (target /home/opam/.opam/download-cache))) 33 | (shell "opam depext -yu obuilder")) 34 | ; Install OCaml dependencies 35 | (run 36 | (network host) 37 | (cache (opam-archives (target /home/opam/.opam/download-cache))) 38 | (shell "opam install --deps-only -t obuilder")) 39 | (copy ; Copy the rest of the source code 40 | (src .) 41 | (dst /src/) 42 | (exclude .git _build _opam)) 43 | (run (shell "opam exec -- dune build @install @runtest")))) ; Build and test 44 | ; Now generate a small runtime image with just the resulting binary: 45 | (from debian:12) 46 | (run 47 | (network host) 48 | (shell "apt-get update && apt-get install -y libsqlite3-0 --no-install-recommends")) 49 | (copy (from (build dev)) 50 | (src /src/_build/default/main.exe) 51 | (dst /usr/local/bin/obuilder)) 52 | (run (shell "obuilder --help"))) 53 | -------------------------------------------------------------------------------- /lib/macos.ml: -------------------------------------------------------------------------------- 1 | (* Extensions to the Os module for macOS *) 2 | open Lwt.Syntax 3 | open Lwt.Infix 4 | open Os 5 | 6 | let ( / ) = Filename.concat 7 | 8 | let user_exists ~user = 9 | let+ s = pread ["sudo"; "dscl"; "."; "list"; "/Users"] in 10 | List.exists (Astring.String.equal user) (Astring.String.cuts ~sep:"\n" s) 11 | 12 | (* Generates a new MacOS user called `' *) 13 | let create_new_user ~username ~home_dir ~uid ~gid = 14 | let* exists = user_exists ~user:username in 15 | if exists then Lwt.return_ok () 16 | else 17 | let user = "/Users" / username in 18 | let pp s ppf = Fmt.pf ppf "[ Mac ] %s\n" s in 19 | let dscl = [ "dscl"; "."; "-create"; user ] in 20 | sudo_result ~pp:(pp "UniqueID") (dscl @ [ "UniqueID"; uid ]) >>!= fun _ -> 21 | sudo_result ~pp:(pp "PrimaryGroupID") (dscl @ [ "PrimaryGroupID"; gid ]) >>!= fun _ -> 22 | sudo_result ~pp:(pp "UserShell") (dscl @ [ "UserShell"; "/bin/bash" ]) >>!= fun _ -> 23 | sudo_result ~pp:(pp "NFSHomeDirectory") (dscl @ [ "NFSHomeDirectory"; home_dir ]) >>!= fun _ -> 24 | Lwt_result.return () 25 | 26 | let delete_user ~user = 27 | let* exists = user_exists ~user in 28 | match exists with 29 | | false -> 30 | Log.info (fun f -> f "Not deleting %s as they don't exist" user); 31 | Lwt_result.return () 32 | | true -> 33 | let user = "/Users" / user in 34 | let pp s ppf = Fmt.pf ppf "[ Mac ] %s\n" s in 35 | let delete = ["dscl"; "."; "-delete"; user ] in 36 | sudo_result ~pp:(pp "Deleting") delete >>!= fun _ -> 37 | Lwt_result.return () 38 | 39 | let rec kill_users_processes ~uid = 40 | let pp _ ppf = Fmt.pf ppf "[ PKILL ]" in 41 | let delete = ["pkill"; "-9"; "-U"; string_of_int uid ] in 42 | let* t = sudo_result ~pp:(pp "PKILL") delete in 43 | match t with 44 | | Ok _ -> kill_users_processes ~uid 45 | | Error (`Msg _) -> 46 | Log.info (fun f -> f "pkill all killed"); 47 | Lwt.return () 48 | 49 | let rec sudo_fallback cmds cmds2 ~uid = 50 | let pp f = pp_cmd f ("", cmds) in 51 | let* t = sudo_result ~pp cmds in 52 | match t with 53 | | Ok _ -> Lwt.return () 54 | | Error (`Msg m) -> 55 | Log.warn (fun f -> f "failed with %s" m); 56 | (* wait a second then try to kill any user processes and retry *) 57 | Lwt_unix.sleep 2.0 >>= fun () -> 58 | kill_users_processes ~uid >>= fun () -> 59 | sudo cmds2 >>= fun () -> 60 | sudo_fallback cmds cmds2 ~uid 61 | 62 | let rm ~directory = 63 | let pp _ ppf = Fmt.pf ppf "[ RM ]" in 64 | let delete = ["rm"; "-r"; directory ] in 65 | let* t = sudo_result ~pp:(pp "RM") delete in 66 | match t with 67 | | Ok _ -> Lwt.return () 68 | | Error (`Msg m) -> 69 | Log.warn (fun f -> f "Failed to remove %s because %s" directory m); 70 | Lwt.return () 71 | 72 | let get_tmpdir ~user = 73 | ["sudo"; "-u"; user; "-i"; "getconf"; "DARWIN_USER_TEMP_DIR"] 74 | -------------------------------------------------------------------------------- /lib/docker.mli: -------------------------------------------------------------------------------- 1 | (** Docker interface over the CLI tool *) 2 | 3 | type ids = [ 4 | | `Docker_container of string | `Docker_image of string 5 | | `Docker_volume of string 6 | | `Obuilder_id of string 7 | ] 8 | 9 | val set_prefix : string -> unit 10 | (** Set the prefix for Docker images, containers, and volumes managed 11 | by the current OBuilder instance. *) 12 | 13 | val obuilder_libexec : unit -> string 14 | val obuilder_libexec_volume : ?readonly:bool -> unit -> Config.Mount.t 15 | 16 | val image_name : ?tmp:bool -> S.id -> string 17 | val container_name : S.id -> string 18 | val volume_copy_name : ?tmp:bool -> S.id -> string 19 | 20 | val docker_image : ?tmp:bool -> S.id -> [> `Docker_image of string ] 21 | val docker_container : S.id -> [> `Docker_container of string ] 22 | val docker_volume_cache : ?tmp:bool -> S.id -> [> `Docker_volume of string ] 23 | val docker_volume_copy : ?tmp:bool -> S.id -> [> `Docker_volume of string ] 24 | 25 | val mount_point_inside_unix : string 26 | (** Mount point of Docker volumes inside Docker containers, Unix path 27 | style. Use with Cygwin tools. *) 28 | 29 | val mount_point_inside_native : string 30 | (** Mount point of Docker volumes inside Docker containers, native 31 | path style. *) 32 | 33 | (** Get the CLI arguments to the Docker client to mount a volume. *) 34 | val mount_args : Config.Mount.t -> string list 35 | 36 | val bash_entrypoint : string -> string list 37 | (** Get a Bash entrypoint in a Docker container to execute Bash 38 | scripts. *) 39 | 40 | val default_entrypoint : string list 41 | (** Get the default entrypoint of Docker container according to the 42 | host (Windows is cmd, everywhere else is sh). *) 43 | 44 | val setup_command : entp:string list -> cmd:string list -> string * string list 45 | (** [setup_command ~entp ~cmd] returns the head of [entp], to be 46 | give to Docker's [--entrypoint], and the concatenation of the tail 47 | of [head] and [cmd] to be given to Docker command, as Docker 48 | [--entrypoint] takes only one argument. *) 49 | 50 | val cp_between_volumes : 51 | base:[< `Docker_image of string ] -> 52 | src:[< `Docker_volume of string] -> dst:[`Docker_volume of string] -> 53 | (unit, [> `Msg of string]) Lwt_result.t 54 | 55 | (** Wrappers for various Docker client commands, exposing file descriptors. *) 56 | module Cmd : S.DOCKER_CMD 57 | with 58 | type 'a log = ?stdout:[ `Dev_null | `FD_move_safely of Os.unix_fd ] -> 59 | ?stderr:[ `Dev_null | `FD_move_safely of Os.unix_fd ] -> 60 | 'a 61 | and 62 | type 'a logerr = ?stderr:[ `Dev_null | `FD_move_safely of Os.unix_fd ] -> 63 | 'a 64 | 65 | (** Wrappers for various Docker client commands, logging directly to the 66 | {!Build_log}. *) 67 | module Cmd_log : S.DOCKER_CMD 68 | with 69 | type 'a log = log:Build_log.t -> 'a 70 | and 71 | type 'a logerr = log:Build_log.t -> 'a 72 | 73 | (** Fetch (pull and extract) base images using Docker *) 74 | module Extract : S.FETCHER 75 | -------------------------------------------------------------------------------- /lib/manifest.ml: -------------------------------------------------------------------------------- 1 | open Sexplib.Std 2 | 3 | let ( / ) = Filename.concat 4 | 5 | type hash = Sha256.t 6 | 7 | let sexp_of_hash t = Sexplib.Sexp.Atom (Sha256.to_hex t) 8 | let hash_of_sexp = function 9 | | Sexplib.Sexp.Atom hash -> Sha256.of_hex hash 10 | | x -> Fmt.failwith "Invalid data source: %a" Sexplib.Sexp.pp_hum x 11 | 12 | type t = [ 13 | | `File of (string * hash) 14 | | `Symlink of (string * string) 15 | | `Dir of (string * t list) 16 | ] [@@deriving sexp] 17 | 18 | let rec generate ~exclude ~src_dir src : t = 19 | let path = src_dir / src in 20 | match Unix.lstat path with 21 | | Unix.{ st_kind = S_DIR; _ } -> 22 | let items = Sys.readdir path in 23 | Array.sort String.compare items; 24 | let items = 25 | items 26 | |> Array.to_list 27 | |> List.filter (fun x -> not (List.mem x exclude)) 28 | |> List.map (fun item -> generate ~exclude ~src_dir (src / item)) 29 | in 30 | `Dir (src, items) 31 | | Unix.{ st_kind = S_REG; _ } -> 32 | let hash = Sha256.file path in 33 | `File (src, hash) 34 | | Unix.{ st_kind = S_LNK; _ } -> 35 | let target = Unix.readlink path in 36 | `Symlink (src, target) 37 | | _ -> Fmt.failwith "Unsupported file type for %S" src 38 | | exception Unix.Unix_error(Unix.ENOENT, _, _) -> 39 | Fmt.failwith "File %S not found in source directory" src 40 | 41 | let pp_rev_path = Fmt.(list ~sep:(const string Filename.dir_sep) string) 42 | 43 | let platform_dir_sep = 44 | assert (String.length Filename.dir_sep = 1); 45 | Filename.dir_sep.[0] 46 | 47 | let rec check_path ~acc base = function 48 | | [] -> Ok acc 49 | | ("" | ".") :: xs -> check_path ~acc base xs 50 | | ".." :: _ -> Error (`Msg "Can't use .. in source paths!") 51 | | x :: _ when String.contains x platform_dir_sep -> 52 | Fmt.error_msg "Can't use platform directory separator in path component: %S" x 53 | | x :: xs -> 54 | let path = base / x in 55 | let acc = x :: acc in 56 | match Unix.lstat path with 57 | | exception Unix.Unix_error(Unix.ENOENT, _, _) -> Error `Not_found 58 | | Unix.{ st_kind = S_DIR; _ } -> check_path ~acc path xs 59 | | Unix.{ st_kind = S_REG | S_LNK; _ } when xs = [] -> Ok acc 60 | | Unix.{ st_kind = S_REG; _ } -> Fmt.error_msg "Not a directory: %a" pp_rev_path acc 61 | | _ -> Fmt.error_msg "Not a regular file: %a" pp_rev_path acc 62 | 63 | let generate ~exclude ~src_dir src = 64 | match check_path ~acc:[] src_dir (String.split_on_char '/' src) with 65 | | Error (`Msg m) -> Fmt.error_msg "%s (in %S)" m src 66 | | Error `Not_found -> Fmt.error_msg "Source path %S not found" src 67 | | Ok src' -> 68 | try 69 | List.rev src' 70 | |> String.concat Filename.dir_sep 71 | |> generate ~exclude ~src_dir 72 | |> Result.ok 73 | with Failure m -> 74 | Error (`Msg m) 75 | 76 | let to_from_files ?(null=false) t = 77 | let sep = if null then '\000' else '\n' in 78 | let buf = Buffer.create 64 in 79 | let rec aux = function 80 | | `File (name, _) | `Symlink (name, _) -> Buffer.add_string buf name; Buffer.add_char buf sep 81 | | `Dir (name, entries) -> Buffer.add_string buf name; Buffer.add_char buf sep; List.iter aux entries 82 | in 83 | aux t; 84 | Buffer.contents buf 85 | -------------------------------------------------------------------------------- /test/mock_store.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | module Os = Obuilder.Os 4 | 5 | let ( / ) = Filename.concat 6 | 7 | type t = { 8 | dir : string; 9 | cond : unit Lwt_condition.t; 10 | mutable builds : int; 11 | } 12 | 13 | let unix_path path = 14 | if Sys.win32 then 15 | Lwt_process.pread ("", [| "cygpath"; "-u"; path|]) >|= fun str -> String.trim str 16 | else 17 | Lwt.return path 18 | 19 | let delay_store = ref Lwt.return_unit 20 | 21 | let rec waitpid_non_intr pid = 22 | try Unix.waitpid [] pid 23 | with Unix.Unix_error (Unix.EINTR, _, _) -> waitpid_non_intr pid 24 | 25 | let rm_r path = 26 | let rm = Unix.create_process "rm" [| "rm"; "-r"; "--"; path |] Unix.stdin Unix.stdout Unix.stderr in 27 | match waitpid_non_intr rm with 28 | | _, Unix.WEXITED 0 -> () 29 | | _ -> failwith "rm -r failed!" 30 | 31 | let build t ?base ~id fn = 32 | t.builds <- t.builds + 1; 33 | Lwt.finalize 34 | (fun () -> 35 | base |> Option.iter (fun base -> assert (not (String.contains base '/'))); 36 | let dir = t.dir / id in 37 | assert (Os.check_dir dir = `Missing); 38 | let tmp_dir = dir ^ "-tmp" in 39 | assert (not (Sys.file_exists tmp_dir)); 40 | begin match base with 41 | | None -> Os.ensure_dir tmp_dir; Lwt.return_unit 42 | | Some base -> 43 | Lwt.both (unix_path (t.dir / base)) (unix_path tmp_dir) >>= fun (src, dst) -> 44 | Lwt_process.exec ("", [| "cp"; "-r"; src; dst |]) >>= function 45 | | Unix.WEXITED 0 -> Lwt.return_unit 46 | | _ -> failwith "cp failed!" 47 | end >>= fun () -> 48 | fn tmp_dir >>= fun r -> 49 | !delay_store >>= fun () -> 50 | match r with 51 | | Ok () -> 52 | Unix.rename tmp_dir dir; 53 | Lwt_result.return () 54 | | Error _ as e -> 55 | unix_path tmp_dir >>= fun tmp_dir -> 56 | rm_r tmp_dir; 57 | Lwt.return e 58 | ) 59 | (fun () -> 60 | t.builds <- t.builds - 1; 61 | Lwt_condition.broadcast t.cond (); 62 | Lwt.return_unit 63 | ) 64 | 65 | let state_dir t = t.dir / "state" 66 | 67 | let path t id = t.dir / id 68 | 69 | let result t id = 70 | let dir = path t id in 71 | match Os.check_dir dir with 72 | | `Present -> Lwt.return_some dir 73 | | `Missing -> Lwt.return_none 74 | 75 | let log_file t id = 76 | Lwt.return (t.dir / "logs" / (id ^ ".log")) 77 | 78 | let rec finish t = 79 | if t.builds > 0 then ( 80 | Logs.info (fun f -> f "Waiting for %d builds to finish" t.builds); 81 | Lwt_condition.wait t.cond >>= fun () -> 82 | finish t 83 | ) else Lwt.return_unit 84 | 85 | let with_store fn = 86 | Lwt_io.with_temp_dir ~prefix:"mock-store-" @@ fun dir -> 87 | let t = { dir; cond = Lwt_condition.create (); builds = 0 } in 88 | Obuilder.Os.ensure_dir (state_dir t); 89 | Obuilder.Os.ensure_dir (t.dir / "logs"); 90 | Lwt.finalize 91 | (fun () -> fn t) 92 | (fun () -> finish t) 93 | 94 | let delete t id = 95 | result t id >>= function 96 | | Some path -> rm_r path; Lwt.return_unit 97 | | None -> Lwt.return_unit 98 | 99 | let find ~output t = 100 | let rec aux = function 101 | | [] -> Lwt.return_none 102 | | x :: xs -> 103 | let output_path = t.dir / x / "rootfs" / "output" in 104 | if Sys.file_exists output_path then ( 105 | Lwt_io.(with_file ~mode:input) output_path Lwt_io.read >>= fun data -> 106 | if data = output then Lwt.return_some x 107 | else aux xs 108 | ) else aux xs 109 | in 110 | let items = Sys.readdir t.dir |> Array.to_list |> List.sort String.compare in 111 | aux items 112 | 113 | let cache ~user:_ _t _ = assert false 114 | 115 | let delete_cache _t _ = assert false 116 | 117 | let complete_deletes _t = Lwt.return_unit 118 | 119 | let root t = t.dir 120 | 121 | let df _ = Lwt.return 100. 122 | -------------------------------------------------------------------------------- /test/mock_exec.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | module Os = Obuilder.Os 4 | 5 | let ( / ) = Filename.concat 6 | 7 | let strf = Printf.sprintf 8 | 9 | let unix_path path = 10 | if Sys.win32 then 11 | Lwt_process.pread ("", [| "cygpath"; "-u"; path|]) >|= fun str -> String.trim str 12 | else 13 | Lwt.return path 14 | 15 | let next_container_id = ref 0 16 | 17 | let base_tar = 18 | let mydir = Sys.getcwd () in 19 | Lwt_main.run begin 20 | let base_tar = mydir / "base.tar" in 21 | Lwt_io.(with_file ~mode:input) base_tar Lwt_io.read 22 | end 23 | |> Bytes.of_string 24 | 25 | let with_fd x f = 26 | match x with 27 | | `FD_move_safely fd -> 28 | let copy = Unix.dup ~cloexec:true fd.Os.raw in 29 | Os.close fd; 30 | Lwt.finalize 31 | (fun () -> f copy) 32 | (fun () -> Unix.close copy; Lwt.return_unit) 33 | | _ -> failwith "Unsupported mock FD redirection" 34 | 35 | let docker_create ?stdout base = 36 | with_fd (Option.get stdout) @@ fun stdout -> 37 | let id = strf "%s-%d\n" base !next_container_id in 38 | incr next_container_id; 39 | let rec aux i = 40 | let len = String.length id - i in 41 | if len = 0 then Lwt_result.return 0 42 | else ( 43 | let sent = Unix.single_write_substring stdout id i len in 44 | aux (i + sent) 45 | ) 46 | in 47 | aux 0 48 | 49 | let docker_export ?stdout _id = 50 | with_fd (Option.get stdout) @@ fun stdout -> 51 | let stdout = Lwt_unix.of_unix_file_descr stdout in 52 | Os.write_all stdout base_tar 0 (Bytes.length base_tar) >|= fun () -> 53 | Ok 0 54 | 55 | let docker_inspect ?stdout _id = 56 | with_fd (Option.get stdout) @@ fun stdout -> 57 | let stdout = Lwt_unix.of_unix_file_descr stdout in 58 | let msg = Bytes.of_string "PATH=/usr/bin:/usr/local/bin" in 59 | Os.write_all stdout msg 0 (Bytes.length msg) >|= fun () -> 60 | Ok 0 61 | 62 | let exec_docker ?stdout = function 63 | | ["create"; "--"; base] -> docker_create ?stdout base 64 | | ["export"; "--"; id] -> docker_export ?stdout id 65 | | ["image"; "inspect"; "--format"; {|{{range .Config.Env}}{{print . "\x00"}}{{end}}|}; "--"; base] -> docker_inspect ?stdout base 66 | | ["rm"; "--force"; "--"; id] -> Fmt.pr "docker rm --force %S@." id; Lwt_result.return 0 67 | | x -> Fmt.failwith "Unknown mock docker command %a" Fmt.(Dump.list string) x 68 | 69 | let mkdir = function 70 | | ["-m"; "755"; "--"; path] -> Unix.mkdir path 0o755; Lwt_result.return 0 71 | | x -> Fmt.failwith "Unexpected mkdir %a" Fmt.(Dump.list string) x 72 | 73 | let closing redir fn = 74 | Lwt.finalize fn 75 | (fun () -> 76 | begin match redir with 77 | | Some (`FD_move_safely fd) -> Os.ensure_closed_unix fd 78 | | _ -> () 79 | end; 80 | Lwt.return_unit 81 | ) 82 | 83 | let exec ?timeout ?cwd ?stdin ?stdout ?stderr ~pp cmd = 84 | ignore timeout; 85 | closing stdin @@ fun () -> 86 | closing stdout @@ fun () -> 87 | closing stderr @@ fun () -> 88 | match cmd with 89 | | ("", argv) -> 90 | Fmt.pr "exec: %a@." Fmt.(Dump.array string) argv; 91 | begin match Array.to_list argv with 92 | | "docker" :: args -> exec_docker ?stdout args 93 | | "sudo" :: "--" :: ("tar" :: _ as tar) when not Os.running_as_root -> 94 | Os.default_exec ?cwd ?stdin ?stdout ~pp ("", Array.of_list tar) 95 | | "tar" :: "-C" :: path :: opts when Os.running_as_root -> 96 | unix_path path >>= fun path -> 97 | let tar = (if Sys.win32 then "C:\\cygwin64\\bin\\tar.exe" else "tar") :: "-C" :: path :: opts in 98 | Os.default_exec ?cwd ?stdin ?stdout ~pp ("", Array.of_list tar) 99 | | "mkdir" :: args when Os.running_as_root -> mkdir args 100 | | "sudo" :: "--" :: "mkdir" :: args when not Os.running_as_root -> mkdir args 101 | | x -> Fmt.failwith "Unknown mock command %a" Fmt.(Dump.list string) x 102 | end 103 | | (x, _) -> Fmt.failwith "Unexpected absolute path: %S" x 104 | -------------------------------------------------------------------------------- /lib/build_log.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | let max_chunk_size = 4096 4 | 5 | type t = { 6 | mutable state : [ 7 | | `Open of Lwt_unix.file_descr * unit Lwt_condition.t (* Fires after writing more data. *) 8 | | `Readonly of string 9 | | `Empty 10 | | `Finished 11 | ]; 12 | mutable len : int; 13 | } 14 | 15 | let with_dup fd fn = 16 | let fd = Lwt_unix.dup ~cloexec:true fd in 17 | Lwt.finalize 18 | (fun () -> fn fd) 19 | (fun () -> Lwt_unix.close fd) 20 | 21 | let catch_cancel fn = 22 | Lwt.catch fn 23 | (function 24 | | Lwt.Canceled -> Lwt_result.fail `Cancelled 25 | | ex -> Lwt.reraise ex 26 | ) 27 | 28 | let tail ?switch t dst = 29 | let rec readonly_tail ch buf = 30 | Lwt_io.read_into ch buf 0 max_chunk_size >>= function 31 | | 0 -> Lwt_result.return () 32 | | n -> dst (Bytes.sub_string buf 0 n); readonly_tail ch buf 33 | in 34 | 35 | let rec open_tail fd cond buf i = 36 | match switch with 37 | | Some sw when not (Lwt_switch.is_on sw) -> Lwt_result.fail `Cancelled 38 | | Some _ | None -> 39 | let avail = min (t.len - i) max_chunk_size in 40 | if avail > 0 then ( 41 | Lwt_unix.pread fd ~file_offset:i buf 0 avail >>= fun n -> 42 | dst (Bytes.sub_string buf 0 n); 43 | open_tail fd cond buf (i + avail) 44 | ) else ( 45 | match t.state with 46 | | `Open _ -> Lwt_condition.wait cond >>= fun () -> open_tail fd cond buf i 47 | | `Readonly _ | `Empty | `Finished -> Lwt_result.return () 48 | ) 49 | in 50 | 51 | let interrupt th = 52 | catch_cancel @@ fun () -> 53 | Lwt_switch.add_hook_or_exec switch (fun () -> Lwt.cancel th; Lwt.return_unit) >>= fun () -> 54 | th 55 | in 56 | 57 | match t.state with 58 | | `Finished -> invalid_arg "tail: log is finished!" 59 | | `Readonly path -> 60 | let flags = [Unix.O_RDONLY; Unix.O_NONBLOCK; Unix.O_CLOEXEC] in 61 | Lwt_io.(with_file ~mode:input ~flags) path @@ fun ch -> 62 | let buf = Bytes.create max_chunk_size in 63 | interrupt (readonly_tail ch buf) 64 | | `Empty -> Lwt_result.return () 65 | | `Open (fd, cond) -> 66 | (* Dup [fd], which can still work after [fd] is closed. *) 67 | with_dup fd @@ fun fd -> 68 | let buf = Bytes.create max_chunk_size in 69 | interrupt (open_tail fd cond buf 0) 70 | 71 | let create path = 72 | Lwt_unix.openfile path Lwt_unix.[O_CREAT; O_TRUNC; O_RDWR; O_CLOEXEC] 0o666 >|= fun fd -> 73 | let cond = Lwt_condition.create () in 74 | { 75 | state = `Open (fd, cond); 76 | len = 0; 77 | } 78 | 79 | let finish t = 80 | match t.state with 81 | | `Finished -> invalid_arg "Log is already finished!" 82 | | `Open (fd, cond) -> 83 | t.state <- `Finished; 84 | Lwt_unix.close fd >|= fun () -> 85 | Lwt_condition.broadcast cond () 86 | | `Readonly _ -> 87 | t.state <- `Finished; 88 | Lwt.return_unit 89 | | `Empty -> 90 | Lwt.return_unit (* Empty can be reused *) 91 | 92 | let write t data = 93 | match t.state with 94 | | `Finished -> invalid_arg "write: log is finished!" 95 | | `Readonly _ | `Empty -> invalid_arg "Log is read-only!" 96 | | `Open (fd, cond) -> 97 | let len = String.length data in 98 | Os.write_all fd (Bytes.of_string data) 0 len >>= fun () -> 99 | t.len <- t.len + len; 100 | Lwt_condition.broadcast cond (); 101 | Lwt.return_unit 102 | 103 | let of_saved path = 104 | Lwt_unix.lstat path >|= fun stat -> 105 | { 106 | state = `Readonly path; 107 | len = stat.st_size; 108 | } 109 | 110 | let printf t fmt = 111 | Fmt.kstr (write t) fmt 112 | 113 | let empty = { 114 | state = `Empty; 115 | len = 0; 116 | } 117 | 118 | let copy ~src ~dst = 119 | let buf = Bytes.create max_chunk_size in 120 | let rec aux () = 121 | Lwt_unix.read src buf 0 (Bytes.length buf) >>= function 122 | | 0 -> Lwt.return_unit 123 | | n -> write dst (Bytes.sub_string buf 0 n) >>= aux 124 | in 125 | aux () 126 | -------------------------------------------------------------------------------- /doc/macOS.md: -------------------------------------------------------------------------------- 1 | # Experimental macOS Support 2 | 3 | The macOS backend uses the "user" as the unit of abstraction for sandboxing. That is, for each build a new user is created. 4 | This user inherits a home-directory from the store which may come from previous builds using the storage backend. 5 | 6 | A macOS base image is really just a home directory and only requires one file to work, an `.obuilder_profile.sh`. 7 | This is sourced every time a command is run and can be useful for setting paths for a given type of build. 8 | 9 | For `spec`s that only need local, per-user access this is great but for quite a few builds we also need external system dependencies. 10 | On macOS a vast majority of users do this using homebrew. Homebrew installs system dependencies into `/usr/local` using 11 | pre-built binaries (a.k.a bottles). It can be placed elsewhere but will often then build from source. 12 | 13 | For OBuilder this means our per-user builds will break if they are all fighting over the global homebrew, so instead OBuilder does the following: 14 | 15 | - On macOS we require a scoreboard directory in which we record a symlink that associates a users identifier (`uid`) to the same user's current home directory. 16 | - Another tool, [obuilderfs](https://github.com/patricoferris/obuilder-fs), provides a [FUSE][] filesystem that rewrites access to a given 17 | directory (here `/usr/local`) to where the symlink points to in the scoreboard directory. 18 | - A set of [scripts](https://github.com/patricoferris/macos-infra/tree/main/scripts) allows us to initialise homebrew in a base image and use 19 | this in the `(from )` stage of our builds. 20 | 21 | The goal of the experimental macOS backend was to see how far we get without introducing any virtualisation. It is not intended to be used like the 22 | runc-Linux backend because it requires a lot more manual setup and care to be taken. 23 | 24 | ## Running the macOS backend with ZFS 25 | 26 | In order to run the macOS backend to build a very simple `spec` (one that doesn't require the FUSE filesystem) you will need to: 27 | 28 | - Install [openZFSonOSX][] and it should be `2.0` or later (this is when automatic snapshot mounting was added). 29 | - Create the "base image" as a directory in `/Users` i.e `sudo mkdir /Users/empty` and add an empty `.obuilder_profile.sh` to that directory. Note this is if you are using the `User_temp` fetcher module as opposed to the `Docker` one. 30 | - To get a ZFS pool quickly without partitioning your disk you can run `mkfile 128m ` and then `sudo zpool create tank `. 31 | - Create a dummy `obuilderfs` binary that is in your `PATH`, this can just be an empty shell-script. 32 | - From the root of this project run: `sudo dune exec -- obuilder macos . --store=zfs:/Volumes/tank -f example.macos.spec --uid=705 --fallback=/tmp --scoreboard=/tmp`. 33 | Because we are not running the FUSE filesystem the `fallback` and `scoreboard` directories should be somewhere you don't mind being written to but they won't 34 | actually be used. 35 | 36 | ## Running the macOS backend with rsync 37 | 38 | This requires much less setup at the cost of it being very slow in comparison to snap-shotting filesystems. All you need to do is create a directory somewhere for the "snapshots" to be written and pass this as `--rsync:/path/to/dir`. Of course, you will need `rsync` installed. 39 | 40 | ## Docker images for macOS 41 | 42 | As mentioned elsewhere, OBuilder also abstracts the initial `FETCHER` whose job it is, is to interpret the `(from )` stage and setup the base image in a given directory. When run on Linux this uses docker and exports the image and untars the filesystem into the directory. The same can be done for macOS! You can create a directory locally and then use the following dockerfile 43 | 44 | ```Dockerfile 45 | FROM scratch 46 | COPY / 47 | CMD [ "/bin/bash" ] 48 | ``` 49 | 50 | Note the `CMD` is important for the internal `docker create` call to not fail. 51 | 52 | 53 | [FUSE]: https://osxfuse.github.io/ 54 | [openZFSonOSX]: https://openzfsonosx.org/wiki/Downloads#2.1.0 55 | -------------------------------------------------------------------------------- /example.windows.spec: -------------------------------------------------------------------------------- 1 | ; This script builds OBuilder itself using a snapshot of the 2 | ; ocaml/opam:windows-server-mingw-ltsc2022-ocaml-4.14 base image. 3 | ; 4 | ; Run it from the top-level of the OBuilder source tree, e.g. 5 | ; 6 | ; root=../var 7 | ; dune exec -- obuilder build --store="docker:$root" -f example.windows.spec . 8 | ; 9 | ; The result can then be found in the Docker image "obuilder-ROOTID-image-HASH" 10 | ; (where HASH is displayed at the end of the build). 11 | ; The logs can be found in "$root/logs/HASH.log". 12 | ; ROOTID is computed as follows: $(realpath "$(root)" | sha256sum | cut -b -7) 13 | 14 | ((build dev 15 | ((from ocaml/opam@sha256:cdd6e6604489d7700af2768f939439593c5c2f5e6585db8827297ec02d1113ef) 16 | (workdir /src) 17 | (env OPAM_REPO_MINGW_HASH "921b0eceb594f96c0c7f40bb2676783be4362aeb") ; Fix the version of opam-repository-mingw we want 18 | (env OPAM_HASH "8187cd8d3681d53f5042b5da316fa3f5e005a247") ; Fix the version of opam-repository we want 19 | (shell /cygwin64/bin/bash.exe --login -c) 20 | (run 21 | (network "nat") 22 | (shell 23 | "cd /home/opam && mv opam-repository opam-repository-mingw \ 24 | && opam repository set-url default file://C:/cygwin64/home/opam/opam-repository-mingw \ 25 | && git clone https://github.com/ocaml/opam-repository.git \ 26 | && opam repository add --all --rank=2 opam file://C:/cygwin64/home/opam/opam-repository \ 27 | && git config --global --add safe.directory /home/opam/opam-repository-mingw")) 28 | (run 29 | (network "nat") 30 | (shell 31 | "cd /home/opam/opam-repository-mingw \ 32 | && (git cat-file -e $OPAM_REPO_MINGW_HASH || git fetch origin sunset) \ 33 | && git reset -q --hard $OPAM_REPO_MINGW_HASH \ 34 | && git --no-pager log --no-decorate -n1 --oneline \ 35 | && rsync -ar --update --exclude='.git' ./ /cygdrive/c/opam/.opam/repo/default")) 36 | ; opam update -u fails because of patch, so I'm overriding the repo with rsync 37 | (run 38 | (network "nat") 39 | (shell 40 | "cd /home/opam/opam-repository \ 41 | && (git cat-file -e $OPAM_HASH || git fetch origin master) \ 42 | && git reset -q --hard $OPAM_HASH \ 43 | && git --no-pager log --no-decorate -n1 --oneline \ 44 | && rsync -ar --update --exclude='.git' ./ /cygdrive/c/opam/.opam/repo/opam")) 45 | ; opam update -u fails because of patch, so I'm overriding the repo with rsync 46 | (run 47 | (network "nat") 48 | (shell "ocaml-env exec --64 -- opam update -u")) 49 | (shell cmd /S /C) 50 | ; Copy just the opam file first (helps caching) 51 | (copy (src obuilder-spec.opam obuilder.opam) (dst ./)) 52 | (run 53 | (network "nat") 54 | (cache (opam-archives (target /opam/.opam/download-cache))) 55 | (shell "ocaml-env exec --64 -- opam pin add -yn .")) 56 | ; Install OS package dependencies 57 | (run 58 | (network "nat") 59 | (cache (opam-archives (target /opam/.opam/download-cache))) 60 | (shell "ocaml-env exec --64 -- opam depext -yu obuilder")) 61 | ; Install OCaml dependencies 62 | (run 63 | (network "nat") 64 | (cache (opam-archives (target /opam/.opam/download-cache))) 65 | (shell "ocaml-env exec --64 -- opam install --deps-only -t obuilder-spec")) 66 | (run 67 | (network "nat") 68 | (cache (opam-archives (target /opam/.opam/download-cache))) 69 | (shell "ocaml-env exec --64 -- opam install --deps-only -t obuilder")) 70 | (copy ; Copy the rest of the source code 71 | (src .) 72 | (dst /src/) 73 | (exclude .git _build _opam duniverse)) 74 | (run (shell "ocaml-env exec --64 -- dune build @install")))) ; Build 75 | ; Now generate a small runtime image with just the resulting binary: 76 | (from mcr.microsoft.com/windows/server:ltsc2022) 77 | (run (shell "mkdir C:\obuilder")) 78 | (copy (from (build dev)) 79 | (src /cygwin64/usr/x86_64-w64-mingw32/sys-root/mingw/bin/libsqlite3-0.dll) 80 | (dst /obuilder/libsqlite3-0.dll)) 81 | (copy (from (build dev)) 82 | (src /src/_build/default/main.exe) 83 | (dst /obuilder/obuilder.exe)) 84 | (run (shell "/obuilder/obuilder.exe --help"))) 85 | -------------------------------------------------------------------------------- /doc/macOS.mld: -------------------------------------------------------------------------------- 1 | {0 Experimental macOS Support} 2 | 3 | The macOS backend uses the "user" as the unit of abstraction for sandboxing. That is, for each build a new user is created. 4 | This user inherits a home-directory from the store which may come from previous builds using the storage backend. 5 | 6 | A macOS base image is really just a home directory and only requires one file to work, an [.obuilder_profile.sh]. 7 | This is sourced every time a command is run and can be useful for setting paths for a given type of build. 8 | 9 | For [spec]s that only need local, per-user access this is great but for quite a few builds we also need external system dependencies. 10 | On macOS a vast majority of users do this using homebrew. Homebrew installs system dependencies into [/usr/local] using 11 | pre-built binaries \(a.k.a bottles\). It can be placed elsewhere but will often then build from source. 12 | 13 | For OBuilder this means our per-user builds will break if they are all fighting over the global homebrew, so instead OBuilder does the following: 14 | 15 | {ul 16 | {- On macOS we require a scoreboard directory in which we record a symlink that associates a users identifier \([uid]\) to the same user's current home directory.} 17 | {- Another tool, {{: https://github.com/patricoferris/obuilder-fs} obuilderfs}, provides a [FUSE][] filesystem that rewrites access to a given 18 | directory \(here [/usr/local]\) to where the symlink points to in the scoreboard directory.} 19 | {- A set of {{: https://github.com/patricoferris/macos-infra/tree/main/scripts} scripts} allows us to initialise homebrew in a base image and use 20 | this in the [(from )] stage of our builds.} 21 | } 22 | 23 | The goal of the experimental macOS backend was to see how far we get without introducing any virtualisation. It is not intended to be used like the 24 | runc-Linux backend because it requires a lot more manual setup and care to be taken. 25 | 26 | {1 Running the macOS backend with ZFS} 27 | 28 | In order to run the macOS backend to build a very simple [spec] \(one that doesn't require the FUSE filesystem\) you will need to: 29 | 30 | {ul 31 | {- Install [openZFSonOSX][] and it should be [2.0] or later \(this is when automatic snapshot mounting was added\).} 32 | {- Create the "base image" as a directory in [/Users] i.e [sudo mkdir /Users/empty] and add an empty [.obuilder_profile.sh] to that directory. Note this is if you are using the [User_temp] fetcher module as opposed to the [Docker] one.} 33 | {- To get a ZFS pool quickly without partitioning your disk you can run [mkfile 128m ] and then [sudo zpool create tank ].} 34 | {- Create a dummy [obuilderfs] binary that is in your [PATH], this can just be an empty shell-script.} 35 | {- From the root of this project run: [sudo dune exec -- obuilder macos . --store=zfs:/Volumes/tank -f example.macos.spec --uid=705 --fallback=/tmp --scoreboard=/tmp]. 36 | Because we are not running the FUSE filesystem the [fallback] and [scoreboard] directories should be somewhere you don't mind being written to but they won't 37 | actually be used.} 38 | } 39 | 40 | {1 Running the macOS backend with rsync} 41 | 42 | This requires much less setup at the cost of it being very slow in comparison to snap-shotting filesystems. All you need to do is create a directory somewhere for the "snapshots" to be written and pass this as [--rsync:/path/to/dir]. Of course, you will need [rsync] installed. 43 | 44 | {1 Docker images for macOS} 45 | 46 | As mentioned elsewhere, OBuilder also abstracts the initial [FETCHER] whose job it is, is to interpret the [(from )] stage and setup the base image in a given directory. When run on Linux this uses docker and exports the image and untars the filesystem into the directory. The same can be done for macOS! You can create a directory locally and then use the following dockerfile 47 | 48 | {[ 49 | FROM scratch 50 | COPY / 51 | CMD [ "/bin/bash" ] 52 | ]} 53 | 54 | Note the [CMD] is important for the internal [docker create] call to not fail. 55 | 56 | 57 | FUSE: {{: https://osxfuse.github.io/} https://osxfuse.github.io/} 58 | openZFSonOSX: {{: https://openzfsonosx.org/wiki/Downloads#2.1.0} https://openzfsonosx.org/wiki/Downloads#2.1.0} 59 | 60 | -------------------------------------------------------------------------------- /lib/store_spec.ml: -------------------------------------------------------------------------------- 1 | (** Configuration information to set up a store. *) 2 | 3 | open Lwt.Infix 4 | 5 | type t = [ 6 | | `Btrfs of string (* Path *) 7 | | `Zfs of string (* Path with pool at end *) 8 | | `Rsync of (string * Rsync_store.mode) (* Path for the root of the store *) 9 | | `Xfs of string (* Path *) 10 | | `Overlayfs of string (* Path *) 11 | | `Docker of string (* Path *) 12 | | `Qemu of string (* Path *) 13 | ] 14 | 15 | let is_absolute path = not (Filename.is_relative path) 16 | 17 | let of_string s = 18 | match Astring.String.cut s ~sep:":" with 19 | | Some ("zfs", pool) -> Ok (`Zfs pool) 20 | | Some ("btrfs", path) when is_absolute path -> Ok (`Btrfs path) 21 | | Some ("rsync", path) when is_absolute path -> Ok (`Rsync path) 22 | | Some ("xfs", path) when is_absolute path -> Ok (`Xfs path) 23 | | Some ("overlayfs", path) when is_absolute path -> Ok (`Overlayfs path) 24 | | Some ("docker", path) -> Ok (`Docker path) 25 | | Some ("qemu", path) -> Ok (`Qemu path) 26 | | _ -> Error (`Msg "Store must start with zfs:, btrfs:/, rsync:/, xfs:/, qemu:/ or overlayfs:") 27 | 28 | let pp f = function 29 | | `Zfs path -> Fmt.pf f "zfs:%s" path 30 | | `Btrfs path -> Fmt.pf f "btrfs:%s" path 31 | | `Rsync path -> Fmt.pf f "rsync:%s" path 32 | | `Xfs path -> Fmt.pf f "xfs:%s" path 33 | | `Overlayfs path -> Fmt.pf f "overlayfs:%s" path 34 | | `Docker path -> Fmt.pf f "docker:%s" path 35 | | `Qemu path -> Fmt.pf f "qemu:%s" path 36 | 37 | type store = Store : (module S.STORE with type t = 'a) * 'a -> store 38 | 39 | let to_store = function 40 | | `Btrfs path -> 41 | `Native, Btrfs_store.create path >|= fun store -> 42 | Store ((module Btrfs_store), store) 43 | | `Zfs path -> 44 | `Native, Zfs_store.create ~path >|= fun store -> 45 | Store ((module Zfs_store), store) 46 | | `Rsync (path, rsync_mode) -> 47 | `Native, Rsync_store.create ~path ~mode:rsync_mode () >|= fun store -> 48 | Store ((module Rsync_store), store) 49 | | `Xfs path -> 50 | `Native, Xfs_store.create ~path >|= fun store -> 51 | Store ((module Xfs_store), store) 52 | | `Overlayfs path -> 53 | `Native, Overlayfs_store.create ~path >|= fun store -> 54 | Store ((module Overlayfs_store), store) 55 | | `Docker path -> 56 | `Docker, Docker_store.create path >|= fun store -> 57 | Store ((module Docker_store), store) 58 | | `Qemu root -> 59 | `Qemu, Qemu_store.create ~root >|= fun store -> 60 | Store ((module Qemu_store), store) 61 | 62 | open Cmdliner 63 | 64 | let store_t = Arg.conv (of_string, pp) 65 | 66 | let store ?docs names = 67 | Arg.opt Arg.(some store_t) None @@ 68 | Arg.info 69 | ~doc:"$(docv) must be one of $(b,btrfs:/path), $(b,rsync:/path), $(b,xfs:/path), $(b,overlayfs:/path), $(b,zfs:pool), $(b,qemu:/path) or $(b,docker:path) for the OBuilder cache." 70 | ~docv:"STORE" 71 | ?docs 72 | names 73 | 74 | let rsync_mode_opt = 75 | let options = 76 | [("copy", Rsync_store.Copy); 77 | ("hardlink", Rsync_store.Hardlink); 78 | ("hardlink_unsafe", Rsync_store.Hardlink_unsafe)] 79 | in 80 | Arg.opt Arg.(some (enum options)) None @@ 81 | Arg.info 82 | ~doc:(Printf.sprintf "Optimize for speed or low disk usage. $(docv) must be %s." 83 | (Arg.doc_alts_enum options)) 84 | ~docv:"RSYNC_MODE" 85 | ~docs:"RSYNC STORE" 86 | ["rsync-mode"] 87 | 88 | let rsync_mode = 89 | Arg.value @@ rsync_mode_opt 90 | 91 | (** Transform a [store] and [rsync-mode] into a validated combination. 92 | 93 | For example an rsync store must supply an rsync-mode. 94 | *) 95 | let of_t store rsync_mode = 96 | match store, rsync_mode with 97 | | Some (`Rsync path), Some rsync_mode -> `Rsync (path, rsync_mode) 98 | | Some (`Rsync _path), None -> failwith "Store rsync:/ must supply an rsync-mode" 99 | | Some (`Btrfs path), None -> (`Btrfs path) 100 | | Some (`Zfs path), None -> (`Zfs path) 101 | | Some (`Xfs path), None -> (`Xfs path) 102 | | Some (`Overlayfs path), None -> (`Overlayfs path) 103 | | Some (`Docker path), None -> (`Docker path) 104 | | Some (`Qemu path), None -> (`Qemu path) 105 | | _, _ -> failwith "Store type required must be one of btrfs:/path, rsync:/path, xfs:/path, zfs:pool, qemu:/path or docker:path for the OBuilder cache." 106 | 107 | (** Parse cli arguments for t *) 108 | let v = 109 | Term.(const of_t 110 | $ Arg.value @@ store ["store"] 111 | $ Arg.value @@ rsync_mode_opt) 112 | 113 | (** Parse cli arguments for t and initialise a [store]. *) 114 | let cmdliner = 115 | Term.(const to_store $ v) 116 | -------------------------------------------------------------------------------- /lib_spec/docker.ml: -------------------------------------------------------------------------------- 1 | type ctx = { 2 | user : Spec.user; 3 | } 4 | 5 | (* Note: could do with some escaping here, but the rules are not clear. *) 6 | let pp_pair f (k, v) = 7 | Fmt.pf f "%s=%s" k v 8 | 9 | let pp_escape ~escape = 10 | match escape with 11 | | '\\' -> Fmt.any " \\@\n " 12 | | '`' -> Fmt.any " `@\n " 13 | | _ -> assert false 14 | 15 | let pp_wrap ~escape = 16 | Fmt.using (String.split_on_char '\n') 17 | Fmt.(list ~sep:(pp_escape ~escape) (using String.trim string)) 18 | 19 | let pp_cache ~ctx f { Cache.id; target; buildkit_options } = 20 | let buildkit_options = match ctx.user with 21 | | `Unix {uid; gid = _} -> ("uid", string_of_int uid) :: buildkit_options 22 | | `Windows _ -> assert false 23 | in 24 | let buildkit_options = 25 | ("--mount=type", "cache") :: 26 | ("id", id) :: 27 | ("target", target) :: 28 | buildkit_options 29 | in 30 | Fmt.pf f "%a" Fmt.(list ~sep:(any ",") pp_pair) buildkit_options 31 | 32 | let pp_mount_secret ~ctx f { Secret.id; target; buildkit_options } = 33 | let buildkit_options = match ctx.user with 34 | | `Unix {uid; gid = _} -> ("uid", string_of_int uid) :: buildkit_options 35 | | `Windows _ -> assert false 36 | in 37 | let buildkit_options = 38 | ("--mount=type", "secret") :: 39 | ("id", id) :: 40 | ("target", target) :: 41 | buildkit_options 42 | in 43 | Fmt.pf f "%a" Fmt.(list ~sep:(any ",") pp_pair) buildkit_options 44 | 45 | let pp_run ~escape ~ctx f { Spec.cache; shell; secrets; network = _ } = 46 | Fmt.pf f "RUN %a%a%a" 47 | Fmt.(list (pp_mount_secret ~ctx ++ const string " ")) secrets 48 | Fmt.(list (pp_cache ~ctx ++ const string " ")) cache 49 | (pp_wrap ~escape) shell 50 | 51 | let is_root user = 52 | user = (Spec.root_windows :> Spec.user) || user = (Spec.root_unix :> Spec.user) 53 | 54 | let pp_copy ~ctx f { Spec.from; src; dst; exclude = _ } = 55 | let from = match from with 56 | | `Build name -> Some name 57 | | `Context -> None 58 | in 59 | let chown = 60 | if is_root ctx.user then None 61 | else ( 62 | match ctx.user with 63 | | `Unix { uid; gid } -> Some (Printf.sprintf "%d:%d" uid gid) 64 | | `Windows _ -> None 65 | ) 66 | in 67 | Fmt.pf f "COPY %a%a%a %s" 68 | Fmt.(option (fmt "--chown=%s ")) chown 69 | Fmt.(option (fmt "--from=%s ")) from 70 | Fmt.(list ~sep:sp string) src 71 | dst 72 | 73 | let quote ~escape v = 74 | let len = String.length v in 75 | let buf = Buffer.create len in 76 | let j = ref 0 in 77 | for i = 0 to len - 1 do 78 | if v.[i] = '"' || v.[i] = escape then begin 79 | if i - !j > 0 then Buffer.add_substring buf v !j (i - !j); 80 | Buffer.add_char buf escape; 81 | j := i 82 | end 83 | done; 84 | Buffer.add_substring buf v !j (len - !j); 85 | Buffer.contents buf 86 | 87 | let pp_op ~buildkit ~escape ctx f : Spec.op -> ctx = function 88 | | `Comment x -> Fmt.pf f "# %s" x; ctx 89 | | `Workdir x -> Fmt.pf f "WORKDIR %s" x; ctx 90 | | `Shell xs -> Fmt.pf f "SHELL [ %a ]" Fmt.(list ~sep:comma (quote string)) xs; ctx 91 | | `Run x when buildkit -> pp_run ~escape ~ctx f x; ctx 92 | | `Run x -> pp_run ~escape ~ctx f { x with cache = []; secrets = []}; ctx 93 | | `Copy x -> pp_copy ~ctx f x; ctx 94 | | `User (`Unix { uid; gid } as u) -> Fmt.pf f "USER %d:%d" uid gid; { user = u } 95 | | `User (`Windows { name } as u) -> Fmt.pf f "USER %s" name; { user = u } 96 | | `Env (k, v) -> Fmt.pf f "ENV %s=\"%s\"" k (quote ~escape v); ctx 97 | 98 | let rec convert ~buildkit ~escape ~ctx f (name, { Spec.child_builds; from; ops }) = 99 | child_builds |> List.iter (fun (name, spec) -> 100 | convert ~buildkit ~escape ~ctx f (Some name, spec); 101 | Format.pp_print_newline f (); 102 | ); 103 | Fmt.pf f "@[FROM %s%a@]@." from Fmt.(option (const string " as " ++ string)) name; 104 | let (_ : ctx) = List.fold_left (fun ctx op -> 105 | Format.pp_open_hbox f (); 106 | let ctx = pp_op ~buildkit ~escape ctx f op in 107 | Format.pp_close_box f (); 108 | Format.pp_print_newline f (); 109 | ctx 110 | ) ctx ops 111 | in () 112 | 113 | let dockerfile_of_spec ~buildkit ~os t = 114 | Fmt.str "%a" (fun f -> 115 | match os with 116 | | `Windows -> 117 | let ctx = { user = (Spec.root_windows :> Spec.user) } in 118 | (Fmt.pf f "@[#escape=`@]@."; 119 | convert ~buildkit ~escape:'`' ~ctx f) 120 | | `Unix -> 121 | let ctx = { user = (Spec.root_unix :> Spec.user) } in 122 | convert ~buildkit ~escape:'\\' ~ctx f) (None, t) 123 | -------------------------------------------------------------------------------- /.github/workflows/main.yml: -------------------------------------------------------------------------------- 1 | name: Main workflow 2 | 3 | on: 4 | pull_request: 5 | push: 6 | schedule: 7 | # Prime the caches every Monday 8 | - cron: 0 1 * * MON 9 | 10 | env: 11 | RUNC_VERSION: v1.1.14 12 | 13 | jobs: 14 | build: 15 | strategy: 16 | fail-fast: false 17 | matrix: 18 | os: 19 | - ubuntu-latest 20 | ocaml-compiler: 21 | - 4.14.x 22 | - 5 23 | 24 | runs-on: ${{ matrix.os }} 25 | 26 | steps: 27 | - uses: awalsh128/cache-apt-pkgs-action@latest 28 | with: 29 | packages: btrfs-progs zfsutils-linux xfsprogs 30 | version: 2 31 | 32 | - name: Checkout code 33 | uses: actions/checkout@v4 34 | 35 | - name: Use OCaml ${{ matrix.ocaml-compiler }} 36 | uses: ocaml/setup-ocaml@v3 37 | with: 38 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 39 | 40 | - run: opam install . --deps-only --with-test 41 | 42 | - name: Cache runc 43 | id: cache-runc 44 | uses: actions/cache@v4 45 | with: 46 | path: /usr/local/bin/runc 47 | key: ${{ env.RUNC_VERSION }} 48 | 49 | - name: Download runc 50 | if: steps.cache-runc.outputs.cache-hit != 'true' 51 | run: | 52 | sudo wget https://github.com/opencontainers/runc/releases/download/$RUNC_VERSION/runc.amd64 -O /usr/local/bin/runc 53 | 54 | - run: $GITHUB_WORKSPACE/.github/workflows/main.sh overlayfs 55 | - run: $GITHUB_WORKSPACE/.github/workflows/main.sh btrfs 56 | - run: $GITHUB_WORKSPACE/.github/workflows/main.sh zfs 57 | - run: $GITHUB_WORKSPACE/.github/workflows/main.sh xfs 58 | 59 | build_rsync: 60 | strategy: 61 | fail-fast: false 62 | matrix: 63 | os: 64 | - ubuntu-latest 65 | ocaml-compiler: 66 | - 4.14.x 67 | - 5 68 | rsync_mode: 69 | # - rsync_hardlink_unsafe 70 | - rsync_hardlink 71 | - rsync_copy 72 | 73 | runs-on: ${{ matrix.os }} 74 | 75 | steps: 76 | - name: Free space 77 | # https://github.com/actions/runner-images/issues/2840#issuecomment-790492173 78 | run: sudo rm -rf /usr/share/dotnet /opt/ghc /usr/local/share/boost "$AGENT_TOOLSDIRECTORY" 79 | 80 | - name: Checkout code 81 | uses: actions/checkout@v4 82 | 83 | - name: Use OCaml ${{ matrix.ocaml-compiler }} 84 | uses: ocaml/setup-ocaml@v3 85 | with: 86 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 87 | 88 | - run: opam install . --deps-only --with-test 89 | 90 | - name: Cache runc 91 | id: cache-runc 92 | uses: actions/cache@v4 93 | with: 94 | path: /usr/local/bin/runc 95 | key: ${{ env.RUNC_VERSION }} 96 | 97 | - name: Download runc 98 | if: steps.cache-runc.outputs.cache-hit != 'true' 99 | run: | 100 | sudo wget https://github.com/opencontainers/runc/releases/download/$RUNC_VERSION/runc.amd64 -O /usr/local/bin/runc 101 | 102 | - run: $GITHUB_WORKSPACE/.github/workflows/main.sh ${{matrix.rsync_mode}} 103 | 104 | # windows: 105 | # strategy: 106 | # fail-fast: false 107 | # matrix: 108 | # os: 109 | # - windows-latest 110 | # ocaml-compiler: 111 | # - 4.14.x 112 | # - 5 113 | 114 | # runs-on: ${{ matrix.os }} 115 | 116 | # steps: 117 | # - name: Checkout code 118 | # uses: actions/checkout@v4 119 | 120 | # - name: Use OCaml ${{ matrix.ocaml-compiler }} 121 | # uses: ocaml/setup-ocaml@v3 122 | # with: 123 | # ocaml-compiler: ${{ matrix.ocaml-compiler }} 124 | # opam-repositories: | 125 | # opam-repository-mingw: https://github.com/ocaml-opam/opam-repository-mingw.git#sunset 126 | # default: https://github.com/ocaml/opam-repository.git 127 | 128 | # - run: opam install . --deps-only --with-test 129 | 130 | # - run: opam exec -- dune runtest 131 | 132 | docker: 133 | strategy: 134 | fail-fast: false 135 | matrix: 136 | os: 137 | - ubuntu-latest 138 | ocaml-compiler: 139 | - 4.14.x 140 | - 5 141 | 142 | runs-on: ${{ matrix.os }} 143 | 144 | steps: 145 | - name: Checkout 146 | uses: actions/checkout@v4 147 | 148 | - name: Use OCaml ${{ matrix.ocaml-compiler }} 149 | uses: ocaml/setup-ocaml@v3 150 | with: 151 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 152 | 153 | - run: opam install . --deps-only --with-test 154 | 155 | # - name: Set up QEMU 156 | # uses: docker/setup-qemu-action@v3 157 | - name: Set up Docker Buildx 158 | uses: docker/setup-buildx-action@v3 159 | 160 | - run: $GITHUB_WORKSPACE/.github/workflows/main.sh docker 161 | -------------------------------------------------------------------------------- /lib/xfs_store.ml: -------------------------------------------------------------------------------- 1 | (* This store will work with any file system which supports reflinks. *) 2 | open Lwt.Infix 3 | 4 | type cache = { 5 | lock : Lwt_mutex.t; 6 | mutable gen : int; 7 | } 8 | 9 | type t = { 10 | path : string; 11 | caches : (string, cache) Hashtbl.t; 12 | mutable next : int; 13 | } 14 | 15 | let ( / ) = Filename.concat 16 | 17 | module Xfs = struct 18 | let create dir = Lwt.return @@ Os.ensure_dir dir 19 | 20 | let delete dir = 21 | Os.sudo [ "rm"; "-r"; dir ] 22 | 23 | let cp ~src ~dst = 24 | Os.sudo [ "cp"; "-pRduT"; "--reflink=always"; src; dst ] 25 | 26 | let rename ~src ~dst = 27 | Os.sudo [ "mv"; src; dst ] 28 | end 29 | 30 | module Path = struct 31 | let state_dirname = "state" 32 | let cache_dirname = "cache" 33 | let cache_tmp_dirname = "cache-tmp" 34 | 35 | let result_dirname = "result" 36 | let result_tmp_dirname = "result-tmp" 37 | 38 | let dirs root = 39 | List.map ((/) root) 40 | [ state_dirname; cache_dirname; cache_tmp_dirname; result_dirname; result_tmp_dirname ] 41 | 42 | let result t id = t.path / result_dirname / id 43 | let cache t id = t.path / cache_dirname / id 44 | 45 | let cache_tmp t n id = t.path / cache_tmp_dirname / Printf.sprintf "%i-%s" n id 46 | 47 | let result_tmp t id = t.path / result_tmp_dirname / id 48 | end 49 | 50 | let root t = t.path 51 | 52 | let df t = Lwt.return (Os.free_space_percent t.path) 53 | 54 | let create ~path = 55 | Xfs.create path >>= fun () -> 56 | Lwt_list.iter_s Xfs.create (Path.dirs path) >|= fun () -> 57 | { path; caches = Hashtbl.create 10; next = 0 } 58 | 59 | let build t ?base ~id fn = 60 | Log.debug (fun f -> f "xfs: build %S" id); 61 | let result = Path.result t id in 62 | let result_tmp = Path.result_tmp t id in 63 | let base = Option.map (Path.result t) base in 64 | begin match base with 65 | | None -> Xfs.create result_tmp 66 | | Some src -> Xfs.cp ~src ~dst:result_tmp 67 | end 68 | >>= fun () -> 69 | Lwt.try_bind 70 | (fun () -> fn result_tmp) 71 | (fun r -> 72 | begin match r with 73 | | Ok () -> Xfs.rename ~src:result_tmp ~dst:result 74 | | Error _ -> Xfs.delete result_tmp 75 | end >>= fun () -> 76 | Lwt.return r 77 | ) 78 | (fun ex -> 79 | Log.warn (fun f -> f "Uncaught exception from %S build function: %a" id Fmt.exn ex); 80 | Xfs.delete result_tmp >>= fun () -> 81 | Lwt.reraise ex 82 | ) 83 | 84 | let delete t id = 85 | let path = Path.result t id in 86 | match Os.check_dir path with 87 | | `Present -> Xfs.delete path 88 | | `Missing -> Lwt.return_unit 89 | 90 | let result t id = 91 | let dir = Path.result t id in 92 | match Os.check_dir dir with 93 | | `Present -> Lwt.return_some dir 94 | | `Missing -> Lwt.return_none 95 | 96 | let log_file t id = 97 | result t id >|= function 98 | | Some dir -> dir / "log" 99 | | None -> (Path.result_tmp t id) / "log" 100 | 101 | let state_dir t = t.path / Path.state_dirname 102 | 103 | let get_cache t name = 104 | match Hashtbl.find_opt t.caches name with 105 | | Some c -> c 106 | | None -> 107 | let c = { lock = Lwt_mutex.create (); gen = 0 } in 108 | Hashtbl.add t.caches name c; 109 | c 110 | 111 | let cache ~user t name = 112 | let cache = get_cache t name in 113 | Lwt_mutex.with_lock cache.lock @@ fun () -> 114 | let tmp = Path.cache_tmp t t.next name in 115 | t.next <- t.next + 1; 116 | let snapshot = Path.cache t name in 117 | (* Create cache if it doesn't already exist. *) 118 | begin match Os.check_dir snapshot with 119 | | `Missing -> Xfs.create snapshot >>= fun () -> 120 | let { Obuilder_spec.uid; gid } = match user with 121 | | `Unix user -> user 122 | | `Windows _ -> assert false (* xfs not supported on Windows *) 123 | in 124 | Os.sudo [ "chown"; Printf.sprintf "%d:%d" uid gid; snapshot ] 125 | | `Present -> Lwt.return_unit 126 | end >>= fun () -> 127 | (* Create writeable clone. *) 128 | let gen = cache.gen in 129 | Xfs.cp ~src:snapshot ~dst:tmp >>= fun () -> 130 | let release () = 131 | Lwt_mutex.with_lock cache.lock @@ fun () -> 132 | begin 133 | if cache.gen = gen then ( 134 | (* The cache hasn't changed since we cloned it. Update it. *) 135 | (* todo: check if it has actually changed. *) 136 | cache.gen <- cache.gen + 1; 137 | Xfs.delete snapshot >>= fun () -> 138 | Xfs.rename ~src:tmp ~dst:snapshot 139 | ) else 140 | Xfs.delete tmp 141 | end 142 | in 143 | Lwt.return (tmp, release) 144 | 145 | let delete_cache t name = 146 | let cache = get_cache t name in 147 | Lwt_mutex.with_lock cache.lock @@ fun () -> 148 | cache.gen <- cache.gen + 1; (* Ensures in-progress writes will be discarded *) 149 | let snapshot = Path.cache t name in 150 | if Sys.file_exists snapshot then ( 151 | Xfs.delete snapshot >>= fun () -> 152 | Lwt_result.return () 153 | ) else Lwt_result.return () 154 | 155 | let complete_deletes _t = Lwt.return_unit 156 | -------------------------------------------------------------------------------- /static/manifest.bash: -------------------------------------------------------------------------------- 1 | # An implementation of the Manifest module in bash, to run inside 2 | # Docker containers. Outputs a list of S-expressions representing a 3 | # sequence of {Manifest.t}. 4 | 5 | # Depends on bash, basename, readlink, sha256sum. 6 | # If running on Windows, also depends on cygpath. 7 | 8 | shopt -s dotglob nullglob 9 | 10 | # https://stackoverflow.com/a/8574392 11 | function mem() { 12 | local e match="$1" 13 | shift 14 | for e; do [[ "$e" == "$match" ]] && return 0; done 15 | return 1 16 | } 17 | 18 | # Filename.concat 19 | function concat() { 20 | local path=$1 21 | local dir_sep=$2 22 | local name=$3 23 | 24 | if [[ -z "$path" ]]; then 25 | printf "%s" "$name" 26 | else 27 | printf '%s%s%s' "$path" "$dir_sep" "$name" 28 | fi 29 | } 30 | 31 | # Cygwin's readlink outputs a Unix path, we prefer mixed paths. 32 | function readlink_wrapper() { 33 | local path 34 | 35 | if [[ "$OS" = "Windows_NT" ]]; then 36 | if ! path="$(readlink -- "$1" | cygpath -m -f-)"; then 37 | return 1 38 | fi 39 | else 40 | if ! path="$(readlink -- "$1")"; then 41 | return 1 42 | fi 43 | fi 44 | printf "%s" "$path" 45 | } 46 | 47 | function generate() { 48 | local src=$1 49 | local path hash target 50 | 51 | path=$(concat "$src_dir" "$dir_sep" "$src") 52 | if [[ -L "$path" ]]; then 53 | if ! target=$(readlink_wrapper "$path"); then return 1; fi 54 | printf '(Symlink ("%s" %s))' "$src" "$target" 55 | elif [[ -d "$path" ]]; then 56 | printf '(Dir ("%s" (' "$src" 57 | for item in "$path"/*; do # Let's hope Bash file iteration is stable. 58 | if ! item=$(basename -- "$item"); then return 1; fi 59 | if ! mem "$item" "${exclude[@]}"; then 60 | if ! generate "$(concat "$src" "$dir_sep" "$item")"; then 61 | return 1 62 | fi 63 | fi 64 | done 65 | printf ')))' 66 | elif [[ -f "$path" ]]; then 67 | if ! hash=$(sha256sum -- "$path"); then return 1; fi 68 | printf '(File ("%s" %s))' "$src" "${hash:0:64}" 69 | elif [[ ! -e "$path" ]]; then 70 | printf 'File "%s" not found in source directory' "$src" 1>&2 71 | return 1 72 | else 73 | printf 'Unsupported file type for "%s"' "$src" 1>&2 74 | return 1 75 | fi 76 | } 77 | 78 | function check_path() { 79 | local acc=$1; shift 80 | local base=$1; shift 81 | local segs=( "$@" ) 82 | local x path 83 | local -a xs 84 | 85 | x=${segs[0]} 86 | xs=("${segs[@]:1}") 87 | 88 | if [[ ${#segs[@]} -eq 0 ]]; then 89 | printf '%s' "$acc" 90 | return 0 91 | elif [[ "$x" = "" || "$x" = "." ]]; then 92 | check_path "$acc" "$base" "${xs[@]}" 93 | elif [[ "$x" == ".." ]]; then 94 | printf "Can't use .. in source paths!" 1>&2 95 | return 1 96 | elif [[ "$x" == *"$dir_sep"* ]]; then 97 | printf "Can't use platform directory separator in path component: %s" "$x" 1>&2 98 | return 1 99 | else 100 | path=$(concat "$base" "$dir_sep" "$x") 101 | if [[ -z "$acc" ]]; then 102 | acc="$x" 103 | else 104 | acc=$(concat "$acc" "$dir_sep" "$x") 105 | fi 106 | 107 | if [[ ! -e "$path" ]]; then 108 | return 2 109 | elif [[ -d "$path" && ! -L "$path" ]]; then 110 | check_path "$acc" "$path" "${xs[@]}" 111 | elif [[ (-f "$path" || -L "$path") && ${#xs[@]} -eq 0 ]]; then 112 | printf '%s' "$acc" 113 | return 0 114 | elif [[ -f "$path" ]]; then 115 | printf 'Not a directory: %s' "$acc" 1>&2 116 | return 1 117 | else 118 | printf 'Not a regular file: %s' "$x" 1>&2 119 | return 1 120 | fi 121 | fi 122 | } 123 | 124 | function main() { 125 | local src src2 src3 126 | local -i exclude_length src_length 127 | local -a srcs 128 | 129 | exclude_length=$1; shift 130 | while (( exclude_length-- > 0 )); do 131 | exclude+=( "$1" ); shift 132 | done 133 | src_length=$1; shift 134 | while (( src_length-- > 0 )); do 135 | srcs+=( "$1" ); shift 136 | done 137 | 138 | for src1 in "${srcs[@]}"; do 139 | IFS='/' read -r -a segs <<< "$src1" 140 | src2=$(check_path "" "$src_dir" "${segs[@]}") 141 | ret=$? 142 | if [[ $ret -eq 1 ]]; then 143 | printf ' (in "%s")' "$src1" 1>&2 144 | return 1 145 | elif [[ $ret -eq 2 ]]; then 146 | src3="$(printf "$dir_sep%s" "${segs[@]}")" 147 | printf 'Source path "%s" not found' "${src3:1}" 1>&2 148 | return 1 149 | elif ! generate "$src2"; then 150 | return 1 151 | fi 152 | done 153 | } 154 | 155 | src_dir=$1; shift 156 | dir_sep=$1; shift 157 | declare -a exclude 158 | 159 | main "$@" 160 | -------------------------------------------------------------------------------- /lib/dao.ml: -------------------------------------------------------------------------------- 1 | type t = { 2 | db : Db.t; 3 | begin_transaction : Sqlite3.stmt; 4 | commit : Sqlite3.stmt; 5 | rollback : Sqlite3.stmt; 6 | add : Sqlite3.stmt; 7 | set_used : Sqlite3.stmt; 8 | update_rc : Sqlite3.stmt; 9 | exists : Sqlite3.stmt; 10 | children : Sqlite3.stmt; 11 | delete : Sqlite3.stmt; 12 | lru : Sqlite3.stmt; 13 | parent : Sqlite3.stmt; 14 | count : Sqlite3.stmt; 15 | } 16 | 17 | let format_timestamp time = 18 | let { Unix.tm_year; tm_mon; tm_mday; tm_hour; tm_min; tm_sec; _ } = time in 19 | Fmt.str "%04d-%02d-%02d %02d:%02d:%02d" (tm_year + 1900) (tm_mon + 1) tm_mday tm_hour tm_min tm_sec 20 | 21 | let create db = 22 | Sqlite3.exec db {| CREATE TABLE IF NOT EXISTS builds ( 23 | id TEXT PRIMARY KEY, 24 | created DATETIME NOT NULL, 25 | used DATETIME NOT NULL, 26 | rc INTEGER NOT NULL, 27 | parent TEXT, 28 | FOREIGN KEY (parent) REFERENCES builds (id) ON DELETE RESTRICT 29 | ) |} |> Db.or_fail db ~cmd:"create builds"; 30 | Sqlite3.exec db {| CREATE INDEX IF NOT EXISTS lru 31 | ON builds (rc, used) |} |> Db.or_fail db ~cmd:"create lru index"; 32 | let begin_transaction = Sqlite3.prepare db "BEGIN TRANSACTION" in 33 | let commit = Sqlite3.prepare db "COMMIT" in 34 | let rollback = Sqlite3.prepare db {| ROLLBACK |} in 35 | let add = Sqlite3.prepare db {| INSERT INTO builds 36 | (id, created, used, rc, parent) 37 | VALUES (?, ?, ?, 0, ?) |} in 38 | let update_rc = Sqlite3.prepare db {| UPDATE builds SET rc = rc + ? WHERE id = ? |} in 39 | let set_used = Sqlite3.prepare db {| UPDATE builds SET used = ? WHERE id = ? |} in 40 | let exists = Sqlite3.prepare db {| SELECT EXISTS(SELECT 1 FROM builds WHERE id = ?) |} in 41 | let children = Sqlite3.prepare db {| SELECT id FROM builds WHERE parent = ? |} in 42 | let delete = Sqlite3.prepare db {| DELETE FROM builds WHERE id = ? |} in 43 | let lru = Sqlite3.prepare db {| SELECT id FROM builds WHERE rc = 0 AND used < ? ORDER BY used ASC LIMIT ? |} in 44 | let parent = Sqlite3.prepare db {| SELECT parent FROM builds WHERE id = ? |} in 45 | let count = Sqlite3.prepare db {| SELECT COUNT(*) FROM builds |} in 46 | { db; begin_transaction; commit; rollback; add; set_used; update_rc; exists; children; delete; lru; parent; count } 47 | 48 | let with_transaction t fn = 49 | Db.exec t.db t.begin_transaction []; 50 | match fn () with 51 | | x -> Db.exec t.db t.commit []; x 52 | | exception ex -> Db.exec t.db t.rollback []; raise ex 53 | 54 | let add ?parent ~id ~now t = 55 | let now = format_timestamp now in 56 | match parent with 57 | | None -> Db.exec t.db t.add Sqlite3.Data.[ TEXT id; TEXT now; TEXT now; NULL ]; 58 | | Some parent -> 59 | with_transaction t (fun () -> 60 | Db.exec t.db t.add Sqlite3.Data.[ TEXT id; TEXT now; TEXT now; TEXT parent ]; 61 | Db.exec t.db t.update_rc Sqlite3.Data.[ INT 1L; TEXT parent ]; 62 | ) 63 | 64 | let set_used ~id ~now t = 65 | let now = format_timestamp now in 66 | Db.exec t.db t.set_used Sqlite3.Data.[ TEXT now; TEXT id ] 67 | 68 | let children t id = 69 | match Db.query_one t.db t.exists Sqlite3.Data.[ TEXT id ] with 70 | | [ INT 0L ] -> Error `No_such_id 71 | | [ INT 1L ] -> 72 | Db.query t.db t.children Sqlite3.Data.[ TEXT id ] |> List.map (function 73 | | Sqlite3.Data.[ TEXT dep ] -> dep 74 | | x -> Fmt.failwith "Invalid row: %a" Db.dump_row x 75 | ) 76 | |> Result.ok 77 | | x -> Fmt.failwith "Invalid row: %a" Db.dump_row x 78 | 79 | let delete t id = 80 | with_transaction t (fun () -> 81 | match Db.query_one t.db t.parent Sqlite3.Data.[ TEXT id ] with 82 | | [ TEXT parent ] -> 83 | Db.exec t.db t.delete Sqlite3.Data.[ TEXT id ]; 84 | Db.exec t.db t.update_rc Sqlite3.Data.[ INT (-1L); TEXT parent ] 85 | | [ NULL ] -> 86 | Db.exec t.db t.delete Sqlite3.Data.[ TEXT id ] 87 | | x -> Fmt.failwith "Invalid row: %a" Db.dump_row x 88 | ) 89 | 90 | let lru t ~before n = 91 | Db.query t.db t.lru Sqlite3.Data.[ TEXT (format_timestamp before); INT (Int64.of_int n) ] 92 | |> List.map @@ function 93 | | Sqlite3.Data.[ TEXT id ] -> id 94 | | x -> Fmt.failwith "Invalid row: %a" Db.dump_row x 95 | 96 | let count t = 97 | match Db.query_one t.db t.count [] with 98 | | [ INT n ] -> n 99 | | x -> Fmt.failwith "Invalid row: %a" Db.dump_row x 100 | 101 | let close t = 102 | Sqlite3.finalize t.begin_transaction |> Db.or_fail t.db ~cmd:"finalize"; 103 | Sqlite3.finalize t.commit |> Db.or_fail t.db ~cmd:"finalize"; 104 | Sqlite3.finalize t.rollback |> Db.or_fail t.db ~cmd:"finalize"; 105 | Sqlite3.finalize t.add |> Db.or_fail t.db ~cmd:"finalize"; 106 | Sqlite3.finalize t.set_used |> Db.or_fail t.db ~cmd:"finalize"; 107 | Sqlite3.finalize t.update_rc |> Db.or_fail t.db ~cmd:"finalize"; 108 | Sqlite3.finalize t.exists |> Db.or_fail t.db ~cmd:"finalize"; 109 | Sqlite3.finalize t.children |> Db.or_fail t.db ~cmd:"finalize"; 110 | Sqlite3.finalize t.delete |> Db.or_fail t.db ~cmd:"finalize"; 111 | Sqlite3.finalize t.lru |> Db.or_fail t.db ~cmd:"finalize"; 112 | Sqlite3.finalize t.parent |> Db.or_fail t.db ~cmd:"finalize"; 113 | Db.close t.db 114 | -------------------------------------------------------------------------------- /lib/sandbox.macos.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | open Cmdliner 3 | 4 | include S.Sandbox_default 5 | 6 | type t = { 7 | uid: int; 8 | gid: int; 9 | (* mount point where Homebrew is installed. Either /opt/homebrew or /usr/local depending upon architecture *) 10 | brew_path : string; 11 | lock : Lwt_mutex.t; 12 | } 13 | 14 | open Sexplib.Conv 15 | 16 | type config = { 17 | uid: int; 18 | brew_path : string; 19 | }[@@deriving sexp] 20 | 21 | let run_as ~env ~user ~cmd = 22 | let command = 23 | let env = String.concat " " (List.map (fun (k, v) -> Filename.quote (k^"="^v)) env) in 24 | "sudo" :: "su" :: "-l" :: user :: "-c" :: "--" 25 | :: Printf.sprintf {|source ~/.obuilder_profile.sh && env %s "$0" "$@"|} env 26 | :: cmd 27 | in 28 | Log.debug (fun f -> f "Running: %s" (String.concat " " command)); 29 | command 30 | 31 | let copy_to_log ~src ~dst = 32 | let buf = Bytes.create 4096 in 33 | let rec aux () = 34 | Lwt_unix.read src buf 0 (Bytes.length buf) >>= function 35 | | 0 -> Lwt.return_unit 36 | | n -> Build_log.write dst (Bytes.sub_string buf 0 n) >>= aux 37 | in 38 | aux () 39 | 40 | let user_name ~prefix ~uid = 41 | Fmt.str "%s%i" prefix uid 42 | 43 | let zfs_volume_from path = 44 | String.split_on_char '/' path 45 | |> List.filter (fun x -> String.length x > 0) 46 | |> List.tl 47 | |> String.concat "/" 48 | 49 | let run ~cancelled ?stdin:stdin ~log (t : t) config result_tmp = 50 | Lwt_mutex.with_lock t.lock (fun () -> 51 | Log.info (fun f -> f "result_tmp = %s" result_tmp); 52 | Os.with_pipe_from_child @@ fun ~r:out_r ~w:out_w -> 53 | let user = user_name ~prefix:"mac" ~uid:t.uid in 54 | let zfs_volume = zfs_volume_from result_tmp in 55 | let home_dir = Filename.concat "/Users/" user in 56 | let zfs_home_dir = Filename.concat zfs_volume "home" in 57 | let zfs_brew = Filename.concat zfs_volume "brew" in 58 | Os.sudo [ "zfs"; "set"; "mountpoint=" ^ home_dir; zfs_home_dir ] >>= fun () -> 59 | Os.sudo [ "zfs"; "set"; "mountpoint=" ^ t.brew_path; zfs_brew ] >>= fun () -> 60 | Lwt_list.iter_s (fun { Config.Mount.src; dst; readonly; _ } -> 61 | Log.info (fun f -> f "src = %s, dst = %s, type %s" src dst (if readonly then "ro" else "rw") ); 62 | if Sys.file_exists dst then 63 | Os.sudo [ "zfs"; "set"; "mountpoint=" ^ dst; zfs_volume_from src ] 64 | else Lwt.return_unit) config.Config.mounts >>= fun () -> 65 | let uid = string_of_int t.uid in 66 | let gid = string_of_int t.gid in 67 | Macos.create_new_user ~username:user ~home_dir ~uid ~gid >>= fun _ -> 68 | let osenv = config.Config.env in 69 | let stdout = `FD_move_safely out_w in 70 | let stderr = stdout in 71 | let copy_log = copy_to_log ~src:out_r ~dst:log in 72 | let proc_id = ref None in 73 | let proc = 74 | let stdin = Option.map (fun x -> `FD_move_safely x) stdin in 75 | let pp f = Os.pp_cmd f ("", config.Config.argv) in 76 | Os.pread @@ Macos.get_tmpdir ~user >>= fun tmpdir -> 77 | let tmpdir = List.hd (String.split_on_char '\n' tmpdir) in 78 | let env = ("TMPDIR", tmpdir) :: osenv in 79 | let cmd = run_as ~env ~user ~cmd:config.Config.argv in 80 | Os.ensure_dir config.Config.cwd; 81 | let pid, proc = Os.open_process ?stdin ~stdout ~stderr ~pp ~cwd:config.Config.cwd cmd in 82 | proc_id := Some pid; 83 | Os.process_result ~pp proc >>= fun r -> 84 | Lwt.return r 85 | in 86 | Lwt.on_termination cancelled (fun () -> 87 | let aux () = 88 | if Lwt.is_sleeping proc then 89 | match !proc_id with 90 | | Some _ -> Macos.kill_users_processes ~uid:t.uid 91 | | None -> Log.warn (fun f -> f "Failed to find pid…"); Lwt.return () 92 | else Lwt.return_unit (* Process has already finished *) 93 | in 94 | Lwt.async aux 95 | ); 96 | proc >>= fun r -> 97 | copy_log >>= fun () -> 98 | Lwt_list.iter_s (fun { Config.Mount.src; dst = _; readonly = _; ty = _ } -> 99 | Os.sudo [ "zfs"; "inherit"; "mountpoint"; zfs_volume_from src ]) config.Config.mounts >>= fun () -> 100 | Macos.sudo_fallback [ "zfs"; "set"; "mountpoint=none"; zfs_home_dir ] [ "zfs"; "unmount"; "-f"; zfs_home_dir ] ~uid:t.uid >>= fun () -> 101 | Macos.sudo_fallback [ "zfs"; "set"; "mountpoint=none"; zfs_brew ] [ "zfs"; "unmount"; "-f"; zfs_brew ] ~uid:t.uid >>= fun () -> 102 | if Lwt.is_sleeping cancelled then 103 | Lwt.return (r :> (unit, [`Msg of string | `Cancelled]) result) 104 | else Lwt_result.fail `Cancelled) 105 | 106 | let create ~state_dir:_ c = 107 | Lwt.return { 108 | uid = c.uid; 109 | gid = 1000; 110 | brew_path = c.brew_path; 111 | lock = Lwt_mutex.create (); 112 | } 113 | 114 | let finished () = 115 | Os.sudo [ "zfs"; "unmount"; "obuilder/result" ] >>= fun () -> 116 | Os.sudo [ "zfs"; "mount"; "obuilder/result" ] >>= fun () -> 117 | Lwt.return () 118 | 119 | let uid = 120 | Arg.required @@ 121 | Arg.opt Arg.(some int) None @@ 122 | Arg.info 123 | ~doc:"The uid of the user that will be used as the builder. This should be unique and not in use. \ 124 | You can run `dscl . -list /Users uid` to see all of the currently active users and their uids." 125 | ~docv:"UID" 126 | ["uid"] 127 | 128 | let brew_path = 129 | Arg.required @@ 130 | Arg.opt Arg.(some file) None @@ 131 | Arg.info 132 | ~doc:"Directory where Homebrew is installed. Typically this is either /usr/local or /opt/homebrew." 133 | ~docv:"BREW_PATH" 134 | ["brew-path"] 135 | 136 | let cmdliner : config Term.t = 137 | let make uid brew_path = 138 | { uid; brew_path } 139 | in 140 | Term.(const make $ uid $ brew_path) 141 | -------------------------------------------------------------------------------- /lib/qemu_store.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | let strf = Printf.sprintf 4 | 5 | let running_as_root = Unix.getuid () = 0 6 | 7 | (* Represents a persistent cache. 8 | You must hold a cache's lock when removing or updating its entry in 9 | "cache". *) 10 | type cache = { 11 | lock : Lwt_mutex.t; 12 | mutable children : int; 13 | } 14 | 15 | type t = { 16 | root : string; (* The top-level directory (containing `result`, etc). *) 17 | caches : (string, cache) Hashtbl.t; 18 | mutable next : int; (* Used to generate unique temporary IDs. *) 19 | } 20 | 21 | let ( / ) = Filename.concat 22 | 23 | module Path = struct 24 | (* A qemu store contains several subdirectories: 25 | 26 | - result: completed builds, named by ID 27 | - result-tmp: in-progress builds 28 | - state: for sqlite DB, etc 29 | - cache: the latest version of each cache, by cache ID 30 | - cache-tmp: in-progress updates to caches 31 | 32 | result-tmp and cache-tmp are wiped at start-up. *) 33 | 34 | let result t id = t.root / "result" / id 35 | let result_tmp t id = t.root / "result-tmp" / id 36 | let state t = t.root / "state" 37 | let cache t name = t.root / "cache" / Escape.cache name 38 | let cache_tmp t i name = t.root / "cache-tmp" / strf "%d-%s" i (Escape.cache name) 39 | let image path = path / "rootfs" / "image.qcow2" 40 | end 41 | 42 | module Qemu_img = struct 43 | let qemu_img ?(sudo=false) args = 44 | let args = "qemu-img" :: args in 45 | let args = if sudo && not running_as_root then "sudo" :: args else args in 46 | Os.exec ~stdout:`Dev_null args 47 | 48 | let snapshot ~src dst = 49 | Os.ensure_dir dst; 50 | Os.ensure_dir (dst / "rootfs"); 51 | qemu_img (["create"; "-f"; "qcow2"; "-b"; Path.image src ; "-F"; "qcow2"; Path.image dst; "40G"]) 52 | 53 | let create dst = 54 | Os.ensure_dir dst; 55 | Os.ensure_dir (dst / "rootfs"); 56 | qemu_img (["create"; "-f"; "qcow2"; Path.image dst; "40G"]) 57 | end 58 | 59 | let delete t id = 60 | let path = Path.result t id in 61 | match Os.check_dir path with 62 | | `Missing -> Lwt.return_unit 63 | | `Present -> Os.rm ~directory:path 64 | 65 | let purge path = 66 | Sys.readdir path |> Array.to_list |> Lwt_list.iter_s (fun item -> 67 | let item = path / item in 68 | Log.warn (fun f -> f "Removing left-over temporary item %S" item); 69 | Os.rm ~directory:item 70 | ) 71 | 72 | let root t = t.root 73 | 74 | module Stats = Map.Make (String) 75 | 76 | let df t = Lwt.return (Os.free_space_percent t.root) 77 | 78 | let create ~root = 79 | Os.ensure_dir (root / "result"); 80 | Os.ensure_dir (root / "result-tmp"); 81 | Os.ensure_dir (root / "state"); 82 | Os.ensure_dir (root / "cache"); 83 | Os.ensure_dir (root / "cache-tmp"); 84 | purge (root / "result-tmp") >>= fun () -> 85 | purge (root / "cache-tmp") >>= fun () -> 86 | Lwt.return { root; caches = Hashtbl.create 10; next = 0 } 87 | 88 | let build t ?base ~id fn = 89 | let result = Path.result t id in 90 | let result_tmp = Path.result_tmp t id in 91 | assert (not (Sys.file_exists result)); (* Builder should have checked first *) 92 | begin match base with 93 | | None -> Lwt.return (Os.ensure_dir result_tmp) 94 | | Some base -> Qemu_img.snapshot ~src:(Path.result t base) result_tmp 95 | end 96 | >>= fun () -> 97 | Lwt.try_bind 98 | (fun () -> fn result_tmp) 99 | (fun r -> 100 | begin match r with 101 | | Ok () -> Os.mv ~src:result_tmp result 102 | | Error _ -> Os.rm ~directory:result_tmp 103 | end >>= fun () -> 104 | Lwt.return r 105 | ) 106 | (fun ex -> 107 | Log.warn (fun f -> f "Uncaught exception from %S build function: %a" id Fmt.exn ex); 108 | Os.rm ~directory:result_tmp >>= fun () -> 109 | Lwt.reraise ex 110 | ) 111 | 112 | let result t id = 113 | let dir = Path.result t id in 114 | match Os.check_dir dir with 115 | | `Present -> Lwt.return_some dir 116 | | `Missing -> Lwt.return_none 117 | 118 | let log_file t id = 119 | result t id >|= function 120 | | Some dir -> dir / "log" 121 | | None -> (Path.result_tmp t id) / "log" 122 | 123 | let get_cache t name = 124 | match Hashtbl.find_opt t.caches name with 125 | | Some c -> c 126 | | None -> 127 | let c = { lock = Lwt_mutex.create (); children = 0 } in 128 | Hashtbl.add t.caches name c; 129 | c 130 | 131 | let cache ~user:_ t name : (string * (unit -> unit Lwt.t)) Lwt.t = 132 | let cache = get_cache t name in 133 | Lwt_mutex.with_lock cache.lock @@ fun () -> 134 | let tmp = Path.cache_tmp t t.next name in 135 | t.next <- t.next + 1; 136 | let master = Path.cache t name in 137 | (* Create cache if it doesn't already exist. *) 138 | (match Os.check_dir master with 139 | | `Missing -> Qemu_img.create master 140 | | `Present -> Lwt.return ()) >>= fun () -> 141 | cache.children <- cache.children + 1; 142 | let () = Os.ensure_dir tmp in 143 | Os.cp ~src:master tmp >>= fun () -> 144 | let release () = 145 | Lwt_mutex.with_lock cache.lock @@ fun () -> 146 | cache.children <- cache.children - 1; 147 | let cache_stat = Unix.stat (Path.image master) in 148 | let tmp_stat = Unix.stat (Path.image tmp) in 149 | (if tmp_stat.st_size > cache_stat.st_size then 150 | Os.cp ~src:tmp master 151 | else 152 | Lwt.return ()) >>= fun () -> 153 | Os.rm ~directory:tmp 154 | in 155 | Lwt.return (tmp, release) 156 | 157 | let delete_cache t name = 158 | let cache = get_cache t name in 159 | Lwt_mutex.with_lock cache.lock @@ fun () -> 160 | if cache.children > 0 161 | then Lwt_result.fail `Busy 162 | else 163 | let snapshot = Path.cache t name in 164 | if Sys.file_exists snapshot then ( 165 | Os.rm ~directory:snapshot >>= fun () -> 166 | Lwt_result.return () 167 | ) else Lwt_result.return () 168 | 169 | let state_dir = Path.state 170 | 171 | let complete_deletes _ = 172 | Lwt.return_unit 173 | -------------------------------------------------------------------------------- /lib/rsync_store.ml: -------------------------------------------------------------------------------- 1 | (* The rsync backend is intended for stability, portability and testing. It 2 | is not supposed to be fast nor is it supposed to be particularly memory 3 | efficient. *) 4 | open Lwt.Infix 5 | 6 | (* The caching approach (and much of the code) is copied from the btrfs 7 | implementation *) 8 | type cache = { 9 | lock : Lwt_mutex.t; 10 | mutable gen : int; 11 | } 12 | 13 | type mode = 14 | | Copy 15 | | Hardlink 16 | | Hardlink_unsafe 17 | 18 | type t = { 19 | path : string; 20 | mode : mode; 21 | caches : (string, cache) Hashtbl.t; 22 | mutable next : int; 23 | } 24 | 25 | let ( / ) = Filename.concat 26 | 27 | module Rsync = struct 28 | let create dir = Lwt.return @@ Os.ensure_dir dir 29 | 30 | let delete dir = 31 | Os.sudo [ "rm"; "-r"; dir ] 32 | 33 | let rsync = [ "rsync"; "-aHq" ] 34 | 35 | let rename ~src ~dst = 36 | let cmd = [ "mv"; src; dst ] in 37 | Os.sudo cmd 38 | 39 | let rename_with_sharing ~mode ~base ~src ~dst = match mode, base with 40 | | Copy, _ | _, None -> rename ~src ~dst 41 | | _, Some base -> 42 | (* Attempt to hard-link existing files shared with [base] *) 43 | let safe = match mode with 44 | | Hardlink -> ["--checksum"] 45 | | _ -> [] 46 | in 47 | let cmd = rsync @ safe @ ["--link-dest=" ^ base; src ^ "/"; dst ] in 48 | Os.ensure_dir dst; 49 | Os.sudo cmd >>= fun () -> 50 | delete src 51 | 52 | let copy_children ?chown ~src ~dst () = 53 | let chown = match chown with 54 | | Some uid_gid -> [ "--chown"; uid_gid ] 55 | | None -> [] 56 | in 57 | let cmd = rsync @ chown @ [ src ^ "/"; dst ] in 58 | Os.ensure_dir dst; 59 | Os.sudo cmd 60 | end 61 | 62 | module Path = struct 63 | let state_dirname = "state" 64 | let cache_dirname = "cache" 65 | let cache_tmp_dirname = "cache-tmp" 66 | 67 | let result_dirname = "result" 68 | let result_tmp_dirname = "result-tmp" 69 | 70 | let dirs root = 71 | List.map ((/) root) 72 | [ state_dirname; cache_dirname; cache_tmp_dirname; result_dirname; result_tmp_dirname ] 73 | 74 | let result t id = t.path / result_dirname / id 75 | let cache t id = t.path / cache_dirname / id 76 | 77 | let cache_tmp t n id = t.path / cache_tmp_dirname / Printf.sprintf "%i-%s" n id 78 | 79 | let result_tmp t id = t.path / result_tmp_dirname / id 80 | end 81 | 82 | let root t = t.path 83 | 84 | let df t = Lwt.return (Os.free_space_percent t.path) 85 | 86 | let create ~path ?(mode = Copy) () = 87 | Rsync.create path >>= fun () -> 88 | Lwt_list.iter_s Rsync.create (Path.dirs path) >|= fun () -> 89 | { path; mode; caches = Hashtbl.create 10; next = 0 } 90 | 91 | let build t ?base ~id fn = 92 | Log.debug (fun f -> f "rsync: build %S" id); 93 | let result = Path.result t id in 94 | let result_tmp = Path.result_tmp t id in 95 | let base = Option.map (Path.result t) base in 96 | begin match base with 97 | | None -> Rsync.create result_tmp 98 | | Some src -> Rsync.copy_children ~src ~dst:result_tmp () 99 | end 100 | >>= fun () -> 101 | Lwt.try_bind 102 | (fun () -> fn result_tmp) 103 | (fun r -> 104 | begin match r with 105 | | Ok () -> Rsync.rename_with_sharing ~mode:t.mode ~base ~src:result_tmp ~dst:result 106 | | Error _ -> Rsync.delete result_tmp 107 | end >>= fun () -> 108 | Lwt.return r 109 | ) 110 | (fun ex -> 111 | Log.warn (fun f -> f "Uncaught exception from %S build function: %a" id Fmt.exn ex); 112 | Rsync.delete result_tmp >>= fun () -> 113 | Lwt.reraise ex 114 | ) 115 | 116 | let delete t id = 117 | let path = Path.result t id in 118 | match Os.check_dir path with 119 | | `Present -> Rsync.delete path 120 | | `Missing -> Lwt.return_unit 121 | 122 | let result t id = 123 | let dir = Path.result t id in 124 | match Os.check_dir dir with 125 | | `Present -> Lwt.return_some dir 126 | | `Missing -> Lwt.return_none 127 | 128 | let log_file t id = 129 | result t id >|= function 130 | | Some dir -> dir / "log" 131 | | None -> (Path.result_tmp t id) / "log" 132 | 133 | let state_dir t = t.path / Path.state_dirname 134 | 135 | let get_cache t name = 136 | match Hashtbl.find_opt t.caches name with 137 | | Some c -> c 138 | | None -> 139 | let c = { lock = Lwt_mutex.create (); gen = 0 } in 140 | Hashtbl.add t.caches name c; 141 | c 142 | 143 | let cache ~user t name = 144 | let cache = get_cache t name in 145 | Lwt_mutex.with_lock cache.lock @@ fun () -> 146 | let tmp = Path.cache_tmp t t.next name in 147 | t.next <- t.next + 1; 148 | let snapshot = Path.cache t name in 149 | (* Create cache if it doesn't already exist. *) 150 | begin match Os.check_dir snapshot with 151 | | `Missing -> Rsync.create snapshot 152 | | `Present -> Lwt.return_unit 153 | end >>= fun () -> 154 | (* Create writeable clone. *) 155 | let gen = cache.gen in 156 | let { Obuilder_spec.uid; gid } = match user with 157 | | `Unix user -> user 158 | | `Windows _ -> assert false (* rsync not supported on Windows *) 159 | in 160 | (* rsync --chown not supported by the rsync that macOS ships with *) 161 | Rsync.copy_children ~src:snapshot ~dst:tmp () >>= fun () -> 162 | Os.sudo [ "chown"; Printf.sprintf "%d:%d" uid gid; tmp ] >>= fun () -> 163 | let release () = 164 | Lwt_mutex.with_lock cache.lock @@ fun () -> 165 | begin 166 | if cache.gen = gen then ( 167 | (* The cache hasn't changed since we cloned it. Update it. *) 168 | (* todo: check if it has actually changed. *) 169 | cache.gen <- cache.gen + 1; 170 | Rsync.delete snapshot >>= fun () -> 171 | Rsync.rename ~src:tmp ~dst:snapshot 172 | ) else Lwt.return_unit 173 | end 174 | in 175 | Lwt.return (tmp, release) 176 | 177 | 178 | let delete_cache t name = 179 | let cache = get_cache t name in 180 | Lwt_mutex.with_lock cache.lock @@ fun () -> 181 | cache.gen <- cache.gen + 1; (* Ensures in-progress writes will be discarded *) 182 | let snapshot = Path.cache t name in 183 | if Sys.file_exists snapshot then ( 184 | Rsync.delete snapshot >>= fun () -> 185 | Lwt_result.return () 186 | ) else Lwt_result.return () 187 | 188 | (* Don't think this applies to rsync *) 189 | let complete_deletes _t = Lwt.return_unit 190 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ### unreleased 2 | 3 | - Add a Docker backend for Windows and Linux jobs. 4 | (@MisterDA #127 #75, reviewed by @talex5 and @tmcgilchrist) 5 | - Add FreeBSD sandbox backend using jail(8) 6 | (@dustanddreams #156 #174, reviewed by @tmcgilchrist, @MisterDA, and @mtelvers) 7 | - Add Macos ZFS sandbox (@mtelvers #164, reviewed by @tmcgilchrist) 8 | - Support XFS store (@mtelvers #170, reviewed by @tmcgilchrist) 9 | 10 | - Search for bash rather than assume it lies in /bin (@dustanddreams #159, reviewed by @tmcgilchrist) 11 | - Prune builds one at a time up to the limit (@mtelvers #157) 12 | - Specify upper bound on number of items in the store (@mtelvers #158, reviewed by @MisterDA) 13 | - Fix case where BTRFS is not fully allocated (@mtelvers #162) 14 | - Avoid pruning parent cache objects (@mtelvers #176, reviewed by @tmcgilchrist) 15 | 16 | ### v0.5.1 2023-02-17 17 | 18 | - Updates to address rsync and sandbox issues. 19 | (@mtelvers #139, reviewed by @tmcgilchrist and @MisterDA) 20 | - Add an obuilder clean command to clean all build results. 21 | (@MisterDA #140, reviewed by @tmcgilchrist) 22 | - Make rsync-mode mandatory when using rsync store. 23 | (@tmcgilchrist #132, reviewed by @kit-ty-kate and @MisterDA) 24 | 25 | ### v0.5 2022-11-08 26 | 27 | - Add --fuse-path to allow selection of the path redirected by FUSE (@mtelvers #128, reviewed by @MisterDA ) 28 | - Pre-requisites for Windows support using docker for Windows (@MisterDA #116, reviewed by @tmcgilchrist) 29 | - Additional tests and prerequistes for Windows support (@MisterDA #130, reviewed by @tmcgilchrist) 30 | - Add support for Docker/Windows spec (@MisterDA #117, reviewed by @tmcgilchrist) 31 | - Depend on Lwt.5.6.1 for bugfixes (@MisterDA #108, reviewed by @tmcgilchrist) 32 | 33 | - Add macOS support (@patricoferris #87, reviewed by @tmcgilchrist @talex5 @kit-ty-kate) 34 | - Enable macOS tests only on macOS (@MisterDA #126, reviewed by @tmcgilchrist) 35 | - Dune 3.0 generates empty intf for executables (@MisterDA #111, reviewed by @talex5) 36 | - Fix warnings and CI failure (@MisterDA #110, reviewed by @talex5) 37 | 38 | - Expose store root and cmdliner term with non-required store (@MisterDA #119, reviewed by @tmcgilchrist) 39 | - Expose Rsync_store module (@MisterDA #114, reviewed by @talex5) 40 | - Rsync hard-links to save space (@art-w #102, reviewed by @patricoferris) 41 | 42 | ### v0.4 2022-06-17 43 | 44 | - Use GNU tar format instead of UStar for `copy` operations (@TheLortex #82, reviewed @dra27). 45 | This enables copying from sources containing long file names (>100 characters). 46 | 47 | - Add support for secrets (@TheLortex #63, reviewed by @talex5). 48 | The obuilder spec's `run` command supports a new `secrets` fields, which allows to temporarily 49 | mount secret files in an user-specified location. The sandbox build context has an additional 50 | `secrets` parameter to provide values for the requested keys. 51 | 52 | - Limit permissions on temporary directories (@talex5 #67) 53 | 54 | - Check Linux kernel version support for btrfs (@kit-ty-kate #68) 55 | 56 | - Generalise obuilder sandbox, removing runc/linux specific pieces and 57 | making the S.SANDBOX interface more general 58 | (@patricoferris #58, reviewed by @talex5, @avsm, @MisterDA) 59 | 60 | - Convert --fast-sync back to a flag (@talex5 #72) 61 | 62 | - Support Fmt.cli and Logs.cli flags. (@MisterDA #74, reviewed by @talex5) 63 | For Fmt the new options are --color=always|never|auto 64 | For Log the new options are: 65 | -v, --verbose Increase verbosity 66 | --verbosity=LEVEL (absent=warning) 67 | Be more or less verbose. LEVEL must be one of quiet, error, 68 | warning, info or debug. Takes over -v. 69 | 70 | - Minor cleanup changes (@talex5 #76) 71 | 72 | - Fix deprecations in Fmt 0.8.10 (@tmcgilchrist #80) 73 | 74 | - Remove travis-ci and replace with Github Actions (@MisterDA #84) 75 | 76 | - Add RSync store backend for obuilder to support macOS builders (@patricoferris #88, reviewed @talex5) 77 | 78 | - Fixes for ZFS tests in CI (@patricoferris #91) 79 | 80 | ### v0.3 2021-03-16 81 | 82 | Security fix: 83 | 84 | - `resolv.conf` file should be mounted read-only. 85 | 86 | Other changes: 87 | 88 | - Make `Os` and `Db` modules private. Move the `env` type to `Config`, as that is used externally. 89 | 90 | - Fix license. It was copy-pasted from OCurrent, and still mentioned that project's `lib_ansi` library. 91 | 92 | - Require obuilder-spec package to be same version. 93 | 94 | ### v0.2 2020-12-30 95 | 96 | - Add support for nested / multi-stage builds (@talex5 #48 #49). 97 | This allows you to use a large build environment to create a binary and then 98 | copy that into a smaller runtime environment. It's also useful to get better caching 99 | if two things can change independently (e.g. you want to build your software and also 100 | a linting tool, and be able to update either without rebuilding the other). 101 | 102 | - Add healthcheck feature (@talex5 #52). 103 | - Checks that Docker is running. 104 | - Does a test build using busybox. 105 | 106 | - Clean up left-over runc containers on restart (@talex5 #53). 107 | If btrfs crashes and makes the filesystem read-only then after rebooting there will be stale runc directories. 108 | New jobs with the same IDs would then fail. 109 | 110 | - Remove dependency on dockerfile (@talex5 #51). 111 | This also allows us more control over the formatting 112 | (e.g. putting a blank line between stages in multi-stage builds). 113 | 114 | - Record log output from docker pull (@talex5 #46). 115 | Otherwise, it's not obvious why we've stopped at a pull step, or what is happening. 116 | 117 | - Improve formatting of OBuilder specs (@talex5 #45). 118 | 119 | - Use seccomp policy to avoid necessary sync operations (@talex5 #44). 120 | Sync operations are really slow on btrfs. They're also pointless, 121 | since if the computer crashes while we're doing a build then we'll just throw it away and start again anyway. 122 | Use a seccomp policy that causes all sync operations to "fail", with errno 0 ("success"). 123 | On my machine, this reduces the time to `apt-get install -y shared-mime-info` from 18.5s to 4.7s. 124 | Use `--fast-sync` to enable to new behaviour (it requires runc 1.0.0-rc92). 125 | 126 | - Use a mutex to avoid concurrent btrfs operations (@talex5 #43). 127 | Btrfs deadlocks enough as it is. Don't stress it further by trying to do two things at once. 128 | 129 | Internal changes: 130 | 131 | - Improve handling of file redirections (@talex5 #46). 132 | Instead of making the caller do all the work of closing the file descriptors safely, add an `FD_move_safely` mode. 133 | 134 | - Travis tests: ensure apt cache is up-to-date (@talex5 #50). 135 | 136 | ### v0.1 2020-10-30 137 | 138 | Initial release. 139 | -------------------------------------------------------------------------------- /qemu/Makefile: -------------------------------------------------------------------------------- 1 | 2 | # Windows 3 | 4 | windows: windows-server-2022-amd64-ocaml-4.14.qcow2 windows-server-2022-amd64-ocaml-5.3.qcow2 windows-server-2022-amd64-ocaml-5.4.qcow2 busybox.qcow2 5 | 6 | windows-server-2022-amd64-ocaml-5.4.qcow2: windows-server-2022-amd64-ocaml-5.4.0.qcow2 7 | ln -sf $< $@ 8 | 9 | windows-server-2022-amd64-ocaml-5.3.qcow2: windows-server-2022-amd64-ocaml-5.3.0.qcow2 10 | ln -sf $< $@ 11 | 12 | windows-server-2022-amd64-ocaml-4.14.qcow2: windows-server-2022-amd64-ocaml-4.14.2.qcow2 13 | ln -sf $< $@ 14 | 15 | windows-server-2022-amd64-ocaml-%.qcow2: unattend-%.iso virtio-win.ISO 16 | qemu-img create -f qcow2 $@ 40G 17 | qemu-img create -f qcow2 cache-ntfs.qcow2 20G 18 | qemu-system-x86_64 -m 16G -smp 8 -machine accel=kvm,type=pc -cpu host -display none -vnc :0 \ 19 | -netdev user,id=net0,hostfwd=tcp::60022-:22 -device virtio-net,netdev=net0 \ 20 | -drive file=$@,if=virtio \ 21 | -drive file=cache-ntfs.qcow2,if=virtio \ 22 | -drive file=SW_DVD9_Win_Server_STD_CORE_2022_2108.24_64Bit_English_DC_STD_MLF_X23-54269.ISO,media=cdrom \ 23 | -drive file=$<,media=cdrom \ 24 | -drive file=virtio-win.ISO,media=cdrom 25 | 26 | unattend-%.iso: autounattend.xml.m4 id_ed25519.pub openssh-win64.msi opam-2.2.exe opam-2.3.exe opam-2.4.exe opam-dev.exe setup-x86_64.exe 27 | m4 -D VERSION=$* $< > autounattend.xml 28 | mkisofs -o $@ -r -J autounattend.xml id_ed25519.pub openssh-win64.msi opam-2.2.exe opam-2.3.exe opam-2.4.exe opam-dev.exe setup-x86_64.exe 29 | 30 | opam-2.2.exe: 31 | curl -L https://github.com/ocaml/opam/releases/download/2.2.1/opam-2.2.1-x86_64-windows.exe -o opam-2.2.exe 32 | 33 | opam-2.3.exe: 34 | curl -L https://github.com/ocaml/opam/releases/download/2.3.0/opam-2.3.0-x86_64-windows.exe -o opam-2.3.exe 35 | 36 | opam-2.4.exe: 37 | curl -L https://github.com/ocaml/opam/releases/download/2.4.1/opam-2.4.1-x86_64-windows.exe -o opam-2.4.exe 38 | 39 | opam-dev.exe: 40 | curl -L https://github.com/ocaml/opam/releases/download/2.3.0/opam-2.3.0-x86_64-windows.exe -o opam-dev.exe 41 | 42 | openssh-win64.msi: 43 | curl -L https://github.com/PowerShell/Win32-OpenSSH/releases/download/v9.2.2.0p1-Beta/OpenSSH-Win64-v9.2.2.0.msi -o openssh-win64.msi 44 | 45 | setup-x86_64.exe: 46 | curl -L https://www.cygwin.com/setup-x86_64.exe -o setup-x86_64.exe 47 | 48 | virtio-win.ISO: 49 | curl -L https://fedorapeople.org/groups/virt/virtio-win/direct-downloads/archive-virtio/virtio-win-0.1.262-2/virtio-win.iso -o virtio-win.ISO 50 | 51 | # Ubuntu 52 | 53 | ubuntu: ubuntu-noble-amd64-ocaml-4.14.qcow2 ubuntu-noble-amd64-ocaml-5.2.qcow2 ubuntu-noble-riscv64-ocaml-4.14.qcow2 ubuntu-noble-riscv64-ocaml-5.2.qcow2 busybox.qcow2 54 | 55 | ubuntu-noble-%-ocaml-5.2.qcow2: ubuntu-noble-%-ocaml-5.2.1.qcow2 56 | ln -sf $< $@ 57 | 58 | ubuntu-noble-%-ocaml-4.14.qcow2: ubuntu-noble-%-ocaml-4.14.2.qcow2 59 | ln -sf $< $@ 60 | 61 | seed-%.iso: user-data.yaml.m4 62 | m4 -D VERSION=$* $< > user-data.yaml 63 | cloud-localds $@ user-data.yaml 64 | 65 | ubuntu-noble-amd64-ocaml-%.qcow2: noble-server-cloudimg-amd64.qcow2 seed-%.iso 66 | qemu-img create -f qcow2 -b $< -F qcow2 $@ 20G 67 | qemu-system-x86_64 -m 16G -smp 8 -machine accel=kvm,type=pc -cpu host -display none -vnc :0 \ 68 | -drive file=$@ \ 69 | -drive file=seed-$*.iso,format=raw \ 70 | -nic user,hostfwd=tcp::60022-:22 71 | 72 | ubuntu-noble-riscv64-ocaml-%.qcow2: noble-server-cloudimg-riscv64.qcow2 seed-%.iso 73 | qemu-img create -f qcow2 -b $< -F qcow2 $@ 20G 74 | qemu-system-riscv64 -m 16G -smp 8 -machine type=virt -nographic \ 75 | -bios /usr/lib/riscv64-linux-gnu/opensbi/generic/fw_jump.bin \ 76 | -kernel /usr/lib/u-boot/qemu-riscv64_smode/uboot.elf \ 77 | -drive file=$@,if=virtio \ 78 | -drive file=seed-$*.iso,format=raw,if=virtio \ 79 | -netdev user,id=net0,hostfwd=tcp::60022-:22 -device virtio-net-device,netdev=net0 80 | 81 | .NOTINTERMEDIATE: $(wildcard noble-server-cloudimg-*.qcow2) 82 | 83 | noble-server-cloudimg-%.qcow2: noble-server-cloudimg-%.img 84 | curl -C - -L https://cloud-images.ubuntu.com/noble/current/$< -o $@ 85 | 86 | noble-server-cloudimg-%.img: ; 87 | 88 | # busybox 89 | 90 | seed.iso: busybox.yaml 91 | cp $< user-data.yaml 92 | cloud-localds $@ user-data.yaml 93 | 94 | busybox.qcow2: noble-server-cloudimg-amd64.qcow2 seed.iso 95 | qemu-img create -f qcow2 -b $< -F qcow2 $@ 20G 96 | qemu-system-x86_64 -m 16G -smp 8 -machine accel=kvm,type=pc -cpu host -display none -vnc :0 \ 97 | -drive file=$@ \ 98 | -drive file=seed.iso,format=raw \ 99 | -nic user,hostfwd=tcp::60022-:22 100 | 101 | # OpenBSD 102 | 103 | openbsd: openbsd-77-amd64-ocaml-4.14.qcow2 openbsd-77-amd64-ocaml-5.2.qcow2 openbsd-77-amd64-ocaml-5.3.qcow2 openbsd-77-amd64-ocaml-5.4.qcow2 104 | 105 | openbsd-77-amd64-ocaml-5.4.qcow2: openbsd-77-amd64-ocaml-5.4.0.qcow2 106 | ln -sf $< $@ 107 | 108 | openbsd-77-amd64-ocaml-5.3.qcow2: openbsd-77-amd64-ocaml-5.3.0.qcow2 109 | ln -sf $< $@ 110 | 111 | openbsd-77-amd64-ocaml-5.2.qcow2: openbsd-77-amd64-ocaml-5.2.1.qcow2 112 | ln -sf $< $@ 113 | 114 | openbsd-77-amd64-ocaml-4.14.qcow2: openbsd-77-amd64-ocaml-4.14.2.qcow2 115 | ln -sf $< $@ 116 | 117 | openbsd-77-amd64-ocaml-%.qcow2: tftp/auto_install tftp/bsd.rd tftp/etc/boot.conf mirror% 118 | qemu-img create -f qcow2 $@ 24G 119 | qemu-img create -f qcow2 cache-ffs.qcow2 20G 120 | python3 -m http.server --directory mirror --bind 0.0.0.0 80 & pid=$$! && \ 121 | qemu-system-x86_64 -m 16G -smp 8 -machine accel=kvm,type=pc -cpu host -display none -vnc :0 \ 122 | -drive file=$@,if=virtio \ 123 | -drive file=cache-ffs.qcow2,if=virtio \ 124 | -nic user,model=virtio,tftp-server-name=10.0.2.2,tftp=tftp,bootfile=auto_install,hostfwd=tcp::60022-:22 ; \ 125 | kill $$pid 126 | 127 | tftp/auto_install: 128 | mkdir -p tftp 129 | curl -L https://cdn.openbsd.org/pub/OpenBSD/7.7/amd64/pxeboot -o tftp/auto_install 130 | 131 | tftp/bsd.rd: 132 | mkdir -p tftp 133 | curl -L https://cdn.openbsd.org/pub/OpenBSD/7.7/amd64/bsd.rd -o tftp/bsd.rd 134 | 135 | tftp/etc/boot.conf: 136 | mkdir -p tftp/etc 137 | echo boot tftp:/bsd.rd > tftp/etc/boot.conf 138 | 139 | mirror%: install.site.m4 install.conf disklabel 140 | m4 -D VERSION=$* $< > install.site 141 | chmod +x install.site 142 | mkdir -p mirror/pub/OpenBSD/7.7/amd64 143 | tar -czf mirror/pub/OpenBSD/7.7/amd64/site77.tgz install.site 144 | for f in BUILDINFO SHA256.sig base77.tgz bsd bsd.mp bsd.rd comp77.tgz game77.tgz man77.tgz pxeboot xbase77.tgz xfont77.tgz xserv77.tgz xshare77.tgz ; do curl -C - -L https://cdn.openbsd.org/pub/OpenBSD/7.7/amd64/$$f -o mirror/pub/OpenBSD/7.7/amd64/$$f ; done 145 | cd mirror/pub/OpenBSD/7.7/amd64 && ls -l > index.txt 146 | cp install.conf disklabel mirror 147 | 148 | deps: 149 | apt install -y make m4 mkisofs cloud-image-utils 150 | 151 | clean: 152 | rm -f *.qcow2 *.iso *.exe *.msi install.site autounattend.xml 153 | rm -rf mirror tftp 154 | 155 | -------------------------------------------------------------------------------- /lib/sandbox.jail.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | open Sexplib.Conv 3 | 4 | include S.Sandbox_default 5 | 6 | let ( / ) = Filename.concat 7 | 8 | type t = { 9 | jail_name_prefix : string; 10 | } 11 | 12 | type config = unit [@@deriving sexp] 13 | 14 | (* Find out the user name to use within the jail, by parsing the 15 | /etc/passwd file within the jail filesystem. This is roughly 16 | equivalent to what Unix.getpwuid would do. 17 | Note that the gid is currently ignored. *) 18 | let jail_username rootdir config = 19 | match config.Config.user with 20 | | `Windows w -> w.name 21 | | `Unix { uid; _ } -> 22 | let pwdfile = rootdir / "etc" / "passwd" in 23 | let uidstr = string_of_int uid in 24 | let rec parse_line ch = 25 | match In_channel.input_line ch with 26 | | None -> None 27 | | Some line -> 28 | let fields = String.split_on_char ':' line in begin 29 | match fields with 30 | | name :: _pass :: uid :: _ -> 31 | if uid = uidstr then Some name else parse_line ch 32 | | _ -> parse_line ch 33 | end 34 | in 35 | match In_channel.with_open_text pwdfile parse_line with 36 | | None -> Fmt.failwith "No user found for uid %d" uid 37 | | Some name -> name 38 | 39 | (* Compute the complete set of arguments passed to the jail(8) command: 40 | jail username, jail path, command to run, etc. *) 41 | let jail_options config rootdir tmp_dir = 42 | let cache = match List.length config.Config.mounts with 43 | | 0 -> [] 44 | | _ -> 45 | let path = tmp_dir / "fstab" in 46 | let rec print_fstab oc = function 47 | | [] -> close_out oc 48 | | { Config.Mount.src; dst; readonly; _ } :: tl -> 49 | let full = rootdir ^ dst in 50 | Os.ensure_dir full; 51 | Printf.fprintf oc "%s %s nullfs %s 0 0\n" src full (if readonly then "ro" else "rw"); 52 | print_fstab oc tl in 53 | let oc = open_out path in 54 | print_fstab oc config.Config.mounts; 55 | [ "mount.fstab=" ^ path ] in 56 | let username = jail_username rootdir config in 57 | let commandline = 58 | let env = List.rev_map (fun (k, v) -> k ^ "='" ^ v ^ "'") config.env in 59 | let commandline = List.rev (List.rev_map Filename.quote config.argv) in 60 | let commandline = 61 | match env with 62 | | [] -> commandline 63 | | _ -> "env" :: List.rev_append env commandline 64 | in 65 | let commandline = 66 | String.concat " " 67 | ([ "cd" ; Filename.quote config.cwd ; "&&" ] @ commandline) 68 | in 69 | (* Ask for a login shell in order to properly source opam settings. *) 70 | [ "command=/usr/bin/su" ; "-l" ; username ; "-c" ; commandline ] 71 | in 72 | let path = "path=" ^ rootdir in 73 | let devfs_setup = "mount.devfs" in 74 | let options = 75 | let options = [ path ; devfs_setup ] @ cache in 76 | match config.network with 77 | | [ "host" ] -> 78 | "ip4=inherit" :: "ip6=inherit" :: "host=inherit" :: options 79 | | _ -> 80 | "exec.start=/sbin/ifconfig lo0 127.0.0.1/8" :: "vnet" :: options 81 | in 82 | List.rev_append options commandline 83 | 84 | let copy_to_log ~src ~dst = 85 | let buf = Bytes.create 4096 in 86 | let rec aux () = 87 | Lwt_unix.read src buf 0 (Bytes.length buf) >>= function 88 | | 0 -> Lwt.return_unit 89 | | n -> Build_log.write dst (Bytes.sub_string buf 0 n) >>= aux 90 | in 91 | aux () 92 | 93 | let jail_id = ref 0 94 | 95 | let run ~cancelled ?stdin:stdin ~log (t : t) config rootdir = 96 | Lwt_io.with_temp_dir ~prefix:"obuilder-jail-" @@ fun tmp_dir -> 97 | let zfs_volume = String.sub rootdir 1 (String.length rootdir - 1) in (* remove / from front *) 98 | Os.sudo [ "zfs"; "inherit"; "mountpoint"; zfs_volume ^ "/rootfs" ] >>= fun () -> 99 | let cwd = rootdir in 100 | let jail_name = t.jail_name_prefix ^ "_" ^ string_of_int !jail_id in 101 | incr jail_id; 102 | Os.with_pipe_from_child @@ fun ~r:out_r ~w:out_w -> 103 | let rootdir = rootdir / "rootfs" in 104 | let workdir = rootdir / config.Config.cwd in 105 | (* Make sure the work directory exists prior to starting the jail. *) 106 | begin 107 | match Os.check_dir workdir with 108 | | `Present -> Lwt.return_unit 109 | | `Missing -> Os.sudo [ "mkdir" ; "-p" ; workdir ] 110 | end >>= fun () -> 111 | let stdout = `FD_move_safely out_w in 112 | let stderr = stdout in 113 | let copy_log = copy_to_log ~src:out_r ~dst:log in 114 | let proc = 115 | let cmd = 116 | let options = jail_options config rootdir tmp_dir in 117 | "jail" :: "-c" :: ("name=" ^ jail_name) :: options 118 | in 119 | let stdin = Option.map (fun x -> `FD_move_safely x) stdin in 120 | let pp f = Os.pp_cmd f ("", cmd) in 121 | (* This is similar to 122 | Os.sudo_result ~cwd ?stdin ~stdout ~stderr ~pp cmd 123 | but also unmounting the in-jail devfs if necessary, see below. *) 124 | let cmd = if Os.running_as_root then cmd else "sudo" :: "--" :: cmd in 125 | Logs.info (fun f -> f "Exec %a" Os.pp_cmd ("", cmd)); 126 | !Os.lwt_process_exec ~cwd ?stdin ~stdout ~stderr ~pp 127 | ("", Array.of_list cmd) >>= function 128 | | Ok 0 -> 129 | let fstab = tmp_dir / "fstab" in 130 | (if Sys.file_exists fstab 131 | then 132 | let cmd = [ "sudo" ; "/sbin/umount" ; "-a" ; "-F" ; fstab ] in 133 | Os.exec ~is_success:(fun _ -> true) cmd 134 | else Lwt.return_unit) >>= fun () -> 135 | (* If the command within the jail completes, the jail is automatically 136 | removed, but without performing any of the stop and release actions, 137 | thus we can not use "exec.stop" to unmount the in-jail devfs 138 | filesystem. Do this here, ignoring the exit code of umount(8). *) 139 | let cmd = [ "sudo" ; "/sbin/umount" ; rootdir / "dev" ] in 140 | Os.exec ~is_success:(fun _ -> true) cmd >>= fun () -> 141 | Lwt_result.ok Lwt.return_unit 142 | | Ok n -> Lwt.return @@ Fmt.error_msg "%t failed with exit status %d" pp n 143 | | Error e -> Lwt_result.fail e 144 | in 145 | Lwt.on_termination cancelled (fun () -> 146 | let rec aux () = 147 | if Lwt.is_sleeping proc then ( 148 | let pp f = Fmt.pf f "jail -r obuilder" in 149 | Os.sudo_result ~cwd [ "jail" ; "-r" ; jail_name ] ~pp >>= function 150 | | Ok () -> Lwt.return_unit 151 | | Error (`Msg _) -> 152 | Lwt_unix.sleep 10.0 >>= aux 153 | ) else Lwt.return_unit (* Process has already finished *) 154 | in 155 | Lwt.async aux 156 | ); 157 | proc >>= fun r -> 158 | copy_log >>= fun () -> 159 | if Lwt.is_sleeping cancelled then 160 | Lwt.return (r :> (unit, [`Msg of string | `Cancelled]) result) 161 | else 162 | Lwt_result.fail `Cancelled 163 | 164 | let create ~state_dir:_ _c = 165 | Lwt.return { 166 | (* Compute a unique (across obuilder instances) name prefix for the jail. *) 167 | jail_name_prefix = "obuilder_" ^ (Int.to_string (Unix.getpid ())); 168 | } 169 | 170 | open Cmdliner 171 | 172 | let cmdliner : config Term.t = 173 | Term.(const ()) 174 | -------------------------------------------------------------------------------- /.github/workflows/main.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -eux 3 | export OPAMYES=true 4 | 5 | sudo sh -c "cat > /usr/local/bin/uname" << EOF 6 | #!/bin/sh 7 | 8 | if test "\$1" = '-r'; then 9 | echo '5.08.0-6-amd64' 10 | else 11 | exec /usr/bin/uname \$@ 12 | fi 13 | EOF 14 | sudo chmod a+x /usr/local/bin/uname 15 | 16 | opam exec -- make 17 | 18 | case "$1" in 19 | overlayfs) 20 | sudo chmod a+x /usr/local/bin/runc 21 | 22 | sudo mkdir /overlayfs 23 | sudo mount -t tmpfs -o size=10G tmpfs /overlayfs 24 | sudo chown "$(whoami)" /overlayfs 25 | 26 | opam exec -- dune exec -- obuilder healthcheck --store=overlayfs:/overlayfs 27 | opam exec -- dune exec -- ./stress/stress.exe --store=overlayfs:/overlayfs 28 | 29 | # Populate the caches from our own GitHub Actions cache 30 | mkdir -p /overlayfs/cache/c-opam-archives 31 | cp -r ~/.opam/download-cache/* /overlayfs/cache/c-opam-archives/ 32 | sudo chown -R 1000:1000 /overlayfs/cache/c-opam-archives 33 | 34 | opam exec -- dune exec -- obuilder build -f example.spec . --store=overlayfs:/overlayfs --color=always 35 | 36 | sudo umount /overlayfs 37 | ;; 38 | 39 | xfs) 40 | sudo chmod a+x /usr/local/bin/runc 41 | 42 | dd if=/dev/zero of=/tmp/xfs.img bs=100M count=100 43 | XFS_LOOP=$(sudo losetup -f) 44 | sudo losetup -P "$XFS_LOOP" /tmp/xfs.img 45 | sudo mkfs.xfs -f "$XFS_LOOP" 46 | sudo mkdir /xfs 47 | sudo mount -t xfs "$XFS_LOOP" /xfs 48 | sudo chown "$(whoami)" /xfs 49 | 50 | opam exec -- dune exec -- obuilder healthcheck --store=xfs:/xfs 51 | opam exec -- dune exec -- ./stress/stress.exe --store=xfs:/xfs 52 | 53 | # Populate the caches from our own GitHub Actions cache 54 | mkdir -p /xfs/cache/c-opam-archives 55 | cp -r ~/.opam/download-cache/* /xfs/cache/c-opam-archives/ 56 | sudo chown -R 1000:1000 /xfs/cache/c-opam-archives 57 | 58 | opam exec -- dune exec -- obuilder build -f example.spec . --store=xfs:/xfs --color=always 59 | 60 | sudo umount /xfs 61 | sudo losetup -d "$XFS_LOOP" 62 | sudo rm -f /tmp/xfs.img 63 | ;; 64 | 65 | btrfs) 66 | sudo chmod a+x /usr/local/bin/runc 67 | 68 | dd if=/dev/zero of=/tmp/btrfs.img bs=100M count=50 69 | BTRFS_LOOP=$(sudo losetup -f) 70 | sudo losetup -P "$BTRFS_LOOP" /tmp/btrfs.img 71 | sudo mkfs.btrfs -f "$BTRFS_LOOP" 72 | sudo mkdir /btrfs 73 | sudo mount -t btrfs "$BTRFS_LOOP" /btrfs 74 | sudo chown "$(whoami)" /btrfs 75 | 76 | opam exec -- dune exec -- obuilder healthcheck --store=btrfs:/btrfs 77 | opam exec -- dune exec -- ./stress/stress.exe --store=btrfs:/btrfs 78 | 79 | # Populate the caches from our own GitHub Actions cache 80 | btrfs subvolume create /btrfs/cache/c-opam-archives 81 | cp -r ~/.opam/download-cache/* /btrfs/cache/c-opam-archives/ 82 | sudo chown -R 1000:1000 /btrfs/cache/c-opam-archives 83 | 84 | opam exec -- dune exec -- obuilder build -f example.spec . --store=btrfs:/btrfs --color=always 85 | 86 | sudo umount /btrfs 87 | sudo losetup -d "$BTRFS_LOOP" 88 | sudo rm -f /tmp/btrfs.img 89 | ;; 90 | 91 | zfs) 92 | sudo chmod a+x /usr/local/bin/runc 93 | 94 | dd if=/dev/zero of=/tmp/zfs.img bs=100M count=50 95 | ZFS_LOOP=$(sudo losetup -f) 96 | sudo losetup -P "$ZFS_LOOP" /tmp/zfs.img 97 | sudo /sbin/modprobe zfs 98 | sudo zpool create zfs "$ZFS_LOOP" 99 | 100 | opam exec -- dune exec -- obuilder healthcheck --store=zfs:zfs 101 | opam exec -- dune exec -- ./stress/stress.exe --store=zfs:zfs 102 | 103 | # Populate the caches from our own GitHub Actions cache 104 | sudo zfs create zfs/cache/c-opam-archives 105 | sudo cp -r ~/.opam/download-cache/* /zfs/cache/c-opam-archives/ 106 | sudo chown -R 1000:1000 /zfs/cache/c-opam-archives 107 | sudo zfs snapshot zfs/cache/c-opam-archives@snap 108 | 109 | opam exec -- dune exec -- obuilder build -f example.spec . --store=zfs:zfs --color=always 110 | 111 | sudo zpool destroy zfs 112 | sudo losetup -d "$ZFS_LOOP" 113 | sudo rm -f /tmp/zfs.img 114 | ;; 115 | 116 | # rsync_hardlink_unsafe) 117 | # sudo mkdir /rsync 118 | # sudo chown "$(whoami)" /rsync 119 | 120 | # opam exec -- dune exec -- obuilder healthcheck --store=rsync:/rsync --rsync-mode hardlink_unsafe 121 | # opam exec -- dune exec -- ./stress/stress.exe --store=rsync:/rsync --rsync-mode hardlink_unsafe 122 | 123 | # # Populate the caches from our own GitHub Actions cache 124 | # sudo mkdir -p /rsync/cache/c-opam-archives 125 | # sudo cp -r ~/.opam/download-cache/* /rsync/cache/c-opam-archives/ 126 | # sudo chown -R 1000:1000 /rsync/cache/c-opam-archives 127 | 128 | # opam exec -- dune exec -- obuilder build -f example.spec . --store=rsync:/rsync --rsync-mode hardlink_unsafe 129 | 130 | # sudo rm -rf /rsync 131 | # ;; 132 | 133 | rsync_hardlink) 134 | sudo chmod a+x /usr/local/bin/runc 135 | 136 | sudo mkdir /rsync 137 | sudo chown "$(whoami)" /rsync 138 | 139 | opam exec -- dune exec -- obuilder healthcheck --store=rsync:/rsync --rsync-mode hardlink 140 | opam exec -- dune exec -- ./stress/stress.exe --store=rsync:/rsync --rsync-mode hardlink 141 | 142 | # Populate the caches from our own GitHub Actions cache 143 | sudo mkdir -p /rsync/cache/c-opam-archives 144 | sudo cp -r ~/.opam/download-cache/* /rsync/cache/c-opam-archives/ 145 | sudo chown -R 1000:1000 /rsync/cache/c-opam-archives 146 | 147 | opam exec -- dune exec -- obuilder build -f example.spec . --store=rsync:/rsync --rsync-mode hardlink --color=always 148 | 149 | sudo rm -rf /rsync 150 | ;; 151 | 152 | rsync_copy) 153 | sudo chmod a+x /usr/local/bin/runc 154 | 155 | sudo mkdir /rsync 156 | sudo chown "$(whoami)" /rsync 157 | 158 | opam exec -- dune exec -- obuilder healthcheck --store=rsync:/rsync --rsync-mode copy 159 | opam exec -- dune exec -- ./stress/stress.exe --store=rsync:/rsync --rsync-mode copy 160 | 161 | # Populate the caches from our own GitHub Actions cache 162 | sudo mkdir -p /rsync/cache/c-opam-archives 163 | sudo cp -r ~/.opam/download-cache/* /rsync/cache/c-opam-archives/ 164 | sudo chown -R 1000:1000 /rsync/cache/c-opam-archives 165 | 166 | opam exec -- dune exec -- obuilder build -f example.spec . --store=rsync:/rsync --rsync-mode copy --color=always 167 | 168 | sudo rm -rf /rsync 169 | ;; 170 | 171 | docker) 172 | sudo mkdir /var/lib/obuilder 173 | sudo chown "$(whoami)" /var/lib/obuilder 174 | 175 | opam exec -- dune exec -- obuilder healthcheck --store=docker:/var/lib/obuilder 176 | 177 | # Populate the caches from our own GitHub Actions cache 178 | sudo mkdir -p /var/lib/obuilder/cache/c-opam-archives 179 | sudo cp -r ~/.opam/download-cache/* /var/lib/obuilder/cache/c-opam-archives/ 180 | sudo chown -R 1000:1000 /var/lib/obuilder/cache/c-opam-archives 181 | 182 | opam exec -- dune exec -- obuilder build -f example.spec . --store=docker:/var/lib/obuilder --color=always 183 | 184 | sudo rm -rf /var/lib/obuilder 185 | ;; 186 | 187 | *) 188 | printf "Usage: .run-gha-tests.sh [btrfs|rsync_hardlink|rsync_copy|zfs|overlayfs]" >&2 189 | exit 1 190 | esac 191 | -------------------------------------------------------------------------------- /lib/db_store.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | let ( / ) = Filename.concat 4 | let ( >>!= ) = Lwt_result.bind 5 | 6 | module Make (Raw : S.STORE) = struct 7 | type build = { 8 | mutable users : int; 9 | set_cancelled : unit Lwt.u; (* Resolve this to cancel (when [users = 0]). *) 10 | log : Build_log.t Lwt.t; 11 | result : (([`Loaded | `Saved] * S.id), [`Cancelled | `Msg of string]) Lwt_result.t; 12 | base : string option; 13 | } 14 | 15 | module Builds = Map.Make(String) 16 | 17 | type t = { 18 | raw : Raw.t; 19 | dao : Dao.t; 20 | (* Invariants for builds in [in_progress]: 21 | - [result] is still pending and [log] isn't finished. 22 | - [set_cancelled] is resolved iff [users = 0]. *) 23 | mutable in_progress : build Builds.t; 24 | mutable cache_hit : int; 25 | mutable cache_miss : int; 26 | } 27 | 28 | let finish_log ~set_log log = 29 | match Lwt.state log with 30 | | Lwt.Return log -> 31 | Build_log.finish log 32 | | Lwt.Fail _ -> 33 | Lwt.return_unit 34 | | Lwt.Sleep -> 35 | Lwt.wakeup_exn set_log (Failure "Build ended without setting a log!"); 36 | Lwt.return_unit 37 | 38 | let dec_ref build = 39 | build.users <- build.users - 1; 40 | if Lwt.is_sleeping build.result then ( 41 | Log.info (fun f -> f "User cancelled job (users now = %d)" build.users); 42 | if build.users = 0 then ( 43 | Lwt.wakeup_later build.set_cancelled () 44 | ) 45 | ) 46 | 47 | (* Get the result for [id], either by loading it from the disk cache 48 | or by doing a new build using [fn]. We only run one instance of this 49 | at a time for a single [id]. *) 50 | let get_build t ~base ~id ~cancelled ~set_log fn = 51 | Raw.result t.raw id >>= function 52 | | Some _ -> 53 | t.cache_hit <- t.cache_hit + 1; 54 | let now = Unix.(gmtime (gettimeofday ())) in 55 | Dao.set_used t.dao ~id ~now; 56 | Raw.log_file t.raw id >>= fun log_file -> 57 | begin 58 | if Sys.file_exists log_file then Build_log.of_saved log_file 59 | else Lwt.return Build_log.empty 60 | end >>= fun log -> 61 | Lwt.wakeup set_log log; 62 | Lwt_result.return (`Loaded, id) 63 | | None -> 64 | t.cache_miss <- t.cache_miss + 1; 65 | Raw.build t.raw ?base ~id (fun dir -> 66 | Raw.log_file t.raw id >>= fun log_file -> 67 | if Sys.file_exists log_file then Unix.unlink log_file; 68 | Build_log.create log_file >>= fun log -> 69 | Lwt.wakeup set_log log; 70 | fn ~cancelled ~log dir 71 | ) 72 | >>!= fun () -> 73 | let now = Unix.(gmtime (gettimeofday () )) in 74 | Dao.add t.dao ?parent:base ~id ~now; 75 | Lwt_result.return (`Saved, id) 76 | 77 | let log_ty client_log ~id = function 78 | | `Loaded -> client_log `Note (Fmt.str "---> using %S from cache" id) 79 | | `Saved -> client_log `Note (Fmt.str "---> saved as %S" id) 80 | 81 | (* Check to see if we're in the process of building [id]. 82 | If so, just tail the log from that. 83 | If not, use [get_build] to get the build. 84 | [get_build] should set the log being used as soon as it knows it 85 | (this can't happen until we've created the temporary directory 86 | in the underlying store). *) 87 | let rec build ?switch t ?base ~id ~log:client_log fn = 88 | match Builds.find_opt id t.in_progress with 89 | | Some existing when existing.users = 0 -> 90 | client_log `Note ("Waiting for previous build to finish cancelling"); 91 | assert (Lwt.is_sleeping existing.result); 92 | existing.result >>= fun _ -> 93 | build ?switch t ?base ~id ~log:client_log fn 94 | | Some existing -> 95 | (* We're already building this, and the build hasn't been cancelled. *) 96 | existing.users <- existing.users + 1; 97 | existing.log >>= fun log -> 98 | Lwt_switch.add_hook_or_exec switch (fun () -> dec_ref existing; Lwt.return_unit) >>= fun () -> 99 | Build_log.tail ?switch log (client_log `Output) >>!= fun () -> 100 | existing.result >>!= fun (ty, r) -> 101 | log_ty client_log ~id ty; 102 | Lwt_result.return r 103 | | None -> 104 | let result, set_result = Lwt.wait () in 105 | let log, set_log = Lwt.wait () in 106 | let tail_log = log >>= fun log -> Build_log.tail ?switch log (client_log `Output) in 107 | let cancelled, set_cancelled = Lwt.wait () in 108 | let build = { users = 1; set_cancelled; log; result; base } in 109 | Lwt_switch.add_hook_or_exec switch (fun () -> dec_ref build; Lwt.return_unit) >>= fun () -> 110 | t.in_progress <- Builds.add id build t.in_progress; 111 | Lwt.async 112 | (fun () -> 113 | Lwt.try_bind 114 | (fun () -> get_build t ~base ~id ~cancelled ~set_log fn) 115 | (fun r -> 116 | t.in_progress <- Builds.remove id t.in_progress; 117 | Lwt.wakeup_later set_result r; 118 | finish_log ~set_log log 119 | ) 120 | (fun ex -> 121 | Log.info (fun f -> f "Build %S error: %a" id Fmt.exn ex); 122 | t.in_progress <- Builds.remove id t.in_progress; 123 | Lwt.wakeup_later_exn set_result ex; 124 | finish_log ~set_log log 125 | ) 126 | ); 127 | tail_log >>!= fun () -> 128 | result >>!= fun (ty, r) -> 129 | log_ty client_log ~id ty; 130 | Lwt_result.return r 131 | 132 | let result t id = Raw.result t.raw id 133 | let count t = Dao.count t.dao 134 | let df t = Raw.df t.raw 135 | let root t = Raw.root t.raw 136 | let cache_stats t = t.cache_hit, t.cache_miss 137 | let cache ~user t = Raw.cache ~user t.raw 138 | 139 | let delete ?(log=ignore) t id = 140 | let rec aux id = 141 | match Dao.children t.dao id with 142 | | Error `No_such_id -> 143 | log id; 144 | Log.warn (fun f -> f "ID %S not in database!" id); 145 | Raw.delete t.raw id (* Try removing it anyway *) 146 | | Ok deps -> 147 | Lwt_list.iter_s aux deps >>= fun () -> 148 | log id; 149 | Raw.delete t.raw id >|= fun () -> 150 | Dao.delete t.dao id 151 | in 152 | aux id 153 | 154 | let prune_lru ?(log=ignore) t ~before limit = 155 | let items = Dao.lru t.dao ~before limit in 156 | let items = List.filter (fun id -> 157 | Builds.filter (fun _ b -> match b.base with 158 | | Some base -> base = id 159 | | None -> false) t.in_progress |> Builds.is_empty) items in 160 | match items with 161 | | [] -> Lwt.return 0 162 | | id :: _ -> 163 | log id; 164 | Raw.delete t.raw id >>= fun () -> 165 | Dao.delete t.dao id ; 166 | Lwt.return 1 167 | 168 | let prune ?log t ~before limit = 169 | Log.info (fun f -> f "Pruning %d items" limit); 170 | let rec aux count = 171 | if count >= limit then Lwt.return count (* Pruned everything we wanted to *) 172 | else ( 173 | prune_lru ?log t ~before limit >>= function 174 | | 0 -> Lwt.return count (* Nothing left to prune *) 175 | | n -> aux (count + n) 176 | ) 177 | in 178 | aux 0 >>= fun n -> 179 | Raw.complete_deletes t.raw >>= fun () -> 180 | Log.info (fun f -> f "Pruned %d items" n); 181 | Lwt.return n 182 | 183 | let wrap raw = 184 | let db_dir = Raw.state_dir raw / "db" in 185 | Os.ensure_dir db_dir; 186 | let db = Db.of_dir (db_dir / "db.sqlite") in 187 | let dao = Dao.create db in 188 | { raw; dao; in_progress = Builds.empty; cache_hit = 0; cache_miss = 0 } 189 | 190 | let unwrap t = 191 | Dao.close t.dao 192 | end 193 | -------------------------------------------------------------------------------- /main.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | let ( / ) = Filename.concat 4 | 5 | module Native_sandbox = Obuilder.Native_sandbox 6 | module Docker_sandbox = Obuilder.Docker_sandbox 7 | module Qemu_sandbox = Obuilder.Qemu_sandbox 8 | module Docker_store = Obuilder.Docker_store 9 | module Docker_extract = Obuilder.Docker_extract 10 | module Archive_extract = Obuilder.Archive_extract 11 | module Qemu_snapshot = Obuilder.Qemu_snapshot 12 | module Store_spec = Obuilder.Store_spec 13 | 14 | type builder = Builder : (module Obuilder.BUILDER with type t = 'a) * 'a -> builder 15 | 16 | let log tag msg = 17 | match tag with 18 | | `Heading -> Fmt.pr "%a@." Fmt.(styled (`Fg (`Hi `Blue)) string) msg 19 | | `Note -> Fmt.pr "%a@." Fmt.(styled (`Fg `Yellow) string) msg 20 | | `Output -> output_string stdout msg; flush stdout 21 | 22 | let create_builder store_spec conf = 23 | store_spec >>= fun (Store_spec.Store ((module Store), store)) -> 24 | let module Builder = Obuilder.Builder (Store) (Native_sandbox) (Docker_extract) in 25 | Native_sandbox.create ~state_dir:(Store.state_dir store / "sandbox") conf >|= fun sandbox -> 26 | let builder = Builder.v ~store ~sandbox in 27 | Builder ((module Builder), builder) 28 | 29 | let create_docker_builder store_spec conf = 30 | store_spec >>= fun (Store_spec.Store ((module Store), store)) -> 31 | let module Builder = Obuilder.Docker_builder (Store) in 32 | Docker_sandbox.create conf >|= fun sandbox -> 33 | let builder = Builder.v ~store ~sandbox in 34 | Builder ((module Builder), builder) 35 | 36 | let create_qemu_builder store_spec conf = 37 | store_spec >>= fun (Store_spec.Store ((module Store), store)) -> 38 | let module Builder = Obuilder.Builder (Store) (Qemu_sandbox) (Qemu_snapshot) in 39 | Qemu_sandbox.create conf >|= fun sandbox -> 40 | let builder = Builder.v ~store ~sandbox in 41 | Builder ((module Builder), builder) 42 | 43 | let read_whole_file path = 44 | let ic = open_in_bin path in 45 | Fun.protect ~finally:(fun () -> close_in ic) @@ fun () -> 46 | let len = in_channel_length ic in 47 | really_input_string ic len 48 | 49 | let select_backend (sandbox, store_spec) native_conf docker_conf qemu_conf = 50 | match sandbox with 51 | | `Native -> create_builder store_spec native_conf 52 | | `Docker -> create_docker_builder store_spec docker_conf 53 | | `Qemu -> create_qemu_builder store_spec qemu_conf 54 | 55 | let build () store spec native_conf docker_conf qemu_conf src_dir secrets = 56 | Lwt_main.run begin 57 | select_backend store native_conf docker_conf qemu_conf 58 | >>= fun (Builder ((module Builder), builder)) -> 59 | Fun.flip Lwt.finalize (fun () -> Builder.finish builder) @@ fun () -> 60 | let spec = 61 | try Obuilder.Spec.t_of_sexp (Sexplib.Sexp.load_sexp spec) 62 | with Failure msg -> 63 | print_endline msg; 64 | exit 1 65 | in 66 | let secrets = List.map (fun (id, path) -> id, read_whole_file path) secrets in 67 | let context = Obuilder.Context.v ~log ~src_dir ~shell:(Builder.shell builder) ~secrets () in 68 | Builder.build builder context spec >>= function 69 | | Ok x -> 70 | Fmt.pr "Got: %S@." (x :> string); 71 | Lwt.return_unit 72 | | Error `Cancelled -> 73 | Fmt.epr "Cancelled at user's request@."; 74 | exit 1 75 | | Error (`Msg m) -> 76 | Fmt.epr "Build step failed: %s@." m; 77 | exit 1 78 | end 79 | 80 | let healthcheck () store native_conf docker_conf qemu_conf = 81 | Lwt_main.run begin 82 | select_backend store native_conf docker_conf qemu_conf 83 | >>= fun (Builder ((module Builder), builder)) -> 84 | Fun.flip Lwt.finalize (fun () -> Builder.finish builder) @@ fun () -> 85 | Builder.healthcheck builder >|= function 86 | | Error (`Msg m) -> 87 | Fmt.epr "Healthcheck failed: %s@." m; 88 | exit 1 89 | | Ok () -> 90 | Fmt.pr "Healthcheck passed@." 91 | end 92 | 93 | let delete () store native_conf docker_conf qemu_conf id = 94 | Lwt_main.run begin 95 | select_backend store native_conf docker_conf qemu_conf 96 | >>= fun (Builder ((module Builder), builder)) -> 97 | Fun.flip Lwt.finalize (fun () -> Builder.finish builder) @@ fun () -> 98 | Builder.delete builder id ~log:(fun id -> Fmt.pr "Removing %s@." id) 99 | end 100 | 101 | let clean () store native_conf docker_conf qemu_conf = 102 | Lwt_main.run begin 103 | select_backend store native_conf docker_conf qemu_conf 104 | >>= fun (Builder ((module Builder), builder)) -> 105 | Fun.flip Lwt.finalize (fun () -> Builder.finish builder) @@ begin fun () -> 106 | let now = Unix.(gmtime (gettimeofday ())) in 107 | Builder.prune builder ~before:now max_int ~log:(fun id -> Fmt.pr "Removing %s@." id) 108 | end >|= fun n -> 109 | Fmt.pr "Removed %d items@." n 110 | end 111 | 112 | let dockerfile () buildkit escape spec = 113 | Sexplib.Sexp.load_sexp spec 114 | |> Obuilder_spec.t_of_sexp 115 | |> Obuilder_spec.Docker.dockerfile_of_spec ~buildkit ~os:escape 116 | |> print_endline 117 | 118 | open Cmdliner 119 | 120 | let setup_log style_renderer level = 121 | Fmt_tty.setup_std_outputs ?style_renderer (); 122 | Logs.set_level level; 123 | Logs.Src.set_level Obuilder.log_src level; 124 | Logs.set_reporter (Logs_fmt.reporter ()); 125 | () 126 | 127 | let setup_log = 128 | let docs = Manpage.s_common_options in 129 | Term.(const setup_log $ Fmt_cli.style_renderer ~docs () $ Logs_cli.level ~docs ()) 130 | 131 | let spec_file = 132 | Arg.required @@ 133 | Arg.opt Arg.(some file) None @@ 134 | Arg.info 135 | ~doc:"Path of build spec file." 136 | ~docv:"FILE" 137 | ["f"] 138 | 139 | let src_dir = 140 | Arg.required @@ 141 | Arg.pos 0 Arg.(some dir) None @@ 142 | Arg.info 143 | ~doc:"Directory containing the source files." 144 | ~docv:"DIR" 145 | [] 146 | 147 | let store = Store_spec.cmdliner 148 | 149 | let id = 150 | Arg.required @@ 151 | Arg.pos 0 Arg.(some string) None @@ 152 | Arg.info 153 | ~doc:"The $(i,ID) of a build within the store." 154 | ~docv:"ID" 155 | [] 156 | 157 | let secrets = 158 | (Arg.value @@ 159 | Arg.(opt_all (pair ~sep:':' string file)) [] @@ 160 | Arg.info 161 | ~doc:"Provide a secret under the form $(b,id:file)." 162 | ~docv:"SECRET" 163 | ["secret"]) 164 | 165 | let build = 166 | let doc = "Build a spec file." in 167 | let info = Cmd.info "build" ~doc in 168 | Cmd.v info 169 | Term.(const build $ setup_log $ store $ spec_file $ Native_sandbox.cmdliner 170 | $ Docker_sandbox.cmdliner $ Qemu_sandbox.cmdliner $ src_dir $ secrets) 171 | 172 | let delete = 173 | let doc = "Recursively delete a cached build result." in 174 | let info = Cmd.info "delete" ~doc in 175 | Cmd.v info 176 | Term.(const delete $ setup_log $ store $ Native_sandbox.cmdliner 177 | $ Docker_sandbox.cmdliner $ Qemu_sandbox.cmdliner $ id) 178 | 179 | let clean = 180 | let doc = "Clean all cached build results." in 181 | let info = Cmd.info "clean" ~doc in 182 | Cmd.v info 183 | Term.(const clean $ setup_log $ store $ Native_sandbox.cmdliner 184 | $ Docker_sandbox.cmdliner $ Qemu_sandbox.cmdliner) 185 | 186 | let buildkit = 187 | Arg.value @@ 188 | Arg.flag @@ 189 | Arg.info 190 | ~doc:"Output extended BuildKit syntax." 191 | ["buildkit"] 192 | 193 | let escape = 194 | let styles = [("unix", `Unix); ("windows", `Windows)] in 195 | let doc = Arg.doc_alts_enum styles |> Printf.sprintf "Dockerfile escape style, must be %s." in 196 | Arg.value @@ 197 | Arg.opt Arg.(enum styles) (if Sys.unix then `Unix else `Windows) @@ 198 | Arg.info ~doc 199 | ~docv:"STYLE" 200 | ["escape"] 201 | 202 | let dockerfile = 203 | let doc = "Convert a spec to Dockerfile format." in 204 | let info = Cmd.info ~doc "dockerfile" in 205 | Cmd.v info 206 | Term.(const dockerfile $ setup_log $ buildkit $ escape $ spec_file) 207 | 208 | let healthcheck = 209 | let doc = "Perform a self-test" in 210 | let info = Cmd.info "healthcheck" ~doc in 211 | Cmd.v info 212 | Term.(const healthcheck $ setup_log $ store $ Native_sandbox.cmdliner 213 | $ Docker_sandbox.cmdliner $ Qemu_sandbox.cmdliner) 214 | 215 | let cmds = [build; delete; clean; dockerfile; healthcheck] 216 | 217 | let () = 218 | let doc = "a command-line interface for OBuilder" in 219 | let info = Cmd.info ~doc "obuilder" in 220 | exit (Cmd.eval @@ Cmd.group info cmds) 221 | -------------------------------------------------------------------------------- /lib_spec/spec.ml: -------------------------------------------------------------------------------- 1 | open Sexplib.Std 2 | 3 | module Scope = Set.Make(String) (* Nested builds in scope *) 4 | 5 | type sexp = Sexplib.Sexp.t = 6 | | Atom of string 7 | | List of sexp list 8 | 9 | (* Convert fields matched by [p] from (name v1 v2 …) to (name (v1 v2 …)) *) 10 | let inflate_record p = 11 | let open Sexplib.Sexp in function 12 | | Atom _ as x -> Fmt.failwith "Invalid record field: %a" Sexplib.Sexp.pp_hum x 13 | | List xs -> 14 | let expand = function 15 | | List (Atom name :: vs) when p name -> List [Atom name; List vs] 16 | | x -> x 17 | in 18 | List (List.map expand xs) 19 | 20 | (* Convert fields matched by [p] from (name (v1 v2 …)) to (name v1 v2 …) *) 21 | let deflate_record p = 22 | let open Sexplib.Sexp in function 23 | | Atom _ as x -> Fmt.failwith "Invalid record field: %a" Sexplib.Sexp.pp_hum x 24 | | List xs -> 25 | let deflate = function 26 | | List [Atom name; List vs] when p name -> List (Atom name :: vs) 27 | | x -> x 28 | in 29 | List (List.map deflate xs) 30 | 31 | type data_source = [ 32 | | `Context 33 | | `Build of string 34 | ] 35 | 36 | let sexp_of_data_source = function 37 | | `Context -> Atom "context" 38 | | `Build name -> List [Atom "build"; Atom name] 39 | 40 | let data_source_of_sexp = function 41 | | Atom "context" -> `Context 42 | | List [Atom "build"; Atom name] -> `Build name 43 | | x -> Fmt.failwith "Invalid data source: %a" Sexplib.Sexp.pp_hum x 44 | 45 | type copy = { 46 | from : data_source [@default `Context] [@sexp_drop_default (=)]; 47 | src : string list; 48 | dst : string; 49 | exclude : string list [@sexp.list]; 50 | } [@@deriving sexp] 51 | 52 | let copy_inlined = function 53 | | "src" | "exclude" -> true 54 | | _ -> false 55 | 56 | let copy_of_sexp x = copy_of_sexp (inflate_record copy_inlined x) 57 | let sexp_of_copy x = deflate_record copy_inlined (sexp_of_copy x) 58 | 59 | type unix_user = { 60 | uid : int; 61 | gid : int; 62 | } [@@deriving sexp] 63 | 64 | type windows_user = { 65 | name : string; 66 | } [@@deriving sexp] 67 | 68 | type user = [ 69 | | `Unix of unix_user 70 | | `Windows of windows_user 71 | ] [@@deriving sexp] 72 | 73 | let user_of_sexp x = 74 | let open Sexplib.Sexp in 75 | match x with 76 | | List [List [Atom "name"; _]] -> 77 | `Windows (windows_user_of_sexp x) 78 | | List [List [Atom "uid"; _]; List [Atom "gid"; _]] -> 79 | `Unix (unix_user_of_sexp x) 80 | | x -> Fmt.failwith "Invalid op: %a" Sexplib.Sexp.pp_hum x 81 | 82 | let sexp_of_user x : Sexplib.Sexp.t = 83 | let x = sexp_of_user x in 84 | match x with 85 | | List [Atom _os; List args] -> List args 86 | | x -> Fmt.failwith "Invalid op: %a" Sexplib.Sexp.pp_hum x 87 | 88 | type run = { 89 | cache : Cache.t list [@sexp.list]; 90 | network : string list [@sexp.list]; 91 | secrets : Secret.t list [@sexp.list]; 92 | shell : string; 93 | } [@@deriving sexp] 94 | 95 | let run_inlined = function 96 | | "cache" | "network" | "secrets" -> true 97 | | _ -> false 98 | 99 | let run_of_sexp x = run_of_sexp (inflate_record run_inlined x) 100 | let sexp_of_run x = deflate_record run_inlined (sexp_of_run x) 101 | 102 | type op = [ 103 | | `Comment of string 104 | | `Workdir of string 105 | | `Shell of string list [@sexp.list] 106 | | `Run of run 107 | | `Copy of copy 108 | | `User of user 109 | | `Env of (string * string) 110 | ] [@@deriving sexp] 111 | 112 | (* For some ops, we remove the extra () in the sexp string format, 113 | formatting them as if they were in-line records. e.g. 114 | (copy ((src …) (dst …))) becomes (copy (src …) (dst …)). *) 115 | let inline = function 116 | | "run" | "copy" | "user" | "env" -> true 117 | | _ -> false 118 | 119 | let sexp_of_op x : Sexplib.Sexp.t = 120 | match sexp_of_op x with 121 | | List (Atom name :: args) -> 122 | let name = String.lowercase_ascii name in 123 | let args = 124 | if inline name then 125 | match args with 126 | | [List args] -> args 127 | | _ -> failwith "Inline op must be a record!" 128 | else args 129 | in 130 | List (Atom name :: args) 131 | | x -> Fmt.failwith "Invalid op: %a" Sexplib.Sexp.pp_hum x 132 | 133 | let op_of_sexp x = 134 | let open Sexplib.Sexp in 135 | (* Fmt.pr "sexp_of_op: %a@." Sexplib.Sexp.pp_hum x; *) 136 | match x with 137 | | List (Atom name :: args) -> 138 | let args = if inline name then [List args] else args in 139 | let name = String.capitalize_ascii name in 140 | op_of_sexp (List (Atom name :: args)) 141 | | x -> Fmt.failwith "Invalid op: %a" Sexplib.Sexp.pp_hum x 142 | 143 | type t = { 144 | child_builds : (string * t) list; 145 | from : string; 146 | ops : op list; 147 | } 148 | 149 | let rec sexp_of_t { child_builds; from; ops } = 150 | let child_builds = 151 | child_builds |> List.map (fun (name, spec) -> 152 | List [ Atom "build"; Atom name; sexp_of_t spec ] 153 | ) 154 | in 155 | List (child_builds @ List [ Atom "from"; Atom from ] :: List.map sexp_of_op ops) 156 | 157 | let rec t_of_sexp = function 158 | | Atom _ as x -> Fmt.failwith "Invalid spec: %a" Sexplib.Sexp.pp_hum x 159 | | List items -> 160 | let rec aux acc = function 161 | | List [ Atom "build"; Atom name; child_spec ] :: xs -> 162 | let child = (name, t_of_sexp child_spec) in 163 | aux (child :: acc) xs 164 | | List [ Atom "from"; Atom from ] :: ops -> 165 | let child_builds = List.rev acc in 166 | { child_builds; from; ops = List.map op_of_sexp ops } 167 | | x :: _ -> Fmt.failwith "Invalid spec item: %a" Sexplib.Sexp.pp_hum x 168 | | [] -> Fmt.failwith "Invalid spec: missing (from)" 169 | in 170 | aux [] items 171 | 172 | let comment fmt = fmt |> Printf.ksprintf (fun c -> `Comment c) 173 | let workdir x = `Workdir x 174 | let shell xs = `Shell xs 175 | let run ?(cache=[]) ?(network=[]) ?(secrets=[]) fmt = fmt |> Printf.ksprintf (fun x -> `Run { shell = x; cache; network; secrets }) 176 | let copy ?(from=`Context) ?(exclude=[]) src ~dst = `Copy { from; src; dst; exclude } 177 | let env k v = `Env (k, v) 178 | let user_unix ~uid ~gid = `User (`Unix { uid; gid }) 179 | let user_windows ~name = `User (`Windows { name }) 180 | 181 | let root_unix = `Unix { uid = 0; gid = 0 } 182 | let root_windows = `Windows { name = "ContainerAdministrator" } 183 | let root = if Sys.win32 then root_windows else root_unix 184 | 185 | let rec pp_no_boxes f : Sexplib.Sexp.t -> unit = function 186 | | List xs -> Fmt.pf f "(%a)" (Fmt.list ~sep:Fmt.sp pp_no_boxes) xs 187 | | Atom _ as a -> Sexplib.Sexp.pp_hum f a 188 | 189 | let pp_one_line = Fmt.hbox pp_no_boxes 190 | 191 | let rec pp_op_sexp f : Sexplib.Sexp.t -> unit = function 192 | | List [(Atom "build" as op); (Atom _ as name); List ops] -> 193 | Fmt.pf f "(%a @[%a@,(@[%a@])@])" 194 | Sexplib.Sexp.pp_hum op 195 | Sexplib.Sexp.pp_hum name 196 | (Fmt.list ~sep:Fmt.cut pp_op_sexp) ops 197 | | List (Atom "copy" as op :: args) -> 198 | Fmt.pf f "(%a @[%a@])" 199 | Sexplib.Sexp.pp_hum op 200 | (Fmt.list ~sep:Fmt.sp pp_one_line) args 201 | | List (Atom ("run") as op :: args) -> 202 | Fmt.pf f "(%a @[%a@])" 203 | Sexplib.Sexp.pp_hum op 204 | (Fmt.list ~sep:Fmt.cut pp_one_line) args 205 | | x -> pp_one_line f x 206 | 207 | let pp f t = 208 | match sexp_of_t t with 209 | | List lines -> 210 | Fmt.pf f "(@[%a@]@,)" (Fmt.list ~sep:Fmt.cut pp_op_sexp) lines 211 | | x -> Sexplib.Sexp.pp_hum f x 212 | 213 | let pp_op = Fmt.using sexp_of_op pp_op_sexp 214 | 215 | let rec validate ?(scope=Scope.empty) { child_builds; from = _; ops } = 216 | let scope = 217 | List.fold_left (fun scope (name, spec) -> 218 | validate ~scope spec; 219 | Scope.add name scope 220 | ) scope child_builds in 221 | ops |> List.iter (function 222 | | `Copy { from = `Build name; src = _; _ } as copy -> 223 | if not (Scope.mem name scope) then ( 224 | let hints = Scope.elements scope in 225 | let post f () = Fmt.pf f " in %a" pp_op copy in 226 | Fmt.failwith "%a" 227 | Fmt.(did_you_mean ~kind:"build" ~post (quote string)) (name, hints) 228 | ) 229 | | _ -> () 230 | ) 231 | 232 | let stage ?(child_builds=[]) ~from ops = 233 | let t = { child_builds; from; ops } in 234 | validate t; 235 | t 236 | 237 | let t_of_sexp sexp = 238 | let t = t_of_sexp sexp in 239 | validate t; 240 | t 241 | -------------------------------------------------------------------------------- /lib/btrfs_store.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | let strf = Printf.sprintf 4 | 5 | let running_as_root = Unix.getuid () = 0 6 | 7 | (* Represents a persistent cache. 8 | You must hold a cache's lock when removing or updating its entry in 9 | "cache", and must assume this may happen at any time when not holding it. 10 | The generation counter is used to check whether the cache has been updated 11 | since being cloned. The counter starts from zero when the in-memory cache 12 | value is created (i.e. you cannot compare across restarts). *) 13 | type cache = { 14 | lock : Lwt_mutex.t; 15 | mutable gen : int; 16 | } 17 | 18 | type t = { 19 | root : string; (* The top-level directory (containing `result`, etc). *) 20 | caches : (string, cache) Hashtbl.t; 21 | mutable next : int; (* Used to generate unique temporary IDs. *) 22 | } 23 | 24 | let ( / ) = Filename.concat 25 | 26 | module Btrfs = struct 27 | let btrfs ?(sudo=false) args = 28 | let args = "btrfs" :: args in 29 | let args = if sudo && not running_as_root then "sudo" :: args else args in 30 | Os.exec ~stdout:`Dev_null args 31 | 32 | let subvolume_create path = 33 | assert (not (Sys.file_exists path)); 34 | btrfs ["subvolume"; "create"; "--"; path] 35 | 36 | let subvolume_delete path = 37 | btrfs ~sudo:true ["subvolume"; "delete"; "--"; path] 38 | 39 | let subvolume_sync path = 40 | btrfs ~sudo:true ["subvolume"; "sync"; "--"; path] 41 | 42 | let subvolume_snapshot mode ~src dst = 43 | assert (not (Sys.file_exists dst)); 44 | let readonly = 45 | match mode with 46 | | `RO -> ["-r"] 47 | | `RW -> [] 48 | in 49 | btrfs ~sudo:true (["subvolume"; "snapshot"] @ readonly @ ["--"; src; dst]) 50 | end 51 | 52 | let delete_snapshot_if_exists path = 53 | match Os.check_dir path with 54 | | `Missing -> Lwt.return_unit 55 | | `Present -> Btrfs.subvolume_delete path 56 | 57 | module Path = struct 58 | (* A btrfs store contains several subdirectories: 59 | 60 | - result: completed builds, named by ID 61 | - result-tmp: in-progress builds 62 | - state: for sqlite DB, etc 63 | - cache: the latest version of each cache, by cache ID 64 | - cache-tmp: in-progress updates to caches 65 | 66 | result-tmp and cache-tmp are wiped at start-up. *) 67 | 68 | let result t id = t.root / "result" / id 69 | let result_tmp t id = t.root / "result-tmp" / id 70 | let state t = t.root / "state" 71 | let cache t name = t.root / "cache" / Escape.cache name 72 | let cache_tmp t i name = t.root / "cache-tmp" / strf "%d-%s" i (Escape.cache name) 73 | end 74 | 75 | let delete t id = 76 | delete_snapshot_if_exists (Path.result t id) 77 | 78 | let purge path = 79 | Sys.readdir path |> Array.to_list |> Lwt_list.iter_s (fun item -> 80 | let item = path / item in 81 | Log.warn (fun f -> f "Removing left-over temporary item %S" item); 82 | Btrfs.subvolume_delete item 83 | ) 84 | 85 | let check_kernel_version () = 86 | Os.pread ["uname"; "-r"] >>= fun kver -> 87 | match String.split_on_char '.' kver with 88 | | maj :: min :: _ -> 89 | begin match int_of_string_opt maj, int_of_string_opt min with 90 | | Some maj, Some min when (maj, min) >= (5, 8) -> 91 | Lwt.return_unit 92 | | Some maj, Some min -> 93 | Fmt.failwith "You need at least linux 5.8 to use the btrfs backend, \ 94 | but current kernel version is '%d.%d'" maj min 95 | | _, _ -> 96 | Fmt.failwith "Could not parse kernel version %S" kver 97 | end 98 | | _ -> 99 | Fmt.failwith "Could not parse output of 'uname -r' (%S)" kver 100 | 101 | let root t = t.root 102 | 103 | module Stats = Map.Make (String) 104 | 105 | let df t = 106 | Lwt_process.pread ("", [| "btrfs"; "filesystem"; "usage"; "-b"; t.root |]) >>= fun output -> 107 | let stats = 108 | String.split_on_char '\n' output 109 | |> List.filter_map (fun s -> 110 | match String.split_on_char ':' s with 111 | | a :: b :: _ -> ( 112 | match Scanf.sscanf b " %Ld " (fun x -> x) with 113 | | x -> Some (String.trim a, Int64.to_float x) 114 | | (exception Scanf.Scan_failure _) | (exception End_of_file) -> 115 | None) 116 | | _ -> None) 117 | |> List.fold_left (fun acc (k, v) -> Stats.add k v acc) Stats.empty 118 | in 119 | Lwt.return (100. -. (100. *. (Stats.find "Used" stats /. Stats.find "Device size" stats))) 120 | 121 | let create root = 122 | check_kernel_version () >>= fun () -> 123 | Os.ensure_dir (root / "result"); 124 | Os.ensure_dir (root / "result-tmp"); 125 | Os.ensure_dir (root / "state"); 126 | Os.ensure_dir (root / "cache"); 127 | Os.ensure_dir (root / "cache-tmp"); 128 | purge (root / "result-tmp") >>= fun () -> 129 | purge (root / "cache-tmp") >>= fun () -> 130 | Lwt.return { root; caches = Hashtbl.create 10; next = 0 } 131 | 132 | let build t ?base ~id fn = 133 | let result = Path.result t id in 134 | let result_tmp = Path.result_tmp t id in 135 | assert (not (Sys.file_exists result)); (* Builder should have checked first *) 136 | begin match base with 137 | | None -> Btrfs.subvolume_create result_tmp 138 | | Some base -> Btrfs.subvolume_snapshot `RW ~src:(Path.result t base) result_tmp 139 | end 140 | >>= fun () -> 141 | Lwt.try_bind 142 | (fun () -> fn result_tmp) 143 | (fun r -> 144 | begin match r with 145 | | Ok () -> Btrfs.subvolume_snapshot `RO ~src:result_tmp result 146 | | Error _ -> Lwt.return_unit 147 | end >>= fun () -> 148 | Btrfs.subvolume_delete result_tmp >>= fun () -> 149 | Lwt.return r 150 | ) 151 | (fun ex -> 152 | Log.warn (fun f -> f "Uncaught exception from %S build function: %a" id Fmt.exn ex); 153 | Btrfs.subvolume_delete result_tmp >>= fun () -> 154 | Lwt.reraise ex 155 | ) 156 | 157 | let result t id = 158 | let dir = Path.result t id in 159 | match Os.check_dir dir with 160 | | `Present -> Lwt.return_some dir 161 | | `Missing -> Lwt.return_none 162 | 163 | let log_file t id = 164 | result t id >|= function 165 | | Some dir -> dir / "log" 166 | | None -> (Path.result_tmp t id) / "log" 167 | 168 | let get_cache t name = 169 | match Hashtbl.find_opt t.caches name with 170 | | Some c -> c 171 | | None -> 172 | let c = { lock = Lwt_mutex.create (); gen = 0 } in 173 | Hashtbl.add t.caches name c; 174 | c 175 | 176 | let cache ~user t name : (string * (unit -> unit Lwt.t)) Lwt.t = 177 | let cache = get_cache t name in 178 | Lwt_mutex.with_lock cache.lock @@ fun () -> 179 | let tmp = Path.cache_tmp t t.next name in 180 | t.next <- t.next + 1; 181 | let snapshot = Path.cache t name in 182 | (* Create cache if it doesn't already exist. *) 183 | begin match Os.check_dir snapshot with 184 | | `Missing -> Btrfs.subvolume_create snapshot 185 | | `Present -> Lwt.return_unit 186 | end >>= fun () -> 187 | (* Create writeable clone. *) 188 | let gen = cache.gen in 189 | Btrfs.subvolume_snapshot `RW ~src:snapshot tmp >>= fun () -> 190 | begin match user with 191 | | `Unix { Obuilder_spec.uid; gid } -> 192 | Os.sudo ["chown"; Printf.sprintf "%d:%d" uid gid; tmp] 193 | | `Windows _ -> assert false (* btrfs not supported on Windows*) 194 | end >>= fun () -> 195 | let release () = 196 | Lwt_mutex.with_lock cache.lock @@ fun () -> 197 | begin 198 | if cache.gen = gen then ( 199 | (* The cache hasn't changed since we cloned it. Update it. *) 200 | (* todo: check if it has actually changed. *) 201 | cache.gen <- cache.gen + 1; 202 | Btrfs.subvolume_delete snapshot >>= fun () -> 203 | Btrfs.subvolume_snapshot `RO ~src:tmp snapshot 204 | ) else Lwt.return_unit 205 | end >>= fun () -> 206 | Btrfs.subvolume_delete tmp 207 | in 208 | Lwt.return (tmp, release) 209 | 210 | let delete_cache t name = 211 | let cache = get_cache t name in 212 | Lwt_mutex.with_lock cache.lock @@ fun () -> 213 | cache.gen <- cache.gen + 1; (* Ensures in-progress writes will be discarded *) 214 | let snapshot = Path.cache t name in 215 | if Sys.file_exists snapshot then ( 216 | Btrfs.subvolume_delete snapshot >>= fun () -> 217 | Lwt_result.return () 218 | ) else Lwt_result.return () 219 | 220 | let state_dir = Path.state 221 | 222 | let complete_deletes t = 223 | Btrfs.subvolume_sync t.root 224 | -------------------------------------------------------------------------------- /lib/docker_store.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Syntax 2 | 3 | (* Represents a persistent cache. 4 | You must hold a cache's lock when removing or updating its entry in 5 | "cache", and must assume this may happen at any time when not holding it. 6 | The generation counter is used to check whether the cache has been updated 7 | since being cloned. The counter starts from zero when the in-memory cache 8 | value is created (i.e. you cannot compare across restarts). *) 9 | type cache = { 10 | lock : Lwt_mutex.t; 11 | mutable gen : int; 12 | } 13 | 14 | type t = { 15 | root : string; (* The top-level directory (containing `state`, etc). *) 16 | caches : (string, cache) Hashtbl.t; 17 | mutable next : int; (* Used to generate unique temporary IDs. *) 18 | } 19 | 20 | let ( / ) = Filename.concat 21 | let strf = Printf.sprintf 22 | 23 | module Path = struct 24 | (* A Docker store contains several subdirectories: 25 | 26 | - state: for sqlite DB, etc 27 | - log_file: for logs *) 28 | 29 | let empty t = t.root / "empty" 30 | let state t = t.root / "state" 31 | let log_file t id = t.root / "logs" / (id ^ ".log") 32 | end 33 | 34 | (* The OBuilder persistent cache is implemented using a shared Docker 35 | volume. As there's no snapshotting in volumes, we implement 36 | poor-man's snapshots: take a lock and copy the source. If the build 37 | of the new cache entry succeeds, it replaces the old one. 38 | 39 | For security reasons, each build step should only have access to 40 | its cache, so we need one volume per cache entry. The copy happens 41 | in the host filesystem. *) 42 | module Cache : sig 43 | val cache : string -> [> `Docker_volume of string] 44 | val cache_tmp : int -> string -> [> `Docker_volume of string] 45 | 46 | val name : [ `Docker_volume of string] -> string 47 | 48 | val exists : [ `Docker_volume of string] -> bool Lwt.t 49 | val create : [ `Docker_volume of string] -> unit Lwt.t 50 | val snapshot : src:[ `Docker_volume of string] -> [ `Docker_volume of string] -> unit Lwt.t 51 | val delete : [`Docker_volume of string] -> unit Lwt.t 52 | end = struct 53 | let cache name = Docker.docker_volume_cache (Escape.cache name) 54 | let cache_tmp i name = Docker.docker_volume_cache ~tmp:true (strf "%d-%s" i (Escape.cache name)) 55 | 56 | let name (`Docker_volume name) = name 57 | 58 | let exists volume = 59 | let+ r = Docker.Cmd.exists volume in 60 | Result.is_ok r 61 | 62 | let create volume = 63 | let* id = Docker.Cmd.volume ~timeout:5.0 (`Create volume) in 64 | Log.debug (fun f -> f "Volume id: %s" (String.trim id)); 65 | Lwt.return_unit 66 | 67 | let snapshot ~src dst = 68 | Log.debug (fun f -> f "Snapshotting volume %s to %s" (match src with `Docker_volume src -> src) (match dst with `Docker_volume dst -> dst)); 69 | let* () = create dst in 70 | let* base = if Sys.win32 then Docker_sandbox.servercore () else Lwt.return (`Docker_image "busybox") in 71 | let* r = Docker.cp_between_volumes ~base ~src ~dst in 72 | Log.debug (fun f -> f "Finished snapshotting"); 73 | match r with Ok () -> Lwt.return_unit | Error (`Msg msg) -> failwith msg 74 | 75 | let delete volume = 76 | let* _ = Docker.Cmd.volume (`Remove [volume]) in 77 | Lwt.return_unit 78 | end 79 | 80 | let root t = t.root 81 | 82 | let df t = Lwt.return (Os.free_space_percent t.root) 83 | let cache_stats _ = 0, 0 84 | 85 | let purge () = 86 | let* containers = Docker.Cmd.obuilder_containers () in 87 | let* () = if containers <> [] then Docker.Cmd.rm containers else Lwt.return_unit in 88 | Log.info (fun f -> f "Removing left-over Docker images"); 89 | let* images = Docker.Cmd.obuilder_images ~tmp:true () in 90 | let* () = if images <> [] then Docker.Cmd.rmi images else Lwt.return_unit in 91 | Log.info (fun f -> f "Removing left-over Docker volumes"); 92 | let* volumes = Docker.Cmd.obuilder_caches_tmp () in 93 | let* _ = if volumes <> [] then Docker.Cmd.volume (`Remove volumes) else Lwt.return "" in 94 | Lwt.return_unit 95 | 96 | let create root = 97 | Os.ensure_dir root; 98 | let hash = Unix.realpath root |> Sha256.string |> Sha256.to_hex in 99 | let hash = String.sub hash 0 7 in 100 | Docker.set_prefix (strf "obuilder-%s" hash); 101 | let t = { root; caches = Hashtbl.create 10; next = 0 } in 102 | Os.ensure_dir ~mode:0o0 (root / "empty"); 103 | Os.ensure_dir (root / "state"); 104 | Os.ensure_dir (root / "logs"); 105 | let* () = purge () in 106 | Lwt.return t 107 | 108 | let build t ?base ~id (fn:(string -> (unit, 'e) Lwt_result.t)) : (unit, 'e) Lwt_result.t = 109 | match base with 110 | | None -> 111 | Lwt.catch 112 | (fun () -> fn (Path.empty t)) 113 | (fun ex -> 114 | Log.warn (fun f -> f "Uncaught exception from %S build function: %a" id Fmt.exn ex); 115 | Lwt.reraise ex) 116 | | Some base -> 117 | let base = Docker.docker_image base in 118 | let tmp_image = (Docker.docker_image ~tmp:true id) in 119 | let* () = Docker.Cmd.tag base tmp_image in 120 | Lwt.try_bind 121 | (fun () -> fn (Path.empty t)) 122 | (fun r -> 123 | (* As the cache is cleaned before this, the sandbox must take 124 | care of committing the container and removing it, otherwise 125 | the container still has a reference to the cache. *) 126 | let+ () = Docker.Cmd.image (`Remove tmp_image) in 127 | r) 128 | (fun ex -> 129 | Log.warn (fun f -> f "Uncaught exception from %S build function: %a" id Fmt.exn ex); 130 | let* () = Docker.Cmd.image (`Remove tmp_image) in 131 | Lwt.reraise ex) 132 | 133 | let delete t id = 134 | let image = Docker.docker_image id in 135 | let* exists = Docker.Cmd.exists image in 136 | let* () = match exists with 137 | | Ok () -> Docker.Cmd.image (`Remove image) 138 | | Error _ -> Lwt.return_unit 139 | in 140 | let log_file = Path.log_file t id in 141 | if Sys.file_exists log_file then 142 | Lwt_unix.unlink log_file 143 | else Lwt.return_unit 144 | 145 | let result t id = 146 | let img = Docker.docker_image id in 147 | let* r = Docker.Cmd.exists img in 148 | match r with 149 | | Ok () -> Lwt.return_some (Path.empty t) 150 | | Error _ -> 151 | Lwt.return_none 152 | 153 | let log_file t id = Lwt.return (Path.log_file t id) 154 | 155 | let state_dir = Path.state 156 | 157 | let get_cache t name = 158 | match Hashtbl.find_opt t.caches name with 159 | | Some c -> c 160 | | None -> 161 | let c = { lock = Lwt_mutex.create (); gen = 0 } in 162 | Hashtbl.add t.caches name c; 163 | c 164 | 165 | let cache ~user t name : (string * (unit -> unit Lwt.t)) Lwt.t = 166 | let cache = get_cache t name in 167 | Lwt_mutex.with_lock cache.lock @@ fun () -> 168 | let tmp = Cache.cache_tmp t.next name in 169 | t.next <- t.next + 1; 170 | let snapshot = Cache.cache name in 171 | (* Create cache if it doesn't already exist. *) 172 | let* () = 173 | let* exists = Cache.exists snapshot in 174 | if not exists then Cache.create snapshot 175 | else Lwt.return_unit 176 | in 177 | (* Create writeable clone. *) 178 | let gen = cache.gen in 179 | let* () = Cache.snapshot ~src:snapshot tmp in 180 | let+ () = match user with 181 | | `Unix { Obuilder_spec.uid; gid } -> 182 | let* tmp = Docker.Cmd.mount_point tmp in 183 | Os.sudo ["chown"; strf "%d:%d" uid gid; tmp] 184 | | `Windows _ -> Lwt.return_unit (* FIXME: does Windows need special treatment? *) 185 | in 186 | let release () = 187 | Lwt_mutex.with_lock cache.lock @@ fun () -> 188 | let* () = 189 | if cache.gen = gen then ( 190 | (* The cache hasn't changed since we cloned it. Update it. *) 191 | (* todo: check if it has actually changed. *) 192 | cache.gen <- cache.gen + 1; 193 | let* () = Cache.delete snapshot in 194 | Cache.snapshot ~src:tmp snapshot 195 | ) else Lwt.return_unit 196 | in 197 | Cache.delete tmp 198 | in 199 | Cache.name tmp, release 200 | 201 | let delete_cache t name = 202 | let cache = get_cache t name in 203 | Lwt_mutex.with_lock cache.lock @@ fun () -> 204 | cache.gen <- cache.gen + 1; (* Ensures in-progress writes will be discarded *) 205 | let snapshot = Cache.cache name in 206 | let* exists = Cache.exists snapshot in 207 | if exists then 208 | let* containers = Docker.Cmd.volume_containers snapshot in 209 | if containers <> [] then 210 | let* () = Cache.delete snapshot in 211 | Lwt_result.ok Lwt.return_unit 212 | else 213 | Lwt_result.fail `Busy 214 | else Lwt_result.ok Lwt.return_unit 215 | 216 | let complete_deletes t = 217 | ignore t; 218 | (* FIXME: how to implement this? *) 219 | Lwt.return_unit 220 | -------------------------------------------------------------------------------- /lib/qemu_sandbox.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | open Sexplib.Conv 3 | 4 | include S.Sandbox_default 5 | 6 | let ( / ) = Filename.concat 7 | 8 | let copy_to_log ~src ~dst = 9 | let buf = Bytes.create 4096 in 10 | let rec aux () = 11 | Lwt_unix.read src buf 0 (Bytes.length buf) >>= function 12 | | 0 -> Lwt.return_unit 13 | | n -> Build_log.write dst (Bytes.sub_string buf 0 n) >>= aux 14 | in 15 | aux () 16 | 17 | type guest_os = 18 | | Linux 19 | | OpenBSD 20 | | Windows 21 | [@@deriving sexp] 22 | 23 | type guest_arch = 24 | | Amd64 25 | | Riscv64 26 | [@@deriving sexp] 27 | 28 | type t = { 29 | qemu_cpus : int; 30 | qemu_memory : int; 31 | qemu_guest_os : guest_os; 32 | qemu_guest_arch : guest_arch; 33 | qemu_boot_time : int; 34 | } 35 | 36 | type config = { 37 | cpus : int; 38 | memory : int; 39 | guest_os : guest_os; 40 | guest_arch : guest_arch; 41 | boot_time : int; 42 | } [@@deriving sexp] 43 | 44 | let get_free_port () = 45 | let fd = Unix.socket PF_INET SOCK_STREAM 0 in 46 | let () = Unix.bind fd (ADDR_INET(Unix.inet_addr_loopback, 0)) in 47 | let sa = Unix.getsockname fd in 48 | let () = Unix.close fd in 49 | match sa with 50 | | ADDR_INET (_, n) -> string_of_int n 51 | | ADDR_UNIX _ -> assert false;; 52 | 53 | let run ~cancelled ?stdin ~log t config result_tmp = 54 | let pp f = Os.pp_cmd f ("", config.Config.argv) in 55 | 56 | let extra_mounts = List.map (fun { Config.Mount.src; _ } -> 57 | ["-drive"; "file=" ^ src / "rootfs" / "image.qcow2" ^ ",if=virtio"] 58 | ) config.Config.mounts |> List.flatten in 59 | 60 | Os.with_pipe_to_child @@ fun ~r:qemu_r ~w:qemu_w -> 61 | let qemu_stdin = `FD_move_safely qemu_r in 62 | let qemu_monitor = Lwt_io.(of_fd ~mode:output) qemu_w in 63 | let port = get_free_port () in 64 | let qemu_binary = match t.qemu_guest_arch with 65 | | Amd64 -> [ "qemu-system-x86_64"; "-machine"; "accel=kvm,type=pc"; "-cpu"; "host"; "-display"; "none"; 66 | "-device"; "virtio-net,netdev=net0" ] 67 | | Riscv64 -> [ "qemu-system-riscv64"; "-machine"; "type=virt"; "-nographic"; 68 | "-bios"; "/usr/lib/riscv64-linux-gnu/opensbi/generic/fw_jump.bin"; 69 | "-kernel"; "/usr/lib/u-boot/qemu-riscv64_smode/uboot.elf"; 70 | "-device"; "virtio-net-device,netdev=net0"; 71 | "-serial"; "none"] in 72 | let network = match config.network with 73 | | [ "host" ] -> "" 74 | | _ -> "restrict=yes," in 75 | let cmd = qemu_binary @ [ 76 | "-monitor"; "stdio"; 77 | "-m"; (string_of_int t.qemu_memory) ^ "G"; 78 | "-smp"; string_of_int t.qemu_cpus; 79 | "-netdev"; "user,id=net0," ^ network ^ "hostfwd=tcp::" ^ port ^ "-:22"; 80 | "-drive"; "file=" ^ result_tmp / "rootfs" / "image.qcow2" ^ ",if=virtio" ] 81 | @ extra_mounts in 82 | let _, proc = Os.open_process ~stdin:qemu_stdin ~stdout:`Dev_null ~pp cmd in 83 | 84 | let ssh = ["ssh"; "opam@localhost"; "-p"; port; "-o"; "NoHostAuthenticationForLocalhost=yes"] in 85 | 86 | let rec loop = function 87 | | 0 -> Lwt_result.fail (`Msg "No connection") 88 | | n -> 89 | Os.exec_result ~pp (ssh @ ["exit"]) >>= function 90 | | Ok _ -> Lwt.return_ok () 91 | | _ -> Lwt_unix.sleep 1. >>= fun _ -> loop (n - 1) in 92 | Lwt_unix.sleep 5. >>= fun _ -> 93 | loop t.qemu_boot_time >>= fun _ -> 94 | 95 | Lwt_list.iteri_s (fun i { Config.Mount.dst; _ } -> 96 | match t.qemu_guest_os with 97 | | Linux -> 98 | let dev = Printf.sprintf "/dev/vd%c1" (Char.chr (Char.code 'b' + i)) in 99 | Os.exec (ssh @ ["sudo"; "mount"; dev; dst]) 100 | | OpenBSD -> 101 | let dev = Printf.sprintf "/dev/sd%ca" (Char.chr (Char.code '1' + i)) in 102 | Os.exec (ssh @ ["doas"; "fsck"; "-y"; dev]) >>= fun () -> 103 | Os.exec (ssh @ ["doas"; "mount"; dev; dst]) 104 | | Windows -> 105 | Os.exec (ssh @ ["cmd"; "/c"; "if exist '" ^ dst ^ "' rmdir /s /q '" ^ dst ^ "'"]) >>= fun () -> 106 | let drive_letter = String.init 1 (fun _ -> Char.chr (Char.code 'd' + i)) in 107 | Os.exec (ssh @ ["cmd"; "/c"; "mklink /j '" ^ dst ^ "' '" ^ drive_letter ^ ":\\'"]) 108 | ) config.Config.mounts >>= fun () -> 109 | 110 | Os.with_pipe_from_child @@ fun ~r:out_r ~w:out_w -> 111 | let stdin = Option.map (fun x -> `FD_move_safely x) stdin in 112 | let stdout = `FD_move_safely out_w in 113 | let stderr = stdout in 114 | let copy_log = copy_to_log ~src:out_r ~dst:log in 115 | let env = List.map (fun (k, v) -> k ^ "=" ^ v) config.Config.env |> Array.of_list in 116 | let sendenv = if Array.length env > 0 then List.map (fun (k, _) -> ["-o"; "SendEnv=" ^ k]) config.Config.env |> List.flatten else [] in 117 | let _, proc2 = Os.open_process ~env ?stdin ~stdout ~stderr ~pp (ssh @ sendenv @ ["cd"; config.Config.cwd; "&&"] @ config.Config.argv) in 118 | Lwt.on_termination cancelled (fun () -> 119 | let aux () = 120 | if Lwt.is_sleeping proc then 121 | Lwt_io.write qemu_monitor "quit\n" 122 | else Lwt.return_unit (* Process has already finished *) 123 | in 124 | Lwt.async aux 125 | ); 126 | Os.process_result ~pp proc2 >>= fun res -> 127 | copy_log >>= fun () -> 128 | 129 | Lwt_list.iter_s (fun { Config.Mount.dst; _ } -> 130 | match t.qemu_guest_os with 131 | | Linux 132 | | OpenBSD -> Lwt.return_unit 133 | | Windows -> 134 | (* if the junction isn't removed and the target drive is missing, then `mkdir -p /foo` fails *) 135 | (* also note that `fsutil reparsepoint delete ` only works if the target exists *) 136 | Os.exec (ssh @ ["cmd"; "/c"; "rmdir '" ^ dst ^ "'"]) 137 | ) config.Config.mounts >>= fun () -> 138 | 139 | (match t.qemu_guest_arch with 140 | | Amd64 -> 141 | Log.info (fun f -> f "Sending QEMU an ACPI shutdown event"); 142 | Lwt_io.write qemu_monitor "system_powerdown\n" 143 | | Riscv64 -> 144 | (* QEMU RISCV does not support ACPI until >= v9 *) 145 | Log.info (fun f -> f "Shutting down the VM"); 146 | Os.exec (ssh @ ["sudo"; "poweroff"])) >>= fun () -> 147 | let rec loop = function 148 | | 0 -> 149 | Log.warn (fun f -> f "Powering off QEMU"); 150 | Lwt_io.write qemu_monitor "quit\n" 151 | | n -> 152 | if Lwt.is_sleeping proc then 153 | Lwt_unix.sleep 1. >>= fun () -> 154 | loop (n - 1) 155 | else Lwt.return () in 156 | loop t.qemu_boot_time >>= fun _ -> 157 | 158 | Os.process_result ~pp proc >>= fun _ -> 159 | 160 | if Lwt.is_sleeping cancelled then Lwt.return (res :> (unit, [`Msg of string | `Cancelled]) result) 161 | else Lwt_result.fail `Cancelled 162 | 163 | let create (c : config) = 164 | let t = { qemu_cpus = c.cpus; qemu_memory = c.memory; qemu_guest_os = c.guest_os; qemu_guest_arch = c.guest_arch; qemu_boot_time = c.boot_time } in 165 | Lwt.return t 166 | 167 | let shell _ = [] 168 | 169 | let tar t = 170 | match t.qemu_guest_os with 171 | | Linux -> tar t 172 | | OpenBSD -> ["gtar"; "-xf"; "-"] 173 | | Windows -> ["/cygdrive/c/Windows/System32/tar.exe"; "-xf"; "-"; "-C"; "/"] 174 | 175 | open Cmdliner 176 | 177 | let docs = "QEMU BACKEND" 178 | 179 | let cpus = 180 | Arg.value @@ 181 | Arg.opt Arg.int 2 @@ 182 | Arg.info ~docs 183 | ~doc:"Number of CPUs to be used by each QEMU machine." 184 | ~docv:"CPUS" 185 | ["qemu-cpus"] 186 | 187 | let memory = 188 | Arg.value @@ 189 | Arg.opt Arg.int 2 @@ 190 | Arg.info ~docs 191 | ~doc:"The amount of memory allocated to the VM in gigabytes." 192 | ~docv:"MEMORY" 193 | ["qemu-memory"] 194 | 195 | let guest_os = 196 | let options = 197 | [("linux", Linux); 198 | ("openbsd", OpenBSD); 199 | ("windows", Windows)] in 200 | Arg.value @@ 201 | Arg.opt Arg.(enum options) Linux @@ 202 | Arg.info ~docs 203 | ~doc:(Printf.sprintf "Set OS used by QEMU guest. $(docv) must be %s." (Arg.doc_alts_enum options)) 204 | ~docv:"GUEST_OS" 205 | ["qemu-guest-os"] 206 | 207 | let guest_arch = 208 | let options = 209 | [("amd64", Amd64); 210 | ("riscv64", Riscv64)] in 211 | Arg.value @@ 212 | Arg.opt Arg.(enum options) Amd64 @@ 213 | Arg.info ~docs 214 | ~doc:(Printf.sprintf "Set system architecture used by QEMU guest. $(docv) must be %s." (Arg.doc_alts_enum options)) 215 | ~docv:"GUEST_OS" 216 | ["qemu-guest-arch"] 217 | 218 | let boot_time = 219 | Arg.value @@ 220 | Arg.opt Arg.int 30 @@ 221 | Arg.info ~docs 222 | ~doc:"The maximum time in seconds to wait for the machine to boot/power off." 223 | ~docv:"BOOT_TIME" 224 | ["qemu-boot-time"] 225 | 226 | let cmdliner : config Term.t = 227 | let make cpus memory guest_os guest_arch boot_time = 228 | { cpus; memory; guest_os; guest_arch; boot_time } 229 | in 230 | Term.(const make $ cpus $ memory $ guest_os $ guest_arch $ boot_time) 231 | -------------------------------------------------------------------------------- /stress/stress.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | open Obuilder 3 | 4 | let ( / ) = Filename.concat 5 | let strf = Printf.sprintf 6 | 7 | let read path = 8 | Lwt_io.(with_file ~mode:input) path Lwt_io.read 9 | 10 | let write ~path data = 11 | Lwt_io.(with_file ~mode:output) path (fun ch -> Lwt_io.write ch data) 12 | 13 | let assert_str expected got = 14 | if expected <> got then ( 15 | Fmt.epr "Expected: %S@.Got : %S@." expected got; 16 | exit 1 17 | ) 18 | 19 | module Test(Store : S.STORE) = struct 20 | let assert_output expected t id = 21 | Store.result t id >>= function 22 | | None -> Fmt.failwith "%S not in store!" id 23 | | Some path -> 24 | let ch = open_in (path / "output") in 25 | let data = really_input_string ch (in_channel_length ch) in 26 | close_in ch; 27 | assert_str expected data; 28 | Lwt.return_unit 29 | 30 | let test_store t = 31 | Store.result t "unknown" >>= fun r -> assert (r = None); 32 | (* Build without a base *) 33 | Store.delete t "base" >>= fun () -> 34 | Store.build t ~id:"base" (fun tmpdir -> write ~path:(tmpdir / "output") "ok" >|= Result.ok) >>= fun r -> 35 | assert (r = Ok ()); 36 | assert_output "ok" t "base" >>= fun () -> 37 | (* Build with a base *) 38 | Store.delete t "sub" >>= fun () -> 39 | Store.build t ~base:"base" ~id:"sub" (fun tmpdir -> 40 | read (tmpdir / "output") >>= fun orig -> 41 | write ~path:(tmpdir / "output") (orig ^ "+") >|= Result.ok 42 | ) >>= fun r -> 43 | assert (r = Ok ()); 44 | assert_output "ok+" t "sub" >>= fun () -> 45 | (* Test deletion *) 46 | Store.result t "sub" >>= fun r -> assert (r <> None); 47 | Store.delete t "sub" >>= fun () -> 48 | Store.result t "sub" >>= fun r -> assert (r = None); 49 | (* A failing build isn't saved *) 50 | Store.delete t "fail" >>= fun () -> 51 | Store.build t ~id:"fail" (fun _tmpdir -> Lwt_result.fail `Failed) >>= fun r -> 52 | assert (r = Error `Failed); 53 | Store.result t "fail" >>= fun r -> assert (r = None); 54 | Lwt.return_unit 55 | 56 | let test_cache t = 57 | let uid = Unix.getuid () in 58 | let gid = Unix.getgid () in 59 | let user = `Unix { Spec.uid = 123; gid = 456 } in 60 | let id = "c1" in 61 | (* Create a new cache *) 62 | Store.delete_cache t id >>= fun x -> 63 | assert (x = Ok ()); 64 | Store.cache ~user t id >>= fun (c, r) -> 65 | assert ((Unix.lstat c).Unix.st_uid = 123); 66 | assert ((Unix.lstat c).Unix.st_gid = 456); 67 | let user = `Unix { Spec.uid; gid } in 68 | Os.exec ["sudo"; "chown"; Printf.sprintf "%d:%d" uid gid; "--"; c] >>= fun () -> 69 | assert (Sys.readdir c = [| |]); 70 | write ~path:(c / "data") "v1" >>= fun () -> 71 | r () >>= fun () -> 72 | (* Check it worked *) 73 | Store.cache ~user t id >>= fun (c, r) -> 74 | read (c / "data") >>= fun data -> 75 | assert_str "v1" data; 76 | r () >>= fun () -> 77 | (* Concurrent updates *) 78 | Store.cache ~user t id >>= fun (c1, r1) -> 79 | Store.cache ~user t id >>= fun (c2, r2) -> 80 | write ~path:(c1 / "data") "v2a" >>= fun () -> 81 | write ~path:(c2 / "data") "v2b" >>= fun () -> 82 | r2 () >>= fun () -> (* v2b wins *) 83 | r1 () >>= fun () -> 84 | (* Check it worked *) 85 | Store.cache ~user t id >>= fun (c, r) -> 86 | read (c / "data") >>= fun data -> 87 | assert_str "v2b" data; 88 | r () >>= fun () -> 89 | (* Concurrent delete *) 90 | Store.cache ~user t id >>= fun (c, r) -> 91 | write ~path:(c / "data") "v3" >>= fun () -> 92 | Store.delete_cache t id >>= function 93 | | Ok () -> (* Btrfs allows deletion here *) 94 | r () >>= fun () -> (* (not saved) *) 95 | Store.cache ~user t id >>= fun (c, r) -> 96 | assert (not (Sys.file_exists (c / "data"))); 97 | r () >>= fun () -> 98 | Lwt.return_unit 99 | | Error `Busy -> (* Zfs does not *) 100 | r () >>= fun () -> 101 | (* Now it can be deleted. *) 102 | Store.delete_cache t id >>= fun x -> 103 | assert (x = Ok ()); 104 | Lwt.return_unit 105 | 106 | type builder = Builder : (module Obuilder.BUILDER with type t = 'a) * 'a -> builder 107 | 108 | let create_builder store conf = 109 | let module Builder = Obuilder.Builder(Store)(Native_sandbox)(Obuilder.Docker_extract) in 110 | Native_sandbox.create ~state_dir:(Store.state_dir store / "sandbox") conf >|= fun sandbox -> 111 | let builder = Builder.v ~store ~sandbox in 112 | Builder ((module Builder), builder) 113 | 114 | let n_steps = 4 115 | let n_values = 3 116 | let n_jobs = 100 117 | let max_running = 10 118 | 119 | let stress_cache = "stress" 120 | 121 | (* A build of [n_steps] where each step appends a random number in 0..!n_values to `output` *) 122 | let random_build () = 123 | let rec aux = function 124 | | 0 -> [] 125 | | i -> Random.int n_values :: aux (i - 1) 126 | in 127 | let items = aux n_steps in 128 | let cache = [ Spec.Cache.v stress_cache ~target:"/mnt" ] in 129 | let ops = items |> List.map (fun i -> Spec.run ~cache "echo -n %d >> output; echo 'added:%d'" i i) in 130 | let expected = items |> List.map string_of_int |> String.concat "" in 131 | let ops = ops @ [Spec.run {|[ `cat output` = %S ] || exit 1|} expected] in 132 | let check_log data = 133 | data |> String.split_on_char '\n' |> List.filter_map (fun line -> 134 | match Astring.String.cut ~sep:":" line with 135 | | Some ("added", x) -> Some x 136 | | _ -> None 137 | ) 138 | |> String.concat "" 139 | |> fun got -> 140 | assert_str expected got 141 | in 142 | check_log, Spec.stage ~from:"busybox" ops 143 | 144 | let do_build (Builder ((module Builder), builder)) = 145 | let src_dir = "/root" in 146 | let buf = Buffer.create 100 in 147 | let log t x = 148 | (* print_endline x; *) 149 | match t with 150 | | `Heading -> Buffer.add_string buf (strf "# %s\n" x) 151 | | `Note -> Buffer.add_string buf (strf ": %s\n" x) 152 | | `Output -> Buffer.add_string buf x 153 | in 154 | let ctx = Context.v ~shell:["/bin/sh"; "-c"] ~log ~src_dir () in 155 | let check_log, spec = random_build () in 156 | Builder.build builder ctx spec >>= function 157 | | Ok _ -> 158 | check_log (Buffer.contents buf); 159 | Lwt.return_unit 160 | | Error (`Msg m) -> failwith m 161 | | Error `Cancelled -> assert false 162 | 163 | let stress_builds store conf = 164 | create_builder store conf >>= fun builder -> 165 | let (Builder ((module Builder), _)) = builder in 166 | let pending = ref n_jobs in 167 | let running = ref 0 in 168 | let cond = Lwt_condition.create () in 169 | let failures = ref 0 in 170 | let rec aux () = 171 | if !running = 0 && !pending = 0 then Lwt.return_unit 172 | else if !running < max_running && !pending > 0 then ( 173 | if !pending mod 10 = 0 then Fmt.pr "%d pending: starting new build@." !pending; 174 | incr running; 175 | decr pending; 176 | let th = do_build builder in 177 | Lwt.on_any th 178 | (fun () -> 179 | decr running; 180 | Lwt_condition.broadcast cond () 181 | ) 182 | (fun ex -> 183 | Logs.warn (fun f -> f "Build failed: %a" Fmt.exn ex); 184 | decr running; 185 | incr failures; 186 | Lwt_condition.broadcast cond () 187 | ); 188 | aux () 189 | ) else ( 190 | Lwt_condition.wait cond >>= aux 191 | ) 192 | in 193 | let t0 = Unix.gettimeofday () in 194 | aux () >>= fun () -> 195 | let time = Unix.gettimeofday () -. t0 in 196 | Fmt.pr "Ran %d jobs (max %d at once). %d failures. Took %.1f s (%.1f jobs/s)@." 197 | n_jobs max_running !failures 198 | time (float n_jobs /. time); 199 | if !failures > 0 then Fmt.failwith "%d failures!" !failures 200 | else Lwt.return_unit 201 | 202 | let prune store conf = 203 | create_builder store conf >>= fun (Builder ((module Builder), builder)) -> 204 | let log id = Logs.info (fun f -> f "Deleting %S" id) in 205 | let end_time = Unix.(gettimeofday () +. 60.0 |> gmtime) in 206 | let rec aux () = 207 | Fmt.pr "Pruning…@."; 208 | Builder.prune ~log builder ~before:end_time 1000 >>= function 209 | | 0 -> Lwt.return_unit 210 | | _ -> aux () 211 | in 212 | aux () 213 | end 214 | 215 | let stress (sandbox, spec) conf = 216 | if sandbox = `Docker then begin 217 | prerr_endline "Cannot stress-test the Docker backend"; 218 | exit 1 219 | end; 220 | Lwt_main.run begin 221 | spec >>= fun (Store_spec.Store ((module Store), store)) -> 222 | let module T = Test(Store) in 223 | T.test_store store >>= fun () -> 224 | T.test_cache store >>= fun () -> 225 | T.stress_builds store conf >>= fun () -> 226 | T.prune store conf 227 | end 228 | 229 | open Cmdliner 230 | 231 | let cmd = 232 | let doc = "Run stress tests." in 233 | let info = Cmd.info ~doc "stress" in 234 | Cmd.v info 235 | Term.(const stress $ Store_spec.cmdliner $ Native_sandbox.cmdliner) 236 | 237 | let () = 238 | (* Logs.(set_level (Some Info)); *) 239 | Fmt_tty.setup_std_outputs (); 240 | Logs.set_reporter @@ Logs.format_reporter (); 241 | exit @@ Cmd.eval cmd 242 | --------------------------------------------------------------------------------