|
| 1 | +open Lwt.Infix |
| 2 | + |
| 3 | +let ( / ) = Filename.concat |
| 4 | + |
| 5 | +let ctr_exec args = |
| 6 | + let pp f = Os.pp_cmd f ("", "ctr" :: args) in |
| 7 | + Os.exec_result ~pp ("ctr" :: args) |
| 8 | + |
| 9 | +let ctr_pread args = |
| 10 | + if Sys.win32 then |
| 11 | + Os.win32_pread ("ctr" :: args) |
| 12 | + else |
| 13 | + let pp f = Os.pp_cmd f ("", "ctr" :: args) in |
| 14 | + Os.pread_result ~pp ("ctr" :: args) |
| 15 | + |
| 16 | +(* Parse the config digest from `ctr images inspect` tree output. |
| 17 | + Look for lines like: "application/vnd.docker.container.image.v1+json @sha256:..." *) |
| 18 | +let parse_config_digest output = |
| 19 | + let lines = String.split_on_char '\n' output in |
| 20 | + List.find_map (fun line -> |
| 21 | + if Astring.String.is_infix ~affix:"container.image.v1+json" line then |
| 22 | + match Astring.String.cut ~sep:"@" line with |
| 23 | + | Some (_, digest) -> |
| 24 | + let digest = String.trim digest in |
| 25 | + (* Extract just the digest, removing any trailing info like "(123 bytes)" *) |
| 26 | + (match Astring.String.cut ~sep:" " digest with |
| 27 | + | Some (d, _) -> Some d |
| 28 | + | None -> Some digest) |
| 29 | + | None -> None |
| 30 | + else None |
| 31 | + ) lines |
| 32 | + |
| 33 | +let parse_env_from_config output = |
| 34 | + try |
| 35 | + let json = Yojson.Safe.from_string output in |
| 36 | + let open Yojson.Safe.Util in |
| 37 | + let config = json |> member "config" in |
| 38 | + let env_list = config |> member "Env" |> to_list |> List.map to_string in |
| 39 | + List.filter_map (fun s -> |
| 40 | + match String.index_opt s '=' with |
| 41 | + | Some i -> |
| 42 | + let key = String.sub s 0 i in |
| 43 | + let value = String.sub s (i + 1) (String.length s - i - 1) in |
| 44 | + Some (key, value) |
| 45 | + | None -> None |
| 46 | + ) env_list |
| 47 | + with _ -> [] |
| 48 | + |
| 49 | + |
| 50 | +(* Parse the chain ID from `ctr images pull --print-chainid --local` output. |
| 51 | + The output contains a line like: "image chain ID: sha256:abc123..." *) |
| 52 | +let parse_chain_id output = |
| 53 | + let lines = String.split_on_char '\n' output in |
| 54 | + List.find_map (fun line -> |
| 55 | + match Astring.String.cut ~sep:"image chain ID: " line with |
| 56 | + | Some (_, chain_id) -> Some (String.trim chain_id) |
| 57 | + | None -> None |
| 58 | + ) lines |
| 59 | + |
| 60 | +(* Normalize image reference for containerd. |
| 61 | + Docker Hub images need docker.io/ prefix: |
| 62 | + - "ubuntu:latest" -> "docker.io/library/ubuntu:latest" |
| 63 | + - "ocaml/opam:tag" -> "docker.io/ocaml/opam:tag" |
| 64 | + - "mcr.microsoft.com/..." -> unchanged (already has registry) |
| 65 | + - "docker.io/..." -> unchanged *) |
| 66 | +let normalize_image_ref image = |
| 67 | + if String.contains image '/' then |
| 68 | + (* Has a slash - check if it starts with a registry *) |
| 69 | + let first_part = |
| 70 | + match String.index_opt image '/' with |
| 71 | + | Some i -> String.sub image 0 i |
| 72 | + | None -> image |
| 73 | + in |
| 74 | + (* If first part contains a dot or colon, it's a registry *) |
| 75 | + if String.contains first_part '.' || String.contains first_part ':' then |
| 76 | + image (* Already has registry prefix *) |
| 77 | + else |
| 78 | + "docker.io/" ^ image (* Docker Hub user/repo format *) |
| 79 | + else |
| 80 | + (* No slash - it's a Docker Hub library image *) |
| 81 | + "docker.io/library/" ^ image |
| 82 | + |
| 83 | +let fetch ~log:(_log : Build_log.t) ~root:(_root : string) ~rootfs base : Config.env Lwt.t = |
| 84 | + let image = normalize_image_ref base in |
| 85 | + let hash = Sha256.to_hex (Sha256.string base) in |
| 86 | + let key = "obuilder-base-" ^ hash in |
| 87 | + (* Pull the image — on Windows containerd, pull also unpacks layers *) |
| 88 | + Log.info (fun f -> f "HCS fetch: pulling image %s (from %s)" image base); |
| 89 | + let platform = ["--platform"; "windows/amd64"] in |
| 90 | + (ctr_exec (["images"; "pull"] @ platform @ [image]) >>= function |
| 91 | + | Ok () -> Log.info (fun f -> f "HCS fetch: pull succeeded"); Lwt.return_unit |
| 92 | + | Error (`Msg m) -> Fmt.failwith "Failed to pull image %s: %s" image m) |
| 93 | + >>= fun () -> |
| 94 | + (* Get the image's chain ID (the snapshot key for the top layer). |
| 95 | + Using --local makes this fast since the image is already pulled. *) |
| 96 | + Log.info (fun f -> f "HCS fetch: getting chain ID"); |
| 97 | + (ctr_pread (["images"; "pull"; "--print-chainid"; "--local"] @ platform @ [image]) >>= function |
| 98 | + | Ok output -> |
| 99 | + Log.info (fun f -> f "HCS fetch: got chainid output"); |
| 100 | + (match parse_chain_id output with |
| 101 | + | Some chain_id -> Log.info (fun f -> f "HCS fetch: chain ID = %s" chain_id); Lwt.return chain_id |
| 102 | + | None -> Fmt.failwith "Could not find chain ID for image %s" image) |
| 103 | + | Error (`Msg m) -> |
| 104 | + Fmt.failwith "Failed to get chain ID for image %s: %s" image m) |
| 105 | + >>= fun chain_id -> |
| 106 | + (* Clean up any existing snapshots with this key first (for idempotency). |
| 107 | + Remove any snapshots that depend on our key, then remove our key itself. *) |
| 108 | + Log.info (fun f -> f "HCS fetch: cleaning up any existing snapshots for %s" key); |
| 109 | + let committed_key = key ^ "-committed" in |
| 110 | + (* Use ctr snapshot ls and parse to find snapshots that have our committed key as parent *) |
| 111 | + (ctr_pread ["snapshot"; "ls"] >>= function |
| 112 | + | Ok output -> |
| 113 | + let lines = String.split_on_char '\n' output in |
| 114 | + let children = lines |> List.filter_map (fun line -> |
| 115 | + (* Format: KEY\s+PARENT\s+KIND *) |
| 116 | + let parts = Astring.String.cuts ~empty:false ~sep:" " (String.trim line) in |
| 117 | + match parts with |
| 118 | + | child :: parent :: _ when parent = committed_key -> Some child |
| 119 | + | _ -> None |
| 120 | + ) in |
| 121 | + Lwt_list.iter_s (fun child -> |
| 122 | + Log.info (fun f -> f "HCS fetch: removing child snapshot %s" child); |
| 123 | + ctr_exec ["snapshot"; "rm"; child] >>= fun _ -> Lwt.return_unit |
| 124 | + ) children |
| 125 | + | Error _ -> Lwt.return_unit) |
| 126 | + >>= fun () -> |
| 127 | + (* Now remove the main snapshots *) |
| 128 | + (ctr_exec ["snapshot"; "rm"; key] >>= function |
| 129 | + | Ok () -> Log.info (fun f -> f "HCS fetch: removed existing snapshot"); Lwt.return_unit |
| 130 | + | Error (`Msg _) -> Log.info (fun f -> f "HCS fetch: no existing snapshot to remove"); Lwt.return_unit) |
| 131 | + >>= fun () -> |
| 132 | + (ctr_exec ["snapshot"; "rm"; committed_key] >>= function |
| 133 | + | Ok () -> Log.info (fun f -> f "HCS fetch: removed existing committed snapshot"); Lwt.return_unit |
| 134 | + | Error (`Msg m) -> Log.info (fun f -> f "HCS fetch: could not remove committed snapshot: %s" m); Lwt.return_unit) |
| 135 | + >>= fun () -> |
| 136 | + (* Prepare a writable snapshot from the image's top layer *) |
| 137 | + Log.info (fun f -> f "HCS fetch: preparing snapshot %s from %s" key chain_id); |
| 138 | + (ctr_pread ["snapshot"; "prepare"; "--mounts"; key; chain_id] >>= function |
| 139 | + | Ok mounts_json -> |
| 140 | + Log.info (fun f -> f "HCS fetch: snapshot prepared, parsing mount json"); |
| 141 | + let source, parent_layer_paths = Hcs.parse_mount_json mounts_json in |
| 142 | + Log.info (fun f -> f "HCS fetch: source=%s, parents=%d" source (List.length parent_layer_paths)); |
| 143 | + Log.info (fun f -> f "HCS fetch: writing layerinfo to %s" rootfs); |
| 144 | + Hcs.write_layerinfo ~dir:rootfs { snapshot_key = key; source; parent_layer_paths } >>= fun () -> |
| 145 | + Log.info (fun f -> f "HCS fetch: layerinfo written"); |
| 146 | + Lwt.return_unit |
| 147 | + | Error (`Msg m) -> |
| 148 | + Fmt.failwith "Failed to prepare snapshot for base %s: %s" base m) |
| 149 | + >>= fun () -> |
| 150 | + (* Get environment variables from the image config. |
| 151 | + First get the config digest from inspect, then get the config content. *) |
| 152 | + Log.info (fun f -> f "HCS fetch: getting image config"); |
| 153 | + (ctr_pread ["images"; "inspect"; image] >>= function |
| 154 | + | Ok inspect_output -> |
| 155 | + (match parse_config_digest inspect_output with |
| 156 | + | Some config_digest -> |
| 157 | + Log.info (fun f -> f "HCS fetch: config digest = %s" config_digest); |
| 158 | + ctr_pread ["content"; "get"; config_digest] >>= (function |
| 159 | + | Ok config_json -> |
| 160 | + Log.info (fun f -> f "HCS fetch: got config, parsing env"); |
| 161 | + Lwt.return (parse_env_from_config config_json) |
| 162 | + | Error (`Msg m) -> |
| 163 | + Log.warn (fun f -> f "HCS fetch: failed to get config content: %s" m); |
| 164 | + Lwt.return []) |
| 165 | + | None -> |
| 166 | + Log.warn (fun f -> f "HCS fetch: could not find config digest in inspect output"); |
| 167 | + Lwt.return []) |
| 168 | + | Error (`Msg m) -> |
| 169 | + Log.warn (fun f -> f "HCS fetch: failed to inspect image: %s" m); |
| 170 | + Lwt.return []) |
| 171 | + >>= fun env -> |
| 172 | + Log.info (fun f -> f "HCS fetch: done, got %d env vars" (List.length env)); |
| 173 | + Lwt.return env |
0 commit comments