OCaml library and CLI for OCI and Docker image manipulation
Squashed 'ocaml-oci/' content from commit 23f402a6 git-subtree-split: 23f402a61d71062490fb085624b63c830fa6c7be
+5876
+6
.github/dependabot.yml
+6
.github/dependabot.yml
+44
.github/workflows/build.yml
+44
.github/workflows/build.yml
···
1
+
name: Build & Tests
2
+
3
+
on:
4
+
- push
5
+
- pull_request
6
+
7
+
permissions: read-all
8
+
9
+
jobs:
10
+
build:
11
+
strategy:
12
+
fail-fast: true
13
+
matrix:
14
+
os: [ubuntu-latest]
15
+
runs-on: ${{ matrix.os }}
16
+
steps:
17
+
- name: Checkout tree
18
+
uses: actions/checkout@v4
19
+
- name: Set-up OCaml
20
+
uses: ocaml/setup-ocaml@v3
21
+
with:
22
+
ocaml-compiler: 5.1
23
+
dune-cache: true
24
+
- run: opam list
25
+
- name: Restore opam cache
26
+
id: restore-cache
27
+
uses: actions/cache/restore@v4
28
+
with:
29
+
path: _opam
30
+
key: ${{ runner.os }}-opam-${{ hashFiles('container-image.opam') }}
31
+
restore-keys: |
32
+
${{ runner.os }}-opam-
33
+
- run: opam list
34
+
- run: sudo apt-get install -qq -yy libev-dev libonig-dev
35
+
- name: Build dependencies
36
+
run: opam install . --deps-only --with-test
37
+
- name: Save opam cache
38
+
if: steps.restore-cache.outputs.cache-hit != 'true'
39
+
uses: actions/cache/save@v4
40
+
with:
41
+
path: _opam
42
+
key: ${{ steps.restore-cache.outputs.cache-primary-key }}
43
+
- run: opam exec -- dune build
44
+
- run: opam exec -- dune runtest
+12
.gitignore
+12
.gitignore
+1
.ocamlformat
+1
.ocamlformat
···
1
+
version = 0.28.1
+71
README.md
+71
README.md
···
1
+
# container-image - Manage OCI and Docker Images in OCaml
2
+
3
+
The `container-image` package provides a straightforward OCaml
4
+
interface for interacting with OCI and Docker image specifications. It
5
+
also provide a CLI tool (named `container-image) that allows users to
6
+
fetch image layers or inspect image contents on your filesystem.
7
+
8
+
## Features
9
+
10
+
- [x] An OCaml API to manage OCI and Docker images
11
+
- [x] Fetch layers of an OCI or Docker image.
12
+
- [ ] Inspect the contents of an image on the local filesystem,
13
+
complete with a git history for easy diff inspection between layers.
14
+
15
+
## Installation
16
+
17
+
### From Source
18
+
19
+
```bash
20
+
git clone https://github.com/your-repo/container-image.git
21
+
cd container-image
22
+
opam install . --deps-only
23
+
dune build @install
24
+
```
25
+
26
+
### Using OPAM (When available)
27
+
28
+
```bash
29
+
opam install container-image
30
+
```
31
+
32
+
## Usage
33
+
34
+
### Fetching Image Layers
35
+
36
+
To fetch the layers of an image:
37
+
38
+
```bash
39
+
container-image fetch IMAGE_NAME[:TAG]
40
+
```
41
+
42
+
This command downloads the image layers to the current directory. By
43
+
default TAG is `latest`.
44
+
45
+
### Checking Out Image Contents
46
+
47
+
To inspect an image's contents on the local filesystem:
48
+
49
+
```bash
50
+
container-image checkout [TAG]
51
+
```
52
+
53
+
After running this command, you'll find the image's contents extracted
54
+
to the current directory. Importantly, this checkout will include a
55
+
git history, allowing you to seamlessly inspect the differences
56
+
between layers.
57
+
58
+
## Documentation
59
+
60
+
For an in-depth guide on the `container-image` commands and the
61
+
underlying OCaml API, check out the [official
62
+
documentation](link-to-docs).
63
+
64
+
## Contributing
65
+
66
+
Contributions to the `container-image` project are welcome!
67
+
68
+
## License
69
+
70
+
This project is licensed under the MIT License. See
71
+
[LICENSE](link-to-license-file) for more details.
+17
bin/dune
+17
bin/dune
+186
bin/main.ml
+186
bin/main.ml
···
1
+
open Cmdliner
2
+
3
+
let all_tags =
4
+
Arg.(
5
+
value @@ flag
6
+
@@ info ~doc:"Download all tagged images in the repository"
7
+
[ "a"; "all-tags" ])
8
+
9
+
let platform =
10
+
Arg.(
11
+
value
12
+
@@ opt (some string) None
13
+
@@ info ~doc:"Set platform if server is multi-platform capable"
14
+
[ "platform" ])
15
+
16
+
let checkout_directory =
17
+
Arg.(
18
+
value
19
+
@@ opt (some dir) None
20
+
@@ info ~doc:"The directory to checkout the image to."
21
+
[ "checkout-directory" ])
22
+
23
+
let image =
24
+
let open Oci in
25
+
let image = Arg.conv (Image.of_string, Image.pp) in
26
+
Arg.(
27
+
required
28
+
@@ pos 0 (some image) None
29
+
@@ info ~doc:"Download an image from a registry" ~docv:"NAME[:TAG|@DIGEST]"
30
+
[])
31
+
32
+
let image_id =
33
+
Arg.(
34
+
required
35
+
@@ pos 0 (some string) None
36
+
@@ info ~doc:"Download an image from a registry" ~docv:"IMAGE" [])
37
+
38
+
let username =
39
+
Arg.(
40
+
value
41
+
@@ opt (some string) None
42
+
@@ info ~doc:"Username" ~docv:"STRING" [ "username"; "u" ])
43
+
44
+
let password =
45
+
let env = Cmd.Env.info "IMAGE_TOKEN" in
46
+
Arg.(
47
+
value
48
+
@@ opt (some string) None
49
+
@@ info ~env ~doc:"Password" ~docv:"FILE" [ "password"; "p" ])
50
+
51
+
let no_progress =
52
+
Arg.(
53
+
value @@ flag
54
+
@@ info ~doc:"Do not display the progress bars" [ "no-progress" ])
55
+
56
+
let setup =
57
+
let style_renderer = Fmt_cli.style_renderer () in
58
+
Term.(
59
+
const (fun style_renderer level ->
60
+
Fmt_tty.setup_std_outputs ?style_renderer ();
61
+
Logs.set_level level;
62
+
Logs.set_reporter (Logs_fmt.reporter ()))
63
+
$ style_renderer $ Logs_cli.level ())
64
+
65
+
let cache env =
66
+
let fs = Eio.Stdenv.fs env in
67
+
let xdg = Xdg.create ~env:Sys.getenv_opt () in
68
+
let root = Eio.Path.(fs / Xdg.cache_dir xdg / "image") in
69
+
let cache = Oci.Cache.v root in
70
+
Oci.Cache.init cache;
71
+
cache
72
+
73
+
let fetch () all_tags platform image username password no_progress =
74
+
ignore all_tags;
75
+
Crypto_rng_unix.use_default ();
76
+
Eio_main.run @@ fun env ->
77
+
let net = Eio.Stdenv.net env in
78
+
let clock = Eio.Stdenv.clock env in
79
+
let client = Oci.Fetch.create_client ~net ~clock in
80
+
let cache = cache env in
81
+
let domain_mgr = Eio.Stdenv.domain_mgr env in
82
+
let show_progress = not no_progress in
83
+
Oci.fetch ~show_progress ~client ~cache ~domain_mgr ?platform ?username
84
+
?password image
85
+
86
+
let list () =
87
+
Eio_main.run @@ fun env ->
88
+
let cache = cache env in
89
+
let images = Oci.list ~cache in
90
+
let text = PrintBox.text in
91
+
let text_bold = PrintBox.(text_with_style Style.bold) in
92
+
let text_color c = PrintBox.(text_with_style Style.(fg_color c)) in
93
+
let box =
94
+
[
95
+
text_bold "📖 REPOSITORY";
96
+
text_bold "IMAGE ID";
97
+
text_bold "TAGS";
98
+
text_bold "PLATFORM";
99
+
text_bold "SIZE";
100
+
]
101
+
:: List.map
102
+
(fun t ->
103
+
let open Oci.List in
104
+
let repo = repository t in
105
+
let tags = String.concat ", " (tags t) in
106
+
let digest = digest t in
107
+
let id =
108
+
let hash = Oci.Spec.Digest.encoded_hash digest in
109
+
String.sub hash 0 12
110
+
in
111
+
let platform =
112
+
let some = Oci.Spec.Platform.to_string in
113
+
Option.fold ~none:"" ~some (platform t)
114
+
in
115
+
let size = size t in
116
+
[
117
+
text_color Cyan repo;
118
+
text id;
119
+
text_color Yellow tags;
120
+
text platform;
121
+
text size;
122
+
])
123
+
images
124
+
|> PrintBox.grid_l ~bars:false ~pad:(PrintBox.hpad 1)
125
+
in
126
+
PrintBox_text.output stdout box;
127
+
Fmt.pr "\n%!"
128
+
129
+
let checkout () image path =
130
+
Eio_main.run @@ fun env ->
131
+
let cache = cache env in
132
+
let root =
133
+
match path with
134
+
| None -> Eio.Stdenv.cwd env
135
+
| Some path ->
136
+
let fs = Eio.Stdenv.fs env in
137
+
Eio.Path.(fs / path)
138
+
in
139
+
let image = Oci.Cache.Manifest.guess cache image in
140
+
Oci.checkout ~cache ~root image
141
+
142
+
let show () image =
143
+
Eio_main.run @@ fun env ->
144
+
let cache = cache env in
145
+
let image = Oci.Cache.Manifest.guess cache image in
146
+
Oci.show ~cache image
147
+
148
+
let version =
149
+
match Build_info.V1.version () with
150
+
| None -> "n/a"
151
+
| Some v -> Build_info.V1.Version.to_string v
152
+
153
+
let fetch_cmd =
154
+
Cmd.v
155
+
(Cmd.info "fetch" ~version)
156
+
Term.(
157
+
const fetch $ setup $ all_tags $ platform $ image $ username $ password
158
+
$ no_progress)
159
+
160
+
let list_term = Term.(const list $ setup)
161
+
let list_cmd = Cmd.v (Cmd.info "list" ~version) list_term
162
+
163
+
let checkout_cmd =
164
+
Cmd.v
165
+
(Cmd.info "checkout" ~version)
166
+
Term.(const checkout $ setup $ image_id $ checkout_directory)
167
+
168
+
let show_cmd =
169
+
Cmd.v (Cmd.info "show" ~version) Term.(const show $ setup $ image_id)
170
+
171
+
let cmd =
172
+
Cmd.group ~default:list_term (Cmd.info "image")
173
+
[ fetch_cmd; list_cmd; checkout_cmd; show_cmd ]
174
+
175
+
let () =
176
+
let () = Printexc.record_backtrace true in
177
+
match Cmd.eval ~catch:false cmd with
178
+
| i -> exit i
179
+
| (exception Failure s) | (exception Invalid_argument s) ->
180
+
Printexc.print_backtrace stderr;
181
+
Fmt.epr "\n%a %s\n%!" Fmt.(styled `Red string) "[ERROR]" s;
182
+
exit Cmd.Exit.cli_error
183
+
| exception e ->
184
+
Printexc.print_backtrace stderr;
185
+
Fmt.epr "\n%a\n%!" Fmt.exn e;
186
+
exit Cmd.Exit.some_error
demo.gif
demo.gif
This is a binary file and will not be displayed.
+41
dune-project
+41
dune-project
···
1
+
(lang dune 3.17)
2
+
3
+
(name oci)
4
+
5
+
(generate_opam_files true)
6
+
7
+
(license ISC)
8
+
(authors "Thomas Gazagnaire <thomas@gazagnaire.org>")
9
+
(maintainers "Thomas Gazagnaire <thomas@gazagnaire.org>")
10
+
(homepage "https://tangled.org/gazagnaire.org/ocaml-oci")
11
+
(bug_reports "https://tangled.org/gazagnaire.org/ocaml-oci/issues")
12
+
13
+
(package
14
+
(name oci)
15
+
(synopsis "OCaml library and CLI for OCI and Docker image manipulation")
16
+
(description
17
+
"Tools to manage OCI and Docker images. Fetch layers from registries, \
18
+
inspect image contents, and checkout with git history for layer diffs.")
19
+
(depends
20
+
(ocaml (>= 5.0.0))
21
+
yojson
22
+
ppx_deriving_yojson
23
+
digestif
24
+
decompress
25
+
base64
26
+
cmdliner
27
+
logs
28
+
astring
29
+
dune-build-info
30
+
(crypto-rng (>= 1.2.0))
31
+
requests
32
+
progress
33
+
tls-eio
34
+
(eio (>= 1.0))
35
+
tar-eio
36
+
eio_main
37
+
xdg
38
+
printbox
39
+
printbox-text
40
+
osrelease
41
+
(alcotest :with-test)))
+50
oci.opam
+50
oci.opam
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
synopsis: "OCaml library and CLI for OCI and Docker image manipulation"
4
+
description:
5
+
"Tools to manage OCI and Docker images. Fetch layers from registries, inspect image contents, and checkout with git history for layer diffs."
6
+
maintainer: ["Thomas Gazagnaire <thomas@gazagnaire.org>"]
7
+
authors: ["Thomas Gazagnaire <thomas@gazagnaire.org>"]
8
+
license: "ISC"
9
+
homepage: "https://tangled.org/gazagnaire.org/ocaml-oci"
10
+
bug-reports: "https://tangled.org/gazagnaire.org/ocaml-oci/issues"
11
+
depends: [
12
+
"dune" {>= "3.17"}
13
+
"ocaml" {>= "5.0.0"}
14
+
"yojson"
15
+
"ppx_deriving_yojson"
16
+
"digestif"
17
+
"decompress"
18
+
"base64"
19
+
"cmdliner"
20
+
"logs"
21
+
"astring"
22
+
"dune-build-info"
23
+
"crypto-rng" {>= "1.2.0"}
24
+
"requests"
25
+
"progress"
26
+
"tls-eio"
27
+
"eio" {>= "1.0"}
28
+
"tar-eio"
29
+
"eio_main"
30
+
"xdg"
31
+
"printbox"
32
+
"printbox-text"
33
+
"osrelease"
34
+
"alcotest" {with-test}
35
+
"odoc" {with-doc}
36
+
]
37
+
build: [
38
+
["dune" "subst"] {dev}
39
+
[
40
+
"dune"
41
+
"build"
42
+
"-p"
43
+
name
44
+
"-j"
45
+
jobs
46
+
"@install"
47
+
"@runtest" {with-test}
48
+
"@doc" {with-doc}
49
+
]
50
+
]
+211
src/cache.ml
+211
src/cache.ml
···
1
+
open Oci_spec
2
+
module B = Blob
3
+
4
+
(* FIXME: code duplication *)
5
+
let error_msg fmt = Fmt.kstr (fun s -> Error (`Msg s)) fmt
6
+
7
+
type task = { promise : unit Eio.Promise.t; resolver : unit Eio.Promise.u }
8
+
9
+
type t = {
10
+
root : [ `Dir ] Eio.Path.t;
11
+
lock : Eio.Mutex.t;
12
+
pending : (string, task) Hashtbl.t;
13
+
}
14
+
15
+
let v root = { root; lock = Eio.Mutex.create (); pending = Hashtbl.create 13 }
16
+
let ( / ) = Eio.Path.( / )
17
+
let mkdirs dir = Eio.Path.mkdirs ~exists_ok:true ~perm:0o700 dir
18
+
19
+
let mkdir_parent file =
20
+
match Eio.Path.split file with
21
+
| None -> ()
22
+
| Some (parent, _) -> mkdirs parent
23
+
24
+
let init t =
25
+
mkdirs (t.root / "blobs" / "sha256");
26
+
mkdirs (t.root / "manifests")
27
+
28
+
let with_lock lock fn =
29
+
Eio.Mutex.lock lock;
30
+
let finally () = Eio.Mutex.unlock lock in
31
+
Fun.protect ~finally fn
32
+
33
+
let task path = Eio.Path.native_exn path
34
+
35
+
let remove_task t path =
36
+
let task = task path in
37
+
with_lock t.lock (fun () ->
38
+
match Hashtbl.find_opt t.pending task with
39
+
| None -> ()
40
+
| Some { resolver; _ } ->
41
+
Eio.Promise.resolve resolver ();
42
+
Hashtbl.remove t.pending task)
43
+
44
+
let find_and_add_task t ?size path =
45
+
let task = task path in
46
+
with_lock t.lock (fun () ->
47
+
match Hashtbl.find_opt t.pending task with
48
+
| Some t -> `Pending t
49
+
| None ->
50
+
let exists = Eio.Path.is_file path in
51
+
let correct_size =
52
+
match size with
53
+
| None -> true
54
+
| Some size ->
55
+
exists && (Eio.Path.stat ~follow:true path).size = size
56
+
in
57
+
if exists && correct_size then `Already_exists
58
+
else
59
+
let p, u = Eio.Promise.create ~label:task () in
60
+
Hashtbl.add t.pending task { promise = p; resolver = u };
61
+
(* if broken file, delete it from the cache *)
62
+
if exists then Eio.Path.unlink path;
63
+
let finally () = remove_task t path in
64
+
`Fresh finally)
65
+
66
+
let if_exists t ?size ?(then_ = Fun.id) ?(else_ = Fun.id) file =
67
+
match find_and_add_task t ?size file with
68
+
| `Already_exists -> then_ ()
69
+
| `Fresh finally -> Fun.protect ~finally else_
70
+
| `Pending l ->
71
+
Eio.Promise.await l.promise;
72
+
then_ ()
73
+
74
+
module Blob = struct
75
+
let file t digest =
76
+
let algo = Digest.string_of_algorithm (Digest.algorithm digest) in
77
+
let hash = Digest.encoded_hash digest in
78
+
Eio.Path.(t.root / "blobs" / algo / hash)
79
+
80
+
let if_exists t ~size ?then_ ?else_ digest =
81
+
if_exists t ~size ?then_ ?else_ (file t digest)
82
+
83
+
let add_fd t digest body =
84
+
Eio.Switch.run @@ fun sw ->
85
+
let file = file t digest in
86
+
mkdir_parent file;
87
+
let dst = Eio.Path.open_out ~sw ~create:(`Exclusive 0o644) file in
88
+
Flow.copy body dst
89
+
90
+
let add_string t digest body =
91
+
Eio.Switch.run @@ fun sw ->
92
+
let file = file t digest in
93
+
mkdir_parent file;
94
+
let dst = Eio.Path.open_out ~sw ~create:(`Exclusive 0o644) file in
95
+
let body = Eio.Flow.string_source body in
96
+
try
97
+
Eio.Flow.copy body dst;
98
+
Eio.Flow.close dst
99
+
with e ->
100
+
Eio.Flow.close dst;
101
+
Eio.Path.unlink file;
102
+
raise e
103
+
104
+
let get_string t digest =
105
+
let file = file t digest in
106
+
Eio.Path.with_open_in file Eio.Flow.read_all
107
+
108
+
let get_fd ~sw t digest =
109
+
let file = file t digest in
110
+
Eio.Path.open_in ~sw file
111
+
end
112
+
113
+
module Manifest = struct
114
+
let file t image =
115
+
let org = Image.org image in
116
+
let name = Image.name image in
117
+
let file str = Eio.Path.(t.root / "manifests" / org / name / str) in
118
+
let tag t = file ("tags/" ^ t) in
119
+
let digest d =
120
+
file
121
+
(Fmt.str "digests/%s/%s"
122
+
Digest.(string_of_algorithm (algorithm d))
123
+
(Digest.encoded_hash d))
124
+
in
125
+
match (Image.tag image, Image.digest image) with
126
+
| None, None -> tag "latest"
127
+
| Some t, None -> tag t
128
+
| _, Some d -> digest d
129
+
130
+
let if_exists t ?then_ ?else_ digest =
131
+
if_exists t ?then_ ?else_ (file t digest)
132
+
133
+
exception Invalid_descriptor of Image.t * string * string
134
+
135
+
let add t image m =
136
+
Eio.Switch.run @@ fun sw ->
137
+
let file = file t image in
138
+
mkdir_parent file;
139
+
let src = Manifest.to_string m in
140
+
let dst = Eio.Path.open_out ~sw ~create:(`Exclusive 0o644) file in
141
+
Eio.Flow.copy_string src dst
142
+
143
+
let get t image =
144
+
let file = file t image in
145
+
let str = Eio.Path.with_open_in file Eio.Flow.read_all in
146
+
match Manifest.of_string str with
147
+
| Ok d -> d
148
+
| Error (`Msg e) -> raise (Invalid_descriptor (image, "get/1", e))
149
+
150
+
let tags_of_repo dir full_name =
151
+
let tags = Eio.Path.read_dir Eio.Path.(dir / full_name / "tags") in
152
+
List.map (fun tag -> Image.v ~tag full_name) tags
153
+
154
+
let digests_of_algo algo dir full_name =
155
+
let digests =
156
+
Eio.Path.read_dir Eio.Path.(dir / full_name / "digests" / algo)
157
+
in
158
+
List.map
159
+
(fun digest ->
160
+
match Digest.algorithm_of_string algo with
161
+
| Error (`Msg e) -> failwith e
162
+
| Ok algo ->
163
+
let digest = Digest.unsafe_v algo digest in
164
+
Image.v ~digest full_name)
165
+
digests
166
+
167
+
let digests_of_repo dir full_name =
168
+
let algos = Eio.Path.read_dir Eio.Path.(dir / full_name / "digests") in
169
+
List.map (fun a -> digests_of_algo a dir full_name) algos |> List.flatten
170
+
171
+
let map_repo f t =
172
+
let dir = Eio.Path.(t.root / "manifests") in
173
+
let orgs = Eio.Path.read_dir dir in
174
+
let orgs =
175
+
Eio.Fiber.List.map
176
+
(fun org ->
177
+
let names = Eio.Path.read_dir Eio.Path.(dir / org) in
178
+
List.map
179
+
(fun name ->
180
+
let full_name = Fmt.str "%s/%s" org name in
181
+
f dir full_name)
182
+
names)
183
+
orgs
184
+
in
185
+
List.concat (List.concat orgs)
186
+
187
+
let list_tags t = map_repo tags_of_repo t
188
+
let list_digests t = map_repo digests_of_repo t
189
+
let list t = list_tags t @ list_digests t
190
+
191
+
let guess' t name =
192
+
let digests = list_digests t in
193
+
let matches =
194
+
List.find_all
195
+
(fun i ->
196
+
match Image.digest i with
197
+
| None -> false
198
+
| Some d -> String.starts_with ~prefix:name (Digest.encoded_hash d))
199
+
digests
200
+
in
201
+
match matches with
202
+
| [] -> Image.of_string name
203
+
| [ i ] -> Ok i
204
+
| l ->
205
+
error_msg "%s: ambiguous name; this corresponds to:\n- %a\n" name
206
+
Fmt.(list ~sep:(any "\n- ") Image.pp)
207
+
l
208
+
209
+
let guess t name =
210
+
match guess' t name with Ok i -> i | Error (`Msg e) -> invalid_arg e
211
+
end
+34
src/cache.mli
+34
src/cache.mli
···
1
+
open Optint
2
+
open Oci_spec
3
+
4
+
type t
5
+
6
+
val v : [ `Dir ] Eio.Path.t -> t
7
+
val init : t -> unit
8
+
9
+
module Blob : sig
10
+
val if_exists :
11
+
t ->
12
+
size:Int63.t ->
13
+
?then_:(unit -> unit) ->
14
+
?else_:(unit -> unit) ->
15
+
Digest.t ->
16
+
unit
17
+
18
+
val add_fd : t -> Digest.t -> Eio.Flow.source_ty Flow.t -> unit
19
+
val get_fd : sw:Eio.Switch.t -> t -> Digest.t -> Eio.File.ro_ty Eio.Resource.t
20
+
val add_string : t -> Digest.t -> string -> unit
21
+
val get_string : t -> Digest.t -> string
22
+
end
23
+
24
+
module Manifest : sig
25
+
val if_exists :
26
+
t -> ?then_:(unit -> unit) -> ?else_:(unit -> unit) -> Image.t -> unit
27
+
28
+
val get : t -> Image.t -> Manifest.t
29
+
val add : t -> Image.t -> Manifest.t -> unit
30
+
val list : t -> Image.t list
31
+
val list_tags : t -> Image.t list
32
+
val list_digests : t -> Image.t list
33
+
val guess : t -> string -> Image.t
34
+
end
+123
src/checkout.ml
+123
src/checkout.ml
···
1
+
open Oci_spec
2
+
3
+
(* FIXME: code duplication *)
4
+
let ( let* ) x f = match x with Ok x -> f x | Error e -> Error e
5
+
let ( let+ ) x f = match x with Ok x -> Ok (f x) | Error e -> Error e
6
+
let sizes = [| "B"; "KiB"; "MiB"; "GiB"; "TiB"; "PiB"; "EiB"; "ZiB"; "YiB" |]
7
+
let ( / ) = Eio.Path.( / )
8
+
let mkdirs dir = Eio.Path.mkdirs ~exists_ok:true ~perm:0o700 dir
9
+
10
+
let mkdir_parent file =
11
+
match Eio.Path.split file with
12
+
| None -> ()
13
+
| Some (parent, _) -> mkdirs parent
14
+
15
+
let bytes_to_size ?(decimals = 2) ppf = function
16
+
| 0L -> Format.fprintf ppf "0 byte"
17
+
| n ->
18
+
let n = Int64.to_float n in
19
+
let i = Float.floor (Float.log n /. Float.log 1024.) in
20
+
let r = n /. Float.pow 1024. i in
21
+
Format.fprintf ppf "%.*f %s" decimals r sizes.(int_of_float i)
22
+
23
+
let fold_gzipped f src init =
24
+
Tar_eio.run (Tar_gz.in_gzipped (Tar.fold f init)) src
25
+
26
+
let checkout_layer ~sw ~cache layer dir =
27
+
let fd = Cache.Blob.get_fd ~sw cache layer in
28
+
Fmt.epr "Extracting layer %a:\n%!" Digest.pp layer;
29
+
let f ?global:_ hdr () =
30
+
let open Tar.Syntax in
31
+
let path = dir / hdr.Tar.Header.file_name in
32
+
mkdir_parent path;
33
+
let file_mode = 0o777 land hdr.Tar.Header.file_mode in
34
+
match hdr.Tar.Header.link_indicator with
35
+
| Directory ->
36
+
Eio.Path.mkdir ~perm:file_mode path;
37
+
Tar.return (Ok ())
38
+
| Symbolic ->
39
+
Eio.Path.symlink ~link_to:hdr.Tar.Header.link_name path;
40
+
Tar.return (Ok ())
41
+
| _ ->
42
+
let file_size = Int64.to_int hdr.Tar.Header.file_size in
43
+
if file_size > 0 then begin
44
+
let* contents = Tar.really_read file_size in
45
+
Eio.Path.save ~create:(`If_missing file_mode) path contents;
46
+
Tar.return (Ok ())
47
+
end
48
+
else begin
49
+
Eio.Path.save ~create:(`If_missing file_mode) path "";
50
+
Tar.return (Ok ())
51
+
end
52
+
in
53
+
match fold_gzipped f (Tar_eio.Flow fd) () with
54
+
| Ok () -> ()
55
+
| Error (`Fatal e) -> Fmt.failwith "Tar error: %a" Tar.pp_error e
56
+
| Error `Eof -> failwith "Unexpected end of file in tar archive"
57
+
| Error (`Gz msg) -> Fmt.failwith "Gzip error: %s" msg
58
+
| Error `Unexpected_end_of_file -> failwith "Unexpected end of file"
59
+
60
+
let checkout_layers ~sw ~cache ~dir layers =
61
+
List.iteri
62
+
(fun i layer ->
63
+
let dir = Eio.Path.(dir / string_of_int i) in
64
+
let d = Descriptor.digest layer in
65
+
checkout_layer ~sw ~cache d dir)
66
+
layers
67
+
68
+
let checkout_docker_manifest ~sw ~cache ~dir m =
69
+
checkout_layers ~sw ~cache ~dir (Manifest.Docker.layers m)
70
+
71
+
let checkout_oci_manifest ~sw ~cache ~dir m =
72
+
checkout_layers ~sw ~cache ~dir (Manifest.OCI.layers m)
73
+
74
+
let checkout_docker_manifests ~sw ~cache ~dir img ds =
75
+
let ms =
76
+
List.map
77
+
(fun d ->
78
+
let digest = Descriptor.digest d in
79
+
let img = Image.v ~digest img in
80
+
let manifest = Cache.Manifest.get cache img in
81
+
match manifest with
82
+
| `Docker_manifest mani -> mani
83
+
| _ -> failwith "Exptected single docker manifest")
84
+
ds
85
+
in
86
+
List.iteri
87
+
(fun i m ->
88
+
let dir = dir / string_of_int i in
89
+
checkout_docker_manifest ~sw ~cache ~dir m)
90
+
ms
91
+
92
+
let checkout_oci_manifests ~sw ~cache ~dir ds =
93
+
let ms =
94
+
List.map
95
+
(fun d ->
96
+
let digest = Descriptor.digest d in
97
+
let str = Cache.Blob.get_string cache digest in
98
+
match Manifest.OCI.of_string str with
99
+
| Ok m -> m
100
+
| Error (`Msg e) -> failwith e)
101
+
ds
102
+
in
103
+
List.iteri
104
+
(fun i m ->
105
+
let dir = dir / string_of_int i in
106
+
checkout_oci_manifest ~sw ~cache ~dir m)
107
+
ms
108
+
109
+
let checkout_docker_manifest_list ~sw ~cache ~dir img l =
110
+
checkout_docker_manifests ~sw ~cache ~dir img (Manifest_list.manifests l)
111
+
112
+
let checkout_oci_index ~sw ~cache ~dir i =
113
+
checkout_oci_manifests ~sw ~cache ~dir (Index.manifests i)
114
+
115
+
let checkout ~cache ~root i =
116
+
let dir = root / Image.to_string i in
117
+
Eio.Switch.run @@ fun sw ->
118
+
match Cache.Manifest.get cache i with
119
+
| `Docker_manifest m -> checkout_docker_manifest ~sw ~cache ~dir m
120
+
| `Docker_manifest_list m ->
121
+
checkout_docker_manifest_list ~sw ~cache ~dir (Image.repository i) m
122
+
| `OCI_index i -> checkout_oci_index ~sw ~cache ~dir i
123
+
| `OCI_manifest m -> checkout_oci_manifest ~sw ~cache ~dir m
+151
src/display.ml
+151
src/display.ml
···
1
+
module Int63 = Optint.Int63
2
+
open Oci_spec
3
+
4
+
(* FIXME: the None type is probably not needed with switch cancellation *)
5
+
type t = {
6
+
stream : (unit -> unit) option Eio.Stream.t;
7
+
display : ((unit -> unit) -> unit, unit) Progress.Display.t;
8
+
}
9
+
10
+
type line = Int63.t Progress.Line.t
11
+
12
+
type reporter = {
13
+
stream : (unit -> unit) option Eio.Stream.t;
14
+
reporter : Int63.t Progress.Reporter.t option;
15
+
}
16
+
17
+
let report r i =
18
+
match r.reporter with
19
+
| None -> ()
20
+
| Some reporter ->
21
+
Eio.Stream.add r.stream
22
+
(Some (fun () -> Progress.Reporter.report reporter i))
23
+
24
+
let report_int r i = report r (Int63.of_int i)
25
+
26
+
let line ~color ~total message =
27
+
let message = String.sub message 0 (min 21 (String.length message)) in
28
+
let open Progress.Line.Using_int63 in
29
+
list
30
+
[
31
+
rpad 22 (const message);
32
+
bytes;
33
+
bytes_per_sec;
34
+
bar ~color ~style:`UTF8 total;
35
+
percentage_of total ++ const " ";
36
+
]
37
+
38
+
let colors =
39
+
let a =
40
+
[
41
+
"#1996f3";
42
+
"#06aeed";
43
+
"#10c6e6";
44
+
"#27dade";
45
+
"#3dead5";
46
+
"#52f5cb";
47
+
"#66fcc2";
48
+
"#7dffb6";
49
+
"#92fda9";
50
+
"#a8f79c";
51
+
"#bced8f";
52
+
"#d2de81";
53
+
"#e8cb72";
54
+
"#feb562";
55
+
"#ff9b52";
56
+
"#ff8143";
57
+
"#ff6232";
58
+
"#ff4121";
59
+
]
60
+
in
61
+
Array.map Progress.Color.hex (Array.of_list (a @ List.rev a))
62
+
63
+
let next_color i = colors.(i mod Array.length colors)
64
+
65
+
let line_of_descriptor d i =
66
+
let total = Descriptor.size d in
67
+
let color = next_color i in
68
+
let txt =
69
+
let digest = Digest.encoded_hash (Descriptor.digest d) in
70
+
let ty =
71
+
match Descriptor.media_type d with
72
+
| Docker Image_manifest_list | OCI Image_index -> "index:"
73
+
| Docker Image_manifest | OCI Image_manifest -> "manifest:"
74
+
| OCI Image_config | Docker Image_config -> "config:"
75
+
| OCI
76
+
( Layer_tar | Layer_tar_gzip | Layer_tar_zstd
77
+
| Layer_non_distributable_tar | Layer_non_distributable_tar_gzip
78
+
| Layer_non_distributable_tar_zstd )
79
+
| Docker (Layer_tar_gzip | Layer_non_distributable_tar_gzip) ->
80
+
"layer:"
81
+
| Docker Plugin_config -> "plugin:"
82
+
| OCI Trust -> "trust:"
83
+
| _ -> "?:"
84
+
in
85
+
ty ^ digest
86
+
in
87
+
line ~color ~total txt
88
+
89
+
let line_of_image i n =
90
+
let color = next_color n in
91
+
let image =
92
+
match (Image.tag i, Image.digest i) with
93
+
| None, None -> Image.with_tag "latest" i
94
+
| _ -> i
95
+
in
96
+
let name = Image.to_string image in
97
+
line ~color ~total:(Int63.of_int 100) name
98
+
99
+
let rec apply_stream ~sw stream =
100
+
Eio.Switch.check sw;
101
+
match Eio.Stream.take stream with
102
+
| Some f ->
103
+
f ();
104
+
apply_stream ~sw stream
105
+
| None -> ()
106
+
107
+
let init ?platform ~sw image : t =
108
+
let image_name =
109
+
Progress.Line.(
110
+
spacer 4
111
+
++ constf "🐫 Fetching %a" Fmt.(styled `Bold Image.pp) image
112
+
++
113
+
match platform with
114
+
| None -> const ""
115
+
| Some p -> constf "%a" Fmt.(styled `Faint (brackets string)) p)
116
+
in
117
+
let stream = Eio.Stream.create max_int in
118
+
let display = Progress.Display.start Progress.Multi.(line image_name) in
119
+
Eio.Fiber.fork ~sw (fun () -> apply_stream ~sw stream);
120
+
{ stream; display }
121
+
122
+
let rec empty_stream stream =
123
+
match Eio.Stream.take_nonblocking stream with
124
+
| None | Some None -> ()
125
+
| Some (Some f) ->
126
+
f ();
127
+
empty_stream stream
128
+
129
+
let finalise { stream; display } =
130
+
Eio.Stream.add stream None;
131
+
empty_stream stream;
132
+
Progress.Display.finalise display
133
+
134
+
let lines = ref 0
135
+
136
+
let with_line ~display ?(show = true) bar f =
137
+
let reporter =
138
+
if show then (
139
+
let r = Progress.Display.add_line display.display (bar !lines) in
140
+
incr lines;
141
+
Some r)
142
+
else None
143
+
in
144
+
let finally () =
145
+
match reporter with
146
+
| None -> ()
147
+
| Some r ->
148
+
Eio.Stream.add display.stream
149
+
(Some (fun () -> Progress.Reporter.finalise r))
150
+
in
151
+
Fun.protect ~finally (fun () -> f { reporter; stream = display.stream })
+16
src/display.mli
+16
src/display.mli
···
1
+
open Optint
2
+
3
+
type t
4
+
type line
5
+
type reporter
6
+
7
+
val report : reporter -> Int63.t -> unit
8
+
val report_int : reporter -> int -> unit
9
+
val init : ?platform:string -> sw:Eio.Switch.t -> Image.t -> t
10
+
val finalise : t -> unit
11
+
val line : color:Terminal.Color.t -> total:Int63.t -> string -> line
12
+
val line_of_descriptor : Oci_spec.Descriptor.t -> int -> line
13
+
val line_of_image : Image.t -> int -> line
14
+
15
+
val with_line :
16
+
display:t -> ?show:bool -> (int -> line) -> (reporter -> 'b) -> 'b
+14
src/dune
+14
src/dune
+320
src/fetch.ml
+320
src/fetch.ml
···
1
+
open Oci_spec
2
+
open Optint
3
+
4
+
(** HTTP client type using GADT for existential type parameters *)
5
+
type client =
6
+
| Client : { net : 'a Eio.Net.t; clock : 'b Eio.Time.clock } -> client
7
+
8
+
let create_client ~net ~clock = Client { net; clock }
9
+
10
+
module API = struct
11
+
let registry_base = "https://registry-1.docker.io"
12
+
let auth_base = "https://auth.docker.io"
13
+
14
+
type response = {
15
+
content_type : Media_type.t;
16
+
content_length : Int63.t option;
17
+
content_digest : Digest.t option;
18
+
body : Eio.Flow.source_ty Eio.Resource.t;
19
+
}
20
+
21
+
let call_get (Client { net; clock }) ~sw ?(accept = []) ?token url out =
22
+
Logs.debug (fun l -> l "GET %s\n%!" url);
23
+
let headers =
24
+
let h = Requests.Headers.empty in
25
+
let h =
26
+
match token with
27
+
| Some token -> Requests.Headers.bearer token h
28
+
| None -> h
29
+
in
30
+
List.fold_left
31
+
(fun h m -> Requests.Headers.add `Accept (Media_type.to_string m) h)
32
+
h accept
33
+
in
34
+
let resp = Requests.One.get ~sw ~clock ~net ~headers url in
35
+
if not (Requests.Response.ok resp) then
36
+
Fmt.failwith "@[<v2>%s error: %d@,%s@]" url
37
+
(Requests.Response.status_code resp)
38
+
(Requests.Response.text resp);
39
+
let content_type =
40
+
match Requests.Response.header_string "Content-Type" resp with
41
+
| Some m -> (
42
+
match Media_type.of_string m with
43
+
| Ok m -> m
44
+
| Error (`Msg e) -> Fmt.failwith "invalid content-type: %s - %s" m e)
45
+
| None -> failwith "missing content-type"
46
+
in
47
+
let content_length =
48
+
match Requests.Response.content_length resp with
49
+
| Some l -> Some (Int63.of_int64 l)
50
+
| None -> None
51
+
in
52
+
let content_digest =
53
+
match Requests.Response.header_string "Docker-Content-Digest" resp with
54
+
| Some s -> (
55
+
match Digest.of_string s with
56
+
| Ok s -> Some s
57
+
| Error (`Msg e) -> Fmt.failwith "%s: invalid digest header: %s" s e)
58
+
| None -> None
59
+
in
60
+
let body = Requests.Response.body resp in
61
+
out { content_length; content_type; content_digest; body }
62
+
63
+
let call_post (Client { net; clock }) ~sw url out =
64
+
Logs.debug (fun l -> l "POST %s\n%!" url);
65
+
let resp = Requests.One.post ~sw ~clock ~net url in
66
+
if not (Requests.Response.ok resp) then
67
+
Fmt.failwith "@[<v2>%s error: %d@,%s@]" url
68
+
(Requests.Response.status_code resp)
69
+
(Requests.Response.text resp);
70
+
let body = Requests.Response.body resp in
71
+
out
72
+
{
73
+
content_length = None;
74
+
content_type = OCI Empty;
75
+
content_digest = None;
76
+
body;
77
+
}
78
+
79
+
let get client ~sw ?accept ?token url out =
80
+
call_get client ~sw ?accept ?token url out
81
+
82
+
let post client ~sw url out = call_post client ~sw url out
83
+
84
+
let get_content_length = function
85
+
| None -> failwith "missing content-length headers"
86
+
| Some s -> s
87
+
88
+
let get_content_digest = function
89
+
| None -> failwith "missing content-digest headers"
90
+
| Some s -> s
91
+
92
+
let manifest_of_fd src =
93
+
match Manifest.of_string (Flow.read_all src) with
94
+
| Ok m -> m
95
+
| Error (`Msg e) -> Fmt.failwith "Fetch.manifest_of_string: %s" e
96
+
97
+
let get_manifest client ~progress ~token image =
98
+
Eio.Switch.run @@ fun sw ->
99
+
let name = Image.repository image in
100
+
let reference = Image.reference image in
101
+
let url = Fmt.str "%s/v2/%s/manifests/%s" registry_base name reference in
102
+
let out { content_length; content_type; content_digest; body; _ } =
103
+
let length = get_content_length content_length in
104
+
let digest = get_content_digest content_digest in
105
+
let fd = Flow.source ~progress ~length ~digest body in
106
+
let m = manifest_of_fd fd in
107
+
assert (content_type = Manifest.media_type m);
108
+
m
109
+
in
110
+
111
+
let accept =
112
+
Media_type.
113
+
[
114
+
Docker Image_manifest;
115
+
Docker Image_manifest_list;
116
+
OCI Image_index;
117
+
OCI Image_manifest;
118
+
]
119
+
in
120
+
get client ~accept ~token ~sw url out
121
+
122
+
let get_blob client ~sw ~progress ~token image d =
123
+
let size = Descriptor.size d in
124
+
let digest = Descriptor.digest d in
125
+
let name = Image.repository image in
126
+
let url = Fmt.str "%s/v2/%s/blobs/%a" registry_base name Digest.pp digest in
127
+
let out { content_length; content_digest; body; _ } =
128
+
let content_length = get_content_length content_length in
129
+
let () =
130
+
if size <> content_length then failwith "invalid length header";
131
+
match content_digest with
132
+
| None -> ()
133
+
| Some d -> if digest <> d then failwith "invalid digest header"
134
+
in
135
+
Flow.source ~progress ~length:content_length ~digest body
136
+
in
137
+
get client ~sw ~token url out
138
+
139
+
type credential = { username : string; password : string }
140
+
141
+
let get_token client ?credentials image =
142
+
Eio.Switch.run @@ fun sw ->
143
+
let name = Image.repository image in
144
+
let queries =
145
+
[
146
+
("service", [ "registry.docker.io" ]);
147
+
("client_id", [ "image" ]);
148
+
("scope", [ "repository:" ^ name ^ ":pull" ]);
149
+
]
150
+
in
151
+
let extra_queries =
152
+
match credentials with
153
+
| None -> []
154
+
| Some { username; password } ->
155
+
[
156
+
("grant_type", [ "password" ]);
157
+
("username", [ username ]);
158
+
("password", [ password ]);
159
+
]
160
+
in
161
+
let queries = Uri.encoded_of_query (queries @ extra_queries) in
162
+
let url = Fmt.str "%s/token?%s" auth_base queries in
163
+
let out { body; _ } =
164
+
let body = Eio.Flow.read_all body in
165
+
match Auth.of_string body with
166
+
| Ok t -> Auth.token t
167
+
| Error (`Msg e) ->
168
+
Fmt.failwith "@[<v2>%s parsing errors: %s@]" auth_base e
169
+
in
170
+
match credentials with
171
+
| None -> get client ~sw url out
172
+
| Some _ -> post client ~sw url out
173
+
end
174
+
175
+
type t = {
176
+
display : Display.t;
177
+
client : client;
178
+
cache : Cache.t;
179
+
token : string;
180
+
image : Image.t;
181
+
}
182
+
183
+
let show_blob d =
184
+
match Descriptor.media_type d with
185
+
| OCI
186
+
( Layer_tar | Layer_tar_gzip | Layer_tar_zstd
187
+
| Layer_non_distributable_tar | Layer_non_distributable_tar_gzip
188
+
| Layer_non_distributable_tar_zstd )
189
+
| Docker (Layer_tar_gzip | Layer_non_distributable_tar_gzip) ->
190
+
true
191
+
| _ -> false
192
+
193
+
let get_blob ?(show = true) ~sw t d =
194
+
let size = Descriptor.size d in
195
+
let digest = Descriptor.digest d in
196
+
let show = show && show_blob d in
197
+
let () =
198
+
Cache.Blob.if_exists t.cache ~size digest
199
+
~then_:(fun () ->
200
+
Logs.info (fun l ->
201
+
l "Blob %a is already in the cache" Digest.pp digest);
202
+
())
203
+
~else_:(fun () ->
204
+
let bar = Display.line_of_descriptor d in
205
+
Display.with_line ~show ~display:t.display bar (fun r ->
206
+
let progress = Display.report_int r in
207
+
Eio.Switch.run @@ fun sw ->
208
+
let fd =
209
+
API.get_blob ~sw t.client ~progress ~token:t.token t.image d
210
+
in
211
+
Cache.Blob.add_fd t.cache digest fd))
212
+
in
213
+
Cache.Blob.get_fd ~sw t.cache digest
214
+
215
+
let get_root_manifest ?(show = true) t =
216
+
Cache.Manifest.if_exists t.cache t.image
217
+
~then_:(fun () ->
218
+
Logs.info (fun l ->
219
+
l "Manifest %a is already in the cache" Image.pp t.image))
220
+
~else_:(fun () ->
221
+
let line = Display.line_of_image t.image in
222
+
Display.with_line ~show ~display:t.display line @@ fun r ->
223
+
let progress = Display.report_int r in
224
+
let m = API.get_manifest t.client ~progress ~token:t.token t.image in
225
+
Cache.Manifest.add t.cache t.image m);
226
+
Cache.Manifest.get t.cache t.image
227
+
228
+
let get_manifest ?(show = false) t d =
229
+
let digest = Descriptor.digest d in
230
+
let image = Image.with_digest digest t.image in
231
+
let size = Descriptor.size d in
232
+
let line = Display.line_of_descriptor d in
233
+
Display.with_line ~show ~display:t.display line (fun r ->
234
+
Cache.Manifest.if_exists t.cache image
235
+
~then_:(fun () ->
236
+
Logs.info (fun l ->
237
+
l "Manifest %a is already in the cache" Digest.pp digest);
238
+
Display.report r size)
239
+
~else_:(fun () ->
240
+
let progress = Display.report_int r in
241
+
let m = API.get_manifest t.client ~progress ~token:t.token image in
242
+
Cache.Manifest.add t.cache image m));
243
+
Cache.Manifest.get t.cache image
244
+
245
+
let fetch ?(show_progress = true) ?platform ~cache ~client ~domain_mgr:_
246
+
?username ?password image =
247
+
Eio.Switch.run @@ fun sw ->
248
+
let display = Display.init ?platform ~sw image in
249
+
let credentials =
250
+
match (username, password) with
251
+
| None, _ -> None
252
+
| Some u, Some p -> Some { API.username = u; password = p }
253
+
| Some u, _ ->
254
+
Fmt.invalid_arg
255
+
"missing credentials for user %s. Use `-p' or set IMAGE_TOKEN." u
256
+
in
257
+
let token = API.get_token client ?credentials image in
258
+
let t = { token; display; cache; client; image } in
259
+
let platform =
260
+
match platform with
261
+
| None -> None
262
+
| Some p -> (
263
+
match Platform.of_string p with
264
+
| Ok p -> Some p
265
+
| Error (`Msg e) -> Fmt.failwith "Fetch.fetch: %s" e)
266
+
in
267
+
let my_platform = platform in
268
+
(* let pool =
269
+
Eio.Executor_pool.create ~sw ~domain_count:4 ~domain_concurrency:25
270
+
domain_mgr
271
+
in
272
+
let get_blob t d =
273
+
Eio.Executor_pool.submit_exn pool (fun () ->
274
+
Eio.Switch.run @@ fun sw -> get_blob ~sw t d)
275
+
in
276
+
*)
277
+
let get_blob t d =
278
+
Eio.Switch.run @@ fun sw -> get_blob ~show:show_progress t ~sw d
279
+
in
280
+
let get_manifest t d = get_manifest ~show:show_progress t d in
281
+
let rec fetch_manifest_descriptor d =
282
+
let platform = Descriptor.platform d in
283
+
let manifest = get_manifest t d in
284
+
fetch_manifest ~platform manifest
285
+
and fetch_layers ~platform config layers =
286
+
match (my_platform, platform) with
287
+
| Some p, Some p' when p <> p' ->
288
+
(* Fmt.epr "XXX SKIP platform=%a\n%!" Platform.pp p'; *)
289
+
()
290
+
| _ ->
291
+
let _config = get_blob t config in
292
+
let _layers = Eio.Fiber.List.map (get_blob t) layers in
293
+
(* Fmt.epr "XXX CONFIG=%a\n%!" pp config; *)
294
+
(* List.iter (fun l -> Fmt.epr "XXX LAYER=%a\n" pp l) layers) *)
295
+
()
296
+
and fetch_descriptors ds =
297
+
Logs.info (fun l ->
298
+
let platforms = List.filter_map Descriptor.platform ds in
299
+
l "supported platforms: %a" Fmt.Dump.(list Platform.pp) platforms);
300
+
Eio.Fiber.List.iter fetch_manifest_descriptor ds
301
+
and fetch_manifest ~platform = function
302
+
| `Docker_manifest m ->
303
+
let config = Manifest.Docker.config m in
304
+
let layers = Manifest.Docker.layers m in
305
+
fetch_layers ~platform config layers
306
+
| `Docker_manifest_list m ->
307
+
let ds = Manifest_list.manifests m in
308
+
fetch_descriptors ds
309
+
| `OCI_index i ->
310
+
let ds = Index.manifests i in
311
+
fetch_descriptors ds
312
+
| `OCI_manifest m ->
313
+
let config = Manifest.OCI.config m in
314
+
let layers = Manifest.OCI.layers m in
315
+
fetch_layers ~platform config layers
316
+
in
317
+
318
+
let root = get_root_manifest ~show:show_progress t in
319
+
fetch_manifest ~platform root;
320
+
Display.finalise display
+16
src/fetch.mli
+16
src/fetch.mli
···
1
+
type client
2
+
(** HTTP client for registry operations. *)
3
+
4
+
val create_client : net:_ Eio.Net.t -> clock:_ Eio.Time.clock -> client
5
+
(** [create_client ~net ~clock] creates an HTTP client for registry access. *)
6
+
7
+
val fetch :
8
+
?show_progress:bool ->
9
+
?platform:string ->
10
+
cache:Cache.t ->
11
+
client:client ->
12
+
domain_mgr:Eio.Domain_manager.ty Eio.Resource.t ->
13
+
?username:string ->
14
+
?password:string ->
15
+
Image.t ->
16
+
unit
+136
src/flow.ml
+136
src/flow.ml
···
1
+
open Optint
2
+
open Oci_spec
3
+
4
+
module Progress = struct
5
+
type t = { flow : Eio.Flow.source_ty Eio.Resource.t; progress : int -> unit }
6
+
7
+
let read_methods = []
8
+
9
+
let single_read (t : t) buf =
10
+
let i = Eio.Flow.single_read t.flow buf in
11
+
t.progress i;
12
+
i
13
+
end
14
+
15
+
module Digest = struct
16
+
type t = {
17
+
flow : Eio.Flow.source_ty Eio.Resource.t;
18
+
feed : ?off:int -> ?len:int -> Cstruct.t -> unit;
19
+
length : Int63.t;
20
+
read : Int63.t ref;
21
+
}
22
+
23
+
let read_methods = []
24
+
25
+
let finalise ctx =
26
+
(* FIXME: make it work for SHA512 too *)
27
+
let hash = Digestif.SHA256.(get !ctx) in
28
+
let hex = Digestif.SHA256.(to_hex hash) in
29
+
Digest.sha256 hex
30
+
31
+
(* FIXME: catch End_of_file and verify finalise here
32
+
to make it full transparent *)
33
+
let single_read (t : t) buf =
34
+
let i = Eio.Flow.single_read t.flow buf in
35
+
t.read := Int63.add !(t.read) (Int63.of_int i);
36
+
if !(t.read) > t.length then failwith "stream too long";
37
+
t.feed ~off:0 ~len:i buf;
38
+
i
39
+
end
40
+
41
+
module Gzip = struct
42
+
type state = Read | Flush of int
43
+
44
+
type t = {
45
+
flow : Eio.Flow.source_ty Eio.Resource.t;
46
+
mutable decoder : Gz.Inf.decoder;
47
+
i : De.bigstring;
48
+
o : De.bigstring;
49
+
mutable state : state;
50
+
}
51
+
52
+
let read_methods = []
53
+
54
+
let rec single_read t buf =
55
+
match t.state with
56
+
| Flush rem ->
57
+
let off = De.bigstring_length t.o - rem in
58
+
let len = min rem (Cstruct.length buf) in
59
+
Cstruct.blit (Cstruct.of_bigarray t.o) off buf 0 len;
60
+
let rem = rem - len in
61
+
if rem = 0 then (
62
+
let decoder = Gz.Inf.flush t.decoder in
63
+
t.decoder <- decoder;
64
+
t.state <- Read)
65
+
else t.state <- Flush rem;
66
+
len
67
+
| Read -> (
68
+
match Gz.Inf.decode t.decoder with
69
+
| `Await decoder ->
70
+
let i = Eio.Flow.single_read t.flow (Cstruct.of_bigarray t.i) in
71
+
let decoder = Gz.Inf.src decoder t.i 0 i in
72
+
t.decoder <- decoder;
73
+
single_read t buf
74
+
| `Flush decoder ->
75
+
t.state <- Flush (De.bigstring_length t.o - Gz.Inf.dst_rem decoder);
76
+
single_read t buf
77
+
| `Malformed err -> Fmt.failwith "Gzip.single_read: Error %s" err
78
+
| `End decoder ->
79
+
t.state <- Flush (De.io_buffer_size - Gz.Inf.dst_rem decoder);
80
+
single_read t buf)
81
+
end
82
+
83
+
type 'a t = { finalise : unit -> unit; flow : 'a Eio.Resource.t }
84
+
85
+
let progress_handler = Eio.Flow.Pi.source (module Progress)
86
+
let digest_handler = Eio.Flow.Pi.source (module Digest)
87
+
let gzip_handler = Eio.Flow.Pi.source (module Gzip)
88
+
89
+
let with_progress ~progress flow =
90
+
Eio.Resource.T (Progress.{ flow; progress }, progress_handler)
91
+
92
+
type ctx = {
93
+
ctx : Digestif.SHA256.ctx ref;
94
+
read : Int63.t ref;
95
+
length : Int63.t;
96
+
}
97
+
98
+
let ctx ~length =
99
+
(* FIXME: make it work for SHA512 too *)
100
+
let ctx = ref (Digestif.SHA256.init ()) in
101
+
let read = ref Int63.zero in
102
+
{ ctx; read; length }
103
+
104
+
let with_digest ~ctx:{ ctx; read; length } flow =
105
+
(* FIXME: make it work for SHA512 too *)
106
+
let feed ?off ?len buf =
107
+
let arr = Cstruct.to_bigarray buf in
108
+
ctx := Digestif.SHA256.feed_bigstring !ctx ?off ?len arr
109
+
in
110
+
Eio.Resource.T (Digest.{ flow; feed; length; read }, digest_handler)
111
+
112
+
let with_gzip flow =
113
+
let i = De.bigstring_create De.io_buffer_size in
114
+
let o = De.bigstring_create De.io_buffer_size in
115
+
let decoder = Gz.Inf.decoder `Manual ~o in
116
+
let flow = (flow :> Eio.Flow.source_ty Eio.Resource.t) in
117
+
Eio.Resource.T (Gzip.{ flow; decoder; i; o; state = Read }, gzip_handler)
118
+
119
+
let source ~progress ~length ~digest flow =
120
+
let ctx = ctx ~length in
121
+
let flow = flow |> with_digest ~ctx |> with_progress ~progress in
122
+
let finalise () =
123
+
if !(ctx.read) <> length then failwith "invalid length";
124
+
let d = Digest.finalise ctx.ctx in
125
+
if d <> digest then failwith "invalid digest"
126
+
in
127
+
{ finalise; flow }
128
+
129
+
let read_all { finalise; flow } =
130
+
let str = Eio.Flow.read_all flow in
131
+
finalise ();
132
+
str
133
+
134
+
let copy { finalise; flow } dst =
135
+
Eio.Flow.copy flow dst;
136
+
finalise ()
+32
src/flow.mli
+32
src/flow.mli
···
1
+
open Optint
2
+
open Oci_spec
3
+
4
+
type 'a t
5
+
6
+
val source :
7
+
progress:(int -> unit) ->
8
+
length:Int63.t ->
9
+
digest:Digest.t ->
10
+
Eio.Flow.source_ty Eio.Resource.t ->
11
+
Eio.Flow.source_ty t
12
+
13
+
val copy : Eio.Flow.source_ty t -> [> Eio.Flow.sink_ty ] Eio.Resource.t -> unit
14
+
val read_all : Eio.Flow.source_ty t -> string
15
+
16
+
(** Flow wrappers *)
17
+
18
+
type ctx
19
+
20
+
val ctx : length:Int63.t -> ctx
21
+
22
+
val with_digest :
23
+
ctx:ctx ->
24
+
Eio.Flow.source_ty Eio.Resource.t ->
25
+
Eio.Flow.source_ty Eio.Resource.t
26
+
27
+
val with_progress :
28
+
progress:(int -> unit) ->
29
+
Eio.Flow.source_ty Eio.Resource.t ->
30
+
Eio.Flow.source_ty Eio.Resource.t
31
+
32
+
val with_gzip : 'a Eio.Flow.source -> Eio.Flow.source_ty Eio.Resource.t
+72
src/image.ml
+72
src/image.ml
···
1
+
open Oci_spec
2
+
open Astring
3
+
4
+
(* TODO: remove code duplication *)
5
+
let ( let* ) x f = match x with Ok x -> f x | Error e -> Error e
6
+
let ( let+ ) x f = match x with Ok x -> Ok (f x) | Error e -> Error e
7
+
let error_msg fmt = Fmt.kstr (fun s -> Error (`Msg s)) fmt
8
+
9
+
type t = {
10
+
org : string option;
11
+
name : string;
12
+
tag : string option;
13
+
digest : Digest.t option;
14
+
}
15
+
16
+
let digest t = t.digest
17
+
let tag t = t.tag
18
+
let org t = match t.org with None -> "library" | Some o -> o
19
+
let name t = t.name
20
+
let repository t = org t ^ "/" ^ t.name
21
+
22
+
let reference t =
23
+
match (t.tag, t.digest) with
24
+
| Some t, None -> t
25
+
| _, Some t -> Digest.to_string t
26
+
| None, None -> assert false
27
+
28
+
let of_string str =
29
+
let* str, digest =
30
+
match String.cut ~sep:"@" str with
31
+
| None -> Ok (str, None)
32
+
| Some (path, digest) ->
33
+
let+ digest = Digest.of_string digest in
34
+
(path, Some digest)
35
+
in
36
+
let str, tag =
37
+
match String.cut ~sep:":" str with
38
+
| None -> (str, None)
39
+
| Some (p, o) -> (p, Some o)
40
+
in
41
+
let org, name =
42
+
match String.cut ~sep:"/" str with
43
+
| None -> (None, str)
44
+
| Some (p, i) -> (Some p, i)
45
+
in
46
+
if name = "sha265" then error_msg "missing image name"
47
+
else
48
+
let tag =
49
+
match (tag, digest) with None, None -> Some "latest" | _ -> tag
50
+
in
51
+
Ok { org; name; tag; digest }
52
+
53
+
let v ?digest ?tag n =
54
+
match of_string n with
55
+
| Ok image -> { image with digest; tag }
56
+
| Error (`Msg e) -> Fmt.invalid_arg "Image.v(%s): error %s" n e
57
+
58
+
let pp ppf t =
59
+
let pp_org ppf = function
60
+
| None | Some "library" -> ()
61
+
| Some s -> Fmt.pf ppf "%s/" s
62
+
in
63
+
let pp_tag ppf = function None -> () | Some s -> Fmt.pf ppf ":%s" s in
64
+
let pp_digest ppf = function
65
+
| None -> ()
66
+
| Some s -> Fmt.pf ppf "@%a" Digest.pp s
67
+
in
68
+
Fmt.pf ppf "%a%s%a%a" pp_org t.org t.name pp_tag t.tag pp_digest t.digest
69
+
70
+
let to_string = Fmt.to_to_string pp
71
+
let with_tag tag t = { t with tag = Some tag }
72
+
let with_digest d t = { t with digest = Some d }
+21
src/image.mli
+21
src/image.mli
···
1
+
open Oci_spec
2
+
3
+
type t
4
+
5
+
val v : ?digest:Digest.t -> ?tag:string -> string -> t
6
+
(** [v repository] *)
7
+
8
+
val pp : t Fmt.t
9
+
val to_string : t -> string
10
+
val of_string : string -> (t, [ `Msg of string ]) result
11
+
val reference : t -> string
12
+
val org : t -> string
13
+
val name : t -> string
14
+
15
+
val repository : t -> string
16
+
(** [repository t] is [org t ^ "/" ^ name t] *)
17
+
18
+
val digest : t -> Digest.t option
19
+
val tag : t -> string option
20
+
val with_tag : string -> t -> t
21
+
val with_digest : Digest.t -> t -> t
+77
src/ls.ml
+77
src/ls.ml
···
1
+
open Oci_spec
2
+
open Optint
3
+
4
+
type t = {
5
+
repository : string;
6
+
tags : string list;
7
+
digest : Digest.t;
8
+
platform : Platform.t option;
9
+
size : string;
10
+
}
11
+
12
+
let repository t = t.repository
13
+
let tags t = t.tags
14
+
let digest t = t.digest
15
+
let platform t = t.platform
16
+
let size t = t.size
17
+
let sizes = [| "B"; "KiB"; "MiB"; "GiB"; "TiB"; "PiB"; "EiB"; "ZiB"; "YiB" |]
18
+
19
+
let bytes_to_size ?(decimals = 2) n =
20
+
if n = Int63.zero then Fmt.str "0 byte"
21
+
else
22
+
let n = Int63.to_float n in
23
+
let i = Float.floor (Float.log n /. Float.log 1024.) in
24
+
let r = n /. Float.pow 1024. i in
25
+
Fmt.str "%.*f %s" decimals r sizes.(int_of_float i)
26
+
27
+
let of_image ~tags ~cache i =
28
+
let repository =
29
+
match Image.org i with "library" -> Image.name i | _ -> Image.repository i
30
+
in
31
+
let digest =
32
+
match Image.digest i with Some d -> d | None -> assert false
33
+
(* it's always a Some x because we used Cache.Manifest.list_digest
34
+
-- would be nice to enforce this statically *)
35
+
in
36
+
let tags = Hashtbl.find_all tags digest in
37
+
let m = Cache.Manifest.get cache i in
38
+
let read d =
39
+
let k = Descriptor.digest d in
40
+
let media_type = Descriptor.media_type d in
41
+
let b = Cache.Blob.get_string cache k in
42
+
match Config.of_string ~media_type b with
43
+
| Ok c -> c
44
+
| Error (`Msg e) ->
45
+
Fmt.failwith "TODO: %a %a %s" Digest.pp k Media_type.pp media_type e
46
+
in
47
+
let platform = Manifest.platform read m in
48
+
let size =
49
+
match Manifest.size m with Some s -> bytes_to_size s | None -> "-"
50
+
in
51
+
{ repository; tags; digest; platform; size }
52
+
53
+
let list ~cache =
54
+
let all_tags = Cache.Manifest.list_tags cache in
55
+
let tags = Hashtbl.create (List.length all_tags) in
56
+
List.iter
57
+
(fun i ->
58
+
let tag =
59
+
match Image.tag i with Some t -> t | None -> assert false
60
+
(* it's always a Some x because we use
61
+
Cache.Manfifest.list_tags. It would be nice to enfore it
62
+
statically. *)
63
+
in
64
+
let m = Cache.Manifest.get cache i in
65
+
let ms = Manifest.manifests m in
66
+
List.iter
67
+
(fun d ->
68
+
let digest = Descriptor.digest d in
69
+
Hashtbl.add tags digest tag)
70
+
ms)
71
+
all_tags;
72
+
73
+
let is = Cache.Manifest.list_digests cache in
74
+
let ts = List.map (of_image ~tags ~cache) is in
75
+
(* FIXME: should use Descriptor.attestation_manifest on the index
76
+
instead *)
77
+
List.filter (fun t -> t.platform <> Some Platform.unknown) ts
+10
src/ls.mli
+10
src/ls.mli
+11
src/oci.ml
+11
src/oci.ml
+21
src/oci.mli
+21
src/oci.mli
···
1
+
module Spec = Oci_spec
2
+
module Cache = Cache
3
+
module Image = Image
4
+
module List = Ls
5
+
module Util = Util
6
+
module Fetch = Fetch
7
+
8
+
val fetch :
9
+
?show_progress:bool ->
10
+
?platform:string ->
11
+
cache:Cache.t ->
12
+
client:Fetch.client ->
13
+
domain_mgr:Eio.Domain_manager.ty Eio.Resource.t ->
14
+
?username:string ->
15
+
?password:string ->
16
+
Image.t ->
17
+
unit
18
+
19
+
val list : cache:Cache.t -> List.t list
20
+
val checkout : cache:Cache.t -> root:[ `Dir ] Eio.Path.t -> Image.t -> unit
21
+
val show : cache:Cache.t -> Image.t -> unit
+14
src/show.ml
+14
src/show.ml
···
1
+
open Oci_spec
2
+
3
+
let show ~cache i =
4
+
Fmt.pr "🔎 Showing %a\n%!" Fmt.(styled `Cyan Image.pp) i;
5
+
let m = Cache.Manifest.get cache i in
6
+
let pp = Oci_spec.Common.pp_json in
7
+
match m with
8
+
| `Docker_manifest m ->
9
+
Fmt.pr "DOCKER MANIFEST:\n%a\n%!" pp (Manifest.Docker.to_yojson m)
10
+
| `OCI_manifest m ->
11
+
Fmt.pr "OCI MANIFEST:\n%a\n%!" pp (Manifest.OCI.to_yojson m)
12
+
| `OCI_index i -> Fmt.pr "OCI INDEX:\n%a\n%!" pp (Index.to_yojson i)
13
+
| `Docker_manifest_list l ->
14
+
Fmt.pr "DOCKER MANIFEST LIST:\n%a\n%!" pp (Manifest_list.to_yojson l)
+63
src/spec/OS.ml
+63
src/spec/OS.ml
···
1
+
open Common
2
+
3
+
type t =
4
+
| Aix
5
+
| Android
6
+
| Darwin
7
+
| Dragonfly
8
+
| Freebsd
9
+
| Illumos
10
+
| Ios
11
+
| Js
12
+
| Linux
13
+
| Netbsd
14
+
| Openbsd
15
+
| Plan9
16
+
| Solaris
17
+
| Wasip1
18
+
| Windows
19
+
| Unknown
20
+
21
+
let to_string = function
22
+
| Aix -> "aix"
23
+
| Android -> "android"
24
+
| Darwin -> "darwin"
25
+
| Dragonfly -> "dragonfly"
26
+
| Freebsd -> "freebsd"
27
+
| Illumos -> "illumos"
28
+
| Ios -> "ios"
29
+
| Js -> "js"
30
+
| Linux -> "linux"
31
+
| Netbsd -> "netbsd"
32
+
| Openbsd -> "openbsd"
33
+
| Plan9 -> "plan9"
34
+
| Solaris -> "solaris"
35
+
| Wasip1 -> "wasip1"
36
+
| Windows -> "windows"
37
+
| Unknown -> "unknown"
38
+
39
+
let of_string = function
40
+
| "aix" -> Ok Aix
41
+
| "android" -> Ok Android
42
+
| "darwin" -> Ok Darwin
43
+
| "dragonfly" -> Ok Dragonfly
44
+
| "freebsd" -> Ok Freebsd
45
+
| "illumos" -> Ok Illumos
46
+
| "ios" -> Ok Ios
47
+
| "js" -> Ok Js
48
+
| "linux" -> Ok Linux
49
+
| "netbsd" -> Ok Netbsd
50
+
| "openbsd" -> Ok Openbsd
51
+
| "plan9" -> Ok Plan9
52
+
| "solaris" -> Ok Solaris
53
+
| "wasip1" -> Ok Wasip1
54
+
| "windows" -> Ok Windows
55
+
| "unknown" -> Ok Unknown
56
+
| s -> error_msg "OS.of_string: invalid string (%S)" s
57
+
58
+
let jsont =
59
+
Jsont.map ~kind:"os"
60
+
~dec:(fun s -> match of_string s with Ok v -> v | Error _ -> Unknown)
61
+
~enc:to_string Jsont.string
62
+
63
+
let pp = Fmt.of_to_string to_string
+25
src/spec/OS.mli
+25
src/spec/OS.mli
···
1
+
(** This property specifies the operating system. Image indexes SHOULD use, and
2
+
implementations SHOULD understand, values listed in the Go Language document
3
+
for GOOS. *)
4
+
type t =
5
+
| Aix
6
+
| Android
7
+
| Darwin
8
+
| Dragonfly
9
+
| Freebsd
10
+
| Illumos
11
+
| Ios
12
+
| Js
13
+
| Linux
14
+
| Netbsd
15
+
| Openbsd
16
+
| Plan9
17
+
| Solaris
18
+
| Wasip1
19
+
| Windows
20
+
| Unknown
21
+
22
+
val jsont : t Jsont.t
23
+
val pp : t Fmt.t
24
+
val of_string : string -> (t, [ `Msg of string ]) result
25
+
val to_string : t -> string
+59
src/spec/annotation.ml
+59
src/spec/annotation.ml
···
1
+
type t =
2
+
| Created
3
+
| Authors
4
+
| Url
5
+
| Documentation
6
+
| Source
7
+
| Version
8
+
| Revision
9
+
| Vendor
10
+
| Licenses
11
+
| Ref_name
12
+
| Title
13
+
| Description
14
+
| Base_image_digest
15
+
| Base_image_name
16
+
| Reference_digest
17
+
| Reference_type
18
+
| Other of string
19
+
20
+
let to_string = function
21
+
| Created -> "org.opencontainers.image.created"
22
+
| Authors -> "org.opencontainers.image.authors"
23
+
| Url -> "org.opencontainers.image.url"
24
+
| Documentation -> "org.opencontainers.image.documentation"
25
+
| Source -> "org.opencontainers.image.source"
26
+
| Version -> "org.opencontainers.image.version"
27
+
| Revision -> "org.opencontainers.image.revision"
28
+
| Vendor -> "org.opencontainers.image.vendor"
29
+
| Licenses -> "org.opencontainers.image.licenses"
30
+
| Ref_name -> "org.opencontainers.image.ref.name"
31
+
| Title -> "org.opencontainers.image.title"
32
+
| Description -> "org.opencontainers.image.description"
33
+
| Base_image_digest -> "org.opencontainers.image.base.digest"
34
+
| Base_image_name -> "org.opencontainers.image.base.name"
35
+
| Reference_digest -> "vnd.docker.reference.digest"
36
+
| Reference_type -> "vnd.docker.reference.type"
37
+
| Other s -> s
38
+
39
+
let of_string = function
40
+
| "org.opencontainers.image.created" -> Created
41
+
| "org.opencontainers.image.authors" -> Authors
42
+
| "org.opencontainers.image.url" -> Url
43
+
| "org.opencontainers.image.documentation" -> Documentation
44
+
| "org.opencontainers.image.source" -> Source
45
+
| "org.opencontainers.image.version" -> Version
46
+
| "org.opencontainers.image.revision" -> Revision
47
+
| "org.opencontainers.image.vendor" -> Vendor
48
+
| "org.opencontainers.image.licenses" -> Licenses
49
+
| "org.opencontainers.image.ref.name" -> Ref_name
50
+
| "org.opencontainers.image.title" -> Title
51
+
| "org.opencontainers.image.description" -> Description
52
+
| "org.opencontainers.image.base.digest" -> Base_image_digest
53
+
| "org.opencontainers.image.base.name" -> Base_image_name
54
+
| "vnd.docker.reference.digest" -> Reference_digest
55
+
| "vnd.docker.reference.type" -> Reference_type
56
+
| s -> Other s
57
+
58
+
let jsont =
59
+
Jsont.map ~kind:"annotation" ~dec:of_string ~enc:to_string Jsont.string
+29
src/spec/annotation.mli
+29
src/spec/annotation.mli
···
1
+
(** Variant type representing different kinds of OCI image annotations. *)
2
+
type t =
3
+
| Created
4
+
| Authors
5
+
| Url
6
+
| Documentation
7
+
| Source
8
+
| Version
9
+
| Revision
10
+
| Vendor
11
+
| Licenses
12
+
| Ref_name
13
+
| Title
14
+
| Description
15
+
| Base_image_digest
16
+
| Base_image_name
17
+
| Reference_digest
18
+
| Reference_type
19
+
| Other of string
20
+
21
+
val jsont : t Jsont.t
22
+
23
+
val to_string : t -> string
24
+
(** [to_string a] converts an annotation variant to its corresponding string. *)
25
+
26
+
val of_string : string -> t
27
+
(** [of_string s] tries to convert a string [s] to its corresponding annotation
28
+
variant. Returns [None] if the string does not match any known annotation.
29
+
*)
+82
src/spec/arch.ml
+82
src/spec/arch.ml
···
1
+
open Common
2
+
3
+
type t =
4
+
| X386
5
+
| Xamd64
6
+
| Arm
7
+
| Arm64
8
+
| Wasm
9
+
| Loong64
10
+
| Mips
11
+
| Mipsle
12
+
| Mips64
13
+
| Mips64le
14
+
| Ppc64
15
+
| Ppc64le
16
+
| Riscv64
17
+
| S390x
18
+
| Unknown
19
+
20
+
let to_string = function
21
+
| X386 -> "386"
22
+
| Xamd64 -> "amd64"
23
+
| Arm -> "arm"
24
+
| Arm64 -> "arm64"
25
+
| Wasm -> "wasm"
26
+
| Loong64 -> "loong64"
27
+
| Mips -> "mips"
28
+
| Mipsle -> "mipsle"
29
+
| Mips64 -> "mips64"
30
+
| Mips64le -> "mips64le"
31
+
| Ppc64 -> "ppc64"
32
+
| Ppc64le -> "ppc64le"
33
+
| Riscv64 -> "riscv64"
34
+
| S390x -> "s390x"
35
+
| Unknown -> "unknown"
36
+
37
+
let of_string = function
38
+
| "386" -> Ok X386
39
+
| "amd64" -> Ok Xamd64
40
+
| "arm" -> Ok Arm
41
+
| "arm64" -> Ok Arm64
42
+
| "wasm" -> Ok Wasm
43
+
| "loong64" -> Ok Loong64
44
+
| "mips" -> Ok Mips
45
+
| "mipsle" -> Ok Mipsle
46
+
| "mips64" -> Ok Mips64
47
+
| "mips64le" -> Ok Mips64le
48
+
| "ppc64" -> Ok Ppc64
49
+
| "ppc64le" -> Ok Ppc64le
50
+
| "riscv64" -> Ok Riscv64
51
+
| "s390x" -> Ok S390x
52
+
| "unknown" -> Ok Unknown
53
+
| s -> error_msg "Arch.of_string: invalid string (%S)" s
54
+
55
+
let jsont =
56
+
Jsont.map ~kind:"arch"
57
+
~dec:(fun s -> match of_string s with Ok v -> v | Error _ -> Unknown)
58
+
~enc:to_string Jsont.string
59
+
60
+
let pp = Fmt.of_to_string to_string
61
+
62
+
type variant = V5 | V6 | V7 | V8
63
+
64
+
let variant_to_string = function
65
+
| V5 -> "v5"
66
+
| V6 -> "v6"
67
+
| V7 -> "v7"
68
+
| V8 -> "v8"
69
+
70
+
let variant_of_string = function
71
+
| "v5" -> Ok V5
72
+
| "v6" -> Ok V6
73
+
| "v7" -> Ok V7
74
+
| "v8" -> Ok V8
75
+
| s -> error_msg "Arch.variant_of_string: invalid string (%S)" s
76
+
77
+
let variant_jsont =
78
+
Jsont.map ~kind:"arch.variant"
79
+
~dec:(fun s -> match variant_of_string s with Ok v -> v | Error _ -> V8)
80
+
~enc:variant_to_string Jsont.string
81
+
82
+
let pp_variant = Fmt.of_to_string variant_to_string
+30
src/spec/arch.mli
+30
src/spec/arch.mli
···
1
+
(** This property specifies the CPU architecture. Image indexes SHOULD use, and
2
+
implementations SHOULD understand, values listed in the Go Language document
3
+
for GOARCH. *)
4
+
type t =
5
+
| X386
6
+
| Xamd64
7
+
| Arm
8
+
| Arm64
9
+
| Wasm
10
+
| Loong64
11
+
| Mips
12
+
| Mipsle
13
+
| Mips64
14
+
| Mips64le
15
+
| Ppc64
16
+
| Ppc64le
17
+
| Riscv64
18
+
| S390x
19
+
| Unknown
20
+
21
+
val jsont : t Jsont.t
22
+
val pp : t Fmt.t
23
+
val of_string : string -> (t, [ `Msg of string ]) result
24
+
val to_string : t -> string
25
+
26
+
type variant = V5 | V6 | V7 | V8
27
+
28
+
val variant_jsont : variant Jsont.t
29
+
val variant_of_string : string -> (variant, [ `Msg of string ]) result
30
+
val pp_variant : variant Fmt.t
+15
src/spec/auth.ml
+15
src/spec/auth.ml
···
1
+
open Common
2
+
3
+
type t = { access_token : string }
4
+
5
+
let jsont =
6
+
Jsont.Object.map ~kind:"auth" (fun access_token -> { access_token })
7
+
|> Jsont.Object.mem "access_token" Jsont.string ~enc:(fun t -> t.access_token)
8
+
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
9
+
10
+
let of_string s =
11
+
match Jsont_bytesrw.decode_string jsont s with
12
+
| Ok t -> Ok t
13
+
| Error e -> error_msg "Auth.of_string: %s" e
14
+
15
+
let token t = t.access_token
+7
src/spec/auth.mli
+7
src/spec/auth.mli
+151
src/spec/blob.ml
+151
src/spec/blob.ml
···
1
+
open Common
2
+
3
+
module OCI = struct
4
+
type t =
5
+
| Empty
6
+
| Descriptor of Descriptor.t
7
+
| Layout_header of Layout.t
8
+
| Image_index of Index.t
9
+
| Image_manifest of Manifest.OCI.t
10
+
| Image_config of Config.OCI.t
11
+
| Raw of string
12
+
13
+
let pp ppf = function
14
+
| Empty -> Fmt.string ppf ""
15
+
| Descriptor d -> pp_json ppf (Descriptor.to_yojson d)
16
+
| Layout_header h -> pp_json ppf (Layout.to_yojson h)
17
+
| Image_index i -> pp_json ppf (Index.to_yojson i)
18
+
| Image_manifest m -> pp_json ppf (Manifest.OCI.to_yojson m)
19
+
| Image_config c -> pp_json ppf (Config.OCI.to_yojson c)
20
+
| Raw _ -> Fmt.string ppf "<raw>"
21
+
22
+
let descriptor str =
23
+
let* json = json_of_string str in
24
+
let+ d = Descriptor.of_yojson json in
25
+
Descriptor d
26
+
27
+
let layout_header str =
28
+
let* json = json_of_string str in
29
+
let+ l = Layout.of_yojson json in
30
+
Layout_header l
31
+
32
+
let image_index str =
33
+
let* json = json_of_string str in
34
+
let+ i = Index.of_yojson json in
35
+
Image_index i
36
+
37
+
let image_manifest str =
38
+
let* json = json_of_string str in
39
+
let+ m = Manifest.OCI.of_yojson json in
40
+
Image_manifest m
41
+
42
+
let image_config str =
43
+
let* json = json_of_string str in
44
+
let+ c = Config.OCI.of_yojson json in
45
+
Image_config c
46
+
47
+
let trust str = Ok (Raw str) (* TODO *)
48
+
let layer str = Ok (Raw str) (* TODO *)
49
+
50
+
let of_string ty str =
51
+
wrap
52
+
@@
53
+
match ty with
54
+
| Media_type.OCI.Empty -> Ok Empty
55
+
| Descriptor -> descriptor str
56
+
| Layout_header -> layout_header str
57
+
| Image_index -> image_index str
58
+
| Image_manifest -> image_manifest str
59
+
| Image_config -> image_config str
60
+
| Layer_tar -> layer str
61
+
| Layer_tar_gzip -> layer str
62
+
| Layer_tar_zstd -> layer str
63
+
| Layer_non_distributable_tar -> layer str
64
+
| Layer_non_distributable_tar_gzip -> layer str
65
+
| Layer_non_distributable_tar_zstd -> layer str
66
+
| Trust -> trust str
67
+
| Other _ -> Ok (Raw str)
68
+
end
69
+
70
+
module Docker = struct
71
+
type t =
72
+
| Image_manifest of Manifest.Docker.t
73
+
| Image_manifest_list of Manifest_list.t
74
+
| Image_config of Config.Docker.t
75
+
| Plugin_config of Jsont.json
76
+
| Raw of string
77
+
78
+
let pp ppf = function
79
+
| Image_manifest m -> pp_json ppf (Manifest.Docker.to_yojson m)
80
+
| Image_manifest_list l -> pp_json ppf (Manifest_list.to_yojson l)
81
+
| Image_config c -> pp_json ppf (Config.Docker.to_yojson c)
82
+
| Plugin_config j -> pp_json ppf j
83
+
| Raw _ -> Fmt.string ppf "<raw>"
84
+
85
+
let image_manifest str =
86
+
let* json = json_of_string str in
87
+
let+ m = Manifest.Docker.of_yojson json in
88
+
Image_manifest m
89
+
90
+
let image_manifest_list str =
91
+
let* json = json_of_string str in
92
+
let+ m = Manifest_list.of_yojson json in
93
+
Image_manifest_list m
94
+
95
+
let image_config str =
96
+
let* json = json_of_string str in
97
+
let+ c = Config.Docker.of_yojson json in
98
+
Image_config c
99
+
100
+
let plugin str =
101
+
let+ json = json_of_string str in
102
+
Plugin_config json
103
+
104
+
let layer str = Ok (Raw str) (* TODO *)
105
+
106
+
let of_string ty str =
107
+
wrap
108
+
@@
109
+
match ty with
110
+
| Media_type.Docker.Image_manifest -> image_manifest str
111
+
| Image_manifest_list -> image_manifest_list str
112
+
| Image_config -> image_config str
113
+
| Plugin_config -> plugin str
114
+
| Layer_tar_gzip -> layer str
115
+
| Layer_non_distributable_tar_gzip -> layer str
116
+
end
117
+
118
+
type v = OCI of OCI.t | Docker of Docker.t
119
+
type t = { media_type : Media_type.t; v : v }
120
+
121
+
let v t = t.v
122
+
123
+
let pp ppf t =
124
+
match t.v with OCI t -> OCI.pp ppf t | Docker t -> Docker.pp ppf t
125
+
126
+
let of_string ~media_type str =
127
+
let+ v =
128
+
match media_type with
129
+
| Media_type.OCI m ->
130
+
let+ t = OCI.of_string m str in
131
+
OCI t
132
+
| Docker m ->
133
+
let+ t = Docker.of_string m str in
134
+
Docker t
135
+
in
136
+
{ media_type; v }
137
+
138
+
let media_type t = t.media_type
139
+
140
+
let err_size e g =
141
+
error_msg "Blob.of_descriptor: invalid size: expected %a, got %d" Int63.pp e g
142
+
143
+
let of_descriptor d body =
144
+
let digest = Descriptor.digest d in
145
+
let expected_size = Descriptor.size d in
146
+
let got_size = String.length body in
147
+
if Int63.of_int got_size <> expected_size then err_size expected_size got_size
148
+
else
149
+
let* () = Digest.validate digest body in
150
+
let media_type = Descriptor.media_type d in
151
+
of_string ~media_type body
+31
src/spec/blob.mli
+31
src/spec/blob.mli
···
1
+
module OCI : sig
2
+
type t =
3
+
| Empty
4
+
| Descriptor of Descriptor.t
5
+
| Layout_header of Layout.t
6
+
| Image_index of Index.t
7
+
| Image_manifest of Manifest.OCI.t
8
+
| Image_config of Config.OCI.t
9
+
| Raw of string
10
+
end
11
+
12
+
module Docker : sig
13
+
type t =
14
+
| Image_manifest of Manifest.Docker.t
15
+
| Image_manifest_list of Manifest_list.t
16
+
| Image_config of Config.Docker.t
17
+
| Plugin_config of Jsont.json
18
+
| Raw of string
19
+
end
20
+
21
+
type v = OCI of OCI.t | Docker of Docker.t
22
+
type t
23
+
24
+
val pp : t Fmt.t
25
+
26
+
val of_string :
27
+
media_type:Media_type.t -> string -> (t, [ `Msg of string ]) result
28
+
29
+
val media_type : t -> Media_type.t
30
+
val v : t -> v
31
+
val of_descriptor : Descriptor.t -> string -> (t, [ `Msg of string ]) result
+174
src/spec/common.ml
+174
src/spec/common.ml
···
1
+
open Astring
2
+
3
+
let error fmt = Fmt.kstr (fun s -> Error s) fmt
4
+
let error_msg fmt = Fmt.kstr (fun s -> Error (`Msg s)) fmt
5
+
6
+
let pp_json ppf t =
7
+
match Jsont_bytesrw.encode_string Jsont.json t with
8
+
| Ok s -> Fmt.string ppf s
9
+
| Error e -> Fmt.pf ppf "<error: %s>" e
10
+
11
+
let unwrap = function Ok _ as ok -> ok | Error (`Msg e) -> Error e
12
+
let wrap = function Ok _ as ok -> ok | Error e -> Error (`Msg e)
13
+
let ( let* ) x f = match x with Ok x -> f x | Error e -> Error e
14
+
let ( let+ ) x f = match x with Ok x -> Ok (f x) | Error e -> Error e
15
+
16
+
(** {1 Jsont helpers} *)
17
+
18
+
let json_of_string str =
19
+
match Jsont_bytesrw.decode_string Jsont.json str with
20
+
| Ok json -> Ok json
21
+
| Error e -> Error e
22
+
23
+
let json_to_string json =
24
+
match Jsont_bytesrw.encode_string Jsont.json json with
25
+
| Ok s -> s
26
+
| Error _ -> "{}"
27
+
28
+
(** {1 Date/time} *)
29
+
30
+
type date_time = Ptime.t * Ptime.tz_offset_s option
31
+
32
+
let date_time_jsont =
33
+
Jsont.map ~kind:"date_time"
34
+
~dec:(fun s ->
35
+
match Ptime.rfc3339_string_error (Ptime.of_rfc3339 s) with
36
+
| Ok (t, tz, _) -> (t, tz)
37
+
| Error _ -> (Ptime.epoch, None))
38
+
~enc:(fun (t, tz) -> Ptime.to_rfc3339 ?tz_offset_s:tz t)
39
+
Jsont.string
40
+
41
+
(** {1 Map type} *)
42
+
43
+
type ('a, 'b) map = ('a * 'b) list
44
+
45
+
(* Helper to convert between JSON object and association list.
46
+
Uses Jsont.Object.Mems.string_map for proper type handling. *)
47
+
let map_jsont key_of_string key_to_string value_jsont =
48
+
let mems = Jsont.Object.Mems.string_map value_jsont in
49
+
Jsont.Object.map ~kind:"map" Fun.id
50
+
|> Jsont.Object.keep_unknown ~enc:Fun.id mems
51
+
|> Jsont.Object.finish
52
+
|> Jsont.map ~kind:"map_list"
53
+
~dec:(fun m ->
54
+
(* The type is 'a Map.Make(String).t - we use Obj.magic to treat it as a fold-able structure *)
55
+
(* This is safe because Map.Make(String) is structurally the same regardless of module application *)
56
+
let module M = Map.Make (String) in
57
+
(Obj.magic M.fold
58
+
: (string -> 'a -> 'b list -> 'b list) -> 'c -> 'b list -> 'b list)
59
+
(fun k v acc ->
60
+
match key_of_string k with
61
+
| Ok key -> (key, v) :: acc
62
+
| Error _ -> acc)
63
+
m [])
64
+
~enc:(fun alist ->
65
+
let module M = Map.Make (String) in
66
+
let m =
67
+
List.fold_left
68
+
(fun m (k, v) -> M.add (key_to_string k) v m)
69
+
M.empty alist
70
+
in
71
+
(* Same Obj.magic trick in reverse *)
72
+
(Obj.magic m : 'c))
73
+
74
+
(** {1 Nil type} *)
75
+
76
+
type nil = Nil
77
+
78
+
let nil_jsont =
79
+
Jsont.Object.map ~kind:"nil" Nil
80
+
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
81
+
82
+
(** {1 Environment variable} *)
83
+
84
+
type env = string * string
85
+
86
+
let env_jsont =
87
+
Jsont.map ~kind:"env"
88
+
~dec:(fun s ->
89
+
match String.cut ~sep:"=" s with
90
+
| Some (k, v) -> (k, v)
91
+
| None ->
92
+
Jsont.Error.msgf Jsont.Meta.none
93
+
"Env value invalid, must be in the format KEY=VALUE")
94
+
~enc:(fun (k, v) -> k ^ "=" ^ v)
95
+
Jsont.string
96
+
97
+
(** {1 Set (object with empty values)} *)
98
+
99
+
type set = string list
100
+
101
+
let set_jsont =
102
+
let mems = Jsont.Object.Mems.string_map nil_jsont in
103
+
Jsont.Object.map ~kind:"set" Fun.id
104
+
|> Jsont.Object.keep_unknown ~enc:Fun.id mems
105
+
|> Jsont.Object.finish
106
+
|> Jsont.map ~kind:"set_list"
107
+
~dec:(fun m ->
108
+
let module M = Map.Make (String) in
109
+
(Obj.magic M.fold
110
+
: (string -> nil -> string list -> string list) ->
111
+
'c ->
112
+
string list ->
113
+
string list)
114
+
(fun k _ acc -> k :: acc)
115
+
m [])
116
+
~enc:(fun lst ->
117
+
let module M = Map.Make (String) in
118
+
let m = List.fold_left (fun m k -> M.add k Nil m) M.empty lst in
119
+
(Obj.magic m : 'c))
120
+
121
+
(** {1 Schema version} *)
122
+
123
+
type v2 = V2
124
+
125
+
let v2_jsont =
126
+
Jsont.map ~kind:"v2"
127
+
~dec:(fun n -> if n = 2 then V2 else failwith "expecting schemaVersion 2")
128
+
~enc:(fun V2 -> 2)
129
+
Jsont.int
130
+
131
+
(** {1 RFC 6838 media type} *)
132
+
133
+
type rfc_6838 = string
134
+
135
+
let rfc_6838_jsont = Jsont.string
136
+
137
+
(** {1 Int63 (large integers)} *)
138
+
139
+
open Optint
140
+
141
+
type z = Int63.t
142
+
143
+
(* Strict integer decoder that rejects strings per OCI spec *)
144
+
let z_jsont =
145
+
Jsont.any ~kind:"int63"
146
+
~dec_number:
147
+
(Jsont.map ~kind:"int63_number" ~dec:Int63.of_int64 ~enc:Int63.to_int64
148
+
Jsont.int64)
149
+
~enc:(fun _ ->
150
+
Jsont.map ~kind:"int63_enc" ~dec:Int63.of_int64 ~enc:Int63.to_int64
151
+
Jsont.int64)
152
+
()
153
+
154
+
module Int63 = Int63
155
+
156
+
(** {1 Base64 encoded strings} *)
157
+
158
+
module Base64 = struct
159
+
type t = string
160
+
161
+
let of_raw x = x
162
+
163
+
let jsont =
164
+
Jsont.map ~kind:"base64"
165
+
~dec:(fun s ->
166
+
match Base64.decode s with
167
+
| Ok _ -> s
168
+
| Error (`Msg e) ->
169
+
Jsont.Error.msgf Jsont.Meta.none "invalid base64: %s" e)
170
+
~enc:Fun.id Jsont.string
171
+
172
+
let decode u = Base64.decode u
173
+
let encode u = Base64.encode_string u
174
+
end
+63
src/spec/common.mli
+63
src/spec/common.mli
···
1
+
module Int63 = Optint.Int63
2
+
3
+
(** Basic types *)
4
+
5
+
type date_time = Ptime.t * Ptime.tz_offset_s option
6
+
type ('a, 'b) map = ('a * 'b) list
7
+
type env = string * string
8
+
type set = string list
9
+
type nil = Nil
10
+
type v2 = V2
11
+
type rfc_6838 = string
12
+
type z = Int63.t
13
+
14
+
(** Jsont codecs *)
15
+
16
+
val date_time_jsont : date_time Jsont.t
17
+
18
+
val map_jsont :
19
+
(string -> ('a, string) result) ->
20
+
('a -> string) ->
21
+
'b Jsont.t ->
22
+
('a, 'b) map Jsont.t
23
+
24
+
val env_jsont : env Jsont.t
25
+
val set_jsont : set Jsont.t
26
+
val nil_jsont : nil Jsont.t
27
+
val v2_jsont : v2 Jsont.t
28
+
val rfc_6838_jsont : rfc_6838 Jsont.t
29
+
val z_jsont : z Jsont.t
30
+
31
+
(** Result *)
32
+
33
+
val ( let* ) : ('a, 'b) result -> ('a -> ('c, 'b) result) -> ('c, 'b) result
34
+
val ( let+ ) : ('a, 'b) result -> ('a -> 'c) -> ('c, 'b) result
35
+
36
+
(** Errors *)
37
+
38
+
val error : ('a, Format.formatter, unit, ('b, string) result) format4 -> 'a
39
+
40
+
val error_msg :
41
+
('a, Format.formatter, unit, ('b, [ `Msg of string ]) result) format4 -> 'a
42
+
43
+
val unwrap : ('a, [ `Msg of string ]) result -> ('a, string) result
44
+
val wrap : ('a, string) result -> ('a, [ `Msg of string ]) result
45
+
46
+
(** JSON *)
47
+
48
+
val pp_json : Jsont.json Fmt.t
49
+
val json_of_string : string -> (Jsont.json, string) result
50
+
51
+
val json_to_string : Jsont.json -> string
52
+
(** Returns "{}" if encoding fails *)
53
+
54
+
(** Base64 *)
55
+
56
+
module Base64 : sig
57
+
type t
58
+
59
+
val jsont : t Jsont.t
60
+
val of_raw : string -> t
61
+
val decode : t -> (string, [ `Msg of string ]) result
62
+
val encode : string -> t
63
+
end
+519
src/spec/config.ml
+519
src/spec/config.ml
···
1
+
open Common
2
+
3
+
let labels_jsont =
4
+
map_jsont
5
+
(fun s -> Ok (Annotation.of_string s))
6
+
Annotation.to_string Jsont.string
7
+
8
+
module OCI = struct
9
+
type config = {
10
+
user : string option;
11
+
exposed_ports : set;
12
+
env : env list;
13
+
entrypoint : string list;
14
+
cmd : string list;
15
+
volumes : set;
16
+
working_dir : string option;
17
+
labels : (Annotation.t, string) map;
18
+
stop_signal : string option;
19
+
args_escaped : bool option;
20
+
memory : int option;
21
+
memory_swap : int option;
22
+
cpu_shares : int option;
23
+
healthcheck : set;
24
+
on_build : string option;
25
+
}
26
+
27
+
let config_jsont =
28
+
Jsont.Object.map ~kind:"oci_config"
29
+
(fun
30
+
user
31
+
exposed_ports
32
+
env
33
+
entrypoint
34
+
cmd
35
+
volumes
36
+
working_dir
37
+
labels
38
+
stop_signal
39
+
args_escaped
40
+
memory
41
+
memory_swap
42
+
cpu_shares
43
+
healthcheck
44
+
on_build
45
+
->
46
+
{
47
+
user;
48
+
exposed_ports = Option.value ~default:[] exposed_ports;
49
+
env = Option.value ~default:[] env;
50
+
entrypoint = Option.value ~default:[] entrypoint;
51
+
cmd = Option.value ~default:[] cmd;
52
+
volumes = Option.value ~default:[] volumes;
53
+
working_dir;
54
+
labels = Option.value ~default:[] labels;
55
+
stop_signal;
56
+
args_escaped;
57
+
memory;
58
+
memory_swap;
59
+
cpu_shares;
60
+
healthcheck = Option.value ~default:[] healthcheck;
61
+
on_build;
62
+
})
63
+
|> Jsont.Object.opt_mem "User" Jsont.string ~enc:(fun c -> c.user)
64
+
|> Jsont.Object.opt_mem "ExposedPorts" set_jsont ~enc:(fun c ->
65
+
if c.exposed_ports = [] then None else Some c.exposed_ports)
66
+
|> Jsont.Object.opt_mem "Env" (Jsont.list env_jsont) ~enc:(fun c ->
67
+
if c.env = [] then None else Some c.env)
68
+
|> Jsont.Object.opt_mem "Entrypoint" (Jsont.list Jsont.string)
69
+
~enc:(fun c -> if c.entrypoint = [] then None else Some c.entrypoint)
70
+
|> Jsont.Object.opt_mem "Cmd" (Jsont.list Jsont.string) ~enc:(fun c ->
71
+
if c.cmd = [] then None else Some c.cmd)
72
+
|> Jsont.Object.opt_mem "Volumes" set_jsont ~enc:(fun c ->
73
+
if c.volumes = [] then None else Some c.volumes)
74
+
|> Jsont.Object.opt_mem "WorkingDir" Jsont.string ~enc:(fun c ->
75
+
c.working_dir)
76
+
|> Jsont.Object.opt_mem "Labels" labels_jsont ~enc:(fun c ->
77
+
if c.labels = [] then None else Some c.labels)
78
+
|> Jsont.Object.opt_mem "StopSignal" Jsont.string ~enc:(fun c ->
79
+
c.stop_signal)
80
+
|> Jsont.Object.opt_mem "ArgsEscaped" Jsont.bool ~enc:(fun c ->
81
+
c.args_escaped)
82
+
|> Jsont.Object.opt_mem "Memory" Jsont.int ~enc:(fun c -> c.memory)
83
+
|> Jsont.Object.opt_mem "MemorySwap" Jsont.int ~enc:(fun c -> c.memory_swap)
84
+
|> Jsont.Object.opt_mem "CpuShares" Jsont.int ~enc:(fun c -> c.cpu_shares)
85
+
|> Jsont.Object.opt_mem "HealthCheck" set_jsont ~enc:(fun c ->
86
+
if c.healthcheck = [] then None else Some c.healthcheck)
87
+
|> Jsont.Object.opt_mem "OnBuild" Jsont.string ~enc:(fun c -> c.on_build)
88
+
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
89
+
90
+
type rootfs = { type_ : string; diff_ids : Digest.t list }
91
+
92
+
let rootfs_jsont =
93
+
Jsont.Object.map ~kind:"rootfs" (fun type_ diff_ids -> { type_; diff_ids })
94
+
|> Jsont.Object.mem "type" Jsont.string ~enc:(fun r -> r.type_)
95
+
|> Jsont.Object.mem "diff_ids" (Jsont.list Digest.jsont) ~enc:(fun r ->
96
+
r.diff_ids)
97
+
|> Jsont.Object.finish
98
+
99
+
type history = {
100
+
created : date_time option;
101
+
author : string option;
102
+
created_by : string option;
103
+
comment : string option;
104
+
empty_layer : bool;
105
+
}
106
+
107
+
let history_jsont =
108
+
Jsont.Object.map ~kind:"history"
109
+
(fun created author created_by comment empty_layer ->
110
+
{
111
+
created;
112
+
author;
113
+
created_by;
114
+
comment;
115
+
empty_layer = Option.value ~default:false empty_layer;
116
+
})
117
+
|> Jsont.Object.opt_mem "created" date_time_jsont ~enc:(fun h -> h.created)
118
+
|> Jsont.Object.opt_mem "author" Jsont.string ~enc:(fun h -> h.author)
119
+
|> Jsont.Object.opt_mem "created_by" Jsont.string ~enc:(fun h ->
120
+
h.created_by)
121
+
|> Jsont.Object.opt_mem "comment" Jsont.string ~enc:(fun h -> h.comment)
122
+
|> Jsont.Object.opt_mem "empty_layer" Jsont.bool ~enc:(fun h ->
123
+
if h.empty_layer then Some true else None)
124
+
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
125
+
126
+
type t = {
127
+
created : date_time option;
128
+
author : string option;
129
+
architecture : Arch.t;
130
+
os : OS.t;
131
+
os_version : string option;
132
+
os_features : string list;
133
+
variant : Arch.variant option;
134
+
config : config option;
135
+
rootfs : rootfs;
136
+
history : history list;
137
+
}
138
+
139
+
let jsont =
140
+
Jsont.Object.map ~kind:"oci_image_config"
141
+
(fun
142
+
created
143
+
author
144
+
architecture
145
+
os
146
+
os_version
147
+
os_features
148
+
variant
149
+
config
150
+
rootfs
151
+
history
152
+
->
153
+
{
154
+
created;
155
+
author;
156
+
architecture;
157
+
os;
158
+
os_version;
159
+
os_features = Option.value ~default:[] os_features;
160
+
variant;
161
+
config;
162
+
rootfs;
163
+
history = Option.value ~default:[] history;
164
+
})
165
+
|> Jsont.Object.opt_mem "created" date_time_jsont ~enc:(fun t -> t.created)
166
+
|> Jsont.Object.opt_mem "author" Jsont.string ~enc:(fun t -> t.author)
167
+
|> Jsont.Object.mem "architecture" Arch.jsont ~enc:(fun t -> t.architecture)
168
+
|> Jsont.Object.mem "os" OS.jsont ~enc:(fun t -> t.os)
169
+
|> Jsont.Object.opt_mem "os.version" Jsont.string ~enc:(fun t ->
170
+
t.os_version)
171
+
|> Jsont.Object.opt_mem "os.features" (Jsont.list Jsont.string)
172
+
~enc:(fun t -> if t.os_features = [] then None else Some t.os_features)
173
+
|> Jsont.Object.opt_mem "variant" Arch.variant_jsont ~enc:(fun t ->
174
+
t.variant)
175
+
|> Jsont.Object.opt_mem "config" config_jsont ~enc:(fun t -> t.config)
176
+
|> Jsont.Object.mem "rootfs" rootfs_jsont ~enc:(fun t -> t.rootfs)
177
+
|> Jsont.Object.opt_mem "history" (Jsont.list history_jsont) ~enc:(fun t ->
178
+
if t.history = [] then None else Some t.history)
179
+
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
180
+
181
+
let of_yojson json =
182
+
match Jsont_bytesrw.decode_string jsont (json_to_string json) with
183
+
| Ok t ->
184
+
if t.rootfs.type_ <> "layers" then Error "rootfs.type must be 'layers'"
185
+
else Ok t
186
+
| Error e -> Error e
187
+
188
+
let to_yojson t =
189
+
match Jsont_bytesrw.encode_string jsont t with
190
+
| Ok s -> (
191
+
match json_of_string s with
192
+
| Ok j -> j
193
+
| Error _ -> Jsont.Null ((), Jsont.Meta.none))
194
+
| Error _ -> Jsont.Null ((), Jsont.Meta.none)
195
+
196
+
let of_string str =
197
+
wrap
198
+
@@
199
+
let* json = json_of_string str in
200
+
of_yojson json
201
+
202
+
let platform { os_version; os_features; variant; architecture; os; _ } =
203
+
Platform.v ?os_version ~os_features ?variant architecture os
204
+
end
205
+
206
+
module Docker = struct
207
+
type config = {
208
+
hostname : string option;
209
+
domain_name : string option;
210
+
user : string option;
211
+
attach_stdin : bool;
212
+
attach_stdout : bool;
213
+
attach_stderr : bool;
214
+
exposed_ports : set;
215
+
tty : bool;
216
+
open_stdin : bool;
217
+
stdin_once : bool;
218
+
env : env list option;
219
+
cmd : string list option;
220
+
healthcheck : set;
221
+
args_escaped : bool option;
222
+
image : string option;
223
+
volumes : set;
224
+
working_dir : string;
225
+
entrypoint : string list option;
226
+
network_disabled : bool;
227
+
mac_address : string option;
228
+
on_build : string list option;
229
+
labels : (Annotation.t, string) map;
230
+
stop_signal : string option;
231
+
stop_timeout : int option;
232
+
shell : string list;
233
+
}
234
+
235
+
let config_jsont =
236
+
Jsont.Object.map ~kind:"docker_config"
237
+
(fun
238
+
hostname
239
+
domain_name
240
+
user
241
+
attach_stdin
242
+
attach_stdout
243
+
attach_stderr
244
+
exposed_ports
245
+
tty
246
+
open_stdin
247
+
stdin_once
248
+
env
249
+
cmd
250
+
healthcheck
251
+
args_escaped
252
+
image
253
+
volumes
254
+
working_dir
255
+
entrypoint
256
+
network_disabled
257
+
mac_address
258
+
on_build
259
+
labels
260
+
stop_signal
261
+
stop_timeout
262
+
shell
263
+
->
264
+
{
265
+
hostname;
266
+
domain_name;
267
+
user;
268
+
attach_stdin = Option.value ~default:false attach_stdin;
269
+
attach_stdout = Option.value ~default:false attach_stdout;
270
+
attach_stderr = Option.value ~default:false attach_stderr;
271
+
exposed_ports = Option.value ~default:[] exposed_ports;
272
+
tty = Option.value ~default:false tty;
273
+
open_stdin = Option.value ~default:false open_stdin;
274
+
stdin_once = Option.value ~default:false stdin_once;
275
+
env;
276
+
cmd;
277
+
healthcheck = Option.value ~default:[] healthcheck;
278
+
args_escaped;
279
+
image;
280
+
volumes = Option.value ~default:[] volumes;
281
+
working_dir = Option.value ~default:"" working_dir;
282
+
entrypoint;
283
+
network_disabled = Option.value ~default:false network_disabled;
284
+
mac_address;
285
+
on_build;
286
+
labels = Option.value ~default:[] labels;
287
+
stop_signal;
288
+
stop_timeout;
289
+
shell = Option.value ~default:[] shell;
290
+
})
291
+
|> Jsont.Object.opt_mem "Hostname" Jsont.string ~enc:(fun c -> c.hostname)
292
+
|> Jsont.Object.opt_mem "Domainname" Jsont.string ~enc:(fun c ->
293
+
c.domain_name)
294
+
|> Jsont.Object.opt_mem "User" Jsont.string ~enc:(fun c -> c.user)
295
+
|> Jsont.Object.opt_mem "AttachStdin" Jsont.bool ~enc:(fun c ->
296
+
if c.attach_stdin then Some true else None)
297
+
|> Jsont.Object.opt_mem "AttachStdout" Jsont.bool ~enc:(fun c ->
298
+
if c.attach_stdout then Some true else None)
299
+
|> Jsont.Object.opt_mem "AttachStderr" Jsont.bool ~enc:(fun c ->
300
+
if c.attach_stderr then Some true else None)
301
+
|> Jsont.Object.opt_mem "ExposedPorts" set_jsont ~enc:(fun c ->
302
+
if c.exposed_ports = [] then None else Some c.exposed_ports)
303
+
|> Jsont.Object.opt_mem "Tty" Jsont.bool ~enc:(fun c ->
304
+
if c.tty then Some true else None)
305
+
|> Jsont.Object.opt_mem "OpenStdin" Jsont.bool ~enc:(fun c ->
306
+
if c.open_stdin then Some true else None)
307
+
|> Jsont.Object.opt_mem "StdinOnce" Jsont.bool ~enc:(fun c ->
308
+
if c.stdin_once then Some true else None)
309
+
|> Jsont.Object.opt_mem "Env" (Jsont.list env_jsont) ~enc:(fun c -> c.env)
310
+
|> Jsont.Object.opt_mem "Cmd" (Jsont.list Jsont.string) ~enc:(fun c ->
311
+
c.cmd)
312
+
|> Jsont.Object.opt_mem "HealthCheck" set_jsont ~enc:(fun c ->
313
+
if c.healthcheck = [] then None else Some c.healthcheck)
314
+
|> Jsont.Object.opt_mem "ArgsEscaped" Jsont.bool ~enc:(fun c ->
315
+
c.args_escaped)
316
+
|> Jsont.Object.opt_mem "Image" Jsont.string ~enc:(fun c -> c.image)
317
+
|> Jsont.Object.opt_mem "Volumes" set_jsont ~enc:(fun c ->
318
+
if c.volumes = [] then None else Some c.volumes)
319
+
|> Jsont.Object.opt_mem "WorkingDir" Jsont.string ~enc:(fun c ->
320
+
if c.working_dir = "" then None else Some c.working_dir)
321
+
|> Jsont.Object.opt_mem "Entrypoint" (Jsont.list Jsont.string)
322
+
~enc:(fun c -> c.entrypoint)
323
+
|> Jsont.Object.opt_mem "NetworkDisabled" Jsont.bool ~enc:(fun c ->
324
+
if c.network_disabled then Some true else None)
325
+
|> Jsont.Object.opt_mem "MacAddress" Jsont.string ~enc:(fun c ->
326
+
c.mac_address)
327
+
|> Jsont.Object.opt_mem "OnBuild" (Jsont.list Jsont.string) ~enc:(fun c ->
328
+
c.on_build)
329
+
|> Jsont.Object.opt_mem "Labels" labels_jsont ~enc:(fun c ->
330
+
if c.labels = [] then None else Some c.labels)
331
+
|> Jsont.Object.opt_mem "StopSignal" Jsont.string ~enc:(fun c ->
332
+
c.stop_signal)
333
+
|> Jsont.Object.opt_mem "StopTimeout" Jsont.int ~enc:(fun c ->
334
+
c.stop_timeout)
335
+
|> Jsont.Object.opt_mem "Shell" (Jsont.list Jsont.string) ~enc:(fun c ->
336
+
if c.shell = [] then None else Some c.shell)
337
+
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
338
+
339
+
type rootfs = { type_ : string; diff_ids : Digest.t list }
340
+
341
+
let rootfs_jsont =
342
+
Jsont.Object.map ~kind:"rootfs" (fun type_ diff_ids -> { type_; diff_ids })
343
+
|> Jsont.Object.mem "type" Jsont.string ~enc:(fun r -> r.type_)
344
+
|> Jsont.Object.mem "diff_ids" (Jsont.list Digest.jsont) ~enc:(fun r ->
345
+
r.diff_ids)
346
+
|> Jsont.Object.finish
347
+
348
+
type history = {
349
+
created : date_time option;
350
+
author : string option;
351
+
created_by : string option;
352
+
comment : string option;
353
+
empty_layer : bool;
354
+
}
355
+
356
+
let history_jsont =
357
+
Jsont.Object.map ~kind:"history"
358
+
(fun created author created_by comment empty_layer ->
359
+
{
360
+
created;
361
+
author;
362
+
created_by;
363
+
comment;
364
+
empty_layer = Option.value ~default:false empty_layer;
365
+
})
366
+
|> Jsont.Object.opt_mem "created" date_time_jsont ~enc:(fun h -> h.created)
367
+
|> Jsont.Object.opt_mem "author" Jsont.string ~enc:(fun h -> h.author)
368
+
|> Jsont.Object.opt_mem "created_by" Jsont.string ~enc:(fun h ->
369
+
h.created_by)
370
+
|> Jsont.Object.opt_mem "comment" Jsont.string ~enc:(fun h -> h.comment)
371
+
|> Jsont.Object.opt_mem "empty_layer" Jsont.bool ~enc:(fun h ->
372
+
if h.empty_layer then Some true else None)
373
+
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
374
+
375
+
type t = {
376
+
id : string option;
377
+
parent : Digest.t option;
378
+
comment : string option;
379
+
created : date_time;
380
+
container : string option;
381
+
container_config : config option;
382
+
docker_version : string option;
383
+
author : string option;
384
+
config : config option;
385
+
architecture : Arch.t;
386
+
variant : Arch.variant option;
387
+
os : OS.t;
388
+
os_version : string option;
389
+
os_features : string list;
390
+
size : int64 option;
391
+
rootfs : rootfs;
392
+
history : history list;
393
+
}
394
+
395
+
let jsont =
396
+
Jsont.Object.map ~kind:"docker_image_config"
397
+
(fun
398
+
id
399
+
parent
400
+
comment
401
+
created
402
+
container
403
+
container_config
404
+
docker_version
405
+
author
406
+
config
407
+
architecture
408
+
variant
409
+
os
410
+
os_version
411
+
os_features
412
+
size
413
+
rootfs
414
+
history
415
+
->
416
+
{
417
+
id;
418
+
parent;
419
+
comment;
420
+
created;
421
+
container;
422
+
container_config;
423
+
docker_version;
424
+
author;
425
+
config;
426
+
architecture;
427
+
variant;
428
+
os;
429
+
os_version;
430
+
os_features = Option.value ~default:[] os_features;
431
+
size;
432
+
rootfs;
433
+
history = Option.value ~default:[] history;
434
+
})
435
+
|> Jsont.Object.opt_mem "id" Jsont.string ~enc:(fun t -> t.id)
436
+
|> Jsont.Object.opt_mem "parent" Digest.jsont ~enc:(fun t -> t.parent)
437
+
|> Jsont.Object.opt_mem "comment" Jsont.string ~enc:(fun t -> t.comment)
438
+
|> Jsont.Object.mem "created" date_time_jsont ~enc:(fun t -> t.created)
439
+
|> Jsont.Object.opt_mem "container" Jsont.string ~enc:(fun t -> t.container)
440
+
|> Jsont.Object.opt_mem "container_config" config_jsont ~enc:(fun t ->
441
+
t.container_config)
442
+
|> Jsont.Object.opt_mem "docker_version" Jsont.string ~enc:(fun t ->
443
+
t.docker_version)
444
+
|> Jsont.Object.opt_mem "author" Jsont.string ~enc:(fun t -> t.author)
445
+
|> Jsont.Object.opt_mem "config" config_jsont ~enc:(fun t -> t.config)
446
+
|> Jsont.Object.mem "architecture" Arch.jsont ~enc:(fun t -> t.architecture)
447
+
|> Jsont.Object.opt_mem "variant" Arch.variant_jsont ~enc:(fun t ->
448
+
t.variant)
449
+
|> Jsont.Object.mem "os" OS.jsont ~enc:(fun t -> t.os)
450
+
|> Jsont.Object.opt_mem "os.version" Jsont.string ~enc:(fun t ->
451
+
t.os_version)
452
+
|> Jsont.Object.opt_mem "os.features" (Jsont.list Jsont.string)
453
+
~enc:(fun t -> if t.os_features = [] then None else Some t.os_features)
454
+
|> Jsont.Object.opt_mem "Size" Jsont.int64 ~enc:(fun t -> t.size)
455
+
|> Jsont.Object.mem "rootfs" rootfs_jsont ~enc:(fun t -> t.rootfs)
456
+
|> Jsont.Object.opt_mem "history" (Jsont.list history_jsont) ~enc:(fun t ->
457
+
if t.history = [] then None else Some t.history)
458
+
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
459
+
460
+
let of_yojson json =
461
+
match Jsont_bytesrw.decode_string jsont (json_to_string json) with
462
+
| Ok t ->
463
+
if t.rootfs.type_ <> "layers" then Error "rootfs.type must be 'layers'"
464
+
else Ok t
465
+
| Error e -> Error e
466
+
467
+
let to_yojson t =
468
+
match Jsont_bytesrw.encode_string jsont t with
469
+
| Ok s -> (
470
+
match json_of_string s with
471
+
| Ok j -> j
472
+
| Error _ -> Jsont.Null ((), Jsont.Meta.none))
473
+
| Error _ -> Jsont.Null ((), Jsont.Meta.none)
474
+
475
+
let pp ppf t = pp_json ppf (to_yojson t)
476
+
477
+
let of_string str =
478
+
wrap
479
+
@@
480
+
let* json = json_of_string str in
481
+
of_yojson json
482
+
483
+
let platform { os_version; os_features; variant; architecture; os; _ } =
484
+
Platform.v ?os_version ~os_features ?variant architecture os
485
+
end
486
+
487
+
type t = OCI of OCI.t | Docker of Docker.t
488
+
489
+
let pp ppf = function
490
+
| OCI oci -> pp_json ppf (OCI.to_yojson oci)
491
+
| Docker docker -> pp_json ppf (Docker.to_yojson docker)
492
+
493
+
let env = function
494
+
| OCI oci -> (
495
+
match Option.map (fun (config : OCI.config) -> config.env) oci.config with
496
+
| None -> []
497
+
| Some v -> v)
498
+
| Docker docker -> (
499
+
match
500
+
Option.bind docker.config (fun (config : Docker.config) -> config.env)
501
+
with
502
+
| None -> []
503
+
| Some v -> v)
504
+
505
+
let platform = function
506
+
| OCI c -> OCI.platform c
507
+
| Docker d -> Docker.platform d
508
+
509
+
let of_string ~media_type str =
510
+
match media_type with
511
+
| Media_type.OCI Image_config ->
512
+
let+ c = OCI.of_string str in
513
+
OCI c
514
+
| Docker Image_config ->
515
+
let+ c = Docker.of_string str in
516
+
Docker c
517
+
| ty ->
518
+
error_msg "Config.of_string: %a is not a supported media type."
519
+
Media_type.pp ty
+35
src/spec/config.mli
+35
src/spec/config.mli
···
1
+
(** Configuration *)
2
+
3
+
module OCI : sig
4
+
type config
5
+
type t
6
+
7
+
val jsont : t Jsont.t
8
+
val of_yojson : Jsont.json -> (t, string) result
9
+
val to_yojson : t -> Jsont.json
10
+
val of_string : string -> (t, [ `Msg of string ]) result
11
+
val platform : t -> Platform.t
12
+
end
13
+
14
+
module Docker : sig
15
+
type t
16
+
17
+
val jsont : t Jsont.t
18
+
val of_yojson : Jsont.json -> (t, string) result
19
+
val to_yojson : t -> Jsont.json
20
+
val pp : t Fmt.t
21
+
val of_string : string -> (t, [ `Msg of string ]) result
22
+
val platform : t -> Platform.t
23
+
end
24
+
25
+
type t = OCI of OCI.t | Docker of Docker.t
26
+
27
+
val pp : t Fmt.t
28
+
29
+
val env : t -> (string * string) list
30
+
(** Environment variables *)
31
+
32
+
val platform : t -> Platform.t
33
+
34
+
val of_string :
35
+
media_type:Media_type.t -> string -> (t, [ `Msg of string ]) result
+89
src/spec/content_type.ml
+89
src/spec/content_type.ml
···
1
+
open Astring
2
+
3
+
type t = {
4
+
type' : string;
5
+
facets : string list;
6
+
suffix : string option;
7
+
parameters : (string * string) list;
8
+
}
9
+
10
+
exception Break of string
11
+
12
+
let break fmt = Fmt.kstr (fun s -> raise (Break s)) fmt
13
+
14
+
let check_name_first = function
15
+
| 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' -> ()
16
+
| _ -> break "rfc6838: name first"
17
+
18
+
let check_name_chars = function
19
+
| 'a' .. 'z'
20
+
| 'A' .. 'Z'
21
+
| '0' .. '9'
22
+
| '!' | '#' | '$' | '&' | '-' | '^' | '_' ->
23
+
()
24
+
| _ -> break "rfc6838: name chars"
25
+
26
+
let check_name = function
27
+
| "" -> break "rfc6838: empty name"
28
+
| s ->
29
+
check_name_first s.[0];
30
+
if String.length s > 127 then
31
+
break "rfc6838: length of type (%d)" (String.length s);
32
+
String.iter check_name_chars s
33
+
34
+
let facet_of_string s =
35
+
let facets = String.cuts ~sep:"." s in
36
+
List.iter check_name facets;
37
+
facets
38
+
39
+
let subtype_of_string s =
40
+
match String.cut ~sep:"+" s with
41
+
| Some (f, suffix) ->
42
+
check_name suffix;
43
+
let fs = facet_of_string f in
44
+
(fs, Some suffix)
45
+
| None ->
46
+
let fs = facet_of_string s in
47
+
(fs, None)
48
+
49
+
let prefix_of_string s =
50
+
match String.cut ~sep:"/" s with
51
+
| Some (type', s) ->
52
+
check_name type';
53
+
let fs, suffix = subtype_of_string s in
54
+
(type', fs, suffix)
55
+
| None -> break "rfc6838: prefix"
56
+
57
+
let parameter_of_string s =
58
+
match String.cut ~sep:"=" s with
59
+
| Some (k, v) ->
60
+
check_name k;
61
+
(k, v)
62
+
| None -> break "rfc6838: parameter"
63
+
64
+
let of_string s =
65
+
match String.cuts ~sep:";" s with
66
+
| [] -> Error "rfc6838: empty"
67
+
| s :: ps -> (
68
+
try
69
+
let parameters = List.map parameter_of_string ps in
70
+
let type', facets, suffix = prefix_of_string s in
71
+
Ok { type'; facets; suffix; parameters }
72
+
with Break e -> Error e)
73
+
74
+
let to_string t =
75
+
let p =
76
+
t.type' ^ "/"
77
+
^ String.concat ~sep:"." t.facets
78
+
^ match t.suffix with None -> "" | Some s -> "+" ^ s
79
+
in
80
+
let ps = List.map (fun (k, v) -> k ^ "=" ^ v) t.parameters in
81
+
String.concat ~sep:"; " (p :: ps)
82
+
83
+
let jsont =
84
+
Jsont.map ~kind:"content_type"
85
+
~dec:(fun s ->
86
+
match of_string s with
87
+
| Ok v -> v
88
+
| Error e -> Jsont.Error.msgf Jsont.Meta.none "invalid content_type: %s" e)
89
+
~enc:to_string Jsont.string
+5
src/spec/content_type.mli
+5
src/spec/content_type.mli
+127
src/spec/descriptor.ml
+127
src/spec/descriptor.ml
···
1
+
open Common
2
+
3
+
module Uri_jsont = struct
4
+
let jsont =
5
+
Jsont.map ~kind:"uri"
6
+
~dec:(fun s ->
7
+
let uri = Uri.of_string s in
8
+
match Uri.scheme uri with
9
+
| Some _ -> uri
10
+
| None ->
11
+
Jsont.Error.msgf Jsont.Meta.none "invalid URL: missing scheme in %s"
12
+
s)
13
+
~enc:Uri.to_string Jsont.string
14
+
end
15
+
16
+
type t = {
17
+
media_type : Media_type.t;
18
+
digest : Digest.t;
19
+
size : z;
20
+
urls : Uri.t list;
21
+
annotations : (Annotation.t, string) map;
22
+
data : Base64.t option;
23
+
platform : Platform.t option;
24
+
artifact_type : Content_type.t option;
25
+
}
26
+
27
+
let annotations_jsont =
28
+
map_jsont
29
+
(fun s -> Ok (Annotation.of_string s))
30
+
Annotation.to_string Jsont.string
31
+
32
+
let jsont =
33
+
Jsont.Object.map ~kind:"descriptor"
34
+
(fun media_type digest size urls annotations data platform artifact_type ->
35
+
{
36
+
media_type;
37
+
digest;
38
+
size;
39
+
urls = Option.value ~default:[] urls;
40
+
annotations = Option.value ~default:[] annotations;
41
+
data;
42
+
platform;
43
+
artifact_type;
44
+
})
45
+
|> Jsont.Object.mem "mediaType" Media_type.jsont ~enc:(fun d -> d.media_type)
46
+
|> Jsont.Object.mem "digest" Digest.jsont ~enc:(fun d -> d.digest)
47
+
|> Jsont.Object.mem "size" z_jsont ~enc:(fun d -> d.size)
48
+
|> Jsont.Object.opt_mem "urls" (Jsont.list Uri_jsont.jsont) ~enc:(fun d ->
49
+
if d.urls = [] then None else Some d.urls)
50
+
|> Jsont.Object.opt_mem "annotations" annotations_jsont ~enc:(fun d ->
51
+
if d.annotations = [] then None else Some d.annotations)
52
+
|> Jsont.Object.opt_mem "data" Base64.jsont ~enc:(fun d -> d.data)
53
+
|> Jsont.Object.opt_mem "platform" Platform.jsont ~enc:(fun d -> d.platform)
54
+
|> Jsont.Object.opt_mem "artifactType" Content_type.jsont ~enc:(fun d ->
55
+
d.artifact_type)
56
+
|> Jsont.Object.finish
57
+
58
+
let v ?platform ?data ~media_type ~size digest =
59
+
let data =
60
+
match data with None -> None | Some d -> Some (Base64.encode d)
61
+
in
62
+
{
63
+
media_type;
64
+
size;
65
+
digest;
66
+
urls = [];
67
+
annotations = [];
68
+
data;
69
+
platform;
70
+
artifact_type = None;
71
+
}
72
+
73
+
let of_yojson json =
74
+
match Jsont_bytesrw.decode_string jsont (json_to_string json) with
75
+
| Ok t -> Ok t
76
+
| Error e -> Error e
77
+
78
+
let to_yojson t =
79
+
match Jsont_bytesrw.encode_string jsont t with
80
+
| Ok s -> (
81
+
match json_of_string s with
82
+
| Ok j -> j
83
+
| Error _ -> Jsont.Null ((), Jsont.Meta.none))
84
+
| Error _ -> Jsont.Null ((), Jsont.Meta.none)
85
+
86
+
let pp ppf t = pp_json ppf (to_yojson t)
87
+
let to_string = Fmt.to_to_string pp
88
+
let media_type t = t.media_type
89
+
let platform t = t.platform
90
+
91
+
let empty =
92
+
{
93
+
media_type = OCI Empty;
94
+
size = Int63.of_int 2;
95
+
digest =
96
+
Digest.sha256
97
+
"44136fa355b3678a1146ad16f7e8649e94fb4fc21fe77e8310c060f61caaff8a";
98
+
data = Some (Base64.of_raw "e30=");
99
+
annotations = [];
100
+
urls = [];
101
+
platform = None;
102
+
artifact_type = None;
103
+
}
104
+
105
+
let size t = t.size
106
+
let digest t = t.digest
107
+
108
+
let decoded_data t =
109
+
match t.data with None -> Error (`Msg "no data") | Some d -> Base64.decode d
110
+
111
+
let check t =
112
+
match t.data with
113
+
| None -> Ok ()
114
+
| Some data -> (
115
+
match Base64.decode data with
116
+
| Error e -> Error e
117
+
| Ok data ->
118
+
if t.size = Int63.of_int (String.length data) then
119
+
Digest.validate t.digest data
120
+
else
121
+
error_msg "Descriptor.check: invalid size: expected %a, got %d"
122
+
Int63.pp t.size (String.length data))
123
+
124
+
let attestation_manifest d =
125
+
match List.assoc_opt Annotation.Reference_type d.annotations with
126
+
| Some "attestation-manifest" -> true
127
+
| _ -> false
+27
src/spec/descriptor.mli
+27
src/spec/descriptor.mli
···
1
+
open Common
2
+
open Optint
3
+
4
+
type t
5
+
6
+
val jsont : t Jsont.t
7
+
val of_yojson : Jsont.json -> (t, string) result
8
+
val to_yojson : t -> Jsont.json
9
+
10
+
val v :
11
+
?platform:Platform.t ->
12
+
?data:string ->
13
+
media_type:Media_type.t ->
14
+
size:z ->
15
+
Oci_spec__Digest.t ->
16
+
t
17
+
18
+
val pp : t Fmt.t
19
+
val to_string : t -> string
20
+
val digest : t -> Digest.t
21
+
val size : t -> Int63.t
22
+
val empty : t
23
+
val media_type : t -> Media_type.t
24
+
val platform : t -> Platform.t option
25
+
val decoded_data : t -> (string, [ `Msg of string ]) result
26
+
val check : t -> (unit, [ `Msg of string ]) result
27
+
val attestation_manifest : t -> bool
+161
src/spec/digest.ml
+161
src/spec/digest.ml
···
1
+
open Common
2
+
open Astring
3
+
4
+
type algorithm = SHA256 | SHA512 | Unregistered of string list
5
+
type t = { algorithm : algorithm; encoded : string }
6
+
7
+
let algorithm t = t.algorithm
8
+
9
+
exception Break of string
10
+
11
+
let break fmt = Fmt.kstr (fun s -> raise (Break s)) fmt
12
+
13
+
let algorithm_of_string = function
14
+
| "" -> error_msg "Digest.algorithm_of_string: error - empty digest"
15
+
| "sha256" -> Ok SHA256
16
+
| "sha512" -> Ok SHA512
17
+
| s -> (
18
+
let l =
19
+
String.fields
20
+
~is_sep:(function '+' | '.' | '_' | '-' -> true | _ -> false)
21
+
s
22
+
in
23
+
try
24
+
List.iter
25
+
(fun s ->
26
+
if s = "" then break "algorithm-component";
27
+
String.iter
28
+
(function
29
+
| 'a' .. 'z' | '0' .. '9' -> ()
30
+
| _ -> break "algorithm-component")
31
+
s)
32
+
l;
33
+
Ok (Unregistered l)
34
+
with Break e -> error_msg "Digest.algorithm_of_string: error - %s" e)
35
+
36
+
let string_of_algorithm = function
37
+
| SHA256 -> "sha256"
38
+
| SHA512 -> "sha512"
39
+
| Unregistered s -> String.concat ~sep:"+" s
40
+
41
+
let assert_hexa = function
42
+
| 'a' .. 'f' | '0' .. '9' -> ()
43
+
| c -> break "%c is not hexa-encoded" c
44
+
45
+
let assert_encoded = function
46
+
| 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '=' | '_' | '-' -> ()
47
+
| c -> break "%c is not encoded properly" c
48
+
49
+
let encoded_of_string algo e =
50
+
try
51
+
let () =
52
+
match algo with
53
+
| SHA256 ->
54
+
if String.length e <> 64 then break "invalid size";
55
+
String.iter assert_hexa e
56
+
| SHA512 ->
57
+
if String.length e <> 128 then break "invalid size";
58
+
String.iter assert_hexa e
59
+
| Unregistered _ -> String.iter assert_encoded e
60
+
in
61
+
Ok e
62
+
with Break e -> error_msg "Digest.encoded_of_string: invalid format (%S)" e
63
+
64
+
let v a e =
65
+
let+ e = encoded_of_string a e in
66
+
{ algorithm = a; encoded = e }
67
+
68
+
let unsafe_v a e = { algorithm = a; encoded = e }
69
+
let encoded_hash d = d.encoded
70
+
71
+
let of_string str =
72
+
match String.cut ~sep:":" str with
73
+
| None -> error_msg "Digest.of_string: %S does not contain ':'" str
74
+
| Some (a, e) -> (
75
+
match algorithm_of_string a with
76
+
| Ok a -> (
77
+
match encoded_of_string a e with
78
+
| Ok e -> Ok { algorithm = a; encoded = e }
79
+
| Error _ as e -> e)
80
+
| Error _ as e -> e)
81
+
82
+
let to_string t = string_of_algorithm t.algorithm ^ ":" ^ t.encoded
83
+
let pp = Fmt.of_to_string to_string
84
+
85
+
let jsont =
86
+
Jsont.map ~kind:"digest"
87
+
~dec:(fun s ->
88
+
match of_string s with
89
+
| Ok v -> v
90
+
| Error (`Msg e) ->
91
+
Jsont.Error.msgf Jsont.Meta.none "invalid digest: %s" e)
92
+
~enc:to_string Jsont.string
93
+
94
+
let equal x y =
95
+
x == y || (x.algorithm = y.algorithm && String.equal x.encoded y.encoded)
96
+
97
+
let sha256 s =
98
+
match encoded_of_string SHA256 s with
99
+
| Ok e -> { algorithm = SHA256; encoded = e }
100
+
| Error (`Msg e) -> invalid_arg e
101
+
102
+
let sha512 s =
103
+
match encoded_of_string SHA512 s with
104
+
| Ok e -> { algorithm = SHA512; encoded = e }
105
+
| Error (`Msg e) -> invalid_arg e
106
+
107
+
let validation_error a to_hex ~got ~expected =
108
+
let a = string_of_algorithm a in
109
+
error_msg "Digest.validate: validation error, got %s:%s, expected %s:%s" a
110
+
(to_hex got) a (to_hex expected)
111
+
112
+
let unregistered_error ds =
113
+
error_msg "Digest.validate: unregistered algorithms %a"
114
+
Fmt.(Dump.list string)
115
+
ds
116
+
117
+
let validate t buf =
118
+
match t.algorithm with
119
+
| SHA256 ->
120
+
let expected = Digestif.SHA256.of_hex t.encoded in
121
+
let got = Digestif.SHA256.digest_string buf in
122
+
if Digestif.SHA256.equal got expected then Ok ()
123
+
else validation_error SHA256 Digestif.SHA256.to_hex ~got ~expected
124
+
| SHA512 ->
125
+
let expected = Digestif.SHA512.of_hex t.encoded in
126
+
let got = Digestif.SHA512.digest_string buf in
127
+
if Digestif.SHA512.equal got expected then Ok ()
128
+
else validation_error SHA512 Digestif.SHA512.to_hex ~got ~expected
129
+
| Unregistered ds -> unregistered_error ds
130
+
131
+
let digest_string algo str =
132
+
let encoded =
133
+
match algo with
134
+
| SHA256 -> Digestif.SHA256.(to_hex (digest_string str))
135
+
| SHA512 -> Digestif.SHA512.(to_hex (digest_string str))
136
+
| _ -> invalid_arg "digest_string"
137
+
in
138
+
unsafe_v algo encoded
139
+
140
+
let chain algo = function
141
+
| [] -> []
142
+
| h :: t ->
143
+
let _, l =
144
+
List.fold_left
145
+
(fun (h, acc) l ->
146
+
let str = to_string h ^ " " ^ to_string l in
147
+
let h' = digest_string algo str in
148
+
(h', h' :: acc))
149
+
(h, [ h ]) t
150
+
in
151
+
List.rev l
152
+
153
+
let chain_id algo = function
154
+
| [] -> invalid_arg "chain_id: empty list"
155
+
| h :: t ->
156
+
List.fold_left
157
+
(fun h l ->
158
+
let str = to_string h ^ " " ^ to_string l in
159
+
let h' = digest_string algo str in
160
+
h')
161
+
h t
+20
src/spec/digest.mli
+20
src/spec/digest.mli
···
1
+
type algorithm = SHA256 | SHA512 | Unregistered of string list
2
+
type t
3
+
4
+
val jsont : t Jsont.t
5
+
val v : algorithm -> string -> (t, [ `Msg of string ]) result
6
+
val unsafe_v : algorithm -> string -> t
7
+
val algorithm : t -> algorithm
8
+
val string_of_algorithm : algorithm -> string
9
+
val algorithm_of_string : string -> (algorithm, [ `Msg of string ]) result
10
+
val sha256 : string -> t
11
+
val sha512 : string -> t
12
+
val validate : t -> string -> (unit, [ `Msg of string ]) result
13
+
val pp : t Fmt.t
14
+
val to_string : t -> string
15
+
val of_string : string -> (t, [ `Msg of string ]) result
16
+
val equal : t -> t -> bool
17
+
val chain : algorithm -> t list -> t list
18
+
val chain_id : algorithm -> t list -> t
19
+
val encoded_hash : t -> string
20
+
val digest_string : algorithm -> string -> t
+4
src/spec/dune
+4
src/spec/dune
+66
src/spec/index.ml
+66
src/spec/index.ml
···
1
+
open Common
2
+
3
+
let annotations_jsont =
4
+
map_jsont
5
+
(fun s -> Ok (Annotation.of_string s))
6
+
Annotation.to_string Jsont.string
7
+
8
+
type t = {
9
+
version : v2; (** Schema version - always 2 *)
10
+
artifact_type : rfc_6838 option;
11
+
manifests : Descriptor.t list;
12
+
platform : Platform.t option;
13
+
subject : Descriptor.t option;
14
+
annotations : (Annotation.t, string) map;
15
+
}
16
+
[@@warning "-69"]
17
+
18
+
let jsont =
19
+
Jsont.Object.map ~kind:"index"
20
+
(fun
21
+
version
22
+
_media_type
23
+
artifact_type
24
+
manifests
25
+
platform
26
+
subject
27
+
annotations
28
+
->
29
+
{
30
+
version;
31
+
artifact_type;
32
+
manifests;
33
+
platform;
34
+
subject;
35
+
annotations = Option.value ~default:[] annotations;
36
+
})
37
+
|> Jsont.Object.mem "schemaVersion" v2_jsont ~enc:(fun _ -> V2)
38
+
|> Jsont.Object.opt_mem "mediaType" Jsont.string ~enc:(fun _ ->
39
+
Some (Media_type.to_string (OCI Image_index)))
40
+
|> Jsont.Object.opt_mem "artifactType" rfc_6838_jsont ~enc:(fun t ->
41
+
t.artifact_type)
42
+
|> Jsont.Object.mem "manifests" (Jsont.list Descriptor.jsont) ~enc:(fun t ->
43
+
t.manifests)
44
+
|> Jsont.Object.opt_mem "platform" Platform.jsont ~enc:(fun t -> t.platform)
45
+
|> Jsont.Object.opt_mem "subject" Descriptor.jsont ~enc:(fun t -> t.subject)
46
+
|> Jsont.Object.opt_mem "annotations" annotations_jsont ~enc:(fun t ->
47
+
if t.annotations = [] then None else Some t.annotations)
48
+
|> Jsont.Object.finish
49
+
50
+
let of_yojson json =
51
+
match Jsont_bytesrw.decode_string jsont (json_to_string json) with
52
+
| Ok t -> Ok t
53
+
| Error e -> Error e
54
+
55
+
let to_yojson t =
56
+
match Jsont_bytesrw.encode_string jsont t with
57
+
| Ok s -> (
58
+
match json_of_string s with
59
+
| Ok j -> j
60
+
| Error _ -> Jsont.Null ((), Jsont.Meta.none))
61
+
| Error _ -> Jsont.Null ((), Jsont.Meta.none)
62
+
63
+
let pp ppf t = pp_json ppf (to_yojson t)
64
+
let to_string = Fmt.to_to_string pp
65
+
let manifests t = t.manifests
66
+
let platform t = t.platform
+9
src/spec/index.mli
+9
src/spec/index.mli
+1
src/spec/layer.ml
+1
src/spec/layer.ml
···
1
+
type t = string
+1
src/spec/layer.mli
+1
src/spec/layer.mli
···
1
+
type t
+26
src/spec/layout.ml
+26
src/spec/layout.ml
···
1
+
open Common
2
+
3
+
let file = "oci-layout"
4
+
let version = "1.0.0"
5
+
let index = "index.json"
6
+
let blobs = "blobs"
7
+
8
+
type t = { version : int }
9
+
10
+
let jsont =
11
+
Jsont.Object.map ~kind:"layout" (fun version -> { version })
12
+
|> Jsont.Object.mem "imageLayoutVersion" Jsont.int ~enc:(fun l -> l.version)
13
+
|> Jsont.Object.finish
14
+
15
+
let of_yojson json =
16
+
match Jsont_bytesrw.decode_string jsont (json_to_string json) with
17
+
| Ok t -> Ok t
18
+
| Error e -> Error e
19
+
20
+
let to_yojson t =
21
+
match Jsont_bytesrw.encode_string jsont t with
22
+
| Ok s -> (
23
+
match json_of_string s with
24
+
| Ok j -> j
25
+
| Error _ -> Jsont.Null ((), Jsont.Meta.none))
26
+
| Error _ -> Jsont.Null ((), Jsont.Meta.none)
+9
src/spec/layout.mli
+9
src/spec/layout.mli
+225
src/spec/manifest.ml
+225
src/spec/manifest.ml
···
1
+
open Common
2
+
3
+
let annotations_jsont =
4
+
map_jsont
5
+
(fun s -> Ok (Annotation.of_string s))
6
+
Annotation.to_string Jsont.string
7
+
8
+
module OCI = struct
9
+
type t = {
10
+
version : v2;
11
+
artifact_type : string option;
12
+
config : Descriptor.t;
13
+
layers : Descriptor.t list;
14
+
subject : Descriptor.t option;
15
+
annotations : (Annotation.t, string) map;
16
+
}
17
+
[@@warning "-69"]
18
+
19
+
let jsont =
20
+
Jsont.Object.map ~kind:"oci_manifest"
21
+
(fun
22
+
version _media_type artifact_type config layers subject annotations ->
23
+
{
24
+
version;
25
+
artifact_type;
26
+
config;
27
+
layers;
28
+
subject;
29
+
annotations = Option.value ~default:[] annotations;
30
+
})
31
+
|> Jsont.Object.mem "schemaVersion" v2_jsont ~enc:(fun _ -> V2)
32
+
|> Jsont.Object.mem "mediaType" Jsont.string ~enc:(fun _ ->
33
+
Media_type.to_string (OCI Image_manifest))
34
+
|> Jsont.Object.opt_mem "artifactType" Jsont.string ~enc:(fun t ->
35
+
t.artifact_type)
36
+
|> Jsont.Object.mem "config" Descriptor.jsont ~enc:(fun t -> t.config)
37
+
|> Jsont.Object.mem "layers" (Jsont.list Descriptor.jsont) ~enc:(fun t ->
38
+
t.layers)
39
+
|> Jsont.Object.opt_mem "subject" Descriptor.jsont ~enc:(fun t -> t.subject)
40
+
|> Jsont.Object.opt_mem "annotations" annotations_jsont ~enc:(fun t ->
41
+
if t.annotations = [] then None else Some t.annotations)
42
+
|> Jsont.Object.finish
43
+
44
+
let of_yojson json =
45
+
match Jsont_bytesrw.decode_string jsont (json_to_string json) with
46
+
| Ok t -> (
47
+
(* Validate the manifest *)
48
+
let check () =
49
+
match Descriptor.media_type t.config with
50
+
| OCI Empty -> (
51
+
match t.artifact_type with
52
+
| None ->
53
+
Error
54
+
"artifactType MUST be set when config.mediaType is set to \
55
+
the empty value."
56
+
| Some _ -> Ok ())
57
+
| _ -> Ok ()
58
+
in
59
+
let check_layers () =
60
+
match t.layers with
61
+
| [] ->
62
+
Error "For portability, layers SHOULD have at least one entry."
63
+
| _ -> Ok ()
64
+
in
65
+
match check () with
66
+
| Error e -> Error e
67
+
| Ok () -> (
68
+
match check_layers () with Error e -> Error e | Ok () -> Ok t))
69
+
| Error e -> Error e
70
+
71
+
let to_yojson t =
72
+
match Jsont_bytesrw.encode_string jsont t with
73
+
| Ok s -> (
74
+
match json_of_string s with
75
+
| Ok j -> j
76
+
| Error _ -> Jsont.Null ((), Jsont.Meta.none))
77
+
| Error _ -> Jsont.Null ((), Jsont.Meta.none)
78
+
79
+
let pp ppf t = pp_json ppf (to_yojson t)
80
+
let to_string = Fmt.to_to_string pp
81
+
let media_type _ = Media_type.OCI.Image_manifest
82
+
let layers t = t.layers
83
+
let config t = t.config
84
+
85
+
let size t =
86
+
List.fold_left
87
+
(fun acc d -> Int63.add acc (Descriptor.size d))
88
+
(Descriptor.size t.config) t.layers
89
+
90
+
let of_string s =
91
+
wrap
92
+
@@ let* json = json_of_string s in
93
+
of_yojson json
94
+
end
95
+
96
+
module Docker = struct
97
+
type t = { version : v2; config : Descriptor.t; layers : Descriptor.t list }
98
+
[@@warning "-69"]
99
+
100
+
let jsont =
101
+
Jsont.Object.map ~kind:"docker_manifest"
102
+
(fun version _media_type config layers -> { version; config; layers })
103
+
|> Jsont.Object.mem "schemaVersion" v2_jsont ~enc:(fun _ -> V2)
104
+
|> Jsont.Object.mem "mediaType" Jsont.string ~enc:(fun _ ->
105
+
Media_type.to_string (Docker Image_manifest))
106
+
|> Jsont.Object.mem "config" Descriptor.jsont ~enc:(fun t -> t.config)
107
+
|> Jsont.Object.mem "layers" (Jsont.list Descriptor.jsont) ~enc:(fun t ->
108
+
t.layers)
109
+
|> Jsont.Object.finish
110
+
111
+
let of_yojson json =
112
+
match Jsont_bytesrw.decode_string jsont (json_to_string json) with
113
+
| Ok t -> Ok t
114
+
| Error e -> Error e
115
+
116
+
let to_yojson t =
117
+
match Jsont_bytesrw.encode_string jsont t with
118
+
| Ok s -> (
119
+
match json_of_string s with
120
+
| Ok j -> j
121
+
| Error _ -> Jsont.Null ((), Jsont.Meta.none))
122
+
| Error _ -> Jsont.Null ((), Jsont.Meta.none)
123
+
124
+
let layers t = t.layers
125
+
let config t = t.config
126
+
let pp ppf t = pp_json ppf (to_yojson t)
127
+
let to_string = Fmt.to_to_string pp
128
+
let media_type _ = Media_type.Docker.Image_manifest
129
+
130
+
let size t =
131
+
List.fold_left
132
+
(fun acc d -> Int63.add acc (Descriptor.size d))
133
+
(Descriptor.size t.config) t.layers
134
+
135
+
let of_string s =
136
+
wrap
137
+
@@ let* json = json_of_string s in
138
+
of_yojson json
139
+
end
140
+
141
+
type t =
142
+
[ `Docker_manifest of Docker.t
143
+
| `Docker_manifest_list of Manifest_list.t
144
+
| `OCI_index of Index.t
145
+
| `OCI_manifest of OCI.t ]
146
+
147
+
let docker_manifest json =
148
+
let+ m = Docker.of_yojson json in
149
+
`Docker_manifest m
150
+
151
+
let docker_manifest_list json =
152
+
let+ m = Manifest_list.of_yojson json in
153
+
`Docker_manifest_list m
154
+
155
+
let oci_index json =
156
+
let+ m = Index.of_yojson json in
157
+
`OCI_index m
158
+
159
+
let oci_manifest json =
160
+
let+ m = OCI.of_yojson json in
161
+
`OCI_manifest m
162
+
163
+
let of_yojson json =
164
+
let str = json_to_string json in
165
+
let media_type =
166
+
match Media_type.guess str with
167
+
| Some mt -> mt
168
+
| None -> Media_type.OCI Image_index
169
+
in
170
+
match media_type with
171
+
| Docker Image_manifest -> docker_manifest json
172
+
| Docker Image_manifest_list -> docker_manifest_list json
173
+
| OCI Image_index -> oci_index json
174
+
| OCI Image_manifest -> oci_manifest json
175
+
| m -> error "Manifest.of_yojson: invalid media-type: %a" Media_type.pp m
176
+
177
+
let of_string body =
178
+
wrap
179
+
@@
180
+
let* json = json_of_string body in
181
+
of_yojson json
182
+
183
+
let to_string = function
184
+
| `Docker_manifest m -> Docker.to_string m
185
+
| `Docker_manifest_list l -> Manifest_list.to_string l
186
+
| `OCI_index i -> Index.to_string i
187
+
| `OCI_manifest m -> OCI.to_string m
188
+
189
+
let to_yojson = function
190
+
| `Docker_manifest m -> Docker.to_yojson m
191
+
| `Docker_manifest_list l -> Manifest_list.to_yojson l
192
+
| `OCI_index i -> Index.to_yojson i
193
+
| `OCI_manifest m -> OCI.to_yojson m
194
+
195
+
let pp = Fmt.of_to_string to_string
196
+
197
+
let size = function
198
+
| `Docker_manifest m -> Some (Docker.size m)
199
+
| `Docker_manifest_list _ -> None
200
+
| `OCI_index _ -> None
201
+
| `OCI_manifest m -> Some (OCI.size m)
202
+
203
+
let media_type = function
204
+
| `Docker_manifest _ -> Media_type.Docker Image_manifest
205
+
| `Docker_manifest_list _ -> Media_type.Docker Image_manifest_list
206
+
| `OCI_index _ -> Media_type.OCI Image_index
207
+
| `OCI_manifest _ -> Media_type.OCI Image_manifest
208
+
209
+
let platform read = function
210
+
| `Docker_manifest m ->
211
+
let config = Docker.config m in
212
+
let c = read config in
213
+
Some (Config.platform c)
214
+
| `Docker_manifest_list _ -> None
215
+
| `OCI_index i -> Index.platform i
216
+
| `OCI_manifest m ->
217
+
let config = OCI.config m in
218
+
let c = read config in
219
+
Some (Config.platform c)
220
+
221
+
let manifests = function
222
+
| `Docker_manifest _ -> []
223
+
| `Docker_manifest_list l -> Manifest_list.manifests l
224
+
| `OCI_index i -> Index.manifests i
225
+
| `OCI_manifest _ -> []
+45
src/spec/manifest.mli
+45
src/spec/manifest.mli
···
1
+
open Optint
2
+
3
+
module OCI : sig
4
+
type t
5
+
6
+
val jsont : t Jsont.t
7
+
val of_yojson : Jsont.json -> (t, string) result
8
+
val to_yojson : t -> Jsont.json
9
+
val pp : t Fmt.t
10
+
val of_string : string -> (t, [ `Msg of string ]) result
11
+
val to_string : t -> string
12
+
val media_type : t -> Media_type.OCI.t
13
+
val config : t -> Descriptor.t
14
+
val layers : t -> Descriptor.t list
15
+
end
16
+
17
+
module Docker : sig
18
+
type t
19
+
20
+
val jsont : t Jsont.t
21
+
val of_yojson : Jsont.json -> (t, string) result
22
+
val to_yojson : t -> Jsont.json
23
+
val pp : t Fmt.t
24
+
val of_string : string -> (t, [ `Msg of string ]) result
25
+
val to_string : t -> string
26
+
val config : t -> Descriptor.t
27
+
val layers : t -> Descriptor.t list
28
+
val media_type : t -> Media_type.Docker.t
29
+
end
30
+
31
+
type t =
32
+
[ `Docker_manifest of Docker.t
33
+
| `Docker_manifest_list of Manifest_list.t
34
+
| `OCI_index of Index.t
35
+
| `OCI_manifest of OCI.t ]
36
+
37
+
val of_yojson : Jsont.json -> (t, string) result
38
+
val to_yojson : t -> Jsont.json
39
+
val pp : t Fmt.t
40
+
val to_string : t -> string
41
+
val of_string : string -> (t, [ `Msg of string ]) result
42
+
val size : t -> Int63.t option
43
+
val media_type : t -> Media_type.t
44
+
val platform : (Descriptor.t -> Config.t) -> t -> Platform.t option
45
+
val manifests : t -> Descriptor.t list
+30
src/spec/manifest_list.ml
+30
src/spec/manifest_list.ml
···
1
+
open Common
2
+
3
+
type t = { version : v2; manifests : Descriptor.t list } [@@warning "-69"]
4
+
5
+
let jsont =
6
+
Jsont.Object.map ~kind:"manifest_list" (fun version _media_type manifests ->
7
+
{ version; manifests })
8
+
|> Jsont.Object.mem "schemaVersion" v2_jsont ~enc:(fun _ -> V2)
9
+
|> Jsont.Object.mem "mediaType" Jsont.string ~enc:(fun _ ->
10
+
Media_type.to_string (Docker Image_manifest_list))
11
+
|> Jsont.Object.mem "manifests" (Jsont.list Descriptor.jsont) ~enc:(fun t ->
12
+
t.manifests)
13
+
|> Jsont.Object.finish
14
+
15
+
let of_yojson json =
16
+
match Jsont_bytesrw.decode_string jsont (json_to_string json) with
17
+
| Ok t -> Ok t
18
+
| Error e -> Error e
19
+
20
+
let to_yojson t =
21
+
match Jsont_bytesrw.encode_string jsont t with
22
+
| Ok s -> (
23
+
match json_of_string s with
24
+
| Ok j -> j
25
+
| Error _ -> Jsont.Null ((), Jsont.Meta.none))
26
+
| Error _ -> Jsont.Null ((), Jsont.Meta.none)
27
+
28
+
let pp ppf t = pp_json ppf (to_yojson t)
29
+
let to_string = Fmt.to_to_string pp
30
+
let manifests t = t.manifests
+8
src/spec/manifest_list.mli
+8
src/spec/manifest_list.mli
+133
src/spec/media_type.ml
+133
src/spec/media_type.ml
···
1
+
open Common
2
+
module Content_type = Content_type
3
+
4
+
module OCI = struct
5
+
type t =
6
+
| Empty
7
+
| Descriptor
8
+
| Layout_header
9
+
| Image_index
10
+
| Image_manifest
11
+
| Image_config
12
+
| Layer_tar
13
+
| Layer_tar_gzip
14
+
| Layer_tar_zstd
15
+
| Layer_non_distributable_tar
16
+
| Layer_non_distributable_tar_gzip
17
+
| Layer_non_distributable_tar_zstd
18
+
| Trust
19
+
| Other of Content_type.t
20
+
21
+
let of_string = function
22
+
| "application/vnd.oci.descriptor.v1+json" -> Ok Descriptor
23
+
| "application/vnd.oci.layout.header.v1+json" -> Ok Layout_header
24
+
| "application/vnd.oci.image.index.v1+json" -> Ok Image_index
25
+
| "application/vnd.oci.image.manifest.v1+json" -> Ok Image_manifest
26
+
| "application/vnd.oci.image.config.v1+json" -> Ok Image_config
27
+
| "application/vnd.oci.image.layer.v1.tar" -> Ok Layer_tar
28
+
| "application/vnd.oci.image.layer.v1.tar+gzip" -> Ok Layer_tar_gzip
29
+
| "application/vnd.oci.image.layer.v1.tar+zstd" -> Ok Layer_tar_zstd
30
+
| "application/vnd.oci.empty.v1+json" -> Ok Empty
31
+
| "application/vnd.oci.image.layer.nondistributable.v1.tar" ->
32
+
Ok Layer_non_distributable_tar
33
+
| "application/vnd.oci.image.layer.nondistributable.v1.tar+gzip" ->
34
+
Ok Layer_non_distributable_tar_gzip
35
+
| "application/vnd.oci.image.layer.nondistributable.v1.tar+zstd" ->
36
+
Ok Layer_non_distributable_tar_zstd
37
+
| "application/vnd.in-toto+json" -> Ok Trust
38
+
| s ->
39
+
let+ s = Content_type.of_string s in
40
+
Other s
41
+
42
+
let to_string = function
43
+
| Descriptor -> "application/vnd.oci.descriptor.v1+json"
44
+
| Layout_header -> "application/vnd.oci.layout.header.v1+json"
45
+
| Image_index -> "application/vnd.oci.image.index.v1+json"
46
+
| Image_manifest -> "application/vnd.oci.image.manifest.v1+json"
47
+
| Image_config -> "application/vnd.oci.image.config.v1+json"
48
+
| Layer_tar -> "application/vnd.oci.image.layer.v1.tar"
49
+
| Layer_tar_gzip -> "application/vnd.oci.image.layer.v1.tar+gzip"
50
+
| Layer_tar_zstd -> "application/vnd.oci.image.layer.v1.tar+zstd"
51
+
| Empty -> "application/vnd.oci.empty.v1+json"
52
+
| Layer_non_distributable_tar ->
53
+
"application/vnd.oci.image.layer.nondistributable.v1.tar"
54
+
| Layer_non_distributable_tar_gzip ->
55
+
"application/vnd.oci.image.layer.nondistributable.v1.tar+gzip"
56
+
| Layer_non_distributable_tar_zstd ->
57
+
"application/vnd.oci.image.layer.nondistributable.v1.tar+zstd"
58
+
| Trust -> "application/vnd.in-toto+json"
59
+
| Other e -> Content_type.to_string e
60
+
end
61
+
62
+
module Docker = struct
63
+
type t =
64
+
| Image_manifest
65
+
| Image_manifest_list
66
+
| Image_config
67
+
| Layer_tar_gzip
68
+
| Layer_non_distributable_tar_gzip
69
+
| Plugin_config
70
+
71
+
let of_string = function
72
+
| "application/vnd.docker.distribution.manifest.v2+json" ->
73
+
Some Image_manifest
74
+
| "application/vnd.docker.distribution.manifest.list.v2+json" ->
75
+
Some Image_manifest_list
76
+
| "application/vnd.docker.container.image.v1+json" -> Some Image_config
77
+
| "application/vnd.docker.image.rootfs.diff.tar.gzip" -> Some Layer_tar_gzip
78
+
| "application/vnd.docker.image.rootfs.foreign.diff.tar.gzip" ->
79
+
Some Layer_non_distributable_tar_gzip
80
+
| "application/vnd.docker.plugin.v1+json" -> Some Plugin_config
81
+
| _ -> None
82
+
83
+
let to_string = function
84
+
| Image_manifest -> "application/vnd.docker.distribution.manifest.v2+json"
85
+
| Image_manifest_list ->
86
+
"application/vnd.docker.distribution.manifest.list.v2+json"
87
+
| Image_config -> "application/vnd.docker.container.image.v1+json"
88
+
| Layer_tar_gzip -> "application/vnd.docker.image.rootfs.diff.tar.gzip"
89
+
| Layer_non_distributable_tar_gzip ->
90
+
"application/vnd.docker.image.rootfs.foreign.diff.tar.gzip"
91
+
| Plugin_config -> "application/vnd.docker.plugin.v1+json"
92
+
end
93
+
94
+
type t = OCI of OCI.t | Docker of Docker.t
95
+
96
+
let of_string str =
97
+
match Docker.of_string str with
98
+
| Some t -> Ok (Docker t)
99
+
| None -> (
100
+
match OCI.of_string str with
101
+
| Ok t -> Ok (OCI t)
102
+
| Error e -> Error (`Msg e))
103
+
104
+
let to_string = function
105
+
| Docker t -> Docker.to_string t
106
+
| OCI t -> OCI.to_string t
107
+
108
+
let jsont =
109
+
Jsont.map ~kind:"media_type"
110
+
~dec:(fun s ->
111
+
match of_string s with
112
+
| Ok t -> t
113
+
| Error (`Msg e) ->
114
+
Jsont.Error.msgf Jsont.Meta.none "invalid media_type: %s" e)
115
+
~enc:to_string Jsont.string
116
+
117
+
let media_type_extractor =
118
+
Jsont.Object.map ~kind:"media_type_extractor" (fun media_type -> media_type)
119
+
|> Jsont.Object.opt_mem "mediaType" Jsont.string ~enc:(fun _ -> None)
120
+
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
121
+
122
+
let guess str =
123
+
if str = "" then None
124
+
else
125
+
match str.[0] with
126
+
| '{' -> (
127
+
match Jsont_bytesrw.decode_string media_type_extractor str with
128
+
| Ok (Some s) -> (
129
+
match of_string s with Ok r -> Some r | Error _ -> None)
130
+
| _ -> None)
131
+
| _ -> None
132
+
133
+
let pp = Fmt.of_to_string to_string
+41
src/spec/media_type.mli
+41
src/spec/media_type.mli
···
1
+
module Content_type = Content_type
2
+
3
+
module OCI : sig
4
+
type t =
5
+
| Empty
6
+
| Descriptor
7
+
| Layout_header
8
+
| Image_index
9
+
| Image_manifest
10
+
| Image_config
11
+
| Layer_tar
12
+
| Layer_tar_gzip
13
+
| Layer_tar_zstd
14
+
| Layer_non_distributable_tar
15
+
| Layer_non_distributable_tar_gzip
16
+
| Layer_non_distributable_tar_zstd
17
+
| Trust
18
+
| Other of Content_type.t
19
+
20
+
val to_string : t -> string
21
+
end
22
+
23
+
module Docker : sig
24
+
type t =
25
+
| Image_manifest
26
+
| Image_manifest_list
27
+
| Image_config
28
+
| Layer_tar_gzip
29
+
| Layer_non_distributable_tar_gzip
30
+
| Plugin_config
31
+
32
+
val to_string : t -> string
33
+
end
34
+
35
+
type t = OCI of OCI.t | Docker of Docker.t
36
+
37
+
val jsont : t Jsont.t
38
+
val pp : t Fmt.t
39
+
val to_string : t -> string
40
+
val of_string : string -> (t, [ `Msg of string ]) result
41
+
val guess : string -> t option
+31
src/spec/oci_spec.ml
+31
src/spec/oci_spec.ml
···
1
+
module Common = Common
2
+
module Config = Config
3
+
module Descriptor = Descriptor
4
+
module Index = Index
5
+
module Annotation = Annotation
6
+
module Digest = Digest
7
+
module Manifest = Manifest
8
+
module Manifest_list = Manifest_list
9
+
module Layer = Layer
10
+
module Media_type = Media_type
11
+
module Blob = Blob
12
+
module Auth = Auth
13
+
module Platform = Platform
14
+
module OS = OS
15
+
module Arch = Arch
16
+
17
+
type oci = {
18
+
manifest : Manifest.OCI.t;
19
+
index : Index.t option;
20
+
layers : Layer.t list;
21
+
config : Config.OCI.t;
22
+
}
23
+
24
+
let manifest t = t.manifest
25
+
let index t = t.index
26
+
let layers t = t.layers
27
+
let config t = t.config
28
+
29
+
type docker = { manifest_list : Manifest_list.t }
30
+
31
+
let manifest_list t = t.manifest_list
+52
src/spec/oci_spec.mli
+52
src/spec/oci_spec.mli
···
1
+
(** {1 Container Image Spec}
2
+
3
+
This module provides converters from OCI and Docker image specifications to
4
+
OCaml data types. It abstracts the details of each image specification to
5
+
allow easy integration and manipulation in OCaml applications.
6
+
7
+
Users of this module can expect types and sub-modules representing each of
8
+
the main components of OCI and Docker image specifications. *)
9
+
10
+
(** {1 Types} *)
11
+
12
+
module Common = Common
13
+
module Config = Config
14
+
module Descriptor = Descriptor
15
+
module Index = Index
16
+
module Annotation = Annotation
17
+
module Digest = Digest
18
+
module Manifest = Manifest
19
+
module Manifest_list = Manifest_list
20
+
module Layer = Layer
21
+
module Media_type = Media_type
22
+
module Blob = Blob
23
+
module Auth = Auth
24
+
module Platform = Platform
25
+
module OS = OS
26
+
module Arch = Arch
27
+
28
+
type oci
29
+
(** The type for OCI images as described in the
30
+
{{:https://github.com/opencontainers/image-spec/blob/main/spec.md} Image
31
+
Format Specification} of the
32
+
{{:https://opencontainers.org/} Open Container Initative}. *)
33
+
34
+
val manifest : oci -> Manifest.OCI.t
35
+
(** [manifest img] is the manifest of the OCI image [img]. *)
36
+
37
+
val index : oci -> Index.t option
38
+
(** [index img] is the optional index of the OCI image [img]. *)
39
+
40
+
val layers : oci -> Layer.t list
41
+
(** [layers img] is the list of layers of the OCI image [img]. *)
42
+
43
+
val config : oci -> Config.OCI.t
44
+
(** [config img] is the configuration of the OCI image [img]. *)
45
+
46
+
type docker
47
+
(** The type for Docker images as specified by the
48
+
{{:https://github.com/moby/moby/blob/master/image/spec/spec.md} Docker Image
49
+
Specification v1.3} *)
50
+
51
+
val manifest_list : docker -> Manifest_list.t
52
+
(** [manifest_list img] is the manifest list of the Docker image [img]. *)
+165
src/spec/platform.ml
+165
src/spec/platform.ml
···
1
+
open Common
2
+
open Astring
3
+
4
+
type t = {
5
+
architecture : Arch.t;
6
+
os : OS.t;
7
+
os_version : string option;
8
+
os_features : string list;
9
+
variant : Arch.variant option;
10
+
features : string list;
11
+
}
12
+
13
+
let jsont =
14
+
Jsont.Object.map ~kind:"platform"
15
+
(fun architecture os os_version os_features variant features ->
16
+
{
17
+
architecture;
18
+
os;
19
+
os_version;
20
+
os_features = Option.value ~default:[] os_features;
21
+
variant;
22
+
features = Option.value ~default:[] features;
23
+
})
24
+
|> Jsont.Object.mem "architecture" Arch.jsont ~enc:(fun p -> p.architecture)
25
+
|> Jsont.Object.mem "os" OS.jsont ~enc:(fun p -> p.os)
26
+
|> Jsont.Object.opt_mem "os.version" Jsont.string ~enc:(fun p -> p.os_version)
27
+
|> Jsont.Object.opt_mem "os.features" (Jsont.list Jsont.string) ~enc:(fun p ->
28
+
if p.os_features = [] then None else Some p.os_features)
29
+
|> Jsont.Object.opt_mem "variant" Arch.variant_jsont ~enc:(fun p -> p.variant)
30
+
|> Jsont.Object.opt_mem "features" (Jsont.list Jsont.string) ~enc:(fun p ->
31
+
if p.features = [] then None else Some p.features)
32
+
|> Jsont.Object.finish
33
+
34
+
let v ?os_version ?(os_features = []) ?variant architecture os =
35
+
{ architecture; os; os_version; os_features; variant; features = [] }
36
+
37
+
let arch t = t.architecture
38
+
let os t = t.os
39
+
let unknown = v Unknown Unknown
40
+
41
+
let of_string str =
42
+
match String.cuts ~sep:"/" str with
43
+
| [ os; arch ] ->
44
+
let* os = OS.of_string os in
45
+
let+ architecture = Arch.of_string arch in
46
+
{
47
+
os;
48
+
architecture;
49
+
os_version = None;
50
+
os_features = [];
51
+
variant = None;
52
+
features = [];
53
+
}
54
+
| [ os; arch; variant ] ->
55
+
let* os = OS.of_string os in
56
+
let* architecture = Arch.of_string arch in
57
+
let+ variant = Arch.variant_of_string variant in
58
+
{
59
+
os;
60
+
architecture;
61
+
os_version = None;
62
+
os_features = [];
63
+
variant = Some variant;
64
+
features = [];
65
+
}
66
+
| _ -> error_msg "Platform.of_string: invalid string (%S)" str
67
+
68
+
let pp ppf t =
69
+
match t.variant with
70
+
| None -> Fmt.pf ppf "%a/%a" OS.pp t.os Arch.pp t.architecture
71
+
| Some v ->
72
+
Fmt.pf ppf "%a/%a/%a" OS.pp t.os Arch.pp t.architecture Arch.pp_variant v
73
+
74
+
let to_string = Fmt.to_to_string pp
75
+
let pp_v = Fmt.option ~none:(Fmt.any "N/A") Arch.pp_variant
76
+
77
+
let dump ppf t =
78
+
match Jsont_bytesrw.encode_string jsont t with
79
+
| Ok s -> (
80
+
match json_of_string s with
81
+
| Ok j -> pp_json ppf j
82
+
| Error e -> Fmt.pf ppf "<error: %s>" e)
83
+
| Error e -> Fmt.pf ppf "<error: %s>" e
84
+
85
+
let err_arch_variant t =
86
+
Fmt.failwith "%a/%a: invalid architecture/variant pair" Arch.pp t.architecture
87
+
pp_v t.variant
88
+
89
+
let err_os_arch t =
90
+
Fmt.failwith "%a/%a: invalid os/architecture pair" OS.pp t.os Arch.pp
91
+
t.architecture
92
+
93
+
let check t =
94
+
let () =
95
+
match (t.os, t.os_features) with
96
+
| Windows, [ "win32k" ] -> ()
97
+
| Windows, l ->
98
+
Fmt.failwith "%a/%a invalid os/os.features pair" OS.pp t.os
99
+
Fmt.(Dump.list string)
100
+
l
101
+
| _ -> ()
102
+
in
103
+
let () =
104
+
match (t.architecture, t.variant) with
105
+
| Arm, Some V6 | Arm, Some V7 | Arm, Some V8 | Arm64, Some V8 -> ()
106
+
| Arm, _ | Arm64, _ | _, Some _ -> err_arch_variant t
107
+
| _ -> ()
108
+
in
109
+
let () =
110
+
match (t.os, t.architecture) with
111
+
| Aix, Ppc64
112
+
| Android, X386
113
+
| Android, Xamd64
114
+
| Android, Arm
115
+
| Android, Arm64
116
+
| Darwin, Xamd64
117
+
| Darwin, Arm64
118
+
| Dragonfly, Xamd64
119
+
| Freebsd, X386
120
+
| Freebsd, Xamd64
121
+
| Freebsd, Arm
122
+
| Illumos, Xamd64
123
+
| Ios, Arm64
124
+
| Js, Wasm
125
+
| Linux, X386
126
+
| Linux, Xamd64
127
+
| Linux, Arm
128
+
| Linux, Arm64
129
+
| Linux, Loong64
130
+
| Linux, Mips
131
+
| Linux, Mipsle
132
+
| Linux, Mips64
133
+
| Linux, Mips64le
134
+
| Linux, Ppc64
135
+
| Linux, Ppc64le
136
+
| Linux, Riscv64
137
+
| Linux, S390x
138
+
| Netbsd, X386
139
+
| Netbsd, Xamd64
140
+
| Netbsd, Arm
141
+
| Openbsd, X386
142
+
| Openbsd, Xamd64
143
+
| Openbsd, Arm
144
+
| Openbsd, Arm64
145
+
| Plan9, X386
146
+
| Plan9, Xamd64
147
+
| Plan9, Arm
148
+
| Solaris, Xamd64
149
+
| Wasip1, Wasm
150
+
| Windows, X386
151
+
| Windows, Xamd64
152
+
| Windows, Arm
153
+
| Windows, Arm64 ->
154
+
()
155
+
| _, _ -> err_os_arch t
156
+
in
157
+
let () =
158
+
match t.features with
159
+
| [] -> ()
160
+
| _ ->
161
+
failwith
162
+
"platform: features is reserved for future versions of the \
163
+
specification"
164
+
in
165
+
()
+20
src/spec/platform.mli
+20
src/spec/platform.mli
···
1
+
type t
2
+
3
+
val jsont : t Jsont.t
4
+
5
+
val v :
6
+
?os_version:string ->
7
+
?os_features:string list ->
8
+
?variant:Arch.variant ->
9
+
Arch.t ->
10
+
OS.t ->
11
+
t
12
+
13
+
val unknown : t
14
+
val pp : t Fmt.t
15
+
val dump : t Fmt.t
16
+
val to_string : t -> string
17
+
val of_string : string -> (t, [ `Msg of string ]) result
18
+
val arch : t -> Arch.t
19
+
val os : t -> OS.t
20
+
val check : t -> unit
+69
src/util.ml
+69
src/util.ml
···
1
+
let guess_manifest (v : Oci_spec.Manifest.t) =
2
+
let open Oci_spec in
3
+
let arch = Osrelease.Arch.v () in
4
+
let os = Osrelease.OS.v () in
5
+
match v with
6
+
| `Docker_manifest d -> (
7
+
let platform = Manifest.Docker.config d |> Descriptor.platform in
8
+
match platform with
9
+
| None -> None
10
+
| Some platform ->
11
+
let m_os =
12
+
Osrelease.OS.of_string (Platform.os platform |> OS.to_string)
13
+
in
14
+
let m_arch =
15
+
Osrelease.Arch.of_string (Platform.arch platform |> Arch.to_string)
16
+
in
17
+
if arch = m_arch && os = m_os then Some (Manifest.Docker.config d)
18
+
else None)
19
+
| `OCI_manifest m -> (
20
+
let platform = Manifest.OCI.config m |> Descriptor.platform in
21
+
match platform with
22
+
| None -> None
23
+
| Some platform ->
24
+
let m_os =
25
+
Osrelease.OS.of_string (Platform.os platform |> OS.to_string)
26
+
in
27
+
let m_arch =
28
+
Osrelease.Arch.of_string (Platform.arch platform |> Arch.to_string)
29
+
in
30
+
if arch = m_arch && os = m_os then Some (Manifest.OCI.config m)
31
+
else None)
32
+
| `Docker_manifest_list l ->
33
+
let manifests = Manifest_list.manifests l in
34
+
let manifest =
35
+
Stdlib.List.find_opt
36
+
(fun m ->
37
+
match Descriptor.platform m with
38
+
| None -> false
39
+
| Some (platform : Platform.t) ->
40
+
let m_os =
41
+
Osrelease.OS.of_string (Platform.os platform |> OS.to_string)
42
+
in
43
+
let m_arch =
44
+
Osrelease.Arch.of_string
45
+
(Platform.arch platform |> Arch.to_string)
46
+
in
47
+
arch = m_arch && os = m_os)
48
+
manifests
49
+
in
50
+
manifest
51
+
| `OCI_index l ->
52
+
let manifests = Index.manifests l in
53
+
let manifest =
54
+
Stdlib.List.find_opt
55
+
(fun m ->
56
+
match Descriptor.platform m with
57
+
| None -> false
58
+
| Some (platform : Platform.t) ->
59
+
let m_os =
60
+
Osrelease.OS.of_string (Platform.os platform |> OS.to_string)
61
+
in
62
+
let m_arch =
63
+
Osrelease.Arch.of_string
64
+
(Platform.arch platform |> Arch.to_string)
65
+
in
66
+
arch = m_arch && os = m_os)
67
+
manifests
68
+
in
69
+
manifest
+3
src/util.mli
+3
src/util.mli
+11
test/test.ml
+11
test/test.ml
···
1
+
(* use alcotest to test run all the test suites *)
2
+
let () =
3
+
Alcotest.run "oci"
4
+
[
5
+
("annotate", Test_annotate.suite);
6
+
("config", Test_config.suite);
7
+
("descriptor", Test_descriptor.suite);
8
+
("index", Test_index.suite);
9
+
("chainID", Test_chain_id.suite);
10
+
("manifest", Test_manifest.suite);
11
+
]
+1
test/test_annotate.ml
+1
test/test_annotate.ml
···
1
+
let suite = [ Alcotest.test_case "base" `Quick (fun () -> ()) ]
+1
test/test_annotate.mli
+1
test/test_annotate.mli
···
1
+
val suite : unit Alcotest.test_case list
+50
test/test_chain_id.ml
+50
test/test_chain_id.ml
···
1
+
open Alcotest
2
+
open Oci_spec
3
+
4
+
let digest str =
5
+
Digest.unsafe_v SHA256 Digestif.SHA256.(to_hex (digest_string str))
6
+
7
+
let chain_digest_AB = digest ("sha256:a" ^ " " ^ "sha256:b")
8
+
9
+
let chain_digest_ABC =
10
+
digest (Digest.to_string chain_digest_AB ^ " " ^ "sha256:c")
11
+
12
+
let chain =
13
+
let eq x y =
14
+
match List.compare_lengths x y with
15
+
| 0 -> List.for_all2 Digest.equal x y
16
+
| _ -> false
17
+
in
18
+
Alcotest.testable Fmt.(Dump.list Digest.pp) eq
19
+
20
+
let a = Digest.unsafe_v SHA256 "a"
21
+
let b = Digest.unsafe_v SHA256 "b"
22
+
let c = Digest.unsafe_v SHA256 "c"
23
+
24
+
let test_empty () =
25
+
let v = [] in
26
+
let v' = Digest.chain SHA256 v in
27
+
Alcotest.(check chain) "empty" v' []
28
+
29
+
let test_identity () =
30
+
let v = [ a ] in
31
+
let v' = Digest.chain SHA256 v in
32
+
Alcotest.(check chain) "identity" v' [ a ]
33
+
34
+
let test_two () =
35
+
let v = [ a; b ] in
36
+
let v' = Digest.chain SHA256 v in
37
+
Alcotest.(check chain) "two" v' [ a; chain_digest_AB ]
38
+
39
+
let test_three () =
40
+
let v = [ a; b; c ] in
41
+
let v' = Digest.chain SHA256 v in
42
+
Alcotest.(check chain) "three" v' [ a; chain_digest_AB; chain_digest_ABC ]
43
+
44
+
let suite =
45
+
[
46
+
test_case "empty" `Quick test_empty;
47
+
test_case "identity" `Quick test_identity;
48
+
test_case "two" `Quick test_two;
49
+
test_case "three" `Quick test_three;
50
+
]
+1
test/test_chain_id.mli
+1
test/test_chain_id.mli
···
1
+
val suite : unit Alcotest.test_case list
+351
test/test_config.ml
+351
test/test_config.ml
···
1
+
open Alcotest
2
+
open Oci_spec
3
+
4
+
let of_json str =
5
+
match Common.json_of_string str with
6
+
| Error _ ->
7
+
Fmt.epr "invalid JSON\n%!";
8
+
None
9
+
| Ok json -> (
10
+
match Config.OCI.of_yojson json with
11
+
| Ok x -> Some x
12
+
| Error e ->
13
+
Fmt.epr "JSON error: %s\n%!" e;
14
+
None)
15
+
16
+
let test_os () =
17
+
let str =
18
+
{|
19
+
{
20
+
"architecture": "amd64",
21
+
"os": 123,
22
+
"rootfs": {
23
+
"diff_ids": [
24
+
"sha256:5f70bf18a086007016e948b04aed3b82103a36bea41755b6cddfaf10ace3c6ef"
25
+
],
26
+
"type": "layers"
27
+
}
28
+
}
29
+
|}
30
+
in
31
+
match of_json str with
32
+
| None -> ()
33
+
| Some _ ->
34
+
Alcotest.fail
35
+
"expected failure: field \"os\" has numeric value, must be string"
36
+
37
+
let test_variant () =
38
+
let str =
39
+
{|
40
+
{
41
+
"architecture": "arm64",
42
+
"variant": 123,
43
+
"os": "linux",
44
+
"rootfs": {
45
+
"diff_ids": [
46
+
"sha256:5f70bf18a086007016e948b04aed3b82103a36bea41755b6cddfaf10ace3c6ef"
47
+
],
48
+
"type": "layers"
49
+
}
50
+
}
51
+
|}
52
+
in
53
+
match of_json str with
54
+
| Some _ ->
55
+
fail
56
+
"expected failure: field \"variant\" has numeric value, must be string"
57
+
| None -> ()
58
+
59
+
let test_config_user () =
60
+
let str =
61
+
{|
62
+
{
63
+
"created": "2015-10-31T22:22:56.015925234Z",
64
+
"author": "Alyssa P. Hacker <alyspdev@example.com>",
65
+
"architecture": "amd64",
66
+
"os": "linux",
67
+
"config": {
68
+
"User": 1234
69
+
},
70
+
"rootfs": {
71
+
"diff_ids": [
72
+
"sha256:5f70bf18a086007016e948b04aed3b82103a36bea41755b6cddfaf10ace3c6ef"
73
+
],
74
+
"type": "layers"
75
+
}
76
+
}
77
+
|}
78
+
in
79
+
match of_json str with
80
+
| Some _ ->
81
+
fail
82
+
"expected failure: field \"config.User\" has numeric value, must be \
83
+
string"
84
+
| None -> ()
85
+
86
+
let test_history () =
87
+
let str =
88
+
{|
89
+
{
90
+
"history": "should be an array",
91
+
"architecture": "amd64",
92
+
"os": 123,
93
+
"rootfs": {
94
+
"diff_ids": [
95
+
"sha256:5f70bf18a086007016e948b04aed3b82103a36bea41755b6cddfaf10ace3c6ef"
96
+
],
97
+
"type": "layers"
98
+
}
99
+
}
100
+
|}
101
+
in
102
+
match of_json str with
103
+
| Some _ ->
104
+
fail "expected failure: history has string value, must be an array"
105
+
| None -> ()
106
+
107
+
let test_env_numeric () =
108
+
let str =
109
+
{|
110
+
{
111
+
"architecture": "amd64",
112
+
"os": 123,
113
+
"config": {
114
+
"Env": [
115
+
7353
116
+
]
117
+
},
118
+
"rootfs": {
119
+
"diff_ids": [
120
+
"sha256:5f70bf18a086007016e948b04aed3b82103a36bea41755b6cddfaf10ace3c6ef"
121
+
],
122
+
"type": "layers"
123
+
}
124
+
}
125
+
|}
126
+
in
127
+
match of_json str with
128
+
| Some _ -> fail "expected failure: Env has numeric value, must be a string"
129
+
| None -> ()
130
+
131
+
let test_volumes_string_array () =
132
+
let str =
133
+
{|
134
+
{
135
+
"architecture": "amd64",
136
+
"os": 123,
137
+
"config": {
138
+
"Volumes": [
139
+
"/var/job-result-data",
140
+
"/var/log/my-app-logs"
141
+
]
142
+
},
143
+
"rootfs": {
144
+
"diff_ids": [
145
+
"sha256:5f70bf18a086007016e948b04aed3b82103a36bea41755b6cddfaf10ace3c6ef"
146
+
],
147
+
"type": "layers"
148
+
}
149
+
}
150
+
|}
151
+
in
152
+
match of_json str with
153
+
| Some _ ->
154
+
fail
155
+
"expected failure: config.Volumes has string array, must be an object \
156
+
(string set)"
157
+
| None -> ()
158
+
159
+
let test_invalid_json () =
160
+
let str = {| invalid JSON |} in
161
+
match of_json str with
162
+
| Some _ -> fail "expected failure: invalid JSON"
163
+
| None -> ()
164
+
165
+
let test_valid_config_optional_fields () =
166
+
let str =
167
+
{|
168
+
{
169
+
"created": "2015-10-31T22:22:56.015925234Z",
170
+
"author": "Alyssa P. Hacker <alyspdev@example.com>",
171
+
"architecture": "arm64",
172
+
"variant": "v8",
173
+
"os": "linux",
174
+
"config": {
175
+
"User": "1:1",
176
+
"ExposedPorts": {
177
+
"8080/tcp": {}
178
+
},
179
+
"Env": [
180
+
"PATH=/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin",
181
+
"FOO=docker_is_a_really",
182
+
"BAR=great_tool_you_know"
183
+
],
184
+
"Entrypoint": [
185
+
"/bin/sh"
186
+
],
187
+
"Cmd": [
188
+
"--foreground",
189
+
"--config",
190
+
"/etc/my-app.d/default.cfg"
191
+
],
192
+
"Volumes": {
193
+
"/var/job-result-data": {},
194
+
"/var/log/my-app-logs": {}
195
+
},
196
+
"StopSignal": "SIGKILL",
197
+
"WorkingDir": "/home/alice",
198
+
"Labels": {
199
+
"com.example.project.git.url": "https://example.com/project.git",
200
+
"com.example.project.git.commit": "45a939b2999782a3f005621a8d0f29aa387e1d6b"
201
+
}
202
+
},
203
+
"rootfs": {
204
+
"diff_ids": [
205
+
"sha256:9d3dd9504c685a304985025df4ed0283e47ac9ffa9bd0326fddf4d59513f0827",
206
+
"sha256:2b689805fbd00b2db1df73fae47562faac1a626d5f61744bfe29946ecff5d73d"
207
+
],
208
+
"type": "layers"
209
+
},
210
+
"history": [
211
+
{
212
+
"created": "2015-10-31T22:22:54.690851953Z",
213
+
"created_by": "/bin/sh -c #(nop) ADD file:a3bc1e842b69636f9df5256c49c5374fb4eef1e281fe3f282c65fb853ee171c5 in /"
214
+
},
215
+
{
216
+
"created": "2015-10-31T22:22:55.613815829Z",
217
+
"created_by": "/bin/sh -c #(nop) CMD [\"sh\"]",
218
+
"empty_layer": true
219
+
}
220
+
]
221
+
}
222
+
|}
223
+
in
224
+
match of_json str with
225
+
| Some _ -> ()
226
+
| None -> fail "expected valid configuration with optional fields"
227
+
228
+
let test_valid_config_required_fields () =
229
+
let str =
230
+
{|
231
+
{
232
+
"architecture": "amd64",
233
+
"os": "linux",
234
+
"rootfs": {
235
+
"diff_ids": [
236
+
"sha256:5f70bf18a086007016e948b04aed3b82103a36bea41755b6cddfaf10ace3c6ef"
237
+
],
238
+
"type": "layers"
239
+
}
240
+
}
241
+
|}
242
+
in
243
+
match of_json str with
244
+
| Some _ -> ()
245
+
| None -> fail "expected valid configuration with only required fields"
246
+
247
+
let test_env_invalid () =
248
+
let str =
249
+
{|
250
+
{
251
+
"architecture": "amd64",
252
+
"os": "linux",
253
+
"config": {
254
+
"Env": [
255
+
"foo"
256
+
]
257
+
},
258
+
"rootfs": {
259
+
"diff_ids": [
260
+
"sha256:5f70bf18a086007016e948b04aed3b82103a36bea41755b6cddfaf10ace3c6ef"
261
+
],
262
+
"type": "layers"
263
+
}
264
+
}
265
+
|}
266
+
in
267
+
match of_json str with
268
+
| Some _ ->
269
+
Alcotest.fail
270
+
"expected failure: Env value invalid, must be in the format KEY=VALUE"
271
+
| None -> ()
272
+
273
+
let test_example () =
274
+
let json =
275
+
{|
276
+
{
277
+
"created": "2015-10-31T22:22:56.015925234Z",
278
+
"author": "Alyssa P. Hacker <alyspdev@example.com>",
279
+
"architecture": "amd64",
280
+
"os": "linux",
281
+
"config": {
282
+
"User": "alice",
283
+
"ExposedPorts": {
284
+
"8080/tcp": {}
285
+
},
286
+
"Env": [
287
+
"PATH=/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin",
288
+
"FOO=oci_is_a",
289
+
"BAR=well_written_spec"
290
+
],
291
+
"Entrypoint": [
292
+
"/bin/my-app-binary"
293
+
],
294
+
"Cmd": [
295
+
"--foreground",
296
+
"--config",
297
+
"/etc/my-app.d/default.cfg"
298
+
],
299
+
"Volumes": {
300
+
"/var/job-result-data": {},
301
+
"/var/log/my-app-logs": {}
302
+
},
303
+
"WorkingDir": "/home/alice",
304
+
"Labels": {
305
+
"com.example.project.git.url": "https://example.com/project.git",
306
+
"com.example.project.git.commit": "45a939b2999782a3f005621a8d0f29aa387e1d6b"
307
+
}
308
+
},
309
+
"rootfs": {
310
+
"diff_ids": [
311
+
"sha256:c6f988f4874bb0add23a778f753c65efe992244e148a1d2ec2a8b664fb66bbd1",
312
+
"sha256:5f70bf18a086007016e948b04aed3b82103a36bea41755b6cddfaf10ace3c6ef"
313
+
],
314
+
"type": "layers"
315
+
},
316
+
"history": [
317
+
{
318
+
"created": "2015-10-31T22:22:54.690851953Z",
319
+
"created_by": "/bin/sh -c #(nop) ADD file:a3bc1e842b69636f9df5256c49c5374fb4eef1e281fe3f282c65fb853ee171c5 in /"
320
+
},
321
+
{
322
+
"created": "2015-10-31T22:22:55.613815829Z",
323
+
"created_by": "/bin/sh -c #(nop) CMD [\"sh\"]",
324
+
"empty_layer": true
325
+
},
326
+
{
327
+
"created": "2015-10-31T22:22:56.329850019Z",
328
+
"created_by": "/bin/sh -c apk add curl"
329
+
}
330
+
]
331
+
}
332
+
|}
333
+
in
334
+
match of_json json with Some _ -> () | None -> Alcotest.fail "example"
335
+
336
+
let suite =
337
+
[
338
+
test_case "os" `Quick test_os;
339
+
test_case "variant" `Quick test_variant;
340
+
test_case "config_user" `Quick test_config_user;
341
+
test_case "history" `Quick test_history;
342
+
test_case "env_numeric" `Quick test_env_numeric;
343
+
test_case "volumes_string_array" `Quick test_volumes_string_array;
344
+
test_case "invalid_json" `Quick test_invalid_json;
345
+
test_case "env_invalid" `Quick test_env_invalid;
346
+
test_case "valid_config_optional_fields" `Quick
347
+
test_valid_config_optional_fields;
348
+
test_case "valid_config_required_fields" `Quick
349
+
test_valid_config_required_fields;
350
+
test_case "example" `Quick test_example;
351
+
]
+1
test/test_config.mli
+1
test/test_config.mli
···
1
+
val suite : unit Alcotest.test_case list
+273
test/test_descriptor.ml
+273
test/test_descriptor.ml
···
1
+
open Oci_spec
2
+
3
+
let of_json str =
4
+
match Common.json_of_string str with
5
+
| Error _ ->
6
+
Fmt.epr "invalid JSON\n%!";
7
+
None
8
+
| Ok json -> (
9
+
match Descriptor.of_yojson json with
10
+
| Ok x -> Some x
11
+
| Error e ->
12
+
Fmt.epr "JSON error: %s\n%!" e;
13
+
None)
14
+
15
+
let test_descriptor fail test_name json =
16
+
let test_fun () =
17
+
match of_json json with
18
+
| Some _ ->
19
+
if fail then Alcotest.failf "%s - unexpected valid descriptor" test_name
20
+
| None ->
21
+
if not fail then
22
+
Alcotest.failf "%s - this test is a valid descriptor" test_name
23
+
in
24
+
(test_name, `Quick, test_fun)
25
+
26
+
let test_ok = test_descriptor false
27
+
let test_ko = test_descriptor true
28
+
29
+
let suite =
30
+
[
31
+
test_ok "Valid descriptor"
32
+
{|
33
+
{
34
+
"mediaType": "application/vnd.oci.image.manifest.v1+json",
35
+
"size": 7682,
36
+
"digest": "sha256:5b0bcabd1ed22e9fb1310cf6c2dec7cdef19f0ad69efa1f392e94a4333501270"
37
+
}
38
+
|};
39
+
test_ko "mediaType missing"
40
+
{|
41
+
{
42
+
"size": 7682,
43
+
"digest": "sha256:5b0bcabd1ed22e9fb1310cf6c2dec7cdef19f0ad69efa1f392e94a4333501270"
44
+
}
45
+
|};
46
+
test_ko "mediaType does not match pattern (no subtype)"
47
+
{|
48
+
{
49
+
"mediaType": "application",
50
+
"size": 7682,
51
+
"digest": "sha256:5b0bcabd1ed22e9fb1310cf6c2dec7cdef19f0ad69efa1f392e94a4333501270"
52
+
}
53
+
|};
54
+
test_ko "mediaType does not match pattern (invalid first type character)"
55
+
{|
56
+
{
57
+
"mediaType": ".foo/bar",
58
+
"size": 7682,
59
+
"digest": "sha256:5b0bcabd1ed22e9fb1310cf6c2dec7cdef19f0ad69efa1f392e94a4333501270"
60
+
}
61
+
|};
62
+
test_ko "mediaType does not match pattern (invalid first subtype character)"
63
+
{|
64
+
{
65
+
"mediaType": "foo/.bar",
66
+
"size": 7682,
67
+
"digest": "sha256:5b0bcabd1ed22e9fb1310cf6c2dec7cdef19f0ad69efa1f392e94a4333501270"
68
+
}
69
+
|};
70
+
test_ok "mediaType has type and subtype as long as possible"
71
+
{|
72
+
{
73
+
"mediaType": "1234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567/1234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567",
74
+
"size": 7682,
75
+
"digest": "sha256:5b0bcabd1ed22e9fb1310cf6c2dec7cdef19f0ad69efa1f392e94a4333501270"
76
+
}
77
+
|};
78
+
test_ko "mediaType does not match pattern (type too long)"
79
+
{|
80
+
{
81
+
"mediaType": "12345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678/bar",
82
+
"size": 7682,
83
+
"digest": "sha256:5b0bcabd1ed22e9fb1310cf6c2dec7cdef19f0ad69efa1f392e94a4333501270"
84
+
}
85
+
|};
86
+
test_ko "mediaType does not match pattern (subtype too long)"
87
+
{|
88
+
{
89
+
"mediaType": "foo/12345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678",
90
+
"size": 7682,
91
+
"digest": "sha256:5b0bcabd1ed22e9fb1310cf6c2dec7cdef19f0ad69efa1f392e94a4333501270"
92
+
}
93
+
|};
94
+
test_ko "size missing"
95
+
{|
96
+
{
97
+
"mediaType": "application/vnd.oci.image.manifest.v1+json",
98
+
"digest": "sha256:5b0bcabd1ed22e9fb1310cf6c2dec7cdef19f0ad69efa1f392e94a4333501270"
99
+
}
100
+
|};
101
+
test_ko "size is a string, expected integer"
102
+
{|
103
+
{
104
+
"mediaType": "application/vnd.oci.image.manifest.v1+json",
105
+
"size": "7682",
106
+
"digest": "sha256:5b0bcabd1ed22e9fb1310cf6c2dec7cdef19f0ad69efa1f392e94a4333501270"
107
+
}
108
+
|};
109
+
test_ko "digest missing"
110
+
{|
111
+
{
112
+
"mediaType": "application/vnd.oci.image.manifest.v1+json",
113
+
"size": 7682
114
+
}
115
+
|};
116
+
test_ko "digest does not match pattern (missing algorithm)"
117
+
{|
118
+
{
119
+
"mediaType": "application/vnd.oci.image.manifest.v1+json",
120
+
"size": 7682,
121
+
"digest": ":5b0bcabd1ed22e9fb1310cf6c2dec7cdef19f0ad69efa1f392e94a4333501270"
122
+
}
123
+
|};
124
+
test_ko "digest does not match pattern (missing hash)"
125
+
{|
126
+
{
127
+
"mediaType": "application/vnd.oci.image.manifest.v1+json",
128
+
"size": 7682,
129
+
"digest": "sha256:"
130
+
}
131
+
|};
132
+
test_ko "digest does not match pattern (invalid algorithm characters)"
133
+
{|
134
+
{
135
+
"mediaType": "application/vnd.oci.image.manifest.v1+json",
136
+
"size": 7682,
137
+
"digest": "SHA256:5b0bcabd1ed22e9fb1310cf6c2dec7cdef19f0ad69efa1f392e94a4333501270"
138
+
}
139
+
|};
140
+
test_ko
141
+
"digest does not match pattern (characters needs to be lower for sha256)"
142
+
{|
143
+
{
144
+
"mediaType": "application/vnd.oci.image.manifest.v1+json",
145
+
"size": 7682,
146
+
"digest": "sha256:5B0BCABD1ED22E9FB1310CF6C2DEC7CDEF19F0AD69EFA1F392E94A4333501270"
147
+
}
148
+
|};
149
+
test_ok "valid URL entry"
150
+
{|
151
+
{
152
+
"mediaType": "application/vnd.oci.image.manifest.v1+json",
153
+
"size": 7682,
154
+
"digest": "sha256:5b0bcabd1ed22e9fb1310cf6c2dec7cdef19f0ad69efa1f392e94a4333501270",
155
+
"urls": [
156
+
"https://example.com/foo"
157
+
]
158
+
}
159
+
|};
160
+
test_ko "urls does not match format (invalid url characters)"
161
+
{|
162
+
{
163
+
"mediaType": "application/vnd.oci.image.manifest.v1+json",
164
+
"size": 7682,
165
+
"digest": "sha256:5b0bcabd1ed22e9fb1310cf6c2dec7cdef19f0ad69efa1f392e94a4333501270",
166
+
"urls": [
167
+
"value"
168
+
]
169
+
}
170
+
|};
171
+
test_ok "artifactType is present and an IANA compliant value"
172
+
{|
173
+
{
174
+
"mediaType": "application/vnd.oci.image.manifest.v1+json",
175
+
"artifactType": "application/vnd.oci.image.manifest.v1+json",
176
+
"size": 7682,
177
+
"digest": "sha256:5b0bcabd1ed22e9fb1310cf6c2dec7cdef19f0ad69efa1f392e94a4333501270"
178
+
}
179
+
|};
180
+
test_ko
181
+
"artifactType does not match pattern (invalid first subtype character)"
182
+
{|
183
+
{
184
+
"mediaType": "application/vnd.oci.image.manifest.v1+json",
185
+
"artifactType": "foo/.bar",
186
+
"size": 7682,
187
+
"digest": "sha256:5b0bcabd1ed22e9fb1310cf6c2dec7cdef19f0ad69efa1f392e94a4333501270"
188
+
}
189
+
|};
190
+
test_ok "data field is present and has base64 content"
191
+
{|
192
+
{
193
+
"mediaType": "text/plain",
194
+
"size": 34,
195
+
"data": "aHR0cHM6Ly9naXRodWIuY29tL29wZW5jb250YWluZXJzCg==",
196
+
"digest": "sha256:2690af59371e9eca9453dc29882643f46e5ca47ec2862bd517b5e17351325153"
197
+
}
198
+
|};
199
+
test_ok "unregistered digest"
200
+
{|
201
+
{
202
+
"mediaType": "application/vnd.oci.image.config.v1+json",
203
+
"size": 1470,
204
+
"digest": "sha256+b64:c86f7763873b6c0aae22d963bab59b4f5debbed6685761b5951584f6efb0633b"
205
+
}
206
+
|};
207
+
test_ok "unregistered digest"
208
+
{|
209
+
{
210
+
"mediaType": "application/vnd.oci.image.config.v1+json",
211
+
"size": 1470,
212
+
"digest": "sha256+b64:c86f7763873b6c0aae22d963bab59b4f5debbed6685761b5951584f6efb0633b"
213
+
}
214
+
|};
215
+
test_ok "unregistered digest"
216
+
{|
217
+
{
218
+
"mediaType": "application/vnd.oci.image.config.v1+json",
219
+
"size": 1470,
220
+
"digest": "sha256+foo-bar:c86f7763873b6c0aae22d963bab59b4f5debbed6685761b5951584f6efb0633b"
221
+
}
222
+
|};
223
+
test_ok "unregistered digest"
224
+
{|
225
+
{
226
+
"mediaType": "application/vnd.oci.image.config.v1+json",
227
+
"size": 1470,
228
+
"digest": "sha256.foo-bar:c86f7763873b6c0aae22d963bab59b4f5debbed6685761b5951584f6efb0633b"
229
+
}
230
+
|};
231
+
test_ok "unregistered digest"
232
+
{|
233
+
{
234
+
"mediaType": "application/vnd.oci.image.config.v1+json",
235
+
"size": 1470,
236
+
"digest": "multihash+base58:QmRZxt2b1FVZPNqd8hsiykDL3TdBDeTSPX9Kv46HmX4Gx8"
237
+
}
238
+
|};
239
+
test_ko "repeated separators in algorithm"
240
+
{|
241
+
{
242
+
"mediaType": "application/vnd.oci.image.config.v1+json",
243
+
"size": 1470,
244
+
"digest": "sha256+foo+-b:c86f7763873b6c0aae22d963bab59b4f5debbed6685761b5951584f6efb0633b"
245
+
}
246
+
|};
247
+
test_ok "unregistered digest"
248
+
{|
249
+
{
250
+
"digest": "sha256+b64u:LCa0a2j_xo_5m0U8HTBBNBNCLXBkg7-g-YpeiGJm564",
251
+
"size": 1000000,
252
+
"mediaType": "application/vnd.oci.image.config.v1+json"
253
+
}
254
+
|};
255
+
test_ok
256
+
"test for those who cannot use modulo arithmetic to recover padding."
257
+
{|
258
+
{
259
+
"digest": "sha256+b64u.unknownlength:LCa0a2j_xo_5m0U8HTBBNBNCLXBkg7-g-YpeiGJm564=",
260
+
"size": 1000000,
261
+
"mediaType": "application/vnd.oci.image.config.v1+json"
262
+
}
263
+
|};
264
+
test_ko "invalid base64 content"
265
+
{|
266
+
{
267
+
"mediaType": "text/plain",
268
+
"size": 34,
269
+
"data": "aHR0cHM6Ly9naXRodWIuY29tL29wZW5jb250YWluZXJzCg",
270
+
"digest": "sha256:2690af59371e9eca9453dc29882643f46e5ca47ec2862bd517b5e17351325153"
271
+
}
272
+
|};
273
+
]
+1
test/test_descriptor.mli
+1
test/test_descriptor.mli
···
1
+
val suite : unit Alcotest.test_case list
+405
test/test_index.ml
+405
test/test_index.ml
···
1
+
open Alcotest
2
+
open Oci_spec
3
+
4
+
let of_json str =
5
+
match Common.json_of_string str with
6
+
| Error _ ->
7
+
Fmt.epr "invalid JSON\n%!";
8
+
None
9
+
| Ok json -> (
10
+
match Index.of_yojson json with
11
+
| Ok x -> Some x
12
+
| Error e ->
13
+
Fmt.epr "JSON error: %s\n%!" e;
14
+
None)
15
+
16
+
let test_invalid_media_type () =
17
+
let json =
18
+
{|
19
+
{
20
+
"schemaVersion": 2,
21
+
"mediaType": "application/vnd.oci.image.index.v1+json",
22
+
"manifests": [
23
+
{
24
+
"mediaType": "invalid",
25
+
"size": 7143,
26
+
"digest": "sha256:e692418e4cbaf90ca69d05a66403747baa33ee08806650b51fab815ad7fc331f",
27
+
"platform": {
28
+
"architecture": "ppc64le",
29
+
"os": "linux"
30
+
}
31
+
}
32
+
]
33
+
}
34
+
|}
35
+
in
36
+
match of_json json with
37
+
| Some _ -> fail "expected failure: mediaType does not match pattern"
38
+
| None -> ()
39
+
40
+
let test_manifest_size_as_string () =
41
+
let json =
42
+
{|
43
+
{
44
+
"schemaVersion": 2,
45
+
"mediaType": "application/vnd.oci.image.index.v1+json",
46
+
"manifests": [
47
+
{
48
+
"mediaType": "application/vnd.oci.image.manifest.v1+json",
49
+
"size": "7682",
50
+
"digest": "sha256:5b0bcabd1ed22e9fb1310cf6c2dec7cdef19f0ad69efa1f392e94a4333501270",
51
+
"platform": {
52
+
"architecture": "amd64",
53
+
"os": "linux"
54
+
}
55
+
}
56
+
]
57
+
}
58
+
|}
59
+
in
60
+
match of_json json with
61
+
| Some _ ->
62
+
fail "expected failure: manifest.size is a string, expected integer"
63
+
| None -> ()
64
+
65
+
let test_missing_manifest_digest () =
66
+
let json =
67
+
{|
68
+
{
69
+
"schemaVersion": 2,
70
+
"mediaType": "application/vnd.oci.image.index.v1+json",
71
+
"manifests": [
72
+
{
73
+
"mediaType": "application/vnd.oci.image.manifest.v1+json",
74
+
"size": 7682,
75
+
"platform": {
76
+
"architecture": "amd64",
77
+
"os": "linux"
78
+
}
79
+
}
80
+
]
81
+
}
82
+
|}
83
+
in
84
+
match of_json json with
85
+
| Some _ ->
86
+
fail "expected failure due to missing digest, but parsing was successful."
87
+
| None -> ()
88
+
89
+
let test_missing_platform_architecture () =
90
+
let json =
91
+
{|
92
+
{
93
+
"schemaVersion": 2,
94
+
"mediaType": "application/vnd.oci.image.index.v1+json",
95
+
"manifests": [
96
+
{
97
+
"mediaType": "application/vnd.oci.image.manifest.v1+json",
98
+
"size": 7682,
99
+
"digest": "sha256:5b0bcabd1ed22e9fb1310cf6c2dec7cdef19f0ad69efa1f392e94a4333501270",
100
+
"platform": {
101
+
"os": "linux"
102
+
}
103
+
}
104
+
]
105
+
}
106
+
|}
107
+
in
108
+
match of_json json with
109
+
| Some _ ->
110
+
fail
111
+
"expected failure due to missing platform architecture, but parsing \
112
+
was successful."
113
+
| None -> ()
114
+
115
+
let test_invalid_manifest_media_type () =
116
+
let json =
117
+
{|
118
+
{
119
+
"schemaVersion": 2,
120
+
"mediaType": "application/vnd.oci.image.index.v1+json",
121
+
"manifests": [
122
+
{
123
+
"mediaType": "invalid",
124
+
"size": 7682,
125
+
"digest": "sha256:5b0bcabd1ed22e9fb1310cf6c2dec7cdef19f0ad69efa1f392e94a4333501270",
126
+
"platform": {
127
+
"architecture": "amd64",
128
+
"os": "linux"
129
+
}
130
+
}
131
+
]
132
+
}
133
+
|}
134
+
in
135
+
match of_json json with
136
+
| Some _ ->
137
+
fail
138
+
"expected failure due to invalid manifest media type, but parsing was \
139
+
successful."
140
+
| None -> ()
141
+
142
+
let test_empty_manifest_media_type () =
143
+
let json =
144
+
{|
145
+
{
146
+
"schemaVersion": 2,
147
+
"mediaType": "application/vnd.oci.image.index.v1+json",
148
+
"manifests": [
149
+
{
150
+
"mediaType": "",
151
+
"size": 7682,
152
+
"digest": "sha256:5b0bcabd1ed22e9fb1310cf6c2dec7cdef19f0ad69efa1f392e94a4333501270",
153
+
"platform": {
154
+
"architecture": "amd64",
155
+
"os": "linux"
156
+
}
157
+
}
158
+
]
159
+
}
160
+
|}
161
+
in
162
+
match of_json json with
163
+
| Some _ ->
164
+
fail
165
+
"expected failure due to empty manifest media type, but parsing was \
166
+
successful."
167
+
| None -> ()
168
+
169
+
let test_valid_with_customized_media_type () =
170
+
let json =
171
+
{|
172
+
{
173
+
"schemaVersion": 2,
174
+
"mediaType": "application/vnd.oci.image.index.v1+json",
175
+
"manifests": [
176
+
{
177
+
"mediaType": "application/customized.manifest+json",
178
+
"size": 7143,
179
+
"digest": "sha256:e692418e4cbaf90ca69d05a66403747baa33ee08806650b51fab815ad7fc331f",
180
+
"platform": {
181
+
"architecture": "ppc64le",
182
+
"os": "linux"
183
+
}
184
+
}
185
+
]
186
+
}
187
+
|}
188
+
in
189
+
match of_json json with
190
+
| Some _ -> ()
191
+
| None -> fail "expected successful parsing, but it failed."
192
+
193
+
let test_valid_with_artifactType () =
194
+
let json =
195
+
{|
196
+
{
197
+
"schemaVersion": 2,
198
+
"mediaType" : "application/vnd.oci.image.index.v1+json",
199
+
"artifactType": "application/vnd.example+type",
200
+
"manifests": [
201
+
{
202
+
"mediaType": "application/vnd.oci.image.manifest.v1+json",
203
+
"size": 7143,
204
+
"digest": "sha256:5b0bcabd1ed22e9fb1310cf6c2dec7cdef19f0ad69efa1f392e94a4333501270"
205
+
},
206
+
{
207
+
"mediaType": "application/vnd.oci.image.manifest.v1+json",
208
+
"artifactType": "application/vnd.example1+type",
209
+
"size": 506,
210
+
"digest": "sha256:99953afc4b90c7d78079d189ae10da0a1002e6be5e9e8dedaf9f7f29def42111"
211
+
}
212
+
]
213
+
}
214
+
|}
215
+
in
216
+
match of_json json with
217
+
| Some _ -> ()
218
+
| None -> fail "expected successful parsing, but it failed."
219
+
220
+
let test_valid_with_subject_field () =
221
+
let json =
222
+
{|
223
+
{
224
+
"schemaVersion": 2,
225
+
"mediaType": "application/vnd.oci.image.index.v1+json",
226
+
"manifests": [
227
+
{
228
+
"mediaType": "application/vnd.oci.image.manifest.v1+json",
229
+
"size": 7682,
230
+
"digest": "sha256:5b0bcabd1ed22e9fb1310cf6c2dec7cdef19f0ad69efa1f392e94a4333501270",
231
+
"platform": {
232
+
"architecture": "amd64",
233
+
"os": "linux"
234
+
}
235
+
}
236
+
],
237
+
"subject" : {
238
+
"mediaType": "application/vnd.oci.image.manifest.v1+json",
239
+
"size": 1234,
240
+
"digest": "sha256:220a60ecd4a3c32c282622a625a54db9ba0ff55b5ba9c29c7064a2bc358b6a3e"
241
+
}
242
+
}
243
+
|}
244
+
in
245
+
match of_json json with
246
+
| Some _ -> ()
247
+
| None -> fail "expected successful parsing, but it failed."
248
+
249
+
let test_invalid_subject_field () =
250
+
let json =
251
+
{|
252
+
{
253
+
"schemaVersion": 2,
254
+
"mediaType": "application/vnd.oci.image.index.v1+json",
255
+
"manifests": [
256
+
{
257
+
"mediaType": "application/vnd.oci.image.manifest.v1+json",
258
+
"size": 7682,
259
+
"digest": "sha256:5b0bcabd1ed22e9fb1310cf6c2dec7cdef19f0ad69efa1f392e94a4333501270",
260
+
"platform": {
261
+
"architecture": "amd64",
262
+
"os": "linux"
263
+
}
264
+
}
265
+
],
266
+
"subject" : "nope"
267
+
}
268
+
|}
269
+
in
270
+
match of_json json with
271
+
| Some _ ->
272
+
fail
273
+
"expected parsing to fail due to invalid subject field, but it \
274
+
succeeded."
275
+
| None -> ()
276
+
277
+
let test_valid_with_optional_fields () =
278
+
let json =
279
+
{|
280
+
{
281
+
"schemaVersion": 2,
282
+
"mediaType": "application/vnd.oci.image.index.v1+json",
283
+
"manifests": [
284
+
{
285
+
"mediaType": "application/vnd.oci.image.manifest.v1+json",
286
+
"size": 7143,
287
+
"digest": "sha256:e692418e4cbaf90ca69d05a66403747baa33ee08806650b51fab815ad7fc331f",
288
+
"platform": {
289
+
"architecture": "ppc64le",
290
+
"os": "linux"
291
+
}
292
+
},
293
+
{
294
+
"mediaType": "application/vnd.oci.image.manifest.v1+json",
295
+
"size": 7682,
296
+
"digest": "sha256:5b0bcabd1ed22e9fb1310cf6c2dec7cdef19f0ad69efa1f392e94a4333501270",
297
+
"platform": {
298
+
"architecture": "amd64",
299
+
"os": "linux"
300
+
}
301
+
}
302
+
],
303
+
"annotations": {
304
+
"com.example.key1": "value1",
305
+
"com.example.key2": "value2"
306
+
}
307
+
}
308
+
|}
309
+
in
310
+
match of_json json with
311
+
| Some _ -> ()
312
+
| None -> fail "expected successful parsing, but it failed."
313
+
314
+
let test_valid_without_optional_fields () =
315
+
let json =
316
+
{|
317
+
{
318
+
"schemaVersion": 2,
319
+
"mediaType": "application/vnd.oci.image.index.v1+json",
320
+
"manifests": [
321
+
{
322
+
"mediaType": "application/vnd.oci.image.manifest.v1+json",
323
+
"size": 7143,
324
+
"digest": "sha256:e692418e4cbaf90ca69d05a66403747baa33ee08806650b51fab815ad7fc331f",
325
+
"platform": {
326
+
"architecture": "ppc64le",
327
+
"os": "linux"
328
+
}
329
+
}
330
+
]
331
+
}
332
+
|}
333
+
in
334
+
match of_json json with
335
+
| Some _ -> ()
336
+
| None -> fail "expected successful parsing, but it failed."
337
+
338
+
let example () =
339
+
let json =
340
+
{|
341
+
{
342
+
"schemaVersion": 2,
343
+
"mediaType": "application/vnd.oci.image.index.v1+json",
344
+
"manifests": [
345
+
{
346
+
"mediaType": "application/vnd.oci.image.index.v1+json",
347
+
"size": 7143,
348
+
"digest": "sha256:0228f90e926ba6b96e4f39cf294b2586d38fbb5a1e385c05cd1ee40ea54fe7fd",
349
+
"annotations": {
350
+
"org.opencontainers.image.ref.name": "stable-release"
351
+
}
352
+
},
353
+
{
354
+
"mediaType": "application/vnd.oci.image.manifest.v1+json",
355
+
"size": 7143,
356
+
"digest": "sha256:e692418e4cbaf90ca69d05a66403747baa33ee08806650b51fab815ad7fc331f",
357
+
"platform": {
358
+
"architecture": "ppc64le",
359
+
"os": "linux"
360
+
},
361
+
"annotations": {
362
+
"org.opencontainers.image.ref.name": "v1.0"
363
+
}
364
+
},
365
+
{
366
+
"mediaType": "application/xml",
367
+
"size": 7143,
368
+
"digest": "sha256:b3d63d132d21c3ff4c35a061adf23cf43da8ae054247e32faa95494d904a007e",
369
+
"annotations": {
370
+
"org.freedesktop.specifications.metainfo.version": "1.0",
371
+
"org.freedesktop.specifications.metainfo.type": "AppStream"
372
+
}
373
+
}
374
+
],
375
+
"annotations": {
376
+
"com.example.index.revision": "r124356"
377
+
}
378
+
}
379
+
|}
380
+
in
381
+
match of_json json with
382
+
| Some _ -> ()
383
+
| None -> fail "expected successful parsing, but it failed."
384
+
385
+
let suite =
386
+
[
387
+
test_case "Invalid mediaType" `Quick test_invalid_media_type;
388
+
test_case "Valid with optional fields" `Quick
389
+
test_valid_with_optional_fields;
390
+
test_case "Valid without optional fields" `Quick
391
+
test_valid_without_optional_fields;
392
+
test_case "Invalid manifest size as string" `Quick
393
+
test_invalid_manifest_media_type;
394
+
test_case "Missing platform architecture" `Quick
395
+
test_missing_platform_architecture;
396
+
test_case "Valid with artifactType" `Quick test_valid_with_artifactType;
397
+
test_case "Valid with subject field" `Quick test_valid_with_subject_field;
398
+
test_case "Invalid subject field" `Quick test_invalid_subject_field;
399
+
test_case "Manifest size as string" `Quick test_manifest_size_as_string;
400
+
test_case "Missing manifest digest" `Quick test_missing_manifest_digest;
401
+
test_case "Empty manifest media type" `Quick test_empty_manifest_media_type;
402
+
test_case "Valid with customized media type" `Quick
403
+
test_valid_with_customized_media_type;
404
+
test_case "example" `Quick example;
405
+
]
+1
test/test_index.mli
+1
test/test_index.mli
···
1
+
val suite : unit Alcotest.test_case list
+419
test/test_manifest.ml
+419
test/test_manifest.ml
···
1
+
open Alcotest
2
+
open Oci_spec
3
+
4
+
let of_json of_yojson str =
5
+
match Common.json_of_string str with
6
+
| Error _ ->
7
+
Fmt.epr "invalid JSON\n%!";
8
+
None
9
+
| Ok json -> (
10
+
match of_yojson json with
11
+
| Ok x -> Some x
12
+
| Error e ->
13
+
Fmt.epr "JSON error: %s\n%!" e;
14
+
None)
15
+
16
+
let oci_of_json = of_json Manifest.OCI.of_yojson
17
+
18
+
let test_invalid_media_type () =
19
+
let json =
20
+
{|
21
+
{
22
+
"schemaVersion": 2,
23
+
"mediaType" : "application/vnd.oci.image.manifest.v1+json",
24
+
"config": {
25
+
"mediaType": "invalid",
26
+
"size": 1470,
27
+
"digest": "sha256:c86f7763873b6c0aae22d963bab59b4f5debbed6685761b5951584f6efb0633b"
28
+
},
29
+
"layers": [
30
+
{
31
+
"mediaType": "application/vnd.oci.image.layer.v1.tar+gzip",
32
+
"size": 148,
33
+
"digest": "sha256:c57089565e894899735d458f0fd4bb17a0f1e0df8d72da392b85c9b35ee777cd"
34
+
}
35
+
]
36
+
}
37
+
|}
38
+
in
39
+
match oci_of_json json with
40
+
| Some _ -> Alcotest.fail "expected failure: mediaType does not match pattern"
41
+
| None -> ()
42
+
43
+
let test_invalid_config_size () =
44
+
let json =
45
+
{|
46
+
{
47
+
"schemaVersion": 2,
48
+
"mediaType" : "application/vnd.oci.image.manifest.v1+json",
49
+
"config": {
50
+
"config": {
51
+
"mediaType": "application/vnd.oci.image.config.v1+json",
52
+
"size": "1470",
53
+
"digest": "sha256:c86f7763873b6c0aae22d963bab59b4f5debbed6685761b5951584f6efb0633b"
54
+
},
55
+
"layers": [
56
+
{
57
+
"mediaType": "application/vnd.oci.image.layer.v1.tar+gzip",
58
+
"size": 148,
59
+
"digest": "sha256:c57089565e894899735d458f0fd4bb17a0f1e0df8d72da392b85c9b35ee777cd"
60
+
}
61
+
]
62
+
}
63
+
|}
64
+
in
65
+
match oci_of_json json with
66
+
| Some _ ->
67
+
Alcotest.fail
68
+
"expected failure: config.size is a string, expected integer"
69
+
| None -> ()
70
+
71
+
let test_invalid_layers_size () =
72
+
let json =
73
+
{|
74
+
{
75
+
"schemaVersion": 2,
76
+
"mediaType" : "application/vnd.oci.image.manifest.v1+json",
77
+
"config": {
78
+
"mediaType": "application/vnd.oci.image.config.v1+json",
79
+
"size": 1470,
80
+
"digest": "sha256:c86f7763873b6c0aae22d963bab59b4f5debbed6685761b5951584f6efb0633b"
81
+
},
82
+
"layers": [
83
+
{
84
+
"mediaType": "application/vnd.oci.image.layer.v1.tar+gzip",
85
+
"size": "675598",
86
+
"digest": "sha256:c86f7763873b6c0aae22d963bab59b4f5debbed6685761b5951584f6efb0633b"
87
+
}
88
+
]
89
+
}
90
+
|}
91
+
in
92
+
match oci_of_json json with
93
+
| Some _ ->
94
+
Alcotest.fail "expected failure: layers.size is string, expected integer"
95
+
| None -> ()
96
+
97
+
let test_valid_manifest_with_optional_fields () =
98
+
let json =
99
+
{|
100
+
{
101
+
"schemaVersion": 2,
102
+
"mediaType" : "application/vnd.oci.image.manifest.v1+json",
103
+
"config": {
104
+
"mediaType": "application/vnd.oci.image.config.v1+json",
105
+
"size": 1470,
106
+
"digest": "sha256:c86f7763873b6c0aae22d963bab59b4f5debbed6685761b5951584f6efb0633b"
107
+
},
108
+
"layers": [
109
+
{
110
+
"mediaType": "application/vnd.oci.image.layer.v1.tar+gzip",
111
+
"size": 675598,
112
+
"digest": "sha256:9d3dd9504c685a304985025df4ed0283e47ac9ffa9bd0326fddf4d59513f0827"
113
+
},
114
+
{
115
+
"mediaType": "application/vnd.oci.image.layer.v1.tar+gzip",
116
+
"size": 156,
117
+
"digest": "sha256:2b689805fbd00b2db1df73fae47562faac1a626d5f61744bfe29946ecff5d73d"
118
+
},
119
+
{
120
+
"mediaType": "application/vnd.oci.image.layer.v1.tar+gzip",
121
+
"size": 148,
122
+
"digest": "sha256:c57089565e894899735d458f0fd4bb17a0f1e0df8d72da392b85c9b35ee777cd"
123
+
}
124
+
],
125
+
"annotations": {
126
+
"key1": "value1",
127
+
"key2": "value2"
128
+
}
129
+
}
130
+
|}
131
+
in
132
+
match oci_of_json json with
133
+
| Some _ -> ()
134
+
| None -> Alcotest.fail "valid manifest with optional fields"
135
+
136
+
let test_valid_manifest_with_required_fields () =
137
+
let json =
138
+
{|
139
+
{
140
+
"schemaVersion": 2,
141
+
"mediaType" : "application/vnd.oci.image.manifest.v1+json",
142
+
"config": {
143
+
"mediaType": "application/vnd.oci.image.config.v1+json",
144
+
"size": 1470,
145
+
"digest": "sha256:c86f7763873b6c0aae22d963bab59b4f5debbed6685761b5951584f6efb0633b"
146
+
},
147
+
"layers": [
148
+
{
149
+
"mediaType": "application/vnd.oci.image.layer.v1.tar+gzip",
150
+
"size": 675598,
151
+
"digest": "sha256:9d3dd9504c685a304985025df4ed0283e47ac9ffa9bd0326fddf4d59513f0827"
152
+
},
153
+
{
154
+
"mediaType": "application/vnd.oci.image.layer.v1.tar+gzip",
155
+
"size": 156,
156
+
"digest": "sha256:2b689805fbd00b2db1df73fae47562faac1a626d5f61744bfe29946ecff5d73d"
157
+
},
158
+
{
159
+
"mediaType": "application/vnd.oci.image.layer.v1.tar+gzip",
160
+
"size": 148,
161
+
"digest": "sha256:c57089565e894899735d458f0fd4bb17a0f1e0df8d72da392b85c9b35ee777cd"
162
+
}
163
+
]
164
+
}
165
+
|}
166
+
in
167
+
match oci_of_json json with
168
+
| Some _ -> ()
169
+
| None -> Alcotest.fail "valid manifest with only required fields"
170
+
171
+
let test_invalid_empty_layer () =
172
+
let json =
173
+
{|
174
+
{
175
+
"schemaVersion": 2,
176
+
"mediaType" : "application/vnd.oci.image.manifest.v1+json",
177
+
"config": {
178
+
"mediaType": "application/vnd.oci.image.config.v1+json",
179
+
"size": 1470,
180
+
"digest": "sha256:c86f7763873b6c0aae22d963bab59b4f5debbed6685761b5951584f6efb0633b"
181
+
},
182
+
"layers": []
183
+
}
184
+
|}
185
+
in
186
+
match oci_of_json json with
187
+
| Some _ ->
188
+
Alcotest.fail "expected failure: empty layer, expected at least one"
189
+
| None -> ()
190
+
191
+
let test_algorithm_bounds () =
192
+
let json =
193
+
{|
194
+
{
195
+
"schemaVersion": 2,
196
+
"mediaType" : "application/vnd.oci.image.manifest.v1+json",
197
+
"config": {
198
+
"mediaType": "application/vnd.oci.image.config.v1+json",
199
+
"size": 1470,
200
+
"digest": "sha256+b64:c86f7763873b6c0aae22d963bab59b4f5debbed6685761b5951584f6efb0633b"
201
+
},
202
+
"layers": [
203
+
{
204
+
"mediaType": "application/vnd.oci.image.layer.v1.tar+gzip",
205
+
"size": 1470,
206
+
"digest": "sha256+foo-bar:c86f7763873b6c0aae22d963bab59b4f5debbed6685761b5951584f6efb0633b"
207
+
},
208
+
{
209
+
"mediaType": "application/vnd.oci.image.layer.v1.tar+gzip",
210
+
"size": 1470,
211
+
"digest": "sha256.foo-bar:c86f7763873b6c0aae22d963bab59b4f5debbed6685761b5951584f6efb0633b"
212
+
},
213
+
{
214
+
"mediaType": "application/vnd.oci.image.layer.v1.tar+gzip",
215
+
"size": 1470,
216
+
"digest": "multihash+base58:QmRZxt2b1FVZPNqd8hsiykDL3TdBDeTSPX9Kv46HmX4Gx8"
217
+
}
218
+
]
219
+
}
220
+
|}
221
+
in
222
+
match oci_of_json json with
223
+
| Some _ -> ()
224
+
| None ->
225
+
Alcotest.fail "expected pass: test bounds of algorithm field in digest."
226
+
227
+
let test_subject () =
228
+
let json =
229
+
{|
230
+
{
231
+
"schemaVersion": 2,
232
+
"mediaType" : "application/vnd.oci.image.manifest.v1+json",
233
+
"config": {
234
+
"mediaType": "application/vnd.oci.image.config.v1+json",
235
+
"size": 1470,
236
+
"digest": "sha256:c86f7763873b6c0aae22d963bab59b4f5debbed6685761b5951584f6efb0633b"
237
+
},
238
+
"layers": [
239
+
{
240
+
"mediaType": "application/vnd.oci.image.layer.v1.tar+gzip",
241
+
"size": 1470,
242
+
"digest": "sha256:c86f7763873b6c0aae22d963bab59b4f5debbed6685761b5951584f6efb0633b"
243
+
}
244
+
],
245
+
"subject" : {
246
+
"mediaType": "application/vnd.oci.image.manifest.v1+json",
247
+
"size": 1234,
248
+
"digest": "sha256:220a60ecd4a3c32c282622a625a54db9ba0ff55b5ba9c29c7064a2bc358b6a3e"
249
+
}
250
+
}
251
+
|}
252
+
in
253
+
match oci_of_json json with
254
+
| Some _ -> ()
255
+
| None ->
256
+
Alcotest.fail "expected success: subject field with a valid descriptor"
257
+
258
+
let test_invalid_subject () =
259
+
let json =
260
+
{|
261
+
{
262
+
"schemaVersion": 2,
263
+
"mediaType" : "application/vnd.oci.image.manifest.v1+json",
264
+
"config": {
265
+
"mediaType": "application/vnd.oci.image.config.v1+json",
266
+
"size": 1470,
267
+
"digest": "sha256:c86f7763873b6c0aae22d963bab59b4f5debbed6685761b5951584f6efb0633b"
268
+
},
269
+
"layers": [
270
+
{
271
+
"mediaType": "application/vnd.oci.image.layer.v1.tar+gzip",
272
+
"size": 1470,
273
+
"digest": "sha256:c86f7763873b6c0aae22d963bab59b4f5debbed6685761b5951584f6efb0633b"
274
+
}
275
+
],
276
+
"subject" : ".nope"
277
+
}
278
+
|}
279
+
in
280
+
match oci_of_json json with
281
+
| Some _ ->
282
+
Alcotest.fail
283
+
"expected failure: subject field with invalid value (something that is \
284
+
not a descriptor)"
285
+
| None -> ()
286
+
287
+
let test_invalid_algorithm_bounds () =
288
+
let json =
289
+
{|
290
+
{
291
+
"schemaVersion": 2,
292
+
"mediaType" : "application/vnd.oci.image.manifest.v1+json",
293
+
"config": {
294
+
"mediaType": "application/vnd.oci.image.config.v1+json",
295
+
"size": 1470,
296
+
"digest": "sha256+b64:c86f7763873b6c0aae22d963bab59b4f5debbed6685761b5951584f6efb0633b"
297
+
},
298
+
"layers": [
299
+
{
300
+
"mediaType": "application/vnd.oci.image.layer.v1.tar+gzip",
301
+
"size": 1470,
302
+
"digest": "sha256+foo+-b:c86f7763873b6c0aae22d963bab59b4f5debbed6685761b5951584f6efb0633b"
303
+
}
304
+
]
305
+
}
306
+
|}
307
+
in
308
+
match oci_of_json json with
309
+
| Some _ ->
310
+
Alcotest.fail
311
+
"expected failure: push bounds of algorithm field in digest too far."
312
+
| None -> ()
313
+
314
+
let test_config () =
315
+
let json =
316
+
{|
317
+
{
318
+
"schemaVersion": 2,
319
+
"mediaType" : "application/vnd.oci.image.manifest.v1+json",
320
+
"config": {
321
+
"mediaType": "application/vnd.example.config+json",
322
+
"size": 1470,
323
+
"digest": "sha256:c86f7763873b6c0aae22d963bab59b4f5debbed6685761b5951584f6efb0633b"
324
+
},
325
+
"layers": [
326
+
{
327
+
"mediaType": "application/vnd.example.data+type",
328
+
"size": 675598,
329
+
"digest": "sha256:9d3dd9504c685a304985025df4ed0283e47ac9ffa9bd0326fddf4d59513f0827"
330
+
}
331
+
]
332
+
}
333
+
|}
334
+
in
335
+
match oci_of_json json with
336
+
| Some _ -> ()
337
+
| None ->
338
+
Alcotest.fail "valid manifest for an artifact with a dedicated config"
339
+
340
+
let test_empty_config () =
341
+
let json =
342
+
{|
343
+
{
344
+
"schemaVersion": 2,
345
+
"mediaType" : "application/vnd.oci.image.manifest.v1+json",
346
+
"artifactType": "application/vnd.example+type",
347
+
"config": {
348
+
"mediaType": "application/vnd.oci.empty.v1+json",
349
+
"size": 2,
350
+
"digest": "sha256:44136fa355b3678a1146ad16f7e8649e94fb4fc21fe77e8310c060f61caaff8a"
351
+
},
352
+
"layers": [
353
+
{
354
+
"mediaType": "application/vnd.example+type",
355
+
"size": 675598,
356
+
"digest": "sha256:9d3dd9504c685a304985025df4ed0283e47ac9ffa9bd0326fddf4d59513f0827"
357
+
}
358
+
]
359
+
}
360
+
|}
361
+
in
362
+
match oci_of_json json with
363
+
| Some _ -> ()
364
+
| None ->
365
+
Alcotest.fail
366
+
"valid manifest for an artifact using the empty config and artifactType"
367
+
368
+
let test_docker () =
369
+
let json =
370
+
{|
371
+
{
372
+
"schemaVersion": 2,
373
+
"mediaType": "application/vnd.docker.distribution.manifest.list.v2+json",
374
+
"manifests": [
375
+
{
376
+
"mediaType": "application/vnd.docker.distribution.manifest.v2+json",
377
+
"size": 530,
378
+
"digest": "sha256:7b5e783161f46453f3f3d8bc81917bbf16fe8ef212e63e1e903186eb6afad1c6",
379
+
"platform": {
380
+
"architecture": "amd64",
381
+
"os": "linux"
382
+
}
383
+
},
384
+
{
385
+
"mediaType": "application/vnd.docker.distribution.manifest.v2+json",
386
+
"size": 530,
387
+
"digest": "sha256:dbe0a2d09b7e2e9ac138a95eea31576da52f0e83f2c3260ffe8c26ed24118f19",
388
+
"platform": {
389
+
"architecture": "arm64",
390
+
"os": "linux"
391
+
}
392
+
}
393
+
]
394
+
}
395
+
|}
396
+
in
397
+
match of_json Manifest_list.of_yojson json with
398
+
| Some _ -> ()
399
+
| None -> Alcotest.fail "invalide docker flat manifest"
400
+
401
+
let suite =
402
+
[
403
+
test_case "test_invalid_media_type" `Quick test_invalid_media_type;
404
+
test_case "test_invalid_config_size" `Quick test_invalid_config_size;
405
+
test_case "test_invalid_layers_size" `Quick test_invalid_layers_size;
406
+
test_case "test_valid_manifest_with_optional_fields" `Quick
407
+
test_valid_manifest_with_optional_fields;
408
+
test_case "test_valid_manifest_with_required_fields" `Quick
409
+
test_valid_manifest_with_required_fields;
410
+
test_case "test_invalid_empty_layer" `Quick test_invalid_empty_layer;
411
+
test_case "test_algorithm_bounds" `Quick test_algorithm_bounds;
412
+
test_case "test_subject" `Quick test_subject;
413
+
test_case "test_invalid_subject" `Quick test_invalid_subject;
414
+
test_case "test_invalid_algorithm_bounds" `Quick
415
+
test_invalid_algorithm_bounds;
416
+
test_case "test_config" `Quick test_config;
417
+
test_case "test_empty_config" `Quick test_empty_config;
418
+
test_case "docker manifest list" `Quick test_docker;
419
+
]
+1
test/test_manifest.mli
+1
test/test_manifest.mli
···
1
+
val suite : unit Alcotest.test_case list