gazagnaire.org
Kubernetes CRI CLI: crictl-shaped client, simulator server, proxy
1(* The container-runtime boundary for the CRI server, and an in-memory
2 simulator. A backend implements every RuntimeService and ImageService
3 operation over its own state; Cri_server.Make builds the gRPC server over any
4 S. The Memory backend tracks a simulated pod/container/image lifecycle with
5 no real process, exactly as the docker-runner Memory backend does: lifecycle
6 transitions are bookkeeping, stats are zero, exec/attach return a URL but
7 stream no bytes, exec_sync exits 0 with empty output. These are documented
8 simulations, never silent stubs. *)
9
10type error =
11 | Not_found of string
12 | Invalid_argument of string
13 | Unimplemented of string
14 | Internal of string
15
16module type S = sig
17 type t
18
19 val version : t -> Version.request -> (Version.response, error) result
20
21 (* Pod sandboxes *)
22 val run_pod_sandbox :
23 t ->
24 Pod_sandbox.run_pod_sandbox_request ->
25 (Pod_sandbox.run_pod_sandbox_response, error) result
26
27 val stop_pod_sandbox :
28 t -> Pod_sandbox.stop_pod_sandbox_request -> (unit, error) result
29
30 val remove_pod_sandbox :
31 t -> Pod_sandbox.remove_pod_sandbox_request -> (unit, error) result
32
33 val pod_sandbox_status :
34 t ->
35 Pod_sandbox.status_request ->
36 (Pod_sandbox.status_response, error) result
37
38 val list_pod_sandbox :
39 t ->
40 Pod_sandbox.list_pod_sandbox_request ->
41 (Pod_sandbox.list_pod_sandbox_response, error) result
42
43 val stream_pod_sandboxes :
44 t ->
45 Pod_sandbox.stream_pod_sandboxes_request ->
46 (Pod_sandbox.stream_pod_sandboxes_response, error) result
47
48 val pod_sandbox_stats :
49 t -> Pod_sandbox.stats_request -> (Pod_sandbox.stats_response, error) result
50
51 val list_pod_sandbox_stats :
52 t ->
53 Pod_sandbox.list_pod_sandbox_stats_request ->
54 (Pod_sandbox.list_pod_sandbox_stats_response, error) result
55
56 val stream_pod_sandbox_stats :
57 t ->
58 Pod_sandbox.stream_pod_sandbox_stats_request ->
59 (Pod_sandbox.stream_pod_sandbox_stats_response, error) result
60
61 val update_pod_sandbox_resources :
62 t ->
63 Pod_sandbox.update_pod_sandbox_resources_request ->
64 (unit, error) result
65
66 (* Containers *)
67 val container_create :
68 t ->
69 Container.creation_request ->
70 (Container.creation_response, error) result
71
72 val start_container :
73 t -> Container.start_container_request -> (unit, error) result
74
75 val stop_container :
76 t -> Container.stop_container_request -> (unit, error) result
77
78 val remove_container :
79 t -> Container.remove_container_request -> (unit, error) result
80
81 val list_containers :
82 t ->
83 Container.list_containers_request ->
84 (Container.list_containers_response, error) result
85
86 val stream_containers :
87 t ->
88 Container.stream_containers_request ->
89 (Container.stream_containers_response, error) result
90
91 val container_status :
92 t -> Container.status_request -> (Container.status_response, error) result
93
94 val update_container_resources :
95 t -> Container.update_container_resources_request -> (unit, error) result
96
97 val reopen_container_log :
98 t -> Container.reopen_container_log_request -> (unit, error) result
99
100 val checkpoint_container :
101 t -> Container.checkpoint_container_request -> (unit, error) result
102
103 val container_stats :
104 t -> Container.stats_request -> (Container.stats_response, error) result
105
106 val list_container_stats :
107 t ->
108 Container.list_container_stats_request ->
109 (Container.list_container_stats_response, error) result
110
111 val stream_container_stats :
112 t ->
113 Container.stream_container_stats_request ->
114 (Container.stream_container_stats_response, error) result
115
116 (* Streaming endpoints *)
117 val exec_sync : t -> Exec.sync_request -> (Exec.sync_response, error) result
118 val exec : t -> Exec.request -> (Exec.response, error) result
119 val attach : t -> Exec.attach_request -> (Exec.attach_response, error) result
120
121 val port_forward :
122 t -> Exec.port_forward_request -> (Exec.port_forward_response, error) result
123
124 (* Runtime *)
125 val update_runtime_config :
126 t -> Runtime.update_runtime_config_request -> (unit, error) result
127
128 val status :
129 t -> Runtime.status_request -> (Runtime.status_response, error) result
130
131 val runtime_config : t -> unit -> (Runtime.config_response, error) result
132
133 val container_events :
134 t -> unit -> (Event.container_event_response list, error) result
135
136 val list_metric_descriptors :
137 t -> unit -> (Metrics.list_metric_descriptors_response, error) result
138
139 val list_pod_sandbox_metrics :
140 t -> unit -> (Metrics.list_pod_sandbox_metrics_response, error) result
141
142 val stream_pod_sandbox_metrics :
143 t -> unit -> (Metrics.stream_pod_sandbox_metrics_response, error) result
144
145 (* Images *)
146 val list_images :
147 t -> Image.list_images_request -> (Image.list_images_response, error) result
148
149 val stream_images :
150 t ->
151 Image.stream_images_request ->
152 (Image.stream_images_response, error) result
153
154 val image_status :
155 t -> Image.status_request -> (Image.status_response, error) result
156
157 val pull_image :
158 t -> Image.pull_image_request -> (Image.pull_image_response, error) result
159
160 val remove_image : t -> Image.remove_image_request -> (unit, error) result
161 val image_fs_info : t -> unit -> (Image.fs_info_response, error) result
162end
163
164module type BACKEND = S
165
166module Memory = struct
167 type pod = {
168 id : string;
169 config : Pod_config.pod_sandbox_config;
170 mutable ready : bool;
171 created : int64;
172 handler : string;
173 }
174
175 type ctr = {
176 id : string;
177 pod : string;
178 config : Container.config;
179 mutable state : int32; (* 0 created, 1 running, 2 exited *)
180 created : int64;
181 mutable started : int64;
182 mutable finished : int64;
183 exit : int32;
184 image_ref : string;
185 }
186
187 type img = { id : string; tags : string list; size : int64 }
188
189 type t = {
190 pods : (string, pod) Hashtbl.t;
191 ctrs : (string, ctr) Hashtbl.t;
192 imgs : (string, img) Hashtbl.t;
193 mutable clock : int64;
194 mutable counter : int;
195 }
196
197 let v () =
198 {
199 pods = Hashtbl.create 16;
200 ctrs = Hashtbl.create 16;
201 imgs = Hashtbl.create 16;
202 clock = 1L;
203 counter = 0;
204 }
205
206 let tick t =
207 t.clock <- Int64.add t.clock 1L;
208 t.clock
209
210 let next_id t prefix =
211 t.counter <- t.counter + 1;
212 Fmt.str "%s-%08d" prefix t.counter
213
214 (* proto3-default empty image-spec used when a request omits the field. *)
215 let image_ref_of_spec (s : Image_spec.t option) =
216 match s with Some s -> s.image | None -> ""
217
218 let labels_match selector labels =
219 List.for_all (fun (k, v) -> List.assoc_opt k labels = Some v) selector
220
221 (* Projections from internal records to wire messages. *)
222 let pod_to_summary (p : pod) : Pod_sandbox.t =
223 {
224 id = p.id;
225 metadata = p.config.metadata;
226 state = (if p.ready then 0l else 1l);
227 created_at = p.created;
228 labels = p.config.labels;
229 annotations = p.config.annotations;
230 runtime_handler = p.handler;
231 }
232
233 let pod_to_status (p : pod) : Pod_sandbox.status =
234 {
235 id = p.id;
236 metadata = p.config.metadata;
237 state = (if p.ready then 0l else 1l);
238 created_at = p.created;
239 network = Some { ip = "10.88.0.1"; additional_ips = [] };
240 linux = None;
241 labels = p.config.labels;
242 annotations = p.config.annotations;
243 runtime_handler = p.handler;
244 }
245
246 let ctr_to_container (c : ctr) : Container.t =
247 {
248 id = c.id;
249 pod_sandbox_id = c.pod;
250 metadata = c.config.metadata;
251 image = c.config.image;
252 image_ref = c.image_ref;
253 state = c.state;
254 created_at = c.created;
255 labels = c.config.labels;
256 annotations = c.config.annotations;
257 image_id = c.image_ref;
258 }
259
260 let ctr_to_status (c : ctr) : Container.status =
261 {
262 id = c.id;
263 metadata = c.config.metadata;
264 state = c.state;
265 created_at = c.created;
266 started_at = c.started;
267 finished_at = c.finished;
268 exit_code = c.exit;
269 image = c.config.image;
270 image_ref = c.image_ref;
271 reason = "";
272 message = "";
273 labels = c.config.labels;
274 annotations = c.config.annotations;
275 mounts = c.config.mounts;
276 log_path = c.config.log_path;
277 resources = None;
278 image_id = c.image_ref;
279 user = None;
280 stop_signal = c.config.stop_signal;
281 }
282
283 let version _ (_ : Version.request) =
284 Ok
285 ({
286 version = "v1";
287 runtime_name = "crid";
288 runtime_version = "0.1.0";
289 runtime_api_version = "v1";
290 }
291 : Version.response)
292
293 (* Pod sandboxes *)
294 let run_pod_sandbox t (r : Pod_sandbox.run_pod_sandbox_request) =
295 match r.config with
296 | None -> Error (Invalid_argument "RunPodSandbox: config required")
297 | Some config ->
298 let id = next_id t "pod" in
299 let p =
300 {
301 id;
302 config;
303 ready = true;
304 created = tick t;
305 handler = r.runtime_handler;
306 }
307 in
308 Hashtbl.replace t.pods id p;
309 Ok ({ pod_sandbox_id = id } : Pod_sandbox.run_pod_sandbox_response)
310
311 let stop_pod_sandbox t (r : Pod_sandbox.stop_pod_sandbox_request) =
312 match Hashtbl.find_opt t.pods r.pod_sandbox_id with
313 | None -> Error (Not_found ("StopPodSandbox: " ^ r.pod_sandbox_id))
314 | Some p ->
315 p.ready <- false;
316 Hashtbl.iter
317 (fun _ c -> if c.pod = p.id && c.state = 1l then c.state <- 2l)
318 t.ctrs;
319 Ok ()
320
321 let remove_pod_sandbox t (r : Pod_sandbox.remove_pod_sandbox_request) =
322 let to_remove =
323 Hashtbl.fold
324 (fun id c acc -> if c.pod = r.pod_sandbox_id then id :: acc else acc)
325 t.ctrs []
326 in
327 List.iter (Hashtbl.remove t.ctrs) to_remove;
328 Hashtbl.remove t.pods r.pod_sandbox_id;
329 Ok ()
330
331 let pod_sandbox_status t (r : Pod_sandbox.status_request) =
332 match Hashtbl.find_opt t.pods r.pod_sandbox_id with
333 | None -> Error (Not_found ("PodSandboxStatus: " ^ r.pod_sandbox_id))
334 | Some p ->
335 let containers_statuses =
336 Hashtbl.fold
337 (fun _ c acc ->
338 if c.pod = p.id then ctr_to_status c :: acc else acc)
339 t.ctrs []
340 in
341 Ok
342 ({
343 status = Some (pod_to_status p);
344 info = [];
345 containers_statuses;
346 timestamp = tick t;
347 }
348 : Pod_sandbox.status_response)
349
350 let pod_matches (f : Pod_sandbox.filter option) (p : pod) =
351 match f with
352 | None -> true
353 | Some f ->
354 (f.id = "" || f.id = p.id)
355 && (match f.state with
356 | None -> true
357 | Some s -> s.state = if p.ready then 0l else 1l)
358 && labels_match f.label_selector p.config.labels
359
360 let list_pods t f =
361 Hashtbl.fold
362 (fun _ p acc -> if pod_matches f p then pod_to_summary p :: acc else acc)
363 t.pods []
364
365 let list_pod_sandbox t (r : Pod_sandbox.list_pod_sandbox_request) =
366 Ok
367 ({ items = list_pods t r.filter } : Pod_sandbox.list_pod_sandbox_response)
368
369 let stream_pod_sandboxes t (r : Pod_sandbox.stream_pod_sandboxes_request) =
370 Ok
371 ({ pod_sandboxes = list_pods t r.filter }
372 : Pod_sandbox.stream_pod_sandboxes_response)
373
374 (* Stats are simulated as zero/absent (no real process is measured). *)
375 let pod_sandbox_stats t (r : Pod_sandbox.stats_request) =
376 match Hashtbl.find_opt t.pods r.pod_sandbox_id with
377 | None -> Error (Not_found ("PodSandboxStats: " ^ r.pod_sandbox_id))
378 | Some p ->
379 let stats : Stats.pod_sandbox_stats =
380 {
381 attributes =
382 Some
383 {
384 id = p.id;
385 metadata = p.config.metadata;
386 labels = p.config.labels;
387 annotations = p.config.annotations;
388 };
389 linux = None;
390 windows = None;
391 }
392 in
393 Ok ({ stats = Some stats } : Pod_sandbox.stats_response)
394
395 let list_pod_sandbox_stats _ (_ : Pod_sandbox.list_pod_sandbox_stats_request)
396 =
397 Ok ({ stats = [] } : Pod_sandbox.list_pod_sandbox_stats_response)
398
399 let stream_pod_sandbox_stats _
400 (_ : Pod_sandbox.stream_pod_sandbox_stats_request) =
401 Ok
402 ({ pod_sandbox_stats = [] }
403 : Pod_sandbox.stream_pod_sandbox_stats_response)
404
405 let update_pod_sandbox_resources t
406 (r : Pod_sandbox.update_pod_sandbox_resources_request) =
407 if Hashtbl.mem t.pods r.pod_sandbox_id then Ok ()
408 else Error (Not_found ("UpdatePodSandboxResources: " ^ r.pod_sandbox_id))
409
410 (* Containers *)
411 let container_create t (r : Container.creation_request) =
412 if not (Hashtbl.mem t.pods r.pod_sandbox_id) then
413 Error (Not_found ("CreateContainer: sandbox " ^ r.pod_sandbox_id))
414 else
415 match r.config with
416 | None -> Error (Invalid_argument "CreateContainer: config required")
417 | Some config ->
418 let id = next_id t "ctr" in
419 let c =
420 {
421 id;
422 pod = r.pod_sandbox_id;
423 config;
424 state = 0l;
425 created = tick t;
426 started = 0L;
427 finished = 0L;
428 exit = 0l;
429 image_ref = image_ref_of_spec config.image;
430 }
431 in
432 Hashtbl.replace t.ctrs id c;
433 Ok ({ container_id = id } : Container.creation_response)
434
435 let start_container t (r : Container.start_container_request) =
436 match Hashtbl.find_opt t.ctrs r.container_id with
437 | None -> Error (Not_found ("StartContainer: " ^ r.container_id))
438 | Some c ->
439 c.state <- 1l;
440 c.started <- tick t;
441 Ok ()
442
443 let stop_container t (r : Container.stop_container_request) =
444 match Hashtbl.find_opt t.ctrs r.container_id with
445 | None -> Error (Not_found ("StopContainer: " ^ r.container_id))
446 | Some c ->
447 c.state <- 2l;
448 c.finished <- tick t;
449 Ok ()
450
451 let remove_container t (r : Container.remove_container_request) =
452 Hashtbl.remove t.ctrs r.container_id;
453 Ok ()
454
455 let ctr_matches (f : Container.filter option) (c : ctr) =
456 match f with
457 | None -> true
458 | Some f ->
459 (f.id = "" || f.id = c.id)
460 && (f.pod_sandbox_id = "" || f.pod_sandbox_id = c.pod)
461 && (match f.state with None -> true | Some s -> s.state = c.state)
462 && labels_match f.label_selector c.config.labels
463
464 let list_ctrs t f =
465 Hashtbl.fold
466 (fun _ c acc ->
467 if ctr_matches f c then ctr_to_container c :: acc else acc)
468 t.ctrs []
469
470 let list_containers t (r : Container.list_containers_request) =
471 Ok
472 ({ containers = list_ctrs t r.filter }
473 : Container.list_containers_response)
474
475 let stream_containers t (r : Container.stream_containers_request) =
476 Ok
477 ({ containers = list_ctrs t r.filter }
478 : Container.stream_containers_response)
479
480 let container_status t (r : Container.status_request) =
481 match Hashtbl.find_opt t.ctrs r.container_id with
482 | None -> Error (Not_found ("ContainerStatus: " ^ r.container_id))
483 | Some c ->
484 Ok
485 ({ status = Some (ctr_to_status c); info = [] }
486 : Container.status_response)
487
488 let update_container_resources t
489 (r : Container.update_container_resources_request) =
490 if Hashtbl.mem t.ctrs r.container_id then Ok ()
491 else Error (Not_found ("UpdateContainerResources: " ^ r.container_id))
492
493 let reopen_container_log t (r : Container.reopen_container_log_request) =
494 if Hashtbl.mem t.ctrs r.container_id then Ok ()
495 else Error (Not_found ("ReopenContainerLog: " ^ r.container_id))
496
497 let checkpoint_container t (r : Container.checkpoint_container_request) =
498 if Hashtbl.mem t.ctrs r.container_id then Ok ()
499 else Error (Not_found ("CheckpointContainer: " ^ r.container_id))
500
501 let container_stats t (r : Container.stats_request) =
502 match Hashtbl.find_opt t.ctrs r.container_id with
503 | None -> Error (Not_found ("ContainerStats: " ^ r.container_id))
504 | Some c ->
505 let stats : Stats.container_stats =
506 {
507 attributes =
508 Some
509 {
510 id = c.id;
511 metadata = c.config.metadata;
512 labels = c.config.labels;
513 annotations = c.config.annotations;
514 };
515 cpu = None;
516 memory = None;
517 writable_layer = None;
518 swap = None;
519 io = None;
520 }
521 in
522 Ok ({ stats = Some stats } : Container.stats_response)
523
524 let list_container_stats _ (_ : Container.list_container_stats_request) =
525 Ok ({ stats = [] } : Container.list_container_stats_response)
526
527 let stream_container_stats _ (_ : Container.stream_container_stats_request) =
528 Ok ({ container_stats = [] } : Container.stream_container_stats_response)
529
530 (* Streaming endpoints: the simulator returns a URL but serves no stream. *)
531 let exec_sync t (r : Exec.sync_request) =
532 if Hashtbl.mem t.ctrs r.container_id then
533 Ok ({ stdout = ""; stderr = ""; exit_code = 0l } : Exec.sync_response)
534 else Error (Not_found ("ExecSync: " ^ r.container_id))
535
536 let exec t (r : Exec.request) =
537 if Hashtbl.mem t.ctrs r.container_id then
538 Ok ({ url = "http://127.0.0.1/exec/" ^ r.container_id } : Exec.response)
539 else Error (Not_found ("Exec: " ^ r.container_id))
540
541 let attach t (r : Exec.attach_request) =
542 if Hashtbl.mem t.ctrs r.container_id then
543 Ok
544 ({ url = "http://127.0.0.1/attach/" ^ r.container_id }
545 : Exec.attach_response)
546 else Error (Not_found ("Attach: " ^ r.container_id))
547
548 let port_forward t (r : Exec.port_forward_request) =
549 if Hashtbl.mem t.pods r.pod_sandbox_id then
550 Ok
551 ({ url = "http://127.0.0.1/portforward/" ^ r.pod_sandbox_id }
552 : Exec.port_forward_response)
553 else Error (Not_found ("PortForward: " ^ r.pod_sandbox_id))
554
555 (* Runtime *)
556 let update_runtime_config _ (_ : Runtime.update_runtime_config_request) =
557 Ok ()
558
559 let status _ (_ : Runtime.status_request) =
560 let cond type_ =
561 ({ type_; status = true; reason = ""; message = "" } : Runtime.condition)
562 in
563 Ok
564 ({
565 status =
566 Some { conditions = [ cond "RuntimeReady"; cond "NetworkReady" ] };
567 info = [];
568 runtime_handlers = [];
569 features = None;
570 }
571 : Runtime.status_response)
572
573 let runtime_config _ () = Ok ({ linux = None } : Runtime.config_response)
574 let container_events _ () = Ok []
575
576 let list_metric_descriptors _ () =
577 Ok ({ descriptors = [] } : Metrics.list_metric_descriptors_response)
578
579 let list_pod_sandbox_metrics _ () =
580 Ok ({ pod_metrics = [] } : Metrics.list_pod_sandbox_metrics_response)
581
582 let stream_pod_sandbox_metrics _ () =
583 Ok
584 ({ pod_sandbox_metrics = [] }
585 : Metrics.stream_pod_sandbox_metrics_response)
586
587 (* Images: metadata only; pulling registers an id derived from the ref. *)
588 let img_to_image (i : img) : Image.t =
589 {
590 id = i.id;
591 repo_tags = i.tags;
592 repo_digests = [];
593 size = i.size;
594 uid = None;
595 username = "";
596 spec =
597 Some
598 {
599 image = i.id;
600 annotations = [];
601 user_specified_image = "";
602 runtime_handler = "";
603 image_ref = i.id;
604 };
605 pinned = false;
606 }
607
608 let list_images t (_ : Image.list_images_request) =
609 let images =
610 Hashtbl.fold (fun _ i acc -> img_to_image i :: acc) t.imgs []
611 in
612 Ok ({ images } : Image.list_images_response)
613
614 let stream_images t (_ : Image.stream_images_request) =
615 let images =
616 Hashtbl.fold (fun _ i acc -> img_to_image i :: acc) t.imgs []
617 in
618 Ok ({ images } : Image.stream_images_response)
619
620 let image_status t (r : Image.status_request) =
621 let ref = image_ref_of_spec r.image in
622 match Hashtbl.find_opt t.imgs ref with
623 | Some i ->
624 Ok
625 ({ image = Some (img_to_image i); info = [] } : Image.status_response)
626 | None -> Ok ({ image = None; info = [] } : Image.status_response)
627
628 let pull_image t (r : Image.pull_image_request) =
629 let ref = image_ref_of_spec r.image in
630 let id = if ref = "" then next_id t "img" else ref in
631 let tags = if ref = "" then [] else [ ref ] in
632 (match Hashtbl.find_opt t.imgs id with
633 | Some _ -> ()
634 | None -> Hashtbl.replace t.imgs id { id; tags; size = 0L });
635 Ok ({ image_ref = id } : Image.pull_image_response)
636
637 let remove_image t (r : Image.remove_image_request) =
638 Hashtbl.remove t.imgs (image_ref_of_spec r.image);
639 Ok ()
640
641 let image_fs_info _ () =
642 Ok
643 ({ image_filesystems = []; container_filesystems = [] }
644 : Image.fs_info_response)
645end