├── .gitignore ├── CHANGES.md ├── LICENSE.md ├── Makefile ├── README.md ├── compatibility.ml ├── docker-api.opam ├── dune-project ├── src ├── docker.ml ├── docker.mli ├── docker_config.pre.ml ├── docker_utils.pre.ml └── dune └── test ├── bind.ml ├── common.ml ├── dune ├── exec.ml ├── ls.ml ├── no_cmd.ml ├── no_image.ml ├── ps.ml ├── robust.ml ├── run.ml ├── secure.ml └── version.ml /.gitignore: -------------------------------------------------------------------------------- 1 | _build/ 2 | .merlin 3 | *.install 4 | src/docker_utils.ml 5 | src/docker_config.ml 6 | *.tar.gz 7 | bind.dir/ 8 | INFO.org 9 | PROBLEMS.md 10 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | 0.2.1 2018-10-30 2 | ---------------- 3 | 4 | - Handle an undocumented status for `Docker.Container.start`. 5 | 6 | 0.2 2017-10-15 7 | -------------- 8 | 9 | - Upgrade to API v1.29. 10 | - New signature of `Container.create`. 11 | - Add functions `Container.wait` and `Container.changes`. 12 | - Handle errors `409 Conflict`. 13 | - New exceptions `Docker.Failure` and `Docker.No_such_container`. 14 | - Rename `Docker.Images` as `Docker.Image` and add the `create` 15 | function to pull images. 16 | - Documentation improvements. 17 | - New tests `ls` and `ps` and improve the other ones. 18 | - Use [Dune](https://github.com/ocaml/dune) and 19 | [dune-release](https://github.com/samoht/dune-release). 20 | 21 | 22 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | 2 | Copyright (c) 3 | 4 | Permission to use, copy, modify, and distribute this software for any 5 | purpose with or without fee is hereby granted, provided that the above 6 | copyright notice and this permission notice appear in all copies. 7 | 8 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # This Makefile is intended for developers. Users simply use dune. 2 | 3 | PKGVERSION = $(shell git describe --always --dirty) 4 | 5 | all build: 6 | dune build @install @tests 7 | 8 | test runtest: 9 | dune runtest --force 10 | 11 | install uninstall: 12 | dune $@ 13 | 14 | doc: all 15 | sed -e 's/%%VERSION%%/$(PKGVERSION)/' src/docker.mli \ 16 | > _build/default/src/docker.mli 17 | dune build @doc 18 | 19 | lint: 20 | @opam lint docker-api.opam 21 | 22 | clean: 23 | dune clean 24 | $(RM) $(wildcard *~ *.pdf *.ps *.png *.svg) 25 | 26 | .PHONY: all build test runtest clean 27 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | OCaml client for Docker Remote API 2 | ================================== 3 | 4 | This library provides an OCaml client for 5 | [Docker Remote API](https://docs.docker.com/reference/api/docker_remote_api/), 6 | version 1.29. 7 | This library is tested with the 8 | [community edition](https://docs.docker.com/engine/installation/) 9 | of Docker. 10 | 11 | Note that the OPAM and ocamlfind packages are called `docker-api` (to 12 | distinguish them from other packages related to Docker) but the OCaml 13 | module is named `Docker` (because the code reads better with that name 14 | IMHO). 15 | 16 | 17 | Compilation & installation 18 | -------------------------- 19 | 20 | The easier way to install this library is to use 21 | [OPAM](http://opam.ocaml.org/). Just type: 22 | 23 | opam install docker-api 24 | 25 | This library depends on [Dune](https://github.com/ocaml/dune) (to 26 | compile) and [Yojson](https://github.com/ocaml-community/yojson). 27 | 28 | To compile as a developer, just type `make` and then `make install` to 29 | install it. 30 | 31 | Documentation 32 | ------------- 33 | 34 | Please read the [interface](src/docker.mli) or the 35 | [HTML version](http://chris00.github.io/ocaml-docker/doc/docker-api/Docker/). 36 | 37 | 38 | Testing 39 | ------- 40 | 41 | If you compile using `make`, the tests will be built. In order to run 42 | them, make sure that the latest Debian image is installed — if not, 43 | simply issue `docker pull debian:latest` in a shell — and issue `make 44 | test`. 45 | -------------------------------------------------------------------------------- /compatibility.ml: -------------------------------------------------------------------------------- 1 | #load "str.cma";; 2 | 3 | (* Utils 4 | ***********************************************************************) 5 | 6 | let major, minor = 7 | Scanf.sscanf Sys.ocaml_version "%i.%i" (fun a b -> a,b) 8 | 9 | let input_file ?(path=".") ?(comments=true) fname = 10 | let fh = open_in (Filename.concat path fname) in 11 | let buf = Buffer.create 2048 in 12 | try 13 | while true do 14 | let l = input_line fh in (* or exn *) 15 | Buffer.add_string buf l; 16 | Buffer.add_char buf '\n' 17 | done; 18 | assert false 19 | with End_of_file -> 20 | close_in fh; 21 | Buffer.contents buf 22 | 23 | let output_file ?(path=".") fname ~content = 24 | let fh = open_out (Filename.concat path fname) in 25 | output_string fh content; 26 | close_out fh 27 | 28 | (* Compatibility 29 | ***********************************************************************) 30 | 31 | let () = 32 | let fname_in = "docker_utils.pre.ml" in 33 | let fname_out = "docker_utils.ml" in 34 | if major >= 4 && minor >= 2 then ( 35 | (* Comment out the compatibility code. *) 36 | let s = input_file fname_in in 37 | let s = Str.global_replace (Str.regexp "BEGIN COMPATIBILITY \\*)") "" s in 38 | let s = Str.global_replace (Str.regexp "(\\* END COMPATIBILITY") "" s in 39 | output_file fname_out s 40 | ) 41 | else ( 42 | (* Just copy the file. *) 43 | output_file fname_out (input_file fname_in) 44 | ) 45 | 46 | (* Docker config 47 | ***********************************************************************) 48 | 49 | let () = 50 | let fname_in = "docker_config.pre.ml" in 51 | let fname_out = "docker_config.ml" in 52 | let s = input_file fname_in in 53 | let s = Str.global_replace (Str.regexp_string "%%SYSTEM%%") Sys.os_type s in 54 | let s = Str.global_replace (Str.regexp_string "%%VERSION%%") "dev" s in 55 | output_file fname_out s 56 | 57 | ;; 58 | -------------------------------------------------------------------------------- /docker-api.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Binding to the Docker Remote API" 4 | description: 5 | "Control Docker containers using the remote API." 6 | maintainer: ["Christophe Troestler "] 7 | authors: ["Christophe Troestler "] 8 | license: "ISC" 9 | homepage: "https://github.com/Chris00/ocaml-docker" 10 | doc: "https://Chris00.github.io/ocaml-docker/doc" 11 | bug-reports: "https://github.com/Chris00/ocaml-docker/issues" 12 | depends: [ 13 | "dune" {>= "2.8"} 14 | "ocaml" {>= "4.03"} 15 | "base-bytes" 16 | "base-unix" 17 | "yojson" {>= "1.6.0"} 18 | "odoc" {with-doc} 19 | ] 20 | build: [ 21 | ["dune" "subst"] {dev} 22 | [ 23 | "dune" 24 | "build" 25 | "-p" 26 | name 27 | "-j" 28 | jobs 29 | "@install" 30 | "@runtest" {with-test} 31 | "@doc" {with-doc} 32 | ] 33 | ] 34 | dev-repo: "git+https://github.com/Chris00/ocaml-docker.git" 35 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.8) 2 | (generate_opam_files true) 3 | 4 | (name docker-api) 5 | 6 | (source (github Chris00/ocaml-docker)) 7 | (license ISC) 8 | (authors "Christophe Troestler ") 9 | (maintainers "Christophe Troestler ") 10 | 11 | (package 12 | (name docker-api) 13 | (synopsis "Binding to the Docker Remote API") 14 | (description "Control Docker containers using the remote API.") 15 | (documentation "https://Chris00.github.io/ocaml-docker/doc") 16 | (depends 17 | (ocaml (>= 4.03)) 18 | base-bytes 19 | base-unix 20 | (yojson (>= 1.6.0)))) 21 | -------------------------------------------------------------------------------- /src/docker.ml: -------------------------------------------------------------------------------- 1 | open Docker_utils 2 | module Json = Yojson.Safe 3 | 4 | exception No_such_container of string 5 | exception Failure of string * string 6 | exception Invalid_argument of string 7 | exception Server_error of string 8 | exception Error of string * string 9 | 10 | let default_addr = 11 | if Sys.win32 then 12 | ref(Unix.ADDR_INET (Unix.inet_addr_of_string "127.0.0.1", 2375)) 13 | else 14 | ref(Unix.ADDR_UNIX "/var/run/docker.sock") 15 | 16 | let set_default_addr addr = default_addr := addr 17 | (* FIXME: When Unix.ADDR_UNIX, check that the file exists?? *) 18 | 19 | let connect fn_name addr = 20 | let fd = Unix.socket (Unix.domain_of_sockaddr addr) Unix.SOCK_STREAM 0 in 21 | try Unix.connect fd addr; 22 | fd 23 | with Unix.Unix_error (Unix.ENOENT, _, _) -> 24 | Unix.close fd; 25 | raise(Error(fn_name, "Cannot connect: socket does not exist")) 26 | 27 | (* Return a number < 0 if not found. 28 | It is ASSUMED that [pos] and [len] delimit a valid substring. *) 29 | let rec index_CRLF (s: Bytes.t) ~pos ~len = 30 | if len <= 1 then -1 (* Cannot match "\r\n" *) 31 | else if Bytes.get s pos = '\r' && Bytes.get s (pos+1) = '\n' then pos 32 | else index_CRLF s ~pos:(pos + 1) ~len:(len - 1) 33 | 34 | (* Return the list of header lines and keep in [buf] the additional 35 | bytes that may have been read. *) 36 | let read_headers fn_name buf fd = 37 | let headers = ref [] in 38 | let b = Bytes.create 4096 in 39 | let continue = ref true in 40 | while !continue do 41 | let r = Unix.read fd b 0 4096 in 42 | if r > 0 then 43 | (* Split on \r\n *) 44 | let i = index_CRLF b ~pos:0 ~len:r in 45 | if i < 0 then 46 | Buffer.add_subbytes buf b 0 r 47 | else if i = 0 && Buffer.length buf = 0 then ( 48 | (* End of headers (all previously captured). *) 49 | Buffer.add_subbytes buf b 0 r; 50 | continue := false 51 | ) 52 | else ( 53 | Buffer.add_subbytes buf b 0 i; 54 | headers := Buffer.contents buf :: !headers; 55 | Buffer.clear buf; 56 | (* Capture all possible additional headers in [b]. *) 57 | let pos = ref (i+2) and len = ref (r - i - 2) in 58 | let i = ref 0 in 59 | while (i := index_CRLF b ~pos:!pos ~len:!len; !i > !pos) do 60 | let h_len = !i - !pos in 61 | headers := Bytes.sub_string b !pos h_len :: !headers; 62 | pos := !i + 2; 63 | len := !len - h_len - 2; 64 | done; 65 | if !i < 0 then Buffer.add_subbytes buf b !pos !len 66 | else ( (* !i = !pos, i.e., empty line *) 67 | Buffer.add_subbytes buf b (!pos + 2) (!len - 2); 68 | continue := false; 69 | ) 70 | ) 71 | else continue := false 72 | done; 73 | match List.rev !headers with 74 | | [] -> 75 | Unix.close fd; 76 | raise (Error(fn_name, "No status sent")) 77 | | status :: tl -> 78 | let code = 79 | try let i1 = String.index status ' ' in 80 | let i2 = String.index_from status (i1 + 1) ' ' in 81 | int_of_string(String.sub status (i1 + 1) (i2 - i1 - 1)) 82 | with _ -> 83 | Unix.close fd; 84 | raise(Error(fn_name, "Incorrect status line: " ^ status)) in 85 | (* Let the client functions deal with 4xx to have more precise 86 | messages. *) 87 | code, tl 88 | 89 | (* [read_all buf fd] add to [buf] the content of [fd] until EOI is reached. *) 90 | let read_all buf fd = 91 | let b = Bytes.create 4096 in 92 | let continue = ref true in 93 | while !continue do 94 | let r = Unix.read fd b 0 4096 in 95 | if r > 0 then Buffer.add_subbytes buf b 0 r 96 | else continue := false 97 | done; 98 | Buffer.contents buf 99 | 100 | let read_response fn_name fd = 101 | let buf = Buffer.create 4096 in 102 | let status, h = read_headers fn_name buf fd in 103 | if status = 204 (* No Content *) || status = 205 (* Reset Content *) then 104 | status, h, "" 105 | else 106 | (* FIXME: Use Content-Length header if exists ? *) 107 | let body = read_all buf fd in 108 | (* In case of error 500, the body may provide an explanation... but 109 | it may also stall the whole computation so do not read it. *) 110 | if status >= 500 then ( 111 | Unix.close fd; 112 | raise(Server_error fn_name); 113 | ); 114 | status, h, body 115 | 116 | (* When the command returns a stream, we only attempt to read the 117 | whole payload in case of error. *) 118 | let deal_with_status_500 fn_name status fd = 119 | if status >= 500 then ( 120 | Unix.close fd; 121 | raise(Server_error fn_name); 122 | ) 123 | 124 | let[@inline] send_buffer fn_name addr buf = 125 | let fd = connect fn_name addr in 126 | ignore(Unix.write fd (Buffer.to_bytes buf) 0 (Buffer.length buf)); 127 | fd 128 | 129 | let get fn_name addr url query = 130 | let buf = Buffer.create 256 in 131 | Buffer.add_string buf "GET /v1.29"; 132 | Buffer.add_string buf url; 133 | Buffer.add_encoded_query buf query; 134 | Buffer.add_string buf Docker_config.http11_header; 135 | Buffer.add_string buf "\r\n"; 136 | send_buffer fn_name addr buf 137 | 138 | let response_of_get fn_name addr url query = 139 | let fd = get fn_name addr url query in 140 | Unix.shutdown fd Unix.SHUTDOWN_SEND; 141 | let r = read_response fn_name fd in 142 | Unix.close fd; 143 | r 144 | 145 | (* Return a buffer containing the beginning of the header, excluding 146 | Content-* headers. *) 147 | let[@inline] post_header url query = 148 | let buf = Buffer.create 4096 in 149 | Buffer.add_string buf "POST /v1.29"; 150 | Buffer.add_string buf url; 151 | Buffer.add_encoded_query buf query; 152 | Buffer.add_string buf Docker_config.http11_header; 153 | buf 154 | 155 | let post fn_name addr url query json = 156 | let buf = post_header url query in 157 | Buffer.add_string buf "Content-Type: application/json\r\n\ 158 | Content-Length: "; 159 | (match json with 160 | | None -> 161 | Buffer.add_string buf "0\r\n\r\n"; 162 | | Some json -> 163 | let json = Json.to_string json in 164 | Buffer.add_string buf (string_of_int (String.length json)); 165 | Buffer.add_string buf "\r\n\r\n"; 166 | Buffer.add_string buf json); 167 | send_buffer fn_name addr buf 168 | 169 | let response_of_post fn_name addr url query json = 170 | let fd = post fn_name addr url query json in 171 | Unix.shutdown fd Unix.SHUTDOWN_SEND; 172 | let r = read_response fn_name fd in 173 | Unix.close fd; 174 | r 175 | 176 | let status_response_of_post fn_name addr url query json ~id = 177 | let status, _, _ = response_of_post fn_name addr url query json in 178 | if status >= 404 then raise(No_such_container id); 179 | status 180 | 181 | let unit_response_of_post fn_name addr url query json ~id = 182 | ignore(status_response_of_post fn_name addr url query json ~id) 183 | 184 | let delete fn_name addr url query = 185 | let fd = connect fn_name addr in 186 | let buf = Buffer.create 256 in 187 | Buffer.add_string buf "DELETE "; 188 | Buffer.add_string buf url; 189 | Buffer.add_encoded_query buf query; 190 | Buffer.add_string buf Docker_config.http11_header; 191 | Buffer.add_string buf "\r\n"; 192 | ignore(Unix.write fd (Buffer.to_bytes buf) 0 (Buffer.length buf)); 193 | fd 194 | 195 | let response_of_delete fn_name addr url query = 196 | let fd = delete fn_name addr url query in 197 | Unix.shutdown fd Unix.SHUTDOWN_SEND; 198 | let r = read_response fn_name fd in 199 | Unix.close fd; 200 | r 201 | 202 | (* Generic JSON utilities *) 203 | 204 | let string_of_json fn_name = function 205 | | `String s -> s 206 | | j -> raise(Error(fn_name, "Not a JSON string:" ^ Json.to_string j)) 207 | 208 | let json_of_strings = function 209 | | [] -> `Null 210 | | l -> `List(List.map (fun s -> `String s) l) 211 | 212 | let message_of_body body = 213 | match Json.from_string body with 214 | | `Assoc l -> 215 | (try (match List.assoc "message" l with 216 | | `String m -> m 217 | | j -> Json.to_string j) 218 | with Not_found -> body) 219 | | _ -> body 220 | 221 | (* Stream processing for [attach] and [Exec]. *) 222 | 223 | module Stream = struct 224 | (* Always assume the TTY is set to false. Thus the stream is 225 | multiplexed to separate stdout and stderr. *) 226 | 227 | type t = { 228 | fd: Unix.file_descr; (* Hijacked from the transport *) 229 | out: out_channel; 230 | (* Read buffer. The bytes buf.[i] with [i0 <= i < i1] contain 231 | the data. *) 232 | buf: Bytes.t; 233 | mutable i0: int; 234 | mutable i1: int; 235 | (* Partially decoded stream *) 236 | } 237 | 238 | type kind = Stdout | Stderr 239 | type read_kind = STDIN | STDOUT | STDERR 240 | 241 | exception Timeout 242 | 243 | (* [buf] is a buffer containing the payload already read. *) 244 | let create buffer fd = 245 | let len = Buffer.length buffer in 246 | let buf = Bytes.create (Int.max len 4096) in 247 | Buffer.blit buffer 0 buf 0 len; 248 | { fd; out = Unix.out_channel_of_descr fd; 249 | buf; i0 = 0; i1 = 0 } 250 | 251 | let out st = st.out 252 | 253 | let shutdown st = 254 | Unix.shutdown st.fd Unix.SHUTDOWN_SEND 255 | 256 | (* [timeout < 0] means unbounded wait. *) 257 | let is_ready_for_read fd ~timeout = 258 | let fds, _, _ = Unix.select [fd] [] [] timeout in 259 | fds <> [] 260 | 261 | let fill_unbounded_wait st = 262 | (* Append data to the existing one. *) 263 | let r = Unix.read st.fd st.buf st.i1 (Bytes.length st.buf - st.i1) in 264 | st.i1 <- st.i1 + r; 265 | r 266 | 267 | let fill st ~timeout = 268 | if is_ready_for_read st.fd ~timeout then fill_unbounded_wait st 269 | else raise Timeout 270 | 271 | (* After a call to this function st.i0 < st.i1 or we have reached 272 | the end of the stream. *) 273 | let fill_if_needed st ~timeout = 274 | if st.i0 >= st.i1 then ( 275 | st.i0 <- 0; 276 | st.i1 <- 0; 277 | ignore(if timeout < 0. then fill_unbounded_wait st 278 | else fill st ~timeout); 279 | ) 280 | 281 | let rec fill_8bytes_with_timeout st ~timeout = 282 | if st.i0 + 8 > st.i1 then ( 283 | (* Only if we do not have the required bytes we care about the time. *) 284 | if timeout < 0. then raise Timeout; 285 | let t0 = Unix.time () in 286 | let r = fill st ~timeout in (* or raise Timeout *) 287 | let timeout = timeout -. (Unix.time () -. t0) in 288 | if r = 0 then 289 | (* Nothing to read, bail out with the condition unsatisfied. *) 290 | if timeout >= 0. then timeout else 0. 291 | else fill_8bytes_with_timeout st ~timeout 292 | ) 293 | else 294 | (* If time is exceeded, allow only for immediate reads *) 295 | if timeout >= 0. then timeout else 0. 296 | 297 | let rec fill_8bytes_unbounded_wait st = 298 | if st.i0 + 8 > st.i1 then ( 299 | let r = fill_unbounded_wait st in 300 | if r > 0 then fill_8bytes_unbounded_wait st 301 | ) 302 | 303 | let fill_8bytes st ~timeout = 304 | if st.i0 + 8 >= Bytes.length st.buf then ( 305 | (* Move the data to the beginning to have at least 8 bytes after i0 *) 306 | let len = st.i1 - st.i0 in 307 | Bytes.blit st.buf st.i0 st.buf 0 len; 308 | st.i1 <- len; 309 | st.i0 <- 0; 310 | ); 311 | if timeout < 0. then (fill_8bytes_unbounded_wait st; timeout) 312 | else fill_8bytes_with_timeout st ~timeout 313 | 314 | let read_header st ~timeout = 315 | let timeout = fill_8bytes st ~timeout in 316 | (* Check whether we succeeded to fill. *) 317 | if st.i0 + 8 > st.i1 then 318 | (* The end of the stream is reached. If we have no bytes at all 319 | in the pipeline, consider that the stream is empty. *) 320 | if st.i0 >= st.i1 then (STDOUT, 0, timeout) 321 | else raise(Error("Docker.Stream", "truncated header")) 322 | else ( 323 | let typ = match Bytes.get st.buf st.i0 with 324 | | '\000' -> STDIN 325 | | '\001' -> STDOUT 326 | | '\002' -> STDERR 327 | | _ -> raise(Error("Docker.Stream.read", "invalid STREAM_TYPE")) in 328 | let size1 = Char.code(Bytes.get st.buf (st.i0 + 4)) in 329 | let size2 = Char.code(Bytes.get st.buf (st.i0 + 5)) in 330 | let size3 = Char.code(Bytes.get st.buf (st.i0 + 6)) in 331 | let size4 = Char.code(Bytes.get st.buf (st.i0 + 7)) in 332 | let len = size1 lsl 24 + size2 lsl 16 + size3 lsl 8 + size4 in 333 | if Sys.word_size = 32 334 | && (size1 lsr 7 = 1 || len > Sys.max_string_length) then 335 | failwith "Docker.Stream.read: payload exceeds max string length \ 336 | (32 bits)"; 337 | st.i0 <- st.i0 + 8; (* 8 bytes processed *) 338 | if len = 0 then 339 | raise(Error("Docker.Stream.read", "Payload with 0 length")); 340 | typ, len, timeout 341 | ) 342 | 343 | (* Reads [len] bytes and store them in [b] starting at position [ofs]. *) 344 | let rec really_read_unbounded_wait st b ofs len = 345 | if len > 0 then ( 346 | fill_if_needed st ~timeout:(-1.); 347 | let buf_len = st.i1 - st.i0 in 348 | if len <= buf_len then ( 349 | Bytes.blit st.buf st.i0 b ofs len; 350 | st.i0 <- st.i0 + len; 351 | ) 352 | else ( (* len > buf_len *) 353 | Bytes.blit st.buf st.i0 b ofs buf_len; 354 | st.i0 <- st.i0 + buf_len; 355 | really_read_unbounded_wait st b (ofs + buf_len) (len - buf_len) 356 | ) 357 | ) 358 | 359 | let rec really_read_with_timeout st b ofs len ~timeout = 360 | if len > 0 then ( 361 | let t0 = Unix.time() in 362 | fill_if_needed st ~timeout; 363 | let buf_len = st.i1 - st.i0 in 364 | if len <= buf_len then ( 365 | Bytes.blit st.buf st.i0 b ofs len; 366 | st.i0 <- st.i0 + len; 367 | ) 368 | else ( (* len > buf_len *) 369 | Bytes.blit st.buf st.i0 b ofs buf_len; 370 | st.i0 <- st.i0 + buf_len; 371 | let timeout = timeout -. (Unix.time () -. t0) in 372 | really_read_with_timeout st b (ofs + buf_len) (len - buf_len) ~timeout 373 | ) 374 | ) 375 | 376 | let rec read ?(timeout= -1.) st = 377 | let typ, len, timeout1 = read_header st ~timeout in 378 | let payload = Bytes.create len in 379 | if timeout1 >= 0. then 380 | really_read_with_timeout st payload 0 len ~timeout:timeout1 381 | else really_read_unbounded_wait st payload 0 len; 382 | match typ with 383 | | STDOUT -> Stdout, Bytes.unsafe_to_string payload 384 | | STDERR -> Stderr, Bytes.unsafe_to_string payload 385 | | STDIN -> read ~timeout st (* skip without decreasing the timeout *) 386 | 387 | let read_all st = 388 | let l = ref [] in 389 | let continue = ref true in 390 | while !continue do 391 | let (_, b) as r = read st in 392 | if String.length b = 0 then continue := false 393 | else l := r :: !l 394 | done; 395 | List.rev !l 396 | 397 | 398 | let close st = 399 | close_out st.out (* also closes the underlying file descriptor *) 400 | end 401 | 402 | 403 | module Container = struct 404 | type id = string 405 | type id_or_name = string 406 | 407 | type port = { priv: int; pub: int; typ: string } 408 | 409 | let port_of_json_assoc l = 410 | (* No port is a negative integer. *) 411 | let priv = ref (-1) and pub = ref (-1) and typ = ref "" in 412 | let update = function 413 | | ("PrivatePort", `Int i) -> priv := i 414 | | ("PublicPort", `Int i) -> pub := i 415 | | ("Type", `String s) -> typ := s 416 | | _ -> () in 417 | List.iter update l; 418 | if !priv < 0 || !pub < 0 || !typ = "" then 419 | raise(Error("Docker.Container.list", "Incorrect port elements")); 420 | { priv = !priv; pub = !pub; typ = !typ } 421 | 422 | let port_of_json = function 423 | | `Assoc port -> port_of_json_assoc port 424 | | _ -> raise(Error("Docker.Container.list", "Incorrect port")); 425 | 426 | type t = { 427 | id: id; 428 | names: string list; 429 | image: string; 430 | command: string; 431 | created: float; 432 | status: string; 433 | ports: port list; 434 | size_rw: int option; 435 | size_root_fs: int option; 436 | } 437 | 438 | let container_of_json (c: Json.t) = 439 | match c with 440 | | `Assoc l -> 441 | let id = ref "" and names = ref [] and image = ref "" in 442 | let command = ref "" and created = ref 0. and status = ref "" in 443 | let ports = ref [] and size_rw = ref (-1) and size_root_fs = ref(-1) in 444 | let update = function 445 | | ("Id", `String s) -> id := s 446 | | ("Names", `List l) -> 447 | names := List.map (string_of_json "Docker.Container.list") l 448 | | ("Image", `String s) -> image := s 449 | | ("Command", `String s) -> command := s 450 | | ("Created", `Int i) -> created := float i (* same as Unix.time *) 451 | | ("Status", `String s) -> status := s 452 | | ("Ports", `List p) -> ports := List.map port_of_json p 453 | | ("SizeRw", `Int i) -> size_rw := i 454 | | ("SizeRootFs", `Int i) -> size_root_fs := i 455 | | _ -> () in 456 | List.iter update l; 457 | { id = !id; names = !names; image = !image; command = !command; 458 | created = !created; status = !status; ports = !ports; 459 | size_rw = if !size_rw < 0 then None else Some !size_rw; 460 | size_root_fs = if !size_root_fs < 0 then None else Some !size_root_fs } 461 | | _ -> raise(Error("Docker.Container.list", 462 | "Invalid container: " ^ Json.to_string c)) 463 | 464 | let json_of_health = function 465 | | `Starting -> `String "starting" 466 | | `Healthy -> `String "healthy" 467 | | `Unhealthy -> `String "unhealthy" 468 | | `None -> `String "none" 469 | 470 | let json_of_status = function 471 | | `Created -> `String "created" 472 | | `Restarting -> `String "restarting" 473 | | `Running -> `String "running" 474 | | `Removing -> `String "removing" 475 | | `Paused -> `String "paused" 476 | | `Exited -> `String "exited" 477 | | `Dead -> `String "dead" 478 | 479 | let list ?(addr= !default_addr) ?(all=false) ?limit ?(size=false) 480 | ?before ?exited ?health ?name ?since ?status ?volume () = 481 | let q = if all then ["all", "1"] else [] in 482 | let q = match limit with 483 | | Some l -> ("limit", string_of_int l) :: q 484 | | None -> q in 485 | let q = if size then ("size", "1") :: q else q in 486 | let filters = [] in 487 | let filters = match before with 488 | | Some id -> ("before", `List[`String id]) :: filters 489 | | None -> filters in 490 | let filters = match exited with 491 | | Some i -> ("exited", `List(List.map (fun i -> `Int i) i)) :: filters 492 | | None -> filters in 493 | let filters = match health with 494 | | Some h -> ("health", `List(List.map json_of_health h)) :: filters 495 | | None -> filters in 496 | let filters = match name with 497 | | Some n -> ("name", `List(List.map (fun n -> `String n) n)) :: filters 498 | | None -> filters in 499 | let filters = match since with 500 | | Some id -> ("since", `List[`String id]) :: filters 501 | | None -> filters in 502 | let filters = match status with 503 | | Some s -> ("status", `List(List.map json_of_status s)) :: filters 504 | | None -> filters in 505 | let filters = match volume with 506 | | Some id -> ("volume", `List[`String id]) :: filters 507 | | None -> filters in 508 | let q = match filters with 509 | | _ :: _ -> ("filters", Json.to_string (`Assoc filters)) :: q 510 | | [] -> q in 511 | let status, _, body = response_of_get "Docker.Container.list" addr 512 | "/containers/json" q in 513 | if status >= 400 then 514 | raise(Invalid_argument("Docker.Container.list")); 515 | match Json.from_string body with 516 | | `List l -> List.map container_of_json l 517 | | _ -> 518 | raise(Error("Docker.Container.list", 519 | "response not a JSON list: " ^ body)) 520 | 521 | 522 | type bind = 523 | | Vol of string 524 | | Mount of string * string 525 | | Mount_ro of string * string 526 | 527 | let absolute_path path = 528 | if Filename.is_relative path then Filename.concat (Sys.getcwd()) path 529 | else path 530 | 531 | let json_of_bind = function 532 | (* FIXME: check the paths to not contain ":" *) 533 | | Vol v -> `String v 534 | | Mount(host_path, container_path) -> 535 | `String(absolute_path host_path ^ ":" ^ container_path) 536 | | Mount_ro(host_path, container_path) -> 537 | `String(absolute_path host_path ^ ":" ^ container_path ^ ":ro") 538 | 539 | let json_of_binds = function 540 | | [] -> (`Null: Json.t) 541 | | binds -> `List(List.map json_of_bind binds) 542 | 543 | let disallowed_chars_for_name = 544 | let a = Array.make 256 true in 545 | let safe = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\ 546 | 0123456789_-" in 547 | for i = 0 to String.length safe - 1 do 548 | a.(Char.code safe.[i]) <- false 549 | done; 550 | a 551 | 552 | let disallowed_char_for_name c = 553 | Array.unsafe_get disallowed_chars_for_name (Char.code c) 554 | 555 | (* Checks that the name is composed of allowed chars only. *) 556 | let name_is_not_allowed name = 557 | let len = String.length name in 558 | if len = 0 then true 559 | else if len = 1 then disallowed_char_for_name (String.unsafe_get name 0) 560 | else (* len >= 2 *) 561 | try 562 | let c0 = String.unsafe_get name 0 in 563 | if disallowed_char_for_name c0 && c0 <> '/' then raise Exit; 564 | for i = 0 to String.length name - 1 do 565 | if disallowed_char_for_name(String.unsafe_get name i) then raise Exit 566 | done; 567 | false 568 | with Exit -> true 569 | 570 | type host_config = { 571 | cpu_shares : int; 572 | memory : int; 573 | cgroup_parent : string; 574 | blk_io_weight : int; 575 | (* blk_io_weight_device : throttle_device; *) 576 | (* blk_io_device_read_bps : throttle_device; *) 577 | (* blk_io_device_write_bps : throttle_device; *) 578 | (* blk_io_device_read_iops : throttle_device; *) 579 | (* blk_io_device_write_iops : throttle_device; *) 580 | cpu_period : int; 581 | (* cpu_quota : int64; *) 582 | (* cpu_realtime_period : int64; *) 583 | (* cpu_realtime_runtime : int64; *) 584 | (* cpuset_cpus : string; *) 585 | (* cpuset_mems : string; *) 586 | (* devices : device_mapping; *) 587 | (* device_cgroup_rules : string; *) 588 | (* disk_quota : int64; *) 589 | (* kernel_memory : int; *) 590 | (* memory_reservation : int; *) 591 | memory_swap : int; 592 | (* memory_swappiness : int; *) 593 | (* nano_cpus : int; *) 594 | (* oom_kill_disable : bool; *) 595 | (* pids_limit : int; *) 596 | (* ulimits : ulimits; *) 597 | (* cpu_count : int *) 598 | (* cpu_percent : int; *) 599 | (* io_maximum_iops : int; *) 600 | (* io_maximum_bandwidth : int; *) 601 | binds : bind list; 602 | network_mode : string; 603 | policy : [ `None | `Auto_remove | `Restart_always 604 | | `Restart_unless_stopped | `Restart_on_failure of int]; 605 | } 606 | 607 | let host ?(cpu_shares=0) ?(memory=0) ?(cgroup_parent="") 608 | ?(blk_io_weight= -1) ?(cpu_period=0) ?(memory_swap= -1) 609 | ?(binds=[]) ?(network_mode = "bridge") ?(policy = `None) () = 610 | { cpu_shares; memory; cgroup_parent; 611 | blk_io_weight; 612 | cpu_period; 613 | memory_swap; 614 | binds; 615 | network_mode; 616 | policy; 617 | } 618 | 619 | let default_host = host() 620 | 621 | let restart_policy name count = 622 | ("RestartPolicy", `Assoc [("Name", `String name); 623 | ("MaximumRetryCount", `Int count)]) 624 | 625 | 626 | let create ?(addr= !default_addr) ?(hostname="") ?(domainname="") 627 | ?(user="") ?(stdin=false) ?(stdout=true) ?(stderr=true) 628 | ?(open_stdin=false) ?(stdin_once=false) 629 | ?(env=[]) ?(workingdir="") ?(networking=false) 630 | ?(host=default_host) 631 | ?name 632 | image cmd = 633 | (*** Host Config *) 634 | let host_config = 635 | if host.cpu_shares > 0 then [("CpuShares", `Int host.cpu_shares)] 636 | else [] in 637 | (* Ensure that "You must use this with memory and make the swap 638 | value larger than memory". *) 639 | let memory, memory_swap = 640 | if host.memory_swap <= 0 then (Int.max host.memory 0, -1) 641 | else if host.memory <= 0 (* = not set *) then 642 | (host.memory_swap, host.memory_swap) 643 | else (host.memory, Int.max host.memory host.memory_swap) in 644 | let host_config = ("Memory", `Int memory) 645 | :: ("MemorySwap", `Int memory_swap) 646 | :: ("CgroupParent", `String host.cgroup_parent) 647 | :: host_config in 648 | let host_config = 649 | if 0 <= host.blk_io_weight && host.blk_io_weight <= 1000 then 650 | ("BlkioWeight", `Int host.blk_io_weight) :: host_config 651 | else host_config in 652 | (* BlkioWeightDevice *) 653 | (* BlkioDeviceReadBps *) 654 | (* BlkioDeviceWriteBps *) 655 | (* BlkioDeviceReadIOps *) 656 | (* BlkioDeviceWriteIOps *) 657 | let host_config = if host.cpu_period > 0 then 658 | ("CpuPeriod", `Int host.cpu_period) :: host_config 659 | else host_config in 660 | (* CpuQuota *) 661 | (* CpuRealtimePeriod *) 662 | (* CpuRealtimeRuntime *) 663 | (* CpusetCpus *) 664 | (* CpusetMems *) 665 | (* ("Devices", `List []) *) 666 | (* DeviceCgroupRules *) 667 | (* DiskQuota *) 668 | (* KernelMemory *) 669 | (* MemoryReservation *) 670 | (* MemorySwappiness *) 671 | (* NanoCPUs *) 672 | (* OomKillDisable *) 673 | (* PidsLimit *) 674 | (* Ulimits *) 675 | (* CpuCount *) 676 | (* CpuPercent *) 677 | (* IOMaximumIOps — Windows *) 678 | (* IOMaximumBandwidth *) 679 | let host_config = ("Binds", json_of_binds host.binds) :: host_config in 680 | (* ContainerIDFile *) 681 | (* LogConfig *) 682 | let host_config = if host.network_mode <> "" then 683 | ("NetworkMode", `String "bridge") :: host_config 684 | else host_config in 685 | (* PortBindings *) 686 | let host_config = match host.policy with 687 | | `Auto_remove -> ("AutoRemove", `Bool true) :: host_config 688 | | `Restart_always -> restart_policy "always" 0 :: host_config 689 | | `Restart_unless_stopped -> restart_policy "unless-stopped" 0 690 | :: host_config 691 | | `Restart_on_failure n -> 692 | if n > 0 then restart_policy "on-failure" n :: host_config 693 | else host_config 694 | | `None -> host_config in 695 | (* VolumeDriver *) 696 | (* VolumesFrom *) 697 | (* Mounts *) 698 | (* CapAdd *) 699 | (* CapDrop *) 700 | (* Dns *) 701 | (* DnsOptions *) 702 | (* DnsSearch *) 703 | (* ExtraHosts *) 704 | (* GroupAdd *) 705 | (* IpcMode *) 706 | (* Cgroup *) 707 | (* Links *) 708 | (* OomScoreAdj *) 709 | (* PidMode *) 710 | (* Privileged *) 711 | (* PublishAllPorts *) 712 | (* ReadonlyRootfs *) 713 | (* SecurityOpt *) 714 | (* StorageOpt *) 715 | (* Tmpfs *) 716 | (* UTSMode *) 717 | (* UsernsMode *) 718 | (* ShmSize *) 719 | (* Sysctls *) 720 | (* Runtime *) 721 | (* ConsoleSize — Windows *) 722 | (* Isolation — Windows *) 723 | (*** Main payload *) 724 | let json : Json.t = 725 | `Assoc [ 726 | ("Hostname", `String hostname); 727 | ("Domainname", `String domainname); 728 | ("User", `String user); 729 | ("AttachStdin", `Bool stdin); 730 | ("AttachStdout", `Bool stdout); 731 | ("AttachStderr", `Bool stderr); 732 | ("ExposedPorts", `Null); (* TODO *) 733 | ("Tty", `Bool false); (* WARNING: see also [attach]. *) 734 | ("OpenStdin", `Bool open_stdin); 735 | ("StdinOnce", `Bool stdin_once); 736 | ("Env", json_of_strings env); 737 | ("Cmd", json_of_strings cmd); 738 | (* Healthcheck *) 739 | (* ArgsEscaped: only for Windows; do not set *) 740 | ("Image", `String image); 741 | ("Volumes", `Null); (* TODO *) 742 | ("WorkingDir", `String workingdir); 743 | ("Entrypoint", `Null); (* TODO *) 744 | ("NetworkDisabled", `Bool(not networking)); 745 | (* MacAddress *) 746 | (* OnBuild *) 747 | (* Labels *) 748 | (* StopSignal *) 749 | (* StopTimeout *) 750 | (* Shell *) 751 | ("HostConfig", `Assoc host_config); 752 | (* NetworkingConfig *) 753 | ] in 754 | let query_params = match name with 755 | | Some name -> 756 | if name_is_not_allowed name then 757 | invalid_arg(Printf.sprintf "Docker.Container.create: container \ 758 | name %S is not allowed" name); 759 | [("name", name)] 760 | | None -> [] in 761 | let status, _, body = 762 | response_of_post "Docker.Container.create" addr 763 | "/containers/create" query_params (Some json) in 764 | if status >= 409 then 765 | raise(Failure("Docker.Container.create", body)) 766 | else if status >= 406 then 767 | raise(Failure("Docker.Container.create", 768 | "Impossible to attach (container not running)")) 769 | else if status >= 400 then ( 770 | (* Try to extract the container ID. *) 771 | match message_of_body body with 772 | | m -> (try let i = String.index m ':' in 773 | let id = String.sub m (i + 2) (String.length m - i - 2) in 774 | raise(No_such_container id) 775 | with _ -> 776 | raise(Failure("Docker.Container.create", m))) 777 | | exception Yojson.Json_error _ -> 778 | raise(Server_error (Printf.sprintf "body %S contains no message" body)) 779 | ); 780 | (* Extract ID *) 781 | match Json.from_string body with 782 | | `Assoc l -> 783 | (try string_of_json "Docker.Containers.create" (List.assoc "Id" l) 784 | with Not_found -> 785 | raise(Error("Docker.Containers.create", "No ID returned"))) 786 | | _ -> 787 | raise(Error("Docker.Container.create", 788 | "Response must be an association list: " ^ body )) 789 | 790 | let change_of_json = function 791 | | `Assoc c -> 792 | (try let path = List.assoc "Path" c in 793 | let kind = match List.assoc "Kind" c with 794 | | `Int 0 -> `Modified 795 | | `Int 1 -> `Added 796 | | `Int 2 -> `Deleted 797 | | j -> raise(Error("Docker.Container.changes", 798 | "Invalid kind:" ^ Json.to_string j)) in 799 | (string_of_json "Docker.Container.changes" path, kind) 800 | with Not_found -> raise(Error("Docker.Container.changes", 801 | "Invalid change object"))) 802 | | j -> raise(Error("Docker.Container.changes", 803 | "object expected, got: " ^ Json.to_string j)) 804 | 805 | let changes ?(addr= !default_addr) id = 806 | let path = "/containers/" ^ id ^ "/changes" in 807 | let _, _, body = response_of_get "Docker.Container.changes" addr path [] in 808 | match Json.from_string body with 809 | | `List l -> List.map change_of_json l 810 | | _ -> raise(Error("Docker.Container.changes", "Invalid response: " ^ body)) 811 | 812 | 813 | let start ?(addr= !default_addr) ?(detach_keys="") id = 814 | (* FIXME: may want to check that [id] does not contain special chars *) 815 | let q = if detach_keys <> "" then ["detachKeys", detach_keys] else [] in 816 | let path = "/containers/" ^ id ^ "/start" in 817 | let status, _, body = response_of_post "Docker.Container.start" addr path q 818 | None in 819 | if status >= 404 then raise(No_such_container id); 820 | if status >= 400 then 821 | (* This is an undocumented status that is raised when the 822 | command asked to run in [create] does not exist. *) 823 | raise(Failure("Docker.Container.start", message_of_body body)); 824 | if status >= 304 then 825 | raise(Failure("Docker.Container.start", "Container already started")) 826 | 827 | 828 | let stop ?(addr= !default_addr) ?wait id = 829 | let q = match wait with None -> [] 830 | | Some t -> ["t", string_of_int t] in 831 | let path = "/containers/" ^ id ^ "/stop" in 832 | let status = 833 | status_response_of_post "Docker.Container.stop" addr path q None ~id in 834 | if status >= 304 then 835 | raise(Failure("Docker.Container.stop", "Container already stopped")) 836 | 837 | let wait ?(addr= !default_addr) id = 838 | let path = "/containers/" ^ id ^ "/wait" in 839 | let _, _, body = response_of_post "Docker.Container.wait" 840 | addr path [] None in 841 | match Json.from_string body with 842 | | `Assoc l -> 843 | (try (match List.assoc "StatusCode" l with 844 | | `Int s -> s 845 | | _ -> raise(Error("Docker.Container.wait", "Invalid StatusCode"))) 846 | with Not_found -> 847 | raise(Error("Docker.Container.wait", "Invalid response: " ^ body))) 848 | | _ -> raise(Error("Docker.Container.wait", "Invalid response: " ^ body)) 849 | 850 | let restart ?(addr= !default_addr) ?wait id = 851 | let q = match wait with None -> [] 852 | | Some t -> ["t", string_of_int t] in 853 | let path = "/containers/" ^ id ^ "/restart" in 854 | unit_response_of_post "Docker.Container.restart" addr path q None ~id 855 | 856 | let rm ?(addr= !default_addr) ?(volumes=false) ?(force=false) ?(link=false) 857 | id = 858 | let q = ["v", string_of_bool volumes; 859 | "force", string_of_bool force; 860 | "link", string_of_bool link] in 861 | let path = "/containers/" ^ id in 862 | let status, _, body = 863 | response_of_delete "Docker.Container.rm" addr path q in 864 | if status >= 409 then 865 | raise(Failure("Docker.Container.rm", message_of_body body)) 866 | else if status >= 404 then raise(No_such_container id) 867 | else if status >= 400 then 868 | (* Errors like "removal of container ... is already in progress" 869 | are reported with 400 — not a bad parameter problem! *) 870 | raise(Failure("Docker.Container.rm", message_of_body body)) 871 | 872 | let kill ?(addr= !default_addr) ?signal id = 873 | let q = match signal with Some s -> ["signal", string_of_int s] 874 | | None -> [] in 875 | let path = "/containers/" ^ id ^ "/kill" in 876 | unit_response_of_post "Docker.Container.kill" addr path q None ~id 877 | 878 | let pause ?(addr= !default_addr) id = 879 | let path = "/containers/" ^ id ^ "/pause" in 880 | unit_response_of_post "Docker.Container.pause" addr path [] None ~id 881 | 882 | let unpause ?(addr= !default_addr) id = 883 | let path = "/containers/" ^ id ^ "/unpause" in 884 | unit_response_of_post "Docker.Container.unpause" addr path [] None ~id 885 | 886 | 887 | let attach ?(addr= !default_addr) 888 | ?(stdin=false) ?(stdout=false) ?(stderr=false) id which = 889 | let logs, stream = match which with 890 | | `Logs -> "true", "false" 891 | | `Stream -> "false", "true" 892 | | `Logs_and_stream -> "true", "true" in 893 | let q = ["logs", logs; 894 | "stream", stream; 895 | "stdin", string_of_bool stdin; 896 | "stdout", string_of_bool stdout; 897 | "stderr", string_of_bool stderr ] in 898 | let path = "/containers/" ^ id ^ "/attach" in 899 | let fd = post "Docker.Containers.attach" addr path q None in 900 | let buf = Buffer.create 4096 in 901 | let status, _h = read_headers "Docker.Containers.attach" buf fd in 902 | deal_with_status_500 "Docker.Containers.attach" status fd; 903 | if status >= 400 then ( 904 | Unix.close fd; 905 | if status >= 404 then raise(No_such_container id) 906 | else raise(Invalid_argument "Docker.Containers.attach") 907 | ); 908 | (* FIXME: need to know whether the TTY setting is enabled by 909 | [create] — [false] at the moment. *) 910 | Stream.create buf fd 911 | 912 | module Exec = struct 913 | type t = string (* exec ID *) 914 | 915 | let create ?(addr= !default_addr) ?(stdin=false) ?(stdout=true) 916 | ?(stderr=true) ?detach_keys ?(env=[]) ?(privileged=false) ?user 917 | container cmd = 918 | let json = 919 | ["AttachStdin", `Bool stdin; 920 | "AttachStdout", `Bool stdout; 921 | "AttachStderr", `Bool stderr; 922 | "Tty", `Bool false; 923 | "Env", json_of_strings env; 924 | "Cmd", json_of_strings cmd; 925 | "Privileged", `Bool privileged ] in 926 | let json = match detach_keys with 927 | | Some d -> ("DetachKeys", `String d) :: json 928 | | None -> json in 929 | let json = match user with 930 | | Some u -> ("User", `String u) :: json 931 | | None -> json in 932 | let path = "/containers/" ^ container ^ "/exec" in 933 | let status, _, body = response_of_post "Docker.Container.Exec.create" 934 | addr path [] (Some (`Assoc json)) in 935 | if status >= 400 then ( 936 | (* Try to extract the container ID. *) 937 | try 938 | let m = message_of_body body in 939 | let i = String.index m ':' in 940 | let id = String.sub m (i + 2) (String.length m - i - 2) in 941 | raise(No_such_container id) 942 | with _ -> raise(No_such_container "unknown ID") 943 | ); 944 | (* Extract ID *) 945 | match Json.from_string body with 946 | | `Assoc l -> 947 | (try string_of_json "Docker.Containers.Exec.create" (List.assoc "Id" l) 948 | with _ -> raise(Error("Docker.Containers.Exec.create", 949 | "No ID returned"))) 950 | | _ -> 951 | raise(Error("Docker.Container.Exec.create", 952 | "Response must be an association list: " ^ body )) 953 | 954 | 955 | let start ?(addr= !default_addr) exec_id = 956 | let json = `Assoc ["Detach", `Bool false; 957 | "Tty", `Bool false ] in 958 | let path = "/exec/" ^ exec_id ^ "/start" in 959 | let fd = post "Docker.Containers.Exec.start" addr path [] (Some json) in 960 | let buf = Buffer.create 4096 in 961 | let status, _h = read_headers "Docker.Containers.Exec.start" buf fd in 962 | deal_with_status_500 "Docker.Containers.Exec.start" status fd; 963 | if status >= 409 then ( 964 | Unix.close fd; 965 | raise(Failure("Docker.Container.Exec.start", 966 | "Container is stopped or paused")); 967 | ) 968 | else if status >= 400 then ( 969 | Unix.close fd; 970 | raise(Failure("Docker.Container.Exec.start", "No such exec instance")); 971 | ); 972 | Stream.create buf fd 973 | 974 | 975 | (* TODO: Exec Resize *) 976 | ;; 977 | end 978 | end 979 | 980 | module Image = struct 981 | type id = string 982 | type t = { 983 | id: id; 984 | created: float; 985 | size: int; 986 | virtual_size: int; 987 | tags: string list; 988 | } 989 | 990 | let image_of_json (img: Json.t) = 991 | match img with 992 | | `Assoc l -> 993 | let id = ref "" and created = ref nan and size = ref 0 in 994 | let virtual_size = ref 0 and tags = ref [] in 995 | let update = function 996 | | ("RepoTags", `List l) -> 997 | tags := List.map (string_of_json "Docker.Images.list") l 998 | | ("Id", `String s) -> id := s 999 | | ("Created", `Int i) -> created := float i 1000 | | ("Size", `Int i) -> size := i 1001 | | ("VirtualSize", `Int i) -> virtual_size := i 1002 | | _ -> () in 1003 | List.iter update l; 1004 | { id = !id; created = !created; size = !size; 1005 | virtual_size = !virtual_size; tags = !tags } 1006 | | _ -> raise(Error("Docker.Images.list", 1007 | "Invalid image: " ^ Json.to_string img)) 1008 | 1009 | let list ?(addr= !default_addr) ?(all=false) () = 1010 | let q = ["all", string_of_bool all] in 1011 | let _, _, body = response_of_get "Docker.Images.list" addr 1012 | "/images/json" q in 1013 | match Json.from_string body with 1014 | | `List l -> List.map image_of_json l 1015 | | _ -> 1016 | raise(Error("Docker.Images.list", 1017 | "Response must be a JSON list: " ^ body)) 1018 | 1019 | type source = 1020 | | Image of { name: string; repo: string; tag: string } 1021 | | Src of string 1022 | | Stdin of { len: int; write : Unix.file_descr -> int -> unit } 1023 | 1024 | let create ?(addr= !default_addr) ?(platform="") from = 1025 | let q = ["platform", platform] in 1026 | let status = match from with 1027 | | Image im -> 1028 | let q = ("fromImage", im.name) :: ("repo", im.repo) 1029 | :: ("tag", im.tag) :: q in 1030 | let status, _, _ = response_of_post "Docker.Image.create" 1031 | addr "/images/create" q None in 1032 | status 1033 | | Src url -> 1034 | if url = "-" then 1035 | raise(Invalid_argument("Docker.Image.create: Invalid URL '-'")); 1036 | let q = ("fromSrc", url) :: q in 1037 | let status, _, _ = response_of_post "Docker.Image.create" 1038 | addr "/images/create" q None in 1039 | status 1040 | | Stdin img -> 1041 | (* We do not use the [response_of_post] function because we 1042 | use a specialized version to insert the body. *) 1043 | let buf = post_header "/images/create" q in 1044 | Buffer.add_string buf "Content-Type: application/octet-stream\r\n\ 1045 | Content-Length: "; 1046 | Buffer.add_string buf (string_of_int img.len); 1047 | Buffer.add_string buf "\r\n\r\n"; 1048 | let fd = send_buffer "Docker.Image.create" addr buf in 1049 | img.write fd img.len; 1050 | Unix.shutdown fd Unix.SHUTDOWN_SEND; 1051 | let status, _, _ = read_response "Docker.Image.create" fd in 1052 | Unix.close fd; 1053 | status in 1054 | if status >= 404 then 1055 | raise(Failure("Docker.Image.create", "repository does not exist \ 1056 | or no read access")) 1057 | 1058 | let from_image ?(repo = "") ?(tag = "") name = 1059 | Image { name; repo; tag } 1060 | end 1061 | 1062 | type version = { api_version: string; 1063 | version: string; 1064 | git_commit: string; 1065 | go_version: string } 1066 | 1067 | let version ?(addr= !default_addr) () = 1068 | let _, _, body = response_of_get "Docker.version" addr "/version" [] in 1069 | match Json.from_string body with 1070 | | `Assoc l -> 1071 | let api_version = ref "" and version = ref "" in 1072 | let git_commit = ref "" and go_version = ref "" in 1073 | let update = function 1074 | | ("ApiVersion", `String s) -> api_version := s 1075 | | ("Version", `String s) -> version := s 1076 | | ("GitCommit", `String s) -> git_commit := s 1077 | | ("GoVersion", `String s) -> go_version := s 1078 | | _ -> () in 1079 | List.iter update l; 1080 | { api_version = !api_version; version = !version; 1081 | git_commit = !git_commit; go_version = !go_version } 1082 | | _ -> raise(Error("Docker.version", 1083 | "Response must be a JSON association list: " ^ body)) 1084 | 1085 | 1086 | 1087 | ;; 1088 | (* Local Variables: *) 1089 | (* compile-command: "make -k -w -C.." *) 1090 | (* End: *) 1091 | -------------------------------------------------------------------------------- /src/docker.mli: -------------------------------------------------------------------------------- 1 | 2 | (** Interface to Docker Remote API. 3 | 4 | See the {{:https://docs.docker.com/engine/api/v1.29/}Docker API} if 5 | needed to complement the documentation below. 6 | 7 | @version %%VERSION%% *) 8 | 9 | 10 | val set_default_addr : Unix.sockaddr -> unit 11 | (** Set the address the Docker daemon listens to. This will be used 12 | by all funtions of this API unless the optional parameter [~addr] 13 | is used. *) 14 | 15 | exception No_such_container of string [@warn_on_literal_pattern] 16 | (** [No_such_container id] is raised to notify that the container [id] 17 | does not exist. *) 18 | 19 | exception Failure of string * string [@warn_on_literal_pattern] 20 | (** [Failure(fn_name, msg)] is raised when the requested action fails 21 | to be performed (because, say, the container stopped,...). 22 | [fn_name] is the name of the function raising the error and [msg] 23 | an explanation. *) 24 | 25 | exception Invalid_argument of string [@warn_on_literal_pattern] 26 | (** [Invalid_argument msg] can be raised by any function 27 | when an incorrect argument. [msg] is the function raising 28 | the exception. *) 29 | 30 | exception Server_error of string [@warn_on_literal_pattern] 31 | (** [Server_error fn_name] indicates that the server encountered 32 | an error or that the returned response is incorrect. [fn_name] is 33 | the function raising the error. *) 34 | 35 | exception Error of string * string [@warn_on_literal_pattern] 36 | (** [Error(fn_name, msg)] is raised for connection of protocol errors. 37 | [fn_name] is the function raising the error and [msg] is a 38 | possible explanation for the error. Typically, this exception 39 | should not be raised with a well behaving server. *) 40 | 41 | (** A stream returned by some Docker functions. *) 42 | module Stream : sig 43 | type t 44 | 45 | type kind = Stdout | Stderr 46 | 47 | exception Timeout 48 | 49 | val out : t -> out_channel 50 | (** [out stream] may be used to send data to the process running in 51 | the container. Closing this channel is equivalent to calling 52 | {!close}. *) 53 | 54 | val shutdown : t -> unit 55 | (** [shutdown stream] transmit an end-of-file condition to the 56 | server reading on the other side of the connection meaning that 57 | you have finished sending data. You can still read data from 58 | the string. You must still close the string with {!close}. *) 59 | 60 | val read : ?timeout: float -> t -> kind * string 61 | (** [read stream] reads the next payload from the stream. The byte 62 | sequence will be empty if there is nothing to read at the time of 63 | the call (in particular, if everything has been read). 64 | 65 | @raise Timeout if the payload could not be read within the allowed 66 | timeout. A negative timeout (the default) means unbounded wait. *) 67 | 68 | val read_all : t -> (kind * string) list 69 | (** Read all the available data on the stream. *) 70 | 71 | val close : t -> unit 72 | (** Close the stream. *) 73 | end 74 | 75 | module Container : sig 76 | type port = { 77 | priv: int; (** Private port number. *) 78 | pub: int; (** Public port number. *) 79 | typ: string; (** Type, e.g., "tcp". *) 80 | } 81 | 82 | type id = string 83 | 84 | type id_or_name = string 85 | 86 | type t = { 87 | id: id; (** Identifier of the container. *) 88 | names: string list; (** Names given to the container. *) 89 | image: string; (** Name of the image used to create the container. *) 90 | command: string; (** Command passed to the container. *) 91 | created: float; (** Unix time of creation. *) 92 | status: string; (** Human readable status. *) 93 | ports: port list; 94 | size_rw: int option; 95 | size_root_fs: int option; 96 | } 97 | 98 | type bind = 99 | | Vol of string (** create a new volume for the container *) 100 | | Mount of string * string 101 | (** [Mount(host_path, container_path)] bind-mount a host path 102 | into the container. A relative [host_path] will be interpreted 103 | as relative to the current working directory (at the time of 104 | the function calling this binding). [container_path] must be an 105 | {i absolute} path inside the container. *) 106 | | Mount_ro of string * string 107 | (** As [Mount] but make the bind-mount read-only inside the container. *) 108 | 109 | val list : ?addr: Unix.sockaddr -> 110 | ?all: bool -> ?limit: int -> ?size: bool -> 111 | ?before: id_or_name -> 112 | ?exited: int list -> 113 | ?health: [`Starting | `Healthy | `Unhealthy | `None] list -> 114 | ?name: string list -> 115 | ?since: id_or_name -> 116 | ?status: [`Created | `Restarting | `Running | `Removing | 117 | `Paused | `Exited | `Dead] list -> 118 | ?volume: string -> 119 | unit -> t list 120 | (** [list ()] lists running containers (or all containers if [~all] 121 | is set to [true]). 122 | 123 | @param all Show all containers. Only running containers are 124 | shown by default (i.e., this defaults to [false]). 125 | @param limit Return this number of most recently created 126 | containers, including non-running ones. 127 | @param size Return the size of container as fields [size_rw] 128 | and [size_root_fs]. 129 | 130 | The following options set filters on the returned container 131 | list: [before], [exited] (containers with exit code given by 132 | [exited]), [health], [name], [since], [status], [volume]. 133 | *) 134 | 135 | type host_config = { 136 | cpu_shares : int; 137 | (** Represents this container's relative CPU weight versus other 138 | containers. Non-positive values are ignored. *) 139 | memory : int; 140 | (** Memory limit in bytes. *) 141 | cgroup_parent : string; 142 | (** Path to cgroups under which the container's cgroup is 143 | created. If the path is not absolute, the path is considered 144 | to be relative to the cgroups path of the init 145 | process. Cgroups are created if they do not already exist. *) 146 | blk_io_weight : int; 147 | (** Block IO weight (relative weight). Values outside 148 | [0 .. 1000] do not set this field. *) 149 | (* blk_io_weight_device : throttle_device; *) 150 | (* Block IO weight (relative device weight) in the form 151 | [{"Path": "device_path", "Weight": weight}]. *) 152 | (* blk_io_device_read_bps : throttle_device; *) 153 | (* Limit read rate (bytes per second) from a device, in the form 154 | [{"Path": "device_path", "Rate": rate}]. *) 155 | (* blk_io_device_write_bps : throttle_device; *) 156 | (* Limit write rate (bytes per second) to a device, in the form 157 | [{"Path": "device_path", "Rate": rate}]. *) 158 | (* blk_io_device_read_iops : throttle_device; *) 159 | (* Limit read rate (IO per second) from a device, in the form 160 | [{"Path": "device_path", "Rate": rate}]. *) 161 | (* blk_io_device_write_iops : throttle_device; *) 162 | (* Limit write rate (IO per second) to a device, in the form 163 | [{"Path": "device_path", "Rate": rate}]. *) 164 | cpu_period : int; 165 | (** The length of a CPU period in microseconds. Non-positive 166 | values do not set this field. *) 167 | (* cpu_quota : int64; *) 168 | (* Microseconds of CPU time that the container can get in a CPU period. *) 169 | (* cpu_realtime_period : int64; *) 170 | (* The length of a CPU real-time period in microseconds. Set to 171 | 0 to allocate no time allocated to real-time tasks. *) 172 | (* cpu_realtime_runtime : int64; *) 173 | (* The length of a CPU real-time runtime in microseconds. Set to 174 | 0 to allocate no time allocated to real-time tasks. *) 175 | (* cpuset_cpus : string; *) 176 | (* CPUs in which to allow execution (e.g., 0-3, 0,1) *) 177 | (* cpuset_mems : string; *) 178 | (* Memory nodes (MEMs) in which to allow execution (0-3, 179 | 0,1). Only effective on NUMA systems. *) 180 | (* devices : device_mapping; *) 181 | (* A list of devices to add to the container. *) 182 | (* device_cgroup_rules : string; *) 183 | (* A list of cgroup rules to apply to the container *) 184 | (* disk_quota : int64; *) 185 | (* Disk limit (in bytes). *) 186 | (* kernel_memory : int; *) 187 | (* Kernel memory limit in bytes. *) 188 | (* memory_reservation : int; *) 189 | (* Memory soft limit in bytes. *) 190 | memory_swap : int; 191 | (** Total memory limit (memory + swap). Set as -1 to enable 192 | unlimited swap. *) 193 | (* memory_swappiness : int; *) 194 | (* Tune a container's memory swappiness behavior. Accepts an 195 | integer between 0 and 100. *) 196 | (* nano_cpus : int; *) 197 | (* CPU quota in units of 10-9 CPUs. *) 198 | (* oom_kill_disable : bool; *) 199 | (* Disable OOM Killer for the container. *) 200 | (* pids_limit : int; *) 201 | (* Tune a container's pids limit. Set -1 for unlimited. *) 202 | (* ulimits : ulimits; *) 203 | (* A list of resource limits to set in the container. For 204 | example: {"Name": "nofile", "Soft": 1024, "Hard": 2048} *) 205 | (* cpu_count : int *) 206 | (* The number of usable CPUs (Windows only). 207 | 208 | On Windows Server containers, the processor resource controls 209 | are mutually exclusive. The order of precedence is CPUCount 210 | first, then CPUShares, and CPUPercent last. *) 211 | (* cpu_percent : int; *) 212 | (* The usable percentage of the available CPUs (Windows only). 213 | 214 | On Windows Server containers, the processor resource controls 215 | are mutually exclusive. The order of precedence is CPUCount 216 | first, then CPUShares, and CPUPercent last. *) 217 | (* io_maximum_iops : int; *) 218 | (* Maximum IOps for the container system drive (Windows only) *) 219 | (* io_maximum_bandwidth : int; *) 220 | (* Maximum IO in bytes per second for the container system drive 221 | (Windows only). *) 222 | binds : bind list; 223 | (** A list of volume bindings for this container. *) 224 | (* container_id_file : string; *) 225 | (* Path to a file where the container ID is written *) 226 | (* log_config : log_config; *) 227 | (* The logging configuration for this container *) 228 | network_mode : string; 229 | (** Network mode to use for this container. Supported standard 230 | values are: bridge, host, none, and container:. Any 231 | other value is taken as a custom network's name to which this 232 | container should connect to. *) 233 | (* port_bindings : port_bindings; *) 234 | (* A map of exposed container ports and the host port they 235 | should map to. *) 236 | policy : [ `None | `Auto_remove | `Restart_always 237 | | `Restart_unless_stopped | `Restart_on_failure of int]; 238 | (** The behavior to apply when the container exits. The default 239 | is not to restart and not to remove the container ([`None]). 240 | An ever increasing delay (double the previous delay, starting 241 | at 100ms) is added before each restart to prevent flooding 242 | the server. 243 | 244 | - [`Auto_remove] Automatically remove the container when the 245 | container's process exits. 246 | - [`Restart_always] Always restart. 247 | - [`Restart_unless_stopped] Restart always except when the 248 | user has manually stopped the container. 249 | - [`Restart_on_failure n] Restart only when the container 250 | exit code is non-zero. The number [n] says how many times 251 | to retry before giving up. *) 252 | (* volume_driver : string; *) 253 | (* Driver that this container uses to mount volumes. *) 254 | (* volumes_from : string; *) 255 | (* A list of volumes to inherit from another container, 256 | specified in the form [:]. *) 257 | (* mounts : mount; *) 258 | (* Specification for mounts to be added to the container. *) 259 | (* cap_add : string; *) 260 | (* A list of kernel capabilities to add to the container. *) 261 | (* cap_drop : string; *) 262 | (* A list of kernel capabilities to drop from the container. *) 263 | (* dns : string; *) 264 | (* A list of DNS servers for the container to use. *) 265 | (* dns_options : string; *) 266 | (* A list of DNS options. *) 267 | (* dns_search : string; *) 268 | (* A list of DNS search domains. *) 269 | (* extra_hosts : string; *) 270 | (* A list of hostnames/IP mappings to add to the container's 271 | /etc/hosts file. Specified in the form ["hostname:IP"]. *) 272 | (* group_add : string; *) 273 | (* A list of additional groups that the container process will run as. *) 274 | (* ipc_mode : string; *) 275 | (* IPC namespace to use for the container. *) 276 | (* cgroup : string; *) 277 | (* Cgroup to use for the container. *) 278 | (* links : string; *) 279 | (* A list of links for the container in the form container_name:alias. *) 280 | (* oom_score_adj : int; *) 281 | (* An integer value containing the score given to the container 282 | in order to tune OOM killer preferences. *) 283 | (* pid_mode : string; *) 284 | (* Set the PID (Process) Namespace mode for the container. It 285 | can be either: 286 | 287 | "container:": joins another container's PID namespace 288 | "host": use the host's PID namespace inside the container *) 289 | (* privileged : bool; *) 290 | (* Gives the container full access to the host. *) 291 | (* publish_all_ports : bool; *) 292 | (* Allocates a random host port for all of a container's exposed ports. *) 293 | (* readonly_rootfs : bool; *) 294 | (* Mount the container's root filesystem as read only. *) 295 | (* security_opt : string; *) 296 | (* A list of string values to customize labels for MLS systems, 297 | such as SELinux. *) 298 | (* storage_opt : storage_opt; *) 299 | (* Storage driver options for this container, in the form 300 | {"size": "120G"}. *) 301 | (* tmpfs : tmpfs; *) 302 | (* A map of container directories which should be replaced by 303 | tmpfs mounts, and their corresponding mount options. For 304 | example: { "/run": "rw,noexec,nosuid,size=65536k" }. *) 305 | (* uts_mode : string; *) 306 | (* UTS namespace to use for the container. *) 307 | (* userns_mode : string; *) 308 | (* Sets the usernamespace mode for the container when 309 | usernamespace remapping option is enabled. *) 310 | (* shm_size : int; *) 311 | (* integer >= 0 312 | Size of /dev/shm in bytes. If omitted, the system uses 64MB. *) 313 | (* sysctls : sysctls; *) 314 | (* A list of kernel parameters (sysctls) to set in the 315 | container. For example: {"net.ipv4.ip_forward": "1"} *) 316 | (* runtime : string; *) 317 | (* Runtime to use with this container. *) 318 | (* console_size : int; *) 319 | (* integer >= 0 320 | Initial console size, as an [height, width] array. (Windows only) *) 321 | (* isolation : string; *) 322 | (* "default" "process" "hyperv" 323 | Isolation technology of the container. (Windows only) *) 324 | } 325 | 326 | val host : 327 | ?cpu_shares: int -> 328 | ?memory: int -> 329 | ?cgroup_parent: string -> 330 | ?blk_io_weight: int -> 331 | ?cpu_period: int -> 332 | ?memory_swap: int -> 333 | ?binds: bind list -> 334 | ?network_mode: string -> 335 | ?policy: [ `Auto_remove | `None | `Restart_always 336 | | `Restart_on_failure of int | `Restart_unless_stopped ] -> 337 | unit -> host_config 338 | (** Return the default host configuration changed according to which 339 | optional labels were set. *) 340 | 341 | val create : 342 | ?addr: Unix.sockaddr -> 343 | ?hostname: string -> ?domainname: string -> ?user: string -> 344 | ?stdin: bool -> ?stdout: bool -> ?stderr: bool -> 345 | ?open_stdin: bool -> ?stdin_once: bool -> 346 | ?env: string list -> ?workingdir: string -> ?networking: bool -> 347 | ?host: host_config -> 348 | ?name: string -> 349 | string -> string list -> id 350 | (** [create image cmd] create a container and returns its ID where 351 | [image] is the image name to use for the container and [cmd] the 352 | command to run. [cmd] has the form [[prog; arg1;...; argN]]. 353 | BEWARE that the output of [cmd] (on stdout and stderr) will be 354 | logged by the container (see {!logs}) so it will consume disk space. 355 | 356 | @param hostname the desired hostname to use for the container. 357 | @param domainname the desired domain name to use for the container. 358 | @param user the user (or UID) to use inside the container. 359 | @param stdin Attaches to stdin (default [false]). 360 | @param stdout Attaches to stdout (default [true]). 361 | @param stdout Attaches to stderr (default [true]). 362 | @param open_stdin opens stdin (sic). 363 | @param stdin_once Close stdin after the 1 attached client disconnects. 364 | Default: [false]. 365 | @param env A list of environment variables of the form ["VAR=value"]. 366 | A variable without = is removed from the environment, rather 367 | than to have an empty value. 368 | @param workingdir The working dir for commands to run in. 369 | @param networking Whether networking is enabled for the container. 370 | Default: [false]. 371 | @param name The name of the container. The name must match 372 | [/?[a-zA-Z0-9_-]+] or [Invalid_argument] is raised. It can be 373 | used in place of the container ID. If the name exists (whether 374 | the container is running or not), the container will not be 375 | recreated. Note that the corresponding name in {!t} (as 376 | obtained by {!list}) will have an initial '/' which means that 377 | the Docker daemon is the parent container. *) 378 | 379 | (* val inspect : ?addr: Unix.sockaddr -> id -> t *) 380 | 381 | (* val top : conn -> id -> *) 382 | 383 | (* val logs : conn -> id -> *) 384 | 385 | val changes : ?addr: Unix.sockaddr -> 386 | id -> (string * [`Modified | `Added | `Deleted]) list 387 | (** [changes conn id] returns which files in a container's 388 | filesystem have been added, deleted, or modified. *) 389 | 390 | (* val export : ?addr: Unix.sockaddr -> id -> stream *) 391 | (** [export conn id] export the contents of container [id]. *) 392 | 393 | val start : ?addr: Unix.sockaddr -> ?detach_keys: string -> 394 | id -> unit 395 | (** [start id] starts the container [id]. 396 | 397 | @raise Server_error when, for example, if the command given by 398 | {!create} does not exist in the container. 399 | 400 | @param detach_keys override the key sequence for detaching a 401 | container. Format is a single character [[a-Z]] or [ctrl-] 402 | where is one of: [a-z], [@], [^], [\[], [,] or [_]. *) 403 | 404 | val stop : ?addr: Unix.sockaddr -> ?wait: int -> id -> unit 405 | (** [stop id] stops the container [id]. 406 | @param wait number of seconds to wait before killing the container. *) 407 | 408 | val wait : ?addr: Unix.sockaddr -> id -> int 409 | (** [wait id] block until a container [id] stops, then returns the 410 | exit code. *) 411 | 412 | val restart : ?addr: Unix.sockaddr -> ?wait: int -> id -> unit 413 | (** [restart id] restart the container [id]. 414 | 415 | @param wait number of seconds to wait before killing the container. *) 416 | 417 | val kill : ?addr: Unix.sockaddr -> ?signal: int -> id -> unit 418 | (** [kill id] kill the container [id]. 419 | 420 | @param signal Signal to send to the container (see the standard 421 | module [Sys]). When not set, [Sys.sigkill] is assumed and the 422 | call will waits for the container to exit. *) 423 | 424 | val pause : ?addr: Unix.sockaddr -> id -> unit 425 | (** [pause id] pause the container [id]. *) 426 | 427 | val unpause : ?addr: Unix.sockaddr -> id -> unit 428 | (** [unpause id] unpause the container [id]. *) 429 | 430 | 431 | val attach : ?addr: Unix.sockaddr -> 432 | ?stdin: bool -> ?stdout: bool -> ?stderr: bool -> 433 | id -> [`Logs | `Stream | `Logs_and_stream] -> Stream.t 434 | (** [attach id what] view or interact with any running container 435 | [id] primary process (pid 1). 436 | - If [what = `Logs] replay the logs from the container: you will 437 | get the output since the container started. 438 | - If [what = `Stream], stream [stdin], [stdout] and [stderr] (if 439 | enabled) from the time the request was made onwards. 440 | - If [what = `Logs_and_stream] after getting the output of 441 | [`Logs], it will seamlessly transition into streaming current 442 | output. 443 | 444 | @param stdin attach to stdin. Default [false]. 445 | @param stdout return and/or attach to stdout. Default [false]. 446 | @param stderr return and/or attach to stderr. Default [false]. *) 447 | 448 | val rm : ?addr: Unix.sockaddr -> ?volumes: bool -> ?force: bool -> 449 | ?link: bool -> 450 | id -> unit 451 | (** [rm id] remove the container [id] from the filesystem. 452 | @raise Docker.Invalid_argument if the container does not exist. 453 | 454 | @param volumes Remove the volumes associated to the container. 455 | Default [false]. 456 | @param force Kill then remove the container. Default [false]. 457 | @param link Remove the specified link associated with the container. 458 | Default: [false]. *) 459 | 460 | module Exec : sig 461 | type t 462 | 463 | val create : ?addr: Unix.sockaddr -> 464 | ?stdin: bool -> ?stdout: bool -> ?stderr: bool -> 465 | ?detach_keys: string -> 466 | ?env: string list -> ?privileged: bool -> ?user: string -> 467 | id -> string list -> t 468 | (** [exec id cmd] sets up an exec instance in the {i running} 469 | container [id] that executes [cmd]. The command [cmd] has the 470 | form [[prog; arg1;...; argN]]. It will not be restarted if the 471 | container is (restarted). If the container is paused, then the 472 | command will wait until the container is unpaused, and then run. 473 | The output of this command is {i not} logged by the container. If 474 | the command does not exist, a message will be printed on the 475 | stderr component of the stream returned by {!start}. 476 | 477 | @param stdin whether to attach stdin. Default: [false]. 478 | @param stdout whether to attach stdout. Default: [true]. 479 | @param stderr whether to attach stderr. Default: [true]. 480 | @param detach_keys Override the key sequence for detaching a 481 | container. Format is a single character \[a-Z\] or 482 | ctrl- where is one of: a-z, @, ^, \[, , 483 | or _. 484 | @param env A list of environment variables of the form ["VAR=value"]. 485 | A variable without = is removed from the environment, rather 486 | than to have an empty value. 487 | @param user The user, and optionally, group to run the exec 488 | process inside the container. Format is one of: 489 | user, user:group, uid, or uid:gid. *) 490 | 491 | val start : ?addr: Unix.sockaddr -> t -> Stream.t 492 | (** [start exec_id] starts a previously set up exec instance 493 | [exec_id]. Returns a stream that enable an interactive session 494 | with the command. *) 495 | end 496 | end 497 | 498 | module Image : sig 499 | type id = string 500 | 501 | type t = { 502 | id: id; 503 | created: float; 504 | size: int; 505 | virtual_size: int; 506 | tags: string list; 507 | } 508 | 509 | val list : ?addr: Unix.sockaddr -> ?all: bool -> unit -> t list 510 | (** [list ()] return the list of images. 511 | @param all return all images. Default: [false]. *) 512 | 513 | (** See {!create}. *) 514 | type source = 515 | | Image of { name: string; repo: string; tag: string } 516 | | Src of string 517 | | Stdin of { len: int; write : Unix.file_descr -> int -> unit } 518 | 519 | val create : ?addr: Unix.sockaddr -> ?platform: string -> 520 | source -> unit 521 | (** [create from] creates an image by either pulling it from a 522 | registry or importing it. 523 | - [`Image img] provides the name [img.name] of the image. The 524 | name may include a tag or digest [img.tag]. If [img.tag] is 525 | empty when pulling an image, it causes all tags for the given 526 | image to be pulled. 527 | - [`Src url] provides the [url] from which the image can be 528 | retrieved. 529 | - [`Stdin img] provides the image as its length [img.len] and a 530 | function [img.write fd len] that will write the image on [fd]. 531 | 532 | @param repo Repository name given to an image when it is 533 | imported. The repo may include a tag. This parameter 534 | may only be used when importing an image. 535 | @param tag Tag or digest. If empty when pulling an image, this 536 | causes all tags for the given image to be pulled. 537 | @param platform Platform in the format os\[/arch\[/variant\]\]. 538 | Default: [""]. *) 539 | 540 | val from_image : ?repo: string -> ?tag: string -> string -> source 541 | (** [from_image name] convenience function that returns an [Image] 542 | source. *) 543 | 544 | (* val insert : ?addr: Unix.sockaddr -> name -> string -> stream *) 545 | 546 | (* val inspect : ?addr: Unix.sockaddr -> name -> t *) 547 | 548 | (* type history = { id: string; created: float; created_by: string } *) 549 | 550 | (* val history : ?addr: Unix.sockaddr -> name -> history list *) 551 | 552 | (* val push : ?addr: Unix.sockaddr -> name -> stream *) 553 | 554 | (* val tag : ?addr: Unix.sockaddr -> ?repo: string -> ?force:bool -> name -> unit *) 555 | 556 | (* val rm : ?addr: Unix.sockaddr -> name -> stream *) 557 | 558 | (* type search_result = { description: string; *) 559 | (* is_official: bool; *) 560 | (* is_trusted: bool; *) 561 | (* name: name; *) 562 | (* star_count: int } *) 563 | 564 | (* val search : ?addr: Unix.sockaddr -> string -> search_result list *) 565 | 566 | (* val build : ?addr: Unix.sockaddr -> unit -> stream *) 567 | ;; 568 | end 569 | 570 | (* val auth : ?addr: Unix.sockaddr -> *) 571 | (* ?username:string -> ?password: string -> ?email: string -> *) 572 | (* ?serveraddress: string -> unit *) 573 | (* (\** Get the default username and email. *\) *) 574 | 575 | (* type info *) 576 | 577 | (* val info : ?addr: Unix.sockaddr -> unit -> info *) 578 | 579 | type version = { api_version: string; 580 | version: string; 581 | git_commit: string; 582 | go_version: string } 583 | 584 | val version : ?addr: Unix.sockaddr -> unit -> version 585 | 586 | (* val ping : ?addr: Unix.sockaddr -> unit -> [`Ok | `Error] *) 587 | 588 | (* val commit : ?addr: Unix.sockaddr -> unit -> Image.t *) 589 | 590 | (* val monitor : ?addr: Unix.sockaddr -> unit -> event list *) 591 | 592 | (* val get : ?addr: Unix.sockaddr -> name: string -> stream *) 593 | 594 | (* val load : ?addr: Unix.sockaddr -> tarball: string -> unit *) 595 | (* FIXME: More general than tarball in memory *) 596 | 597 | 598 | ;; 599 | -------------------------------------------------------------------------------- /src/docker_config.pre.ml: -------------------------------------------------------------------------------- 1 | (* -*-tuareg-*- *) 2 | 3 | (* Host and User Agent to send to Docker. *) 4 | let http11_header = 5 | " HTTP/1.1\r\n\ 6 | Host:\r\n\ 7 | User-Agent: OCaml-Docker/%%VERSION%% (%%SYSTEM%%)\r\n" 8 | -------------------------------------------------------------------------------- /src/docker_utils.pre.ml: -------------------------------------------------------------------------------- 1 | # 2 "src/docker_utils.pre.ml" 2 | 3 | module Int = struct 4 | let max i j = if (i: int) > j then i else j 5 | end 6 | 7 | module Buffer = struct 8 | include Buffer 9 | 10 | let safe_chars_for_query = 11 | let a = Array.make 256 false in 12 | let safe = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\ 13 | 0123456789_.-~!$'()*,:@/?" in 14 | for i = 0 to String.length safe - 1 do 15 | a.(Char.code safe.[i]) <- true 16 | done; 17 | a 18 | 19 | let rec add_pct_encoded_scan buf s start curr len = 20 | if curr >= len then 21 | add_substring buf s start (curr - start) 22 | else 23 | let c = Char.code s.[curr] in 24 | if safe_chars_for_query.(c) then 25 | add_pct_encoded_scan buf s start (curr + 1) len 26 | else ( 27 | if curr > start then add_substring buf s start (curr - start); 28 | add_string buf (Printf.sprintf "%%%02X" c); 29 | add_pct_encoded_scan buf s (curr + 1) (curr + 1) len 30 | ) 31 | 32 | let add_pct_encoded buf s = 33 | add_pct_encoded_scan buf s 0 0 (String.length s) 34 | 35 | (* Url query encode. (Avoid to depend on external librarues for 36 | this and insert it directly into the buffer instead of going 37 | through a string.) Inspired by [Uri]. *) 38 | let add_encoded_query buf = function 39 | | [] -> () 40 | | (k0, v0) :: query -> 41 | add_string buf "?"; 42 | add_pct_encoded buf k0; 43 | add_char buf '='; 44 | add_pct_encoded buf v0; 45 | let encode (k, v) = 46 | add_char buf '&'; 47 | add_pct_encoded buf k; 48 | add_char buf '='; 49 | add_pct_encoded buf v in 50 | List.iter encode query 51 | 52 | 53 | (* BEGIN COMPATIBILITY *) 54 | (* Compatibility with pre-Bytes versions of OCaml *) 55 | let add_subbytes = add_substring 56 | let to_bytes = contents 57 | (* END COMPATIBILITY *) 58 | end 59 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name docker) 3 | (public_name docker-api) 4 | (libraries bytes unix yojson) 5 | (synopsis "Binding to the Docker Remote API")) 6 | 7 | (rule 8 | (targets docker_config.ml docker_utils.ml) 9 | (deps (:p ../compatibility.ml) docker_config.pre.ml docker_utils.pre.ml) 10 | (action (run ocaml %{p}))) 11 | -------------------------------------------------------------------------------- /test/bind.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | module C = Docker.Container 3 | 4 | let () = 5 | Common.install_image "debian" ~tag:"latest"; 6 | (* The bind.dir directory will be created with root ownership. *) 7 | let c = C.create "debian:latest" ["dash"; "-s"] ~open_stdin: true 8 | ~host:(C.host () ~binds:[C.Mount("bind.dir", "/tmp/b")]) in 9 | C.start c; 10 | (* Allow a non-root user to remove the dir: *) 11 | ignore(C.Exec.(start (create c ["chmod"; "ugo+w"; "/tmp/b"]))); 12 | ignore(C.Exec.(start (create c ["touch"; "/tmp/b/bind.txt"]))); 13 | let e = C.Exec.create c ["ls"; "-l"; "/tmp/b"] in 14 | let st = C.Exec.start e in 15 | let s = Docker.Stream.read_all st in 16 | Docker.Container.stop c; 17 | Docker.Container.rm c; 18 | let identify (ty, s) = match ty with 19 | | Docker.Stream.Stdout -> "out> " ^ s 20 | | Docker.Stream.Stderr -> "err> " ^ s in 21 | printf "Exec in the container returned:\n%s\n" 22 | (String.concat "\n" (List.map identify s)) 23 | 24 | -------------------------------------------------------------------------------- /test/common.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | 3 | let install_image ?tag img = 4 | try Docker.Image.(create (from_image img ?tag)) 5 | with Docker.Error(_, msg) -> 6 | (* Continuous Integration do not usually have docker installed so 7 | connecting to the daemon will fail. Thus, just print a message. *) 8 | printf "%s: Error: could not install the image %S because %S\n" 9 | (Filename.basename Sys.argv.(0)) img msg; 10 | exit 0 11 | 12 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names version ls exec bind robust ps no_image no_cmd run secure) 3 | (libraries docker-api str)) 4 | 5 | (alias 6 | (name tests) 7 | (deps version.exe ls.exe exec.exe bind.exe robust.exe ps.exe no_image.exe 8 | no_cmd.exe run.exe secure.exe)) 9 | 10 | (rule 11 | (alias runtest) 12 | (deps version.exe) 13 | (action (run %{deps}))) 14 | 15 | (rule 16 | (alias runtest) 17 | (deps ls.exe) 18 | (action (progn 19 | (run %{deps}) 20 | (run %{deps} --logs)))) 21 | 22 | (rule 23 | (alias runtest) 24 | (deps exec.exe) 25 | (action (run %{deps}))) 26 | 27 | (rule 28 | (alias runtest) 29 | (deps bind.exe) 30 | (action (run %{deps}))) 31 | 32 | (rule 33 | (alias runtest) 34 | (deps robust.exe) 35 | (action (run %{deps}))) 36 | 37 | (rule 38 | (alias runtest) 39 | (deps ps.exe) 40 | (action (run %{deps}))) 41 | 42 | (rule 43 | (alias runtest) 44 | (deps no_image.exe) 45 | (action (run %{deps}))) 46 | 47 | (rule 48 | (alias runtest) 49 | (deps no_cmd.exe) 50 | (action (run %{deps}))) 51 | 52 | (rule 53 | (alias runtest) 54 | (deps run.exe) 55 | (action (run %{deps}))) 56 | 57 | (rule 58 | (alias runtest) 59 | (deps secure.exe) 60 | (action (run %{deps}))) 61 | -------------------------------------------------------------------------------- /test/exec.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | module C = Docker.Container 3 | 4 | let () = 5 | Common.install_image "debian" ~tag:"latest"; 6 | let c = C.create "debian:latest" ["bash"; "-s"] ~open_stdin:true in 7 | C.start c; 8 | let e = C.Exec.create c ["ls"; "-lp"; "/"] in 9 | let st = C.Exec.start e in 10 | (* fprintf (Docker.Stream.out st) "ls -l /home/\n%!"; *) 11 | let s = Docker.Stream.read_all st in 12 | Docker.Container.stop c; 13 | Docker.Container.rm c; 14 | let identify (ty, s) = match ty with 15 | | Docker.Stream.Stdout -> "out> " ^ s 16 | | Docker.Stream.Stderr -> "err> " ^ s in 17 | printf "Exec in the container returned:\n%s\n" 18 | (String.concat "\n" (List.map identify s)) 19 | 20 | -------------------------------------------------------------------------------- /test/ls.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | 3 | let show_stream () = 4 | let cmd = ["ls"; "-l"] in 5 | let c = Docker.Container.create "debian:latest" cmd in 6 | Docker.Container.start c; 7 | let st = Docker.Container.attach c `Stream ~stdout:true in 8 | let a = Docker.Stream.read_all st in 9 | (try Docker.Container.stop c 10 | with Docker.Failure(_, msg) -> printf "Docker.Failure: %s\n" msg); 11 | Docker.Container.rm c; 12 | printf "%S in the container returned (stream):\n> %s\n" 13 | (String.concat " " cmd) (String.concat "> " (List.map snd a)) 14 | 15 | let show_logs () = 16 | let cmd = ["ls"; "-l"] in 17 | let c = Docker.Container.create "debian:latest" cmd in 18 | Docker.Container.start c; 19 | Unix.sleep 1; 20 | let s = Docker.Container.attach c ~stdout:true `Logs in 21 | let a = Docker.Stream.read_all s in 22 | (try Docker.Container.stop c 23 | with Docker.Failure(_, msg) -> printf "Docker.Failure: %s\n" msg); 24 | Docker.Container.rm c; 25 | printf "%S in the container returned (logs):\n> %s\n" 26 | (String.concat " " cmd) (String.concat "> " (List.map snd a)) 27 | 28 | let () = 29 | let logs = ref false in 30 | let args = [ 31 | "--logs", Arg.Set logs, " use Docker.Container.attach ~logs"; 32 | ] in 33 | Arg.parse (Arg.align args) (fun _ -> raise(Arg.Bad "no anonymous argument")) 34 | "ls "; 35 | Common.install_image "debian" ~tag:"latest"; 36 | if !logs then show_logs () 37 | else show_stream () 38 | -------------------------------------------------------------------------------- /test/no_cmd.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | module C = Docker.Container 3 | 4 | let () = 5 | (* When one tries to run a non-existing command, the call should 6 | fail with a clear error message. *) 7 | try 8 | let c = C.create "alpine:latest" ["/bin/bash"] ~open_stdin:true in 9 | C.start c; 10 | assert false 11 | with Docker.Failure _ as e -> 12 | printf "Raised %s\n%!" (Printexc.to_string e) 13 | 14 | let () = 15 | try 16 | let c = C.create "alpine:latest" ["/bin/ash"] ~open_stdin:true in 17 | C.start c; 18 | let e = C.Exec.create c ["bash"] in 19 | let stream = C.Exec.start e in 20 | let ty, s = Docker.Stream.read stream in 21 | printf "Read %S on %s\n%!" s (match ty with Stdout -> "Stdout" 22 | | Stderr -> "Stderr"); 23 | C.stop c; 24 | C.rm c; 25 | (* assert false *) 26 | printf "Unfortunately, Docker does not indicate when a command is not \ 27 | available.\n" 28 | with Docker.Failure _ as e -> 29 | printf "Raised %s\n%!" (Printexc.to_string e) 30 | -------------------------------------------------------------------------------- /test/no_image.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | module C = Docker.Container 3 | 4 | let () = 5 | (* When one tries to run a non-existing image, the call should fail 6 | with a clear error message. *) 7 | try 8 | let _c = C.create "nonexisting" ["bash"; "-s"] ~open_stdin:true in 9 | assert false 10 | with Docker.Failure _ -> 11 | printf "Good, raised exception as expected.\n" 12 | -------------------------------------------------------------------------------- /test/ps.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | module C = Docker.Container 3 | 4 | let () = 5 | Common.install_image "alpine" ~tag:"latest"; 6 | let cmd = ["sleep"; "0.3"] in 7 | let c = C.create "alpine:latest" ~name:"waiting_container" cmd in 8 | printf "Created container id: %s\n%!" c; 9 | (try C.start c 10 | with Docker.Failure(_, m) -> printf "Docker.Container.start: %s\n" m); 11 | let l = C.list() in 12 | (try C.stop c 13 | with Docker.Failure(_, m) -> printf "Docker.Container.stop: %s\n" m); 14 | C.rm c; 15 | printf "List containers:\n"; 16 | List.iter (fun c -> printf "- id: %s\n names: %s\n" 17 | c.C.id (String.concat ", " c.C.names)) l 18 | -------------------------------------------------------------------------------- /test/robust.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | module C = Docker.Container 3 | 4 | let rec seq a b = 5 | if a > b then [] 6 | else a :: seq (a + 1) b 7 | 8 | (* Express an ordered sequence of integers as an union of intervals. *) 9 | type range = Single of int | Range of int * int 10 | 11 | let rec ranges (x0: int) = function 12 | | x :: (y :: _ as tl) -> 13 | if y = x + 1 then ranges x0 tl 14 | else (if x = x0 then Single x0 else Range(x0, x)) :: ranges y tl 15 | | [x] -> [if x = x0 then Single x0 else Range(x0, x)] 16 | | [] -> [] 17 | 18 | let ranges l = match l with 19 | | [] -> [] 20 | | x0 :: _ -> ranges x0 l 21 | 22 | let ranges_to_string l = 23 | let to_string = function 24 | | Single i -> sprintf "%d" i 25 | | Range(i1, i2) -> sprintf "%d-%d" i1 i2 in 26 | String.concat "," (List.map to_string l) 27 | 28 | let () = 29 | Common.install_image "debian" ~tag:"latest"; 30 | let c = C.create "debian:latest" ["bash"; "-s"] ~open_stdin:true in 31 | C.start c; 32 | (* Check that sequences of integers created by `seq` in the 33 | container are correctly read on the output stream of the 34 | container. Show incorrect output (collapsing intervals). *) 35 | let check n = 36 | assert(n >= 2); 37 | let e = C.Exec.create c ["seq"; string_of_int n] ~stdin:true in 38 | let st = C.Exec.start e in 39 | let s = Docker.Stream.read_all st in 40 | let buf = Buffer.create (n * truncate(log(float n))) in 41 | List.iter (function 42 | | (Docker.Stream.Stdout, s) -> Buffer.add_string buf s 43 | | (Docker.Stream.Stderr, s) -> failwith("STDERR: " ^ s) 44 | ) s; 45 | let out = Str.split (Str.regexp "[ \r\n]+") (Buffer.contents buf) in 46 | let out = List.map int_of_string out in 47 | if out <> seq 1 n then ( 48 | printf "n = %d: output = %s\n" n (ranges_to_string (ranges out)); 49 | ) in 50 | Random.self_init(); 51 | for _i = 1 to 100 do 52 | check (2 + Random.int 100000) 53 | done; 54 | Docker.Container.stop c; 55 | Docker.Container.rm c 56 | -------------------------------------------------------------------------------- /test/run.ml: -------------------------------------------------------------------------------- 1 | 2 | let () = 3 | Common.install_image "alpine" ~tag:"latest"; 4 | let c = Docker.Container.create "alpine:latest" ["echo"; "Hello"; "World"] in 5 | Docker.Container.start c; 6 | let _code = Docker.Container.wait c in 7 | Docker.Container.stop c; 8 | Docker.Container.rm c 9 | -------------------------------------------------------------------------------- /test/secure.ml: -------------------------------------------------------------------------------- 1 | 2 | let ls () = 3 | Common.install_image "alpine" ~tag:"latest"; 4 | let c = Docker.Container.create "alpine:latest" ["uname"; "-a"] 5 | ~name:"test" ~open_stdin:true in 6 | Docker.Container.start c; 7 | let _e = Docker.Container.Exec.create c ["ls"; "-l"; "/"] in 8 | 9 | Docker.Container.stop c; 10 | Docker.Container.rm c 11 | -------------------------------------------------------------------------------- /test/version.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | 3 | let () = 4 | let v = try Docker.version() 5 | with Docker.Error(_, msg) -> 6 | printf "version: Error: %s\n" msg; 7 | exit 0 in 8 | let open Docker in 9 | printf "API version: %s\n" v.api_version; 10 | printf "Version: %s\n" v.version; 11 | printf "Git commit: %s\n" v.git_commit; 12 | printf "Go version: %s\n" v.go_version 13 | --------------------------------------------------------------------------------