From 47e706a376e7d51d6184ee906354ce34e77f28af Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Antonin=20D=C3=A9cimo?= Date: Fri, 17 Feb 2023 16:18:29 +0100 Subject: [PATCH 1/9] Add buildkit_syntax convenience function --- src/dockerfile.ml | 1 + src/dockerfile.mli | 7 ++++++- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/src/dockerfile.ml b/src/dockerfile.ml index a0ad70c9..075ad36f 100644 --- a/src/dockerfile.ml +++ b/src/dockerfile.ml @@ -235,6 +235,7 @@ 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 diff --git a/src/dockerfile.mli b/src/dockerfile.mli index d4a25a8d..807dfee4 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 *) From 37d607861e3e9957a4c4617aa4884efd0ea032b1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Antonin=20D=C3=A9cimo?= Date: Thu, 2 Feb 2023 15:01:38 +0100 Subject: [PATCH 2/9] Allow mounts in RUN commands --- src/dockerfile.ml | 142 +++++++++++++++++++++++++++++++++++++++++---- src/dockerfile.mli | 84 ++++++++++++++++++++++----- 2 files changed, 203 insertions(+), 23 deletions(-) diff --git a/src/dockerfile.ml b/src/dockerfile.ml index 075ad36f..e5a38013 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; @@ -67,7 +111,7 @@ type line = | `Comment of string | `From of from | `Maintainer of string - | `Run of shell_or_exec + | `Run of mount list * shell_or_exec | `Cmd of shell_or_exec | `Expose of int list | `Arg of string * string option @@ -98,15 +142,18 @@ 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, `Shell a) :: `Run (m', `Shell b) :: tl -> + aux (`Run (merge m m', `Shells [ a; b ]) :: acc) tl + | `Run (m, `Shells a) :: `Run (m', `Shell b) :: tl -> + aux (`Run (merge m m', `Shells (a @ [ b ])) :: acc) tl + | `Run (m, `Shells a) :: `Run (m', `Shells b) :: tl -> + aux (`Run (merge m m', `Shells (a @ b)) :: acc) tl | hd :: tl -> aux (hd :: acc) tl in List.rev (aux [] l) @@ -162,6 +209,14 @@ 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 -> [] @@ -188,6 +243,52 @@ 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 c = + let mounts = List.map string_of_mount mounts in + let run = string_of_shell_or_exec ~escape c in + String.concat " " (mounts @ [ run ]) + let rec string_of_line ~escape (t : line) = match t with | `ParserDirective (`Escape c) -> cmd "#" ("escape=" ^ String.make 1 c) @@ -205,7 +306,7 @@ 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, c) -> cmd "RUN" (string_of_run ~escape mounts 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) @@ -240,11 +341,32 @@ 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 = []) fmt = ksprintf (fun b -> [ `Run (mounts, `Shell b) ]) fmt +let run_exec ?(mounts = []) cmds : t = [ `Run (mounts, `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 807dfee4..2c5cd55f 100644 --- a/src/dockerfile.mli +++ b/src/dockerfile.mli @@ -120,18 +120,74 @@ 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. *) - -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]. *) +type mount + +val run : ?mounts:mount list -> ('a, unit, string, t) format4 -> 'a +(** [run ?mounts 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 + BuildKit {{!val:parser_directive}syntax} 1.2. *) + +val run_exec : ?mounts:mount list -> string list -> t +(** [run_exec ?mounts 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 mounts A list of filesystem mounts that the build can access. Requires + BuildKit {{!val:parser_directive}syntax} 1.2. *) + +val mount_bind : + target:string -> + ?source:string -> + ?from:string -> + ?readwrite:bool -> + unit -> + mount +(** Creates a bind mount for {!run}. Requires BuildKit syntax. *) + +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 +(** Creates a cache mount for {!run}. Requires BuildKit syntax. *) + +val mount_tmpfs : target:string -> ?size:int -> unit -> mount +(** Creates a tmpfs mount for {!run}. Requires BuildKit syntax. *) + +val mount_secret : + ?id:string -> + ?target:string -> + ?required:bool -> + ?mode:int -> + ?uid:int -> + ?gid:int -> + unit -> + mount +(** Creates a secret mount for {!run}. Requires BuildKit syntax. *) + +val mount_ssh : + ?id:string -> + ?target:string -> + ?required:bool -> + ?mode:int -> + ?uid:int -> + ?gid:int -> + unit -> + mount +(** Creates an ssh mount for {!run}. Requires BuildKit syntax. *) val cmd : ('a, unit, string, t) format4 -> 'a (** [cmd args] provides defaults for an executing container. These defaults @@ -377,4 +433,6 @@ 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 differ for each run command. *) From ede80f9023fbd5ae4fdd709ee8431b7b04c3775f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Antonin=20D=C3=A9cimo?= Date: Thu, 2 Feb 2023 15:17:38 +0100 Subject: [PATCH 3/9] Allow networks in RUN commands --- src/dockerfile.ml | 44 ++++++++++++++++++++++++++++++++------------ src/dockerfile.mli | 20 ++++++++++++++------ 2 files changed, 46 insertions(+), 18 deletions(-) diff --git a/src/dockerfile.ml b/src/dockerfile.ml index e5a38013..c5df2371 100644 --- a/src/dockerfile.ml +++ b/src/dockerfile.ml @@ -106,12 +106,14 @@ type healthcheck_options = { type healthcheck = [ `Cmd of healthcheck_options * shell_or_exec | `None ] [@@deriving sexp] +type network = [ `Default | `None | `Host ] [@@deriving sexp] + type line = [ `ParserDirective of parser_directive | `Comment of string | `From of from | `Maintainer of string - | `Run of mount list * shell_or_exec + | `Run of mount list * network option * shell_or_exec | `Cmd of shell_or_exec | `Expose of int list | `Arg of string * string option @@ -148,12 +150,15 @@ let crunch l = let pack l = let rec aux acc = function | [] -> acc - | `Run (m, `Shell a) :: `Run (m', `Shell b) :: tl -> - aux (`Run (merge m m', `Shells [ a; b ]) :: acc) tl - | `Run (m, `Shells a) :: `Run (m', `Shell b) :: tl -> - aux (`Run (merge m m', `Shells (a @ [ b ])) :: acc) tl - | `Run (m, `Shells a) :: `Run (m', `Shells b) :: tl -> - aux (`Run (merge m m', `Shells (a @ b)) :: acc) tl + | `Run (m, n, `Shell a) :: `Run (m', n', `Shell b) :: tl -> + if n <> n' then invalid_arg "crunch: at least two networks differ."; + aux (`Run (merge m m', n, `Shells [ a; b ]) :: acc) tl + | `Run (m, n, `Shells a) :: `Run (m', n', `Shell b) :: tl -> + if n <> n' then invalid_arg "crunch: at least two networks differ."; + aux (`Run (merge m m', n, `Shells (a @ [ b ])) :: acc) tl + | `Run (m, n, `Shells a) :: `Run (m', n', `Shells b) :: tl -> + if n <> n' then invalid_arg "crunch: at least two networks differ."; + aux (`Run (merge m m', n, `Shells (a @ b)) :: acc) tl | hd :: tl -> aux (hd :: acc) tl in List.rev (aux [] l) @@ -221,6 +226,10 @@ 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 " " @@ -284,10 +293,15 @@ let string_of_mount { typ } = @ optional_int_octal "mode" mode @ optional_int "uid" uid @ optional_int "gid" gid) -let string_of_run ~escape mounts c = +let string_of_run ~escape mounts network c = let mounts = List.map string_of_mount mounts in + let network = + optional_enum "network" + (function `Default -> "default" | `None -> "none" | `Host -> "host") + network + in let run = string_of_shell_or_exec ~escape c in - String.concat " " (mounts @ [ run ]) + String.concat " " (mounts @ network @ [ run ]) let rec string_of_line ~escape (t : line) = match t with @@ -306,7 +320,8 @@ let rec string_of_line ~escape (t : line) = (match alias with None -> "" | Some a -> " as " ^ a); ]) | `Maintainer m -> cmd "MAINTAINER" m - | `Run (mounts, c) -> cmd "RUN" (string_of_run ~escape mounts c) + | `Run (mounts, network, c) -> + cmd "RUN" (string_of_run ~escape mounts network 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) @@ -365,8 +380,13 @@ let mount_ssh ?id ?target ?required ?mode ?uid ?gid () = 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 ?(mounts = []) fmt = ksprintf (fun b -> [ `Run (mounts, `Shell b) ]) fmt -let run_exec ?(mounts = []) cmds : t = [ `Run (mounts, `Exec cmds) ] + +let run ?(mounts = []) ?network fmt = + ksprintf (fun b -> [ `Run (mounts, network, `Shell b) ]) fmt + +let run_exec ?(mounts = []) ?network cmds : t = + [ `Run (mounts, network, `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 2c5cd55f..3a354748 100644 --- a/src/dockerfile.mli +++ b/src/dockerfile.mli @@ -121,25 +121,33 @@ val maintainer : ('a, unit, string, t) format4 -> 'a (** [maintainer] sets the author field of the generated images. *) type mount +type network = [ `Default | `None | `Host ] -val run : ?mounts:mount list -> ('a, unit, string, t) format4 -> 'a +val run : + ?mounts:mount list -> ?network:network -> ('a, unit, string, t) format4 -> 'a (** [run ?mounts 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 - BuildKit {{!val:parser_directive}syntax} 1.2. *) + BuildKit {{!val:parser_directive}syntax} 1.2. -val run_exec : ?mounts:mount list -> string list -> t -(** [run_exec ?mounts args] will execute any commands in a new layer on top of + @param network Control which networking environment the command is run in. + Requires BuildKit {{!val:parser_directive}syntax} 1.1. *) + +val run_exec : ?mounts:mount list -> ?network:network -> string list -> t +(** [run_exec ?mounts ?network 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 mounts A list of filesystem mounts that the build can access. Requires - BuildKit {{!val:parser_directive}syntax} 1.2. *) + BuildKit {{!val:parser_directive}syntax} 1.2. + + @param network Control which networking environment the command is run in. + Requires BuildKit {{!val:parser_directive}syntax} 1.1. *) val mount_bind : target:string -> @@ -435,4 +443,4 @@ val crunch : t -> t one that is chained using the shell [&&] operator. This reduces the number of layers required for a production image. - @raise Invalid_argument if mounts differ for each run command. *) + @raise Invalid_argument if mounts or networks differ for each run command. *) From f5a3413d997654cdba343adddb8fb07d898c6c0f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Antonin=20D=C3=A9cimo?= Date: Thu, 2 Feb 2023 15:25:49 +0100 Subject: [PATCH 4/9] Allow security in RUN commands --- src/dockerfile.ml | 39 +++++++++++++++++++++-------------- src/dockerfile.mli | 51 ++++++++++++++++++++++++++++++---------------- 2 files changed, 58 insertions(+), 32 deletions(-) diff --git a/src/dockerfile.ml b/src/dockerfile.ml index c5df2371..265c0da2 100644 --- a/src/dockerfile.ml +++ b/src/dockerfile.ml @@ -107,13 +107,14 @@ 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] type line = [ `ParserDirective of parser_directive | `Comment of string | `From of from | `Maintainer of string - | `Run of mount list * network option * 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 @@ -150,15 +151,18 @@ let crunch l = let pack l = let rec aux acc = function | [] -> acc - | `Run (m, n, `Shell a) :: `Run (m', n', `Shell b) :: 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."; - aux (`Run (merge m m', n, `Shells [ a; b ]) :: acc) tl - | `Run (m, n, `Shells a) :: `Run (m', n', `Shell b) :: tl -> + 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."; - aux (`Run (merge m m', n, `Shells (a @ [ b ])) :: acc) tl - | `Run (m, n, `Shells a) :: `Run (m', n', `Shells b) :: tl -> + 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."; - aux (`Run (merge m m', n, `Shells (a @ b)) :: acc) tl + 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) @@ -293,15 +297,20 @@ let string_of_mount { typ } = @ optional_int_octal "mode" mode @ optional_int "uid" uid @ optional_int "gid" gid) -let string_of_run ~escape mounts network c = +let string_of_run ~escape mounts network security c = let mounts = List.map string_of_mount mounts 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 @ [ run ]) + String.concat " " (mounts @ network @ security @ [ run ]) let rec string_of_line ~escape (t : line) = match t with @@ -320,8 +329,8 @@ let rec string_of_line ~escape (t : line) = (match alias with None -> "" | Some a -> " as " ^ a); ]) | `Maintainer m -> cmd "MAINTAINER" m - | `Run (mounts, network, c) -> - cmd "RUN" (string_of_run ~escape mounts network 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) @@ -381,11 +390,11 @@ 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 ?(mounts = []) ?network fmt = - ksprintf (fun b -> [ `Run (mounts, network, `Shell b) ]) fmt +let run ?(mounts = []) ?network ?security fmt = + ksprintf (fun b -> [ `Run (mounts, network, security, `Shell b) ]) fmt -let run_exec ?(mounts = []) ?network cmds : t = - [ `Run (mounts, network, `Exec cmds) ] +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) ] diff --git a/src/dockerfile.mli b/src/dockerfile.mli index 3a354748..84a14108 100644 --- a/src/dockerfile.mli +++ b/src/dockerfile.mli @@ -122,32 +122,48 @@ val maintainer : ('a, unit, string, t) format4 -> 'a type mount type network = [ `Default | `None | `Host ] +type security = [ `Insecure | `Sandbox ] val run : - ?mounts:mount list -> ?network:network -> ('a, unit, string, t) format4 -> 'a -(** [run ?mounts 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. + ?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 BuildKit {{!val:parser_directive}syntax} 1.2. @param network Control which networking environment the command is run in. - Requires BuildKit {{!val:parser_directive}syntax} 1.1. *) + Requires BuildKit {{!val:parser_directive}syntax} 1.1. -val run_exec : ?mounts:mount list -> ?network:network -> string list -> t -(** [run_exec ?mounts ?network 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 security Control which security mode the command is run in. + Requires BuildKit {{!val:parser_directive}syntax} 1-labs. *) - @param mounts A list of filesystem mounts that the build can access. Requires - BuildKit {{!val:parser_directive}syntax} 1.2. +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 network Control which networking environment the command is run in. - Requires BuildKit {{!val:parser_directive}syntax} 1.1. *) + @param mounts A list of filesystem mounts that the build can access. Requires + BuildKit syntax 1.2. + + @param network Control which networking environment the command is run in. + 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 mount_bind : target:string -> @@ -443,4 +459,5 @@ val crunch : t -> t one that is chained using the shell [&&] operator. This reduces the number of layers required for a production image. - @raise Invalid_argument if mounts or networks differ for each run command. *) + @raise Invalid_argument if mounts or networks or security modes differ for + each run command. *) From b8c45efdab65e957693d4c1d84ac864a72fe82b6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Fri, 17 Feb 2023 11:01:24 +0000 Subject: [PATCH 5/9] Dockerfile: refer to {!buildkit_syntax} MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- src/dockerfile.mli | 30 ++++++++++++++++-------------- 1 file changed, 16 insertions(+), 14 deletions(-) diff --git a/src/dockerfile.mli b/src/dockerfile.mli index 84a14108..8630cca7 100644 --- a/src/dockerfile.mli +++ b/src/dockerfile.mli @@ -81,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]. @@ -136,9 +136,10 @@ val run : 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 - BuildKit {{!val:parser_directive}syntax} 1.2. + {!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. @@ -157,10 +158,10 @@ val run_exec : using a base image that does not contain [/bin/sh]. @param mounts A list of filesystem mounts that the build can access. Requires - BuildKit syntax 1.2. + {!val:buildkit_syntax} 1.2. @param network Control which networking environment the command is run in. - Requires BuildKit {{!val:parser_directive}syntax} 1.1. + 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. *) @@ -172,7 +173,7 @@ val mount_bind : ?readwrite:bool -> unit -> mount -(** Creates a bind mount for {!run}. Requires BuildKit syntax. *) +(** Creates a bind mount for {!run}. Requires {!val:buildkit_syntax}. *) val mount_cache : ?id:string -> @@ -186,10 +187,10 @@ val mount_cache : ?gid:int -> unit -> mount -(** Creates a cache mount for {!run}. Requires BuildKit syntax. *) +(** Creates a cache mount for {!run}. Requires {!val:buildkit_syntax}. *) val mount_tmpfs : target:string -> ?size:int -> unit -> mount -(** Creates a tmpfs mount for {!run}. Requires BuildKit syntax. *) +(** Creates a tmpfs mount for {!run}. Requires {!val:buildkit_syntax}. *) val mount_secret : ?id:string -> @@ -200,7 +201,7 @@ val mount_secret : ?gid:int -> unit -> mount -(** Creates a secret mount for {!run}. Requires BuildKit syntax. *) +(** Creates a secret mount for {!run}. Requires {!val:buildkit_syntax}. *) val mount_ssh : ?id:string -> @@ -211,7 +212,7 @@ val mount_ssh : ?gid:int -> unit -> mount -(** Creates an ssh mount for {!run}. Requires BuildKit syntax. *) +(** Creates an ssh mount for {!run}. Requires {!val:buildkit_syntax}. *) val cmd : ('a, unit, string, t) format4 -> 'a (** [cmd args] provides defaults for an executing container. These defaults @@ -281,8 +282,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 @@ -308,8 +309,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. @@ -321,7 +322,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 *) From 1ca26ce2a222cfc92e4e93ee24e26eadf61162a1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Fri, 17 Feb 2023 11:04:42 +0000 Subject: [PATCH 6/9] Dockerfile.mli: more documentation on mounts MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The official docs are quite scarce on how these work, add a few more details here to make it easier to use. Most of these work with both Docker and Podman 4.x, some options are only supported by Docker, and some options are parsed but do not work on older versions of Podman. Signed-off-by: Edwin Török --- src/dockerfile.mli | 64 ++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 59 insertions(+), 5 deletions(-) diff --git a/src/dockerfile.mli b/src/dockerfile.mli index 8630cca7..d061cd8a 100644 --- a/src/dockerfile.mli +++ b/src/dockerfile.mli @@ -173,7 +173,17 @@ val mount_bind : ?readwrite:bool -> unit -> mount -(** Creates a bind mount for {!run}. Requires {!val:buildkit_syntax}. *) +(** [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 -> @@ -187,10 +197,42 @@ val mount_cache : ?gid:int -> unit -> mount -(** Creates a cache mount for {!run}. Requires {!val:buildkit_syntax}. *) +(** [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 -(** Creates a tmpfs mount for {!run}. Requires {!val:buildkit_syntax}. *) +(** [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 -> @@ -201,7 +243,12 @@ val mount_secret : ?gid:int -> unit -> mount -(** Creates a secret mount for {!run}. Requires {!val:buildkit_syntax}. *) +(** [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 -> @@ -212,7 +259,14 @@ val mount_ssh : ?gid:int -> unit -> mount -(** Creates an ssh mount for {!run}. Requires {!val:buildkit_syntax}. *) +(** [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 From 847e416a962d2a9abf8e4d9e0ada71b453afd7ef Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Fri, 17 Feb 2023 14:13:52 +0000 Subject: [PATCH 7/9] Dockerfile: escape spaces in mount args MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Space is the separator between mount args, and if some mount arg contains a space (e.g. a cache id, or directory) then we must escape it. Signed-off-by: Edwin Török --- src/dockerfile.ml | 31 ++++++++++++++++++------------- 1 file changed, 18 insertions(+), 13 deletions(-) diff --git a/src/dockerfile.ml b/src/dockerfile.ml index 265c0da2..87756d15 100644 --- a/src/dockerfile.ml +++ b/src/dockerfile.ml @@ -109,6 +109,19 @@ type healthcheck = [ `Cmd of healthcheck_options * shell_or_exec | `None ] 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 v.[i] = char_to_escape || 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 @@ -187,18 +200,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) @@ -298,7 +300,10 @@ let string_of_mount { typ } = @ optional_int "uid" uid @ optional_int "gid" gid) let string_of_run ~escape mounts network security c = - let mounts = List.map string_of_mount mounts in + 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") From d54c8d4baee1a50ce3fa3ae16b1a354b5466c3aa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Antonin=20D=C3=A9cimo?= Date: Mon, 20 Feb 2023 10:58:22 +0100 Subject: [PATCH 8/9] Dockerfile: use unchecked char access when escaping strings --- src/dockerfile.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/dockerfile.ml b/src/dockerfile.ml index 87756d15..5fa8fe9b 100644 --- a/src/dockerfile.ml +++ b/src/dockerfile.ml @@ -114,7 +114,8 @@ let escape_string ~char_to_escape ~escape v = let buf = Buffer.create len in let j = ref 0 in for i = 0 to len - 1 do - if v.[i] = char_to_escape || v.[i] = escape then ( + 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) From 98bfa3b3121acf7f6d90939c110a15444b9f3d3d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Antonin=20D=C3=A9cimo?= Date: Thu, 2 Feb 2023 15:26:31 +0100 Subject: [PATCH 9/9] Update changes --- CHANGES.md | 3 +++ 1 file changed, 3 insertions(+) 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)