diff --git a/CHANGES.md b/CHANGES.md index ac3d81ab..2bdcc5bc 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,9 @@ unreleased ---------- +- Support mounts, networks, and security parameters in RUN + commands, add buildkit_syntax helper function. + (@MisterDA, @edwintorok, #137, #139, review by @edwintorok) - Build and install opam master from source in Windows images. (@MisterDA #140, #142, #143) - Include the ocaml-beta-repository in the images. (@kit-ty-kate #132, review by @MisterDA) diff --git a/src/dockerfile.ml b/src/dockerfile.ml index a0ad70c9..5fa8fe9b 100644 --- a/src/dockerfile.ml +++ b/src/dockerfile.ml @@ -51,6 +51,50 @@ type heredoc = { type heredocs_to_dest = [ `Chown of string option ] * heredoc list * string [@@deriving sexp] +type mount_bind = { + target : string; + source : string option; + from : string option; + readwrite : bool option; +} +[@@deriving sexp] + +type mount_cache = { + id : string option; + target : string; + readonly : bool option; + sharing : [ `Shared | `Private | `Locked ] option; + from : string option; + source : string option; + mode : int option; + uid : int option; + gid : int option; +} +[@@deriving sexp] + +type mount_tmpfs = { target : string; size : int option } [@@deriving sexp] + +(* secret or ssh *) +type mount_file = { + id : string option; + target : string option; + required : bool option; + mode : int option; + uid : int option; + gid : int option; +} +[@@deriving sexp] + +type mount = { + typ : + [ `Bind of mount_bind + | `Cache of mount_cache + | `Tmpfs of mount_tmpfs + | `Secret of mount_file + | `Ssh of mount_file ]; +} +[@@deriving sexp] + type healthcheck_options = { interval : string option; timeout : string option; @@ -62,12 +106,29 @@ type healthcheck_options = { type healthcheck = [ `Cmd of healthcheck_options * shell_or_exec | `None ] [@@deriving sexp] +type network = [ `Default | `None | `Host ] [@@deriving sexp] +type security = [ `Insecure | `Sandbox ] [@@deriving sexp] + +let escape_string ~char_to_escape ~escape v = + let len = String.length v in + let buf = Buffer.create len in + let j = ref 0 in + for i = 0 to len - 1 do + if String.unsafe_get v i = char_to_escape || String.unsafe_get v i = escape + then ( + if i - !j > 0 then Buffer.add_substring buf v !j (i - !j); + Buffer.add_char buf escape; + j := i) + done; + Buffer.add_substring buf v !j (len - !j); + Buffer.contents buf + type line = [ `ParserDirective of parser_directive | `Comment of string | `From of from | `Maintainer of string - | `Run of shell_or_exec + | `Run of mount list * network option * security option * shell_or_exec | `Cmd of shell_or_exec | `Expose of int list | `Arg of string * string option @@ -98,15 +159,24 @@ open Printf (* Multiple RUN lines will be compressed into a single one in order to reduce the number of layers used *) let crunch l = + let merge m m' = + if m = m' then m else invalid_arg "crunch: at least two mounts list differ." + in let pack l = let rec aux acc = function | [] -> acc - | `Run (`Shell a) :: `Run (`Shell b) :: tl -> - aux (`Run (`Shells [ a; b ]) :: acc) tl - | `Run (`Shells a) :: `Run (`Shell b) :: tl -> - aux (`Run (`Shells (a @ [ b ])) :: acc) tl - | `Run (`Shells a) :: `Run (`Shells b) :: tl -> - aux (`Run (`Shells (a @ b)) :: acc) tl + | `Run (m, n, s, `Shell a) :: `Run (m', n', s', `Shell b) :: tl -> + if n <> n' then invalid_arg "crunch: at least two networks differ."; + if s <> s' then invalid_arg "crunch: at least two securities differ."; + aux (`Run (merge m m', n, s, `Shells [ a; b ]) :: acc) tl + | `Run (m, n, s, `Shells a) :: `Run (m', n', s', `Shell b) :: tl -> + if n <> n' then invalid_arg "crunch: at least two networks differ."; + if s <> s' then invalid_arg "crunch: at least two securities differ."; + aux (`Run (merge m m', n, s, `Shells (a @ [ b ])) :: acc) tl + | `Run (m, n, s, `Shells a) :: `Run (m', n', s', `Shells b) :: tl -> + if n <> n' then invalid_arg "crunch: at least two networks differ."; + if s <> s' then invalid_arg "crunch: at least two securities differ."; + aux (`Run (merge m m', n, s, `Shells (a @ b)) :: acc) tl | hd :: tl -> aux (hd :: acc) tl in List.rev (aux [] l) @@ -131,18 +201,7 @@ let string_of_shell_or_exec ~escape (t : shell_or_exec) = | `Shells l -> String.concat (" && " ^ String.make 1 escape ^ "\n ") l | `Exec sl -> json_array_of_list sl -let quote_env_var ~escape v = - let len = String.length v in - let buf = Buffer.create len in - let j = ref 0 in - for i = 0 to len - 1 do - if v.[i] = '"' || v.[i] = escape then ( - if i - !j > 0 then Buffer.add_substring buf v !j (i - !j); - Buffer.add_char buf escape; - j := i) - done; - Buffer.add_substring buf v !j (len - !j); - Buffer.contents buf +let quote_env_var = escape_string ~char_to_escape:'"' let string_of_env_var ~escape (name, value) = sprintf {|%s="%s"|} name (quote_env_var ~escape value) @@ -162,10 +221,22 @@ let optional_int name = function | None -> [] | Some value -> [ sprintf "%s=%d" name value ] +let optional_int_octal name = function + | None -> [] + | Some value -> [ sprintf "%s=%04o" name value ] + +let optional_bool name = function + | None -> [] + | Some value -> [ sprintf "%s=%b" name value ] + let optional_flag name = function | Some true -> [ name ] | Some false | None -> [] +let optional_enum name string_of_val = function + | None -> [] + | Some value -> [ sprintf "--%s=%s" name (string_of_val value) ] + let string_of_sources_to_dest (t : sources_to_dest) = let `From frm, `Src sl, `Dst d, `Chown chown, `Link link = t in String.concat " " @@ -188,6 +259,65 @@ let string_of_copy_heredoc (t : heredocs_to_dest) = String.concat " " (optional "--chown" chown @ List.rev header @ [ dst ]) ^ docs +let string_of_mount { typ } = + match typ with + | `Bind { target; source; from; readwrite } -> + String.concat "," + ([ "--mount=type=bind" ] + @ [ sprintf "target=%s" target ] + @ optional "source" source @ optional "from" from + @ optional_bool "readwrite" readwrite) + | `Cache { id; target; readonly; sharing; from; source; mode; uid; gid } -> + String.concat "," + ([ "--mount=type=cache" ] @ optional "id" id + @ [ sprintf "target=%s" target ] + @ optional_bool "readonly" readonly + @ (match sharing with + | None -> [] + | Some `Shared -> [ "sharing=shared" ] + | Some `Private -> [ "sharing=private" ] + | Some `Locked -> [ "sharing=locked" ]) + @ optional "from" from @ optional "source" source + @ optional_int_octal "mode" mode + @ optional_int "uid" uid @ optional_int "gid" gid) + | `Tmpfs { target; size } -> + String.concat "," + ([ "--mount=type=bind" ] + @ [ sprintf "target=%s" target ] + @ optional_int "size" size) + | `Ssh m | `Secret m -> + let typ = + match typ with + | `Ssh _ -> "ssh" + | `Secret _ -> "secret" + | _ -> assert false + in + let { id; target; required; mode; uid; gid } = m in + String.concat "," + ([ sprintf "--mount=type=%s" typ ] + @ optional "id" id @ optional "target" target + @ optional_bool "required" required + @ optional_int_octal "mode" mode + @ optional_int "uid" uid @ optional_int "gid" gid) + +let string_of_run ~escape mounts network security c = + let mounts = + mounts |> List.map string_of_mount + |> List.map (escape_string ~char_to_escape:' ' ~escape) + in + let network = + optional_enum "network" + (function `Default -> "default" | `None -> "none" | `Host -> "host") + network + in + let security = + optional_enum "security" + (function `Insecure -> "insecure" | `Sandbox -> "sandbox") + security + in + let run = string_of_shell_or_exec ~escape c in + String.concat " " (mounts @ network @ security @ [ run ]) + let rec string_of_line ~escape (t : line) = match t with | `ParserDirective (`Escape c) -> cmd "#" ("escape=" ^ String.make 1 c) @@ -205,7 +335,8 @@ let rec string_of_line ~escape (t : line) = (match alias with None -> "" | Some a -> " as " ^ a); ]) | `Maintainer m -> cmd "MAINTAINER" m - | `Run c -> cmd "RUN" (string_of_shell_or_exec ~escape c) + | `Run (mounts, network, security, c) -> + cmd "RUN" (string_of_run ~escape mounts network security c) | `Cmd c -> cmd "CMD" (string_of_shell_or_exec ~escape c) | `Expose pl -> cmd "EXPOSE" (String.concat " " (List.map string_of_int pl)) | `Arg a -> cmd "ARG" (string_of_arg ~escape a) @@ -235,15 +366,42 @@ and string_of_healthcheck ~escape options c = (* Function interface *) let parser_directive pd : t = [ `ParserDirective pd ] +let buildkit_syntax = parser_directive (`Syntax "docker/dockerfile:1") let heredoc ?(strip = false) ?(word = "EOF") ?(delimiter = word) fmt = ksprintf (fun here_document -> { here_document; strip; word; delimiter }) fmt +let mount_bind ~target ?source ?from ?readwrite () = + let m = { target; source; from; readwrite } in + { typ = `Bind m } + +let mount_cache ?id ~target ?readonly ?sharing ?from ?source ?mode ?uid ?gid () + = + let m = { id; target; readonly; sharing; from; source; mode; uid; gid } in + { typ = `Cache m } + +let mount_tmpfs ~target ?size () = + let m = { target; size } in + { typ = `Tmpfs m } + +let mount_secret ?id ?target ?required ?mode ?uid ?gid () = + let m = { id; target; required; mode; uid; gid } in + { typ = `Secret m } + +let mount_ssh ?id ?target ?required ?mode ?uid ?gid () = + let m = { id; target; required; mode; uid; gid } in + { typ = `Ssh m } + let from ?alias ?tag ?platform image = [ `From { image; tag; alias; platform } ] let comment fmt = ksprintf (fun c -> [ `Comment c ]) fmt let maintainer fmt = ksprintf (fun m -> [ `Maintainer m ]) fmt -let run fmt = ksprintf (fun b -> [ `Run (`Shell b) ]) fmt -let run_exec cmds : t = [ `Run (`Exec cmds) ] + +let run ?(mounts = []) ?network ?security fmt = + ksprintf (fun b -> [ `Run (mounts, network, security, `Shell b) ]) fmt + +let run_exec ?(mounts = []) ?network ?security cmds : t = + [ `Run (mounts, network, security, `Exec cmds) ] + let cmd fmt = ksprintf (fun b -> [ `Cmd (`Shell b) ]) fmt let cmd_exec cmds : t = [ `Cmd (`Exec cmds) ] let expose_port p : t = [ `Expose [ p ] ] diff --git a/src/dockerfile.mli b/src/dockerfile.mli index d4a25a8d..d061cd8a 100644 --- a/src/dockerfile.mli +++ b/src/dockerfile.mli @@ -58,7 +58,12 @@ type parser_directive = [ `Syntax of string | `Escape of char ] val parser_directive : parser_directive -> t (** A parser directive. If used, needs to be the first line of the Dockerfile. - @see *) + @see + @see *) + +val buildkit_syntax : t +(** Convenience function, returns the {{!val-parser_directive}parser directive} + describing the latest BuildKit syntax. *) val comment : ('a, unit, string, t) format4 -> 'a (** Adds a comment to the Dockerfile for documentation purposes *) @@ -76,7 +81,7 @@ val heredoc : [here_document] as content and [word] () as opening delimiter. If [word] is quoted, then [delimiter] (unquoted [word]) needs to be specified. Quoting affects expansion in the here-document. - Requires BuildKit 1.4 {{!val:parser_directive}syntax}. + Requires 1.4 {!val:buildkit_syntax}. @param strip Whether to strip leading tab characters. Defaults to false. @param word The opening delimiter, possibly quoted. Defaults to [EOF]. @@ -115,18 +120,153 @@ val from : ?alias:string -> ?tag:string -> ?platform:string -> string -> t val maintainer : ('a, unit, string, t) format4 -> 'a (** [maintainer] sets the author field of the generated images. *) -val run : ('a, unit, string, t) format4 -> 'a -(** [run fmt] will execute any commands in a new layer on top of the current - image and commit the results. The resulting committed image will be used - for the next step in the Dockerfile. The string result of formatting - [arg] will be passed as a [/bin/sh -c] invocation. *) +type mount +type network = [ `Default | `None | `Host ] +type security = [ `Insecure | `Sandbox ] + +val run : + ?mounts:mount list -> + ?network:network -> + ?security:security -> + ('a, unit, string, t) format4 -> + 'a +(** [run ?mounts ?network ?security fmt] will execute any commands in a new + layer on top of the current image and commit the results. The resulting + committed image will be used for the next step in the Dockerfile. The string + result of formatting [arg] will be passed as a [/bin/sh -c] invocation. + + @param mounts A list of filesystem mounts that the build can access. Requires + {!val:buildkit_syntax} 1.2. + + @param network Control which networking environment the command is run in. + Requires {!val:buildkit_syntax} 1.1. + Requires BuildKit {{!val:parser_directive}syntax} 1.1. + + @param security Control which security mode the command is run in. + Requires BuildKit {{!val:parser_directive}syntax} 1-labs. *) + +val run_exec : + ?mounts:mount list -> + ?network:network -> + ?security:security -> + string list -> + t +(** [run_exec ?mounts ?network ?security args] will execute any commands in a + new layer on top of current image and commit the results. The resulting + committed image will be used for the next step in the Dockerfile. The [cmd] + form makes it possible to avoid shell string munging, and to run commands + using a base image that does not contain [/bin/sh]. + + @param mounts A list of filesystem mounts that the build can access. Requires + {!val:buildkit_syntax} 1.2. -val run_exec : string list -> t -(** [run_exec args] will execute any commands in a new layer on top of the current - image and commit the results. The resulting committed image will be used - for the next step in the Dockerfile. The [args] form makes it possible - to avoid shell string munging, and to run commands using a base image that - does not contain [/bin/sh]. *) + @param network Control which networking environment the command is run in. + Requires {!val:buildkit_syntax} 1.1. + + @param security Control which security mode the command is run in. Requires + BuildKit {{!val:parser_directive}syntax} 1-labs. *) + +val mount_bind : + target:string -> + ?source:string -> + ?from:string -> + ?readwrite:bool -> + unit -> + mount +(** [mount_bind ~target ?source ?from ?readwrite ()] Creates a bind mount for {!run}. + + Requires {!buildkit_syntax}. + + @param target the target of the mount inside the container. Usually a path, but for 'podman' it can also contain SELinux flags like ',z' or ',Z' + @param from a build stage to bind mount from (if absent: bind mount host) + @param source path to mount. When [from] is absent this is relative to the build context on the host. When [source] is absent it defaults to root of [from]. + @param readwrite enables writing to the mount (default: read-only). The data written is not persisted, [source] always remains unchanged. + + @see Docker --mount=type=bind reference +*) + +val mount_cache : + ?id:string -> + target:string -> + ?readonly:bool -> + ?sharing:[ `Locked | `Private | `Shared ] -> + ?from:string -> + ?source:string -> + ?mode:int -> + ?uid:int -> + ?gid:int -> + unit -> + mount +(** [mount_cache ?id ~target ?readonly ?sharing ?from ?source ?mode ?uid ?gid ()] Creates a cache mount for {!run}. + + Requires {!buildkit_syntax}. + + @param id the cache id: all container builds with same cache id (even from other unrelated builds) will get the same writable directory mounted. + Defaults to [target] when absent. + @param target where to mount the cache inside the container. The [RUN] + command needs to cope with a completely empty cache, and with files from the + cache being deleted by the container runtime's GC in arbitrary order. + E.g. a download cache would be suitable here, an entire git repository wouldn't. + Also make sure that your RUN commands doesn't inadvertently wipe the cache + (e.g. apt inside a container by default would). + @param readonly whether the cache is read-only (by default it is writable) + @param sharing how to share the cache between concurrent builds. The default is [`Shared] which doesn't use any locking. + @param from the stage to use for the initial contents of the cache. + @param source the initial contents of the cache, default is empty. + @param mode file mode for cache directory + @param uid UID of cache directory, default 0. + @param gid GID of cache directory, default 0. + + @see Docker --mount=type=cache reference +*) + +val mount_tmpfs : target:string -> ?size:int -> unit -> mount +(** [mount_tmpfs ~target ?size ())] Creates a tmpfs mount for {!run}. + + Requires {!buildkit_syntax}. + + @param target mounts a [tmpfs] at [target] + @param size maximum size of [tmpfs] (only supported by Docker) + + Note that the directory seems to be completely removed from the image, so once you start using [tmpfs] for a dir, + it is recommended that all further [RUN] commands use it too to avoid ENOENT errors. + + @see Docker --mount=type=tmpfs reference +*) + +val mount_secret : + ?id:string -> + ?target:string -> + ?required:bool -> + ?mode:int -> + ?uid:int -> + ?gid:int -> + unit -> + mount +(** [mount_secret ?id ?target ?required ?mode ?uid ?gid] Creates a secret mount for {!run}. + + Requires {!buildkit_syntax}. + + @see Docker --mount=type=secret reference +*) + +val mount_ssh : + ?id:string -> + ?target:string -> + ?required:bool -> + ?mode:int -> + ?uid:int -> + ?gid:int -> + unit -> + mount +(** [mount_ssh ?id ?target ?required ?mode ?uid ?gid] Creates an ssh mount for {!run}. + + Requires {!buildkit_syntax}. + + Seems to be only supported by Docker at the moment. + + @see Docker --mount=type=ssh reference +*) val cmd : ('a, unit, string, t) format4 -> 'a (** [cmd args] provides defaults for an executing container. These defaults @@ -196,8 +336,8 @@ val add : @param link Add files with enhanced semantics where your files remain independent on their own layer and don’t get invalidated - when commands on previous layers are changed. Requires BuildKit - 1.4 {{!val:parser_directive}syntax}. + when commands on previous layers are changed. + Requires 1.4 {!val:buildkit_syntax}. @param chown Specify a given username, groupname, or UID/GID combination to request specific ownership of the copied @@ -223,8 +363,8 @@ val copy : @param link Copy files with enhanced semantics where your files remain independent on their own layer and don’t get invalidated - when commands on previous layers are changed. Requires BuildKit - 1.4 {{!val:parser_directive}syntax}. + when commands on previous layers are changed. + Requires 1.4 {!val:buildkit_syntax}. @param chown Specify a given username, groupname, or UID/GID combination to request specific ownership of the copied content. @@ -236,7 +376,8 @@ val copy : val copy_heredoc : ?chown:string -> src:heredoc list -> dst:string -> unit -> t (** [copy_heredoc src dst] creates the file [dst] using the content of - the here-documents [src]. Requires BuildKit 1.4 {{!val:parser_directive}syntax}. + the here-documents [src]. + Requires 1.4 {!val:buildkit_syntax}. @see *) @@ -372,4 +513,7 @@ val stopsignal : string -> t val crunch : t -> t (** [crunch t] will reduce coincident {!run} commands into a single one that is chained using the shell [&&] operator. This reduces the - number of layers required for a production image. *) + number of layers required for a production image. + + @raise Invalid_argument if mounts or networks or security modes differ for + each run command. *)