(*docker * Copyright (c) 2014-2016 Anil Madhavapeddy * * Permission to use, copy, modify, and distribute this software for any * purpose with or without fee is hereby granted, provided that the above * copyright notice and this permission notice appear in all copies. * * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. * *) type shell_or_exec = [ `Shell of string | `Shells of string list | `Exec of string list ] type sources_to_dest = [ `From of string option ] * [ `Src of string list ] * [ `Dst of string ] * [ `Chown of string option ] * [ `Chmod of int option ] * [ `Link of bool option ] * [ `Checksum of string option ] * [ `Keep_git_dir of bool option ] * [ `Parents of bool option ] * [ `Exclude of string list option ] * [ `Unpack of bool option ] type from = { image : string; tag : string option; alias : string option; platform : string option; } type parser_directive = [ `Syntax of string | `Escape of char | `Check of string list * bool ] type heredoc = { here_document : string; word : string; delimiter : string; strip : bool; } type heredocs_to_dest = [ `Chown of string option ] * [ `Chmod of int option ] * heredoc list * string type mount_bind = { target : string; source : string option; from : string option; readwrite : bool option; } 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; } type mount_tmpfs = { target : string; size : int option } (* secret or ssh *) type mount_file = { id : string option; target : string option; required : bool option; mode : int option; uid : int option; gid : int option; } type mount = { typ : [ `Bind of mount_bind | `Cache of mount_cache | `Tmpfs of mount_tmpfs | `Secret of mount_file | `Ssh of mount_file ]; } type variable = string type device = { name : string; required : bool option } type port_number = Port_number of int | Port_range of int * int type port = | Port of { number : port_number; protocol : [ `Udp | `Tcp ] option } | Port_variable of variable type healthcheck_options = { interval : string option; timeout : string option; start_period : string option; start_interval : string option; retries : int option; } type healthcheck = [ `Cmd of healthcheck_options * shell_or_exec | `None ] type network = [ `Default | `None | `Host ] type security = [ `Insecure | `Sandbox ] 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 mount list * network option * security option * device option * shell_or_exec | `Run_heredoc of mount list * network option * security option * device option * (heredoc * string option) list | `Cmd of shell_or_exec | `Expose of port list | `Arg of string * string option | `Env of (string * string) list | `Add of sources_to_dest | `Copy of sources_to_dest | `Copy_heredoc of heredocs_to_dest | `Entrypoint of shell_or_exec | `Shell of string list | `Volume of string list | `User of string | `Workdir of string | `Onbuild of line | `Label of (string * string) list | `Healthcheck of healthcheck | `Stopsignal of string ] type t = line list let ( @@ ) = ( @ ) let ( @@@ ) = List.fold_left (fun a b -> a @@ b) let empty = [] let maybe f = function None -> empty | Some v -> f v (* 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 (* Combine two adjacent RUN instructions whose mounts/network/security/device match into a single shell-list RUN. The differ checks reject merges that would silently drop a modifier. *) let merge_run (m, n, s, d) (m', n', s', d') shells = if n <> n' then invalid_arg "crunch: at least two networks differ."; if s <> s' then invalid_arg "crunch: at least two securities differ."; if d <> d' then invalid_arg "crunch: devices differ"; `Run (merge m m', n, s, d, `Shells shells) in let pack l = let rec aux acc = function | [] -> acc | `Run (m, n, s, d, `Shell a) :: `Run (m', n', s', d', `Shell b) :: tl -> aux (merge_run (m, n, s, d) (m', n', s', d') [ a; b ] :: acc) tl | `Run (m, n, s, d, `Shells a) :: `Run (m', n', s', d', `Shell b) :: tl -> aux (merge_run (m, n, s, d) (m', n', s', d') (a @ [ b ]) :: acc) tl | `Run (m, n, s, d, `Shells a) :: `Run (m', n', s', d', `Shells b) :: tl -> aux (merge_run (m, n, s, d) (m', n', s', d') (a @ b) :: acc) tl | hd :: tl -> aux (hd :: acc) tl in List.rev (aux [] l) in let rec fixp fn l = let a = fn l in if a = l then l else fixp fn a in fixp pack l let quote s = Fmt.str "%S" s let cmd c r = c ^ " " ^ r let json_array_of_list sl = Fmt.str "[ %s ]" (String.concat ", " (List.map quote sl)) let string_of_shell_or_exec ~escape (t : shell_or_exec) = match t with | `Shell s -> s | `Shells [] -> "" | `Shells [ s ] -> s | `Shells l -> String.concat (" && " ^ String.make 1 escape ^ "\n ") l | `Exec sl -> json_array_of_list sl let quote_env_var = escape_string ~char_to_escape:'"' let string_of_env_var ~escape (name, value) = Fmt.str {|%s="%s"|} name (quote_env_var ~escape value) let string_of_env_list ~escape el = List.map (string_of_env_var ~escape) el |> String.concat " " let string_of_arg ~escape = function | name, Some value -> string_of_env_var ~escape (name, value) | name, None -> name let optional name = function | None -> [] | Some value -> [ Fmt.str "%s=%s" name value ] let optional_int name = function | None -> [] | Some value -> [ Fmt.str "%s=%d" name value ] let optional_int_octal name = function | None -> [] | Some value -> [ Fmt.str "%s=%04o" name value ] let optional_bool name = function | None -> [] | Some value -> [ Fmt.str "%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 -> [ Fmt.str "--%s=%s" name (string_of_val value) ] let optional_list name string_of_val = function | None | Some [] -> [] | Some list -> List.map (fun e -> Fmt.str "--%s=%s" name (string_of_val e)) list let string_of_sources_dest (t : sources_to_dest) = let ( `From frm, `Src sl, `Dst d, `Chown chown, `Chmod chmod, `Link link, `Checksum checksum, `Keep_git_dir keep_git_dir, `Parents parents, `Exclude exclude, `Unpack unpack ) = t in String.concat " " (optional_flag "--link" link @ optional "--chown" chown @ optional_int_octal "--chmod" chmod @ optional "--from" frm @ optional "--checksum" checksum @ optional_bool "--keep-git-dir" keep_git_dir @ optional_bool "--parents" parents @ optional_list "--exclude" Fun.id exclude @ optional_bool "--unpack" unpack @ [ json_array_of_list (sl @ [ d ]) ]) let string_of_label_list ls = List.map (fun (k, v) -> Fmt.str "%s=%S" k v) ls |> String.concat " " let string_of_copy_heredoc (t : heredocs_to_dest) = let `Chown chown, `Chmod chmod, heredocs, dst = t in let header, docs = List.fold_left (fun (header, docs) t -> ( Fmt.str "<<%s%s" (if t.strip then "-" else "") t.word :: header, Fmt.str "%s\n%s\n%s" docs t.here_document t.delimiter )) ([], "") heredocs in String.concat " " (optional "--chown" chown @ optional_int_octal "--chmod" chmod @ List.rev header @ [ dst ]) ^ docs let string_of_mount { typ } = match typ with | `Bind { target; source; from; readwrite } -> String.concat "," ([ "--mount=type=bind" ] @ [ Fmt.str "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 @ [ Fmt.str "target=%s" target ] @ optional_flag "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" ] @ [ Fmt.str "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 "," ([ Fmt.str "--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 device = 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 device = match device with | None -> [] | Some { name; required } -> [ String.concat "," ([ Fmt.str "--device=%s" name ] @ optional_flag "required" required); ] in mounts @ network @ security @ device let string_of_run ~escape mounts network security device c = let params = string_of_run' ~escape mounts network security device in let run = string_of_shell_or_exec ~escape c in String.concat " " (params @ [ run ]) let string_of_run_heredoc ~escape mounts network security device c = let params = string_of_run' ~escape mounts network security device in let escape_cmd = function | Some cmd -> " " ^ escape_string ~char_to_escape:'\n' ~escape cmd | None -> "" in let cmds, docs = List.fold_left (fun (cmds, docs) (t, cmd) -> let cmd = escape_cmd cmd in ( cmds @ [ Fmt.str "<<%s%s%s" (if t.strip then "-" else "") t.word cmd ], Fmt.str "%s\n%s\n%s" docs t.here_document t.delimiter )) ([], "") c in String.concat " " (params @ [ String.concat " && " cmds ]) ^ docs let string_of_port p = match p with | Port_variable s -> s | Port { number; protocol } -> ( let number = match number with | Port_number n -> string_of_int n | Port_range (from, to_) -> string_of_int from ^ "-" ^ string_of_int to_ in match protocol with | None -> number | Some `Tcp -> number ^ "/tcp" | Some `Udp -> number ^ "/udp") let rec string_of_line ~escape (t : line) = match t with | `ParserDirective (`Escape c) -> cmd "#" ("escape=" ^ String.make 1 c) | `ParserDirective (`Syntax str) -> cmd "#" ("syntax=" ^ str) | `ParserDirective (`Check (skip, error)) -> ( let skip = match skip with | [] -> [] | skip -> [ "skip=" ^ String.concat "," skip ] and error = if error then [ "error=true" ] else [] in match String.concat ";" (skip @ error) with | "" -> "" | check -> cmd "#" ("check=" ^ check)) | `Comment c -> cmd "#" c | `From { image; tag; alias; platform } -> cmd "FROM" (String.concat "" [ (match platform with | None -> "" | Some p -> "--platform=" ^ p ^ " "); image; (match tag with None -> "" | Some t -> ":" ^ t); (match alias with None -> "" | Some a -> " AS " ^ a); ]) | `Maintainer m -> cmd "MAINTAINER" m | `Run (mounts, network, security, device, c) -> cmd "RUN" (string_of_run ~escape mounts network security device c) | `Run_heredoc (mounts, network, security, device, c) -> cmd "RUN" (string_of_run_heredoc ~escape mounts network security device c) | `Cmd c -> cmd "CMD" (string_of_shell_or_exec ~escape c) | `Expose pl -> cmd "EXPOSE" (String.concat " " (List.map string_of_port pl)) | `Arg a -> cmd "ARG" (string_of_arg ~escape a) | `Env el -> cmd "ENV" (string_of_env_list ~escape el) | `Add c -> cmd "ADD" (string_of_sources_dest c) | `Copy c -> cmd "COPY" (string_of_sources_dest c) | `Copy_heredoc c -> cmd "COPY" (string_of_copy_heredoc c) | `User u -> cmd "USER" u | `Volume vl -> cmd "VOLUME" (json_array_of_list vl) | `Entrypoint el -> cmd "ENTRYPOINT" (string_of_shell_or_exec ~escape el) | `Shell sl -> cmd "SHELL" (json_array_of_list sl) | `Workdir wd -> cmd "WORKDIR" wd | `Onbuild t -> cmd "ONBUILD" (string_of_line ~escape t) | `Label ls -> cmd "LABEL" (string_of_label_list ls) | `Stopsignal s -> cmd "STOPSIGNAL" s | `Healthcheck (`Cmd (opts, c)) -> cmd "HEALTHCHECK" (string_of_healthcheck ~escape opts c) | `Healthcheck `None -> "HEALTHCHECK NONE" and string_of_healthcheck ~escape options c = String.concat " " (optional "--interval" options.interval @ optional "--timeout" options.timeout @ optional "--start-period" options.start_period @ optional "--start-interval" options.start_interval @ optional_int "--retries" options.retries) ^ Fmt.str " %c\n %s" escape (string_of_line ~escape (`Cmd 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 = Fmt.kstr (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 device ~name ?required () = { name; required } let from ?alias ?tag ?platform image = [ `From { image; tag; alias; platform } ] let comment fmt = Fmt.kstr (fun c -> [ `Comment c ]) fmt let maintainer fmt = Fmt.kstr (fun m -> [ `Maintainer m ]) fmt let run ?(mounts = []) ?network ?security ?device fmt = Fmt.kstr (fun b -> [ `Run (mounts, network, security, device, `Shell b) ]) fmt let run_exec ?(mounts = []) ?network ?security ?device cmds : t = [ `Run (mounts, network, security, device, `Exec cmds) ] let run_heredoc ?(mounts = []) ?network ?security ?device docs : t = [ `Run_heredoc (mounts, network, security, device, docs) ] let cmd fmt = Fmt.kstr (fun b -> [ `Cmd (`Shell b) ]) fmt let cmd_exec cmds : t = [ `Cmd (`Exec cmds) ] let expose_port ?protocol p : t = [ `Expose [ Port { number = Port_number p; protocol } ] ] let expose_ports ps : t = let ports = List.map (fun (number, protocol) -> Port { number = Port_number number; protocol }) ps in [ `Expose ports ] let arg ?default a : t = [ `Arg (a, default) ] let env e : t = [ `Env e ] let add ?link ?chown ?chmod ?from ?exclude ?checksum ?keep_git_dir ?unpack ~src ~dst () : t = [ `Add ( `From from, `Src src, `Dst dst, `Chown chown, `Chmod chmod, `Link link, `Checksum checksum, `Keep_git_dir keep_git_dir, `Parents None, `Exclude exclude, `Unpack unpack ); ] let copy ?link ?chown ?chmod ?from ?parents ?exclude ~src ~dst () : t = [ `Copy ( `From from, `Src src, `Dst dst, `Chown chown, `Chmod chmod, `Link link, `Checksum None, `Keep_git_dir None, `Parents parents, `Exclude exclude, `Unpack None ); ] let copy_heredoc ?chown ?chmod ~src ~dst () : t = [ `Copy_heredoc (`Chown chown, `Chmod chmod, src, dst) ] let user fmt = Fmt.kstr (fun u -> [ `User u ]) fmt let onbuild t = List.map (fun l -> `Onbuild l) t let volume fmt = Fmt.kstr (fun v -> [ `Volume [ v ] ]) fmt let volumes v : t = [ `Volume v ] let label ls = [ `Label ls ] let entrypoint fmt = Fmt.kstr (fun e -> [ `Entrypoint (`Shell e) ]) fmt let entrypoint_exec e : t = [ `Entrypoint (`Exec e) ] let shell s : t = [ `Shell s ] let workdir fmt = Fmt.kstr (fun wd -> [ `Workdir wd ]) fmt let stopsignal s = [ `Stopsignal s ] let healthcheck ?interval ?timeout ?start_period ?start_interval ?retries fmt = let opts = { interval; timeout; start_period; start_interval; retries } in Fmt.kstr (fun b -> [ `Healthcheck (`Cmd (opts, `Shell b)) ]) fmt let healthcheck_exec ?interval ?timeout ?start_period ?start_interval ?retries cmds : t = let opts = { interval; timeout; start_period; start_interval; retries } in [ `Healthcheck (`Cmd (opts, `Exec cmds)) ] let healthcheck_none () : t = [ `Healthcheck `None ] let to_string tl = let rec find_escape = function | `ParserDirective (`Escape c) :: _ -> c | `ParserDirective _ :: tl -> find_escape tl | _ -> '\\' in let escape = find_escape tl in let buf = Buffer.create 4096 in let is_parser_directive = function `ParserDirective _ -> true | _ -> false and is_arg = function `Arg _ -> true | _ -> false in let space l = Buffer.add_string buf (string_of_line ~escape l); Buffer.add_string buf "\n\n" and print l = Buffer.add_string buf (string_of_line ~escape l); Buffer.add_char buf '\n' in let rec inside = function | (`Comment _ as l1) :: (`From _ as l2) :: tl -> Buffer.add_string buf "\n"; print l1; inside (l2 :: tl) | l1 :: (`From _ as l2) :: tl -> space l1; inside (l2 :: tl) | l :: tl -> print l; inside tl | [] -> () in let rec outside = function | (`ParserDirective _ as l1) :: l2 :: tl when not (is_parser_directive l2) -> space l1; outside (l2 :: tl) | (`Arg _ as l1) :: l2 :: tl when not (is_arg l2) -> space l1; outside (l2 :: tl) | (`From _ as l) :: tl -> print l; inside tl | l :: tl -> print l; outside tl | [] -> () in outside tl; Buffer.contents buf let layers (t : t) : int = let is_layer = function | `From _ | `Run _ | `Copy _ | `Add _ -> true | _ -> false in List.fold_left (fun acc l -> match l with `From _ -> 1 | _ -> if is_layer l then acc + 1 else acc) 0 t let pp ppf tl = Fmt.pf ppf "%s" (to_string tl) (* {2 Parsing} *) let words s = List.filter (fun w -> w <> "") (String.split_on_char ' ' s) let split_keyword s = match String.index_opt s ' ' with | None -> (String.uppercase_ascii s, "") | Some i -> ( String.uppercase_ascii (String.sub s 0 i), String.trim (String.sub s (i + 1) (String.length s - i - 1)) ) (* Exec / JSON-array form [ "a", "b" ] -> Some ["a"; "b"]; None otherwise. Each element is an OCaml string literal, the form {!to_string} emits via "%S". *) let exec_array s = let s = String.trim s in let n = String.length s in if n < 2 || s.[0] <> '[' || s.[n - 1] <> ']' then None else let inner = String.trim (String.sub s 1 (n - 2)) in if inner = "" then Some [] else try Some (List.map (fun p -> Scanf.sscanf (String.trim p) "%S%!" Fun.id) (String.split_on_char ',' inner)) with End_of_file | Failure _ | Scanf.Scan_failure _ -> None let shell_or_exec ~shell ~exec rest = match exec_array rest with Some l -> exec l | None -> shell rest (* "[--flag=v ...] src... dst" for COPY / ADD: (flags, sources, destination). *) let split_sources_dest rest = let flags, rest = List.partition (fun w -> String.length w > 1 && w.[0] = '-') (words rest) in match List.rev rest with | dst :: src_rev -> (flags, List.rev src_rev, dst) | [] -> Fmt.failwith "COPY/ADD: missing source and destination" let flag_value name flags = let p = "--" ^ name ^ "=" in List.find_map (fun f -> if String.starts_with ~prefix:p f then Some (String.sub f (String.length p) (String.length f - String.length p)) else None) flags (* COPY / ADD arguments parse into (chown, chmod, sources, destination). Both the shell form ([COPY --chown=u a b /dst]) and the JSON-array form that {!to_string} emits ([COPY [ "a", "b", "/dst" ]]) are accepted; in the array form the last element is the destination. *) let parse_copy_args rest = match exec_array rest with | Some elems -> ( match List.rev elems with | dst :: src_rev -> (None, None, None, List.rev src_rev, dst) | [] -> Fmt.failwith "COPY/ADD: empty array") | None -> let flags, src, dst = split_sources_dest rest in ( flag_value "from" flags, flag_value "chown" flags, Option.bind (flag_value "chmod" flags) int_of_string_opt, src, dst ) (* "[--flag=v ...] cmd..." for COPY / ADD: (flags, sources, destination). *) let split_healthcheck_cmd rest = let flags, rest = List.partition (fun w -> String.length w > 1 && w.[0] = '-') (words rest) in match rest with | _ :: _ -> (flags, rest) | [] -> failwith "HEALTHCHECK: missing command" (* HEALTHCHECK parse into flags returning [interval, timeout, start-period, start-internal, retires, cmd] *) let parse_healthcheck rest = match rest with | "NONE" -> (None, None, None, None, None, None) | _ -> let flags, cmd = split_healthcheck_cmd rest in let cmd = match cmd with | "CMD" :: rest -> rest | _ -> Fmt.failwith "Malformed CMD in healthcheck" in ( flag_value "interval" flags, flag_value "timeout" flags, flag_value "start-period" flags, flag_value "start-interval" flags, flag_value "retries" flags |> Option.map int_of_string, Some (String.concat " " cmd) ) (* "key=value" pairs separated by spaces; a value may be double-quoted with backslash-escaped quotes and backslashes, as emitted for ENV and LABEL. *) let parse_kv_pairs rest = let toks = ref [] and buf = Buffer.create 16 in let in_q = ref false and esc = ref false and started = ref false in let flush () = if !started then ( toks := Buffer.contents buf :: !toks; Buffer.clear buf; started := false) in String.iter (fun c -> started := true; if !esc then ( Buffer.add_char buf c; esc := false) else if c = '\\' then esc := true else if c = '"' then in_q := not !in_q else if c = ' ' && not !in_q then ( started := true; flush ()) else Buffer.add_char buf c) rest; flush (); try List.rev_map (fun t -> match String.index_opt t '=' with | Some i -> (String.sub t 0 i, String.sub t (i + 1) (String.length t - i - 1)) | None -> Fmt.failwith "expected key=value, got %S" t) !toks with Failure _ as exn -> ( (* We try to parse the "alternative syntax" as many Dockerfiles in the wild use a simple, single " " pair. *) match String.index_opt rest ' ' with | Some i -> [ ( String.sub rest 0 i, String.sub rest (i + 1) (String.length rest - i - 1) ); ] | None -> raise exn) let instr_from rest = let platform = ref None and alias = ref None and image = ref None in let rec go = function | [] -> () | w :: tl when String.starts_with ~prefix:"--platform=" w -> platform := Some (String.sub w 11 (String.length w - 11)); go tl | w :: tl -> ( match !image with | None -> image := Some w; go tl | Some _ -> if String.uppercase_ascii w = "AS" then match tl with | a :: tl' -> alias := Some a; go tl' | [] -> () else go tl) in go (words rest); match !image with | None -> Fmt.failwith "FROM: missing image" | Some img -> let slash = try String.rindex img '/' with Not_found -> -1 in let image, tag = match String.rindex_opt img ':' with | Some i when i > slash -> ( String.sub img 0 i, Some (String.sub img (i + 1) (String.length img - i - 1)) ) | _ -> (img, None) in from ?platform:!platform ?tag ?alias:!alias image (* Parse a [--mount=...] spec (the part after "--mount=") into a mount. *) let parse_run_mount spec = let parts = String.split_on_char ',' spec in let kv = List.filter_map (fun p -> match String.index_opt p '=' with | Some i -> Some (String.sub p 0 i, String.sub p (i + 1) (String.length p - i - 1)) | None -> None) parts in let has_flag k = List.exists (String.equal k) parts in let get k = List.assoc_opt k kv in let bool k = match get k with | Some "true" | Some "1" -> Some true | Some "false" | Some "0" -> Some false | Some _ -> None | None -> if has_flag k then Some true else None in let mode () = Option.bind (get "mode") int_of_string_opt in let int k = Option.bind (get k) int_of_string_opt in let sharing () = match get "sharing" with | None -> None | Some "shared" -> Some `Shared | Some "private" -> Some `Private | Some "locked" -> Some `Locked | Some other -> Fmt.failwith "--mount: invalid cache sharing %S" other in let target () = match get "target" with | Some t -> t | None -> ( match get "dst" with | Some t -> t | None -> Fmt.failwith "--mount: missing target") in match get "type" with | None | Some "bind" -> mount_bind ~target:(target ()) ?source:(get "source") ?from:(get "from") () | Some "cache" -> mount_cache ?id:(get "id") ~target:(target ()) ?from:(get "from") ?source:(get "source") ?readonly:(bool "readonly") ?sharing:(sharing ()) ?mode:(mode ()) ?uid:(int "uid") ?gid:(int "gid") () | Some "secret" -> mount_secret ?id:(get "id") ?target:(get "target") ?mode:(mode ()) () | Some "ssh" -> mount_ssh ?id:(get "id") ?target:(get "target") ?mode:(mode ()) () | Some "tmpfs" -> mount_tmpfs ~target:(target ()) () | Some other -> Fmt.failwith "--mount: unknown type %S" other let parse_run_network = function | "none" -> `None | "host" -> `Host | "default" -> `Default | s -> Fmt.failwith "--network: unknown value %S" s let parse_run_security = function | "insecure" -> `Insecure | "sandbox" -> `Sandbox | s -> Fmt.failwith "--security: unknown value %S" s (* RUN with BuildKit modifiers: strip leading --mount / --network / --security flags, then the remainder is the command (shell or exec form). *) let instr_run rest = let mounts = ref [] and network = ref None and security = ref None in let first_word s = match String.index_opt s ' ' with | Some i -> ( String.sub s 0 i, String.trim (String.sub s (i + 1) (String.length s - i - 1)) ) | None -> (s, "") in let chop p w = String.sub w (String.length p) (String.length w - String.length p) in let rec strip s = let s = String.trim s in if String.starts_with ~prefix:"--mount=" s then ( let w, r = first_word s in mounts := parse_run_mount (chop "--mount=" w) :: !mounts; strip r) else if String.starts_with ~prefix:"--network=" s then ( let w, r = first_word s in network := Some (parse_run_network (chop "--network=" w)); strip r) else if String.starts_with ~prefix:"--security=" s then ( let w, r = first_word s in security := Some (parse_run_security (chop "--security=" w)); strip r) else s in let cmd = strip rest in let mounts = List.rev !mounts and network = !network and security = !security in match exec_array cmd with | Some l -> run_exec ~mounts ?network ?security l | None -> run ~mounts ?network ?security "%s" cmd let tabs_to_spaces ?(n = 2) s = let spaces = String.make n ' ' in let len = String.length s in let buf = Buffer.create len in let i = ref 0 in while !i < len do let c = String.unsafe_get s !i in let () = if Char.equal c '\t' then Buffer.add_string buf spaces else Buffer.add_char buf c in incr i done; Buffer.contents buf let parse_port_number s = match int_of_string_opt s with | Some i -> Some (Port_number i) | None -> ( match String.split_on_char '-' s with | [ from; to_ ] -> ( match (int_of_string_opt from, int_of_string_opt to_) with | Some from, Some to_ -> Some (Port_range (from, to_)) | _ -> None) | _ -> None) let rec instr_of_line s = (* Maybe not the best approach, but okay for now. *) let s = tabs_to_spaces s in let kw, rest = split_keyword s in match kw with | "FROM" -> instr_from rest | "RUN" -> instr_run rest | "CMD" -> shell_or_exec ~shell:(fun r -> cmd "%s" r) ~exec:cmd_exec rest | "ENTRYPOINT" -> shell_or_exec ~shell:(fun r -> entrypoint "%s" r) ~exec:entrypoint_exec rest | "WORKDIR" -> workdir "%s" rest | "USER" -> user "%s" rest | "MAINTAINER" -> maintainer "%s" rest | "STOPSIGNAL" -> stopsignal rest | "ENV" -> env (parse_kv_pairs rest) | "LABEL" -> label (parse_kv_pairs rest) | "SHELL" -> ( match exec_array rest with | Some l -> shell l | None -> Fmt.failwith "SHELL requires a JSON array") | "EXPOSE" -> [ `Expose (List.map (fun w -> if String.contains w '$' then Port_variable w else match parse_port_number w with | Some p -> Port { number = p; protocol = None } | None -> ( match String.index_opt w '/' with | Some i -> ( let number = String.sub w 0 i in let protocol = String.sub w (i + 1) (String.length w - i - 1) in match ( parse_port_number number, String.lowercase_ascii protocol ) with | Some number, "udp" -> Port { number; protocol = Some `Udp } | Some number, "tcp" -> Port { number; protocol = Some `Tcp } | _ -> Fmt.failwith "EXPOSE: bad port %S" w) | None -> Fmt.failwith "EXPOSE: bad port %S" w)) (words rest)); ] | "VOLUME" -> ( match exec_array rest with | Some l -> volumes l | None -> volumes (words rest)) | "ARG" -> ( match String.index_opt rest '=' with | Some i -> arg ~default:(String.sub rest (i + 1) (String.length rest - i - 1)) (String.sub rest 0 i) | None -> arg rest) | "COPY" -> let from, chown, chmod, src, dst = parse_copy_args rest in copy ?from ?chown ?chmod ~src ~dst () | "ADD" -> let from, chown, chmod, src, dst = parse_copy_args rest in add ?from ?chown ?chmod ~src ~dst () | "HEALTHCHECK" -> ( let interval, timeout, start_period, start_interval, retries, cmd = parse_healthcheck rest in match cmd with | None -> healthcheck_none () | Some cmd -> healthcheck ?interval ?timeout ?start_period ?start_interval ?retries "%s" cmd) | "ONBUILD" -> let instr = instr_of_line rest in onbuild instr | other -> Error.fail_unsupported_instruction Loc.Meta.none other (* A [Lexing.position] span as a {!Loc.Meta.t}, so parse and interpretation errors report the exact line and byte range of the offending input. *) let meta_of_span (start : Lexing.position) (stop : Lexing.position) = Loc.Meta.v (Loc.v ~file:start.pos_fname ~first_byte:start.pos_cnum ~last_byte:(Int.max start.pos_cnum (stop.pos_cnum - 1)) ~first_line_num:start.pos_lnum ~first_line_byte:start.pos_bol ~last_line_num:stop.pos_lnum ~last_line_byte:stop.pos_bol) (* Interpret one raw line, stamping its source span onto any error it raises: uncaught [Failure]s from the keyword handlers become located messages, and already-typed {!Loc.Error}s (the unsupported-instruction kind) are relocated to the line. *) let interpret_line (raw, (start, stop)) = match raw with | Raw.Comment c -> comment "%s" c | Raw.Instr s -> ( let meta = meta_of_span start stop in match instr_of_line s with | t -> t | exception Failure m -> Error.fail meta m | exception Loc.Error e -> Stdlib.raise (Loc.Error (Error.relocate meta e))) let of_string_exn ?(file = Loc.file_none) s = let lexbuf = Lexing.from_string s in let escape_char = ref '\\' in Lexing.set_filename lexbuf file; match Parser.file (Lexer.token escape_char) lexbuf with | exception Parser.Error -> Error.failf (meta_of_span (Lexing.lexeme_start_p lexbuf) (Lexing.lexeme_end_p lexbuf)) "syntax error" | raws -> List.concat_map interpret_line raws let of_string ?file s = match of_string_exn ?file s with | t -> Ok t | exception Loc.Error e -> Error e (* {2 Curated instruction view} *) type command = [ `Shell of string | `Exec of string list ] type run_mount = | Cache of { target : string; id : string option; readonly : bool option; sharing : [ `Shared | `Private | `Locked ] option; from : string option; source : string option; mode : int option; uid : int option; gid : int option; } | Bind of { target : string; source : string option; from : string option } | Secret of { id : string option; target : string option } | Ssh of { id : string option; target : string option } | Tmpfs of { target : string } type copy = { from : string option; src : string list; dst : string; chown : string option; chmod : int option; } type instruction = | From of { image : string; tag : string option; alias : string option; platform : string option; } | Run of { command : command; network : network option; security : security option; mounts : run_mount list; } | Cmd of command | Entrypoint of command | Copy of copy | Add of copy | Env of (string * string) list | Arg of string * string option | Label of (string * string) list | Expose of port list | Volume of string list | User of string | Workdir of string | Shell of string list | Maintainer of string | Stopsignal of string | Comment of string | Other of string let command_view : shell_or_exec -> command = function | `Shell s -> `Shell s | `Shells l -> `Shell (String.concat " && " l) | `Exec l -> `Exec l let run_mount_view (m : mount) : run_mount = match m.typ with | `Cache c -> Cache { target = c.target; id = c.id; readonly = c.readonly; sharing = c.sharing; from = c.from; source = c.source; mode = c.mode; uid = c.uid; gid = c.gid; } | `Bind b -> Bind { target = b.target; source = b.source; from = b.from } | `Secret f -> Secret { id = f.id; target = f.target } | `Ssh f -> Ssh { id = f.id; target = f.target } | `Tmpfs t -> Tmpfs { target = t.target } let copy_view (std : sources_to_dest) : copy = let ( `From from, `Src src, `Dst dst, `Chown chown, `Chmod chmod, _, _, _, _, _, _ ) = std in { from; src; dst; chown; chmod } let instruction_of_line : line -> instruction = function | `From { image; tag; alias; platform } -> From { image; tag; alias; platform } | `Run (mounts, network, security, _device, soe) -> Run { command = command_view soe; network; security; mounts = List.map run_mount_view mounts; } | `Cmd soe -> Cmd (command_view soe) | `Entrypoint soe -> Entrypoint (command_view soe) | `Copy std -> Copy (copy_view std) | `Add std -> Add (copy_view std) | `Env l -> Env l | `Arg (n, d) -> Arg (n, d) | `Label l -> Label l | `Expose p -> Expose p | `Volume l -> Volume l | `User s -> User s | `Workdir s -> Workdir s | `Shell l -> Shell l | `Maintainer s -> Maintainer s | `Stopsignal s -> Stopsignal s | `Comment s -> Comment s | ( `ParserDirective _ | `Run_heredoc _ | `Copy_heredoc _ | `Onbuild _ | `Healthcheck _ ) as l -> Other (String.trim (string_of_line ~escape:'\\' l)) let instructions (t : t) : instruction list = List.map instruction_of_line t module Cursor = struct type dockerfile = t (* A list zipper: [before] holds the instructions left of the focus, nearest first (reversed); the focus is the head of [after], or none past the last instruction. Edits keep the internal [line] so reconstruction is lossless; the focus is surfaced through the curated {!instruction} view. *) type t = { before : line list; after : line list } let v (d : dockerfile) : t = { before = []; after = d } let to_dockerfile c = List.rev_append c.before c.after let length c = List.length c.before + List.length c.after let index c = List.length c.before let focus c = match c.after with [] -> None | l :: _ -> Some (instruction_of_line l) let next c = match c.after with | [] -> None | l :: after -> Some { before = l :: c.before; after } let prev c = match c.before with | [] -> None | l :: before -> Some { before; after = l :: c.after } let seek n c = if n < 0 then None else let rec go i before after = if i = n then Some { before; after } else match after with [] -> None | l :: tl -> go (i + 1) (l :: before) tl in go 0 [] (to_dockerfile c) let replace (frag : dockerfile) c = match c.after with [] -> c | _ :: after -> { c with after = frag @ after } let insert (frag : dockerfile) c = { c with after = frag @ c.after } let delete c = match c.after with [] -> None | _ :: after -> Some { c with after } end module Error = Error