2024-10-25 18:26.30: New job: test moby/vpnkit https://github.com/moby/vpnkit.git#refs/pull/643/head (b5687cdcb8779e7dcc1a6319e4b92e3fd19aca51) (linux-x86_64:(lint-fmt)) Base: ocaml/opam:debian-12-ocaml-4.08@sha256:313659e036d93aad64e3d503c7a2aa6326e0a2c7426087b094ccca6aed7d1612 ocamlformat version: version 0.20.1 (from opam) To reproduce locally: git clone --recursive "https://github.com/moby/vpnkit.git" && cd "vpnkit" && git fetch origin "refs/pull/643/head" && git reset --hard b5687cdc cat > Dockerfile <<'END-OF-DOCKERFILE' FROM ocaml/opam:debian-12-ocaml-4.08@sha256:313659e036d93aad64e3d503c7a2aa6326e0a2c7426087b094ccca6aed7d1612 USER 1000:1000 RUN cd ~/opam-repository && (git cat-file -e 46c2d8c268fa7d5c448331593f34c5c7d413205b || git fetch origin master) && git reset -q --hard 46c2d8c268fa7d5c448331593f34c5c7d413205b && git log --no-decorate -n1 --oneline && opam update -u RUN opam depext -i dune WORKDIR /src RUN opam depext -i ocamlformat=0.20.1 COPY --chown=1000:1000 . /src/ RUN opam exec -- dune build @fmt --ignore-promoted-rules || (echo "dune build @fmt failed"; exit 2) END-OF-DOCKERFILE docker build . END-REPRO-BLOCK 2024-10-25 18:26.30: Using cache hint "moby/vpnkit-ocaml/opam:debian-12-ocaml-4.08@sha256:313659e036d93aad64e3d503c7a2aa6326e0a2c7426087b094ccca6aed7d1612-debian-12-4.08_opam-2.2-ocamlformat-46c2d8c268fa7d5c448331593f34c5c7d413205b" 2024-10-25 18:26.30: Using OBuilder spec: ((from ocaml/opam:debian-12-ocaml-4.08@sha256:313659e036d93aad64e3d503c7a2aa6326e0a2c7426087b094ccca6aed7d1612) (user (uid 1000) (gid 1000)) (run (cache (opam-archives (target /home/opam/.opam/download-cache))) (network host) (shell "cd ~/opam-repository && (git cat-file -e 46c2d8c268fa7d5c448331593f34c5c7d413205b || git fetch origin master) && git reset -q --hard 46c2d8c268fa7d5c448331593f34c5c7d413205b && git log --no-decorate -n1 --oneline && opam update -u")) (run (cache (opam-archives (target /home/opam/.opam/download-cache))) (network host) (shell "opam depext -i dune")) (workdir /src) (run (cache (opam-archives (target /home/opam/.opam/download-cache))) (network host) (shell "opam depext -i ocamlformat=0.20.1")) (copy (src .) (dst /src/)) (run (shell "opam exec -- dune build @fmt --ignore-promoted-rules || (echo \"dune build @fmt failed\"; exit 2)")) ) 2024-10-25 18:26.30: Waiting for resource in pool OCluster 2024-10-25 18:26.30: Waiting for worker… 2024-10-25 18:26.30: Got resource from pool OCluster Building on x86-bm-c3.sw.ocaml.org All commits already cached HEAD is now at b5687cdc Generate SBOM with build (from ocaml/opam:debian-12-ocaml-4.08@sha256:313659e036d93aad64e3d503c7a2aa6326e0a2c7426087b094ccca6aed7d1612) 2024-10-25 18:26.32 ---> using "8ac68bced7188653db7b81863dbdd05e2bdaccde05c724cc4b90798d2e42b237" from cache /: (user (uid 1000) (gid 1000)) /: (run (cache (opam-archives (target /home/opam/.opam/download-cache))) (network host) (shell "cd ~/opam-repository && (git cat-file -e 46c2d8c268fa7d5c448331593f34c5c7d413205b || git fetch origin master) && git reset -q --hard 46c2d8c268fa7d5c448331593f34c5c7d413205b && git log --no-decorate -n1 --oneline && opam update -u")) 46c2d8c268 Merge pull request #26322 from gridbugs/either-depend-on-ocaml <><> Updating package repositories ><><><><><><><><><><><><><><><><><><><><><><> [default] synchronised from file:///home/opam/opam-repository default (at file:///home/opam/opam-repository): [INFO] opam 2.1 and 2.2 include many performance improvements over 2.0; please consider upgrading (https://opam.ocaml.org/doc/Install.html) The following actions will be performed: - downgrade opam-depext 1.2.3 to 1.2.1-1 <><> Gathering sources ><><><><><><><><><><><><><><><><><><><><><><><><><><><><> [opam-depext.1.2.1-1] found in cache <><> Processing actions <><><><><><><><><><><><><><><><><><><><><><><><><><><><> -> removed opam-depext.1.2.3 -> installed opam-depext.1.2.1-1 Done. # Run eval $(opam env) to update the current shell environment 2024-10-25 18:27.33 ---> saved as "48cea5b0ef418e34fa5f7732bf323280b448775ea0d8b2c7d9b0e0081dea23fa" /: (run (cache (opam-archives (target /home/opam/.opam/download-cache))) (network host) (shell "opam depext -i dune")) # Detecting depexts using vars: arch=x86_64, os=linux, os-distribution=debian, os-family=debian # No extra OS packages requirements found. # All required OS packages found. # Now letting opam install the packages The following actions will be performed: - install dune 3.16.0 <><> Gathering sources ><><><><><><><><><><><><><><><><><><><><><><><><><><><><> [dune.3.16.0] found in cache <><> Processing actions <><><><><><><><><><><><><><><><><><><><><><><><><><><><> -> installed dune.3.16.0 Done. # Run eval $(opam env) to update the current shell environment 2024-10-25 18:28.33 ---> saved as "d148f7d3de35514d89ae221bbbb17b61ce694ffba87256e2dd926ded42513f19" /: (workdir /src) /src: (run (cache (opam-archives (target /home/opam/.opam/download-cache))) (network host) (shell "opam depext -i ocamlformat=0.20.1")) # Detecting depexts using vars: arch=x86_64, os=linux, os-distribution=debian, os-family=debian # No extra OS packages requirements found. # All required OS packages found. # Now letting opam install the packages The following actions will be performed: - install sexplib0 v0.14.0 [required by base] - install menhirLib 20240715 [required by ocamlformat] - install menhirCST 20240715 [required by menhir] - install menhirSdk 20240715 [required by ocamlformat] - install ocamlbuild 0.15.0 [required by fpath, uuseg] - install either 1.0.0 [required by ocamlformat] - install ocaml-version 3.5.0 [required by ocamlformat] - install ocamlfind 1.9.6 [required by ocp-indent, fpath, uuseg] - install cmdliner 1.3.0 [required by ocamlformat] - install result 1.5 [required by odoc-parser] - install seq base [required by re] - install csexp 1.5.2 [required by dune-configurator] - install camlp-streams 5.0.1 [required by odoc-parser] - install dune-build-info 3.16.0 [required by ocamlformat] - install fix 20230505 [required by ocamlformat] - install menhir 20240715 [required by ocamlformat] - install topkg 1.0.7 [required by fpath, uuseg] - install base-bytes base [required by ocp-indent] - install re 1.11.0 [required by ocamlformat] - install dune-configurator 3.16.0 [required by base] - install uutf 1.0.3 [required by ocamlformat] - install astring 0.8.5 [required by fpath, odoc-parser] - install ocp-indent 1.8.1 [required by ocamlformat] - install base v0.14.3 [required by ocamlformat] - install uucp 15.0.0 [required by uuseg] - install odoc-parser 1.0.1 [required by ocamlformat] - install fpath 0.7.3 [required by ocamlformat] - install stdio v0.14.0 [required by ocamlformat] - install uuseg 15.0.0 [required by ocamlformat] - install ocamlformat 0.20.1 ===== 30 to install ===== <><> Gathering sources ><><><><><><><><><><><><><><><><><><><><><><><><><><><><> [astring.0.8.5] found in cache [base.v0.14.3] found in cache [camlp-streams.5.0.1] found in cache [cmdliner.1.3.0] found in cache [csexp.1.5.2] found in cache [dune-build-info.3.16.0] found in cache [dune-configurator.3.16.0] found in cache [either.1.0.0] found in cache [fix.20230505] found in cache [fpath.0.7.3] found in cache [menhir.20240715] found in cache [menhirCST.20240715] found in cache [menhirLib.20240715] found in cache [menhirSdk.20240715] found in cache [ocaml-version.3.5.0] found in cache [ocamlbuild.0.15.0] found in cache [ocamlfind.1.9.6] found in cache [ocamlformat.0.20.1] found in cache [ocp-indent.1.8.1] found in cache [odoc-parser.1.0.1] found in cache [re.1.11.0] found in cache [result.1.5] found in cache [sexplib0.v0.14.0] found in cache [stdio.v0.14.0] found in cache [topkg.1.0.7] found in cache [uucp.15.0.0] found in cache [uuseg.15.0.0] found in cache [uutf.1.0.3] found in cache <><> Processing actions <><><><><><><><><><><><><><><><><><><><><><><><><><><><> -> installed seq.base -> installed camlp-streams.5.0.1 -> installed csexp.1.5.2 -> installed either.1.0.0 -> installed fix.20230505 -> installed menhirCST.20240715 -> installed cmdliner.1.3.0 -> installed menhirLib.20240715 -> installed menhirSdk.20240715 -> installed ocaml-version.3.5.0 -> installed re.1.11.0 -> installed result.1.5 -> installed sexplib0.v0.14.0 -> installed dune-build-info.3.16.0 -> installed dune-configurator.3.16.0 -> installed ocamlfind.1.9.6 -> installed base-bytes.base -> installed ocp-indent.1.8.1 -> installed ocamlbuild.0.15.0 -> installed base.v0.14.3 -> installed stdio.v0.14.0 -> installed topkg.1.0.7 -> installed uutf.1.0.3 -> installed astring.0.8.5 -> installed odoc-parser.1.0.1 -> installed fpath.0.7.3 -> installed menhir.20240715 -> installed uucp.15.0.0 -> installed uuseg.15.0.0 -> installed ocamlformat.0.20.1 Done. <><> ocp-indent.1.8.1 installed successfully ><><><><><><><><><><><><><><><><><> => This package requires additional configuration for use in editors. Install package 'user-setup', or manually: * for Emacs, add these lines to ~/.emacs: (add-to-list 'load-path "/home/opam/.opam/4.08/share/emacs/site-lisp") (require 'ocp-indent) * for Vim, add this line to ~/.vimrc: set rtp^="/home/opam/.opam/4.08/share/ocp-indent/vim" # Run eval $(opam env) to update the current shell environment 2024-10-25 18:29.40 ---> saved as "c5120af4f59dbf477cda3d939db0e632fc0d1f5052e9bc66dcdf25e5859ce0f0" /src: (copy (src .) (dst /src/)) 2024-10-25 18:29.42 ---> saved as "44fad41ca4cbc82ccdd74d13c4ad1bb519cb2534cc4bcaa363a43a1cbe43bedb" /src: (run (shell "opam exec -- dune build @fmt --ignore-promoted-rules || (echo \"dune build @fmt failed\"; exit 2)")) File "scripts/dune", line 1, characters 0-0: diff --git a/_build/default/scripts/dune b/_build/default/scripts/.formatted/dune index ce48c8a..a8b22c6 100644 --- a/_build/default/scripts/dune +++ b/_build/default/scripts/.formatted/dune @@ -6,4 +6,4 @@ (executable (libraries unix stringext ezjsonm) (modules Licenses) - (name licenses)) \ No newline at end of file + (name licenses)) File "dune", line 1, characters 0-0: diff --git a/_build/default/dune b/_build/default/.formatted/dune index f1ab0b4..888d163 100644 --- a/_build/default/dune +++ b/_build/default/.formatted/dune @@ -4,44 +4,56 @@ (rule (targets COMMIT) - (action (with-outputs-to %{targets} (run git rev-parse HEAD)))) + (action + (with-outputs-to + %{targets} + (run git rev-parse HEAD)))) (rule (target deps.csv) (deps vpnkit.opam) - (action (with-outputs-to %{target} (run opam list --installed --required-by=vpnkit --recursive --columns name,package,license: --separator=, --nobuild --color=never)))) + (action + (with-outputs-to + %{target} + (run opam list --installed --required-by=vpnkit --recursive --columns + name,package,license: --separator=, --nobuild --color=never)))) (rule (target licenses.json) - (deps deps.csv (:gen ./scripts/licenses.exe)) - (action (run %{gen} -out %{target} -in %{deps}))) + (deps + deps.csv + (:gen ./scripts/licenses.exe)) + (action + (run %{gen} -out %{target} -in %{deps}))) (rule (target vpnkit.exe) (deps src/bin/main.exe) - (action (copy %{deps} %{target}))) + (action + (copy %{deps} %{target}))) (rule (target vpnkit.tgz) - (deps vpnkit.exe (:gen ./scripts/mac_package.exe)) - (action (run %{gen} -out %{target} -in %{deps}))) + (deps + vpnkit.exe + (:gen ./scripts/mac_package.exe)) + (action + (run %{gen} -out %{target} -in %{deps}))) (rule - (alias sbom) - (target vpnkit.spdx.json) - (deps (:gen ./scripts/sbom.sh)) - (action (run %{gen} %{target}))) + (alias sbom) + (target vpnkit.spdx.json) + (deps + (:gen ./scripts/sbom.sh)) + (action + (run %{gen} %{target}))) (rule (alias e2e) - (deps src/hostnet_test/main.exe - go/test_inputs/open_dedicated_connection.bin + (deps src/hostnet_test/main.exe go/test_inputs/open_dedicated_connection.bin go/test_inputs/close.bin go/test_inputs/open_multiplexed_unix_connection.bin - go/test_inputs/window.bin - go/test_inputs/data.bin - go/test_inputs/open_multiplexed_connection.bin - go/test_inputs/shutdown.bin - ) - (action (run ./src/hostnet_test/main.exe)) -) + go/test_inputs/window.bin go/test_inputs/data.bin + go/test_inputs/open_multiplexed_connection.bin go/test_inputs/shutdown.bin) + (action + (run ./src/hostnet_test/main.exe))) File "src/forwarder/dune", line 1, characters 0-0: diff --git a/_build/default/src/forwarder/dune b/_build/default/src/forwarder/.formatted/dune index 9d7b34d..fd84568 100644 --- a/_build/default/src/forwarder/dune +++ b/_build/default/src/forwarder/.formatted/dune @@ -1,3 +1,4 @@ (library (name forwarder) - (libraries cstruct cstructs ipaddr mirage-flow mirage-flow-combinators mirage-channel)) + (libraries cstruct cstructs ipaddr mirage-flow mirage-flow-combinators + mirage-channel)) File "src/dns/dune", line 1, characters 0-0: diff --git a/_build/default/src/dns/dune b/_build/default/src/dns/.formatted/dune index 25490f0..a0f2c7b 100644 --- a/_build/default/src/dns/dune +++ b/_build/default/src/dns/.formatted/dune @@ -1,4 +1,5 @@ (library - (name dns) - (libraries re re.str ipaddr uri uri.services base64 cstruct result) - (preprocess (pps ppx_cstruct))) + (name dns) + (libraries re re.str ipaddr uri uri.services base64 cstruct result) + (preprocess + (pps ppx_cstruct))) File "src/dns_lwt/dune", line 1, characters 0-0: diff --git a/_build/default/src/dns_lwt/dune b/_build/default/src/dns_lwt/.formatted/dune index a674583..c3cbcf1 100644 --- a/_build/default/src/dns_lwt/dune +++ b/_build/default/src/dns_lwt/.formatted/dune @@ -1,4 +1,4 @@ (library - (name dns_lwt) - (libraries dns lwt mirage-profile) - (wrapped false)) + (name dns_lwt) + (libraries dns lwt mirage-profile) + (wrapped false)) File "src/dns_forward/dune", line 1, characters 0-0: diff --git a/_build/default/src/dns_forward/dune b/_build/default/src/dns_forward/.formatted/dune index fa19afe..f7bd839 100644 --- a/_build/default/src/dns_forward/dune +++ b/_build/default/src/dns_forward/.formatted/dune @@ -1,7 +1,7 @@ (library (name dns_forward) - (libraries lwt logs dns astring result cstruct fmt ipaddr - mirage-flow mirage-flow-combinators mirage-time mirage-channel mirage-clock - sexplib duration) + (libraries lwt logs dns astring result cstruct fmt ipaddr mirage-flow + mirage-flow-combinators mirage-time mirage-channel mirage-clock sexplib + duration) (preprocess (pps ppx_sexp_conv))) File "src/forwarder/multiplexer.mli", line 1, characters 0-0: diff --git a/_build/default/src/forwarder/multiplexer.mli b/_build/default/src/forwarder/.formatted/multiplexer.mli index 97c9840..8f5900f 100644 --- a/_build/default/src/forwarder/multiplexer.mli +++ b/_build/default/src/forwarder/.formatted/multiplexer.mli @@ -8,7 +8,8 @@ module Make (Flow : Mirage_flow.S) : sig include Mirage_flow_combinators.SHUTDOWNABLE with type flow = channel - val read_into: channel -> Cstruct.t -> (unit Mirage_flow.or_eof, error) result Lwt.t + val read_into : + channel -> Cstruct.t -> (unit Mirage_flow.or_eof, error) result Lwt.t end type listen_cb = Channel.flow -> Frame.Destination.t -> unit Lwt.t @@ -18,6 +19,6 @@ module Make (Flow : Mirage_flow.S) : sig val is_running : flow -> bool (** [is_running flow] is true if the dispatcher thread is still running. *) - val disconnect: flow -> unit Lwt.t + val disconnect : flow -> unit Lwt.t (** [disconnect flow] disconnects the underlying flow *) end File "src/fs9p/fs9p.mli", line 1, characters 0-0: diff --git a/_build/default/src/fs9p/fs9p.mli b/_build/default/src/fs9p/.formatted/fs9p.mli index ad32968..831ad10 100644 --- a/_build/default/src/fs9p/fs9p.mli +++ b/_build/default/src/fs9p/.formatted/fs9p.mli @@ -12,5 +12,5 @@ module type S = sig and returns when the connection has beenn closed. *) end -module Make (Flow : Mirage_flow.S) : S with type flow = Flow.flow (** Server builder. *) +module Make (Flow : Mirage_flow.S) : S with type flow = Flow.flow File "src/fs9p/fs9p_error.mli", line 1, characters 0-0: diff --git a/_build/default/src/fs9p/fs9p_error.mli b/_build/default/src/fs9p/.formatted/fs9p_error.mli index 6d5c2fa..71d9199 100644 --- a/_build/default/src/fs9p/fs9p_error.mli +++ b/_build/default/src/fs9p/.formatted/fs9p_error.mli @@ -1,12 +1,9 @@ type t = Protocol_9p.Response.Err.t val map_error : ('a, Vfs.Error.t) result -> ('a, t) result Lwt.t - val error : ?errno:int32 -> ('a, unit, string, ('b, t) result) format4 -> 'a module Infix : sig val ( >>*= ) : - ('a, t) result Lwt.t -> - ('a -> ('b, t) result Lwt.t) -> - ('b, t) result Lwt.t + ('a, t) result Lwt.t -> ('a -> ('b, t) result Lwt.t) -> ('b, t) result Lwt.t end File "src/cstructs/cstructs.mli", line 1, characters 0-0: diff --git a/_build/default/src/cstructs/cstructs.mli b/_build/default/src/cstructs/.formatted/cstructs.mli index 79d9391..3d7734b 100644 --- a/_build/default/src/cstructs/cstructs.mli +++ b/_build/default/src/cstructs/.formatted/cstructs.mli @@ -1,4 +1,3 @@ - (** A subset of the Cstruct signature with type t = Cstruct.t list This should be replaced with another parser, perhaps angstrom? *) @@ -6,20 +5,16 @@ type t = Cstruct.t list (** Data stored as a list of fragments *) -val to_string: t -> string - -val shift: t -> int -> t - -val len: t -> int - -val sub: t -> int -> int -> t - -val get_uint8: t -> int -> int +val to_string : t -> string +val shift : t -> int -> t +val len : t -> int +val sub : t -> int -> int -> t +val get_uint8 : t -> int -> int -val to_cstruct: t -> Cstruct.t +val to_cstruct : t -> Cstruct.t (** Returns a contiguous Cstruct.t, which may or may not involve a copy. *) -module BE: sig - val get_uint16: t -> int -> int - val get_uint32: t -> int -> int32 +module BE : sig + val get_uint16 : t -> int -> int + val get_uint32 : t -> int -> int32 end File "gen_commit.ml", line 1, characters 0-0: diff --git a/_build/default/gen_commit.ml b/_build/default/.formatted/gen_commit.ml index 2023253..21323d0 100644 --- a/_build/default/gen_commit.ml +++ b/_build/default/.formatted/gen_commit.ml @@ -1,18 +1,17 @@ -(* Generate the artifact COMMIT which stores the source commit sha *) -let usage_msg = "gen_commit -o <output>" -let output_file = ref "COMMIT" - -let speclist = - [("-o", Arg.Set_string output_file, "Set output file name")] - -let other_arg name = Printf.fprintf stderr "ignoring unexpected argument %s" name - -let () = - Arg.parse speclist other_arg usage_msg; - (* Avoid using Unix shell features like redirection *) - let ic = Unix.open_process_in "git rev-parse HEAD" in - let commit = input_line ic in - let oc = open_out !output_file in - output_string oc commit; - close_out oc; - close_in ic +(* Generate the artifact COMMIT which stores the source commit sha *) +let usage_msg = "gen_commit -o <output>" +let output_file = ref "COMMIT" +let speclist = [ ("-o", Arg.Set_string output_file, "Set output file name") ] + +let other_arg name = + Printf.fprintf stderr "ignoring unexpected argument %s" name + +let () = + Arg.parse speclist other_arg usage_msg; + (* Avoid using Unix shell features like redirection *) + let ic = Unix.open_process_in "git rev-parse HEAD" in + let commit = input_line ic in + let oc = open_out !output_file in + output_string oc commit; + close_out oc; + close_in ic File "scripts/mac_package.ml", line 1, characters 0-0: diff --git a/_build/default/scripts/mac_package.ml b/_build/default/scripts/.formatted/mac_package.ml index 657a0cf..e02da70 100644 --- a/_build/default/scripts/mac_package.ml +++ b/_build/default/scripts/.formatted/mac_package.ml @@ -4,10 +4,13 @@ let output_file = ref "vpnkit.tgz" let input_file = ref "vpnkit.exe" let speclist = - [("-out", Arg.Set_string output_file, "Set output file name"); - ("-in", Arg.Set_string input_file, "Set input file name")] + [ + ("-out", Arg.Set_string output_file, "Set output file name"); + ("-in", Arg.Set_string input_file, "Set input file name"); + ] -let run cmd = match Unix.system cmd with +let run cmd = + match Unix.system cmd with | Unix.WEXITED 0 -> () | Unix.WEXITED n -> failwith (Printf.sprintf "%s: %d" cmd n) | _ -> failwith (Printf.sprintf "%s: unexpected signal" cmd) @@ -15,9 +18,11 @@ let run cmd = match Unix.system cmd with let () = Arg.parse speclist ignore usage_msg; let root = "package" in - List.iter run [ - "mkdir -p " ^ (root ^ "/Contents/Resources/bin"); - "cp " ^ !input_file ^ " " ^ root ^ "/Contents/Resources/bin/vpnkit"; - "dylibbundler -od -b -x " ^ root ^ "/Contents/Resources/bin/vpnkit -d " ^ root ^ "/Contents/Resources/lib -p @executable_path/../lib"; - "tar -C " ^ root ^ " -cvzf " ^ !output_file ^ " Contents"; - ] + List.iter run + [ + "mkdir -p " ^ root ^ "/Contents/Resources/bin"; + "cp " ^ !input_file ^ " " ^ root ^ "/Contents/Resources/bin/vpnkit"; + "dylibbundler -od -b -x " ^ root ^ "/Contents/Resources/bin/vpnkit -d " + ^ root ^ "/Contents/Resources/lib -p @executable_path/../lib"; + "tar -C " ^ root ^ " -cvzf " ^ !output_file ^ " Contents"; + ] File "src/forwarder/frame.mli", line 1, characters 0-0: diff --git a/_build/default/src/forwarder/frame.mli b/_build/default/src/forwarder/.formatted/frame.mli index e436ce9..5fcb246 100644 --- a/_build/default/src/forwarder/frame.mli +++ b/_build/default/src/forwarder/.formatted/frame.mli @@ -1,66 +1,58 @@ - module Destination : sig type port = int type path = string - type t = [ - | `Tcp of Ipaddr.t * port - | `Udp of Ipaddr.t * port - | `Unix of path - ] + type t = [ `Tcp of Ipaddr.t * port | `Udp of Ipaddr.t * port | `Unix of path ] - val sizeof: t -> int + val sizeof : t -> int - val write: t -> Cstruct.t -> Cstruct.t + val write : t -> Cstruct.t -> Cstruct.t (** [write t buf] writes t into [buf] and returns the part of [buf] containing [t] *) - - val read: Cstruct.t -> t + + val read : Cstruct.t -> t (** [read buf] reads [t] from [buf] or raises an exception *) - val to_string: t -> string + val to_string : t -> string end module Udp : sig - type t = { - ip: Ipaddr.t; - port: int; - payload_length: int; - } + type t = { ip : Ipaddr.t; port : int; payload_length : int } - val write_header: t -> Cstruct.t -> Cstruct.t + val write_header : t -> Cstruct.t -> Cstruct.t (** [write t buf] writes t into [buf] and returns the part of [buf] containing [t] *) - val read: Cstruct.t -> t * Cstruct.t - (** [read buf] reads [t] from [buf] and returns [t, payload] or raises an exception *) + val read : Cstruct.t -> t * Cstruct.t + (** [read buf] reads [t] from [buf] and returns [t, payload] or raises an exception *) - val max_sizeof: int + val max_sizeof : int (** The maximum size of a UDP header *) end -type connection = - | Dedicated (** the connection will be dedicated to this channel *) - | Multiplexed (** multiple channels will be multiplexed within this connection *) (** Describes the relationship between the connection and the connections within *) +type connection = + | Dedicated (** the connection will be dedicated to this channel *) + | Multiplexed + (** multiple channels will be multiplexed within this connection *) -type command = - | Open of connection * Destination.t (** open a channel to a destination *) - | Close (** request / confirm close a channel *) - | Shutdown (** flush and shutdown this side of a channel *) - | Data of int32 (** payload on a given channel *) - | Window of int64 (** sequence number to allow up to *) (** Frames containing commands open, close and transmit data along connections *) +type command = + | Open of connection * Destination.t (** open a channel to a destination *) + | Close (** request / confirm close a channel *) + | Shutdown (** flush and shutdown this side of a channel *) + | Data of int32 (** payload on a given channel *) + | Window of int64 (** sequence number to allow up to *) type t = { - command: command; - id: int32; (** The channel id which this frame refers to *) + command : command; + id : int32; (** The channel id which this frame refers to *) } (** A framed message sent from one side to the other *) -val sizeof: t -> int +val sizeof : t -> int -val write: t -> Cstruct.t -> Cstruct.t +val write : t -> Cstruct.t -> Cstruct.t (** [write t buf] writes t into [buf] and returns the part of [buf] containing [t] *) -val read: Cstruct.t -> t +val read : Cstruct.t -> t (** [read buf] reads [t] from [buf] or raises an exception *) -val to_string: t -> string +val to_string : t -> string ocamlformat: ignoring "src/dns/operators.ml" (misplaced documentation comments - warning 50) File "src/dns/operators.ml", line 35, characters 0-19: 35 | (** Logical AND. *) ^^^^^^^^^^^^^^^^^^^ Warning 50 [unexpected-docstring]: ambiguous documentation comment File "src/dns/operators.ml", line 38, characters 0-18: 38 | (** Logical OR. *) ^^^^^^^^^^^^^^^^^^ Warning 50 [unexpected-docstring]: ambiguous documentation comment File "src/dns/operators.ml", line 41, characters 0-19: 41 | (** Logical XOR. *) ^^^^^^^^^^^^^^^^^^^ Warning 50 [unexpected-docstring]: ambiguous documentation comment File "src/dns/operators.ml", line 44, characters 0-26: 44 | (** Logical shift-left. *) ^^^^^^^^^^^^^^^^^^^^^^^^^^ Warning 50 [unexpected-docstring]: ambiguous documentation comment File "src/dns/operators.ml", line 47, characters 0-27: 47 | (** Logical shift-right. *) ^^^^^^^^^^^^^^^^^^^^^^^^^^^ Warning 50 [unexpected-docstring]: ambiguous documentation comment Hint: (Warning 50) This file contains a documentation comment (** ... *) that the OCaml compiler does not know how to attach to the AST. OCamlformat does not support these cases. You can find more information at: https://github.com/ocaml-ppx/ocamlformat#overview. If you'd like to disable this check and let ocamlformat make a choice (though it might not be consistent with the ocaml compilers and odoc), you can set the --no-comment-check option. -> required by _build/default/src/dns/.formatted/operators.ml -> required by alias src/dns/.formatted/fmt -> required by alias src/dns/fmt ocamlformat: ignoring "src/dns/packet.mli" (misplaced documentation comments - warning 50) File "src/dns/packet.mli", lines 311-312, characters 0-58: 311 | (** A convenience function to create a question record with default 312 | values for q_class (Q_IN) and q_unicast (Q_Normal). *) Warning 50 [unexpected-docstring]: ambiguous documentation comment Hint: (Warning 50) This file contains a documentation comment (** ... *) that the OCaml compiler does not know how to attach to the AST. OCamlformat does not support these cases. You can find more information at: https://github.com/ocaml-ppx/ocamlformat#overview. If you'd like to disable this check and let ocamlformat make a choice (though it might not be consistent with the ocaml compilers and odoc), you can set the --no-comment-check option. -> required by _build/default/src/dns/.formatted/packet.mli -> required by alias src/dns/.formatted/fmt -> required by alias src/dns/fmt File "src/fs9p/fs9p_error.ml", line 1, characters 0-0: diff --git a/_build/default/src/fs9p/fs9p_error.ml b/_build/default/src/fs9p/.formatted/fs9p_error.ml index b6c4d22..5404ee4 100644 --- a/_build/default/src/fs9p/fs9p_error.ml +++ b/_build/default/src/fs9p/.formatted/fs9p_error.ml @@ -10,13 +10,9 @@ let error ?(errno = 0l) fmt = fmt let enoent = error "No such file or directory" - let eisdir = error "Is a directory" - let enotdir = error "Is not a directory" - let ero = error "Read-only file" - let eperm = error "Operation not permitted" let of_error x = @@ -36,6 +32,5 @@ let map_error = function module Infix = struct open Lwt.Infix - let ( >>*= ) x f = - x >>= function Ok x -> f x | Error _ as e -> Lwt.return e + let ( >>*= ) x f = x >>= function Ok x -> f x | Error _ as e -> Lwt.return e end File "src/cstructs/cstructs.ml", line 1, characters 0-0: diff --git a/_build/default/src/cstructs/cstructs.ml b/_build/default/src/cstructs/.formatted/cstructs.ml index 16f17d9..4f9780c 100644 --- a/_build/default/src/cstructs/cstructs.ml +++ b/_build/default/src/cstructs/.formatted/cstructs.ml @@ -1,27 +1,32 @@ type t = Cstruct.t list let pp_t ppf t = - List.iter (fun t -> - Fmt.pf ppf "[%d,%d](%d)" - t.Cstruct.off t.Cstruct.len (Bigarray.Array1.dim t.Cstruct.buffer) - ) t + List.iter + (fun t -> + Fmt.pf ppf "[%d,%d](%d)" t.Cstruct.off t.Cstruct.len + (Bigarray.Array1.dim t.Cstruct.buffer)) + t let len = List.fold_left (fun acc c -> Cstruct.length c + acc) 0 let err fmt = - let b = Buffer.create 20 in (* for thread safety. *) + let b = Buffer.create 20 in + (* for thread safety. *) let ppf = Format.formatter_of_buffer b in - let k ppf = Format.pp_print_flush ppf (); invalid_arg (Buffer.contents b) in + let k ppf = + Format.pp_print_flush ppf (); + invalid_arg (Buffer.contents b) + in Format.kfprintf k ppf fmt let rec shift t x = - if x = 0 then t else match t with - | [] -> err "Cstructs.shift %a %d" pp_t t x - | y :: ys -> - let y' = Cstruct.length y in - if y' > x - then Cstruct.shift y x :: ys - else shift ys (x - y') + if x = 0 then t + else + match t with + | [] -> err "Cstructs.shift %a %d" pp_t t x + | y :: ys -> + let y' = Cstruct.length y in + if y' > x then Cstruct.shift y x :: ys else shift ys (x - y') let to_string t = let b = Buffer.create 20 in @@ -31,20 +36,22 @@ let to_string t = let sub t off len = let t' = shift t off in (* trim the length *) - let rec trim acc ts remaining = match remaining, ts with - | 0, _ -> List.rev acc - | _, [] -> err "invalid bounds in Cstructs.sub %a off=%d len=%d" pp_t t off len - | n, t :: ts -> - let to_take = min (Cstruct.length t) n in - (* either t is consumed and we only need ts, or t has data - remaining in which case we're finished *) - trim (Cstruct.sub t 0 to_take :: acc) ts (remaining - to_take) + let rec trim acc ts remaining = + match (remaining, ts) with + | 0, _ -> List.rev acc + | _, [] -> + err "invalid bounds in Cstructs.sub %a off=%d len=%d" pp_t t off len + | n, t :: ts -> + let to_take = min (Cstruct.length t) n in + (* either t is consumed and we only need ts, or t has data + remaining in which case we're finished *) + trim (Cstruct.sub t 0 to_take :: acc) ts (remaining - to_take) in trim [] t' len let to_cstruct = function -| [ common_case ] -> common_case -| uncommon_case -> Cstruct.concat uncommon_case + | [ common_case ] -> common_case + | uncommon_case -> Cstruct.concat uncommon_case (* Return a Cstruct.t representing (off, len) by either returning a reference or making a copy if the value is split across two fragments. Ideally this @@ -53,33 +60,35 @@ let get f t off len = let t' = shift t off in match t' with | x :: xs -> - (* Return a reference to the existing buffer *) - if Cstruct.length x >= len - then Cstruct.sub x 0 len - else begin - (* Copy into a fresh buffer *) - let rec copy remaining frags = - if Cstruct.length remaining > 0 - then match frags with - | [] -> - err "invalid bounds in Cstructs.%s %a off=%d len=%d" f pp_t t off len - | x :: xs -> - let to_copy = min (Cstruct.length x) (Cstruct.length remaining) in - Cstruct.blit x 0 remaining 0 to_copy; - (* either we've copied all of x, or we've filled the - remaining buffer *) - copy (Cstruct.shift remaining to_copy) xs in - let result = Cstruct.create len in - copy result (x :: xs); - result - end - | [] -> - err "invalid bounds in Cstructs.%s %a off=%d len=%d" f pp_t t off len + (* Return a reference to the existing buffer *) + if Cstruct.length x >= len then Cstruct.sub x 0 len + else + (* Copy into a fresh buffer *) + let rec copy remaining frags = + if Cstruct.length remaining > 0 then + match frags with + | [] -> + err "invalid bounds in Cstructs.%s %a off=%d len=%d" f pp_t t + off len + | x :: xs -> + let to_copy = + min (Cstruct.length x) (Cstruct.length remaining) + in + Cstruct.blit x 0 remaining 0 to_copy; + (* either we've copied all of x, or we've filled the + remaining buffer *) + copy (Cstruct.shift remaining to_copy) xs + in + let result = Cstruct.create len in + copy result (x :: xs); + result + | [] -> err "invalid bounds in Cstructs.%s %a off=%d len=%d" f pp_t t off len -let get_uint8 t off = Cstruct.get_uint8 (get "get_uint8" t off 1) 0 +let get_uint8 t off = Cstruct.get_uint8 (get "get_uint8" t off 1) 0 module BE = struct open Cstruct.BE + let get_uint16 t off = get_uint16 (get "get_uint16" t off 2) 0 let get_uint32 t off = get_uint32 (get "get_uint32" t off 4) 0 end File "src/fs9p/vfs.mli", line 1, characters 0-0: diff --git a/_build/default/src/fs9p/vfs.mli b/_build/default/src/fs9p/.formatted/vfs.mli index dcd4be5..be665d4 100644 --- a/_build/default/src/fs9p/vfs.mli +++ b/_build/default/src/fs9p/.formatted/vfs.mli @@ -67,7 +67,6 @@ val error : ('a, unit, string, 'b or_err) format4 -> 'a (** [error fmt] is [Lwt.return (Error <fmt>)]. *) type perm = [ `Normal | `Exec | `Link of string ] - type metadata = { length : int64; perm : perm } (** File operations. *) @@ -199,7 +198,6 @@ module File : sig (** {1 Errors} *) val err_no_entry : 'a or_err - val err_read_only : 'a or_err end @@ -273,9 +271,7 @@ module rec Dir : sig (** {1 Errors} *) val err_already_exists : 'a or_err - val err_dir_only : 'a or_err - val err_no_entry : 'a or_err end File "src/dns/RR.ml", line 1, characters 0-0: diff --git a/_build/default/src/dns/RR.ml b/_build/default/src/dns/.formatted/RR.ml index 2d376a6..5452312 100644 --- a/_build/default/src/dns/RR.ml +++ b/_build/default/src/dns/.formatted/RR.ml @@ -19,30 +19,25 @@ (* Mnemonicity! *) type serial = int32 + type cstr = string (* DNS node: everything we know about a domain name *) -and dnsnode = { - owner: Name.t; - mutable rrsets: rrset list; -} +and dnsnode = { owner : Name.t; mutable rrsets : rrset list } (* RRSet: TTL, type, and some number of rdata *) -and rrset = { - ttl: int32; - rdata: rdata; -} +and rrset = { ttl : int32; rdata : rdata } and rrsig = { - rrsig_type : Packet.rr_type; - rrsig_alg : Packet.dnssec_alg; + rrsig_type : Packet.rr_type; + rrsig_alg : Packet.dnssec_alg; rrsig_labels : char; - rrsig_ttl : int32; + rrsig_ttl : int32; rrsig_expiry : int32; rrsig_incept : int32; rrsig_keytag : int; - rrsig_name : Name.t; - rrsig_sig : string; + rrsig_name : Name.t; + rrsig_sig : string; } and rdata = @@ -64,7 +59,7 @@ and rdata = | RT of (Cstruct.uint16 * dnsnode) list | SOA of (dnsnode * dnsnode * serial * int32 * int32 * int32 * int32) list | SRV of (Cstruct.uint16 * Cstruct.uint16 * Cstruct.uint16 * dnsnode) list - | TXT of (cstr list) list + | TXT of cstr list list (* | UNSPEC of cstr list*) | Unknown of int * cstr list | WKS of (Ipaddr.V4.t * Cstruct.byte * cstr) list File "src/dns/name.mli", line 1, characters 0-0: diff --git a/_build/default/src/dns/name.mli b/_build/default/src/dns/.formatted/name.mli index 64f04e5..13dd672 100644 --- a/_build/default/src/dns/name.mli +++ b/_build/default/src/dns/.formatted/name.mli @@ -23,69 +23,73 @@ @author Richard Mortier <mort\@cantab.net> (documentation) *) -(** DNS label, including pointer and zero. *) type label +(** DNS label, including pointer and zero. *) -(** Domain name, as a list of labels ordered from the leaf to the root. *) type t +(** Domain name, as a list of labels ordered from the leaf to the root. *) -(** Lookup key for the {! Trie}. *) type key = string +(** Lookup key for the {! Trie}. *) +module Map : Map.S with type key = t (** Domain name map *) -module Map: Map.S with type key = t +module Set : Set.S with type elt = t (** Domain name set *) -module Set: Set.S with type elt = t +val empty : t (** [empty] is the empty {! t}. *) -val empty: t -(** [to_string_list name] is the label list corresponding to [name]. *) val to_string_list : t -> string list +(** [to_string_list name] is the label list corresponding to [name]. *) +val of_string_list : string list -> t (** [of_string_list slist] is the domain name corresponding to label list [slist]. *) -val of_string_list : string list -> t +val append : t -> t -> t (** [append a b] is the domain name of the concatenation of [a] and [b]. *) -val append: t -> t -> t +val cons : string -> t -> t (** [cons label name] is the domain name with subdomain [label] under [name]. *) -val cons: string -> t -> t +val to_string : t -> string (** [to_string name] is the normal, human-readable string serialization of [name] without the trailing dot. *) -val to_string : t -> string +val of_string : string -> t (** [of_string name] is the domain name parsed out of the normal, human-readable serialization [name]. *) -val of_string : string -> t +val string_to_domain_name : string -> t (** [string_to_domain_name] is {! of_string } but retained for backward compatibility. @deprecated since 0.15.0; use {! of_string } in new developments *) -val string_to_domain_name : string -> t -(** [of_ipaddr ip] is the name used for reverse lookup of IP address [ip]. *) val of_ipaddr : Ipaddr.t -> t +(** [of_ipaddr ip] is the name used for reverse lookup of IP address [ip]. *) +val parse : (int, label) Hashtbl.t -> int -> Cstruct.t -> t * (int * Cstruct.t) (** Parse a {! t} out of a {! Cstruct.t} given a set of already observed names from the packet, and the offset we are into the packet. @return {! t} and the remainder *) -val parse : - (int, label) Hashtbl.t -> int -> Cstruct.t -> t * (int * Cstruct.t) -val marshal : ?compress:bool -> - int Map.t -> int -> Cstruct.t -> t -> int Map.t * int * Cstruct.t +val marshal : + ?compress:bool -> + int Map.t -> + int -> + Cstruct.t -> + t -> + int Map.t * int * Cstruct.t -(** Malformed input to {! canon2key}. *) exception BadDomainName of string +(** Malformed input to {! canon2key}. *) -(** Convert a canonical [[ "www"; "example"; "com" ]] domain name into a key. *) val to_key : t -> key +(** Convert a canonical [[ "www"; "example"; "com" ]] domain name into a key. *) val dnssec_compare : t -> t -> int val dnssec_compare_str : string list -> string list -> int File "src/dns/protocol.ml", line 1, characters 0-0: diff --git a/_build/default/src/dns/protocol.ml b/_build/default/src/dns/.formatted/protocol.ml index fda5fe6..0c2869c 100644 --- a/_build/default/src/dns/protocol.ml +++ b/_build/default/src/dns/.formatted/protocol.ml @@ -22,9 +22,10 @@ module type CLIENT = sig val get_id : unit -> int - val marshal : ?alloc:(unit -> Cstruct.t) -> Packet.t -> (context * Cstruct.t) list - val parse : context -> Cstruct.t -> Packet.t option + val marshal : + ?alloc:(unit -> Cstruct.t) -> Packet.t -> (context * Cstruct.t) list + val parse : context -> Cstruct.t -> Packet.t option val timeout : context -> exn end @@ -36,8 +37,7 @@ module Client : CLIENT = struct Random.self_init (); Random.int (1 lsl 16) - let marshal ?alloc q = - [q.Packet.id, Packet.marshal ?alloc q] + let marshal ?alloc q = [ (q.Packet.id, Packet.marshal ?alloc q) ] let parse id buf = let pkt = Packet.parse buf in @@ -50,15 +50,14 @@ module type SERVER = sig type context val query_of_context : context -> Packet.t + val parse : Cstruct.t -> context option - val parse : Cstruct.t -> context option - val marshal : ?alloc:(unit -> Cstruct.t) -> context -> Packet.t -> Cstruct.t option - + val marshal : + ?alloc:(unit -> Cstruct.t) -> context -> Packet.t -> Cstruct.t option end let contain_exc l v = - try - Some (v ()) + try Some (v ()) with exn -> Printexc.print_backtrace stderr; Printf.eprintf "dns %s exn: %s\n%!" l (Printexc.to_string exn); @@ -68,8 +67,8 @@ module Server : SERVER with type context = Packet.t = struct type context = Packet.t let query_of_context x = x - let parse buf = contain_exc "parse" (fun () -> Packet.parse buf) + let marshal ?alloc _q response = contain_exc "marshal" (fun () -> Packet.marshal ?alloc response) end File "src/dns/query.ml", line 1, characters 0-0: diff --git a/_build/default/src/dns/query.ml b/_build/default/src/dns/.formatted/query.ml index 9882958..7df1083 100644 --- a/_build/default/src/dns/query.ml +++ b/_build/default/src/dns/.formatted/query.ml @@ -21,62 +21,92 @@ type answer = { rcode : Packet.rcode; - aa: bool; - answer: Packet.rr list; - authority: Packet.rr list; - additional: Packet.rr list; + aa : bool; + answer : Packet.rr list; + authority : Packet.rr list; + additional : Packet.rr list; } type filter = Name.t -> RR.rrset -> RR.rrset - type flush = Name.t -> Packet.rdata -> bool -let response_of_answer ?(mdns=false) query answer = +let response_of_answer ?(mdns = false) query answer = (*let edns_rec = try List.find (fun rr -> ) query.additionals with Not_found -> [] in *) - let detail = { - Packet.qr=Packet.Response; opcode=Packet.Standard; aa=answer.aa; - tc=false; - rd=(if mdns then false else Packet.(query.detail.rd)); (* rfc6762 s18.6_p1_c1 *) - ra=false; rcode=answer.rcode - } in - Packet.({ - id=(if mdns then 0 else query.id); + let detail = + { + Packet.qr = Packet.Response; + opcode = Packet.Standard; + aa = answer.aa; + tc = false; + rd = (if mdns then false else Packet.(query.detail.rd)); + (* rfc6762 s18.6_p1_c1 *) + ra = false; + rcode = answer.rcode; + } + in + Packet. + { + id = (if mdns then 0 else query.id); detail; (* mDNS does not echo questions in the response *) - questions=(if mdns then [] else query.questions); - answers=answer.answer; - authorities=answer.authority; - additionals=answer.additional; - }) + questions = (if mdns then [] else query.questions); + answers = answer.answer; + authorities = answer.authority; + additionals = answer.additional; + } -let answer_of_response ?(preserve_aa=false) ({ - Packet.detail={ Packet.rcode; aa; _ }; - answers; authorities; additionals; _ -}) = { rcode; aa = if preserve_aa then aa else false; - answer=answers; - authority=authorities; - additional=additionals; - } +let answer_of_response ?(preserve_aa = false) + { + Packet.detail = { Packet.rcode; aa; _ }; + answers; + authorities; + additionals; + _; + } = + { + rcode; + aa = (if preserve_aa then aa else false); + answer = answers; + authority = authorities; + additional = additionals; + } -let create ?(dnssec=false) ~id q_class q_type q_name = +let create ?(dnssec = false) ~id q_class q_type q_name = let open Packet in - let detail = { - qr=Query; opcode=Standard; - aa=false; tc=false; rd=true; ra=false; rcode=NoError; - } in + let detail = + { + qr = Query; + opcode = Standard; + aa = false; + tc = false; + rd = true; + ra = false; + rcode = NoError; + } + in let additionals = if dnssec then - [ ( { - name=Name.empty; cls=RR_IN; flush=false; ttl=0l; - rdata=(EDNS0(1500, 0, true, []));} ) ] - else - [] + [ + { + name = Name.empty; + cls = RR_IN; + flush = false; + ttl = 0l; + rdata = EDNS0 (1500, 0, true, []); + }; + ] + else [] in - let question = { q_name; q_type; q_class; q_unicast=Q_Normal } in - { id; detail; questions=[question]; - answers=[]; authorities=[]; additionals; + let question = { q_name; q_type; q_class; q_unicast = Q_Normal } in + { + id; + detail; + questions = [ question ]; + answers = []; + authorities = []; + additionals; } File "src/dns/query.mli", line 1, characters 0-0: diff --git a/_build/default/src/dns/query.mli b/_build/default/src/dns/.formatted/query.mli index f70c407..7a1f58e 100644 --- a/_build/default/src/dns/query.mli +++ b/_build/default/src/dns/.formatted/query.mli @@ -21,35 +21,38 @@ @author Richard Mortier <mort\@cantab.net> (documentation) *) +type answer = { + rcode : Packet.rcode; + aa : bool; + answer : Packet.rr list; + authority : Packet.rr list; + additional : Packet.rr list; +} (** Partially-marshalled query response; that is, it has been uncompacted from the compact {! Trie} representation, but not yet rendered into a {! Cstruct.buf }. *) -type answer = { - rcode : Packet.rcode; - aa: bool; - answer: Packet.rr list; - authority: Packet.rr list; - additional: Packet.rr list; -} type filter = Name.t -> RR.rrset -> RR.rrset - type flush = Name.t -> Packet.rdata -> bool +val response_of_answer : ?mdns:bool -> Packet.t -> answer -> Packet.t (** [response_of_answer query answer] is the {! Packet.t } constructed from the [answer] to the [query] *) -val response_of_answer : ?mdns:bool -> - Packet.t -> answer -> Packet.t +val answer_of_response : ?preserve_aa:bool -> Packet.t -> answer (** [answer_of_response response] is the {! answer } corresponding to the upstream [response] for proxied or forwarded response. *) -val answer_of_response : ?preserve_aa:bool -> Packet.t -> answer +val create : + ?dnssec:bool -> + id:int -> + Packet.q_class -> + Packet.q_type -> + Name.t -> + Packet.t (** [create ~id q_class q_type q_name] creates a query for [q_name] with the supplied [id], [q_class], and [q_type]. *) -val create : ?dnssec:bool -> id:int -> Packet.q_class -> Packet.q_type -> - Name.t -> Packet.t File "src/dns/protocol.mli", line 1, characters 0-0: diff --git a/_build/default/src/dns/protocol.mli b/_build/default/src/dns/.formatted/protocol.mli index 3a64fc9..452876a 100644 --- a/_build/default/src/dns/protocol.mli +++ b/_build/default/src/dns/.formatted/protocol.mli @@ -25,6 +25,8 @@ module type CLIENT = sig val get_id : unit -> int + val marshal : + ?alloc:(unit -> Cstruct.t) -> Packet.t -> (context * Cstruct.t) list (** [marshal query] is a list of context-buffer pairs corresponding to the channel contexts and request buffers with which to attempt DNS requests. Requests are made in parallel and the first response to successfully @@ -32,21 +34,20 @@ module type CLIENT = sig successful parse or timeout. With this behavior, it is easy to construct low-latency but network-environment-aware DNS resolvers. *) - val marshal : ?alloc:(unit -> Cstruct.t) -> Packet.t -> (context * Cstruct.t) list + val parse : context -> Cstruct.t -> Packet.t option (** [parse ctxt buf] is the potential packet extracted out of [buf] with [ctxt] *) - val parse : context -> Cstruct.t -> Packet.t option + val timeout : context -> exn (** [timeout ctxt] is the exception resulting from a context [ctxt] that has timed-out *) - val timeout : context -> exn end -(** The default DNS resolver using the standard DNS protocol *) module Client : CLIENT +(** The default DNS resolver using the standard DNS protocol *) (** The type of pluggable DNS server modules for request contexts and custom metadata dn wire protocols. @@ -54,25 +55,26 @@ module Client : CLIENT module type SERVER = sig type context - (** Projects a context into its associated query *) val query_of_context : context -> Packet.t + (** Projects a context into its associated query *) + val parse : Cstruct.t -> context option (** DNS wire format parser function. @param buf message buffer @return parsed packet and context *) - val parse : Cstruct.t -> context option + val marshal : + ?alloc:(unit -> Cstruct.t) -> context -> Packet.t -> Cstruct.t option (** DNS wire format marshal function. @param alloc allocator @param _q context @param response answer packet @return buffer to write *) - val marshal : ?alloc:(unit -> Cstruct.t) -> context -> Packet.t -> Cstruct.t option end -(** The default DNS server using the standard DNS protocol *) module Server : SERVER with type context = Packet.t +(** The default DNS server using the standard DNS protocol *) val contain_exc : string -> (unit -> 'a) -> 'a option File "src/dns/RR.mli", line 1, characters 0-0: diff --git a/_build/default/src/dns/RR.mli b/_build/default/src/dns/.formatted/RR.mli index aee5e06..5234988 100644 --- a/_build/default/src/dns/RR.mli +++ b/_build/default/src/dns/.formatted/RR.mli @@ -21,35 +21,35 @@ @author Richard Mortier <mort\@cantab.net> (documentation) *) -(** DNS serial number -- 32 bits. *) type serial = int32 +(** DNS serial number -- 32 bits. *) -(** DNS character string. *) type cstr = string +(** DNS character string. *) -(** A node in the trie. *) and dnsnode = { owner : Name.t; - (** The name for which the node contains memoised attributes. *) + (** The name for which the node contains memoised attributes. *) mutable rrsets : rrset list; -(** The set of attributes as resource records. *) + (** The set of attributes as resource records. *) } +(** A node in the trie. *) +and rrset = { ttl : int32; rdata : rdata } (** An RRset, comprising a 32 bit TTL and an {!type: rdata} record. *) -and rrset = { ttl : int32; rdata : rdata; } -(** The DNSSEC signature of an {! type : rrset } *) and rrsig = { - rrsig_type : Packet.rr_type; - rrsig_alg : Packet.dnssec_alg; + rrsig_type : Packet.rr_type; + rrsig_alg : Packet.dnssec_alg; rrsig_labels : char; - rrsig_ttl : int32; + rrsig_ttl : int32; rrsig_expiry : int32; rrsig_incept : int32; rrsig_keytag : int; - rrsig_name : Name.t; - rrsig_sig : string; + rrsig_name : Name.t; + rrsig_sig : string; } +(** The DNSSEC signature of an {! type : rrset } *) (** A resource record. File "src/dns/resolvconf.mli", line 1, characters 0-0: diff --git a/_build/default/src/dns/resolvconf.mli b/_build/default/src/dns/.formatted/resolvconf.mli index c5aebb1..fa9d08d 100644 --- a/_build/default/src/dns/resolvconf.mli +++ b/_build/default/src/dns/.formatted/resolvconf.mli @@ -17,38 +17,35 @@ *) module LookupValue : sig - type t = - | Bind - | File - | Yp + type t = Bind | File | Yp + exception Unknown of string + val of_string : string -> t val to_string : t -> string end module OptionsValue : sig - type t = - | Debug - | Edns0 - | Inet6 - | Insecure1 - | Insecure2 - | Ndots of int + type t = Debug | Edns0 | Inet6 | Insecure1 | Insecure2 | Ndots of int + exception Unknown of string + val of_string : string -> t val to_string : t -> string end module KeywordValue : sig type t = - | Nameserver of Ipaddr.t * int option - | Port of int - | Domain of string - | Lookup of LookupValue.t list - | Search of string list - | Sortlist of string list - | Options of OptionsValue.t list + | Nameserver of Ipaddr.t * int option + | Port of int + | Domain of string + | Lookup of LookupValue.t list + | Search of string list + | Sortlist of string list + | Options of OptionsValue.t list + exception Unknown of string + val of_string : string -> t val to_string : t -> string end @@ -56,6 +53,7 @@ end val map_line : string -> string option type t = KeywordValue.t list + val all_servers : KeywordValue.t list -> (Ipaddr.t * int) list val choose_server : KeywordValue.t list -> (Ipaddr.t * int) option val search_domains : KeywordValue.t list -> string list File "src/dns_forward/dns_forward.ml", line 1, characters 0-0: diff --git a/_build/default/src/dns_forward/dns_forward.ml b/_build/default/src/dns_forward/.formatted/dns_forward.ml index 1cf6e55..a2bfd51 100644 --- a/_build/default/src/dns_forward/dns_forward.ml +++ b/_build/default/src/dns_forward/.formatted/dns_forward.ml @@ -15,7 +15,6 @@ * *) include Dns_forward_s - module Error = Dns_forward_error module Flow = Dns_forward_flow module Rpc = Dns_forward_rpc File "src/dns/name.ml", line 1, characters 0-0: diff --git a/_build/default/src/dns/name.ml b/_build/default/src/dns/.formatted/name.ml index 1aad0ab..66b18d4 100644 --- a/_build/default/src/dns/name.ml +++ b/_build/default/src/dns/.formatted/name.ml @@ -21,143 +21,144 @@ open Printf open Operators type t = string list - type key = string module Ordered = struct type x = t type t = x - let rec compare l1 l2 = match (l1, l2) with - | [] , [] -> 0 - | _::_ , [] -> 1 - | [] , _::_ -> -1 - | h1::t1, h2::t2 -> - match String.compare h1 h2 with - | 0 -> compare t1 t2 - | i -> i + + let rec compare l1 l2 = + match (l1, l2) with + | [], [] -> 0 + | _ :: _, [] -> 1 + | [], _ :: _ -> -1 + | h1 :: t1, h2 :: t2 -> ( + match String.compare h1 h2 with 0 -> compare t1 t2 | i -> i) end -module Map = Map.Make(Ordered) -module Set = Set.Make(Ordered) +module Map = Map.Make (Ordered) +module Set = Set.Make (Ordered) let empty = [] -let append = (@) -let cons x xs = (String.lowercase_ascii x) :: xs +let append = ( @ ) +let cons x xs = String.lowercase_ascii x :: xs let to_string_list dn = dn let of_string_list = List.map String.lowercase_ascii - let to_string = String.concat "." (* TODO: this looks wrong for the trailing dot case/we should ensure we handle the trailing dot case consistently *) -let of_string (s:string) : t = +let of_string (s : string) : t = Re.Str.split (Re.Str.regexp "\\.") (String.lowercase_ascii s) + let string_to_domain_name = of_string -let of_ipaddr ip = of_string_list @@ Domain_name.to_strings @@ Ipaddr.to_domain_name ip +let of_ipaddr ip = + of_string_list @@ Domain_name.to_strings @@ Ipaddr.to_domain_name ip type label = | L of string * int (* string *) | P of int * int (* pointer *) - | Z of int (* zero; terminator *) + | Z of int +(* zero; terminator *) let parse_label base buf = (* NB. we're shifting buf for each call; offset is for the names Hashtbl *) match Cstruct.get_uint8 buf 0 with - | 0 -> - Z base, 1 - - | v when ((v land 0b0_11000000) = 0b0_11000000) -> - let ptr = ((v land 0b0_00111111) lsl 8) + Cstruct.get_uint8 buf 1 in - P (ptr, base), 2 - - | v -> - if ((0 < v) && (v < 64)) then ( - let name = Cstruct.(sub buf 1 v |> to_string) in - L (name, base), 1+v - ) - else - failwith (sprintf "Name.parse_label: invalid length %d" v) - -let parse names base buf = (* what. a. mess. *) + | 0 -> (Z base, 1) + | v when v land 0b0_11000000 = 0b0_11000000 -> + let ptr = ((v land 0b0_00111111) lsl 8) + Cstruct.get_uint8 buf 1 in + (P (ptr, base), 2) + | v -> + if 0 < v && v < 64 then + let name = Cstruct.(sub buf 1 v |> to_string) in + (L (name, base), 1 + v) + else failwith (sprintf "Name.parse_label: invalid length %d" v) + +let parse names base buf = + (* what. a. mess. *) let rec aux offsets name base buf size = match parse_label base buf with - | (Z o as zero, offset) -> - Hashtbl.add names o zero; - name, base+offset, Cstruct.shift buf offset, (size + 1) - - | (L (n, o) as label, offset) -> - Hashtbl.add names o label; - offsets |> List.iter (fun off -> (Hashtbl.add names off label)); - aux (o :: offsets) (n :: name) (base+offset) (Cstruct.shift buf offset) (size + offset) - - | (P (p, _), offset) -> - (match Hashtbl.find_all names p with - | [] -> failwith (sprintf "Name.parse_pointer: Cannot dereference pointer to (%n) at position (%n)" p base); - | all -> - let labels = (all |> List.filter (function L _ -> true | _ -> false)) in - (* update the list of offsets-so-far to include current label *) - (base :: offsets) |> List.iter (fun o -> - (List.rev labels) |> List.iter (fun n -> Hashtbl.add names o n) - ); - (* convert label list into string list *) - let labels_str = (labels ||> (function - | L (nm,_) -> nm - | _ -> failwith "Name.parse") - ) - in - let nb_labels = List.length labels_str in - let label_size = List.fold_left (fun size str -> size + (String.length str)) nb_labels labels_str in - labels_str@name, base+offset, Cstruct.shift buf offset, (size + label_size) - ) - + | (Z o as zero), offset -> + Hashtbl.add names o zero; + (name, base + offset, Cstruct.shift buf offset, size + 1) + | (L (n, o) as label), offset -> + Hashtbl.add names o label; + offsets |> List.iter (fun off -> Hashtbl.add names off label); + aux (o :: offsets) (n :: name) (base + offset) + (Cstruct.shift buf offset) (size + offset) + | P (p, _), offset -> ( + match Hashtbl.find_all names p with + | [] -> + failwith + (sprintf + "Name.parse_pointer: Cannot dereference pointer to (%n) at \ + position (%n)" + p base) + | all -> + let labels = + all |> List.filter (function L _ -> true | _ -> false) + in + (* update the list of offsets-so-far to include current label *) + base :: offsets + |> List.iter (fun o -> + List.rev labels |> List.iter (fun n -> Hashtbl.add names o n)); + (* convert label list into string list *) + let labels_str = + labels ||> function L (nm, _) -> nm | _ -> failwith "Name.parse" + in + let nb_labels = List.length labels_str in + let label_size = + List.fold_left + (fun size str -> size + String.length str) + nb_labels labels_str + in + ( labels_str @ name, + base + offset, + Cstruct.shift buf offset, + size + label_size )) in + let name, base, buf, size = aux [] [] base buf 0 in - if size > 255 then - failwith (sprintf "Name.parse: invalid length %d" size) - else - List.rev name, (base,buf) + if size > 255 then failwith (sprintf "Name.parse: invalid length %d" size) + else (List.rev name, (base, buf)) -let marshal ?(compress=true) names base buf name = +let marshal ?(compress = true) names base buf name = let not_compressed names base buf name = let base, buf = - List.fold_left (fun (base,buf) label -> - let label,llen = charstr label in - Cstruct.blit_from_string label 0 buf 0 llen; - base+llen, Cstruct.shift buf llen - ) (base, buf) name - in names, base+1, Cstruct.shift buf 1 + List.fold_left + (fun (base, buf) label -> + let label, llen = charstr label in + Cstruct.blit_from_string label 0 buf 0 llen; + (base + llen, Cstruct.shift buf llen)) + (base, buf) name + in + (names, base + 1, Cstruct.shift buf 1) in let compressed names base buf name = - let pointer o = ((0b11_l <|< 14) +++ (Int32.of_int o)) |> Int32.to_int in + let pointer o = (0b11_l <|< 14) +++ Int32.of_int o |> Int32.to_int in - let lookup names n = - try Some (Map.find n names) - with Not_found -> None - in + let lookup names n = try Some (Map.find n names) with Not_found -> None in let rec aux names offset labels = match lookup names labels with - | None -> - (match labels with - | [] -> - Cstruct.set_uint8 buf offset 0; - names, offset+1 - - | (hd :: tl) as ls -> - let names = Map.add ls (base+offset) names in - let label, llen = charstr hd in - Cstruct.blit_from_string label 0 buf offset llen; - aux names (offset+llen) tl - ) - - | Some o -> - Cstruct.BE.set_uint16 buf offset (pointer o); - names, offset+2 + | None -> ( + match labels with + | [] -> + Cstruct.set_uint8 buf offset 0; + (names, offset + 1) + | hd :: tl as ls -> + let names = Map.add ls (base + offset) names in + let label, llen = charstr hd in + Cstruct.blit_from_string label 0 buf offset llen; + aux names (offset + llen) tl) + | Some o -> + Cstruct.BE.set_uint16 buf offset (pointer o); + (names, offset + 2) in let names, offset = aux names 0 name in - names, (base+offset), Cstruct.shift buf offset + (names, base + offset, Cstruct.shift buf offset) in if compress then compressed names base buf name else not_compressed names base buf name @@ -168,10 +169,8 @@ let to_key domain_name = let check s = if String.contains s '\000' then raise (BadDomainName "contains null character"); - if String.length s = 0 then - raise (BadDomainName "zero-length label"); - if String.length s > 63 then - raise (BadDomainName ("label too long: " ^ s)) + if String.length s = 0 then raise (BadDomainName "zero-length label"); + if String.length s > 63 then raise (BadDomainName ("label too long: " ^ s)) in List.iter check domain_name; String.concat "\000" (List.rev_map String.lowercase_ascii domain_name) @@ -181,13 +180,9 @@ let dnssec_compare a b = | [], [] -> 0 | [], _ -> -1 | _, [] -> 1 - | a::a_tl, b::b_tl -> - if (String.compare a b = 0) then - compare a_tl b_tl - else - ( if (String.length a) = (String.length b) then - String.compare a b - else - compare (String.length a) (String.length b) - ) + | a :: a_tl, b :: b_tl -> + if String.compare a b = 0 then compare a_tl b_tl + else if String.length a = String.length b then String.compare a b + else compare (String.length a) (String.length b) + let dnssec_compare_str = dnssec_compare File "src/forwarder/multiplexer.ml", line 1, characters 0-0: diff --git a/_build/default/src/forwarder/multiplexer.ml b/_build/default/src/forwarder/.formatted/multiplexer.ml index 5d49217..70da37c 100644 --- a/_build/default/src/forwarder/multiplexer.ml +++ b/_build/default/src/forwarder/.formatted/multiplexer.ml @@ -1,20 +1,19 @@ let src = let src = Logs.Src.create "multiplexer" ~doc:"multiplex flows" in - Logs.Src.set_level src (Some Logs.Info) ; + Logs.Src.set_level src (Some Logs.Info); src module Log = (val Logs.src_log src : Logs.LOG) module Make (Flow : Mirage_flow.S) = struct module Window = struct - type t = - { mutable current_seq: int64 - ; (* highest sequence number read *) - mutable allowed_seq: int64 - (* other end is allowed to write *) } - - let create () = {current_seq= 0L; allowed_seq= 0L} + type t = { + mutable current_seq : int64; + (* highest sequence number read *) + mutable allowed_seq : int64; (* other end is allowed to write *) + } + let create () = { current_seq = 0L; allowed_seq = 0L } let size t = Int64.(to_int @@ sub t.allowed_seq t.current_seq) (* Advertise more window if there is buffer space available *) @@ -26,39 +25,41 @@ module Make (Flow : Mirage_flow.S) = struct let new_allowed_seq = Int64.(add t.current_seq (of_int max_buffer_size)) in - t.allowed_seq <- new_allowed_seq ; - Some new_allowed_seq ) + t.allowed_seq <- new_allowed_seq; + Some new_allowed_seq) else None let receive t new_allowed_seq = t.allowed_seq <- new_allowed_seq - let advance t by = t.current_seq <- Int64.(add t.current_seq (of_int by)) end module Subflow = struct - type t = - { read: Window.t - ; write: Window.t - ; mutable incoming: Cstruct.t list - ; mutable incoming_shutdown: bool - ; incoming_c: unit Lwt_condition.t - ; write_c: unit Lwt_condition.t - ; mutable close_sent: bool - ; mutable close_received: bool - ; mutable shutdown_sent: bool - ; mutable ref_count: int } + type t = { + read : Window.t; + write : Window.t; + mutable incoming : Cstruct.t list; + mutable incoming_shutdown : bool; + incoming_c : unit Lwt_condition.t; + write_c : unit Lwt_condition.t; + mutable close_sent : bool; + mutable close_received : bool; + mutable shutdown_sent : bool; + mutable ref_count : int; + } let create () = - { read= Window.create () - ; write= Window.create () - ; incoming= [] - ; incoming_shutdown= false - ; incoming_c= Lwt_condition.create () - ; write_c= Lwt_condition.create () - ; close_sent= false - ; close_received= false - ; shutdown_sent= false - ; ref_count= 2 (* sender + receiver *) } + { + read = Window.create (); + write = Window.create (); + incoming = []; + incoming_shutdown = false; + incoming_c = Lwt_condition.create (); + write_c = Lwt_condition.create (); + close_sent = false; + close_received = false; + shutdown_sent = false; + ref_count = 2 (* sender + receiver *); + } end module C = Mirage_channel.Make (Flow) @@ -67,48 +68,46 @@ module Make (Flow : Mirage_flow.S) = struct open Lwt.Infix - type outer = - { label: string - ; (* for debug logging *) - channel: C.t - ; flow: Flow.flow - ; m: Lwt_mutex.t - ; (* held when writing frames *) - subflows: (int32, Subflow.t) Hashtbl.t - ; mutable next_subflowid: int32 - ; max_buffer_size: int - ; mutable running: bool } + type outer = { + label : string; + (* for debug logging *) + channel : C.t; + flow : Flow.flow; + m : Lwt_mutex.t; + (* held when writing frames *) + subflows : (int32, Subflow.t) Hashtbl.t; + mutable next_subflowid : int32; + max_buffer_size : int; + mutable running : bool; + } (* When the refcount goes to 0 i.e. when both the sender and receiver side have sent Close, then we can mark the id as free. *) let decr_refcount outer id = - if Hashtbl.mem outer.subflows id then begin + if Hashtbl.mem outer.subflows id then let flow = Hashtbl.find outer.subflows id in - if flow.ref_count = 1 then begin - Log.debug (fun f -> f "%s: forgetting flow %ld" outer.label id) ; - Hashtbl.remove outer.subflows id - end else begin - flow.ref_count <- flow.ref_count - 1 - end - end + if flow.ref_count = 1 then ( + Log.debug (fun f -> f "%s: forgetting flow %ld" outer.label id); + Hashtbl.remove outer.subflows id) + else flow.ref_count <- flow.ref_count - 1 let send outer frame = - Log.debug (fun f -> f "%s: send %s" outer.label (Frame.to_string frame)) ; + Log.debug (fun f -> f "%s: send %s" outer.label (Frame.to_string frame)); let buf = Cstruct.create @@ Frame.sizeof frame in let header = Frame.write frame buf in C.write_buffer outer.channel header let flush outer = Lwt_mutex.with_lock outer.m (fun () -> - C.flush outer.channel - >>= function - | Ok () -> Lwt.return_unit | Error _ -> Lwt.fail Multiplexer_failed ) + C.flush outer.channel >>= function + | Ok () -> Lwt.return_unit + | Error _ -> Lwt.fail Multiplexer_failed) >>= fun () -> - Log.debug (fun f -> f "%s: flushed" outer.label) ; + Log.debug (fun f -> f "%s: flushed" outer.label); Lwt.return_unit module Channel = struct - type channel = {outer: outer; id: int32; subflow: Subflow.t} + type channel = { outer : outer; id : int32; subflow : Subflow.t } let send_window_update channel = match @@ -117,16 +116,14 @@ module Make (Flow : Mirage_flow.S) = struct with | None -> Lwt.return_unit | Some seq -> - send channel.outer Frame.{command= Window seq; id= channel.id}; + send channel.outer Frame.{ command = Window seq; id = channel.id }; flush channel.outer let create outer id = let subflow = Subflow.create () in - Hashtbl.add outer.subflows id subflow ; - let channel = {outer; id; subflow} in - send_window_update channel - >>= fun () -> - Lwt.return channel + Hashtbl.add outer.subflows id subflow; + let channel = { outer; id; subflow } in + send_window_update channel >>= fun () -> Lwt.return channel let connect outer destination = let find_free_flowid outer = @@ -135,42 +132,39 @@ module Make (Flow : Mirage_flow.S) = struct else from in let id = loop outer.next_subflowid in - outer.next_subflowid <- Int32.succ id ; + outer.next_subflowid <- Int32.succ id; id in let id = find_free_flowid outer in - send outer Frame.{command= Open (Multiplexed, destination); id} ; + send outer Frame.{ command = Open (Multiplexed, destination); id }; create outer id let is_read_eof channel = - false - || channel.subflow.Subflow.incoming_shutdown + false || channel.subflow.Subflow.incoming_shutdown || channel.subflow.Subflow.close_received let rec read_into channel buf = let rec wait () = match channel.subflow.Subflow.incoming with | [] -> - if is_read_eof channel - then Lwt.return (Ok `Eof) + if is_read_eof channel then Lwt.return (Ok `Eof) else Lwt_condition.wait channel.subflow.Subflow.incoming_c >>= fun () -> wait () | first :: rest -> - let num_from_first = min (Cstruct.length first) (Cstruct.length buf) in + let num_from_first = + min (Cstruct.length first) (Cstruct.length buf) + in Cstruct.blit first 0 buf 0 num_from_first; let buf = Cstruct.shift buf num_from_first in let first = Cstruct.shift first num_from_first in Window.advance channel.subflow.Subflow.read num_from_first; - (channel.subflow).Subflow.incoming <- - if Cstruct.length first = 0 - then rest - else first :: rest; - if Cstruct.length buf = 0 then begin - send_window_update channel - >>= fun () -> + channel.subflow.Subflow.incoming <- + (if Cstruct.length first = 0 then rest else first :: rest); + if Cstruct.length buf = 0 then + send_window_update channel >>= fun () -> Lwt.return (Ok (`Data ())) - end else read_into channel buf + else read_into channel buf in wait () @@ -178,23 +172,21 @@ module Make (Flow : Mirage_flow.S) = struct let rec wait () = match channel.subflow.Subflow.incoming with | [] -> - if is_read_eof channel - then Lwt.return (Ok `Eof) + if is_read_eof channel then Lwt.return (Ok `Eof) else Lwt_condition.wait channel.subflow.Subflow.incoming_c >>= fun () -> wait () | bufs -> - (channel.subflow).Subflow.incoming <- [] ; + channel.subflow.Subflow.incoming <- []; let len = List.fold_left ( + ) 0 (List.map Cstruct.length bufs) in - Window.advance channel.subflow.Subflow.read len ; - send_window_update channel - >>= fun () -> Lwt.return (Ok (`Data (Cstruct.concat bufs))) + Window.advance channel.subflow.Subflow.read len; + send_window_update channel >>= fun () -> + Lwt.return (Ok (`Data (Cstruct.concat bufs))) in wait () let is_write_eof channel = - false - || channel.subflow.Subflow.close_received + false || channel.subflow.Subflow.close_received || channel.subflow.Subflow.close_sent || channel.subflow.Subflow.shutdown_sent @@ -205,12 +197,11 @@ module Make (Flow : Mirage_flow.S) = struct Window.size channel.subflow.Subflow.write = 0 && not (is_write_eof channel) then - Lwt_condition.wait channel.subflow.Subflow.write_c - >>= fun () -> wait () + Lwt_condition.wait channel.subflow.Subflow.write_c >>= fun () -> + wait () else Lwt.return_unit in - wait () - >>= fun () -> + wait () >>= fun () -> if is_write_eof channel then Lwt.return `Eof else let len = Window.size channel.subflow.Subflow.write in @@ -224,53 +215,46 @@ module Make (Flow : Mirage_flow.S) = struct It has to be able to cope with unexpected Data. *) send channel.outer Frame. - { command= Data (Int32.of_int (Cstruct.length buf)) - ; id= channel.id } ; - C.write_buffer channel.outer.channel buf ) - to_send ; - flush channel.outer - >>= fun () -> + { + command = Data (Int32.of_int (Cstruct.length buf)); + id = channel.id; + }; + C.write_buffer channel.outer.channel buf) + to_send; + flush channel.outer >>= fun () -> if remaining = [] then Lwt.return `Ok else loop remaining in - loop bufs - >>= fun _ -> + loop bufs >>= fun _ -> (* FIXME: consider `Eof *) Lwt.return (Ok ()) let shutdown_write channel = (* Avoid sending Shutdown twice or sending a shutdown after a Close *) - if is_write_eof channel - then Lwt.return_unit - else begin + if is_write_eof channel then Lwt.return_unit + else ( channel.subflow.Subflow.shutdown_sent <- true; - send channel.outer Frame.{command= Shutdown; id= channel.id} ; - flush channel.outer - end + send channel.outer Frame.{ command = Shutdown; id = channel.id }; + flush channel.outer) let close channel = (* Don't send Close more than once *) - if channel.subflow.Subflow.close_sent - then Lwt.return_unit - else begin - (channel.subflow).Subflow.close_sent <- true ; - send channel.outer Frame.{command= Close; id= channel.id} ; - decr_refcount channel.outer channel.id ; - flush channel.outer - end + if channel.subflow.Subflow.close_sent then Lwt.return_unit + else ( + channel.subflow.Subflow.close_sent <- true; + send channel.outer Frame.{ command = Close; id = channel.id }; + decr_refcount channel.outer channel.id; + flush channel.outer) (* boilerplate: *) let shutdown_read _chanel = Lwt.return_unit - - let write channel buf = writev channel [buf] + let write channel buf = writev channel [ buf ] type flow = channel let pp_error = Flow.pp_error - let pp_write_error = Flow.pp_write_error type error = Flow.error - type write_error = Flow.write_error end @@ -287,104 +271,108 @@ module Make (Flow : Mirage_flow.S) = struct let next_subflowid = Int32.max_int in let max_buffer_size = 65536 in let outer = - {label; channel; flow; m; subflows; next_subflowid; max_buffer_size; running = true} + { + label; + channel; + flow; + m; + subflows; + next_subflowid; + max_buffer_size; + running = true; + } in (* Process incoming data, window advertisements *) let handle_one () = - C.read_exactly ~len:2 channel - >>= function + C.read_exactly ~len:2 channel >>= function | Error _ -> - Log.err (fun f -> f "%s: error while reading frame length" label) ; + Log.err (fun f -> f "%s: error while reading frame length" label); Lwt.return false | Ok `Eof -> - Log.err (fun f -> f "%s: EOF reading frame length" label) ; + Log.err (fun f -> f "%s: EOF reading frame length" label); Lwt.return false | Ok (`Data bufs) -> ( let buf = Cstruct.concat bufs in let len = Cstruct.LE.get_uint16 buf 0 in - C.read_exactly ~len:(len - 2) channel - >>= function + C.read_exactly ~len:(len - 2) channel >>= function | Error _ -> Log.err (fun f -> - f "%s: error while reading frame header (length %d)" label - len ) ; + f "%s: error while reading frame header (length %d)" label len); Lwt.return false | Ok `Eof -> Log.err (fun f -> - f "%s: EOF reading frame header (length %d)" label len ) ; + f "%s: EOF reading frame header (length %d)" label len); Lwt.return false | Ok (`Data rest) -> ( let header = Cstruct.concat (bufs @ rest) in try let open Frame in let frame = read header in - Log.debug (fun f -> f "%s: recv %s" label (to_string frame)) ; + Log.debug (fun f -> f "%s: recv %s" label (to_string frame)); match frame.command with | Open (Dedicated, _) -> Lwt.fail_with "dispatcher lacks support for dedicated mode" | Open (Multiplexed, destination) -> - Channel.create outer frame.id - >>= fun channel -> - Lwt.async (fun () -> listen_cb channel destination) ; + Channel.create outer frame.id >>= fun channel -> + Lwt.async (fun () -> listen_cb channel destination); Lwt.return true | Close -> let subflow = Hashtbl.find subflows frame.id in - subflow.Subflow.close_received <- true ; + subflow.Subflow.close_received <- true; (* Unblock any waiting read *) - Lwt_condition.signal subflow.incoming_c () ; + Lwt_condition.signal subflow.incoming_c (); (* Unblock any waiting write *) - Lwt_condition.signal subflow.write_c () ; - decr_refcount outer frame.id ; + Lwt_condition.signal subflow.write_c (); + decr_refcount outer frame.id; Lwt.return true | Shutdown -> let subflow = Hashtbl.find subflows frame.id in - subflow.Subflow.incoming_shutdown <- true ; + subflow.Subflow.incoming_shutdown <- true; (* Unblock any waiting read *) - Lwt_condition.signal subflow.incoming_c () ; + Lwt_condition.signal subflow.incoming_c (); Lwt.return true | Data len -> ( let subflow = Hashtbl.find subflows frame.id in let len = Int32.to_int len in - C.read_exactly ~len channel - >>= function + C.read_exactly ~len channel >>= function | Error _ -> Log.err (fun f -> f "%s: error while reading payload (length %d)" - label len ) ; + label len); Lwt.return false | Ok `Eof -> Log.err (fun f -> f "%s: EOF while reading payload (length %d)" label - len ) ; + len); Lwt.return false | Ok (`Data bufs) -> - subflow.Subflow.incoming - <- subflow.Subflow.incoming @ bufs ; + subflow.Subflow.incoming <- + subflow.Subflow.incoming @ bufs; (* Unblock any waiting read *) - Lwt_condition.signal subflow.incoming_c () ; - Lwt.return true ) + Lwt_condition.signal subflow.incoming_c (); + Lwt.return true) | Window seq -> let subflow = Hashtbl.find subflows frame.id in - Window.receive subflow.Subflow.write seq ; + Window.receive subflow.Subflow.write seq; (* Unblock any waiting write *) - Lwt_condition.signal subflow.write_c () ; + Lwt_condition.signal subflow.write_c (); Lwt.return true with e -> Log.err (fun f -> f "%s: error handling frame: %s" label - (Printexc.to_string e) ) ; - Lwt.return false ) ) + (Printexc.to_string e)); + Lwt.return false)) in let rec dispatcher () = - handle_one () - >>= function + handle_one () >>= function | false -> - Log.err (fun f -> f "%s: dispatcher shutting down" label) ; + Log.err (fun f -> f "%s: dispatcher shutting down" label); outer.running <- false; Lwt.return_unit | true -> dispatcher () in - Lwt.async dispatcher ; outer + Lwt.async dispatcher; + outer let disconnect m = Flow.close m.flow end File "src/dns_forward/dns_forward_cache.mli", line 1, characters 0-0: diff --git a/_build/default/src/dns_forward/dns_forward_cache.mli b/_build/default/src/dns_forward/.formatted/dns_forward_cache.mli index 504e902..8bee3e5 100644 --- a/_build/default/src/dns_forward/dns_forward_cache.mli +++ b/_build/default/src/dns_forward/.formatted/dns_forward_cache.mli @@ -15,21 +15,30 @@ * *) -module Make(Time: Mirage_time.S): sig +module Make (Time : Mirage_time.S) : sig type t (** A cache of DNS answers *) - val make: ?max_bindings:int -> unit -> t + val make : ?max_bindings:int -> unit -> t (** Create an empty cache. If [?max_bindings] is provided then the cache will not contain more than the given number of bindings. *) - val destroy: t -> unit + val destroy : t -> unit (** Destroy the cache and free associated resources *) - val answer: t -> Dns_forward_config.Address.t -> Dns.Packet.question -> Dns.Packet.rr list option + val answer : + t -> + Dns_forward_config.Address.t -> + Dns.Packet.question -> + Dns.Packet.rr list option (** Look up the answer given by a specific server to a question. Returns None if no answer is cached from that server. *) - val insert: t -> Dns_forward_config.Address.t -> Dns.Packet.question -> Dns.Packet.rr list -> unit + val insert : + t -> + Dns_forward_config.Address.t -> + Dns.Packet.question -> + Dns.Packet.rr list -> + unit (** Insert the answer to the question into the cache *) end File "src/dns_forward/dns_forward_flow.ml", line 1, characters 0-0: diff --git a/_build/default/src/dns_forward/dns_forward_flow.ml b/_build/default/src/dns_forward/.formatted/dns_forward_flow.ml index bf0d68e..a05f331 100644 --- a/_build/default/src/dns_forward/dns_forward_flow.ml +++ b/_build/default/src/dns_forward/.formatted/dns_forward_flow.ml @@ -16,5 +16,4 @@ *) module type Client = Dns_forward_s.FLOW_CLIENT - module type Server = Dns_forward_s.FLOW_SERVER File "src/dns_forward/dns_forward_error.ml", line 1, characters 0-0: diff --git a/_build/default/src/dns_forward/dns_forward_error.ml b/_build/default/src/dns_forward/.formatted/dns_forward_error.ml index 6dd4e0a..e0bb3e6 100644 --- a/_build/default/src/dns_forward/dns_forward_error.ml +++ b/_build/default/src/dns_forward/.formatted/dns_forward_error.ml @@ -20,11 +20,12 @@ type 'a t = ('a, [ `Msg of string ]) Lwt_result.t let errorf fmt = Fmt.kstr (fun s -> Lwt.return (Error (`Msg s))) fmt -module FromFlowError(Flow: Mirage_flow.S) = struct - let (>>=) m f = m >>= function - | `Eof -> errorf "Unexpected end of file" +module FromFlowError (Flow : Mirage_flow.S) = struct + let ( >>= ) m f = + m >>= function + | `Eof -> errorf "Unexpected end of file" | `Error e -> errorf "%a" Flow.pp_error e - | `Ok x -> f x + | `Ok x -> f x end module Infix = Lwt_result.Infix File "src/dns_lwt/dns_resolver.mli", line 1, characters 0-0: diff --git a/_build/default/src/dns_lwt/dns_resolver.mli b/_build/default/src/dns_lwt/.formatted/dns_resolver.mli index 54fc7e1..7a01833 100644 --- a/_build/default/src/dns_lwt/dns_resolver.mli +++ b/_build/default/src/dns_lwt/.formatted/dns_resolver.mli @@ -17,18 +17,15 @@ *) type commfn = { - txfn : Cstruct.t -> unit Lwt.t; - (** [txfn buf] resolves when [buf] has been transmitted. *) - - rxfn : (Cstruct.t -> Dns.Packet.t option) -> Dns.Packet.t Lwt.t; - (** [rxfn parse] resolves to a packet processed by [parse] after it + txfn : Cstruct.t -> unit Lwt.t; + (** [txfn buf] resolves when [buf] has been transmitted. *) + rxfn : (Cstruct.t -> Dns.Packet.t option) -> Dns.Packet.t Lwt.t; + (** [rxfn parse] resolves to a packet processed by [parse] after it has been received. *) - timerfn : unit -> unit Lwt.t; - (** [timerfn ()] resolves when a request should be timed out. *) - + (** [timerfn ()] resolves when a request should be timed out. *) cleanfn : unit -> unit Lwt.t; - (** [cleanfn ()] resolves after any resources used by the rest of + (** [cleanfn ()] resolves after any resources used by the rest of the {!commfn} have been released. *) } (** A [commfn] value describes the means by which datagram @@ -38,7 +35,8 @@ type commfn = { val resolve_pkt : (module Dns.Protocol.CLIENT) -> ?alloc:(unit -> Cstruct.t) -> - commfn -> Dns.Packet.t -> + commfn -> + Dns.Packet.t -> Dns.Packet.t Lwt.t (** [resolve_pkt client ?alloc commfn packet] will attempt resolution of the query contained in [packet] via the protocol client @@ -52,12 +50,13 @@ val resolve_pkt : {!Dns.Protocol.Dns_resolve_error} exception which contains a list of all of the errors encountered during resolution. *) -val resolve : +val resolve : (module Dns.Protocol.CLIENT) -> ?alloc:(unit -> Cstruct.t) -> ?dnssec:bool -> - commfn -> Dns.Packet.q_class -> - Dns.Packet.q_type -> + commfn -> + Dns.Packet.q_class -> + Dns.Packet.q_type -> Dns.Name.t -> Dns.Packet.t Lwt.t (** [resolve client ?alloc ?dnssec commfn q_class q_type name] will @@ -67,11 +66,15 @@ val resolve : val gethostbyname : ?alloc:(unit -> Cstruct.t) -> ?q_class:Dns.Packet.q_class -> - ?q_type:Dns.Packet.q_type -> commfn -> - string -> Ipaddr.t list Lwt.t + ?q_type:Dns.Packet.q_type -> + commfn -> + string -> + Ipaddr.t list Lwt.t val gethostbyaddr : ?alloc:(unit -> Cstruct.t) -> ?q_class:Dns.Packet.q_class -> - ?q_type:Dns.Packet.q_type -> commfn -> - Ipaddr.V4.t -> string list Lwt.t + ?q_type:Dns.Packet.q_type -> + commfn -> + Ipaddr.V4.t -> + string list Lwt.t File "src/dns_forward/dns_forward_flow.mli", line 1, characters 0-0: diff --git a/_build/default/src/dns_forward/dns_forward_flow.mli b/_build/default/src/dns_forward/.formatted/dns_forward_flow.mli index bf0d68e..a05f331 100644 --- a/_build/default/src/dns_forward/dns_forward_flow.mli +++ b/_build/default/src/dns_forward/.formatted/dns_forward_flow.mli @@ -16,5 +16,4 @@ *) module type Client = Dns_forward_s.FLOW_CLIENT - module type Server = Dns_forward_s.FLOW_SERVER File "src/dns_forward/dns_forward_config.mli", line 1, characters 0-0: diff --git a/_build/default/src/dns_forward/dns_forward_config.mli b/_build/default/src/dns_forward/.formatted/dns_forward_config.mli index 7b952a5..fa5b207 100644 --- a/_build/default/src/dns_forward/dns_forward_config.mli +++ b/_build/default/src/dns_forward/.formatted/dns_forward_config.mli @@ -15,53 +15,51 @@ * *) -module Address: sig - type t = { - ip: Ipaddr.t; - port: int; - } - val to_string: t -> string +module Address : sig + type t = { ip : Ipaddr.t; port : int } + + val to_string : t -> string + val compare : t -> t -> int - val compare: t -> t -> int - module Set: Set.S with type elt = t - module Map: Map.S with type key = t + module Set : Set.S with type elt = t + module Map : Map.S with type key = t end -module Domain: sig +module Domain : sig type t = string list - val to_string: t -> string - val compare: t -> t -> int + val to_string : t -> string + val compare : t -> t -> int - module Set: Set.S with type elt = t - module Map: Map.S with type key = t + module Set : Set.S with type elt = t + module Map : Map.S with type key = t end -module Server: sig +module Server : sig type t = { - zones: Domain.Set.t; - address: Address.t; - timeout_ms: int option; - order: int; + zones : Domain.Set.t; + address : Address.t; + timeout_ms : int option; + order : int; } (** A single upstream DNS server *) - val compare: t -> t -> int - module Set: Set.S with type elt = t - module Map: Map.S with type key = t + val compare : t -> t -> int + + module Set : Set.S with type elt = t + module Map : Map.S with type key = t end type t = { - servers: Server.Set.t; - search: string list; - assume_offline_after_drops: int option; + servers : Server.Set.t; + search : string list; + assume_offline_after_drops : int option; } -val of_string: string -> (t, [ `Msg of string ]) result -val to_string: t -> string - -val compare: t -> t -> int +val of_string : string -> (t, [ `Msg of string ]) result +val to_string : t -> string +val compare : t -> t -> int -module Unix: sig - val of_resolv_conf: string -> (t, [ `Msg of string ]) result +module Unix : sig + val of_resolv_conf : string -> (t, [ `Msg of string ]) result end File "src/dns_forward/dns_forward_error.mli", line 1, characters 0-0: diff --git a/_build/default/src/dns_forward/dns_forward_error.mli b/_build/default/src/dns_forward/.formatted/dns_forward_error.mli index 8955a3a..215e787 100644 --- a/_build/default/src/dns_forward/dns_forward_error.mli +++ b/_build/default/src/dns_forward/.formatted/dns_forward_error.mli @@ -17,13 +17,17 @@ type 'a t = ('a, [ `Msg of string ]) Lwt_result.t -module FromFlowError(Flow: Mirage_flow.S): sig - val ( >>= ) : [< `Eof | `Error of Flow.error | `Ok of 'b ] Lwt.t -> - ('b -> ('c, [> `Msg of string ] as 'd) result Lwt.t) -> ('c, 'd) result Lwt.t +module FromFlowError (Flow : Mirage_flow.S) : sig + val ( >>= ) : + [< `Eof | `Error of Flow.error | `Ok of 'b ] Lwt.t -> + ('b -> ('c, ([> `Msg of string ] as 'd)) result Lwt.t) -> + ('c, 'd) result Lwt.t end -val errorf: ('a, Format.formatter, unit, ('b, [> `Msg of string ]) result Lwt.t) format4 -> 'a +val errorf : + ('a, Format.formatter, unit, ('b, [> `Msg of string ]) result Lwt.t) format4 -> + 'a -module Infix: sig +module Infix : sig include module type of Lwt_result.Infix end File "src/dns_forward/dns_forward_framing.mli", line 1, characters 0-0: diff --git a/_build/default/src/dns_forward/dns_forward_framing.mli b/_build/default/src/dns_forward/.formatted/dns_forward_framing.mli index 4d43031..0bbd1f4 100644 --- a/_build/default/src/dns_forward/dns_forward_framing.mli +++ b/_build/default/src/dns_forward/.formatted/dns_forward_framing.mli @@ -17,12 +17,10 @@ module type S = Dns_forward_s.READERWRITER -module Tcp(Flow: Mirage_flow.S): sig - include Dns_forward_s.READERWRITER - with type flow = Flow.flow +module Tcp (Flow : Mirage_flow.S) : sig + include Dns_forward_s.READERWRITER with type flow = Flow.flow end -module Udp(Flow: Mirage_flow.S): sig - include Dns_forward_s.READERWRITER - with type flow = Flow.flow +module Udp (Flow : Mirage_flow.S) : sig + include Dns_forward_s.READERWRITER with type flow = Flow.flow end File "src/dns_forward/dns_forward_free_id.ml", line 1, characters 0-0: diff --git a/_build/default/src/dns_forward/dns_forward_free_id.ml b/_build/default/src/dns_forward/.formatted/dns_forward_free_id.ml index a5f3b6a..52aa165 100644 --- a/_build/default/src/dns_forward/dns_forward_free_id.ml +++ b/_build/default/src/dns_forward/.formatted/dns_forward_free_id.ml @@ -15,17 +15,21 @@ * *) -module IntSet = Set.Make(struct type t = int let compare (a: int) (b: int) = compare a b end) +module IntSet = Set.Make (struct + type t = int + + let compare (a : int) (b : int) = compare a b +end) (* track the ids in use to - avoid accidental re-use - limit the total number of simultaneous upstream requests *) type t = { - mutable used_ids: IntSet.t; (* used by in-progress requests *) - max_elements: int; (* bound on the number of in-progress requests *) - free_ids_c: unit Lwt_condition.t; - g: int -> int; (* generate unpredictable id *) + mutable used_ids : IntSet.t; (* used by in-progress requests *) + max_elements : int; (* bound on the number of in-progress requests *) + free_ids_c : unit Lwt_condition.t; + g : int -> int; (* generate unpredictable id *) } let make ~g ?(max_elements = 512) () = @@ -35,25 +39,20 @@ let make ~g ?(max_elements = 512) () = let rec with_id t f = let open Lwt.Infix in - if IntSet.cardinal t.used_ids = t.max_elements then begin - Lwt_condition.wait t.free_ids_c - >>= fun () -> - with_id t f - end else begin + if IntSet.cardinal t.used_ids = t.max_elements then + Lwt_condition.wait t.free_ids_c >>= fun () -> with_id t f + else let rec find_free_id () = (* [gen n] picks a value in the interval [0, n-1]. DNS transaction ids are between [0, 0xffff] *) let id = t.g 0x10000 in - if IntSet.mem id t.used_ids - then find_free_id () - else id in + if IntSet.mem id t.used_ids then find_free_id () else id + in let free_id = find_free_id () in t.used_ids <- IntSet.add free_id t.used_ids; Lwt.finalize - (fun () -> f free_id) - (fun () -> - t.used_ids <- IntSet.remove free_id t.used_ids; - Lwt_condition.signal t.free_ids_c (); - Lwt.return_unit - ) - end + (fun () -> f free_id) + (fun () -> + t.used_ids <- IntSet.remove free_id t.used_ids; + Lwt_condition.signal t.free_ids_c (); + Lwt.return_unit) File "src/dns_forward/dns_forward_free_id.mli", line 1, characters 0-0: diff --git a/_build/default/src/dns_forward/dns_forward_free_id.mli b/_build/default/src/dns_forward/.formatted/dns_forward_free_id.mli index 2e304fd..8f255aa 100644 --- a/_build/default/src/dns_forward/dns_forward_free_id.mli +++ b/_build/default/src/dns_forward/.formatted/dns_forward_free_id.mli @@ -18,9 +18,9 @@ type t (** A finite set of free integer ids *) -val make: g:(int -> int) -> ?max_elements:int -> unit -> t +val make : g:(int -> int) -> ?max_elements:int -> unit -> t (** Construct a free set with the given maximum number of elements and a function for generating unpredictable integers *) -val with_id: t -> (int -> 'a Lwt.t) -> 'a Lwt.t +val with_id : t -> (int -> 'a Lwt.t) -> 'a Lwt.t (** [with_id t f] waits for an id to become free and then calls [f id] with it *) File "src/dns_forward/dns_forward_resolver.mli", line 1, characters 0-0: diff --git a/_build/default/src/dns_forward/dns_forward_resolver.mli b/_build/default/src/dns_forward/.formatted/dns_forward_resolver.mli index c958f3a..0b12210 100644 --- a/_build/default/src/dns_forward/dns_forward_resolver.mli +++ b/_build/default/src/dns_forward/.formatted/dns_forward_resolver.mli @@ -18,7 +18,6 @@ module type S = Dns_forward_s.RESOLVER module Make - (Client: Dns_forward_s.RPC_CLIENT) - (Time: Mirage_time.S) - (Clock: Mirage_clock.MCLOCK): - S + (Client : Dns_forward_s.RPC_CLIENT) + (Time : Mirage_time.S) + (Clock : Mirage_clock.MCLOCK) : S File "src/forwarder/frame.ml", line 1, characters 0-0: diff --git a/_build/default/src/forwarder/frame.ml b/_build/default/src/forwarder/.formatted/frame.ml index 4c66f7b..403f9d3 100644 --- a/_build/default/src/forwarder/frame.ml +++ b/_build/default/src/forwarder/.formatted/frame.ml @@ -1,34 +1,23 @@ - module Destination = struct type port = int type path = string - type t = [ - | `Tcp of Ipaddr.t * port - | `Udp of Ipaddr.t * port - | `Unix of path - ] + type t = [ `Tcp of Ipaddr.t * port | `Udp of Ipaddr.t * port | `Unix of path ] let to_string = function - | `Tcp (ip, port) -> - Printf.sprintf "TCP %s:%d" (Ipaddr.to_string ip) port - | `Udp (ip, port) -> - Printf.sprintf "UDP %s:%d" (Ipaddr.to_string ip) port - | `Unix path -> - Printf.sprintf "Unix %s" path + | `Tcp (ip, port) -> Printf.sprintf "TCP %s:%d" (Ipaddr.to_string ip) port + | `Udp (ip, port) -> Printf.sprintf "UDP %s:%d" (Ipaddr.to_string ip) port + | `Unix path -> Printf.sprintf "Unix %s" path let sizeof = function - | `Tcp (ip, _) - | `Udp (ip, _) -> - 1 + 2 + (match ip with Ipaddr.V4 _ -> 4 | Ipaddr.V6 _ -> 16) + 2 - | `Unix path -> - 1 + 2 + (String.length path) + | `Tcp (ip, _) | `Udp (ip, _) -> + 1 + 2 + (match ip with Ipaddr.V4 _ -> 4 | Ipaddr.V6 _ -> 16) + 2 + | `Unix path -> 1 + 2 + String.length path let write t rest = (* Matches the Go definition *) - let proto = match t with - | `Tcp (_, _) -> 1 - | `Udp (_, _) -> 2 - | `Unix _ -> 3 in + let proto = + match t with `Tcp (_, _) -> 1 | `Udp (_, _) -> 2 | `Unix _ -> 3 + in let header = Cstruct.sub rest 0 (sizeof t) in Cstruct.set_uint8 rest 0 proto; let rest = Cstruct.shift header 1 in @@ -36,67 +25,77 @@ module Destination = struct let write_string s buf = Cstruct.LE.set_uint16 buf 0 (String.length s); Cstruct.blit_from_string s 0 buf 2 (String.length s); - Cstruct.shift buf (2 + (String.length s)) in + Cstruct.shift buf (2 + String.length s) + in let write_ip ip buf = - let ip = match ip with + let ip = + match ip with | Ipaddr.V4 ip -> Ipaddr.V4.to_octets ip - | Ipaddr.V6 ip -> Ipaddr.V6.to_octets ip in - write_string ip buf in + | Ipaddr.V6 ip -> Ipaddr.V6.to_octets ip + in + write_string ip buf + in match t with - | `Tcp(ip, port) - | `Udp(ip, port) -> - let rest = write_ip ip rest in - Cstruct.LE.set_uint16 rest 0 port; - header + | `Tcp (ip, port) | `Udp (ip, port) -> + let rest = write_ip ip rest in + Cstruct.LE.set_uint16 rest 0 port; + header | `Unix path -> - let _rest = write_string path rest in - header + let _rest = write_string path rest in + header let read buf = - let read_string (rest: Cstruct.t) = + let read_string (rest : Cstruct.t) = let str_len : int = Cstruct.LE.get_uint16 rest 0 in let str = Cstruct.(to_string (sub rest 2 str_len)) in - str, Cstruct.shift rest (2 + str_len) in + (str, Cstruct.shift rest (2 + str_len)) + in let read_ip rest = let str, rest = read_string rest in match String.length str with - | 4 -> Ipaddr.V4 (Ipaddr.V4.of_octets_exn @@ str), rest - | 16 -> Ipaddr.V6 (Ipaddr.V6.of_octets_exn @@ str), rest - | _ -> failwith (Printf.sprintf "Failed to parse IP address of length %d: %s" (String.length str) (String.escaped str)) in + | 4 -> (Ipaddr.V4 (Ipaddr.V4.of_octets_exn @@ str), rest) + | 16 -> (Ipaddr.V6 (Ipaddr.V6.of_octets_exn @@ str), rest) + | _ -> + failwith + (Printf.sprintf "Failed to parse IP address of length %d: %s" + (String.length str) (String.escaped str)) + in let rest = Cstruct.shift buf 1 in match Cstruct.get_uint8 buf 0 with | 1 -> - let ip, rest = read_ip rest in - let port = Cstruct.LE.get_uint16 rest 0 in - `Tcp (ip, port) + let ip, rest = read_ip rest in + let port = Cstruct.LE.get_uint16 rest 0 in + `Tcp (ip, port) | 2 -> - let ip, rest = read_ip rest in - let port = Cstruct.LE.get_uint16 rest 0 in - `Udp (ip, port) + let ip, rest = read_ip rest in + let port = Cstruct.LE.get_uint16 rest 0 in + `Udp (ip, port) | 3 -> - let path, _ = read_string rest in - `Unix path - | x -> - failwith (Printf.sprintf "Unknown Destination protocol: %d" x) - + let path, _ = read_string rest in + `Unix path + | x -> failwith (Printf.sprintf "Unknown Destination protocol: %d" x) end module Udp = struct - type t = { - ip: Ipaddr.t; - port: int; - payload_length: int; - } + type t = { ip : Ipaddr.t; port : int; payload_length : int } + let max_sizeof = - 2 + (* length of frame *) - 2 + (* length of IP *) - 16 + (* IPv6 *) - 2 + (* port *) - 2 + (* length of Zone, which is "" *) - 2 (* length of payload length *) + 2 + + (* length of frame *) + 2 + + (* length of IP *) + 16 + + (* IPv6 *) + 2 + + (* port *) + 2 + + (* length of Zone, which is "" *) + 2 + (* length of payload length *) + let write_header t buf = (* Leave space for a uint16 frame length *) let rest = Cstruct.shift buf 2 in @@ -139,8 +138,8 @@ module Udp = struct let rest = Cstruct.shift rest (2 + ip_bytes_len) in let ip = let open Ipaddr in - if String.length ip_bytes_string = 4 - then V4 (V4.of_octets_exn ip_bytes_string) + if String.length ip_bytes_string = 4 then + V4 (V4.of_octets_exn ip_bytes_string) else V6 (Ipaddr.V6.of_octets_exn ip_bytes_string) in (* uint16 Port *) @@ -153,12 +152,10 @@ module Udp = struct let payload_length = Cstruct.LE.get_uint16 rest 0 in (* payload *) let payload = Cstruct.sub rest 2 payload_length in - { ip; port; payload_length }, payload + ({ ip; port; payload_length }, payload) end -type connection = - | Dedicated - | Multiplexed +type connection = Dedicated | Multiplexed let string_of_connection = function | Dedicated -> "Dedicated" @@ -172,47 +169,49 @@ type command = | Window of int64 let string_of_command = function - | Open(connection, destination) -> Printf.sprintf "Open(%s, %s)" (string_of_connection connection) (Destination.to_string destination) + | Open (connection, destination) -> + Printf.sprintf "Open(%s, %s)" + (string_of_connection connection) + (Destination.to_string destination) | Close -> "Close" | Shutdown -> "Shutdown" | Data len -> Printf.sprintf "Data length = %ld" len | Window seq -> Printf.sprintf "Window seq = %Ld" seq -type t = { - command: command; - id: int32; -} +type t = { command : command; id : int32 } let to_string { command; id } = - Printf.sprintf "Frame { command = %s; id = %ld }" (string_of_command command) id - -let sizeof t = match t.command with - | Open (_, d) -> 2 + 1 + 4 + 1 + (Destination.sizeof d) - | Close - | Shutdown -> 2 + 1 + 4 + Printf.sprintf "Frame { command = %s; id = %ld }" + (string_of_command command) + id + +let sizeof t = + match t.command with + | Open (_, d) -> 2 + 1 + 4 + 1 + Destination.sizeof d + | Close | Shutdown -> 2 + 1 + 4 | Data _ -> 2 + 1 + 4 + 4 | Window _ -> 2 + 1 + 4 + 8 let write t buf = Cstruct.LE.set_uint16 buf 0 (sizeof t); Cstruct.LE.set_uint32 buf 3 t.id; - begin match t.command with + (match t.command with | Open (connection, destination) -> - Cstruct.set_uint8 buf 2 1; - Cstruct.set_uint8 buf 7 (match connection with Dedicated -> 1 | Multiplexed -> 2); - let (_: Cstruct.t) = Destination.write destination (Cstruct.shift buf 8) in - () - | Close-> - Cstruct.set_uint8 buf 2 2 - | Shutdown-> - Cstruct.set_uint8 buf 2 3 + Cstruct.set_uint8 buf 2 1; + Cstruct.set_uint8 buf 7 + (match connection with Dedicated -> 1 | Multiplexed -> 2); + let (_ : Cstruct.t) = + Destination.write destination (Cstruct.shift buf 8) + in + () + | Close -> Cstruct.set_uint8 buf 2 2 + | Shutdown -> Cstruct.set_uint8 buf 2 3 | Data payloadlen -> - Cstruct.set_uint8 buf 2 4; - Cstruct.LE.set_uint32 buf 7 payloadlen + Cstruct.set_uint8 buf 2 4; + Cstruct.LE.set_uint32 buf 7 payloadlen | Window seq -> - Cstruct.set_uint8 buf 2 5; - Cstruct.LE.set_uint64 buf 7 seq - end; + Cstruct.set_uint8 buf 2 5; + Cstruct.LE.set_uint64 buf 7 seq); Cstruct.sub buf 0 (sizeof t) let read buf = @@ -220,20 +219,20 @@ let read buf = let id = Cstruct.LE.get_uint32 buf 3 in match Cstruct.get_uint8 buf 2 with | 1 -> - let connection = match Cstruct.get_uint8 buf 7 with - | 1 -> Dedicated - | 2 -> Multiplexed - | x -> failwith (Printf.sprintf "Unknown connection type: %d" x) in - let destination = Destination.read (Cstruct.shift buf 8) in - { command = Open(connection, destination); id } - | 2 -> - { command = Close; id } - | 3 -> - { command = Shutdown; id } + let connection = + match Cstruct.get_uint8 buf 7 with + | 1 -> Dedicated + | 2 -> Multiplexed + | x -> failwith (Printf.sprintf "Unknown connection type: %d" x) + in + let destination = Destination.read (Cstruct.shift buf 8) in + { command = Open (connection, destination); id } + | 2 -> { command = Close; id } + | 3 -> { command = Shutdown; id } | 4 -> - let payloadlen = Cstruct.LE.get_uint32 buf 7 in - { command = Data payloadlen; id } + let payloadlen = Cstruct.LE.get_uint32 buf 7 in + { command = Data payloadlen; id } | 5 -> - let seq = Cstruct.LE.get_uint64 buf 7 in - { command = Window seq; id } + let seq = Cstruct.LE.get_uint64 buf 7 in + { command = Window seq; id } | x -> failwith (Printf.sprintf "Unknown command type: %d" x) File "src/dns_forward/dns_forward_rpc.mli", line 1, characters 0-0: diff --git a/_build/default/src/dns_forward/dns_forward_rpc.mli b/_build/default/src/dns_forward/.formatted/dns_forward_rpc.mli index c378a39..75659ed 100644 --- a/_build/default/src/dns_forward/dns_forward_rpc.mli +++ b/_build/default/src/dns_forward/.formatted/dns_forward_rpc.mli @@ -17,31 +17,29 @@ (** Implement the client and server DNS RPC protocol*) -module Client: sig +module Client : sig module type S = Dns_forward_s.RPC_CLIENT - module Persistent: sig + module Persistent : sig module Make - (Flow: Dns_forward_s.FLOW_CLIENT with type address = Ipaddr.t * int) - (Framing: Dns_forward_s.READERWRITER with type flow = Flow.flow) - (Time: Mirage_time.S): - S + (Flow : Dns_forward_s.FLOW_CLIENT with type address = Ipaddr.t * int) + (Framing : Dns_forward_s.READERWRITER with type flow = Flow.flow) + (Time : Mirage_time.S) : S end - module Nonpersistent: sig + + module Nonpersistent : sig module Make - (Flow: Dns_forward_s.FLOW_CLIENT with type address = Ipaddr.t * int) - (Framing: Dns_forward_s.READERWRITER with type flow = Flow.flow) - (Time: Mirage_time.S): - S + (Flow : Dns_forward_s.FLOW_CLIENT with type address = Ipaddr.t * int) + (Framing : Dns_forward_s.READERWRITER with type flow = Flow.flow) + (Time : Mirage_time.S) : S end end -module Server: sig +module Server : sig module type S = Dns_forward_s.RPC_SERVER module Make - (Flow: Dns_forward_s.FLOW_SERVER with type address = Ipaddr.t * int) - (Framing: Dns_forward_s.READERWRITER with type flow = Flow.flow) - (Time: Mirage_time.S): - S + (Flow : Dns_forward_s.FLOW_SERVER with type address = Ipaddr.t * int) + (Framing : Dns_forward_s.READERWRITER with type flow = Flow.flow) + (Time : Mirage_time.S) : S end File "src/dns_forward/dns_forward_server.mli", line 1, characters 0-0: diff --git a/_build/default/src/dns_forward/dns_forward_server.mli b/_build/default/src/dns_forward/.formatted/dns_forward_server.mli index 2cab73a..c3909bd 100644 --- a/_build/default/src/dns_forward/dns_forward_server.mli +++ b/_build/default/src/dns_forward/.formatted/dns_forward_server.mli @@ -17,4 +17,6 @@ module type S = Dns_forward_s.SERVER -module Make(Server: Dns_forward_s.RPC_SERVER)(Resolver: Dns_forward_s.RESOLVER): S with type resolver = Resolver.t +module Make + (Server : Dns_forward_s.RPC_SERVER) + (Resolver : Dns_forward_s.RESOLVER) : S with type resolver = Resolver.t ocamlformat: ignoring "src/dns/packet.ml" (misplaced documentation comments - warning 50) File "src/dns/packet.ml", line 910, characters 2-60: 910 | (** Drop remainder of buf to stop parsing and demuxing. *) ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Warning 50 [unexpected-docstring]: unattached documentation comment (ignored) File "src/dns/packet.ml", lines 912-913, characters 2-18: 912 | ..(** Extract (length, string) encoded strings, with remainder for 913 | chaining. *) Warning 50 [unexpected-docstring]: unattached documentation comment (ignored) File "src/dns/packet.ml", line 1530, characters 2-48: 1530 | (** Map name (list of labels) to an offset. *) ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Warning 50 [unexpected-docstring]: unattached documentation comment (ignored) Hint: (Warning 50) This file contains a documentation comment (** ... *) that the OCaml compiler does not know how to attach to the AST. OCamlformat does not support these cases. You can find more information at: https://github.com/ocaml-ppx/ocamlformat#overview. If you'd like to disable this check and let ocamlformat make a choice (though it might not be consistent with the ocaml compilers and odoc), you can set the --no-comment-check option. -> required by _build/default/src/dns/.formatted/packet.ml -> required by alias src/dns/.formatted/fmt -> required by alias src/dns/fmt File "src/dns_mirage/dune", line 1, characters 0-0: diff --git a/_build/default/src/dns_mirage/dune b/_build/default/src/dns_mirage/.formatted/dune index 88901b3..39f04c9 100644 --- a/_build/default/src/dns_mirage/dune +++ b/_build/default/src/dns_mirage/.formatted/dune @@ -1,4 +1,4 @@ (library - (name mirage_dns) - (libraries dns_lwt duration mirage-time mirage-stack mirage-kv) - (wrapped false)) + (name mirage_dns) + (libraries dns_lwt duration mirage-time mirage-stack mirage-kv) + (wrapped false)) File "src/dns_test/dune", line 1, characters 0-0: diff --git a/_build/default/src/dns_test/dune b/_build/default/src/dns_test/.formatted/dune index 5d22fe0..b7498b6 100644 --- a/_build/default/src/dns_test/dune +++ b/_build/default/src/dns_test/.formatted/dune @@ -1,9 +1,13 @@ (test - (name test) - (libraries dns oUnit pcap-format bigarray bigarray-compat lwt) - (deps (glob_files *.pcap) (glob_files *.zone)) - (preprocess (pps ppx_cstruct))) + (name test) + (libraries dns oUnit pcap-format bigarray bigarray-compat lwt) + (deps + (glob_files *.pcap) + (glob_files *.zone)) + (preprocess + (pps ppx_cstruct))) (rule - (alias runtest) - (action (run ./test.exe))) + (alias runtest) + (action + (run ./test.exe))) File "src/dns/resolvconf.ml", line 1, characters 0-0: diff --git a/_build/default/src/dns/resolvconf.ml b/_build/default/src/dns/.formatted/resolvconf.ml index 685af4a..e398b58 100644 --- a/_build/default/src/dns/resolvconf.ml +++ b/_build/default/src/dns/.formatted/resolvconf.ml @@ -36,96 +36,103 @@ let strip_comments = let ltrim = Re.Str.(replace_first (regexp "^[\t ]+") "") let rtrim = Re.Str.(replace_first (regexp "[\t ]+$") "") let trim x = ltrim (rtrim x) - -let map_line x = - match trim (strip_comments x) with - |"" -> None - |x -> Some x +let map_line x = match trim (strip_comments x) with "" -> None | x -> Some x module LookupValue = struct type t = Bind | File | Yp + exception Unknown of string - let of_string x = match (String.lowercase_ascii x) with - | "bind" -> Bind - | "file" -> File - | "yp" -> Yp - | x -> raise (Unknown x) - let to_string = function - | Bind -> "bind" - | File -> "file" - | Yp -> "yp" + + let of_string x = + match String.lowercase_ascii x with + | "bind" -> Bind + | "file" -> File + | "yp" -> Yp + | x -> raise (Unknown x) + + let to_string = function Bind -> "bind" | File -> "file" | Yp -> "yp" end module OptionsValue = struct type t = Debug | Edns0 | Inet6 | Insecure1 | Insecure2 | Ndots of int + exception Unknown of string + let of_string x = let x = String.lowercase_ascii x in - if String.length x >= 6 && (String.sub x 0 6 = "ndots:") then begin - try - Ndots (int_of_string (String.sub x 6 (String.length x - 6))) + if String.length x >= 6 && String.sub x 0 6 = "ndots:" then + try Ndots (int_of_string (String.sub x 6 (String.length x - 6))) with Failure _ -> raise (Unknown x) - end else match x with - | "debug" -> Debug - | "edns0" -> Edns0 - | "inet6" -> Inet6 - | "insecure1" -> Insecure1 - | "insecure2" -> Insecure2 - | x -> raise (Unknown x) + else + match x with + | "debug" -> Debug + | "edns0" -> Edns0 + | "inet6" -> Inet6 + | "insecure1" -> Insecure1 + | "insecure2" -> Insecure2 + | x -> raise (Unknown x) + let to_string = function - | Debug -> "debug" | Edns0 -> "edns0" | Inet6 -> "inet6" - | Insecure1 -> "insecure1" | Insecure2 -> "insecure2" | Ndots n -> "ndots:" ^ (string_of_int n) + | Debug -> "debug" + | Edns0 -> "edns0" + | Inet6 -> "inet6" + | Insecure1 -> "insecure1" + | Insecure2 -> "insecure2" + | Ndots n -> "ndots:" ^ string_of_int n end module KeywordValue = struct type t = - | Nameserver of Ipaddr.t * int option (* ipv4 dotted quad or ipv6 hex and colon *) - | Port of int - | Domain of string - | Lookup of LookupValue.t list - | Search of string list - | Sortlist of string list - | Options of OptionsValue.t list + | Nameserver of Ipaddr.t * int option (* ipv4 dotted quad or ipv6 hex and colon *) + | Port of int + | Domain of string + | Lookup of LookupValue.t list + | Search of string list + | Sortlist of string list + | Options of OptionsValue.t list + exception Unknown of string + let split = Re.Str.split (Re.Str.regexp "[\t ]+") let ns_of_string ns = let open Re.Str in match string_match (regexp "\\[\\(.+\\)\\]:\\([0-9]+\\)") ns 0 with - |false -> Nameserver (Ipaddr.of_string_exn ns, None) - |true -> - let server = Ipaddr.of_string_exn (matched_group 1 ns) in - let port = - try Some (int_of_string (matched_group 2 ns)) - with _ -> None - in - Nameserver (server, port) + | false -> Nameserver (Ipaddr.of_string_exn ns, None) + | true -> + let server = Ipaddr.of_string_exn (matched_group 1 ns) in + let port = + try Some (int_of_string (matched_group 2 ns)) with _ -> None + in + Nameserver (server, port) let string_of_ns ns = match ns with - |ns, None -> Ipaddr.to_string ns - |ns, Some p -> Printf.sprintf "[%s]:%d" (Ipaddr.to_string ns) p + | ns, None -> Ipaddr.to_string ns + | ns, Some p -> Printf.sprintf "[%s]:%d" (Ipaddr.to_string ns) p let of_string x = match split (String.lowercase_ascii x) with | [ "nameserver"; ns ] -> ns_of_string ns | [ "domain"; domain ] -> Domain domain - | [ "port"; port ] -> (try Port (int_of_string port) with _ -> raise (Unknown x)) - | "lookup"::lst -> Lookup (List.map LookupValue.of_string lst) - | "search"::lst -> Search lst - | "sortlist"::lst -> Sortlist lst - | "options"::lst -> Options (List.map OptionsValue.of_string lst) + | [ "port"; port ] -> ( + try Port (int_of_string port) with _ -> raise (Unknown x)) + | "lookup" :: lst -> Lookup (List.map LookupValue.of_string lst) + | "search" :: lst -> Search lst + | "sortlist" :: lst -> Sortlist lst + | "options" :: lst -> Options (List.map OptionsValue.of_string lst) | _ -> raise (Unknown x) let to_string = - let sc = String.concat " " in function - | Nameserver (n,p) -> sc [ "nameserver"; (string_of_ns (n,p)) ] - | Port p -> sc [ "port" ; (string_of_int p) ] + let sc = String.concat " " in + function + | Nameserver (n, p) -> sc [ "nameserver"; string_of_ns (n, p) ] + | Port p -> sc [ "port"; string_of_int p ] | Domain domain -> sc [ "domain"; domain ] - | Lookup l -> sc ( "lookup"::(List.map LookupValue.to_string l) ) - | Search lst -> sc ( "search"::lst ) - | Sortlist lst -> sc ( "sortlist"::lst ) - | Options lst -> sc ( "options"::(List.map OptionsValue.to_string lst) ) + | Lookup l -> sc ("lookup" :: List.map LookupValue.to_string l) + | Search lst -> sc ("search" :: lst) + | Sortlist lst -> sc ("sortlist" :: lst) + | Options lst -> sc ("options" :: List.map OptionsValue.to_string lst) end (* The state of the resolver could be extended later *) @@ -134,33 +141,33 @@ type t = KeywordValue.t list (* Choose a DNS port, which will default to 53 or can be overridden by the nameserver entry *) let choose_port config = - List.fold_left (fun port -> - function - | KeywordValue.Port x -> x - | _ -> port) 53 config + List.fold_left + (fun port -> function KeywordValue.Port x -> x | _ -> port) + 53 config let all_servers config = let default_port = choose_port config in - List.rev (List.fold_left (fun a -> - function - | KeywordValue.Nameserver (ns,Some p) -> (ns,p) :: a - | KeywordValue.Nameserver (ns,None) -> (ns,default_port) :: a - | _ -> a) [] config) + List.rev + (List.fold_left + (fun a -> function + | KeywordValue.Nameserver (ns, Some p) -> (ns, p) :: a + | KeywordValue.Nameserver (ns, None) -> (ns, default_port) :: a + | _ -> a) + [] config) (* Choose a DNS server to query. Might do some round-robin thingy later *) let choose_server config = - match (all_servers config) with - | [] -> None - | (ns, port)::_ -> Some (ns, port) + match all_servers config with [] -> None | (ns, port) :: _ -> Some (ns, port) (* Return a list of domain suffixes to search *) let search_domains config = let relevant_entries = - List.fold_left (fun a -> function - | KeywordValue.Domain x -> [x] :: a - | KeywordValue.Search xs -> xs :: a - | _ -> a) [] config in + List.fold_left + (fun a -> function + | KeywordValue.Domain x -> [ x ] :: a + | KeywordValue.Search xs -> xs :: a + | _ -> a) + [] config + in (* entries are mutually-exclusive, last one overrides *) - match relevant_entries with - | [] -> [] - | x::_ -> x + match relevant_entries with [] -> [] | x :: _ -> x File "src/dns_forward/dns_forward_server.ml", line 1, characters 0-0: diff --git a/_build/default/src/dns_forward/dns_forward_server.ml b/_build/default/src/dns_forward/.formatted/dns_forward_server.ml index 873ede9..74a28da 100644 --- a/_build/default/src/dns_forward/dns_forward_server.ml +++ b/_build/default/src/dns_forward/.formatted/dns_forward_server.ml @@ -21,35 +21,28 @@ let src = src module Log = (val Logs.src_log src : Logs.LOG) - open Lwt.Infix module type S = Dns_forward_s.SERVER -module Make(Server: Dns_forward_s.RPC_SERVER)(Resolver: Dns_forward_s.RESOLVER) = struct - +module Make + (Server : Dns_forward_s.RPC_SERVER) + (Resolver : Dns_forward_s.RESOLVER) = +struct type resolver = Resolver.t + type t = { resolver : Resolver.t; mutable server : Server.server option } - type t = { - resolver: Resolver.t; - mutable server: Server.server option; - } - - let create resolver = - Lwt.return { resolver; server = None } + let create resolver = Lwt.return { resolver; server = None } let serve ~address t = let open Lwt_result.Infix in - Server.bind address - >>= fun server -> + Server.bind address >>= fun server -> t.server <- Some server; Server.listen server (fun buf -> Resolver.answer buf t.resolver) - >>= fun () -> - Lwt_result.return () + >>= fun () -> Lwt_result.return () let destroy { resolver; server } = - Resolver.destroy resolver - >>= fun () -> + Resolver.destroy resolver >>= fun () -> match server with | None -> Lwt.return_unit | Some server -> Server.shutdown server File "src/dns_forward/dns_forward_cache.ml", line 1, characters 0-0: diff --git a/_build/default/src/dns_forward/dns_forward_cache.ml b/_build/default/src/dns_forward/.formatted/dns_forward_cache.ml index 0af0f62..f7189b6 100644 --- a/_build/default/src/dns_forward/dns_forward_cache.ml +++ b/_build/default/src/dns_forward/.formatted/dns_forward_cache.ml @@ -24,62 +24,65 @@ module Question = struct nice `compare` functions. *) let compare = Stdlib.compare end - module Map = Map.Make(M) + + module Map = Map.Make (M) include M end module Address = Dns_forward_config.Address type answer = { - rrs: Dns.Packet.rr list; + rrs : Dns.Packet.rr list; (* We'll use the Lwt scheduler as a priority queue to expire records, one timeout thread per record. *) - timeout: unit Lwt.t; + timeout : unit Lwt.t; } -module Make(Time: Mirage_time.S) = struct +module Make (Time : Mirage_time.S) = struct type t = { - max_bindings: int; + max_bindings : int; (* For every question we store a mapping of server address to the answer *) - mutable cache: answer Address.Map.t Question.Map.t; + mutable cache : answer Address.Map.t Question.Map.t; } - let make ?(max_bindings=1024) () = + let make ?(max_bindings = 1024) () = let cache = Question.Map.empty in { max_bindings; cache } let answer t address question = - if Question.Map.mem question t.cache then begin + if Question.Map.mem question t.cache then let all = Question.Map.find question t.cache in - if Address.Map.mem address all - then Some (Address.Map.find address all).rrs + if Address.Map.mem address all then + Some (Address.Map.find address all).rrs else None - end else None + else None let remove t question = - if Question.Map.mem question t.cache then begin + if Question.Map.mem question t.cache then ( let all = Question.Map.find question t.cache in Address.Map.iter (fun _ answer -> Lwt.cancel answer.timeout) all; - t.cache <- Question.Map.remove question t.cache; - end + t.cache <- Question.Map.remove question t.cache) let destroy t = - Question.Map.iter (fun _ all -> - Address.Map.iter (fun _ answer -> - Lwt.cancel answer.timeout) all) t.cache; + Question.Map.iter + (fun _ all -> + Address.Map.iter (fun _ answer -> Lwt.cancel answer.timeout) all) + t.cache; t.cache <- Question.Map.empty let insert t address question rrs = (* If we already have the maximum number of bindings then remove one at random *) - if Question.Map.cardinal t.cache >= t.max_bindings then begin - let choice = Random.int (Question.Map.cardinal t.cache) in - match Question.Map.fold (fun question _ (i, existing) -> - i + 1, if i = choice then Some question else existing - ) t.cache (0, None) with - | _, None -> (* should never happen *) () - | _, Some question -> remove t question - end; + (if Question.Map.cardinal t.cache >= t.max_bindings then + let choice = Random.int (Question.Map.cardinal t.cache) in + match + Question.Map.fold + (fun question _ (i, existing) -> + (i + 1, if i = choice then Some question else existing)) + t.cache (0, None) + with + | _, None -> (* should never happen *) () + | _, Some question -> remove t question); (* Each resource record could be expired separately using a different TTL but we'll simplify the code by expiring all resource records received from the same server address when the lowest TTL is exceeded. *) @@ -89,24 +92,24 @@ module Make(Time: Mirage_time.S) = struct in let timeout = let open Lwt.Infix in - Time.sleep_ns (Duration.of_sec @@ Int32.to_int min_ttl) - >>= fun () -> - if Question.Map.mem question t.cache then begin - let address_to_answer = - Question.Map.find question t.cache - |> Address.Map.remove address in - if Address.Map.is_empty address_to_answer - then t.cache <- Question.Map.remove question t.cache - else t.cache <- Question.Map.add question address_to_answer t.cache - end; + Time.sleep_ns (Duration.of_sec @@ Int32.to_int min_ttl) >>= fun () -> + (if Question.Map.mem question t.cache then + let address_to_answer = + Question.Map.find question t.cache |> Address.Map.remove address + in + if Address.Map.is_empty address_to_answer then + t.cache <- Question.Map.remove question t.cache + else t.cache <- Question.Map.add question address_to_answer t.cache); Lwt.return_unit in let answer = { rrs; timeout } in let address_to_answer = - if Question.Map.mem question t.cache - then Question.Map.find question t.cache + if Question.Map.mem question t.cache then + Question.Map.find question t.cache else Address.Map.empty in - t.cache <- Question.Map.add question - (Address.Map.add address answer address_to_answer) t.cache + t.cache <- + Question.Map.add question + (Address.Map.add address answer address_to_answer) + t.cache end File "src/dns_forward/dns_forward_s.ml", line 1, characters 0-0: diff --git a/_build/default/src/dns_forward/dns_forward_s.ml b/_build/default/src/dns_forward/.formatted/dns_forward_s.ml index 1c1480b..07a5d96 100644 --- a/_build/default/src/dns_forward/dns_forward_s.ml +++ b/_build/default/src/dns_forward/.formatted/dns_forward_s.ml @@ -18,24 +18,29 @@ module type Comparable = sig type t - val compare: t -> t -> int + val compare : t -> t -> int end module type FLOW_CLIENT = sig include Mirage_flow_combinators.SHUTDOWNABLE + type address - val connect: ?read_buffer_size:int -> address - -> (flow, [ `Msg of string ]) Lwt_result.t + + val connect : + ?read_buffer_size:int -> address -> (flow, [ `Msg of string ]) Lwt_result.t end module type FLOW_SERVER = sig type server type address - val bind: address -> (server, [ `Msg of string ]) Lwt_result.t - val getsockname: server -> address + + val bind : address -> (server, [ `Msg of string ]) Lwt_result.t + val getsockname : server -> address + type flow - val listen: server -> (flow -> unit Lwt.t) -> unit - val shutdown: server -> unit Lwt.t + + val listen : server -> (flow -> unit Lwt.t) -> unit + val shutdown : server -> unit Lwt.t end module type RPC_CLIENT = sig @@ -43,55 +48,78 @@ module type RPC_CLIENT = sig type response = Cstruct.t type address = Dns_forward_config.Address.t type t - type message_cb = ?src:address -> ?dst:address -> buf:Cstruct.t -> unit -> unit Lwt.t - val connect: gen_transaction_id:(int -> int) -> ?message_cb:message_cb -> address -> (t, [ `Msg of string ]) Lwt_result.t - val rpc: t -> request -> (response, [ `Msg of string ]) Lwt_result.t - val disconnect: t -> unit Lwt.t + + type message_cb = + ?src:address -> ?dst:address -> buf:Cstruct.t -> unit -> unit Lwt.t + + val connect : + gen_transaction_id:(int -> int) -> + ?message_cb:message_cb -> + address -> + (t, [ `Msg of string ]) Lwt_result.t + + val rpc : t -> request -> (response, [ `Msg of string ]) Lwt_result.t + val disconnect : t -> unit Lwt.t end module type RPC_SERVER = sig type request = Cstruct.t type response = Cstruct.t type address = Dns_forward_config.Address.t - type server - val bind: address -> (server, [ `Msg of string ]) Lwt_result.t - val listen: server -> (request -> (response, [ `Msg of string ]) Lwt_result.t) -> (unit, [ `Msg of string ]) Lwt_result.t - val shutdown: server -> unit Lwt.t + + val bind : address -> (server, [ `Msg of string ]) Lwt_result.t + + val listen : + server -> + (request -> (response, [ `Msg of string ]) Lwt_result.t) -> + (unit, [ `Msg of string ]) Lwt_result.t + + val shutdown : server -> unit Lwt.t end module type RESOLVER = sig type t type address = Dns_forward_config.Address.t - type message_cb = ?src:address -> ?dst:address -> buf:Cstruct.t -> unit -> unit Lwt.t - val create: + + type message_cb = + ?src:address -> ?dst:address -> buf:Cstruct.t -> unit -> unit Lwt.t + + val create : ?local_names_cb:(Dns.Packet.question -> Dns.Packet.rr list option Lwt.t) -> gen_transaction_id:(int -> int) -> ?message_cb:message_cb -> Dns_forward_config.t -> t Lwt.t - val destroy: t -> unit Lwt.t - val answer: Cstruct.t -> t -> (Cstruct.t, [ `Msg of string ]) Lwt_result.t + + val destroy : t -> unit Lwt.t + val answer : Cstruct.t -> t -> (Cstruct.t, [ `Msg of string ]) Lwt_result.t end module type SERVER = sig type t type resolver - val create: resolver -> t Lwt.t - val serve: + + val create : resolver -> t Lwt.t + + val serve : address:Dns_forward_config.Address.t -> - t -> (unit, [ `Msg of string ]) Lwt_result.t - val destroy: t -> unit Lwt.t + t -> + (unit, [ `Msg of string ]) Lwt_result.t + + val destroy : t -> unit Lwt.t end module type READERWRITER = sig - (** Read and write DNS packets from a flow *) type request = Cstruct.t + (** Read and write DNS packets from a flow *) + type response = Cstruct.t type t type flow - val connect: flow -> t - val read: t -> (request, [ `Msg of string ]) Lwt_result.t - val write: t -> response -> (unit, [ `Msg of string]) Lwt_result.t - val close: t -> unit Lwt.t + + val connect : flow -> t + val read : t -> (request, [ `Msg of string ]) Lwt_result.t + val write : t -> response -> (unit, [ `Msg of string ]) Lwt_result.t + val close : t -> unit Lwt.t end File "src/dns_lwt/dns_resolver.ml", line 1, characters 0-0: diff --git a/_build/default/src/dns_lwt/dns_resolver.ml b/_build/default/src/dns_lwt/.formatted/dns_resolver.ml index c74a8e1..2c8fa83 100644 --- a/_build/default/src/dns_lwt/dns_resolver.ml +++ b/_build/default/src/dns_lwt/.formatted/dns_resolver.ml @@ -20,103 +20,96 @@ open Lwt.Infix open Dns open Operators open Protocol - module DP = Packet type result = Answer of DP.t | Error of exn type commfn = { - txfn : Cstruct.t -> unit Lwt.t; - rxfn : (Cstruct.t -> Dns.Packet.t option) -> DP.t Lwt.t; + txfn : Cstruct.t -> unit Lwt.t; + rxfn : (Cstruct.t -> Dns.Packet.t option) -> DP.t Lwt.t; timerfn : unit -> unit Lwt.t; cleanfn : unit -> unit Lwt.t; } -let rec send_req txfn timerfn q = - function +let rec send_req txfn timerfn q = function | 0 -> Lwt.return_unit | count -> - txfn q >>= fun () -> - timerfn () >>= fun () -> - send_req txfn timerfn q (count - 1) + txfn q >>= fun () -> + timerfn () >>= fun () -> send_req txfn timerfn q (count - 1) -let send_pkt client ?alloc ({ txfn; rxfn; timerfn; _ }) pkt = +let send_pkt client ?alloc { txfn; rxfn; timerfn; _ } pkt = let module R = (val client : CLIENT) in let cqpl = R.marshal ?alloc pkt in - let resl = List.map (fun (ctxt,q) -> - (* make a new socket for each request flavor *) - (* start the requests in parallel and run them until success or timeout*) - let t, w = Lwt.wait () in - Lwt.async (fun () -> Lwt.pick [ - (send_req txfn timerfn q 4 >|= fun () -> Error (R.timeout ctxt)); - (Lwt.catch - (fun () -> rxfn (R.parse ctxt) >|= fun r -> Answer r) - (fun exn -> Lwt.return (Error exn)) - ) - ] >|= Lwt.wakeup w); - t - ) cqpl in + let resl = + List.map + (fun (ctxt, q) -> + (* make a new socket for each request flavor *) + (* start the requests in parallel and run them until success or timeout*) + let t, w = Lwt.wait () in + Lwt.async (fun () -> + Lwt.pick + [ + (send_req txfn timerfn q 4 >|= fun () -> Error (R.timeout ctxt)); + Lwt.catch + (fun () -> rxfn (R.parse ctxt) >|= fun r -> Answer r) + (fun exn -> Lwt.return (Error exn)); + ] + >|= Lwt.wakeup w); + t) + cqpl + in (* return an answer or all the errors if no request succeeded *) let rec select errors = function | [] -> Lwt.fail (Dns_resolve_error errors) | ts -> - Lwt.nchoose_split ts - >>= fun (rs, ts) -> - let rec find_answer errors = function - | [] -> select errors ts - | (Answer a)::_ -> Lwt.return a - | (Error e)::r -> find_answer (e::errors) r - in - find_answer errors rs - in select [] resl + Lwt.nchoose_split ts >>= fun (rs, ts) -> + let rec find_answer errors = function + | [] -> select errors ts + | Answer a :: _ -> Lwt.return a + | Error e :: r -> find_answer (e :: errors) r + in + find_answer errors rs + in + select [] resl -let resolve_pkt client ?alloc (commfn:commfn) pkt = - Lwt.catch (fun () -> - send_pkt client ?alloc commfn pkt - >>= fun r -> commfn.cleanfn () - >>= fun () -> Lwt.return r) - (function exn -> - commfn.cleanfn () >>= fun () -> - Lwt.fail exn) +let resolve_pkt client ?alloc (commfn : commfn) pkt = + Lwt.catch + (fun () -> + send_pkt client ?alloc commfn pkt >>= fun r -> + commfn.cleanfn () >>= fun () -> Lwt.return r) + (function exn -> commfn.cleanfn () >>= fun () -> Lwt.fail exn) -let resolve client - ?alloc - ?(dnssec=false) - (commfn:commfn) - (q_class:DP.q_class) (q_type:DP.q_type) - (q_name:Name.t) = - let id = (let module R = (val client : CLIENT) in R.get_id ()) in +let resolve client ?alloc ?(dnssec = false) (commfn : commfn) + (q_class : DP.q_class) (q_type : DP.q_type) (q_name : Name.t) = + let id = + let module R = (val client : CLIENT) in + R.get_id () + in let q = Dns.Query.create ~id ~dnssec q_class q_type q_name in resolve_pkt client ?alloc commfn q -let gethostbyname - ?alloc - ?(q_class:DP.q_class = DP.Q_IN) ?(q_type:DP.q_type = DP.Q_A) - commfn - name = +let gethostbyname ?alloc ?(q_class : DP.q_class = DP.Q_IN) + ?(q_type : DP.q_type = DP.Q_A) commfn name = let open DP in let domain = Name.of_string name in resolve (module Dns.Protocol.Client) ?alloc commfn q_class q_type domain >|= fun r -> - List.fold_left (fun a x -> + List.fold_left + (fun a x -> match x.rdata with | A ip -> Ipaddr.V4 ip :: a | AAAA ip -> Ipaddr.V6 ip :: a - | _ -> a - ) [] r.answers + | _ -> a) + [] r.answers |> List.rev -let gethostbyaddr - ?alloc - ?(q_class:DP.q_class = DP.Q_IN) ?(q_type:DP.q_type = DP.Q_PTR) - commfn - addr - = +let gethostbyaddr ?alloc ?(q_class : DP.q_class = DP.Q_IN) + ?(q_type : DP.q_type = DP.Q_PTR) commfn addr = let addr = Name.of_ipaddr (Ipaddr.V4 addr) in let open DP in resolve (module Dns.Protocol.Client) ?alloc commfn q_class q_type addr >|= fun r -> - List.fold_left (fun a x -> - match x.rdata with |PTR n -> (Name.to_string n)::a |_->a - ) [] r.answers + List.fold_left + (fun a x -> match x.rdata with PTR n -> Name.to_string n :: a | _ -> a) + [] r.answers |> List.rev File "src/fs9p/fs9p.ml", line 1, characters 0-0: diff --git a/_build/default/src/fs9p/fs9p.ml b/_build/default/src/fs9p/.formatted/fs9p.ml index 6cac3d7..2d20cb8 100644 --- a/_build/default/src/fs9p/fs9p.ml +++ b/_build/default/src/fs9p/.formatted/fs9p.ml @@ -13,39 +13,22 @@ let pp_fid = type 'a or_err = 'a Protocol_9p.Error.t Lwt.t let ok x = Lwt.return (Ok x) - let map_error x = Fs9p_error.map_error x - let error fmt = Fmt.kstr (fun s -> Lwt.return (Fs9p_error.error "%s" s)) fmt - let err_not_a_dir name = error "%S is not a directory" name - let err_can't_set_length_of_dir = error "Can't set length of a directory" - let err_can't_walk_from_file = error "Can't walk from a file" - let err_can't_seek_dir = error "Can't seek in a directory" - let err_unknown_fid fid = error "Unknown fid %a" pp_fid fid - let err_fid_in_use fid = error "Fid %a already in use" pp_fid fid - let err_dot = error "'.' is not valid in 9p" - let err_read_not_open = error "Can't read from unopened fid" - let err_already_open = error "Already open" - let err_create_open = error "Can't create in an opened fid" - let err_write_not_open = error "Can't write to unopened fid" - let err_write_dir = error "Can't write to directories" - let err_rename_root = error "Can't rename /" - let err_multiple_updates = error "Can't rename/truncate/chmod at the same time" - let max_chunk_size = Int32.of_int (100 * 1024) module type S = sig @@ -65,7 +48,6 @@ module Inode = struct Fmt.pf ppf "offset:%Ld unread:[%a]" t.offset Fmt.(list pp) t.unread let offset t = t.offset - let unread t = t.unread type fd = [ `OpenFile of Vfs.File.fd | `OpenDir of open_dir ] @@ -79,11 +61,8 @@ end (* 9p operations. *) module Op9p = struct let rwx = [ `Read; `Write; `Execute ] - let rw = [ `Read; `Write ] - let rx = [ `Read; `Execute ] - let r = [ `Read ] let stat ~info inode = @@ -93,10 +72,10 @@ module Op9p = struct if info.P.Info.version <> P.Types.Version.unix then None else Some - (P.Types.Stat.make_extension ?extension ~n_uid:0l ~n_gid:0l - ~n_muid:0l ()) + (P.Types.Stat.make_extension ?extension ~n_uid:0l ~n_gid:0l ~n_muid:0l + ()) in - ( match Inode.kind inode with + (match Inode.kind inode with | `Dir _ -> let dir = P.Types.FileMode.make ~owner:rwx ~group:rwx ~other:rx @@ -117,7 +96,7 @@ module Op9p = struct ~other:rx (), u ) in - ok (info.Vfs.length, file, u) ) + ok (info.Vfs.length, file, u)) >>*= fun (length, mode, u) -> let qid = Inode.qid inode in let name = Inode.basename inode in @@ -156,8 +135,7 @@ module Op9p = struct let read inode = match Inode.kind inode with | `File file -> - Vfs.File.open_ file >>= map_error >>*= fun o -> - ok (`OpenFile o) + Vfs.File.open_ file >>= map_error >>*= fun o -> ok (`OpenFile o) | `Dir dir -> Vfs.Dir.ls dir >>= map_error >>*= fun items -> ok (`OpenDir { Inode.offset = 0L; unread = items }) @@ -173,7 +151,7 @@ module Op9p = struct stat ~info x >>*= fun x_info -> match P.Types.Stat.write x_info buf with | Ok buf -> aux buf xs - | Error _ -> ok (buf, items) ) + | Error _ -> ok (buf, items)) (* No more room *) in aux buffer (Inode.unread state) >>*= fun (unused, remaining) -> @@ -193,8 +171,7 @@ module Op9p = struct | `Dir -> Vfs.Dir.mkdir d name >>= map_error | #Vfs.perm as perm -> Vfs.Dir.mkfile d ~perm name >>= map_error) >>*= fun inode -> - read inode >>*= fun open_file -> - ok (inode, open_file) + read inode >>*= fun open_file -> ok (inode, open_file) | `File _ -> err_not_a_dir (Inode.basename parent) let remove inode = @@ -250,18 +227,18 @@ module Make (Flow : Mirage_flow.S) = struct match Inode.kind inode with | `File _ -> err_can't_walk_from_file | `Dir dir -> - ( match x with + (match x with | "." -> err_dot | ".." -> ( match parents with | [] -> ok (inode, parents) (* /.. = / *) - | p :: ps -> ok (p, ps) ) + | p :: ps -> ok (p, ps)) | x -> Vfs.Dir.lookup dir x >>= map_error >>*= fun x_inode -> - ok (x_inode, inode :: parents) ) + ok (x_inode, inode :: parents)) >>*= fun (inode, parents) -> let wqids = Inode.qid inode :: wqids in - do_walk ~parents ~wqids inode xs ) + do_walk ~parents ~wqids inode xs) let walk connection ~cancel:_ { P.Request.Walk.fid; newfid; wnames } = lookup connection fid >>*= fun fd -> @@ -284,8 +261,7 @@ module Make (Flow : Mirage_flow.S) = struct let clunk connection ~cancel:_ { P.Request.Clunk.fid } = let old = connection.fds in clunk_fid connection fid; - if connection.fds == old then error "Unknown fid %a" pp_fid fid - else ok () + if connection.fds == old then error "Unknown fid %a" pp_fid fid else ok () let stat connection ~cancel:_ { P.Request.Stat.fid } = lookup connection fid >>*= fun fd -> @@ -383,12 +359,9 @@ module Make (Flow : Mirage_flow.S) = struct let accept ~root ~msg flow = Log.info (fun l -> l "accepted a new connection on %s" msg); Server.connect root flow () >>= function - | Error _ as e -> - Flow.close flow >|= fun () -> - e + | Error _ as e -> Flow.close flow >|= fun () -> e | Ok t -> (* Close the flow when the 9P connection shuts down *) Server.after_disconnect t >>= fun () -> - Flow.close flow >>= fun () -> - ok () + Flow.close flow >>= fun () -> ok () end File "src/ofs/active_list.ml", line 1, characters 0-0: diff --git a/_build/default/src/ofs/active_list.ml b/_build/default/src/ofs/.formatted/active_list.ml index d003eb2..b816a18 100644 --- a/_build/default/src/ofs/active_list.ml +++ b/_build/default/src/ofs/.formatted/active_list.ml @@ -8,11 +8,7 @@ let src = module Log = (val Logs.src_log src : Logs.LOG) module Var = struct - - type 'a t = { - mutable thing: 'a option; - c: unit Lwt_condition.t; - } + type 'a t = { mutable thing : 'a option; c : unit Lwt_condition.t } let create () = let c = Lwt_condition.create () in @@ -23,32 +19,31 @@ module Var = struct Lwt_condition.broadcast t.c () let read t = - let rec loop () = match t.thing with - | Some c -> Lwt.return c - | None -> Lwt_condition.wait t.c >>= loop + let rec loop () = + match t.thing with + | Some c -> Lwt.return c + | None -> Lwt_condition.wait t.c >>= loop in loop () - end module type Instance = sig type t - val to_string: t -> string - val of_string: string -> (t, [ `Msg of string ]) result - - val description_of_format: string - val start: t -> (t, [ `Msg of string ]) result Lwt.t - - val stop: t -> unit Lwt.t + val to_string : t -> string + val of_string : string -> (t, [ `Msg of string ]) result + val description_of_format : string + val start : t -> (t, [ `Msg of string ]) result Lwt.t + val stop : t -> unit Lwt.t type key - val get_key: t -> key + + val get_key : t -> key end -module StringMap = Map.Make(String) +module StringMap = Map.Make (String) -module Make (Instance: Instance) = struct +module Make (Instance : Instance) = struct open Protocol_9p type t = unit @@ -57,51 +52,44 @@ module Make (Instance: Instance) = struct (* We manage a list of named entries *) type entry = { - name: string; - mutable instance: Instance.t option; - mutable result: string option; + name : string; + mutable instance : Instance.t option; + mutable result : string option; } let active : entry StringMap.t ref = ref StringMap.empty - type resource = - | ControlFile of entry - | README - | Entry of entry - | Root + type resource = ControlFile of entry | README | Entry of entry | Root let string_of_resource = function - | ControlFile entry -> Printf.sprintf "ControlFile(%s)" entry.name - | README -> "README" - | Entry entry -> Printf.sprintf "Entry(%s)" entry.name - | Root -> "Root" - - type connection = { - t: t; - fids: resource Types.Fid.Map.t ref; - } + | ControlFile entry -> Printf.sprintf "ControlFile(%s)" entry.name + | README -> "README" + | Entry entry -> Printf.sprintf "Entry(%s)" entry.name + | Root -> "Root" - let connect t _ = { - t; - fids = ref (Types.Fid.Map.empty); - } + type connection = { t : t; fids : resource Types.Fid.Map.t ref } + + let connect t _ = { t; fids = ref Types.Fid.Map.empty } module Error = struct let badfid = Lwt.return (Response.error "fid not found") let enoent = Lwt.return (Response.error "file not found") - let eperm = Lwt.return (Response.error "permission denied") + let eperm = Lwt.return (Response.error "permission denied") end let qid_path = ref 0_L let next_qid flags = let id = !qid_path in - qid_path := Int64.(add one !qid_path); - Protocol_9p.Types.Qid.({ flags; version = 0_l; id; }) + (qid_path := Int64.(add one !qid_path)); + Protocol_9p.Types.Qid.{ flags; version = 0_l; id } let root_qid = next_qid [ Types.Qid.Directory ] - let readme = Cstruct.of_string (Printf.sprintf {| + let readme = + Cstruct.of_string + (Printf.sprintf + {| Directory of active Instances ----------------------------- @@ -124,7 +112,8 @@ Immediately read the file contents and check whether it says: perhaps some needed resource is still in use. The directory will be deleted and replaced with a file of the same name. -|} Instance.description_of_format) +|} + Instance.description_of_format) let return x = Lwt.return (Ok x) @@ -137,27 +126,31 @@ The directory will be deleted and replaced with a file of the same name. let walk connection ~cancel:_ { Request.Walk.fid; newfid; wnames } = try let from = Types.Fid.Map.find fid !(connection.fids) in - let from, wqids = List.fold_left (fun (from,qids) x -> - match x, fst from with - | "..", _ -> - (Root, root_qid), root_qid::qids - | "README", _ -> - let qid = next_qid [] in - (README, qid), qid :: qids - | name, Root -> - if StringMap.mem name !active then begin - let entry = StringMap.find name !active in - let qid = next_qid (match entry.instance with - | None -> [ Types.Qid.Directory ] - | Some _ -> [] - ) in - (Entry entry, qid), qid :: qids - end else raise Enoent - | "ctl", Entry entry -> - let qid = next_qid [] in - (ControlFile entry, qid), qid :: qids - | _, _ -> raise Enoent - ) ((from, next_qid []), []) wnames + let from, wqids = + List.fold_left + (fun (from, qids) x -> + match (x, fst from) with + | "..", _ -> ((Root, root_qid), root_qid :: qids) + | "README", _ -> + let qid = next_qid [] in + ((README, qid), qid :: qids) + | name, Root -> + if StringMap.mem name !active then + let entry = StringMap.find name !active in + let qid = + next_qid + (match entry.instance with + | None -> [ Types.Qid.Directory ] + | Some _ -> []) + in + ((Entry entry, qid), qid :: qids) + else raise Enoent + | "ctl", Entry entry -> + let qid = next_qid [] in + ((ControlFile entry, qid), qid :: qids) + | _, _ -> raise Enoent) + ((from, next_qid []), []) + wnames in connection.fids := Types.Fid.Map.add newfid (fst from) !(connection.fids); let wqids = List.rev wqids in @@ -167,25 +160,24 @@ The directory will be deleted and replaced with a file of the same name. | Enoent -> Error.enoent let free_resource = function - | ControlFile entry -> - Log.debug (fun f -> f "freeing entry %s" entry.name); - let open Lwt.Infix in - ( match entry.instance with - | None -> Lwt.return () - | Some f -> Instance.stop f ) - >>= fun () -> - entry.instance <- None; - active := StringMap.remove entry.name !active; - Lwt.return () - | _ -> - Lwt.return () + | ControlFile entry -> + Log.debug (fun f -> f "freeing entry %s" entry.name); + let open Lwt.Infix in + (match entry.instance with + | None -> Lwt.return () + | Some f -> Instance.stop f) + >>= fun () -> + entry.instance <- None; + active := StringMap.remove entry.name !active; + Lwt.return () + | _ -> Lwt.return () let clunk connection ~cancel:_ { Request.Clunk.fid } = let open Lwt.Infix in - ( if Types.Fid.Map.mem fid !(connection.fids) then begin - let resource = Types.Fid.Map.find fid !(connection.fids) in - free_resource resource - end else Lwt.return () ) + (if Types.Fid.Map.mem fid !(connection.fids) then + let resource = Types.Fid.Map.find fid !(connection.fids) in + free_resource resource + else Lwt.return ()) >>= fun () -> connection.fids := Types.Fid.Map.remove fid !(connection.fids); return () @@ -199,45 +191,44 @@ The directory will be deleted and replaced with a file of the same name. let make_stat ~is_directory ~writable ~name = let exec = if is_directory then [ `Execute ] else [] in - let perms = - `Read :: (if writable then [ `Write ] else [] ) @ exec in + let perms = (`Read :: (if writable then [ `Write ] else [])) @ exec in let qid = next_qid [] in - Types.({ + Types. + { Stat.ty = 0xFFFF; - dev = Int32.(neg one); - qid = qid; - mode = FileMode.make - ~owner:perms ~group:perms ~other:perms ~is_directory (); - atime = 1146711721l; - mtime = 1146711721l; - length = 0_L; (* TODO: wrong for regular files *) - name = name; - uid = "uid"; - gid = "gid"; - muid = "muid"; - u = None; - }) + dev = Int32.(neg one); + qid; + mode = + FileMode.make ~owner:perms ~group:perms ~other:perms ~is_directory (); + atime = 1146711721l; + mtime = 1146711721l; + length = 0_L; + (* TODO: wrong for regular files *) + name; + uid = "uid"; + gid = "gid"; + muid = "muid"; + u = None; + } let read_children count offset children = let buf = Cstruct.create count in let rec write off rest = function - | [] -> return off - | stat :: xs -> - let open Infix in - let n = Types.Stat.sizeof stat in - if off < offset - then write (off + n) rest xs - else if Cstruct.length rest < n then return off - else - Lwt.return (Types.Stat.write stat rest) - >>*= fun rest -> - write (off + n) rest xs in + | [] -> return off + | stat :: xs -> + let open Infix in + let n = Types.Stat.sizeof stat in + if off < offset then write (off + n) rest xs + else if Cstruct.length rest < n then return off + else + Lwt.return (Types.Stat.write stat rest) >>*= fun rest -> + write (off + n) rest xs + in let open Lwt.Infix in - write 0 buf children - >>= function + write 0 buf children >>= function | Ok offset' -> - let data = Cstruct.sub buf 0 (max 0 (offset' - offset)) in - return { Response.Read.data } + let data = Cstruct.sub buf 0 (max 0 (offset' - offset)) in + return { Response.Read.data } | Error _ -> Error.badfid let dot = make_stat ~is_directory:true ~writable:false ~name:"." @@ -257,49 +248,54 @@ The directory will be deleted and replaced with a file of the same name. let resource = Types.Fid.Map.find fid !(connection.fids) in match resource with | ControlFile entry -> - let message = match entry.result with - | None -> "ERROR no request received. Please read the README.\n" - | Some x -> x in - read_string count offset message + let message = + match entry.result with + | None -> "ERROR no request received. Please read the README.\n" + | Some x -> x + in + read_string count offset message | README -> - let len = min count Cstruct.(length readme - offset) in - let data = Cstruct.sub readme offset len in - return { Response.Read.data } + let len = min count Cstruct.(length readme - offset) in + let data = Cstruct.sub readme offset len in + return { Response.Read.data } | Entry { instance = Some i; _ } -> - let i' = Instance.to_string i in - read_string count offset (i' ^ "\n") + let i' = Instance.to_string i in + read_string count offset (i' ^ "\n") | Entry { instance = None; _ } -> - let children = - dot - :: dotdot - :: [ make_stat ~is_directory:false ~writable:false ~name:"ctl" ] in - read_children count offset children + let children = + dot :: dotdot + :: [ make_stat ~is_directory:false ~writable:false ~name:"ctl" ] + in + read_children count offset children | Root -> - let children = - dot - :: dotdot - :: make_stat ~is_directory:false ~writable:false ~name:"README" - :: (StringMap.fold (fun name entry acc -> - let is_directory = match entry.instance with - | None -> true - | Some _ -> false in - make_stat ~is_directory ~writable:false ~name - :: acc) !active []) in - read_children count offset children + let children = + dot :: dotdot + :: make_stat ~is_directory:false ~writable:false ~name:"README" + :: StringMap.fold + (fun name entry acc -> + let is_directory = + match entry.instance with None -> true | Some _ -> false + in + make_stat ~is_directory ~writable:false ~name :: acc) + !active [] + in + read_children count offset children with Not_found -> Error.badfid let stat connection ~cancel:_ { Request.Stat.fid } = try let resource = Types.Fid.Map.find fid !(connection.fids) in - let stat = match resource with - | Root -> make_stat ~is_directory:true ~writable:true ~name:"" - | README -> make_stat ~is_directory:false ~writable:false ~name:"README" - | ControlFile _ -> - make_stat ~is_directory:false ~writable:true ~name:"ctl" - | Entry { name; instance = None; _ } -> - make_stat ~is_directory:true ~writable:false ~name - | Entry { name; instance = Some _; _ } -> - make_stat ~is_directory:false ~writable:false ~name in + let stat = + match resource with + | Root -> make_stat ~is_directory:true ~writable:true ~name:"" + | README -> make_stat ~is_directory:false ~writable:false ~name:"README" + | ControlFile _ -> + make_stat ~is_directory:false ~writable:true ~name:"ctl" + | Entry { name; instance = None; _ } -> + make_stat ~is_directory:true ~writable:false ~name + | Entry { name; instance = Some _; _ } -> + make_stat ~is_directory:false ~writable:false ~name + in return { Response.Stat.stat } with Not_found -> Error.badfid @@ -307,17 +303,18 @@ The directory will be deleted and replaced with a file of the same name. let resource = Types.Fid.Map.find fid !(connection.fids) in match resource with | Root when perm.Types.FileMode.is_directory -> - let qid = next_qid [ Types.Qid.Directory ] in - let entry = { name; instance = None; result = None } in - active := StringMap.add name entry !active; - let resource = Entry entry in - connection.fids := Types.Fid.Map.add fid resource !(connection.fids); - Log.debug (fun f -> f "Creating resource %s" (string_of_resource resource)); - return { Response.Create.qid; iounit = 512l } + let qid = next_qid [ Types.Qid.Directory ] in + let entry = { name; instance = None; result = None } in + active := StringMap.add name entry !active; + let resource = Entry entry in + connection.fids := Types.Fid.Map.add fid resource !(connection.fids); + Log.debug (fun f -> + f "Creating resource %s" (string_of_resource resource)); + return { Response.Create.qid; iounit = 512l } | resource -> - Log.err (fun f -> f "EPERM creating resource = %s" - (string_of_resource resource)); - Error.eperm + Log.err (fun f -> + f "EPERM creating resource = %s" (string_of_resource resource)); + Error.eperm let write connection ~cancel:_ { Request.Write.fid; offset; data } = Log.debug (fun f -> @@ -326,36 +323,35 @@ The directory will be deleted and replaced with a file of the same name. try let resource = Types.Fid.Map.find fid !(connection.fids) in match resource with - | ControlFile entry -> - if entry.result <> None then begin - Log.err (fun f -> - f "EPERM writing to an already-configured control file"); - Error.eperm - end else begin match Instance.of_string @@ Cstruct.to_string data with - | Ok f -> - let open Lwt.Infix in - begin Instance.start f >>= - function - | Ok f' -> (* local_port is resolved *) - entry.instance <- Some f'; - entry.result <- Some ("OK " ^ (Instance.to_string f') ^ "\n"); - Log.debug (fun f -> - f "Created instance %s" (Instance.to_string f')); - return ok + | ControlFile entry -> ( + if entry.result <> None then ( + Log.err (fun f -> + f "EPERM writing to an already-configured control file"); + Error.eperm) + else + match Instance.of_string @@ Cstruct.to_string data with + | Ok f -> ( + let open Lwt.Infix in + Instance.start f >>= function + | Ok f' -> + (* local_port is resolved *) + entry.instance <- Some f'; + entry.result <- Some ("OK " ^ Instance.to_string f' ^ "\n"); + Log.debug (fun f -> + f "Created instance %s" (Instance.to_string f')); + return ok + | Error (`Msg m) -> + entry.result <- Some ("ERROR " ^ m ^ "\n"); + return ok) | Error (`Msg m) -> - entry.result <- Some ("ERROR " ^ m ^ "\n"); - return ok - end - | Error (`Msg m) -> - Log.err (fun f -> - f "Return an error message via the control file: %s" m); - entry.result <- Some ("ERROR " ^ m ^ "\n"); - return ok - end + Log.err (fun f -> + f "Return an error message via the control file: %s" m); + entry.result <- Some ("ERROR " ^ m ^ "\n"); + return ok) | _ -> - Log.err (fun f -> - f "EPERM writing to resource %s" (string_of_resource resource)); - Error.eperm + Log.err (fun f -> + f "EPERM writing to resource %s" (string_of_resource resource)); + Error.eperm with Not_found -> Log.err (fun f -> f "Fid not bound, returning badfid"); Error.badfid @@ -365,11 +361,11 @@ The directory will be deleted and replaced with a file of the same name. let resource = Types.Fid.Map.find fid !(connection.fids) in match resource with | Entry _ | ControlFile _ -> - clunk connection ~cancel { Request.Clunk.fid } + clunk connection ~cancel { Request.Clunk.fid } | _ -> - Log.err (fun f -> - f "EPERM removing resource %s" (string_of_resource resource)); - Error.eperm + Log.err (fun f -> + f "EPERM removing resource %s" (string_of_resource resource)); + Error.eperm with Not_found -> Log.err (fun f -> f "Fid not bound, returning badfid"); Error.badfid File "scripts/licenses.ml", line 1, characters 0-0: diff --git a/_build/default/scripts/licenses.ml b/_build/default/scripts/.formatted/licenses.ml index 4c7469e..fe7aeb5 100644 --- a/_build/default/scripts/licenses.ml +++ b/_build/default/scripts/.formatted/licenses.ml @@ -1,12 +1,10 @@ -(* Lookup package licenses and obligations, specifically Copyright statements since - the source code is already freely available. *) - -type license = { - link: string; - text: string; -} - -let isc = {| +(* Lookup package licenses and obligations, specifically Copyright statements since + the source code is already freely available. *) + +type license = { link : string; text : string } + +let isc = + {| Permission to use, copy, modify, and distribute this software for any purpose with or without fee is hereby granted, provided that the above copyright notice and this permission notice appear in all copies. @@ -18,17 +16,19 @@ ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -|} - -let mit = {| +|} + +let mit = + {| Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -|} - -let bsd_2_clause_simplified = {| +|} + +let bsd_2_clause_simplified = + {| Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. @@ -36,18 +36,20 @@ Redistributions of source code must retain the above copyright notice, this list Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -|} - -let bsd_3_clause_new_or_revised = {| +|} + +let bsd_3_clause_new_or_revised = + {| Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. The name of the author may not be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -|} - -let lgpl21 = {| +|} + +let lgpl21 = + {| GNU LESSER GENERAL PUBLIC LICENSE Version 2.1, February 1999 @@ -228,9 +230,10 @@ signature of Ty Coon, 1 April 1990 Ty Coon, President of Vice That's all there is to it! -|} - -let lgpl21_with_ocaml_linking_exception = {| +|} + +let lgpl21_with_ocaml_linking_exception = + {| This repository is distributed under the terms of the GNU Lesser General Public License version 2.1 (included below). @@ -250,9 +253,11 @@ Public License. ------------ -|} ^ lgpl21 - -let apache2 copyright = {| +|} + ^ lgpl21 + +let apache2 copyright = + {| Apache License Version 2.0, January 2004 @@ -431,7 +436,9 @@ of your accepting any such warranty or additional liability. END OF TERMS AND CONDITIONS -|} ^ copyright ^ {| +|} + ^ copyright + ^ {| Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. @@ -444,12 +451,15 @@ distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. -|} - -let licenses = function - | "angstrom.0.15.0" | "angstrom.0.16.0" -> { - link = "https://github.com/inhabitedtype/angstrom/blob/21333c8629ade0b99732a7c34c9513096d7efa05/LICENSE"; - text = {| +|} + +let licenses = function + | "angstrom.0.15.0" | "angstrom.0.16.0" -> + { + link = + "https://github.com/inhabitedtype/angstrom/blob/21333c8629ade0b99732a7c34c9513096d7efa05/LICENSE"; + text = + {| Copyright (c) 2016, Inhabited Type LLC All rights reserved. @@ -479,107 +489,129 @@ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -POSSIBILITY OF SUCH DAMAGE.|} - } - | "arp.3.0.0" | "arp.3.1.1" -> { - link = "https://github.com/mirage/arp/blob/7222488873ae6d54233480322cb2f92a8df312ba/LICENSE.md"; - text = {| +POSSIBILITY OF SUCH DAMAGE.|}; + } + | "arp.3.0.0" | "arp.3.1.1" -> + { + link = + "https://github.com/mirage/arp/blob/7222488873ae6d54233480322cb2f92a8df312ba/LICENSE.md"; + text = + {| Copyright (c) 2016 Hannes Mehnert hannes@mehnert.org Portions copyright to MirageOS team under ISC license: src/arp_packet.ml mirage/arpv4.mli mirage/arpv4.ml - |} ^ isc - } - | "asetmap.0.8.1" -> { - link = "https://github.com/dbuenzli/asetmap/blob/a3b70cfd95c6db04a1618db0bb3e8b77dbf164a9/LICENSE.md"; - text = {| + |} + ^ isc; + } + | "asetmap.0.8.1" -> + { + link = + "https://github.com/dbuenzli/asetmap/blob/a3b70cfd95c6db04a1618db0bb3e8b77dbf164a9/LICENSE.md"; + text = {| Copyright (c) 2016 Daniel C. Bünzli - |} ^ isc - } - | "astring.0.8.5" -> { - link = "https://github.com/dbuenzli/astring/blob/ec7a266a3a680e5d246689855c639da53d713428/LICENSE.md"; - text = {| + |} ^ isc; + } + | "astring.0.8.5" -> + { + link = + "https://github.com/dbuenzli/astring/blob/ec7a266a3a680e5d246689855c639da53d713428/LICENSE.md"; + text = {| Copyright (c) 2016 The astring programmers - |} ^ isc - } - | "fpath.0.7.3" -> { - link = "https://raw.githubusercontent.com/dbuenzli/fpath/master/LICENSE.md"; - text = {| + |} ^ isc; + } + | "fpath.0.7.3" -> + { + link = + "https://raw.githubusercontent.com/dbuenzli/fpath/master/LICENSE.md"; + text = {| Copyright (c) 2014 The fpath programmers - |} ^ isc - } - | "octavius.1.2.2" -> { - link = "https://raw.githubusercontent.com/ocaml-doc/octavius/master/LICENSE.md"; - text = {| + |} ^ isc; + } + | "octavius.1.2.2" -> + { + link = + "https://raw.githubusercontent.com/ocaml-doc/octavius/master/LICENSE.md"; + text = {| Copyright (c) 2015 Leo White <leo@lpw25.net> - |} ^ isc - } - | "luv_unix.0.5.0" | "luv.0.5.11" | "luv.0.5.13" | "luv_unix.0.5.1" -> { - link = "https://raw.githubusercontent.com/aantron/luv/master/LICENSE.md"; - text = {| + |} ^ isc; + } + | "luv_unix.0.5.0" | "luv.0.5.11" | "luv.0.5.13" | "luv_unix.0.5.1" -> + { + link = "https://raw.githubusercontent.com/aantron/luv/master/LICENSE.md"; + text = {| Copyright (c) 2018-2021 Anton Bachin - |} ^ mit - } - | "integers.0.7.0" -> { - link = "https://raw.githubusercontent.com/ocamllabs/ocaml-integers/0.7.0/LICENSE.md"; - text = {| + |} ^ mit; + } + | "integers.0.7.0" -> + { + link = + "https://raw.githubusercontent.com/ocamllabs/ocaml-integers/0.7.0/LICENSE.md"; + text = {| Copyright (c) 2013-2016 Jeremy Yallop - |} ^ mit - } - | "ctypes.0.20.1" | "ctypes.0.22.0" | "ctypes.0.23.0" -> { - link = "https://raw.githubusercontent.com/ocamllabs/ocaml-ctypes/master/LICENSE"; - text = {| + |} ^ mit; + } + | "ctypes.0.20.1" | "ctypes.0.22.0" | "ctypes.0.23.0" -> + { + link = + "https://raw.githubusercontent.com/ocamllabs/ocaml-ctypes/master/LICENSE"; + text = {| Copyright (c) 2013 Jeremy Yallop - |} ^ mit - } - | "time_now.v0.14.0" - | "stdio.v0.14.0" - | "ppx_optcomp.v0.14.3" - | "ppx_js_style.v0.14.1" - | "ppx_inline_test.v0.14.1" - | "ppx_here.v0.14.0" - | "ppx_hash.v0.14.0" - | "ppx_enumerate.v0.14.0" - | "ppx_compare.v0.14.0" - | "ppx_cold.v0.14.0" - | "ppx_base.v0.14.0" - | "ppx_assert.v0.14.0" - | "jst-config.v0.14.1" - | "jane-street-headers.v0.14.0" - | "base.v0.14.2" | "base.v0.14.3" - | "csexp.1.5.1" | "csexp.1.5.2" - | "dune.2.9.1" | "dune.2.9.2" | "dune.2.9.3" | "dune.3.0.2" | "dune.3.0.3" | "dune.3.1.1" | "dune.3.2.0" | "dune.3.3.0" | "dune.3.4.1" | "dune.3.5.0" | "dune.3.16.0" - | "dune-configurator.2.9.1" | "dune-configurator.2.9.3" | "dune-configurator.3.0.2" | "dune-configurator.3.0.3" | "dune-configurator.3.1.1" | "dune-configurator.3.3.0" | "dune-configurator.3.5.0" | "dune-configurator.3.16.0" - | "dune-configurator.3.2.0" | "dune-configurator.3.4.1" - | "ocaml-compiler-libs.v0.12.4" - | "ocaml-syntax-shims.1.0.0" - | "parsexp.v0.14.2" - | "result.1.5" - | "sexplib.v0.14.0" - | "sexplib0.v0.14.0" -> { - link = "https://github.com/janestreet/base/blob/83a70d184c98fb192d2030df1c3defea499195af/LICENSE.md"; - text = {| + |} ^ mit; + } + | "time_now.v0.14.0" | "stdio.v0.14.0" | "ppx_optcomp.v0.14.3" + | "ppx_js_style.v0.14.1" | "ppx_inline_test.v0.14.1" | "ppx_here.v0.14.0" + | "ppx_hash.v0.14.0" | "ppx_enumerate.v0.14.0" | "ppx_compare.v0.14.0" + | "ppx_cold.v0.14.0" | "ppx_base.v0.14.0" | "ppx_assert.v0.14.0" + | "jst-config.v0.14.1" | "jane-street-headers.v0.14.0" | "base.v0.14.2" + | "base.v0.14.3" | "csexp.1.5.1" | "csexp.1.5.2" | "dune.2.9.1" | "dune.2.9.2" + | "dune.2.9.3" | "dune.3.0.2" | "dune.3.0.3" | "dune.3.1.1" | "dune.3.2.0" + | "dune.3.3.0" | "dune.3.4.1" | "dune.3.5.0" | "dune.3.16.0" + | "dune-configurator.2.9.1" | "dune-configurator.2.9.3" + | "dune-configurator.3.0.2" | "dune-configurator.3.0.3" + | "dune-configurator.3.1.1" | "dune-configurator.3.3.0" + | "dune-configurator.3.5.0" | "dune-configurator.3.16.0" + | "dune-configurator.3.2.0" | "dune-configurator.3.4.1" + | "ocaml-compiler-libs.v0.12.4" | "ocaml-syntax-shims.1.0.0" + | "parsexp.v0.14.2" | "result.1.5" | "sexplib.v0.14.0" | "sexplib0.v0.14.0" -> + { + link = + "https://github.com/janestreet/base/blob/83a70d184c98fb192d2030df1c3defea499195af/LICENSE.md"; + text = + {| The MIT License Copyright (c) 2016--2020 Jane Street Group, LLC opensource@janestreet.com - |} ^ mit - } - | "base64.3.5.0" | "base64.3.5.1" -> { - link = "https://github.com/mirage/ocaml-base64/blob/3a5e259895acef979a0fab8bb59d396e1bccead0/LICENSE.md"; - text = {| + |} + ^ mit; + } + | "base64.3.5.0" | "base64.3.5.1" -> + { + link = + "https://github.com/mirage/ocaml-base64/blob/3a5e259895acef979a0fab8bb59d396e1bccead0/LICENSE.md"; + text = + {| Copyright (c) 2006-2009 Citrix Systems Inc. Copyright (c) 2010 Thomas Gazagnaire thomas@gazagnaire.com - |} ^ isc - } - | "bigarray-compat.1.0.0" | "bigarray-compat.1.1.0" -> { - link = "https://github.com/mirage/bigarray-compat/blob/757e11302b40619322fb839a8ef0cb0e16ba0828/LICENSE.md"; - text = {| + |} + ^ isc; + } + | "bigarray-compat.1.0.0" | "bigarray-compat.1.1.0" -> + { + link = + "https://github.com/mirage/bigarray-compat/blob/757e11302b40619322fb839a8ef0cb0e16ba0828/LICENSE.md"; + text = + {| Copyright (c) 2019-2021 Lucas Pluvinage lucas.pluvinage@gmail.com - |} ^ isc - } - | "bigstringaf.0.8.0" | "bigstringaf.0.9.0" | "bigstringaf.0.10.0" -> { - link = "https://github.com/inhabitedtype/bigstringaf/blob/9c1e57375f3da15cf344c228e2cc14a36513923d/LICENSE"; - text = {| + |} + ^ isc; + } + | "bigstringaf.0.8.0" | "bigstringaf.0.9.0" | "bigstringaf.0.10.0" -> + { + link = + "https://github.com/inhabitedtype/bigstringaf/blob/9c1e57375f3da15cf344c228e2cc14a36513923d/LICENSE"; + text = + {| Copyright (c) 2018, Inhabited Type LLC All rights reserved. @@ -610,198 +642,303 @@ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - |} - } - | "cmdliner.1.0.4" | "cmdliner.1.1.1" -> { - link = "https://github.com/dbuenzli/cmdliner/blob/93ee8854625a312d9ce69f83398bbc1e8443402f/LICENSE.md"; - text = {| + |}; + } + | "cmdliner.1.0.4" | "cmdliner.1.1.1" -> + { + link = + "https://github.com/dbuenzli/cmdliner/blob/93ee8854625a312d9ce69f83398bbc1e8443402f/LICENSE.md"; + text = {| Copyright (c) 2011 Daniel C. Bünzli - |} ^ isc - } - | "cohttp.5.0.0" | "cohttp.5.3.1" | "cohttp-lwt.5.0.0" | "cohttp-lwt.5.3.0" -> { - link = "https://github.com/mirage/ocaml-cohttp/blob/5f9c0ae88a69e4280810fe73344367e90954dea5/LICENSE.md"; - text = {| + |} ^ isc; + } + | "cohttp.5.0.0" | "cohttp.5.3.1" | "cohttp-lwt.5.0.0" | "cohttp-lwt.5.3.0" -> + { + link = + "https://github.com/mirage/ocaml-cohttp/blob/5f9c0ae88a69e4280810fe73344367e90954dea5/LICENSE.md"; + text = + {| ISC License Copyright (c) 2009-2018 <the authors, see individual headers on files> - |} ^isc - } - | "cstruct.6.0.1" | "cstruct-lwt.6.0.1" | "cstruct-sexp.6.0.1" | "ppx_cstruct.6.0.1" - | "cstruct.6.1.0" | "cstruct-lwt.6.1.0" | "cstruct-sexp.6.1.0" | "ppx_cstruct.6.1.0" - | "cstruct.6.1.1" | "cstruct-lwt.6.1.1" | "cstruct-sexp.6.1.1" | "ppx_cstruct.6.1.1" -> { - link = "https://raw.githubusercontent.com/mirage/ocaml-cstruct/v6.1.0/LICENSE.md"; - text = {| + |} + ^ isc; + } + | "cstruct.6.0.1" | "cstruct-lwt.6.0.1" | "cstruct-sexp.6.0.1" + | "ppx_cstruct.6.0.1" | "cstruct.6.1.0" | "cstruct-lwt.6.1.0" + | "cstruct-sexp.6.1.0" | "ppx_cstruct.6.1.0" | "cstruct.6.1.1" + | "cstruct-lwt.6.1.1" | "cstruct-sexp.6.1.1" | "ppx_cstruct.6.1.1" -> + { + link = + "https://raw.githubusercontent.com/mirage/ocaml-cstruct/v6.1.0/LICENSE.md"; + text = + {| Copyright (c) 2012 Anil Madhavapeddy anil@recoil.org Copyright (c) 2012 Pierre Chambart Copyright (c) Christiano F. Haesbaert haesbaert@haesbaert.org Copyright (c) Citrix Inc Copyright (c) David Sheets sheets@alum.mit.edu Copyright (c) Drup drupyog@zoho.com Copyright (c) Hannes Mehnert hannes@mehnert.org Copyright (c) Jeremy Yallop yallop@gmail.com Copyright (c) Mindy Preston meetup@yomimono.org Copyright (c) Nicolas Ojeda Bar n.oje.bar@gmail.com Copyright (c) Richard Mortier mort@cantab.net Copyright (c) Rudi Grinberg rudi.grinberg@gmail.com Copyright (c) Thomas Gazagnaire thomas@gazagnaire.com Copyright (c) Thomas Leonard talex5@gmail.com Copyright (c) Vincent Bernardoff vb@luminar.eu.org Copyright (c) pqwy david@numm.org - |}^isc - } - | "ethernet.3.0.0" -> { - link = "https://github.com/mirage/ethernet/blob/6c93d92d0363165729a4d1f51c63b43bc4987c3c/LICENSE.md"; - text = {| + |} + ^ isc; + } + | "ethernet.3.0.0" -> + { + link = + "https://github.com/mirage/ethernet/blob/6c93d92d0363165729a4d1f51c63b43bc4987c3c/LICENSE.md"; + text = + {| Copyright (c) Anil Madhavapeddy anil@recoil.org Copyright (c) Balraj Singh balrajsingh@ieee.org Copyright (c) Citrix Inc Copyright (c) David Scott dave@recoil.org Copyright (c) Docker Inc Copyright (c) Drup drupyog@zoho.com Copyright (c) Gabor Pali pali.gabor@gmail.com Copyright (c) Hannes Mehnert hannes@mehnert.org Copyright (c) Haris Rotsos cr409@cam.ac.uk Copyright (c) Kia sadieperkins@riseup.net Copyright (c) Luke Dunstan LukeDunstan81@gmail.com Copyright (c) Magnus Skjegstad magnus@skjegstad.com Copyright (c) Mindy Preston meetup@yomimono.org Copyright (c) Nicolas Ojeda Bar n.oje.bar@gmail.com Copyright (c) Pablo Polvorin ppolvorin@process-one.net Copyright (c) Richard Mortier mort@cantab.net Copyright (c) Thomas Gazagnaire thomas@gazagnaire.org Copyright (c) Thomas Leonard talex5@gmail.com Copyright (c) Tim Cuthbertson tim@gfxmonk.net Copyright (c) Vincent Bernardoff vb@luminar.eu.org Copyright (c) lnmx len@lnmx.org Copyright (c) pqwy david@numm.org - |} ^ isc - } - | "ezjsonm.1.3.0" -> { - link = "https://github.com/mirage/ezjsonm/blob/a2b724b3bb084ce5045aca6f3431bf1abb096b6f/LICENSE"; - text = {| + |} + ^ isc; + } + | "ezjsonm.1.3.0" -> + { + link = + "https://github.com/mirage/ezjsonm/blob/a2b724b3bb084ce5045aca6f3431bf1abb096b6f/LICENSE"; + text = + {| Copyright (c) 2013 Thomas Gazagnaire <thomas@gazagnaire.org> - |} ^ isc - } - | "functoria-runtime.3.0.3" | "functoria-runtime.3.1.2" -> { - link = "https://github.com/mirage/functoria/blob/d89fadb14bef0b1eb43761cdced0816e7772a533/LICENSE.md"; - text = {| + |} + ^ isc; + } + | "functoria-runtime.3.0.3" | "functoria-runtime.3.1.2" -> + { + link = + "https://github.com/mirage/functoria/blob/d89fadb14bef0b1eb43761cdced0816e7772a533/LICENSE.md"; + text = + {| Copyright (c) 2015-2018, Thomas Gazagnaire, Anil Madhavapeddy, Dave Scott, Thomas Leonard, Gabriel Radanne - |} ^ isc - } - | "hex.1.4.0" | "hex.1.5.0" -> { - link = "https://github.com/mirage/ocaml-hex/blob/a248fd213bd2248f610e8c5a7eeb39c92283896e/LICENSE.md"; - text = {| + |} + ^ isc; + } + | "hex.1.4.0" | "hex.1.5.0" -> + { + link = + "https://github.com/mirage/ocaml-hex/blob/a248fd213bd2248f610e8c5a7eeb39c92283896e/LICENSE.md"; + text = + {| Copyright (c) 2015 Trevor Summers Smith trevorsummerssmith@gmail.com Copyright (c) 2014 Thomas Gazagnaire thomas@gazagnaire.org - |} ^ isc - } - | "hvsock.3.0.0" -> { - link = "https://github.com/mirage/ocaml-hvsock/blob/f4f4ff02b90f2c12568140b30fb8fceeedd8e2f1/LICENSE.md"; - text = {| + |} + ^ isc; + } + | "hvsock.3.0.0" -> + { + link = + "https://github.com/mirage/ocaml-hvsock/blob/f4f4ff02b90f2c12568140b30fb8fceeedd8e2f1/LICENSE.md"; + text = {| Copyright (c) 2016, Dave Scott - |} ^ isc - } - | "io-page.2.3.0" | "io-page-unix.2.3.0" -> { - link = "https://github.com/mirage/io-page/blob/3e5b66ffbe922550c9b8b4c9c48b616efec65e61/LICENSE.md"; - text = {| + |} ^ isc; + } + | "io-page.2.3.0" | "io-page-unix.2.3.0" -> + { + link = + "https://github.com/mirage/io-page/blob/3e5b66ffbe922550c9b8b4c9c48b616efec65e61/LICENSE.md"; + text = + {| Copyright (c) 2013 Thomas Gazagnaire thomas@gazagnaire.org Copyright (C) 2012-2013 Citrix Inc Copyright (c) 2010-2012 Anil Madhavapeddy anil@recoil.org - |} ^ isc - } - | "ipaddr.5.2.0" | "ipaddr.5.3.0" | "ipaddr.5.3.1" | "ipaddr.5.6.0" | "ipaddr-sexp.5.2.0" | "ipaddr-sexp.5.3.0" | "ipaddr-sexp.5.3.1" | "ipaddr-sexp.5.6.0"| "macaddr.5.2.0" | "macaddr.5.3.0" | "macaddr.5.3.1" | "macaddr.5.6.0" | "macaddr-cstruct.5.2.0" | "macaddr-cstruct.5.3.0" | "macaddr-cstruct.5.3.1" | "macaddr-cstruct.5.6.0" | "macaddr-sexp.5.2.0" | "macaddr-sexp.5.3.0" | "macaddr-sexp.5.3.1" | "macaddr-sexp.5.6.0" -> { - link = "https://github.com/mirage/ocaml-ipaddr/blob/7745ea4be2c1c5a7ab95908b26a6ed81a0947ab5/LICENSE.md"; - text = {| + |} + ^ isc; + } + | "ipaddr.5.2.0" | "ipaddr.5.3.0" | "ipaddr.5.3.1" | "ipaddr.5.6.0" + | "ipaddr-sexp.5.2.0" | "ipaddr-sexp.5.3.0" | "ipaddr-sexp.5.3.1" + | "ipaddr-sexp.5.6.0" | "macaddr.5.2.0" | "macaddr.5.3.0" | "macaddr.5.3.1" + | "macaddr.5.6.0" | "macaddr-cstruct.5.2.0" | "macaddr-cstruct.5.3.0" + | "macaddr-cstruct.5.3.1" | "macaddr-cstruct.5.6.0" | "macaddr-sexp.5.2.0" + | "macaddr-sexp.5.3.0" | "macaddr-sexp.5.3.1" | "macaddr-sexp.5.6.0" -> + { + link = + "https://github.com/mirage/ocaml-ipaddr/blob/7745ea4be2c1c5a7ab95908b26a6ed81a0947ab5/LICENSE.md"; + text = + {| Copyright (c) 2013-2015 David Sheets sheets@alum.mit.edu Copyright (c) 2010-2011, 2014 Anil Madhavapeddy anil@recoil.org - |} ^ isc - } - | "metrics.0.3.0" | "metrics.0.4.0" | "metrics.0.4.1" -> { - link = "https://github.com/mirage/metrics/blob/0f48d63c5e1c0e33d7043b2c6e053ba380516433/LICENSE.md"; - text = isc; - } - | "mirage-channel.4.0.1" | "mirage-channel.4.1.0" -> { - link = "https://raw.githubusercontent.com/mirage/mirage-channel/v4.1.0/LICENSE.md"; - text = {| + |} + ^ isc; + } + | "metrics.0.3.0" | "metrics.0.4.0" | "metrics.0.4.1" -> + { + link = + "https://github.com/mirage/metrics/blob/0f48d63c5e1c0e33d7043b2c6e053ba380516433/LICENSE.md"; + text = isc; + } + | "mirage-channel.4.0.1" | "mirage-channel.4.1.0" -> + { + link = + "https://raw.githubusercontent.com/mirage/mirage-channel/v4.1.0/LICENSE.md"; + text = + {| Copyright (c) 2011-2015 Anil Madhavapeddy anil@recoil.org Copyright (c) 2015 Mindy Preston Copyright (c) 2015 Thomas Gazagnaire thomas@gazagnaire.org - |} ^ isc - } - | "mirage-clock.4.0.0" | "mirage-clock-unix.4.0.0" | "mirage-clock.4.1.0" | "mirage-clock-unix.4.1.0" | "mirage-clock.4.2.0" | "mirage-clock-unix.4.2.0" -> { - link = "https://github.com/mirage/mirage-clock/blob/5c1fa5e5818d1a5d8600894e95f07d48ad705c6f/LICENSE.md"; - text = {| + |} + ^ isc; + } + | "mirage-clock.4.0.0" | "mirage-clock-unix.4.0.0" | "mirage-clock.4.1.0" + | "mirage-clock-unix.4.1.0" | "mirage-clock.4.2.0" | "mirage-clock-unix.4.2.0" + -> + { + link = + "https://github.com/mirage/mirage-clock/blob/5c1fa5e5818d1a5d8600894e95f07d48ad705c6f/LICENSE.md"; + text = + {| Copyright (c) 2010 Anil Madhavapeddy anil@recoil.org 2014 Daniel C. Bünzli - |} ^ isc - } - | "mirage-flow.3.0.0" | "mirage-flow-combinators.3.0.0" -> { - link = "https://github.com/mirage/mirage-flow/blob/f5f6c131a9e72ac473719eb8740058385638a524/LICENSE.md"; - text = isc; - } - | "mirage-net.4.0.0" -> { - link = "https://github.com/mirage/mirage-net/blob/f440f203ed2d1653f11d6c0b184dbbdfb94ef723/LICENSE.md"; - text = isc; - } - | "mirage-profile.0.9.1" -> { - link = "https://github.com/mirage/mirage-profile/blob/5b6e0c3a6c2fe622eb081b0cc61c5c8637ab71d6/LICENSE.md"; - text = {| + |} + ^ isc; + } + | "mirage-flow.3.0.0" | "mirage-flow-combinators.3.0.0" -> + { + link = + "https://github.com/mirage/mirage-flow/blob/f5f6c131a9e72ac473719eb8740058385638a524/LICENSE.md"; + text = isc; + } + | "mirage-net.4.0.0" -> + { + link = + "https://github.com/mirage/mirage-net/blob/f440f203ed2d1653f11d6c0b184dbbdfb94ef723/LICENSE.md"; + text = isc; + } + | "mirage-profile.0.9.1" -> + { + link = + "https://github.com/mirage/mirage-profile/blob/5b6e0c3a6c2fe622eb081b0cc61c5c8637ab71d6/LICENSE.md"; + text = + {| Copyright (c) 2014, Thomas Leonard All rights reserved. - |} ^ bsd_2_clause_simplified; - } - | "mirage-random.3.0.0" -> { - link = "https://github.com/mirage/mirage-random/blob/2f2434c30cedb476b44b10c55cec0052f1eaa1f4/LICENSE.md"; - text = isc; - } - | "mirage-random-stdlib.0.1.0" -> { - link = "https://github.com/mirage/mirage-random-stdlib/blob/ee19066dbfa6f541d34261bdba65415bf1552b28/LICENSE.md"; - text = isc; - } - | "mirage-runtime.3.10.8" -> { - link = "https://github.com/mirage/mirage/blob/main/LICENSE.md"; - text = {| + |} + ^ bsd_2_clause_simplified; + } + | "mirage-random.3.0.0" -> + { + link = + "https://github.com/mirage/mirage-random/blob/2f2434c30cedb476b44b10c55cec0052f1eaa1f4/LICENSE.md"; + text = isc; + } + | "mirage-random-stdlib.0.1.0" -> + { + link = + "https://github.com/mirage/mirage-random-stdlib/blob/ee19066dbfa6f541d34261bdba65415bf1552b28/LICENSE.md"; + text = isc; + } + | "mirage-runtime.3.10.8" -> + { + link = "https://github.com/mirage/mirage/blob/main/LICENSE.md"; + text = + {| Copyright (X) 2011-2018, the MirageOS contributors - |} ^ isc - } - | "mirage-time.3.0.0" -> { - link = "https://github.com/mirage/mirage-time/blob/c68f199b1952f0656526a3212f82afd2a49c1f00/LICENSE.md"; - text = isc; - } - | "mirage-vnetif.0.5.0" | "mirage-vnetif.0.6.0" -> { - link = "https://github.com/mirage/mirage-vnetif/blob/8582e89c194b1253550daa755b4a4ff608bd07ca/LICENSE.md"; - text = {| + |} ^ isc; + } + | "mirage-time.3.0.0" -> + { + link = + "https://github.com/mirage/mirage-time/blob/c68f199b1952f0656526a3212f82afd2a49c1f00/LICENSE.md"; + text = isc; + } + | "mirage-vnetif.0.5.0" | "mirage-vnetif.0.6.0" -> + { + link = + "https://github.com/mirage/mirage-vnetif/blob/8582e89c194b1253550daa755b4a4ff608bd07ca/LICENSE.md"; + text = + {| Copyright (c) 2015, Magnus Skjegstad magnus@skjegstad.com - |} ^ isc - } - | "mirage-stack.4.0.0" -> { - link = "https://github.com/mirage/mirage-stack/blob/2d0fe8f5a198e04415eafd6496d5719f0a610e7e/LICENSE.md"; - text = isc; - } - | "pcap-format.0.5.2" | "pcap-format.0.6.0" -> { - link = "https://github.com/mirage/ocaml-pcap/blob/76bf3ce75fed04a0625fc2a1c83545c0437bf823/LICENSE.md"; - text = {| + |} + ^ isc; + } + | "mirage-stack.4.0.0" -> + { + link = + "https://github.com/mirage/mirage-stack/blob/2d0fe8f5a198e04415eafd6496d5719f0a610e7e/LICENSE.md"; + text = isc; + } + | "pcap-format.0.5.2" | "pcap-format.0.6.0" -> + { + link = + "https://github.com/mirage/ocaml-pcap/blob/76bf3ce75fed04a0625fc2a1c83545c0437bf823/LICENSE.md"; + text = + {| Copyright (c) 2012-2018 The ocaml-pcap contributors - |} ^ isc - } - | "prometheus.1.1" -> { - link = "https://github.com/mirage/prometheus/blob/4a85699fa5e37975484fc99bdf3ff944a315a1ed/LICENSE.md"; - text = apache2 "Copyright 2016-2017 Docker, Inc." - } - | "protocol-9p.2.0.2" | "protocol-9p-unix.2.0.2" -> { - link = "https://github.com/mirage/ocaml-9p/blob/931c745e45d685f4351f14ce50d2ca128895316f/LICENSE.md"; - text = {| + |} + ^ isc; + } + | "prometheus.1.1" -> + { + link = + "https://github.com/mirage/prometheus/blob/4a85699fa5e37975484fc99bdf3ff944a315a1ed/LICENSE.md"; + text = apache2 "Copyright 2016-2017 Docker, Inc."; + } + | "protocol-9p.2.0.2" | "protocol-9p-unix.2.0.2" -> + { + link = + "https://github.com/mirage/ocaml-9p/blob/931c745e45d685f4351f14ce50d2ca128895316f/LICENSE.md"; + text = {| Copyright (c) 2015, MirageOS - |} ^ isc - } - | "uri.4.2.0" | "uri.4.4.0" | "uri-sexp.4.2.0" | "uri-sexp.4.4.0" -> { - link = "https://github.com/mirage/ocaml-uri/blob/0ff3efbbc235bef5a7d67cc01bc1dadbe2e859b9/LICENSE.md"; - text = {| + |} ^ isc; + } + | "uri.4.2.0" | "uri.4.4.0" | "uri-sexp.4.2.0" | "uri-sexp.4.4.0" -> + { + link = + "https://github.com/mirage/ocaml-uri/blob/0ff3efbbc235bef5a7d67cc01bc1dadbe2e859b9/LICENSE.md"; + text = + {| Copyright (c) <the authors, see individual headers on files> - |} ^ isc - } - | "mirage-entropy.0.4.1" | "mirage-entropy.0.5.0" | "mirage-entropy.0.5.1" -> { - link = "https://github.com/mirage/mirage-entropy/blob/8d4c9ed42dbea225b306af082acd8e15464287ba/LICENSE.md"; - text = {| + |} + ^ isc; + } + | "mirage-entropy.0.4.1" | "mirage-entropy.0.5.0" | "mirage-entropy.0.5.1" -> + { + link = + "https://github.com/mirage/mirage-entropy/blob/8d4c9ed42dbea225b306af082acd8e15464287ba/LICENSE.md"; + text = + {| Copyright (c) 2014-2016, Hannes Mehnert, Anil Madhavapeddy, David Kaloper Meršinjak All rights reserved. - |} ^ bsd_2_clause_simplified - } - | "mirage-kv.4.0.0" | "mirage-kv.4.0.1" | "mirage-kv.5.0.0" -> { - link = "https://github.com/mirage/mirage-kv/blob/5c2c75e5a0efc0c9390b11fab75b1e706ea8d4ab/LICENSE.md"; - text = isc - } - | "mirage-protocols.8.0.0" -> { - link = "https://github.com/mirage/mirage-protocols/blob/37aa4a86f9f423bb7fe1d70c8a71331060a45048/LICENSE.md"; - text = isc; - } - | "psq.0.2.0" | "psq.0.2.1" -> { - link = "https://github.com/pqwy/psq/blob/beeaf9396655d195f9a20243102c9773d826d3b0/LICENSE.md"; - text = {| + |} + ^ bsd_2_clause_simplified; + } + | "mirage-kv.4.0.0" | "mirage-kv.4.0.1" | "mirage-kv.5.0.0" -> + { + link = + "https://github.com/mirage/mirage-kv/blob/5c2c75e5a0efc0c9390b11fab75b1e706ea8d4ab/LICENSE.md"; + text = isc; + } + | "mirage-protocols.8.0.0" -> + { + link = + "https://github.com/mirage/mirage-protocols/blob/37aa4a86f9f423bb7fe1d70c8a71331060a45048/LICENSE.md"; + text = isc; + } + | "psq.0.2.0" | "psq.0.2.1" -> + { + link = + "https://github.com/pqwy/psq/blob/beeaf9396655d195f9a20243102c9773d826d3b0/LICENSE.md"; + text = {| Copyright (c) 2016 David Kaloper Meršinjak - |} ^ isc - } - | "randomconv.0.1.3" -> { - link = "https://github.com/hannesm/randomconv/blob/045d7fd3454151930cb9941b0cd3a228ddebe68b/LICENSE.md"; - text = {| + |} ^ isc; + } + | "randomconv.0.1.3" -> + { + link = + "https://github.com/hannesm/randomconv/blob/045d7fd3454151930cb9941b0cd3a228ddebe68b/LICENSE.md"; + text = + {| Copyright (c) 2016 Hannes Mehnert hannes@mehnert.org - |} ^ isc - } - | "re.1.10.3" | "re.1.10.4" | "re.1.11.0" -> { - link = "https://github.com/ocaml/ocaml-re/blob/c5d5df80e128c3d7646b7d8b1322012c5fcc35f3/LICENSE.md"; - text = {| + |} + ^ isc; + } + | "re.1.10.3" | "re.1.10.4" | "re.1.11.0" -> + { + link = + "https://github.com/ocaml/ocaml-re/blob/c5d5df80e128c3d7646b7d8b1322012c5fcc35f3/LICENSE.md"; + text = + {| This Software is distributed under the terms of the GNU Lesser General Public License version 2.1 (included below), or (at your option) any later version. @@ -821,11 +958,15 @@ covered by the GNU Library General Public License. ---------------------------------------------------------------------- - |} ^ lgpl21 - } - | "mmap.1.1.0" | "mmap.1.2.0" -> { - link = "https://github.com/mirage/mmap/blob/46f613db11c00667764523ccbb3d63e53e1c666c/LICENSE"; - text = {| + |} + ^ lgpl21; + } + | "mmap.1.1.0" | "mmap.1.2.0" -> + { + link = + "https://github.com/mirage/mmap/blob/46f613db11c00667764523ccbb3d63e53e1c666c/LICENSE"; + text = + {| In the following, "the OCaml Core System" refers to all files marked "Copyright INRIA" in this distribution. @@ -848,11 +989,15 @@ might be covered by the GNU Lesser General Public License. ---------------------------------------------------------------------- - |} ^ lgpl21 - } - | "num.1.4" | "num.1.5-1" -> { - link = "https://github.com/ocaml/num/blob/814c159ea6cebff3b1f61b2055b893be87084ae3/LICENSE"; - text = {| + |} + ^ lgpl21; + } + | "num.1.4" | "num.1.5-1" -> + { + link = + "https://github.com/ocaml/num/blob/814c159ea6cebff3b1f61b2055b893be87084ae3/LICENSE"; + text = + {| The Num library is copyright Institut National de Recherche en Informatique et en Automatique (INRIA) and distributed under the terms of the GNU Lesser General Public License (LGPL) version 2.1 (included below). @@ -876,11 +1021,14 @@ the license in file toplevel/LICENSE-findlib. ---------------------------------------------------------------------- - |} ^ lgpl21 - } - | "camlp-streams.5.0" | "camlp-streams.5.0.1" -> { - link = "https://github.com/ocaml/camlp-streams/blob/trunk/LICENSE"; - text = {| + |} + ^ lgpl21; + } + | "camlp-streams.5.0" | "camlp-streams.5.0.1" -> + { + link = "https://github.com/ocaml/camlp-streams/blob/trunk/LICENSE"; + text = + {| The Camlp-streams library is copyright Institut National de Recherche en Informatique et en Automatique (INRIA) and distributed under the terms of the GNU Lesser General Public License (LGPL) version 2.1 @@ -904,20 +1052,21 @@ the license in file toplevel/LICENSE-findlib. ---------------------------------------------------------------------- - |} ^ lgpl21 - } - | "ocaml.4.08.0" | "ocaml-base-compiler.4.08.0" - | "ocaml.4.12.0" | "ocaml-base-compiler.4.12.0" - | "ocaml.4.13.0" | "ocaml-base-compiler.4.13.0" - | "ocaml.4.13.1" | "ocaml-base-compiler.4.13.1" - | "ocaml.4.14.0" | "ocaml-base-compiler.4.14.0" - | "ocaml.4.14.1" | "ocaml-base-compiler.4.14.1" - | "ocaml.4.14.2" | "ocaml-base-compiler.4.14.2" - | "ocaml-variants.4.08.0+mingw64c" - | "ocaml-variants.4.13.1+mingw64c" - | "seq.base" | "stdlib-shims.0.3.0" | "uchar.0.0.2" -> { - link = "https://github.com/ocaml/ocaml/blob/a095535e5c02a95da4908a82d9f75a62609cc592/LICENSE"; - text = {| + |} + ^ lgpl21; + } + | "ocaml.4.08.0" | "ocaml-base-compiler.4.08.0" | "ocaml.4.12.0" + | "ocaml-base-compiler.4.12.0" | "ocaml.4.13.0" | "ocaml-base-compiler.4.13.0" + | "ocaml.4.13.1" | "ocaml-base-compiler.4.13.1" | "ocaml.4.14.0" + | "ocaml-base-compiler.4.14.0" | "ocaml.4.14.1" | "ocaml-base-compiler.4.14.1" + | "ocaml.4.14.2" | "ocaml-base-compiler.4.14.2" + | "ocaml-variants.4.08.0+mingw64c" | "ocaml-variants.4.13.1+mingw64c" + | "seq.base" | "stdlib-shims.0.3.0" | "uchar.0.0.2" -> + { + link = + "https://github.com/ocaml/ocaml/blob/a095535e5c02a95da4908a82d9f75a62609cc592/LICENSE"; + text = + {| In the following, "the OCaml Core System" refers to all files marked "Copyright INRIA" in this distribution. @@ -940,103 +1089,145 @@ might be covered by the GNU Lesser General Public License. ---------------------------------------------------------------------- - |} ^ lgpl21 - } - | "domain-name.0.4.0" | "duration.0.2.0" | "duration.0.2.1" -> { - link = "https://github.com/hannesm/domain-name/blob/e9833486ee40ef2c49c43dd72976022a627b4a34/LICENSE.md"; - text = {| + |} + ^ lgpl21; + } + | "domain-name.0.4.0" | "duration.0.2.0" | "duration.0.2.1" -> + { + link = + "https://github.com/hannesm/domain-name/blob/e9833486ee40ef2c49c43dd72976022a627b4a34/LICENSE.md"; + text = + {| Copyright (c) 2017 2018 Hannes Mehnert hannes@mehnert.org - |} ^ isc - } - | "cppo.1.6.8" | "cppo.1.6.9" -> { - link = "https://github.com/ocaml-community/cppo/blob/94b2d0f21fcda5473773518a12afbcff45a52990/LICENSE.md"; - text = {| + |} + ^ isc; + } + | "cppo.1.6.8" | "cppo.1.6.9" -> + { + link = + "https://github.com/ocaml-community/cppo/blob/94b2d0f21fcda5473773518a12afbcff45a52990/LICENSE.md"; + text = + {| Copyright (c) 2009-2011 Martin Jambon All rights reserved. - |}^bsd_3_clause_new_or_revised - } - | "fd-send-recv.2.0.1" -> { - link = "https://github.com/xapi-project/ocaml-fd-send-recv/blob/7c9b151a7cc54f11c45280177027d9d42473737c/LICENSE"; - text = lgpl21_with_ocaml_linking_exception; - } - | "fmt.0.9.0" -> { - link = "https://github.com/dbuenzli/fmt/blob/11221dcfd08c9b21c2dc63378fd6ffe75333fb33/LICENSE.md"; - text = {| + |} + ^ bsd_3_clause_new_or_revised; + } + | "fd-send-recv.2.0.1" -> + { + link = + "https://github.com/xapi-project/ocaml-fd-send-recv/blob/7c9b151a7cc54f11c45280177027d9d42473737c/LICENSE"; + text = lgpl21_with_ocaml_linking_exception; + } + | "fmt.0.9.0" -> + { + link = + "https://github.com/dbuenzli/fmt/blob/11221dcfd08c9b21c2dc63378fd6ffe75333fb33/LICENSE.md"; + text = {| Copyright (c) 2016 The fmt programmers - |} ^ isc - } - | "logs.0.7.0" -> { - link = "https://github.com/dbuenzli/logs/blob/346f2cb5279a0dfee0e57fff109b8994982ce66f/LICENSE.md"; - text = {| + |} ^ isc; + } + | "logs.0.7.0" -> + { + link = + "https://github.com/dbuenzli/logs/blob/346f2cb5279a0dfee0e57fff109b8994982ce66f/LICENSE.md"; + text = {| Copyright (c) 2016 The logs programmers - |} ^ isc - } - | "rresult.0.7.0" -> { - link = "https://github.com/dbuenzli/rresult/blob/e94378d2b216632970dc41f8ca6c71611acbaf03/LICENSE.md"; - text = {| + |} ^ isc; + } + | "rresult.0.7.0" -> + { + link = + "https://github.com/dbuenzli/rresult/blob/e94378d2b216632970dc41f8ca6c71611acbaf03/LICENSE.md"; + text = {| Copyright (c) 2014 The rresult programmers - |} ^ isc - } - | "jsonm.1.0.1" | "jsonm.1.0.2" -> { - link = "https://github.com/dbuenzli/jsonm/blob/15ba785854b8b6e45958570d23238b603cd3f8d6/LICENSE.md"; - text = {| + |} ^ isc; + } + | "jsonm.1.0.1" | "jsonm.1.0.2" -> + { + link = + "https://github.com/dbuenzli/jsonm/blob/15ba785854b8b6e45958570d23238b603cd3f8d6/LICENSE.md"; + text = {| Copyright (c) 2012 Daniel C. Bünzli - |} ^ isc - } - | "uuidm.0.9.7" -> { - link = "https://github.com/dbuenzli/uuidm/blob/091571745bc207eaf9aec450e36ff885b0b631e9/LICENSE.md"; - text = {| + |} ^ isc; + } + | "uuidm.0.9.7" -> + { + link = + "https://github.com/dbuenzli/uuidm/blob/091571745bc207eaf9aec450e36ff885b0b631e9/LICENSE.md"; + text = {| Copyright (c) 2008 Daniel C. Bünzli - |} ^ isc - } - | "uutf.1.0.2" | "uutf.1.0.3" -> { - link = "https://github.com/dbuenzli/uutf/blob/d43c88c0673b0d30dc34960645d0f992d68b23a1/LICENSE.md"; - text = {| + |} ^ isc; + } + | "uutf.1.0.2" | "uutf.1.0.3" -> + { + link = + "https://github.com/dbuenzli/uutf/blob/d43c88c0673b0d30dc34960645d0f992d68b23a1/LICENSE.md"; + text = {| Copyright (c) 2016 Daniel C. Bünzli - |} ^ isc - } - | "uwt.0.3.3" | "uwt.0.3.4~dev" -> { - link = "https://github.com/fdopen/uwt/blob/44276aa6755b92eddc9ad58662a968afad243e8b/LICENSE.md"; - text = {| + |} ^ isc; + } + | "uwt.0.3.3" | "uwt.0.3.4~dev" -> + { + link = + "https://github.com/fdopen/uwt/blob/44276aa6755b92eddc9ad58662a968afad243e8b/LICENSE.md"; + text = + {| Copyright (c) 2015-2018, the Authors of uwt (dist/AUTHORS) - |} ^ mit - } - | "lru.0.3.0" | "lru.0.3.1" -> { - link = "https://github.com/pqwy/lru/blob/3a0b5f9effa86f6615501a648069b9a12c5096e5/LICENSE.md"; - text = {| + |} + ^ mit; + } + | "lru.0.3.0" | "lru.0.3.1" -> + { + link = + "https://github.com/pqwy/lru/blob/3a0b5f9effa86f6615501a648069b9a12c5096e5/LICENSE.md"; + text = {| Copyright (c) 2016 David Kaloper Meršinjak - |} ^ isc - } - | "lwt.5.5.0" | "lwt.5.6.1" | "lwt.5.7.0" | "lwt-dllist.1.0.1" -> { - link = "https://github.com/ocsigen/lwt/blob/bab52d9744cb2d5cd3cfe86cda65ba73752998ee/LICENSE.md"; - text = {| + |} ^ isc; + } + | "lwt.5.5.0" | "lwt.5.6.1" | "lwt.5.7.0" | "lwt-dllist.1.0.1" -> + { + link = + "https://github.com/ocsigen/lwt/blob/bab52d9744cb2d5cd3cfe86cda65ba73752998ee/LICENSE.md"; + text = + {| Copyright (c) 1999-2020, the Authors of Lwt (docs/AUTHORS) - |} ^ mit - } - | "menhir.20211230" | "menhirLib.20211230" | "menhirSdk.20211230" - | "menhir.20220210" | "menhirLib.20220210" | "menhirSdk.20220210" - | "menhirSdk.20240715" | "menhirLib.20240715" | "menhirCST.20240715" | "menhir.20240715" - -> { - link = "https://gitlab.inria.fr/fpottier/menhir/-/blob/20211230/LICENSE"; - text = {| + |} + ^ mit; + } + | "menhir.20211230" | "menhirLib.20211230" | "menhirSdk.20211230" + | "menhir.20220210" | "menhirLib.20220210" | "menhirSdk.20220210" + | "menhirSdk.20240715" | "menhirLib.20240715" | "menhirCST.20240715" + | "menhir.20240715" -> + { + link = "https://gitlab.inria.fr/fpottier/menhir/-/blob/20211230/LICENSE"; + text = + {| THE RUNTIME LIBRARY is distributed under the terms of the GNU Library General Public License version 2 (included below). - |} ^ lgpl21_with_ocaml_linking_exception - } - | "ocplib-endian.1.2" -> { - link = "https://github.com/OCamlPro/ocplib-endian/blob/10292cd3ffa4d23d737e3f855ad04f22d3d95460/COPYING.txt"; - text = lgpl21_with_ocaml_linking_exception; - } - | "ounit.2.2.4" | "ounit.2.2.6" | "ounit.2.2.7" | "ounit2.2.2.4" | "ounit2.2.2.6" | "ounit2.2.2.7" -> { - link = "https://github.com/gildor478/ounit/blob/faf4936b17507406c7592186dcaa3f25c6fc138a/LICENSE.txt"; - text = {| + |} + ^ lgpl21_with_ocaml_linking_exception; + } + | "ocplib-endian.1.2" -> + { + link = + "https://github.com/OCamlPro/ocplib-endian/blob/10292cd3ffa4d23d737e3f855ad04f22d3d95460/COPYING.txt"; + text = lgpl21_with_ocaml_linking_exception; + } + | "ounit.2.2.4" | "ounit.2.2.6" | "ounit.2.2.7" | "ounit2.2.2.4" + | "ounit2.2.2.6" | "ounit2.2.2.7" -> + { + link = + "https://github.com/gildor478/ounit/blob/faf4936b17507406c7592186dcaa3f25c6fc138a/LICENSE.txt"; + text = + {| Copyright (c) 2002, 2003 by Maas-Maarten Zeeman Copyright (c) 2010 by OCamlCore SARL Copyright (C) 2013 Sylvain Le Gall @@ -1061,29 +1252,40 @@ In no event shall Maas-Maarten Zeeman be liable for any claim, damages or other liability, whether in an action of contract, tort or otherwise, arising from, out of or in connection with the Software or the use or other dealings in the software. - |} - } - | "sha.1.15.1" | "sha.1.15.2" | "sha.1.15.4" -> { - link = "https://github.com/djs55/ocaml-sha/blob/af5c7b1c7d3b8f9492038b7b40ba9cad82fb4ee8/LICENSE.md"; - text = isc; - } - | "stringext.1.6.0" -> { - link = "https://github.com/rgrinberg/stringext/blob/2bce0a6fe54e8f8782f7a3b2be44a5e1fb37a522/LICENSE.md"; - text = {| + |}; + } + | "sha.1.15.1" | "sha.1.15.2" | "sha.1.15.4" -> + { + link = + "https://github.com/djs55/ocaml-sha/blob/af5c7b1c7d3b8f9492038b7b40ba9cad82fb4ee8/LICENSE.md"; + text = isc; + } + | "stringext.1.6.0" -> + { + link = + "https://github.com/rgrinberg/stringext/blob/2bce0a6fe54e8f8782f7a3b2be44a5e1fb37a522/LICENSE.md"; + text = {| Copyright (c) 2017 Rudi Grinberg - |} ^ mit - } - | "tar.2.0.0" | "tar.2.0.1" -> { - link = "https://github.com/mirage/ocaml-tar/blob/4da72c48eb1ea1066052216cdcfa12c5931c6eec/LICENSE.md"; - text = {| + |} ^ mit; + } + | "tar.2.0.0" | "tar.2.0.1" -> + { + link = + "https://github.com/mirage/ocaml-tar/blob/4da72c48eb1ea1066052216cdcfa12c5931c6eec/LICENSE.md"; + text = + {| Copyright (c) 2012-2018 The ocaml-tar contributors - |} ^ isc - } - | "tcpip.7.0.1" | "tcpip.7.1.0" | "tcpip.7.1.1" | "tcpip.7.1.2" -> { - link = "https://github.com/mirage/mirage-tcpip/blob/353f7b92a1a8747923ce6918426fd3f82aa27445/LICENSE.md"; - text = {| + |} + ^ isc; + } + | "tcpip.7.0.1" | "tcpip.7.1.0" | "tcpip.7.1.1" | "tcpip.7.1.2" -> + { + link = + "https://github.com/mirage/mirage-tcpip/blob/353f7b92a1a8747923ce6918426fd3f82aa27445/LICENSE.md"; + text = + {| Copyright (c) Anil Madhavapeddy <anil@recoil.org> Copyright (c) Balraj Singh <balrajsingh@ieee.org> Copyright (c) Citrix Inc @@ -1106,108 +1308,130 @@ Copyright (c) Tim Cuthbertson <tim@gfxmonk.net> Copyright (c) Vincent Bernardoff <vb@luminar.eu.org> Copyright (c) lnmx <len@lnmx.org> Copyright (c) pqwy <david@numm.org> - |} ^ isc - } - | "charrua.1.5.0" | "charrua-client.1.5.0" | "charrua-server.1.5.0"-> { - link = "https://github.com/mirage/charrua/blob/fb614f77b8f4cbd5f6409453a8f030b21d7e1a93/LICENSE.md"; - text = {| + |} + ^ isc; + } + | "charrua.1.5.0" | "charrua-client.1.5.0" | "charrua-server.1.5.0" -> + { + link = + "https://github.com/mirage/charrua/blob/fb614f77b8f4cbd5f6409453a8f030b21d7e1a93/LICENSE.md"; + text = + {| Copyright (c) 2015-2017 Christiano F. Haesbaert <haesbaert@haesbaert.org> Copyright (c) 2016 Gina Marie Maini <gina@beancode.io> Copyright (c) 2016-2017 Mindy Preston - |} ^ isc - - } - | "vpnkit.0.2.0" | "vpnkit.0.5.0" -> { - link = "https://github.com/moby/vpnkit/blob/master/LICENSE"; - text = apache2 "Copyright 2013-2016 Docker, Inc." - } - | "win-error.1.0" -> { - link = "https://github.com/mirage/ocaml-win-error/blob/4cf370285d1d2e45cf750b037222cee0c6f52e9f/LICENSE"; - text = {| + |} + ^ isc; + } + | "vpnkit.0.2.0" | "vpnkit.0.5.0" -> + { + link = "https://github.com/moby/vpnkit/blob/master/LICENSE"; + text = apache2 "Copyright 2013-2016 Docker, Inc."; + } + | "win-error.1.0" -> + { + link = + "https://github.com/mirage/ocaml-win-error/blob/4cf370285d1d2e45cf750b037222cee0c6f52e9f/LICENSE"; + text = {| Copyright (c) 2016, Dave Scott - |} ^ isc - } - | x -> failwith (Printf.sprintf "unknown license for " ^ x) - -let linked_into_executable = function - | "ocaml-config" - | "conf-which" -> false (* part of OCaml infra *) - | "conf-pkg-config" - | "ocamlbuild" - | "ocamlfind" - | "ppx_derivers" - | "ppx_sexp_conv" - | "ppx_tools" - | "ppxlib" -> false - | _ -> true - -let base_package name = Stringext.chop_prefix ~prefix:"base-" name <> None - -(* Command-line frontend and .csv parser: *) - -let usage_msg = "licenses -in <deps.csv> -out <licenses.json>" -let output_file = ref "licenses.json" -let input_file = ref "deps.csv" - -let speclist = - [("-out", Arg.Set_string output_file, "Set output file name"); - ("-in", Arg.Set_string input_file, "Set input file name")] - -let run cmd = match Unix.system cmd with - | Unix.WEXITED 0 -> () - | Unix.WEXITED n -> failwith (Printf.sprintf "%s: %d" cmd n) - | _ -> failwith (Printf.sprintf "%s: unexpected signal" cmd) - -let trim_comment line = match Stringext.cut ~on:"#" line with - | None -> line - | Some (line, _comment) -> line - -let () = - Arg.parse speclist ignore usage_msg; - let ic = open_in !input_file in - let missing = ref [] in - let parse_line line = - let line = trim_comment line in - if line = "" - then None - else match Stringext.split ~on:',' (trim_comment line) with - | name :: package :: rest -> - let name = String.trim name in - let package = String.trim package in - let license_ty = match rest with - | [ x ] -> - (* opam quotes these *) - if String.length x >= 2 && x.[0] = '"' && x.[String.length x - 1] = '"' - then String.sub x 1 (String.length x - 2) - else x - | _ -> "" in - if linked_into_executable name && not(base_package name) - then (try Some (package, license_ty, licenses package) with _ -> missing := package :: !missing; None) - else None - | _ -> - failwith (Printf.sprintf "unable to parse %s" line) in - let gather_licenses () = - let all = ref [] in - try - while true do - match parse_line (input_line ic) with - | None -> () - | Some l -> all := l :: !all - done; - !all - with - | End_of_file -> !all in - let all = gather_licenses () in - if !missing <> [] then failwith (Printf.sprintf "unknown licenses for %s" (String.concat ", " !missing)); - let json = `A (List.map (fun (package, license_ty, license) -> - `O [ - "name", `String package; (* name.version *) - "type", `String license_ty; - "link", `String license.link; - "text", `String license.text; - ] - ) all) in - let oc = open_out !output_file in - Ezjsonm.to_channel ~minify:false oc json + |} ^ isc; + } + | x -> failwith (Printf.sprintf "unknown license for " ^ x) + +let linked_into_executable = function + | "ocaml-config" | "conf-which" -> false (* part of OCaml infra *) + | "conf-pkg-config" | "ocamlbuild" | "ocamlfind" | "ppx_derivers" + | "ppx_sexp_conv" | "ppx_tools" | "ppxlib" -> + false + | _ -> true + +let base_package name = Stringext.chop_prefix ~prefix:"base-" name <> None + +(* Command-line frontend and .csv parser: *) + +let usage_msg = "licenses -in <deps.csv> -out <licenses.json>" +let output_file = ref "licenses.json" +let input_file = ref "deps.csv" + +let speclist = + [ + ("-out", Arg.Set_string output_file, "Set output file name"); + ("-in", Arg.Set_string input_file, "Set input file name"); + ] + +let run cmd = + match Unix.system cmd with + | Unix.WEXITED 0 -> () + | Unix.WEXITED n -> failwith (Printf.sprintf "%s: %d" cmd n) + | _ -> failwith (Printf.sprintf "%s: unexpected signal" cmd) + +let trim_comment line = + match Stringext.cut ~on:"#" line with + | None -> line + | Some (line, _comment) -> line + +let () = + Arg.parse speclist ignore usage_msg; + let ic = open_in !input_file in + let missing = ref [] in + let parse_line line = + let line = trim_comment line in + if line = "" then None + else + match Stringext.split ~on:',' (trim_comment line) with + | name :: package :: rest -> + let name = String.trim name in + let package = String.trim package in + let license_ty = + match rest with + | [ x ] -> + (* opam quotes these *) + if + String.length x >= 2 + && x.[0] = '"' + && x.[String.length x - 1] = '"' + then String.sub x 1 (String.length x - 2) + else x + | _ -> "" + in + if linked_into_executable name && not (base_package name) then ( + try Some (package, license_ty, licenses package) + with _ -> + missing := package :: !missing; + None) + else None + | _ -> failwith (Printf.sprintf "unable to parse %s" line) + in + let gather_licenses () = + let all = ref [] in + try + while true do + match parse_line (input_line ic) with + | None -> () + | Some l -> all := l :: !all + done; + !all + with End_of_file -> !all + in + let all = gather_licenses () in + if !missing <> [] then + failwith + (Printf.sprintf "unknown licenses for %s" (String.concat ", " !missing)); + let json = + `A + (List.map + (fun (package, license_ty, license) -> + `O + [ + ("name", `String package); + (* name.version *) + ("type", `String license_ty); + ("link", `String license.link); + ("text", `String license.text); + ]) + all) + in + let oc = open_out !output_file in + Ezjsonm.to_channel ~minify:false oc json File "src/dns_forward/dns_forward.mli", line 1, characters 0-0: diff --git a/_build/default/src/dns_forward/dns_forward.mli b/_build/default/src/dns_forward/.formatted/dns_forward.mli index bed2650..9bdbd0b 100644 --- a/_build/default/src/dns_forward/dns_forward.mli +++ b/_build/default/src/dns_forward/.formatted/dns_forward.mli @@ -15,23 +15,23 @@ * *) -module Error: sig +module Error : sig type 'a t = ('a, [ `Msg of string ]) result Lwt.t (** All errors are currently fatal and should cause the request being processed or the program to abort *) - module Infix: sig - val (>>=): 'a t -> ('a -> 'b t) -> 'b t + module Infix : sig + val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t end end module type Comparable = sig type t - val compare: t -> t -> int + val compare : t -> t -> int end -module Flow: sig +module Flow : sig (** A BSD-socket-like interface for establishing flows by connecting to a well-known address (see Client) or by listening for incoming connections on a well-known address (see Server) *) @@ -42,34 +42,35 @@ module Flow: sig type address (** Identifies an endpoint for [connect] *) - val connect: ?read_buffer_size:int -> address -> flow Error.t + val connect : ?read_buffer_size:int -> address -> flow Error.t (** [connect address] creates a connection to [address] and returns he connected flow. *) end + module type Server = sig type server (* A server bound to some address *) type address - val bind: address -> server Error.t + val bind : address -> server Error.t (** Bind a server to an address *) - val getsockname: server -> address + val getsockname : server -> address (** Query the address the server is bound to *) type flow - val listen: server -> (flow -> unit Lwt.t) -> unit + val listen : server -> (flow -> unit Lwt.t) -> unit (** Accept connections forever, calling the callback with each one. Connections are closed automatically when the callback finishes. *) - val shutdown: server -> unit Lwt.t + val shutdown : server -> unit Lwt.t (** Stop accepting connections on the given server *) end end -module Framing: sig +module Framing : sig (** DNS messages are framed when sent over other protocols. These modules convert byte-stream flows into streams of framed messages. *) @@ -88,58 +89,56 @@ module Framing: sig type flow (** The flow over which we read and write complete DNS messages *) - val connect: flow -> t + val connect : flow -> t (** Prepare to read and write complete DNS messages over the given flow *) - val read: t -> request Error.t + val read : t -> request Error.t (** Read a complete DNS message *) - val write: t -> response -> unit Error.t + val write : t -> response -> unit Error.t (** Write a complete DNS message *) - val close: t -> unit Lwt.t + val close : t -> unit Lwt.t (** Free resources and close the underlying flow *) end - module Tcp(Flow: Mirage_flow.S): S with type flow = Flow.flow (** Use TCP framing *) + module Tcp (Flow : Mirage_flow.S) : S with type flow = Flow.flow - module Udp(Flow: Mirage_flow.S): S with type flow = Flow.flow (** Use UDP framing *) + module Udp (Flow : Mirage_flow.S) : S with type flow = Flow.flow end -module Config: sig - module Address: sig - type t = { - ip: Ipaddr.t; - port: int; - } +module Config : sig + module Address : sig + type t = { ip : Ipaddr.t; port : int } (** The address of a DNS server *) - val to_string: t -> string + val to_string : t -> string include Comparable with type t := t - module Set: Set.S with type elt = t - module Map: Map.S with type key = t + module Set : Set.S with type elt = t + module Map : Map.S with type key = t end - module Domain: sig + module Domain : sig type t = string list (** A DNS domain e.g. [ "a"; "b" ] would be the domain a.b. *) - val to_string: t -> string + val to_string : t -> string include Comparable with type t := t - module Set: Set.S with type elt = t - module Map: Map.S with type key = t + module Set : Set.S with type elt = t + module Map : Map.S with type key = t end - module Server: sig + module Server : sig type t = { - zones: Domain.Set.t; (** use this server for these specific domains *) - address: Address.t; - timeout_ms: int option; (** a specific timeout to use for this server in milliseconds *) - order: int; (** lower means earlier *) + zones : Domain.Set.t; (** use this server for these specific domains *) + address : Address.t; + timeout_ms : int option; + (** a specific timeout to use for this server in milliseconds *) + order : int; (** lower means earlier *) } (** A single upstream DNS server. If [zones = []] then the server can handle all queries; otherwise [zones] is a list of domains that this server @@ -149,38 +148,38 @@ module Config: sig leaking internal names by sending queries to public server. *) include Comparable with type t := t - module Set: Set.S with type elt = t - module Map: Map.S with type key = t + module Set : Set.S with type elt = t + module Map : Map.S with type key = t end type t = { - servers: Server.Set.t; (** Upstream DNS servers *) - search: string list; (** Ordered list of domains to search *) - assume_offline_after_drops: int option; - (** Once this number of drops have happened, assume the server is offline *) + servers : Server.Set.t; (** Upstream DNS servers *) + search : string list; (** Ordered list of domains to search *) + assume_offline_after_drops : int option; + (** Once this number of drops have happened, assume the server is offline *) } (** A DNS configuration *) include Comparable with type t := t - val to_string: t -> string + val to_string : t -> string (** Return a human-readable string corresponding to a configuration *) - val of_string: string -> (t, [ `Msg of string ]) result + val of_string : string -> (t, [ `Msg of string ]) result (** Parse the output of [to_string] *) - val compare: t -> t -> int + val compare : t -> t -> int - module Unix: sig - val of_resolv_conf: string -> (t, [ `Msg of string ]) result + module Unix : sig + val of_resolv_conf : string -> (t, [ `Msg of string ]) result (** Parse a Unix-style /etc/resolv.conf file *) end end -module Rpc: sig +module Rpc : sig (** A Remote Procedure Call client and server implementation *) - module Client: sig + module Client : sig module type S = sig type t (** A Remote Procedure Call client which can send requests to a server @@ -195,42 +194,48 @@ module Rpc: sig type address = Config.Address.t (** The address of the remote endpoint *) - type message_cb = ?src:address -> ?dst:address -> buf:Cstruct.t -> unit -> unit Lwt.t + type message_cb = + ?src:address -> ?dst:address -> buf:Cstruct.t -> unit -> unit Lwt.t (** A callback called per message, which permits recording and analysis. If an address is unknown (e.g. it is selected by the kernel when routing the packets) then the corresponding argument will be omitted *) - val connect: gen_transaction_id:(int -> int) -> ?message_cb:message_cb -> address -> t Error.t + val connect : + gen_transaction_id:(int -> int) -> + ?message_cb:message_cb -> + address -> + t Error.t (** Connect to the remote server *) - val rpc: t -> request -> response Error.t + val rpc : t -> request -> response Error.t (** Send a request and await a response. Multiple threads may call this in parallel and it is the implementation's job to associate the right response with the original request. *) - val disconnect: t -> unit Lwt.t + val disconnect : t -> unit Lwt.t (** Disconnect from the server and free all resources. *) end - module Persistent: sig - module Make - (Flow: Flow.Client with type address = Ipaddr.t * int) - (Framing: Framing.S with type flow = Flow.flow) - (Time: Mirage_time.S): S + module Persistent : sig (** Construct a multiplexing RPC client given a Flow and a method of Framing messages over the flow. *) - end - module Nonpersistent: sig module Make - (Flow: Flow.Client with type address = Ipaddr.t * int) - (Framing: Framing.S with type flow = Flow.flow) - (Time: Mirage_time.S): S + (Flow : Flow.Client with type address = Ipaddr.t * int) + (Framing : Framing.S with type flow = Flow.flow) + (Time : Mirage_time.S) : S + end + + module Nonpersistent : sig (** Construct an RPC client given a Flow which sends one message per fresh connection over the flow. *) + module Make + (Flow : Flow.Client with type address = Ipaddr.t * int) + (Framing : Framing.S with type flow = Flow.flow) + (Time : Mirage_time.S) : S end end - module Server: sig + module Server : sig module type S = sig type server (** A Remote Procedure Call server which will listen on an address, accept @@ -245,50 +250,52 @@ module Rpc: sig type address = Config.Address.t (** The address of the server *) - val bind: address -> server Error.t + val bind : address -> server Error.t (** Bind to the given address. This will fail if the address does not exist or if another server is already bound there. *) - val listen: server -> (request -> response Error.t) -> unit Error.t + val listen : server -> (request -> response Error.t) -> unit Error.t (** Listen and accept incoming connections, use the provided callback to answer requests. *) - val shutdown: server -> unit Lwt.t + val shutdown : server -> unit Lwt.t (** Shutdown the server and free any allocated resources. *) end - module Make - (Flow: Flow.Server with type address = Ipaddr.t * int) - (Framing: Framing.S with type flow = Flow.flow) - (Time: Mirage_time.S): S (** Construct an RPC server given a Flow and a method of Framing messages over the flow. *) + module Make + (Flow : Flow.Server with type address = Ipaddr.t * int) + (Framing : Framing.S with type flow = Flow.flow) + (Time : Mirage_time.S) : S end end -module Resolver: sig +module Resolver : sig (** A Resolver converts a DNS query into an optional DNS response. *) module type S = sig type t type address = Config.Address.t - type message_cb = ?src:address -> ?dst:address -> buf:Cstruct.t -> unit -> unit Lwt.t + type message_cb = + ?src:address -> ?dst:address -> buf:Cstruct.t -> unit -> unit Lwt.t (** A callback called per message, which permits recording and analysis. If an address is unknown (e.g. it is selected by the kernel when routing the packets) then the corresponding argument will be omitted *) - val create: + val create : ?local_names_cb:(Dns.Packet.question -> Dns.Packet.rr list option Lwt.t) -> gen_transaction_id:(int -> int) -> ?message_cb:message_cb -> - Config.t -> t Lwt.t + Config.t -> + t Lwt.t (** Construct a resolver given some configuration *) - val destroy: t -> unit Lwt.t + val destroy : t -> unit Lwt.t (** Destroy and free all resources associated with the resolver *) - val answer: Cstruct.t -> t -> Cstruct.t Error.t + val answer : Cstruct.t -> t -> Cstruct.t Error.t (** Process a query by first checking whether the name can be satisfied locally via the [local_names_cb] and failing that, sending it to upstream servers according to the resolver configuration. The call @@ -296,17 +303,16 @@ module Resolver: sig should be prepared to timeout and cancel the thread. *) end - module Make - (Client: Rpc.Client.S) - (Time : Mirage_time.S) - (Clock : Mirage_clock.MCLOCK): - S (** Construct a DNS resolver which will use the given [Client] Implementation to contact upstream servers, and the given [Time] implementation to handle timeouts. *) + module Make + (Client : Rpc.Client.S) + (Time : Mirage_time.S) + (Clock : Mirage_clock.MCLOCK) : S end -module Server: sig +module Server : sig (** A server listens for incoming connections containing streams of requests and attempts to answer them using the given client. *) @@ -316,18 +322,16 @@ module Server: sig type resolver - val create: resolver -> t Lwt.t + val create : resolver -> t Lwt.t (** Construct a server given a resolver configuration *) - val serve: - address:Config.Address.t -> - t -> unit Error.t + val serve : address:Config.Address.t -> t -> unit Error.t (** Serve requests on the given [address] forever *) - val destroy: t -> unit Lwt.t + val destroy : t -> unit Lwt.t (** Shutdown the server and release allocated resources *) end - module Make(Server: Rpc.Server.S)(Resolver: Resolver.S): S with type resolver = Resolver.t - + module Make (Server : Rpc.Server.S) (Resolver : Resolver.S) : + S with type resolver = Resolver.t end File "src/dns_forward/dns_forward_config.ml", line 1, characters 0-0: diff --git a/_build/default/src/dns_forward/dns_forward_config.ml b/_build/default/src/dns_forward/.formatted/dns_forward_config.ml index 78faa13..a76ab4e 100644 --- a/_build/default/src/dns_forward/dns_forward_config.ml +++ b/_build/default/src/dns_forward/.formatted/dns_forward_config.ml @@ -17,42 +17,45 @@ module Address = struct module M = struct - type t = { - ip: Ipaddr.t; - port: int; - } + type t = { ip : Ipaddr.t; port : int } let compare a b = let ip = Ipaddr.compare a.ip b.ip in if ip <> 0 then ip else Stdlib.compare a.port b.port end + include M + let to_string { ip; port } = Printf.sprintf "%s:%d" (Ipaddr.to_string ip) port - module Set = Set.Make(M) - module Map = Map.Make(M) + + module Set = Set.Make (M) + module Map = Map.Make (M) end module Domain = struct module M = struct type t = string list - let compare (a: t) (b: t) = Stdlib.compare a b + + let compare (a : t) (b : t) = Stdlib.compare a b end + include M - module Set = Set.Make(M) - module Map = Map.Make(M) + module Set = Set.Make (M) + module Map = Map.Make (M) + let to_string = String.concat "." end module Server = struct module M = struct type t = { - zones: Domain.Set.t; - address: Address.t; - timeout_ms: int option; - order: int; + zones : Domain.Set.t; + address : Address.t; + timeout_ms : int option; + order : int; } - let compare (a: t) (b: t) = + let compare (a : t) (b : t) = let zones = Domain.Set.compare a.zones b.zones in let address = Address.compare a.address b.address in let order = Stdlib.compare a.order b.order in @@ -62,15 +65,16 @@ module Server = struct else if order <> 0 then order else timeout_ms end + include M - module Set = Set.Make(M) - module Map = Map.Make(M) + module Set = Set.Make (M) + module Map = Map.Make (M) end type t = { - servers: Server.Set.t; - search: string list; - assume_offline_after_drops: int option; + servers : Server.Set.t; + search : string list; + assume_offline_after_drops : int option; } let compare a b = @@ -93,99 +97,175 @@ let of_string txt = |> List.map (String.trim ?drop:None) |> List.filter (fun x -> x <> "") |> List.fold_left - (fun acc line -> - if String.is_prefix ~affix:nameserver_prefix line then begin - let line = String.with_range ~first:(String.length nameserver_prefix) line in - if String.cut ~sep:"::" line <> None then begin - (* IPv6 *) - let host = Ipaddr.V6.of_string_exn line in - (`Nameserver (Ipaddr.V6 host, 53)) :: acc - end else match String.cut ~sep:"#" line with - | Some (host, port) -> - (* IPv4 with non-standard port *) - let host = Ipaddr.V4.of_string_exn host in - let port = int_of_string port in - (`Nameserver (Ipaddr.V4 host, port)) :: acc - | None -> - (* IPv4 with standard port *) - let host = Ipaddr.V4.of_string_exn line in - (`Nameserver (Ipaddr.V4 host, 53)) :: acc - end else if String.is_prefix ~affix:zone_prefix line then begin - let line = String.with_range ~first:(String.length zone_prefix) line in - (`Zones (String.cuts ~sep:" " line)) :: acc - end else if String.is_prefix ~affix:search_prefix line then begin - let line = String.with_range ~first:(String.length search_prefix) line in - (`Search (String.cuts ~sep:" " line)) :: acc - end else if String.is_prefix ~affix:timeout_prefix line then begin - let line = String.with_range ~first:(String.length timeout_prefix) line in - (`Timeout (int_of_string @@ String.trim ~drop:whitespace line)) :: acc - end else if String.is_prefix ~affix:order_prefix line then begin - let line = String.with_range ~first:(String.length order_prefix) line in - (`Order (int_of_string @@ String.trim ~drop:whitespace line)) :: acc - end else if String.is_prefix ~affix:assume_offline_after_prefix line then begin - let line = String.with_range ~first:(String.length assume_offline_after_prefix) line in - (`Offline (int_of_string @@ String.trim ~drop:whitespace line)) :: acc - end else acc - ) [] + (fun acc line -> + if String.is_prefix ~affix:nameserver_prefix line then + let line = + String.with_range ~first:(String.length nameserver_prefix) line + in + if String.cut ~sep:"::" line <> None then + (* IPv6 *) + let host = Ipaddr.V6.of_string_exn line in + `Nameserver (Ipaddr.V6 host, 53) :: acc + else + match String.cut ~sep:"#" line with + | Some (host, port) -> + (* IPv4 with non-standard port *) + let host = Ipaddr.V4.of_string_exn host in + let port = int_of_string port in + `Nameserver (Ipaddr.V4 host, port) :: acc + | None -> + (* IPv4 with standard port *) + let host = Ipaddr.V4.of_string_exn line in + `Nameserver (Ipaddr.V4 host, 53) :: acc + else if String.is_prefix ~affix:zone_prefix line then + let line = + String.with_range ~first:(String.length zone_prefix) line + in + `Zones (String.cuts ~sep:" " line) :: acc + else if String.is_prefix ~affix:search_prefix line then + let line = + String.with_range ~first:(String.length search_prefix) line + in + `Search (String.cuts ~sep:" " line) :: acc + else if String.is_prefix ~affix:timeout_prefix line then + let line = + String.with_range ~first:(String.length timeout_prefix) line + in + `Timeout (int_of_string @@ String.trim ~drop:whitespace line) + :: acc + else if String.is_prefix ~affix:order_prefix line then + let line = + String.with_range ~first:(String.length order_prefix) line + in + `Order (int_of_string @@ String.trim ~drop:whitespace line) :: acc + else if String.is_prefix ~affix:assume_offline_after_prefix line then + let line = + String.with_range + ~first:(String.length assume_offline_after_prefix) + line + in + `Offline (int_of_string @@ String.trim ~drop:whitespace line) + :: acc + else acc) + [] (* Merge the zones and nameservers together *) |> List.fold_left - (fun (zones, timeout, order, acc) line -> match zones, timeout, order, line with - | _, timeout, order, `Zones zones -> zones, timeout, order, acc - | zones, _, order, `Timeout timeout -> zones, Some timeout, order, acc - | zones, timeout, _, `Order order -> zones, timeout, order, acc - | zones, timeout_ms, order, `Nameserver (ip, port) -> - let zones = List.map (String.cuts ~sep:"." ?rev:None ?empty:None) zones |> Domain.Set.of_list in - let server = { Server.address = { Address.ip; port }; zones; timeout_ms; order } in - [], None, 0, { acc with servers = Server.Set.add server acc.servers } - | _, _, _, `Search search -> - zones, timeout, order, { acc with search } - | _, _, _, `Offline n -> - zones, timeout, order, { acc with assume_offline_after_drops = Some n } - ) ([], None, 0, { servers = Server.Set.empty; search = []; assume_offline_after_drops = None }) - |> (fun (_, _, _, x) -> Ok x) - with e -> Error (`Msg (Printf.sprintf "Failed to parse configuration: %s" (Printexc.to_string e))) + (fun (zones, timeout, order, acc) line -> + match (zones, timeout, order, line) with + | _, timeout, order, `Zones zones -> (zones, timeout, order, acc) + | zones, _, order, `Timeout timeout -> + (zones, Some timeout, order, acc) + | zones, timeout, _, `Order order -> (zones, timeout, order, acc) + | zones, timeout_ms, order, `Nameserver (ip, port) -> + let zones = + List.map (String.cuts ~sep:"." ?rev:None ?empty:None) zones + |> Domain.Set.of_list + in + let server = + { + Server.address = { Address.ip; port }; + zones; + timeout_ms; + order; + } + in + ( [], + None, + 0, + { acc with servers = Server.Set.add server acc.servers } ) + | _, _, _, `Search search -> + (zones, timeout, order, { acc with search }) + | _, _, _, `Offline n -> + ( zones, + timeout, + order, + { acc with assume_offline_after_drops = Some n } )) + ( [], + None, + 0, + { + servers = Server.Set.empty; + search = []; + assume_offline_after_drops = None; + } ) + |> fun (_, _, _, x) -> Ok x + with e -> + Error + (`Msg + (Printf.sprintf "Failed to parse configuration: %s" + (Printexc.to_string e))) let to_string t = - let nameservers = Server.Set.fold + let nameservers = + Server.Set.fold (fun server acc -> - [ nameserver_prefix ^ (Ipaddr.to_string server.Server.address.Address.ip) ^ "#" ^ (string_of_int server.Server.address.Address.port) ] - @ (if server.Server.zones <> Domain.Set.empty then [ zone_prefix ^ (String.concat " " @@ List.map Domain.to_string @@ Domain.Set.elements server.Server.zones) ] else []) - @ (match server.Server.timeout_ms with None -> [] | Some t -> [ timeout_prefix ^ (string_of_int t) ]) - @ [ order_prefix ^ (string_of_int server.Server.order) ] - @ acc - ) t.servers [] in - let search = List.map - (fun search -> - search_prefix ^ search - ) t.search in + [ + nameserver_prefix + ^ Ipaddr.to_string server.Server.address.Address.ip + ^ "#" + ^ string_of_int server.Server.address.Address.port; + ] + @ (if server.Server.zones <> Domain.Set.empty then + [ + zone_prefix ^ String.concat " " @@ List.map Domain.to_string + @@ Domain.Set.elements server.Server.zones; + ] + else []) + @ (match server.Server.timeout_ms with + | None -> [] + | Some t -> [ timeout_prefix ^ string_of_int t ]) + @ [ order_prefix ^ string_of_int server.Server.order ] + @ acc) + t.servers [] + in + let search = List.map (fun search -> search_prefix ^ search) t.search in String.concat "\n" (nameservers @ search) module Unix = struct let of_resolv_conf txt = let open Dns.Resolvconf in let lines = Astring.String.cuts ~sep:"\n" txt in - let config = List.rev @@ List.fold_left (fun acc x -> - match map_line x with - | None -> acc - | Some x -> - begin - try - KeywordValue.of_string x :: acc - with - | _ -> acc - end - ) [] lines in - let servers = List.fold_left (fun acc x -> match x with - | KeywordValue.Nameserver(ip, Some port) -> - Server.Set.add { Server.address = { Address.ip; port }; zones = Domain.Set.empty; timeout_ms = None; order = 0 } acc - | KeywordValue.Nameserver(ip, None) -> - Server.Set.add { Server.address = { Address.ip; port = 53 }; zones = Domain.Set.empty; timeout_ms = None; order = 0 } acc - | _ -> acc - ) Server.Set.empty config in - let search = List.fold_left (fun acc x -> match x with - | KeywordValue.Search names -> names @ acc - | _ -> acc - ) [] config |> List.rev in + let config = + List.rev + @@ List.fold_left + (fun acc x -> + match map_line x with + | None -> acc + | Some x -> ( try KeywordValue.of_string x :: acc with _ -> acc)) + [] lines + in + let servers = + List.fold_left + (fun acc x -> + match x with + | KeywordValue.Nameserver (ip, Some port) -> + Server.Set.add + { + Server.address = { Address.ip; port }; + zones = Domain.Set.empty; + timeout_ms = None; + order = 0; + } + acc + | KeywordValue.Nameserver (ip, None) -> + Server.Set.add + { + Server.address = { Address.ip; port = 53 }; + zones = Domain.Set.empty; + timeout_ms = None; + order = 0; + } + acc + | _ -> acc) + Server.Set.empty config + in + let search = + List.fold_left + (fun acc x -> + match x with KeywordValue.Search names -> names @ acc | _ -> acc) + [] config + |> List.rev + in let assume_offline_after_drops = None in Ok { servers; search; assume_offline_after_drops } end File "src/dns_forward/dns_forward_framing.ml", line 1, characters 0-0: diff --git a/_build/default/src/dns_forward/dns_forward_framing.ml b/_build/default/src/dns_forward/.formatted/dns_forward_framing.ml index 0b1c08e..2e41cc1 100644 --- a/_build/default/src/dns_forward/dns_forward_framing.ml +++ b/_build/default/src/dns_forward/.formatted/dns_forward_framing.ml @@ -26,19 +26,15 @@ module Log = (val Logs.src_log src : Logs.LOG) module type S = Dns_forward_s.READERWRITER -module Tcp (Flow: Mirage_flow.S) = struct +module Tcp (Flow : Mirage_flow.S) = struct let errorf = Dns_forward_error.errorf - module C = Mirage_channel.Make(Flow) + module C = Mirage_channel.Make (Flow) type request = Cstruct.t type response = Cstruct.t type flow = Flow.flow - type t = { - c: C.t; - write_m: Lwt_mutex.t; - read_m: Lwt_mutex.t; - } + type t = { c : C.t; write_m : Lwt_mutex.t; read_m : Lwt_mutex.t } let connect flow = let c = C.create flow in @@ -46,23 +42,22 @@ module Tcp (Flow: Mirage_flow.S) = struct let read_m = Lwt_mutex.create () in { c; write_m; read_m } - let close t = - Flow.close @@ C.to_flow t.c + let close t = Flow.close @@ C.to_flow t.c let read t = Lwt_mutex.with_lock t.read_m (fun () -> C.read_exactly ~len:2 t.c >>= function | Error e -> errorf "Failed to read response header: %a" C.pp_error e | Ok `Eof -> errorf "Got EOF while reading the response header" - | Ok (`Data bufs) -> + | Ok (`Data bufs) -> ( let buf = Cstruct.concat bufs in let len = Cstruct.BE.get_uint16 buf 0 in C.read_exactly ~len t.c >>= function - | Error e -> errorf "Failed to read response payload (%d bytes): \ - %a" len C.pp_error e + | Error e -> + errorf "Failed to read response payload (%d bytes): %a" len + C.pp_error e | Ok `Eof -> errorf "Got EOF while reading the response payload" - | Ok (`Data bufs) -> Lwt_result.return (Cstruct.concat bufs) - ) + | Ok (`Data bufs) -> Lwt_result.return (Cstruct.concat bufs))) let write t buffer = Lwt_mutex.with_lock t.write_m (fun () -> @@ -72,15 +67,15 @@ module Tcp (Flow: Mirage_flow.S) = struct C.write_buffer t.c header; C.write_buffer t.c buffer; C.flush t.c >>= function - | Ok () -> Lwt_result.return () + | Ok () -> Lwt_result.return () | Error e -> errorf "Failed to write %d bytes: %a" (Cstruct.length buffer) - C.pp_write_error e - ) + C.pp_write_error e) end -module Udp (Flow: Mirage_flow.S) = struct +module Udp (Flow : Mirage_flow.S) = struct module Error = Dns_forward_error.Infix + let errorf = Dns_forward_error.errorf type request = Cstruct.t @@ -94,8 +89,8 @@ module Udp (Flow: Mirage_flow.S) = struct let read t = Flow.read t >>= function | Ok (`Data buf) -> Lwt_result.return buf - | Ok `Eof -> errorf "read: Eof" - | Error e -> errorf "read: %a" Flow.pp_error e + | Ok `Eof -> errorf "read: Eof" + | Error e -> errorf "read: %a" Flow.pp_error e let write t buf = Flow.write t buf >>= function File "src/dns_forward/dns_forward_resolver.ml", line 1, characters 0-0: diff --git a/_build/default/src/dns_forward/dns_forward_resolver.ml b/_build/default/src/dns_forward/.formatted/dns_forward_resolver.ml index a4c968d..7a05beb 100644 --- a/_build/default/src/dns_forward/dns_forward_resolver.ml +++ b/_build/default/src/dns_forward/.formatted/dns_forward_resolver.ml @@ -21,50 +21,66 @@ let src = src module Log = (val Logs.src_log src : Logs.LOG) - open Lwt.Infix let is_in_domain name domain = let name' = List.length name and domain' = List.length domain in - name' >= domain' && begin - let to_remove = name' - domain' in - let rec trim n xs = match n, xs with + name' >= domain' + && + let to_remove = name' - domain' in + let rec trim n xs = + match (n, xs) with | 0, _ -> xs | _, [] -> invalid_arg "trim" - | n, _ :: xs -> trim (n - 1) xs in - let trimmed_name = trim to_remove name in - trimmed_name = domain - end + | n, _ :: xs -> trim (n - 1) xs + in + let trimmed_name = trim to_remove name in + trimmed_name = domain + +module IntSet = Set.Make (struct + type t = int -module IntSet = Set.Make(struct type t = int let compare (a: int) (b: int) = compare a b end) + let compare (a : int) (b : int) = compare a b +end) let choose_servers config request = let open Dns.Packet in let open Dns_forward_config in (* Match the name in the query against the configuration *) - begin match request with + match request with | { questions = [ { q_name; _ } ]; _ } -> let labels = Dns.Name.to_string_list q_name in - let matching_servers = List.filter (fun server -> - Domain.Set.fold (fun zone acc -> acc || (is_in_domain labels zone)) server.Server.zones false - ) config in - let all = match matching_servers with - | _ :: _ -> - (* If any of the configured domains match, send to these servers *) - matching_servers - | [] -> - (* Otherwise send to all servers *) - config in + let matching_servers = + List.filter + (fun server -> + Domain.Set.fold + (fun zone acc -> acc || is_in_domain labels zone) + server.Server.zones false) + config + in + let all = + match matching_servers with + | _ :: _ -> + (* If any of the configured domains match, send to these servers *) + matching_servers + | [] -> + (* Otherwise send to all servers *) + config + in (* Now we order by the order field *) - let orders = List.fold_left (fun set server -> IntSet.add server.Server.order set) IntSet.empty all in + let orders = + List.fold_left + (fun set server -> IntSet.add server.Server.order set) + IntSet.empty all + in List.map (fun order -> - List.filter (fun server -> server.Server.order = order) all - ) (IntSet.elements orders) + List.filter (fun server -> server.Server.order = order) all) + (IntSet.elements orders) | _ -> [] - end -let or_fail_msg m = m >>= function +let or_fail_msg m = + m >>= function | Result.Error `Eof -> Lwt.fail End_of_file | Result.Error (`Msg m) -> Lwt.fail (Failure m) | Result.Ok x -> Lwt.return x @@ -72,43 +88,49 @@ let or_fail_msg m = m >>= function module type S = Dns_forward_s.RESOLVER module Make - (Client: Dns_forward_s.RPC_CLIENT) - (Time : Mirage_time.S) + (Client : Dns_forward_s.RPC_CLIENT) + (Time : Mirage_time.S) (Clock : Mirage_clock.MCLOCK) = struct + module Cache = Dns_forward_cache.Make (Time) - module Cache = Dns_forward_cache.Make(Time) type address = Dns_forward_config.Address.t - type message_cb = ?src:address -> ?dst:address -> buf:Cstruct.t -> unit -> unit Lwt.t + + type message_cb = + ?src:address -> ?dst:address -> buf:Cstruct.t -> unit -> unit Lwt.t type connection = { - server: Dns_forward_config.Server.t; - client: Client.t; - mutable reply_expected_since: int64 option; + server : Dns_forward_config.Server.t; + client : Client.t; + mutable reply_expected_since : int64 option; (* if None: we don't expect a reply if Some t: we haven't heard from the server since time t *) - mutable replies_missing: int; + mutable replies_missing : int; (* the number of requests we've sent which have not been replied to *) - mutable online: bool; - (* true if we assume the server is online *) + mutable online : bool; (* true if we assume the server is online *) } type t = { - connections: connection list; - local_names_cb: (Dns.Packet.question -> Dns.Packet.rr list option Lwt.t); - cache: Cache.t; - config: Dns_forward_config.t; + connections : connection list; + local_names_cb : Dns.Packet.question -> Dns.Packet.rr list option Lwt.t; + cache : Cache.t; + config : Dns_forward_config.t; } - let create ?(local_names_cb=fun _ -> Lwt.return_none) ~gen_transaction_id ?message_cb config = - Lwt_list.map_s (fun server -> - or_fail_msg @@ Client.connect ~gen_transaction_id ?message_cb server.Dns_forward_config.Server.address + let create ?(local_names_cb = fun _ -> Lwt.return_none) ~gen_transaction_id + ?message_cb config = + Lwt_list.map_s + (fun server -> + or_fail_msg + @@ Client.connect ~gen_transaction_id ?message_cb + server.Dns_forward_config.Server.address >>= fun client -> let reply_expected_since = None in let replies_missing = 0 in let online = true in - Lwt.return { server; client; reply_expected_since; replies_missing; online } - ) (Dns_forward_config.Server.Set.elements config.Dns_forward_config.servers) + Lwt.return + { server; client; reply_expected_since; replies_missing; online }) + (Dns_forward_config.Server.Set.elements config.Dns_forward_config.servers) >|= fun connections -> let cache = Cache.make () in { connections; local_names_cb; cache; config } @@ -122,180 +144,214 @@ struct let buf = buffer in let open Dns.Packet in match Dns.Protocol.Server.parse (Cstruct.sub buf 0 len) with - | Some ({ questions = [ question ]; _ } as request) -> - + | Some ({ questions = [ question ]; _ } as request) -> ( (* Given a set of answers (resource records), synthesize an answer to the current question. *) let reply answers = let id = request.id in - let detail = { request.detail with Dns.Packet.qr = Dns.Packet.Response; ra = true } in + let detail = + { + request.detail with + Dns.Packet.qr = Dns.Packet.Response; + ra = true; + } + in let questions = request.questions in let authorities = [] and additionals = [] in - { id; detail; questions; answers; authorities; additionals } in + { id; detail; questions; answers; authorities; additionals } + in (* Look for any local answers to this question *) - begin - t.local_names_cb question - >>= function - | Some answers -> Lwt_result.return (marshal @@ reply answers) - | None -> - (* Ask one server, with caching. Possible results are: - Ok (`Success buf): succesful reply - Ok (`Failure buf): an error like NXDomain - Error (`Msg m): a low-level error or timeout - *) - let one_rpc server = - let open Dns_forward_config in - let address = server.Server.address in - (* Look in the cache *) - match Cache.answer t.cache address question with - | Some answers -> Lwt.return (Ok (`Success (marshal @@ reply answers))) - | None -> - let c = List.find (fun c -> c.server = server) t.connections in - begin - let now_ns = Clock.elapsed_ns () in - (* If no timeout is configured, we will stop listening after - 5s to avoid leaking threads if a server is offline *) - let timeout_ns = - match server.Server.timeout_ms with - | None -> Duration.of_sec 5 - | Some x -> Duration.of_ms x - in - (* If no assume_offline_after_drops is configured then set this - to 5s. *) - let assume_offline_after_drops = - match t.config.assume_offline_after_drops with - | Some c -> c - | None -> 5 - in - (* Within the overall timeout_ms (configured by the user) we will send - the request at 1s intervals to guard against packet drops. *) - let delays_ns = - let rec make from = - if from > timeout_ns then [] else - from :: make (Int64.add from Duration.(of_sec 1)) - in - make 0L in - let requests = List.map (fun delay_ns -> - Time.sleep_ns delay_ns >>= fun () -> - Client.rpc c.client buffer - ) delays_ns in - let timeout = - Time.sleep_ns timeout_ns >|= fun () -> - Error (`Msg "timeout") - in - Lwt.pick (timeout :: requests) - >>= function - | Error x -> - if c.reply_expected_since = None then c.reply_expected_since <- Some now_ns; - c.replies_missing <- c.replies_missing + (List.length delays_ns); - if assume_offline_after_drops < c.replies_missing && c.online then begin - Log.err (fun f -> f "Upstream DNS server %s has dropped %d packets in a row: assuming it's offline" - (Dns_forward_config.Address.to_string address) c.replies_missing - ); - c.online <- false - end; - Lwt.return (Error x) - | Ok reply -> - c.reply_expected_since <- None; - c.replies_missing <- 0; - if not c.online then begin - Log.info (fun f -> f "Upstream DNS server %s is back online" - (Dns_forward_config.Address.to_string address) - ); - c.online <- true; - end; - (* Determine whether it's a success or a failure; if a success - then insert the value into the cache. *) - let len = Cstruct.length reply in - let buf = reply in - begin match Dns.Protocol.Server.parse (Cstruct.sub buf 0 len) with - | Some { detail = { rcode = NoError; _ }; answers = ((_ :: _) as answers); _ } -> - Cache.insert t.cache address question answers; - Lwt.return (Ok (`Success reply)) - | packet -> - Lwt.return (Ok (`Failure (packet, reply))) - end - end in + t.local_names_cb question >>= function + | Some answers -> Lwt_result.return (marshal @@ reply answers) + | None -> ( + (* Ask one server, with caching. Possible results are: + Ok (`Success buf): succesful reply + Ok (`Failure buf): an error like NXDomain + Error (`Msg m): a low-level error or timeout + *) + let one_rpc server = + let open Dns_forward_config in + let address = server.Server.address in + (* Look in the cache *) + match Cache.answer t.cache address question with + | Some answers -> + Lwt.return (Ok (`Success (marshal @@ reply answers))) + | None -> ( + let c = + List.find (fun c -> c.server = server) t.connections + in + let now_ns = Clock.elapsed_ns () in + (* If no timeout is configured, we will stop listening after + 5s to avoid leaking threads if a server is offline *) + let timeout_ns = + match server.Server.timeout_ms with + | None -> Duration.of_sec 5 + | Some x -> Duration.of_ms x + in + (* If no assume_offline_after_drops is configured then set this + to 5s. *) + let assume_offline_after_drops = + match t.config.assume_offline_after_drops with + | Some c -> c + | None -> 5 + in + (* Within the overall timeout_ms (configured by the user) we will send + the request at 1s intervals to guard against packet drops. *) + let delays_ns = + let rec make from = + if from > timeout_ns then [] + else from :: make (Int64.add from Duration.(of_sec 1)) + in + make 0L + in + let requests = + List.map + (fun delay_ns -> + Time.sleep_ns delay_ns >>= fun () -> + Client.rpc c.client buffer) + delays_ns + in + let timeout = + Time.sleep_ns timeout_ns >|= fun () -> + Error (`Msg "timeout") + in + Lwt.pick (timeout :: requests) >>= function + | Error x -> + if c.reply_expected_since = None then + c.reply_expected_since <- Some now_ns; + c.replies_missing <- + c.replies_missing + List.length delays_ns; + if + assume_offline_after_drops < c.replies_missing + && c.online + then ( + Log.err (fun f -> + f + "Upstream DNS server %s has dropped %d packets \ + in a row: assuming it's offline" + (Dns_forward_config.Address.to_string address) + c.replies_missing); + c.online <- false); + Lwt.return (Error x) + | Ok reply -> ( + c.reply_expected_since <- None; + c.replies_missing <- 0; + if not c.online then ( + Log.info (fun f -> + f "Upstream DNS server %s is back online" + (Dns_forward_config.Address.to_string address)); + c.online <- true); + (* Determine whether it's a success or a failure; if a success + then insert the value into the cache. *) + let len = Cstruct.length reply in + let buf = reply in + match + Dns.Protocol.Server.parse (Cstruct.sub buf 0 len) + with + | Some + { + detail = { rcode = NoError; _ }; + answers = _ :: _ as answers; + _; + } -> + Cache.insert t.cache address question answers; + Lwt.return (Ok (`Success reply)) + | packet -> Lwt.return (Ok (`Failure (packet, reply))))) + in - (* Ask many servers but first - - Filter the list of servers using any "zone" setting -- this will - prevent queries for private names being leaked to public servers - (if configured). - - Group the servers into lists of equal priorities. - - Send all the requests concurrently. *) - let many_rpcs connections = - let equal_priority_groups = choose_servers (List.map (fun c -> c.server) connections) request in - (* Send all requests in parallel to minimise the chance of hitting a - timeout. Positive replies will be cached, but servers which don't - recognise the name will be queried each time. *) - List.map (List.map one_rpc) equal_priority_groups in + (* Ask many servers but first + - Filter the list of servers using any "zone" setting -- this will + prevent queries for private names being leaked to public servers + (if configured). + - Group the servers into lists of equal priorities. + - Send all the requests concurrently. *) + let many_rpcs connections = + let equal_priority_groups = + choose_servers + (List.map (fun c -> c.server) connections) + request + in + (* Send all requests in parallel to minimise the chance of hitting a + timeout. Positive replies will be cached, but servers which don't + recognise the name will be queried each time. *) + List.map (List.map one_rpc) equal_priority_groups + in - let online, offline = List.partition (fun c -> c.online) t.connections in - if online = [] && t.connections <> [] then begin - let open Dns_forward_config in - Log.warn (fun f -> f "There are no online DNS servers configured."); - Log.warn (fun f -> f "DNS servers %s are all marked offline" - (String.concat ", " (List.map (fun c -> Address.to_string @@ c.server.Server.address) offline)) - ) - end; - (* For all the offline servers, send the requests as a "ping" to see - if they are alive or not. Any response will flip them back to online - but we won't consider their responses until the next RPC *) - let _ = many_rpcs offline in + let online, offline = + List.partition (fun c -> c.online) t.connections + in + if online = [] && t.connections <> [] then ( + let open Dns_forward_config in + Log.warn (fun f -> + f "There are no online DNS servers configured."); + Log.warn (fun f -> + f "DNS servers %s are all marked offline" + (String.concat ", " + (List.map + (fun c -> + Address.to_string @@ c.server.Server.address) + offline)))); + (* For all the offline servers, send the requests as a "ping" to see + if they are alive or not. Any response will flip them back to online + but we won't consider their responses until the next RPC *) + let _ = many_rpcs offline in - (* For all the online servers, send the requests and return the waiting - threads. *) - let online_results = many_rpcs online in + (* For all the online servers, send the requests and return the waiting + threads. *) + let online_results = many_rpcs online in - (* Wait for the best result from a set of equal priority requests *) - let rec wait best_so_far remaining = - if remaining = [] - then Lwt.return best_so_far - else - Lwt.nchoose_split remaining - >>= fun (terminated, remaining) -> - match List.fold_left - (fun best_so_far next -> match best_so_far with - | Ok (`Success result) -> - (* No need to wait for any of the rest: one success is good enough *) - Ok (`Success result) - | best_so_far -> - begin match best_so_far, next with - | _, Ok (`Success result) -> - Ok (`Success result) - | Ok (`Failure (a_packet, a_reply)), Ok (`Failure (b_packet, b_reply)) -> - begin match a_packet, b_packet with - (* Prefer NXDomain to errors like Refused *) - | Some { detail = { rcode = NXDomain; _ }; _ }, _ -> Ok (`Failure (a_packet, a_reply)) - | _, Some { detail = { rcode = NXDomain; _ }; _ } -> Ok (`Failure (b_packet, b_reply)) - | _, _ -> - (* other than that, the earlier error is better *) - Ok (`Failure (a_packet, a_reply)) - end - | Error _, Ok (`Failure (b_packet, b_reply)) -> - (* prefer a high-level error over a low-level (e.g. socket) error *) + (* Wait for the best result from a set of equal priority requests *) + let rec wait best_so_far remaining = + if remaining = [] then Lwt.return best_so_far + else + Lwt.nchoose_split remaining >>= fun (terminated, remaining) -> + match + List.fold_left + (fun best_so_far next -> + match best_so_far with + | Ok (`Success result) -> + (* No need to wait for any of the rest: one success is good enough *) + Ok (`Success result) + | best_so_far -> ( + match (best_so_far, next) with + | _, Ok (`Success result) -> Ok (`Success result) + | ( Ok (`Failure (a_packet, a_reply)), + Ok (`Failure (b_packet, b_reply)) ) -> ( + match (a_packet, b_packet) with + (* Prefer NXDomain to errors like Refused *) + | Some { detail = { rcode = NXDomain; _ }; _ }, _ + -> + Ok (`Failure (a_packet, a_reply)) + | _, Some { detail = { rcode = NXDomain; _ }; _ } + -> Ok (`Failure (b_packet, b_reply)) - | best_so_far, _ -> - best_so_far - end - ) best_so_far terminated with + | _, _ -> + (* other than that, the earlier error is better *) + Ok (`Failure (a_packet, a_reply))) + | Error _, Ok (`Failure (b_packet, b_reply)) -> + (* prefer a high-level error over a low-level (e.g. socket) error *) + Ok (`Failure (b_packet, b_reply)) + | best_so_far, _ -> best_so_far)) + best_so_far terminated + with | Ok (`Success result) -> Lwt.return (Ok (`Success result)) - | best_so_far -> wait best_so_far remaining in - (* Wait for each equal priority group at a time *) - Lwt_list.fold_left_s - (fun best_so_far next -> match best_so_far with - | Ok (`Success result) -> Lwt.return (Ok (`Success result)) - | best_so_far -> wait best_so_far next - ) (Error (`Msg "no servers configured")) online_results - >>= function - | Ok (`Success reply) -> Lwt_result.return reply - | Ok (`Failure (_, reply)) -> Lwt_result.return reply - | Error x -> Lwt_result.fail x - end - | Some { questions = _; _} -> - Lwt_result.fail (`Msg "cannot handle DNS packets where len(questions)<>1") - | None -> - Lwt_result.fail (`Msg "failed to parse request") - + | best_so_far -> wait best_so_far remaining + in + (* Wait for each equal priority group at a time *) + Lwt_list.fold_left_s + (fun best_so_far next -> + match best_so_far with + | Ok (`Success result) -> Lwt.return (Ok (`Success result)) + | best_so_far -> wait best_so_far next) + (Error (`Msg "no servers configured")) + online_results + >>= function + | Ok (`Success reply) -> Lwt_result.return reply + | Ok (`Failure (_, reply)) -> Lwt_result.return reply + | Error x -> Lwt_result.fail x)) + | Some { questions = _; _ } -> + Lwt_result.fail + (`Msg "cannot handle DNS packets where len(questions)<>1") + | None -> Lwt_result.fail (`Msg "failed to parse request") end File "src/fs9p/vfs.ml", line 1, characters 0-0: diff --git a/_build/default/src/fs9p/vfs.ml b/_build/default/src/fs9p/.formatted/vfs.ml index 04ce94c..dc195d8 100644 --- a/_build/default/src/fs9p/vfs.ml +++ b/_build/default/src/fs9p/.formatted/vfs.ml @@ -3,29 +3,21 @@ open Rresult open Lwt.Infix type perm = [ `Normal | `Exec | `Link of string ] - type metadata = { length : int64; perm : perm } module Error = struct type err = { errno : int32 option; descr : string } - type t = Noent | Isdir | Notdir | Read_only_file | Perm | Other of err let otherk k ?errno fmt = Printf.ksprintf (fun descr -> k (Error (Other { descr; errno }))) fmt let other ?errno fmt = otherk (fun e -> e) ?errno fmt - let no_entry = Error Noent - let is_dir = Error Isdir - let not_dir = Error Notdir - let read_only_file = Error Read_only_file - let perm = Error Perm - let negative_offset o = other "Negative offset %Ld" o let offset_too_large ~offset l = @@ -50,26 +42,18 @@ end open Error.Infix let ok x = Lwt.return (Ok x) - let error fmt = Error.otherk Lwt.return fmt type 'a or_err = ('a, Error.t) result Lwt.t module File = struct let err_no_entry = Lwt.return Error.no_entry - let err_read_only = Lwt.return Error.read_only_file - let err_perm = Lwt.return Error.perm - let err_bad_write_offset off = error "Bad write offset %d" off - let err_stream_seek = error "Attempt to seek in stream" - let err_extend_cmd_file = error "Can't extend command file" - let err_normal_only = error "Can't chmod special file" - let ok x = Lwt.return (Ok x) let check_offset ~offset len = @@ -87,7 +71,6 @@ module File = struct } let read t = t.read - let write t = t.write type 'a session = { mutable v : 'a; c : unit Lwt_condition.t } @@ -113,7 +96,7 @@ module File = struct if current = !last then Lwt_condition.wait session.c >>= next else ( last := current; - Lwt.return (Cstruct.of_string current) ) + Lwt.return (Cstruct.of_string current)) in buffer := next () in @@ -121,7 +104,7 @@ module File = struct !buffer >>= fun avail -> if Cstruct.length avail = 0 then ( refill (); - read count ) + read count) else let count = min count (Cstruct.length avail) in let response = Cstruct.sub avail 0 count in @@ -139,9 +122,7 @@ module File = struct } let create ~read ~write = { read; write } - let read t = t.read - let write t = t.write let static data = @@ -169,7 +150,7 @@ module File = struct if offset <> !current_offset then err_stream_seek else if !need_flush then ( need_flush := false; - ok empty ) + ok empty) else Stream.read stream count >>*= fun result -> current_offset := @@ -181,7 +162,8 @@ module File = struct if offset <> !current_offset then err_stream_seek else Stream.write stream data >>*= fun () -> - current_offset := !current_offset ++ Int64.of_int (Cstruct.length data); + current_offset := + !current_offset ++ Int64.of_int (Cstruct.length data); ok () in ok { read; write } @@ -190,9 +172,7 @@ module File = struct type fd = Fd.t let create_fd = Fd.create - let read = Fd.read - let write = Fd.write type t = { @@ -210,17 +190,10 @@ module File = struct { debug; stat; open_; remove; truncate; chmod } let stat t = t.stat () - - let size t = - stat t >>*= fun info -> - Lwt.return (Ok info.length) - + let size t = stat t >>*= fun info -> Lwt.return (Ok info.length) let open_ t = t.open_ () - let remove t = t.remove () - let truncate t = t.truncate - let chmod t = t.chmod let read_only_aux = @@ -240,10 +213,7 @@ module File = struct let of_stream stream = let stat () = ok { length = 0L; perm = `Normal } in - let open_ () = - stream () >>= fun s -> - Fd.of_stream s - in + let open_ () = stream () >>= fun s -> Fd.of_stream s in read_only_aux ~debug:"of_stream" ~stat ~open_ let normal_only = function @@ -289,19 +259,14 @@ module File = struct let stat () = let length = match length with - | None -> - fn () >|= fun data -> - String.length data + | None -> fn () >|= fun data -> String.length data | Some f -> f () in length >|= fun length -> Ok { length = length |> Int64.of_int; perm = `Normal } in let open_ () = - let data = - fn () >|= fun result -> - ref (Cstruct.of_string result) - in + let data = fn () >|= fun result -> ref (Cstruct.of_string result) in let read count = data >>= fun data -> let count = min count (Cstruct.length !data) in @@ -332,10 +297,11 @@ module File = struct else empty in Cstruct.concat - [ Cstruct.sub orig 0 (min offset (Cstruct.length orig)); + [ + Cstruct.sub orig 0 (min offset (Cstruct.length orig)); padding; data; - tail + tail; ] let of_kv_aux ~read ~write ~stat ~remove ~chmod = @@ -351,9 +317,7 @@ module File = struct and write ~offset data = let offset = Int64.to_int offset in if offset < 0 then err_bad_write_offset offset - else - read () >>*= fun old -> - write (overwrite old (data, offset)) + else read () >>*= fun old -> write (overwrite old (data, offset)) in ok @@ Fd.create ~read ~write in @@ -397,7 +361,6 @@ module File = struct (file, fun () -> Cstruct.to_string !data) let create = create_aux ~debug:"create" - let of_kv = of_kv_aux ~debug:"of_kv" let stat_of ~read () = @@ -409,11 +372,8 @@ end module Dir = struct let err_read_only = error "Directory is read-only" - let err_already_exists = error "Already exists" - let err_dir_only = error "Can only contain directories" - let err_no_entry = Lwt.return Error.no_entry type t = { @@ -427,7 +387,6 @@ module Dir = struct } and kind = [ `File of File.t | `Dir of t ] - and inode = { mutable basename : string; kind : kind; ino : int64 } let pp ppf t = Fmt.pf ppf "Vfs.Dir.%s" t.debug @@ -436,17 +395,11 @@ module Dir = struct Fmt.string ppf (match k with `Dir _ -> "dir" | `File _ -> "file") let pp_inode ppf t = Fmt.pf ppf "%s:%a[%Ld]" t.basename pp_kind t.kind t.ino - let ls t = t.ls () - let mkfile t ?(perm = `Normal) name = t.mkfile name perm - let lookup t = t.lookup - let mkdir t = t.mkdir - let remove t = t.remove () - let rename t = t.rename let create_aux ~debug ~ls ~mkfile ~lookup ~mkdir ~remove ~rename = @@ -476,9 +429,7 @@ module Dir = struct let of_map_ref m = let ls () = ok (String.Map.bindings !m |> List.map snd) in let lookup name = - match String.Map.find name !m with - | Some x -> ok x - | None -> err_no_entry + match String.Map.find name !m with Some x -> ok x | None -> err_no_entry in let remove () = err_read_only in read_only_aux ~debug:"of_map_ref" ~ls ~lookup ~remove @@ -488,9 +439,7 @@ module Dir = struct create_aux ~debug:"dir_only" ~mkfile let of_list = of_list_aux ~debug:"of_list" - let create = create_aux ~debug:"create" - let read_only = read_only_aux ~debug:"read_only" end @@ -512,13 +461,9 @@ module Inode = struct { Dir.basename; kind = `File file; ino = mint_ino () } let dir basename dir = { Dir.basename; kind = `Dir dir; ino = mint_ino () } - let basename t = t.Dir.basename - let set_basename t b = t.Dir.basename <- b - let ino t = t.Dir.ino - let kind t = t.Dir.kind end @@ -543,7 +488,7 @@ module Logs = struct | Ok l -> Logs.Src.set_level s l; ok () - | Error (`Msg msg) -> error "%s" msg ) + | Error (`Msg msg) -> error "%s" msg) in let chmod _ = Lwt.return Error.perm in let remove () = Lwt.return Error.perm in @@ -551,8 +496,9 @@ module Logs = struct let src s = let items = - [ Inode.file "doc" (File.ro_of_string (Logs.Src.doc s ^ "\n")); - Inode.file "level" (level s) + [ + Inode.file "doc" (File.ro_of_string (Logs.Src.doc s ^ "\n")); + Inode.file "level" (level s); ] in Dir.of_list (fun () -> ok items) File "src/dns_forward/dns_forward_rpc.ml", line 1, characters 0-0: diff --git a/_build/default/src/dns_forward/dns_forward_rpc.ml b/_build/default/src/dns_forward/.formatted/dns_forward_rpc.ml index ec2b69f..8f6e60a 100644 --- a/_build/default/src/dns_forward/dns_forward_rpc.ml +++ b/_build/default/src/dns_forward/.formatted/dns_forward_rpc.ml @@ -23,321 +23,352 @@ let src = module Log = (val Logs.src_log src : Logs.LOG) module Client = struct - module type S = Dns_forward_s.RPC_CLIENT module Nonpersistent = struct module Make - (Sockets: Dns_forward_s.FLOW_CLIENT with type address = Ipaddr.t * int) - (Packet: Dns_forward_s.READERWRITER with type flow = Sockets.flow) - (Time: Mirage_time.S) = struct - type address = Dns_forward_config.Address.t - type request = Cstruct.t - type response = Cstruct.t - - type message_cb = ?src:address -> ?dst:address -> buf:Cstruct.t -> unit -> unit Lwt.t - - type t = { - address: address; - free_ids: Dns_forward_free_id.t; - message_cb: message_cb; - } - - let connect - ~gen_transaction_id - ?(message_cb = fun ?src:_ ?dst:_ ~buf:_ () -> Lwt.return_unit) - address = - let free_ids = Dns_forward_free_id.make ~g:gen_transaction_id () in - Lwt_result.return { address; free_ids; message_cb } - - let to_string t = Dns_forward_config.Address.to_string t.address - - let rpc (t: t) buffer = - let buf = buffer in - match Dns.Protocol.Server.parse (Cstruct.sub buf 0 (Cstruct.length buffer)) with - | Some request -> + (Sockets : Dns_forward_s.FLOW_CLIENT with type address = Ipaddr.t * int) + (Packet : Dns_forward_s.READERWRITER with type flow = Sockets.flow) + (Time : Mirage_time.S) = + struct + type address = Dns_forward_config.Address.t + type request = Cstruct.t + type response = Cstruct.t + + type message_cb = + ?src:address -> ?dst:address -> buf:Cstruct.t -> unit -> unit Lwt.t + + type t = { + address : address; + free_ids : Dns_forward_free_id.t; + message_cb : message_cb; + } + + let connect ~gen_transaction_id + ?(message_cb = fun ?src:_ ?dst:_ ~buf:_ () -> Lwt.return_unit) address + = + let free_ids = Dns_forward_free_id.make ~g:gen_transaction_id () in + Lwt_result.return { address; free_ids; message_cb } + + let to_string t = Dns_forward_config.Address.to_string t.address + + let rpc (t : t) buffer = + let buf = buffer in + match + Dns.Protocol.Server.parse (Cstruct.sub buf 0 (Cstruct.length buffer)) + with + | Some request -> (* Although we aren't multiplexing requests on the same flow (unlike the Persistent case below) we still rewrite the request id - to limit the number of sockets we allocate - to work around clients who use predictable request ids *) - (* The id whose scope is the link to the client *) - let client_id = request.Dns.Packet.id in - (* The id whose scope is the link to the server *) - Dns_forward_free_id.with_id t.free_ids - (fun free_id -> - (* Copy the buffer since this function will be run in parallel with the - same buffer *) - let buffer = - let tmp = Cstruct.create (Cstruct.length buffer) in - Cstruct.blit buffer 0 tmp 0 (Cstruct.length buffer); - tmp in - (* Rewrite the query id before forwarding *) - Cstruct.BE.set_uint16 buffer 0 free_id; - Log.debug (fun f -> f "%s mapping DNS id %d -> %d" (to_string t) client_id free_id); - - let open Lwt_result.Infix in - Sockets.connect (t.address.Dns_forward_config.Address.ip, t.address.Dns_forward_config.Address.port) - >>= fun flow -> - Lwt.finalize - (fun () -> - let rw = Packet.connect flow in - let open Lwt.Infix in - t.message_cb ~dst:t.address ~buf:buffer () - >>= fun () -> - let open Lwt_result.Infix in - - (* An existing connection to the server might have been closed by the server; - therefore if we fail to write the request, reconnect and try once more. *) - Packet.write rw buffer - >>= fun () -> - Packet.read rw - >>= fun buf -> - let open Lwt.Infix in - t.message_cb ~src:t.address ~buf () - >>= fun () -> - (* Rewrite the query id back to the original *) - Cstruct.BE.set_uint16 buf 0 client_id; - Lwt_result.return buf - ) (fun () -> - Sockets.close flow - ) - ) - | _ -> - Log.err (fun f -> f "%s: rpc: failed to parse request" (to_string t)); - Lwt_result.fail (`Msg (to_string t ^ ":failed to parse request")) - - let disconnect _ = - Lwt.return_unit + (* The id whose scope is the link to the client *) + let client_id = request.Dns.Packet.id in + (* The id whose scope is the link to the server *) + Dns_forward_free_id.with_id t.free_ids (fun free_id -> + (* Copy the buffer since this function will be run in parallel with the + same buffer *) + let buffer = + let tmp = Cstruct.create (Cstruct.length buffer) in + Cstruct.blit buffer 0 tmp 0 (Cstruct.length buffer); + tmp + in + (* Rewrite the query id before forwarding *) + Cstruct.BE.set_uint16 buffer 0 free_id; + Log.debug (fun f -> + f "%s mapping DNS id %d -> %d" (to_string t) client_id + free_id); + + let open Lwt_result.Infix in + Sockets.connect + ( t.address.Dns_forward_config.Address.ip, + t.address.Dns_forward_config.Address.port ) + >>= fun flow -> + Lwt.finalize + (fun () -> + let rw = Packet.connect flow in + let open Lwt.Infix in + t.message_cb ~dst:t.address ~buf:buffer () >>= fun () -> + let open Lwt_result.Infix in + (* An existing connection to the server might have been closed by the server; + therefore if we fail to write the request, reconnect and try once more. *) + Packet.write rw buffer >>= fun () -> + Packet.read rw >>= fun buf -> + let open Lwt.Infix in + t.message_cb ~src:t.address ~buf () >>= fun () -> + (* Rewrite the query id back to the original *) + Cstruct.BE.set_uint16 buf 0 client_id; + Lwt_result.return buf) + (fun () -> Sockets.close flow)) + | _ -> + Log.err (fun f -> + f "%s: rpc: failed to parse request" (to_string t)); + Lwt_result.fail (`Msg (to_string t ^ ":failed to parse request")) + + let disconnect _ = Lwt.return_unit end end module Persistent = struct - module Make - (Sockets: Dns_forward_s.FLOW_CLIENT with type address = Ipaddr.t * int) - (Packet: Dns_forward_s.READERWRITER with type flow = Sockets.flow) - (Time: Mirage_time.S) = struct - type address = Dns_forward_config.Address.t - type request = Cstruct.t - type response = Cstruct.t - - type message_cb = ?src:address -> ?dst:address -> buf:Cstruct.t -> unit -> unit Lwt.t - - type t = { - address: address; - mutable client_address: address; - mutable rw: Packet.t option; - mutable disconnect_on_idle: unit Lwt.t; - wakeners: (int, Dns.Packet.question * ((Cstruct.t, [ `Msg of string ]) result Lwt.u)) Hashtbl.t; - m: Lwt_mutex.t; - free_ids: Dns_forward_free_id.t; - message_cb: message_cb; - } - - module FlowError = Dns_forward_error.FromFlowError(Sockets) - - let to_string t = Dns_forward_config.Address.to_string t.client_address - - let disconnect t = - Lwt_mutex.with_lock t.m - (fun () -> - match t with - | { rw = Some rw; _ } as t -> - t.rw <- None; - let error = Error (`Msg (to_string t ^ ": connection to server was closed")) in - Hashtbl.iter (fun id (question, u) -> - Log.info (fun f -> f "%s %04x: disconnect: failing request for question %s" - (to_string t) id - (Dns.Packet.question_to_string question) - ); - (* It's possible that the response just arrived but hasn't been - processed by the client thread *) - try Lwt.wakeup_later u error - with Invalid_argument _ -> - Log.warn (fun f -> f "%s %04x: disconnect: response for DNS request just arrived in time" (to_string t) id) - ) t.wakeners; - Packet.close rw - | _ -> Lwt.return_unit - ) - - (* Receive all the responses and demux to the right thread. When the connection - is closed, `read_buffer` will fail and this thread will exit. *) - let dispatcher t rw () = - let open Lwt.Infix in - let rec loop () = - Packet.read rw - >>= function - | Error (`Msg m) -> - Log.debug (fun f -> f "%s: dispatcher shutting down: %s" (to_string t) m); - disconnect t - | Ok buffer -> - let buf = buffer in - begin match Dns.Protocol.Server.parse (Cstruct.sub buf 0 (Cstruct.length buffer)) with - | Some ({ Dns.Packet.questions = [ question ]; _ } as response) -> - let client_id = response.Dns.Packet.id in - if Hashtbl.mem t.wakeners client_id then begin - let expected_question, u = Hashtbl.find t.wakeners client_id in - if expected_question <> question then begin - Log.warn (fun f -> f "%s %04x: response arrived for a different question: expected %s <> got %s" - (to_string t) client_id - (Dns.Packet.question_to_string expected_question) - (Dns.Packet.question_to_string question) - ) - end else begin - (* It's possible that disconnect has already failed the thread *) - try Lwt.wakeup_later u (Ok buffer) + module Make + (Sockets : Dns_forward_s.FLOW_CLIENT with type address = Ipaddr.t * int) + (Packet : Dns_forward_s.READERWRITER with type flow = Sockets.flow) + (Time : Mirage_time.S) = + struct + type address = Dns_forward_config.Address.t + type request = Cstruct.t + type response = Cstruct.t + + type message_cb = + ?src:address -> ?dst:address -> buf:Cstruct.t -> unit -> unit Lwt.t + + type t = { + address : address; + mutable client_address : address; + mutable rw : Packet.t option; + mutable disconnect_on_idle : unit Lwt.t; + wakeners : + ( int, + Dns.Packet.question * (Cstruct.t, [ `Msg of string ]) result Lwt.u + ) + Hashtbl.t; + m : Lwt_mutex.t; + free_ids : Dns_forward_free_id.t; + message_cb : message_cb; + } + + module FlowError = Dns_forward_error.FromFlowError (Sockets) + + let to_string t = Dns_forward_config.Address.to_string t.client_address + + let disconnect t = + Lwt_mutex.with_lock t.m (fun () -> + match t with + | { rw = Some rw; _ } as t -> + t.rw <- None; + let error = + Error + (`Msg (to_string t ^ ": connection to server was closed")) + in + Hashtbl.iter + (fun id (question, u) -> + Log.info (fun f -> + f "%s %04x: disconnect: failing request for question %s" + (to_string t) id + (Dns.Packet.question_to_string question)); + (* It's possible that the response just arrived but hasn't been + processed by the client thread *) + try Lwt.wakeup_later u error with Invalid_argument _ -> - Log.warn (fun f -> f "%s %04x: response arrived for DNS request just after disconnection" (to_string t) client_id) - end - end else begin - Log.debug (fun f -> f "%s %04x: no wakener: it was probably cancelled" (to_string t) client_id); - end; - loop () - | _ -> - Log.err (fun f -> f "%s: dispatcher failed to parse response" (to_string t)); - Lwt.fail (Failure "failed to parse response") - end - in - Lwt.catch loop - (fun e -> - Log.info (fun f -> f "%s dispatcher caught %s" (to_string t) (Printexc.to_string e)); - Lwt.return_unit - ) - - let get_rw t = - let open Lwt_result.Infix in - Lwt.cancel t.disconnect_on_idle; - Lwt_mutex.with_lock t.m - (fun () -> match t.rw with - | None -> - Sockets.connect (t.address.Dns_forward_config.Address.ip, t.address.Dns_forward_config.Address.port) - >>= fun flow -> - let rw = Packet.connect flow in - t.rw <- Some rw; - Lwt.async (dispatcher t rw); - Lwt_result.return rw - | Some rw -> - Lwt_result.return rw) - >>= fun rw -> - (* Add a fresh idle timer *) - t.disconnect_on_idle <- (let open Lwt.Infix in Time.sleep_ns Duration.(of_sec 30) >>= fun () -> disconnect t); - Lwt_result.return rw - - let connect ~gen_transaction_id ?(message_cb = fun ?src:_ ?dst:_ ~buf:_ () -> Lwt.return_unit) address = - let rw = None in - let m = Lwt_mutex.create () in - let disconnect_on_idle = Lwt.return_unit in - let wakeners = Hashtbl.create 7 in - let free_ids = Dns_forward_free_id.make ~g:gen_transaction_id () in - let client_address = { Dns_forward_config.Address.ip = Ipaddr.V4 Ipaddr.V4.localhost; port = 0 } in - Lwt_result.return { client_address; address; rw; disconnect_on_idle; wakeners; m; free_ids; message_cb } - - let rpc (t: t) buffer = - let buf = buffer in - match Dns.Protocol.Server.parse (Cstruct.sub buf 0 (Cstruct.length buffer)) with - | Some ({ Dns.Packet.questions = [ question ]; _ } as request) -> - (* Note: the received request id is scoped to the connection with the - client. Since we are multiplexing requests to a single server we need - to track used/unused ids on the link to the server and remember the - mapping to the client. *) - - (* The id whose scope is the link to the client *) - let client_id = request.Dns.Packet.id in - (* The id whose scope is the link to the server *) - Dns_forward_free_id.with_id t.free_ids - (fun free_id -> - Lwt.finalize - (fun () -> + Log.warn (fun f -> + f + "%s %04x: disconnect: response for DNS request \ + just arrived in time" + (to_string t) id)) + t.wakeners; + Packet.close rw + | _ -> Lwt.return_unit) + + (* Receive all the responses and demux to the right thread. When the connection + is closed, `read_buffer` will fail and this thread will exit. *) + let dispatcher t rw () = + let open Lwt.Infix in + let rec loop () = + Packet.read rw >>= function + | Error (`Msg m) -> + Log.debug (fun f -> + f "%s: dispatcher shutting down: %s" (to_string t) m); + disconnect t + | Ok buffer -> ( + let buf = buffer in + match + Dns.Protocol.Server.parse + (Cstruct.sub buf 0 (Cstruct.length buffer)) + with + | Some ({ Dns.Packet.questions = [ question ]; _ } as response) -> + let client_id = response.Dns.Packet.id in + if Hashtbl.mem t.wakeners client_id then + let expected_question, u = + Hashtbl.find t.wakeners client_id + in + if expected_question <> question then + Log.warn (fun f -> + f + "%s %04x: response arrived for a different \ + question: expected %s <> got %s" + (to_string t) client_id + (Dns.Packet.question_to_string expected_question) + (Dns.Packet.question_to_string question)) + else + (* It's possible that disconnect has already failed the thread *) + try Lwt.wakeup_later u (Ok buffer) + with Invalid_argument _ -> + Log.warn (fun f -> + f + "%s %04x: response arrived for DNS request just \ + after disconnection" + (to_string t) client_id) + else + Log.debug (fun f -> + f "%s %04x: no wakener: it was probably cancelled" + (to_string t) client_id); + loop () + | _ -> + Log.err (fun f -> + f "%s: dispatcher failed to parse response" (to_string t)); + Lwt.fail (Failure "failed to parse response")) + in + Lwt.catch loop (fun e -> + Log.info (fun f -> + f "%s dispatcher caught %s" (to_string t) (Printexc.to_string e)); + Lwt.return_unit) + + let get_rw t = + let open Lwt_result.Infix in + Lwt.cancel t.disconnect_on_idle; + Lwt_mutex.with_lock t.m (fun () -> + match t.rw with + | None -> + Sockets.connect + ( t.address.Dns_forward_config.Address.ip, + t.address.Dns_forward_config.Address.port ) + >>= fun flow -> + let rw = Packet.connect flow in + t.rw <- Some rw; + Lwt.async (dispatcher t rw); + Lwt_result.return rw + | Some rw -> Lwt_result.return rw) + >>= fun rw -> + (* Add a fresh idle timer *) + t.disconnect_on_idle <- + (let open Lwt.Infix in + Time.sleep_ns Duration.(of_sec 30) >>= fun () -> disconnect t); + Lwt_result.return rw + + let connect ~gen_transaction_id + ?(message_cb = fun ?src:_ ?dst:_ ~buf:_ () -> Lwt.return_unit) address + = + let rw = None in + let m = Lwt_mutex.create () in + let disconnect_on_idle = Lwt.return_unit in + let wakeners = Hashtbl.create 7 in + let free_ids = Dns_forward_free_id.make ~g:gen_transaction_id () in + let client_address = + { + Dns_forward_config.Address.ip = Ipaddr.V4 Ipaddr.V4.localhost; + port = 0; + } + in + Lwt_result.return + { + client_address; + address; + rw; + disconnect_on_idle; + wakeners; + m; + free_ids; + message_cb; + } + + let rpc (t : t) buffer = + let buf = buffer in + match + Dns.Protocol.Server.parse (Cstruct.sub buf 0 (Cstruct.length buffer)) + with + | Some ({ Dns.Packet.questions = [ question ]; _ } as request) -> + (* Note: the received request id is scoped to the connection with the + client. Since we are multiplexing requests to a single server we need + to track used/unused ids on the link to the server and remember the + mapping to the client. *) + + (* The id whose scope is the link to the client *) + let client_id = request.Dns.Packet.id in + (* The id whose scope is the link to the server *) + Dns_forward_free_id.with_id t.free_ids (fun free_id -> + Lwt.finalize + (fun () -> (* Copy the buffer since this function will be run in parallel with the same buffer *) let buffer = let tmp = Cstruct.create (Cstruct.length buffer) in Cstruct.blit buffer 0 tmp 0 (Cstruct.length buffer); - tmp in + tmp + in (* Rewrite the query id before forwarding *) Cstruct.BE.set_uint16 buffer 0 free_id; - Log.debug (fun f -> f "%s mapping DNS id %d -> %d" (to_string t) client_id free_id); + Log.debug (fun f -> + f "%s mapping DNS id %d -> %d" (to_string t) client_id + free_id); let th, u = Lwt.task () in Hashtbl.replace t.wakeners free_id (question, u); (* If we fail to connect, return the error *) let open Lwt.Infix in - begin - let open Lwt_result.Infix in - get_rw t - >>= fun rw -> - let open Lwt.Infix in - t.message_cb ~dst:t.address ~buf:buffer () - >>= fun () -> - (* An existing connection to the server might have been closed by the server; - therefore if we fail to write the request, reconnect and try once more. *) - Packet.write rw buffer - >>= function - | Ok () -> - Lwt_result.return () - | Error (`Msg m) -> - Log.info (fun f -> f "%s: caught %s writing request, attempting to reconnect" (to_string t) m); - disconnect t - >>= fun () -> - let open Lwt_result.Infix in - get_rw t - >>= fun rw -> - let open Lwt.Infix in - t.message_cb ~dst:t.address ~buf:buffer () - >>= fun () -> - Packet.write rw buffer - end - >>= function + (let open Lwt_result.Infix in + get_rw t >>= fun rw -> + let open Lwt.Infix in + t.message_cb ~dst:t.address ~buf:buffer () >>= fun () -> + (* An existing connection to the server might have been closed by the server; + therefore if we fail to write the request, reconnect and try once more. *) + Packet.write rw buffer >>= function + | Ok () -> Lwt_result.return () | Error (`Msg m) -> - Lwt_result.fail (`Msg m) + Log.info (fun f -> + f + "%s: caught %s writing request, attempting to \ + reconnect" + (to_string t) m); + disconnect t >>= fun () -> + let open Lwt_result.Infix in + get_rw t >>= fun rw -> + let open Lwt.Infix in + t.message_cb ~dst:t.address ~buf:buffer () >>= fun () -> + Packet.write rw buffer) + >>= function + | Error (`Msg m) -> Lwt_result.fail (`Msg m) | Ok () -> let open Lwt_result.Infix in th (* will be woken up by the dispatcher *) >>= fun buf -> let open Lwt.Infix in - t.message_cb ~src:t.address ~buf () - >>= fun () -> + t.message_cb ~src:t.address ~buf () >>= fun () -> (* Rewrite the query id back to the original *) Cstruct.BE.set_uint16 buf 0 client_id; - Lwt_result.return buf - ) (fun () -> - (* This happens on cancel, disconnect, successful response *) - Hashtbl.remove t.wakeners free_id; - Lwt.return_unit - ) - ) - | _ -> - Log.err (fun f -> f "%s: rpc: failed to parse request" (to_string t)); - Lwt_result.fail (`Msg (to_string t ^ ":failed to parse request")) + Lwt_result.return buf) + (fun () -> + (* This happens on cancel, disconnect, successful response *) + Hashtbl.remove t.wakeners free_id; + Lwt.return_unit)) + | _ -> + Log.err (fun f -> + f "%s: rpc: failed to parse request" (to_string t)); + Lwt_result.fail (`Msg (to_string t ^ ":failed to parse request")) + end end end -end module Server = struct - module type S = Dns_forward_s.RPC_SERVER module Make - (Sockets: Dns_forward_s.FLOW_SERVER with type address = Ipaddr.t * int) + (Sockets : Dns_forward_s.FLOW_SERVER with type address = Ipaddr.t * int) (Packet : Dns_forward_s.READERWRITER with type flow = Sockets.flow) - (Time : Mirage_time.S) = + (Time : Mirage_time.S) = struct - type address = Dns_forward_config.Address.t type request = Cstruct.t type response = Cstruct.t - - type server = { - address: address; - server: Sockets.server; - } + type server = { address : address; server : Sockets.server } let bind address = let open Lwt_result.Infix in - Sockets.bind (address.Dns_forward_config.Address.ip, address.Dns_forward_config.Address.port) - >>= fun server -> - Lwt_result.return { address; server } + Sockets.bind + ( address.Dns_forward_config.Address.ip, + address.Dns_forward_config.Address.port ) + >>= fun server -> Lwt_result.return { address; server } let listen { server; _ } cb = Sockets.listen server (fun flow -> @@ -345,33 +376,22 @@ module Server = struct let rw = Packet.connect flow in let rec loop () = let open Lwt_result.Infix in - Packet.read rw - >>= fun request -> - Lwt.async - (fun () -> - let open Lwt.Infix in - cb request - >>= function - | Error _ -> - Lwt.return_unit - | Ok response -> - Packet.write rw response - >>= fun _ -> - Lwt.return_unit - ); - loop () in - loop () - >>= function + Packet.read rw >>= fun request -> + Lwt.async (fun () -> + let open Lwt.Infix in + cb request >>= function + | Error _ -> Lwt.return_unit + | Ok response -> + Packet.write rw response >>= fun _ -> Lwt.return_unit); + loop () + in + loop () >>= function | Error (`Msg m) -> Log.err (fun f -> f "server loop failed with: %s" m); Lwt.return_unit - | Ok () -> - Lwt.return_unit - ); + | Ok () -> Lwt.return_unit); Lwt_result.return () - let shutdown server = - Sockets.shutdown server.server - + let shutdown server = Sockets.shutdown server.server end end File "src/dns_forward_test/dune", line 1, characters 0-0: diff --git a/_build/default/src/dns_forward_test/dune b/_build/default/src/dns_forward_test/.formatted/dune index 26795c6..28dfe8c 100644 --- a/_build/default/src/dns_forward_test/dune +++ b/_build/default/src/dns_forward_test/.formatted/dune @@ -1,7 +1,9 @@ (executables (names test) - (libraries dns_forward dns_forward_lwt_unix lwt-dllist logs logs.fmt alcotest)) + (libraries dns_forward dns_forward_lwt_unix lwt-dllist logs logs.fmt + alcotest)) (rule - (alias runtest) - (action (run ./test.exe))) + (alias runtest) + (action + (run ./test.exe))) File "src/dns_test/test.ml", line 1, characters 0-0: diff --git a/_build/default/src/dns_test/test.ml b/_build/default/src/dns_test/.formatted/test.ml index 5980c72..2d36160 100644 --- a/_build/default/src/dns_test/test.ml +++ b/_build/default/src/dns_test/.formatted/test.ml @@ -1,13 +1,13 @@ - open OUnit2 let () = - run_test_tt_main ("dns" >::: [ - Test_name.tests; - Test_packet.tests; - (* Test_dns_resolver_unix.tests; - Test_dns_server_mirage.tests; - Test_mdns_responder.tests; - Test_mdns_resolver_mirage.tests; *) - ]) - + run_test_tt_main + ("dns" + >::: [ + Test_name.tests; + Test_packet.tests + (* Test_dns_resolver_unix.tests; + Test_dns_server_mirage.tests; + Test_mdns_responder.tests; + Test_mdns_resolver_mirage.tests; *); + ]) File "src/dns_mirage/dns_resolver_mirage.mli", line 1, characters 0-0: diff --git a/_build/default/src/dns_mirage/dns_resolver_mirage.mli b/_build/default/src/dns_mirage/.formatted/dns_resolver_mirage.mli index 45c319a..daf0dde 100644 --- a/_build/default/src/dns_mirage/dns_resolver_mirage.mli +++ b/_build/default/src/dns_mirage/.formatted/dns_resolver_mirage.mli @@ -25,31 +25,39 @@ module type S = sig val resolve : (module Dns.Protocol.CLIENT) -> - t -> Ipaddr.V4.t -> int -> + t -> + Ipaddr.V4.t -> + int -> Dns.Packet.q_class -> Dns.Packet.q_type -> Dns.Name.t -> Dns.Packet.t Lwt.t - val gethostbyname : t -> - ?server:Ipaddr.V4.t -> ?dns_port:int -> + val gethostbyname : + t -> + ?server:Ipaddr.V4.t -> + ?dns_port:int -> ?q_class:Dns.Packet.q_class -> ?q_type:Dns.Packet.q_type -> - string -> Ipaddr.t list Lwt.t + string -> + Ipaddr.t list Lwt.t - val gethostbyaddr : t -> - ?server:Ipaddr.V4.t -> ?dns_port:int -> + val gethostbyaddr : + t -> + ?server:Ipaddr.V4.t -> + ?dns_port:int -> ?q_class:Dns.Packet.q_class -> ?q_type:Dns.Packet.q_type -> - Ipaddr.V4.t -> string list Lwt.t + Ipaddr.V4.t -> + string list Lwt.t end -type static_dns = -{ - names: (string, Ipaddr.t) Hashtbl.t; - rev: (Ipaddr.V4.t, string) Hashtbl.t; +type static_dns = { + names : (string, Ipaddr.t) Hashtbl.t; + rev : (Ipaddr.V4.t, string) Hashtbl.t; } module Static : S with type stack = static_dns -module Make(Time:Mirage_time.S)(S:Tcpip.Stack.V4) : S with type stack = S.t +module Make (Time : Mirage_time.S) (S : Tcpip.Stack.V4) : + S with type stack = S.t File "src/dns_forward_lwt_unix/dns_forward_lwt_unix.mli", line 1, characters 0-0: diff --git a/_build/default/src/dns_forward_lwt_unix/dns_forward_lwt_unix.mli b/_build/default/src/dns_forward_lwt_unix/.formatted/dns_forward_lwt_unix.mli index 4a3cc0d..36de88e 100644 --- a/_build/default/src/dns_forward_lwt_unix/dns_forward_lwt_unix.mli +++ b/_build/default/src/dns_forward_lwt_unix/.formatted/dns_forward_lwt_unix.mli @@ -17,20 +17,20 @@ (** DNS utilities over Lwt_unix *) -module Resolver: sig - module Udp: Dns_forward.Resolver.S +module Resolver : sig + module Udp : Dns_forward.Resolver.S (** A DNS resolver over UDP *) - module Tcp: Dns_forward.Resolver.S + module Tcp : Dns_forward.Resolver.S (** A DNS resolver over TCP *) end -module Server: sig - module Udp: Dns_forward.Server.S with type resolver = Resolver.Udp.t +module Server : sig + module Udp : Dns_forward.Server.S with type resolver = Resolver.Udp.t (** A forwarding DNS proxy over UDP *) - module Tcp: Dns_forward.Server.S with type resolver = Resolver.Tcp.t + module Tcp : Dns_forward.Server.S with type resolver = Resolver.Tcp.t (** A forwarding DNS proxy over TCP *) end -module Clock: Mirage_clock.MCLOCK +module Clock : Mirage_clock.MCLOCK File "src/dns_forward_test/flow.mli", line 1, characters 0-0: diff --git a/_build/default/src/dns_forward_test/flow.mli b/_build/default/src/dns_forward_test/.formatted/flow.mli index 287ade3..9060de8 100644 --- a/_build/default/src/dns_forward_test/flow.mli +++ b/_build/default/src/dns_forward_test/.formatted/flow.mli @@ -19,11 +19,10 @@ type address = Ipaddr.t * int -include Dns_forward.Flow.Client - with type address := address -include Dns_forward.Flow.Server - with type address := address - and type flow := flow +include Dns_forward.Flow.Client with type address := address -val get_connections: unit -> (address * int) list +include + Dns_forward.Flow.Server with type address := address and type flow := flow + +val get_connections : unit -> (address * int) list (** Return a list of [server address, number of clients still connected] *) File "src/dns_forward_test/fake.ml", line 1, characters 0-0: diff --git a/_build/default/src/dns_forward_test/fake.ml b/_build/default/src/dns_forward_test/.formatted/fake.ml index 55f4633..616c2d8 100644 --- a/_build/default/src/dns_forward_test/fake.ml +++ b/_build/default/src/dns_forward_test/.formatted/fake.ml @@ -35,12 +35,10 @@ module Time = struct (* All sleeping is relative to the start of the program for now *) let now = 0L in let rec loop () = - if !timeofday > Int64.add now n then Lwt.return_unit else ( - Lwt_condition.wait c >>= fun () -> - loop () - ) in + if !timeofday > Int64.add now n then Lwt.return_unit + else Lwt_condition.wait c >>= fun () -> loop () + in loop () - end module Clock = struct File "src/dns_forward_test/fake.mli", line 1, characters 0-0: diff --git a/_build/default/src/dns_forward_test/fake.mli b/_build/default/src/dns_forward_test/.formatted/fake.mli index ded1fad..0971113 100644 --- a/_build/default/src/dns_forward_test/fake.mli +++ b/_build/default/src/dns_forward_test/.formatted/fake.mli @@ -18,14 +18,13 @@ (** A fake Time and Clock module for testing the timing without having to actually wait. *) -module Time: Mirage_time.S +module Time : Mirage_time.S +module Clock : Mirage_clock.MCLOCK -module Clock: Mirage_clock.MCLOCK - -val advance: int64 -> unit +val advance : int64 -> unit (** [advance nsecs]: advances the clock by [nsecs]. Note this will make sleeping threads runnable but it will not wait for them to finish or even to run. External synchronisation still needs to be used. *) -val reset: unit -> unit +val reset : unit -> unit (** [reset ()] sets the clock back to the initial value for another test. *) File "src/dns_forward_test/rpc.mli", line 1, characters 0-0: diff --git a/_build/default/src/dns_forward_test/rpc.mli b/_build/default/src/dns_forward_test/.formatted/rpc.mli index 0914b3b..42c54ee 100644 --- a/_build/default/src/dns_forward_test/rpc.mli +++ b/_build/default/src/dns_forward_test/.formatted/rpc.mli @@ -21,15 +21,17 @@ type request = Cstruct.t type response = Cstruct.t type address = Dns_forward.Config.Address.t -include Dns_forward.Rpc.Client.S - with type request := request - and type response := response - and type address := address +include + Dns_forward.Rpc.Client.S + with type request := request + and type response := response + and type address := address -include Dns_forward.Rpc.Server.S - with type request := request - and type response := response - and type address := address +include + Dns_forward.Rpc.Server.S + with type request := request + and type response := response + and type address := address -val get_connections: unit -> (address * int) list +val get_connections : unit -> (address * int) list (** Return a list of [server address, number of clients still connected] *) File "src/dns_forward_test/server.mli", line 1, characters 0-0: diff --git a/_build/default/src/dns_forward_test/server.mli b/_build/default/src/dns_forward_test/.formatted/server.mli index df75911..f29c418 100644 --- a/_build/default/src/dns_forward_test/server.mli +++ b/_build/default/src/dns_forward_test/.formatted/server.mli @@ -16,11 +16,12 @@ *) open Dns_forward -module Make(Server: Rpc.Server.S): sig +module Make (Server : Rpc.Server.S) : sig type t (** A DNS server for testing *) - val make: ?delay:float -> ?simulate_bad_question:bool -> (string * Ipaddr.t) list -> t + val make : + ?delay:float -> ?simulate_bad_question:bool -> (string * Ipaddr.t) list -> t (** Construct a server with a fixed set of name mappings. If the ?delay argument is provided then an artificial delay will be added before all responses. If ?simulate_bad_question is true then the responses will contain @@ -29,13 +30,12 @@ module Make(Server: Rpc.Server.S): sig type server (** A running server *) - val serve: address: Config.Address.t -> t -> server Error.t + val serve : address:Config.Address.t -> t -> server Error.t (** Serve requests on the given IP and port forever *) - val shutdown: server -> unit Lwt.t + val shutdown : server -> unit Lwt.t (** Shutdown the running server *) - val get_nr_queries: t -> int + val get_nr_queries : t -> int (** Return the number of queries which reached this server *) - end File "src/dns_mirage/dns_resolver_mirage.ml", line 1, characters 0-0: diff --git a/_build/default/src/dns_mirage/dns_resolver_mirage.ml b/_build/default/src/dns_mirage/.formatted/dns_resolver_mirage.ml index c075d6c..dd3c818 100644 --- a/_build/default/src/dns_mirage/dns_resolver_mirage.ml +++ b/_build/default/src/dns_mirage/.formatted/dns_resolver_mirage.ml @@ -17,7 +17,6 @@ open Lwt open Dns open Dns_resolver - module DP = Packet let default_ns = Ipaddr.V4.of_string_exn "8.8.8.8" @@ -31,28 +30,36 @@ module type S = sig val resolve : (module Protocol.CLIENT) -> - t -> Ipaddr.V4.t -> int -> + t -> + Ipaddr.V4.t -> + int -> Packet.q_class -> Packet.q_type -> Name.t -> Packet.t Lwt.t - val gethostbyname : t -> - ?server:Ipaddr.V4.t -> ?dns_port:int -> + val gethostbyname : + t -> + ?server:Ipaddr.V4.t -> + ?dns_port:int -> ?q_class:Dns.Packet.q_class -> ?q_type:Dns.Packet.q_type -> - string -> Ipaddr.t list Lwt.t + string -> + Ipaddr.t list Lwt.t - val gethostbyaddr : t -> - ?server:Ipaddr.V4.t -> ?dns_port:int -> + val gethostbyaddr : + t -> + ?server:Ipaddr.V4.t -> + ?dns_port:int -> ?q_class:Dns.Packet.q_class -> ?q_type:Dns.Packet.q_type -> - Ipaddr.V4.t -> string list Lwt.t + Ipaddr.V4.t -> + string list Lwt.t end type static_dns = { - names: (string, Ipaddr.t) Hashtbl.t; - rev: (Ipaddr.V4.t, string) Hashtbl.t; + names : (string, Ipaddr.t) Hashtbl.t; + rev : (Ipaddr.V4.t, string) Hashtbl.t; } module Static = struct @@ -61,89 +68,65 @@ module Static = struct let create s = s - let resolve _client - _s _server _dns_port - (_q_class:DP.q_class) (_q_type:DP.q_type) - (_q_name:Name.t) = + let resolve _client _s _server _dns_port (_q_class : DP.q_class) + (_q_type : DP.q_type) (_q_name : Name.t) = fail (Failure "Dummy stack cannot call resolve") - let gethostbyname - s ?server:_ ?dns_port:_ - ?q_class:_ ?q_type:_ - name = + let gethostbyname s ?server:_ ?dns_port:_ ?q_class:_ ?q_type:_ name = return (Hashtbl.find_all s.names name) - let gethostbyaddr - s ?server:_ ?dns_port:_ - ?q_class:_ ?q_type:_ - addr = - return (Hashtbl.find_all s.rev addr) + let gethostbyaddr s ?server:_ ?dns_port:_ ?q_class:_ ?q_type:_ addr = + return (Hashtbl.find_all s.rev addr) end -module Make(Time:Mirage_time.S)(S:Tcpip.Stack.V4) = struct - +module Make (Time : Mirage_time.S) (S : Tcpip.Stack.V4) = struct type stack = S.t type endp = Ipaddr.V4.t * int - - type t = { - s: S.t; - res: (endp, Dns_resolver.commfn) Hashtbl.t; - } + type t = { s : S.t; res : (endp, Dns_resolver.commfn) Hashtbl.t } let create s = let res = Hashtbl.create 3 in { s; res } - let connect_to_resolver {s; res} ((dst,dst_port) as endp) = + let connect_to_resolver { s; res } ((dst, dst_port) as endp) = let udp = S.udpv4 s in - try - Hashtbl.find res endp + try Hashtbl.find res endp with Not_found -> let timerfn () = Time.sleep_ns (Duration.of_sec 5) in let mvar = Lwt_mvar.create_empty () in (* TODO: test that port is free. Needs more functions exposed in tcpip *) - let src_port = (Random.int 64511) + 1024 in + let src_port = Random.int 64511 + 1024 in let callback ~src:_ ~dst:_ ~src_port:_ buf = Lwt_mvar.put mvar buf in let cleanfn () = return () in S.UDPV4.listen (S.udpv4 s) ~port:src_port callback; let txfn buf = S.UDPV4.write ~src_port ~dst ~dst_port udp buf >>= function | Error e -> - Fmt.kstr fail_with - "Attempting to communicate with remote resolver: %a" - S.UDPV4.pp_error e + Fmt.kstr fail_with + "Attempting to communicate with remote resolver: %a" + S.UDPV4.pp_error e | Ok () -> Lwt.return_unit in let rec rxfn f = - Lwt_mvar.take mvar - >>= fun buf -> - match f buf with - | None -> rxfn f - | Some packet -> return packet + Lwt_mvar.take mvar >>= fun buf -> + match f buf with None -> rxfn f | Some packet -> return packet in let commfn = { txfn; rxfn; timerfn; cleanfn } in Hashtbl.add res endp commfn; commfn - let resolve client - s server dns_port - (q_class:DP.q_class) (q_type:DP.q_type) - (q_name:Name.t) = - let commfn = connect_to_resolver s (server,dns_port) in + let resolve client s server dns_port (q_class : DP.q_class) + (q_type : DP.q_type) (q_name : Name.t) = + let commfn = connect_to_resolver s (server, dns_port) in resolve client commfn q_class q_type q_name - let gethostbyname - s ?(server = default_ns) ?(dns_port = default_port) - ?(q_class:DP.q_class = DP.Q_IN) ?(q_type:DP.q_type = DP.Q_A) - name = - let commfn = connect_to_resolver s (server,dns_port) in + let gethostbyname s ?(server = default_ns) ?(dns_port = default_port) + ?(q_class : DP.q_class = DP.Q_IN) ?(q_type : DP.q_type = DP.Q_A) name = + let commfn = connect_to_resolver s (server, dns_port) in gethostbyname ~q_class ~q_type commfn name - let gethostbyaddr - s ?(server = default_ns) ?(dns_port = default_port) - ?(q_class:DP.q_class = DP.Q_IN) ?(q_type:DP.q_type = DP.Q_PTR) - addr = - let commfn = connect_to_resolver s (server,dns_port) in + let gethostbyaddr s ?(server = default_ns) ?(dns_port = default_port) + ?(q_class : DP.q_class = DP.Q_IN) ?(q_type : DP.q_type = DP.Q_PTR) addr = + let commfn = connect_to_resolver s (server, dns_port) in gethostbyaddr ~q_class ~q_type commfn addr - end File "src/hostnet/dune", line 1, characters 0-0: diff --git a/_build/default/src/hostnet/dune b/_build/default/src/hostnet/.formatted/dune index 222bbbd..f781626 100644 --- a/_build/default/src/hostnet/dune +++ b/_build/default/src/hostnet/.formatted/dune @@ -1,13 +1,15 @@ (library (name hostnet) (inline_tests) - (preprocess (pps ppx_inline_test)) - (libraries base64 cstruct logs ipaddr mirage-flow mirage-flow-combinators ppx_sexp_conv - pcap-format ethernet arp tcpip.ipv4 tcpip.icmpv4 tcpip.udp + (preprocess + (pps ppx_inline_test)) + (libraries base64 cstruct logs ipaddr mirage-flow mirage-flow-combinators + ppx_sexp_conv pcap-format ethernet arp tcpip.ipv4 tcpip.icmpv4 tcpip.udp tcpip.tcp tcpip.stack-direct charrua charrua-server dns dns_lwt ofs luv - luv_unix lwt.unix threads astring fs9p dns_forward tar - mirage-vnetif uuidm cohttp-lwt mirage-channel ezjsonm - duration mirage-time mirage-clock + luv_unix lwt.unix threads astring fs9p dns_forward tar mirage-vnetif uuidm + cohttp-lwt mirage-channel ezjsonm duration mirage-time mirage-clock mirage-random tcpip.checksum forwarder cstructs sha) - (foreign_stubs (language c) (names stubs_utils)) + (foreign_stubs + (language c) + (names stubs_utils)) (wrapped false)) File "src/dns_forward_test/server.ml", line 1, characters 0-0: diff --git a/_build/default/src/dns_forward_test/server.ml b/_build/default/src/dns_forward_test/.formatted/server.ml index 24e2c58..2f472e2 100644 --- a/_build/default/src/dns_forward_test/server.ml +++ b/_build/default/src/dns_forward_test/.formatted/server.ml @@ -17,16 +17,19 @@ open Dns_forward module Error = Error.Infix -let bad_question = Dns.Packet.make_question Dns.Packet.Q_A (Dns.Name.of_string "this.is.a.bad.question.") +let bad_question = + Dns.Packet.make_question Dns.Packet.Q_A + (Dns.Name.of_string "this.is.a.bad.question.") -module Make(Server: Rpc.Server.S) = struct +module Make (Server : Rpc.Server.S) = struct type t = { - names: (string * Ipaddr.t) list; - mutable nr_queries: int; - delay: float; - mutable simulate_bad_question: bool; + names : (string * Ipaddr.t) list; + mutable nr_queries : int; + delay : float; + mutable simulate_bad_question : bool; } - let make ?(delay=0.) ?(simulate_bad_question = false) names = + + let make ?(delay = 0.) ?(simulate_bad_question = false) names = { names; nr_queries = 0; delay; simulate_bad_question } let get_nr_queries { nr_queries; _ } = nr_queries @@ -34,59 +37,98 @@ module Make(Server: Rpc.Server.S) = struct let answer buffer t = t.nr_queries <- t.nr_queries + 1; let open Lwt.Infix in - Lwt_unix.sleep t.delay - >>= fun () -> + Lwt_unix.sleep t.delay >>= fun () -> let len = Cstruct.length buffer in let buf = buffer in match Dns.Protocol.Server.parse (Cstruct.sub buf 0 len) with - | Some request -> + | Some request -> ( let open Dns.Packet in - begin match request with - | { id; detail; additionals; questions = [ { q_class = Q_IN; q_type = Q_A; q_name; _ } ]; _ } -> - begin match List.fold_left (fun found (name, ip) -> match found, ip with - | Some v4, _ -> Some v4 - | None, Ipaddr.V4 v4 -> - if Dns.Name.to_string q_name = name then Some v4 else None - | None, Ipaddr.V6 _ -> None - ) None t.names with + match request with + | { + id; + detail; + additionals; + questions = [ { q_class = Q_IN; q_type = Q_A; q_name; _ } ]; + _; + } -> ( + match + List.fold_left + (fun found (name, ip) -> + match (found, ip) with + | Some v4, _ -> Some v4 + | None, Ipaddr.V4 v4 -> + if Dns.Name.to_string q_name = name then Some v4 else None + | None, Ipaddr.V6 _ -> None) + None t.names + with | None -> let answers = [] in - let detail = { detail with - Dns.Packet.qr = Dns.Packet.Response; - rcode = Dns.Packet.NXDomain - } in - let questions = match t.simulate_bad_question with - | true -> [ bad_question ] - | false -> request.questions in - let pkt = { Dns.Packet.id; detail; questions; authorities=[]; additionals; answers } in + let detail = + { + detail with + Dns.Packet.qr = Dns.Packet.Response; + rcode = Dns.Packet.NXDomain; + } + in + let questions = + match t.simulate_bad_question with + | true -> [ bad_question ] + | false -> request.questions + in + let pkt = + { + Dns.Packet.id; + detail; + questions; + authorities = []; + additionals; + answers; + } + in let buf = Dns.Packet.marshal pkt in Lwt.return (Ok buf) | Some v4 -> - let answers = [ { name = q_name; cls = RR_IN; flush = false; ttl = 0l; rdata = A v4 } ] in - let detail = { detail with Dns.Packet.qr = Dns.Packet.Response } in - let questions = match t.simulate_bad_question with - | true -> [ bad_question ] - | false -> request.questions in - let pkt = { Dns.Packet.id; detail; questions; authorities=[]; additionals; answers } in + let answers = + [ + { + name = q_name; + cls = RR_IN; + flush = false; + ttl = 0l; + rdata = A v4; + }; + ] + in + let detail = + { detail with Dns.Packet.qr = Dns.Packet.Response } + in + let questions = + match t.simulate_bad_question with + | true -> [ bad_question ] + | false -> request.questions + in + let pkt = + { + Dns.Packet.id; + detail; + questions; + authorities = []; + additionals; + answers; + } + in let buf = Dns.Packet.marshal pkt in - Lwt.return (Ok buf) - end - | _ -> - Lwt.return (Error (`Msg "unexpected query type")) - end - | None -> - Lwt.return (Error (`Msg "failed to parse request")) + Lwt.return (Ok buf)) + | _ -> Lwt.return (Error (`Msg "unexpected query type"))) + | None -> Lwt.return (Error (`Msg "failed to parse request")) type server = Server.server let serve ~address t = let open Error in - Server.bind address - >>= fun server -> - Server.listen server (fun buf -> answer buf t) - >>= fun () -> + Server.bind address >>= fun server -> + Server.listen server (fun buf -> answer buf t) >>= fun () -> Lwt.return (Ok server) let shutdown = Server.shutdown - end File "src/dns_forward_test/rpc.ml", line 1, characters 0-0: diff --git a/_build/default/src/dns_forward_test/rpc.ml b/_build/default/src/dns_forward_test/.formatted/rpc.ml index 02b818b..899ab2f 100644 --- a/_build/default/src/dns_forward_test/rpc.ml +++ b/_build/default/src/dns_forward_test/.formatted/rpc.ml @@ -17,74 +17,84 @@ open Dns_forward module Error = Error.Infix -let errorf fmt = Printf.ksprintf (fun s -> Lwt.return (Result.Error (`Msg s))) fmt +let errorf fmt = + Printf.ksprintf (fun s -> Lwt.return (Result.Error (`Msg s))) fmt type request = Cstruct.t type response = Cstruct.t type address = Config.Address.t -let string_of_address a = Ipaddr.to_string a.Config.Address.ip ^ ":" ^ (string_of_int a.Config.Address.port) + +let string_of_address a = + Ipaddr.to_string a.Config.Address.ip + ^ ":" + ^ string_of_int a.Config.Address.port type cb = request -> (response, [ `Msg of string ]) result Lwt.t -type message_cb = ?src:address -> ?dst:address -> buf:Cstruct.t -> unit -> unit Lwt.t +type message_cb = + ?src:address -> ?dst:address -> buf:Cstruct.t -> unit -> unit Lwt.t type t = { - mutable cb: cb; - client_address: address; - server_address: address; - message_cb: message_cb; + mutable cb : cb; + client_address : address; + server_address : address; + message_cb : message_cb; } let rpc t request = let open Lwt.Infix in t.message_cb ~src:t.client_address ~dst:t.server_address ~buf:request () >>= fun () -> - t.cb request - >>= function + t.cb request >>= function | Result.Ok response -> t.message_cb ~src:t.server_address ~dst:t.client_address ~buf:response () - >>= fun () -> - Lwt.return (Result.Ok response) - | Result.Error e -> - Lwt.return (Result.Error e) + >>= fun () -> Lwt.return (Result.Ok response) + | Result.Error e -> Lwt.return (Result.Error e) let nr_connects = Hashtbl.create 7 -let get_connections () = Hashtbl.fold (fun k v acc -> (k, v) :: acc) nr_connects [] +let get_connections () = + Hashtbl.fold (fun k v acc -> (k, v) :: acc) nr_connects [] let disconnect t = let nr = Hashtbl.find nr_connects t.server_address - 1 in - if nr = 0 then Hashtbl.remove nr_connects t.server_address else Hashtbl.replace nr_connects t.server_address nr; + if nr = 0 then Hashtbl.remove nr_connects t.server_address + else Hashtbl.replace nr_connects t.server_address nr; t.cb <- (fun _ -> Lwt.return (Result.Error (`Msg "disconnected"))); Lwt.return_unit -type server = { - mutable listen_cb: cb; - address: address; -} +type server = { mutable listen_cb : cb; address : address } + let bound = Hashtbl.create 7 -let connect ~gen_transaction_id:_ ?(message_cb = (fun ?src:_ ?dst:_ ~buf:_ () -> Lwt.return_unit)) address = +let connect ~gen_transaction_id:_ + ?(message_cb = fun ?src:_ ?dst:_ ~buf:_ () -> Lwt.return_unit) address = (* Use a fixed client address for now *) - let client_address = { Config.Address.ip = Ipaddr.of_string_exn "1.2.3.4"; port = 32768 } in - if Hashtbl.mem bound address then begin - Hashtbl.replace nr_connects address (if Hashtbl.mem nr_connects address then Hashtbl.find nr_connects address else 1); + let client_address = + { Config.Address.ip = Ipaddr.of_string_exn "1.2.3.4"; port = 32768 } + in + if Hashtbl.mem bound address then ( + Hashtbl.replace nr_connects address + (if Hashtbl.mem nr_connects address then Hashtbl.find nr_connects address + else 1); let cb = (Hashtbl.find bound address).listen_cb in - Lwt.return (Result.Ok { cb; client_address; server_address = address; message_cb }) - end else errorf "connect: no server bound to %s" (string_of_address address) + Lwt.return + (Result.Ok { cb; client_address; server_address = address; message_cb })) + else errorf "connect: no server bound to %s" (string_of_address address) let bind address = let listen_cb _ = Lwt.return (Result.Error (`Msg "no callback")) in let server = { listen_cb; address } in - if Hashtbl.mem bound address - then Lwt.return (Result.Error (`Msg "address already bound")) - else begin + if Hashtbl.mem bound address then + Lwt.return (Result.Error (`Msg "address already bound")) + else ( Hashtbl.replace bound address server; - Lwt.return (Result.Ok server) - end + Lwt.return (Result.Ok server)) + let listen server cb = server.listen_cb <- cb; Lwt.return (Result.Ok ()) + let shutdown server = server.listen_cb <- (fun _ -> Lwt.return (Result.Error (`Msg "shutdown"))); Hashtbl.remove bound server.address; File "src/bin/config/discover.ml", line 1, characters 0-0: diff --git a/_build/default/src/bin/config/discover.ml b/_build/default/src/bin/config/.formatted/discover.ml index b819968..2a7cd7c 100644 --- a/_build/default/src/bin/config/discover.ml +++ b/_build/default/src/bin/config/.formatted/discover.ml @@ -1,22 +1,21 @@ let os_type () = match Sys.os_type with | "Unix" -> - (* We want to differentiate between Linux and Darwin/macOS *) - let ic = Unix.open_process_in "uname" in - let line = input_line ic in - let _ = Unix.close_process_in ic in - line + (* We want to differentiate between Linux and Darwin/macOS *) + let ic = Unix.open_process_in "uname" in + let line = input_line ic in + let _ = Unix.close_process_in ic in + line | x -> x let flags () = - match os_type () with - | "Linux" -> - [ "-ccopt"; "-static" ] - | _ -> - [] + match os_type () with "Linux" -> [ "-ccopt"; "-static" ] | _ -> [] let _ = - let txt = Sexplib.Sexp.(to_string (List (List.map (fun flag -> Atom flag) (flags ())))) in + let txt = + Sexplib.Sexp.( + to_string (List (List.map (fun flag -> Atom flag) (flags ())))) + in let oc = open_out "flags.sexp" in output_string oc txt; close_out oc File "src/dns_forward_test/flow.ml", line 1, characters 0-0: diff --git a/_build/default/src/dns_forward_test/flow.ml b/_build/default/src/dns_forward_test/.formatted/flow.ml index 647cf2f..0318eb7 100644 --- a/_build/default/src/dns_forward_test/flow.ml +++ b/_build/default/src/dns_forward_test/.formatted/flow.ml @@ -18,24 +18,31 @@ open Dns_forward module Error = Error.Infix -let errorf fmt = Printf.ksprintf (fun s -> Lwt.return (Result.Error (`Msg s))) fmt +let errorf fmt = + Printf.ksprintf (fun s -> Lwt.return (Result.Error (`Msg s))) fmt type address = Ipaddr.t * int -let string_of_address (ip, port) = Ipaddr.to_string ip ^ ":" ^ (string_of_int port) + +let string_of_address (ip, port) = + Ipaddr.to_string ip ^ ":" ^ string_of_int port + type error = [ `Msg of string ] + let pp_error ppf (`Msg x) = Fmt.string ppf x + type write_error = Mirage_flow.write_error + let pp_write_error = Mirage_flow.pp_write_error type flow = { - l2r: Cstruct.t Lwt_dllist.t; (* pending data from left to right *) - mutable l2r_closed: bool; - l2r_c: unit Lwt_condition.t; - r2l: Cstruct.t Lwt_dllist.t; (* pending data from right to left *) - mutable r2l_closed: bool; - r2l_c: unit Lwt_condition.t; - client_address: address; - server_address: address; + l2r : Cstruct.t Lwt_dllist.t; (* pending data from left to right *) + mutable l2r_closed : bool; + l2r_c : unit Lwt_condition.t; + r2l : Cstruct.t Lwt_dllist.t; (* pending data from right to left *) + mutable r2l_closed : bool; + r2l_c : unit Lwt_condition.t; + client_address : address; + server_address : address; } let openflow server_address = @@ -45,34 +52,47 @@ let openflow server_address = let r2l_c = Lwt_condition.create () in let l2r_closed = false in let r2l_closed = false in - let client_address = Ipaddr.V4 Ipaddr.V4.localhost, 32768 in - { l2r; r2l; l2r_c; r2l_c; l2r_closed; r2l_closed; client_address; server_address } + let client_address = (Ipaddr.V4 Ipaddr.V4.localhost, 32768) in + { + l2r; + r2l; + l2r_c; + r2l_c; + l2r_closed; + r2l_closed; + client_address; + server_address; + } let otherend flow = - { l2r = flow.r2l; l2r_c = flow.r2l_c; r2l = flow.l2r; r2l_c = flow.l2r_c; - l2r_closed = flow.r2l_closed; r2l_closed = flow.l2r_closed; - client_address = flow.server_address; server_address = flow.client_address } + { + l2r = flow.r2l; + l2r_c = flow.r2l_c; + r2l = flow.l2r; + r2l_c = flow.l2r_c; + l2r_closed = flow.r2l_closed; + r2l_closed = flow.l2r_closed; + client_address = flow.server_address; + server_address = flow.client_address; + } let read flow = let open Lwt.Infix in let rec wait () = - if Lwt_dllist.is_empty flow.r2l && not(flow.r2l_closed) then begin - Lwt_condition.wait flow.r2l_c - >>= fun () -> - wait () - end else Lwt.return_unit in - wait () - >>= fun () -> - if flow.r2l_closed - then Lwt.return (Ok `Eof) + if Lwt_dllist.is_empty flow.r2l && not flow.r2l_closed then + Lwt_condition.wait flow.r2l_c >>= fun () -> wait () + else Lwt.return_unit + in + wait () >>= fun () -> + if flow.r2l_closed then Lwt.return (Ok `Eof) else Lwt.return (Ok (`Data (Lwt_dllist.take_r flow.r2l))) let write flow buf = - if flow.l2r_closed then Lwt.return (Error `Closed) else ( + if flow.l2r_closed then Lwt.return (Error `Closed) + else ( ignore @@ Lwt_dllist.add_l buf flow.l2r; Lwt_condition.signal flow.l2r_c (); - Lwt.return (Ok ()) - ) + Lwt.return (Ok ())) let shutdown_read flow = flow.r2l_closed <- true; @@ -85,19 +105,21 @@ let shutdown_write flow = Lwt.return_unit let writev flow bufs = - if flow.l2r_closed then Lwt.return (Error `Closed) else ( + if flow.l2r_closed then Lwt.return (Error `Closed) + else ( List.iter (fun buf -> ignore @@ Lwt_dllist.add_l buf flow.l2r) bufs; Lwt_condition.signal flow.l2r_c (); - Lwt.return (Ok ()) - ) + Lwt.return (Ok ())) let nr_connects = Hashtbl.create 7 -let get_connections () = Hashtbl.fold (fun k v acc -> (k, v) :: acc) nr_connects [] +let get_connections () = + Hashtbl.fold (fun k v acc -> (k, v) :: acc) nr_connects [] let close flow = let nr = Hashtbl.find nr_connects flow.server_address - 1 in - if nr = 0 then Hashtbl.remove nr_connects flow.server_address else Hashtbl.replace nr_connects flow.server_address nr; + if nr = 0 then Hashtbl.remove nr_connects flow.server_address + else Hashtbl.replace nr_connects flow.server_address nr; flow.l2r_closed <- true; flow.r2l_closed <- true; Lwt_condition.signal flow.l2r_c (); @@ -105,46 +127,42 @@ let close flow = Lwt.return_unit type server = { - mutable listen_cb: unit -> (flow, [ `Msg of string ]) result Lwt.t; - address: address; + mutable listen_cb : unit -> (flow, [ `Msg of string ]) result Lwt.t; + address : address; } -let bound = Hashtbl.create 7 +let bound = Hashtbl.create 7 let getsockname server = server.address let connect ?read_buffer_size:_ address = - if Hashtbl.mem bound address then begin - Hashtbl.replace nr_connects address (if Hashtbl.mem nr_connects address then Hashtbl.find nr_connects address + 1 else 1); + if Hashtbl.mem bound address then ( + Hashtbl.replace nr_connects address + (if Hashtbl.mem nr_connects address then + Hashtbl.find nr_connects address + 1 + else 1); let cb = (Hashtbl.find bound address).listen_cb in let open Error in - cb () - >>= fun flow -> - Lwt.return (Result.Ok flow) - end else errorf "connect: no server bound to %s" (string_of_address address) + cb () >>= fun flow -> Lwt.return (Result.Ok flow)) + else errorf "connect: no server bound to %s" (string_of_address address) let bind address = let listen_cb _ = Lwt.return (Result.Error (`Msg "no callback")) in let server = { listen_cb; address } in - if Hashtbl.mem bound address - then Lwt.return (Result.Error (`Msg "address already bound")) - else begin + if Hashtbl.mem bound address then + Lwt.return (Result.Error (`Msg "address already bound")) + else ( Hashtbl.replace bound address server; - Lwt.return (Result.Ok server) - end -let listen server (cb: flow -> unit Lwt.t) = + Lwt.return (Result.Ok server)) + +let listen server (cb : flow -> unit Lwt.t) = let listen_cb () = let flow = openflow server.address in - Lwt.async - (fun () -> - Lwt.catch - (fun () -> - cb (otherend flow) - ) (fun _e -> - Lwt.return_unit - ) - ); - Lwt.return (Result.Ok flow) in + Lwt.async (fun () -> + Lwt.catch (fun () -> cb (otherend flow)) (fun _e -> Lwt.return_unit)); + Lwt.return (Result.Ok flow) + in server.listen_cb <- listen_cb + let shutdown server = server.listen_cb <- (fun _ -> Lwt.return (Result.Error (`Msg "shutdown"))); Hashtbl.remove bound server.address; File "src/dns_test/test_name.ml", line 1, characters 0-0: diff --git a/_build/default/src/dns_test/test_name.ml b/_build/default/src/dns_test/.formatted/test_name.ml index 3cbe776..0a72088 100644 --- a/_build/default/src/dns_test/test_name.ml +++ b/_build/default/src/dns_test/.formatted/test_name.ml @@ -1,167 +1,367 @@ [@@@warning "-27"] + open OUnit2 let cstruct_of ints = let buf = Buffer.create (List.length ints) in - ints |> List.iter (fun i -> - Buffer.add_char buf (Char.chr i)); + ints |> List.iter (fun i -> Buffer.add_char buf (Char.chr i)); Cstruct.of_string (Buffer.contents buf) open Dns open Name let tests = - "Name" >::: - [ - "parse-root-domain-name" >:: (fun test_ctxt -> - let buf = cstruct_of [0x00] in - let names = Hashtbl.create 32 in - let name, (base,buf) = parse names 0 buf in - assert_equal "" (Name.to_string name); - ); - - "parse-label-single" >:: (fun test_ctxt -> - let buf = cstruct_of [ - 0x03; 0x63; 0x6f; 0x6d; - 0x00 - ] in - let names = Hashtbl.create 32 in - let name, (base,buf) = parse names 0 buf in - assert_equal "com" (Name.to_string name); - ); - - "parse-label-seq" >:: (fun test_ctxt -> - let buf = cstruct_of [ - 0x03; 0x66; 0x6f; 0x6f; - 0x03; 0x63; 0x6f; 0x6d; - 0x00 - ] in - let names = Hashtbl.create 32 in - let name, (base,buf) = parse names 0 buf in - assert_equal "foo.com" (Name.to_string name); - ); - - "parse-pointer-to-root-domain" >:: (fun test_ctxt -> - let buf = cstruct_of [ - 0xff; (* padding *) - 0x00; - 0xc0; 0x01 - ] in - let names = Hashtbl.create 32 in - let buf = Cstruct.shift buf 1 in - let name, (base,buf) = parse names 1 buf in - let name, (base,buf) = parse names 2 buf in - assert_equal "" (Name.to_string name); - ); - - "parse-pointer-to-label" >:: (fun test_ctxt -> - let buf = cstruct_of [ - 0x03; 0x63; 0x6f; 0x6d; - 0x00; - 0xc0; 0x00 - ] in - let names = Hashtbl.create 32 in - let name, (base,buf) = parse names 0 buf in - let name, (base,buf) = parse names base buf in - assert_equal "com" (Name.to_string name); - ); - - "parse-pointer-to-pointer-to-label" >:: (fun test_ctxt -> - let buf = cstruct_of [ - 0x03; 0x63; 0x6f; 0x6d; - 0x00; - 0xc0; 0x00; - 0xc0; 0x05 - ] in - let names = Hashtbl.create 32 in - let name, (base,buf) = parse names 0 buf in - let name, (base,buf) = parse names base buf in - let name, (base,buf) = parse names base buf in - assert_equal "com" (Name.to_string name); - ); - - "parse-label-then-label-with-pointer-to-label" >:: (fun test_ctxt -> - let buf = cstruct_of [ - 0x03; 0x63; 0x6f; 0x6d; - 0x00; - 0x03; 0x66; 0x6f; 0x6f; - 0xc0; 0x00 - ] in - let names = Hashtbl.create 32 in - let name, (base,buf) = parse names 0 buf in - let name, (base,buf) = parse names base buf in - assert_equal "foo.com" (Name.to_string name); - ); - - "parse-pointer-to-self" >:: (fun test_ctxt -> - let buf = cstruct_of [ 0xc0; 0x00 ] in - let names = Hashtbl.create 32 in - assert_raises - (Failure "Name.parse_pointer: Cannot dereference pointer to (0) at position (0)") - (fun () -> parse names 0 buf) - ); - - "parse-pointer-to-invalid-address" >:: (fun test_ctxt -> - let buf = cstruct_of [ 0xc0; 0x0e ] in - let names = Hashtbl.create 32 in - assert_raises - (Failure "Name.parse_pointer: Cannot dereference pointer to (14) at position (0)") - (fun () -> parse names 0 buf) - ); - - "parse-pointer-cycle" >:: (fun test_ctxt -> - let buf = cstruct_of [ - 0xc0; 0x02; - 0xc0; 0x00 - ] in - let names = Hashtbl.create 32 in - assert_raises - (Failure "Name.parse_pointer: Cannot dereference pointer to (2) at position (0)") - (fun () -> parse names 0 buf) - ); - - "parse-corrupted-label" >:: (fun test_ctxt -> - let buf = cstruct_of [0x40] in - let names = Hashtbl.create 32 in - assert_raises - (Failure "Name.parse_label: invalid length 64") - (fun () -> parse names 0 buf) - ); - - "parse-name-too-long" >:: (fun test_ctxt -> - let buf = cstruct_of [ - 0x09; 0x61; 0x62; 0x63; 0x64; 0x65; 0x66; 0x67; 0x68; 0x69; - 0x09; 0x61; 0x62; 0x63; 0x64; 0x65; 0x66; 0x67; 0x68; 0x69; - 0x09; 0x61; 0x62; 0x63; 0x64; 0x65; 0x66; 0x67; 0x68; 0x69; - 0x09; 0x61; 0x62; 0x63; 0x64; 0x65; 0x66; 0x67; 0x68; 0x69; - 0x09; 0x61; 0x62; 0x63; 0x64; 0x65; 0x66; 0x67; 0x68; 0x69; - 0x09; 0x61; 0x62; 0x63; 0x64; 0x65; 0x66; 0x67; 0x68; 0x69; - 0x09; 0x61; 0x62; 0x63; 0x64; 0x65; 0x66; 0x67; 0x68; 0x69; - 0x09; 0x61; 0x62; 0x63; 0x64; 0x65; 0x66; 0x67; 0x68; 0x69; - 0x09; 0x61; 0x62; 0x63; 0x64; 0x65; 0x66; 0x67; 0x68; 0x69; - 0x09; 0x61; 0x62; 0x63; 0x64; 0x65; 0x66; 0x67; 0x68; 0x69; - 0x09; 0x61; 0x62; 0x63; 0x64; 0x65; 0x66; 0x67; 0x68; 0x69; - 0x09; 0x61; 0x62; 0x63; 0x64; 0x65; 0x66; 0x67; 0x68; 0x69; - 0x09; 0x61; 0x62; 0x63; 0x64; 0x65; 0x66; 0x67; 0x68; 0x69; - 0x09; 0x61; 0x62; 0x63; 0x64; 0x65; 0x66; 0x67; 0x68; 0x69; - 0x09; 0x61; 0x62; 0x63; 0x64; 0x65; 0x66; 0x67; 0x68; 0x69; - 0x09; 0x61; 0x62; 0x63; 0x64; 0x65; 0x66; 0x67; 0x68; 0x69; - 0x09; 0x61; 0x62; 0x63; 0x64; 0x65; 0x66; 0x67; 0x68; 0x69; - 0x09; 0x61; 0x62; 0x63; 0x64; 0x65; 0x66; 0x67; 0x68; 0x69; - 0x09; 0x61; 0x62; 0x63; 0x64; 0x65; 0x66; 0x67; 0x68; 0x69; - 0x09; 0x61; 0x62; 0x63; 0x64; 0x65; 0x66; 0x67; 0x68; 0x69; - 0x09; 0x61; 0x62; 0x63; 0x64; 0x65; 0x66; 0x67; 0x68; 0x69; - 0x09; 0x61; 0x62; 0x63; 0x64; 0x65; 0x66; 0x67; 0x68; 0x69; - 0x09; 0x61; 0x62; 0x63; 0x64; 0x65; 0x66; 0x67; 0x68; 0x69; - 0x09; 0x61; 0x62; 0x63; 0x64; 0x65; 0x66; 0x67; 0x68; 0x69; - 0x09; 0x61; 0x62; 0x63; 0x64; 0x65; 0x66; 0x67; 0x68; 0x69; - 0x04; 0x61; 0x62; 0x63; 0x64; 0x00; - ] - in - let names = Hashtbl.create 32 in - assert_raises - (Failure "Name.parse: invalid length 256") - (fun () -> parse names 0 buf) - ); - - ] + "Name" + >::: [ + ( "parse-root-domain-name" >:: fun test_ctxt -> + let buf = cstruct_of [ 0x00 ] in + let names = Hashtbl.create 32 in + let name, (base, buf) = parse names 0 buf in + assert_equal "" (Name.to_string name) ); + ( "parse-label-single" >:: fun test_ctxt -> + let buf = cstruct_of [ 0x03; 0x63; 0x6f; 0x6d; 0x00 ] in + let names = Hashtbl.create 32 in + let name, (base, buf) = parse names 0 buf in + assert_equal "com" (Name.to_string name) ); + ( "parse-label-seq" >:: fun test_ctxt -> + let buf = + cstruct_of [ 0x03; 0x66; 0x6f; 0x6f; 0x03; 0x63; 0x6f; 0x6d; 0x00 ] + in + let names = Hashtbl.create 32 in + let name, (base, buf) = parse names 0 buf in + assert_equal "foo.com" (Name.to_string name) ); + ( "parse-pointer-to-root-domain" >:: fun test_ctxt -> + let buf = cstruct_of [ 0xff; (* padding *) 0x00; 0xc0; 0x01 ] in + let names = Hashtbl.create 32 in + let buf = Cstruct.shift buf 1 in + let name, (base, buf) = parse names 1 buf in + let name, (base, buf) = parse names 2 buf in + assert_equal "" (Name.to_string name) ); + ( "parse-pointer-to-label" >:: fun test_ctxt -> + let buf = cstruct_of [ 0x03; 0x63; 0x6f; 0x6d; 0x00; 0xc0; 0x00 ] in + let names = Hashtbl.create 32 in + let name, (base, buf) = parse names 0 buf in + let name, (base, buf) = parse names base buf in + assert_equal "com" (Name.to_string name) ); + ( "parse-pointer-to-pointer-to-label" >:: fun test_ctxt -> + let buf = + cstruct_of [ 0x03; 0x63; 0x6f; 0x6d; 0x00; 0xc0; 0x00; 0xc0; 0x05 ] + in + let names = Hashtbl.create 32 in + let name, (base, buf) = parse names 0 buf in + let name, (base, buf) = parse names base buf in + let name, (base, buf) = parse names base buf in + assert_equal "com" (Name.to_string name) ); + ( "parse-label-then-label-with-pointer-to-label" >:: fun test_ctxt -> + let buf = + cstruct_of + [ + 0x03; + 0x63; + 0x6f; + 0x6d; + 0x00; + 0x03; + 0x66; + 0x6f; + 0x6f; + 0xc0; + 0x00; + ] + in + let names = Hashtbl.create 32 in + let name, (base, buf) = parse names 0 buf in + let name, (base, buf) = parse names base buf in + assert_equal "foo.com" (Name.to_string name) ); + ( "parse-pointer-to-self" >:: fun test_ctxt -> + let buf = cstruct_of [ 0xc0; 0x00 ] in + let names = Hashtbl.create 32 in + assert_raises + (Failure + "Name.parse_pointer: Cannot dereference pointer to (0) at \ + position (0)") (fun () -> parse names 0 buf) ); + ( "parse-pointer-to-invalid-address" >:: fun test_ctxt -> + let buf = cstruct_of [ 0xc0; 0x0e ] in + let names = Hashtbl.create 32 in + assert_raises + (Failure + "Name.parse_pointer: Cannot dereference pointer to (14) at \ + position (0)") (fun () -> parse names 0 buf) ); + ( "parse-pointer-cycle" >:: fun test_ctxt -> + let buf = cstruct_of [ 0xc0; 0x02; 0xc0; 0x00 ] in + let names = Hashtbl.create 32 in + assert_raises + (Failure + "Name.parse_pointer: Cannot dereference pointer to (2) at \ + position (0)") (fun () -> parse names 0 buf) ); + ( "parse-corrupted-label" >:: fun test_ctxt -> + let buf = cstruct_of [ 0x40 ] in + let names = Hashtbl.create 32 in + assert_raises (Failure "Name.parse_label: invalid length 64") + (fun () -> parse names 0 buf) ); + ( "parse-name-too-long" >:: fun test_ctxt -> + let buf = + cstruct_of + [ + 0x09; + 0x61; + 0x62; + 0x63; + 0x64; + 0x65; + 0x66; + 0x67; + 0x68; + 0x69; + 0x09; + 0x61; + 0x62; + 0x63; + 0x64; + 0x65; + 0x66; + 0x67; + 0x68; + 0x69; + 0x09; + 0x61; + 0x62; + 0x63; + 0x64; + 0x65; + 0x66; + 0x67; + 0x68; + 0x69; + 0x09; + 0x61; + 0x62; + 0x63; + 0x64; + 0x65; + 0x66; + 0x67; + 0x68; + 0x69; + 0x09; + 0x61; + 0x62; + 0x63; + 0x64; + 0x65; + 0x66; + 0x67; + 0x68; + 0x69; + 0x09; + 0x61; + 0x62; + 0x63; + 0x64; + 0x65; + 0x66; + 0x67; + 0x68; + 0x69; + 0x09; + 0x61; + 0x62; + 0x63; + 0x64; + 0x65; + 0x66; + 0x67; + 0x68; + 0x69; + 0x09; + 0x61; + 0x62; + 0x63; + 0x64; + 0x65; + 0x66; + 0x67; + 0x68; + 0x69; + 0x09; + 0x61; + 0x62; + 0x63; + 0x64; + 0x65; + 0x66; + 0x67; + 0x68; + 0x69; + 0x09; + 0x61; + 0x62; + 0x63; + 0x64; + 0x65; + 0x66; + 0x67; + 0x68; + 0x69; + 0x09; + 0x61; + 0x62; + 0x63; + 0x64; + 0x65; + 0x66; + 0x67; + 0x68; + 0x69; + 0x09; + 0x61; + 0x62; + 0x63; + 0x64; + 0x65; + 0x66; + 0x67; + 0x68; + 0x69; + 0x09; + 0x61; + 0x62; + 0x63; + 0x64; + 0x65; + 0x66; + 0x67; + 0x68; + 0x69; + 0x09; + 0x61; + 0x62; + 0x63; + 0x64; + 0x65; + 0x66; + 0x67; + 0x68; + 0x69; + 0x09; + 0x61; + 0x62; + 0x63; + 0x64; + 0x65; + 0x66; + 0x67; + 0x68; + 0x69; + 0x09; + 0x61; + 0x62; + 0x63; + 0x64; + 0x65; + 0x66; + 0x67; + 0x68; + 0x69; + 0x09; + 0x61; + 0x62; + 0x63; + 0x64; + 0x65; + 0x66; + 0x67; + 0x68; + 0x69; + 0x09; + 0x61; + 0x62; + 0x63; + 0x64; + 0x65; + 0x66; + 0x67; + 0x68; + 0x69; + 0x09; + 0x61; + 0x62; + 0x63; + 0x64; + 0x65; + 0x66; + 0x67; + 0x68; + 0x69; + 0x09; + 0x61; + 0x62; + 0x63; + 0x64; + 0x65; + 0x66; + 0x67; + 0x68; + 0x69; + 0x09; + 0x61; + 0x62; + 0x63; + 0x64; + 0x65; + 0x66; + 0x67; + 0x68; + 0x69; + 0x09; + 0x61; + 0x62; + 0x63; + 0x64; + 0x65; + 0x66; + 0x67; + 0x68; + 0x69; + 0x09; + 0x61; + 0x62; + 0x63; + 0x64; + 0x65; + 0x66; + 0x67; + 0x68; + 0x69; + 0x09; + 0x61; + 0x62; + 0x63; + 0x64; + 0x65; + 0x66; + 0x67; + 0x68; + 0x69; + 0x09; + 0x61; + 0x62; + 0x63; + 0x64; + 0x65; + 0x66; + 0x67; + 0x68; + 0x69; + 0x04; + 0x61; + 0x62; + 0x63; + 0x64; + 0x00; + ] + in + let names = Hashtbl.create 32 in + assert_raises (Failure "Name.parse: invalid length 256") (fun () -> + parse names 0 buf) ); + ] File "src/bin/dune", line 1, characters 0-0: diff --git a/_build/default/src/bin/dune b/_build/default/src/bin/.formatted/dune index fae10e6..bc4775d 100644 --- a/_build/default/src/bin/dune +++ b/_build/default/src/bin/.formatted/dune @@ -1,8 +1,7 @@ (executable (name main) - (libraries cmdliner ofs logs.fmt hostnet hvsock hvsock.lwt - fd-send-recv duration mirage-clock-unix mirage-random - fs9p mirage-random-stdlib) + (libraries cmdliner ofs logs.fmt hostnet hvsock hvsock.lwt fd-send-recv + duration mirage-clock-unix mirage-random fs9p mirage-random-stdlib) (flags :standard (:include flags.sexp)) File "src/hostnet/capture.mli", line 1, characters 0-0: diff --git a/_build/default/src/hostnet/capture.mli b/_build/default/src/hostnet/.formatted/capture.mli index f64a5ac..d51de7a 100644 --- a/_build/default/src/hostnet/capture.mli +++ b/_build/default/src/hostnet/.formatted/capture.mli @@ -1,21 +1,26 @@ -module Make(Input: Sig.VMNET): sig +module Make (Input : Sig.VMNET) : sig include Sig.VMNET include Sig.RECORDER with type t := t - val connect: Input.t -> t + val connect : Input.t -> t (** Capture traffic from a network, match against a set of capture rules and keep a limited amount of the most recent traffic that matches. *) type rule (** A rule matches some packets *) - val add_match: t:t -> name:string -> limit:int -> snaplen:int -> - predicate:(Frame.t -> bool) -> rule + val add_match : + t:t -> + name:string -> + limit:int -> + snaplen:int -> + predicate:(Frame.t -> bool) -> + rule (** Start capturing traffic which matches a given rule *) - val to_pcap: rule -> (Cstruct.t list) Lwt_stream.t + val to_pcap : rule -> Cstruct.t list Lwt_stream.t (** Given a rule return a pcap formatted stream of packets matching the rule *) - val filesystem: t -> Vfs.Dir.t + val filesystem : t -> Vfs.Dir.t (** A virtual filesystem containing pcap-formatted data from each match *) end File "src/hostnet/cohttp_mirage_io.mli", line 1, characters 0-0: diff --git a/_build/default/src/hostnet/cohttp_mirage_io.mli b/_build/default/src/hostnet/.formatted/cohttp_mirage_io.mli index 489f080..5e1a17c 100644 --- a/_build/default/src/hostnet/cohttp_mirage_io.mli +++ b/_build/default/src/hostnet/.formatted/cohttp_mirage_io.mli @@ -19,8 +19,9 @@ (** Cohttp IO implementation using Mirage channels. *) -module Make (Channel: Mirage_channel.S) : Cohttp.S.IO - with type 'a t = 'a Lwt.t - and type ic = Channel.t - and type oc = Channel.t - and type conn = Channel.flow +module Make (Channel : Mirage_channel.S) : + Cohttp.S.IO + with type 'a t = 'a Lwt.t + and type ic = Channel.t + and type oc = Channel.t + and type conn = Channel.flow File "src/hostnet/filter.mli", line 1, characters 0-0: diff --git a/_build/default/src/hostnet/filter.mli b/_build/default/src/hostnet/.formatted/filter.mli index b44ee23..faaa04f 100644 --- a/_build/default/src/hostnet/filter.mli +++ b/_build/default/src/hostnet/.formatted/filter.mli @@ -1,10 +1,11 @@ -module Make(Input: Sig.VMNET): sig +module Make (Input : Sig.VMNET) : sig include Sig.VMNET - val connect: - valid_subnets:Ipaddr.V4.Prefix.t list - -> valid_sources:Ipaddr.V4.t list -> Input.t - -> t - (** Construct a filtered ethernet network which removes IP packets whose + val connect : + valid_subnets:Ipaddr.V4.Prefix.t list -> + valid_sources:Ipaddr.V4.t list -> + Input.t -> + t + (** Construct a filtered ethernet network which removes IP packets whose source IP is not in [valid_sources] *) end File "src/hostnet/forward.mli", line 1, characters 0-0: diff --git a/_build/default/src/hostnet/forward.mli b/_build/default/src/hostnet/.formatted/forward.mli index 9ee0943..d33497d 100644 --- a/_build/default/src/hostnet/forward.mli +++ b/_build/default/src/hostnet/.formatted/forward.mli @@ -1,15 +1,12 @@ - module Port : sig - type t - val of_string: string -> (t, [ `Msg of string ]) result + val of_string : string -> (t, [ `Msg of string ]) result end module Make - (Clock: Mirage_clock.MCLOCK) - (Connector: Sig.Connector) - (Socket: Sig.SOCKETS): - Active_list.Instance + (Clock : Mirage_clock.MCLOCK) + (Connector : Sig.Connector) + (Socket : Sig.SOCKETS) : Active_list.Instance -val set_allowed_addresses: Ipaddr.t list option -> unit +val set_allowed_addresses : Ipaddr.t list option -> unit File "src/hostnet_test/dune", line 1, characters 0-0: diff --git a/_build/default/src/hostnet_test/dune b/_build/default/src/hostnet_test/.formatted/dune index 16f8bb5..156f173 100644 --- a/_build/default/src/hostnet_test/dune +++ b/_build/default/src/hostnet_test/.formatted/dune @@ -1,6 +1,6 @@ (executable (name main) (libraries hostnet cmdliner alcotest logs.fmt protocol-9p mirage_dns - mirage-clock-unix charrua-client.mirage forwarder sha - mirage-random-stdlib arp.mirage) + mirage-clock-unix charrua-client.mirage forwarder sha mirage-random-stdlib + arp.mirage) (preprocess no_preprocessing)) File "src/hostnet/cohttp_mirage_io.ml", line 1, characters 0-0: diff --git a/_build/default/src/hostnet/cohttp_mirage_io.ml b/_build/default/src/hostnet/.formatted/cohttp_mirage_io.ml index 83cf0bf..858d6a0 100644 --- a/_build/default/src/hostnet/cohttp_mirage_io.ml +++ b/_build/default/src/hostnet/.formatted/cohttp_mirage_io.ml @@ -19,8 +19,7 @@ open Lwt.Infix -module Make (Channel: Mirage_channel.S) = struct - +module Make (Channel : Mirage_channel.S) = struct type 'a t = 'a Lwt.t type ic = Channel.t type oc = Channel.t @@ -30,29 +29,28 @@ module Make (Channel: Mirage_channel.S) = struct let read_line ic = Channel.read_line ic >>= function - | Ok (`Data []) -> Lwt.return_none - | Ok `Eof -> Lwt.return_none + | Ok (`Data []) -> Lwt.return_none + | Ok `Eof -> Lwt.return_none | Ok (`Data bufs) -> Lwt.return (Some (Cstruct.copyv bufs)) - | Error e -> failf "Flow error: %a" Channel.pp_error e + | Error e -> failf "Flow error: %a" Channel.pp_error e let read ic len = Channel.read_some ~len ic >>= function | Ok (`Data buf) -> Lwt.return (Cstruct.to_string buf) - | Ok `Eof -> Lwt.return "" - | Error e -> failf "Flow error: %a" Channel.pp_error e + | Ok `Eof -> Lwt.return "" + | Error e -> failf "Flow error: %a" Channel.pp_error e let write oc buf = Channel.write_string oc buf 0 (String.length buf); Channel.flush oc >>= function - | Ok () -> Lwt.return_unit + | Ok () -> Lwt.return_unit | Error `Closed -> Lwt.fail_with "Trying to write on closed channel" - | Error e -> failf "Flow error: %a" Channel.pp_write_error e + | Error e -> failf "Flow error: %a" Channel.pp_write_error e let flush _ = (* NOOP since we flush in the normal writer functions above *) Lwt.return_unit - let (>>= ) = Lwt.( >>= ) + let ( >>= ) = Lwt.( >>= ) let return = Lwt.return - end File "src/hostnet/frame.mli", line 1, characters 0-0: diff --git a/_build/default/src/hostnet/frame.mli b/_build/default/src/hostnet/.formatted/frame.mli index ec764c8..4d5ed96 100644 --- a/_build/default/src/hostnet/frame.mli +++ b/_build/default/src/hostnet/.formatted/frame.mli @@ -1,27 +1,42 @@ type icmp = - | Echo: { seq: int; id: int; payload: Cstruct.t } -> icmp - | Time_exceeded: { ipv4: (ipv4, [ `Msg of string ]) result } -> icmp - | Destination_unreachable: { ipv4: (ipv4, [ `Msg of string ]) result } -> icmp - | Unknown_icmp: { ty: int } -> icmp + | Echo : { seq : int; id : int; payload : Cstruct.t } -> icmp + | Time_exceeded : { ipv4 : (ipv4, [ `Msg of string ]) result } -> icmp + | Destination_unreachable : { + ipv4 : (ipv4, [ `Msg of string ]) result; + } + -> icmp + | Unknown_icmp : { ty : int } -> icmp and ipv4 = { - src: Ipaddr.V4.t; dst: Ipaddr.V4.t; - dnf: bool; ihl: int; - ttl: int; raw: Cstruct.t; payload: t + src : Ipaddr.V4.t; + dst : Ipaddr.V4.t; + dnf : bool; + ihl : int; + ttl : int; + raw : Cstruct.t; + payload : t; } and t = - | Ethernet: { src: Macaddr.t; dst: Macaddr.t; payload: t } -> t - | Arp: { op: [ `Request | `Reply | `Unknown ] } -> t - | Icmp: { ty: int; code: int; raw: Cstruct.t; icmp: icmp } -> t - | Ipv4: ipv4 -> t - | Udp: { src: int; dst: int; len: int; raw: Cstruct.t; payload: t } -> t - | Tcp: { src: int; dst: int; syn: bool; rst: bool; raw: Cstruct.t; payload: t } -> t - | Payload: Cstruct.t -> t - | Unknown: t + | Ethernet : { src : Macaddr.t; dst : Macaddr.t; payload : t } -> t + | Arp : { op : [ `Request | `Reply | `Unknown ] } -> t + | Icmp : { ty : int; code : int; raw : Cstruct.t; icmp : icmp } -> t + | Ipv4 : ipv4 -> t + | Udp : { src : int; dst : int; len : int; raw : Cstruct.t; payload : t } -> t + | Tcp : { + src : int; + dst : int; + syn : bool; + rst : bool; + raw : Cstruct.t; + payload : t; + } + -> t + | Payload : Cstruct.t -> t + | Unknown : t -val ipv4: Cstructs.t -> (ipv4, [ `Msg of string ]) result +val ipv4 : Cstructs.t -> (ipv4, [ `Msg of string ]) result (** [ipv4 buffers] parses the IPv4 frame in [buffers] *) -val parse: Cstructs.t -> (t, [ `Msg of string]) result +val parse : Cstructs.t -> (t, [ `Msg of string ]) result (** [parse buffers] parses the frame in [buffers] *) File "src/hostnet/hostnet_dhcp.mli", line 1, characters 0-0: diff --git a/_build/default/src/hostnet/hostnet_dhcp.mli b/_build/default/src/hostnet/.formatted/hostnet_dhcp.mli index d02d977..b049e73 100644 --- a/_build/default/src/hostnet/hostnet_dhcp.mli +++ b/_build/default/src/hostnet/.formatted/hostnet_dhcp.mli @@ -1,11 +1,12 @@ -module Make (Clock: Mirage_clock.MCLOCK) (Netif: Mirage_net.S): sig +module Make (Clock : Mirage_clock.MCLOCK) (Netif : Mirage_net.S) : sig type t - val make: configuration:Configuration.t -> Netif.t -> t + val make : configuration:Configuration.t -> Netif.t -> t (** Create a DHCP server. *) - val callback: t -> Cstruct.t -> unit Lwt.t + val callback : t -> Cstruct.t -> unit Lwt.t end -val update_global_configuration: Configuration.Dhcp_configuration.t option -> unit -(** Update the global DHCP configuration: gateway IP, search domains etc *) \ No newline at end of file +val update_global_configuration : + Configuration.Dhcp_configuration.t option -> unit +(** Update the global DHCP configuration: gateway IP, search domains etc *) File "src/hostnet/gateway_forwards.mli", line 1, characters 0-0: diff --git a/_build/default/src/hostnet/gateway_forwards.mli b/_build/default/src/hostnet/.formatted/gateway_forwards.mli index a9db939..99c9465 100644 --- a/_build/default/src/hostnet/gateway_forwards.mli +++ b/_build/default/src/hostnet/.formatted/gateway_forwards.mli @@ -1,37 +1,35 @@ -type protocol = - | Tcp - | Udp +type protocol = Tcp | Udp type forward = { - protocol: protocol; - external_port: int; - internal_ip: Ipaddr.V4.t; - internal_port: int; + protocol : protocol; + external_port : int; + internal_ip : Ipaddr.V4.t; + internal_port : int; } type t = forward list -val to_string: t -> string -val of_string: string -> (t, [`Msg of string]) result +val to_string : t -> string +val of_string : string -> (t, [ `Msg of string ]) result -val set_static: t -> unit +val set_static : t -> unit (** update the static forwarding table *) -val update: t -> unit +val update : t -> unit (** update the dynamic forwarding table *) -module Udp: sig - val mem: int -> bool +module Udp : sig + val mem : int -> bool (** [mem port] is true if there is a rule to forward UDP from external port [port] *) - val find: int -> (Ipaddr.V4.t * int) + val find : int -> Ipaddr.V4.t * int (** [find port] returns the internal IP and port to forward UDP on external port [port] *) end -module Tcp: sig - val mem: int -> bool +module Tcp : sig + val mem : int -> bool (** [mem port] is true if there is a rule to forward TCP from external port [port] *) - val find: int -> (Ipaddr.V4.t * int) + val find : int -> Ipaddr.V4.t * int (** [find port] returns the internal IP and port to forward TCP on external port [port] *) -end \ No newline at end of file +end File "src/hostnet/hostnet_icmp.mli", line 1, characters 0-0: diff --git a/_build/default/src/hostnet/hostnet_icmp.mli b/_build/default/src/hostnet/.formatted/hostnet_icmp.mli index 7dafff4..92a3f89 100644 --- a/_build/default/src/hostnet/hostnet_icmp.mli +++ b/_build/default/src/hostnet/.formatted/hostnet_icmp.mli @@ -5,37 +5,37 @@ type address = Ipaddr.V4.t type datagram = { - src: address; - dst: address; - ty: int; - code: int; - seq: int; - id: int; - payload: Cstruct.t; + src : address; + dst : address; + ty : int; + code : int; + seq : int; + id : int; + payload : Cstruct.t; } (** An ICMP datagram *) type reply = Cstruct.t -> unit Lwt.t module Make - (Sockets: Sig.SOCKETS) - (Clock: Mirage_clock.MCLOCK) - (Time: Mirage_time.S) -: sig - + (Sockets : Sig.SOCKETS) + (Clock : Mirage_clock.MCLOCK) + (Time : Mirage_time.S) : sig type t (** An ICMP NAT implementation *) - val create: ?max_idle_time:int64 -> unit -> t Lwt.t + val create : ?max_idle_time:int64 -> unit -> t Lwt.t (** Create an ICMP NAT implementation which will keep "NAT rules" alive until they become idle for the given [?max_idle_time] *) - val set_send_reply: t:t -> send_reply:(src:address -> dst:address -> payload:Cstruct.t -> unit Lwt.t) -> unit + val set_send_reply : + t:t -> + send_reply:(src:address -> dst:address -> payload:Cstruct.t -> unit Lwt.t) -> + unit (** Register a reply callback which will be used to send datagrams to the NAT client. *) - val input: t:t -> datagram:datagram -> ttl:int -> unit -> unit Lwt.t + val input : t:t -> datagram:datagram -> ttl:int -> unit -> unit Lwt.t (** Process an incoming datagram, forwarding it over the Sockets implementation and set up a listening rule to catch replies. *) - end File "src/hostnet/hosts.mli", line 1, characters 0-0: diff --git a/_build/default/src/hostnet/hosts.mli b/_build/default/src/hostnet/.formatted/hosts.mli index 5376583..20f8fe2 100644 --- a/_build/default/src/hostnet/hosts.mli +++ b/_build/default/src/hostnet/.formatted/hosts.mli @@ -1,22 +1,20 @@ -val default_etc_hosts_path: string +val default_etc_hosts_path : string (** Default path where /etc/hosts should be on this machine *) -val etc_hosts: (string * Ipaddr.t) list ref +val etc_hosts : (string * Ipaddr.t) list ref (** The current contents of the hosts file *) -val of_string: string -> (string * Ipaddr.t) list +val of_string : string -> (string * Ipaddr.t) list (** Parse the contents of a hosts file *) -module Make(Files: Sig.FILES): sig - +module Make (Files : Sig.FILES) : sig type watch - val watch: ?path:string -> unit -> (watch, [ `Msg of string ]) result Lwt.t + val watch : ?path:string -> unit -> (watch, [ `Msg of string ]) result Lwt.t (** Start watching the hosts file, updating the [etc_hosts] binding in the background. The [?path] argument allows the location of the hosts file to be overriden. This blocks until the watch has been established. *) - val unwatch: watch -> unit Lwt.t + val unwatch : watch -> unit Lwt.t (** Stop watching the hosts file *) - end File "src/hostnet/hostnet_dns.mli", line 1, characters 0-0: diff --git a/_build/default/src/hostnet/hostnet_dns.mli b/_build/default/src/hostnet/.formatted/hostnet_dns.mli index 1132b45..8cca967 100644 --- a/_build/default/src/hostnet/hostnet_dns.mli +++ b/_build/default/src/hostnet/.formatted/hostnet_dns.mli @@ -1,46 +1,49 @@ -module Policy(Files: Sig.FILES): Sig.DNS_POLICY (** Global DNS configuration *) +module Policy (Files : Sig.FILES) : Sig.DNS_POLICY -module Config: sig - type t = [ - | `Upstream of Dns_forward.Config.t (** use upstream servers *) - | `Host (** use the host's resolver *) - ] - val to_string: t -> string - val compare: t -> t -> int +module Config : sig + type t = + [ `Upstream of Dns_forward.Config.t (** use upstream servers *) + | `Host (** use the host's resolver *) ] + + val to_string : t -> string + val compare : t -> t -> int end module Make - (Ip: Tcpip.Ip.S with type ipaddr = Ipaddr.V4.t) - (Udp: Tcpip.Udp.S with type ipaddr = Ipaddr.V4.t) - (Tcp: Tcpip.Tcp.S with type ipaddr = Ipaddr.V4.t) - (Socket: Sig.SOCKETS) - (Dns_resolver: Sig.DNS) - (Time: Mirage_time.S) - (Clock: Mirage_clock.MCLOCK) - (Recorder: Sig.RECORDER) : -sig - + (Ip : Tcpip.Ip.S with type ipaddr = Ipaddr.V4.t) + (Udp : Tcpip.Udp.S with type ipaddr = Ipaddr.V4.t) + (Tcp : Tcpip.Tcp.S with type ipaddr = Ipaddr.V4.t) + (Socket : Sig.SOCKETS) + (Dns_resolver : Sig.DNS) + (Time : Mirage_time.S) + (Clock : Mirage_clock.MCLOCK) + (Recorder : Sig.RECORDER) : sig type t (** A DNS proxy instance with a fixed configuration *) - val create: + val create : local_address:Dns_forward.Config.Address.t -> builtin_names:(Dns.Name.t * Ipaddr.t) list -> - Config.t -> t Lwt.t + Config.t -> + t Lwt.t (** Create a DNS forwarding instance based on the given configuration, either [`Upstream config]: send DNS requests to the given upstream servers [`Host]: use the Host's resolver. The parameter [~local_address] will be used in any .pcap trace as the source address of DNS requests sent from this host. *) - val set_recorder: Recorder.t -> unit - - val handle_udp: - t:t -> udp:Udp.t -> src:Ipaddr.V4.t -> dst:Ipaddr.V4.t -> src_port:int -> - Cstruct.t -> (unit, Udp.error) result Lwt.t + val set_recorder : Recorder.t -> unit - val handle_tcp: t:t -> (int -> (Tcp.flow -> unit Lwt.t) option) Lwt.t + val handle_udp : + t:t -> + udp:Udp.t -> + src:Ipaddr.V4.t -> + dst:Ipaddr.V4.t -> + src_port:int -> + Cstruct.t -> + (unit, Udp.error) result Lwt.t - val destroy: t -> unit Lwt.t + val handle_tcp : t:t -> (int -> (Tcp.flow -> unit Lwt.t) option) Lwt.t + val destroy : t -> unit Lwt.t end File "src/hostnet/hostnet_http.mli", line 1, characters 0-0: diff --git a/_build/default/src/hostnet/hostnet_http.mli b/_build/default/src/hostnet/.formatted/hostnet_http.mli index 1b19095..143444f 100644 --- a/_build/default/src/hostnet/hostnet_http.mli +++ b/_build/default/src/hostnet/.formatted/hostnet_http.mli @@ -1,60 +1,65 @@ -module Match: sig +module Match : sig type t (** A request destination which should bypass the proxy *) - val of_string: string -> t - val to_string: t -> string + val of_string : string -> t + val to_string : t -> string - val matches: string -> t -> bool + val matches : string -> t -> bool (** [matches host_or_ip excludes] is true if [host_or_ip] matches the excludes rules and should bypass the proxy. *) end module Make - (Ip: Tcpip.Ip.S with type ipaddr = Ipaddr.V4.t) - (Udp: Tcpip.Udp.S with type ipaddr = Ipaddr.V4.t) - (Tcp: Mirage_flow_combinators.SHUTDOWNABLE) - (Remote: Sig.FLOW_CLIENT with type address = Ipaddr.t * int) - (Dns_resolver: Sig.DNS) : -sig - + (Ip : Tcpip.Ip.S with type ipaddr = Ipaddr.V4.t) + (Udp : Tcpip.Udp.S with type ipaddr = Ipaddr.V4.t) + (Tcp : Mirage_flow_combinators.SHUTDOWNABLE) + (Remote : Sig.FLOW_CLIENT with type address = Ipaddr.t * int) + (Dns_resolver : Sig.DNS) : sig type t (** An HTTP proxy instance with a fixed configuration *) - val to_string: t -> string + val to_string : t -> string - val create: ?http:string -> ?https:string -> ?exclude:string - -> ?transparent_http_ports:int list -> ?transparent_https_ports:int list - -> ?allow_enabled:bool -> ?allow:string list -> ?allow_error_msg:string - -> unit -> - (t, [`Msg of string]) result Lwt.t + val create : + ?http:string -> + ?https:string -> + ?exclude:string -> + ?transparent_http_ports:int list -> + ?transparent_https_ports:int list -> + ?allow_enabled:bool -> + ?allow:string list -> + ?allow_error_msg:string -> + unit -> + (t, [ `Msg of string ]) result Lwt.t (** Create a transparent HTTP forwarding instance which forwards HTTP to the proxy [http], HTTPS to the proxy [https] or connects directly if the URL matches [exclude]. If an allow list is provided then host names not on the list will be rejected. *) - val of_json: Ezjsonm.value -> (t, [`Msg of string]) result Lwt.t + val of_json : Ezjsonm.value -> (t, [ `Msg of string ]) result Lwt.t (** [of_json json] decodes [json] into a proxy configuration *) - val to_json: t -> Ezjsonm.t + val to_json : t -> Ezjsonm.t (** [to_json t] encodes [t] into json *) - val transparent_proxy_handler: + val transparent_proxy_handler : localhost_names:Dns.Name.t list -> localhost_ips:Ipaddr.t list -> - dst:(Ipaddr.V4.t * int) -> t:t -> + dst:Ipaddr.V4.t * int -> + t:t -> (int -> (Tcp.flow -> unit Lwt.t) option) Lwt.t option (** Intercept outgoing HTTP flows and redirect to the upstream proxy if one is defined. *) - val explicit_proxy_handler: + val explicit_proxy_handler : localhost_names:Dns.Name.t list -> localhost_ips:Ipaddr.t list -> - dst:(Ipaddr.V4.t * int) -> t:t -> + dst:Ipaddr.V4.t * int -> + t:t -> (int -> (Tcp.flow -> unit Lwt.t) option) Lwt.t option (** Intercept outgoing HTTP proxy flows and if an upstream proxy is defined, redirect to it, otherwise implement the proxy function ourselves. *) - end File "src/dns_test/test_packet.ml", line 1, characters 0-0: diff --git a/_build/default/src/dns_test/test_packet.ml b/_build/default/src/dns_test/.formatted/test_packet.ml index 50a9847..6e54dae 100644 --- a/_build/default/src/dns_test/test_packet.ml +++ b/_build/default/src/dns_test/.formatted/test_packet.ml @@ -1,4 +1,5 @@ [@@@warning "-3-27"] + open OUnit2 open Printf @@ -6,366 +7,448 @@ open Printf [%%cstruct type ethernet = { - dst: uint8_t [@len 6]; - src: uint8_t [@len 6]; - ethertype: uint16_t; - } [@@big_endian] -] + dst : uint8_t; [@len 6] + src : uint8_t; [@len 6] + ethertype : uint16_t; +} +[@@big_endian]] [%%cstruct type ipv4 = { - hlen_version: uint8_t; - tos: uint8_t; - len: uint16_t; - id: uint16_t; - off: uint16_t; - ttl: uint8_t; - proto: uint8_t; - csum: uint16_t; - src: uint8_t [@len 4]; - dst: uint8_t [@len 4]; - } [@@big_endian] -] + hlen_version : uint8_t; + tos : uint8_t; + len : uint16_t; + id : uint16_t; + off : uint16_t; + ttl : uint8_t; + proto : uint8_t; + csum : uint16_t; + src : uint8_t; [@len 4] + dst : uint8_t; [@len 4] +} +[@@big_endian]] [%%cstruct type udpv4 = { - srouce_port: uint16_t; - dest_port: uint16_t; - length: uint16_t; - checksum: uint16_t; - } [@@big_endian] -] + srouce_port : uint16_t; + dest_port : uint16_t; + length : uint16_t; + checksum : uint16_t; +} +[@@big_endian]] let load_pcap path = - let fd = Unix.(openfile path [O_RDONLY] 0) in - let buf = Bigarray.(array1_of_genarray @@ Unix.map_file fd char c_layout false [|-1|]) in + let fd = Unix.(openfile path [ O_RDONLY ] 0) in + let buf = + Bigarray.( + array1_of_genarray @@ Unix.map_file fd char c_layout false [| -1 |]) + in let buf = Cstruct.of_bigarray buf in let header, body = Cstruct.split buf Pcap.sizeof_pcap_header in match Pcap.detect header with - | Some h -> - Pcap.packets h body - | None -> - assert_failure "Not pcap format" + | Some h -> Pcap.packets h body + | None -> assert_failure "Not pcap format" let load_packet path = match (load_pcap path) () with | Some (hdr, eth) -> - assert_equal 0x0800 (get_ethernet_ethertype eth); - let ip = Cstruct.shift eth sizeof_ethernet in - let version = get_ipv4_hlen_version ip lsr 4 in - assert_equal 4 version; - assert_equal 17 (get_ipv4_proto ip); - let udp = Cstruct.shift ip sizeof_ipv4 in - Cstruct.shift udp sizeof_udpv4 - | None -> - assert_failure "No packets" + assert_equal 0x0800 (get_ethernet_ethertype eth); + let ip = Cstruct.shift eth sizeof_ethernet in + let version = get_ipv4_hlen_version ip lsr 4 in + assert_equal 4 version; + assert_equal 17 (get_ipv4_proto ip); + let udp = Cstruct.shift ip sizeof_ipv4 in + Cstruct.shift udp sizeof_udpv4 + | None -> assert_failure "No packets" let hexdump ibuf = let b = Buffer.create 16 in - Cstruct.hexdump_to_buffer b ibuf ; + Cstruct.hexdump_to_buffer b ibuf; Buffer.contents b open Dns open Packet let tests = - "Packet" >::: - [ - "parse-dns-q-A" >:: (fun test_ctxt -> - let raw = load_packet "dns-q-A.pcap" in - let packet = parse raw in - assert_equal ~msg:"id" 0x930b packet.id; - assert_equal ~msg:"qr" Query packet.detail.qr; - assert_equal ~msg:"opcode" Standard packet.detail.opcode; - assert_equal ~msg:"aa" false packet.detail.aa; - assert_equal ~msg:"tc" false packet.detail.tc; - assert_equal ~msg:"rd" true packet.detail.rd; - assert_equal ~msg:"ra" false packet.detail.ra; - assert_equal ~msg:"rcode" NoError packet.detail.rcode; - assert_equal ~msg:"#qu" 1 (List.length packet.questions); - assert_equal ~msg:"#an" 0 (List.length packet.answers); - assert_equal ~msg:"#au" 0 (List.length packet.authorities); - assert_equal ~msg:"#ad" 0 (List.length packet.additionals); - - let q = List.hd packet.questions in - assert_equal ~msg:"q_name" "www.google.com" (Name.to_string q.q_name); - assert_equal ~msg:"q_type" Q_A q.q_type; - assert_equal ~msg:"q_class" Q_IN q.q_class; - assert_equal ~msg:"q_unicast" Q_Normal q.q_unicast; - ); - - "marshal-dns-q-A" >:: (fun test_ctxt -> - let raw = load_packet "dns-q-A.pcap" in - let packet = - let detail = { - qr=Query; opcode=Standard; aa=false; - tc=false; rd=true; ra=false; rcode=NoError - } in - let q = make_question Q_A (Name.of_string "www.google.com") in - { - id=0x930b; detail; questions=[q]; - answers=[]; authorities=[]; additionals=[]; - } in - let buf = marshal packet in - assert_equal ~cmp:Cstruct.equal ~printer:hexdump raw buf - ); - - "parse-dns-r-A" >:: (fun test_ctxt -> - let raw = load_packet "dns-r-A.pcap" in - let packet = parse raw in - assert_equal ~msg:"id" 0x930b packet.id; - assert_equal ~msg:"qr" Response packet.detail.qr; - assert_equal ~msg:"opcode" Standard packet.detail.opcode; - assert_equal ~msg:"aa" false packet.detail.aa; - assert_equal ~msg:"tc" false packet.detail.tc; - assert_equal ~msg:"rd" true packet.detail.rd; - assert_equal ~msg:"ra" true packet.detail.ra; - assert_equal ~msg:"rcode" NoError packet.detail.rcode; - assert_equal ~msg:"#qu" 1 (List.length packet.questions); - assert_equal ~msg:"#an" 5 (List.length packet.answers); - assert_equal ~msg:"#au" 0 (List.length packet.authorities); - assert_equal ~msg:"#ad" 0 (List.length packet.additionals); - - let q = List.hd packet.questions in - assert_equal ~msg:"q_name" "www.google.com" (Name.to_string q.q_name); - assert_equal ~msg:"q_type" Q_A q.q_type; - assert_equal ~msg:"q_class" Q_IN q.q_class; - assert_equal ~msg:"q_unicast" Q_Normal q.q_unicast; - - let expected_fourth = [208; 211; 209; 212; 210] in - List.iter2 (fun fourth a -> - assert_equal ~msg:"name" "www.google.com" (Name.to_string a.name); - assert_equal ~msg:"cls" RR_IN a.cls; - assert_equal ~msg:"flush" false a.flush; - assert_equal ~msg:"ttl" (Int32.of_int 220) a.ttl; - let expected_addr = "74.125.237." ^ (string_of_int fourth) in - match a.rdata with - | A addr -> assert_equal ~msg:"A" ~printer:(fun s -> s) expected_addr (Ipaddr.V4.to_string addr) - | _ -> assert_failure "RR type"; - ) expected_fourth packet.answers - ); - - "parse-dns-pointer-to-pointer" >:: (fun test_ctxt -> - let raw = load_packet "dns-r-pointer-to-pointer.pcap" in - let packet = parse raw in - assert_equal ~msg:"#an" 3 (List.length packet.answers); - - packet.answers |> List.iter (fun a -> ( - assert_equal ~msg:"name" "amazonaws.com" (Name.to_string a.name) - )); - ); + "Packet" + >::: [ + ( "parse-dns-q-A" >:: fun test_ctxt -> + let raw = load_packet "dns-q-A.pcap" in + let packet = parse raw in + assert_equal ~msg:"id" 0x930b packet.id; + assert_equal ~msg:"qr" Query packet.detail.qr; + assert_equal ~msg:"opcode" Standard packet.detail.opcode; + assert_equal ~msg:"aa" false packet.detail.aa; + assert_equal ~msg:"tc" false packet.detail.tc; + assert_equal ~msg:"rd" true packet.detail.rd; + assert_equal ~msg:"ra" false packet.detail.ra; + assert_equal ~msg:"rcode" NoError packet.detail.rcode; + assert_equal ~msg:"#qu" 1 (List.length packet.questions); + assert_equal ~msg:"#an" 0 (List.length packet.answers); + assert_equal ~msg:"#au" 0 (List.length packet.authorities); + assert_equal ~msg:"#ad" 0 (List.length packet.additionals); - "parse-dns-q-self-pointer" >:: (fun test_ctxt -> - let raw = load_packet "dns-q-self-pointer.pcap" in - assert_raises (Failure "Name.parse_pointer: Cannot dereference pointer to (12) at position (12)") (fun () -> parse raw) - ); + let q = List.hd packet.questions in + assert_equal ~msg:"q_name" "www.google.com" (Name.to_string q.q_name); + assert_equal ~msg:"q_type" Q_A q.q_type; + assert_equal ~msg:"q_class" Q_IN q.q_class; + assert_equal ~msg:"q_unicast" Q_Normal q.q_unicast ); + ( "marshal-dns-q-A" >:: fun test_ctxt -> + let raw = load_packet "dns-q-A.pcap" in + let packet = + let detail = + { + qr = Query; + opcode = Standard; + aa = false; + tc = false; + rd = true; + ra = false; + rcode = NoError; + } + in + let q = make_question Q_A (Name.of_string "www.google.com") in + { + id = 0x930b; + detail; + questions = [ q ]; + answers = []; + authorities = []; + additionals = []; + } + in + let buf = marshal packet in + assert_equal ~cmp:Cstruct.equal ~printer:hexdump raw buf ); + ( "parse-dns-r-A" >:: fun test_ctxt -> + let raw = load_packet "dns-r-A.pcap" in + let packet = parse raw in + assert_equal ~msg:"id" 0x930b packet.id; + assert_equal ~msg:"qr" Response packet.detail.qr; + assert_equal ~msg:"opcode" Standard packet.detail.opcode; + assert_equal ~msg:"aa" false packet.detail.aa; + assert_equal ~msg:"tc" false packet.detail.tc; + assert_equal ~msg:"rd" true packet.detail.rd; + assert_equal ~msg:"ra" true packet.detail.ra; + assert_equal ~msg:"rcode" NoError packet.detail.rcode; + assert_equal ~msg:"#qu" 1 (List.length packet.questions); + assert_equal ~msg:"#an" 5 (List.length packet.answers); + assert_equal ~msg:"#au" 0 (List.length packet.authorities); + assert_equal ~msg:"#ad" 0 (List.length packet.additionals); - "marshal-dns-r-A" >:: (fun test_ctxt -> - let raw = load_packet "dns-r-A.pcap" in - let packet = - let detail = { - qr=Response; opcode=Standard; aa=false; - tc=false; rd=true; ra=true; rcode=NoError - } in - let q = make_question ~q_class:Q_IN ~q_unicast:Q_Normal Q_A (Name.of_string "www.google.com") in - let answers = List.map (fun fourth -> { - name=q.q_name; cls=RR_IN; flush=false; ttl=Int32.of_int 220; - rdata=A (Ipaddr.V4.of_string_exn (sprintf "74.125.237.%d" fourth)); - }) [208; 211; 209; 212; 210] - in - { - id=0x930b; detail; questions=[q]; - answers; authorities=[]; additionals=[]; - } in - let buf = marshal packet in - assert_equal ~cmp:Cstruct.equal ~printer:hexdump raw buf - ); + let q = List.hd packet.questions in + assert_equal ~msg:"q_name" "www.google.com" (Name.to_string q.q_name); + assert_equal ~msg:"q_type" Q_A q.q_type; + assert_equal ~msg:"q_class" Q_IN q.q_class; + assert_equal ~msg:"q_unicast" Q_Normal q.q_unicast; - "parse-mdns-q-A" >:: (fun test_ctxt -> - let raw = load_packet "mdns-q-A.pcap" in - let packet = parse raw in - assert_equal ~msg:"id" 0 packet.id; - assert_equal ~msg:"qr" Query packet.detail.qr; - assert_equal ~msg:"opcode" Standard packet.detail.opcode; - assert_equal ~msg:"aa" false packet.detail.aa; - assert_equal ~msg:"tc" false packet.detail.tc; - assert_equal ~msg:"rd" false packet.detail.rd; - assert_equal ~msg:"ra" false packet.detail.ra; - assert_equal ~msg:"rcode" NoError packet.detail.rcode; - assert_equal ~msg:"#qu" 1 (List.length packet.questions); - assert_equal ~msg:"#an" 0 (List.length packet.answers); - assert_equal ~msg:"#au" 0 (List.length packet.authorities); - assert_equal ~msg:"#ad" 0 (List.length packet.additionals); + let expected_fourth = [ 208; 211; 209; 212; 210 ] in + List.iter2 + (fun fourth a -> + assert_equal ~msg:"name" "www.google.com" (Name.to_string a.name); + assert_equal ~msg:"cls" RR_IN a.cls; + assert_equal ~msg:"flush" false a.flush; + assert_equal ~msg:"ttl" (Int32.of_int 220) a.ttl; + let expected_addr = "74.125.237." ^ string_of_int fourth in + match a.rdata with + | A addr -> + assert_equal ~msg:"A" + ~printer:(fun s -> s) + expected_addr (Ipaddr.V4.to_string addr) + | _ -> assert_failure "RR type") + expected_fourth packet.answers ); + ( "parse-dns-pointer-to-pointer" >:: fun test_ctxt -> + let raw = load_packet "dns-r-pointer-to-pointer.pcap" in + let packet = parse raw in + assert_equal ~msg:"#an" 3 (List.length packet.answers); - let q = List.hd packet.questions in - assert_equal ~msg:"q_name" "cubieboard2.local" (Name.to_string q.q_name); - assert_equal ~msg:"q_type" Q_A q.q_type; - assert_equal ~msg:"q_class" Q_IN q.q_class; - assert_equal ~msg:"q_unicast" Q_Normal q.q_unicast; - ); + packet.answers + |> List.iter (fun a -> + assert_equal ~msg:"name" "amazonaws.com" + (Name.to_string a.name)) ); + ( "parse-dns-q-self-pointer" >:: fun test_ctxt -> + let raw = load_packet "dns-q-self-pointer.pcap" in + assert_raises + (Failure + "Name.parse_pointer: Cannot dereference pointer to (12) at \ + position (12)") (fun () -> parse raw) ); + ( "marshal-dns-r-A" >:: fun test_ctxt -> + let raw = load_packet "dns-r-A.pcap" in + let packet = + let detail = + { + qr = Response; + opcode = Standard; + aa = false; + tc = false; + rd = true; + ra = true; + rcode = NoError; + } + in + let q = + make_question ~q_class:Q_IN ~q_unicast:Q_Normal Q_A + (Name.of_string "www.google.com") + in + let answers = + List.map + (fun fourth -> + { + name = q.q_name; + cls = RR_IN; + flush = false; + ttl = Int32.of_int 220; + rdata = + A + (Ipaddr.V4.of_string_exn + (sprintf "74.125.237.%d" fourth)); + }) + [ 208; 211; 209; 212; 210 ] + in + { + id = 0x930b; + detail; + questions = [ q ]; + answers; + authorities = []; + additionals = []; + } + in + let buf = marshal packet in + assert_equal ~cmp:Cstruct.equal ~printer:hexdump raw buf ); + ( "parse-mdns-q-A" >:: fun test_ctxt -> + let raw = load_packet "mdns-q-A.pcap" in + let packet = parse raw in + assert_equal ~msg:"id" 0 packet.id; + assert_equal ~msg:"qr" Query packet.detail.qr; + assert_equal ~msg:"opcode" Standard packet.detail.opcode; + assert_equal ~msg:"aa" false packet.detail.aa; + assert_equal ~msg:"tc" false packet.detail.tc; + assert_equal ~msg:"rd" false packet.detail.rd; + assert_equal ~msg:"ra" false packet.detail.ra; + assert_equal ~msg:"rcode" NoError packet.detail.rcode; + assert_equal ~msg:"#qu" 1 (List.length packet.questions); + assert_equal ~msg:"#an" 0 (List.length packet.answers); + assert_equal ~msg:"#au" 0 (List.length packet.authorities); + assert_equal ~msg:"#ad" 0 (List.length packet.additionals); - "marshal-mdns-q-A" >:: (fun test_ctxt -> - let raw = load_packet "mdns-q-A.pcap" in - let packet = - let detail = { - qr=Query; opcode=Standard; aa=false; - tc=false; rd=false; ra=false; rcode=NoError - } in - let q = { - q_name=(Name.of_string "cubieboard2.local"); - q_type=Q_A; q_class=Q_IN; q_unicast=Q_Normal; - } in - { - id=0; detail; questions=[q]; - answers=[]; authorities=[]; additionals=[]; - } in - let buf = marshal packet in - assert_equal ~cmp:Cstruct.equal ~printer:hexdump raw buf - ); + let q = List.hd packet.questions in + assert_equal ~msg:"q_name" "cubieboard2.local" + (Name.to_string q.q_name); + assert_equal ~msg:"q_type" Q_A q.q_type; + assert_equal ~msg:"q_class" Q_IN q.q_class; + assert_equal ~msg:"q_unicast" Q_Normal q.q_unicast ); + ( "marshal-mdns-q-A" >:: fun test_ctxt -> + let raw = load_packet "mdns-q-A.pcap" in + let packet = + let detail = + { + qr = Query; + opcode = Standard; + aa = false; + tc = false; + rd = false; + ra = false; + rcode = NoError; + } + in + let q = + { + q_name = Name.of_string "cubieboard2.local"; + q_type = Q_A; + q_class = Q_IN; + q_unicast = Q_Normal; + } + in + { + id = 0; + detail; + questions = [ q ]; + answers = []; + authorities = []; + additionals = []; + } + in + let buf = marshal packet in + assert_equal ~cmp:Cstruct.equal ~printer:hexdump raw buf ); + ( "parse-mdns-r-A" >:: fun test_ctxt -> + let raw = load_packet "mdns-r-A.pcap" in + let packet = parse raw in + assert_equal ~msg:"id" 0 packet.id; + assert_equal ~msg:"qr" Response packet.detail.qr; + assert_equal ~msg:"opcode" Standard packet.detail.opcode; + assert_equal ~msg:"aa" true packet.detail.aa; + assert_equal ~msg:"tc" false packet.detail.tc; + assert_equal ~msg:"rd" false packet.detail.rd; + assert_equal ~msg:"ra" false packet.detail.ra; + assert_equal ~msg:"rcode" NoError packet.detail.rcode; + assert_equal ~msg:"#qu" 0 (List.length packet.questions); + assert_equal ~msg:"#an" 1 (List.length packet.answers); + assert_equal ~msg:"#au" 0 (List.length packet.authorities); + assert_equal ~msg:"#ad" 0 (List.length packet.additionals); - "parse-mdns-r-A" >:: (fun test_ctxt -> - let raw = load_packet "mdns-r-A.pcap" in - let packet = parse raw in - assert_equal ~msg:"id" 0 packet.id; - assert_equal ~msg:"qr" Response packet.detail.qr; - assert_equal ~msg:"opcode" Standard packet.detail.opcode; - assert_equal ~msg:"aa" true packet.detail.aa; - assert_equal ~msg:"tc" false packet.detail.tc; - assert_equal ~msg:"rd" false packet.detail.rd; - assert_equal ~msg:"ra" false packet.detail.ra; - assert_equal ~msg:"rcode" NoError packet.detail.rcode; - assert_equal ~msg:"#qu" 0 (List.length packet.questions); - assert_equal ~msg:"#an" 1 (List.length packet.answers); - assert_equal ~msg:"#au" 0 (List.length packet.authorities); - assert_equal ~msg:"#ad" 0 (List.length packet.additionals); + let a = List.hd packet.answers in + assert_equal ~msg:"name" "cubieboard2.local" (Name.to_string a.name); + assert_equal ~msg:"cls" RR_IN a.cls; + assert_equal ~msg:"flush" true a.flush; + assert_equal ~msg:"ttl" (Int32.of_int 120) a.ttl; + match a.rdata with + | A addr -> + assert_equal ~msg:"A" "192.168.2.106" (Ipaddr.V4.to_string addr) + | _ -> assert_failure "RR type" ); + ( "marshal-mdns-r-A" >:: fun test_ctxt -> + let raw = load_packet "mdns-r-A.pcap" in + let packet = + let detail = + { + qr = Response; + opcode = Standard; + aa = true; + tc = false; + rd = false; + ra = false; + rcode = NoError; + } + in + let a = + { + name = Name.of_string "cubieboard2.local"; + cls = RR_IN; + flush = true; + ttl = Int32.of_int 120; + rdata = A (Ipaddr.V4.of_string_exn "192.168.2.106"); + } + in + { + id = 0; + detail; + questions = []; + answers = [ a ]; + authorities = []; + additionals = []; + } + in + let buf = marshal packet in + assert_equal ~cmp:Cstruct.equal ~printer:hexdump raw buf ); + ( "q_unicast" >:: fun test_ctxt -> + (* Verify that q_unicast=Q_mDNS_Unicast can be marshalled and then parsed *) + let packet = + let detail = + { + qr = Query; + opcode = Standard; + aa = false; + tc = false; + rd = false; + ra = false; + rcode = NoError; + } + in + let q = + { + q_name = Name.of_string "cubieboard2.local"; + q_type = Q_A; + q_class = Q_IN; + q_unicast = Q_mDNS_Unicast; + } + in + { + id = 0; + detail; + questions = [ q ]; + answers = []; + authorities = []; + additionals = []; + } + in + let buf = marshal packet in + let parsed = parse buf in + let q = List.hd parsed.questions in + assert_equal Q_mDNS_Unicast q.q_unicast ); + ( "parse-mdns-r-SD" >:: fun test_ctxt -> + let raw = load_packet "mdns-r-SD.pcap" in + let packet = parse raw in + assert_equal ~msg:"#an" ~printer:string_of_int 4 + (List.length packet.answers); + let srv_name = "_udisks-ssh._tcp.local" in + let srv_inst = "luke-xps." ^ srv_name in - let a = List.hd packet.answers in - assert_equal ~msg:"name" "cubieboard2.local" (Name.to_string a.name); - assert_equal ~msg:"cls" RR_IN a.cls; - assert_equal ~msg:"flush" true a.flush; - assert_equal ~msg:"ttl" (Int32.of_int 120) a.ttl; - match a.rdata with - | A addr -> assert_equal ~msg:"A" "192.168.2.106" (Ipaddr.V4.to_string addr) - | _ -> assert_failure "RR type"; - ); - - "marshal-mdns-r-A" >:: (fun test_ctxt -> - let raw = load_packet "mdns-r-A.pcap" in - let packet = - let detail = { - qr=Response; opcode=Standard; aa=true; - tc=false; rd=false; ra=false; rcode=NoError - } in - let a = { - name=(Name.of_string "cubieboard2.local"); cls=RR_IN; flush=true; ttl=Int32.of_int 120; - rdata=A (Ipaddr.V4.of_string_exn "192.168.2.106"); - } in - { - id=0; detail; questions=[]; - answers=[a]; authorities=[]; additionals=[]; - } in - let buf = marshal packet in - assert_equal ~cmp:Cstruct.equal ~printer:hexdump raw buf - ); - - "q_unicast" >:: (fun test_ctxt -> - (* Verify that q_unicast=Q_mDNS_Unicast can be marshalled and then parsed *) - let packet = - let detail = { - qr=Query; opcode=Standard; aa=false; - tc=false; rd=false; ra=false; rcode=NoError - } in - let q = { - q_name=(Name.of_string "cubieboard2.local"); - q_type=Q_A; q_class=Q_IN; q_unicast=Q_mDNS_Unicast; - } in - { - id=0; detail; questions=[q]; - answers=[]; authorities=[]; additionals=[]; - } in - let buf = marshal packet in - let parsed = parse buf in - let q = List.hd parsed.questions in - assert_equal Q_mDNS_Unicast q.q_unicast - ); - - "parse-mdns-r-SD" >:: (fun test_ctxt -> - let raw = load_packet "mdns-r-SD.pcap" in - let packet = parse raw in - assert_equal ~msg:"#an" ~printer:string_of_int 4 (List.length packet.answers); - let srv_name = "_udisks-ssh._tcp.local" in - let srv_inst = "luke-xps." ^ srv_name in - - let a = List.nth packet.answers 0 in - begin - assert_equal ~msg:"TXT name" ~printer:(fun s -> s) srv_inst - (Name.to_string a.name); - assert_equal ~msg:"TXT cls" RR_IN a.cls; - assert_equal ~msg:"TXT flush" true a.flush; - assert_equal ~msg:"TXT ttl" (Int32.of_int 4500) a.ttl; - match a.rdata with - | TXT l -> - assert_equal ~msg:"TXT#" 1 (List.length l); - assert_equal ~msg:"TXT" "" (List.hd l) - | _ -> assert_failure "not TXT"; - end; - - let a = List.nth packet.answers 1 in - begin - assert_equal ~msg:"PTR name" ~printer:(fun s -> s) srv_name (Name.to_string a.name); - assert_equal ~msg:"PTR cls" RR_IN a.cls; - assert_equal ~msg:"PTR flush" false a.flush; - assert_equal ~msg:"PTR ttl" (Int32.of_int 4500) a.ttl; - match a.rdata with - | PTR ptr -> assert_equal ~msg:"PTR" ~printer:(fun s -> s) srv_inst (Name.to_string ptr) - | _ -> assert_failure "not PTR"; - end; + let a = List.nth packet.answers 0 in + (assert_equal ~msg:"TXT name" + ~printer:(fun s -> s) + srv_inst (Name.to_string a.name); + assert_equal ~msg:"TXT cls" RR_IN a.cls; + assert_equal ~msg:"TXT flush" true a.flush; + assert_equal ~msg:"TXT ttl" (Int32.of_int 4500) a.ttl; + match a.rdata with + | TXT l -> + assert_equal ~msg:"TXT#" 1 (List.length l); + assert_equal ~msg:"TXT" "" (List.hd l) + | _ -> assert_failure "not TXT"); - let a = List.nth packet.answers 2 in - begin - assert_equal ~msg:"SRV name" ~printer:(fun s -> s) srv_inst (Name.to_string a.name); - assert_equal ~msg:"SRV cls" RR_IN a.cls; - assert_equal ~msg:"SRV flush" true a.flush; - assert_equal ~msg:"SRV ttl" (Int32.of_int 120) a.ttl; - match a.rdata with - | SRV (priority, weight, port, srv) -> - assert_equal 0 priority; - assert_equal 0 weight; - assert_equal 22 port; - assert_equal ~msg:"SRV" ~printer:(fun s -> s) "luke-xps.local" (Name.to_string srv) - | _ -> assert_failure "not SRV"; - end; + let a = List.nth packet.answers 1 in + (assert_equal ~msg:"PTR name" + ~printer:(fun s -> s) + srv_name (Name.to_string a.name); + assert_equal ~msg:"PTR cls" RR_IN a.cls; + assert_equal ~msg:"PTR flush" false a.flush; + assert_equal ~msg:"PTR ttl" (Int32.of_int 4500) a.ttl; + match a.rdata with + | PTR ptr -> + assert_equal ~msg:"PTR" + ~printer:(fun s -> s) + srv_inst (Name.to_string ptr) + | _ -> assert_failure "not PTR"); - let a = List.nth packet.answers 3 in - begin - assert_equal ~msg:"PTR2 name" ~printer:(fun s -> s) "_services._dns-sd._udp.local" (Name.to_string a.name); - assert_equal ~msg:"PTR2 cls" RR_IN a.cls; - assert_equal ~msg:"PTR2 flush" false a.flush; - assert_equal ~msg:"PTR2 ttl" (Int32.of_int 4500) a.ttl; - match a.rdata with - | PTR ptr -> assert_equal ~msg:"PTR2" ~printer:(fun s -> s) srv_name (Name.to_string ptr) - | _ -> assert_failure "not PTR2"; - end; - ); + let a = List.nth packet.answers 2 in + (assert_equal ~msg:"SRV name" + ~printer:(fun s -> s) + srv_inst (Name.to_string a.name); + assert_equal ~msg:"SRV cls" RR_IN a.cls; + assert_equal ~msg:"SRV flush" true a.flush; + assert_equal ~msg:"SRV ttl" (Int32.of_int 120) a.ttl; + match a.rdata with + | SRV (priority, weight, port, srv) -> + assert_equal 0 priority; + assert_equal 0 weight; + assert_equal 22 port; + assert_equal ~msg:"SRV" + ~printer:(fun s -> s) + "luke-xps.local" (Name.to_string srv) + | _ -> assert_failure "not SRV"); - "parse-mdns-r-SD2" >:: (fun test_ctxt -> - (* Compared to parse-mdns-r-SD above, this one is a better test of decompression *) - (* TODO: this packet was generated by ocaml-dns so it may not be 100% realistic *) - let raw = load_packet "mdns-r-SD2.pcap" in - let packet = parse raw in - let expected_str = - "0000 Response:0 a:c:nr:rn 0 <qs:> \ - <an:\ - _snake._tcp.local <IN|120> [PTR (king brown._snake._tcp.local)],\ - _snake._tcp.local <IN|120> [PTR (tiger._snake._tcp.local)],\ - _snake._tcp.local <IN|120> [PTR (dugite._snake._tcp.local)]> <au:> <ad:\ - dugite._snake._tcp.local <IN|120> [SRV (0,0,33333, fake2.local)],\ - dugite._snake._tcp.local <IN|120> [TXT (txtvers=1species=Pseudonaja affinis)],\ - tiger._snake._tcp.local <IN|120> [SRV (0,0,33333, fake1.local)],\ - tiger._snake._tcp.local <IN|120> [TXT (txtvers=1species=Notechis scutatus)],\ - king brown._snake._tcp.local <IN|120> [SRV (0,0,33333, fake3.local)],\ - king brown._snake._tcp.local <IN|120> [TXT (txtvers=1species=Pseudechis australis)]\ - >" in - assert_equal ~msg:"Packet.to_string" ~printer:(fun s -> s) expected_str (to_string packet) - ); - ] + let a = List.nth packet.answers 3 in + assert_equal ~msg:"PTR2 name" + ~printer:(fun s -> s) + "_services._dns-sd._udp.local" (Name.to_string a.name); + assert_equal ~msg:"PTR2 cls" RR_IN a.cls; + assert_equal ~msg:"PTR2 flush" false a.flush; + assert_equal ~msg:"PTR2 ttl" (Int32.of_int 4500) a.ttl; + match a.rdata with + | PTR ptr -> + assert_equal ~msg:"PTR2" + ~printer:(fun s -> s) + srv_name (Name.to_string ptr) + | _ -> assert_failure "not PTR2" ); + ( "parse-mdns-r-SD2" >:: fun test_ctxt -> + (* Compared to parse-mdns-r-SD above, this one is a better test of decompression *) + (* TODO: this packet was generated by ocaml-dns so it may not be 100% realistic *) + let raw = load_packet "mdns-r-SD2.pcap" in + let packet = parse raw in + let expected_str = + "0000 Response:0 a:c:nr:rn 0 <qs:> <an:_snake._tcp.local <IN|120> \ + [PTR (king brown._snake._tcp.local)],_snake._tcp.local <IN|120> \ + [PTR (tiger._snake._tcp.local)],_snake._tcp.local <IN|120> [PTR \ + (dugite._snake._tcp.local)]> <au:> <ad:dugite._snake._tcp.local \ + <IN|120> [SRV (0,0,33333, fake2.local)],dugite._snake._tcp.local \ + <IN|120> [TXT (txtvers=1species=Pseudonaja \ + affinis)],tiger._snake._tcp.local <IN|120> [SRV (0,0,33333, \ + fake1.local)],tiger._snake._tcp.local <IN|120> [TXT \ + (txtvers=1species=Notechis scutatus)],king \ + brown._snake._tcp.local <IN|120> [SRV (0,0,33333, \ + fake3.local)],king brown._snake._tcp.local <IN|120> [TXT \ + (txtvers=1species=Pseudechis australis)]>" + in + assert_equal ~msg:"Packet.to_string" + ~printer:(fun s -> s) + expected_str (to_string packet) ); + ] File "src/hostnet/hostnet_udp.mli", line 1, characters 0-0: diff --git a/_build/default/src/hostnet/hostnet_udp.mli b/_build/default/src/hostnet/.formatted/hostnet_udp.mli index c1897fd..b904fd1 100644 --- a/_build/default/src/hostnet/hostnet_udp.mli +++ b/_build/default/src/hostnet/.formatted/hostnet_udp.mli @@ -6,36 +6,40 @@ type address = Ipaddr.t * int type datagram = { - src: address; (** origin of the packet from the guest *) - dst: address; (** expected destination of the packet from the guest *) - intercept: address; (** address we will really send the packet to, pretending to be `dst` *) - payload: Cstruct.t; + src : address; (** origin of the packet from the guest *) + dst : address; (** expected destination of the packet from the guest *) + intercept : address; + (** address we will really send the packet to, pretending to be `dst` *) + payload : Cstruct.t; } (** A UDP datagram *) type reply = Cstruct.t -> unit Lwt.t module Make - (Sockets: Sig.SOCKETS) - (Clock: Mirage_clock.MCLOCK) - (Time: Mirage_time.S): -sig - + (Sockets : Sig.SOCKETS) + (Clock : Mirage_clock.MCLOCK) + (Time : Mirage_time.S) : sig type t (** A UDP NAT implementation *) - val create: ?max_idle_time:int64 -> ?preserve_remote_port:bool -> ?max_active_flows:int -> unit -> t + val create : + ?max_idle_time:int64 -> + ?preserve_remote_port:bool -> + ?max_active_flows:int -> + unit -> + t (** Create a UDP NAT implementation which will keep "NAT rules" alive until they become idle for the given [?max_idle_time] or until the number of flows hits [?max_active_flows] at which point the oldest will be expired. If [~preserve_remote_port] is set then reply traffic will come from the remote source port, otherwise it will come from the NAT port. *) - val set_send_reply: t:t -> send_reply:(datagram -> unit Lwt.t) -> unit + val set_send_reply : t:t -> send_reply:(datagram -> unit Lwt.t) -> unit (** Register a reply callback which will be used to send datagrams to the NAT client. *) - val input: t:t -> datagram:datagram -> ttl:int -> unit -> unit Lwt.t + val input : t:t -> datagram:datagram -> ttl:int -> unit -> unit Lwt.t (** Process an incoming datagram, forwarding it over the Sockets implementation and set up a listening rule to catch replies. *) @@ -43,17 +47,17 @@ sig type address = Ipaddr.t * int type flow = { - inside: address; - outside: address; - last_use_time_ns: int64; + inside : address; + outside : address; + last_use_time_ns : int64; } - val get_table: t -> flow list + val get_table : t -> flow list (** Return an instantaneous snapshot of the NAT table *) - val get_max_active_flows: t -> int + val get_max_active_flows : t -> int end end -val external_to_internal: (int, address) Hashtbl.t -(** A mapping of external (host) port to internal address *) \ No newline at end of file +val external_to_internal : (int, address) Hashtbl.t +(** A mapping of external (host) port to internal address *) File "src/hostnet/luv_lwt.mli", line 1, characters 0-0: diff --git a/_build/default/src/hostnet/luv_lwt.mli b/_build/default/src/hostnet/.formatted/luv_lwt.mli index 9140e9f..1b89d52 100644 --- a/_build/default/src/hostnet/luv_lwt.mli +++ b/_build/default/src/hostnet/.formatted/luv_lwt.mli @@ -4,8 +4,6 @@ the other. A typical example would be: - - *) val in_luv : (('a -> unit) -> unit) -> 'a Lwt.t File "src/hostnet/mux.mli", line 1, characters 0-0: diff --git a/_build/default/src/hostnet/mux.mli b/_build/default/src/hostnet/.formatted/mux.mli index dab3e73..979fd9f 100644 --- a/_build/default/src/hostnet/mux.mli +++ b/_build/default/src/hostnet/.formatted/mux.mli @@ -1,4 +1,4 @@ -module Make(Netif: Mirage_net.S) : sig +module Make (Netif : Mirage_net.S) : sig include Mirage_net.S (** A simple ethernet multiplexer/demultiplexer @@ -14,7 +14,7 @@ module Make(Netif: Mirage_net.S) : sig *) - val connect: Netif.t -> (t, error) result Lwt.t + val connect : Netif.t -> (t, error) result Lwt.t (** Connect a multiplexer/demultiplexer and return a [t] which behaves like a V1.NETWORK representing the multiplexed end. *) @@ -24,13 +24,13 @@ module Make(Netif: Mirage_net.S) : sig module Port : Mirage_net.S (** A network which receives all the traffic matching a specific rule *) - val port: t -> rule -> Port.t + val port : t -> rule -> Port.t (** Given a rule, create a network which will receive traffic matching the rule. *) - val remove: t -> rule -> unit + val remove : t -> rule -> unit (** Given a rule, remove the associated port if one exists *) - val filesystem: t -> Vfs.File.t + val filesystem : t -> Vfs.File.t (** A virtual filesystem for debugging *) end File "src/hostnet/gateway_forwards.ml", line 1, characters 0-0: diff --git a/_build/default/src/hostnet/gateway_forwards.ml b/_build/default/src/hostnet/.formatted/gateway_forwards.ml index e3e52ec..a43cd9b 100644 --- a/_build/default/src/hostnet/gateway_forwards.ml +++ b/_build/default/src/hostnet/.formatted/gateway_forwards.ml @@ -1,83 +1,92 @@ let src = - let src = Logs.Src.create "gateway_forwards" ~doc:"Manages IP forwarding from the gateway IP" in - Logs.Src.set_level src (Some Logs.Info); - src + let src = + Logs.Src.create "gateway_forwards" + ~doc:"Manages IP forwarding from the gateway IP" + in + Logs.Src.set_level src (Some Logs.Info); + src module Log = (val Logs.src_log src : Logs.LOG) -type protocol = - | Tcp - | Udp +type protocol = Tcp | Udp type forward = { - protocol: protocol; - external_port: int; - internal_ip: Ipaddr.V4.t; - internal_port: int; + protocol : protocol; + external_port : int; + internal_ip : Ipaddr.V4.t; + internal_port : int; } let forward_to_json t = - let open Ezjsonm in - dict [ - "protocol", string (match t.protocol with Tcp -> "tcp" | Udp -> "udp"); - "external_port", int t.external_port; - "internal_ip", string (Ipaddr.V4.to_string t.internal_ip); - "internal_port", int t.internal_port; + let open Ezjsonm in + dict + [ + ("protocol", string (match t.protocol with Tcp -> "tcp" | Udp -> "udp")); + ("external_port", int t.external_port); + ("internal_ip", string (Ipaddr.V4.to_string t.internal_ip)); + ("internal_port", int t.internal_port); ] let forward_of_json j = - let open Ezjsonm in - let protocol = match get_string @@ find j [ "protocol" ] with - | "tcp" -> Tcp - | "udp" -> Udp - | _ -> raise (Parse_error(j, "protocol should be tcp or udp")) in - let external_port = get_int @@ find j [ "external_port" ] in - let internal_port = get_int @@ find j [ "internal_port" ] in - let internal_ip = match Ipaddr.V4.of_string @@ get_string @@ find j [ "internal_ip" ] with - | Error (`Msg m) -> raise (Parse_error(j, "internal_ip should be an IPv4 address: " ^ m)) - | Ok x -> x in - { - protocol; external_port; internal_ip; internal_port; - } + let open Ezjsonm in + let protocol = + match get_string @@ find j [ "protocol" ] with + | "tcp" -> Tcp + | "udp" -> Udp + | _ -> raise (Parse_error (j, "protocol should be tcp or udp")) + in + let external_port = get_int @@ find j [ "external_port" ] in + let internal_port = get_int @@ find j [ "internal_port" ] in + let internal_ip = + match Ipaddr.V4.of_string @@ get_string @@ find j [ "internal_ip" ] with + | Error (`Msg m) -> + raise (Parse_error (j, "internal_ip should be an IPv4 address: " ^ m)) + | Ok x -> x + in + { protocol; external_port; internal_ip; internal_port } type t = forward list let to_json = Ezjsonm.list forward_to_json let of_json = Ezjsonm.get_list forward_of_json - let to_string x = Ezjsonm.to_string @@ to_json x + let of_string x = - try - Ok (of_json @@ Ezjsonm.from_string x) - with Ezjsonm.Parse_error(_v, msg) -> - Error (`Msg msg) + try Ok (of_json @@ Ezjsonm.from_string x) + with Ezjsonm.Parse_error (_v, msg) -> Error (`Msg msg) let dynamic = ref [] - let static = ref [] - let all = ref [] let set_static xs = - static := xs; - all := !static @ !dynamic; - Log.info (fun f -> f "New Gateway forward configuration: %s" (to_string !all)) + static := xs; + all := !static @ !dynamic; + Log.info (fun f -> f "New Gateway forward configuration: %s" (to_string !all)) let update xs = - dynamic := xs; - all := !static @ !dynamic; - Log.info (fun f -> f "New Gateway forward configuration: %s" (to_string !all)) + dynamic := xs; + all := !static @ !dynamic; + Log.info (fun f -> f "New Gateway forward configuration: %s" (to_string !all)) module Udp = struct - let mem port = List.exists (fun f -> f.protocol = Udp && f.external_port = port) !all + let mem port = + List.exists (fun f -> f.protocol = Udp && f.external_port = port) !all + let find port = - let f = List.find (fun f -> f.protocol = Udp && f.external_port = port) !all in - f.internal_ip, f.internal_port + let f = + List.find (fun f -> f.protocol = Udp && f.external_port = port) !all + in + (f.internal_ip, f.internal_port) end module Tcp = struct - let mem port = List.exists (fun f -> f.protocol = Tcp && f.external_port = port) !all + let mem port = + List.exists (fun f -> f.protocol = Tcp && f.external_port = port) !all + let find port = - let f = List.find (fun f -> f.protocol = Tcp && f.external_port = port) !all in - f.internal_ip, f.internal_port -end \ No newline at end of file + let f = + List.find (fun f -> f.protocol = Tcp && f.external_port = port) !all + in + (f.internal_ip, f.internal_port) +end File "src/hostnet/static_arp.mli", line 1, characters 0-0: diff --git a/_build/default/src/hostnet/static_arp.mli b/_build/default/src/hostnet/.formatted/static_arp.mli index 7b84730..7062874 100644 --- a/_build/default/src/hostnet/static_arp.mli +++ b/_build/default/src/hostnet/.formatted/static_arp.mli @@ -2,12 +2,11 @@ rely on the dynamic version which can fail with `No_route_to_host` if the other side doesn't respond *) -module Make(Ethif: Ethernet.S): sig +module Make (Ethif : Ethernet.S) : sig include Arp.S type ethif = Ethif.t - val connect: - table:(Ipaddr.V4.t * Macaddr.t) list -> ethif -> t - (** Construct a static ARP table *) + val connect : table:(Ipaddr.V4.t * Macaddr.t) list -> ethif -> t + (** Construct a static ARP table *) end File "src/hostnet/utils.mli", line 1, characters 0-0: diff --git a/_build/default/src/hostnet/utils.mli b/_build/default/src/hostnet/.formatted/utils.mli index a22d24f..ddb415e 100644 --- a/_build/default/src/hostnet/utils.mli +++ b/_build/default/src/hostnet/.formatted/utils.mli @@ -1,9 +1,8 @@ +val somaxconn : int ref (* can be overriden by the command-line *) -val somaxconn: int ref (* can be overriden by the command-line *) - -val rtlGenRandom: int -> bytes option +val rtlGenRandom : int -> bytes option (** [rtlGenRandom len] returns [len] bytes of secure random data on Windows. Returns None if called on non-Windows platforms *) -val setSocketTTL: Unix.file_descr -> int -> unit +val setSocketTTL : Unix.file_descr -> int -> unit (** [setSocketTTL s ttl] sets the TTL on the socket [s] to [ttl] *) File "src/hostnet/hosts.ml", line 1, characters 0-0: diff --git a/_build/default/src/hostnet/hosts.ml b/_build/default/src/hostnet/.formatted/hosts.ml index 73d2e55..872c972 100644 --- a/_build/default/src/hostnet/hosts.ml +++ b/_build/default/src/hostnet/.formatted/hosts.ml @@ -10,8 +10,7 @@ let src = module Log = (val Logs.src_log src : Logs.LOG) let default_etc_hosts_path = - if Sys.os_type = "Win32" - then "C:\\Windows\\System32\\drivers\\etc\\hosts" + if Sys.os_type = "Win32" then "C:\\Windows\\System32\\drivers\\etc\\hosts" else "/etc/hosts" let etc_hosts = ref [] @@ -20,48 +19,47 @@ let of_string txt = let open Astring in try let lines = String.cuts ~sep:"\n" txt in - List.fold_left (fun acc line -> + List.fold_left + (fun acc line -> let line = String.trim line in - if line = "" then acc else begin - let line = match String.cut ~sep:"#" line with - | None -> line - | Some (important, _) -> important + if line = "" then acc + else + let line = + match String.cut ~sep:"#" line with + | None -> line + | Some (important, _) -> important in let whitespace = function - | ' ' | '\n' | '\011' | '\012' | '\r' | '\t' -> true - | _ -> false + | ' ' | '\n' | '\011' | '\012' | '\r' | '\t' -> true + | _ -> false in match String.fields ~empty:false ~is_sep:whitespace line with - | addr :: names -> - begin match Ipaddr.of_string addr with - | Ok addr -> List.map (fun name -> (name, addr)) names @ acc - | Error (`Msg m) -> - Log.err (fun f -> - f "Failed to parse address '%s' from hosts file: %s" addr m); - acc - end - | _ -> acc - end - ) [] lines + | addr :: names -> ( + match Ipaddr.of_string addr with + | Ok addr -> List.map (fun name -> (name, addr)) names @ acc + | Error (`Msg m) -> + Log.err (fun f -> + f "Failed to parse address '%s' from hosts file: %s" addr + m); + acc) + | _ -> acc) + [] lines |> List.rev with _ -> [] -module Make(Files: Sig.FILES) = struct - +module Make (Files : Sig.FILES) = struct let m = Lwt_mutex.create () let parse filename = Lwt_mutex.with_lock m (fun () -> Files.read_file filename >|= function | Error (`Msg msg) -> - Log.err (fun f -> f "Failed to read %s: %s" filename msg) + Log.err (fun f -> f "Failed to read %s: %s" filename msg) | Ok txt -> - etc_hosts := of_string txt; - Log.info (fun f -> - f "%s file has bindings for %s" - filename - (String.concat " " @@ List.map fst !etc_hosts)) - ) + etc_hosts := of_string txt; + Log.info (fun f -> + f "%s file has bindings for %s" filename + (String.concat " " @@ List.map fst !etc_hosts))) type watch = Files.watch @@ -69,5 +67,4 @@ module Make(Files: Sig.FILES) = struct Files.watch_file path (fun () -> Lwt.async (fun () -> parse path)) let unwatch = Files.unwatch - end File "src/hostnet/slirp.mli", line 1, characters 0-0: diff --git a/_build/default/src/hostnet/slirp.mli b/_build/default/src/hostnet/.formatted/slirp.mli index 14da622..3db90bb 100644 --- a/_build/default/src/hostnet/slirp.mli +++ b/_build/default/src/hostnet/.formatted/slirp.mli @@ -5,70 +5,76 @@ type pcap = (string * int64 option) option bigger than the given limit. *) module Make - (Vmnet: Sig.VMNET) - (Dns_policy: Sig.DNS_POLICY) - (Clock: Mirage_clock.MCLOCK) - (Random: Mirage_random.S) - (Vnet : Vnetif.BACKEND with type macaddr = Macaddr.t) : -sig - + (Vmnet : Sig.VMNET) + (Dns_policy : Sig.DNS_POLICY) + (Clock : Mirage_clock.MCLOCK) + (Random : Mirage_random.S) + (Vnet : Vnetif.BACKEND with type macaddr = Macaddr.t) : sig type stack (** A TCP/IP stack which may talk to multiple ethernet clients *) - val create_static: Vnet.t -> Configuration.t -> stack Lwt.t + val create_static : Vnet.t -> Configuration.t -> stack Lwt.t (** Initialise a TCP/IP stack, with a static configuration *) type connection (** An ethernet connection to a stack *) - val connect: stack -> Vmnet.fd -> connection Lwt.t + val connect : stack -> Vmnet.fd -> connection Lwt.t (** Read and write ethernet frames on the given fd, connected to the specified Vnetif backend *) - val after_disconnect: connection -> unit Lwt.t + val after_disconnect : connection -> unit Lwt.t (** Waits until the stack has been disconnected *) - val filesystem: connection -> Vfs.Dir.t + val filesystem : connection -> Vfs.Dir.t (** A virtual filesystem which exposes internal state for debugging *) - val diagnostics: connection -> Host.Sockets.Stream.Unix.flow -> unit Lwt.t + val diagnostics : connection -> Host.Sockets.Stream.Unix.flow -> unit Lwt.t (** Output diagnostics in .tar format over a local Unix socket or named pipe *) - val pcap: connection -> Host.Sockets.Stream.Unix.flow -> unit Lwt.t + val pcap : connection -> Host.Sockets.Stream.Unix.flow -> unit Lwt.t (** Output all traffic in pcap format over a local Unix socket or named pipe *) - val http_intercept_api_handler: Host.Sockets.Stream.Unix.flow -> unit Lwt.t + val http_intercept_api_handler : Host.Sockets.Stream.Unix.flow -> unit Lwt.t (** Handle HTTP proxy reconfigurations via an HTTP API *) - module Debug: sig + module Debug : sig module Nat : sig type address = Ipaddr.t * int type flow = { - inside: address; - outside: address; - last_use_time_ns: int64; + inside : address; + outside : address; + last_use_time_ns : int64; } - val get_table: connection -> flow list + val get_table : connection -> flow list (** Return an instantaneous snapshot of the NAT table *) - val get_max_active_flows: connection -> int + val get_max_active_flows : connection -> int end - val update_dns: ?local_ip:Ipaddr.t -> ?builtin_names:(Dns.Name.t * Ipaddr.t) list -> - unit -> unit + val update_dns : + ?local_ip:Ipaddr.t -> + ?builtin_names:(Dns.Name.t * Ipaddr.t) list -> + unit -> + unit (** Update the DNS forwarder following a configuration change *) - val update_http: ?http:string -> ?https:string -> ?exclude:string - -> ?transparent_http_ports:int list -> ?transparent_https_ports:int list - -> unit -> (unit, [`Msg of string]) result Lwt.t + val update_http : + ?http:string -> + ?https:string -> + ?exclude:string -> + ?transparent_http_ports:int list -> + ?transparent_https_ports:int list -> + unit -> + (unit, [ `Msg of string ]) result Lwt.t (** Update the HTTP forwarder following a configuration change *) - val update_http_json: Ezjsonm.value -> - unit -> (unit, [`Msg of string]) result Lwt.t + val update_http_json : + Ezjsonm.value -> unit -> (unit, [ `Msg of string ]) result Lwt.t (** Update the HTTP forwarder using the json interface *) end end -val print_pcap: pcap -> string +val print_pcap : pcap -> string File "src/hostnet/utils.ml", line 1, characters 0-0: diff --git a/_build/default/src/hostnet/utils.ml b/_build/default/src/hostnet/.formatted/utils.ml index dd0ee91..acf1948 100644 --- a/_build/default/src/hostnet/utils.ml +++ b/_build/default/src/hostnet/.formatted/utils.ml @@ -1,7 +1,6 @@ -external get_SOMAXCONN: unit -> int = "stub_get_SOMAXCONN" +external get_SOMAXCONN : unit -> int = "stub_get_SOMAXCONN" let somaxconn = ref (get_SOMAXCONN ()) -external rtlGenRandom: int -> bytes option = "stub_RtlGenRandom" - -external setSocketTTL: Unix.file_descr -> int -> unit = "stub_setSocketTTL" +external rtlGenRandom : int -> bytes option = "stub_RtlGenRandom" +external setSocketTTL : Unix.file_descr -> int -> unit = "stub_setSocketTTL" File "src/hostnet/vmnet.mli", line 1, characters 0-0: diff --git a/_build/default/src/hostnet/vmnet.mli b/_build/default/src/hostnet/.formatted/vmnet.mli index 2a49ec4..ab6288d 100644 --- a/_build/default/src/hostnet/vmnet.mli +++ b/_build/default/src/hostnet/.formatted/vmnet.mli @@ -1,4 +1,4 @@ -module Make(C: Sig.CONN): sig +module Make (C : Sig.CONN) : sig (** Accept connections and talk to clients via the vmnetd protocol, exposing the packets as a Mirage NETWORK interface *) @@ -6,16 +6,21 @@ module Make(C: Sig.CONN): sig include Mirage_net.S - val after_disconnect: t -> unit Lwt.t + val after_disconnect : t -> unit Lwt.t (** [after_disconnect connection] resolves after [connection] has disconnected. *) - val add_listener: t -> (Cstruct.t -> unit Lwt.t) -> unit - - val of_fd: - connect_client_fn:(Uuidm.t -> Ipaddr.V4.t option -> (Macaddr.t, [`Msg of string]) result Lwt.t) -> - server_macaddr:Macaddr.t -> mtu:int -> C.flow -> - (t, [`Msg of string]) result Lwt.t + val add_listener : t -> (Cstruct.t -> unit Lwt.t) -> unit + + val of_fd : + connect_client_fn: + (Uuidm.t -> + Ipaddr.V4.t option -> + (Macaddr.t, [ `Msg of string ]) result Lwt.t) -> + server_macaddr:Macaddr.t -> + mtu:int -> + C.flow -> + (t, [ `Msg of string ]) result Lwt.t (** [of_fd ~connect_client_fn ~server_macaddr ~mtu fd] negotiates with the client over [fd]. The server uses [connect_client_fn] to create a source address for the @@ -24,10 +29,14 @@ module Make(C: Sig.CONN): sig [server_macaddr] as the source address of all its ethernet frames and sets the MTU to [mtu]. *) - val client_of_fd: uuid:Uuidm.t -> ?preferred_ip:Ipaddr.V4.t -> - server_macaddr:Macaddr.t -> C.flow -> (t, [`Msg of string]) result Lwt.t + val client_of_fd : + uuid:Uuidm.t -> + ?preferred_ip:Ipaddr.V4.t -> + server_macaddr:Macaddr.t -> + C.flow -> + (t, [ `Msg of string ]) result Lwt.t - val start_capture: t -> ?size_limit:int64 -> string -> unit Lwt.t + val start_capture : t -> ?size_limit:int64 -> string -> unit Lwt.t (** [start_capture t ?size_limit filename] closes any existing pcap capture file and starts capturing to [filename]. If [?size_limit] is provided then the file will be automatically @@ -35,37 +44,31 @@ module Make(C: Sig.CONN): sig avoid forgetting to close the file and filling up your storage with capture data. *) - val stop_capture: t -> unit Lwt.t + val stop_capture : t -> unit Lwt.t (** [stop_capture t] stops any in-progress capture and closes the file. *) - val get_client_uuid: t -> Uuidm.t - - val get_client_macaddr: t -> Macaddr.t - + val get_client_uuid : t -> Uuidm.t + val get_client_macaddr : t -> Macaddr.t end module Init : sig type t - val to_string: t -> string - val sizeof: int - val default: t - - val marshal: t -> Cstruct.t -> Cstruct.t - val unmarshal: Cstruct.t -> t * Cstruct.t + val to_string : t -> string + val sizeof : int + val default : t + val marshal : t -> Cstruct.t -> Cstruct.t + val unmarshal : Cstruct.t -> t * Cstruct.t end module Command : sig - type t = | Ethernet of Uuidm.t (* 36 bytes *) | Preferred_ipv4 of Uuidm.t (* 36 bytes *) * Ipaddr.V4.t | Bind_ipv4 of Ipaddr.V4.t * int * bool - val to_string: t -> string - val sizeof: int - - val marshal: t -> Cstruct.t -> Cstruct.t - val unmarshal: Cstruct.t -> (t * Cstruct.t, [ `Msg of string ]) result + val to_string : t -> string + val sizeof : int + val marshal : t -> Cstruct.t -> Cstruct.t + val unmarshal : Cstruct.t -> (t * Cstruct.t, [ `Msg of string ]) result end - File "src/bin/bind.mli", line 1, characters 0-0: diff --git a/_build/default/src/bin/bind.mli b/_build/default/src/bin/.formatted/bind.mli index 1f309de..b42d312 100644 --- a/_build/default/src/bin/bind.mli +++ b/_build/default/src/bin/.formatted/bind.mli @@ -1 +1 @@ -module Make(Socket: Sig.SOCKETS): Sig.SOCKETS +module Make (Socket : Sig.SOCKETS) : Sig.SOCKETS File "src/bin/connect.mli", line 1, characters 0-0: diff --git a/_build/default/src/bin/connect.mli b/_build/default/src/bin/.formatted/connect.mli index 1300a49..e44f290 100644 --- a/_build/default/src/bin/connect.mli +++ b/_build/default/src/bin/.formatted/connect.mli @@ -1,11 +1,11 @@ -module Unix: sig +module Unix : sig include Sig.Connector - val vsock_path: string ref + val vsock_path : string ref end -module Hvsock: sig +module Hvsock : sig include Sig.Connector - val set_port_forward_addr: Hvsock.Af_hyperv.sockaddr -> unit + val set_port_forward_addr : Hvsock.Af_hyperv.sockaddr -> unit end File "src/hostnet/filter.ml", line 1, characters 0-0: diff --git a/_build/default/src/hostnet/filter.ml b/_build/default/src/hostnet/.formatted/filter.ml index f84a57a..7d6f3fa 100644 --- a/_build/default/src/hostnet/filter.ml +++ b/_build/default/src/hostnet/.formatted/filter.ml @@ -7,25 +7,24 @@ let src = module Log = (val Logs.src_log src : Logs.LOG) -module Make(Input: Sig.VMNET) = struct - +module Make (Input : Sig.VMNET) = struct type fd = Input.fd - type error = [Mirage_net.Net.error | `Unknown of string] + type error = [ Mirage_net.Net.error | `Unknown of string ] let pp_error ppf = function - | #Mirage_net.Net.error as e -> Mirage_net.Net.pp_error ppf e - | `Unknown s -> Fmt.pf ppf "unknown: %s" s + | #Mirage_net.Net.error as e -> Mirage_net.Net.pp_error ppf e + | `Unknown s -> Fmt.pf ppf "unknown: %s" s let lift_error = function - | Ok x -> Ok x - | Error (#Mirage_net.Net.error as e) -> Error e - | Error e -> Fmt.kstr (fun s -> Error (`Unknown s)) "%a" Input.pp_error e + | Ok x -> Ok x + | Error (#Mirage_net.Net.error as e) -> Error e + | Error e -> Fmt.kstr (fun s -> Error (`Unknown s)) "%a" Input.pp_error e type t = { - input: Input.t; - stats: Mirage_net.stats; - valid_subnets: Ipaddr.V4.Prefix.t list; - valid_sources: Ipaddr.V4.t list; + input : Input.t; + stats : Mirage_net.stats; + valid_subnets : Ipaddr.V4.Prefix.t list; + valid_sources : Ipaddr.V4.t list; } let connect ~valid_subnets ~valid_sources input = @@ -34,83 +33,80 @@ module Make(Input: Sig.VMNET) = struct let disconnect t = Input.disconnect t.input let after_disconnect t = Input.after_disconnect t.input - let write t ~size fill = Input.write t.input ~size fill >|= lift_error let filter valid_subnets valid_sources next buf = match Ethernet.Packet.of_cstruct buf with | Ok (_header, payload) -> - let src = Ipaddr.V4.of_int32 @@ Ipv4_wire.get_ipv4_src payload in - let from_valid_networks = - List.fold_left (fun acc network -> - acc || (Ipaddr.V4.Prefix.mem src network) - ) false valid_subnets - in - let from_valid_sources = - List.fold_left (fun acc valid -> - acc || (Ipaddr.V4.compare src valid = 0) - ) false valid_sources - in - if from_valid_sources || from_valid_networks - then next buf - else begin - let src = Ipaddr.V4.to_string src in - let dst = - Ipaddr.V4.to_string @@ - Ipaddr.V4.of_int32 @@ - Ipv4_wire.get_ipv4_dst payload + let src = Ipaddr.V4.of_int32 @@ Ipv4_wire.get_ipv4_src payload in + let from_valid_networks = + List.fold_left + (fun acc network -> acc || Ipaddr.V4.Prefix.mem src network) + false valid_subnets in - let body = Cstruct.shift payload Ipv4_wire.sizeof_ipv4 in - begin match - Ipv4_packet.Unmarshal.int_to_protocol - @@ Ipv4_wire.get_ipv4_proto payload - with - | Some `UDP -> - let src_port = Udp_wire.get_udp_source_port body in - let dst_port = Udp_wire.get_udp_dest_port body in - Log.warn (fun f -> - f "dropping unexpected UDP packet sent from %s:%d to %s:%d \ - (valid subnets = %s; valid sources = %s)" - src src_port dst dst_port - (String.concat ", " - (List.map Ipaddr.V4.Prefix.to_string valid_subnets)) - (String.concat ", " - (List.map Ipaddr.V4.to_string valid_sources)) - ) - | Some `TCP -> - let src_port = Tcp.Tcp_wire.get_tcp_src_port body in - let dst_port = Tcp.Tcp_wire.get_tcp_dst_port body in - Log.warn (fun f -> - f "dropping unexpected TCP packet sent from %s:%d to %s:%d \ - (valid subnets = %s; valid sources = %s)" - src src_port dst dst_port - (String.concat ", " - (List.map Ipaddr.V4.Prefix.to_string valid_subnets)) - (String.concat ", " - (List.map Ipaddr.V4.to_string valid_sources)) - ) - | _ -> - Log.warn (fun f -> - f "dropping unknown IP protocol %d sent from %s to %s (valid \ - subnets = %s; valid sources = %s)" - (Ipv4_wire.get_ipv4_proto payload) src dst - (String.concat ", " - (List.map Ipaddr.V4.Prefix.to_string valid_subnets)) - (String.concat ", " - (List.map Ipaddr.V4.to_string valid_sources)) - ) - end; - Lwt.return () - end + let from_valid_sources = + List.fold_left + (fun acc valid -> acc || Ipaddr.V4.compare src valid = 0) + false valid_sources + in + if from_valid_sources || from_valid_networks then next buf + else + let src = Ipaddr.V4.to_string src in + let dst = + Ipaddr.V4.to_string @@ Ipaddr.V4.of_int32 + @@ Ipv4_wire.get_ipv4_dst payload + in + let body = Cstruct.shift payload Ipv4_wire.sizeof_ipv4 in + (match + Ipv4_packet.Unmarshal.int_to_protocol + @@ Ipv4_wire.get_ipv4_proto payload + with + | Some `UDP -> + let src_port = Udp_wire.get_udp_source_port body in + let dst_port = Udp_wire.get_udp_dest_port body in + Log.warn (fun f -> + f + "dropping unexpected UDP packet sent from %s:%d to %s:%d \ + (valid subnets = %s; valid sources = %s)" + src src_port dst dst_port + (String.concat ", " + (List.map Ipaddr.V4.Prefix.to_string valid_subnets)) + (String.concat ", " + (List.map Ipaddr.V4.to_string valid_sources))) + | Some `TCP -> + let src_port = Tcp.Tcp_wire.get_tcp_src_port body in + let dst_port = Tcp.Tcp_wire.get_tcp_dst_port body in + Log.warn (fun f -> + f + "dropping unexpected TCP packet sent from %s:%d to %s:%d \ + (valid subnets = %s; valid sources = %s)" + src src_port dst dst_port + (String.concat ", " + (List.map Ipaddr.V4.Prefix.to_string valid_subnets)) + (String.concat ", " + (List.map Ipaddr.V4.to_string valid_sources))) + | _ -> + Log.warn (fun f -> + f + "dropping unknown IP protocol %d sent from %s to %s (valid \ + subnets = %s; valid sources = %s)" + (Ipv4_wire.get_ipv4_proto payload) + src dst + (String.concat ", " + (List.map Ipaddr.V4.Prefix.to_string valid_subnets)) + (String.concat ", " + (List.map Ipaddr.V4.to_string valid_sources)))); + Lwt.return () | _ -> next buf let listen t ~header_size callback = Input.listen t.input ~header_size (fun buf -> - filter t.valid_subnets t.valid_sources callback buf - ) >|= lift_error + filter t.valid_subnets t.valid_sources callback buf) + >|= lift_error let add_listener t callback = - Input.add_listener t.input @@ filter t.valid_subnets t.valid_sources callback + Input.add_listener t.input + @@ filter t.valid_subnets t.valid_sources callback let mac t = Input.mac t.input let mtu t = Input.mtu t.input @@ -120,15 +116,11 @@ module Make(Input: Sig.VMNET) = struct let of_fd ~connect_client_fn:_ ~server_macaddr:_ ~mtu:_ = failwith "Filter.of_fd unimplemented" - let get_client_uuid _ = - failwith "Filter.get_client_uuid unimplemented" - - let get_client_macaddr _ = - failwith "Filter.get_client_macaddr unimplemented" + let get_client_uuid _ = failwith "Filter.get_client_uuid unimplemented" + let get_client_macaddr _ = failwith "Filter.get_client_macaddr unimplemented" let start_capture _ ?size_limit:_ _ = failwith "Filter.start_capture unimplemented" - let stop_capture _ = - failwith "Filter.stop_capture unimplemented" + let stop_capture _ = failwith "Filter.stop_capture unimplemented" end File "src/hostnet/static_arp.ml", line 1, characters 0-0: diff --git a/_build/default/src/hostnet/static_arp.ml b/_build/default/src/hostnet/.formatted/static_arp.ml index 822e7d0..32cdec3 100644 --- a/_build/default/src/hostnet/static_arp.ml +++ b/_build/default/src/hostnet/.formatted/static_arp.ml @@ -32,32 +32,29 @@ let src = module Log = (val Logs.src_log src : Logs.LOG) -module Make (Ethif: Ethernet.S) = struct - - module Table = Map.Make(Ipaddr.V4) +module Make (Ethif : Ethernet.S) = struct + module Table = Map.Make (Ipaddr.V4) type macaddr = Macaddr.t - type t = { ethif: Ethif.t; mutable table: macaddr Table.t } + type t = { ethif : Ethif.t; mutable table : macaddr Table.t } type error = [ `Timeout ] + let pp_error ppf `Timeout = Fmt.string ppf "Timeout" let to_string t = let pp_one (ip, mac) = Fmt.str "%s -> %s" (Ipaddr.V4.to_string ip) (Macaddr.to_string mac) in - Table.bindings t.table - |> List.map pp_one - |> String.concat "; " + Table.bindings t.table |> List.map pp_one |> String.concat "; " let pp fmt t = Format.pp_print_string fmt @@ to_string t - let get_ips t = List.map fst (Table.bindings t.table) let add_ip t ip = let mac = Ethif.mac t.ethif in Log.debug (fun f -> - f "ARP: adding %s -> %s" - (Ipaddr.V4.to_string ip) (Macaddr.to_string mac)); + f "ARP: adding %s -> %s" (Ipaddr.V4.to_string ip) + (Macaddr.to_string mac)); Lwt.return_unit let set_ips t ips = Lwt_list.iter_s (add_ip t) ips @@ -68,53 +65,55 @@ module Make (Ethif: Ethernet.S) = struct Lwt.return_unit let query t ip = - if Table.mem ip t.table - then Lwt.return (Ok (Table.find ip t.table)) - else begin + if Table.mem ip t.table then Lwt.return (Ok (Table.find ip t.table)) + else ( Log.warn (fun f -> f "ARP table has no entry for %s" (Ipaddr.V4.to_string ip)); - Lwt.return (Error `Timeout) - end + Lwt.return (Error `Timeout)) let output t pkt = - Ethif.write t.ethif ~src:pkt.Arp_packet.source_mac pkt.Arp_packet.target_mac `ARP - (fun buf -> + Ethif.write t.ethif ~src:pkt.Arp_packet.source_mac pkt.Arp_packet.target_mac + `ARP (fun buf -> Arp_packet.encode_into pkt buf; - Arp_packet.size - ) - - let input t frame = match Arp_packet.decode frame with - | Error err -> - Log.err (fun f -> f "error while reading ARP packet: %a" Arp_packet.pp_error err); - Lwt.return_unit - | Ok ({ Arp_packet.operation = Arp_packet.Reply; _ } as pkt) -> - Log.debug (fun f -> f "ARP ignoring reply %a" Arp_packet.pp pkt); - Lwt.return_unit - | Ok pkt -> - if Table.mem pkt.target_ip t.table then begin - Log.debug (fun f -> - f "ARP responding to: who-has %s?" (Ipaddr.V4.to_string pkt.target_ip)); - let sha = Table.find pkt.target_ip t.table in - output t { - Arp_packet.operation = Arp_packet.Reply; - source_mac = sha; - source_ip = pkt.target_ip; - target_ip = pkt.source_ip; - target_mac = pkt.source_mac; - } >|= function - | Ok () -> () - | Error e -> - Log.err (fun f -> - f "error while reading ARP packet: %a" Ethif.pp_error e); - end else Lwt.return_unit + Arp_packet.size) + + let input t frame = + match Arp_packet.decode frame with + | Error err -> + Log.err (fun f -> + f "error while reading ARP packet: %a" Arp_packet.pp_error err); + Lwt.return_unit + | Ok ({ Arp_packet.operation = Arp_packet.Reply; _ } as pkt) -> + Log.debug (fun f -> f "ARP ignoring reply %a" Arp_packet.pp pkt); + Lwt.return_unit + | Ok pkt -> + if Table.mem pkt.target_ip t.table then ( + Log.debug (fun f -> + f "ARP responding to: who-has %s?" + (Ipaddr.V4.to_string pkt.target_ip)); + let sha = Table.find pkt.target_ip t.table in + output t + { + Arp_packet.operation = Arp_packet.Reply; + source_mac = sha; + source_ip = pkt.target_ip; + target_ip = pkt.source_ip; + target_mac = pkt.source_mac; + } + >|= function + | Ok () -> () + | Error e -> + Log.err (fun f -> + f "error while reading ARP packet: %a" Ethif.pp_error e)) + else Lwt.return_unit type ethif = Ethif.t let connect ~table ethif = let table = - List.fold_left (fun acc (ip, mac) -> - Table.add ip mac acc - ) Table.empty table + List.fold_left + (fun acc (ip, mac) -> Table.add ip mac acc) + Table.empty table in { table; ethif } File "src/hostnet/configuration.ml", line 1, characters 0-0: diff --git a/_build/default/src/hostnet/configuration.ml b/_build/default/src/hostnet/.formatted/configuration.ml index 0aa6d13..3f00449 100644 --- a/_build/default/src/hostnet/configuration.ml +++ b/_build/default/src/hostnet/.formatted/configuration.ml @@ -1,5 +1,7 @@ let src = - let src = Logs.Src.create "configuration" ~doc:"Mirage TCP/IP <-> socket proxy" in + let src = + Logs.Src.create "configuration" ~doc:"Mirage TCP/IP <-> socket proxy" + in Logs.Src.set_level src (Some Logs.Info); src @@ -8,61 +10,68 @@ module Log = (val Logs.src_log src : Logs.LOG) let default_domain = "localdomain" module Dhcp_configuration = struct - type t = { - searchDomains: string list; - domainName: string option; - } - let to_string t = Printf.sprintf "{ searchDomains = %s; domainName = %s }" - (String.concat ", " t.searchDomains) - (match t.domainName with None -> "None" | Some x -> x) + type t = { searchDomains : string list; domainName : string option } + + let to_string t = + Printf.sprintf "{ searchDomains = %s; domainName = %s }" + (String.concat ", " t.searchDomains) + (match t.domainName with None -> "None" | Some x -> x) + let of_string txt = let open Ezjsonm in - begin match from_string txt with + match from_string txt with | exception _ -> - Log.err (fun f -> f "Failed to parse DHCP configuration json: %s" txt); - None + Log.err (fun f -> f "Failed to parse DHCP configuration json: %s" txt); + None | j -> - let searchDomains = - try get_strings @@ find j [ "searchDomains" ] - with Not_found -> [] in - let domainName = - try Some (get_string @@ find j [ "domainName" ]) - with Not_found -> None in - Some { searchDomains; domainName } - end + let searchDomains = + try get_strings @@ find j [ "searchDomains" ] with Not_found -> [] + in + let domainName = + try Some (get_string @@ find j [ "domainName" ]) + with Not_found -> None + in + Some { searchDomains; domainName } end type t = { - server_macaddr: Macaddr.t; - max_connections: int option; - dns: Dns_forward.Config.t; - dns_path: string option; - resolver: [ `Host | `Upstream ]; - domain: string option; - allowed_bind_addresses: Ipaddr.V4.t list; - gateway_ip: Ipaddr.V4.t; - host_ip: Ipaddr.V4.t; + server_macaddr : Macaddr.t; + max_connections : int option; + dns : Dns_forward.Config.t; + dns_path : string option; + resolver : [ `Host | `Upstream ]; + domain : string option; + allowed_bind_addresses : Ipaddr.V4.t list; + gateway_ip : Ipaddr.V4.t; + host_ip : Ipaddr.V4.t; (* TODO: remove this from the record since it is not constant across all clients *) - lowest_ip: Ipaddr.V4.t; - highest_ip: Ipaddr.V4.t; - dhcp_json_path: string option; - dhcp_configuration: Dhcp_configuration.t option; - mtu: int; - http_intercept: Ezjsonm.value option; - http_intercept_path: string option; - port_max_idle_time: int; - host_names: Dns.Name.t list; - gateway_names: Dns.Name.t list; - vm_names: Dns.Name.t list; - udpv4_forwards: Gateway_forwards.t; - tcpv4_forwards: Gateway_forwards.t; - gateway_forwards_path: string option; - forwards_path: string option; - pcap_snaplen: int; + lowest_ip : Ipaddr.V4.t; + highest_ip : Ipaddr.V4.t; + dhcp_json_path : string option; + dhcp_configuration : Dhcp_configuration.t option; + mtu : int; + http_intercept : Ezjsonm.value option; + http_intercept_path : string option; + port_max_idle_time : int; + host_names : Dns.Name.t list; + gateway_names : Dns.Name.t list; + vm_names : Dns.Name.t list; + udpv4_forwards : Gateway_forwards.t; + tcpv4_forwards : Gateway_forwards.t; + gateway_forwards_path : string option; + forwards_path : string option; + pcap_snaplen : int; } let to_string t = - Printf.sprintf "server_macaddr = %s; max_connection = %s; dns_path = %s; dns = %s; resolver = %s; domain = %s; allowed_bind_addresses = %s; gateway_ip = %s; host_ip = %s; lowest_ip = %s; highest_ip = %s; dhcp_json_path = %s; dhcp_configuration = %s; mtu = %d; http_intercept = %s; http_intercept_path = %s; port_max_idle_time = %s; host_names = %s; gateway_names = %s; vm_names = %s; udpv4_forwards = %s; tcpv4_forwards = %s; gateway_forwards_path = %s; forwards_path = %s; pcap_snaplen = %d" + Printf.sprintf + "server_macaddr = %s; max_connection = %s; dns_path = %s; dns = %s; \ + resolver = %s; domain = %s; allowed_bind_addresses = %s; gateway_ip = %s; \ + host_ip = %s; lowest_ip = %s; highest_ip = %s; dhcp_json_path = %s; \ + dhcp_configuration = %s; mtu = %d; http_intercept = %s; \ + http_intercept_path = %s; port_max_idle_time = %s; host_names = %s; \ + gateway_names = %s; vm_names = %s; udpv4_forwards = %s; tcpv4_forwards = \ + %s; gateway_forwards_path = %s; forwards_path = %s; pcap_snaplen = %d" (Macaddr.to_string t.server_macaddr) (match t.max_connections with None -> "None" | Some x -> string_of_int x) (match t.dns_path with None -> "None" | Some x -> x) @@ -75,9 +84,13 @@ let to_string t = (Ipaddr.V4.to_string t.lowest_ip) (Ipaddr.V4.to_string t.highest_ip) (match t.dhcp_json_path with None -> "None" | Some x -> x) - (match t.dhcp_configuration with None -> "None" | Some x -> Dhcp_configuration.to_string x) + (match t.dhcp_configuration with + | None -> "None" + | Some x -> Dhcp_configuration.to_string x) t.mtu - (match t.http_intercept with None -> "None" | Some x -> Ezjsonm.(to_string @@ wrap x)) + (match t.http_intercept with + | None -> "None" + | Some x -> Ezjsonm.(to_string @@ wrap x)) (match t.http_intercept_path with None -> "None" | Some x -> x) (string_of_int t.port_max_idle_time) (String.concat ", " (List.map Dns.Name.to_string t.host_names)) @@ -90,103 +103,110 @@ let to_string t = t.pcap_snaplen let no_dns_servers = - Dns_forward.Config.({ servers = Server.Set.empty; search = []; assume_offline_after_drops = None }) + Dns_forward.Config. + { + servers = Server.Set.empty; + search = []; + assume_offline_after_drops = None; + } let default_lowest_ip = Ipaddr.V4.of_string_exn "192.168.65.3" let default_gateway_ip = Ipaddr.V4.of_string_exn "192.168.65.1" let default_host_ip = Ipaddr.V4.of_string_exn "192.168.65.2" let default_highest_ip = Ipaddr.V4.of_string_exn "192.168.65.254" + (* The default MTU is limited by the maximum message size on a Hyper-V socket. On currently available windows versions, we need to stay below 8192 bytes *) let default_mtu = 1500 (* used for the virtual ethernet link *) + let default_port_max_idle_time = 300 + (* random MAC from https://www.hellion.org.uk/cgi-bin/randmac.pl *) let default_server_macaddr = Macaddr.of_string_exn "F6:16:36:BC:F9:C6" let default_host_names = [ Dns.Name.of_string "vpnkit.host" ] let default_gateway_names = [ Dns.Name.of_string "gateway.internal" ] let default_vm_names = [ Dns.Name.of_string "vm.internal" ] let default_pcap_snaplen = 128 - let default_resolver = `Host -let default = { - server_macaddr = default_server_macaddr; - max_connections = None; - dns = no_dns_servers; - dns_path = None; - resolver = default_resolver; - domain = None; - allowed_bind_addresses = []; - gateway_ip = default_gateway_ip; - host_ip = default_host_ip; - lowest_ip = default_lowest_ip; - highest_ip = default_highest_ip; - dhcp_json_path = None; - dhcp_configuration = None; - mtu = default_mtu; - http_intercept = None; - http_intercept_path = None; - port_max_idle_time = default_port_max_idle_time; - host_names = default_host_names; - gateway_names = default_gateway_names; - vm_names = default_gateway_names; - udpv4_forwards = []; - tcpv4_forwards = []; - gateway_forwards_path = None; - forwards_path = None; - pcap_snaplen = default_pcap_snaplen; -} +let default = + { + server_macaddr = default_server_macaddr; + max_connections = None; + dns = no_dns_servers; + dns_path = None; + resolver = default_resolver; + domain = None; + allowed_bind_addresses = []; + gateway_ip = default_gateway_ip; + host_ip = default_host_ip; + lowest_ip = default_lowest_ip; + highest_ip = default_highest_ip; + dhcp_json_path = None; + dhcp_configuration = None; + mtu = default_mtu; + http_intercept = None; + http_intercept_path = None; + port_max_idle_time = default_port_max_idle_time; + host_names = default_host_names; + gateway_names = default_gateway_names; + vm_names = default_gateway_names; + udpv4_forwards = []; + tcpv4_forwards = []; + gateway_forwards_path = None; + forwards_path = None; + pcap_snaplen = default_pcap_snaplen; + } module Parse = struct - - let ipv4 default x = match Ipaddr.V4.of_string @@ String.trim x with - | Error (`Msg m) -> - Log.err (fun f -> - f "Failed to parse IPv4 address '%s', using default of %a: %s" - x Ipaddr.V4.pp default m); - Lwt.return default - | Ok x -> Lwt.return x + let ipv4 default x = + match Ipaddr.V4.of_string @@ String.trim x with + | Error (`Msg m) -> + Log.err (fun f -> + f "Failed to parse IPv4 address '%s', using default of %a: %s" x + Ipaddr.V4.pp default m); + Lwt.return default + | Ok x -> Lwt.return x let ipv4_list default x = let all = - List.map Ipaddr.V4.of_string @@ - List.filter (fun x -> x <> "") @@ - List.map String.trim @@ - Astring.String.cuts ~sep:"," x + List.map Ipaddr.V4.of_string + @@ List.filter (fun x -> x <> "") + @@ List.map String.trim + @@ Astring.String.cuts ~sep:"," x in - let any_error, ok = List.fold_left (fun (any_error, ok) x -> match x with - | Error _ -> true, ok - | Ok x -> any_error, x :: ok - ) (false, []) all in - if any_error then begin + let any_error, ok = + List.fold_left + (fun (any_error, ok) x -> + match x with Error _ -> (true, ok) | Ok x -> (any_error, x :: ok)) + (false, []) all + in + if any_error then ( Log.err (fun f -> f "Failed to parse IPv4 address list '%s', using default of %s" x (String.concat "," (List.map Ipaddr.V4.to_string default))); - default - end else ok + default) + else ok let int = function - | None -> Lwt.return None - | Some x -> Lwt.return ( - try Some (int_of_string @@ String.trim x) - with _ -> - Log.err (fun f -> - f "Failed to parse integer value: '%s'" x); - None - ) + | None -> Lwt.return None + | Some x -> + Lwt.return + (try Some (int_of_string @@ String.trim x) + with _ -> + Log.err (fun f -> f "Failed to parse integer value: '%s'" x); + None) let resolver = function - | Some "host" -> Lwt.return `Host - | _ -> Lwt.return `Upstream + | Some "host" -> Lwt.return `Host + | _ -> Lwt.return `Upstream let dns txt = let open Dns_forward in - begin match Config.of_string txt with + match Config.of_string txt with | Ok config -> Some config | Error (`Msg m) -> - Log.err (fun f -> f "failed to parse dns configuration: %s" m); - None - end - -end \ No newline at end of file + Log.err (fun f -> f "failed to parse dns configuration: %s" m); + None +end File "src/hostnet/sig.ml", line 1, characters 0-0: diff --git a/_build/default/src/hostnet/sig.ml b/_build/default/src/hostnet/.formatted/sig.ml index d3002ce..0abb907 100644 --- a/_build/default/src/hostnet/sig.ml +++ b/_build/default/src/hostnet/.formatted/sig.ml @@ -2,9 +2,9 @@ module type READ_INTO = sig type flow type error - val read_into: flow -> Cstruct.t -> - (unit Mirage_flow.or_eof, error) result Lwt.t - (** Completely fills the given buffer with data from [fd] *) + val read_into : + flow -> Cstruct.t -> (unit Mirage_flow.or_eof, error) result Lwt.t + (** Completely fills the given buffer with data from [fd] *) end module type FLOW_CLIENT = sig @@ -12,18 +12,15 @@ module type FLOW_CLIENT = sig type address - val connect: ?read_buffer_size:int -> address -> - (flow, [`Msg of string]) result Lwt.t - (** [connect address] creates a connection to [address] and returns + val connect : + ?read_buffer_size:int -> address -> (flow, [ `Msg of string ]) result Lwt.t + (** [connect address] creates a connection to [address] and returns he connected flow. *) end module type CONN = sig include Mirage_flow.S - - include READ_INTO - with type flow := flow - and type error := error + include READ_INTO with type flow := flow and type error := error end module type FLOW_SERVER = sig @@ -32,83 +29,70 @@ module type FLOW_SERVER = sig type address - val of_bound_fd: ?read_buffer_size:int -> Unix.file_descr -> server Lwt.t + val of_bound_fd : ?read_buffer_size:int -> Unix.file_descr -> server Lwt.t (** Create a server from a file descriptor bound to a Unix domain socket by some other process and passed to us. *) - val bind: ?description:string -> address -> server Lwt.t + val bind : ?description:string -> address -> server Lwt.t (** Bind a server to an address *) - val getsockname: server -> address Lwt.t + val getsockname : server -> address Lwt.t (** Query the address the server is bound to *) - val disable_connection_tracking: server -> unit + val disable_connection_tracking : server -> unit (** For a particular server, exempt connections from the tracking mechanism. This is intended for internal purposes only (e.g. extracting diagnostics information) *) type flow - val listen: server -> (flow -> unit Lwt.t) -> unit + val listen : server -> (flow -> unit Lwt.t) -> unit (** Accept connections forever, calling the callback with each one. Connections are closed automatically when the callback finishes. *) - val shutdown: server -> unit Lwt.t + val shutdown : server -> unit Lwt.t (** Stop accepting connections on the given server *) end module type FLOW_CLIENT_SERVER = sig include FLOW_CLIENT - include FLOW_SERVER - with type address := address - and type flow := flow + include FLOW_SERVER with type address := address and type flow := flow end module type SOCKETS = sig (* An OS-based BSD sockets implementation *) - module Datagram: sig - + module Datagram : sig type address = Ipaddr.t * int - module Udp: sig + module Udp : sig type address = Ipaddr.t * int - include FLOW_CLIENT_SERVER - with type address := address + include FLOW_CLIENT_SERVER with type address := address - val recvfrom: server -> Cstruct.t -> (int * address) Lwt.t - - val sendto: server -> address -> ?ttl:int -> Cstruct.t -> unit Lwt.t + val recvfrom : server -> Cstruct.t -> (int * address) Lwt.t + val sendto : server -> address -> ?ttl:int -> Cstruct.t -> unit Lwt.t end end - module Stream: sig - module Tcp: sig - type address = Ipaddr.t * int - include FLOW_CLIENT_SERVER - with type address := address + module Stream : sig + module Tcp : sig + type address = Ipaddr.t * int - include READ_INTO - with type flow := flow - and type error := error + include FLOW_CLIENT_SERVER with type address := address + include READ_INTO with type flow := flow and type error := error end - module Unix: sig + module Unix : sig type address = string - include FLOW_CLIENT_SERVER - with type address := address - - include READ_INTO - with type flow := flow - and type error := error + include FLOW_CLIENT_SERVER with type address := address + include READ_INTO with type flow := flow and type error := error - val unsafe_get_raw_fd: flow -> Unix.file_descr + val unsafe_get_raw_fd : flow -> Unix.file_descr (** Return the underlying fd. This is intended for careful integration with 3rd party libraries. Don't use this fd at the same time as the flow. *) - end end end @@ -116,62 +100,62 @@ end module type FILES = sig (** An OS-based file reading implementation *) - val read_file: string -> (string, [`Msg of string]) result Lwt.t + val read_file : string -> (string, [ `Msg of string ]) result Lwt.t (** Read a whole file into a string *) type watch - val watch_file: string -> (unit -> unit) -> (watch, [ `Msg of string ]) result Lwt.t + val watch_file : + string -> (unit -> unit) -> (watch, [ `Msg of string ]) result Lwt.t (** [watch_file path callback] executes [callback] whenever the contents of [path] may have changed. This blocks until the watch has been established. *) - val unwatch: watch -> unit Lwt.t + val unwatch : watch -> unit Lwt.t (** [unwatch watch] stops watching the path(s) associated with [watch] *) end module type DNS = sig - val resolve: Dns.Packet.question -> Dns.Packet.rr list Lwt.t + val resolve : Dns.Packet.question -> Dns.Packet.rr list Lwt.t (** Given a question, find associated resource records *) end module type HOST = sig (** The Host interface *) - module Sockets: sig - (** User-space socket connections *) + module Sockets : sig include SOCKETS + (** User-space socket connections *) end - module Files: sig + module Files : sig include FILES end - module Time: Mirage_time.S + module Time : Mirage_time.S - module Dns: sig + module Dns : sig include DNS end - module Main: sig - val run: unit Lwt.t -> unit + module Main : sig + val run : unit Lwt.t -> unit (** Run the main event loop *) - val run_in_main: (unit -> 'a Lwt.t) -> 'a + val run_in_main : (unit -> 'a Lwt.t) -> 'a (** Run the function in the main thread *) end - module Fn: sig + module Fn : sig (** Call a blocking ('a -> 'b) function in a ('a -> 'b Lwt.t) context *) type ('request, 'response) t (** A function from 'request to 'response *) - val create: ('request -> 'response) -> ('request, 'response) t - val destroy: ('request, 'response) t -> unit + val create : ('request -> 'response) -> ('request, 'response) t + val destroy : ('request, 'response) t -> unit - val fn: ('request, 'response) t -> 'request -> 'response Lwt.t + val fn : ('request, 'response) t -> 'request -> 'response Lwt.t (** Apply the function *) - end end @@ -180,27 +164,28 @@ module type VMNET = sig include Mirage_net.S - val add_listener: t -> (Cstruct.t -> unit Lwt.t) -> unit + val add_listener : t -> (Cstruct.t -> unit Lwt.t) -> unit (** Add a callback which will be invoked in parallel with all received packets *) - val after_disconnect: t -> unit Lwt.t + val after_disconnect : t -> unit Lwt.t (** Waits until the network has disconnected *) type fd - val of_fd: - connect_client_fn:(Uuidm.t -> Ipaddr.V4.t option -> (Macaddr.t, [`Msg of string]) result Lwt.t) -> + val of_fd : + connect_client_fn: + (Uuidm.t -> + Ipaddr.V4.t option -> + (Macaddr.t, [ `Msg of string ]) result Lwt.t) -> server_macaddr:Macaddr.t -> mtu:int -> - fd -> (t, [`Msg of string]) result Lwt.t - - val start_capture: t -> ?size_limit:int64 -> string -> unit Lwt.t - - val stop_capture: t -> unit Lwt.t - - val get_client_uuid: t -> Uuidm.t + fd -> + (t, [ `Msg of string ]) result Lwt.t - val get_client_macaddr: t -> Macaddr.t + val start_capture : t -> ?size_limit:int64 -> string -> unit Lwt.t + val stop_capture : t -> unit Lwt.t + val get_client_uuid : t -> Uuidm.t + val get_client_macaddr : t -> Macaddr.t end module type DNS_POLICY = sig @@ -217,16 +202,19 @@ module type DNS_POLICY = sig If configuration with a higher priority is found then it completely overrides lower priority configuration. *) - type priority = int (** higher is more important *) + type priority = int + (** higher is more important *) - val add: priority:priority -> - config:[ `Upstream of Dns_forward.Config.t | `Host ] -> unit + val add : + priority:priority -> + config:[ `Upstream of Dns_forward.Config.t | `Host ] -> + unit (** Add some configuration at the given priority level *) - val remove: priority:priority -> unit + val remove : priority:priority -> unit (** Remove the configuration at the given priority level *) - val config: unit -> [ `Upstream of Dns_forward.Config.t | `Host ] + val config : unit -> [ `Upstream of Dns_forward.Config.t | `Host ] (** Return the currently active DNS configuration *) end @@ -235,7 +223,7 @@ module type RECORDER = sig type t - val record: t -> Cstruct.t list -> unit + val record : t -> Cstruct.t list -> unit (** Inject a packet and record it if it matches a rule. This is intended for debugging: the packet will not be transmitted to the underlying network. *) @@ -246,10 +234,8 @@ module type Connector = sig include FLOW_CLIENT - val connect: unit -> flow Lwt.t + val connect : unit -> flow Lwt.t (** Connect to the port multiplexing service in the VM *) - include READ_INTO - with type flow := flow - and type error := error + include READ_INTO with type flow := flow and type error := error end File "src/bin/logging.ml", line 1, characters 0-0: diff --git a/_build/default/src/bin/logging.ml b/_build/default/src/bin/.formatted/logging.ml index 123b7eb..64b627d 100644 --- a/_build/default/src/bin/logging.ml +++ b/_build/default/src/bin/.formatted/logging.ml @@ -1,12 +1,12 @@ (* Based on https://github.com/moby/datakit/blob/master/src/datakit-log/datakit_log.ml *) - let pp_ptime f () = - let open Unix in - let s = Unix.gettimeofday () in - let tm = Unix.gmtime s in - let nsecs = Float.rem s Float.one *. 1e9 |> int_of_float in - Fmt.pf f "%04d-%02d-%02dT%02d:%02d:%02d.%09dZ" (tm.tm_year + 1900) (tm.tm_mon + 1) - tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec nsecs +let pp_ptime f () = + let open Unix in + let s = Unix.gettimeofday () in + let tm = Unix.gmtime s in + let nsecs = Float.rem s Float.one *. 1e9 |> int_of_float in + Fmt.pf f "%04d-%02d-%02dT%02d:%02d:%02d.%09dZ" (tm.tm_year + 1900) + (tm.tm_mon + 1) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec nsecs let process = Filename.basename Sys.argv.(0) @@ -33,45 +33,52 @@ let shutdown () = Buffer.add_string buffer "logging system has shutdown"; Condition.broadcast c; while not !shutdown_done do - Condition.wait c m; - done - ) () + Condition.wait c m + done) + () let reporter = let max_buffer_size = 65536 in let dropped_bytes = ref 0 in - let (_: Thread.t) = Thread.create (fun () -> - let rec next () = match Buffer.contents buffer with - | "" -> - Condition.wait c m; - next () - | data -> - let dropped = !dropped_bytes in - dropped_bytes := 0; - Buffer.reset buffer; - data, dropped in - let should_continue () = match Buffer.contents buffer with - | "" -> - if !shutdown_requested then begin - shutdown_done := true; - Condition.broadcast c; - end; - not !shutdown_done - | _ -> true (* more logs to print *) in - let rec loop () = - let data, dropped = with_lock m next () in - (* Block writing to stderr without the buffer mutex held. Logging may continue into the buffer. *) - output_string stderr data; - if dropped > 0 then begin - output_string stderr (Printf.sprintf "%d bytes of logs dropped\n" dropped) - end; - flush stderr; - if with_lock m should_continue () then loop () in - loop () - ) () in + let (_ : Thread.t) = + Thread.create + (fun () -> + let rec next () = + match Buffer.contents buffer with + | "" -> + Condition.wait c m; + next () + | data -> + let dropped = !dropped_bytes in + dropped_bytes := 0; + Buffer.reset buffer; + (data, dropped) + in + let should_continue () = + match Buffer.contents buffer with + | "" -> + if !shutdown_requested then ( + shutdown_done := true; + Condition.broadcast c); + not !shutdown_done + | _ -> true + (* more logs to print *) + in + let rec loop () = + let data, dropped = with_lock m next () in + (* Block writing to stderr without the buffer mutex held. Logging may continue into the buffer. *) + output_string stderr data; + if dropped > 0 then + output_string stderr + (Printf.sprintf "%d bytes of logs dropped\n" dropped); + flush stderr; + if with_lock m should_continue () then loop () + in + loop ()) + () + in let buffer_fmt = Format.formatter_of_buffer buffer in - let report src level ~over k msgf = let k _ = Condition.broadcast c; @@ -80,20 +87,18 @@ let reporter = in let src = Logs.Src.name src in msgf @@ fun ?header:_ ?tags:_ fmt -> - let level = Logs.level_to_string (Some level) in - with_lock m - (fun () -> - let destination = - if Buffer.length buffer > max_buffer_size then begin - Format.make_formatter (fun _ _ _ -> ()) (fun () -> ()) - end else buffer_fmt in - Format.kfprintf k destination - ("[%a][%a][%a] %a: " ^^ fmt ^^ "@.") - pp_ptime () - Fmt.string process - Fmt.string level - Fmt.string src - ) () + let level = Logs.level_to_string (Some level) in + with_lock m + (fun () -> + let destination = + if Buffer.length buffer > max_buffer_size then + Format.make_formatter (fun _ _ _ -> ()) (fun () -> ()) + else buffer_fmt + in + Format.kfprintf k destination + ("[%a][%a][%a] %a: " ^^ fmt ^^ "@.") + pp_ptime () Fmt.string process Fmt.string level Fmt.string src) + () in { Logs.report } File "src/bin/bind.ml", line 1, characters 0-0: diff --git a/_build/default/src/bin/bind.ml b/_build/default/src/bin/.formatted/bind.ml index ba0a43d..1efd927 100644 --- a/_build/default/src/bin/bind.ml +++ b/_build/default/src/bin/.formatted/bind.ml @@ -1,24 +1,22 @@ let src = - let src = Logs.Src.create "port forward" ~doc:"forward local ports to the VM" in + let src = + Logs.Src.create "port forward" ~doc:"forward local ports to the VM" + in Logs.Src.set_level src (Some Logs.Info); src module Log = (val Logs.src_log src : Logs.LOG) - open Lwt.Infix open Vmnet let is_windows = Sys.os_type = "Win32" - let failf fmt = Fmt.kstr (fun e -> Lwt_result.fail (`Msg e)) fmt -let ( >>*= ) m f = m >>= function - | Error (`Msg m) -> Lwt.fail_with m - | Ok x -> f x +let ( >>*= ) m f = + m >>= function Error (`Msg m) -> Lwt.fail_with m | Ok x -> f x -module Make(Socket: Sig.SOCKETS) = struct - - module Channel = Mirage_channel.Make(Socket.Stream.Unix) +module Make (Socket : Sig.SOCKETS) = struct + module Channel = Mirage_channel.Make (Socket.Stream.Unix) let err_eof = Lwt_result.fail (`Msg "EOF") let err_read e = failf "while reading: %a" Channel.pp_error e @@ -26,37 +24,30 @@ module Make(Socket: Sig.SOCKETS) = struct let with_read x f = x >>= function - | Error e -> err_read e - | Ok `Eof -> err_eof + | Error e -> err_read e + | Ok `Eof -> err_eof | Ok (`Data x) -> f x - let with_flush x f = - x >>= function - | Error e -> err_flush e - | Ok () -> f () + let with_flush x f = x >>= function Error e -> err_flush e | Ok () -> f () - type t = { - fd: Socket.Stream.Unix.flow; - c: Channel.t; - } + type t = { fd : Socket.Stream.Unix.flow; c : Channel.t } let of_fd fd = let buf = Cstruct.create Init.sizeof in - let (_: Cstruct.t) = Init.marshal Init.default buf in + let (_ : Cstruct.t) = Init.marshal Init.default buf in let c = Channel.create fd in Channel.write_buffer c buf; with_flush (Channel.flush c) @@ fun () -> with_read (Channel.read_exactly ~len:Init.sizeof c) @@ fun bufs -> let buf = Cstruct.concat bufs in let init, _ = Init.unmarshal buf in - Log.info (fun f -> - f "Client.negotiate: received %s" (Init.to_string init)); + Log.info (fun f -> f "Client.negotiate: received %s" (Init.to_string init)); Lwt_result.return { fd; c } let bind_ipv4 t (ipv4, port, stream) = let buf = Cstruct.create Command.sizeof in - let (_: Cstruct.t) = - Command.marshal (Command.Bind_ipv4(ipv4, port, stream)) buf + let (_ : Cstruct.t) = + Command.marshal (Command.Bind_ipv4 (ipv4, port, stream)) buf in Channel.write_buffer t.c buf; with_flush (Channel.flush t.c) @@ fun () -> @@ -64,35 +55,35 @@ module Make(Socket: Sig.SOCKETS) = struct let result = Bytes.make 8 '\000' in let n, _, fd = Fd_send_recv.recv_fd rawfd result 0 8 [] in - (if n <> 8 then failf "Message only contained %d bytes" n else - let buf = Cstruct.create 8 in - Cstruct.blit_from_bytes result 0 buf 0 8; - Log.debug (fun f -> - let b = Buffer.create 16 in - Cstruct.hexdump_to_buffer b buf; - f "received result bytes: %s which is %s" (String.escaped (Bytes.to_string result)) - (Buffer.contents b)); - match Cstruct.LE.get_uint64 buf 0 with - | 0L -> Lwt_result.return fd - | 48L -> failf "EADDRINUSE" - | 49L -> failf "EADDRNOTAVAIL" - | n -> failf "Failed to bind: unrecognised errno: %Ld" n - ) >>= function + (if n <> 8 then failf "Message only contained %d bytes" n + else + let buf = Cstruct.create 8 in + Cstruct.blit_from_bytes result 0 buf 0 8; + Log.debug (fun f -> + let b = Buffer.create 16 in + Cstruct.hexdump_to_buffer b buf; + f "received result bytes: %s which is %s" + (String.escaped (Bytes.to_string result)) + (Buffer.contents b)); + match Cstruct.LE.get_uint64 buf 0 with + | 0L -> Lwt_result.return fd + | 48L -> failf "EADDRINUSE" + | 49L -> failf "EADDRNOTAVAIL" + | n -> failf "Failed to bind: unrecognised errno: %Ld" n) + >>= function | Error x -> - Unix.close fd; - Lwt_result.fail x - | Ok x -> - Lwt_result.return x + Unix.close fd; + Lwt_result.fail x + | Ok x -> Lwt_result.return x (* This implementation is OSX-only *) let request_privileged_port local_ip local_port sock_stream = let open Lwt_result.Infix in - Socket.Stream.Unix.connect "/var/run/com.docker.vmnetd.sock" - >>= fun flow -> - Lwt.finalize (fun () -> - of_fd flow >>= fun c -> - bind_ipv4 c (local_ip, local_port, sock_stream) - ) (fun () -> Socket.Stream.Unix.close flow) + Socket.Stream.Unix.connect "/var/run/com.docker.vmnetd.sock" >>= fun flow -> + Lwt.finalize + (fun () -> + of_fd flow >>= fun c -> bind_ipv4 c (local_ip, local_port, sock_stream)) + (fun () -> Socket.Stream.Unix.close flow) module Datagram = struct type address = Socket.Datagram.address @@ -103,12 +94,10 @@ module Make(Socket: Sig.SOCKETS) = struct let bind ?description (local_ip, local_port) = match local_ip with | Ipaddr.V4 ipv4 -> - if local_port < 1024 && not is_windows then - request_privileged_port ipv4 local_port false - >>*= fun fd -> - Socket.Datagram.Udp.of_bound_fd fd - else - bind ?description (local_ip, local_port) + if local_port < 1024 && not is_windows then + request_privileged_port ipv4 local_port false >>*= fun fd -> + Socket.Datagram.Udp.of_bound_fd fd + else bind ?description (local_ip, local_port) | _ -> bind ?description (local_ip, local_port) end end @@ -120,12 +109,10 @@ module Make(Socket: Sig.SOCKETS) = struct let bind ?description (local_ip, local_port) = match local_ip with | Ipaddr.V4 ipv4 -> - if local_port < 1024 && not is_windows then - request_privileged_port ipv4 local_port true - >>*= fun fd -> - Socket.Stream.Tcp.of_bound_fd fd - else - bind ?description (local_ip, local_port) + if local_port < 1024 && not is_windows then + request_privileged_port ipv4 local_port true >>*= fun fd -> + Socket.Stream.Tcp.of_bound_fd fd + else bind ?description (local_ip, local_port) | _ -> bind ?description (local_ip, local_port) end File "src/hostnet/mux.ml", line 1, characters 0-0: diff --git a/_build/default/src/hostnet/mux.ml b/_build/default/src/hostnet/.formatted/mux.ml index da0f04b..ac8e9f6 100644 --- a/_build/default/src/hostnet/mux.ml +++ b/_build/default/src/hostnet/.formatted/mux.ml @@ -13,50 +13,43 @@ module DontCareAboutStats = struct end module ObviouslyCommon = struct - - type error = [Mirage_net.Net.error | `Unknown of string] + type error = [ Mirage_net.Net.error | `Unknown of string ] let pp_error ppf = function - | #Mirage_net.Net.error as e -> Mirage_net.Net.pp_error ppf e - | `Unknown s -> Fmt.pf ppf "unknown: %s" s - + | #Mirage_net.Net.error as e -> Mirage_net.Net.pp_error ppf e + | `Unknown s -> Fmt.pf ppf "unknown: %s" s end -module Make (Netif: Mirage_net.S) = struct - +module Make (Netif : Mirage_net.S) = struct include DontCareAboutStats include ObviouslyCommon type rule = Ipaddr.V4.t - module RuleMap = Map.Make(Ipaddr.V4) + module RuleMap = Map.Make (Ipaddr.V4) type callback = Cstruct.t -> unit Lwt.t - - type port = { - callback: callback; - mutable last_active_time: float; - } + type port = { callback : callback; mutable last_active_time : float } type t = { - netif: Netif.t; - mutable rules: port RuleMap.t; - mutable default_callback: callback; + netif : Netif.t; + mutable rules : port RuleMap.t; + mutable default_callback : callback; } - let lift_error: ('a, Netif.error) result -> ('a, error) result = function - | Ok x -> Ok x - | Error (#Mirage_net.Net.error as e) -> Error e - | Error e -> Fmt.kstr (fun s -> Error (`Unknown s)) "%a" Netif.pp_error e + let lift_error : ('a, Netif.error) result -> ('a, error) result = function + | Ok x -> Ok x + | Error (#Mirage_net.Net.error as e) -> Error e + | Error e -> Fmt.kstr (fun s -> Error (`Unknown s)) "%a" Netif.pp_error e let filesystem t = let xs = RuleMap.fold (fun ip t acc -> - Fmt.str "%a last_active_time = %.1f" Ipaddr.V4.pp ip - t.last_active_time - :: acc - ) t.rules [] + Fmt.str "%a last_active_time = %.1f" Ipaddr.V4.pp ip + t.last_active_time + :: acc) + t.rules [] in Vfs.File.ro_of_string (String.concat "\n" xs) @@ -70,35 +63,38 @@ module Make (Netif: Mirage_net.S) = struct let open Frame in match parse [ buf ] with | Ok (Ethernet { payload = Ipv4 { dst; _ }; _ }) -> - if RuleMap.mem dst t.rules then begin - let port = RuleMap.find dst t.rules in - port.last_active_time <- Unix.gettimeofday (); - port.callback buf - end else begin - Log.debug (fun f -> - f "using default callback for packet for %a" Ipaddr.V4.pp dst); - t.default_callback buf - end + if RuleMap.mem dst t.rules then ( + let port = RuleMap.find dst t.rules in + port.last_active_time <- Unix.gettimeofday (); + port.callback buf) + else ( + Log.debug (fun f -> + f "using default callback for packet for %a" Ipaddr.V4.pp dst); + t.default_callback buf) | _ -> - Log.debug (fun f -> f "using default callback for non-IPv4 frame"); - t.default_callback buf + Log.debug (fun f -> f "using default callback for non-IPv4 frame"); + t.default_callback buf let connect netif = let rules = RuleMap.empty in - let default_callback = fun _ -> Lwt.return_unit in + let default_callback _ = Lwt.return_unit in let t = { netif; rules; default_callback } in - Lwt.async - (fun () -> - Netif.listen netif ~header_size:Ethernet.Packet.sizeof_ethernet @@ callback t >>= function - | Ok () -> Lwt.return_unit - | Error _e -> - Log.err (fun f -> f "Mux.connect calling Netif.listen: failed"); - Lwt.return_unit - ); + Lwt.async (fun () -> + Netif.listen netif ~header_size:Ethernet.Packet.sizeof_ethernet + @@ callback t + >>= function + | Ok () -> Lwt.return_unit + | Error _e -> + Log.err (fun f -> f "Mux.connect calling Netif.listen: failed"); + Lwt.return_unit); Lwt.return (Ok t) let write t ~size fill = Netif.write t.netif ~size fill >|= lift_error - let listen t ~header_size:_ callback = t.default_callback <- callback; Lwt.return (Ok ()) + + let listen t ~header_size:_ callback = + t.default_callback <- callback; + Lwt.return (Ok ()) + let disconnect t = Netif.disconnect t.netif let mac t = Netif.mac t.netif let mtu t = Netif.mtu t.netif @@ -107,11 +103,7 @@ module Make (Netif: Mirage_net.S) = struct include DontCareAboutStats include ObviouslyCommon - type _t = { - switch: t; - netif: Netif.t; - rule: rule; - } + type _t = { switch : t; netif : Netif.t; rule : rule } let write t ~size fill = Netif.write t.netif ~size fill >|= lift_error @@ -136,5 +128,4 @@ module Make (Netif: Mirage_net.S) = struct end let port t rule = { Port.switch = t; netif = t.netif; rule } - end File "src/hostnet/hostnet_udp.ml", line 1, characters 0-0: diff --git a/_build/default/src/hostnet/hostnet_udp.ml b/_build/default/src/hostnet/.formatted/hostnet_udp.ml index f006c8a..5dfc002 100644 --- a/_build/default/src/hostnet/hostnet_udp.ml +++ b/_build/default/src/hostnet/.formatted/hostnet_udp.ml @@ -8,14 +8,13 @@ let src = module Log = (val Logs.src_log src : Logs.LOG) type reply = Cstruct.t -> unit Lwt.t - type address = Ipaddr.t * int type datagram = { - src: address; - dst: address; - intercept: address; - payload: Cstruct.t; + src : address; + dst : address; + intercept : address; + payload : Cstruct.t; } (* A table mapping host ports to the corresponding internal address. @@ -25,39 +24,38 @@ type datagram = { let external_to_internal = Hashtbl.create 7 module Make - (Sockets: Sig.SOCKETS) - (Clock: Mirage_clock.MCLOCK) - (Time: Mirage_time.S) = + (Sockets : Sig.SOCKETS) + (Clock : Mirage_clock.MCLOCK) + (Time : Mirage_time.S) = struct - module Udp = Sockets.Datagram.Udp (* For every source address, we allocate a flow with a receiving loop *) type flow = { - description: string; - src: address; - server: Udp.server; - external_address: address; - mutable last_use: int64; + description : string; + src : address; + server : Udp.server; + external_address : address; + mutable last_use : int64; } (* We keep a map of last_use (nanosecond) -> flow so we can partition it and expire the oldest. *) - module By_last_use = Map.Make(Int64) + module By_last_use = Map.Make (Int64) (* For every src, src_port behind the NAT we create one listening socket on the external network. We translate the source address on the way out but preserve them on the way in. *) type t = { - max_idle_time: int64; - max_active_flows: int; - new_flow_lock: Lwt_mutex.t; - background_gc_t: unit Lwt.t; - table: (address, flow) Hashtbl.t; (* src -> flow *) - by_last_use: flow By_last_use.t ref; (* last use -> flow *) - mutable send_reply: (datagram -> unit Lwt.t) option; - preserve_remote_port: bool; + max_idle_time : int64; + max_active_flows : int; + new_flow_lock : Lwt_mutex.t; + background_gc_t : unit Lwt.t; + table : (address, flow) Hashtbl.t; (* src -> flow *) + by_last_use : flow By_last_use.t ref; (* last use -> flow *) + mutable send_reply : (datagram -> unit Lwt.t) option; + preserve_remote_port : bool; } let set_send_reply ~t ~send_reply = t.send_reply <- Some send_reply @@ -66,195 +64,207 @@ struct type address = Ipaddr.t * int type flow = { - inside: address; - outside: address; - last_use_time_ns: int64; + inside : address; + outside : address; + last_use_time_ns : int64; } let get_table t = - Hashtbl.fold (fun _ flow acc -> - { - inside = flow.src; - outside = flow.external_address; - last_use_time_ns = flow.last_use; - } :: acc - ) t.table [] + Hashtbl.fold + (fun _ flow acc -> + { + inside = flow.src; + outside = flow.external_address; + last_use_time_ns = flow.last_use; + } + :: acc) + t.table [] let get_max_active_flows t = t.max_active_flows end let expire table by_last_use flow = - Lwt.catch (fun () -> - Udp.shutdown flow.server - ) (fun e -> + Lwt.catch + (fun () -> Udp.shutdown flow.server) + (fun e -> Log.err (fun f -> f "Hostnet_udp %s: close raised %a" flow.description Fmt.exn e); - Lwt.return_unit - ) + Lwt.return_unit) >>= fun () -> Hashtbl.remove table flow.src; Hashtbl.remove external_to_internal (snd flow.external_address); - by_last_use := By_last_use.remove flow.last_use (!by_last_use); + by_last_use := By_last_use.remove flow.last_use !by_last_use; Lwt.return_unit let touch t flow = let last_use = Clock.elapsed_ns () in (* Remove the old entry t.last_use and add a new one for last_use *) - t.by_last_use := By_last_use.(add last_use flow @@ remove flow.last_use !(t.by_last_use)); + (t.by_last_use := + By_last_use.(add last_use flow @@ remove flow.last_use !(t.by_last_use))); flow.last_use <- last_use let start_background_gc table by_last_use max_idle_time new_flow_lock = let rec loop () = Time.sleep_ns max_idle_time >>= fun () -> - Lwt_mutex.with_lock new_flow_lock - (fun () -> + Lwt_mutex.with_lock new_flow_lock (fun () -> let now_ns = Clock.elapsed_ns () in let to_shutdown = - Hashtbl.fold (fun _ flow acc -> - if Int64.(sub now_ns flow.last_use) > max_idle_time then begin + Hashtbl.fold + (fun _ flow acc -> + if Int64.(sub now_ns flow.last_use) > max_idle_time then ( Log.debug (fun f -> f "Hostnet_udp %s: expiring UDP NAT rule" flow.description); - flow :: acc - end else acc - ) table [] + flow :: acc) + else acc) + table [] in - Lwt_list.iter_s (expire table by_last_use) to_shutdown - ) - >>= fun () -> - loop () + Lwt_list.iter_s (expire table by_last_use) to_shutdown) + >>= fun () -> loop () in loop () - let create ?(max_idle_time = Duration.(of_sec 60)) ?(preserve_remote_port=true) ?(max_active_flows=1024) () = + let create ?(max_idle_time = Duration.(of_sec 60)) + ?(preserve_remote_port = true) ?(max_active_flows = 1024) () = let table = Hashtbl.create 7 in let by_last_use = ref By_last_use.empty in let new_flow_lock = Lwt_mutex.create () in - let background_gc_t = start_background_gc table by_last_use max_idle_time new_flow_lock in + let background_gc_t = + start_background_gc table by_last_use max_idle_time new_flow_lock + in let send_reply = None in - { max_idle_time; max_active_flows; new_flow_lock; background_gc_t; table; by_last_use; send_reply; preserve_remote_port } + { + max_idle_time; + max_active_flows; + new_flow_lock; + background_gc_t; + table; + by_last_use; + send_reply; + preserve_remote_port; + } let description { src = src, src_port; dst = dst, dst_port; _ } = - Fmt.str "udp:%a:%d-%a:%d" Ipaddr.pp src src_port Ipaddr.pp - dst dst_port + Fmt.str "udp:%a:%d-%a:%d" Ipaddr.pp src src_port Ipaddr.pp dst dst_port let outside_to_inside t flow server d = let buf = Cstruct.create Constants.max_udp_length in let rec loop () = - Lwt.catch (fun () -> - Udp.recvfrom server buf - >>= fun (n, from) -> - touch t flow; - (* Copy the payload because lower down in the stack we will keep - references, for example in the .pcap capturing logic. *) - let payload = Cstruct.create n in - Cstruct.blit buf 0 payload 0 n; - (* In the default configuration with preserve_remote_port=true, - the from address should be the true external address so the - client behind the NAT can tell different peers apart. It - is not necessarily the same as the original external - address that we created the rule for -- it's possible for a - client to send data to a rendezvous server, which then - communicates the NAT IP and port to other peers who can - then communicate with the client behind the NAT. + Lwt.catch + (fun () -> + Udp.recvfrom server buf >>= fun (n, from) -> + touch t flow; + (* Copy the payload because lower down in the stack we will keep + references, for example in the .pcap capturing logic. *) + let payload = Cstruct.create n in + Cstruct.blit buf 0 payload 0 n; + (* In the default configuration with preserve_remote_port=true, + the from address should be the true external address so the + client behind the NAT can tell different peers apart. It + is not necessarily the same as the original external + address that we created the rule for -- it's possible for a + client to send data to a rendezvous server, which then + communicates the NAT IP and port to other peers who can + then communicate with the client behind the NAT. - If preserve_remote_port=false then we reply with the original - port number, as if we were a UDP proxy. Note the IP address is - set by the `send_reply` function. *) - let reply = { d with - src = if t.preserve_remote_port then from else d.dst; - dst = d.src; - payload; - } in - ( match t.send_reply with - | Some fn -> fn reply - | None -> Lwt.return_unit ) - >>= fun () -> - Lwt.return true - ) (function - | e -> - Log.err (fun f -> - f "Hostnet_udp %s: caught unexpected exception %a" - (description d) Fmt.exn e); - Lwt.return false - ) + If preserve_remote_port=false then we reply with the original + port number, as if we were a UDP proxy. Note the IP address is + set by the `send_reply` function. *) + let reply = + { + d with + src = (if t.preserve_remote_port then from else d.dst); + dst = d.src; + payload; + } + in + (match t.send_reply with + | Some fn -> fn reply + | None -> Lwt.return_unit) + >>= fun () -> Lwt.return true) + (function + | e -> + Log.err (fun f -> + f "Hostnet_udp %s: caught unexpected exception %a" + (description d) Fmt.exn e); + Lwt.return false) >>= function - | false -> - Lwt.return () - | true -> loop () in + | false -> Lwt.return () + | true -> loop () + in loop () let expire_old_flows_locked t = let current = By_last_use.cardinal !(t.by_last_use) in - if current < t.max_active_flows - then Lwt.return_unit - else begin + if current < t.max_active_flows then Lwt.return_unit + else (* Although we want a hard limit of max_active_flows, when we hit the limit we will expire the oldest 25% to amortise the cost. *) let to_delete = current - (t.max_active_flows / 4 * 3) in let seq = By_last_use.to_seq !(t.by_last_use) in - let rec loop remaining seq count = match remaining, seq () with + let rec loop remaining seq count = + match (remaining, seq ()) with | _, Seq.Nil -> Lwt.return count | 0, _ -> Lwt.return count - | n, Cons((_, oldest_flow), rest) -> - expire t.table t.by_last_use oldest_flow - >>= fun () -> - loop (n - 1) rest (count + 1) in - loop to_delete seq 0 - >>= fun count -> + | n, Cons ((_, oldest_flow), rest) -> + expire t.table t.by_last_use oldest_flow >>= fun () -> + loop (n - 1) rest (count + 1) + in + loop to_delete seq 0 >>= fun count -> Log.info (fun f -> f "Expired %d UDP NAT rules" count); Lwt.return_unit - end let input ~t ~datagram ~ttl () = let d = description datagram in - (if Hashtbl.mem t.table datagram.src then begin - Lwt.return (Some (Hashtbl.find t.table datagram.src)) - end else begin - if Ipaddr.compare (fst datagram.dst) Ipaddr.(V4 V4.broadcast) = 0 - then begin - Log.debug (fun f -> f "Hostnet_udp %s: ignoring broadcast packet" d); - Lwt.return None - end else begin - Log.debug (fun f -> f "Hostnet_udp %s: creating UDP NAT rule" d); - Lwt.catch (fun () -> - Lwt_mutex.with_lock t.new_flow_lock - (fun () -> - (* Re-check the table with the lock held as another thread might - have acquired the lock before us. *) - if Hashtbl.mem t.table datagram.src - then Lwt.return (Some (Hashtbl.find t.table datagram.src)) - else begin - expire_old_flows_locked t - >>= fun () -> - Udp.bind ~description:(description datagram) (Ipaddr.(V4 V4.any), 0) - >>= fun server -> - Udp.getsockname server - >>= fun external_address -> - let last_use = Clock.elapsed_ns () in - let flow = { description = d; src = datagram.src; server; external_address; last_use } in - Hashtbl.replace t.table datagram.src flow; - t.by_last_use := By_last_use.add last_use flow !(t.by_last_use); - Hashtbl.replace external_to_internal (snd external_address) datagram.src; - (* Start a listener *) - Lwt.async (fun () -> outside_to_inside t flow server datagram); - Lwt.return (Some flow) - end - ) - ) (fun e -> - Log.err (fun f -> f "Hostnet_udp.input: bind raised %a" Fmt.exn e); - Lwt.return None - ) - end - end) >>= function + (if Hashtbl.mem t.table datagram.src then + Lwt.return (Some (Hashtbl.find t.table datagram.src)) + else if Ipaddr.compare (fst datagram.dst) Ipaddr.(V4 V4.broadcast) = 0 then ( + Log.debug (fun f -> f "Hostnet_udp %s: ignoring broadcast packet" d); + Lwt.return None) + else ( + Log.debug (fun f -> f "Hostnet_udp %s: creating UDP NAT rule" d); + Lwt.catch + (fun () -> + Lwt_mutex.with_lock t.new_flow_lock (fun () -> + (* Re-check the table with the lock held as another thread might + have acquired the lock before us. *) + if Hashtbl.mem t.table datagram.src then + Lwt.return (Some (Hashtbl.find t.table datagram.src)) + else + expire_old_flows_locked t >>= fun () -> + Udp.bind ~description:(description datagram) + (Ipaddr.(V4 V4.any), 0) + >>= fun server -> + Udp.getsockname server >>= fun external_address -> + let last_use = Clock.elapsed_ns () in + let flow = + { + description = d; + src = datagram.src; + server; + external_address; + last_use; + } + in + Hashtbl.replace t.table datagram.src flow; + t.by_last_use := By_last_use.add last_use flow !(t.by_last_use); + Hashtbl.replace external_to_internal (snd external_address) + datagram.src; + (* Start a listener *) + Lwt.async (fun () -> outside_to_inside t flow server datagram); + Lwt.return (Some flow))) + (fun e -> + Log.err (fun f -> f "Hostnet_udp.input: bind raised %a" Fmt.exn e); + Lwt.return None))) + >>= function | None -> Lwt.return () | Some flow -> - Lwt.catch (fun () -> - Udp.sendto flow.server datagram.intercept ~ttl datagram.payload >|= fun () -> - touch t flow - ) (fun e -> - Log.err (fun f -> - f "Hostnet_udp %s: Lwt_bytes.send caught %a" - flow.description Fmt.exn e); - Lwt.return () - ) + Lwt.catch + (fun () -> + Udp.sendto flow.server datagram.intercept ~ttl datagram.payload + >|= fun () -> touch t flow) + (fun e -> + Log.err (fun f -> + f "Hostnet_udp %s: Lwt_bytes.send caught %a" flow.description + Fmt.exn e); + Lwt.return ()) end File "src/bin/connect.ml", line 1, characters 0-0: diff --git a/_build/default/src/bin/connect.ml b/_build/default/src/bin/.formatted/connect.ml index 86e47c0..d337e9e 100644 --- a/_build/default/src/bin/connect.ml +++ b/_build/default/src/bin/.formatted/connect.ml @@ -6,78 +6,68 @@ let src = src module Log = (val Logs.src_log src : Logs.LOG) - open Lwt.Infix -let ( >>*= ) m f = m >>= function - | Error (`Msg m) -> Lwt.fail_with m - | Ok x -> f x +let ( >>*= ) m f = + m >>= function Error (`Msg m) -> Lwt.fail_with m | Ok x -> f x -let (/) = Filename.concat +let ( / ) = Filename.concat let home = try Sys.getenv "HOME" with Not_found -> "/Users/root" let vsock_port = 62373l module Unix = struct - let vsock_path = ref (home / "Library/Containers/com.docker.docker/Data/@connect") include Host.Sockets.Stream.Unix let connect () = - connect (!vsock_path) - >>*= fun flow -> - let address = - Cstruct.of_string (Printf.sprintf "00000003.%08lx\n" vsock_port) - in - write flow address >>= function - | Ok () -> Lwt.return flow - | Error `Closed -> + connect !vsock_path >>*= fun flow -> + let address = + Cstruct.of_string (Printf.sprintf "00000003.%08lx\n" vsock_port) + in + write flow address >>= function + | Ok () -> Lwt.return flow + | Error `Closed -> Log.err (fun f -> f "vsock connect write got Eof"); - close flow >>= fun () -> - Lwt.fail End_of_file - | Error e -> + close flow >>= fun () -> Lwt.fail End_of_file + | Error e -> Log.err (fun f -> f "vsock connect write got %a" pp_write_error e); - close flow >>= fun () -> - Fmt.kstr Lwt.fail_with "%a" pp_write_error e + close flow >>= fun () -> Fmt.kstr Lwt.fail_with "%a" pp_write_error e end module Hvsock = struct (* Avoid using `detach` because we don't want to exhaust the thread pool since this will block the main TCP/IP stack. *) module F = - Hvsock_lwt.Flow_shutdown.Make(Host.Time) - (Hvsock_lwt.In_main_thread.Make(Host.Main)) + Hvsock_lwt.Flow_shutdown.Make + (Host.Time) + (Hvsock_lwt.In_main_thread.Make (Host.Main)) (Hvsock.Af_hyperv) - type flow = { - idx: int; - flow: F.flow; - } - + type flow = { idx : int; flow : F.flow } type address = unit let hvsockaddr = ref None - let set_port_forward_addr x = hvsockaddr := Some x let close flow = Connection_limit.deregister flow.idx; F.close flow.flow - let connect () = match !hvsockaddr with - | None -> - Log.err (fun f -> - f "Please set a Hyper-V socket address for port forwarding"); - failwith "Hyper-V socket forwarding not initialised" - | Some sockaddr -> - let description = "hvsock" in - (Lwt.return @@ Connection_limit.register description) - >>*= fun idx -> - let fd = F.Socket.create () in - F.Socket.connect fd sockaddr >|= fun () -> - let flow = F.connect fd in - { idx; flow } + let connect () = + match !hvsockaddr with + | None -> + Log.err (fun f -> + f "Please set a Hyper-V socket address for port forwarding"); + failwith "Hyper-V socket forwarding not initialised" + | Some sockaddr -> + let description = "hvsock" in + Lwt.return @@ Connection_limit.register description >>*= fun idx -> + let fd = F.Socket.create () in + F.Socket.connect fd sockaddr >|= fun () -> + let flow = F.connect fd in + { idx; flow } let read_into t = F.read_into t.flow let read t = F.read t.flow @@ -87,6 +77,7 @@ module Hvsock = struct let shutdown_write t = F.shutdown_write t.flow let pp_error = F.pp_error let pp_write_error = F.pp_write_error + type error = F.error type write_error = F.write_error end File "src/hostnet/frame.ml", line 1, characters 0-0: diff --git a/_build/default/src/hostnet/frame.ml b/_build/default/src/hostnet/.formatted/frame.ml index 6a03611..e0cff33 100644 --- a/_build/default/src/hostnet/frame.ml +++ b/_build/default/src/hostnet/.formatted/frame.ml @@ -6,146 +6,166 @@ let src = module Log = (val Logs.src_log src : Logs.LOG) type icmp = - | Echo: { seq: int; id: int; payload: Cstruct.t } -> icmp - | Time_exceeded: { ipv4: (ipv4, [ `Msg of string ]) result } -> icmp - | Destination_unreachable: { ipv4: (ipv4, [ `Msg of string ]) result } -> icmp - | Unknown_icmp: {ty: int } -> icmp + | Echo : { seq : int; id : int; payload : Cstruct.t } -> icmp + | Time_exceeded : { ipv4 : (ipv4, [ `Msg of string ]) result } -> icmp + | Destination_unreachable : { + ipv4 : (ipv4, [ `Msg of string ]) result; + } + -> icmp + | Unknown_icmp : { ty : int } -> icmp and ipv4 = { - src: Ipaddr.V4.t; dst: Ipaddr.V4.t; - dnf: bool; ihl: int; - ttl: int; raw: Cstruct.t; payload: t + src : Ipaddr.V4.t; + dst : Ipaddr.V4.t; + dnf : bool; + ihl : int; + ttl : int; + raw : Cstruct.t; + payload : t; } and t = - | Ethernet: { src: Macaddr.t; dst: Macaddr.t; payload: t } -> t - | Arp: { op: [ `Request | `Reply | `Unknown ] } -> t - | Icmp: { ty: int; code: int; raw: Cstruct.t; icmp: icmp } -> t - | Ipv4: ipv4 -> t - | Udp: { src: int; dst: int; len: int; raw: Cstruct.t; payload: t } -> t - | Tcp: { src: int; dst: int; syn: bool; rst: bool; raw: Cstruct.t; payload: t } -> t - | Payload: Cstruct.t -> t - | Unknown: t - -let ( >>= ) m f = match m with -| Ok x -> f x -| Error x -> Error x + | Ethernet : { src : Macaddr.t; dst : Macaddr.t; payload : t } -> t + | Arp : { op : [ `Request | `Reply | `Unknown ] } -> t + | Icmp : { ty : int; code : int; raw : Cstruct.t; icmp : icmp } -> t + | Ipv4 : ipv4 -> t + | Udp : { src : int; dst : int; len : int; raw : Cstruct.t; payload : t } -> t + | Tcp : { + src : int; + dst : int; + syn : bool; + rst : bool; + raw : Cstruct.t; + payload : t; + } + -> t + | Payload : Cstruct.t -> t + | Unknown : t +let ( >>= ) m f = match m with Ok x -> f x | Error x -> Error x let errorf fmt = Fmt.kstr (fun e -> Error (`Msg e)) fmt let need_space_for bufs n description = - if Cstructs.len bufs < n - then errorf "buffer is too short for %s: needed %d bytes but only have %d" + if Cstructs.len bufs < n then + errorf "buffer is too short for %s: needed %d bytes but only have %d" description n (Cstructs.len bufs) else Ok () let rec ipv4 inner = - need_space_for inner 16 "IP datagram" - >>= fun () -> - let vihl = Cstructs.get_uint8 inner 0 in - let len = Cstructs.BE.get_uint16 inner (1 + 1) in - let off = Cstructs.BE.get_uint16 inner (1 + 1 + 2 + 2) in - let ttl = Cstructs.get_uint8 inner (1 + 1 + 2 + 2 + 2) in - let proto = Cstructs.get_uint8 inner (1 + 1 + 2 + 2 + 2 + 1) in - let src = Cstructs.BE.get_uint32 inner (1 + 1 + 2 + 2 + 2 + 1 + 1 + 2) - |> Ipaddr.V4.of_int32 in - let dst = Cstructs.BE.get_uint32 inner (1 + 1 + 2 + 2 + 2 + 1 + 1 + 2 + 4) - |> Ipaddr.V4.of_int32 in - let dnf = ((off lsr 8) land 0x40) <> 0 in + need_space_for inner 16 "IP datagram" >>= fun () -> + let vihl = Cstructs.get_uint8 inner 0 in + let len = Cstructs.BE.get_uint16 inner (1 + 1) in + let off = Cstructs.BE.get_uint16 inner (1 + 1 + 2 + 2) in + let ttl = Cstructs.get_uint8 inner (1 + 1 + 2 + 2 + 2) in + let proto = Cstructs.get_uint8 inner (1 + 1 + 2 + 2 + 2 + 1) in + let src = + Cstructs.BE.get_uint32 inner (1 + 1 + 2 + 2 + 2 + 1 + 1 + 2) + |> Ipaddr.V4.of_int32 + in + let dst = + Cstructs.BE.get_uint32 inner (1 + 1 + 2 + 2 + 2 + 1 + 1 + 2 + 4) + |> Ipaddr.V4.of_int32 + in + let dnf = (off lsr 8) land 0x40 <> 0 in let ihl = vihl land 0xf in let raw = Cstructs.to_cstruct inner in - need_space_for inner (4 * ihl) "IP options" - >>= fun () -> + need_space_for inner (4 * ihl) "IP options" >>= fun () -> let after_header = Cstructs.shift inner (4 * ihl) in (* Trim the packet to the size given in the length field. Note the received data can be truncated too. *) - let inner = Cstructs.sub after_header 0 (min (len - 4 * ihl) (Cstructs.len after_header)) in - ( match proto with - | 1 -> - let raw = Cstructs.to_cstruct inner in - need_space_for inner 8 "ICMP message" - >>= fun () -> - let ty = Cstructs.get_uint8 inner 0 in - let code = Cstructs.get_uint8 inner 1 in - let _csum = Cstructs.BE.get_uint16 inner 2 in - ( match ty with + let inner = + Cstructs.sub after_header 0 + (min (len - (4 * ihl)) (Cstructs.len after_header)) + in + (match proto with + | 1 -> ( + let raw = Cstructs.to_cstruct inner in + need_space_for inner 8 "ICMP message" >>= fun () -> + let ty = Cstructs.get_uint8 inner 0 in + let code = Cstructs.get_uint8 inner 1 in + let _csum = Cstructs.BE.get_uint16 inner 2 in + match ty with | 0 | 8 -> - let id = Cstructs.BE.get_uint16 inner 4 in - let seq = Cstructs.BE.get_uint16 inner 6 in - let payload = Cstructs.shift inner 8 |> Cstructs.to_cstruct in - Ok (Icmp { ty; code; raw; icmp = Echo { id; seq; payload } }) + let id = Cstructs.BE.get_uint16 inner 4 in + let seq = Cstructs.BE.get_uint16 inner 6 in + let payload = Cstructs.shift inner 8 |> Cstructs.to_cstruct in + Ok (Icmp { ty; code; raw; icmp = Echo { id; seq; payload } }) | 3 -> - let nested_ip = Cstructs.shift inner 8 in - let ipv4 = ipv4 nested_ip in (* truncated so might not parse correctly *) - Ok (Icmp { ty; code; raw; icmp = Destination_unreachable { ipv4 }}) + let nested_ip = Cstructs.shift inner 8 in + let ipv4 = ipv4 nested_ip in + (* truncated so might not parse correctly *) + Ok (Icmp { ty; code; raw; icmp = Destination_unreachable { ipv4 } }) | 11 -> - let nested_ip = Cstructs.shift inner 8 in - let ipv4 = ipv4 nested_ip in (* truncated so might not parse correctly *) - Ok (Icmp { ty; code; raw; icmp = Time_exceeded { ipv4 }}) - | _ -> - Ok (Icmp { ty; code; raw; icmp = Unknown_icmp { ty } }) - ) + let nested_ip = Cstructs.shift inner 8 in + let ipv4 = ipv4 nested_ip in + (* truncated so might not parse correctly *) + Ok (Icmp { ty; code; raw; icmp = Time_exceeded { ipv4 } }) + | _ -> Ok (Icmp { ty; code; raw; icmp = Unknown_icmp { ty } })) | 6 -> - need_space_for inner 14 "TCP header" - >>= fun () -> - let src = Cstructs.BE.get_uint16 inner 0 in - let dst = Cstructs.BE.get_uint16 inner 2 in - let offres = Cstructs.get_uint8 inner (2 + 2 + 4 + 4) in - let flags = Cstructs.get_uint8 inner (2 + 2 + 4 + 4 + 1) in - need_space_for inner ((offres lsr 4) * 4) "TCP options" - >>= fun () -> - let payload = Cstructs.shift inner ((offres lsr 4) * 4) - |> Cstructs.to_cstruct in - let syn = (flags land (1 lsl 1)) > 0 in - let rst = (flags land (1 lsl 2)) > 0 in - Ok (Tcp { src; dst; syn; rst; raw = Cstructs.to_cstruct inner; - payload = Payload payload }) + need_space_for inner 14 "TCP header" >>= fun () -> + let src = Cstructs.BE.get_uint16 inner 0 in + let dst = Cstructs.BE.get_uint16 inner 2 in + let offres = Cstructs.get_uint8 inner (2 + 2 + 4 + 4) in + let flags = Cstructs.get_uint8 inner (2 + 2 + 4 + 4 + 1) in + need_space_for inner ((offres lsr 4) * 4) "TCP options" >>= fun () -> + let payload = + Cstructs.shift inner ((offres lsr 4) * 4) |> Cstructs.to_cstruct + in + let syn = flags land (1 lsl 1) > 0 in + let rst = flags land (1 lsl 2) > 0 in + Ok + (Tcp + { + src; + dst; + syn; + rst; + raw = Cstructs.to_cstruct inner; + payload = Payload payload; + }) | 17 -> - let raw = Cstructs.to_cstruct inner in - need_space_for inner 8 "UDP header" - >>= fun () -> - let src = Cstructs.BE.get_uint16 inner 0 in - let dst = Cstructs.BE.get_uint16 inner 2 in - let len = Cstructs.BE.get_uint16 inner 4 in - let payload = Cstructs.shift inner 8 |> Cstructs.to_cstruct in - let len = len - 8 in (* subtract header length *) - Ok (Udp { src; dst; len; raw; payload = Payload payload }) - | _ -> - Ok Unknown ) - >>= fun payload -> - Ok ({ src; dst; dnf; ihl; ttl; raw; payload }) + let raw = Cstructs.to_cstruct inner in + need_space_for inner 8 "UDP header" >>= fun () -> + let src = Cstructs.BE.get_uint16 inner 0 in + let dst = Cstructs.BE.get_uint16 inner 2 in + let len = Cstructs.BE.get_uint16 inner 4 in + let payload = Cstructs.shift inner 8 |> Cstructs.to_cstruct in + let len = len - 8 in + (* subtract header length *) + Ok (Udp { src; dst; len; raw; payload = Payload payload }) + | _ -> Ok Unknown) + >>= fun payload -> Ok { src; dst; dnf; ihl; ttl; raw; payload } let parse bufs = try - need_space_for bufs 14 "ethernet frame" - >>= fun () -> - let ethertype = Cstructs.BE.get_uint16 bufs 12 in + need_space_for bufs 14 "ethernet frame" >>= fun () -> + let ethertype = Cstructs.BE.get_uint16 bufs 12 in let dst_option = Cstructs.sub bufs 0 6 |> Cstructs.to_string |> Macaddr.of_octets in let src_option = Cstructs.sub bufs 6 6 |> Cstructs.to_string |> Macaddr.of_octets in - match dst_option, src_option with - | Error (`Msg m), _ -> errorf "failed to parse ethernet destination MAC: %s" m + match (dst_option, src_option) with + | Error (`Msg m), _ -> + errorf "failed to parse ethernet destination MAC: %s" m | _, Error (`Msg m) -> errorf "failed to parse ethernet source MAC: %s" m | Ok dst, Ok src -> - let inner = Cstructs.shift bufs 14 in - ( match ethertype with - | 0x0800 -> - ( match ipv4 inner with - | Error x -> Error x - | Ok ipv4 -> Ok (Ipv4 ipv4) ) - | 0x0806 -> - need_space_for inner 2 "ARP header" - >>= fun () -> - let code = Cstructs.BE.get_uint16 inner 6 in - let op = match code with 1 -> `Request | 2 -> `Reply | _ -> `Unknown in - Ok (Arp { op }) - | _ -> - (* This is going to be quite common e.g. with IPv6 *) - Ok Unknown ) - >>= fun payload -> - Ok (Ethernet { src; dst; payload }) - with e -> - errorf "Failed to parse ethernet frame: %a" Fmt.exn e + let inner = Cstructs.shift bufs 14 in + (match ethertype with + | 0x0800 -> ( + match ipv4 inner with + | Error x -> Error x + | Ok ipv4 -> Ok (Ipv4 ipv4)) + | 0x0806 -> + need_space_for inner 2 "ARP header" >>= fun () -> + let code = Cstructs.BE.get_uint16 inner 6 in + let op = + match code with 1 -> `Request | 2 -> `Reply | _ -> `Unknown + in + Ok (Arp { op }) + | _ -> + (* This is going to be quite common e.g. with IPv6 *) + Ok Unknown) + >>= fun payload -> Ok (Ethernet { src; dst; payload }) + with e -> errorf "Failed to parse ethernet frame: %a" Fmt.exn e File "src/hostnet/hostnet_dhcp.ml", line 1, characters 0-0: diff --git a/_build/default/src/hostnet/hostnet_dhcp.ml b/_build/default/src/hostnet/.formatted/hostnet_dhcp.ml index b7c2701..c7e28d4 100644 --- a/_build/default/src/hostnet/hostnet_dhcp.ml +++ b/_build/default/src/hostnet/.formatted/hostnet_dhcp.ml @@ -9,32 +9,29 @@ module Log = (val Logs.src_log src : Logs.LOG) (* Global configuration: options, gateway etc *) let global_dhcp_configuration = ref None +let update_global_configuration x = global_dhcp_configuration := x -let update_global_configuration x = - global_dhcp_configuration := x - -module Make (Clock: Mirage_clock.MCLOCK) (Netif: Mirage_net.S) = struct - +module Make (Clock : Mirage_clock.MCLOCK) (Netif : Mirage_net.S) = struct type t = { - netif: Netif.t; - server_macaddr: Macaddr.t; - get_dhcp_configuration: unit -> Dhcp_server.Config.t; + netif : Netif.t; + server_macaddr : Macaddr.t; + get_dhcp_configuration : unit -> Dhcp_server.Config.t; } (* Compute the smallest IPv4 network which includes both [a_ip] and all [other_ips]. *) let rec smallest_prefix a_ip other_ips = function - | 0 -> Ipaddr.V4.Prefix.global - | bits -> - let prefix = Ipaddr.V4.Prefix.make bits a_ip in - if List.for_all (fun b_ip -> Ipaddr.V4.Prefix.mem b_ip prefix) other_ips - then prefix - else smallest_prefix a_ip other_ips (bits - 1) + | 0 -> Ipaddr.V4.Prefix.global + | bits -> + let prefix = Ipaddr.V4.Prefix.make bits a_ip in + if List.for_all (fun b_ip -> Ipaddr.V4.Prefix.mem b_ip prefix) other_ips + then prefix + else smallest_prefix a_ip other_ips (bits - 1) let maximum_ip = function - | [] -> Ipaddr.V4.of_string_exn "0.0.0.0" - | hd::tl -> - List.fold_left (fun acc x -> if compare acc x > 0 then acc else x) hd tl + | [] -> Ipaddr.V4.of_string_exn "0.0.0.0" + | hd :: tl -> + List.fold_left (fun acc x -> if compare acc x > 0 then acc else x) hd tl let very_long_lease = Int32.max_int (* over 68 years *) @@ -43,57 +40,93 @@ module Make (Clock: Mirage_clock.MCLOCK) (Netif: Mirage_net.S) = struct let open Dhcp_server.Config in let low_ip = let open Ipaddr.V4 in - let all_static_ips = [ c.Configuration.gateway_ip; c.Configuration.lowest_ip ] in + let all_static_ips = + [ c.Configuration.gateway_ip; c.Configuration.lowest_ip ] + in let highest = maximum_ip all_static_ips in - of_int32 @@ Int32.succ (to_int32 highest) in - let ip_list = [ c.Configuration.gateway_ip; low_ip; c.Configuration.highest_ip ] in + of_int32 @@ Int32.succ (to_int32 highest) + in + let ip_list = + [ c.Configuration.gateway_ip; low_ip; c.Configuration.highest_ip ] + in let prefix = smallest_prefix c.Configuration.lowest_ip ip_list 32 in (* Use the dhcp.json in preference, otherwise fall back to the DNS configuration *) - let domain_search = match !global_dhcp_configuration with - | Some { Configuration.Dhcp_configuration.searchDomains = domain_search; _ } when domain_search <> [] -> domain_search - | _ -> c.dns.Dns_forward.Config.search in + let domain_search = + match !global_dhcp_configuration with + | Some + { Configuration.Dhcp_configuration.searchDomains = domain_search; _ } + when domain_search <> [] -> + domain_search + | _ -> c.dns.Dns_forward.Config.search + in let get_dhcp_configuration () = (* The domain search is encoded using the scheme used for DNS names *) let domain_search = let open Dns in let b = Cstruct.create 1024 in - let _, n, _ = List.fold_left (fun (map, n, buffer) name -> - Name.marshal map n buffer (Name.of_string name) - ) (Name.Map.empty, 0, b) domain_search in - Cstruct.(to_string (sub b 0 n)) in + let _, n, _ = + List.fold_left + (fun (map, n, buffer) name -> + Name.marshal map n buffer (Name.of_string name)) + (Name.Map.empty, 0, b) domain_search + in + Cstruct.(to_string (sub b 0 n)) + in (* Use the domainName from the command-line if present, otherwise use the dhcp.json file *) - let domain_name = match c.Configuration.domain, !global_dhcp_configuration with + let domain_name = + match (c.Configuration.domain, !global_dhcp_configuration) with | Some domain_name, _ -> domain_name - | None, Some { Configuration.Dhcp_configuration.domainName = Some domain_name; _ } -> domain_name - | _, _ -> Configuration.default_domain in - let options = [ - Dhcp_wire.Routers [ c.Configuration.gateway_ip ]; - Dhcp_wire.Dns_servers [ c.Configuration.gateway_ip ]; - Dhcp_wire.Ntp_servers [ c.Configuration.gateway_ip ]; - Dhcp_wire.Broadcast_addr (Ipaddr.V4.Prefix.broadcast prefix); - Dhcp_wire.Subnet_mask (Ipaddr.V4.Prefix.netmask prefix); - ] in + | ( None, + Some + { + Configuration.Dhcp_configuration.domainName = Some domain_name; + _; + } ) -> + domain_name + | _, _ -> Configuration.default_domain + in + let options = + [ + Dhcp_wire.Routers [ c.Configuration.gateway_ip ]; + Dhcp_wire.Dns_servers [ c.Configuration.gateway_ip ]; + Dhcp_wire.Ntp_servers [ c.Configuration.gateway_ip ]; + Dhcp_wire.Broadcast_addr (Ipaddr.V4.Prefix.broadcast prefix); + Dhcp_wire.Subnet_mask (Ipaddr.V4.Prefix.netmask prefix); + ] + in (* domain_search and get_domain_name may produce an empty string, which is - * invalid, so only add the option if there is content *) - let options = if domain_search = "" then options - else Dhcp_wire.Domain_search domain_search :: options in - let options = if domain_name = "" then options - else Dhcp_wire.Domain_name domain_name :: options in + * invalid, so only add the option if there is content *) + let options = + if domain_search = "" then options + else Dhcp_wire.Domain_search domain_search :: options + in + let options = + if domain_name = "" then options + else Dhcp_wire.Domain_name domain_name :: options + in { - options = options; - hostname = "vpnkit"; (* it's us! *) - hosts = [ ]; + options; + hostname = "vpnkit"; + (* it's us! *) + hosts = []; (* This avoids clients seeing network glitches when the leases are renewed *) default_lease_time = very_long_lease; max_lease_time = very_long_lease; ip_addr = c.Configuration.gateway_ip; mac_addr = c.Configuration.server_macaddr; network = prefix; - range = Some (c.Configuration.lowest_ip, c.Configuration.lowest_ip); (* allow one dynamic client *) - } in + range = + Some (c.Configuration.lowest_ip, c.Configuration.lowest_ip) + (* allow one dynamic client *); + } + in - { server_macaddr = c.Configuration.server_macaddr; get_dhcp_configuration; netif } + { + server_macaddr = c.Configuration.server_macaddr; + get_dhcp_configuration; + netif; + } let of_interest mac dest = Macaddr.compare dest mac = 0 || not (Macaddr.is_unicast dest) @@ -107,79 +140,89 @@ module Make (Clock: Mirage_clock.MCLOCK) (Netif: Mirage_net.S) = struct let open Dhcp_server in match Dhcp_wire.pkt_of_buf buf (Cstruct.length buf) with | Error e -> - Log.err (fun f -> f "failed to parse DHCP packet: %s" e); - Lwt.return database - | Ok pkt -> - let elapsed_seconds = - Clock.elapsed_ns () - |> Duration.to_sec - |> Int32.of_int - in - match Input.input_pkt config database pkt elapsed_seconds with - | Input.Silence -> Lwt.return database - | Input.Update database -> - Log.debug (fun f -> f "lease database updated"); - Lwt.return database - | Input.Warning w -> - Log.warn (fun f -> f "%s" w); - Lwt.return database - | Input.Error e -> - Log.err (fun f -> f "%s" e); + Log.err (fun f -> f "failed to parse DHCP packet: %s" e); Lwt.return database - | Input.Reply (reply, database) -> - let open Dhcp_wire in - if pkt.op <> Dhcp_wire.BOOTREQUEST || not !logged_bootrequest - then Log.info (fun f -> - f "%s from %s" (op_to_string pkt.op) - (Macaddr.to_string (pkt.srcmac))); - logged_bootrequest := - !logged_bootrequest || (pkt.op = Dhcp_wire.BOOTREQUEST); - Netif.write net ~size:1500 (fun buf -> - Dhcp_wire.pkt_into_buf reply buf - ) >>= function - | Error e -> - Log.err (fun f -> f "failed to parse DHCP reply: %a" Netif.pp_error e); - Lwt.return database - | Ok () -> - let domain = List.fold_left (fun acc x -> match x with - | Domain_name y -> y - | _ -> acc) "unknown" reply.options in - let dns = List.fold_left (fun acc x -> match x with - | Dns_servers ys -> String.concat ", " (List.map Ipaddr.V4.to_string ys) - | _ -> acc) "none" reply.options in - let routers = List.fold_left (fun acc x -> match x with - | Routers ys -> String.concat ", " (List.map Ipaddr.V4.to_string ys) - | _ -> acc) "none" reply.options in - if reply.op <> Dhcp_wire.BOOTREPLY || not !logged_bootreply - then Log.info (fun f -> - f "%s to %s yiddr %a siddr %a dns %s router %s domain %s" - (op_to_string reply.op) (Macaddr.to_string (reply.dstmac)) - Ipaddr.V4.pp reply.yiaddr Ipaddr.V4.pp reply.siaddr - dns routers domain - ); - logged_bootreply := - !logged_bootreply || (reply.op = Dhcp_wire.BOOTREPLY); - Lwt.return database + | Ok pkt -> ( + let elapsed_seconds = + Clock.elapsed_ns () |> Duration.to_sec |> Int32.of_int + in + match Input.input_pkt config database pkt elapsed_seconds with + | Input.Silence -> Lwt.return database + | Input.Update database -> + Log.debug (fun f -> f "lease database updated"); + Lwt.return database + | Input.Warning w -> + Log.warn (fun f -> f "%s" w); + Lwt.return database + | Input.Error e -> + Log.err (fun f -> f "%s" e); + Lwt.return database + | Input.Reply (reply, database) -> ( + let open Dhcp_wire in + if pkt.op <> Dhcp_wire.BOOTREQUEST || not !logged_bootrequest then + Log.info (fun f -> + f "%s from %s" (op_to_string pkt.op) + (Macaddr.to_string pkt.srcmac)); + logged_bootrequest := + !logged_bootrequest || pkt.op = Dhcp_wire.BOOTREQUEST; + Netif.write net ~size:1500 (fun buf -> + Dhcp_wire.pkt_into_buf reply buf) + >>= function + | Error e -> + Log.err (fun f -> + f "failed to parse DHCP reply: %a" Netif.pp_error e); + Lwt.return database + | Ok () -> + let domain = + List.fold_left + (fun acc x -> match x with Domain_name y -> y | _ -> acc) + "unknown" reply.options + in + let dns = + List.fold_left + (fun acc x -> + match x with + | Dns_servers ys -> + String.concat ", " (List.map Ipaddr.V4.to_string ys) + | _ -> acc) + "none" reply.options + in + let routers = + List.fold_left + (fun acc x -> + match x with + | Routers ys -> + String.concat ", " (List.map Ipaddr.V4.to_string ys) + | _ -> acc) + "none" reply.options + in + if reply.op <> Dhcp_wire.BOOTREPLY || not !logged_bootreply then + Log.info (fun f -> + f "%s to %s yiddr %a siddr %a dns %s router %s domain %s" + (op_to_string reply.op) + (Macaddr.to_string reply.dstmac) + Ipaddr.V4.pp reply.yiaddr Ipaddr.V4.pp reply.siaddr dns + routers domain); + logged_bootreply := + !logged_bootreply || reply.op = Dhcp_wire.BOOTREPLY; + Lwt.return database)) let callback t buf = (* TODO: the scope of this reference ensures that the database won't actually remain updated after any particular transaction. In our case that's OK, because we only really want to serve one pre-allocated IP anyway, but this will present a problem if - that assumption ever changes. *) + that assumption ever changes. *) let database = ref (Dhcp_server.Lease.make_db ()) in match Ethernet.Packet.of_cstruct buf with - | Ok (pkt, _payload) when - of_interest t.server_macaddr pkt.Ethernet.Packet.destination -> - (match pkt.Ethernet.Packet.ethertype with - | `IPv4 -> - if Dhcp_wire.is_dhcp buf (Cstruct.length buf) then begin - input t.netif (t.get_dhcp_configuration ()) !database buf - >|= fun db -> - database := db - end - else - Lwt.return_unit - | _ -> Lwt.return_unit) + | Ok (pkt, _payload) + when of_interest t.server_macaddr pkt.Ethernet.Packet.destination -> ( + match pkt.Ethernet.Packet.ethertype with + | `IPv4 -> + if Dhcp_wire.is_dhcp buf (Cstruct.length buf) then + input t.netif (t.get_dhcp_configuration ()) !database buf + >|= fun db -> database := db + else Lwt.return_unit + | _ -> Lwt.return_unit) | _ -> Lwt.return_unit end File "src/dns_forward_lwt_unix/dns_forward_lwt_unix.ml", line 1, characters 0-0: diff --git a/_build/default/src/dns_forward_lwt_unix/dns_forward_lwt_unix.ml b/_build/default/src/dns_forward_lwt_unix/.formatted/dns_forward_lwt_unix.ml index 4ef24b7..c10b994 100644 --- a/_build/default/src/dns_forward_lwt_unix/dns_forward_lwt_unix.ml +++ b/_build/default/src/dns_forward_lwt_unix/.formatted/dns_forward_lwt_unix.ml @@ -24,17 +24,20 @@ let src = module Log = (val Logs.src_log src : Logs.LOG) let default_read_buffer_size = 65536 -let max_udp_length = 65507 (* IP datagram (65535) - IP header(20) - UDP header(8) *) +let max_udp_length = 65507 +(* IP datagram (65535) - IP header(20) - UDP header(8) *) let string_of_sockaddr = function -| Lwt_unix.ADDR_INET(ip, port) -> Unix.string_of_inet_addr ip ^ ":" ^ (string_of_int port) -| Lwt_unix.ADDR_UNIX path -> path + | Lwt_unix.ADDR_INET (ip, port) -> + Unix.string_of_inet_addr ip ^ ":" ^ string_of_int port + | Lwt_unix.ADDR_UNIX path -> path module Common = struct (** Both UDP and TCP *) type error = [ `Msg of string ] type write_error = Mirage_flow.write_error + let pp_error ppf (`Msg x) = Fmt.string ppf x let pp_write_error = Mirage_flow.pp_write_error let errorf fmt = Printf.ksprintf (fun s -> Lwt.return (Error (`Msg s))) fmt @@ -42,34 +45,37 @@ module Common = struct type address = Ipaddr.t * int let sockaddr_of_address (dst, dst_port) = - Unix.ADDR_INET(Unix.inet_addr_of_string @@ Ipaddr.to_string dst, dst_port) + Unix.ADDR_INET (Unix.inet_addr_of_string @@ Ipaddr.to_string dst, dst_port) let address_of_sockaddr = function - | Lwt_unix .ADDR_INET(ip, port) -> - ( try Some (Ipaddr.of_string_exn @@ Unix.string_of_inet_addr ip, port) with _ -> None ) - | _ -> None + | Lwt_unix.ADDR_INET (ip, port) -> ( + try Some (Ipaddr.of_string_exn @@ Unix.string_of_inet_addr ip, port) + with _ -> None) + | _ -> None let string_of_address (dst, dst_port) = - Ipaddr.to_string dst ^ ":" ^ (string_of_int dst_port) - - let getsockname fn_name fd_opt = match fd_opt with - | None -> failwith (fn_name ^ ": socket is closed") - | Some fd -> - begin match Lwt_unix.getsockname fd with - | Lwt_unix.ADDR_INET(iaddr, port) -> - Ipaddr.V4 (Ipaddr.V4.of_string_exn (Unix.string_of_inet_addr iaddr)), port - | _ -> invalid_arg (fn_name ^ ": passed a non-TCP socket") - end + Ipaddr.to_string dst ^ ":" ^ string_of_int dst_port + + let getsockname fn_name fd_opt = + match fd_opt with + | None -> failwith (fn_name ^ ": socket is closed") + | Some fd -> ( + match Lwt_unix.getsockname fd with + | Lwt_unix.ADDR_INET (iaddr, port) -> + ( Ipaddr.V4 + (Ipaddr.V4.of_string_exn (Unix.string_of_inet_addr iaddr)), + port ) + | _ -> invalid_arg (fn_name ^ ": passed a non-TCP socket")) end module Tcp = struct include Common type flow = { - mutable fd: Lwt_unix.file_descr option; - read_buffer_size: int; - mutable read_buffer: Cstruct.t; - address: address; + mutable fd : Lwt_unix.file_descr option; + read_buffer_size : int; + mutable read_buffer : Cstruct.t; + address : address; } let of_fd ~read_buffer_size address fd = @@ -79,7 +85,7 @@ module Tcp = struct let string_of_flow flow = Printf.sprintf "tcp -> %s" (string_of_address flow.address) - let connect ?(read_buffer_size=default_read_buffer_size) address = + let connect ?(read_buffer_size = default_read_buffer_size) address = let description = Printf.sprintf "tcp -> %s" (string_of_address address) in Log.debug (fun f -> f "%s: connect" description); @@ -87,116 +93,110 @@ module Tcp = struct let fd = Lwt_unix.socket Lwt_unix.PF_INET Lwt_unix.SOCK_STREAM 0 in Lwt.catch (fun () -> - Lwt_unix.connect fd sockaddr - >>= fun () -> - Lwt.return (Ok (of_fd ~read_buffer_size address fd)) - ) + Lwt_unix.connect fd sockaddr >>= fun () -> + Lwt.return (Ok (of_fd ~read_buffer_size address fd))) (fun e -> - Lwt_unix.close fd - >>= fun () -> - errorf "%s: Lwt_unix.connect: caught %s" description (Printexc.to_string e) - ) - - let read t = match t.fd with - | None -> Lwt.return (Ok `Eof) - | Some fd -> - if Cstruct.length t.read_buffer = 0 then t.read_buffer <- Cstruct.create t.read_buffer_size; - Lwt.catch - (fun () -> - Lwt_bytes.read fd t.read_buffer.Cstruct.buffer t.read_buffer.Cstruct.off t.read_buffer.Cstruct.len - >>= function - | 0 -> Lwt.return (Ok `Eof) - | n -> - let results = Cstruct.sub t.read_buffer 0 n in - t.read_buffer <- Cstruct.shift t.read_buffer n; - Lwt.return (Ok (`Data results)) - ) (fun e -> - Log.err (fun f -> f "%s: read caught %s returning Eof" - (string_of_flow t) - (Printexc.to_string e) - ); - Lwt.return (Ok `Eof) - ) - - let write t buf = match t.fd with - | None -> Lwt.return (Error `Closed) - | Some fd -> - Lwt.catch - (fun () -> - Lwt_cstruct.(complete (write fd) buf) - >>= fun () -> - Lwt.return (Ok ()) - ) (function - | Unix.Unix_error(Unix.ECONNRESET, _, _) -> Lwt.return (Error `Closed) - | e -> - Log.err (fun f -> f "%s: write caught %s returning Eof" - (string_of_flow t) - (Printexc.to_string e) - ); - Lwt.return (Error `Closed) - ) - - let writev t bufs = match t.fd with - | None -> Lwt.return (Error `Closed) - | Some fd -> - Lwt.catch - (fun () -> - let rec loop = function - | [] -> Lwt.return (Ok ()) - | buf :: bufs -> - Lwt_cstruct.(complete (write fd) buf) - >>= fun () -> - loop bufs in - loop bufs - ) (fun _e -> - Lwt.return (Error `Closed) - ) - - let close t = match t.fd with - | None -> Lwt.return_unit - | Some fd -> - t.fd <- None; - Log.debug (fun f -> f "%s: Tcp.close" (string_of_flow t)); - Lwt_unix.close fd - - let shutdown_read t = match t.fd with - | None -> Lwt.return_unit - | Some fd -> - Lwt.catch - (fun () -> - Lwt_unix.shutdown fd Unix.SHUTDOWN_RECEIVE; - Lwt.return_unit - ) (function - | Unix.Unix_error(Unix.ENOTCONN, _, _) -> Lwt.return_unit - | e -> - Log.err (fun f -> f "%s: Lwt_unix.shutdown receive caught %s" - (string_of_flow t) - (Printexc.to_string e) - ); - Lwt.return_unit - ) - - let shutdown_write t = match t.fd with - | None -> Lwt.return_unit - | Some fd -> - Lwt.catch - (fun () -> - Lwt_unix.shutdown fd Unix.SHUTDOWN_SEND; - Lwt.return_unit - ) (function - | Unix.Unix_error(Unix.ENOTCONN, _, _) -> Lwt.return_unit - | e -> - Log.err (fun f -> f "%s: Lwt_unix.shutdown send caught %s" - (string_of_flow t) - (Printexc.to_string e) - ); - Lwt.return_unit - ) + Lwt_unix.close fd >>= fun () -> + errorf "%s: Lwt_unix.connect: caught %s" description + (Printexc.to_string e)) + + let read t = + match t.fd with + | None -> Lwt.return (Ok `Eof) + | Some fd -> + if Cstruct.length t.read_buffer = 0 then + t.read_buffer <- Cstruct.create t.read_buffer_size; + Lwt.catch + (fun () -> + Lwt_bytes.read fd t.read_buffer.Cstruct.buffer + t.read_buffer.Cstruct.off t.read_buffer.Cstruct.len + >>= function + | 0 -> Lwt.return (Ok `Eof) + | n -> + let results = Cstruct.sub t.read_buffer 0 n in + t.read_buffer <- Cstruct.shift t.read_buffer n; + Lwt.return (Ok (`Data results))) + (fun e -> + Log.err (fun f -> + f "%s: read caught %s returning Eof" (string_of_flow t) + (Printexc.to_string e)); + Lwt.return (Ok `Eof)) + + let write t buf = + match t.fd with + | None -> Lwt.return (Error `Closed) + | Some fd -> + Lwt.catch + (fun () -> + Lwt_cstruct.(complete (write fd) buf) >>= fun () -> + Lwt.return (Ok ())) + (function + | Unix.Unix_error (Unix.ECONNRESET, _, _) -> + Lwt.return (Error `Closed) + | e -> + Log.err (fun f -> + f "%s: write caught %s returning Eof" (string_of_flow t) + (Printexc.to_string e)); + Lwt.return (Error `Closed)) + + let writev t bufs = + match t.fd with + | None -> Lwt.return (Error `Closed) + | Some fd -> + Lwt.catch + (fun () -> + let rec loop = function + | [] -> Lwt.return (Ok ()) + | buf :: bufs -> + Lwt_cstruct.(complete (write fd) buf) >>= fun () -> loop bufs + in + loop bufs) + (fun _e -> Lwt.return (Error `Closed)) + + let close t = + match t.fd with + | None -> Lwt.return_unit + | Some fd -> + t.fd <- None; + Log.debug (fun f -> f "%s: Tcp.close" (string_of_flow t)); + Lwt_unix.close fd + + let shutdown_read t = + match t.fd with + | None -> Lwt.return_unit + | Some fd -> + Lwt.catch + (fun () -> + Lwt_unix.shutdown fd Unix.SHUTDOWN_RECEIVE; + Lwt.return_unit) + (function + | Unix.Unix_error (Unix.ENOTCONN, _, _) -> Lwt.return_unit + | e -> + Log.err (fun f -> + f "%s: Lwt_unix.shutdown receive caught %s" + (string_of_flow t) (Printexc.to_string e)); + Lwt.return_unit) + + let shutdown_write t = + match t.fd with + | None -> Lwt.return_unit + | Some fd -> + Lwt.catch + (fun () -> + Lwt_unix.shutdown fd Unix.SHUTDOWN_SEND; + Lwt.return_unit) + (function + | Unix.Unix_error (Unix.ENOTCONN, _, _) -> Lwt.return_unit + | e -> + Log.err (fun f -> + f "%s: Lwt_unix.shutdown send caught %s" (string_of_flow t) + (Printexc.to_string e)); + Lwt.return_unit) type server = { - mutable server_fd: Lwt_unix.file_descr option; - read_buffer_size: int; - address: address; + mutable server_fd : Lwt_unix.file_descr option; + read_buffer_size : int; + address : address; } let string_of_server t = @@ -206,106 +206,96 @@ module Tcp = struct let fd = Lwt_unix.socket Lwt_unix.PF_INET Lwt_unix.SOCK_STREAM 0 in Lwt.catch (fun () -> - Lwt_unix.setsockopt fd Lwt_unix.SO_REUSEADDR true; - Lwt_unix.bind fd (sockaddr_of_address address) >|= fun () -> - Ok { server_fd = Some fd; - read_buffer_size = default_read_buffer_size; - address } - ) (fun e -> - Lwt_unix.close fd - >>= fun () -> - errorf "listen:tcp <- %s caught %s" - (string_of_address address) - (Printexc.to_string e) - ) + Lwt_unix.setsockopt fd Lwt_unix.SO_REUSEADDR true; + Lwt_unix.bind fd (sockaddr_of_address address) >|= fun () -> + Ok + { + server_fd = Some fd; + read_buffer_size = default_read_buffer_size; + address; + }) + (fun e -> + Lwt_unix.close fd >>= fun () -> + errorf "listen:tcp <- %s caught %s" + (string_of_address address) + (Printexc.to_string e)) let getsockname server = getsockname "Tcp.getsockname" server.server_fd - let shutdown server = match server.server_fd with - | None -> Lwt.return_unit - | Some fd -> - server.server_fd <- None; - Log.debug (fun f -> f "%s: close server socket" (string_of_server server)); - Lwt_unix.close fd + let shutdown server = + match server.server_fd with + | None -> Lwt.return_unit + | Some fd -> + server.server_fd <- None; + Log.debug (fun f -> + f "%s: close server socket" (string_of_server server)); + Lwt_unix.close fd - let listen (server: server) cb = + let listen (server : server) cb = let rec loop fd = - Lwt_unix.accept fd - >>= fun (client, sockaddr) -> + Lwt_unix.accept fd >>= fun (client, sockaddr) -> let read_buffer_size = server.read_buffer_size in - Lwt.async - (fun () -> - Lwt.catch - (fun () -> - ( match address_of_sockaddr sockaddr with - | Some address -> - Lwt.return address - | _ -> - Lwt.fail (Failure "unknown incoming socket address") - ) >>= fun address -> - Lwt.return (Some (of_fd ~read_buffer_size address client)) - ) (fun _e -> - Lwt_unix.close client - >>= fun () -> - Lwt.return_none - ) - >>= function - | None -> Lwt.return_unit - | Some flow -> - Lwt.finalize - (fun () -> - Lwt.catch - (fun () -> cb flow) - (fun e -> - Log.info (fun f -> f "tcp:%s <- %s: caught %s so closing flow" - (string_of_server server) - (string_of_sockaddr sockaddr) - (Printexc.to_string e) - ); - Lwt.return_unit) - ) (fun () -> close flow) - ); - loop fd in + Lwt.async (fun () -> + Lwt.catch + (fun () -> + (match address_of_sockaddr sockaddr with + | Some address -> Lwt.return address + | _ -> Lwt.fail (Failure "unknown incoming socket address")) + >>= fun address -> + Lwt.return (Some (of_fd ~read_buffer_size address client))) + (fun _e -> Lwt_unix.close client >>= fun () -> Lwt.return_none) + >>= function + | None -> Lwt.return_unit + | Some flow -> + Lwt.finalize + (fun () -> + Lwt.catch + (fun () -> cb flow) + (fun e -> + Log.info (fun f -> + f "tcp:%s <- %s: caught %s so closing flow" + (string_of_server server) + (string_of_sockaddr sockaddr) + (Printexc.to_string e)); + Lwt.return_unit)) + (fun () -> close flow)); + loop fd + in match server.server_fd with | None -> () | Some fd -> - Lwt.async - (fun () -> - Lwt.catch - (fun () -> - Lwt.finalize - (fun () -> - Lwt_unix.listen fd 32; - loop fd - ) (fun () -> - shutdown server - ) - ) (fun e -> - Log.info (fun f -> f "%s: caught %s so shutting down server" - (string_of_server server) - (Printexc.to_string e) - ); - Lwt.return_unit - ) - ) + Lwt.async (fun () -> + Lwt.catch + (fun () -> + Lwt.finalize + (fun () -> + Lwt_unix.listen fd 32; + loop fd) + (fun () -> shutdown server)) + (fun e -> + Log.info (fun f -> + f "%s: caught %s so shutting down server" + (string_of_server server) (Printexc.to_string e)); + Lwt.return_unit)) end module Udp = struct - include Common type flow = { - mutable fd: Lwt_unix.file_descr option; - read_buffer_size: int; - mutable already_read: Cstruct.t option; - sockaddr: Unix.sockaddr; - address: address; + mutable fd : Lwt_unix.file_descr option; + read_buffer_size : int; + mutable already_read : Cstruct.t option; + sockaddr : Unix.sockaddr; + address : address; } - let string_of_flow t = Printf.sprintf "udp -> %s" (string_of_address t.address) + let string_of_flow t = + Printf.sprintf "udp -> %s" (string_of_address t.address) - let of_fd ?(read_buffer_size = max_udp_length) ?(already_read = None) sockaddr address fd = + let of_fd ?(read_buffer_size = max_udp_length) ?(already_read = None) sockaddr + address fd = { fd = Some fd; read_buffer_size; already_read; sockaddr; address } let connect ?read_buffer_size address = @@ -313,72 +303,71 @@ module Udp = struct let fd = Lwt_unix.socket Lwt_unix.PF_INET Lwt_unix.SOCK_DGRAM 0 in (* Win32 requires all sockets to be bound however macOS and Linux don't *) - Lwt.catch (fun () -> - Lwt_unix.bind fd (Lwt_unix.ADDR_INET(Unix.inet_addr_any, 0)) - ) (fun _ -> Lwt.return ()) + Lwt.catch + (fun () -> Lwt_unix.bind fd (Lwt_unix.ADDR_INET (Unix.inet_addr_any, 0))) + (fun _ -> Lwt.return ()) >|= fun () -> let sockaddr = sockaddr_of_address address in Ok (of_fd ?read_buffer_size sockaddr address fd) - let read t = match t.fd, t.already_read with - | None, _ -> Lwt.return (Ok `Eof) - | Some _, Some data when Cstruct.length data > 0 -> - t.already_read <- Some (Cstruct.sub data 0 0); (* next read is `Eof *) - Lwt.return (Ok (`Data data)) - | Some _, Some _ -> - Lwt.return (Ok `Eof) - | Some fd, None -> - let buffer = Cstruct.create t.read_buffer_size in - let bytes = Bytes.make t.read_buffer_size '\000' in - Lwt.catch - (fun () -> - (* Lwt on Win32 doesn't support Lwt_bytes.recvfrom *) - Lwt_unix.recvfrom fd bytes 0 (Bytes.length bytes) [] - >>= fun (n, _) -> - Cstruct.blit_from_bytes bytes 0 buffer 0 n; - let response = Cstruct.sub buffer 0 n in - Lwt.return (Ok (`Data response)) - ) (fun e -> - Log.err (fun f -> f "%s: recvfrom caught %s returning Eof" - (string_of_flow t) - (Printexc.to_string e) - ); - Lwt.return (Ok `Eof) - ) - - let write t buf = match t.fd with - | None -> Lwt.return (Error `Closed) - | Some fd -> - Lwt.catch - (fun () -> - (* Lwt on Win32 doesn't support Lwt_bytes.sendto *) - let bytes = Bytes.make (Cstruct.length buf) '\000' in - Cstruct.blit_to_bytes buf 0 bytes 0 (Cstruct.length buf); - Lwt_unix.sendto fd bytes 0 (Bytes.length bytes) [] t.sockaddr - >|= fun _n -> Ok () - ) (fun e -> - Log.err (fun f -> f "%s: sendto caught %s returning Eof" - (string_of_flow t) - (Printexc.to_string e) - ); - Lwt.return (Error `Closed) - ) + let read t = + match (t.fd, t.already_read) with + | None, _ -> Lwt.return (Ok `Eof) + | Some _, Some data when Cstruct.length data > 0 -> + t.already_read <- Some (Cstruct.sub data 0 0); + (* next read is `Eof *) + Lwt.return (Ok (`Data data)) + | Some _, Some _ -> Lwt.return (Ok `Eof) + | Some fd, None -> + let buffer = Cstruct.create t.read_buffer_size in + let bytes = Bytes.make t.read_buffer_size '\000' in + Lwt.catch + (fun () -> + (* Lwt on Win32 doesn't support Lwt_bytes.recvfrom *) + Lwt_unix.recvfrom fd bytes 0 (Bytes.length bytes) [] + >>= fun (n, _) -> + Cstruct.blit_from_bytes bytes 0 buffer 0 n; + let response = Cstruct.sub buffer 0 n in + Lwt.return (Ok (`Data response))) + (fun e -> + Log.err (fun f -> + f "%s: recvfrom caught %s returning Eof" (string_of_flow t) + (Printexc.to_string e)); + Lwt.return (Ok `Eof)) + + let write t buf = + match t.fd with + | None -> Lwt.return (Error `Closed) + | Some fd -> + Lwt.catch + (fun () -> + (* Lwt on Win32 doesn't support Lwt_bytes.sendto *) + let bytes = Bytes.make (Cstruct.length buf) '\000' in + Cstruct.blit_to_bytes buf 0 bytes 0 (Cstruct.length buf); + Lwt_unix.sendto fd bytes 0 (Bytes.length bytes) [] t.sockaddr + >|= fun _n -> Ok ()) + (fun e -> + Log.err (fun f -> + f "%s: sendto caught %s returning Eof" (string_of_flow t) + (Printexc.to_string e)); + Lwt.return (Error `Closed)) let writev t bufs = write t (Cstruct.concat bufs) - let close t = match t.fd with - | None -> Lwt.return_unit - | Some fd -> - t.fd <- None; - Log.debug (fun f -> f "%s: close" (string_of_flow t)); - Lwt_unix.close fd + let close t = + match t.fd with + | None -> Lwt.return_unit + | Some fd -> + t.fd <- None; + Log.debug (fun f -> f "%s: close" (string_of_flow t)); + Lwt_unix.close fd let shutdown_read _t = Lwt.return_unit let shutdown_write _t = Lwt.return_unit type server = { - mutable server_fd: Lwt_unix.file_descr option; - address: address; + mutable server_fd : Lwt_unix.file_descr option; + address : address; } let string_of_server t = @@ -392,16 +381,18 @@ module Udp = struct let sockaddr = sockaddr_of_address address in Lwt_unix.bind fd sockaddr >|= fun () -> Ok { server_fd = Some fd; address } - with - | e -> errorf "udp:%s: bind caught %s" - (string_of_address address) (Printexc.to_string e) + with e -> + errorf "udp:%s: bind caught %s" + (string_of_address address) + (Printexc.to_string e) - let shutdown t = match t.server_fd with - | None -> Lwt.return_unit - | Some fd -> - t.server_fd <- None; - Log.debug (fun f -> f "%s: close" (string_of_server t)); - Lwt_unix.close fd + let shutdown t = + match t.server_fd with + | None -> Lwt.return_unit + | Some fd -> + t.server_fd <- None; + Log.debug (fun f -> f "%s: close" (string_of_server t)); + Lwt_unix.close fd let listen t flow_cb = let buffer = Cstruct.create max_udp_length in @@ -412,64 +403,69 @@ module Udp = struct let rec loop () = Lwt.catch (fun () -> - (* Lwt on Win32 doesn't support Lwt_bytes.recvfrom *) - Lwt_unix.recvfrom fd bytes 0 (Bytes.length bytes) [] - >>= fun (n, sockaddr) -> - Cstruct.blit_from_bytes bytes 0 buffer 0 n; - let data = Cstruct.sub buffer 0 n in - (* construct a flow with this buffer available for reading *) - ( match address_of_sockaddr sockaddr with - | Some address -> Lwt.return address - | None -> Lwt.fail (Failure "failed to discover incoming socket address") - ) >>= fun address -> - let flow = of_fd ~read_buffer_size:0 ~already_read:(Some data) sockaddr address fd in - Lwt.async - (fun () -> - Lwt.catch - (fun () -> flow_cb flow) - (fun e -> - Log.info (fun f -> f "%s: listen callback caught: %s" - (string_of_server t) - (Printexc.to_string e) - ); - Lwt.return_unit - ) - ); - Lwt.return true - ) (fun e -> - Log.err (fun f -> f "%s: listen caught %s shutting down server" - (string_of_server t) - (Printexc.to_string e) - ); - Lwt.return false - ) + (* Lwt on Win32 doesn't support Lwt_bytes.recvfrom *) + Lwt_unix.recvfrom fd bytes 0 (Bytes.length bytes) [] + >>= fun (n, sockaddr) -> + Cstruct.blit_from_bytes bytes 0 buffer 0 n; + let data = Cstruct.sub buffer 0 n in + (* construct a flow with this buffer available for reading *) + (match address_of_sockaddr sockaddr with + | Some address -> Lwt.return address + | None -> + Lwt.fail + (Failure "failed to discover incoming socket address")) + >>= fun address -> + let flow = + of_fd ~read_buffer_size:0 ~already_read:(Some data) sockaddr + address fd + in + Lwt.async (fun () -> + Lwt.catch + (fun () -> flow_cb flow) + (fun e -> + Log.info (fun f -> + f "%s: listen callback caught: %s" + (string_of_server t) (Printexc.to_string e)); + Lwt.return_unit)); + Lwt.return true) + (fun e -> + Log.err (fun f -> + f "%s: listen caught %s shutting down server" + (string_of_server t) (Printexc.to_string e)); + Lwt.return false) >>= function | false -> Lwt.return_unit - | true -> loop () in + | true -> loop () + in Lwt.async loop end module Time = struct let sleep_ns ns = Lwt_unix.sleep (Duration.to_f ns) end + module Clock = Mclock module R = struct open Dns_forward - module Udp_client = Rpc.Client.Nonpersistent.Make(Udp)(Framing.Udp(Udp))(Time) - module Udp = Resolver.Make(Udp_client)(Time)(Clock) - module Tcp_client = Rpc.Client.Persistent.Make(Tcp)(Framing.Tcp(Tcp))(Time) - module Tcp = Resolver.Make(Tcp_client)(Time)(Clock) + module Udp_client = + Rpc.Client.Nonpersistent.Make (Udp) (Framing.Udp (Udp)) (Time) + + module Udp = Resolver.Make (Udp_client) (Time) (Clock) + + module Tcp_client = + Rpc.Client.Persistent.Make (Tcp) (Framing.Tcp (Tcp)) (Time) + + module Tcp = Resolver.Make (Tcp_client) (Time) (Clock) end module Server = struct open Dns_forward - module Udp_server = Rpc.Server.Make(Udp)(Framing.Udp(Udp))(Time) - module Udp = Server.Make(Udp_server)(R.Udp) - - module Tcp_server = Rpc.Server.Make(Tcp)(Framing.Tcp(Tcp))(Time) - module Tcp = Server.Make(Tcp_server)(R.Tcp) + module Udp_server = Rpc.Server.Make (Udp) (Framing.Udp (Udp)) (Time) + module Udp = Server.Make (Udp_server) (R.Udp) + module Tcp_server = Rpc.Server.Make (Tcp) (Framing.Tcp (Tcp)) (Time) + module Tcp = Server.Make (Tcp_server) (R.Tcp) end module Resolver = R File "src/hostnet/capture.ml", line 1, characters 0-0: diff --git a/_build/default/src/hostnet/capture.ml b/_build/default/src/hostnet/.formatted/capture.ml index 43d1176..be20413 100644 --- a/_build/default/src/hostnet/capture.ml +++ b/_build/default/src/hostnet/.formatted/capture.ml @@ -7,48 +7,46 @@ let src = module Log = (val Logs.src_log src : Logs.LOG) -module Make(Input: Sig.VMNET) = struct - +module Make (Input : Sig.VMNET) = struct type fd = Input.fd - type error = [Mirage_net.Net.error | `Unknown of string] + type error = [ Mirage_net.Net.error | `Unknown of string ] let pp_error ppf = function - | #Mirage_net.Net.error as e -> Mirage_net.Net.pp_error ppf e - | `Unknown s -> Fmt.pf ppf "unknown: %s" s + | #Mirage_net.Net.error as e -> Mirage_net.Net.pp_error ppf e + | `Unknown s -> Fmt.pf ppf "unknown: %s" s let lift_error = function - | Ok x -> Ok x - | Error (#Mirage_net.Net.error as e) -> Error e - | Error e -> Fmt.kstr (fun s -> Error (`Unknown s)) "%a" Input.pp_error e + | Ok x -> Ok x + | Error (#Mirage_net.Net.error as e) -> Error e + | Error e -> Fmt.kstr (fun s -> Error (`Unknown s)) "%a" Input.pp_error e type packet = { - id: int; (* unique id *) - len: int; - orig_len: int; - time: float; - bufs: Cstruct.t list; + id : int; (* unique id *) + len : int; + orig_len : int; + time : float; + bufs : Cstruct.t list; } type rule = { - predicate: Frame.t -> bool; - snaplen: int; - limit: int; - packets: packet Queue.t; - packets_c: unit Lwt_condition.t; - mutable nr_bytes: int; + predicate : Frame.t -> bool; + snaplen : int; + limit : int; + packets : packet Queue.t; + packets_c : unit Lwt_condition.t; + mutable nr_bytes : int; } let initial_packet_id = 0 let next_packet_id = ref initial_packet_id let push rule bufs = - let orig_len = List.fold_left (+) 0 (List.map Cstruct.length bufs) in + let orig_len = List.fold_left ( + ) 0 (List.map Cstruct.length bufs) in let bufs = - if Cstructs.len bufs > rule.snaplen - then Cstructs.sub bufs 0 rule.snaplen + if Cstructs.len bufs > rule.snaplen then Cstructs.sub bufs 0 rule.snaplen else bufs in - let len = List.fold_left (+) 0 (List.map Cstruct.length bufs) in + let len = List.fold_left ( + ) 0 (List.map Cstruct.length bufs) in let time = Unix.gettimeofday () in let id = !next_packet_id in incr next_packet_id; @@ -58,7 +56,7 @@ module Make(Input: Sig.VMNET) = struct rule.nr_bytes <- rule.nr_bytes + len; while rule.nr_bytes > rule.limit do let to_drop = Queue.pop rule.packets in - rule.nr_bytes <- rule.nr_bytes - to_drop.len; + rule.nr_bytes <- rule.nr_bytes - to_drop.len done let write_file_header file_header_buf rule = @@ -74,7 +72,7 @@ module Make(Input: Sig.VMNET) = struct let frame_header frame_header_buf p = let secs = Int32.of_float p.time in - let usecs = Int32.of_float (1e6 *. (p.time -. (floor p.time))) in + let usecs = Int32.of_float (1e6 *. (p.time -. floor p.time)) in let open Pcap.LE in set_pcap_packet_ts_sec frame_header_buf secs; set_pcap_packet_ts_usec frame_header_buf usecs; @@ -91,30 +89,36 @@ module Make(Input: Sig.VMNET) = struct let rec wait () = let new_packets = Queue.fold - (fun acc p -> - if p.id > !last_seen_packet_id - then p :: acc - else acc - ) [] rule.packets |> List.rev in - if new_packets = [] then begin - Lwt_condition.wait rule.packets_c - >>= fun () -> - wait () - end else Lwt.return new_packets in - wait () - >>= fun new_packets -> + (fun acc p -> if p.id > !last_seen_packet_id then p :: acc else acc) + [] rule.packets + |> List.rev + in + if new_packets = [] then + Lwt_condition.wait rule.packets_c >>= fun () -> wait () + else Lwt.return new_packets + in + wait () >>= fun new_packets -> (* We could note the number of dropped packets here *) - last_seen_packet_id := List.fold_left max !last_seen_packet_id (List.map (fun p -> p.id) new_packets); - let marshalled_packets = List.map (fun p -> - let header = frame_header (Cstruct.create Pcap.sizeof_pcap_packet) p in - header :: p.bufs - ) new_packets in - Lwt.return (Some (List.concat marshalled_packets)) in + last_seen_packet_id := + List.fold_left max !last_seen_packet_id + (List.map (fun p -> p.id) new_packets); + let marshalled_packets = + List.map + (fun p -> + let header = + frame_header (Cstruct.create Pcap.sizeof_pcap_packet) p + in + header :: p.bufs) + new_packets + in + Lwt.return (Some (List.concat marshalled_packets)) + in Lwt_stream.(append header (from body)) let pcap rule = let stat () = - Vfs.ok { Vfs.perm = `Normal; length = Int64.of_int rule.nr_bytes } in + Vfs.ok { Vfs.perm = `Normal; length = Int64.of_int rule.nr_bytes } + in let remove () = Vfs.error "remove()" in let truncate _size = Vfs.error "truncate" in let chmod _perm = Vfs.error "chmod" in @@ -128,29 +132,41 @@ module Make(Input: Sig.VMNET) = struct (* Capture a copy of the packet queue and synthesize a (lazily-marshalled) view of the data *) let length, fragments = - let hdr = 0, fun () -> file_header_buf in + let hdr = (0, fun () -> file_header_buf) in let offset = Cstruct.length file_header_buf in - let _, packets = Queue.fold (fun (offset, acc) pkt -> - let packet_hdr = offset, fun () -> frame_header frame_header_buf pkt in - let offset = offset + (Cstruct.length frame_header_buf) in - (* assemble packet bodies reversed, in a reversed list of packets *) - let offset, packet_bodies = List.fold_left (fun (offset, acc) buf -> - let this = offset, fun () -> buf in - offset + (Cstruct.length buf), this :: acc - ) (offset, []) pkt.bufs in - offset, packet_bodies @ [ packet_hdr ] @ acc - ) (offset, []) rule.packets in - let length = match packets with - | [] -> Cstruct.length file_header_buf - | (x, buf_fn) :: _ -> x + (Cstruct.length (buf_fn ())) in - length, hdr :: (List.rev packets) in + let _, packets = + Queue.fold + (fun (offset, acc) pkt -> + let packet_hdr = + (offset, fun () -> frame_header frame_header_buf pkt) + in + let offset = offset + Cstruct.length frame_header_buf in + (* assemble packet bodies reversed, in a reversed list of packets *) + let offset, packet_bodies = + List.fold_left + (fun (offset, acc) buf -> + let this = (offset, fun () -> buf) in + (offset + Cstruct.length buf, this :: acc)) + (offset, []) pkt.bufs + in + (offset, packet_bodies @ [ packet_hdr ] @ acc)) + (offset, []) rule.packets + in + let length = + match packets with + | [] -> Cstruct.length file_header_buf + | (x, buf_fn) :: _ -> x + Cstruct.length (buf_fn ()) + in + (length, hdr :: List.rev packets) + in let read ~offset ~count = (* Check if we try to read beyond the end of the file *) let offset = Int64.to_int offset in let dst_len = min count (length - offset) in let dst = Cstruct.create dst_len in - List.iter (fun (offset', src_fn) -> + List.iter + (fun (offset', src_fn) -> let src = src_fn () in let count' = Cstruct.length src in (* Consider 4 cases of this packet relative to the requested region @@ -158,35 +174,34 @@ module Make(Input: Sig.VMNET) = struct - this packet is completely after - this packet partially overlaps from the left - this packet partially overlaps with the right *) - let before = offset' + count' < offset (* completely before *) - and after = (offset + count) < offset' (* completely after *) in + let before = offset' + count' < offset (* completely before *) + and after = offset + count < offset' (* completely after *) in let srcoff, dstoff, len = - if before || after - then 0, 0, 0 - else - if offset' > offset then begin + if before || after then (0, 0, 0) + else if offset' > offset then let dstoff = offset' - offset in let srcoff = 0 in let len = min count' (count - dstoff) in - srcoff, dstoff, len - end else begin + (srcoff, dstoff, len) + else let dstoff = 0 in let srcoff = offset - offset' in let len = min (count' - srcoff) count in - srcoff, dstoff, len - end in - Cstruct.blit src srcoff dst dstoff len - ) fragments; - Vfs.ok dst in - let write ~offset:_ _ = - Vfs.error "write" in - Vfs.ok (Vfs.File.create_fd ~read ~write) in + (srcoff, dstoff, len) + in + Cstruct.blit src srcoff dst dstoff len) + fragments; + Vfs.ok dst + in + let write ~offset:_ _ = Vfs.error "write" in + Vfs.ok (Vfs.File.create_fd ~read ~write) + in Vfs.File.create ~stat ~open_ ~remove ~truncate ~chmod type t = { - input: Input.t; - rules: (string, rule) Hashtbl.t; - stats: Mirage_net.stats; + input : Input.t; + rules : (string, rule) Hashtbl.t; + stats : Mirage_net.stats; } let add_match ~t ~name ~limit ~snaplen ~predicate = @@ -205,29 +220,30 @@ module Make(Input: Sig.VMNET) = struct let t = { input; rules; stats } in (* Add a special capture rule for packets for which there is an error processing the packet captures. Ideally there should be no matches! *) - let (_: rule) = add_match ~t ~name:bad_pcap ~limit:1048576 ~snaplen:1500 - ~predicate:(fun _ -> false) in + let (_ : rule) = + add_match ~t ~name:bad_pcap ~limit:1048576 ~snaplen:1500 + ~predicate:(fun _ -> false) + in t let filesystem t = Vfs.Dir.of_list (fun () -> - Vfs.ok ( - Hashtbl.fold - (fun name rule acc -> Vfs.Inode.file name (pcap rule) :: acc) - t.rules [] - ) - ) + Vfs.ok + (Hashtbl.fold + (fun name rule acc -> Vfs.Inode.file name (pcap rule) :: acc) + t.rules [])) let disconnect t = Input.disconnect t.input let after_disconnect t = Input.after_disconnect t.input let record t bufs = try - Hashtbl.iter (fun _ rule -> + Hashtbl.iter + (fun _ rule -> match Frame.parse bufs with | Ok f -> if rule.predicate f then push rule bufs - | Error (`Msg m) -> failwith m - ) t.rules + | Error (`Msg m) -> failwith m) + t.rules with e -> Log.err (fun f -> f "caught %s matching packet" (Printexc.to_string e)); let rule = Hashtbl.find t.rules bad_pcap in @@ -235,23 +251,20 @@ module Make(Input: Sig.VMNET) = struct let write t ~size fill = Input.write t.input ~size (fun buf -> - let n = fill buf in - record t [ Cstruct.sub buf 0 n ]; - n - ) >|= lift_error + let n = fill buf in + record t [ Cstruct.sub buf 0 n ]; + n) + >|= lift_error let listen t ~header_size callback = Input.listen t.input ~header_size (fun buf -> record t [ buf ]; - callback buf - ) >|= lift_error + callback buf) + >|= lift_error let add_listener t callback = Input.add_listener t.input callback - let mac t = Input.mac t.input - let mtu t = Input.mtu t.input - let get_stats_counters t = t.stats let reset_stats_counters t = @@ -266,12 +279,7 @@ module Make(Input: Sig.VMNET) = struct let start_capture _ ?size_limit:_ _ = failwith "Capture.start_capture unimplemented" - let stop_capture _ = - failwith "Capture.stop_capture unimplemented" - - let get_client_uuid _ = - failwith "Capture.get_client_uuid unimplemented" - - let get_client_macaddr _ = - failwith "Capture.get_client_macaddr unimplemented" + let stop_capture _ = failwith "Capture.stop_capture unimplemented" + let get_client_uuid _ = failwith "Capture.get_client_uuid unimplemented" + let get_client_macaddr _ = failwith "Capture.get_client_macaddr unimplemented" end File "src/hostnet/hostnet_icmp.ml", line 1, characters 0-0: diff --git a/_build/default/src/hostnet/hostnet_icmp.ml b/_build/default/src/hostnet/.formatted/hostnet_icmp.ml index 0791a9e..cca8b84 100644 --- a/_build/default/src/hostnet/hostnet_icmp.ml +++ b/_build/default/src/hostnet/.formatted/hostnet_icmp.ml @@ -8,47 +8,50 @@ let src = module Log = (val Logs.src_log src : Logs.LOG) type reply = Cstruct.t -> unit Lwt.t - type address = Ipaddr.V4.t type datagram = { - src: address; - dst: address; - ty: int; - code: int; - seq: int; - id: int; - payload: Cstruct.t; + src : address; + dst : address; + ty : int; + code : int; + seq : int; + id : int; + payload : Cstruct.t; } module Make - (Sockets: Sig.SOCKETS) - (Clock: Mirage_clock.MCLOCK) - (Time: Mirage_time.S) -= struct - + (Sockets : Sig.SOCKETS) + (Clock : Mirage_clock.MCLOCK) + (Time : Mirage_time.S) = +struct module Icmp = Sockets.Datagram.Udp type key = Ipaddr.V4.t * int (* IP * ICMP ty *) (* An active ICMP "flow" *) type flow = { - description: string; - phys: key; - virt: key; - mutable last_use: int64; + description : string; + phys : key; + virt : key; + mutable last_use : int64; } - module IntSet = Set.Make(struct type t = int let compare = compare end) + module IntSet = Set.Make (struct + type t = int + + let compare = compare + end) type t = { - server_fd: Unix.file_descr; - server: Icmp.server; - phys_to_flow: (key, flow) Hashtbl.t; - virt_to_flow: (key, flow) Hashtbl.t; - ids_in_use: IntSet.t ref; - mutable next_id: int; - mutable send_reply: (src:address -> dst:address -> payload:Cstruct.t -> unit Lwt.t) option; + server_fd : Unix.file_descr; + server : Icmp.server; + phys_to_flow : (key, flow) Hashtbl.t; + virt_to_flow : (key, flow) Hashtbl.t; + ids_in_use : IntSet.t ref; + mutable next_id : int; + mutable send_reply : + (src:address -> dst:address -> payload:Cstruct.t -> unit Lwt.t) option; } let start_background_gc phys_to_flow virt_to_flow ids_in_use max_idle_time = @@ -56,20 +59,23 @@ module Make Time.sleep_ns max_idle_time >>= fun () -> let now_ns = Clock.elapsed_ns () in let to_shutdown = - Hashtbl.fold (fun phys flow acc -> - if Int64.(sub now_ns flow.last_use) > max_idle_time then begin + Hashtbl.fold + (fun phys flow acc -> + if Int64.(sub now_ns flow.last_use) > max_idle_time then ( Log.info (fun f -> f "Hostnet_icmp %s: expiring ICMP NAT rule" flow.description); - (phys, flow) :: acc - end else acc - ) phys_to_flow [] + (phys, flow) :: acc) + else acc) + phys_to_flow [] in - List.iter (fun (phys, flow) -> - ids_in_use := IntSet.remove (snd flow.phys) !ids_in_use; - Hashtbl.remove phys_to_flow phys; - Hashtbl.remove virt_to_flow flow.virt; - ) to_shutdown; - loop () in + List.iter + (fun (phys, flow) -> + ids_in_use := IntSet.remove (snd flow.phys) !ids_in_use; + Hashtbl.remove phys_to_flow phys; + Hashtbl.remove virt_to_flow flow.virt) + to_shutdown; + loop () + in loop () (* Allocate a free physical id for a new "flow" *) @@ -77,202 +83,365 @@ module Make let start = t.next_id in let in_use = !(t.ids_in_use) in let rec find from = - if not(IntSet.mem from in_use) then begin + if not (IntSet.mem from in_use) then ( t.ids_in_use := IntSet.add from in_use; t.next_id <- from; - Some from - end else begin + Some from) + else let next = (from + 1) mod 0xffff in - if next = start - then None (* all are in use, we'll have to drop the packet *) + if next = start then None + (* all are in use, we'll have to drop the packet *) else find next - end in + in find start let is_win32 = Sys.os_type = "Win32" let sock_icmp = (* Windows uses SOCK_RAW protocol 1 for ICMP - Unix uses SOCK_DGRAM protocol 1 for ICMP *) + Unix uses SOCK_DGRAM protocol 1 for ICMP *) if is_win32 then Unix.SOCK_RAW else Unix.SOCK_DGRAM let ipproto_icmp = 1 (* according to BSD /etc/protocols *) + let _port = 0 (* port isn't meaningful in this context *) let create ?(max_idle_time = Duration.(of_sec 60)) () = let phys_to_flow = Hashtbl.create 7 in let virt_to_flow = Hashtbl.create 7 in - (try Lwt.return @@ Unix.socket Unix.PF_INET sock_icmp ipproto_icmp with e -> Lwt.fail e) + (try Lwt.return @@ Unix.socket Unix.PF_INET sock_icmp ipproto_icmp + with e -> Lwt.fail e) >>= fun server_fd -> - Icmp.of_bound_fd server_fd - >>= fun server -> + Icmp.of_bound_fd server_fd >>= fun server -> let ids_in_use = ref IntSet.empty in let next_id = 0 in let send_reply = None in - let _background_gc_t = start_background_gc phys_to_flow virt_to_flow ids_in_use max_idle_time in - Lwt.return { server; server_fd; phys_to_flow; virt_to_flow; ids_in_use; next_id; send_reply } + let _background_gc_t = + start_background_gc phys_to_flow virt_to_flow ids_in_use max_idle_time + in + Lwt.return + { + server; + server_fd; + phys_to_flow; + virt_to_flow; + ids_in_use; + next_id; + send_reply; + } let start_receiver t = let buf = Cstruct.create 4096 in let try_to_send ~src ~dst ~payload = match t.send_reply with - | Some fn -> - fn ~src ~dst ~payload - >>= fun () -> - Lwt.return true + | Some fn -> fn ~src ~dst ~payload >>= fun () -> Lwt.return true | None -> - Log.warn (fun f -> f "dropping ICMP because reply callback not set"); - Lwt.return true in + Log.warn (fun f -> f "dropping ICMP because reply callback not set"); + Lwt.return true + in let rec loop () = - Lwt.catch (fun () -> - Icmp.recvfrom t.server buf - >>= fun (n, _) -> - let datagram = Cstruct.sub buf 0 n in - (* On macOS the IP length field is set to a very large value (16384) which - probably reflects some kernel datastructure size rather than the real - on-the-wire size. This confuses our IPv4 parser so we correct the size - here. *) - let len = Ipv4_wire.get_ipv4_len datagram in - Ipv4_wire.set_ipv4_len datagram (min len n); - match Frame.ipv4 [ datagram ] with - | Error (`Msg m) -> - Log.err (fun f -> f "Error unmarshalling IP datagram: %s" m); - Lwt.return_true - | Ok { src; payload = Frame.Icmp { raw; icmp = Frame.Echo { id; _ }; _ }; _ } -> - if Hashtbl.mem t.phys_to_flow (src, id) then begin - let flow = Hashtbl.find t.phys_to_flow (src, id) in - let id' = snd flow.virt in - (* Rewrite the id in the Echo response *) - Icmpv4_wire.set_icmpv4_id raw id'; - Icmpv4_wire.set_icmpv4_csum raw 0; - Icmpv4_wire.set_icmpv4_csum raw (Tcpip_checksum.ones_complement raw); - try_to_send ~src ~dst:(fst flow.virt) ~payload:raw - end else begin - Log.debug (fun f -> - f "ICMP dropping (%a, %d) %a" - Ipaddr.V4.pp src id Cstruct.hexdump_pp raw); - Lwt.return_true - end - | Ok { src=src'; dst=dst'; payload = Frame.Icmp { raw = icmp_buffer; icmp = Frame.Time_exceeded { ipv4 = Ok { src; dst; raw = original_ipv4; payload = Frame.Icmp { raw = original_icmp; icmp = Frame.Echo { id; _ }; _ }; _ }; _ }; _ }; _ } -> - (* This message comes from a router. We need to examine the nested packet to see - where to forward it. *) - if Hashtbl.mem t.phys_to_flow (dst, id) then begin - (* Our only idea of the true destination is in the NAT table *) - let flow = Hashtbl.find t.phys_to_flow (dst, id) in - let id' = snd flow.virt in - (* Rewrite the id in the nested original packet *) - Icmpv4_wire.set_icmpv4_id original_icmp id'; - Icmpv4_wire.set_icmpv4_csum original_icmp 0; - Icmpv4_wire.set_icmpv4_csum original_icmp (Tcpip_checksum.ones_complement original_icmp); - (* Rewrite the src address to use the internal address *) - let new_src = Ipaddr.V4.to_int32 @@ fst flow.virt in - Ipv4_wire.set_ipv4_src original_ipv4 new_src; - (* Note we don't recompute the IPv4 checksum since the packet is truncated *) - Icmpv4_wire.set_icmpv4_csum icmp_buffer 0; - Icmpv4_wire.set_icmpv4_csum icmp_buffer (Tcpip_checksum.ones_complement icmp_buffer); - try_to_send ~src:src' ~dst:(fst flow.virt) ~payload:icmp_buffer - end else begin - Log.debug (fun f -> f "Dropping TTL exceeded src' = %a dst' = %a; src = %a; dst = %a; id = %d" - Ipaddr.V4.pp src' - Ipaddr.V4.pp dst' - Ipaddr.V4.pp src - Ipaddr.V4.pp dst - id - ); - Lwt.return_true - end - | Ok { src=src'; dst=dst'; payload = Frame.Icmp { raw = icmp_buffer; icmp = Frame.Time_exceeded { ipv4 = Ok { src; dst; raw = original_ipv4; payload = Frame.Udp { raw = original_udp; src = src_port; dst = dst_port; _ }; _ }; _ }; _ }; _ } - | Ok { src=src'; dst=dst'; payload = Frame.Icmp { raw = icmp_buffer; icmp = Frame.Destination_unreachable { ipv4 = Ok { src; dst; raw = original_ipv4; payload = Frame.Udp { raw = original_udp; src = src_port; dst = dst_port; _ }; _ }; _ }; _ }; _ } -> - (* src:src_port are host addresses. We need to discover the internal IP and port *) - if Hashtbl.mem Hostnet_udp.external_to_internal src_port then begin - match Hashtbl.find Hostnet_udp.external_to_internal src_port with - | Ipaddr.V4 internal_src, internal_port -> - (* Rewrite the src address on the IPv4 to use the internal address *) - Ipv4_wire.set_ipv4_src original_ipv4 (Ipaddr.V4.to_int32 internal_src); - (* Rewrite the src_port on the UDP to use the internal address *) - Udp_wire.set_udp_source_port original_udp internal_port; - Icmpv4_wire.set_icmpv4_csum icmp_buffer 0; - Icmpv4_wire.set_icmpv4_csum icmp_buffer (Tcpip_checksum.ones_complement icmp_buffer); - try_to_send ~src:src' ~dst:internal_src ~payload:icmp_buffer - | _, _ -> - Log.debug (fun f -> f "Dropping TTL exceeded from internal IPv6 address"); + Lwt.catch + (fun () -> + Icmp.recvfrom t.server buf >>= fun (n, _) -> + let datagram = Cstruct.sub buf 0 n in + (* On macOS the IP length field is set to a very large value (16384) which + probably reflects some kernel datastructure size rather than the real + on-the-wire size. This confuses our IPv4 parser so we correct the size + here. *) + let len = Ipv4_wire.get_ipv4_len datagram in + Ipv4_wire.set_ipv4_len datagram (min len n); + match Frame.ipv4 [ datagram ] with + | Error (`Msg m) -> + Log.err (fun f -> f "Error unmarshalling IP datagram: %s" m); Lwt.return_true - end else begin - Log.debug (fun f -> f "Dropping TTL exceeded src' = %a dst' = %a; src = %a:%d; dst = %a:%d" - Ipaddr.V4.pp src' - Ipaddr.V4.pp dst' - Ipaddr.V4.pp src src_port - Ipaddr.V4.pp dst dst_port - ); - Lwt.return_true - end - | Ok { payload = Frame.Icmp { icmp = Frame.Time_exceeded { ipv4 = Error (`Msg m) }; _ }; _ } -> - Log.err (fun f -> f "Failed to forward TTL exceeeded: failed to parse inner packet: %s" m); - Lwt.return_true - | Ok { payload = Frame.Icmp { icmp = Frame.Time_exceeded { ipv4 = Ok { src; dst; payload = Frame.Tcp { src = src_port; dst = dst_port; _ }; _ }; _ }; _ }; _ } -> - (* TODO: implement for TCP *) - Log.debug (fun f -> f "Dropping TTL exceeeded for TCP %a:%d -> %a%d" - Ipaddr.V4.pp src src_port Ipaddr.V4.pp dst dst_port - ); - Lwt.return_true - | Ok { payload = Frame.Icmp { icmp = Frame.Time_exceeded _; _ }; _ } -> - Log.debug (fun f -> f "Dropping TTL exceeded for non-ICMP/UDP/TCP"); - Lwt.return_true - | Ok { payload = Frame.Icmp { icmp = Frame.Unknown_icmp { ty } ; _ }; _ } -> - Log.err (fun f -> f "Failed to forward unexpected ICMP datagram with type %d" ty); - Lwt.return_true - | Ok _ -> - Log.debug (fun f -> f "Failed to forward unexpected IPv4 datagram"); - Lwt.return_true - ) (fun e -> - Log.err (fun f -> - f "Hostnet_icmp: caught unexpected exception %a" - Fmt.exn e); - Lwt.return false - ) >>= function - | false -> - Lwt.return_unit - | true -> loop () in + | Ok + { + src; + payload = Frame.Icmp { raw; icmp = Frame.Echo { id; _ }; _ }; + _; + } -> + if Hashtbl.mem t.phys_to_flow (src, id) then ( + let flow = Hashtbl.find t.phys_to_flow (src, id) in + let id' = snd flow.virt in + (* Rewrite the id in the Echo response *) + Icmpv4_wire.set_icmpv4_id raw id'; + Icmpv4_wire.set_icmpv4_csum raw 0; + Icmpv4_wire.set_icmpv4_csum raw + (Tcpip_checksum.ones_complement raw); + try_to_send ~src ~dst:(fst flow.virt) ~payload:raw) + else ( + Log.debug (fun f -> + f "ICMP dropping (%a, %d) %a" Ipaddr.V4.pp src id + Cstruct.hexdump_pp raw); + Lwt.return_true) + | Ok + { + src = src'; + dst = dst'; + payload = + Frame.Icmp + { + raw = icmp_buffer; + icmp = + Frame.Time_exceeded + { + ipv4 = + Ok + { + src; + dst; + raw = original_ipv4; + payload = + Frame.Icmp + { + raw = original_icmp; + icmp = Frame.Echo { id; _ }; + _; + }; + _; + }; + _; + }; + _; + }; + _; + } -> + (* This message comes from a router. We need to examine the nested packet to see + where to forward it. *) + if Hashtbl.mem t.phys_to_flow (dst, id) then ( + (* Our only idea of the true destination is in the NAT table *) + let flow = Hashtbl.find t.phys_to_flow (dst, id) in + let id' = snd flow.virt in + (* Rewrite the id in the nested original packet *) + Icmpv4_wire.set_icmpv4_id original_icmp id'; + Icmpv4_wire.set_icmpv4_csum original_icmp 0; + Icmpv4_wire.set_icmpv4_csum original_icmp + (Tcpip_checksum.ones_complement original_icmp); + (* Rewrite the src address to use the internal address *) + let new_src = Ipaddr.V4.to_int32 @@ fst flow.virt in + Ipv4_wire.set_ipv4_src original_ipv4 new_src; + (* Note we don't recompute the IPv4 checksum since the packet is truncated *) + Icmpv4_wire.set_icmpv4_csum icmp_buffer 0; + Icmpv4_wire.set_icmpv4_csum icmp_buffer + (Tcpip_checksum.ones_complement icmp_buffer); + try_to_send ~src:src' ~dst:(fst flow.virt) ~payload:icmp_buffer) + else ( + Log.debug (fun f -> + f + "Dropping TTL exceeded src' = %a dst' = %a; src = %a; \ + dst = %a; id = %d" + Ipaddr.V4.pp src' Ipaddr.V4.pp dst' Ipaddr.V4.pp src + Ipaddr.V4.pp dst id); + Lwt.return_true) + | Ok + { + src = src'; + dst = dst'; + payload = + Frame.Icmp + { + raw = icmp_buffer; + icmp = + Frame.Time_exceeded + { + ipv4 = + Ok + { + src; + dst; + raw = original_ipv4; + payload = + Frame.Udp + { + raw = original_udp; + src = src_port; + dst = dst_port; + _; + }; + _; + }; + _; + }; + _; + }; + _; + } + | Ok + { + src = src'; + dst = dst'; + payload = + Frame.Icmp + { + raw = icmp_buffer; + icmp = + Frame.Destination_unreachable + { + ipv4 = + Ok + { + src; + dst; + raw = original_ipv4; + payload = + Frame.Udp + { + raw = original_udp; + src = src_port; + dst = dst_port; + _; + }; + _; + }; + _; + }; + _; + }; + _; + } -> + (* src:src_port are host addresses. We need to discover the internal IP and port *) + if Hashtbl.mem Hostnet_udp.external_to_internal src_port then ( + match + Hashtbl.find Hostnet_udp.external_to_internal src_port + with + | Ipaddr.V4 internal_src, internal_port -> + (* Rewrite the src address on the IPv4 to use the internal address *) + Ipv4_wire.set_ipv4_src original_ipv4 + (Ipaddr.V4.to_int32 internal_src); + (* Rewrite the src_port on the UDP to use the internal address *) + Udp_wire.set_udp_source_port original_udp internal_port; + Icmpv4_wire.set_icmpv4_csum icmp_buffer 0; + Icmpv4_wire.set_icmpv4_csum icmp_buffer + (Tcpip_checksum.ones_complement icmp_buffer); + try_to_send ~src:src' ~dst:internal_src ~payload:icmp_buffer + | _, _ -> + Log.debug (fun f -> + f "Dropping TTL exceeded from internal IPv6 address"); + Lwt.return_true) + else ( + Log.debug (fun f -> + f + "Dropping TTL exceeded src' = %a dst' = %a; src = %a:%d; \ + dst = %a:%d" + Ipaddr.V4.pp src' Ipaddr.V4.pp dst' Ipaddr.V4.pp src + src_port Ipaddr.V4.pp dst dst_port); + Lwt.return_true) + | Ok + { + payload = + Frame.Icmp + { icmp = Frame.Time_exceeded { ipv4 = Error (`Msg m) }; _ }; + _; + } -> + Log.err (fun f -> + f + "Failed to forward TTL exceeeded: failed to parse inner \ + packet: %s" + m); + Lwt.return_true + | Ok + { + payload = + Frame.Icmp + { + icmp = + Frame.Time_exceeded + { + ipv4 = + Ok + { + src; + dst; + payload = + Frame.Tcp + { src = src_port; dst = dst_port; _ }; + _; + }; + _; + }; + _; + }; + _; + } -> + (* TODO: implement for TCP *) + Log.debug (fun f -> + f "Dropping TTL exceeeded for TCP %a:%d -> %a%d" Ipaddr.V4.pp + src src_port Ipaddr.V4.pp dst dst_port); + Lwt.return_true + | Ok { payload = Frame.Icmp { icmp = Frame.Time_exceeded _; _ }; _ } + -> + Log.debug (fun f -> + f "Dropping TTL exceeded for non-ICMP/UDP/TCP"); + Lwt.return_true + | Ok + { + payload = Frame.Icmp { icmp = Frame.Unknown_icmp { ty }; _ }; + _; + } -> + Log.err (fun f -> + f "Failed to forward unexpected ICMP datagram with type %d" ty); + Lwt.return_true + | Ok _ -> + Log.debug (fun f -> + f "Failed to forward unexpected IPv4 datagram"); + Lwt.return_true) + (fun e -> + Log.err (fun f -> + f "Hostnet_icmp: caught unexpected exception %a" Fmt.exn e); + Lwt.return false) + >>= function + | false -> Lwt.return_unit + | true -> loop () + in Lwt.async loop let set_send_reply ~t ~send_reply = t.send_reply <- Some send_reply; start_receiver t - let input ~t ~datagram:{src; dst; ty; code; id; seq; payload} ~ttl () = + let input ~t ~datagram:{ src; dst; ty; code; id; seq; payload } ~ttl () = Log.debug (fun f -> - f "ICMP received %a -> %a ttl=%d ty=%d code=%d id=%d seq=%d payload len %d" - Ipaddr.V4.pp src Ipaddr.V4.pp dst - ttl ty code id seq (Cstruct.length payload)); + f + "ICMP received %a -> %a ttl=%d ty=%d code=%d id=%d seq=%d payload \ + len %d" + Ipaddr.V4.pp src Ipaddr.V4.pp dst ttl ty code id seq + (Cstruct.length payload)); match Icmpv4_wire.int_to_ty ty with - | None -> + | None -> Log.err (fun f -> f "Unknown ICMP type: %d" ty); Lwt.return_unit - | Some ty -> - let virt = src, id in + | Some ty -> ( + let virt = (src, id) in let id = - if Hashtbl.mem t.virt_to_flow virt then begin + if Hashtbl.mem t.virt_to_flow virt then let flow = Hashtbl.find t.virt_to_flow virt in Some (snd flow.phys) - end else allocate_next_id t in - begin match id with - | None -> - Log.warn (fun f -> f "Dropping ICMP because we've run out of external ids"); + else allocate_next_id t + in + match id with + | None -> + Log.warn (fun f -> + f "Dropping ICMP because we've run out of external ids"); Lwt.return_unit - | Some id' -> - let phys = dst, id' in - let description = Printf.sprintf "%s id=%d -> %s id=%d" - (Ipaddr.V4.to_string @@ fst virt) (snd virt) (Ipaddr.V4.to_string @@ fst phys) (snd phys) in + | Some id' -> + let phys = (dst, id') in + let description = + Printf.sprintf "%s id=%d -> %s id=%d" + (Ipaddr.V4.to_string @@ fst virt) + (snd virt) + (Ipaddr.V4.to_string @@ fst phys) + (snd phys) + in let last_use = Clock.elapsed_ns () in let flow = { description; virt; phys; last_use } in Hashtbl.replace t.phys_to_flow phys flow; Hashtbl.replace t.virt_to_flow virt flow; - let req = Icmpv4_packet.({code; ty; - subheader = Id_and_seq (id', seq)}) in + let req = + Icmpv4_packet.{ code; ty; subheader = Id_and_seq (id', seq) } + in let header = Icmpv4_packet.Marshal.make_cstruct req ~payload in let icmp = Cstruct.concat [ header; payload ] in - Icmp.sendto t.server (Ipaddr.V4 dst, 0) ~ttl icmp - end + Icmp.sendto t.server (Ipaddr.V4 dst, 0) ~ttl icmp) end File "src/hostnet/forward.ml", line 1, characters 0-0: diff --git a/_build/default/src/hostnet/forward.ml b/_build/default/src/hostnet/.formatted/forward.ml index 4929f3b..cf407c8 100644 --- a/_build/default/src/hostnet/forward.ml +++ b/_build/default/src/hostnet/.formatted/forward.ml @@ -13,16 +13,17 @@ let log_exception_continue description f = Lwt.catch (fun () -> f ()) (fun e -> - Log.warn (fun f -> f "%s: caught %a" description Fmt.exn e); - Lwt.return ()) + Log.warn (fun f -> f "%s: caught %a" description Fmt.exn e); + Lwt.return ()) let allowed_addresses = ref None let set_allowed_addresses ips = - Log.info (fun f -> f "allowing binds to %s" (match ips with - | None -> "any IP addresses" - | Some ips -> String.concat ", " (List.map Ipaddr.to_string ips) - )); + Log.info (fun f -> + f "allowing binds to %s" + (match ips with + | None -> "any IP addresses" + | Some ips -> String.concat ", " (List.map Ipaddr.to_string ips))); allowed_addresses := ips let errorf fmt = Fmt.kstr (fun e -> Error (`Msg e)) fmt @@ -32,47 +33,39 @@ module Port = struct type t = Forwarder.Frame.Destination.t let to_string = function - | `Tcp (ip, port) -> - Fmt.str "tcp:%a:%d" Ipaddr.pp ip port - | `Udp (ip, port) -> - Fmt.str "udp:%a:%d" Ipaddr.pp ip port - | `Unix path -> - Fmt.str "unix:%s" (Base64.encode_exn path) + | `Tcp (ip, port) -> Fmt.str "tcp:%a:%d" Ipaddr.pp ip port + | `Udp (ip, port) -> Fmt.str "udp:%a:%d" Ipaddr.pp ip port + | `Unix path -> Fmt.str "unix:%s" (Base64.encode_exn path) let of_string x = try match Stringext.split ~on:':' x with - | [ proto; ip; port ] -> - let port = int_of_string port in - let ip = Ipaddr.of_string_exn ip in - begin match String.lowercase_ascii proto with - | "tcp" -> Ok (`Tcp(ip, port)) - | "udp" -> Ok (`Udp(ip, port)) - | _ -> errorf "unknown protocol: should be tcp or udp" - end + | [ proto; ip; port ] -> ( + let port = int_of_string port in + let ip = Ipaddr.of_string_exn ip in + match String.lowercase_ascii proto with + | "tcp" -> Ok (`Tcp (ip, port)) + | "udp" -> Ok (`Udp (ip, port)) + | _ -> errorf "unknown protocol: should be tcp or udp") | [ "unix"; path ] -> Ok (`Unix (Base64.decode_exn path)) | _ -> errorf "port should be of the form proto:IP:port or unix:path" - with - | _ -> errorf "port is not a proto:IP:port or unix:path: '%s'" x - + with _ -> errorf "port is not a proto:IP:port or unix:path: '%s'" x end module Make - (Clock: Mirage_clock.MCLOCK) - (Connector: Sig.Connector) - (Socket: Sig.SOCKETS) = + (Clock : Mirage_clock.MCLOCK) + (Connector : Sig.Connector) + (Socket : Sig.SOCKETS) = struct - - type server = [ - | `Tcp of Socket.Stream.Tcp.server + type server = + [ `Tcp of Socket.Stream.Tcp.server | `Udp of Socket.Datagram.Udp.server - | `Unix of Socket.Stream.Unix.server - ] + | `Unix of Socket.Stream.Unix.server ] type t = { - mutable local: Port.t; - remote_port: Port.t; - mutable server: server option; + mutable local : Port.t; + remote_port : Port.t; + mutable server : server option; } type key = Port.t @@ -83,26 +76,28 @@ struct Fmt.str "%s:%s" (Port.to_string t.local) (Port.to_string t.remote_port) let description_of_format = - "tcp:<local IP>:<local port>:tcp:<remote IP>:<remote port> -udp:<local IP>:<local port>:udp:<remote IP>:<remote port> -unix:<base64-encoded local path>:unix:<base64-encoded remote path>" + "tcp:<local IP>:<local port>:tcp:<remote IP>:<remote port>\n\ + udp:<local IP>:<local port>:udp:<remote IP>:<remote port>\n\ + unix:<base64-encoded local path>:unix:<base64-encoded remote path>" - let check_bind_allowed ip = match !allowed_addresses with - | None -> Lwt.return () (* no restriction *) - | Some ips -> - let match_ip allowed_ip = - let exact_match = Ipaddr.compare allowed_ip ip = 0 in - let wildcard = match ip, allowed_ip with - | Ipaddr.V4 _, Ipaddr.V4 x when x = Ipaddr.V4.any -> true - | _, _ -> false - in - exact_match || wildcard - in - if List.fold_left (||) false (List.map match_ip ips) - then Lwt.return () - else Lwt.fail (Unix.Unix_error(Unix.EPERM, "bind", "")) + let check_bind_allowed ip = + match !allowed_addresses with + | None -> Lwt.return () (* no restriction *) + | Some ips -> + let match_ip allowed_ip = + let exact_match = Ipaddr.compare allowed_ip ip = 0 in + let wildcard = + match (ip, allowed_ip) with + | Ipaddr.V4 _, Ipaddr.V4 x when x = Ipaddr.V4.any -> true + | _, _ -> false + in + exact_match || wildcard + in + if List.fold_left ( || ) false (List.map match_ip ips) then + Lwt.return () + else Lwt.fail (Unix.Unix_error (Unix.EPERM, "bind", "")) - module Mux = Forwarder.Multiplexer.Make(Connector) + module Mux = Forwarder.Multiplexer.Make (Connector) (* Since we only need one connection to the port forwarding service, connect on demand and cache it. *) @@ -110,94 +105,85 @@ unix:<base64-encoded local path>:unix:<base64-encoded remote path>" let mux = ref None in let m = Lwt_mutex.create () in fun () -> - Lwt_mutex.with_lock m - (fun () -> + Lwt_mutex.with_lock m (fun () -> (* If there is a multiplexer but it is broken, reconnect *) - begin match !mux with + (match !mux with | None -> Lwt.return_unit | Some m -> - if not(Mux.is_running m) then begin - Log.err (fun f -> f "Multiplexer has shutdown, reconnecting"); - mux := None; - Mux.disconnect m - end else Lwt.return_unit - end >>= fun () -> + if not (Mux.is_running m) then ( + Log.err (fun f -> f "Multiplexer has shutdown, reconnecting"); + mux := None; + Mux.disconnect m) + else Lwt.return_unit) + >>= fun () -> match !mux with | None -> - Connector.connect () - >>= fun remote -> - let mux' = Mux.connect remote "port-forwarding" - (fun flow destination -> - Log.err (fun f -> f "Unexpected connection from %s via port multiplexer" (Forwarder.Frame.Destination.to_string destination)); - Mux.Channel.close flow - ) in - mux := Some mux'; - Lwt.return mux' - | Some m -> Lwt.return m - ) + Connector.connect () >>= fun remote -> + let mux' = + Mux.connect remote "port-forwarding" (fun flow destination -> + Log.err (fun f -> + f "Unexpected connection from %s via port multiplexer" + (Forwarder.Frame.Destination.to_string destination)); + Mux.Channel.close flow) + in + mux := Some mux'; + Lwt.return mux' + | Some m -> Lwt.return m) let open_channel destination = - get_mux () - >>= fun mux -> - Mux.Channel.connect mux destination + get_mux () >>= fun mux -> Mux.Channel.connect mux destination let start_tcp_proxy description remote_port server = - let module Proxy = Mirage_flow_combinators.Proxy(Clock)(Mux.Channel)(Socket.Stream.Tcp) in + let module Proxy = + Mirage_flow_combinators.Proxy (Clock) (Mux.Channel) (Socket.Stream.Tcp) + in Socket.Stream.Tcp.listen server (fun local -> - open_channel remote_port - >>= fun remote -> - Lwt.finalize (fun () -> + open_channel remote_port >>= fun remote -> + Lwt.finalize + (fun () -> Log.debug (fun f -> f "%s: connected" description); - Proxy.proxy remote local >|= function + Proxy.proxy remote local >|= function | Error e -> - Log.err (fun f -> - f "%s proxy failed with %a" description Proxy.pp_error e) + Log.err (fun f -> + f "%s proxy failed with %a" description Proxy.pp_error e) | Ok (l_stats, r_stats) -> - Log.debug (fun f -> - f "%s completed: l2r = %a; r2l = %a" description - Mirage_flow.pp_stats l_stats - Mirage_flow.pp_stats r_stats - ) - ) (fun () -> - Mux.Channel.close remote - ) - ); + Log.debug (fun f -> + f "%s completed: l2r = %a; r2l = %a" description + Mirage_flow.pp_stats l_stats Mirage_flow.pp_stats r_stats)) + (fun () -> Mux.Channel.close remote)); Lwt.return () let start_unix_proxy description remote_port server = - let module Proxy = Mirage_flow_combinators.Proxy(Clock)(Mux.Channel)(Socket.Stream.Unix) in + let module Proxy = + Mirage_flow_combinators.Proxy (Clock) (Mux.Channel) (Socket.Stream.Unix) + in Socket.Stream.Unix.listen server (fun local -> - open_channel remote_port - >>= fun remote -> - Lwt.finalize (fun () -> + open_channel remote_port >>= fun remote -> + Lwt.finalize + (fun () -> Log.debug (fun f -> f "%s: connected" description); - Proxy.proxy remote local >|= function + Proxy.proxy remote local >|= function | Error e -> - Log.err (fun f -> - f "%s proxy failed with %a" description Proxy.pp_error e) + Log.err (fun f -> + f "%s proxy failed with %a" description Proxy.pp_error e) | Ok (l_stats, r_stats) -> - Log.debug (fun f -> - f "%s completed: l2r = %a; r2l = %a" description - Mirage_flow.pp_stats l_stats - Mirage_flow.pp_stats r_stats - ) - ) (fun () -> - Mux.Channel.close remote - ) - ); + Log.debug (fun f -> + f "%s completed: l2r = %a; r2l = %a" description + Mirage_flow.pp_stats l_stats Mirage_flow.pp_stats r_stats)) + (fun () -> Mux.Channel.close remote)); Lwt.return () let conn_read flow buf = Mux.Channel.read_into flow buf >>= function - | Ok `Eof -> Lwt.fail End_of_file - | Error e -> Fmt.kstr Lwt.fail_with "%a" Mux.Channel.pp_error e + | Ok `Eof -> Lwt.fail End_of_file + | Error e -> Fmt.kstr Lwt.fail_with "%a" Mux.Channel.pp_error e | Ok (`Data ()) -> Lwt.return () let conn_write flow buf = Mux.Channel.write flow buf >>= function | Error `Closed -> Lwt.fail End_of_file - | Error e -> Fmt.kstr Lwt.fail_with "%a" Mux.Channel.pp_write_error e - | Ok () -> Lwt.return () + | Error e -> Fmt.kstr Lwt.fail_with "%a" Mux.Channel.pp_write_error e + | Ok () -> Lwt.return () let start_udp_proxy description remote_port server = let from_internet_buffer = Cstruct.create Constants.max_udp_length in @@ -210,61 +196,63 @@ unix:<base64-encoded local path>:unix:<base64-encoded remote path>" directly from the from_internet_buffer *) let write_header_buffer = Cstruct.create Forwarder.Frame.Udp.max_sizeof in let write v buf (ip, port) = - let udp = Forwarder.Frame.Udp.({ - ip; port; - payload_length = Cstruct.length buf; - }) in + let udp = + Forwarder.Frame.Udp.{ ip; port; payload_length = Cstruct.length buf } + in let header = Forwarder.Frame.Udp.write_header udp write_header_buffer in - conn_write v header >>= fun () -> - conn_write v buf + conn_write v header >>= fun () -> conn_write v buf in (* Read the vsock header and payload into the same buffer, and write it to the internet from there. *) let read v = conn_read v (Cstruct.sub from_vsock_buffer 0 2) >>= fun () -> let frame_length = Cstruct.LE.get_uint16 from_vsock_buffer 0 in - if frame_length > (Cstruct.length from_vsock_buffer) then begin + if frame_length > Cstruct.length from_vsock_buffer then ( Log.err (fun f -> - f "UDP encapsulated frame length is %d but buffer has length %d: \ - dropping" frame_length (Cstruct.length from_vsock_buffer)); - Lwt.return None - end else begin + f + "UDP encapsulated frame length is %d but buffer has length %d: \ + dropping" + frame_length + (Cstruct.length from_vsock_buffer)); + Lwt.return None) + else let rest = Cstruct.sub from_vsock_buffer 2 (frame_length - 2) in conn_read v rest >|= fun () -> let udp, payload = Forwarder.Frame.Udp.read from_vsock_buffer in - Some (payload, (udp.Forwarder.Frame.Udp.ip, udp.Forwarder.Frame.Udp.port)) - end + Some + (payload, (udp.Forwarder.Frame.Udp.ip, udp.Forwarder.Frame.Udp.port)) in let rec from_internet v = - Lwt.catch (fun () -> + Lwt.catch + (fun () -> Socket.Datagram.Udp.recvfrom fd from_internet_buffer >>= fun (len, address) -> write v (Cstruct.sub from_internet_buffer 0 len) address - >>= fun () -> - Lwt.return true - ) (function - | Unix.Unix_error(Unix.EBADF, _, _) -> Lwt.return false - | e -> - Log.err (fun f -> - f "%s: shutting down recvfrom thread: %a" description Fmt.exn e); - Lwt.return false) + >>= fun () -> Lwt.return true) + (function + | Unix.Unix_error (Unix.EBADF, _, _) -> Lwt.return false + | e -> + Log.err (fun f -> + f "%s: shutting down recvfrom thread: %a" description + Fmt.exn e); + Lwt.return false) >>= function | true -> from_internet v | false -> Lwt.return () in let rec from_vsock v = - Lwt.catch (fun () -> + Lwt.catch + (fun () -> read v >>= function - | None -> Lwt.return false + | None -> Lwt.return false | Some (buf, address) -> - Socket.Datagram.Udp.sendto fd address buf >|= fun () -> - true - ) (fun e -> + Socket.Datagram.Udp.sendto fd address buf >|= fun () -> true) + (fun e -> Log.debug (fun f -> - f "%s: shutting down from vsock thread: %a" - description Fmt.exn e); - Lwt.return false - ) >>= function + f "%s: shutting down from vsock thread: %a" description Fmt.exn + e); + Lwt.return false) + >>= function | true -> from_vsock v | false -> Lwt.return () in @@ -272,16 +260,16 @@ unix:<base64-encoded local path>:unix:<base64-encoded remote path>" f "%s: connecting to vsock port %s" description (Port.to_string remote_port)); - open_channel remote_port - >>= fun remote -> - Lwt.finalize (fun () -> + open_channel remote_port >>= fun remote -> + Lwt.finalize + (fun () -> Log.debug (fun f -> f "%s: connected to vsock port %s" description (Port.to_string remote_port)); (* FIXME(samoht): why ignoring that thread here? *) let _ = from_vsock remote in - from_internet remote - ) (fun () -> Mux.Channel.close remote) + from_internet remote) + (fun () -> Mux.Channel.close remote) in Lwt.async (fun () -> log_exception_continue "udp handle" (fun () -> handle server)); @@ -290,91 +278,85 @@ unix:<base64-encoded local path>:unix:<base64-encoded remote path>" let start t = match t.local with | `Tcp (local_ip, local_port) -> - let description = - Fmt.str "forwarding from tcp:%a:%d" Ipaddr.pp local_ip local_port - in - Lwt.catch (fun () -> - check_bind_allowed local_ip >>= fun () -> - Socket.Stream.Tcp.bind ~description (local_ip, local_port) - >>= fun server -> - t.server <- Some (`Tcp server); - (* Resolve the local port yet (the fds are already bound) *) - Socket.Stream.Tcp.getsockname server - >>= fun (_, bound_port) -> - t.local <- ( match t.local with - | `Tcp (ip, 0) -> `Tcp (ip, bound_port) - | _ -> t.local ); - start_tcp_proxy (to_string t) t.remote_port server - >|= fun () -> - Ok t - ) (function - | Unix.Unix_error(Unix.EADDRINUSE, _, _) -> - errorf' "Bind for %a:%d failed: port is already allocated" - Ipaddr.pp local_ip local_port - | Unix.Unix_error(Unix.EADDRNOTAVAIL, _, _) -> - errorf' "listen tcp %a:%d: bind: cannot assign requested address" - Ipaddr.pp local_ip local_port - | Unix.Unix_error(Unix.EPERM, _, _) -> - errorf' "Bind for %a:%d failed: permission denied" - Ipaddr.pp local_ip local_port - | e -> - errorf' "Bind for %a:%d: unexpected error %a" Ipaddr.pp local_ip - local_port Fmt.exn e - ) + let description = + Fmt.str "forwarding from tcp:%a:%d" Ipaddr.pp local_ip local_port + in + Lwt.catch + (fun () -> + check_bind_allowed local_ip >>= fun () -> + Socket.Stream.Tcp.bind ~description (local_ip, local_port) + >>= fun server -> + t.server <- Some (`Tcp server); + (* Resolve the local port yet (the fds are already bound) *) + Socket.Stream.Tcp.getsockname server >>= fun (_, bound_port) -> + t.local <- + (match t.local with + | `Tcp (ip, 0) -> `Tcp (ip, bound_port) + | _ -> t.local); + start_tcp_proxy (to_string t) t.remote_port server >|= fun () -> + Ok t) + (function + | Unix.Unix_error (Unix.EADDRINUSE, _, _) -> + errorf' "Bind for %a:%d failed: port is already allocated" + Ipaddr.pp local_ip local_port + | Unix.Unix_error (Unix.EADDRNOTAVAIL, _, _) -> + errorf' + "listen tcp %a:%d: bind: cannot assign requested address" + Ipaddr.pp local_ip local_port + | Unix.Unix_error (Unix.EPERM, _, _) -> + errorf' "Bind for %a:%d failed: permission denied" Ipaddr.pp + local_ip local_port + | e -> + errorf' "Bind for %a:%d: unexpected error %a" Ipaddr.pp local_ip + local_port Fmt.exn e) | `Udp (local_ip, local_port) -> - let description = - Fmt.str "forwarding from udp:%a:%d" Ipaddr.pp local_ip local_port - in - Lwt.catch (fun () -> - check_bind_allowed local_ip >>= fun () -> - Socket.Datagram.Udp.bind ~description (local_ip, local_port) - >>= fun server -> - t.server <- Some (`Udp server); - (* Resolve the local port yet (the fds are already bound) *) - Socket.Datagram.Udp.getsockname server - >>= fun (_, bound_port) -> - t.local <- ( match t.local with - | `Udp (ip, 0) -> `Udp (ip, bound_port) - | _ -> t.local ); - start_udp_proxy (to_string t) t.remote_port server - >|= fun () -> - Ok t - ) (function - | Unix.Unix_error(Unix.EADDRINUSE, _, _) -> - errorf' "Bind for %a:%d failed: port is already allocated" - Ipaddr.pp local_ip local_port - | Unix.Unix_error(Unix.EADDRNOTAVAIL, _, _) -> - errorf' "listen udp %a:%d: bind: cannot assign requested address" - Ipaddr.pp local_ip local_port - | Unix.Unix_error(Unix.EPERM, _, _) -> - errorf' "Bind for %a:%d failed: permission denied" - Ipaddr.pp local_ip local_port - | e -> - errorf' "Bind for %a:%d: unexpected error %a" Ipaddr.pp local_ip - local_port Fmt.exn e - ) + let description = + Fmt.str "forwarding from udp:%a:%d" Ipaddr.pp local_ip local_port + in + Lwt.catch + (fun () -> + check_bind_allowed local_ip >>= fun () -> + Socket.Datagram.Udp.bind ~description (local_ip, local_port) + >>= fun server -> + t.server <- Some (`Udp server); + (* Resolve the local port yet (the fds are already bound) *) + Socket.Datagram.Udp.getsockname server >>= fun (_, bound_port) -> + t.local <- + (match t.local with + | `Udp (ip, 0) -> `Udp (ip, bound_port) + | _ -> t.local); + start_udp_proxy (to_string t) t.remote_port server >|= fun () -> + Ok t) + (function + | Unix.Unix_error (Unix.EADDRINUSE, _, _) -> + errorf' "Bind for %a:%d failed: port is already allocated" + Ipaddr.pp local_ip local_port + | Unix.Unix_error (Unix.EADDRNOTAVAIL, _, _) -> + errorf' + "listen udp %a:%d: bind: cannot assign requested address" + Ipaddr.pp local_ip local_port + | Unix.Unix_error (Unix.EPERM, _, _) -> + errorf' "Bind for %a:%d failed: permission denied" Ipaddr.pp + local_ip local_port + | e -> + errorf' "Bind for %a:%d: unexpected error %a" Ipaddr.pp local_ip + local_port Fmt.exn e) | `Unix path -> - let description = - Fmt.str "forwarding from unix:%s" path - in - Lwt.catch (fun () -> - Socket.Stream.Unix.bind ~description path - >>= fun server -> - t.server <- Some (`Unix server); - start_unix_proxy (to_string t) t.remote_port server - >|= fun () -> - Ok t - ) (function - | Unix.Unix_error(Unix.EADDRINUSE, _, _) -> - errorf' "Bind for %s failed: port is already allocated" path - | Unix.Unix_error(Unix.EADDRNOTAVAIL, _, _) -> - errorf' "listen %s: bind: cannot assign requested address" path - | Unix.Unix_error(Unix.EPERM, _, _) -> - errorf' "Bind for %s failed: permission denied" path - | e -> - errorf' "Bind for %s: unexpected error %a" path - Fmt.exn e - ) + let description = Fmt.str "forwarding from unix:%s" path in + Lwt.catch + (fun () -> + Socket.Stream.Unix.bind ~description path >>= fun server -> + t.server <- Some (`Unix server); + start_unix_proxy (to_string t) t.remote_port server >|= fun () -> + Ok t) + (function + | Unix.Unix_error (Unix.EADDRINUSE, _, _) -> + errorf' "Bind for %s failed: port is already allocated" path + | Unix.Unix_error (Unix.EADDRNOTAVAIL, _, _) -> + errorf' "listen %s: bind: cannot assign requested address" path + | Unix.Unix_error (Unix.EPERM, _, _) -> + errorf' "Bind for %s failed: permission denied" path + | e -> errorf' "Bind for %s: unexpected error %a" path Fmt.exn e) let stop t = Log.debug (fun f -> f "%s: closing listening socket" (to_string t)); @@ -386,28 +368,22 @@ unix:<base64-encoded local path>:unix:<base64-encoded remote path>" let of_string x = match Stringext.split ~on:':' ~max:6 x with - | [ proto1; ip1; port1; proto2; ip2; port2 ] -> - begin + | [ proto1; ip1; port1; proto2; ip2; port2 ] -> ( match - Port.of_string (proto1 ^ ":" ^ ip1 ^ ":" ^ port1), - Port.of_string (proto2 ^ ":" ^ ip2 ^ ":" ^ port2) + ( Port.of_string (proto1 ^ ":" ^ ip1 ^ ":" ^ port1), + Port.of_string (proto2 ^ ":" ^ ip2 ^ ":" ^ port2) ) with | Error x, _ -> Error x | _, Error x -> Error x - | Ok local, Ok remote_port -> - Ok { local; remote_port; server = None } - end - | [ "unix"; path1; "unix"; path2 ] -> - begin + | Ok local, Ok remote_port -> Ok { local; remote_port; server = None }) + | [ "unix"; path1; "unix"; path2 ] -> ( match - Port.of_string ("unix:" ^ path1), - Port.of_string ("unix:" ^ path2) + (Port.of_string ("unix:" ^ path1), Port.of_string ("unix:" ^ path2)) with | Error x, _ -> Error x | _, Error x -> Error x - | Ok local, Ok remote_port -> - Ok { local; remote_port; server = None } - end + | Ok local, Ok remote_port -> Ok { local; remote_port; server = None }) | _ -> - errorf "Failed to parse request [%s], expected %s" x description_of_format + errorf "Failed to parse request [%s], expected %s" x + description_of_format end File "src/hostnet_test/packets.ml", line 1, characters 0-0: diff --git a/_build/default/src/hostnet_test/packets.ml b/_build/default/src/hostnet_test/.formatted/packets.ml index 2bc60d3..5c80f33 100644 --- a/_build/default/src/hostnet_test/packets.ml +++ b/_build/default/src/hostnet_test/.formatted/packets.ml @@ -1,12 +1,16 @@ - - let icmp_echo_request ~id ~seq ~len = let payload = Cstruct.create len in let pattern = "plz reply i'm so lonely" in for i = 0 to Cstruct.length payload - 1 do - Cstruct.set_char payload i pattern.[i mod (String.length pattern)] + Cstruct.set_char payload i pattern.[i mod String.length pattern] done; - let req = Icmpv4_packet.({code = 0x00; ty = Icmpv4_wire.Echo_request; - subheader = Id_and_seq (id, seq)}) in + let req = + Icmpv4_packet. + { + code = 0x00; + ty = Icmpv4_wire.Echo_request; + subheader = Id_and_seq (id, seq); + } + in let header = Icmpv4_packet.Marshal.make_cstruct req ~payload in Cstruct.concat [ header; payload ] File "src/hostnet_test/hosts_test.ml", line 1, characters 0-0: diff --git a/_build/default/src/hostnet_test/hosts_test.ml b/_build/default/src/hostnet_test/.formatted/hosts_test.ml index ea8fcc9..00bc75b 100644 --- a/_build/default/src/hostnet_test/hosts_test.ml +++ b/_build/default/src/hostnet_test/.formatted/hosts_test.ml @@ -1,44 +1,53 @@ -let examples = [ - "Windows-style", String.concat "\n" [ - "# For example:"; - "#"; - "1.2.3.4 www.docker.com # web server"; - "4.5.6.7 staging.docker.com # staging web server"; - ], [ - "www.docker.com", Ipaddr.of_string_exn "1.2.3.4"; - "staging.docker.com", Ipaddr.of_string_exn "4.5.6.7"; - ]; - "Mac-style", String.concat "\n" [ - "##"; - "# Host Database"; - "#"; - "# localhost is used to configure the loopback interface"; - "# when the system is booting. Do not change this entry."; - "##"; - "127.0.0.1 localhost mylocalhostalias"; - "255.255.255.255 broadcasthost"; - "::1 localhost"; - ], [ - "mylocalhostalias", Ipaddr.V4 Ipaddr.V4.localhost; - "localhost", Ipaddr.V4 Ipaddr.V4.localhost; - "broadcasthost", Ipaddr.of_string_exn "255.255.255.255"; - "localhost", Ipaddr.of_string_exn "::1"; +let examples = + [ + ( "Windows-style", + String.concat "\n" + [ + "# For example:"; + "#"; + "1.2.3.4 www.docker.com # web server"; + "4.5.6.7 staging.docker.com # staging web server"; + ], + [ + ("www.docker.com", Ipaddr.of_string_exn "1.2.3.4"); + ("staging.docker.com", Ipaddr.of_string_exn "4.5.6.7"); + ] ); + ( "Mac-style", + String.concat "\n" + [ + "##"; + "# Host Database"; + "#"; + "# localhost is used to configure the loopback interface"; + "# when the system is booting. Do not change this entry."; + "##"; + "127.0.0.1 \tlocalhost mylocalhostalias"; + "255.255.255.255\tbroadcasthost"; + "::1 localhost"; + ], + [ + ("mylocalhostalias", Ipaddr.V4 Ipaddr.V4.localhost); + ("localhost", Ipaddr.V4 Ipaddr.V4.localhost); + ("broadcasthost", Ipaddr.of_string_exn "255.255.255.255"); + ("localhost", Ipaddr.of_string_exn "::1"); + ] ); ] -] let test_one txt expected () = let x = Hosts.of_string txt in let expected' = List.length expected in let x' = List.length x in - if expected' <> x' - then - Fmt.kstr failwith "Expected %d hosts in /etc/hosts but found %d" - expected' x'; - List.iter (fun ((a_name, a_ip), (b_name, b_ip)) -> + if expected' <> x' then + Fmt.kstr failwith "Expected %d hosts in /etc/hosts but found %d" expected' + x'; + List.iter + (fun ((a_name, a_ip), (b_name, b_ip)) -> if Ipaddr.compare a_ip b_ip <> 0 then failwith "IP doesn't match"; - if a_name <> b_name then failwith "name doesn't match" - ) (List.combine expected x) + if a_name <> b_name then failwith "name doesn't match") + (List.combine expected x) -let tests = List.map (fun (name, txt, expected) -> - "hosts " ^ name, [ "", `Quick, test_one txt expected ] - ) examples +let tests = + List.map + (fun (name, txt, expected) -> + ("hosts " ^ name, [ ("", `Quick, test_one txt expected) ])) + examples File "src/hostnet_test/test_nmap.ml", line 1, characters 0-0: diff --git a/_build/default/src/hostnet_test/test_nmap.ml b/_build/default/src/hostnet_test/.formatted/test_nmap.ml index 43364ee..15df5bc 100644 --- a/_build/default/src/hostnet_test/test_nmap.ml +++ b/_build/default/src/hostnet_test/.formatted/test_nmap.ml @@ -10,10 +10,9 @@ module Log = (val Logs.src_log src : Logs.LOG) let failf fmt = Fmt.kstr failwith fmt -let run_test ?(timeout=Duration.of_sec 60) t = +let run_test ?(timeout = Duration.of_sec 60) t = let timeout = - Host.Time.sleep_ns timeout >>= fun () -> - Lwt.fail_with "timeout" + Host.Time.sleep_ns timeout >>= fun () -> Lwt.fail_with "timeout" in Host.Main.run @@ Lwt.pick [ timeout; t ] @@ -22,86 +21,74 @@ let run ?timeout ~pcap t = run_test ?timeout (with_stack ~pcap t) let test_nmap () = (* Attempt to connect to all ports on the host IP, then see if the host is still pingable afterwards. This checks for connection leaks / exchaustion. *) - let t _ stack = let start = Unix.gettimeofday () in let open_ports = ref [] in let connect_disconnect ip port = Client.TCPV4.create_connection (Client.tcpv4 stack.Client.t) (ip, port) >>= function - | Error _ -> - Lwt.return_unit + | Error _ -> Lwt.return_unit | Ok flow -> - open_ports := port :: !open_ports; - Client.TCPV4.close flow - >>= fun () -> - Lwt.return_unit in + open_ports := port :: !open_ports; + Client.TCPV4.close flow >>= fun () -> Lwt.return_unit + in (* Limit the number of concurrent connection requests *) let max_concurrent = 10000 in let cur_concurrent = ref 0 in let completed = ref 0 in let cur_concurrent_c = Lwt_condition.create () in let rec scan_all_ports ip first last = - if first > last - then Lwt.return_unit - else begin + if first > last then Lwt.return_unit + else let rec wait () = - if !cur_concurrent < max_concurrent then begin + if !cur_concurrent < max_concurrent then ( incr cur_concurrent; - Lwt.return_unit - end else begin - Lwt_condition.wait cur_concurrent_c - >>= fun () -> - wait () - end in - wait () - >>= fun () -> + Lwt.return_unit) + else Lwt_condition.wait cur_concurrent_c >>= fun () -> wait () + in + wait () >>= fun () -> Lwt.async (fun () -> - connect_disconnect ip first - >>= fun () -> - decr cur_concurrent; - incr completed; - Lwt_condition.broadcast cur_concurrent_c (); - Lwt.return_unit - ); + connect_disconnect ip first >>= fun () -> + decr cur_concurrent; + incr completed; + Lwt_condition.broadcast cur_concurrent_c (); + Lwt.return_unit); scan_all_ports ip (first + 1) last - end in + in let rec show_status () = - Host.Time.sleep_ns (Duration.of_sec 5) - >>= fun () -> - Log.info (fun f -> f "Connections completed: %d; connections in progress: %d" !completed !cur_concurrent); - show_status () in - Lwt.pick [ - scan_all_ports localhost_ip 1 65535; + Host.Time.sleep_ns (Duration.of_sec 5) >>= fun () -> + Log.info (fun f -> + f "Connections completed: %d; connections in progress: %d" !completed + !cur_concurrent); show_status () - ] >>= fun () -> - let rec wait () = - if !cur_concurrent > 0 then begin - Lwt_condition.wait cur_concurrent_c - >>= fun () -> - wait () - end else Lwt.return_unit in - wait () + in + Lwt.pick [ scan_all_ports localhost_ip 1 65535; show_status () ] >>= fun () -> - Log.info (fun f -> f "Total time taken to scan localhost: %.1f seconds" (Unix.gettimeofday () -. start)); + let rec wait () = + if !cur_concurrent > 0 then + Lwt_condition.wait cur_concurrent_c >>= fun () -> wait () + else Lwt.return_unit + in + wait () >>= fun () -> + Log.info (fun f -> + f "Total time taken to scan localhost: %.1f seconds" + (Unix.gettimeofday () -. start)); Log.info (fun f -> f "The following ports are open:"); List.iter (fun port -> Log.info (fun f -> f " %d" port)) !open_ports; (* Ping the host to check it's still working *) let rec loop seq = - if Queue.length Client.Icmpv41.packets > 0 - then Lwt.return_unit - else begin + if Queue.length Client.Icmpv41.packets > 0 then Lwt.return_unit + else let ping = Packets.icmp_echo_request ~id:0x1234 ~seq ~len:0 in - Log.info (fun f -> f "sending ping to verify the stack is still working"); + Log.info (fun f -> + f "sending ping to verify the stack is still working"); Client.Icmpv41.write stack.Client.icmpv4 ~dst:localhost_ip ping >>= function | Error e -> failf "Icmpv41.write failed: %a" Client.Icmpv41.pp_error e | Ok () -> - Host.Time.sleep_ns (Duration.of_sec 1) - >>= fun () -> - loop (seq + 1) - end in + Host.Time.sleep_ns (Duration.of_sec 1) >>= fun () -> loop (seq + 1) + in Queue.clear Client.Icmpv41.packets; loop 0 in - run ~timeout:(Duration.of_sec 900) ~pcap:"nmap.pcap" t \ No newline at end of file + run ~timeout:(Duration.of_sec 900) ~pcap:"nmap.pcap" t File "src/hostnet_test/main.ml", line 1, characters 0-0: diff --git a/_build/default/src/hostnet_test/main.ml b/_build/default/src/hostnet_test/.formatted/main.ml index cdd071b..952a64b 100644 --- a/_build/default/src/hostnet_test/main.ml +++ b/_build/default/src/hostnet_test/.formatted/main.ml @@ -7,47 +7,59 @@ module Log = (val Logs.src_log src : Logs.LOG) let ppf, flush = let b = Buffer.create 255 in - let flush () = let s = Buffer.contents b in Buffer.clear b; s in - Format.formatter_of_buffer b, flush + let flush () = + let s = Buffer.contents b in + Buffer.clear b; + s + in + (Format.formatter_of_buffer b, flush) let reporter = let start = Unix.gettimeofday () in fun () -> let report _src level ~over k msgf = - let k _ = Printf.printf "%s%!" (flush ()); over (); k () in + let k _ = + Printf.printf "%s%!" (flush ()); + over (); + k () + in msgf @@ fun ?header:_ ?tags:_ fmt -> let t = Unix.gettimeofday () -. start in - Format.kfprintf k ppf ("%.5f [%a] @[" ^^ fmt ^^ "@]@.") t Logs.pp_level level in + Format.kfprintf k ppf + ("%.5f [%a] @[" ^^ fmt ^^ "@]@.") + t Logs.pp_level level + in { Logs.report } (* Run it *) let () = Logs.set_reporter (reporter ()); - Lwt.async_exception_hook := (fun exn -> - Log.err (fun f -> f "Lwt.async failure %s: %s" - (Printexc.to_string exn) - (Printexc.get_backtrace ()) - ) - ); + (Lwt.async_exception_hook := + fun exn -> + Log.err (fun f -> + f "Lwt.async failure %s: %s" (Printexc.to_string exn) + (Printexc.get_backtrace ()))); (* One test requires 1026 descriptors on Unix so run ourself with the ulimit *) let child_arg = "--child" in let is_child = Array.length Sys.argv = 2 && Sys.argv.(1) = child_arg in - if Sys.os_type = "Unix" && not is_child then begin - match Unix.system (Printf.sprintf "ulimit -n 1500 && %s --child" Sys.argv.(0)) with - | Unix.WEXITED n -> exit n - | _ -> - Printf.fprintf stderr "unable to re-run with ulimit\n"; - exit 1 - end; + (if Sys.os_type = "Unix" && not is_child then + match + Unix.system (Printf.sprintf "ulimit -n 1500 && %s --child" Sys.argv.(0)) + with + | Unix.WEXITED n -> exit n + | _ -> + Printf.fprintf stderr "unable to re-run with ulimit\n"; + exit 1); Host.start_background_gc None; List.iter (fun (test, cases) -> - Printf.fprintf stderr "\n**** Starting test %s\n%!" test; - List.iter (fun (case, _, fn) -> - Printf.fprintf stderr "Starting test case %s\n%!" case; - fn () - ) cases - ) (Suite.tests @ Suite.scalability) + Printf.fprintf stderr "\n**** Starting test %s\n%!" test; + List.iter + (fun (case, _, fn) -> + Printf.fprintf stderr "Starting test case %s\n%!" case; + fn ()) + cases) + (Suite.tests @ Suite.scalability) File "src/hostnet_test/test_ping.ml", line 1, characters 0-0: diff --git a/_build/default/src/hostnet_test/test_ping.ml b/_build/default/src/hostnet_test/.formatted/test_ping.ml index aaee5e3..fa9ba51 100644 --- a/_build/default/src/hostnet_test/test_ping.ml +++ b/_build/default/src/hostnet_test/.formatted/test_ping.ml @@ -15,77 +15,97 @@ let google_2 = Ipaddr.V4.of_string_exn "8.8.4.4" let test_ping () = let id = 0x1234 in Queue.clear Slirp_stack.Client.Icmpv41.packets; - Host.Main.run begin - Slirp_stack.with_stack ~pcap:"test_ping.pcap" (fun _ stack -> - let rec loop seq = - if Queue.length Slirp_stack.Client.Icmpv41.packets > 0 - then Lwt.return_unit - else begin - let ping = Packets.icmp_echo_request ~id ~seq ~len:0 in - Printf.printf "sending ping\n%!"; - Slirp_stack.Client.Icmpv41.write stack.Slirp_stack.Client.icmpv4 ~dst:google_1 ping - >>= function - | Error e -> failf "Icmpv41.write failed: %a" Slirp_stack.Client.Icmpv41.pp_error e - | Ok () -> - Host.Time.sleep_ns (Duration.of_sec 1) - >>= fun () -> - loop (seq + 1) - end in - loop 0 - ) - end + Host.Main.run + (Slirp_stack.with_stack ~pcap:"test_ping.pcap" (fun _ stack -> + let rec loop seq = + if Queue.length Slirp_stack.Client.Icmpv41.packets > 0 then + Lwt.return_unit + else + let ping = Packets.icmp_echo_request ~id ~seq ~len:0 in + Printf.printf "sending ping\n%!"; + Slirp_stack.Client.Icmpv41.write stack.Slirp_stack.Client.icmpv4 + ~dst:google_1 ping + >>= function + | Error e -> + failf "Icmpv41.write failed: %a" + Slirp_stack.Client.Icmpv41.pp_error e + | Ok () -> + Host.Time.sleep_ns (Duration.of_sec 1) >>= fun () -> + loop (seq + 1) + in + loop 0)) let test_two_pings () = Queue.clear Slirp_stack.Client.Icmpv41.packets; - Host.Main.run begin - Slirp_stack.with_stack ~pcap:"test_two_pings.pcap" (fun _ stack -> - let rec loop seq = - let id_1 = 0x1234 in - let id_2 = 0x4321 in - let ping_1 = Packets.icmp_echo_request ~id:id_1 ~seq ~len:0 in - let ping_2 = Packets.icmp_echo_request ~id:id_2 ~seq ~len:128 in + Host.Main.run + (Slirp_stack.with_stack ~pcap:"test_two_pings.pcap" (fun _ stack -> + let rec loop seq = + let id_1 = 0x1234 in + let id_2 = 0x4321 in + let ping_1 = Packets.icmp_echo_request ~id:id_1 ~seq ~len:0 in + let ping_2 = Packets.icmp_echo_request ~id:id_2 ~seq ~len:128 in - Printf.printf "sending ping\n%!"; - Slirp_stack.Client.Icmpv41.write stack.Slirp_stack.Client.icmpv4 ~dst:google_1 ping_1 - >>= function - | Error e -> failf "Icmpv41.write failed: %a" Slirp_stack.Client.Icmpv41.pp_error e - | Ok () -> - Slirp_stack.Client.Icmpv41.write stack.Slirp_stack.Client.icmpv4 ~dst:google_2 ping_2 - >>= function - | Error e -> failf "Icmpv41.write failed: %a" Slirp_stack.Client.Icmpv41.pp_error e - | Ok () -> - Host.Time.sleep_ns (Duration.of_sec 1) - >>= fun () -> - if Queue.length Slirp_stack.Client.Icmpv41.packets > 0 then begin - let all = Queue.fold (fun xs x -> x :: xs) [] Slirp_stack.Client.Icmpv41.packets in - let one, two = List.partition (fun (_, _, id) -> id = id_1) all in - let src_one = List.map (fun (src, _, _) -> src) one in - let src_two = List.map (fun (src, _, _) -> src) two in - let one_from_1, one_from_2 = List.partition (fun src -> Ipaddr.V4.compare google_1 src = 0) src_one in - let two_from_1, two_from_2 = List.partition (fun src -> Ipaddr.V4.compare google_1 src = 0) src_two in - (* all id_2 (two) should have come from google_2 *) - (* all id_1 (one) should have come from google_1 *) - if two_from_1 <> [] || one_from_2 <> [] - then failf "Received pings from the wrong IP addresses" - else - if one_from_1 <> [] && two_from_2 <> [] then begin - Printf.printf "Received %d pings from google_1 and %d from google_2\n%!" - (List.length one_from_1) (List.length two_from_2); - Lwt.return_unit - end else loop (seq + 1) - end else loop (seq + 1) in - loop 0 - ) - end + Printf.printf "sending ping\n%!"; + Slirp_stack.Client.Icmpv41.write stack.Slirp_stack.Client.icmpv4 + ~dst:google_1 ping_1 + >>= function + | Error e -> + failf "Icmpv41.write failed: %a" + Slirp_stack.Client.Icmpv41.pp_error e + | Ok () -> ( + Slirp_stack.Client.Icmpv41.write stack.Slirp_stack.Client.icmpv4 + ~dst:google_2 ping_2 + >>= function + | Error e -> + failf "Icmpv41.write failed: %a" + Slirp_stack.Client.Icmpv41.pp_error e + | Ok () -> + Host.Time.sleep_ns (Duration.of_sec 1) >>= fun () -> + if Queue.length Slirp_stack.Client.Icmpv41.packets > 0 then + let all = + Queue.fold + (fun xs x -> x :: xs) + [] Slirp_stack.Client.Icmpv41.packets + in + let one, two = + List.partition (fun (_, _, id) -> id = id_1) all + in + let src_one = List.map (fun (src, _, _) -> src) one in + let src_two = List.map (fun (src, _, _) -> src) two in + let one_from_1, one_from_2 = + List.partition + (fun src -> Ipaddr.V4.compare google_1 src = 0) + src_one + in + let two_from_1, two_from_2 = + List.partition + (fun src -> Ipaddr.V4.compare google_1 src = 0) + src_two + in + (* all id_2 (two) should have come from google_2 *) + (* all id_1 (one) should have come from google_1 *) + if two_from_1 <> [] || one_from_2 <> [] then + failf "Received pings from the wrong IP addresses" + else if one_from_1 <> [] && two_from_2 <> [] then ( + Printf.printf + "Received %d pings from google_1 and %d from google_2\n\ + %!" + (List.length one_from_1) (List.length two_from_2); + Lwt.return_unit) + else loop (seq + 1) + else loop (seq + 1)) + in + loop 0)) -let tests = [ - "ICMP: ping 8.8.8.8", [ - "check that we can ping google's DNS", `Quick, - test_ping - ] ; - - "ICMP: two pings", [ - "check that two processes can send pings without the responses getting confused", `Quick, - test_two_pings - ]; -] +let tests = + [ + ( "ICMP: ping 8.8.8.8", + [ ("check that we can ping google's DNS", `Quick, test_ping) ] ); + ( "ICMP: two pings", + [ + ( "check that two processes can send pings without the responses \ + getting confused", + `Quick, + test_two_pings ); + ] ); + ] File "src/hostnet_test/test_bridge.ml", line 1, characters 0-0: diff --git a/_build/default/src/hostnet_test/test_bridge.ml b/_build/default/src/hostnet_test/.formatted/test_bridge.ml index df17f2c..43c0927 100644 --- a/_build/default/src/hostnet_test/test_bridge.ml +++ b/_build/default/src/hostnet_test/.formatted/test_bridge.ml @@ -12,118 +12,150 @@ exception Test_failure of string (* Open multiple connections and verify that the connection succeeds and MAC and IP changes *) let test_connect n () = - Host.Main.run begin - let rec loop x used_ips used_macs = - match x, used_ips, used_macs with - | 0, _, _ -> Lwt.return_unit - | x, used_ips, used_macs -> - let uuid = (Uuidm.v `V4) in - with_stack ~uuid ~pcap:"test_connect.pcap" (fun _ client_stack -> - (* Same IP should not appear twice *) - let ips = Client.IPV4.get_ip (Client.ipv4 client_stack.t) in - assert(List.length ips == 1); - let ip = List.hd ips in - assert((List.mem ip used_ips) == false); + Host.Main.run + (let rec loop x used_ips used_macs = + match (x, used_ips, used_macs) with + | 0, _, _ -> Lwt.return_unit + | x, used_ips, used_macs -> + let uuid = Uuidm.v `V4 in + with_stack ~uuid ~pcap:"test_connect.pcap" (fun _ client_stack -> + (* Same IP should not appear twice *) + let ips = Client.IPV4.get_ip (Client.ipv4 client_stack.t) in + assert (List.length ips == 1); + let ip = List.hd ips in + assert (List.mem ip used_ips == false); - (* Same MAC should not appear twice *) - let mac = (VMNET.mac client_stack.netif) in - assert((List.mem mac used_macs) == false); + (* Same MAC should not appear twice *) + let mac = VMNET.mac client_stack.netif in + assert (List.mem mac used_macs == false); - Lwt.return (ip, mac) - ) >>= fun (ip, mac) -> - Log.info (fun f -> f "Stack %d got IP %s and MAC %s" x (Ipaddr.V4.to_string ip) (Macaddr.to_string mac)); - loop (x - 1) ([ip] @ used_ips) ([mac] @ used_macs) - in - loop n [] [] - end + Lwt.return (ip, mac)) + >>= fun (ip, mac) -> + Log.info (fun f -> + f "Stack %d got IP %s and MAC %s" x (Ipaddr.V4.to_string ip) + (Macaddr.to_string mac)); + loop (x - 1) ([ ip ] @ used_ips) ([ mac ] @ used_macs) + in + loop n [] []) (* Connect twice with the same UUID and verify that MAC and IP are the same *) let test_reconnect () = - Host.Main.run begin - let uuid = (Uuidm.v `V4) in - Log.info (fun f -> f "Using UUID %s" (Uuidm.to_string uuid)); - with_stack ~uuid ~pcap:"test_reconnect.pcap" (fun _ client_stack -> - let ips = Client.IPV4.get_ip (Client.ipv4 client_stack.t) in - let ip = List.hd ips in - let mac = (VMNET.mac client_stack.netif) in - Lwt.return (ip, mac) - ) >>= fun (ip, mac) -> - Log.info (fun f -> f "First connection got IP %s and MAC %s" (Ipaddr.V4.to_string ip) (Macaddr.to_string mac)); - with_stack ~uuid ~pcap:"test_reconnect.2.pcap" (fun _ client_stack -> - let ips = Client.IPV4.get_ip (Client.ipv4 client_stack.t) in - let ip = List.hd ips in - let mac = (VMNET.mac client_stack.netif) in - Lwt.return (ip, mac) - ) >>= fun (reconnect_ip, reconnect_mac) -> - Log.info (fun f -> f "Reconnect got IP %s and MAC %s" (Ipaddr.V4.to_string reconnect_ip) (Macaddr.to_string reconnect_mac)); - assert(Ipaddr.V4.compare ip reconnect_ip == 0); - assert(Macaddr.compare mac reconnect_mac == 0); - Lwt.return () - end + Host.Main.run + (let uuid = Uuidm.v `V4 in + Log.info (fun f -> f "Using UUID %s" (Uuidm.to_string uuid)); + with_stack ~uuid ~pcap:"test_reconnect.pcap" (fun _ client_stack -> + let ips = Client.IPV4.get_ip (Client.ipv4 client_stack.t) in + let ip = List.hd ips in + let mac = VMNET.mac client_stack.netif in + Lwt.return (ip, mac)) + >>= fun (ip, mac) -> + Log.info (fun f -> + f "First connection got IP %s and MAC %s" (Ipaddr.V4.to_string ip) + (Macaddr.to_string mac)); + with_stack ~uuid ~pcap:"test_reconnect.2.pcap" (fun _ client_stack -> + let ips = Client.IPV4.get_ip (Client.ipv4 client_stack.t) in + let ip = List.hd ips in + let mac = VMNET.mac client_stack.netif in + Lwt.return (ip, mac)) + >>= fun (reconnect_ip, reconnect_mac) -> + Log.info (fun f -> + f "Reconnect got IP %s and MAC %s" + (Ipaddr.V4.to_string reconnect_ip) + (Macaddr.to_string reconnect_mac)); + assert (Ipaddr.V4.compare ip reconnect_ip == 0); + assert (Macaddr.compare mac reconnect_mac == 0); + Lwt.return ()) (* Connect with random UUID and request an unused IP *) let test_connect_preferred_ipv4 preferred_ip () = - Host.Main.run begin - let uuid = (Uuidm.v `V4) in - Log.info (fun f -> f "Using UUID %s, requesting IP %s" (Uuidm.to_string uuid) (Ipaddr.V4.to_string preferred_ip)); - with_stack ~uuid ~preferred_ip ~pcap:"test_connect_preferred_ipv4.pcap" (fun _ client_stack -> - let ips = Client.IPV4.get_ip (Client.ipv4 client_stack.t) in - let ip = List.hd ips in - let mac = (VMNET.mac client_stack.netif) in - Lwt.return (ip, mac) - ) >>= fun (ip, mac) -> - (* Verify that we got the IP we requested *) - assert(Ipaddr.V4.compare ip preferred_ip == 0); - Log.info (fun f -> f "First connection got IP %s and MAC %s" (Ipaddr.V4.to_string ip) (Macaddr.to_string mac)); - with_stack ~uuid ~preferred_ip ~pcap:"test_connect_preferred_ipv4.2.pcap" (fun _ client_stack -> - let ips = Client.IPV4.get_ip (Client.ipv4 client_stack.t) in - let ip = List.hd ips in - let mac = (VMNET.mac client_stack.netif) in - Lwt.return (ip, mac) - ) >>= fun (reconnect_ip, reconnect_mac) -> - Log.info (fun f -> f "Reconnect got IP %s and MAC %s" (Ipaddr.V4.to_string reconnect_ip) (Macaddr.to_string reconnect_mac)); - (* Verify that we got the same IP and MAC when reconnecting with the same UUID *) - assert(Ipaddr.V4.compare ip reconnect_ip == 0); - assert(Macaddr.compare mac reconnect_mac == 0); - (* Try to reconnect with the same UUID, but request a different IP (this should fail) *) - let different_ip = Ipaddr.V4.of_int32 (Int32.succ (Ipaddr.V4.to_int32 preferred_ip)) in - Lwt.catch (fun () -> - with_stack ~uuid ~preferred_ip:different_ip ~pcap:"test_connect_preferred_ipv4.3.pcap" (fun _ client_stack -> - let ips = Client.IPV4.get_ip (Client.ipv4 client_stack.t) in - let ip = List.hd ips in - let mac = (VMNET.mac client_stack.netif) in - Lwt.return (ip, mac) - ) >>= fun (reconnect_ip, reconnect_mac) -> - Log.err (fun f -> f "Failure: Request for different IP got IP %s and MAC %s" (Ipaddr.V4.to_string reconnect_ip) (Macaddr.to_string reconnect_mac)); - raise (Test_failure "Request for different IP for same UUID succeeded")) - (fun e -> match e with - | Failure _ -> Lwt.return () (* test was successful, an exception was triggered *) - | e -> raise e) >>= fun () -> - (* Try to reconnect with a different UUID, but request a used IP (this should fail) *) - Lwt.catch (fun () -> - let uuid = (Uuidm.v `V4) in - with_stack ~uuid ~preferred_ip ~pcap:"test_connect_preferred_ipv4.4.pcap" (fun _ client_stack -> - let ips = Client.IPV4.get_ip (Client.ipv4 client_stack.t) in - let ip = List.hd ips in - let mac = (VMNET.mac client_stack.netif) in - Lwt.return (ip, mac) - ) >>= fun (reconnect_ip, reconnect_mac) -> - Log.err (fun f -> f "Failure: Request for same IP with different UUID got IP %s and MAC %s" (Ipaddr.V4.to_string reconnect_ip) (Macaddr.to_string reconnect_mac)); - raise (Test_failure "Request for same IP with different UUID succeeded")) - (fun e -> match e with - | Failure _ -> Lwt.return () (* test was successful, an exception was triggered *) - | e -> raise e) >>= fun () -> - Lwt.return () - end - - -let tests = - [ "Vnet bridge", - [ ("connect 2 nodes", `Quick, (test_connect 2)) ; - ("connect 10 nodes", `Quick, (test_connect 10)) ; - ("reconnect node", `Quick, test_reconnect) ; - ("preferred_ipv4", `Quick, (test_connect_preferred_ipv4 preferred_ip1)); - ] - ] - + Host.Main.run + (let uuid = Uuidm.v `V4 in + Log.info (fun f -> + f "Using UUID %s, requesting IP %s" (Uuidm.to_string uuid) + (Ipaddr.V4.to_string preferred_ip)); + with_stack ~uuid ~preferred_ip ~pcap:"test_connect_preferred_ipv4.pcap" + (fun _ client_stack -> + let ips = Client.IPV4.get_ip (Client.ipv4 client_stack.t) in + let ip = List.hd ips in + let mac = VMNET.mac client_stack.netif in + Lwt.return (ip, mac)) + >>= fun (ip, mac) -> + (* Verify that we got the IP we requested *) + assert (Ipaddr.V4.compare ip preferred_ip == 0); + Log.info (fun f -> + f "First connection got IP %s and MAC %s" (Ipaddr.V4.to_string ip) + (Macaddr.to_string mac)); + with_stack ~uuid ~preferred_ip ~pcap:"test_connect_preferred_ipv4.2.pcap" + (fun _ client_stack -> + let ips = Client.IPV4.get_ip (Client.ipv4 client_stack.t) in + let ip = List.hd ips in + let mac = VMNET.mac client_stack.netif in + Lwt.return (ip, mac)) + >>= fun (reconnect_ip, reconnect_mac) -> + Log.info (fun f -> + f "Reconnect got IP %s and MAC %s" + (Ipaddr.V4.to_string reconnect_ip) + (Macaddr.to_string reconnect_mac)); + (* Verify that we got the same IP and MAC when reconnecting with the same UUID *) + assert (Ipaddr.V4.compare ip reconnect_ip == 0); + assert (Macaddr.compare mac reconnect_mac == 0); + (* Try to reconnect with the same UUID, but request a different IP (this should fail) *) + let different_ip = + Ipaddr.V4.of_int32 (Int32.succ (Ipaddr.V4.to_int32 preferred_ip)) + in + Lwt.catch + (fun () -> + with_stack ~uuid ~preferred_ip:different_ip + ~pcap:"test_connect_preferred_ipv4.3.pcap" (fun _ client_stack -> + let ips = Client.IPV4.get_ip (Client.ipv4 client_stack.t) in + let ip = List.hd ips in + let mac = VMNET.mac client_stack.netif in + Lwt.return (ip, mac)) + >>= fun (reconnect_ip, reconnect_mac) -> + Log.err (fun f -> + f "Failure: Request for different IP got IP %s and MAC %s" + (Ipaddr.V4.to_string reconnect_ip) + (Macaddr.to_string reconnect_mac)); + raise (Test_failure "Request for different IP for same UUID succeeded")) + (fun e -> + match e with + | Failure _ -> + Lwt.return () (* test was successful, an exception was triggered *) + | e -> raise e) + >>= fun () -> + (* Try to reconnect with a different UUID, but request a used IP (this should fail) *) + Lwt.catch + (fun () -> + let uuid = Uuidm.v `V4 in + with_stack ~uuid ~preferred_ip + ~pcap:"test_connect_preferred_ipv4.4.pcap" (fun _ client_stack -> + let ips = Client.IPV4.get_ip (Client.ipv4 client_stack.t) in + let ip = List.hd ips in + let mac = VMNET.mac client_stack.netif in + Lwt.return (ip, mac)) + >>= fun (reconnect_ip, reconnect_mac) -> + Log.err (fun f -> + f + "Failure: Request for same IP with different UUID got IP %s and \ + MAC %s" + (Ipaddr.V4.to_string reconnect_ip) + (Macaddr.to_string reconnect_mac)); + raise + (Test_failure "Request for same IP with different UUID succeeded")) + (fun e -> + match e with + | Failure _ -> + Lwt.return () (* test was successful, an exception was triggered *) + | e -> raise e) + >>= fun () -> Lwt.return ()) +let tests = + [ + ( "Vnet bridge", + [ + ("connect 2 nodes", `Quick, test_connect 2); + ("connect 10 nodes", `Quick, test_connect 10); + ("reconnect node", `Quick, test_reconnect); + ("preferred_ipv4", `Quick, test_connect_preferred_ipv4 preferred_ip1); + ] ); + ] File "src/hostnet_test/test_dns.ml", line 1, characters 0-0: diff --git a/_build/default/src/hostnet_test/test_dns.ml b/_build/default/src/hostnet_test/.formatted/test_dns.ml index e2aff32..734f236 100644 --- a/_build/default/src/hostnet_test/test_dns.ml +++ b/_build/default/src/hostnet_test/.formatted/test_dns.ml @@ -11,15 +11,13 @@ module Log = (val Logs.src_log src : Logs.LOG) let pp_ips = Fmt.(list ~sep:(any ", ") Ipaddr.pp) let pp_ip4s = Fmt.(list ~sep:(any ", ") Ipaddr.V4.pp) -let run_test ?(timeout=Duration.of_sec 60) t = +let run_test ?(timeout = Duration.of_sec 60) t = let timeout = - Host.Time.sleep_ns timeout >>= fun () -> - Lwt.fail_with "timeout" + Host.Time.sleep_ns timeout >>= fun () -> Lwt.fail_with "timeout" in Host.Main.run @@ Lwt.pick [ timeout; t ] let run ?timeout ~pcap t = run_test ?timeout (with_stack ~pcap t) - let default_upstream_dns = Dns_policy.google_dns let set_dns_policy ?builtin_names config = @@ -36,26 +34,29 @@ let test_dns_query server config () = set_dns_policy config; let resolver = DNS.create stack.Client.t in DNS.gethostbyname ~server resolver "www.google.com" >|= function - | (_ :: _) as ips -> - Log.info (fun f -> f "www.google.com has IPs: %a" pp_ips ips); + | _ :: _ as ips -> + Log.info (fun f -> f "www.google.com has IPs: %a" pp_ips ips) | _ -> - Log.err (fun f -> f "Failed to lookup www.google.com"); - failwith "Failed to lookup www.google.com" + Log.err (fun f -> f "Failed to lookup www.google.com"); + failwith "Failed to lookup www.google.com" in run ~pcap:"test_dns_query.pcap" t let test_builtin_dns_query server config () = let name = "experimental.host.name.localhost" in let t _ stack = - set_dns_policy ~builtin_names:[ Dns.Name.of_string name, Ipaddr.V4 (Ipaddr.V4.localhost) ] config; + set_dns_policy + ~builtin_names: + [ (Dns.Name.of_string name, Ipaddr.V4 Ipaddr.V4.localhost) ] + config; let resolver = DNS.create stack.Client.t in DNS.gethostbyname ~server resolver name >>= function - | (_ :: _) as ips -> - Log.info (fun f -> f "%s has IPs: %a" name pp_ips ips); - Lwt.return () + | _ :: _ as ips -> + Log.info (fun f -> f "%s has IPs: %a" name pp_ips ips); + Lwt.return () | _ -> - Log.err (fun f -> f "Failed to lookup %s" name); - failwith ("Failed to lookup " ^ name) + Log.err (fun f -> f "Failed to lookup %s" name); + failwith ("Failed to lookup " ^ name) in run ~pcap:"test_builtin_dns_query.pcap" t @@ -65,23 +66,23 @@ let test_etc_hosts_query server config () = set_dns_policy config; let resolver = DNS.create stack.Client.t in DNS.gethostbyname ~server resolver test_name >>= function - | (_ :: _) as ips -> - Log.err (fun f -> - f "This test relies on the name %s not existing but it really \ - has IPs: %a" test_name pp_ips ips); - Fmt.kstr failwith "Test name %s really does exist" test_name - | _ -> - Hosts.etc_hosts := [ - test_name, Ipaddr.V4 (Ipaddr.V4.localhost); - ]; - DNS.gethostbyname ~server resolver test_name >|= function - | (_ :: _) as ips -> - Log.info (fun f -> f "Name %s has IPs: %a" test_name pp_ips ips); - Hosts.etc_hosts := [] - | _ -> - Log.err (fun f -> f "Failed to lookup name from /etc/hosts"); - Hosts.etc_hosts := []; - failwith "failed to lookup name from /etc/hosts" + | _ :: _ as ips -> + Log.err (fun f -> + f + "This test relies on the name %s not existing but it really has \ + IPs: %a" + test_name pp_ips ips); + Fmt.kstr failwith "Test name %s really does exist" test_name + | _ -> ( + Hosts.etc_hosts := [ (test_name, Ipaddr.V4 Ipaddr.V4.localhost) ]; + DNS.gethostbyname ~server resolver test_name >|= function + | _ :: _ as ips -> + Log.info (fun f -> f "Name %s has IPs: %a" test_name pp_ips ips); + Hosts.etc_hosts := [] + | _ -> + Log.err (fun f -> f "Failed to lookup name from /etc/hosts"); + Hosts.etc_hosts := []; + failwith "failed to lookup name from /etc/hosts") in run ~pcap:"test_etc_hosts_query.pcap" t @@ -90,98 +91,98 @@ let test_etc_hosts_priority server config () = let builtin_ip = Ipaddr.of_string_exn "127.0.0.1" in let hosts_ip = Ipaddr.of_string_exn "127.0.0.2" in let t _ stack = - set_dns_policy ~builtin_names:[ Dns.Name.of_string name, builtin_ip ] config; - Hosts.etc_hosts := [ - name, hosts_ip; - ]; + set_dns_policy + ~builtin_names:[ (Dns.Name.of_string name, builtin_ip) ] + config; + Hosts.etc_hosts := [ (name, hosts_ip) ]; let resolver = DNS.create stack.Client.t in DNS.gethostbyname ~server resolver name >>= function | [ ip ] -> - Log.info (fun f -> f "%s has single IP: %a" name Ipaddr.pp ip); - if Ipaddr.compare ip builtin_ip = 0 - then Lwt.return () - else failwith ("Builtin DNS names should have higher priority than /etc/hosts") - | (_ :: _) as ips -> - Log.info (fun f -> f "%s has IPs: %a" name pp_ips ips); - failwith ("Duplicate DNS names resolved for " ^ name); + Log.info (fun f -> f "%s has single IP: %a" name Ipaddr.pp ip); + if Ipaddr.compare ip builtin_ip = 0 then Lwt.return () + else + failwith + "Builtin DNS names should have higher priority than /etc/hosts" + | _ :: _ as ips -> + Log.info (fun f -> f "%s has IPs: %a" name pp_ips ips); + failwith ("Duplicate DNS names resolved for " ^ name) | _ -> - Log.err (fun f -> f "Failed to lookup %s" name); - failwith ("Failed to lookup " ^ name) + Log.err (fun f -> f "Failed to lookup %s" name); + failwith ("Failed to lookup " ^ name) in run ~pcap:"test_etc_hosts_priority.pcap" t let test_dns config = - let prefix = Dns_policy.(Config.to_string @@ config ()) in [ - prefix ^ ": lookup ", - ["", `Quick, test_dns_query primary_dns_ip config]; - - prefix ^ ": builtins", - [ "", `Quick, test_builtin_dns_query primary_dns_ip config ]; - - prefix ^ ": _etc_hosts", - [ "", `Quick, test_etc_hosts_query primary_dns_ip config ]; - - prefix ^ ": _etc_hosts_priority", - [ "", `Quick, test_etc_hosts_priority primary_dns_ip config ]; + let prefix = Dns_policy.(Config.to_string @@ config ()) in + [ + ( prefix ^ ": lookup ", + [ ("", `Quick, test_dns_query primary_dns_ip config) ] ); + ( prefix ^ ": builtins", + [ ("", `Quick, test_builtin_dns_query primary_dns_ip config) ] ); + ( prefix ^ ": _etc_hosts", + [ ("", `Quick, test_etc_hosts_query primary_dns_ip config) ] ); + ( prefix ^ ": _etc_hosts_priority", + [ ("", `Quick, test_etc_hosts_priority primary_dns_ip config) ] ); ] (* A real UDP server listening on a physical port *) module Server = struct open Host.Sockets.Datagram - type t = { - ip: Ipaddr.t; - port: int; - server: Udp.server; - } + + type t = { ip : Ipaddr.t; port : int; server : Udp.server } + let with_server ip answers f = - Udp.bind ~description:"DNS server" (ip, 0) - >>= fun server -> - Udp.listen server - (fun flow -> + Udp.bind ~description:"DNS server" (ip, 0) >>= fun server -> + Udp.listen server (fun flow -> Log.debug (fun f -> f "Received UDP datagram"); - let open Dns.Packet in - Udp.read flow - >>= function + let open Dns.Packet in + Udp.read flow >>= function | Error _ -> - Log.err (fun f -> f "Udp.listen failed to read"); - Lwt.return_unit - | Ok `Eof -> - Log.err (fun f -> f "Udp.read got EOF"); - Lwt.return_unit - | Ok (`Data buf) -> - let len = Cstruct.length buf in - begin match Dns.Protocol.Server.parse (Cstruct.sub buf 0 len) with - | None -> - Log.err (fun f -> f "failed to parse DNS packet"); + Log.err (fun f -> f "Udp.listen failed to read"); Lwt.return_unit - | Some ({ questions = [ _question ]; _ } as request) -> - - let reply answers = - let id = request.id in - let detail = - { request.detail with Dns.Packet.qr = Dns.Packet.Response; ra = true } - in - let questions = request.questions in - let authorities = [] and additionals = [] in - { Dns.Packet.id; detail; questions; answers; authorities; additionals } - in - let buf = marshal @@ reply answers in - Log.info (fun f -> f "DNS response is a UDP datagram of length %d" (Cstruct.length buf)); - begin Udp.write flow buf - >>= function - | Ok () -> - Lwt.return_unit - | Error _ -> - Log.err (fun f -> f "Failed to send UDP response"); - Lwt.return_unit - end - | Some _ -> - Log.info (fun f -> f "Dropping unexpected DNS request"); + | Ok `Eof -> + Log.err (fun f -> f "Udp.read got EOF"); Lwt.return_unit - end - ); - Udp.getsockname server - >>= fun (_, realport) -> + | Ok (`Data buf) -> ( + let len = Cstruct.length buf in + match Dns.Protocol.Server.parse (Cstruct.sub buf 0 len) with + | None -> + Log.err (fun f -> f "failed to parse DNS packet"); + Lwt.return_unit + | Some ({ questions = [ _question ]; _ } as request) -> ( + let reply answers = + let id = request.id in + let detail = + { + request.detail with + Dns.Packet.qr = Dns.Packet.Response; + ra = true; + } + in + let questions = request.questions in + let authorities = [] and additionals = [] in + { + Dns.Packet.id; + detail; + questions; + answers; + authorities; + additionals; + } + in + let buf = marshal @@ reply answers in + Log.info (fun f -> + f "DNS response is a UDP datagram of length %d" + (Cstruct.length buf)); + Udp.write flow buf >>= function + | Ok () -> Lwt.return_unit + | Error _ -> + Log.err (fun f -> f "Failed to send UDP response"); + Lwt.return_unit) + | Some _ -> + Log.info (fun f -> f "Dropping unexpected DNS request"); + Lwt.return_unit)); + Udp.getsockname server >>= fun (_, realport) -> let t = { ip; port = realport; server } in Lwt.finalize (fun () -> f t.port) (fun () -> Udp.shutdown t.server) end @@ -191,37 +192,51 @@ let err_udp e = Fmt.kstr failwith "%a" Client.UDPV4.pp_error e let udp_rpc client src_port dst dst_port buffer = let udpv4 = Client.udpv4 client.Client.t in let send_request () = - Client.UDPV4.write ~src_port ~dst ~dst_port udpv4 buffer - >>= function + Client.UDPV4.write ~src_port ~dst ~dst_port udpv4 buffer >>= function | Error e -> err_udp e - | Ok () -> Lwt.return_unit in + | Ok () -> Lwt.return_unit + in let response = ref None in - Client.UDPV4.listen (Client.udpv4 client.Client.t) ~port:src_port (fun ~src:_ ~dst:_ ~src_port:remote_src_port buffer -> - Log.debug (fun f -> - f "Received UDP %d -> %d" remote_src_port src_port); - begin match !response with - | Some _ -> () (* drop duplicates *) - | None -> response := Some buffer - end; - Lwt.return_unit - ); + Client.UDPV4.listen (Client.udpv4 client.Client.t) ~port:src_port + (fun ~src:_ ~dst:_ ~src_port:remote_src_port buffer -> + Log.debug (fun f -> f "Received UDP %d -> %d" remote_src_port src_port); + (match !response with + | Some _ -> () (* drop duplicates *) + | None -> response := Some buffer); + Lwt.return_unit); let rec loop () = - send_request () - >>= fun () -> + send_request () >>= fun () -> match !response with | Some x -> Lwt.return x - | None -> - Host.Time.sleep_ns (Duration.of_sec 1) - >>= fun () -> - loop () in + | None -> Host.Time.sleep_ns (Duration.of_sec 1) >>= fun () -> loop () + in loop () let query_a name = let open Dns.Packet in let id = Random.int 0xffff in - let detail = { qr = Query; opcode = Standard; aa = false; tc = false; rd = true; ra = false; rcode = NoError } in - let questions = [ { q_name = Dns.Name.of_string name; q_type = Q_A; q_class = Q_IN; q_unicast = Q_Normal }] in + let detail = + { + qr = Query; + opcode = Standard; + aa = false; + tc = false; + rd = true; + ra = false; + rcode = NoError; + } + in + let questions = + [ + { + q_name = Dns.Name.of_string name; + q_type = Q_A; + q_class = Q_IN; + q_unicast = Q_Normal; + }; + ] + in let answers = [] and authorities = [] and additionals = [] in { id; detail; questions; answers; authorities; additionals } @@ -229,42 +244,62 @@ let truncate_big_response () = let t _ client = let ip = Ipaddr.V4 Ipaddr.V4.localhost in (* The DNS response will be over 512 bytes *) - let answers = Array.to_list @@ Array.make 64 - { Dns.Packet.name = Dns.Name.of_string "anything"; cls = RR_IN; - flush = false; ttl = 0l; rdata = A Ipaddr.V4.localhost } in - Server.with_server ip answers - (fun port -> + let answers = + Array.to_list + @@ Array.make 64 + { + Dns.Packet.name = Dns.Name.of_string "anything"; + cls = RR_IN; + flush = false; + ttl = 0l; + rdata = A Ipaddr.V4.localhost; + } + in + Server.with_server ip answers (fun port -> let open Dns_forward.Config in - let servers = Server.Set.of_list [ - { Server.address = { Address.ip; port }; - zones = Domain.Set.empty; - timeout_ms = Some 2000; order = 0 - } - ] in - let config = `Upstream { servers; search = []; assume_offline_after_drops = None } in + let servers = + Server.Set.of_list + [ + { + Server.address = { Address.ip; port }; + zones = Domain.Set.empty; + timeout_ms = Some 2000; + order = 0; + }; + ] + in + let config = + `Upstream { servers; search = []; assume_offline_after_drops = None } + in set_dns_policy config; Lwt.finalize (fun () -> - udp_rpc client 1024 primary_dns_ip 53 (Dns.Packet.marshal @@ query_a "very.big.name") + udp_rpc client 1024 primary_dns_ip 53 + (Dns.Packet.marshal @@ query_a "very.big.name") >>= fun response -> - Log.err (fun f -> f "UDP response has length %d" (Cstruct.length response)); - begin match Dns.Protocol.Server.parse response with - | None -> - failwith "failed to parse truncated DNS response" + Log.err (fun f -> + f "UDP response has length %d" (Cstruct.length response)); + match Dns.Protocol.Server.parse response with + | None -> failwith "failed to parse truncated DNS response" | Some { Dns.Packet.detail = { tc = true; _ }; answers; _ } -> - Log.info (fun f -> f "DNS response has truncated bit set"); - if List.length answers <> 29 - then failwith (Printf.sprintf "expected 29 answers, got %d" (List.length answers)); - Lwt.return_unit + Log.info (fun f -> f "DNS response has truncated bit set"); + if List.length answers <> 29 then + failwith + (Printf.sprintf "expected 29 answers, got %d" + (List.length answers)); + Lwt.return_unit | Some { Dns.Packet.detail = { tc = false; _ }; _ } -> - failwith "DNS response does not have truncated bit set" - end - ) (fun () -> reset_dns_policy (); Lwt.return_unit) - ) - in + failwith "DNS response does not have truncated bit set") + (fun () -> + reset_dns_policy (); + Lwt.return_unit)) + in run ~pcap:"truncate_big_response.pcap" t -let suite = test_dns `Host @ (test_dns default_upstream_dns) @ [ - "big UDP responses are truncated", - [ "", `Quick, truncate_big_response ] -] +let suite = + test_dns `Host + @ test_dns default_upstream_dns + @ [ + ( "big UDP responses are truncated", + [ ("", `Quick, truncate_big_response) ] ); + ] File "src/hostnet_test/test_half_close.ml", line 1, characters 0-0: diff --git a/_build/default/src/hostnet_test/test_half_close.ml b/_build/default/src/hostnet_test/.formatted/test_half_close.ml index cab4c69..f909a83 100644 --- a/_build/default/src/hostnet_test/test_half_close.ml +++ b/_build/default/src/hostnet_test/.formatted/test_half_close.ml @@ -10,254 +10,264 @@ let failf fmt = Fmt.kstr failwith fmt module Log = (val Logs.src_log src : Logs.LOG) module Server = struct - type t = { - server: Host.Sockets.Stream.Tcp.server; - port: int; - } + type t = { server : Host.Sockets.Stream.Tcp.server; port : int } + let create on_accept = Host.Sockets.Stream.Tcp.bind (Ipaddr.V4 Ipaddr.V4.localhost, 0) >>= fun server -> - Host.Sockets.Stream.Tcp.getsockname server - >>= fun (_, port) -> + Host.Sockets.Stream.Tcp.getsockname server >>= fun (_, port) -> Host.Sockets.Stream.Tcp.listen server on_accept; Lwt.return { server; port } - let destroy t = - Host.Sockets.Stream.Tcp.shutdown t.server + + let destroy t = Host.Sockets.Stream.Tcp.shutdown t.server end + let with_server on_accept f = - Server.create on_accept - >>= fun server -> + Server.create on_accept >>= fun server -> Lwt.finalize (fun () -> f server) (fun () -> Server.destroy server) module Outgoing = struct - module C = Mirage_channel.Make(Slirp_stack.Client.TCPV4) + module C = Mirage_channel.Make (Slirp_stack.Client.TCPV4) end + module Incoming = struct - module C = Mirage_channel.Make(Host.Sockets.Stream.Tcp) + module C = Mirage_channel.Make (Host.Sockets.Stream.Tcp) end let request = "Hello there" let response = "And hello to you" let data = function -| Ok (`Data x) -> x -| Ok `Eof -> failwith "data: eof" -| Error _ -> failwith "data: error" + | Ok (`Data x) -> x + | Ok `Eof -> failwith "data: eof" + | Error _ -> failwith "data: error" -let unit = function -| Ok () -> () -| Error _ -> failwith "unit: error" +let unit = function Ok () -> () | Error _ -> failwith "unit: error" let flow ip port = function -| Ok flow -> flow -| Error _ -> - Log.err (fun f -> f "Failed to connect to %a:%d" Ipaddr.V4.pp ip port); - failwith "Client.TCPV4.create_connection" + | Ok flow -> flow + | Error _ -> + Log.err (fun f -> f "Failed to connect to %a:%d" Ipaddr.V4.pp ip port); + failwith "Client.TCPV4.create_connection" (* Run a simple server on localhost and connect to it via vpnkit. The Mirage client will call `close` to trigger a half-close of the TCP connection before reading the response. This verifies that the other side of the connection remains open. *) let test_mirage_half_close () = - Host.Main.run begin - let forwarded, forwarded_u = Lwt.task () in - Slirp_stack.with_stack ~pcap:"test_mirage_half_close.pcap" (fun _ stack -> with_server (fun flow -> - (* Read the request until EOF *) - let ic = Incoming.C.create flow in - Incoming.C.read_line ic >|= data >>= fun bufs -> - let txt = Cstruct.(to_string @@ concat bufs) in - if txt <> request - then failf "Expected to read '%s', got '%s'" request txt; - Incoming.C.read_line ic >|= data >>= fun bufs -> - assert (Cstruct.(length @@ concat bufs) = 0); - Log.info (fun f -> f "Read the request (up to and including EOF)"); + Host.Main.run + (let forwarded, forwarded_u = Lwt.task () in + Slirp_stack.with_stack ~pcap:"test_mirage_half_close.pcap" (fun _ stack -> + with_server + (fun flow -> + (* Read the request until EOF *) + let ic = Incoming.C.create flow in + Incoming.C.read_line ic >|= data >>= fun bufs -> + let txt = Cstruct.(to_string @@ concat bufs) in + if txt <> request then + failf "Expected to read '%s', got '%s'" request txt; + Incoming.C.read_line ic >|= data >>= fun bufs -> + assert (Cstruct.(length @@ concat bufs) = 0); + Log.info (fun f -> f "Read the request (up to and including EOF)"); - (* Write a response. If the connection is fully closed - rather than half-closed then this will fail. *) - Incoming.C.write_line ic response; - Incoming.C.flush ic >|= unit >>= fun () -> - Log.info (fun f -> f "Written response"); - Lwt.wakeup_later forwarded_u (); - Lwt.return_unit - ) (fun server -> - (* Now that the server is running, connect to it and send a - request. *) - let open Slirp_stack in - let ip = Ipaddr.V4.localhost in - let port = server.Server.port in - Client.TCPV4.create_connection (Client.tcpv4 stack.t) (ip, port) - >|= flow ip port >>= fun flow -> - Log.info (fun f -> f "Connected to %a:%d" Ipaddr.V4.pp ip port); - let oc = Outgoing.C.create flow in - Outgoing.C.write_line oc request; - Outgoing.C.flush oc >|= unit >>= fun () -> - - (* This will perform a TCP half-close *) - Client.TCPV4.close flow >>= fun () -> - - (* Verify the response is still intact *) - Outgoing.C.read_line oc >|= data >>= fun bufs -> - let txt = Cstruct.(to_string @@ concat bufs) in - if txt <> response - then failf "Expected to read '%s', got '%s'" response txt; - Log.info (fun f -> f "Read the response. Waiting for cleanup"); - Lwt.pick [ - (Host.Time.sleep_ns (Duration.of_sec 100) >|= fun () -> `Timeout); - (forwarded >|= fun x -> `Result x) ] - ) >>= function - | `Timeout -> failwith "TCP half close test timed-out" - | `Result x -> Lwt.return x - ) - end + (* Write a response. If the connection is fully closed + rather than half-closed then this will fail. *) + Incoming.C.write_line ic response; + Incoming.C.flush ic >|= unit >>= fun () -> + Log.info (fun f -> f "Written response"); + Lwt.wakeup_later forwarded_u (); + Lwt.return_unit) + (fun server -> + (* Now that the server is running, connect to it and send a + request. *) + let open Slirp_stack in + let ip = Ipaddr.V4.localhost in + let port = server.Server.port in + Client.TCPV4.create_connection (Client.tcpv4 stack.t) (ip, port) + >|= flow ip port + >>= fun flow -> + Log.info (fun f -> f "Connected to %a:%d" Ipaddr.V4.pp ip port); + let oc = Outgoing.C.create flow in + Outgoing.C.write_line oc request; + Outgoing.C.flush oc >|= unit >>= fun () -> + (* This will perform a TCP half-close *) + Client.TCPV4.close flow >>= fun () -> + (* Verify the response is still intact *) + Outgoing.C.read_line oc >|= data >>= fun bufs -> + let txt = Cstruct.(to_string @@ concat bufs) in + if txt <> response then + failf "Expected to read '%s', got '%s'" response txt; + Log.info (fun f -> f "Read the response. Waiting for cleanup"); + Lwt.pick + [ + ( Host.Time.sleep_ns (Duration.of_sec 100) >|= fun () -> + `Timeout ); + (forwarded >|= fun x -> `Result x); + ]) + >>= function + | `Timeout -> failwith "TCP half close test timed-out" + | `Result x -> Lwt.return x)) (* Run a simple server on localhost and connect to it via vpnkit. The server on the host will call `close` to trigger a half-close of the TCP connection before reading the response. This verifies that the other side of the connection remains open. *) let test_host_half_close () = - Host.Main.run begin - let forwarded, forwarded_u = Lwt.task () in - Slirp_stack.with_stack ~pcap:"test_host_half_close.pcap" (fun _ stack -> with_server (fun flow -> - (* Write a request *) - let ic = Incoming.C.create flow in - Incoming.C.write_line ic request; - Incoming.C.flush ic >|= unit >>= fun () -> - - (* This will perform a TCP half-close *) - Host.Sockets.Stream.Tcp.shutdown_write flow >>= fun () -> - - (* Read the response from the other side of the connection *) - Incoming.C.read_line ic >|= data - >>= fun bufs -> - let txt = Cstruct.(to_string @@ concat bufs) in - if txt <> response - then failf "Expected to read '%s', got '%s'" response txt; - Log.info (fun f -> f "Read the response, signalling complete"); - Lwt.wakeup_later forwarded_u (); - Lwt.return_unit - ) (fun server -> - (* Now that the server is running, connect to it and send a - request. *) - let open Slirp_stack in - let ip = Ipaddr.V4.localhost in - let port = server.Server.port in - Client.TCPV4.create_connection (Client.tcpv4 stack.t) (ip, port) - >|= flow ip port >>= fun flow -> - Log.info (fun f -> f "Connected to %a:%d" Ipaddr.V4.pp ip port); - let oc = Outgoing.C.create flow in - (* Read the request *) - Outgoing.C.read_line oc >|= data >>= fun bufs -> - let txt = Cstruct.(to_string @@ concat bufs) in - if txt <> request - then failf "Expected to read '%s', got '%s'" request txt; - (* Check we're at EOF *) - Outgoing.C.read_line oc >|= data >>= fun bufs -> - assert (Cstruct.(length @@ concat bufs) = 0); - Log.info (fun f -> f "Read the request (up to and including EOF)"); - (* Write response *) - Outgoing.C.write_line oc response; - Outgoing.C.flush oc >|= unit >>= fun () -> - Log.info (fun f -> f "Written response and will wait."); - Lwt.pick [ - (Host.Time.sleep_ns (Duration.of_sec 100) >|= fun () -> `Timeout); - (forwarded >|= fun x -> `Result x) ] - ) >>= function - | `Timeout -> failwith "TCP half close test timed-out" - | `Result x -> Lwt.return x - ) - end + Host.Main.run + (let forwarded, forwarded_u = Lwt.task () in + Slirp_stack.with_stack ~pcap:"test_host_half_close.pcap" (fun _ stack -> + with_server + (fun flow -> + (* Write a request *) + let ic = Incoming.C.create flow in + Incoming.C.write_line ic request; + Incoming.C.flush ic >|= unit >>= fun () -> + (* This will perform a TCP half-close *) + Host.Sockets.Stream.Tcp.shutdown_write flow >>= fun () -> + (* Read the response from the other side of the connection *) + Incoming.C.read_line ic >|= data >>= fun bufs -> + let txt = Cstruct.(to_string @@ concat bufs) in + if txt <> response then + failf "Expected to read '%s', got '%s'" response txt; + Log.info (fun f -> f "Read the response, signalling complete"); + Lwt.wakeup_later forwarded_u (); + Lwt.return_unit) + (fun server -> + (* Now that the server is running, connect to it and send a + request. *) + let open Slirp_stack in + let ip = Ipaddr.V4.localhost in + let port = server.Server.port in + Client.TCPV4.create_connection (Client.tcpv4 stack.t) (ip, port) + >|= flow ip port + >>= fun flow -> + Log.info (fun f -> f "Connected to %a:%d" Ipaddr.V4.pp ip port); + let oc = Outgoing.C.create flow in + (* Read the request *) + Outgoing.C.read_line oc >|= data >>= fun bufs -> + let txt = Cstruct.(to_string @@ concat bufs) in + if txt <> request then + failf "Expected to read '%s', got '%s'" request txt; + (* Check we're at EOF *) + Outgoing.C.read_line oc >|= data >>= fun bufs -> + assert (Cstruct.(length @@ concat bufs) = 0); + Log.info (fun f -> f "Read the request (up to and including EOF)"); + (* Write response *) + Outgoing.C.write_line oc response; + Outgoing.C.flush oc >|= unit >>= fun () -> + Log.info (fun f -> f "Written response and will wait."); + Lwt.pick + [ + ( Host.Time.sleep_ns (Duration.of_sec 100) >|= fun () -> + `Timeout ); + (forwarded >|= fun x -> `Result x); + ]) + >>= function + | `Timeout -> failwith "TCP half close test timed-out" + | `Result x -> Lwt.return x)) let test_connect_valid_invalid_port () = - Host.Main.run begin - Slirp_stack.with_stack ~pcap:"test_connect_valid_invalid_port.pcap" (fun _ stack -> with_server (fun _ -> - Lwt.return_unit - ) (fun server -> - (* Now that a server is running, connect to a valid port and ensure it succeeds quickly *) - let open Slirp_stack in - let ip = Ipaddr.V4.localhost in - let port = server.Server.port in - let mkconn = Client.TCPV4.create_connection (Client.tcpv4 stack.t) (ip, port) - >|= function - | Ok _ -> - Log.debug (fun f -> - f "Connected to localhost:%d" port); - | Error _ -> - Log.err (fun f -> - f "Failure to connect to localhost:%d" port); - failwith "Connection should have succeeded"; - >>= fun () -> - Server.destroy server; - >>= fun () -> - (* Now that a server is down, connect to an invalid port and ensure it fails quickly *) - Client.TCPV4.create_connection (Client.tcpv4 stack.t) (ip, port) - >|= function - | Ok _ -> - Log.err (fun f -> - f "Connected to localhost:%d" port); - failwith "Connection should have failed" - | Error _ -> - Log.debug (fun f -> - f "Expected failure to connect to localhost:%d" port); - in Lwt.pick [ - (Host.Time.sleep_ns (Duration.of_sec 5) >|= fun () -> `Timeout); - (mkconn >|= fun x -> `Result x) ] - ) >>= function - | `Timeout -> failwith "TCP server invalid port test timed-out" - | `Result x -> Lwt.return x - ) - end - - let test_connect_multiple_valid_ports () = - Host.Main.run begin - Slirp_stack.with_stack ~pcap:"test_connect_multiple_valid_ports.pcap" (fun _ stack -> with_server (fun _ -> - Lwt.return_unit - ) (fun server -> - let open Slirp_stack in - let ip = Ipaddr.V4.localhost in - let port = server.Server.port in - let rec mkconn = function - | 0 -> Lwt.return (); - | 3 -> Server.destroy server >>= fun () -> mkconn 1; - | count -> Client.TCPV4.create_connection (Client.tcpv4 stack.t) (ip, port) - >|= function - | Ok _ -> - Log.debug (fun f -> - f "Connected tentative %d to localhost:%d" count port); - | Error _ -> - Log.debug (fun f -> - f "Failure to connect to localhost:%d" port); - >>= - fun () -> mkconn (count-1); - in - Lwt.pick [ - (Host.Time.sleep_ns (Duration.of_sec 5) >|= fun () -> `Timeout); - (mkconn 8 >|= fun x -> `Result x) ] - ) >>= function - | `Timeout -> failwith "TCP server valid port test timed-out" - | `Result x -> Lwt.return x - ) - end - -let tests = [ - - "TCP: test Mirage half close", [ - "check that Mirage half-close isn't a full-close", `Quick, - test_mirage_half_close - ] ; - - "TCP: test Host half close", [ - "check that the Host half-close isn't a full-close", `Quick, - test_host_half_close - ] ; - - "TCP: test server valid invalid port", [ - "check that a connection to a valid port does not block after the port becomes invalid", `Quick, - test_connect_valid_invalid_port - ] ; + Host.Main.run + (Slirp_stack.with_stack ~pcap:"test_connect_valid_invalid_port.pcap" + (fun _ stack -> + with_server + (fun _ -> Lwt.return_unit) + (fun server -> + (* Now that a server is running, connect to a valid port and ensure it succeeds quickly *) + let open Slirp_stack in + let ip = Ipaddr.V4.localhost in + let port = server.Server.port in + let mkconn = + ( (Client.TCPV4.create_connection (Client.tcpv4 stack.t) + (ip, port) + >|= function + | Ok _ -> + Log.debug (fun f -> f "Connected to localhost:%d" port) + | Error _ -> + Log.err (fun f -> + f "Failure to connect to localhost:%d" port); + failwith "Connection should have succeeded") + >>= fun () -> Server.destroy server ) + >>= fun () -> + (* Now that a server is down, connect to an invalid port and ensure it fails quickly *) + Client.TCPV4.create_connection (Client.tcpv4 stack.t) (ip, port) + >|= function + | Ok _ -> + Log.err (fun f -> f "Connected to localhost:%d" port); + failwith "Connection should have failed" + | Error _ -> + Log.debug (fun f -> + f "Expected failure to connect to localhost:%d" port) + in + Lwt.pick + [ + (Host.Time.sleep_ns (Duration.of_sec 5) >|= fun () -> `Timeout); + (mkconn >|= fun x -> `Result x); + ]) + >>= function + | `Timeout -> failwith "TCP server invalid port test timed-out" + | `Result x -> Lwt.return x)) - "TCP: test server multiple valid ports", [ - "check that multiple connections to valid and invalid ports", `Quick, - test_connect_multiple_valid_ports - ] ; +let test_connect_multiple_valid_ports () = + Host.Main.run + (Slirp_stack.with_stack ~pcap:"test_connect_multiple_valid_ports.pcap" + (fun _ stack -> + with_server + (fun _ -> Lwt.return_unit) + (fun server -> + let open Slirp_stack in + let ip = Ipaddr.V4.localhost in + let port = server.Server.port in + let rec mkconn = function + | 0 -> Lwt.return () + | 3 -> Server.destroy server >>= fun () -> mkconn 1 + | count -> + (Client.TCPV4.create_connection (Client.tcpv4 stack.t) + (ip, port) + >|= function + | Ok _ -> + Log.debug (fun f -> + f "Connected tentative %d to localhost:%d" count + port) + | Error _ -> + Log.debug (fun f -> + f "Failure to connect to localhost:%d" port)) + >>= fun () -> mkconn (count - 1) + in + Lwt.pick + [ + (Host.Time.sleep_ns (Duration.of_sec 5) >|= fun () -> `Timeout); + (mkconn 8 >|= fun x -> `Result x); + ]) + >>= function + | `Timeout -> failwith "TCP server valid port test timed-out" + | `Result x -> Lwt.return x)) -] +let tests = + [ + ( "TCP: test Mirage half close", + [ + ( "check that Mirage half-close isn't a full-close", + `Quick, + test_mirage_half_close ); + ] ); + ( "TCP: test Host half close", + [ + ( "check that the Host half-close isn't a full-close", + `Quick, + test_host_half_close ); + ] ); + ( "TCP: test server valid invalid port", + [ + ( "check that a connection to a valid port does not block after the \ + port becomes invalid", + `Quick, + test_connect_valid_invalid_port ); + ] ); + ( "TCP: test server multiple valid ports", + [ + ( "check that multiple connections to valid and invalid ports", + `Quick, + test_connect_multiple_valid_ports ); + ] ); + ] File "src/dns_forward_test/test.ml", line 1, characters 0-0: diff --git a/_build/default/src/dns_forward_test/test.ml b/_build/default/src/dns_forward_test/.formatted/test.ml index 61d117d..29db8cd 100644 --- a/_build/default/src/dns_forward_test/test.ml +++ b/_build/default/src/dns_forward_test/.formatted/test.ml @@ -1,4 +1,3 @@ - module Error = Dns_forward.Error.Infix module Clock = Dns_forward_lwt_unix.Clock @@ -12,7 +11,17 @@ let fresh_id = let make_a_query name = let open Dns.Packet in let id = fresh_id () in - let detail = { qr = Query; opcode = Standard; aa = true; tc = false; rd = true; ra = false; rcode = NoError } in + let detail = + { + qr = Query; + opcode = Standard; + aa = true; + tc = false; + rd = true; + ra = false; + rcode = NoError; + } + in let questions = [ make_question Q_A name ] in let answers = [] in let authorities = [] in @@ -24,13 +33,18 @@ let parse_response response = let pkt = Dns.Packet.parse response in match pkt.Dns.Packet.detail with | { Dns.Packet.qr = Dns.Packet.Query; _ } -> - Lwt.return (Error (`Msg "parsed a response which was actually a query in disguise")) - | { Dns.Packet.qr = Dns.Packet.Response; _ } -> - begin match pkt.Dns.Packet.answers with - | [ { Dns.Packet.rdata = Dns.Packet.A ipv4; _ } ] -> - Lwt.return (Ok ipv4) - | xs -> Lwt.return (Error (`Msg (Printf.sprintf "failed to find answers: [ %s ]" (String.concat "; " (List.map Dns.Packet.rr_to_string xs))))) - end + Lwt.return + (Error (`Msg "parsed a response which was actually a query in disguise")) + | { Dns.Packet.qr = Dns.Packet.Response; _ } -> ( + match pkt.Dns.Packet.answers with + | [ { Dns.Packet.rdata = Dns.Packet.A ipv4; _ } ] -> Lwt.return (Ok ipv4) + | xs -> + Lwt.return + (Error + (`Msg + (Printf.sprintf "failed to find answers: [ %s ]" + (String.concat "; " (List.map Dns.Packet.rr_to_string xs))))) + ) let fresh_port = let next = ref 0 in @@ -40,371 +54,488 @@ let fresh_port = port let test_server () = - match Lwt_main.run begin - let module S = Server.Make(Rpc) in - let s = S.make [ "foo", Ipaddr.V4 Ipaddr.V4.localhost; "bar", Ipaddr.of_string_exn "1.2.3.4" ] in + match + Lwt_main.run + (let module S = Server.Make (Rpc) in + let s = + S.make + [ + ("foo", Ipaddr.V4 Ipaddr.V4.localhost); + ("bar", Ipaddr.of_string_exn "1.2.3.4"); + ] + in let open Error in (* The virtual address we run our server on: *) let port = fresh_port () in - let address = { Dns_forward.Config.Address.ip = Ipaddr.V4 Ipaddr.V4.localhost; port } in - S.serve ~address s - >>= fun _ -> + let address = + { Dns_forward.Config.Address.ip = Ipaddr.V4 Ipaddr.V4.localhost; port } + in + S.serve ~address s >>= fun _ -> let expected_dst = ref false in let message_cb ?src:_ ?dst:d ~buf:_ () = - ( match d with + (match d with | Some d -> - if Dns_forward.Config.Address.compare address d = 0 then expected_dst := true - | None -> - () - ); + if Dns_forward.Config.Address.compare address d = 0 then + expected_dst := true + | None -> ()); Lwt.return_unit in Rpc.connect ~gen_transaction_id:Random.int ~message_cb address >>= fun c -> let request = make_a_query (Dns.Name.of_string "foo") in - Rpc.rpc c request - >>= fun response -> - parse_response response - >>= fun ipv4 -> + Rpc.rpc c request >>= fun response -> + parse_response response >>= fun ipv4 -> Alcotest.(check string) "IPv4" "127.0.0.1" (Ipaddr.V4.to_string ipv4); let open Lwt.Infix in - Rpc.disconnect c - >>= fun () -> - if not (!expected_dst) then failwith ("Expected destination address never seen in message_cb"); - Lwt.return (Ok ()) - end with + Rpc.disconnect c >>= fun () -> + if not !expected_dst then + failwith "Expected destination address never seen in message_cb"; + Lwt.return (Ok ())) + with | Ok () -> - Alcotest.(check int) "number of connections" 0 (List.length @@ Rpc.get_connections ()); + Alcotest.(check int) + "number of connections" 0 + (List.length @@ Rpc.get_connections ()) | Error (`Msg m) -> failwith m module NormalTime = struct type 'a io = 'a Lwt.t + let sleep_ns ns = Lwt_unix.sleep (Duration.to_f ns) end let test_local_lookups () = - Alcotest.(check int) "number of connections" 0 (List.length @@ Rpc.get_connections ()); - match Lwt_main.run begin - let module S = Server.Make(Rpc) in + Alcotest.(check int) + "number of connections" 0 + (List.length @@ Rpc.get_connections ()); + match + Lwt_main.run + (let module S = Server.Make (Rpc) in let foo_public = "8.8.8.8" in let foo_private = "192.168.1.1" in (* a public server mapping 'foo' to a public ip *) - let public_server = S.make [ "foo", Ipaddr.of_string_exn foo_public ] in + let public_server = S.make [ ("foo", Ipaddr.of_string_exn foo_public) ] in let port = fresh_port () in - let public_address = { Dns_forward.Config.Address.ip = Ipaddr.V4 Ipaddr.V4.localhost; port } in + let public_address = + { Dns_forward.Config.Address.ip = Ipaddr.V4 Ipaddr.V4.localhost; port } + in let open Error in - S.serve ~address:public_address public_server - >>= fun _ -> - let module R = Dns_forward.Resolver.Make(Rpc)(NormalTime)(Mclock) in + S.serve ~address:public_address public_server >>= fun _ -> + let module R = Dns_forward.Resolver.Make (Rpc) (NormalTime) (Mclock) in let open Dns_forward.Config in - let servers = Server.Set.of_list [ - { Server.address = public_address; zones = Domain.Set.empty; timeout_ms = None; order = 0 }; - ] in - let config = { servers; search = []; assume_offline_after_drops = None } in + let servers = + Server.Set.of_list + [ + { + Server.address = public_address; + zones = Domain.Set.empty; + timeout_ms = None; + order = 0; + }; + ] + in + let config = + { servers; search = []; assume_offline_after_drops = None } + in let open Lwt.Infix in let local_names_cb question = let open Dns.Packet in match question with | { q_name; q_type = Q_A; _ } -> let rdata = A (Ipaddr.V4.of_string_exn foo_private) in - let name = q_name and cls = RR_IN and flush = false and ttl = 100l in + let name = q_name + and cls = RR_IN + and flush = false + and ttl = 100l in Lwt.return (Some [ { name; cls; flush; ttl; rdata } ]) - | _ -> - Lwt.return None + | _ -> Lwt.return None in R.create ~local_names_cb ~gen_transaction_id:Random.int config >>= fun r -> - let module F = Dns_forward.Server.Make(Rpc)(R) in - F.create r - >>= fun f -> + let module F = Dns_forward.Server.Make (Rpc) (R) in + F.create r >>= fun f -> let port = fresh_port () in - let f_address = { Dns_forward.Config.Address.ip = Ipaddr.V4 Ipaddr.V4.localhost; port } in + let f_address = + { Dns_forward.Config.Address.ip = Ipaddr.V4 Ipaddr.V4.localhost; port } + in let open Error in - F.serve ~address:f_address f - >>= fun () -> - Rpc.connect ~gen_transaction_id:Random.int f_address - >>= fun c -> + F.serve ~address:f_address f >>= fun () -> + Rpc.connect ~gen_transaction_id:Random.int f_address >>= fun c -> let request = make_a_query (Dns.Name.of_string "foo") in - Rpc.rpc c request - >>= fun response -> - parse_response response - >>= fun ipv4 -> + Rpc.rpc c request >>= fun response -> + parse_response response >>= fun ipv4 -> Alcotest.(check string) "IPv4" foo_private (Ipaddr.V4.to_string ipv4); let open Lwt.Infix in - Rpc.disconnect c - >>= fun () -> - F.destroy f - >>= fun () -> - Lwt.return (Ok ()) - end with + Rpc.disconnect c >>= fun () -> + F.destroy f >>= fun () -> Lwt.return (Ok ())) + with | Ok () -> - Alcotest.(check int) "number of connections" 0 (List.length @@ Rpc.get_connections ()); + Alcotest.(check int) + "number of connections" 0 + (List.length @@ Rpc.get_connections ()) | Error (`Msg m) -> failwith m let test_udp_nonpersistent () = - Alcotest.(check int) "number of connections" 0 (List.length @@ Rpc.get_connections ()); - match Lwt_main.run begin - let module Proto_server = Dns_forward.Rpc.Server.Make(Flow)(Dns_forward.Framing.Udp(Flow))(NormalTime) in - let module Proto_client = Dns_forward.Rpc.Client.Nonpersistent.Make(Flow)(Dns_forward.Framing.Udp(Flow))(NormalTime) in - let module S = Server.Make(Proto_server) in + Alcotest.(check int) + "number of connections" 0 + (List.length @@ Rpc.get_connections ()); + match + Lwt_main.run + (let module Proto_server = + Dns_forward.Rpc.Server.Make (Flow) (Dns_forward.Framing.Udp (Flow)) + (NormalTime) + in + let module Proto_client = + Dns_forward.Rpc.Client.Nonpersistent.Make + (Flow) + (Dns_forward.Framing.Udp (Flow)) + (NormalTime) + in + let module S = Server.Make (Proto_server) in let foo_public = "8.8.8.8" in (* a public server mapping 'foo' to a public ip *) - let public_server = S.make [ "foo", Ipaddr.of_string_exn foo_public ] in + let public_server = S.make [ ("foo", Ipaddr.of_string_exn foo_public) ] in let port = fresh_port () in - let public_address = { Dns_forward.Config.Address.ip = Ipaddr.V4 Ipaddr.V4.localhost; port } in + let public_address = + { Dns_forward.Config.Address.ip = Ipaddr.V4 Ipaddr.V4.localhost; port } + in let open Error in - S.serve ~address:public_address public_server - >>= fun _ -> - let module R = Dns_forward.Resolver.Make(Proto_client)(NormalTime)(Mclock) in + S.serve ~address:public_address public_server >>= fun _ -> + let module R = + Dns_forward.Resolver.Make (Proto_client) (NormalTime) (Mclock) + in let open Dns_forward.Config in - let servers = Server.Set.of_list [ - { Server.address = public_address; zones = Domain.Set.empty; timeout_ms = None; order = 0 }; - ] in - let config = { servers; search = []; assume_offline_after_drops = None } in + let servers = + Server.Set.of_list + [ + { + Server.address = public_address; + zones = Domain.Set.empty; + timeout_ms = None; + order = 0; + }; + ] + in + let config = + { servers; search = []; assume_offline_after_drops = None } + in let open Lwt.Infix in - R.create ~gen_transaction_id:Random.int config - >>= fun r -> - let module F = Dns_forward.Server.Make(Proto_server)(R) in - F.create r - >>= fun f -> + R.create ~gen_transaction_id:Random.int config >>= fun r -> + let module F = Dns_forward.Server.Make (Proto_server) (R) in + F.create r >>= fun f -> let port = fresh_port () in - let f_address = { Dns_forward.Config.Address.ip = Ipaddr.V4 Ipaddr.V4.localhost; port } in + let f_address = + { Dns_forward.Config.Address.ip = Ipaddr.V4 Ipaddr.V4.localhost; port } + in let open Error in - F.serve ~address:f_address f - >>= fun () -> + F.serve ~address:f_address f >>= fun () -> let expected_dst = ref false in let message_cb ?src:_ ?dst ~buf:_ () = - ( match dst with + (match dst with | Some d -> - if Dns_forward.Config.Address.compare f_address d = 0 then expected_dst := true - | None -> - () - ); + if Dns_forward.Config.Address.compare f_address d = 0 then + expected_dst := true + | None -> ()); Lwt.return_unit in Proto_client.connect ~gen_transaction_id:Random.int ~message_cb f_address >>= fun c -> let request = make_a_query (Dns.Name.of_string "foo") in let send_request () = - Proto_client.rpc c request - >>= fun response -> + Proto_client.rpc c request >>= fun response -> (* Check the response has the correct transaction id *) let request' = Dns.Packet.parse request and response' = Dns.Packet.parse response in - Alcotest.(check int) "DNS.id" request'.Dns.Packet.id response'.Dns.Packet.id; - parse_response response - >>= fun ipv4 -> + Alcotest.(check int) + "DNS.id" request'.Dns.Packet.id response'.Dns.Packet.id; + parse_response response >>= fun ipv4 -> Alcotest.(check string) "IPv4" foo_public (Ipaddr.V4.to_string ipv4); - Lwt.return (Ok ()) in + Lwt.return (Ok ()) + in let rec seq f = function - | 0 -> Lwt.return (Ok ()) - | n -> - f () - >>= fun () -> - seq f (n - 1) in + | 0 -> Lwt.return (Ok ()) + | n -> f () >>= fun () -> seq f (n - 1) + in let rec par f = function - | 0 -> Lwt.return (Ok ()) - | n -> - let first = f () in - let rest = par f (n - 1) in - first - >>= fun () -> - rest in + | 0 -> Lwt.return (Ok ()) + | n -> + let first = f () in + let rest = par f (n - 1) in + first >>= fun () -> rest + in (* Run 5 threads each sending 1000 requests *) - par (fun () -> seq send_request 1000) 5 - >>= fun () -> + par (fun () -> seq send_request 1000) 5 >>= fun () -> let open Lwt.Infix in - Proto_client.disconnect c - >>= fun () -> - F.destroy f - >>= fun () -> - if not (!expected_dst) then failwith ("Expected destination address never seen in message_cb"); - Lwt.return (Ok ()) - end with + Proto_client.disconnect c >>= fun () -> + F.destroy f >>= fun () -> + if not !expected_dst then + failwith "Expected destination address never seen in message_cb"; + Lwt.return (Ok ())) + with | Ok () -> - Alcotest.(check int) "number of connections" 0 (List.length @@ Rpc.get_connections ()); + Alcotest.(check int) + "number of connections" 0 + (List.length @@ Rpc.get_connections ()) | Error (`Msg m) -> failwith m let test_tcp_multiplexing () = - Alcotest.(check int) "number of connections" 0 (List.length @@ Rpc.get_connections ()); - match Lwt_main.run begin - let module Proto_server = Dns_forward.Rpc.Server.Make(Flow)(Dns_forward.Framing.Tcp(Flow))(NormalTime) in - let module Proto_client = Dns_forward.Rpc.Client.Persistent.Make(Flow)(Dns_forward.Framing.Tcp(Flow))(NormalTime) in - let module S = Server.Make(Proto_server) in + Alcotest.(check int) + "number of connections" 0 + (List.length @@ Rpc.get_connections ()); + match + Lwt_main.run + (let module Proto_server = + Dns_forward.Rpc.Server.Make (Flow) (Dns_forward.Framing.Tcp (Flow)) + (NormalTime) + in + let module Proto_client = + Dns_forward.Rpc.Client.Persistent.Make + (Flow) + (Dns_forward.Framing.Tcp (Flow)) + (NormalTime) + in + let module S = Server.Make (Proto_server) in let foo_public = "8.8.8.8" in (* a public server mapping 'foo' to a public ip *) - let public_server = S.make [ "foo", Ipaddr.of_string_exn foo_public ] in + let public_server = S.make [ ("foo", Ipaddr.of_string_exn foo_public) ] in let port = fresh_port () in - let public_address = { Dns_forward.Config.Address.ip = Ipaddr.V4 Ipaddr.V4.localhost; port } in + let public_address = + { Dns_forward.Config.Address.ip = Ipaddr.V4 Ipaddr.V4.localhost; port } + in let open Error in - S.serve ~address:public_address public_server - >>= fun _ -> - let module R = Dns_forward.Resolver.Make(Proto_client)(NormalTime)(Mclock) in + S.serve ~address:public_address public_server >>= fun _ -> + let module R = + Dns_forward.Resolver.Make (Proto_client) (NormalTime) (Mclock) + in let open Dns_forward.Config in - let servers = Server.Set.of_list [ - { Server.address = public_address; zones = Domain.Set.empty; timeout_ms = None; order = 0 }; - ] in - let config = { servers; search = []; assume_offline_after_drops = None } in + let servers = + Server.Set.of_list + [ + { + Server.address = public_address; + zones = Domain.Set.empty; + timeout_ms = None; + order = 0; + }; + ] + in + let config = + { servers; search = []; assume_offline_after_drops = None } + in let open Lwt.Infix in - R.create ~gen_transaction_id:Random.int config - >>= fun r -> - let module F = Dns_forward.Server.Make(Proto_server)(R) in - F.create r - >>= fun f -> + R.create ~gen_transaction_id:Random.int config >>= fun r -> + let module F = Dns_forward.Server.Make (Proto_server) (R) in + F.create r >>= fun f -> let port = fresh_port () in - let f_address = { Dns_forward.Config.Address.ip = Ipaddr.V4 Ipaddr.V4.localhost; port } in + let f_address = + { Dns_forward.Config.Address.ip = Ipaddr.V4 Ipaddr.V4.localhost; port } + in let open Error in - F.serve ~address:f_address f - >>= fun () -> + F.serve ~address:f_address f >>= fun () -> let expected_dst = ref false in let message_cb ?src:_ ?dst ~buf:_ () = - ( match dst with + (match dst with | Some d -> - if Dns_forward.Config.Address.compare f_address d = 0 then expected_dst := true - | None -> - () - ); + if Dns_forward.Config.Address.compare f_address d = 0 then + expected_dst := true + | None -> ()); Lwt.return_unit in Proto_client.connect ~gen_transaction_id:Random.int ~message_cb f_address >>= fun c -> let request = make_a_query (Dns.Name.of_string "foo") in let send_request () = - Proto_client.rpc c request - >>= fun response -> + Proto_client.rpc c request >>= fun response -> (* Check the response has the correct transaction id *) let request' = Dns.Packet.parse request and response' = Dns.Packet.parse response in - Alcotest.(check int) "DNS.id" request'.Dns.Packet.id response'.Dns.Packet.id; - parse_response response - >>= fun ipv4 -> + Alcotest.(check int) + "DNS.id" request'.Dns.Packet.id response'.Dns.Packet.id; + parse_response response >>= fun ipv4 -> Alcotest.(check string) "IPv4" foo_public (Ipaddr.V4.to_string ipv4); - Lwt.return (Ok ()) in + Lwt.return (Ok ()) + in let rec seq f = function - | 0 -> Lwt.return (Ok ()) - | n -> - f () - >>= fun () -> - seq f (n - 1) in + | 0 -> Lwt.return (Ok ()) + | n -> f () >>= fun () -> seq f (n - 1) + in let rec par f = function - | 0 -> Lwt.return (Ok ()) - | n -> - let first = f () in - let rest = par f (n - 1) in - first - >>= fun () -> - rest in + | 0 -> Lwt.return (Ok ()) + | n -> + let first = f () in + let rest = par f (n - 1) in + first >>= fun () -> rest + in (* Run 5 threads each sending 1000 requests *) - par (fun () -> seq send_request 1000) 5 - >>= fun () -> + par (fun () -> seq send_request 1000) 5 >>= fun () -> let open Lwt.Infix in - Proto_client.disconnect c - >>= fun () -> - F.destroy f - >>= fun () -> - if not (!expected_dst) then failwith ("Expected destination address never seen in message_cb"); - Lwt.return (Ok ()) - end with + Proto_client.disconnect c >>= fun () -> + F.destroy f >>= fun () -> + if not !expected_dst then + failwith "Expected destination address never seen in message_cb"; + Lwt.return (Ok ())) + with | Ok () -> - Alcotest.(check int) "number of connections" 0 (List.length @@ Rpc.get_connections ()); + Alcotest.(check int) + "number of connections" 0 + (List.length @@ Rpc.get_connections ()) | Error (`Msg m) -> failwith m (* One good one bad server should behave like the good server *) let test_good_bad_server () = - Alcotest.(check int) "number of connections" 0 (List.length @@ Rpc.get_connections ()); - match Lwt_main.run begin - let module Proto_server = Dns_forward.Rpc.Server.Make(Flow)(Dns_forward.Framing.Tcp(Flow))(NormalTime) in - let module Proto_client = Dns_forward.Rpc.Client.Persistent.Make(Flow)(Dns_forward.Framing.Tcp(Flow))(NormalTime) in - let module S = Server.Make(Proto_server) in + Alcotest.(check int) + "number of connections" 0 + (List.length @@ Rpc.get_connections ()); + match + Lwt_main.run + (let module Proto_server = + Dns_forward.Rpc.Server.Make (Flow) (Dns_forward.Framing.Tcp (Flow)) + (NormalTime) + in + let module Proto_client = + Dns_forward.Rpc.Client.Persistent.Make + (Flow) + (Dns_forward.Framing.Tcp (Flow)) + (NormalTime) + in + let module S = Server.Make (Proto_server) in let foo_public = "8.8.8.8" in (* a public server mapping 'foo' to a public ip *) - let public_server = S.make ~delay:0.1 [ "foo", Ipaddr.of_string_exn foo_public ] in + let public_server = + S.make ~delay:0.1 [ ("foo", Ipaddr.of_string_exn foo_public) ] + in let port = fresh_port () in - let public_address = { Dns_forward.Config.Address.ip = Ipaddr.V4 Ipaddr.V4.localhost; port } in + let public_address = + { Dns_forward.Config.Address.ip = Ipaddr.V4 Ipaddr.V4.localhost; port } + in let open Error in - S.serve ~address:public_address public_server - >>= fun _ -> + S.serve ~address:public_address public_server >>= fun _ -> let bad_server = S.make [] in let port = fresh_port () in - let bad_address = { Dns_forward.Config.Address.ip = Ipaddr.V4 Ipaddr.V4.localhost; port } in - S.serve ~address:bad_address bad_server - >>= fun _ -> - let module R = Dns_forward.Resolver.Make(Proto_client)(NormalTime)(Mclock) in + let bad_address = + { Dns_forward.Config.Address.ip = Ipaddr.V4 Ipaddr.V4.localhost; port } + in + S.serve ~address:bad_address bad_server >>= fun _ -> + let module R = + Dns_forward.Resolver.Make (Proto_client) (NormalTime) (Mclock) + in let open Dns_forward.Config in (* Forward to a good server and a bad server, both with timeouts. The request to the bad request should fail fast but the good server should be given up to the timeout to respond *) - let servers = Server.Set.of_list [ - { Server.address = public_address; zones = Domain.Set.empty; timeout_ms = Some 1000; order = 0 }; - { Server.address = bad_address; zones = Domain.Set.empty; timeout_ms = Some 1000; order = 0 }; - ] in - let config = { servers; search = []; assume_offline_after_drops = None } in + let servers = + Server.Set.of_list + [ + { + Server.address = public_address; + zones = Domain.Set.empty; + timeout_ms = Some 1000; + order = 0; + }; + { + Server.address = bad_address; + zones = Domain.Set.empty; + timeout_ms = Some 1000; + order = 0; + }; + ] + in + let config = + { servers; search = []; assume_offline_after_drops = None } + in let open Lwt.Infix in - R.create ~gen_transaction_id:Random.int config - >>= fun r -> + R.create ~gen_transaction_id:Random.int config >>= fun r -> let request = make_a_query (Dns.Name.of_string "foo") in let request = - R.answer request r - >>= function - | Ok reply -> + R.answer request r >>= function + | Ok reply -> ( let len = Cstruct.length reply in let buf = reply in - begin match Dns.Protocol.Server.parse (Cstruct.sub buf 0 len) with - | Some { Dns.Packet.answers = _ :: _ ; _ } -> Lwt.return_true - | Some packet -> failwith ("test_good_bad_server bad response: " ^ (Dns.Packet.to_string packet)) - | None -> failwith "test_good_bad_server: failed to parse response" - end - | Error _ -> failwith "test_good_bad_server timeout: did the failure overtake the success?" in - let timeout = - Lwt_unix.sleep 5. - >>= fun () -> - Lwt.return false in - Lwt.pick [ request; timeout ] - >>= fun ok -> + match Dns.Protocol.Server.parse (Cstruct.sub buf 0 len) with + | Some { Dns.Packet.answers = _ :: _; _ } -> Lwt.return_true + | Some packet -> + failwith + ("test_good_bad_server bad response: " + ^ Dns.Packet.to_string packet) + | None -> failwith "test_good_bad_server: failed to parse response") + | Error _ -> + failwith + "test_good_bad_server timeout: did the failure overtake the \ + success?" + in + let timeout = Lwt_unix.sleep 5. >>= fun () -> Lwt.return false in + Lwt.pick [ request; timeout ] >>= fun ok -> if not ok then failwith "test_good_bad_server hit timeout"; - R.destroy r - >>= fun () -> - Lwt.return (Ok ()) - end with + R.destroy r >>= fun () -> Lwt.return (Ok ())) + with | Ok () -> - Alcotest.(check int) "number of connections" 0 (List.length @@ Rpc.get_connections ()); + Alcotest.(check int) + "number of connections" 0 + (List.length @@ Rpc.get_connections ()) | Error (`Msg m) -> failwith m (* One good one dead server should behave like the good server *) let test_good_dead_server () = - Alcotest.(check int) "number of connections" 0 (List.length @@ Rpc.get_connections ()); - match Lwt_main.run begin - let module Proto_server = Dns_forward.Rpc.Server.Make(Flow)(Dns_forward.Framing.Tcp(Flow))(Fake.Time) in - let module Proto_client = Dns_forward.Rpc.Client.Persistent.Make(Flow)(Dns_forward.Framing.Tcp(Flow))(Fake.Time) in - let module S = Server.Make(Proto_server) in + Alcotest.(check int) + "number of connections" 0 + (List.length @@ Rpc.get_connections ()); + match + Lwt_main.run + (let module Proto_server = + Dns_forward.Rpc.Server.Make (Flow) (Dns_forward.Framing.Tcp (Flow)) + (Fake.Time) + in + let module Proto_client = + Dns_forward.Rpc.Client.Persistent.Make + (Flow) + (Dns_forward.Framing.Tcp (Flow)) + (Fake.Time) + in + let module S = Server.Make (Proto_server) in let foo_public = "8.8.8.8" in (* a public server mapping 'foo' to a public ip *) - let public_server = S.make [ "foo", Ipaddr.of_string_exn foo_public ] in + let public_server = S.make [ ("foo", Ipaddr.of_string_exn foo_public) ] in let public_address = let port = fresh_port () in - { Dns_forward.Config.Address.ip = Ipaddr.(V4 V4.localhost); port } in + { Dns_forward.Config.Address.ip = Ipaddr.(V4 V4.localhost); port } + in let open Error in - S.serve ~address:public_address public_server - >>= fun _ -> + S.serve ~address:public_address public_server >>= fun _ -> let bad_server = S.make ~delay:30. [] in let bad_address = let port = fresh_port () in - { Dns_forward.Config.Address.ip = Ipaddr.(V4 V4.localhost); port } in - S.serve ~address:bad_address bad_server - >>= fun _ -> - let module R = Dns_forward.Resolver.Make(Proto_client)(Fake.Time)(Fake.Clock) in + { Dns_forward.Config.Address.ip = Ipaddr.(V4 V4.localhost); port } + in + S.serve ~address:bad_address bad_server >>= fun _ -> + let module R = + Dns_forward.Resolver.Make (Proto_client) (Fake.Time) (Fake.Clock) + in let open Dns_forward.Config in (* Forward to a good server and a bad server, both with timeouts. The request to the bad request should fail fast but the good server should be given up to the timeout to respond *) - let servers = Server.Set.of_list [ - { Server.address = public_address; zones = Domain.Set.empty; timeout_ms = Some 1000; order = 0 }; - { Server.address = bad_address; zones = Domain.Set.empty; timeout_ms = Some 1000; order = 0 }; - ] in - let config = { servers; search = []; assume_offline_after_drops = Some 1 } in + let servers = + Server.Set.of_list + [ + { + Server.address = public_address; + zones = Domain.Set.empty; + timeout_ms = Some 1000; + order = 0; + }; + { + Server.address = bad_address; + zones = Domain.Set.empty; + timeout_ms = Some 1000; + order = 0; + }; + ] + in + let config = + { servers; search = []; assume_offline_after_drops = Some 1 } + in let open Lwt.Infix in - R.create ~gen_transaction_id:Random.int config - >>= fun r -> + R.create ~gen_transaction_id:Random.int config >>= fun r -> let request = make_a_query (Dns.Name.of_string "foo") in let t = R.answer request r in (* First request will trigger the internal timeout and mark the bad server @@ -415,386 +546,569 @@ let test_good_dead_server () = Lwt_unix.sleep 0.1 >>= fun () -> Fake.advance Duration.(of_sec 1); Lwt_unix.sleep 0.1 >>= fun () -> - Lwt.pick [ - (Lwt_unix.sleep 1. >>= fun () -> Lwt.fail_with "test_good_dead_server: initial request had no response"); - t >>= fun _ -> Lwt.return_unit - ] + Lwt.pick + [ + ( Lwt_unix.sleep 1. >>= fun () -> + Lwt.fail_with + "test_good_dead_server: initial request had no response" ); + (t >>= fun _ -> Lwt.return_unit); + ] >>= fun () -> (* The bad server should be marked offline and no-one will wait for it *) Fake.reset (); - Fake.advance Duration.(of_ms 500); (* avoid the timeouts winning the race with the actual result *) + Fake.advance Duration.(of_ms 500); + (* avoid the timeouts winning the race with the actual result *) let request = - R.answer request r - >>= function - | Ok reply -> + R.answer request r >>= function + | Ok reply -> ( let len = Cstruct.length reply in let buf = reply in - begin match Dns.Protocol.Server.parse (Cstruct.sub buf 0 len) with - | Some { Dns.Packet.answers = _ :: _ ; _ } -> Lwt.return_true - | Some packet -> failwith ("test_good_dead_server bad response: " ^ (Dns.Packet.to_string packet)) + match Dns.Protocol.Server.parse (Cstruct.sub buf 0 len) with + | Some { Dns.Packet.answers = _ :: _; _ } -> Lwt.return_true + | Some packet -> + failwith + ("test_good_dead_server bad response: " + ^ Dns.Packet.to_string packet) | None -> failwith "test_good_dead_server: failed to parse response" - end - | Error _ -> failwith "test_good_dead_server timeout: did the failure overtake the success?" in - let timeout = - Lwt_unix.sleep 5. - >>= fun () -> - Lwt.return false in - Lwt.pick [ request; timeout ] - >>= fun ok -> + ) + | Error _ -> + failwith + "test_good_dead_server timeout: did the failure overtake the \ + success?" + in + let timeout = Lwt_unix.sleep 5. >>= fun () -> Lwt.return false in + Lwt.pick [ request; timeout ] >>= fun ok -> if not ok then failwith "test_good_dead_server hit timeout"; - R.destroy r - >>= fun () -> - Lwt.return (Ok ()) - end with + R.destroy r >>= fun () -> Lwt.return (Ok ())) + with | Ok () -> - Alcotest.(check int) "number of connections" 0 (List.length @@ Rpc.get_connections ()); + Alcotest.(check int) + "number of connections" 0 + (List.length @@ Rpc.get_connections ()) | Error (`Msg m) -> failwith m (* One bad server should be ignored *) let test_bad_server () = - Alcotest.(check int) "number of connections" 0 (List.length @@ Rpc.get_connections ()); - match Lwt_main.run begin - let module Proto_server = Dns_forward.Rpc.Server.Make(Flow)(Dns_forward.Framing.Tcp(Flow))(NormalTime) in - let module Proto_client = Dns_forward.Rpc.Client.Persistent.Make(Flow)(Dns_forward.Framing.Tcp(Flow))(NormalTime) in - let module S = Server.Make(Proto_server) in + Alcotest.(check int) + "number of connections" 0 + (List.length @@ Rpc.get_connections ()); + match + Lwt_main.run + (let module Proto_server = + Dns_forward.Rpc.Server.Make (Flow) (Dns_forward.Framing.Tcp (Flow)) + (NormalTime) + in + let module Proto_client = + Dns_forward.Rpc.Client.Persistent.Make + (Flow) + (Dns_forward.Framing.Tcp (Flow)) + (NormalTime) + in + let module S = Server.Make (Proto_server) in let foo_public = "8.8.8.8" in (* a public server mapping 'foo' to a public ip *) - let public_server = S.make ~simulate_bad_question:true [ "foo", Ipaddr.of_string_exn foo_public ] in + let public_server = + S.make ~simulate_bad_question:true + [ ("foo", Ipaddr.of_string_exn foo_public) ] + in let port = fresh_port () in - let public_address = { Dns_forward.Config.Address.ip = Ipaddr.V4 Ipaddr.V4.localhost; port } in + let public_address = + { Dns_forward.Config.Address.ip = Ipaddr.V4 Ipaddr.V4.localhost; port } + in let open Error in - S.serve ~address:public_address public_server - >>= fun _ -> - let module R = Dns_forward.Resolver.Make(Proto_client)(NormalTime)(Mclock) in + S.serve ~address:public_address public_server >>= fun _ -> + let module R = + Dns_forward.Resolver.Make (Proto_client) (NormalTime) (Mclock) + in let open Dns_forward.Config in let port = fresh_port () in - let bad_address = { Dns_forward.Config.Address.ip = Ipaddr.V4 Ipaddr.V4.localhost; port } in + let bad_address = + { Dns_forward.Config.Address.ip = Ipaddr.V4 Ipaddr.V4.localhost; port } + in (* Forward to a good server and a bad server, both with timeouts. The request to the bad request should fail fast but the good server should be given up to the timeout to respond *) - let servers = Server.Set.of_list [ - { Server.address = public_address; zones = Domain.Set.empty; timeout_ms = Some 1000; order = 0 }; - { Server.address = bad_address; zones = Domain.Set.empty; timeout_ms = Some 1000; order = 0 }; - ] in - let config = { servers; search = []; assume_offline_after_drops = None } in + let servers = + Server.Set.of_list + [ + { + Server.address = public_address; + zones = Domain.Set.empty; + timeout_ms = Some 1000; + order = 0; + }; + { + Server.address = bad_address; + zones = Domain.Set.empty; + timeout_ms = Some 1000; + order = 0; + }; + ] + in + let config = + { servers; search = []; assume_offline_after_drops = None } + in let open Lwt.Infix in - R.create ~gen_transaction_id:Random.int config - >>= fun r -> + R.create ~gen_transaction_id:Random.int config >>= fun r -> let request = make_a_query (Dns.Name.of_string "foo") in let request = - R.answer request r - >>= function + R.answer request r >>= function | Ok _ -> Lwt.return_false - | Error _ -> failwith "test_bad_server rpc error" in - let timeout = - Lwt_unix.sleep 0.5 - >>= fun () -> - Lwt.return true in - Lwt.pick [ request; timeout ] - >>= fun timeout -> + | Error _ -> failwith "test_bad_server rpc error" + in + let timeout = Lwt_unix.sleep 0.5 >>= fun () -> Lwt.return true in + Lwt.pick [ request; timeout ] >>= fun timeout -> if not timeout then failwith "test_bad_server did not hit timeout"; - R.destroy r - >>= fun () -> - Lwt.return (Ok ()) - end with + R.destroy r >>= fun () -> Lwt.return (Ok ())) + with | Ok () -> - Alcotest.(check int) "number of connections" 0 (List.length @@ Rpc.get_connections ()); + Alcotest.(check int) + "number of connections" 0 + (List.length @@ Rpc.get_connections ()) | Error (`Msg m) -> failwith m let test_timeout () = - Alcotest.(check int) "number of connections" 0 (List.length @@ Rpc.get_connections ()); - let module Proto_server = Dns_forward.Rpc.Server.Make(Flow)(Dns_forward.Framing.Tcp(Flow))(NormalTime) in - let module Proto_client = Dns_forward.Rpc.Client.Persistent.Make(Flow)(Dns_forward.Framing.Tcp(Flow))(NormalTime) in - let module S = Server.Make(Proto_server) in + Alcotest.(check int) + "number of connections" 0 + (List.length @@ Rpc.get_connections ()); + let module Proto_server = + Dns_forward.Rpc.Server.Make (Flow) (Dns_forward.Framing.Tcp (Flow)) + (NormalTime) + in + let module Proto_client = + Dns_forward.Rpc.Client.Persistent.Make + (Flow) + (Dns_forward.Framing.Tcp (Flow)) + (NormalTime) + in + let module S = Server.Make (Proto_server) in let foo_public = "8.8.8.8" in (* a public server mapping 'foo' to a public ip *) - let bar_server = S.make ~delay:60. [ "foo", Ipaddr.of_string_exn foo_public ] in + let bar_server = + S.make ~delay:60. [ ("foo", Ipaddr.of_string_exn foo_public) ] + in let port = fresh_port () in - let bar_address = { Dns_forward.Config.Address.ip = Ipaddr.V4 Ipaddr.V4.localhost; port } in + let bar_address = + { Dns_forward.Config.Address.ip = Ipaddr.V4 Ipaddr.V4.localhost; port } + in let open Error in - match Lwt_main.run begin - S.serve ~address:bar_address bar_server - >>= fun _ -> - (* a resolver which uses both servers *) - let module R = Dns_forward.Resolver.Make(Proto_client)(NormalTime)(Mclock) in - let open Dns_forward.Config in - let servers = Server.Set.of_list [ - { Server.address = bar_address; zones = Domain.Set.empty; timeout_ms = Some 0; order = 0 } - ] in - let config = { servers; search = []; assume_offline_after_drops = None } in - let open Lwt.Infix in - R.create ~gen_transaction_id:Random.int config - >>= fun r -> - let request = make_a_query (Dns.Name.of_string "foo") in - let request = - R.answer request r - >>= function - | Error _ -> Lwt.return true - | Ok _ -> failwith "got a result when timeout expected" in - let timeout = - Lwt_unix.sleep 5. - >>= fun () -> - Lwt.return false in - Lwt.pick [ request; timeout ] - >>= fun ok -> - if not ok then failwith "server timeout was not respected"; - R.destroy r - >>= fun () -> - Lwt.return (Ok ()) - end with + match + Lwt_main.run + ( S.serve ~address:bar_address bar_server >>= fun _ -> + (* a resolver which uses both servers *) + let module R = + Dns_forward.Resolver.Make (Proto_client) (NormalTime) (Mclock) + in + let open Dns_forward.Config in + let servers = + Server.Set.of_list + [ + { + Server.address = bar_address; + zones = Domain.Set.empty; + timeout_ms = Some 0; + order = 0; + }; + ] + in + let config = + { servers; search = []; assume_offline_after_drops = None } + in + let open Lwt.Infix in + R.create ~gen_transaction_id:Random.int config >>= fun r -> + let request = make_a_query (Dns.Name.of_string "foo") in + let request = + R.answer request r >>= function + | Error _ -> Lwt.return true + | Ok _ -> failwith "got a result when timeout expected" + in + let timeout = Lwt_unix.sleep 5. >>= fun () -> Lwt.return false in + Lwt.pick [ request; timeout ] >>= fun ok -> + if not ok then failwith "server timeout was not respected"; + R.destroy r >>= fun () -> Lwt.return (Ok ()) ) + with | Ok () -> (* the disconnects and close should have removed all the connections: *) - Alcotest.(check int) "number of connections" 0 (List.length @@ Rpc.get_connections ()); - Alcotest.(check int) "bar_server queries" 1 (S.get_nr_queries bar_server); + Alcotest.(check int) + "number of connections" 0 + (List.length @@ Rpc.get_connections ()); + Alcotest.(check int) "bar_server queries" 1 (S.get_nr_queries bar_server) | Error (`Msg m) -> failwith m let test_cache () = - Alcotest.(check int) "number of connections" 0 (List.length @@ Rpc.get_connections ()); - let module Proto_server = Dns_forward.Rpc.Server.Make(Flow)(Dns_forward.Framing.Tcp(Flow))(NormalTime) in - let module Proto_client = Dns_forward.Rpc.Client.Persistent.Make(Flow)(Dns_forward.Framing.Tcp(Flow))(NormalTime) in - let module S = Server.Make(Proto_server) in + Alcotest.(check int) + "number of connections" 0 + (List.length @@ Rpc.get_connections ()); + let module Proto_server = + Dns_forward.Rpc.Server.Make (Flow) (Dns_forward.Framing.Tcp (Flow)) + (NormalTime) + in + let module Proto_client = + Dns_forward.Rpc.Client.Persistent.Make + (Flow) + (Dns_forward.Framing.Tcp (Flow)) + (NormalTime) + in + let module S = Server.Make (Proto_server) in let foo_public = "8.8.8.8" in (* a public server mapping 'foo' to a public ip *) - let bar_server = S.make [ "foo", Ipaddr.of_string_exn foo_public ] in + let bar_server = S.make [ ("foo", Ipaddr.of_string_exn foo_public) ] in let port = fresh_port () in - let bar_address = { Dns_forward.Config.Address.ip = Ipaddr.V4 Ipaddr.V4.localhost; port } in + let bar_address = + { Dns_forward.Config.Address.ip = Ipaddr.V4 Ipaddr.V4.localhost; port } + in let open Error in - match Lwt_main.run begin - S.serve ~address:bar_address bar_server - >>= fun server -> - (* a resolver which uses both servers *) - let module R = Dns_forward.Resolver.Make(Proto_client)(NormalTime)(Mclock) in - let open Dns_forward.Config in - let servers = Server.Set.of_list [ - { Server.address = bar_address; zones = Domain.Set.empty; timeout_ms = Some 1000; order = 0 } - ] in - let config = { servers; search = []; assume_offline_after_drops = None } in - let open Lwt.Infix in - R.create ~gen_transaction_id:Random.int config - >>= fun r -> - let request = make_a_query (Dns.Name.of_string "foo") in - R.answer request r - >>= function - | Error _ -> failwith "failed initial lookup" - | Ok _ -> - S.shutdown server - >>= fun () -> - R.answer request r - >>= function - | Error (`Msg m) -> failwith ("failed cached lookup: " ^ m) - | Ok _ -> - R.destroy r - >>= fun () -> - Lwt.return (Ok ()) - end with + match + Lwt_main.run + ( S.serve ~address:bar_address bar_server >>= fun server -> + (* a resolver which uses both servers *) + let module R = + Dns_forward.Resolver.Make (Proto_client) (NormalTime) (Mclock) + in + let open Dns_forward.Config in + let servers = + Server.Set.of_list + [ + { + Server.address = bar_address; + zones = Domain.Set.empty; + timeout_ms = Some 1000; + order = 0; + }; + ] + in + let config = + { servers; search = []; assume_offline_after_drops = None } + in + let open Lwt.Infix in + R.create ~gen_transaction_id:Random.int config >>= fun r -> + let request = make_a_query (Dns.Name.of_string "foo") in + R.answer request r >>= function + | Error _ -> failwith "failed initial lookup" + | Ok _ -> ( + S.shutdown server >>= fun () -> + R.answer request r >>= function + | Error (`Msg m) -> failwith ("failed cached lookup: " ^ m) + | Ok _ -> R.destroy r >>= fun () -> Lwt.return (Ok ())) ) + with | Ok () -> (* the disconnects and close should have removed all the connections: *) - Alcotest.(check int) "number of connections" 0 (List.length @@ Rpc.get_connections ()); - Alcotest.(check int) "bar_server queries" 1 (S.get_nr_queries bar_server); + Alcotest.(check int) + "number of connections" 0 + (List.length @@ Rpc.get_connections ()); + Alcotest.(check int) "bar_server queries" 1 (S.get_nr_queries bar_server) | Error (`Msg m) -> failwith m (* One slow private server, one fast public server with different bindings for the same name. The order field guarantees that we take the answer from the slow private server. *) let test_order () = - Alcotest.(check int) "number of connections" 0 (List.length @@ Rpc.get_connections ()); - let module Proto_server = Dns_forward.Rpc.Server.Make(Flow)(Dns_forward.Framing.Tcp(Flow))(NormalTime) in - let module Proto_client = Dns_forward.Rpc.Client.Persistent.Make(Flow)(Dns_forward.Framing.Tcp(Flow))(NormalTime) in - let module S = Server.Make(Proto_server) in + Alcotest.(check int) + "number of connections" 0 + (List.length @@ Rpc.get_connections ()); + let module Proto_server = + Dns_forward.Rpc.Server.Make (Flow) (Dns_forward.Framing.Tcp (Flow)) + (NormalTime) + in + let module Proto_client = + Dns_forward.Rpc.Client.Persistent.Make + (Flow) + (Dns_forward.Framing.Tcp (Flow)) + (NormalTime) + in + let module S = Server.Make (Proto_server) in let foo_public = "8.8.8.8" in let foo_private = "192.168.1.1" in (* a public server mapping 'foo' to a public ip *) - let public_server = S.make [ "foo", Ipaddr.of_string_exn foo_public ] in + let public_server = S.make [ ("foo", Ipaddr.of_string_exn foo_public) ] in let port = fresh_port () in - let public_address = { Dns_forward.Config.Address.ip = Ipaddr.V4 Ipaddr.V4.localhost; port } in + let public_address = + { Dns_forward.Config.Address.ip = Ipaddr.V4 Ipaddr.V4.localhost; port } + in (* a private server mapping 'foo' to a private ip *) - let private_server = S.make [ "foo", Ipaddr.of_string_exn foo_private ] in + let private_server = S.make [ ("foo", Ipaddr.of_string_exn foo_private) ] in let port = fresh_port () in - let private_address = { Dns_forward.Config.Address.ip = Ipaddr.V4 Ipaddr.V4.localhost; port } in + let private_address = + { Dns_forward.Config.Address.ip = Ipaddr.V4 Ipaddr.V4.localhost; port } + in let open Error in - match Lwt_main.run begin - S.serve ~address:public_address public_server - >>= fun _ -> - S.serve ~address:private_address private_server - >>= fun _ -> - - (* a resolver which uses both servers *) - let module R = Dns_forward.Resolver.Make(Proto_client)(NormalTime)(Mclock) in - let open Dns_forward.Config in - let servers = Server.Set.of_list [ - { Server.address = public_address; zones = Domain.Set.empty; timeout_ms = None; order = 1 }; - { Server.address = private_address; zones = Domain.Set.empty; timeout_ms = None; order = 0 } - ] in - let config = { servers; search = []; assume_offline_after_drops = None } in - let open Lwt.Infix in - R.create ~gen_transaction_id:Random.int config - >>= fun r -> - let request = make_a_query (Dns.Name.of_string "foo") in - let open Error in - R.answer request r - >>= fun response -> - parse_response response - >>= fun ipv4 -> - Alcotest.(check string) "IPv4" foo_private (Ipaddr.V4.to_string ipv4); - let open Lwt.Infix in - R.destroy r - >>= fun () -> - Lwt.return (Ok ()) - end with + match + Lwt_main.run + ( S.serve ~address:public_address public_server >>= fun _ -> + S.serve ~address:private_address private_server >>= fun _ -> + (* a resolver which uses both servers *) + let module R = + Dns_forward.Resolver.Make (Proto_client) (NormalTime) (Mclock) + in + let open Dns_forward.Config in + let servers = + Server.Set.of_list + [ + { + Server.address = public_address; + zones = Domain.Set.empty; + timeout_ms = None; + order = 1; + }; + { + Server.address = private_address; + zones = Domain.Set.empty; + timeout_ms = None; + order = 0; + }; + ] + in + let config = + { servers; search = []; assume_offline_after_drops = None } + in + let open Lwt.Infix in + R.create ~gen_transaction_id:Random.int config >>= fun r -> + let request = make_a_query (Dns.Name.of_string "foo") in + let open Error in + R.answer request r >>= fun response -> + parse_response response >>= fun ipv4 -> + Alcotest.(check string) "IPv4" foo_private (Ipaddr.V4.to_string ipv4); + let open Lwt.Infix in + R.destroy r >>= fun () -> Lwt.return (Ok ()) ) + with | Ok () -> (* the disconnects and close should have removed all the connections: *) - Alcotest.(check int) "number of connections" 0 (List.length @@ Rpc.get_connections ()); + Alcotest.(check int) + "number of connections" 0 + (List.length @@ Rpc.get_connections ()); (* We now query all servers matching a zone *) - Alcotest.(check int) "private_server queries" 1 (S.get_nr_queries private_server); - Alcotest.(check int) "public_server queries" 1 (S.get_nr_queries public_server); + Alcotest.(check int) + "private_server queries" 1 + (S.get_nr_queries private_server); + Alcotest.(check int) + "public_server queries" 1 + (S.get_nr_queries public_server) | Error (`Msg m) -> failwith m let test_forwarder_zone () = - Alcotest.(check int) "number of connections" 0 (List.length @@ Rpc.get_connections ()); - let module S = Server.Make(Rpc) in + Alcotest.(check int) + "number of connections" 0 + (List.length @@ Rpc.get_connections ()); + let module S = Server.Make (Rpc) in let foo_public = "8.8.8.8" in let foo_private = "192.168.1.1" in (* a VPN mapping 'foo' to an internal ip *) - let foo_server = S.make [ "foo", Ipaddr.of_string_exn foo_private ] in + let foo_server = S.make [ ("foo", Ipaddr.of_string_exn foo_private) ] in let port = fresh_port () in - let foo_address = { Dns_forward.Config.Address.ip = Ipaddr.V4 Ipaddr.V4.localhost; port } in + let foo_address = + { Dns_forward.Config.Address.ip = Ipaddr.V4 Ipaddr.V4.localhost; port } + in (* a public server mapping 'foo' to a public ip *) - let bar_server = S.make [ "foo", Ipaddr.of_string_exn foo_public ] in + let bar_server = S.make [ ("foo", Ipaddr.of_string_exn foo_public) ] in let port = fresh_port () in - let bar_address = { Dns_forward.Config.Address.ip = Ipaddr.V4 Ipaddr.V4.localhost; port } in + let bar_address = + { Dns_forward.Config.Address.ip = Ipaddr.V4 Ipaddr.V4.localhost; port } + in let open Error in - match Lwt_main.run begin - S.serve ~address:foo_address foo_server - >>= fun _ -> - - S.serve ~address:bar_address bar_server - >>= fun _ -> - (* a resolver which uses both servers *) - let module R = Dns_forward.Resolver.Make(Rpc)(NormalTime)(Mclock) in - let open Dns_forward.Config in - let servers = Server.Set.of_list [ - { Server.address = foo_address; zones = Domain.Set.add [ "foo" ] Domain.Set.empty; timeout_ms = None; order = 0 }; - { Server.address = bar_address; zones = Domain.Set.empty; timeout_ms = None; order = 0 } - ] in - let config = { servers; search = []; assume_offline_after_drops = None } in - let open Lwt.Infix in - R.create ~gen_transaction_id:Random.int config - >>= fun r -> - let module F = Dns_forward.Server.Make(Rpc)(R) in - F.create r - >>= fun f -> - let port = fresh_port () in - let f_address = { Dns_forward.Config.Address.ip = Ipaddr.V4 Ipaddr.V4.localhost; port } in - let open Error in - F.serve ~address:f_address f - >>= fun () -> - Rpc.connect ~gen_transaction_id:Random.int f_address - >>= fun c -> - let request = make_a_query (Dns.Name.of_string "foo") in - Rpc.rpc c request - >>= fun response -> - parse_response response - >>= fun ipv4 -> - Alcotest.(check string) "IPv4" foo_private (Ipaddr.V4.to_string ipv4); - let open Lwt.Infix in - Rpc.disconnect c - >>= fun () -> - F.destroy f - >>= fun () -> - Lwt.return (Ok ()) - end with + match + Lwt_main.run + ( S.serve ~address:foo_address foo_server >>= fun _ -> + S.serve ~address:bar_address bar_server >>= fun _ -> + (* a resolver which uses both servers *) + let module R = Dns_forward.Resolver.Make (Rpc) (NormalTime) (Mclock) in + let open Dns_forward.Config in + let servers = + Server.Set.of_list + [ + { + Server.address = foo_address; + zones = Domain.Set.add [ "foo" ] Domain.Set.empty; + timeout_ms = None; + order = 0; + }; + { + Server.address = bar_address; + zones = Domain.Set.empty; + timeout_ms = None; + order = 0; + }; + ] + in + let config = + { servers; search = []; assume_offline_after_drops = None } + in + let open Lwt.Infix in + R.create ~gen_transaction_id:Random.int config >>= fun r -> + let module F = Dns_forward.Server.Make (Rpc) (R) in + F.create r >>= fun f -> + let port = fresh_port () in + let f_address = + { + Dns_forward.Config.Address.ip = Ipaddr.V4 Ipaddr.V4.localhost; + port; + } + in + let open Error in + F.serve ~address:f_address f >>= fun () -> + Rpc.connect ~gen_transaction_id:Random.int f_address >>= fun c -> + let request = make_a_query (Dns.Name.of_string "foo") in + Rpc.rpc c request >>= fun response -> + parse_response response >>= fun ipv4 -> + Alcotest.(check string) "IPv4" foo_private (Ipaddr.V4.to_string ipv4); + let open Lwt.Infix in + Rpc.disconnect c >>= fun () -> + F.destroy f >>= fun () -> Lwt.return (Ok ()) ) + with | Ok () -> (* the disconnects and close should have removed all the connections: *) - Alcotest.(check int) "number of connections" 0 (List.length @@ Rpc.get_connections ()); + Alcotest.(check int) + "number of connections" 0 + (List.length @@ Rpc.get_connections ()); (* The server should have sent the query only to foo and not to bar *) Alcotest.(check int) "foo_server queries" 1 (S.get_nr_queries foo_server); - Alcotest.(check int) "bar_server queries" 0 (S.get_nr_queries bar_server); + Alcotest.(check int) "bar_server queries" 0 (S.get_nr_queries bar_server) | Error (`Msg m) -> failwith m +let test_infra_set = + [ + ("Server responds correctly", `Quick, test_server); + ("Bad server responses are ignored", `Quick, test_bad_server); + ] -let test_infra_set = [ - "Server responds correctly", `Quick, test_server; - "Bad server responses are ignored", `Quick, test_bad_server; -] - -let test_protocol_set = [ - "TCP multiplexing", `Quick, test_tcp_multiplexing; - "UDP non-persistent", `Quick, test_udp_nonpersistent; -] +let test_protocol_set = + [ + ("TCP multiplexing", `Quick, test_tcp_multiplexing); + ("UDP non-persistent", `Quick, test_udp_nonpersistent); + ] -let test_forwarder_set = [ - "Per-server timeouts", `Quick, test_timeout; - "Zone config respected", `Quick, test_forwarder_zone; - "Local names resolve ok", `Quick, test_local_lookups; - "Server order", `Quick, test_order; - "Caching", `Quick, test_cache; - "Tolerate bad server", `Quick, test_good_bad_server; - "Tolerate broken server", `Quick, test_good_dead_server; -] +let test_forwarder_set = + [ + ("Per-server timeouts", `Quick, test_timeout); + ("Zone config respected", `Quick, test_forwarder_zone); + ("Local names resolve ok", `Quick, test_local_lookups); + ("Server order", `Quick, test_order); + ("Caching", `Quick, test_cache); + ("Tolerate bad server", `Quick, test_good_bad_server); + ("Tolerate broken server", `Quick, test_good_dead_server); + ] open Dns_forward.Config -let config_examples = [ - "nameserver 10.0.0.2\nnameserver 1.2.3.4#54\nsearch a b c", - { servers = Server.Set.of_list [ - { Server.address = { Address.ip = Ipaddr.V4 (Ipaddr.V4.of_string_exn "10.0.0.2"); port = 53 }; zones = Domain.Set.empty; timeout_ms = None; order = 0 }; - { Server.address = { Address.ip = Ipaddr.V4 (Ipaddr.V4.of_string_exn "1.2.3.4"); port = 54 }; zones = Domain.Set.empty; timeout_ms = None; order = 0 }; - ]; search = [ "a"; "b"; "c" ]; assume_offline_after_drops = None - }; - "nameserver 10.0.0.2\n", - { servers = Server.Set.of_list [ - { Server.address = { Address.ip = Ipaddr.V4 (Ipaddr.V4.of_string_exn "10.0.0.2"); port = 53 }; zones = Domain.Set.empty; timeout_ms = None; order = 0 }; - ]; search = []; assume_offline_after_drops = None - }; - String.concat "\n" [ - "# a pretend VPN zone with a private nameserver"; - "nameserver 1.2.3.4"; - "zone mirage.io foo.com"; - "timeout 5000"; - "order 1"; - ""; - "# a default nameserver"; - "nameserver 8.8.8.8"; - ], { - servers = Server.Set.of_list [ - { Server.address = { Address.ip = Ipaddr.V4 (Ipaddr.V4.of_string_exn "8.8.8.8"); port = 53 }; zones = Domain.Set.empty; timeout_ms = None; order = 0; }; - { Server.address = { Address.ip = Ipaddr.V4 (Ipaddr.V4.of_string_exn "1.2.3.4"); port = 53 }; - zones = Domain.Set.of_list [ [ "mirage"; "io" ]; [ "foo"; "com" ] ]; - timeout_ms = Some 5000; - order = 1; - }; - ]; search = []; assume_offline_after_drops = None; - }; -] +let config_examples = + [ + ( "nameserver 10.0.0.2\nnameserver 1.2.3.4#54\nsearch a b c", + { + servers = + Server.Set.of_list + [ + { + Server.address = + { + Address.ip = Ipaddr.V4 (Ipaddr.V4.of_string_exn "10.0.0.2"); + port = 53; + }; + zones = Domain.Set.empty; + timeout_ms = None; + order = 0; + }; + { + Server.address = + { + Address.ip = Ipaddr.V4 (Ipaddr.V4.of_string_exn "1.2.3.4"); + port = 54; + }; + zones = Domain.Set.empty; + timeout_ms = None; + order = 0; + }; + ]; + search = [ "a"; "b"; "c" ]; + assume_offline_after_drops = None; + } ); + ( "nameserver 10.0.0.2\n", + { + servers = + Server.Set.of_list + [ + { + Server.address = + { + Address.ip = Ipaddr.V4 (Ipaddr.V4.of_string_exn "10.0.0.2"); + port = 53; + }; + zones = Domain.Set.empty; + timeout_ms = None; + order = 0; + }; + ]; + search = []; + assume_offline_after_drops = None; + } ); + ( String.concat "\n" + [ + "# a pretend VPN zone with a private nameserver"; + "nameserver 1.2.3.4"; + "zone mirage.io foo.com"; + "timeout 5000"; + "order 1"; + ""; + "# a default nameserver"; + "nameserver 8.8.8.8"; + ], + { + servers = + Server.Set.of_list + [ + { + Server.address = + { + Address.ip = Ipaddr.V4 (Ipaddr.V4.of_string_exn "8.8.8.8"); + port = 53; + }; + zones = Domain.Set.empty; + timeout_ms = None; + order = 0; + }; + { + Server.address = + { + Address.ip = Ipaddr.V4 (Ipaddr.V4.of_string_exn "1.2.3.4"); + port = 53; + }; + zones = + Domain.Set.of_list [ [ "mirage"; "io" ]; [ "foo"; "com" ] ]; + timeout_ms = Some 5000; + order = 1; + }; + ]; + search = []; + assume_offline_after_drops = None; + } ); + ] let test_parse_config txt expected () = match of_string txt with | Error (`Msg m) -> failwith m - | Ok x -> - if compare expected x <> 0 - then failwith ("failed to parse " ^ txt) + | Ok x -> if compare expected x <> 0 then failwith ("failed to parse " ^ txt) -let test_config = List.map (fun (txt, expected) -> - "DNS " ^ (String.escaped txt), `Quick, test_parse_config txt expected - ) config_examples +let test_config = + List.map + (fun (txt, expected) -> + ("DNS " ^ String.escaped txt, `Quick, test_parse_config txt expected)) + config_examples let () = Logs.set_reporter (Logs_fmt.reporter ()); - Lwt.async_exception_hook := (fun exn -> - Logs.err (fun f -> f "Lwt.async failure %s: %s" - (Printexc.to_string exn) - (Printexc.get_backtrace ()) - ) - ); + (Lwt.async_exception_hook := + fun exn -> + Logs.err (fun f -> + f "Lwt.async failure %s: %s" (Printexc.to_string exn) + (Printexc.get_backtrace ()))); Random.self_init (); - Alcotest.run "dns-forward" [ - "Test infrastructure", test_infra_set; - "Test forwarding", test_forwarder_set; - "Test protocols", test_protocol_set; - "Test config parsing", test_config; - ] + Alcotest.run "dns-forward" + [ + ("Test infrastructure", test_infra_set); + ("Test forwarding", test_forwarder_set); + ("Test protocols", test_protocol_set); + ("Test config parsing", test_config); + ] File "src/hostnet/hostnet_dns.ml", line 1, characters 0-0: diff --git a/_build/default/src/hostnet/hostnet_dns.ml b/_build/default/src/hostnet/.formatted/hostnet_dns.ml index 80d55f9..930a7fc 100644 --- a/_build/default/src/hostnet/hostnet_dns.ml +++ b/_build/default/src/hostnet/.formatted/hostnet_dns.ml @@ -11,448 +11,519 @@ module Log = (val Logs.src_log src : Logs.LOG) let max_udp_response = 512 module Config = struct - type t = [ - | `Upstream of Dns_forward.Config.t - | `Host - ] + type t = [ `Upstream of Dns_forward.Config.t | `Host ] let to_string = function - | `Upstream x -> "use upstream DNS servers " ^ (Dns_forward.Config.to_string x) - | `Host -> "use host resolver" - - let compare a b = match a, b with - | `Upstream x, `Upstream y -> Dns_forward.Config.compare x y - | `Host, `Upstream _ -> -1 - | `Upstream _, `Host -> 1 - | `Host, `Host -> 0 + | `Upstream x -> + "use upstream DNS servers " ^ Dns_forward.Config.to_string x + | `Host -> "use host resolver" + + let compare a b = + match (a, b) with + | `Upstream x, `Upstream y -> Dns_forward.Config.compare x y + | `Host, `Upstream _ -> -1 + | `Upstream _, `Host -> 1 + | `Host, `Host -> 0 end - -module Policy(Files: Sig.FILES) = struct +module Policy (Files : Sig.FILES) = struct let config_of_ips ips = let open Dns_forward.Config in - let servers = Server.Set.of_list ( - List.map (fun (ip, _) -> - { Server.address = { Address.ip; port = 53 }; zones = Domain.Set.empty; - timeout_ms = Some 2000; order = 0 } - ) ips) in + let servers = + Server.Set.of_list + (List.map + (fun (ip, _) -> + { + Server.address = { Address.ip; port = 53 }; + zones = Domain.Set.empty; + timeout_ms = Some 2000; + order = 0; + }) + ips) + in { servers; search = []; assume_offline_after_drops = None } - module IntMap = - Map.Make(struct - type t = int - let compare (a: int) (b: int) = Stdlib.compare a b - end) + module IntMap = Map.Make (struct + type t = int + + let compare (a : int) (b : int) = Stdlib.compare a b + end) let google_dns = - let ips = [ - Ipaddr.of_string_exn "8.8.8.8", 53; - Ipaddr.of_string_exn "8.8.4.4", 53; - ] in + let ips = + [ + (Ipaddr.of_string_exn "8.8.8.8", 53); + (Ipaddr.of_string_exn "8.8.4.4", 53); + ] + in `Upstream (config_of_ips ips) type priority = int let t = ref (IntMap.add 0 google_dns IntMap.empty) - - let config () = - snd @@ IntMap.max_binding !t + let config () = snd @@ IntMap.max_binding !t let add ~priority ~config:c = let before = config () in - t := IntMap.add priority c (!t); + t := IntMap.add priority c !t; let after = config () in - if Config.compare before after <> 0 - then Log.info (fun f -> - f "Add(%d): DNS configuration changed to: %s" priority - (Config.to_string after)) + if Config.compare before after <> 0 then + Log.info (fun f -> + f "Add(%d): DNS configuration changed to: %s" priority + (Config.to_string after)) let remove ~priority = let before = config () in t := IntMap.remove priority !t; let after = config () in - if Config.compare before after <> 0 - then + if Config.compare before after <> 0 then Log.info (fun f -> f "Remove(%d): DNS configuration changed to: %s" priority (Config.to_string after)) (* Watch for the /etc/resolv.file *) let resolv_conf = "/etc/resolv.conf" - let _ : unit Lwt.t = + + let (_ : unit Lwt.t) = Files.watch_file resolv_conf (fun () -> Lwt.async (fun () -> - Files.read_file resolv_conf - >>= function + Files.read_file resolv_conf >>= function | Error (`Msg m) -> - Log.info (fun f -> f "reading %s: %s" resolv_conf m); - Lwt.return_unit - | Ok txt -> - begin match Dns_forward.Config.Unix.of_resolv_conf txt with - | Error (`Msg m) -> - Log.err (fun f -> f "parsing %s: %s" resolv_conf m); + Log.info (fun f -> f "reading %s: %s" resolv_conf m); Lwt.return_unit - | Ok servers -> - add ~priority:2 ~config:(`Upstream servers); - Lwt.return_unit - end - ) - ) + | Ok txt -> ( + match Dns_forward.Config.Unix.of_resolv_conf txt with + | Error (`Msg m) -> + Log.err (fun f -> f "parsing %s: %s" resolv_conf m); + Lwt.return_unit + | Ok servers -> + add ~priority:2 ~config:(`Upstream servers); + Lwt.return_unit))) >>= function | Error (`Msg "ENOENT") -> - Log.info (fun f -> f "Not watching %s because it does not exist" resolv_conf); - Lwt.return_unit + Log.info (fun f -> + f "Not watching %s because it does not exist" resolv_conf); + Lwt.return_unit | Error (`Msg m) -> - Log.info (fun f -> f "Cannot watch %s: %s" resolv_conf m); - Lwt.return_unit + Log.info (fun f -> f "Cannot watch %s: %s" resolv_conf m); + Lwt.return_unit | Ok _watch -> - Log.info (fun f -> f "Will watch %s for changes" resolv_conf); - Lwt.return_unit - + Log.info (fun f -> f "Will watch %s for changes" resolv_conf); + Lwt.return_unit end let try_etc_hosts = let open Dns.Packet in function - | { q_class = Q_IN; q_type = Q_A; q_name; _ } -> - begin - match List.fold_left (fun found (name, ip) -> - match found, ip with - | Some v4, _ -> Some v4 - | None, Ipaddr.V4 v4 -> - if Dns.Name.to_string q_name = name then Some v4 else None - | None, Ipaddr.V6 _ -> None - ) None !(Hosts.etc_hosts) + | { q_class = Q_IN; q_type = Q_A; q_name; _ } -> ( + match + List.fold_left + (fun found (name, ip) -> + match (found, ip) with + | Some v4, _ -> Some v4 + | None, Ipaddr.V4 v4 -> + if Dns.Name.to_string q_name = name then Some v4 else None + | None, Ipaddr.V6 _ -> None) + None !Hosts.etc_hosts with | None -> None | Some v4 -> - Some [ { name = q_name; cls = RR_IN; - flush = false; ttl = 0l; rdata = A v4 } ] - end - | { q_class = Q_IN; q_type = Q_AAAA; q_name; _ } -> - begin - match List.fold_left (fun found (name, ip) -> match found, ip with - | Some v6, _ -> Some v6 - | None, Ipaddr.V6 v6 -> - if Dns.Name.to_string q_name = name then Some v6 else None - | None, Ipaddr.V4 _ -> None - ) None !(Hosts.etc_hosts) + Some + [ + { + name = q_name; + cls = RR_IN; + flush = false; + ttl = 0l; + rdata = A v4; + }; + ]) + | { q_class = Q_IN; q_type = Q_AAAA; q_name; _ } -> ( + match + List.fold_left + (fun found (name, ip) -> + match (found, ip) with + | Some v6, _ -> Some v6 + | None, Ipaddr.V6 v6 -> + if Dns.Name.to_string q_name = name then Some v6 else None + | None, Ipaddr.V4 _ -> None) + None !Hosts.etc_hosts with | None -> None | Some v6 -> - Some [ { name = q_name; cls = RR_IN; flush = false; ttl = 0l; - rdata = AAAA v6 } ] - end + Some + [ + { + name = q_name; + cls = RR_IN; + flush = false; + ttl = 0l; + rdata = AAAA v6; + }; + ]) | _ -> None let try_builtins builtin_names question = let open Dns.Packet in match question with - | { q_class = Q_IN; q_type = (Q_A|Q_AAAA); q_name; _ } -> - let bindings = List.filter (fun (name, _) -> name = q_name) builtin_names in - if bindings = [] - then `Dont_know - else begin - let ipv4_rrs = - List.fold_left (fun acc (_, ip) -> - match ip with - | Ipaddr.V4 ipv4 -> { name = q_name; cls = RR_IN; flush = false; ttl = 0l; rdata = A ipv4 } :: acc - | _ -> acc - ) [] bindings in - let ipv6_rrs = - List.fold_left (fun acc (_, ip) -> - match ip with - | Ipaddr.V6 ipv6 -> { name = q_name; cls = RR_IN; flush = false; ttl = 0l; rdata = AAAA ipv6 } :: acc - | _ -> acc - ) [] bindings in - let rrs = if question.q_type = Q_A then ipv4_rrs else ipv6_rrs in - if rrs = [] then begin - Log.debug (fun f -> - f "DNS: %s is a builtin but there are no resource records for %s" - (Dns.Name.to_string q_name) - (if question.q_type = Q_A then "IPv4" else "IPv6") - ); - `Does_not_exist (* we've claimed the name but maybe don't have an AAAA record *) - end else begin - Log.debug (fun f -> - f "DNS: %s is a builtin: %s" (Dns.Name.to_string q_name) - (String.concat "; " (List.map (fun rr -> Dns.Packet.rr_to_string rr) rrs)) - ); - `Answers rrs - end - end + | { q_class = Q_IN; q_type = Q_A | Q_AAAA; q_name; _ } -> + let bindings = + List.filter (fun (name, _) -> name = q_name) builtin_names + in + if bindings = [] then `Dont_know + else + let ipv4_rrs = + List.fold_left + (fun acc (_, ip) -> + match ip with + | Ipaddr.V4 ipv4 -> + { + name = q_name; + cls = RR_IN; + flush = false; + ttl = 0l; + rdata = A ipv4; + } + :: acc + | _ -> acc) + [] bindings + in + let ipv6_rrs = + List.fold_left + (fun acc (_, ip) -> + match ip with + | Ipaddr.V6 ipv6 -> + { + name = q_name; + cls = RR_IN; + flush = false; + ttl = 0l; + rdata = AAAA ipv6; + } + :: acc + | _ -> acc) + [] bindings + in + let rrs = if question.q_type = Q_A then ipv4_rrs else ipv6_rrs in + if rrs = [] then ( + Log.debug (fun f -> + f "DNS: %s is a builtin but there are no resource records for %s" + (Dns.Name.to_string q_name) + (if question.q_type = Q_A then "IPv4" else "IPv6")); + `Does_not_exist + (* we've claimed the name but maybe don't have an AAAA record *)) + else ( + Log.debug (fun f -> + f "DNS: %s is a builtin: %s" + (Dns.Name.to_string q_name) + (String.concat "; " + (List.map (fun rr -> Dns.Packet.rr_to_string rr) rrs))); + `Answers rrs) | _ -> `Dont_know module Make - (Ip: Tcpip.Ip.S with type ipaddr = Ipaddr.V4.t) - (Udp: Tcpip.Udp.S with type ipaddr = Ipaddr.V4.t) - (Tcp: Tcpip.Tcp.S with type ipaddr = Ipaddr.V4.t) - (Socket: Sig.SOCKETS) - (D: Sig.DNS) - (Time: Mirage_time.S) - (Clock: Mirage_clock.MCLOCK) - (Recorder: Sig.RECORDER) = + (Ip : Tcpip.Ip.S with type ipaddr = Ipaddr.V4.t) + (Udp : Tcpip.Udp.S with type ipaddr = Ipaddr.V4.t) + (Tcp : Tcpip.Tcp.S with type ipaddr = Ipaddr.V4.t) + (Socket : Sig.SOCKETS) + (D : Sig.DNS) + (Time : Mirage_time.S) + (Clock : Mirage_clock.MCLOCK) + (Recorder : Sig.RECORDER) = struct - (* DNS uses slightly different protocols over TCP and UDP. We need both a UDP and TCP resolver configured to use the upstream servers. We will map UDP onto UDP and TCP onto TCP, leaving the client to handle the truncated bit and retransmissions. *) module Dns_tcp_client = - Dns_forward.Rpc.Client.Persistent.Make(Socket.Stream.Tcp) - (Dns_forward.Framing.Tcp(Socket.Stream.Tcp))(Time) + Dns_forward.Rpc.Client.Persistent.Make + (Socket.Stream.Tcp) + (Dns_forward.Framing.Tcp (Socket.Stream.Tcp)) + (Time) module Dns_tcp_resolver = - Dns_forward.Resolver.Make(Dns_tcp_client)(Time)(Clock) + Dns_forward.Resolver.Make (Dns_tcp_client) (Time) (Clock) module Dns_udp_client = - Dns_forward.Rpc.Client.Nonpersistent.Make(Socket.Datagram.Udp) - (Dns_forward.Framing.Udp(Socket.Datagram.Udp))(Time) + Dns_forward.Rpc.Client.Nonpersistent.Make + (Socket.Datagram.Udp) + (Dns_forward.Framing.Udp (Socket.Datagram.Udp)) + (Time) module Dns_udp_resolver = - Dns_forward.Resolver.Make(Dns_udp_client)(Time)(Clock) + Dns_forward.Resolver.Make (Dns_udp_client) (Time) (Clock) (* We need to be able to parse the incoming framed TCP messages *) - module Dns_tcp_framing = Dns_forward.Framing.Tcp(Tcp) + module Dns_tcp_framing = Dns_forward.Framing.Tcp (Tcp) type dns = { - dns_tcp_resolver: Dns_tcp_resolver.t; - dns_udp_resolver: Dns_udp_resolver.t; + dns_tcp_resolver : Dns_tcp_resolver.t; + dns_udp_resolver : Dns_udp_resolver.t; } type resolver = - | Upstream of dns (* use upstream DNS servers *) - | Host (* use the host resolver *) + | Upstream of dns + (* use upstream DNS servers *) + | Host + (* use the host resolver *) type t = { - local_ip: Ipaddr.t; - builtin_names: (Dns.Name.t * Ipaddr.t) list; - resolver: resolver; + local_ip : Ipaddr.t; + builtin_names : (Dns.Name.t * Ipaddr.t) list; + resolver : resolver; } let recorder = ref None let set_recorder r = recorder := Some r let destroy = function - | { resolver = Upstream { dns_tcp_resolver; dns_udp_resolver; _ }; _ } -> - (* We need a source of randomness in this case *) - let _ = - match Utils.rtlGenRandom 1 with - | None -> - Log.warn (fun f -> f "No secure random number generator available") - | Some _ -> - Log.info (fun f -> f "Secure random number generator is available") in - Dns_tcp_resolver.destroy dns_tcp_resolver - >>= fun () -> - Dns_udp_resolver.destroy dns_udp_resolver - | { resolver = Host; _ } -> - Log.info (fun f -> f "We do not need secure random numbers in Host mode"); - Lwt.return_unit + | { resolver = Upstream { dns_tcp_resolver; dns_udp_resolver; _ }; _ } -> + (* We need a source of randomness in this case *) + let _ = + match Utils.rtlGenRandom 1 with + | None -> + Log.warn (fun f -> + f "No secure random number generator available") + | Some _ -> + Log.info (fun f -> + f "Secure random number generator is available") + in + Dns_tcp_resolver.destroy dns_tcp_resolver >>= fun () -> + Dns_udp_resolver.destroy dns_udp_resolver + | { resolver = Host; _ } -> + Log.info (fun f -> + f "We do not need secure random numbers in Host mode"); + Lwt.return_unit let record_udp ~source_ip ~source_port ~dest_ip ~dest_port bufs = match !recorder with | Some recorder -> - (* This is from mirage-tcpip-- ideally we would use a simpler - packet creation fn *) - let frame = Io_page.to_cstruct (Io_page.get 1) in - let smac = "\000\000\000\000\000\000" in - Ethernet__Ethernet_wire.set_ethernet_src smac 0 frame; - Ethernet__Ethernet_wire.set_ethernet_ethertype frame 0x0800; - let buf = Cstruct.shift frame Ethernet.Packet.sizeof_ethernet in - Ipv4_wire.set_ipv4_hlen_version buf ((4 lsl 4) + (5)); - Ipv4_wire.set_ipv4_tos buf 0; - Ipv4_wire.set_ipv4_ttl buf 38; - let proto = Ipv4_packet.Marshal.protocol_to_int `UDP in - Ipv4_wire.set_ipv4_proto buf proto; - Ipv4_wire.set_ipv4_src buf (Ipaddr.V4.to_int32 source_ip); - Ipv4_wire.set_ipv4_dst buf (Ipaddr.V4.to_int32 dest_ip); - let header_len = - Ethernet.Packet.sizeof_ethernet + Ipv4_wire.sizeof_ipv4 - in + (* This is from mirage-tcpip-- ideally we would use a simpler + packet creation fn *) + let frame = Io_page.to_cstruct (Io_page.get 1) in + let smac = "\000\000\000\000\000\000" in + Ethernet__Ethernet_wire.set_ethernet_src smac 0 frame; + Ethernet__Ethernet_wire.set_ethernet_ethertype frame 0x0800; + let buf = Cstruct.shift frame Ethernet.Packet.sizeof_ethernet in + Ipv4_wire.set_ipv4_hlen_version buf ((4 lsl 4) + 5); + Ipv4_wire.set_ipv4_tos buf 0; + Ipv4_wire.set_ipv4_ttl buf 38; + let proto = Ipv4_packet.Marshal.protocol_to_int `UDP in + Ipv4_wire.set_ipv4_proto buf proto; + Ipv4_wire.set_ipv4_src buf (Ipaddr.V4.to_int32 source_ip); + Ipv4_wire.set_ipv4_dst buf (Ipaddr.V4.to_int32 dest_ip); + let header_len = + Ethernet.Packet.sizeof_ethernet + Ipv4_wire.sizeof_ipv4 + in - let frame = Cstruct.sub frame 0 (header_len + Udp_wire.sizeof_udp) in - let udp_buf = Cstruct.shift frame header_len in - Udp_wire.set_udp_source_port udp_buf source_port; - Udp_wire.set_udp_dest_port udp_buf dest_port; - Udp_wire.set_udp_length udp_buf (Udp_wire.sizeof_udp + Cstruct.lenv bufs); - Udp_wire.set_udp_checksum udp_buf 0; - (* Only for recording, no need to set a checksum. *) - (* Ip.writev *) - let bufs = frame :: bufs in - let tlen = Cstruct.lenv bufs - Ethernet.Packet.sizeof_ethernet in - let dmac = String.make 6 '\000' in - (* Ip.adjust_output_header *) - Ethernet__Ethernet_wire.set_ethernet_dst dmac 0 frame; - let buf = - Cstruct.sub frame Ethernet.Packet.sizeof_ethernet Ipv4_wire.sizeof_ipv4 - in - (* Set the mutable values in the ipv4 header *) - Ipv4_wire.set_ipv4_len buf tlen; - Ipv4_wire.set_ipv4_id buf (Random.int 65535); (* TODO *) - Ipv4_wire.set_ipv4_csum buf 0; - (* Only for recording, no need to set a checksum *) - Recorder.record recorder bufs - | None -> - () (* nowhere to log packet *) + let frame = Cstruct.sub frame 0 (header_len + Udp_wire.sizeof_udp) in + let udp_buf = Cstruct.shift frame header_len in + Udp_wire.set_udp_source_port udp_buf source_port; + Udp_wire.set_udp_dest_port udp_buf dest_port; + Udp_wire.set_udp_length udp_buf (Udp_wire.sizeof_udp + Cstruct.lenv bufs); + Udp_wire.set_udp_checksum udp_buf 0; + (* Only for recording, no need to set a checksum. *) + (* Ip.writev *) + let bufs = frame :: bufs in + let tlen = Cstruct.lenv bufs - Ethernet.Packet.sizeof_ethernet in + let dmac = String.make 6 '\000' in + (* Ip.adjust_output_header *) + Ethernet__Ethernet_wire.set_ethernet_dst dmac 0 frame; + let buf = + Cstruct.sub frame Ethernet.Packet.sizeof_ethernet + Ipv4_wire.sizeof_ipv4 + in + (* Set the mutable values in the ipv4 header *) + Ipv4_wire.set_ipv4_len buf tlen; + Ipv4_wire.set_ipv4_id buf (Random.int 65535); + (* TODO *) + Ipv4_wire.set_ipv4_csum buf 0; + (* Only for recording, no need to set a checksum *) + Recorder.record recorder bufs + | None -> () + (* nowhere to log packet *) (* Generate a cryptograpically sure random number *) let gen_transaction_id bound = if bound <> 0x10000 then failwith "gen_transaction_id"; match Utils.rtlGenRandom 2 with | Some bytes -> - (int_of_char (Bytes.get bytes 0) lsl 8) lor (int_of_char (Bytes.get bytes 1)) - | None -> - Random.int bound + (int_of_char (Bytes.get bytes 0) lsl 8) + lor int_of_char (Bytes.get bytes 1) + | None -> Random.int bound let create ~local_address ~builtin_names = let local_ip = local_address.Dns_forward.Config.Address.ip in Log.info (fun f -> - let suffix = match builtin_names with - | [] -> "no builtin DNS names; everything will be forwarded" - | _ -> Printf.sprintf "builtin DNS names [ %s ]" (String.concat ", " @@ List.map (fun (name, ip) -> Dns.Name.to_string name ^ " -> " ^ (Ipaddr.to_string ip)) builtin_names) in - f "DNS server configured with %s" suffix); + let suffix = + match builtin_names with + | [] -> "no builtin DNS names; everything will be forwarded" + | _ -> + Printf.sprintf "builtin DNS names [ %s ]" + (String.concat ", " + @@ List.map + (fun (name, ip) -> + Dns.Name.to_string name ^ " -> " ^ Ipaddr.to_string ip) + builtin_names) + in + f "DNS server configured with %s" suffix); function | `Upstream config -> - let open Dns_forward.Config.Address in - let nr_servers = - let open Dns_forward.Config in - Server.Set.cardinal config.servers in - Log.info (fun f -> f "%d upstream DNS servers are configured" nr_servers); - - let message_cb ?(src = local_address) ?(dst = local_address) ~buf () = - match src, dst with - | { ip = Ipaddr.V4 source_ip; port = source_port }, - { ip = Ipaddr.V4 dest_ip; port = dest_port } -> - record_udp ~source_ip ~source_port ~dest_ip ~dest_port [ buf ]; - Lwt.return_unit - | _ -> - (* We don't know how to marshal IPv6 yet *) - Lwt.return_unit - in - Dns_udp_resolver.create ~gen_transaction_id ~message_cb config - >>= fun dns_udp_resolver -> - Dns_tcp_resolver.create ~gen_transaction_id ~message_cb config - >>= fun dns_tcp_resolver -> - Lwt.return { local_ip; builtin_names; - resolver = Upstream { dns_tcp_resolver; dns_udp_resolver } } + let open Dns_forward.Config.Address in + let nr_servers = + let open Dns_forward.Config in + Server.Set.cardinal config.servers + in + Log.info (fun f -> + f "%d upstream DNS servers are configured" nr_servers); + + let message_cb ?(src = local_address) ?(dst = local_address) ~buf () = + match (src, dst) with + | ( { ip = Ipaddr.V4 source_ip; port = source_port }, + { ip = Ipaddr.V4 dest_ip; port = dest_port } ) -> + record_udp ~source_ip ~source_port ~dest_ip ~dest_port [ buf ]; + Lwt.return_unit + | _ -> + (* We don't know how to marshal IPv6 yet *) + Lwt.return_unit + in + Dns_udp_resolver.create ~gen_transaction_id ~message_cb config + >>= fun dns_udp_resolver -> + Dns_tcp_resolver.create ~gen_transaction_id ~message_cb config + >>= fun dns_tcp_resolver -> + Lwt.return + { + local_ip; + builtin_names; + resolver = Upstream { dns_tcp_resolver; dns_udp_resolver }; + } | `Host -> - Log.info (fun f -> f "Will use the host's DNS resolver"); - Lwt.return { local_ip; builtin_names; resolver = Host } + Log.info (fun f -> f "Will use the host's DNS resolver"); + Lwt.return { local_ip; builtin_names; resolver = Host } let search f low high = - if not(f low) - then None (* none of the elements satisfy the predicate *) + if not (f low) then None (* none of the elements satisfy the predicate *) else let rec loop low high = - if low = high - then Some low + if low = high then Some low else let mid = (low + high + 1) / 2 in (* since low <> high, mid <> low but it might be mid = high *) - if f mid - then loop mid high - else - if mid = high - then Some low - else loop low mid in + if f mid then loop mid high + else if mid = high then Some low + else loop low mid + in loop low high let answer t is_tcp buf = let open Dns.Packet in let len = Cstruct.length buf in match Dns.Protocol.Server.parse (Cstruct.sub buf 0 len) with - | None -> - Lwt.return (Error (`Msg "failed to parse DNS packet")) - | Some ({ questions = [ question ]; _ } as request) -> - let reply ~tc answers = - let id = request.id in - let detail = - { request.detail with Dns.Packet.qr = Dns.Packet.Response; ra = true; tc } + | None -> Lwt.return (Error (`Msg "failed to parse DNS packet")) + | Some ({ questions = [ question ]; _ } as request) -> ( + let reply ~tc answers = + let id = request.id in + let detail = + { + request.detail with + Dns.Packet.qr = Dns.Packet.Response; + ra = true; + tc; + } + in + let questions = request.questions in + let authorities = [] and additionals = [] in + { + Dns.Packet.id; + detail; + questions; + answers; + authorities; + additionals; + } in - let questions = request.questions in - let authorities = [] and additionals = [] in - { Dns.Packet.id; detail; questions; answers; authorities; additionals } - in - let nxdomain = - let id = request.id in - let detail = - { request.detail with Dns.Packet.qr = Dns.Packet.Response; - ra = true; rcode = Dns.Packet.NXDomain - } in - let questions = request.questions in - let authorities = [] and additionals = [] and answers = [] + let nxdomain = + let id = request.id in + let detail = + { + request.detail with + Dns.Packet.qr = Dns.Packet.Response; + ra = true; + rcode = Dns.Packet.NXDomain; + } + in + let questions = request.questions in + let authorities = [] and additionals = [] and answers = [] in + { + Dns.Packet.id; + detail; + questions; + answers; + authorities; + additionals; + } + in + let marshal_reply answers = + let buf = marshal @@ reply ~tc:false answers in + if is_tcp then Some buf (* No need to truncate for TCP *) + else + (* If the packet is too big then set the TC bit and truncate by dropping answers *) + let take n from = + let rec loop n from acc = + match (n, from) with + | 0, _ -> acc + | _, [] -> acc + | n, x :: xs -> loop (n - 1) xs (x :: acc) + in + List.rev @@ loop n from [] + in + if Cstruct.length buf > max_udp_response then + match + search + (fun num -> + (* use only the first 'num' answers *) + Cstruct.length (marshal @@ reply ~tc:true (take num answers)) + <= max_udp_response) + 0 (List.length answers) + with + | None -> None + | Some num -> Some (marshal @@ reply ~tc:true (take num answers)) + else Some buf in - { Dns.Packet.id; detail; questions; answers; authorities; - additionals } - in - let marshal_reply answers = - let buf = marshal @@ reply ~tc:false answers in - if is_tcp - then Some buf (* No need to truncate for TCP *) - else begin - (* If the packet is too big then set the TC bit and truncate by dropping answers *) - let take n from = - let rec loop n from acc = match n, from with - | 0, _ -> acc - | _, [] -> acc - | n, x :: xs -> loop (n - 1) xs (x :: acc) in - List.rev @@ loop n from [] in - if Cstruct.length buf > max_udp_response then begin - match search (fun num -> - (* use only the first 'num' answers *) - Cstruct.length (marshal @@ reply ~tc:true (take num answers)) <= max_udp_response - ) 0 (List.length answers) with - | None -> None - | Some num -> Some (marshal @@ reply ~tc:true (take num answers)) - end - else Some buf - end in - begin (* Consider the builtins (from the command-line) to have higher priority than the addresses in the /etc/hosts file. *) match try_builtins t.builtin_names question with - | `Does_not_exist -> - Lwt.return (Ok (Some (marshal nxdomain))) - | `Answers answers -> - Lwt.return (Ok (marshal_reply answers)) - | `Dont_know -> - match try_etc_hosts question with - | Some answers -> - Lwt.return (Ok (marshal_reply answers)) - | None -> - match is_tcp, t.resolver with - | true, Upstream { dns_tcp_resolver; _ } -> - begin - Dns_tcp_resolver.answer buf dns_tcp_resolver - >>= function - | Error e -> Lwt.return (Error e) - | Ok buf -> Lwt.return (Ok (Some buf)) - end - | false, Upstream { dns_udp_resolver; _ } -> - begin - Dns_udp_resolver.answer buf dns_udp_resolver - >>= function - | Error e -> Lwt.return (Error e) - | Ok buf -> - (* We need to parse and re-marshal so we can set the TC bit and truncate *) - begin match Dns.Protocol.Server.parse buf with - | None -> - Lwt.return (Error (`Msg "Failed to unmarshal DNS response from upstream")) - | Some { answers; _ } -> - Lwt.return (Ok (marshal_reply answers)) - end - end - | _, Host -> - D.resolve question - >>= function - | [] -> - Lwt.return (Ok (Some (marshal nxdomain))) - | answers -> - Lwt.return (Ok (marshal_reply answers)) - end - | _ -> - Lwt.return (Error (`Msg "DNS packet had multiple questions")) + | `Does_not_exist -> Lwt.return (Ok (Some (marshal nxdomain))) + | `Answers answers -> Lwt.return (Ok (marshal_reply answers)) + | `Dont_know -> ( + match try_etc_hosts question with + | Some answers -> Lwt.return (Ok (marshal_reply answers)) + | None -> ( + match (is_tcp, t.resolver) with + | true, Upstream { dns_tcp_resolver; _ } -> ( + Dns_tcp_resolver.answer buf dns_tcp_resolver >>= function + | Error e -> Lwt.return (Error e) + | Ok buf -> Lwt.return (Ok (Some buf))) + | false, Upstream { dns_udp_resolver; _ } -> ( + Dns_udp_resolver.answer buf dns_udp_resolver >>= function + | Error e -> Lwt.return (Error e) + | Ok buf -> ( + (* We need to parse and re-marshal so we can set the TC bit and truncate *) + match Dns.Protocol.Server.parse buf with + | None -> + Lwt.return + (Error + (`Msg + "Failed to unmarshal DNS response from \ + upstream")) + | Some { answers; _ } -> + Lwt.return (Ok (marshal_reply answers)))) + | _, Host -> ( + D.resolve question >>= function + | [] -> Lwt.return (Ok (Some (marshal nxdomain))) + | answers -> Lwt.return (Ok (marshal_reply answers)))))) + | _ -> Lwt.return (Error (`Msg "DNS packet had multiple questions")) let describe buf = let len = Cstruct.length buf in @@ -461,16 +532,16 @@ struct | Some request -> Dns.Packet.to_string request let handle_udp ~t ~udp ~src ~dst:_ ~src_port buf = - answer t false buf - >>= function + answer t false buf >>= function | Error (`Msg m) -> - Log.warn (fun f -> f "%s lookup failed: %s" (describe buf) m); - Lwt.return (Ok ()) + Log.warn (fun f -> f "%s lookup failed: %s" (describe buf) m); + Lwt.return (Ok ()) | Ok None -> - Log.err (fun f -> f "%s unable to marshal response" (describe buf)); - Lwt.return (Ok ()) + Log.err (fun f -> f "%s unable to marshal response" (describe buf)); + Lwt.return (Ok ()) | Ok (Some buffer) -> - Udp.write ~src_port:53 (* ~src:dst *) ~dst:src ~dst_port:src_port udp buffer + Udp.write ~src_port:53 (* ~src:dst *) + ~dst:src ~dst_port:src_port udp buffer let handle_tcp ~t = (* FIXME: need to record the upstream request *) @@ -480,33 +551,34 @@ struct let packets = Dns_tcp_framing.connect flow in let rec loop () = Dns_tcp_framing.read packets >>= function - | Error _ -> Lwt.return_unit + | Error _ -> Lwt.return_unit | Ok request -> - (* Perform queries in background threads *) - let queries () = - answer t true request >>= function - | Error (`Msg m) -> - Log.warn (fun f -> f "%s lookup failed: %s" (describe request) m); - Lwt.return_unit - | Ok None -> - Log.err (fun f -> f "%s unable to marshal response to" (describe request)); - Lwt.return_unit - | Ok (Some buffer) -> - Dns_tcp_framing.write packets buffer >>= function + (* Perform queries in background threads *) + let queries () = + answer t true request >>= function | Error (`Msg m) -> - Log.warn (fun f -> - f "%s failed to write response: %s" (describe buffer) m); - Lwt.return_unit - | Ok () -> - Lwt.return_unit - in - Lwt.async queries; - loop () + Log.warn (fun f -> + f "%s lookup failed: %s" (describe request) m); + Lwt.return_unit + | Ok None -> + Log.err (fun f -> + f "%s unable to marshal response to" (describe request)); + Lwt.return_unit + | Ok (Some buffer) -> ( + Dns_tcp_framing.write packets buffer >>= function + | Error (`Msg m) -> + Log.warn (fun f -> + f "%s failed to write response: %s" + (describe buffer) m); + Lwt.return_unit + | Ok () -> Lwt.return_unit) + in + Lwt.async queries; + loop () in loop () in Some f in Lwt.return listeners - end File "src/hostnet_test/suite.ml", line 1, characters 0-0: diff --git a/_build/default/src/hostnet_test/suite.ml b/_build/default/src/hostnet_test/.formatted/suite.ml index 8c4380e..06ec44e 100644 --- a/_build/default/src/hostnet_test/suite.ml +++ b/_build/default/src/hostnet_test/.formatted/suite.ml @@ -11,10 +11,9 @@ module Log = (val Logs.src_log src : Logs.LOG) let pp_ips = Fmt.(list ~sep:(any ", ") Ipaddr.pp) let pp_ip4s = Fmt.(list ~sep:(any ", ") Ipaddr.V4.pp) -let run_test ?(timeout=Duration.of_sec 60) t = +let run_test ?(timeout = Duration.of_sec 60) t = let timeout = - Host.Time.sleep_ns timeout >>= fun () -> - Lwt.fail_with "timeout" + Host.Time.sleep_ns timeout >>= fun () -> Lwt.fail_with "timeout" in Host.Main.run @@ Lwt.pick [ timeout; t ] @@ -30,48 +29,46 @@ let test_dhcp_query () = let test_max_connections () = let t _ stack = - Lwt.finalize (fun () -> + Lwt.finalize + (fun () -> let resolver = DNS.create stack.Client.t in DNS.gethostbyname ~server:primary_dns_ip resolver "www.google.com" >>= function - | Ipaddr.V4 ip :: _ -> - Log.info (fun f -> f "Setting max connections to 0"); - Connection_limit.set_max (Some 0); - begin - Client.TCPV4.create_connection (Client.tcpv4 stack.Client.t) (ip, 80) - >|= function - | Ok _ -> - Log.err (fun f -> - f "Connected to www.google.com, max_connections exceeded"); - failwith "too many connections" - | Error _ -> - Log.debug (fun f -> - f "Expected failure to connect to www.google.com") - end - >>= fun () -> - Log.info (fun f -> f "Removing connection limit"); - Connection_limit.set_max None; - (* Check that connections work again *) - begin + | Ipaddr.V4 ip :: _ -> ( + Log.info (fun f -> f "Setting max connections to 0"); + Connection_limit.set_max (Some 0); + (Client.TCPV4.create_connection + (Client.tcpv4 stack.Client.t) + (ip, 80) + >|= function + | Ok _ -> + Log.err (fun f -> + f "Connected to www.google.com, max_connections exceeded"); + failwith "too many connections" + | Error _ -> + Log.debug (fun f -> + f "Expected failure to connect to www.google.com")) + >>= fun () -> + Log.info (fun f -> f "Removing connection limit"); + Connection_limit.set_max None; + (* Check that connections work again *) Client.TCPV4.create_connection (Client.tcpv4 stack.Client.t) (ip, 80) >|= function - | Ok _ -> - Log.debug (fun f -> f "Connected to www.google.com"); + | Ok _ -> Log.debug (fun f -> f "Connected to www.google.com") | Error _ -> - Log.debug (fun f -> - f "Failure to connect to www.google.com: removing \ - max_connections limit didn't work"); - failwith "wrong max connections limit" - end + Log.debug (fun f -> + f + "Failure to connect to www.google.com: removing \ + max_connections limit didn't work"); + failwith "wrong max connections limit") | _ -> - Log.err (fun f -> - f "Failed to look up an IPv4 address for www.google.com"); - failwith "http_fetch dns" - ) (fun () -> + Log.err (fun f -> + f "Failed to look up an IPv4 address for www.google.com"); + failwith "http_fetch dns") + (fun () -> Log.info (fun f -> f "Removing connection limit"); Connection_limit.set_max None; - Lwt.return_unit - ) + Lwt.return_unit) in run ~timeout:(Duration.of_sec 240) ~pcap:"test_max_connections.pcap" t @@ -79,132 +76,130 @@ let test_http_fetch () = let t _ stack = let resolver = DNS.create stack.Client.t in DNS.gethostbyname resolver "www.google.com" >>= function - | Ipaddr.V4 ip :: _ -> - begin + | Ipaddr.V4 ip :: _ -> ( Client.TCPV4.create_connection (Client.tcpv4 stack.Client.t) (ip, 80) >>= function | Error _ -> - Log.err (fun f -> f "Failed to connect to www.google.com:80"); - failwith "http_fetch" - | Ok flow -> - Log.info (fun f -> f "Connected to www.google.com:80"); - let page = Io_page.(to_cstruct (get 1)) in - let http_get = "GET / HTTP/1.0\nHost: anil.recoil.org\n\n" in - Cstruct.blit_from_string http_get 0 page 0 (String.length http_get); - let buf = Cstruct.sub page 0 (String.length http_get) in - Client.TCPV4.write flow buf >>= function - | Error `Closed -> - Log.err (fun f -> - f "EOF writing HTTP request to www.google.com:80"); - failwith "EOF on writing HTTP GET" - | Error _ -> - Log.err (fun f -> - f "Failure writing HTTP request to www.google.com:80"); - failwith "Failure on writing HTTP GET" - | Ok () -> - let rec loop total_bytes = - Client.TCPV4.read flow >>= function - | Ok `Eof -> Lwt.return total_bytes - | Error _ -> + Log.err (fun f -> f "Failed to connect to www.google.com:80"); + failwith "http_fetch" + | Ok flow -> ( + Log.info (fun f -> f "Connected to www.google.com:80"); + let page = Io_page.(to_cstruct (get 1)) in + let http_get = "GET / HTTP/1.0\nHost: anil.recoil.org\n\n" in + Cstruct.blit_from_string http_get 0 page 0 (String.length http_get); + let buf = Cstruct.sub page 0 (String.length http_get) in + Client.TCPV4.write flow buf >>= function + | Error `Closed -> Log.err (fun f -> - f "Failure read HTTP response from www.google.com:80"); - failwith "Failure on reading HTTP GET" - | Ok (`Data buf) -> - Log.info (fun f -> - f "Read %d bytes from www.google.com:80" (Cstruct.length buf)); - Log.info (fun f -> f "%s" (Cstruct.to_string buf)); - loop (total_bytes + (Cstruct.length buf)) - in - loop 0 >|= fun total_bytes -> - Log.info (fun f -> f "Response had %d total bytes" total_bytes); - if total_bytes == 0 then failwith "response was empty" - end + f "EOF writing HTTP request to www.google.com:80"); + failwith "EOF on writing HTTP GET" + | Error _ -> + Log.err (fun f -> + f "Failure writing HTTP request to www.google.com:80"); + failwith "Failure on writing HTTP GET" + | Ok () -> + let rec loop total_bytes = + Client.TCPV4.read flow >>= function + | Ok `Eof -> Lwt.return total_bytes + | Error _ -> + Log.err (fun f -> + f "Failure read HTTP response from www.google.com:80"); + failwith "Failure on reading HTTP GET" + | Ok (`Data buf) -> + Log.info (fun f -> + f "Read %d bytes from www.google.com:80" + (Cstruct.length buf)); + Log.info (fun f -> f "%s" (Cstruct.to_string buf)); + loop (total_bytes + Cstruct.length buf) + in + loop 0 >|= fun total_bytes -> + Log.info (fun f -> f "Response had %d total bytes" total_bytes); + if total_bytes == 0 then failwith "response was empty")) | _ -> - Log.err (fun f -> - f "Failed to look up an IPv4 address for www.google.com"); - failwith "http_fetch dns" + Log.err (fun f -> + f "Failed to look up an IPv4 address for www.google.com"); + failwith "http_fetch dns" in run ~pcap:"test_http_fetch.pcap" t let test_tcp_forwards () = let t _ stack = let path = "/tmp/forwards.sock" in - let module ForwardsTest = Forwards.Test(Mclock) in - ForwardsTest.start_forwarder path - >>= fun forwarder -> - Forwards.update [ - { - Forwards.protocol = `Tcp; - dst_prefix = Ipaddr.V4 Ipaddr.V4.Prefix.global; - dst_port = 80; - path = path; - } - ]; + let module ForwardsTest = Forwards.Test (Mclock) in + ForwardsTest.start_forwarder path >>= fun forwarder -> + Forwards.update + [ + { + Forwards.protocol = `Tcp; + dst_prefix = Ipaddr.V4 Ipaddr.V4.Prefix.global; + dst_port = 80; + path; + }; + ]; Lwt.finalize (fun () -> let resolver = DNS.create stack.Client.t in DNS.gethostbyname resolver "www.google.com" >>= function - | Ipaddr.V4 ip :: _ -> - begin + | Ipaddr.V4 ip :: _ -> ( Client.TCPV4.create_connection (Client.tcpv4 stack.Client.t) (ip, 80) >>= function | Error _ -> - Log.err (fun f -> f "Failed to connect to www.google.com:80"); - failwith "http_fetch" - | Ok flow -> - Log.info (fun f -> f "Connected to www.google.com:80"); - let page = Io_page.(to_cstruct (get 1)) in - let http_get = "GET / HTTP/1.0\nHost: anil.recoil.org\n\n" in - Cstruct.blit_from_string http_get 0 page 0 (String.length http_get); - let buf = Cstruct.sub page 0 (String.length http_get) in - Client.TCPV4.write flow buf >>= function - | Error `Closed -> - Log.err (fun f -> - f "EOF writing HTTP request to www.google.com:80"); - failwith "EOF on writing HTTP GET" - | Error _ -> - Log.err (fun f -> - f "Failure writing HTTP request to www.google.com:80"); - failwith "Failure on writing HTTP GET" - | Ok () -> - let rec loop total_bytes = - Client.TCPV4.read flow >>= function - | Ok `Eof -> Lwt.return total_bytes - | Error _ -> + Log.err (fun f -> f "Failed to connect to www.google.com:80"); + failwith "http_fetch" + | Ok flow -> ( + Log.info (fun f -> f "Connected to www.google.com:80"); + let page = Io_page.(to_cstruct (get 1)) in + let http_get = "GET / HTTP/1.0\nHost: anil.recoil.org\n\n" in + Cstruct.blit_from_string http_get 0 page 0 + (String.length http_get); + let buf = Cstruct.sub page 0 (String.length http_get) in + Client.TCPV4.write flow buf >>= function + | Error `Closed -> Log.err (fun f -> - f "Failure read HTTP response from www.google.com:80"); - failwith "Failure on reading HTTP GET" - | Ok (`Data buf) -> + f "EOF writing HTTP request to www.google.com:80"); + failwith "EOF on writing HTTP GET" + | Error _ -> + Log.err (fun f -> + f "Failure writing HTTP request to www.google.com:80"); + failwith "Failure on writing HTTP GET" + | Ok () -> + let rec loop total_bytes = + Client.TCPV4.read flow >>= function + | Ok `Eof -> Lwt.return total_bytes + | Error _ -> + Log.err (fun f -> + f + "Failure read HTTP response from \ + www.google.com:80"); + failwith "Failure on reading HTTP GET" + | Ok (`Data buf) -> + Log.info (fun f -> + f "Read %d bytes from www.google.com:80" + (Cstruct.length buf)); + Log.info (fun f -> f "%s" (Cstruct.to_string buf)); + loop (total_bytes + Cstruct.length buf) + in + loop 0 >|= fun total_bytes -> Log.info (fun f -> - f "Read %d bytes from www.google.com:80" (Cstruct.length buf)); - Log.info (fun f -> f "%s" (Cstruct.to_string buf)); - loop (total_bytes + (Cstruct.length buf)) - in - loop 0 >|= fun total_bytes -> - Log.info (fun f -> f "Response had %d total bytes" total_bytes); - if total_bytes == 0 then failwith "response was empty" - end + f "Response had %d total bytes" total_bytes); + if total_bytes == 0 then failwith "response was empty")) | _ -> - Log.err (fun f -> - f "Failed to look up an IPv4 address for www.google.com"); - failwith "http_fetch dns" - ) (fun () -> + Log.err (fun f -> + f "Failed to look up an IPv4 address for www.google.com"); + failwith "http_fetch dns") + (fun () -> Forwards.update []; - ForwardsTest.shutdown forwarder - ) + ForwardsTest.shutdown forwarder) in run ~pcap:"test_tcp_forwards.pcap" t module DevNullServer = struct (* Accept local TCP connections, throw away all incoming data and then return the total number of bytes processed. *) - type t = { - local_port: int; - server: Host.Sockets.Stream.Tcp.server; - } + type t = { local_port : int; server : Host.Sockets.Stream.Tcp.server } let accept flow = - let module Channel = Mirage_channel.Make(Host.Sockets.Stream.Tcp) in + let module Channel = Mirage_channel.Make (Host.Sockets.Stream.Tcp) in let ch = Channel.create flow in (* XXX: this looks like it isn't tail recursive to me *) let rec drop_all_data count = @@ -212,39 +207,37 @@ module DevNullServer = struct | Error e -> Fmt.kstr Lwt.fail_with "%a" Channel.pp_error e | Ok `Eof -> Lwt.return count | Ok (`Data buffer) -> - drop_all_data Int64.(add count (of_int (Cstruct.length buffer))) + drop_all_data Int64.(add count (of_int (Cstruct.length buffer))) in - drop_all_data 0L - >>= fun total -> + drop_all_data 0L >>= fun total -> let response = Cstruct.create 8 in Cstruct.LE.set_uint64 response 0 total; Channel.write_buffer ch response; Channel.flush ch >>= function | Error e -> Fmt.kstr Lwt.fail_with "%a" Channel.pp_write_error e - | Ok () -> Lwt.return_unit + | Ok () -> Lwt.return_unit let create () = Host.Sockets.Stream.Tcp.bind (Ipaddr.V4 Ipaddr.V4.localhost, 0) >>= fun server -> - Host.Sockets.Stream.Tcp.getsockname server - >|= fun (_, local_port) -> + Host.Sockets.Stream.Tcp.getsockname server >|= fun (_, local_port) -> Host.Sockets.Stream.Tcp.listen server accept; { local_port; server } let to_string t = Printf.sprintf "tcp:127.0.0.1:%d" t.local_port let destroy t = Host.Sockets.Stream.Tcp.shutdown t.server + let with_server f = create () >>= fun server -> Lwt.finalize (fun () -> f server) (fun () -> destroy server) end -let rec count = function 0 -> [] | n -> () :: (count (n - 1)) +let rec count = function 0 -> [] | n -> () :: count (n - 1) let run' ?timeout ~pcap t = run ?timeout ~pcap (fun x b -> DevNullServer.with_server (fun { DevNullServer.local_port; _ } -> - t local_port x b) - ) + t local_port x b)) let test_many_connections n () = let t local_port _ stack = @@ -255,118 +248,121 @@ let test_many_connections n () = calculate overheads, we connect until the system tells us we've hit the target number of connections. *) let rec loop acc i = - if Connection_limit.get_num_connections () >= n - then Lwt.return acc + if Connection_limit.get_num_connections () >= n then Lwt.return acc else - Client.TCPV4.create_connection (Client.tcpv4 stack.Client.t) + Client.TCPV4.create_connection + (Client.tcpv4 stack.Client.t) (Ipaddr.V4.localhost, local_port) >>= function | Ok c -> - Log.info (fun f -> - f "Connected %d, total tracked connections %d" i - (Connection_limit.get_num_connections ())); - loop (c :: acc) (i + 1) + Log.info (fun f -> + f "Connected %d, total tracked connections %d" i + (Connection_limit.get_num_connections ())); + loop (c :: acc) (i + 1) | Error _ -> - Fmt.kstr failwith - "Connection %d failed, total tracked connections %d" i - (Connection_limit.get_num_connections ()) + Fmt.kstr failwith + "Connection %d failed, total tracked connections %d" i + (Connection_limit.get_num_connections ()) in loop [] 0 >|= fun flows -> Log.info (fun f -> - f "Connected %d, total tracked connections %d" - (List.length flows) (Connection_limit.get_num_connections ())); + f "Connected %d, total tracked connections %d" (List.length flows) + (Connection_limit.get_num_connections ())) (* How many connections is this? *) in run' ~timeout:(Duration.of_sec 240) ~pcap:"test_many_connections.pcap" t let test_stream_data connections length () = let t local_port _ stack = - Lwt_list.iter_p (fun () -> + Lwt_list.iter_p + (fun () -> let rec connect () = - Client.TCPV4.create_connection (Client.tcpv4 stack.Client.t) + Client.TCPV4.create_connection + (Client.tcpv4 stack.Client.t) (Ipaddr.V4.localhost, local_port) >>= function | Error `Refused -> - Log.info (fun f -> f "DevNullServer Refused connection"); - Host.Time.sleep_ns (Duration.of_ms 200) - >>= fun () -> - connect () + Log.info (fun f -> f "DevNullServer Refused connection"); + Host.Time.sleep_ns (Duration.of_ms 200) >>= fun () -> connect () | Error `Timeout -> - Log.err (fun f -> f "DevNullServer connection timeout"); - failwith "DevNullServer connection timeout"; + Log.err (fun f -> f "DevNullServer connection timeout"); + failwith "DevNullServer connection timeout" | Error e -> - Log.err (fun f -> - f "DevNullServer connnection failure: %a" - Client.TCPV4.pp_error e); - Fmt.kstr failwith "%a" Client.TCPV4.pp_error e + Log.err (fun f -> + f "DevNullServer connnection failure: %a" + Client.TCPV4.pp_error e); + Fmt.kstr failwith "%a" Client.TCPV4.pp_error e | Ok flow -> - Log.info (fun f -> f "Connected to local server"); - Lwt.return flow + Log.info (fun f -> f "Connected to local server"); + Lwt.return flow in - connect () - >>= fun flow -> + connect () >>= fun flow -> let page = Io_page.(to_cstruct (get 1)) in Cstruct.memset page 0; let rec loop remaining = - if remaining = 0 - then Lwt.return () - else begin + if remaining = 0 then Lwt.return () + else let this_time = min remaining (Cstruct.length page) in let buf = Cstruct.sub page 0 this_time in Client.TCPV4.write flow buf >>= function | Error `Closed -> - Log.err (fun f -> - f "EOF writing to DevNullServerwith %d bytes left" - remaining); - (* failwith "EOF on writing to DevNullServer" *) - Lwt.return () + Log.err (fun f -> + f "EOF writing to DevNullServerwith %d bytes left" remaining); + (* failwith "EOF on writing to DevNullServer" *) + Lwt.return () | Error _ -> - Log.err (fun f -> - f "Failure writing to DevNullServer with %d bytes left" - remaining); - (* failwith "Failure on writing to DevNullServer" *) - Lwt.return () - | Ok () -> - loop (remaining - this_time) - end + Log.err (fun f -> + f "Failure writing to DevNullServer with %d bytes left" + remaining); + (* failwith "Failure on writing to DevNullServer" *) + Lwt.return () + | Ok () -> loop (remaining - this_time) in loop length >>= fun () -> Client.TCPV4.close flow >>= fun () -> Client.TCPV4.read flow >|= function | Ok `Eof -> - Log.err (fun f -> f "EOF reading result from DevNullServer"); - (* failwith "EOF reading result from DevNullServer" *) + Log.err (fun f -> f "EOF reading result from DevNullServer") + (* failwith "EOF reading result from DevNullServer" *) | Error _ -> - Log.err (fun f -> f "Failure reading result from DevNullServer"); - (* failwith "Failure on reading result from DevNullServer" *) + Log.err (fun f -> f "Failure reading result from DevNullServer") + (* failwith "Failure on reading result from DevNullServer" *) | Ok (`Data buf) -> - Log.info (fun f -> - f "Read %d bytes from DevNullServer" (Cstruct.length buf)); - let response = Cstruct.LE.get_uint64 buf 0 in - if Int64.to_int response != length - then Fmt.kstr failwith - "Response was %Ld while expected %d" response length; - ) (count connections) + Log.info (fun f -> + f "Read %d bytes from DevNullServer" (Cstruct.length buf)); + let response = Cstruct.LE.get_uint64 buf 0 in + if Int64.to_int response != length then + Fmt.kstr failwith "Response was %Ld while expected %d" response + length) + (count connections) in run' ~pcap:"test_stream_data.pcap" t -let test_dhcp = [ - "DHCP: simple query", - ["check that the DHCP server works", `Quick, test_dhcp_query]; -] - -let test_tcp = [ - "HTTP GET", [ "HTTP GET http://www.google.com/", `Quick, test_http_fetch ]; - - "TCP forward", [ "HTTP GET http://www.google.com/ via TCP forwarder", `Quick, test_tcp_forwards ]; - - "Max connections", - [ "HTTP GET fails beyond max connections", `Quick, test_max_connections ]; - - "TCP streaming", - [ "1 TCP connection transferring 1 KiB", `Quick, test_stream_data 1 1024 ]; +let test_dhcp = + [ + ( "DHCP: simple query", + [ ("check that the DHCP server works", `Quick, test_dhcp_query) ] ); + ] - (* +let test_tcp = + [ + ( "HTTP GET", + [ ("HTTP GET http://www.google.com/", `Quick, test_http_fetch) ] ); + ( "TCP forward", + [ + ( "HTTP GET http://www.google.com/ via TCP forwarder", + `Quick, + test_tcp_forwards ); + ] ); + ( "Max connections", + [ + ("HTTP GET fails beyond max connections", `Quick, test_max_connections); + ] ); + ( "TCP streaming", + [ + ("1 TCP connection transferring 1 KiB", `Quick, test_stream_data 1 1024); + ] ) + (* "10 TCP connections each transferring 1 KiB", `Quick, test_stream_data 10 1024; "32 TCP connections each transferring 1 KiB", `Quick, test_stream_data 32 1024; "1 TCP connection transferring 1 MiB", `Quick, test_stream_data 1 (1024*1024); @@ -376,19 +372,23 @@ let test_tcp = [ (1024*1024*1024); "32 TCP connections each transferring 1 GiB", `Slow, test_stream_data 32 (1024*1024*1024); - *) -] + *); + ] let tests = - Hosts_test.tests @ Forwarding.tests @ test_dhcp - @ Test_dns.suite - @ test_tcp @ Test_nat.tests @ Test_http.tests @ Test_http.Match.tests - @ Test_half_close.tests @ Test_ping.tests - @ Test_bridge.tests @ Test_forward_protocol.suite + Hosts_test.tests @ Forwarding.tests @ test_dhcp @ Test_dns.suite @ test_tcp + @ Test_nat.tests @ Test_http.tests @ Test_http.Match.tests + @ Test_half_close.tests @ Test_ping.tests @ Test_bridge.tests + @ Test_forward_protocol.suite -let scalability = [ - "1026conns", - [ "Test many connections", `Quick, test_many_connections (1024 + 2) ]; - "nmap the host", - [ "check that we can survive an agressive port scan", `Quick, Test_nmap.test_nmap ]; -] +let scalability = + [ + ( "1026conns", + [ ("Test many connections", `Quick, test_many_connections (1024 + 2)) ] ); + ( "nmap the host", + [ + ( "check that we can survive an agressive port scan", + `Quick, + Test_nmap.test_nmap ); + ] ); + ] File "src/hostnet_test/slirp_stack.ml", line 1, characters 0-0: diff --git a/_build/default/src/hostnet_test/slirp_stack.ml b/_build/default/src/hostnet_test/.formatted/slirp_stack.ml index 8ad6ca0..21ab8dc 100644 --- a/_build/default/src/hostnet_test/slirp_stack.ml +++ b/_build/default/src/hostnet_test/.formatted/slirp_stack.ml @@ -11,109 +11,127 @@ module Dns_policy = struct let config_of_ips ips = let open Dns_forward.Config in let servers = - Server.Set.of_list ( - List.map (fun (ip, _) -> - { Server.address = { Address.ip; port = 53 }; - zones = Domain.Set.empty; - timeout_ms = Some 2000; order = 0 } - ) ips) + Server.Set.of_list + (List.map + (fun (ip, _) -> + { + Server.address = { Address.ip; port = 53 }; + zones = Domain.Set.empty; + timeout_ms = Some 2000; + order = 0; + }) + ips) in { servers; search = []; assume_offline_after_drops = None } module Config = Hostnet_dns.Config let google_dns = - let ips = [ - Ipaddr.of_string_exn "8.8.8.8", 53; - Ipaddr.of_string_exn "8.8.4.4", 53; - ] in + let ips = + [ + (Ipaddr.of_string_exn "8.8.8.8", 53); + (Ipaddr.of_string_exn "8.8.4.4", 53); + ] + in `Upstream (config_of_ips ips) type priority = int - module IntMap = - Map.Make(struct - type t = int let - compare (a: int) (b: int) = Stdlib.compare a b - end) - - let t = ref (IntMap.add 0 google_dns IntMap.empty) + module IntMap = Map.Make (struct + type t = int - let clear () = t := (IntMap.add 0 google_dns IntMap.empty) + let compare (a : int) (b : int) = Stdlib.compare a b + end) - let config () = - snd @@ IntMap.max_binding !t + let t = ref (IntMap.add 0 google_dns IntMap.empty) + let clear () = t := IntMap.add 0 google_dns IntMap.empty + let config () = snd @@ IntMap.max_binding !t let add ~priority ~config:c = let before = config () in - t := IntMap.add priority c (!t); + t := IntMap.add priority c !t; let after = config () in - if Config.compare before after <> 0 - then Log.info (fun f -> - f "Add(%d): DNS configuration changed to: %s" priority - (Config.to_string after)) + if Config.compare before after <> 0 then + Log.info (fun f -> + f "Add(%d): DNS configuration changed to: %s" priority + (Config.to_string after)) let remove ~priority = let before = config () in t := IntMap.remove priority !t; let after = config () in - if Config.compare before after <> 0 - then Log.info (fun f -> - f "Remove(%d): DNS configuration changed to: %s" priority - (Config.to_string after)) - + if Config.compare before after <> 0 then + Log.info (fun f -> + f "Remove(%d): DNS configuration changed to: %s" priority + (Config.to_string after)) end -module VMNET = Vmnet.Make(Host.Sockets.Stream.Tcp) +module VMNET = Vmnet.Make (Host.Sockets.Stream.Tcp) module Vnet = Basic_backend.Make + module Slirp_stack = - Slirp.Make(VMNET)(Dns_policy)(Mclock)(Mirage_random_stdlib)(Vnet) + Slirp.Make (VMNET) (Dns_policy) (Mclock) (Mirage_random_stdlib) (Vnet) module Client = struct module Netif = VMNET - module Ethif1 = Ethernet.Make(Netif) - module Arpv41 = Arp.Make(Ethif1)(Host.Time) + module Ethif1 = Ethernet.Make (Netif) + module Arpv41 = Arp.Make (Ethif1) (Host.Time) + + module Dhcp_client_mirage1 = + Dhcp_client_mirage.Make (Mirage_random_stdlib) (Host.Time) (Netif) + + module Ipv41 = + Dhcp_ipv4.Make (Mirage_random_stdlib) (Mclock) (Host.Time) (Netif) (Ethif1) + (Arpv41) - module Dhcp_client_mirage1 = Dhcp_client_mirage.Make(Mirage_random_stdlib)(Host.Time)(Netif) - module Ipv41 = Dhcp_ipv4.Make(Mirage_random_stdlib)(Mclock)(Host.Time)(Netif)(Ethif1)(Arpv41) module Icmpv41 = struct - include Icmpv4.Make(Ipv41) + include Icmpv4.Make (Ipv41) + let packets = Queue.create () + let input _ ~src ~dst buf = match Icmpv4_packet.Unmarshal.of_cstruct buf with | Error msg -> - Log.err (fun f -> f "Error unmarshalling ICMP message: %s" msg); - Lwt.return_unit - | Ok (reply, _) -> - let open Icmpv4_packet in - begin match reply.subheader with + Log.err (fun f -> f "Error unmarshalling ICMP message: %s" msg); + Lwt.return_unit + | Ok (reply, _) -> ( + let open Icmpv4_packet in + match reply.subheader with | Next_hop_mtu _ | Pointer _ | Address _ | Unused -> - Log.err (fun f -> f "received an ICMP message which wasn't an echo-request or reply"); - Lwt.return_unit + Log.err (fun f -> + f + "received an ICMP message which wasn't an echo-request or \ + reply"); + Lwt.return_unit | Id_and_seq (id, _) -> - Log.info (fun f -> - f "ICMP src:%a dst:%a id:%d" Ipaddr.V4.pp src Ipaddr.V4.pp dst id); + Log.info (fun f -> + f "ICMP src:%a dst:%a id:%d" Ipaddr.V4.pp src Ipaddr.V4.pp dst + id); Queue.push (src, dst, id) packets; - Lwt.return_unit - end + Lwt.return_unit) end - module Udp1 = Udp.Make(Ipv41)(Mirage_random_stdlib) - module Tcp1 = Tcp.Flow.Make(Ipv41)(Host.Time)(Mclock)(Mirage_random_stdlib) - include Tcpip_stack_direct.Make(Host.Time) - (Mirage_random_stdlib)(Netif)(Ethif1)(Arpv41)(Ipv41)(Icmpv41)(Udp1)(Tcp1) + + module Udp1 = Udp.Make (Ipv41) (Mirage_random_stdlib) + + module Tcp1 = + Tcp.Flow.Make (Ipv41) (Host.Time) (Mclock) (Mirage_random_stdlib) + + include + Tcpip_stack_direct.Make (Host.Time) (Mirage_random_stdlib) (Netif) (Ethif1) + (Arpv41) + (Ipv41) + (Icmpv41) + (Udp1) + (Tcp1) let or_error name m = m >>= function | `Error _ -> Fmt.kstr failwith "Failed to connect %s device" name - | `Ok x -> Lwt.return x + | `Ok x -> Lwt.return x - type stack = { - t: t; - icmpv4: Icmpv41.t; - netif: VMNET.t; - } + type stack = { t : t; icmpv4 : Icmpv41.t; netif : VMNET.t } - let connect (interface: VMNET.t) = + let connect (interface : VMNET.t) = Ethif1.connect interface >>= fun ethif -> Arpv41.connect ethif >>= fun arp -> Dhcp_client_mirage1.connect interface >>= fun _dhcp -> @@ -121,36 +139,39 @@ module Client = struct Icmpv41.connect ipv4 >>= fun icmpv4 -> Udp1.connect ipv4 >>= fun udp4 -> Tcp1.connect ipv4 >>= fun tcp4 -> - connect interface ethif arp ipv4 icmpv4 udp4 tcp4 - >>= fun t -> + connect interface ethif arp ipv4 icmpv4 udp4 tcp4 >>= fun t -> Log.info (fun f -> f "Client has connected"); - Lwt.return { t; icmpv4 ; netif=interface } + Lwt.return { t; icmpv4; netif = interface } end -module DNS = Dns_resolver_mirage.Make(Host.Time)(Client) +module DNS = Dns_resolver_mirage.Make (Host.Time) (Client) let primary_dns_ip = Ipaddr.V4.of_string_exn "192.168.65.1" - let localhost_ip = Ipaddr.V4.of_string_exn "192.168.65.2" - let preferred_ip1 = Ipaddr.V4.of_string_exn "192.168.65.250" -let names_for_localhost = List.map Dns.Name.of_string [ "name1.for.localhost"; "name2.for.localhost" ] +let names_for_localhost = + List.map Dns.Name.of_string [ "name1.for.localhost"; "name2.for.localhost" ] let local_tcpv4_forwarded_port = 8888 let config = - let configuration = { - Configuration.default with - domain = Some "local"; - host_names = names_for_localhost; - tcpv4_forwards = [ { - protocol = Tcp; - external_port = local_tcpv4_forwarded_port; - internal_ip = Ipaddr.V4.localhost; - internal_port = local_tcpv4_forwarded_port; - } ]; - } in + let configuration = + { + Configuration.default with + domain = Some "local"; + host_names = names_for_localhost; + tcpv4_forwards = + [ + { + protocol = Tcp; + external_port = local_tcpv4_forwarded_port; + internal_ip = Ipaddr.V4.localhost; + internal_port = local_tcpv4_forwarded_port; + }; + ]; + } + in let vnet = Vnet.create () in Slirp_stack.create_static vnet configuration @@ -160,7 +181,7 @@ let slirp_stack_c = Lwt_condition.create () let rec get_slirp_stack () = match !slirp_stack with - | None -> Lwt_condition.wait slirp_stack_c >>= get_slirp_stack + | None -> Lwt_condition.wait slirp_stack_c >>= get_slirp_stack | Some x -> Lwt.return x let set_slirp_stack c = @@ -170,18 +191,16 @@ let set_slirp_stack c = let start_stack config () = Host.Sockets.Stream.Tcp.bind (Ipaddr.V4 Ipaddr.V4.localhost, 0) >>= fun server -> - Host.Sockets.Stream.Tcp.getsockname server - >|= fun (_, port) -> + Host.Sockets.Stream.Tcp.getsockname server >|= fun (_, port) -> Log.info (fun f -> f "Bound vpnkit server to localhost:%d" port); Host.Sockets.Stream.Tcp.listen server (fun flow -> Log.info (fun f -> f "Server connecting TCP/IP stack"); - Slirp_stack.connect config flow >>= fun stack -> + Slirp_stack.connect config flow >>= fun stack -> Log.info (fun f -> f "Server connected TCP/IP stack"); set_slirp_stack stack; Slirp_stack.after_disconnect stack >|= fun () -> - Log.info (fun f -> f "Server disconnected TCP/IP stack") - ); - server, port + Log.info (fun f -> f "Server disconnected TCP/IP stack")); + (server, port) let stop_stack server = Log.info (fun f -> f "Shutting down slirp stack"); @@ -191,42 +210,41 @@ let pcap_dir = "./_pcap/" let with_stack ?uuid ?preferred_ip ~pcap f = config >>= fun config -> - start_stack config () - >>= fun (server, port) -> + start_stack config () >>= fun (server, port) -> Log.info (fun f -> f "Connecting to vpnkit server on localhost:%d" port); Host.Sockets.Stream.Tcp.connect (Ipaddr.V4 Ipaddr.V4.localhost, port) >>= function | Error (`Msg x) -> failwith x - | Ok flow -> - Log.info (fun f -> f "Connected to vpnkit server on localhost:%d" port); - let server_macaddr = Configuration.default_server_macaddr in - let uuid = - match uuid, Uuidm.of_string "d1d9cd61-d0dc-4715-9bb3-4c11da7ad7a5" with - | Some x, Some _ -> x - | None, Some x -> x - | _, None -> failwith "unable to parse test uuid" - in - VMNET.client_of_fd ~uuid ?preferred_ip:preferred_ip ~server_macaddr:server_macaddr flow - >>= function - | Error (`Msg x ) -> - (* Server will close when it gets EOF *) - Host.Sockets.Stream.Tcp.close flow >>= fun () -> - failwith x - | Ok client' -> - Log.info (fun f -> f "Client has established an ethernet link with the vpnkit server"); - (try Unix.mkdir pcap_dir 0o0755 with Unix.Unix_error(Unix.EEXIST, _, _) -> ()); - VMNET.start_capture client' (pcap_dir ^ pcap) - >>= fun () -> - Lwt.finalize (fun () -> - Log.info (fun f -> f "Client connecting TCP/IP stack"); - Client.connect client' >>= fun client -> - Log.info (fun f -> f "Client connected TCP/IP stack"); - get_slirp_stack () >>= fun slirp_stack -> - Log.info (fun f -> f "Calling test case with client and server stack handles"); - f slirp_stack client - ) (fun () -> + | Ok flow -> ( + Log.info (fun f -> f "Connected to vpnkit server on localhost:%d" port); + let server_macaddr = Configuration.default_server_macaddr in + let uuid = + match + (uuid, Uuidm.of_string "d1d9cd61-d0dc-4715-9bb3-4c11da7ad7a5") + with + | Some x, Some _ -> x + | None, Some x -> x + | _, None -> failwith "unable to parse test uuid" + in + VMNET.client_of_fd ~uuid ?preferred_ip ~server_macaddr flow >>= function + | Error (`Msg x) -> (* Server will close when it gets EOF *) - VMNET.disconnect client' - >>= fun () -> - stop_stack server - ) + Host.Sockets.Stream.Tcp.close flow >>= fun () -> failwith x + | Ok client' -> + Log.info (fun f -> + f "Client has established an ethernet link with the vpnkit server"); + (try Unix.mkdir pcap_dir 0o0755 + with Unix.Unix_error (Unix.EEXIST, _, _) -> ()); + VMNET.start_capture client' (pcap_dir ^ pcap) >>= fun () -> + Lwt.finalize + (fun () -> + Log.info (fun f -> f "Client connecting TCP/IP stack"); + Client.connect client' >>= fun client -> + Log.info (fun f -> f "Client connected TCP/IP stack"); + get_slirp_stack () >>= fun slirp_stack -> + Log.info (fun f -> + f "Calling test case with client and server stack handles"); + f slirp_stack client) + (fun () -> + (* Server will close when it gets EOF *) + VMNET.disconnect client' >>= fun () -> stop_stack server)) File "src/hostnet_test/test_forward_protocol.ml", line 1, characters 0-0: diff --git a/_build/default/src/hostnet_test/test_forward_protocol.ml b/_build/default/src/hostnet_test/.formatted/test_forward_protocol.ml index 2347212..b76e9b9 100644 --- a/_build/default/src/hostnet_test/test_forward_protocol.ml +++ b/_build/default/src/hostnet_test/.formatted/test_forward_protocol.ml @@ -5,66 +5,76 @@ let src = Logs.Src.create "test-forwarder" ~doc:"Test the protocol used by the vpnkit-forwarder" in - Logs.Src.set_level src (Some Logs.Info) ; + Logs.Src.set_level src (Some Logs.Info); src module Log = (val Logs.src_log src : Logs.LOG) - open Forwarder.Frame let inputs = - [ ( "open_dedicated_connection" - , { command= Open (Dedicated, `Tcp (Ipaddr.V4 Ipaddr.V4.localhost, 8080)) - ; id= 4l } ) - ; ( "open_multiplexed_connection" - , { command= Open (Multiplexed, `Udp (Ipaddr.V6 Ipaddr.V6.localhost, 8080)) - ; id= 5l } ) - ; ( "open_multiplexed_unix_connection" - , {command= Open (Multiplexed, `Unix "/tmp/foo"); id= 5l} ) - ; ("close", {command= Close; id= 6l}) - ; ("shutdown", {command= Shutdown; id= 7l}) - ; ("data", {command= Data 128l; id= 8l}) - ; ("window", {command= Window 8888888L; id= 9l}) ] - -let output_dir = List.fold_left Filename.concat (Filename.dirname Sys.argv.(0)) [ ".."; ".."; "go"; "test_inputs" ] + [ + ( "open_dedicated_connection", + { + command = Open (Dedicated, `Tcp (Ipaddr.V4 Ipaddr.V4.localhost, 8080)); + id = 4l; + } ); + ( "open_multiplexed_connection", + { + command = Open (Multiplexed, `Udp (Ipaddr.V6 Ipaddr.V6.localhost, 8080)); + id = 5l; + } ); + ( "open_multiplexed_unix_connection", + { command = Open (Multiplexed, `Unix "/tmp/foo"); id = 5l } ); + ("close", { command = Close; id = 6l }); + ("shutdown", { command = Shutdown; id = 7l }); + ("data", { command = Data 128l; id = 8l }); + ("window", { command = Window 8888888L; id = 9l }); + ] + +let output_dir = + List.fold_left Filename.concat + (Filename.dirname Sys.argv.(0)) + [ ".."; ".."; "go"; "test_inputs" ] (* Regenerate test output files. This is only needed when changing the protocol and updating the tests. *) let test_print name frame () = let buf = write frame (Cstruct.create (sizeof frame)) in let oc = open_out (Filename.concat output_dir (name ^ ".bin")) in - output_string oc (Cstruct.to_string buf) ; + output_string oc (Cstruct.to_string buf); close_out oc let test_print_parse frame () = let buf = write frame (Cstruct.create (sizeof frame)) in let frame' = read buf in if frame <> frame' then ( - Printf.fprintf stderr "%s <> %s\n" (to_string frame) (to_string frame') ; - assert false ) + Printf.fprintf stderr "%s <> %s\n" (to_string frame) (to_string frame'); + assert false) let test_parse name frame () = let ic = open_in (Filename.concat output_dir (name ^ ".bin")) in let b = Bytes.create 100 in (* more than big enough *) let n = input ic b 0 100 in - close_in ic ; + close_in ic; let buf = Cstruct.create n in - Cstruct.blit_from_bytes b 0 buf 0 n ; + Cstruct.blit_from_bytes b 0 buf 0 n; let frame' = read buf in assert (frame = frame') let packet_suite = List.map (fun (name, frame) -> - ( name - , [ (* "check that we can print", `Quick, test_print name frame; *) - ( "check that we can parse what we print" - , `Quick - , test_print_parse frame ) - ; ( "check that we can parse files on disk" - , `Quick - , test_parse name frame ) ] ) ) + ( name, + [ + (* "check that we can print", `Quick, test_print name frame; *) + ( "check that we can parse what we print", + `Quick, + test_print_parse frame ); + ( "check that we can parse files on disk", + `Quick, + test_parse name frame ); + ] )) inputs (* Test the multiplexing protocol *) @@ -73,43 +83,45 @@ open Lwt.Infix module Shared_memory = struct module Pipe = struct - type t = - { mutable bufs: Cstruct.t list - ; mutable shutdown: bool - ; c: unit Lwt_condition.t } + type t = { + mutable bufs : Cstruct.t list; + mutable shutdown : bool; + c : unit Lwt_condition.t; + } - let create () = {bufs= []; shutdown= false; c= Lwt_condition.create ()} + let create () = { bufs = []; shutdown = false; c = Lwt_condition.create () } let read t = match t.bufs with | [] -> if t.shutdown then `Eof else `Wait | buf :: bufs -> - t.bufs <- bufs ; + t.bufs <- bufs; `Data buf let write t bufs = - t.bufs <- t.bufs @ bufs ; - Lwt_condition.signal t.c () ; + t.bufs <- t.bufs @ bufs; + Lwt_condition.signal t.c (); Ok () let shutdown_write t = - t.shutdown <- true ; + t.shutdown <- true; Lwt_condition.signal t.c () end - type t = {write: Pipe.t; read: Pipe.t; mutable closed: bool} + type t = { write : Pipe.t; read : Pipe.t; mutable closed : bool } - let create () = {write= Pipe.create (); read= Pipe.create (); closed= false} + let create () = + { write = Pipe.create (); read = Pipe.create (); closed = false } - let otherend t = {write= t.read; read= t.write; closed= false} + let otherend t = { write = t.read; read = t.write; closed = false } let shutdown_write t = - Pipe.shutdown_write t.write ; + Pipe.shutdown_write t.write; Lwt.return_unit let close t = - t.closed <- true ; - Lwt_condition.signal t.read.Pipe.c () ; + t.closed <- true; + Lwt_condition.signal t.read.Pipe.c (); Lwt.return_unit let read t = @@ -124,10 +136,8 @@ module Shared_memory = struct wait () let writev t bufs = Lwt.return (Pipe.write t.write bufs) - let shutdown_read _chanel = Lwt.return_unit - - let write channel buf = writev channel [buf] + let write channel buf = writev channel [ buf ] type flow = t @@ -137,13 +147,11 @@ module Shared_memory = struct | `Closed -> Fmt.pf ppf "attempted to write to a closed flow" type error = [] - type write_error = Mirage_flow.write_error end (* Check it matches the signature *) module Test : Mirage_flow_combinators.SHUTDOWNABLE = Shared_memory - module Mux = Forwarder.Multiplexer.Make (Shared_memory) let test_connect_close () = @@ -152,14 +160,13 @@ let test_connect_close () = let right_flow = Shared_memory.otherend left_flow in let left_mux = Mux.connect left_flow "left" (fun _channel _destination -> - Lwt.fail_with "left side shouldn't get a connection" ) + Lwt.fail_with "left side shouldn't get a connection") in let _right_mux = Mux.connect right_flow "right" (fun channel destination -> Log.debug (fun f -> - f "Got a connection to %s" (Destination.to_string destination) - ) ; - Mux.Channel.close channel ) + f "Got a connection to %s" (Destination.to_string destination)); + Mux.Channel.close channel) in Mux.Channel.connect left_mux (`Tcp (Ipaddr.V4 Ipaddr.V4.localhost, 8080)) >>= fun channel -> Mux.Channel.close channel) @@ -170,27 +177,21 @@ let test_close_close () = let right_flow = Shared_memory.otherend left_flow in let left_mux = Mux.connect left_flow "left" (fun _channel _destination -> - Lwt.fail_with "left side shouldn't get a connection" ) + Lwt.fail_with "left side shouldn't get a connection") in let right_mux = Mux.connect right_flow "right" (fun channel destination -> Log.debug (fun f -> - f "Got a connection to %s" (Destination.to_string destination) - ) ; - Mux.Channel.close channel ) + f "Got a connection to %s" (Destination.to_string destination)); + Mux.Channel.close channel) in Mux.Channel.connect left_mux (`Tcp (Ipaddr.V4 Ipaddr.V4.localhost, 8080)) >>= fun channel -> - Mux.Channel.close channel - >>= fun () -> - Mux.Channel.close channel - >>= fun () -> - if not (Mux.is_running left_mux) - then failwith "left_mux has failed"; - if not (Mux.is_running right_mux) - then failwith "right_mux has failed"; - Lwt.return_unit - ) + Mux.Channel.close channel >>= fun () -> + Mux.Channel.close channel >>= fun () -> + if not (Mux.is_running left_mux) then failwith "left_mux has failed"; + if not (Mux.is_running right_mux) then failwith "right_mux has failed"; + Lwt.return_unit) let test_close_shutdown () = Host.Main.run @@ -198,27 +199,21 @@ let test_close_shutdown () = let right_flow = Shared_memory.otherend left_flow in let left_mux = Mux.connect left_flow "left" (fun _channel _destination -> - Lwt.fail_with "left side shouldn't get a connection" ) + Lwt.fail_with "left side shouldn't get a connection") in let right_mux = Mux.connect right_flow "right" (fun channel destination -> Log.debug (fun f -> - f "Got a connection to %s" (Destination.to_string destination) - ) ; - Mux.Channel.close channel ) + f "Got a connection to %s" (Destination.to_string destination)); + Mux.Channel.close channel) in Mux.Channel.connect left_mux (`Tcp (Ipaddr.V4 Ipaddr.V4.localhost, 8080)) >>= fun channel -> - Mux.Channel.close channel - >>= fun () -> - Mux.Channel.shutdown_write channel - >>= fun () -> - if not (Mux.is_running left_mux) - then failwith "left_mux has failed"; - if not (Mux.is_running right_mux) - then failwith "right_mux has failed"; - Lwt.return_unit - ) + Mux.Channel.close channel >>= fun () -> + Mux.Channel.shutdown_write channel >>= fun () -> + if not (Mux.is_running left_mux) then failwith "left_mux has failed"; + if not (Mux.is_running right_mux) then failwith "right_mux has failed"; + Lwt.return_unit) let send channel n = let sha = Sha256.init () in @@ -230,10 +225,9 @@ let send channel n = let buf = Cstruct.sub send_buf 0 this_time in for i = 0 to Cstruct.length buf - 1 do Cstruct.set_uint8 buf i (Random.int 255) - done ; - Sha256.update_string sha (Cstruct.to_string buf) ; - Mux.Channel.write channel buf - >>= function + done; + Sha256.update_string sha (Cstruct.to_string buf); + Mux.Channel.write channel buf >>= function | Error _ -> Lwt.fail_with (Printf.sprintf "send %d got error" n) | Ok () -> loop (n - this_time) in @@ -242,31 +236,35 @@ let send channel n = let count_recv channel = let sha = Sha256.init () in let rec loop n = - Mux.Channel.read channel - >>= function + Mux.Channel.read channel >>= function | Error _ -> Lwt.fail_with (Printf.sprintf "recv got error after %d" n) | Ok `Eof -> Lwt.return n | Ok (`Data buf) -> - Sha256.update_string sha (Cstruct.to_string buf) ; + Sha256.update_string sha (Cstruct.to_string buf); loop (Cstruct.length buf + n) in loop 0 >>= fun n -> Lwt.return (n, Sha256.(to_hex @@ finalize sha)) -type metadata = {written: int; written_sha: string; read: int; read_sha: string} +type metadata = { + written : int; + written_sha : string; + read : int; + read_sha : string; +} let compare_metadata left right = if left.written <> right.read then failwith (Printf.sprintf "Left wrote %d but right only read %d" left.written - right.read) ; + right.read); if right.read_sha <> left.written_sha then failwith (Printf.sprintf "Left has written sha %s but write has read %s" - left.written_sha right.read_sha) ; + left.written_sha right.read_sha); if left.read_sha <> right.written_sha then failwith (Printf.sprintf "Right has written sha %s but left has read %s" - right.written_sha left.read_sha) ; + right.written_sha left.read_sha); if right.written <> left.read then failwith (Printf.sprintf "Right wrote %d but left only read %d" right.written @@ -274,13 +272,11 @@ let compare_metadata left right = let read_and_write channel to_write = let read = count_recv channel in - send channel to_write - >>= fun written_sha -> - Mux.Channel.shutdown_write channel - >>= fun () -> - read - >>= fun (num_read, sha) -> - Lwt.return {written= to_write; written_sha; read= num_read; read_sha= sha} + send channel to_write >>= fun written_sha -> + Mux.Channel.shutdown_write channel >>= fun () -> + read >>= fun (num_read, sha) -> + Lwt.return + { written = to_write; written_sha; read = num_read; read_sha = sha } let port_of = function | `Tcp (_, port) -> port @@ -294,41 +290,40 @@ let test_read_write to_write_left to_write_right = let right_flow = Shared_memory.otherend left_flow in let left_mux = Mux.connect left_flow "left" (fun _channel _destination -> - Lwt.fail_with "left side shouldn't get a connection" ) + Lwt.fail_with "left side shouldn't get a connection") in let _right_mux = Mux.connect right_flow "right" (fun channel destination -> Log.debug (fun f -> - f "Got a connection to %s" (Destination.to_string destination) - ) ; - read_and_write channel to_write_right - >>= fun metadata -> - Hashtbl.replace right_metadata (port_of destination) metadata ; - Mux.Channel.close channel ) + f "Got a connection to %s" (Destination.to_string destination)); + read_and_write channel to_write_right >>= fun metadata -> + Hashtbl.replace right_metadata (port_of destination) metadata; + Mux.Channel.close channel) in let port = 8080 in Mux.Channel.connect left_mux (`Tcp (Ipaddr.V4 Ipaddr.V4.localhost, port)) >>= fun channel -> - read_and_write channel to_write_left - >>= fun metadata -> - compare_metadata metadata (Hashtbl.find right_metadata port) ; + read_and_write channel to_write_left >>= fun metadata -> + compare_metadata metadata (Hashtbl.find right_metadata port); Mux.Channel.close channel) let interesting_sizes = - [ 0 - ; 1 - ; 4 - ; 4095 - ; 4096 - ; 4097 - ; 4098 - ; 4099 - ; 5000 - ; 5001 - ; 5002 - ; 1048575 - ; 1048576 - ; 1048577 ] + [ + 0; + 1; + 4; + 4095; + 4096; + 4097; + 4098; + 4099; + 5000; + 5001; + 5002; + 1048575; + 1048576; + 1048577; + ] let rec cross xs ys = match xs with @@ -336,13 +331,15 @@ let rec cross xs ys = | x :: xs -> List.map (fun y -> (x, y)) ys @ cross xs ys let test_buffering = - [ ( "buffering" - , List.map + [ + ( "buffering", + List.map (fun (x, y) -> - ( Printf.sprintf "write %d, write %d" x y - , `Quick - , fun () -> test_read_write x y ) ) - (cross interesting_sizes interesting_sizes) ) ] + ( Printf.sprintf "write %d, write %d" x y, + `Quick, + fun () -> test_read_write x y )) + (cross interesting_sizes interesting_sizes) ); + ] let stress_multiplexer () = let right_metadata = Hashtbl.create 7 in @@ -351,17 +348,15 @@ let stress_multiplexer () = let right_flow = Shared_memory.otherend left_flow in let left_mux = Mux.connect left_flow "left" (fun _channel _destination -> - Lwt.fail_with "left side shouldn't get a connection" ) + Lwt.fail_with "left side shouldn't get a connection") in let _right_mux = Mux.connect right_flow "right" (fun channel destination -> Log.debug (fun f -> - f "Got a connection to %s" (Destination.to_string destination) - ) ; - read_and_write channel (Random.int 8192) - >>= fun metadata -> - Hashtbl.replace right_metadata (port_of destination) metadata ; - Mux.Channel.close channel ) + f "Got a connection to %s" (Destination.to_string destination)); + read_and_write channel (Random.int 8192) >>= fun metadata -> + Hashtbl.replace right_metadata (port_of destination) metadata; + Mux.Channel.close channel) in let rec mkints a b = if a = b then [] else a :: mkints (a + 1) b in (* 2000 concurrent connections 10 times in a row *) @@ -375,10 +370,9 @@ let stress_multiplexer () = Mux.Channel.connect left_mux (`Tcp (Ipaddr.V4 Ipaddr.V4.localhost, port)) >>= fun channel -> - read_and_write channel (Random.int 8192) - >>= fun metadata -> - compare_metadata metadata (Hashtbl.find right_metadata port) ; - Mux.Channel.close channel ) + read_and_write channel (Random.int 8192) >>= fun metadata -> + compare_metadata metadata (Hashtbl.find right_metadata port); + Mux.Channel.close channel) ports in Lwt.join threads) @@ -387,18 +381,22 @@ let stress_multiplexer () = loop 0) let mux_suite = - [ ( "multiplexer" - , [ ( "check that the multiplexer can connect and disconnect" - , `Quick - , test_connect_close ) - ; ( "check that double-close doesn't break the connection" - , `Quick - , test_close_close ) - ; ( "check that shutdown after close doesn't break the connection" - , `Quick - , test_close_shutdown ) - ; ( "check that the multiplexer can handle concurrent connections" - , `Quick - , stress_multiplexer ) ] ) ] + [ + ( "multiplexer", + [ + ( "check that the multiplexer can connect and disconnect", + `Quick, + test_connect_close ); + ( "check that double-close doesn't break the connection", + `Quick, + test_close_close ); + ( "check that shutdown after close doesn't break the connection", + `Quick, + test_close_shutdown ); + ( "check that the multiplexer can handle concurrent connections", + `Quick, + stress_multiplexer ); + ] ); + ] let suite = packet_suite @ mux_suite @ test_buffering File "src/bin/main.ml", line 1, characters 0-0: diff --git a/_build/default/src/bin/main.ml b/_build/default/src/bin/.formatted/main.ml index 379f733..d8e5cb8 100644 --- a/_build/default/src/bin/main.ml +++ b/_build/default/src/bin/.formatted/main.ml @@ -16,390 +16,399 @@ module Log = (val Logs.src_log src : Logs.LOG) let _ = Printexc.register_printer (function - | Unix.Unix_error(e, _, _) -> Some (Unix.error_message e) - | _ -> None - ) + | Unix.Unix_error (e, _, _) -> Some (Unix.error_message e) + | _ -> None) let log_exception_continue description f = Lwt.catch (fun () -> f ()) (fun e -> - Log.warn (fun f -> f "%s: failed with %a" description Fmt.exn e); - Lwt.return () - ) + Log.warn (fun f -> f "%s: failed with %a" description Fmt.exn e); + Lwt.return ()) let ethernet_serviceid = "30D48B34-7D27-4B0B-AAAF-BBBED334DD59" let ports_serviceid = "0B95756A-9985-48AD-9470-78E060895BE7" let hvsock_addr_of_uri ~default_serviceid uri = (* hyperv://vmid/serviceid *) - let vmid = match Uri.host uri with - | None -> Hvsock.Af_hyperv.Loopback - | Some x -> - begin match Uuidm.of_string x with - | Some x -> Hvsock.Af_hyperv.Id x - | None -> failwith (Printf.sprintf "In uri %s serviceid %s is not a GUID" (Uri.to_string uri) x) - end + let vmid = + match Uri.host uri with + | None -> Hvsock.Af_hyperv.Loopback + | Some x -> ( + match Uuidm.of_string x with + | Some x -> Hvsock.Af_hyperv.Id x + | None -> + failwith + (Printf.sprintf "In uri %s serviceid %s is not a GUID" + (Uri.to_string uri) x)) in let serviceid = let p = Uri.path uri in - if p = "" - then default_serviceid - (* trim leading / *) - else if String.length p > 0 then String.sub p 1 (String.length p - 1) else p + if p = "" then default_serviceid (* trim leading / *) + else if String.length p > 0 then String.sub p 1 (String.length p - 1) + else p in { Hvsock.Af_hyperv.vmid; serviceid } - module Vnet = Basic_backend.Make - module Connect_unix = Connect.Unix - module Connect_hvsock = Connect.Hvsock - module Bind = Bind.Make(Host.Sockets) - module Dns_policy = Hostnet_dns.Policy(Host.Files) - module Forward_unix = Forward.Make(Mclock)(Connect_unix)(Bind) - module Forward_hvsock = Forward.Make(Mclock)(Connect_hvsock)(Bind) - module HV = Hvsock_lwt.Flow.Make(Host.Time)(Host.Fn)(Hvsock.Af_hyperv) - module HV_generic = Hvsock_lwt.Flow.Make(Host.Time)(Host.Fn)(Hvsock.Socket) - module HostsFile = Hosts.Make(Host.Files) - - let file_descr_of_int (x: int) : Unix.file_descr = - if Sys.os_type <> "Unix" - then - failwith "Cannot convert from an int to Unix.file_descr on platforms \ - other than Unix"; - Obj.magic x - - let unix_listen path = - let startswith prefix x = - let prefix' = String.length prefix in - let x' = String.length x in - prefix' <= x' && (String.sub x 0 prefix' = prefix) in - if startswith "fd:" path then begin - let i = String.sub path 3 (String.length path - 3) in - try - let fd = file_descr_of_int @@ int_of_string i in - Host.Sockets.Stream.Unix.of_bound_fd fd - >>= fun x -> - Lwt.return (Ok x) - with _ -> - Log.err (fun f -> f "Failed to parse command-line argument [%s] expected fd:<int>" path); - Lwt.return (Error (`Msg "Failed to parase command-line argument")) - end else - Lwt.catch - (fun () -> - Host.Sockets.Stream.Unix.bind path - >>= fun s -> - Lwt.return (Ok s) - ) (fun e -> - Log.err (fun f -> f "Failed to call Stream.Unix.bind \"%s\": %s" path (Printexc.to_string e)); - Lwt.return (Error (`Msg "Failed to bind to Unix domain socket")) - ) - - let hvsock_create () = - let rec loop () = - match HV.Socket.create () with - | x -> Lwt.return x - | exception e -> - Log.err (fun f -> f "Caught %s while creating Hyper-V socket" (Printexc.to_string e)); - Host.Time.sleep_ns (Duration.of_sec 1) - >>= fun () -> - loop () in - loop () - - let hvsock_listen sockaddr callback = - Log.info (fun f -> f "Listening on %s" (Hvsock.Af_hyperv.string_of_sockaddr sockaddr)); - let rec aux () = - hvsock_create () - >>= fun socket -> - Lwt.catch (fun () -> +module Vnet = Basic_backend.Make +module Connect_unix = Connect.Unix +module Connect_hvsock = Connect.Hvsock +module Bind = Bind.Make (Host.Sockets) +module Dns_policy = Hostnet_dns.Policy (Host.Files) +module Forward_unix = Forward.Make (Mclock) (Connect_unix) (Bind) +module Forward_hvsock = Forward.Make (Mclock) (Connect_hvsock) (Bind) +module HV = Hvsock_lwt.Flow.Make (Host.Time) (Host.Fn) (Hvsock.Af_hyperv) +module HV_generic = Hvsock_lwt.Flow.Make (Host.Time) (Host.Fn) (Hvsock.Socket) +module HostsFile = Hosts.Make (Host.Files) + +let file_descr_of_int (x : int) : Unix.file_descr = + if Sys.os_type <> "Unix" then + failwith + "Cannot convert from an int to Unix.file_descr on platforms other than \ + Unix"; + Obj.magic x + +let unix_listen path = + let startswith prefix x = + let prefix' = String.length prefix in + let x' = String.length x in + prefix' <= x' && String.sub x 0 prefix' = prefix + in + if startswith "fd:" path then ( + let i = String.sub path 3 (String.length path - 3) in + try + let fd = file_descr_of_int @@ int_of_string i in + Host.Sockets.Stream.Unix.of_bound_fd fd >>= fun x -> Lwt.return (Ok x) + with _ -> + Log.err (fun f -> + f "Failed to parse command-line argument [%s] expected fd:<int>" path); + Lwt.return (Error (`Msg "Failed to parase command-line argument"))) + else + Lwt.catch + (fun () -> + Host.Sockets.Stream.Unix.bind path >>= fun s -> Lwt.return (Ok s)) + (fun e -> + Log.err (fun f -> + f "Failed to call Stream.Unix.bind \"%s\": %s" path + (Printexc.to_string e)); + Lwt.return (Error (`Msg "Failed to bind to Unix domain socket"))) + +let hvsock_create () = + let rec loop () = + match HV.Socket.create () with + | x -> Lwt.return x + | exception e -> + Log.err (fun f -> + f "Caught %s while creating Hyper-V socket" (Printexc.to_string e)); + Host.Time.sleep_ns (Duration.of_sec 1) >>= fun () -> loop () + in + loop () + +let hvsock_listen sockaddr callback = + Log.info (fun f -> + f "Listening on %s" (Hvsock.Af_hyperv.string_of_sockaddr sockaddr)); + let rec aux () = + hvsock_create () >>= fun socket -> + Lwt.catch + (fun () -> HV.Socket.bind socket sockaddr; HV.Socket.listen socket 5; let rec accept_forever () = - HV.Socket.accept socket - >>= fun (t, clientaddr) -> - Log.info (fun f -> f "Accepted connection from %s" (Hvsock.Af_hyperv.string_of_sockaddr clientaddr)); + HV.Socket.accept socket >>= fun (t, clientaddr) -> + Log.info (fun f -> + f "Accepted connection from %s" + (Hvsock.Af_hyperv.string_of_sockaddr clientaddr)); Lwt.async (fun () -> callback t); - accept_forever () in - accept_forever () - ) (fun e -> - Log.warn (fun f -> f "Caught %s while listening on %s" - (Printexc.to_string e) - (Hvsock.Af_hyperv.string_of_sockaddr sockaddr)); - log_exception_continue "HV.Socket.close" (fun () -> HV.Socket.close socket) - >>= fun () -> - Host.Time.sleep_ns (Duration.of_sec 1) - ) - >>= fun () -> - aux () in - aux () - - let hv_generic_create () = - let rec loop () = - match HV_generic.Socket.create () with - | x -> Lwt.return x - | exception e -> - Log.err (fun f -> f "Caught %s while creating hypervisor socket" (Printexc.to_string e)); - Host.Time.sleep_ns (Duration.of_sec 1) - >>= fun () -> - loop () in - loop () - - let hv_generic_listen uri callback = - let sockaddr = Hvsock.Socket.sockaddr_of_uri uri in - Log.info (fun f -> f "Listening on %s" (Hvsock.Socket.string_of_sockaddr sockaddr)); - let rec aux () = - hv_generic_create () - >>= fun socket -> - Lwt.catch (fun () -> + accept_forever () + in + accept_forever ()) + (fun e -> + Log.warn (fun f -> + f "Caught %s while listening on %s" (Printexc.to_string e) + (Hvsock.Af_hyperv.string_of_sockaddr sockaddr)); + log_exception_continue "HV.Socket.close" (fun () -> + HV.Socket.close socket) + >>= fun () -> Host.Time.sleep_ns (Duration.of_sec 1)) + >>= fun () -> aux () + in + aux () + +let hv_generic_create () = + let rec loop () = + match HV_generic.Socket.create () with + | x -> Lwt.return x + | exception e -> + Log.err (fun f -> + f "Caught %s while creating hypervisor socket" + (Printexc.to_string e)); + Host.Time.sleep_ns (Duration.of_sec 1) >>= fun () -> loop () + in + loop () + +let hv_generic_listen uri callback = + let sockaddr = Hvsock.Socket.sockaddr_of_uri uri in + Log.info (fun f -> + f "Listening on %s" (Hvsock.Socket.string_of_sockaddr sockaddr)); + let rec aux () = + hv_generic_create () >>= fun socket -> + Lwt.catch + (fun () -> HV_generic.Socket.bind socket sockaddr; HV_generic.Socket.listen socket 5; let rec accept_forever () = - HV_generic.Socket.accept socket - >>= fun (t, clientaddr) -> - Log.info (fun f -> f "Accepted connection from %s" (Hvsock.Socket.string_of_sockaddr clientaddr)); + HV_generic.Socket.accept socket >>= fun (t, clientaddr) -> + Log.info (fun f -> + f "Accepted connection from %s" + (Hvsock.Socket.string_of_sockaddr clientaddr)); Lwt.async (fun () -> callback t); - accept_forever () in - accept_forever () - ) (fun e -> - Log.warn (fun f -> f "Caught %s while listening on %s" - (Printexc.to_string e) - (Hvsock.Socket.string_of_sockaddr sockaddr)); - log_exception_continue "HV_generic.Socket.close" (fun () -> HV_generic.Socket.close socket) - >>= fun () -> - Host.Time.sleep_ns (Duration.of_sec 1) - ) - >>= fun () -> - aux () in - aux () - - let hvsock_connect_forever url sockaddr callback = - Log.info (fun f -> f "Connecting to %s" (Hvsock.Af_hyperv.string_of_sockaddr sockaddr)); - let rec aux () = - hvsock_create () - >>= fun socket -> - Lwt.catch (fun () -> - HV.Socket.connect ~timeout_ms:300 socket sockaddr >>= fun () -> - Log.info (fun f -> f "AF_HVSOCK connected successfully"); - callback socket - ) (function - | Unix.Unix_error(Unix.ETIMEDOUT, _, _) -> - log_exception_continue "HV.Socket.close" (fun () -> HV.Socket.close socket) - (* no need to add more delay *) - | Unix.Unix_error(_, _, _) -> - log_exception_continue "HV.Socket.close" (fun () -> HV.Socket.close socket) - >>= fun () -> - Host.Time.sleep_ns (Duration.of_sec 1) - | _ -> - log_exception_continue "HV.Socket.close" (fun () -> HV.Socket.close socket) - >>= fun () -> - Host.Time.sleep_ns (Duration.of_sec 1) - ) - >>= fun () -> - aux () - in - Log.debug (fun f -> f "Waiting for connections on socket %s" url); - Lwt.catch - aux + accept_forever () + in + accept_forever ()) (fun e -> - Log.err (fun f -> f "Caught %s while accepting connections on socket %s" (Printexc.to_string e) url); - Lwt.return_unit - ) - - let start_introspection introspection_url root = - if introspection_url = "" - then Log.info (fun f -> - f "There is no introspection server requested. See the --introspection argument") - else Lwt.async (fun () -> + Log.warn (fun f -> + f "Caught %s while listening on %s" (Printexc.to_string e) + (Hvsock.Socket.string_of_sockaddr sockaddr)); + log_exception_continue "HV_generic.Socket.close" (fun () -> + HV_generic.Socket.close socket) + >>= fun () -> Host.Time.sleep_ns (Duration.of_sec 1)) + >>= fun () -> aux () + in + aux () + +let hvsock_connect_forever url sockaddr callback = + Log.info (fun f -> + f "Connecting to %s" (Hvsock.Af_hyperv.string_of_sockaddr sockaddr)); + let rec aux () = + hvsock_create () >>= fun socket -> + Lwt.catch + (fun () -> + HV.Socket.connect ~timeout_ms:300 socket sockaddr >>= fun () -> + Log.info (fun f -> f "AF_HVSOCK connected successfully"); + callback socket) + (function + | Unix.Unix_error (Unix.ETIMEDOUT, _, _) -> + log_exception_continue "HV.Socket.close" (fun () -> + HV.Socket.close socket) + (* no need to add more delay *) + | Unix.Unix_error (_, _, _) -> + log_exception_continue "HV.Socket.close" (fun () -> + HV.Socket.close socket) + >>= fun () -> Host.Time.sleep_ns (Duration.of_sec 1) + | _ -> + log_exception_continue "HV.Socket.close" (fun () -> + HV.Socket.close socket) + >>= fun () -> Host.Time.sleep_ns (Duration.of_sec 1)) + >>= fun () -> aux () + in + Log.debug (fun f -> f "Waiting for connections on socket %s" url); + Lwt.catch aux (fun e -> + Log.err (fun f -> + f "Caught %s while accepting connections on socket %s" + (Printexc.to_string e) url); + Lwt.return_unit) + +let start_introspection introspection_url root = + if introspection_url = "" then + Log.info (fun f -> + f + "There is no introspection server requested. See the --introspection \ + argument") + else + Lwt.async (fun () -> log_exception_continue - ("Starting introspection server on: " ^ introspection_url) - (fun () -> - Log.info (fun f -> - f "Starting introspection server on: %s" introspection_url); - let module Server = Fs9p.Make(Host.Sockets.Stream.Unix) in - unix_listen introspection_url - >>= function - | Error (`Msg m) -> - Log.err (fun f -> f "Failed to start introspection server because: %s" m); - Lwt.return_unit - | Ok s -> - Host.Sockets.Stream.Unix.disable_connection_tracking s; - Host.Sockets.Stream.Unix.listen s (fun flow -> - Server.accept ~root ~msg:introspection_url flow >>= function - | Error (`Msg m) -> - Log.err (fun f -> - f "Failed to establish 9P connection: %s" m); - Lwt.return () - | Ok () -> - Lwt.return_unit - ); - Lwt.return_unit)) - - let start_server name url flow_cb = - if url = "" - then Log.info (fun f -> + ("Starting introspection server on: " ^ introspection_url) (fun () -> + Log.info (fun f -> + f "Starting introspection server on: %s" introspection_url); + let module Server = Fs9p.Make (Host.Sockets.Stream.Unix) in + unix_listen introspection_url >>= function + | Error (`Msg m) -> + Log.err (fun f -> + f "Failed to start introspection server because: %s" m); + Lwt.return_unit + | Ok s -> + Host.Sockets.Stream.Unix.disable_connection_tracking s; + Host.Sockets.Stream.Unix.listen s (fun flow -> + Server.accept ~root ~msg:introspection_url flow >>= function + | Error (`Msg m) -> + Log.err (fun f -> + f "Failed to establish 9P connection: %s" m); + Lwt.return () + | Ok () -> Lwt.return_unit); + Lwt.return_unit)) + +let start_server name url flow_cb = + if url = "" then + Log.info (fun f -> f "No %s server requested. See the --%s argument" name name) - else Lwt.async (fun () -> + else + Lwt.async (fun () -> log_exception_continue ("Starting " ^ name ^ " server on: " ^ url) (fun () -> - Log.info (fun f -> - f "Starting %s server on: %s" name url); - unix_listen url - >>= function - | Error (`Msg m) -> - Log.err (fun f -> f "Failed to start %s server because: %s" name m); - Lwt.return_unit - | Ok s -> - Host.Sockets.Stream.Unix.disable_connection_tracking s; - Host.Sockets.Stream.Unix.listen s flow_cb; - Lwt.return_unit)) - - module type Forwarder = sig - include Protocol_9p.Filesystem.S - val make: unit -> t - end - - (* Create one instance of the Active_list functor per-process. The list of - current port forwards is stored in a map inside the module (not in the - `type t` returned from `make`) *) - let port_forwarder = - if Sys.os_type = "Unix" - then (module Active_list.Make(Forward_unix) : Forwarder) - else (module Active_list.Make(Forward_hvsock) : Forwarder) - - let start_port_forwarding port_control_url max_connections port_forwards = - (* Figure out where to forward incoming connections to forwarded ports. *) - let uri = Uri.of_string port_forwards in - begin match Uri.scheme uri with - | Some "hyperv-connect" -> - let sockaddr = hvsock_addr_of_uri ~default_serviceid:ports_serviceid uri in - Log.info (fun f -> f "Will forward ports over AF_HVSOCK to vpnkit-forwarder on %s" - (Hvsock.Af_hyperv.string_of_sockaddr sockaddr) - ); + Log.info (fun f -> f "Starting %s server on: %s" name url); + unix_listen url >>= function + | Error (`Msg m) -> + Log.err (fun f -> + f "Failed to start %s server because: %s" name m); + Lwt.return_unit + | Ok s -> + Host.Sockets.Stream.Unix.disable_connection_tracking s; + Host.Sockets.Stream.Unix.listen s flow_cb; + Lwt.return_unit)) + +module type Forwarder = sig + include Protocol_9p.Filesystem.S + + val make : unit -> t +end + +(* Create one instance of the Active_list functor per-process. The list of + current port forwards is stored in a map inside the module (not in the + `type t` returned from `make`) *) +let port_forwarder = + if Sys.os_type = "Unix" then + (module Active_list.Make (Forward_unix) : Forwarder) + else (module Active_list.Make (Forward_hvsock) : Forwarder) + +let start_port_forwarding port_control_url max_connections port_forwards = + (* Figure out where to forward incoming connections to forwarded ports. *) + let uri = Uri.of_string port_forwards in + (match Uri.scheme uri with + | Some "hyperv-connect" -> + let sockaddr = + hvsock_addr_of_uri ~default_serviceid:ports_serviceid uri + in + Log.info (fun f -> + f "Will forward ports over AF_HVSOCK to vpnkit-forwarder on %s" + (Hvsock.Af_hyperv.string_of_sockaddr sockaddr)); Connect_hvsock.set_port_forward_addr sockaddr - | Some "unix" -> + | Some "unix" -> Connect_unix.vsock_path := Uri.path uri; - Log.info (fun f -> f "Will forward ports over AF_VSOCK to vpnkit-forwarder on %s" !Connect_unix.vsock_path) - | None -> + Log.info (fun f -> + f "Will forward ports over AF_VSOCK to vpnkit-forwarder on %s" + !Connect_unix.vsock_path) + | None -> (* backwards compatible with plain unix path *) Connect_unix.vsock_path := port_forwards; - Log.info (fun f -> f "Will forward ports over AF_VSOCK to vpnkit-forwarder on %s" !Connect_unix.vsock_path) - | _ -> - Log.err (fun f -> f "I don't know how to forward ports to %s. Port forwarding will be disabled." port_forwards) - end; - - (match max_connections with - | None -> () - | Some _ -> + Log.info (fun f -> + f "Will forward ports over AF_VSOCK to vpnkit-forwarder on %s" + !Connect_unix.vsock_path) + | _ -> + Log.err (fun f -> + f + "I don't know how to forward ports to %s. Port forwarding will be \ + disabled." + port_forwards)); + + (match max_connections with + | None -> () + | Some _ -> Log.warn (fun f -> - f "The argument max-connections is nolonger supported, use the \ + f + "The argument max-connections is nolonger supported, use the \ database key slirp/max-connections instead")); - Connection_limit.set_max max_connections; + Connection_limit.set_max max_connections; - Log.info (fun f -> f "Starting port forwarding control 9P server on %s" port_control_url); - let uri = Uri.of_string port_control_url in - let module Ports = (val port_forwarder: Forwarder) in - let fs = Ports.make () in + Log.info (fun f -> + f "Starting port forwarding control 9P server on %s" port_control_url); + let uri = Uri.of_string port_control_url in + let module Ports = (val port_forwarder : Forwarder) in + let fs = Ports.make () in - match Uri.scheme uri with - | Some ("hyperv-connect" | "hyperv-listen") -> - let module Server = Protocol_9p.Server.Make(Log9P)(HV)(Ports) in - let sockaddr = hvsock_addr_of_uri ~default_serviceid:ports_serviceid uri in + match Uri.scheme uri with + | Some ("hyperv-connect" | "hyperv-listen") -> + let module Server = Protocol_9p.Server.Make (Log9P) (HV) (Ports) in + let sockaddr = + hvsock_addr_of_uri ~default_serviceid:ports_serviceid uri + in let callback fd = let flow = HV.connect fd in Server.connect fs flow () >>= function | Error (`Msg m) -> - Log.err (fun f -> f "Failed to establish 9P connection: %s" m); - Lwt.return () - | Ok server -> Server.after_disconnect server in - if Uri.scheme uri = Some "hyperv-connect" - then hvsock_connect_forever port_control_url sockaddr callback + Log.err (fun f -> f "Failed to establish 9P connection: %s" m); + Lwt.return () + | Ok server -> Server.after_disconnect server + in + if Uri.scheme uri = Some "hyperv-connect" then + hvsock_connect_forever port_control_url sockaddr callback else hvsock_listen sockaddr callback - | Some "fd" | None -> + | Some "fd" | None -> ( let module Server = - Protocol_9p.Server.Make(Log9P)(Host.Sockets.Stream.Unix)(Ports) + Protocol_9p.Server.Make (Log9P) (Host.Sockets.Stream.Unix) (Ports) in - begin unix_listen port_control_url - >>= function + unix_listen port_control_url >>= function | Error (`Msg m) -> - Log.err (fun f -> f "Failed to start port forwarding server because: %s" m); - Lwt.return_unit + Log.err (fun f -> + f "Failed to start port forwarding server because: %s" m); + Lwt.return_unit | Ok port_s -> - Host.Sockets.Stream.Unix.listen port_s (fun conn -> - Server.connect fs conn () >>= function - | Error (`Msg m) -> - Log.err (fun f -> f "Failed to establish 9P connection: %s" m); - Lwt.return_unit - | Ok server -> - Server.after_disconnect server); - Lwt.return_unit - end - | _ -> - let module Server = Protocol_9p.Server.Make(Log9P)(HV_generic)(Ports) in + Host.Sockets.Stream.Unix.listen port_s (fun conn -> + Server.connect fs conn () >>= function + | Error (`Msg m) -> + Log.err (fun f -> f "Failed to establish 9P connection: %s" m); + Lwt.return_unit + | Ok server -> Server.after_disconnect server); + Lwt.return_unit) + | _ -> + let module Server = Protocol_9p.Server.Make (Log9P) (HV_generic) (Ports) + in let callback fd = let flow = HV_generic.connect fd in Server.connect fs flow () >>= function | Error (`Msg m) -> - Log.err (fun f -> f "Failed to establish 9P connection: %s" m); - Lwt.return () - | Ok server -> Server.after_disconnect server in + Log.err (fun f -> f "Failed to establish 9P connection: %s" m); + Lwt.return () + | Ok server -> Server.after_disconnect server + in hv_generic_listen uri callback - let main_t - configuration - socket_url port_control_urls introspection_urls diagnostics_urls pcap_urls - http_intercept_api_path - port_forwards hosts - listen_backlog gc_compact - = - (* This will always succeed on Mac but will raise Illegal_argument - on Windows. Happily on Windows there is no such thing as - SIGPIPE so it's safe to catch the exception and throw it - away. *) - (try Sys.set_signal Sys.sigpipe Sys.Signal_ignore - with Invalid_argument _ -> ()); - Log.info (fun f -> - f "Version is %s" Version.git - ); - - Log.info (fun f -> f "System SOMAXCONN is %d" !Utils.somaxconn); - Utils.somaxconn := - (match listen_backlog with None -> !Utils.somaxconn | Some x -> x); - Log.info (fun f -> f "Will use a listen backlog of %d" !Utils.somaxconn); +let main_t configuration socket_url port_control_urls introspection_urls + diagnostics_urls pcap_urls http_intercept_api_path port_forwards hosts + listen_backlog gc_compact = + (* This will always succeed on Mac but will raise Illegal_argument + on Windows. Happily on Windows there is no such thing as + SIGPIPE so it's safe to catch the exception and throw it + away. *) + (try Sys.set_signal Sys.sigpipe Sys.Signal_ignore + with Invalid_argument _ -> ()); + Log.info (fun f -> f "Version is %s" Version.git); + + Log.info (fun f -> f "System SOMAXCONN is %d" !Utils.somaxconn); + (Utils.somaxconn := + match listen_backlog with None -> !Utils.somaxconn | Some x -> x); + Log.info (fun f -> f "Will use a listen backlog of %d" !Utils.somaxconn); - Printexc.record_backtrace true; + Printexc.record_backtrace true; - Host.start_background_gc gc_compact; + Host.start_background_gc gc_compact; - if hosts <> "" then begin - Lwt.async (fun () -> - HostsFile.watch ~path:hosts () - >>= function - | Ok _ -> Lwt.return_unit + if hosts <> "" then + Lwt.async (fun () -> + HostsFile.watch ~path:hosts () >>= function + | Ok _ -> Lwt.return_unit | Error (`Msg m) -> - Log.err (fun f -> f "Failed to watch hosts file %s: %s" hosts m); - Lwt.return_unit - ) - end; - - List.iter - (fun url -> - Lwt.async (fun () -> - log_exception_continue ("Starting the 9P port control filesystem on " ^ url) (fun () -> - start_port_forwarding url configuration.Configuration.max_connections port_forwards - ) - ) - ) port_control_urls; + Log.err (fun f -> f "Failed to watch hosts file %s: %s" hosts m); + Lwt.return_unit); + List.iter + (fun url -> + Lwt.async (fun () -> + log_exception_continue + ("Starting the 9P port control filesystem on " ^ url) (fun () -> + start_port_forwarding url + configuration.Configuration.max_connections port_forwards))) + port_control_urls; - let vnet_switch = Vnet.create () in + let vnet_switch = Vnet.create () in - let uri = Uri.of_string socket_url in + let uri = Uri.of_string socket_url in - match Uri.scheme uri with - | Some ("hyperv-connect"|"hyperv-listen") -> + match Uri.scheme uri with + | Some ("hyperv-connect" | "hyperv-listen") -> let module Slirp_stack = - Slirp.Make(Vmnet.Make(HV))(Dns_policy) - (Mclock)(Mirage_random_stdlib)(Vnet) + Slirp.Make (Vmnet.Make (HV)) (Dns_policy) (Mclock) + (Mirage_random_stdlib) + (Vnet) in let sockaddr = hvsock_addr_of_uri ~default_serviceid:ethernet_serviceid @@ -407,134 +416,163 @@ let hvsock_addr_of_uri ~default_serviceid uri = in Slirp_stack.create_static vnet_switch configuration >>= fun stack_config -> - begin match http_intercept_api_path with + (match http_intercept_api_path with | None -> () - | Some path -> start_server "http_intercept_api" path Slirp_stack.http_intercept_api_handler - end; + | Some path -> + start_server "http_intercept_api" path + Slirp_stack.http_intercept_api_handler); let callback fd = let conn = HV.connect fd in Slirp_stack.connect stack_config conn >>= fun stack -> Log.info (fun f -> f "TCP/IP stack connected"); - List.iter (fun url -> - start_introspection url (Slirp_stack.filesystem stack) - ) introspection_urls; - List.iter (fun url -> - start_server "diagnostics" url @@ Slirp_stack.diagnostics stack - ) diagnostics_urls; - List.iter (fun url -> - start_server "pcap" url @@ Slirp_stack.pcap stack - ) pcap_urls; + List.iter + (fun url -> start_introspection url (Slirp_stack.filesystem stack)) + introspection_urls; + List.iter + (fun url -> + start_server "diagnostics" url @@ Slirp_stack.diagnostics stack) + diagnostics_urls; + List.iter + (fun url -> start_server "pcap" url @@ Slirp_stack.pcap stack) + pcap_urls; Slirp_stack.after_disconnect stack >|= fun () -> - Log.info (fun f -> f "TCP/IP stack disconnected") in - if Uri.scheme uri = Some "hyperv-connect" - then hvsock_connect_forever socket_url sockaddr callback + Log.info (fun f -> f "TCP/IP stack disconnected") + in + if Uri.scheme uri = Some "hyperv-connect" then + hvsock_connect_forever socket_url sockaddr callback else hvsock_listen sockaddr callback - | Some "fd" | None -> + | Some "fd" | None -> ( let module Slirp_stack = - Slirp.Make(Vmnet.Make(Host.Sockets.Stream.Unix))(Dns_policy) - (Mclock)(Mirage_random_stdlib)(Vnet) + Slirp.Make (Vmnet.Make (Host.Sockets.Stream.Unix)) (Dns_policy) (Mclock) + (Mirage_random_stdlib) + (Vnet) in - begin match http_intercept_api_path with + (match http_intercept_api_path with | None -> () - | Some path -> start_server "http_intercept_api" path Slirp_stack.http_intercept_api_handler - end; - begin unix_listen socket_url - >>= function - | Error (`Msg m) -> - Log.err (fun f -> f "Failed to listen on ethernet socket because: %s" m); + | Some path -> + start_server "http_intercept_api" path + Slirp_stack.http_intercept_api_handler); + unix_listen socket_url >>= function + | Error (`Msg m) -> + Log.err (fun f -> + f "Failed to listen on ethernet socket because: %s" m); Lwt.return_unit - | Ok server -> - Slirp_stack.create_static vnet_switch configuration - >>= fun stack_config -> - Host.Sockets.Stream.Unix.listen server (fun conn -> - Slirp_stack.connect stack_config conn >>= fun stack -> - Log.info (fun f -> f "TCP/IP stack connected"); - List.iter (fun url -> - start_introspection url (Slirp_stack.filesystem stack); - ) introspection_urls; - List.iter (fun url -> - start_server "diagnostics" url @@ Slirp_stack.diagnostics stack - ) diagnostics_urls; - List.iter (fun url -> - start_server "pcap" url @@ Slirp_stack.pcap stack - ) pcap_urls; - Slirp_stack.after_disconnect stack >|= fun () -> - Log.info (fun f -> f "TCP/IP stack disconnected") - ); - let wait_forever, _ = Lwt.task () in - wait_forever - end - | _ -> + | Ok server -> + Slirp_stack.create_static vnet_switch configuration + >>= fun stack_config -> + Host.Sockets.Stream.Unix.listen server (fun conn -> + Slirp_stack.connect stack_config conn >>= fun stack -> + Log.info (fun f -> f "TCP/IP stack connected"); + List.iter + (fun url -> + start_introspection url (Slirp_stack.filesystem stack)) + introspection_urls; + List.iter + (fun url -> + start_server "diagnostics" url + @@ Slirp_stack.diagnostics stack) + diagnostics_urls; + List.iter + (fun url -> start_server "pcap" url @@ Slirp_stack.pcap stack) + pcap_urls; + Slirp_stack.after_disconnect stack >|= fun () -> + Log.info (fun f -> f "TCP/IP stack disconnected")); + let wait_forever, _ = Lwt.task () in + wait_forever) + | _ -> let module Slirp_stack = - Slirp.Make(Vmnet.Make(HV_generic))(Dns_policy) - (Mclock)(Mirage_random_stdlib)(Vnet) + Slirp.Make (Vmnet.Make (HV_generic)) (Dns_policy) (Mclock) + (Mirage_random_stdlib) + (Vnet) in Slirp_stack.create_static vnet_switch configuration >>= fun stack_config -> - begin match http_intercept_api_path with + (match http_intercept_api_path with | None -> () - | Some path -> start_server "http_intercept_api" path Slirp_stack.http_intercept_api_handler - end; + | Some path -> + start_server "http_intercept_api" path + Slirp_stack.http_intercept_api_handler); let callback fd = let conn = HV_generic.connect fd in Slirp_stack.connect stack_config conn >>= fun stack -> Log.info (fun f -> f "TCP/IP stack connected"); - List.iter (fun url -> - start_introspection url (Slirp_stack.filesystem stack) - ) introspection_urls; - List.iter (fun url -> - start_server "diagnostics" url @@ Slirp_stack.diagnostics stack - ) diagnostics_urls; - List.iter (fun url -> - start_server "pcap" url @@ Slirp_stack.pcap stack - ) pcap_urls; + List.iter + (fun url -> start_introspection url (Slirp_stack.filesystem stack)) + introspection_urls; + List.iter + (fun url -> + start_server "diagnostics" url @@ Slirp_stack.diagnostics stack) + diagnostics_urls; + List.iter + (fun url -> start_server "pcap" url @@ Slirp_stack.pcap stack) + pcap_urls; Slirp_stack.after_disconnect stack >|= fun () -> - Log.info (fun f -> f "TCP/IP stack disconnected") in + Log.info (fun f -> f "TCP/IP stack disconnected") + in hv_generic_listen uri callback - let main - socket_url port_control_urls introspection_urls diagnostics_urls pcap_urls pcap_snaplen - max_connections port_forwards dns http http_intercept_api_path hosts host_names gateway_names - vm_names listen_backlog port_max_idle_time debug - server_macaddr domain allowed_bind_addresses gateway_ip host_ip lowest_ip highest_ip - dhcp_json_path mtu udpv4_forwards tcpv4_forwards gateway_forwards_path forwards_path gc_compact - = - let level = - let env_debug = - try ignore @@ Unix.getenv "VPNKIT_DEBUG"; true - with Not_found -> false - in - if debug || env_debug then Some Logs.Debug else Some Logs.Info in - Logging.setup level; - Log.info (fun f -> f "Starting"); - - - let host_names = List.map Dns.Name.of_string @@ Astring.String.cuts ~sep:"," host_names in - let gateway_names = List.map Dns.Name.of_string @@ Astring.String.cuts ~sep:"," gateway_names in - let vm_names = List.map Dns.Name.of_string @@ Astring.String.cuts ~sep:"," vm_names in - - let dns_path, resolver = match dns with - | None -> None, Configuration.default_resolver - | Some file -> Some file, `Upstream in - let server_macaddr = Macaddr.of_string_exn server_macaddr in - let allowed_bind_addresses = Configuration.Parse.ipv4_list [] allowed_bind_addresses in - let gateway_ip = Ipaddr.V4.of_string_exn gateway_ip in - let host_ip = Ipaddr.V4.of_string_exn host_ip in - let lowest_ip = Ipaddr.V4.of_string_exn lowest_ip in - let highest_ip = Ipaddr.V4.of_string_exn highest_ip in - let parse_forwards protocol forwards = - List.map (fun x -> match Stringext.split ~on:':' x with +let main socket_url port_control_urls introspection_urls diagnostics_urls + pcap_urls pcap_snaplen max_connections port_forwards dns http + http_intercept_api_path hosts host_names gateway_names vm_names + listen_backlog port_max_idle_time debug server_macaddr domain + allowed_bind_addresses gateway_ip host_ip lowest_ip highest_ip + dhcp_json_path mtu udpv4_forwards tcpv4_forwards gateway_forwards_path + forwards_path gc_compact = + let level = + let env_debug = + try + ignore @@ Unix.getenv "VPNKIT_DEBUG"; + true + with Not_found -> false + in + if debug || env_debug then Some Logs.Debug else Some Logs.Info + in + Logging.setup level; + Log.info (fun f -> f "Starting"); + + let host_names = + List.map Dns.Name.of_string @@ Astring.String.cuts ~sep:"," host_names + in + let gateway_names = + List.map Dns.Name.of_string @@ Astring.String.cuts ~sep:"," gateway_names + in + let vm_names = + List.map Dns.Name.of_string @@ Astring.String.cuts ~sep:"," vm_names + in + + let dns_path, resolver = + match dns with + | None -> (None, Configuration.default_resolver) + | Some file -> (Some file, `Upstream) + in + let server_macaddr = Macaddr.of_string_exn server_macaddr in + let allowed_bind_addresses = + Configuration.Parse.ipv4_list [] allowed_bind_addresses + in + let gateway_ip = Ipaddr.V4.of_string_exn gateway_ip in + let host_ip = Ipaddr.V4.of_string_exn host_ip in + let lowest_ip = Ipaddr.V4.of_string_exn lowest_ip in + let highest_ip = Ipaddr.V4.of_string_exn highest_ip in + let parse_forwards protocol forwards = + List.map + (fun x -> + match Stringext.split ~on:':' x with | [ external_port; internal_ip; internal_port ] -> - let external_port = int_of_string external_port in - let internal_ip = Ipaddr.V4.of_string_exn internal_ip in - let internal_port = int_of_string internal_port in - Gateway_forwards.( { protocol; external_port; internal_ip; internal_port } ) + let external_port = int_of_string external_port in + let internal_ip = Ipaddr.V4.of_string_exn internal_ip in + let internal_port = int_of_string internal_port in + Gateway_forwards. + { protocol; external_port; internal_ip; internal_port } | _ -> - failwith "Failed to parse forwards: expected <local-port>:<remote IP>:<remote port>" - ) (Stringext.split ~on:',' forwards) in - let udpv4_forwards = parse_forwards Gateway_forwards.Udp udpv4_forwards in - let tcpv4_forwards = parse_forwards Gateway_forwards.Tcp tcpv4_forwards in - let configuration = { + failwith + "Failed to parse forwards: expected <local-port>:<remote \ + IP>:<remote port>") + (Stringext.split ~on:',' forwards) + in + let udpv4_forwards = parse_forwards Gateway_forwards.Udp udpv4_forwards in + let tcpv4_forwards = parse_forwards Gateway_forwards.Tcp tcpv4_forwards in + let configuration = + { Configuration.default with max_connections; port_max_idle_time; @@ -559,197 +597,214 @@ let hvsock_addr_of_uri ~default_serviceid uri = gateway_forwards_path; forwards_path; pcap_snaplen; - } in - match socket_url with - | None -> - Printf.fprintf stderr "Please provide an --ethernet argument\n" - | Some socket_url -> - try - Host.Main.run - (main_t configuration socket_url port_control_urls introspection_urls diagnostics_urls pcap_urls - http_intercept_api_path - port_forwards hosts - listen_backlog gc_compact); - with e -> - Log.err (fun f -> f "Host.Main.run caught exception %s: %s" (Printexc.to_string e) (Printexc.get_backtrace ())) + } + in + match socket_url with + | None -> Printf.fprintf stderr "Please provide an --ethernet argument\n" + | Some socket_url -> ( + try + Host.Main.run + (main_t configuration socket_url port_control_urls introspection_urls + diagnostics_urls pcap_urls http_intercept_api_path port_forwards + hosts listen_backlog gc_compact) + with e -> + Log.err (fun f -> + f "Host.Main.run caught exception %s: %s" (Printexc.to_string e) + (Printexc.get_backtrace ()))) + open Cmdliner let socket = let doc = - Arg.info ~doc: - "The address on the host for the VM ethernet connection. Possible values \ - include: hyperv-connect://vmid/serviceid to connect to a specific \ - Hyper-V 'serviceid' on VM 'vmid'; hyperv-connect://vmid to connect to \ - the default Hyper-V 'serviceid' on VM 'vmid'; \ - hyperv-listen://vmid/serviceid to accept incoming Hyper-V connections \ - on `serviceid` and `vmid`; hyperv-listen://vmid to accept connections \ - to the default Hyper-V `serviceid` on VM `vmid`; \ - /var/tmp/com.docker.slirp.socket to listen on a Unix domain socket for \ - incoming connections." + Arg.info + ~doc: + "The address on the host for the VM ethernet connection. Possible \ + values include: hyperv-connect://vmid/serviceid to connect to a \ + specific Hyper-V 'serviceid' on VM 'vmid'; hyperv-connect://vmid to \ + connect to the default Hyper-V 'serviceid' on VM 'vmid'; \ + hyperv-listen://vmid/serviceid to accept incoming Hyper-V connections \ + on `serviceid` and `vmid`; hyperv-listen://vmid to accept connections \ + to the default Hyper-V `serviceid` on VM `vmid`; \ + /var/tmp/com.docker.slirp.socket to listen on a Unix domain socket \ + for incoming connections." [ "ethernet" ] in Arg.(value & opt (some string) None doc) let port_control_urls = let doc = - Arg.info ~doc: - "The address on the host for the 9P filesystem needed to control host \ - port forwarding. Possible values include: \ - hyperv-connect://vmid/serviceid to connect to a specific Hyper-V \ - 'serviceid' on VM 'vmid'; hyperv-connect://vmid to connect to the \ - default Hyper-V 'serviceid' on VM 'vmid'; \ - hyperv-listen://vmid/serviceid to accept incoming Hyper-V connections \ - on `serviceid` and `vmid`; hyperv-listen://vmid to accept connections \ - to the default Hyper-V `serviceid` on VM `vmid`; \ - /var/tmp/com.docker.port.socket to listen on a Unix domain socket for \ - incoming connections." + Arg.info + ~doc: + "The address on the host for the 9P filesystem needed to control host \ + port forwarding. Possible values include: \ + hyperv-connect://vmid/serviceid to connect to a specific Hyper-V \ + 'serviceid' on VM 'vmid'; hyperv-connect://vmid to connect to the \ + default Hyper-V 'serviceid' on VM 'vmid'; \ + hyperv-listen://vmid/serviceid to accept incoming Hyper-V connections \ + on `serviceid` and `vmid`; hyperv-listen://vmid to accept connections \ + to the default Hyper-V `serviceid` on VM `vmid`; \ + /var/tmp/com.docker.port.socket to listen on a Unix domain socket for \ + incoming connections." [ "port" ] in Arg.(value & opt_all string [] doc) let introspection_urls = let doc = - Arg.info ~doc: - "The address on the host on which to serve a 9P filesystem which exposes \ - internal daemon state. So far this allows active network connections to \ - be listed, to help debug problems with the connection tracking. \ - Possible values include: \ - /var/tmp/com.docker.slirp.introspection.socket to listen on a Unix \ - domain socket for incoming connections or \ - \\\\\\\\.\\\\pipe\\\\introspection to listen on a Windows named pipe" + Arg.info + ~doc: + "The address on the host on which to serve a 9P filesystem which \ + exposes internal daemon state. So far this allows active network \ + connections to be listed, to help debug problems with the connection \ + tracking. Possible values include: \ + /var/tmp/com.docker.slirp.introspection.socket to listen on a Unix \ + domain socket for incoming connections or \ + \\\\\\\\.\\\\pipe\\\\introspection to listen on a Windows named pipe" [ "introspection" ] in Arg.(value & opt_all string [] doc) let diagnostics_urls = let doc = - Arg.info ~doc: - "The address on the host on which to serve a .tar file containing \ - internal daemon diagnostics which can be used to help debug problems \ - Possible values include: \ - /var/tmp/com.docker.slirp.diagnostics.socket to listen on a Unix domain \ - socket for incoming connections or \ - \\\\\\\\.\\\\pipe\\\\diagnostics to listen on a Windows named pipe" + Arg.info + ~doc: + "The address on the host on which to serve a .tar file containing \ + internal daemon diagnostics which can be used to help debug problems \ + Possible values include: /var/tmp/com.docker.slirp.diagnostics.socket \ + to listen on a Unix domain socket for incoming connections or \ + \\\\\\\\.\\\\pipe\\\\diagnostics to listen on a Windows named pipe" [ "diagnostics" ] in Arg.(value & opt_all string [] doc) let pcap_urls = let doc = - Arg.info ~doc: - "The address on the host on which to serve a pcap file containing \ - a live stream of all the network traffic on the internal link. \ - Possible values include: \ - /var/tmp/com.docker.slirp.pcap.socket to listen on a Unix domain \ - socket for incoming connections or \ - \\\\\\\\.\\\\pipe\\\\pcap to listen on a Windows named pipe" + Arg.info + ~doc: + "The address on the host on which to serve a pcap file containing a \ + live stream of all the network traffic on the internal link. Possible \ + values include: /var/tmp/com.docker.slirp.pcap.socket to listen on a \ + Unix domain socket for incoming connections or \ + \\\\\\\\.\\\\pipe\\\\pcap to listen on a Windows named pipe" [ "pcap" ] in Arg.(value & opt_all string [] doc) let pcap_snaplen = let doc = - Arg.info ~doc: - "The maximum amount of network packet data to record, see --pcap <address>." + Arg.info + ~doc: + "The maximum amount of network packet data to record, see --pcap \ + <address>." [ "pcap-snaplen" ] in Arg.(value & opt int Configuration.default_pcap_snaplen doc) let max_connections = let doc = - Arg.info ~doc: - "This argument is deprecated: use the database key slirp/max-connections \ - instead." [ "max-connections" ] + Arg.info + ~doc: + "This argument is deprecated: use the database key \ + slirp/max-connections instead." + [ "max-connections" ] in Arg.(value & opt (some int) None doc) let port_forwards = let doc = - Arg.info ~doc: - "Path of the Unix domain socket used to setup virtio-vsock connections \ - to the VM." [ "vsock-path"; "port-forwards" ] ~docv:"VSOCK" + Arg.info + ~doc: + "Path of the Unix domain socket used to setup virtio-vsock connections \ + to the VM." + [ "vsock-path"; "port-forwards" ] + ~docv:"VSOCK" in Arg.(value & opt string "" doc) let dns = let doc = - Arg.info ~doc: - "File containing DNS configuration. The file consists of a series of lines, \ - each line starting either with a # comment or containing a keyword followed by \ - arguments. For example 'nameserver 8.8.8.8' or 'timeout 5000'.\ - " ["dns"] + Arg.info + ~doc: + "File containing DNS configuration. The file consists of a series of \ + lines, each line starting either with a # comment or containing a \ + keyword followed by arguments. For example 'nameserver 8.8.8.8' or \ + 'timeout 5000'." + [ "dns" ] in Arg.(value & opt (some string) None doc) let http = let doc = - Arg.info ~doc: - "File containing transparent HTTP redirection configuration.\ - If this argument is given, then outgoing connections to port 80 (HTTP) \ - and 443 (HTTPS) are transparently redirected to the proxies mentioned \ - in the configuration file. The configuration file is in .json format as \ - follows: `{\"http\": \"host:3128\",\ - \"https\": \"host:3128\",\ - \"exclude\": \"*.local\"\ - }`\ - " ["http"] + Arg.info + ~doc: + "File containing transparent HTTP redirection configuration.If this \ + argument is given, then outgoing connections to port 80 (HTTP) and \ + 443 (HTTPS) are transparently redirected to the proxies mentioned in \ + the configuration file. The configuration file is in .json format as \ + follows: `{\"http\": \"host:3128\",\"https\": \ + \"host:3128\",\"exclude\": \"*.local\"}`" + [ "http" ] in Arg.(value & opt (some string) None doc) let http_intercept_api_path = let doc = - Arg.info ~doc: - "HTTP proxy configuration update API server path. \ - If this argument is given, then vpnkit will listen on this Unix domain socket \ - or Windows named pipe and receive HTTP proxy configuration updates. HTTP POST /http_proxy.json \ - requests should contain the configuration in .json format as \ - follows: `{\"http\": \"host:3128\",\ - \"https\": \"host:3128\",\ - \"exclude\": \"*.local\"\ - }`\ - " ["http-api-path"] + Arg.info + ~doc: + "HTTP proxy configuration update API server path. If this argument is \ + given, then vpnkit will listen on this Unix domain socket or Windows \ + named pipe and receive HTTP proxy configuration updates. HTTP POST \ + /http_proxy.json requests should contain the configuration in .json \ + format as follows: `{\"http\": \"host:3128\",\"https\": \ + \"host:3128\",\"exclude\": \"*.local\"}`" + [ "http-api-path" ] in Arg.(value & opt (some string) None doc) let hosts = - let doc = - Arg.info ~doc: - "Path to /etc/hosts file" ["hosts"] - in + let doc = Arg.info ~doc:"Path to /etc/hosts file" [ "hosts" ] in Arg.(value & opt string Hosts.default_etc_hosts_path doc) let host_names = let doc = - Arg.info ~doc: - "Comma-separated list of DNS names to map to the Host's virtual IP" - ["host-names"] + Arg.info + ~doc:"Comma-separated list of DNS names to map to the Host's virtual IP" + [ "host-names" ] in Arg.(value & opt string "host.internal" doc) let gateway_names = let doc = - Arg.info ~doc: - "Comma-separated list of DNS names to map to the gateway's virtual IP" - ["gateway-names"] + Arg.info + ~doc: + "Comma-separated list of DNS names to map to the gateway's virtual IP" + [ "gateway-names" ] in Arg.(value & opt string "gateway.internal" doc) let vm_names = let doc = - Arg.info ~doc: - "Comma-separated list of DNS names to map to the VM's virtual IP" + Arg.info + ~doc:"Comma-separated list of DNS names to map to the VM's virtual IP" [ "vm-names" ] in Arg.(value & opt string "vm.internal" doc) let listen_backlog = - let doc = "Specify a maximum listen(2) backlog. If no override is specified \ - then we will use SOMAXCONN." in + let doc = + "Specify a maximum listen(2) backlog. If no override is specified then we \ + will use SOMAXCONN." + in Arg.(value & opt (some int) None & info [ "listen-backlog" ] ~doc) let port_max_idle_time = - let doc = "Idle time to wait before timing out and disconnecting switch ports." in - Arg.(value & opt int Configuration.default_port_max_idle_time & info [ "port-max-idle-time" ] ~doc) + let doc = + "Idle time to wait before timing out and disconnecting switch ports." + in + Arg.( + value + & opt int Configuration.default_port_max_idle_time + & info [ "port-max-idle-time" ] ~doc) let debug = let doc = "Verbose debug logging to stdout" in @@ -757,7 +812,10 @@ let debug = let server_macaddr = let doc = "Ethernet MAC for the host to use" in - Arg.(value & opt string (Macaddr.to_string Configuration.default_server_macaddr) & info [ "server-macaddr" ] ~doc) + Arg.( + value + & opt string (Macaddr.to_string Configuration.default_server_macaddr) + & info [ "server-macaddr" ] ~doc) let domain = let doc = "Domain name to include in DHCP offers" in @@ -765,125 +823,125 @@ let domain = let allowed_bind_addresses = let doc = - Arg.info ~doc: - "List of interfaces where container ports may be exposed. For example \ - to limit port exposure to localhost, use `127.0.0.1`. The default setting \ - allows ports to be exposed on any interface." + Arg.info + ~doc: + "List of interfaces where container ports may be exposed. For example \ + to limit port exposure to localhost, use `127.0.0.1`. The default \ + setting allows ports to be exposed on any interface." [ "allowed-bind-addresses" ] in Arg.(value & opt string "0.0.0.0" doc) let gateway_ip = - let doc = - Arg.info ~doc: - "IP address of the vpnkit gateway" - [ "gateway-ip" ] - in - Arg.(value & opt string (Ipaddr.V4.to_string Configuration.default_gateway_ip) doc) + let doc = Arg.info ~doc:"IP address of the vpnkit gateway" [ "gateway-ip" ] in + Arg.( + value + & opt string (Ipaddr.V4.to_string Configuration.default_gateway_ip) doc) let host_ip = let doc = - Arg.info ~doc: - "IP address which represents the host. Connections to this IP will be forwarded to localhost on the host. Use the value 0.0.0.0 to disable this feature." + Arg.info + ~doc: + "IP address which represents the host. Connections to this IP will be \ + forwarded to localhost on the host. Use the value 0.0.0.0 to disable \ + this feature." [ "host-ip" ] in - Arg.(value & opt string (Ipaddr.V4.to_string Configuration.default_host_ip) doc) + Arg.( + value & opt string (Ipaddr.V4.to_string Configuration.default_host_ip) doc) let lowest_ip = let doc = - Arg.info ~doc: - "Lowest IP address to hand out by DHCP" - [ "lowest-ip" ] + Arg.info ~doc:"Lowest IP address to hand out by DHCP" [ "lowest-ip" ] in - Arg.(value & opt string (Ipaddr.V4.to_string Configuration.default_lowest_ip) doc) + Arg.( + value & opt string (Ipaddr.V4.to_string Configuration.default_lowest_ip) doc) let highest_ip = let doc = - Arg.info ~doc: - "Highest IP address to hand out by DHCP" - [ "highest-ip" ] + Arg.info ~doc:"Highest IP address to hand out by DHCP" [ "highest-ip" ] in - Arg.(value & opt string (Ipaddr.V4.to_string Configuration.default_highest_ip) doc) + Arg.( + value + & opt string (Ipaddr.V4.to_string Configuration.default_highest_ip) doc) let dhcp_json_path = - let doc = - Arg.info ~doc: - "Path of DHCP configuration file" - [ "dhcp-path" ] - in + let doc = Arg.info ~doc:"Path of DHCP configuration file" [ "dhcp-path" ] in Arg.(value & opt (some file) None doc) let mtu = let doc = - Arg.info ~doc: - "Maximum Transfer Unit of the ethernet links" - [ "mtu" ] + Arg.info ~doc:"Maximum Transfer Unit of the ethernet links" [ "mtu" ] in Arg.(value & opt int Configuration.default_mtu doc) let udpv4_forwards = let doc = - Arg.info ~doc: - "Configure UDPv4 forwards from the gateway address to remote systems. - The argument is a comma-separated list of <local port>:<remote IPv4>:<remote port>" - [ "udpv4-forwards" ] + Arg.info + ~doc: + "Configure UDPv4 forwards from the gateway address to remote systems.\n\ + \ The argument is a comma-separated list of <local port>:<remote \ + IPv4>:<remote port>" + [ "udpv4-forwards" ] in Arg.(value & opt string "" doc) let tcpv4_forwards = let doc = - Arg.info ~doc: - "Configure TCPv4 forwards from the gateway address to remote systems. - The argument is a comma-separated list of <local port>:<remote IPv4>:<remote port>" - [ "tcpv4-forwards" ] + Arg.info + ~doc: + "Configure TCPv4 forwards from the gateway address to remote systems.\n\ + \ The argument is a comma-separated list of <local port>:<remote \ + IPv4>:<remote port>" + [ "tcpv4-forwards" ] in Arg.(value & opt string "" doc) let gateway_forwards_path = let doc = - Arg.info ~doc: - "Path of gateway forwards configuration file" + Arg.info ~doc:"Path of gateway forwards configuration file" [ "gateway-forwards" ] in Arg.(value & opt (some string) None doc) let forwards_path = let doc = - Arg.info ~doc: - "Path of forwards configuration file" - [ "forwards" ] + Arg.info ~doc:"Path of forwards configuration file" [ "forwards" ] in Arg.(value & opt (some string) None doc) let gc_compact = let doc = - Arg.info ~doc: - "Seconds between heap compactions" - [ "gc-compact-interval" ] + Arg.info ~doc:"Seconds between heap compactions" [ "gc-compact-interval" ] in Arg.(value & opt (some int) None doc) let command = let doc = "proxy TCP/IP connections from an ethernet link via sockets" in let man = - [`S "DESCRIPTION"; - `P "Terminates TCP/IP and UDP/IP connections from a client and proxy the\ - flows via userspace sockets"] - in - Term.(pure main - $ socket $ port_control_urls $ introspection_urls $ diagnostics_urls $ pcap_urls $ pcap_snaplen - $ max_connections $ port_forwards $ dns $ http $ http_intercept_api_path $ hosts - $ host_names $ gateway_names $ vm_names $ listen_backlog $ port_max_idle_time $ debug - $ server_macaddr $ domain $ allowed_bind_addresses $ gateway_ip $ host_ip - $ lowest_ip $ highest_ip $ dhcp_json_path $ mtu $ udpv4_forwards $ tcpv4_forwards - $ gateway_forwards_path $ forwards_path $ gc_compact), - Term.info (Filename.basename Sys.argv.(0)) ~version:Version.git ~doc ~man + [ + `S "DESCRIPTION"; + `P + "Terminates TCP/IP and UDP/IP connections from a client and proxy \ + theflows via userspace sockets"; + ] + in + ( Term.( + pure main $ socket $ port_control_urls $ introspection_urls + $ diagnostics_urls $ pcap_urls $ pcap_snaplen $ max_connections + $ port_forwards $ dns $ http $ http_intercept_api_path $ hosts + $ host_names $ gateway_names $ vm_names $ listen_backlog + $ port_max_idle_time $ debug $ server_macaddr $ domain + $ allowed_bind_addresses $ gateway_ip $ host_ip $ lowest_ip $ highest_ip + $ dhcp_json_path $ mtu $ udpv4_forwards $ tcpv4_forwards + $ gateway_forwards_path $ forwards_path $ gc_compact), + Term.info (Filename.basename Sys.argv.(0)) ~version:Version.git ~doc ~man ) let () = Printexc.record_backtrace true; - Lwt.async_exception_hook := (fun exn -> - Log.err (fun f -> - f "Lwt.async failure %a: %s" Fmt.exn exn (Printexc.get_backtrace ())) - ); + (Lwt.async_exception_hook := + fun exn -> + Log.err (fun f -> + f "Lwt.async failure %a: %s" Fmt.exn exn (Printexc.get_backtrace ()))); Term.exit @@ Term.eval command File "src/hostnet/vmnet.ml", line 1, characters 0-0: diff --git a/_build/default/src/hostnet/vmnet.ml b/_build/default/src/hostnet/.formatted/vmnet.ml index 39d02bd..38da207 100644 --- a/_build/default/src/hostnet/vmnet.ml +++ b/_build/default/src/hostnet/.formatted/vmnet.ml @@ -10,24 +10,20 @@ module Log = (val Logs.src_log src : Logs.LOG) let ethernet_header_length = 14 (* no VLAN *) module Init = struct - - type t = { - magic: string; - version: int32; - commit: string; - } + type t = { magic : string; version : int32; commit : string } let to_string t = - Fmt.str "{ magic = %s; version = %ld; commit = %s }" - t.magic t.version t.commit + Fmt.str "{ magic = %s; version = %ld; commit = %s }" t.magic t.version + t.commit let sizeof = 5 + 4 + 40 - let default = { - magic = "VMN3T"; - version = 22l; - commit = "0123456789012345678901234567890123456789"; - } + let default = + { + magic = "VMN3T"; + version = 22l; + commit = "0123456789012345678901234567890123456789"; + } let marshal t rest = Cstruct.blit_from_string t.magic 0 rest 0 5; @@ -40,93 +36,88 @@ module Init = struct let version = Cstruct.LE.get_uint32 rest 5 in let commit = Cstruct.(to_string @@ sub rest 9 40) in let rest = Cstruct.shift rest sizeof in - { magic; version; commit }, rest + ({ magic; version; commit }, rest) end module Command = struct - type t = | Ethernet of Uuidm.t (* 36 bytes *) | Preferred_ipv4 of Uuidm.t (* 36 bytes *) * Ipaddr.V4.t | Bind_ipv4 of Ipaddr.V4.t * int * bool let to_string = function - | Ethernet x -> Fmt.str "Ethernet %a" Uuidm.pp x - | Preferred_ipv4 (uuid, ip) -> - Fmt.str "Preferred_ipv4 %a %a" Uuidm.pp uuid Ipaddr.V4.pp ip - | Bind_ipv4 (ip, port, tcp) -> - Fmt.str "Bind_ipv4 %a %d %b" Ipaddr.V4.pp ip port tcp + | Ethernet x -> Fmt.str "Ethernet %a" Uuidm.pp x + | Preferred_ipv4 (uuid, ip) -> + Fmt.str "Preferred_ipv4 %a %a" Uuidm.pp uuid Ipaddr.V4.pp ip + | Bind_ipv4 (ip, port, tcp) -> + Fmt.str "Bind_ipv4 %a %d %b" Ipaddr.V4.pp ip port tcp let sizeof = 1 + 36 + 4 - let marshal t rest = match t with - | Ethernet uuid -> - Cstruct.set_uint8 rest 0 1; - let rest = Cstruct.shift rest 1 in - let uuid_str = Uuidm.to_string uuid in - Cstruct.blit_from_string uuid_str 0 rest 0 (String.length uuid_str); - Cstruct.shift rest (String.length uuid_str) - | Preferred_ipv4 (uuid, ip) -> - Cstruct.set_uint8 rest 0 8; - let rest = Cstruct.shift rest 1 in - let uuid_str = Uuidm.to_string uuid in - Cstruct.blit_from_string uuid_str 0 rest 0 (String.length uuid_str); - let rest = Cstruct.shift rest (String.length uuid_str) in - Cstruct.LE.set_uint32 rest 0 (Ipaddr.V4.to_int32 ip); - Cstruct.shift rest 4 - | Bind_ipv4 (ip, port, stream) -> - Cstruct.set_uint8 rest 0 6; - let rest = Cstruct.shift rest 1 in - Cstruct.LE.set_uint32 rest 0 (Ipaddr.V4.to_int32 ip); - let rest = Cstruct.shift rest 4 in - Cstruct.LE.set_uint16 rest 0 port; - let rest = Cstruct.shift rest 2 in - Cstruct.set_uint8 rest 0 (if stream then 0 else 1); - Cstruct.shift rest 1 + let marshal t rest = + match t with + | Ethernet uuid -> + Cstruct.set_uint8 rest 0 1; + let rest = Cstruct.shift rest 1 in + let uuid_str = Uuidm.to_string uuid in + Cstruct.blit_from_string uuid_str 0 rest 0 (String.length uuid_str); + Cstruct.shift rest (String.length uuid_str) + | Preferred_ipv4 (uuid, ip) -> + Cstruct.set_uint8 rest 0 8; + let rest = Cstruct.shift rest 1 in + let uuid_str = Uuidm.to_string uuid in + Cstruct.blit_from_string uuid_str 0 rest 0 (String.length uuid_str); + let rest = Cstruct.shift rest (String.length uuid_str) in + Cstruct.LE.set_uint32 rest 0 (Ipaddr.V4.to_int32 ip); + Cstruct.shift rest 4 + | Bind_ipv4 (ip, port, stream) -> + Cstruct.set_uint8 rest 0 6; + let rest = Cstruct.shift rest 1 in + Cstruct.LE.set_uint32 rest 0 (Ipaddr.V4.to_int32 ip); + let rest = Cstruct.shift rest 4 in + Cstruct.LE.set_uint16 rest 0 port; + let rest = Cstruct.shift rest 2 in + Cstruct.set_uint8 rest 0 (if stream then 0 else 1); + Cstruct.shift rest 1 let unmarshal rest = let process_uuid uuid_str = - if (String.compare (String.make 36 '\000') uuid_str) = 0 then - begin - let random_uuid = (Uuidm.v `V4) in - Log.info (fun f -> - f "Generated UUID on behalf of client: %a" Uuidm.pp random_uuid); - (* generate random uuid on behalf of client if client sent - array of \0 *) - Some random_uuid - end else - Uuidm.of_string uuid_str + if String.compare (String.make 36 '\000') uuid_str = 0 then ( + let random_uuid = Uuidm.v `V4 in + Log.info (fun f -> + f "Generated UUID on behalf of client: %a" Uuidm.pp random_uuid); + (* generate random uuid on behalf of client if client sent + array of \0 *) + Some random_uuid) + else Uuidm.of_string uuid_str in match Cstruct.get_uint8 rest 0 with - | 1 -> (* ethernet *) - let uuid_str = Cstruct.(to_string (sub rest 1 36)) in - let rest = Cstruct.shift rest 37 in - (match process_uuid uuid_str with - | Some uuid -> Ok (Ethernet uuid, rest) - | None -> Error (`Msg (Printf.sprintf "Invalid UUID: %s" uuid_str))) - | 8 -> (* preferred_ipv4 *) - let uuid_str = Cstruct.(to_string (sub rest 1 36)) in - let rest = Cstruct.shift rest 37 in - let ip = Ipaddr.V4.of_int32 (Cstruct.LE.get_uint32 rest 0) in - let rest = Cstruct.shift rest 4 in - (match process_uuid uuid_str with - | Some uuid -> Ok (Preferred_ipv4 (uuid, ip), rest) - | None -> Error (`Msg (Printf.sprintf "Invalid UUID: %s" uuid_str))) + | 1 -> ( + (* ethernet *) + let uuid_str = Cstruct.(to_string (sub rest 1 36)) in + let rest = Cstruct.shift rest 37 in + match process_uuid uuid_str with + | Some uuid -> Ok (Ethernet uuid, rest) + | None -> Error (`Msg (Printf.sprintf "Invalid UUID: %s" uuid_str))) + | 8 -> ( + (* preferred_ipv4 *) + let uuid_str = Cstruct.(to_string (sub rest 1 36)) in + let rest = Cstruct.shift rest 37 in + let ip = Ipaddr.V4.of_int32 (Cstruct.LE.get_uint32 rest 0) in + let rest = Cstruct.shift rest 4 in + match process_uuid uuid_str with + | Some uuid -> Ok (Preferred_ipv4 (uuid, ip), rest) + | None -> Error (`Msg (Printf.sprintf "Invalid UUID: %s" uuid_str))) | n -> Error (`Msg (Printf.sprintf "Unknown command: %d" n)) - end module Vif = struct - - type t = { - mtu: int; - max_packet_size: int; - client_macaddr: Macaddr.t; - } + type t = { mtu : int; max_packet_size : int; client_macaddr : Macaddr.t } let to_string t = - Fmt.str "{ mtu = %d; max_packet_size = %d; client_macaddr = %s }" - t.mtu t.max_packet_size (Macaddr.to_string t.client_macaddr) + Fmt.str "{ mtu = %d; max_packet_size = %d; client_macaddr = %s }" t.mtu + t.max_packet_size + (Macaddr.to_string t.client_macaddr) let create client_macaddr mtu () = let max_packet_size = mtu + 50 in @@ -147,124 +138,110 @@ module Vif = struct try let client_macaddr = Macaddr.of_octets_exn mac in Ok ({ mtu; max_packet_size; client_macaddr }, Cstruct.shift rest sizeof) - with _ -> - Error (`Msg (Printf.sprintf "Failed to parse MAC: [%s]" mac)) - + with _ -> Error (`Msg (Printf.sprintf "Failed to parse MAC: [%s]" mac)) end module Response = struct type t = - | Vif of Vif.t (* 10 bytes *) - | Disconnect of string (* disconnect reason *) - - let sizeof = 1+1+256 (* leave room for error message and length *) - - let marshal t rest = match t with - | Vif vif -> - Cstruct.set_uint8 rest 0 1; - let rest = Cstruct.shift rest 1 in - Vif.marshal vif rest - | Disconnect reason -> - Cstruct.set_uint8 rest 0 2; - let rest = Cstruct.shift rest 1 in - Cstruct.set_uint8 rest 0 (String.length reason); - let rest = Cstruct.shift rest 1 in - Cstruct.blit_from_string reason 0 rest 0 (String.length reason); - Cstruct.shift rest (String.length reason) + | Vif of Vif.t + (* 10 bytes *) + | Disconnect of string + (* disconnect reason *) + + let sizeof = 1 + 1 + 256 (* leave room for error message and length *) + + let marshal t rest = + match t with + | Vif vif -> + Cstruct.set_uint8 rest 0 1; + let rest = Cstruct.shift rest 1 in + Vif.marshal vif rest + | Disconnect reason -> + Cstruct.set_uint8 rest 0 2; + let rest = Cstruct.shift rest 1 in + Cstruct.set_uint8 rest 0 (String.length reason); + let rest = Cstruct.shift rest 1 in + Cstruct.blit_from_string reason 0 rest 0 (String.length reason); + Cstruct.shift rest (String.length reason) let unmarshal rest = match Cstruct.get_uint8 rest 0 with - | 1 -> (* vif *) - let rest = Cstruct.shift rest 1 in - let vif = Vif.unmarshal rest in - (match vif with - | Ok (vif, rest) -> Ok (Vif vif, rest) - | Error msg -> Error (msg)) - | 2 -> (* disconnect *) - let rest = Cstruct.shift rest 1 in - let str_len = Cstruct.get_uint8 rest 0 in - let rest = Cstruct.shift rest 1 in - let reason_str = Cstruct.(to_string (sub rest 0 str_len)) in - let rest = Cstruct.shift rest str_len in - Ok (Disconnect reason_str, rest) + | 1 -> ( + (* vif *) + let rest = Cstruct.shift rest 1 in + let vif = Vif.unmarshal rest in + match vif with + | Ok (vif, rest) -> Ok (Vif vif, rest) + | Error msg -> Error msg) + | 2 -> + (* disconnect *) + let rest = Cstruct.shift rest 1 in + let str_len = Cstruct.get_uint8 rest 0 in + let rest = Cstruct.shift rest 1 in + let reason_str = Cstruct.(to_string (sub rest 0 str_len)) in + let rest = Cstruct.shift rest str_len in + Ok (Disconnect reason_str, rest) | n -> Error (`Msg (Printf.sprintf "Unknown response: %d" n)) - end - module Packet = struct let sizeof = 2 - - let marshal t rest = - Cstruct.LE.set_uint16 rest 0 t + let marshal t rest = Cstruct.LE.set_uint16 rest 0 t let unmarshal rest = let t = Cstruct.LE.get_uint16 rest 0 in Ok (t, Cstruct.shift rest sizeof) end -module Make(C: Sig.CONN) = struct - - module Channel = Mirage_channel.Make(C) +module Make (C : Sig.CONN) = struct + module Channel = Mirage_channel.Make (C) - type error = [Mirage_net.Net.error | `Channel of Channel.write_error] + type error = [ Mirage_net.Net.error | `Channel of Channel.write_error ] let pp_error ppf = function - | #Mirage_net.Net.error as e -> Mirage_net.Net.pp_error ppf e - | `Channel e -> Channel.pp_write_error ppf e + | #Mirage_net.Net.error as e -> Mirage_net.Net.pp_error ppf e + | `Channel e -> Channel.pp_write_error ppf e let failf fmt = Fmt.kstr (fun e -> Lwt_result.fail (`Msg e)) fmt type t = { - mutable fd: Channel.t option; - stats: Mirage_net.stats; - client_uuid: Uuidm.t; - client_macaddr: Macaddr.t; - server_macaddr: Macaddr.t; - mtu: int; - mutable write_header: Cstruct.t; - write_m: Lwt_mutex.t; - mutable pcap: Unix.file_descr option; - mutable pcap_size_limit: int64 option; - pcap_m: Lwt_mutex.t; - mutable listeners: (Cstruct.t -> unit Lwt.t) list; - mutable listening: bool; - after_disconnect: unit Lwt.t; - after_disconnect_u: unit Lwt.u; + mutable fd : Channel.t option; + stats : Mirage_net.stats; + client_uuid : Uuidm.t; + client_macaddr : Macaddr.t; + server_macaddr : Macaddr.t; + mtu : int; + mutable write_header : Cstruct.t; + write_m : Lwt_mutex.t; + mutable pcap : Unix.file_descr option; + mutable pcap_size_limit : int64 option; + pcap_m : Lwt_mutex.t; + mutable listeners : (Cstruct.t -> unit Lwt.t) list; + mutable listening : bool; + after_disconnect : unit Lwt.t; + after_disconnect_u : unit Lwt.u; (* NB: The Mirage DHCP client calls `listen` and then later the Tcp_direct_direct will do the same. This behaviour seems to be undefined, but common implementations adopt a last-caller-wins semantic. This is the last caller wins callback *) - mutable callback: (Cstruct.t -> unit Lwt.t); - log_prefix: string; + mutable callback : Cstruct.t -> unit Lwt.t; + log_prefix : string; } - let get_client_uuid t = - t.client_uuid - - let get_client_macaddr t = - t.client_macaddr - + let get_client_uuid t = t.client_uuid + let get_client_macaddr t = t.client_macaddr let err_eof = Lwt_result.fail (`Msg "EOF") let err_read e = failf "while reading: %a" Channel.pp_error e let err_flush e = failf "while flushing: %a" Channel.pp_write_error e let with_read x f = x >>= function - | Error e -> err_read e - | Ok `Eof -> err_eof + | Error e -> err_read e + | Ok `Eof -> err_eof | Ok (`Data x) -> f x - let with_flush x f = - x >>= function - | Error e -> err_flush e - | Ok () -> f () - - let with_msg x f = - match x with - | Ok x -> f x - | Error _ as e -> Lwt.return e - + let with_flush x f = x >>= function Error e -> err_flush e | Ok () -> f () + let with_msg x f = match x with Ok x -> f x | Error _ as e -> Lwt.return e let server_log_prefix = "Vmnet.Server" let client_log_prefix = "Vmnet.Client" @@ -274,16 +251,20 @@ module Make(C: Sig.CONN) = struct match mac with | Error (`Msg msg) -> let buf = Cstruct.create Response.sizeof in - let (_: Cstruct.t) = Response.marshal (Disconnect msg) buf in - Log.err (fun f -> f "%s.negotiate: disconnecting client, reason: %s" server_log_prefix msg); + let (_ : Cstruct.t) = Response.marshal (Disconnect msg) buf in + Log.err (fun f -> + f "%s.negotiate: disconnecting client, reason: %s" + server_log_prefix msg); Channel.write_buffer fd buf; with_flush (Channel.flush fd) @@ fun () -> - failf "%s.negotiate: disconnecting client, reason: %s " server_log_prefix msg - | Ok client_macaddr -> + failf "%s.negotiate: disconnecting client, reason: %s " + server_log_prefix msg + | Ok client_macaddr -> let vif = Vif.create client_macaddr mtu () in let buf = Cstruct.create Response.sizeof in - let (_: Cstruct.t) = Response.marshal (Vif vif) buf in - Log.info (fun f -> f "%s.negotiate: sending %s" server_log_prefix (Vif.to_string vif)); + let (_ : Cstruct.t) = Response.marshal (Vif vif) buf in + Log.info (fun f -> + f "%s.negotiate: sending %s" server_log_prefix (Vif.to_string vif)); Channel.write_buffer fd buf; with_flush (Channel.flush fd) @@ fun () -> Lwt_result.return (uuid, client_macaddr) @@ -291,48 +272,59 @@ module Make(C: Sig.CONN) = struct with_read (Channel.read_exactly ~len:Init.sizeof fd) @@ fun bufs -> let buf = Cstruct.concat bufs in let init, _ = Init.unmarshal buf in - Log.info (fun f -> f "%s.negotiate: received %s" server_log_prefix (Init.to_string init)); + Log.info (fun f -> + f "%s.negotiate: received %s" server_log_prefix (Init.to_string init)); match init.version with - | 22l -> begin - let (_: Cstruct.t) = Init.marshal Init.default buf in + | 22l -> ( + let (_ : Cstruct.t) = Init.marshal Init.default buf in Channel.write_buffer fd buf; with_flush (Channel.flush fd) @@ fun () -> with_read (Channel.read_exactly ~len:Command.sizeof fd) @@ fun bufs -> let buf = Cstruct.concat bufs in with_msg (Command.unmarshal buf) @@ fun (command, _) -> Log.info (fun f -> - f "%s.negotiate: received %s" server_log_prefix (Command.to_string command)); + f "%s.negotiate: received %s" server_log_prefix + (Command.to_string command)); match command with - | Command.Bind_ipv4 _ -> - let buf = Cstruct.create Response.sizeof in - let (_: Cstruct.t) = Response.marshal (Disconnect "Unsupported command Bind_ipv4") buf in - Channel.write_buffer fd buf; - with_flush (Channel.flush fd) @@ fun () -> - failf "%s.negotiate: unsupported command Bind_ipv4" server_log_prefix + | Command.Bind_ipv4 _ -> + let buf = Cstruct.create Response.sizeof in + let (_ : Cstruct.t) = + Response.marshal (Disconnect "Unsupported command Bind_ipv4") buf + in + Channel.write_buffer fd buf; + with_flush (Channel.flush fd) @@ fun () -> + failf "%s.negotiate: unsupported command Bind_ipv4" + server_log_prefix | Command.Ethernet uuid -> assign_uuid_ip uuid None - | Command.Preferred_ipv4 (uuid, ip) -> assign_uuid_ip uuid (Some ip) - end - | x -> - let (_: Cstruct.t) = Init.marshal Init.default buf in (* write our version before disconnecting *) - Channel.write_buffer fd buf; - with_flush (Channel.flush fd) @@ fun () -> - Log.err (fun f -> f "%s: Client requested protocol version %s, server only supports version %s" server_log_prefix (Int32.to_string x) (Int32.to_string Init.default.version)); - Lwt_result.fail (`Msg "Client requested unsupported protocol version") - + | Command.Preferred_ipv4 (uuid, ip) -> assign_uuid_ip uuid (Some ip)) + | x -> + let (_ : Cstruct.t) = Init.marshal Init.default buf in + (* write our version before disconnecting *) + Channel.write_buffer fd buf; + with_flush (Channel.flush fd) @@ fun () -> + Log.err (fun f -> + f + "%s: Client requested protocol version %s, server only supports \ + version %s" + server_log_prefix (Int32.to_string x) + (Int32.to_string Init.default.version)); + Lwt_result.fail (`Msg "Client requested unsupported protocol version") let client_negotiate ~uuid ?preferred_ip ~fd () = let buf = Cstruct.create Init.sizeof in - let (_: Cstruct.t) = Init.marshal Init.default buf in + let (_ : Cstruct.t) = Init.marshal Init.default buf in Channel.write_buffer fd buf; with_flush (Channel.flush fd) @@ fun () -> with_read (Channel.read_exactly ~len:Init.sizeof fd) @@ fun bufs -> let buf = Cstruct.concat bufs in let init, _ = Init.unmarshal buf in - Log.info (fun f -> f "%s.negotiate: received %s" client_log_prefix (Init.to_string init)); + Log.info (fun f -> + f "%s.negotiate: received %s" client_log_prefix (Init.to_string init)); match init.version with - | 22l -> + | 22l -> ( let buf = Cstruct.create Command.sizeof in - let (_: Cstruct.t) = match preferred_ip with + let (_ : Cstruct.t) = + match preferred_ip with | None -> Command.marshal (Command.Ethernet uuid) buf | Some ip -> Command.marshal (Command.Preferred_ipv4 (uuid, ip)) buf in @@ -342,24 +334,28 @@ module Make(C: Sig.CONN) = struct let buf = Cstruct.concat bufs in let open Lwt_result.Infix in Lwt.return (Response.unmarshal buf) >>= fun (response, _) -> - (match response with - | Vif vif -> - Log.debug (fun f -> f "%s.negotiate: vif %s" client_log_prefix (Vif.to_string vif)); - Lwt_result.return (vif) + match response with + | Vif vif -> + Log.debug (fun f -> + f "%s.negotiate: vif %s" client_log_prefix (Vif.to_string vif)); + Lwt_result.return vif | Disconnect reason -> - let msg = "Server disconnected with reason: " ^ reason in - Log.err (fun f -> f "%s.negotiate: %s" client_log_prefix msg); - Lwt_result.fail (`Msg msg)) - | x -> - Log.err (fun f -> f "%s: Server requires protocol version %s, we have %s" client_log_prefix (Int32.to_string x) (Int32.to_string Init.default.version)); - Lwt_result.fail (`Msg "Server does not support our version of the protocol") + let msg = "Server disconnected with reason: " ^ reason in + Log.err (fun f -> f "%s.negotiate: %s" client_log_prefix msg); + Lwt_result.fail (`Msg msg)) + | x -> + Log.err (fun f -> + f "%s: Server requires protocol version %s, we have %s" + client_log_prefix (Int32.to_string x) + (Int32.to_string Init.default.version)); + Lwt_result.fail + (`Msg "Server does not support our version of the protocol") (* Use blocking I/O here so we can avoid Using Lwt_unix or Uwt. Ideally we would use a FLOW handle referencing a file/stream. *) let really_write fd str = let rec loop ofs = - if ofs = (Bytes.length str) - then () + if ofs = Bytes.length str then () else let n = Unix.write fd str ofs (Bytes.length str - ofs) in loop (ofs + n) @@ -370,7 +366,8 @@ module Make(C: Sig.CONN) = struct Lwt_mutex.with_lock t.pcap_m (fun () -> (match t.pcap with Some fd -> Unix.close fd | None -> ()); let fd = - Unix.openfile filename [ Unix.O_WRONLY; Unix.O_TRUNC; Unix.O_CREAT ] + Unix.openfile filename + [ Unix.O_WRONLY; Unix.O_TRUNC; Unix.O_CREAT ] 0o0644 in let buf = Cstruct.create Pcap.LE.sizeof_pcap_header in @@ -386,21 +383,20 @@ module Make(C: Sig.CONN) = struct really_write fd (Cstruct.to_string buf |> Bytes.of_string); t.pcap <- Some fd; t.pcap_size_limit <- size_limit; - Lwt.return () - ) + Lwt.return ()) - let stop_capture_already_locked t = match t.pcap with - | None -> () - | Some fd -> - Unix.close fd; - t.pcap <- None; - t.pcap_size_limit <- None + let stop_capture_already_locked t = + match t.pcap with + | None -> () + | Some fd -> + Unix.close fd; + t.pcap <- None; + t.pcap_size_limit <- None let stop_capture t = - Lwt_mutex.with_lock t.pcap_m (fun () -> + Lwt_mutex.with_lock t.pcap_m (fun () -> stop_capture_already_locked t; - Lwt.return_unit - ) + Lwt.return_unit) let make ~client_macaddr ~server_macaddr ~mtu ~client_uuid ~log_prefix fd = let fd = Some fd in @@ -414,9 +410,25 @@ module Make(C: Sig.CONN) = struct let listening = false in let after_disconnect, after_disconnect_u = Lwt.task () in let callback _ = Lwt.return_unit in - { fd; stats; client_macaddr; client_uuid; server_macaddr; mtu; write_header; - write_m; pcap; pcap_size_limit; pcap_m; listeners; listening; - after_disconnect; after_disconnect_u; callback; log_prefix } + { + fd; + stats; + client_macaddr; + client_uuid; + server_macaddr; + mtu; + write_header; + write_m; + pcap; + pcap_size_limit; + pcap_m; + listeners; + listening; + after_disconnect; + after_disconnect_u; + callback; + log_prefix; + } type fd = C.flow @@ -425,36 +437,36 @@ module Make(C: Sig.CONN) = struct let channel = Channel.create flow in server_negotiate ~fd:channel ~connect_client_fn ~mtu >>= fun (client_uuid, client_macaddr) -> - let t = make ~client_macaddr ~server_macaddr ~mtu ~client_uuid - ~log_prefix:server_log_prefix channel in + let t = + make ~client_macaddr ~server_macaddr ~mtu ~client_uuid + ~log_prefix:server_log_prefix channel + in Lwt_result.return t let client_of_fd ~uuid ?preferred_ip ~server_macaddr flow = let open Lwt_result.Infix in let channel = Channel.create flow in - client_negotiate ~uuid ?preferred_ip ~fd:channel () - >>= fun vif -> + client_negotiate ~uuid ?preferred_ip ~fd:channel () >>= fun vif -> let t = - make ~client_macaddr:server_macaddr - ~server_macaddr:vif.Vif.client_macaddr ~mtu:vif.Vif.mtu ~client_uuid:uuid - ~log_prefix:client_log_prefix - channel in + make ~client_macaddr:server_macaddr ~server_macaddr:vif.Vif.client_macaddr + ~mtu:vif.Vif.mtu ~client_uuid:uuid ~log_prefix:client_log_prefix channel + in Lwt_result.return t - let disconnect t = match t.fd with - | None -> Lwt.return () - | Some fd -> - Log.info (fun f -> f "%s.disconnect" t.log_prefix); - t.fd <- None; - Log.debug (fun f -> f "%s.disconnect flushing channel" t.log_prefix); - (Channel.flush fd >|= function - | Ok () -> () - | Error e -> - Log.err (fun l -> - l "%s error while disconnecting the vmtnet connection: %a" - t.log_prefix Channel.pp_write_error e); - ) >|= fun () -> - Lwt.wakeup_later t.after_disconnect_u () + let disconnect t = + match t.fd with + | None -> Lwt.return () + | Some fd -> + Log.info (fun f -> f "%s.disconnect" t.log_prefix); + t.fd <- None; + Log.debug (fun f -> f "%s.disconnect flushing channel" t.log_prefix); + (Channel.flush fd >|= function + | Ok () -> () + | Error e -> + Log.err (fun l -> + l "%s error while disconnecting the vmtnet connection: %a" + t.log_prefix Channel.pp_write_error e)) + >|= fun () -> Lwt.wakeup_later t.after_disconnect_u () let after_disconnect t = t.after_disconnect @@ -462,108 +474,100 @@ module Make(C: Sig.CONN) = struct match t.pcap with | None -> Lwt.return () | Some pcap -> - Lwt_mutex.with_lock t.pcap_m (fun () -> - let len = List.(fold_left (+) 0 (map Cstruct.length bufs)) in - let time = Unix.gettimeofday () in - let secs = Int32.of_float time in - let usecs = Int32.of_float (1e6 *. (time -. (floor time))) in - let buf = Cstruct.create Pcap.sizeof_pcap_packet in - let open Pcap.LE in - set_pcap_packet_ts_sec buf secs; - set_pcap_packet_ts_usec buf usecs; - set_pcap_packet_incl_len buf @@ Int32.of_int len; - set_pcap_packet_orig_len buf @@ Int32.of_int len; - really_write pcap (Cstruct.to_string buf |> Bytes.of_string); - List.iter (fun buf -> really_write pcap (Cstruct.to_string buf |> Bytes.of_string)) bufs; - match t.pcap_size_limit with - | None -> Lwt.return () (* no limit *) - | Some limit -> - let limit = Int64.(sub limit (of_int len)) in - t.pcap_size_limit <- Some limit; - if limit < 0L then stop_capture_already_locked t; - Lwt.return_unit - ) + Lwt_mutex.with_lock t.pcap_m (fun () -> + let len = List.(fold_left ( + ) 0 (map Cstruct.length bufs)) in + let time = Unix.gettimeofday () in + let secs = Int32.of_float time in + let usecs = Int32.of_float (1e6 *. (time -. floor time)) in + let buf = Cstruct.create Pcap.sizeof_pcap_packet in + let open Pcap.LE in + set_pcap_packet_ts_sec buf secs; + set_pcap_packet_ts_usec buf usecs; + set_pcap_packet_incl_len buf @@ Int32.of_int len; + set_pcap_packet_orig_len buf @@ Int32.of_int len; + really_write pcap (Cstruct.to_string buf |> Bytes.of_string); + List.iter + (fun buf -> + really_write pcap (Cstruct.to_string buf |> Bytes.of_string)) + bufs; + match t.pcap_size_limit with + | None -> Lwt.return () (* no limit *) + | Some limit -> + let limit = Int64.(sub limit (of_int len)) in + t.pcap_size_limit <- Some limit; + if limit < 0L then stop_capture_already_locked t; + Lwt.return_unit) let err_eof t = - Log.info (fun f -> f "%s.listen: read EOF so closing connection" t.log_prefix); - disconnect t >>= fun () -> - Lwt.return false + Log.info (fun f -> + f "%s.listen: read EOF so closing connection" t.log_prefix); + disconnect t >>= fun () -> Lwt.return false let err_unexpected t pp e = Log.err (fun f -> f "%s listen: caught unexpected %a: disconnecting" t.log_prefix pp e); - disconnect t >>= fun () -> - Lwt.return false + disconnect t >>= fun () -> Lwt.return false - let with_fd t f = match t.fd with - | None -> Lwt.return false - | Some fd -> f fd + let with_fd t f = match t.fd with None -> Lwt.return false | Some fd -> f fd let with_read t x f = x >>= function - | Error e -> err_unexpected t Channel.pp_error e - | Ok `Eof -> err_eof t + | Error e -> err_unexpected t Channel.pp_error e + | Ok `Eof -> err_eof t | Ok (`Data x) -> f x let with_msg t x f = - match x with - | Error (`Msg e) -> err_unexpected t Fmt.string e - | Ok x -> f x + match x with Error (`Msg e) -> err_unexpected t Fmt.string e | Ok x -> f x let listen_nocancel t new_callback = - Log.info (fun f -> f "%s.listen: rebinding the primary listen callback" t.log_prefix); + Log.info (fun f -> + f "%s.listen: rebinding the primary listen callback" t.log_prefix); t.callback <- new_callback; let last_error_log = ref 0. in let rec loop () = - (with_fd t @@ fun fd -> - with_read t (Channel.read_exactly ~len:Packet.sizeof fd) @@ fun bufs -> - let read_header = Cstruct.concat bufs in - with_msg t (Packet.unmarshal read_header) @@ fun (len, _) -> - with_read t (Channel.read_exactly ~len fd) @@ fun bufs -> - capture t bufs >>= fun () -> - Log.debug (fun f -> - let b = Buffer.create 128 in - List.iter (Cstruct.hexdump_to_buffer b) bufs; - f "received%s" (Buffer.contents b) - ); - let buf = Cstruct.concat bufs in - let callback buf = - Lwt.catch (fun () -> t.callback buf) - (function - | e -> - let now = Unix.gettimeofday () in - if (now -. !last_error_log) > 30. then begin - Log.err (fun f -> - f "%s.listen callback caught %a" t.log_prefix Fmt.exn e); - last_error_log := now; - end; - Lwt.return_unit - ) - in - Lwt.async (fun () -> callback buf); - List.iter (fun callback -> - Lwt.async (fun () -> callback buf) - ) t.listeners; - Lwt.return true - ) >>= function - | true -> loop () + ( with_fd t @@ fun fd -> + with_read t (Channel.read_exactly ~len:Packet.sizeof fd) @@ fun bufs -> + let read_header = Cstruct.concat bufs in + with_msg t (Packet.unmarshal read_header) @@ fun (len, _) -> + with_read t (Channel.read_exactly ~len fd) @@ fun bufs -> + capture t bufs >>= fun () -> + Log.debug (fun f -> + let b = Buffer.create 128 in + List.iter (Cstruct.hexdump_to_buffer b) bufs; + f "received%s" (Buffer.contents b)); + let buf = Cstruct.concat bufs in + let callback buf = + Lwt.catch + (fun () -> t.callback buf) + (function + | e -> + let now = Unix.gettimeofday () in + if now -. !last_error_log > 30. then ( + Log.err (fun f -> + f "%s.listen callback caught %a" t.log_prefix Fmt.exn e); + last_error_log := now); + Lwt.return_unit) + in + Lwt.async (fun () -> callback buf); + List.iter + (fun callback -> Lwt.async (fun () -> callback buf)) + t.listeners; + Lwt.return true ) + >>= function + | true -> loop () | false -> Lwt.return () in - begin - if not t.listening then begin - t.listening <- true; - Log.info (fun f -> f "%s.listen: starting event loop" t.log_prefix); - loop () - end else begin - (* Block forever without running a second loop() *) - Log.info (fun f -> f "%s.listen: blocking until disconnect" t.log_prefix); - t.after_disconnect - >>= fun () -> - Log.info (fun f -> f "%s.listen: disconnected" t.log_prefix); - Lwt.return_unit - end - end + (if not t.listening then ( + t.listening <- true; + Log.info (fun f -> f "%s.listen: starting event loop" t.log_prefix); + loop ()) + else ( + (* Block forever without running a second loop() *) + Log.info (fun f -> f "%s.listen: blocking until disconnect" t.log_prefix); + t.after_disconnect >>= fun () -> + Log.info (fun f -> f "%s.listen: disconnected" t.log_prefix); + Lwt.return_unit)) >>= fun () -> Log.info (fun f -> f "%s.listen returning Ok()" t.log_prefix); Lwt.return (Ok ()) @@ -577,11 +581,11 @@ module Make(C: Sig.CONN) = struct Unfortunately the DHCP client calls `cancel` after 4s which can ripple through and cancel the ethernet `read`. We work around that by ignoring `cancel`. *) Lwt.on_cancel task (fun () -> - Log.warn (fun f -> f "%s.listen: ignoring Lwt.cancel (called from the DHCP client)" t.log_prefix); - ); + Log.warn (fun f -> + f "%s.listen: ignoring Lwt.cancel (called from the DHCP client)" + t.log_prefix)); let _ = - listen_nocancel t new_callback - >>= fun x -> + listen_nocancel t new_callback >>= fun x -> Lwt.wakeup_later u x; Lwt.return_unit in @@ -589,42 +593,37 @@ module Make(C: Sig.CONN) = struct let write t ~size fill = Lwt_mutex.with_lock t.write_m (fun () -> - let allocated = Cstruct.create (size + t.mtu) in - let len = fill allocated in - let buf = Cstruct.sub allocated 0 len in + let allocated = Cstruct.create (size + t.mtu) in + let len = fill allocated in + let buf = Cstruct.sub allocated 0 len in capture t [ buf ] >>= fun () -> - if len > (t.mtu + ethernet_header_length) then begin + if len > t.mtu + ethernet_header_length then ( Log.err (fun f -> - f "%s Dropping over-large ethernet frame, length = %d, mtu = \ - %d" t.log_prefix len t.mtu - ); - Lwt.return (Ok ()) - end else begin - if Cstruct.length t.write_header < Packet.sizeof then begin - t.write_header <- Cstruct.create (1024 * Packet.sizeof) - end; + f "%s Dropping over-large ethernet frame, length = %d, mtu = %d" + t.log_prefix len t.mtu); + Lwt.return (Ok ())) + else ( + if Cstruct.length t.write_header < Packet.sizeof then + t.write_header <- Cstruct.create (1024 * Packet.sizeof); Packet.marshal len t.write_header; match t.fd with - | None -> Lwt.return (Error `Disconnected) - | Some fd -> - Channel.write_buffer fd - (Cstruct.sub t.write_header 0 Packet.sizeof); - t.write_header <- Cstruct.shift t.write_header Packet.sizeof; - Log.debug (fun f -> - let b = Buffer.create 128 in - Cstruct.hexdump_to_buffer b buf; - f "sending%s" (Buffer.contents b) - ); - Channel.write_buffer fd buf; - Channel.flush fd >|= function - | Ok () -> Ok () - | Error e -> Error (`Channel e) - end) + | None -> Lwt.return (Error `Disconnected) + | Some fd -> ( + Channel.write_buffer fd + (Cstruct.sub t.write_header 0 Packet.sizeof); + t.write_header <- Cstruct.shift t.write_header Packet.sizeof; + Log.debug (fun f -> + let b = Buffer.create 128 in + Cstruct.hexdump_to_buffer b buf; + f "sending%s" (Buffer.contents b)); + Channel.write_buffer fd buf; + Channel.flush fd >|= function + | Ok () -> Ok () + | Error e -> Error (`Channel e)))) let add_listener t callback = t.listeners <- callback :: t.listeners let mac t = t.server_macaddr let mtu t = t.mtu let get_stats_counters t = t.stats let reset_stats_counters t = Mirage_net.Stats.reset t.stats - end File "src/hostnet_test/test_nat.ml", line 1, characters 0-0: diff --git a/_build/default/src/hostnet_test/test_nat.ml b/_build/default/src/hostnet_test/.formatted/test_nat.ml index 8961f8f..cd3989f 100644 --- a/_build/default/src/hostnet_test/test_nat.ml +++ b/_build/default/src/hostnet_test/.formatted/test_nat.ml @@ -8,10 +8,9 @@ let src = module Log = (val Logs.src_log src : Logs.LOG) -let run ?(timeout=Duration.of_sec 60) t = +let run ?(timeout = Duration.of_sec 60) t = let timeout = - Host.Time.sleep_ns timeout >>= fun () -> - Lwt.fail_with "timeout" + Host.Time.sleep_ns timeout >>= fun () -> Lwt.fail_with "timeout" in Host.Main.run @@ Lwt.pick [ timeout; t ] @@ -20,23 +19,21 @@ module EchoServer = struct a chat protocol, in particular this allows us to test many replies to one request. *) type t = { - local_port: int; - server: Host.Sockets.Datagram.Udp.server; - mutable seen_addresses: Host.Sockets.Datagram.address list; - mutable buf: Cstruct.t; + local_port : int; + server : Host.Sockets.Datagram.Udp.server; + mutable seen_addresses : Host.Sockets.Datagram.address list; + mutable buf : Cstruct.t; } let resend_all_replies t = - Lwt_list.iter_p (fun address -> - Host.Sockets.Datagram.Udp.sendto t.server address - t.buf - ) t.seen_addresses + Lwt_list.iter_p + (fun address -> Host.Sockets.Datagram.Udp.sendto t.server address t.buf) + t.seen_addresses let create () = Host.Sockets.Datagram.Udp.bind (Ipaddr.(V4 V4.localhost), 0) >>= fun server -> - Host.Sockets.Datagram.Udp.getsockname server - >>= fun (_, local_port) -> + Host.Sockets.Datagram.Udp.getsockname server >>= fun (_, local_port) -> (* Start a background echo thread. This will naturally fail when the file descriptor is closed underneath it from `shutdown` *) let seen_addresses = [] in @@ -45,77 +42,76 @@ module EchoServer = struct let _ = let buf = Cstruct.create 2048 in let rec loop () = - Host.Sockets.Datagram.Udp.recvfrom server buf - >>= fun (len, address) -> + Host.Sockets.Datagram.Udp.recvfrom server buf >>= fun (len, address) -> t.seen_addresses <- address :: t.seen_addresses; t.buf <- Cstruct.sub buf 0 len; - resend_all_replies t - >>= - loop + resend_all_replies t >>= loop in loop () in Lwt.return t let get_seen_addresses t = t.seen_addresses - - let to_string t = - Printf.sprintf "udp:127.0.0.1:%d" t.local_port + let to_string t = Printf.sprintf "udp:127.0.0.1:%d" t.local_port let destroy t = Host.Sockets.Datagram.Udp.shutdown t.server + let with_server f = create () >>= fun server -> Lwt.finalize (fun () -> f server) (fun () -> destroy server) end module UdpServer = struct - module PortSet = - Set.Make(struct type t = int let compare = Stdlib.compare end) + module PortSet = Set.Make (struct + type t = int + + let compare = Stdlib.compare + end) type t = { - port: int; - mutable highest: int; (* highest packet payload received *) - mutable num_received: int; - mutable seen_source_ports: PortSet.t; (* all source addresses seen *) - c: unit Lwt_condition.t; + port : int; + mutable highest : int; (* highest packet payload received *) + mutable num_received : int; + mutable seen_source_ports : PortSet.t; (* all source addresses seen *) + c : unit Lwt_condition.t; } + let make stack port = let highest = 0 in let c = Lwt_condition.create () in let seen_source_ports = PortSet.empty in let num_received = 0 in let t = { port; highest; num_received; seen_source_ports; c } in - Client.UDPV4.listen (Client.udpv4 stack) ~port (fun ~src:_ ~dst:_ ~src_port buffer -> + Client.UDPV4.listen (Client.udpv4 stack) ~port + (fun ~src:_ ~dst:_ ~src_port buffer -> t.highest <- max t.highest (Cstruct.get_uint8 buffer 0); t.seen_source_ports <- PortSet.add src_port t.seen_source_ports; t.num_received <- t.num_received + 1; Log.debug (fun f -> f "Received UDP %d -> %d highest %d" src_port port t.highest); Lwt_condition.signal c (); - Lwt.return_unit - ); + Lwt.return_unit); t + let wait_for_data ~highest t = - if t.highest < highest then begin - Lwt.pick [ Lwt_condition.wait t.c; - Host.Time.sleep_ns (Duration.of_sec 1) ] - >>= fun () -> - Lwt.return (t.highest >= highest) - end else Lwt.return true + if t.highest < highest then + Lwt.pick + [ Lwt_condition.wait t.c; Host.Time.sleep_ns (Duration.of_sec 1) ] + >>= fun () -> Lwt.return (t.highest >= highest) + else Lwt.return true + let wait_for_ports ~num t = - if PortSet.cardinal t.seen_source_ports < num then begin - Lwt.pick [ Lwt_condition.wait t.c; - Host.Time.sleep_ns (Duration.of_sec 1) ] - >|= fun () -> - PortSet.cardinal t.seen_source_ports >= num - end else Lwt.return true + if PortSet.cardinal t.seen_source_ports < num then + Lwt.pick + [ Lwt_condition.wait t.c; Host.Time.sleep_ns (Duration.of_sec 1) ] + >|= fun () -> PortSet.cardinal t.seen_source_ports >= num + else Lwt.return true + let wait_for_traffic ~initial t = - if t.num_received > initial - then Lwt.return true + if t.num_received > initial then Lwt.return true else - Lwt.pick [ Lwt_condition.wait t.c; - Host.Time.sleep_ns (Duration.of_sec 1) ] - >>= fun () -> - Lwt.return false + Lwt.pick + [ Lwt_condition.wait t.c; Host.Time.sleep_ns (Duration.of_sec 1) ] + >>= fun () -> Lwt.return false end let err_udp e = Fmt.kstr failwith "%a" Client.UDPV4.pp_error e @@ -123,176 +119,187 @@ let err_udp e = Fmt.kstr failwith "%a" Client.UDPV4.pp_error e (* Start a local UDP echo server, send traffic to it and listen for a response *) let test_udp () = - let t = EchoServer.with_server (fun { EchoServer.local_port; _ } -> - with_stack ~pcap:"test_udp.pcap" (fun _ stack -> - let buffer = Cstruct.create 1024 in - (* Send '1' *) - Cstruct.set_uint8 buffer 0 1; - let udpv4 = Client.udpv4 stack.t in - let virtual_port = 1024 in - let server = UdpServer.make stack.t virtual_port in - let rec loop remaining = - if remaining = 0 then - failwith "Timed-out before UDP response arrived"; - Log.debug (fun f -> - f "Sending %d -> %d value %d" virtual_port local_port - (Cstruct.get_uint8 buffer 0)); - Client.UDPV4.write - ~src_port:virtual_port - ~dst:Ipaddr.V4.localhost - ~dst_port:local_port udpv4 buffer - >>= function - | Error e -> err_udp e - | Ok () -> - UdpServer.wait_for_data ~highest:1 server >>= function - | true -> Lwt.return_unit - | false -> loop (remaining - 1) - in - loop 5 - )) + let t = + EchoServer.with_server (fun { EchoServer.local_port; _ } -> + with_stack ~pcap:"test_udp.pcap" (fun _ stack -> + let buffer = Cstruct.create 1024 in + (* Send '1' *) + Cstruct.set_uint8 buffer 0 1; + let udpv4 = Client.udpv4 stack.t in + let virtual_port = 1024 in + let server = UdpServer.make stack.t virtual_port in + let rec loop remaining = + if remaining = 0 then + failwith "Timed-out before UDP response arrived"; + Log.debug (fun f -> + f "Sending %d -> %d value %d" virtual_port local_port + (Cstruct.get_uint8 buffer 0)); + Client.UDPV4.write ~src_port:virtual_port ~dst:Ipaddr.V4.localhost + ~dst_port:local_port udpv4 buffer + >>= function + | Error e -> err_udp e + | Ok () -> ( + UdpServer.wait_for_data ~highest:1 server >>= function + | true -> Lwt.return_unit + | false -> loop (remaining - 1)) + in + loop 5)) in run t (* Set up a UDP flow and verify that replies update the last use *) let test_udp_reply_last_use () = - let t = EchoServer.with_server (fun ({ EchoServer.local_port; _ } as echoserver) -> - with_stack ~pcap:"test_udp_reply_last_use.pcap" (fun slirp_server stack -> - let buffer = Cstruct.create 1024 in - (* Send '1' *) - Cstruct.set_uint8 buffer 0 1; - let udpv4 = Client.udpv4 stack.t in - let virtual_port = 1024 in - let server = UdpServer.make stack.t virtual_port in - let rec loop remaining = - if remaining = 0 then - failwith "Timed-out before UDP response arrived"; - Log.debug (fun f -> - f "Sending %d -> %d value %d" virtual_port local_port - (Cstruct.get_uint8 buffer 0)); - Client.UDPV4.write - ~src_port:virtual_port - ~dst:Ipaddr.V4.localhost - ~dst_port:local_port udpv4 buffer - >>= function - | Error e -> err_udp e - | Ok () -> - UdpServer.wait_for_data ~highest:1 server >>= function - | true -> Lwt.return_unit - | false -> loop (remaining - 1) - in - loop 5 - >>= fun () -> - let get_last_use () = - let table = Slirp_stack.Debug.Nat.get_table slirp_server in - let rec search = function - | [] -> failwith "Failed to locate NAT rule in table" - | flow :: rest -> - if snd flow.Slirp_stack.Debug.Nat.inside = virtual_port - then flow.Slirp_stack.Debug.Nat.last_use_time_ns - else (search rest) in - search table in - let last_use = get_last_use () in - (* Trigger replies and verify the last_use is updated *) - let rec loop remaining = match remaining with - | 0 -> failwith "UDP replies didn't bump the last_use" - | _ -> - EchoServer.resend_all_replies echoserver - >>= fun () -> - if get_last_use () <> last_use - then Lwt.return_unit - else - Host.Time.sleep_ns (Duration.of_sec 5) - >>= fun () -> - loop (remaining - 1) in - loop 5 - )) + let t = + EchoServer.with_server (fun ({ EchoServer.local_port; _ } as echoserver) -> + with_stack ~pcap:"test_udp_reply_last_use.pcap" + (fun slirp_server stack -> + let buffer = Cstruct.create 1024 in + (* Send '1' *) + Cstruct.set_uint8 buffer 0 1; + let udpv4 = Client.udpv4 stack.t in + let virtual_port = 1024 in + let server = UdpServer.make stack.t virtual_port in + let rec loop remaining = + if remaining = 0 then + failwith "Timed-out before UDP response arrived"; + Log.debug (fun f -> + f "Sending %d -> %d value %d" virtual_port local_port + (Cstruct.get_uint8 buffer 0)); + Client.UDPV4.write ~src_port:virtual_port ~dst:Ipaddr.V4.localhost + ~dst_port:local_port udpv4 buffer + >>= function + | Error e -> err_udp e + | Ok () -> ( + UdpServer.wait_for_data ~highest:1 server >>= function + | true -> Lwt.return_unit + | false -> loop (remaining - 1)) + in + loop 5 >>= fun () -> + let get_last_use () = + let table = Slirp_stack.Debug.Nat.get_table slirp_server in + let rec search = function + | [] -> failwith "Failed to locate NAT rule in table" + | flow :: rest -> + if snd flow.Slirp_stack.Debug.Nat.inside = virtual_port then + flow.Slirp_stack.Debug.Nat.last_use_time_ns + else search rest + in + search table + in + let last_use = get_last_use () in + (* Trigger replies and verify the last_use is updated *) + let rec loop remaining = + match remaining with + | 0 -> failwith "UDP replies didn't bump the last_use" + | _ -> + EchoServer.resend_all_replies echoserver >>= fun () -> + if get_last_use () <> last_use then Lwt.return_unit + else + Host.Time.sleep_ns (Duration.of_sec 5) >>= fun () -> + loop (remaining - 1) + in + loop 5)) in run t (* Check that NAT table overflow doesn't kill new flows *) let test_udp_expiry () = - let t = EchoServer.with_server (fun { EchoServer.local_port; _ } -> - with_stack ~pcap:"test_udp_expiry.pcap" (fun slirp_server stack -> - let active = Slirp_stack.Debug.Nat.get_table slirp_server |> List.length in - let limit = Slirp_stack.Debug.Nat.get_max_active_flows slirp_server in - let buffer = Cstruct.create 1024 in - (* Send '1' *) - Cstruct.set_uint8 buffer 0 1; - let udpv4 = Client.udpv4 stack.t in - let virtual_port = 1024 in - let server = UdpServer.make stack.t virtual_port in - (* Send spam to almost fill up the table. Leave one entry. *) - let initial_spam_entries = limit - active - 1 in - let rec spam from_port remaining = match remaining with - | 0 -> Lwt.return_unit - | n -> - Client.UDPV4.write - ~src_port:(from_port + n) - ~dst:Ipaddr.V4.localhost - ~dst_port:(local_port + 1) (* not the echo server *) - udpv4 buffer - >>= function - | Error e -> err_udp e - | Ok () -> - spam from_port (remaining - 1) in - spam virtual_port initial_spam_entries - >>= fun () -> - (* Send some real data -- this should take up the last slot *) - let rec loop remaining = - if remaining = 0 then - failwith "Timed-out before UDP response arrived"; - Log.debug (fun f -> - f "Sending %d -> %d value %d" virtual_port local_port - (Cstruct.get_uint8 buffer 0)); - Client.UDPV4.write - ~src_port:virtual_port - ~dst:Ipaddr.V4.localhost - ~dst_port:local_port udpv4 buffer - >>= function - | Error e -> err_udp e - | Ok () -> - UdpServer.wait_for_data ~highest:1 server >>= function - | true -> Lwt.return_unit - | false -> loop (remaining - 1) - in - loop 5 - >>= fun () -> - (* Check the table is full *) - let rec loop remaining = - let active = Slirp_stack.Debug.Nat.get_table slirp_server |> List.length in - match remaining with - | 0 -> failwith (Printf.sprintf "Failed to fill NAT table, active = %d, limit = %d" active limit) - | _ -> - if active <> limit - then Host.Time.sleep_ns (Duration.of_sec 1) >>= fun () -> loop (remaining - 1) - else Lwt.return_unit in - loop 5 - >>= fun () -> - (* Send a little bit more spam to trigger an expiry *) - spam (virtual_port + initial_spam_entries) 1 - >>= fun () -> - (* Verify there was an expiry *) - let rec loop remaining = - let active = Slirp_stack.Debug.Nat.get_table slirp_server |> List.length in - match remaining with - | 0 -> failwith (Printf.sprintf "Failed to expire NAT table, active = %d, limit = %d" active limit) - | _ -> - if active >= limit - then Host.Time.sleep_ns (Duration.of_sec 1) >>= fun () -> loop (remaining - 1) - else Lwt.return_unit in - loop 5 - >>= fun () -> - (* Verify our rule still exists *) - let table = Slirp_stack.Debug.Nat.get_table slirp_server in - let rec search = function - | [] -> failwith "Failed to locate NAT rule in table" - | flow :: rest -> - if snd flow.Slirp_stack.Debug.Nat.inside = virtual_port - then () - else (search rest) in - search table; - Lwt.return_unit - )) + let t = + EchoServer.with_server (fun { EchoServer.local_port; _ } -> + with_stack ~pcap:"test_udp_expiry.pcap" (fun slirp_server stack -> + let active = + Slirp_stack.Debug.Nat.get_table slirp_server |> List.length + in + let limit = + Slirp_stack.Debug.Nat.get_max_active_flows slirp_server + in + let buffer = Cstruct.create 1024 in + (* Send '1' *) + Cstruct.set_uint8 buffer 0 1; + let udpv4 = Client.udpv4 stack.t in + let virtual_port = 1024 in + let server = UdpServer.make stack.t virtual_port in + (* Send spam to almost fill up the table. Leave one entry. *) + let initial_spam_entries = limit - active - 1 in + let rec spam from_port remaining = + match remaining with + | 0 -> Lwt.return_unit + | n -> ( + Client.UDPV4.write ~src_port:(from_port + n) + ~dst:Ipaddr.V4.localhost + ~dst_port:(local_port + 1) (* not the echo server *) + udpv4 buffer + >>= function + | Error e -> err_udp e + | Ok () -> spam from_port (remaining - 1)) + in + spam virtual_port initial_spam_entries >>= fun () -> + (* Send some real data -- this should take up the last slot *) + let rec loop remaining = + if remaining = 0 then + failwith "Timed-out before UDP response arrived"; + Log.debug (fun f -> + f "Sending %d -> %d value %d" virtual_port local_port + (Cstruct.get_uint8 buffer 0)); + Client.UDPV4.write ~src_port:virtual_port ~dst:Ipaddr.V4.localhost + ~dst_port:local_port udpv4 buffer + >>= function + | Error e -> err_udp e + | Ok () -> ( + UdpServer.wait_for_data ~highest:1 server >>= function + | true -> Lwt.return_unit + | false -> loop (remaining - 1)) + in + loop 5 >>= fun () -> + (* Check the table is full *) + let rec loop remaining = + let active = + Slirp_stack.Debug.Nat.get_table slirp_server |> List.length + in + match remaining with + | 0 -> + failwith + (Printf.sprintf + "Failed to fill NAT table, active = %d, limit = %d" + active limit) + | _ -> + if active <> limit then + Host.Time.sleep_ns (Duration.of_sec 1) >>= fun () -> + loop (remaining - 1) + else Lwt.return_unit + in + loop 5 >>= fun () -> + (* Send a little bit more spam to trigger an expiry *) + spam (virtual_port + initial_spam_entries) 1 >>= fun () -> + (* Verify there was an expiry *) + let rec loop remaining = + let active = + Slirp_stack.Debug.Nat.get_table slirp_server |> List.length + in + match remaining with + | 0 -> + failwith + (Printf.sprintf + "Failed to expire NAT table, active = %d, limit = %d" + active limit) + | _ -> + if active >= limit then + Host.Time.sleep_ns (Duration.of_sec 1) >>= fun () -> + loop (remaining - 1) + else Lwt.return_unit + in + loop 5 >>= fun () -> + (* Verify our rule still exists *) + let table = Slirp_stack.Debug.Nat.get_table slirp_server in + let rec search = function + | [] -> failwith "Failed to locate NAT rule in table" + | flow :: rest -> + if snd flow.Slirp_stack.Debug.Nat.inside = virtual_port then + () + else search rest + in + search table; + Lwt.return_unit)) in run t @@ -300,63 +307,59 @@ let test_udp_expiry () = source port, wait for the response, send traffic to it from another source port, expect responses to *both* source ports. *) let test_udp_2 () = - let t = EchoServer.with_server (fun { EchoServer.local_port; _ } -> - with_stack ~pcap:"test_udp_2.pcap" (fun _ stack -> - let buffer = Cstruct.create 1024 in - (* Send '1' *) - Cstruct.set_uint8 buffer 0 1; - let udpv4 = Client.udpv4 stack.t in + let t = + EchoServer.with_server (fun { EchoServer.local_port; _ } -> + with_stack ~pcap:"test_udp_2.pcap" (fun _ stack -> + let buffer = Cstruct.create 1024 in + (* Send '1' *) + Cstruct.set_uint8 buffer 0 1; + let udpv4 = Client.udpv4 stack.t in - (* Listen on one virtual source port and count received packets *) - let virtual_port1 = 1024 in - let server1 = UdpServer.make stack.t virtual_port1 in + (* Listen on one virtual source port and count received packets *) + let virtual_port1 = 1024 in + let server1 = UdpServer.make stack.t virtual_port1 in - let rec loop remaining = - if remaining = 0 then - failwith "Timed-out before UDP response arrived"; - Log.debug (fun f -> - f "Sending %d -> %d value %d" virtual_port1 local_port - (Cstruct.get_uint8 buffer 0)); - Client.UDPV4.write - ~src_port:virtual_port1 - ~dst:Ipaddr.V4.localhost - ~dst_port:local_port udpv4 buffer - >>= function - | Error e -> err_udp e - | Ok () -> - UdpServer.wait_for_data ~highest:1 server1 >>= function - | true -> Lwt.return_unit - | false -> loop (remaining - 1) - in - loop 5 >>= fun () -> - (* Listen on a second virtual source port and count - received packets *) - (* Send '2' *) - Cstruct.set_uint8 buffer 0 2; - let virtual_port2 = 1025 in - let server2 = UdpServer.make stack.t virtual_port2 in - let rec loop remaining = - if remaining = 0 then - failwith "Timed-out before UDP response arrived"; - Log.debug (fun f -> - f "Sending %d -> %d value %d" virtual_port2 local_port - (Cstruct.get_uint8 buffer 0)); - Client.UDPV4.write - ~src_port:virtual_port2 - ~dst:Ipaddr.V4.localhost - ~dst_port:local_port udpv4 buffer - >>= function - | Error e -> err_udp e - | Ok () -> - UdpServer.wait_for_data ~highest:2 server2 >>= fun ok2 -> - (* The server should "multicast" the packet to the - original "connection" *) - UdpServer.wait_for_data ~highest:2 server1 >>= fun ok1 -> - if ok1 && ok2 then Lwt.return_unit else loop (remaining - 1) - in - loop 5 - ) - ) in + let rec loop remaining = + if remaining = 0 then + failwith "Timed-out before UDP response arrived"; + Log.debug (fun f -> + f "Sending %d -> %d value %d" virtual_port1 local_port + (Cstruct.get_uint8 buffer 0)); + Client.UDPV4.write ~src_port:virtual_port1 + ~dst:Ipaddr.V4.localhost ~dst_port:local_port udpv4 buffer + >>= function + | Error e -> err_udp e + | Ok () -> ( + UdpServer.wait_for_data ~highest:1 server1 >>= function + | true -> Lwt.return_unit + | false -> loop (remaining - 1)) + in + loop 5 >>= fun () -> + (* Listen on a second virtual source port and count + received packets *) + (* Send '2' *) + Cstruct.set_uint8 buffer 0 2; + let virtual_port2 = 1025 in + let server2 = UdpServer.make stack.t virtual_port2 in + let rec loop remaining = + if remaining = 0 then + failwith "Timed-out before UDP response arrived"; + Log.debug (fun f -> + f "Sending %d -> %d value %d" virtual_port2 local_port + (Cstruct.get_uint8 buffer 0)); + Client.UDPV4.write ~src_port:virtual_port2 + ~dst:Ipaddr.V4.localhost ~dst_port:local_port udpv4 buffer + >>= function + | Error e -> err_udp e + | Ok () -> + UdpServer.wait_for_data ~highest:2 server2 >>= fun ok2 -> + (* The server should "multicast" the packet to the + original "connection" *) + UdpServer.wait_for_data ~highest:2 server1 >>= fun ok1 -> + if ok1 && ok2 then Lwt.return_unit else loop (remaining - 1) + in + loop 5)) + in run t (* Start a local UDP echo server, send some traffic to it over the @@ -364,61 +367,59 @@ let test_udp_2 () = second physical interface, check that this external third party can traverse the NAT *) let test_nat_punch () = - let t = EchoServer.with_server (fun echoserver -> - with_stack ~pcap:"test_nat_punch.pcap" (fun _ stack -> - let buffer = Cstruct.create 1024 in - (* Send '1' *) - Cstruct.set_uint8 buffer 0 1; - let udpv4 = Client.udpv4 stack.t in + let t = + EchoServer.with_server (fun echoserver -> + with_stack ~pcap:"test_nat_punch.pcap" (fun _ stack -> + let buffer = Cstruct.create 1024 in + (* Send '1' *) + Cstruct.set_uint8 buffer 0 1; + let udpv4 = Client.udpv4 stack.t in - (* Listen on one virtual source port and count received packets *) - let virtual_port1 = 1024 in - let server1 = UdpServer.make stack.t virtual_port1 in + (* Listen on one virtual source port and count received packets *) + let virtual_port1 = 1024 in + let server1 = UdpServer.make stack.t virtual_port1 in - let rec loop remaining = - if remaining = 0 then - failwith "Timed-out before UDP response arrived"; - let dst_port = echoserver.EchoServer.local_port in - Log.debug (fun f -> - f "Sending %d -> %d value %d" virtual_port1 dst_port - (Cstruct.get_uint8 buffer 0)); - Client.UDPV4.write - ~src_port:virtual_port1 - ~dst:Ipaddr.V4.localhost - ~dst_port udpv4 buffer - >>= function - | Error e -> err_udp e - | Ok () -> - UdpServer.wait_for_data ~highest:1 server1 >>= function - | true -> Lwt.return_unit + let rec loop remaining = + if remaining = 0 then + failwith "Timed-out before UDP response arrived"; + let dst_port = echoserver.EchoServer.local_port in + Log.debug (fun f -> + f "Sending %d -> %d value %d" virtual_port1 dst_port + (Cstruct.get_uint8 buffer 0)); + Client.UDPV4.write ~src_port:virtual_port1 + ~dst:Ipaddr.V4.localhost ~dst_port udpv4 buffer + >>= function + | Error e -> err_udp e + | Ok () -> ( + UdpServer.wait_for_data ~highest:1 server1 >>= function + | true -> Lwt.return_unit + | false -> loop (remaining - 1)) + in + loop 5 >>= fun () -> + (* Using the physical outside interface, send traffic to + the address and see if this traffic will also be sent + via the NAT. *) + (* Send '2' *) + Cstruct.set_uint8 buffer 0 2; + Host.Sockets.Datagram.Udp.bind (Ipaddr.(V4 V4.localhost), 0) + >>= fun client -> + Host.Sockets.Datagram.Udp.getsockname client + >>= fun (_, source_port) -> + let address = List.hd (EchoServer.get_seen_addresses echoserver) in + let _, dest_port = address in + let rec loop remaining = + if remaining = 0 then + failwith "Timed-out before UDP response arrived"; + Log.debug (fun f -> + f "Sending %d -> %d value %d" source_port dest_port + (Cstruct.get_uint8 buffer 0)); + Host.Sockets.Datagram.Udp.sendto client address buffer + >>= fun () -> + UdpServer.wait_for_data ~highest:2 server1 >>= function + | true -> Lwt.return_unit | false -> loop (remaining - 1) - in - loop 5 >>= fun () -> - - (* Using the physical outside interface, send traffic to - the address and see if this traffic will also be sent - via the NAT. *) - (* Send '2' *) - Cstruct.set_uint8 buffer 0 2; - Host.Sockets.Datagram.Udp.bind (Ipaddr.(V4 V4.localhost), 0) - >>= fun client -> - Host.Sockets.Datagram.Udp.getsockname client - >>= fun (_, source_port) -> - let address = List.hd (EchoServer.get_seen_addresses echoserver) in - let _, dest_port = address in - let rec loop remaining = - if remaining = 0 then - failwith "Timed-out before UDP response arrived"; - Log.debug (fun f -> - f "Sending %d -> %d value %d" source_port dest_port - (Cstruct.get_uint8 buffer 0)); - Host.Sockets.Datagram.Udp.sendto client address buffer - >>= fun () -> - UdpServer.wait_for_data ~highest:2 server1 >>= function - | true -> Lwt.return_unit - | false -> loop (remaining - 1) - in - loop 5)) + in + loop 5)) in run t @@ -426,119 +427,116 @@ let test_nat_punch () = rather than physical address. Check if we have 2 physical servers we have only a single NAT rule *) let test_shared_nat_rule () = - let t = EchoServer.with_server (fun { EchoServer.local_port; _ } -> - with_stack ~pcap:"test_shared_nat_rule.pcap" (fun slirp_server stack -> - let buffer = Cstruct.create 1024 in - (* Send '1' *) - Cstruct.set_uint8 buffer 0 1; - let udpv4 = Client.udpv4 stack.t in - let virtual_port = 1024 in - let server = UdpServer.make stack.t virtual_port in - let init_table_size = - List.length @@ Slirp_stack.Debug.Nat.get_table slirp_server - in + let t = + EchoServer.with_server (fun { EchoServer.local_port; _ } -> + with_stack ~pcap:"test_shared_nat_rule.pcap" (fun slirp_server stack -> + let buffer = Cstruct.create 1024 in + (* Send '1' *) + Cstruct.set_uint8 buffer 0 1; + let udpv4 = Client.udpv4 stack.t in + let virtual_port = 1024 in + let server = UdpServer.make stack.t virtual_port in + let init_table_size = + List.length @@ Slirp_stack.Debug.Nat.get_table slirp_server + in - let rec loop remaining = - if remaining = 0 then - failwith "Timed-out before UDP response arrived"; - Log.debug (fun f -> - f "Sending %d -> %d value %d" virtual_port local_port - (Cstruct.get_uint8 buffer 0)); - Client.UDPV4.write - ~src_port:virtual_port - ~dst:Ipaddr.V4.localhost - ~dst_port:local_port udpv4 buffer - >>= function - | Error e -> err_udp e - | Ok () -> - UdpServer.wait_for_data ~highest:1 server >>= function - | true -> Lwt.return_unit - | false -> loop (remaining - 1) - in - loop 5 >>= fun () -> - Alcotest.(check int) "One NAT rule" 1 - ((List.length @@ Slirp_stack.Debug.Nat.get_table slirp_server) - - init_table_size); - (* Send '2' *) - Cstruct.set_uint8 buffer 0 2; - (* Create another physical server and send traffic from - the same virtual address *) - EchoServer.with_server (fun { EchoServer.local_port; _ } -> - let rec loop remaining = - if remaining = 0 then - failwith "Timed-out before UDP response arrived"; - Log.debug (fun f -> - f "Sending %d -> %d value %d" virtual_port local_port - (Cstruct.get_uint8 buffer 0)); - Client.UDPV4.write ~src_port:virtual_port - ~dst:Ipaddr.V4.localhost - ~dst_port:local_port udpv4 buffer - >>= function - | Error e -> err_udp e - | Ok () -> - UdpServer.wait_for_data ~highest:2 server >>= function - | true -> Lwt.return_unit - | false -> loop (remaining - 1) - in - loop 5 >|= fun () -> - Alcotest.(check int) "Still one NAT rule" 1 - ((List.length @@ Slirp_stack.Debug.Nat.get_table slirp_server) - - init_table_size) - ))) + let rec loop remaining = + if remaining = 0 then + failwith "Timed-out before UDP response arrived"; + Log.debug (fun f -> + f "Sending %d -> %d value %d" virtual_port local_port + (Cstruct.get_uint8 buffer 0)); + Client.UDPV4.write ~src_port:virtual_port ~dst:Ipaddr.V4.localhost + ~dst_port:local_port udpv4 buffer + >>= function + | Error e -> err_udp e + | Ok () -> ( + UdpServer.wait_for_data ~highest:1 server >>= function + | true -> Lwt.return_unit + | false -> loop (remaining - 1)) + in + loop 5 >>= fun () -> + Alcotest.(check int) + "One NAT rule" 1 + ((List.length @@ Slirp_stack.Debug.Nat.get_table slirp_server) + - init_table_size); + (* Send '2' *) + Cstruct.set_uint8 buffer 0 2; + (* Create another physical server and send traffic from + the same virtual address *) + EchoServer.with_server (fun { EchoServer.local_port; _ } -> + let rec loop remaining = + if remaining = 0 then + failwith "Timed-out before UDP response arrived"; + Log.debug (fun f -> + f "Sending %d -> %d value %d" virtual_port local_port + (Cstruct.get_uint8 buffer 0)); + Client.UDPV4.write ~src_port:virtual_port + ~dst:Ipaddr.V4.localhost ~dst_port:local_port udpv4 buffer + >>= function + | Error e -> err_udp e + | Ok () -> ( + UdpServer.wait_for_data ~highest:2 server >>= function + | true -> Lwt.return_unit + | false -> loop (remaining - 1)) + in + loop 5 >|= fun () -> + Alcotest.(check int) + "Still one NAT rule" 1 + ((List.length @@ Slirp_stack.Debug.Nat.get_table slirp_server) + - init_table_size)))) in run t (* If we have two physical servers but send data from the same source port, we should see both physical server source ports *) let test_source_ports () = - let t = EchoServer.with_server - (fun { EchoServer.local_port = local_port1; _ } -> - EchoServer.with_server - (fun { EchoServer.local_port = local_port2; _ } -> - with_stack ~pcap:"test_source_ports.pcap" (fun _ stack -> - let buffer = Cstruct.create 1024 in - let udpv4 = Client.udpv4 stack.t in - (* This is the port we shall send from *) - let virtual_port = 1024 in - let server = UdpServer.make stack.t virtual_port in - let rec loop remaining = - Printf.fprintf stderr "remaining=%d\n%!" remaining; - if remaining = 0 then - failwith "Timed-out before both UDP ports were seen"; - Log.debug (fun f -> - f "Sending %d -> %d value %d" virtual_port local_port1 - (Cstruct.get_uint8 buffer 0)); - Client.UDPV4.write - ~src_port:virtual_port - ~dst:Ipaddr.V4.localhost - ~dst_port:local_port1 udpv4 buffer - >>= function - | Error e -> err_udp e - | Ok () -> + let t = + EchoServer.with_server (fun { EchoServer.local_port = local_port1; _ } -> + EchoServer.with_server + (fun { EchoServer.local_port = local_port2; _ } -> + with_stack ~pcap:"test_source_ports.pcap" (fun _ stack -> + let buffer = Cstruct.create 1024 in + let udpv4 = Client.udpv4 stack.t in + (* This is the port we shall send from *) + let virtual_port = 1024 in + let server = UdpServer.make stack.t virtual_port in + let rec loop remaining = + Printf.fprintf stderr "remaining=%d\n%!" remaining; + if remaining = 0 then + failwith "Timed-out before both UDP ports were seen"; + Log.debug (fun f -> + f "Sending %d -> %d value %d" virtual_port local_port1 + (Cstruct.get_uint8 buffer 0)); + Client.UDPV4.write ~src_port:virtual_port + ~dst:Ipaddr.V4.localhost ~dst_port:local_port1 udpv4 buffer + >>= function + | Error e -> err_udp e + | Ok () -> ( Log.debug (fun f -> f "Sending %d -> %d value %d" virtual_port local_port2 (Cstruct.get_uint8 buffer 0)); - Client.UDPV4.write - ~src_port:virtual_port - ~dst:Ipaddr.V4.localhost - ~dst_port:local_port2 udpv4 buffer + Client.UDPV4.write ~src_port:virtual_port + ~dst:Ipaddr.V4.localhost ~dst_port:local_port2 udpv4 + buffer >>= function | Error e -> err_udp e - | Ok () -> - UdpServer.wait_for_ports ~num:2 server >>= function - | true -> Lwt.return_unit - | false -> loop (remaining - 1) - in - loop 5))) + | Ok () -> ( + UdpServer.wait_for_ports ~num:2 server >>= function + | true -> Lwt.return_unit + | false -> loop (remaining - 1))) + in + loop 5))) in Host.Main.run t -let tests = [ - "NAT: shared rule", [ "", `Quick, test_shared_nat_rule ]; - "NAT: 1 UDP connection", [ "", `Quick, test_udp ]; - "NAT: 2 UDP connections", [ "", `Quick, test_udp_2 ]; - "NAT: punch", [ "", `Quick, test_nat_punch ]; - "NAT: source ports", [ "", `Quick, test_source_ports ]; - "NAT: flow reply last use", [ "", `Quick, test_udp_reply_last_use ]; - "NAT: flow expiry", [ "", `Quick, test_udp_expiry ]; -] +let tests = + [ + ("NAT: shared rule", [ ("", `Quick, test_shared_nat_rule) ]); + ("NAT: 1 UDP connection", [ ("", `Quick, test_udp) ]); + ("NAT: 2 UDP connections", [ ("", `Quick, test_udp_2) ]); + ("NAT: punch", [ ("", `Quick, test_nat_punch) ]); + ("NAT: source ports", [ ("", `Quick, test_source_ports) ]); + ("NAT: flow reply last use", [ ("", `Quick, test_udp_reply_last_use) ]); + ("NAT: flow expiry", [ ("", `Quick, test_udp_expiry) ]); + ] File "src/hostnet/hostnet_http.ml", line 1, characters 0-0: diff --git a/_build/default/src/hostnet/hostnet_http.ml b/_build/default/src/hostnet/.formatted/hostnet_http.ml index 910bc5f..b5416c0 100644 --- a/_build/default/src/hostnet/hostnet_http.ml +++ b/_build/default/src/hostnet/.formatted/hostnet_http.ml @@ -11,23 +11,14 @@ module Log = (val Logs.src_log src : Logs.LOG) let errorf fmt = Fmt.kstr (fun e -> Lwt.return (Error (`Msg e))) fmt module Match = struct - module One = struct module Element = struct (* One element of a DNS name *) type t = Any | String of string - let of_string = function - | "*" | "" -> Any - | x -> String x - - let to_string = function - | Any -> "*" - | String x -> x - - let matches x = function - | Any -> true - | String y -> x = y + let of_string = function "*" | "" -> Any | x -> String x + let to_string = function Any -> "*" | String x -> x + let matches x = function Any -> true | String y -> x = y end type t = @@ -37,36 +28,37 @@ module Match = struct let of_string s = match Ipaddr.V4.Prefix.of_string s with - | Error _ -> - begin match Ipaddr.V4.of_string s with - | Error _ -> - let bits = Astring.String.cuts ~sep:"." s in - Subdomain (List.map Element.of_string bits) - | Ok ip -> IP ip - end + | Error _ -> ( + match Ipaddr.V4.of_string s with + | Error _ -> + let bits = Astring.String.cuts ~sep:"." s in + Subdomain (List.map Element.of_string bits) + | Ok ip -> IP ip) | Ok prefix -> CIDR prefix let to_string = function - | Subdomain x -> - "Subdomain " ^ String.concat ~sep:"." @@ List.map Element.to_string x - | CIDR prefix -> "CIDR " ^ Ipaddr.V4.Prefix.to_string prefix - | IP ip -> "IP " ^ Ipaddr.V4.to_string ip + | Subdomain x -> + "Subdomain " ^ String.concat ~sep:"." @@ List.map Element.to_string x + | CIDR prefix -> "CIDR " ^ Ipaddr.V4.Prefix.to_string prefix + | IP ip -> "IP " ^ Ipaddr.V4.to_string ip let matches_ip ip = function - | CIDR prefix -> Ipaddr.V4.Prefix.mem ip prefix - | IP ip' -> Ipaddr.V4.compare ip ip' = 0 - | _ -> false + | CIDR prefix -> Ipaddr.V4.Prefix.mem ip prefix + | IP ip' -> Ipaddr.V4.compare ip ip' = 0 + | _ -> false let matches_host host = function - | CIDR _ | IP _ -> false - | Subdomain domains -> - let bits = Astring.String.cuts ~sep:"." host in - (* does 'bits' match 'domains' *) - let rec loop bits domains = match bits, domains with - | _, [] -> true - | [], _ :: _ -> false - | b :: bs, d :: ds -> Element.matches b d && loop bs ds in - loop (List.rev bits) (List.rev domains) + | CIDR _ | IP _ -> false + | Subdomain domains -> + let bits = Astring.String.cuts ~sep:"." host in + (* does 'bits' match 'domains' *) + let rec loop bits domains = + match (bits, domains) with + | _, [] -> true + | [], _ :: _ -> false + | b :: bs, d :: ds -> Element.matches b d && loop bs ds + in + loop (List.rev bits) (List.rev domains) let matches thing exclude = match Ipaddr.V4.of_string thing with @@ -83,25 +75,24 @@ module Match = struct (* Accept either space or comma-separated ignoring whitespace *) let parts = String.fields ~empty:false - ~is_sep:(fun c -> c = ',' || Char.Ascii.is_white c) s + ~is_sep:(fun c -> c = ',' || Char.Ascii.is_white c) + s in List.map One.of_string parts - let to_string t = String.concat ~sep:" " @@ (List.map One.to_string t) + let to_string t = String.concat ~sep:" " @@ List.map One.to_string t let matches thing t = - List.fold_left (||) false (List.map (One.matches thing) t) - + List.fold_left ( || ) false (List.map (One.matches thing) t) end module Make - (Ip: Tcpip.Ip.S with type ipaddr = Ipaddr.V4.t) - (Udp: Tcpip.Udp.S with type ipaddr = Ipaddr.V4.t) - (Tcp:Mirage_flow_combinators.SHUTDOWNABLE) - (Remote: Sig.FLOW_CLIENT with type address = Ipaddr.t * int) - (Dns_resolver: Sig.DNS) -= struct - + (Ip : Tcpip.Ip.S with type ipaddr = Ipaddr.V4.t) + (Udp : Tcpip.Udp.S with type ipaddr = Ipaddr.V4.t) + (Tcp : Mirage_flow_combinators.SHUTDOWNABLE) + (Remote : Sig.FLOW_CLIENT with type address = Ipaddr.t * int) + (Dns_resolver : Sig.DNS) = +struct type proxy = Uri.t let string_of_proxy = Uri.to_string @@ -110,88 +101,98 @@ module Make let proxy_of_string x = (* Is it a URL? *) let uri = Uri.of_string x in - match Uri.host uri, Uri.port uri with + match (Uri.host uri, Uri.port uri) with | Some _, Some _ -> Some uri - | _, _ -> - begin match String.cuts ~sep:":" x with - | [] -> - Log.err (fun f -> f "Failed to parse HTTP(S) proxy as URI or host:port: %s" x); - None - | [host; port] -> - begin - try - let port = int_of_string port in - Some (Uri.make ~scheme:"http" ~host ~port ()) - with Failure _ -> - Log.err (fun f -> f "Failed to parse HTTP(S) proxy as URI or host:port: %s" x); + | _, _ -> ( + match String.cuts ~sep:":" x with + | [] -> + Log.err (fun f -> + f "Failed to parse HTTP(S) proxy as URI or host:port: %s" x); None - end - | _ -> - Log.err (fun f -> f "Failed to parse HTTP(S) proxy as URI or host:port: %s" x); - None - end + | [ host; port ] -> ( + try + let port = int_of_string port in + Some (Uri.make ~scheme:"http" ~host ~port ()) + with Failure _ -> + Log.err (fun f -> + f "Failed to parse HTTP(S) proxy as URI or host:port: %s" x); + None) + | _ -> + Log.err (fun f -> + f "Failed to parse HTTP(S) proxy as URI or host:port: %s" x); + None) let string_of_address (ip, port) = Fmt.str "%s:%d" (Ipaddr.to_string ip) port type t = { - http: proxy option; - https: proxy option; - exclude: Match.t; - transparent_http_ports: int list; - transparent_https_ports: int list; - allow_enabled: bool; - allow: Match.t; - allow_error_msg: string; + http : proxy option; + https : proxy option; + exclude : Match.t; + transparent_http_ports : int list; + transparent_https_ports : int list; + allow_enabled : bool; + allow : Match.t; + allow_error_msg : string; } let resolve_ip name_or_ip = match Ipaddr.of_string name_or_ip with | Error _ -> - let open Dns.Packet in - let question = - make_question ~q_class:Q_IN Q_A (Dns.Name.of_string name_or_ip) - in - Dns_resolver.resolve question - >>= fun rrs -> - (* Any IN record will do (NB it might be a CNAME) *) - let rec find_ip = function - | { cls = RR_IN; rdata = A ipv4; _ } :: _ -> - Lwt.return (Ok (Ipaddr.V4 ipv4)) - | _ :: rest -> find_ip rest - | [] -> errorf "Failed to lookup host: %s" name_or_ip in - find_ip rrs + let open Dns.Packet in + let question = + make_question ~q_class:Q_IN Q_A (Dns.Name.of_string name_or_ip) + in + Dns_resolver.resolve question >>= fun rrs -> + (* Any IN record will do (NB it might be a CNAME) *) + let rec find_ip = function + | { cls = RR_IN; rdata = A ipv4; _ } :: _ -> + Lwt.return (Ok (Ipaddr.V4 ipv4)) + | _ :: rest -> find_ip rest + | [] -> errorf "Failed to lookup host: %s" name_or_ip + in + find_ip rrs | Ok x -> Lwt.return (Ok x) let to_json t = let open Ezjsonm in - let http = match t.http with - | None -> [] - | Some x -> [ "http", string @@ string_of_proxy x ] + let http = + match t.http with + | None -> [] + | Some x -> [ ("http", string @@ string_of_proxy x) ] + in + let https = + match t.https with + | None -> [] + | Some x -> [ ("https", string @@ string_of_proxy x) ] + in + let exclude = [ ("exclude", string @@ Match.to_string t.exclude) ] in + let transparent_http_ports = + [ ("transparent_http_ports", list int t.transparent_http_ports) ] in - let https = match t.https with - | None -> [] - | Some x -> [ "https", string @@ string_of_proxy x ] + let transparent_https_ports = + [ ("transparent_https_ports", list int t.transparent_https_ports) ] in - let exclude = [ "exclude", string @@ Match.to_string t.exclude ] in - let transparent_http_ports = [ "transparent_http_ports", list int t.transparent_http_ports ] in - let transparent_https_ports = [ "transparent_https_ports", list int t.transparent_https_ports ] in - let allow_enabled = [ "allow_enabled", bool t.allow_enabled ] in - let allow = [ "allow", list string @@ List.map Match.One.to_string t.allow ] in - let allow_error_msg = [ "allow_error_msg", string t.allow_error_msg ] in - dict (http @ https @ exclude @ transparent_http_ports @ transparent_https_ports @ allow_enabled @ allow @ allow_error_msg) + let allow_enabled = [ ("allow_enabled", bool t.allow_enabled) ] in + let allow = + [ ("allow", list string @@ List.map Match.One.to_string t.allow) ] + in + let allow_error_msg = [ ("allow_error_msg", string t.allow_error_msg) ] in + dict + (http @ https @ exclude @ transparent_http_ports @ transparent_https_ports + @ allow_enabled @ allow @ allow_error_msg) - let default_error_msg = "Connections to %s are forbidden by policy. Please contact your IT administrator." + let default_error_msg = + "Connections to %s are forbidden by policy. Please contact your IT \ + administrator." let of_json j = try let open Ezjsonm in let http = - try Some (get_string @@ find j [ "http" ]) - with Not_found -> None + try Some (get_string @@ find j [ "http" ]) with Not_found -> None in let https = - try Some (get_string @@ find j [ "https" ]) - with Not_found -> None + try Some (get_string @@ find j [ "https" ]) with Not_found -> None in let exclude = try Match.of_string @@ get_string @@ find j [ "exclude" ] @@ -199,48 +200,84 @@ module Make in let transparent_http_ports = try get_list get_int @@ find j [ "transparent_http_ports" ] - with Not_found -> [ 80 ] in + with Not_found -> [ 80 ] + in let transparent_https_ports = try get_list get_int @@ find j [ "transparent_https_ports" ] - with Not_found -> [ 443 ] in + with Not_found -> [ 443 ] + in let allow_enabled = - try (get_bool @@ find j [ "allow_enabled" ]) - with Not_found -> false + try get_bool @@ find j [ "allow_enabled" ] with Not_found -> false in let allow = - try List.map Match.One.of_string @@ get_list get_string @@ find j [ "allow" ] - with Not_found -> [] in + try + List.map Match.One.of_string + @@ get_list get_string + @@ find j [ "allow" ] + with Not_found -> [] + in let allow_error_msg = try get_string @@ find j [ "allow_error_msg" ] - with Not_found -> default_error_msg in + with Not_found -> default_error_msg + in let http = match http with None -> None | Some x -> proxy_of_string x in - let https = match https with None -> None | Some x -> proxy_of_string x in - Lwt.return (Ok { http; https; exclude; transparent_http_ports; transparent_https_ports; allow_enabled; allow; allow_error_msg }) + let https = + match https with None -> None | Some x -> proxy_of_string x + in + Lwt.return + (Ok + { + http; + https; + exclude; + transparent_http_ports; + transparent_https_ports; + allow_enabled; + allow; + allow_error_msg; + }) with e -> - Lwt.return (Error (`Msg (Printf.sprintf "parsing json: %s" (Printexc.to_string e)))) + Lwt.return + (Error (`Msg (Printf.sprintf "parsing json: %s" (Printexc.to_string e)))) let to_string t = Ezjsonm.to_string ~minify:true @@ to_json t - let create ?http ?https ?exclude ?(transparent_http_ports=[ 80 ]) ?(transparent_https_ports=[ 443 ]) ?(allow_enabled=false) ?(allow=[]) ?(allow_error_msg = default_error_msg) () = + let create ?http ?https ?exclude ?(transparent_http_ports = [ 80 ]) + ?(transparent_https_ports = [ 443 ]) ?(allow_enabled = false) + ?(allow = []) ?(allow_error_msg = default_error_msg) () = let http = match http with None -> None | Some x -> proxy_of_string x in let https = match https with None -> None | Some x -> proxy_of_string x in - let exclude = match exclude with None -> [] | Some x -> Match.of_string x in + let exclude = + match exclude with None -> [] | Some x -> Match.of_string x + in let allow = List.map Match.One.of_string allow in - let t = { http; https; exclude; transparent_http_ports; transparent_https_ports; allow_enabled; allow; allow_error_msg } in + let t = + { + http; + https; + exclude; + transparent_http_ports; + transparent_https_ports; + allow_enabled; + allow; + allow_error_msg; + } + in Log.info (fun f -> f "HTTP proxy settings changed to: %s" (to_string t)); Lwt.return (Ok t) module Incoming = struct - module C = Mirage_channel.Make(Tcp) - module IO = Cohttp_mirage_io.Make(C) - module Request = Cohttp.Request.Make(IO) - module Response = Cohttp.Response.Make(IO) + module C = Mirage_channel.Make (Tcp) + module IO = Cohttp_mirage_io.Make (C) + module Request = Cohttp.Request.Make (IO) + module Response = Cohttp.Response.Make (IO) end + module Outgoing = struct - module C = Mirage_channel.Make(Remote) - module IO = Cohttp_mirage_io.Make(C) - module Request = Cohttp.Request.Make(IO) - module Response = Cohttp.Response.Make(IO) + module C = Mirage_channel.Make (Remote) + module IO = Cohttp_mirage_io.Make (C) + module Request = Cohttp.Request.Make (IO) + module Response = Cohttp.Response.Make (IO) end (* Since we've already layered a channel on top, we can't use the Mirage_flow.proxy @@ -250,76 +287,82 @@ module Make (* forward outgoing to ingoing *) let a_t flow ~incoming ~outgoing = let warn pp e = - Log.warn (fun f -> f "Unexpected exeption %a in proxy" pp e); + Log.warn (fun f -> f "Unexpected exeption %a in proxy" pp e) in let rec loop () = Lwt.catch (fun () -> Outgoing.C.read_some outgoing >>= function - | Ok `Eof -> Lwt.return false - | Error e -> warn Outgoing.C.pp_error e; Lwt.return false - | Ok (`Data buf) -> + | Ok `Eof -> Lwt.return false + | Error e -> + warn Outgoing.C.pp_error e; + Lwt.return false + | Ok (`Data buf) -> ( Incoming.C.write_buffer incoming buf; Incoming.C.flush incoming >|= function - | Ok () -> true + | Ok () -> true | Error `Closed -> false - | Error e -> warn Incoming.C.pp_write_error e; false - ) (fun e -> - Log.warn (fun f -> f "a_t: caught unexpected exception: %s" (Printexc.to_string e)); - Lwt.return false - ) - >>= fun continue -> - if continue then loop () else Tcp.close flow + | Error e -> + warn Incoming.C.pp_write_error e; + false)) + (fun e -> + Log.warn (fun f -> + f "a_t: caught unexpected exception: %s" (Printexc.to_string e)); + Lwt.return false) + >>= fun continue -> if continue then loop () else Tcp.close flow in - loop () in + loop () + in (* forward ingoing to outgoing *) let b_t remote ~incoming ~outgoing = let warn pp e = - Log.warn (fun f -> f "Unexpected exeption %a in proxy" pp e); + Log.warn (fun f -> f "Unexpected exeption %a in proxy" pp e) in let rec loop () = Lwt.catch (fun () -> Incoming.C.read_some incoming >>= function - | Ok `Eof -> Lwt.return false - | Error e -> warn Incoming.C.pp_error e; Lwt.return false - | Ok (`Data buf) -> + | Ok `Eof -> Lwt.return false + | Error e -> + warn Incoming.C.pp_error e; + Lwt.return false + | Ok (`Data buf) -> ( Outgoing.C.write_buffer outgoing buf; Outgoing.C.flush outgoing >|= function - | Ok () -> true + | Ok () -> true | Error `Closed -> false - | Error e -> warn Outgoing.C.pp_write_error e; false - ) (fun e -> - Log.warn (fun f -> f "b_t: caught unexpected exception: %s" (Printexc.to_string e)); - Lwt.return false - ) + | Error e -> + warn Outgoing.C.pp_write_error e; + false)) + (fun e -> + Log.warn (fun f -> + f "b_t: caught unexpected exception: %s" (Printexc.to_string e)); + Lwt.return false) >>= fun continue -> if continue then loop () else Remote.shutdown_write remote in - loop () in - Lwt.join [ - a_t flow ~incoming ~outgoing; - b_t remote ~incoming ~outgoing - ] + loop () + in + Lwt.join [ a_t flow ~incoming ~outgoing; b_t remote ~incoming ~outgoing ] let rec proxy_body_request_exn ~reader ~writer = let open Cohttp.Transfer in Incoming.Request.read_body_chunk reader >>= function - | Done -> Lwt.return_unit + | Done -> Lwt.return_unit | Final_chunk x -> Outgoing.Request.write_body writer x - | Chunk x -> - Outgoing.Request.write_body writer x >>= fun () -> - proxy_body_request_exn ~reader ~writer + | Chunk x -> + Outgoing.Request.write_body writer x >>= fun () -> + proxy_body_request_exn ~reader ~writer let rec proxy_body_response_exn ~reader ~writer = let open Cohttp.Transfer in - Outgoing.Response.read_body_chunk reader >>= function - | Done -> Lwt.return_unit + Outgoing.Response.read_body_chunk reader >>= function + | Done -> Lwt.return_unit | Final_chunk x -> Incoming.Response.write_body writer x - | Chunk x -> - Incoming.Response.write_body writer x >>= fun () -> - proxy_body_response_exn ~reader ~writer + | Chunk x -> + Incoming.Response.write_body writer x >>= fun () -> + proxy_body_response_exn ~reader ~writer (* Take a request and a pair (incoming, outgoing) of channels, send the request to the outgoing channel and then proxy back any response. @@ -330,130 +373,154 @@ module Make (fun () -> let reader = Incoming.Request.make_body_reader req incoming in Log.info (fun f -> f "Outgoing.Request.write"); - Outgoing.Request.write ~flush:true (fun writer -> + Outgoing.Request.write ~flush:true + (fun writer -> match Incoming.Request.has_body req with - | `Yes -> proxy_body_request_exn ~reader ~writer - | `No -> Lwt.return_unit + | `Yes -> proxy_body_request_exn ~reader ~writer + | `No -> Lwt.return_unit | `Unknown -> - Log.warn (fun f -> - f "Request.has_body returned `Unknown: not sure what \ - to do"); - Lwt.return_unit - ) req outgoing + Log.warn (fun f -> + f "Request.has_body returned `Unknown: not sure what to do"); + Lwt.return_unit) + req outgoing >>= fun () -> Log.info (fun f -> f "Outgoing.Response.read"); Outgoing.Response.read outgoing >>= function | `Eof -> - Log.warn (fun f -> f "%s: EOF" (description false)); - Lwt.return false + Log.warn (fun f -> f "%s: EOF" (description false)); + Lwt.return false | `Invalid x -> - Log.warn (fun f -> - f "%s: Failed to parse HTTP response: %s" - (description false) x); - Lwt.return false - | `Ok res -> - Log.info (fun f -> - f "%s: %s %s" - (description false) - (Cohttp.Code.string_of_version res.Cohttp.Response.version) - (Cohttp.Code.string_of_status res.Cohttp.Response.status)); - Log.debug (fun f -> - f "%s" (Sexplib.Sexp.to_string_hum - (Cohttp.Response.sexp_of_t res))); - let res_headers = res.Cohttp.Response.headers in - let connection_close = - (* HTTP 1.0 defaults to Connection: close *) - match res.Cohttp.Response.version, Cohttp.Header.get res_headers "connection" with - | _, Some "keep-alive" -> false - | _, Some "close" -> true - | `HTTP_1_0, _ -> true - | _, _ -> false in - match Cohttp.Request.meth req, Cohttp.Response.status res with - | `CONNECT, `OK -> - (* Write the response and then switch to proxying the bytes *) - Incoming.Response.write ~flush:true (fun _writer -> Lwt.return_unit) res incoming - >>= fun () -> - proxy_bytes ~incoming ~outgoing ~flow ~remote - >>= fun () -> - Log.debug (fun f -> f "%s: HTTP CONNECT complete" (description false)); + Log.warn (fun f -> + f "%s: Failed to parse HTTP response: %s" (description false) x); Lwt.return false - | _, _ -> - (* Otherwise stay in HTTP mode *) - let reader = Outgoing.Response.make_body_reader res outgoing in - Incoming.Response.write ~flush:true (fun writer -> - match Cohttp.Request.meth req, Incoming.Response.has_body res with - | `HEAD, `Yes -> - (* Bug in cohttp.1.0.2: according to Section 9.4 of RFC2616 - https://www.w3.org/Protocols/rfc2616/rfc2616-sec9.html - > The HEAD method is identical to GET except that the server - > MUST NOT return a message-body in the response. - *) - Log.debug (fun f -> f "%s: HEAD requests MUST NOT have response bodies" (description false)); - Lwt.return_unit - | _, `Yes -> - Log.info (fun f -> f "%s: proxying body" (description false)); - proxy_body_response_exn ~reader ~writer - >>= fun () -> - Lwt.return_unit - | _, `No -> - Log.info (fun f -> f "%s: no body to proxy" (description false)); - Lwt.return_unit - | _, `Unknown when connection_close -> - (* There may be a body between here and the EOF *) - Log.info (fun f -> f "%s: proxying until EOF" (description false)); - proxy_body_response_exn ~reader ~writer - | _, `Unknown -> - Log.warn (fun f -> - f "Response.has_body returned `Unknown: not sure \ - what to do"); - Lwt.return_unit - ) res incoming - >>= fun () -> - Lwt.return (not connection_close) - ) (fun e -> - Log.warn (fun f -> f "proxy_request caught exception: %s" (Printexc.to_string e)); - Lwt.return false - ) + | `Ok res -> ( + Log.info (fun f -> + f "%s: %s %s" (description false) + (Cohttp.Code.string_of_version res.Cohttp.Response.version) + (Cohttp.Code.string_of_status res.Cohttp.Response.status)); + Log.debug (fun f -> + f "%s" + (Sexplib.Sexp.to_string_hum (Cohttp.Response.sexp_of_t res))); + let res_headers = res.Cohttp.Response.headers in + let connection_close = + (* HTTP 1.0 defaults to Connection: close *) + match + ( res.Cohttp.Response.version, + Cohttp.Header.get res_headers "connection" ) + with + | _, Some "keep-alive" -> false + | _, Some "close" -> true + | `HTTP_1_0, _ -> true + | _, _ -> false + in + match (Cohttp.Request.meth req, Cohttp.Response.status res) with + | `CONNECT, `OK -> + (* Write the response and then switch to proxying the bytes *) + Incoming.Response.write ~flush:true + (fun _writer -> Lwt.return_unit) + res incoming + >>= fun () -> + proxy_bytes ~incoming ~outgoing ~flow ~remote >>= fun () -> + Log.debug (fun f -> + f "%s: HTTP CONNECT complete" (description false)); + Lwt.return false + | _, _ -> + (* Otherwise stay in HTTP mode *) + let reader = Outgoing.Response.make_body_reader res outgoing in + Incoming.Response.write ~flush:true + (fun writer -> + match + (Cohttp.Request.meth req, Incoming.Response.has_body res) + with + | `HEAD, `Yes -> + (* Bug in cohttp.1.0.2: according to Section 9.4 of RFC2616 + https://www.w3.org/Protocols/rfc2616/rfc2616-sec9.html + > The HEAD method is identical to GET except that the server + > MUST NOT return a message-body in the response. + *) + Log.debug (fun f -> + f "%s: HEAD requests MUST NOT have response bodies" + (description false)); + Lwt.return_unit + | _, `Yes -> + Log.info (fun f -> + f "%s: proxying body" (description false)); + proxy_body_response_exn ~reader ~writer >>= fun () -> + Lwt.return_unit + | _, `No -> + Log.info (fun f -> + f "%s: no body to proxy" (description false)); + Lwt.return_unit + | _, `Unknown when connection_close -> + (* There may be a body between here and the EOF *) + Log.info (fun f -> + f "%s: proxying until EOF" (description false)); + proxy_body_response_exn ~reader ~writer + | _, `Unknown -> + Log.warn (fun f -> + f + "Response.has_body returned `Unknown: not sure \ + what to do"); + Lwt.return_unit) + res incoming + >>= fun () -> Lwt.return (not connection_close))) + (fun e -> + Log.warn (fun f -> + f "proxy_request caught exception: %s" (Printexc.to_string e)); + Lwt.return false) let add_proxy_authorization proxy headers = let proxy_authorization = "Proxy-Authorization" in let headers = Cohttp.Header.remove headers proxy_authorization in match Uri.userinfo proxy with - | None -> headers - | Some s -> Cohttp.Header.add headers proxy_authorization ("Basic " ^ (Base64.encode_exn s)) + | None -> headers + | Some s -> + Cohttp.Header.add headers proxy_authorization + ("Basic " ^ Base64.encode_exn s) let address_of_proxy ~localhost_names ~localhost_ips proxy = - match Uri.host proxy, Uri.port proxy with + match (Uri.host proxy, Uri.port proxy) with | None, _ -> - Lwt.return (Error (`Msg ("HTTP proxy URI does not include a hostname: " ^ (Uri.to_string proxy)))) + Lwt.return + (Error + (`Msg + ("HTTP proxy URI does not include a hostname: " + ^ Uri.to_string proxy))) | _, None -> - Lwt.return (Error (`Msg ("HTTP proxy URI does not include a port: " ^ (Uri.to_string proxy)))) - | Some host, Some port -> - let host = - if List.mem (Dns.Name.of_string host) localhost_names - then "localhost" - else host in - resolve_ip host - >>= function - | Error e -> Lwt.return (Error e) - | Ok ip -> - let ip = - if List.mem ip localhost_ips - then Ipaddr.(V4 V4.localhost) - else ip in - Lwt.return (Ok (ip, port)) + Lwt.return + (Error + (`Msg + ("HTTP proxy URI does not include a port: " ^ Uri.to_string proxy))) + | Some host, Some port -> ( + let host = + if List.mem (Dns.Name.of_string host) localhost_names then "localhost" + else host + in + resolve_ip host >>= function + | Error e -> Lwt.return (Error e) + | Ok ip -> + let ip = + if List.mem ip localhost_ips then Ipaddr.(V4 V4.localhost) else ip + in + Lwt.return (Ok (ip, port))) let send_error status incoming description = - let header = "HTTP/1.1 " ^ status ^ " " ^ description ^ "\r\nConnection: closed\r\n\r\n" in - let body = {| + let header = + "HTTP/1.1 " ^ status ^ " " ^ description + ^ "\r\nConnection: closed\r\n\r\n" + in + let body = + {| <html> <head> <meta http-equiv="Content-Type" content="text/html; charset=utf-8"> - <title> |} ^ description ^ {| </title> + <title> |} + ^ description ^ {| </title> </head> <body> - <h1>|} ^ description ^ {|</h1> + <h1>|} ^ description + ^ {|</h1> <p> Please check: </p> @@ -466,16 +533,15 @@ module Make </p> </body> </html> - |} in + |} + in let response = header ^ body in Incoming.C.write_string incoming response 0 (String.length response); - begin Incoming.C.flush incoming >>= function + Incoming.C.flush incoming >>= function | Error _ -> - Log.warn (fun f -> f "failed to return %s %s" status description); - Lwt.return_unit - | Ok () -> - Lwt.return_unit - end + Log.warn (fun f -> f "failed to return %s %s" status description); + Lwt.return_unit + | Ok () -> Lwt.return_unit let tunnel_https_over_connect ~localhost_names ~localhost_ips ~dst proxy = let listeners _port = @@ -488,63 +554,82 @@ module Make address_of_proxy ~localhost_names ~localhost_ips proxy >>= function | Error (`Msg m) -> - Log.warn (fun f -> f "HTTP proxy: cannot forward to %s: %s" (Uri.to_string proxy) m); - Lwt.return_unit - | Ok ((ip, port) as address) -> - let host = Ipaddr.V4.to_string dst in - let description outgoing = - Fmt.str "%s:443 %s %s:%d" host - (if outgoing then "-->" else "<--") (Ipaddr.to_string ip) port - in - Log.info (fun f -> f "%s: CONNECT" (description true)); - let connect = - let host = Ipaddr.V4.to_string dst in - let port = 443 in - let uri = Uri.make ~host ~port () in - let headers = add_proxy_authorization proxy (Cohttp.Header.init ()) in - let request = Cohttp.Request.make ~meth:`CONNECT ~headers uri in - { request with Cohttp.Request.resource = host ^ ":" ^ (string_of_int port) } - in - Remote.connect address >>= function - | Error _ -> Log.warn (fun f -> - f "Failed to connect to %s" (string_of_address address)); + f "HTTP proxy: cannot forward to %s: %s" + (Uri.to_string proxy) m); Lwt.return_unit - | Ok remote -> - let outgoing = Outgoing.C.create remote in - Lwt.finalize (fun () -> - Outgoing.Request.write ~flush:true (fun _ -> Lwt.return_unit) - connect outgoing - >>= fun () -> - Outgoing.Response.read outgoing >>= function - | `Eof -> - Log.warn (fun f -> - f "EOF from %s" (string_of_address address)); - Lwt.return_unit - | `Invalid x -> - Log.warn (fun f -> - f "Failed to parse HTTP response on port %s: %s" - (string_of_address address) x); - Lwt.return_unit - | `Ok res -> - Log.info (fun f -> - let open Cohttp.Response in - f "%s: %s %s" - (description false) - (Cohttp.Code.string_of_version res.version) - (Cohttp.Code.string_of_status res.status)); - Log.debug (fun f -> - f "%s" (Sexplib.Sexp.to_string_hum - (Cohttp.Response.sexp_of_t res))); - let incoming = Incoming.C.create flow in - proxy_bytes ~incoming ~outgoing ~flow ~remote - ) (fun () -> Remote.close remote) - ) (fun () -> Tcp.close flow) - ) (fun e -> - Log.warn (fun f -> f "tunnel_https_over_connect caught exception: %s" (Printexc.to_string e)); - Lwt.return_unit - ) - in Some process + | Ok ((ip, port) as address) -> ( + let host = Ipaddr.V4.to_string dst in + let description outgoing = + Fmt.str "%s:443 %s %s:%d" host + (if outgoing then "-->" else "<--") + (Ipaddr.to_string ip) port + in + Log.info (fun f -> f "%s: CONNECT" (description true)); + let connect = + let host = Ipaddr.V4.to_string dst in + let port = 443 in + let uri = Uri.make ~host ~port () in + let headers = + add_proxy_authorization proxy (Cohttp.Header.init ()) + in + let request = + Cohttp.Request.make ~meth:`CONNECT ~headers uri + in + { + request with + Cohttp.Request.resource = + host ^ ":" ^ string_of_int port; + } + in + Remote.connect address >>= function + | Error _ -> + Log.warn (fun f -> + f "Failed to connect to %s" + (string_of_address address)); + Lwt.return_unit + | Ok remote -> + let outgoing = Outgoing.C.create remote in + Lwt.finalize + (fun () -> + Outgoing.Request.write ~flush:true + (fun _ -> Lwt.return_unit) + connect outgoing + >>= fun () -> + Outgoing.Response.read outgoing >>= function + | `Eof -> + Log.warn (fun f -> + f "EOF from %s" (string_of_address address)); + Lwt.return_unit + | `Invalid x -> + Log.warn (fun f -> + f + "Failed to parse HTTP response on port \ + %s: %s" + (string_of_address address) + x); + Lwt.return_unit + | `Ok res -> + Log.info (fun f -> + let open Cohttp.Response in + f "%s: %s %s" (description false) + (Cohttp.Code.string_of_version res.version) + (Cohttp.Code.string_of_status res.status)); + Log.debug (fun f -> + f "%s" + (Sexplib.Sexp.to_string_hum + (Cohttp.Response.sexp_of_t res))); + let incoming = Incoming.C.create flow in + proxy_bytes ~incoming ~outgoing ~flow ~remote) + (fun () -> Remote.close remote))) + (fun () -> Tcp.close flow)) + (fun e -> + Log.warn (fun f -> + f "tunnel_https_over_connect caught exception: %s" + (Printexc.to_string e)); + Lwt.return_unit) + in + Some process in Lwt.return listeners @@ -553,266 +638,326 @@ module Make - the URI or the Host: header in the request - whether the request matches the proxy excludes or not *) type route = { - next_hop_address: (Ipaddr.t * int); - host: string; - port: int; - description: bool -> string; - ty: [ `Origin | `Proxy ]; + next_hop_address : Ipaddr.t * int; + host : string; + port : int; + description : bool -> string; + ty : [ `Origin | `Proxy ]; } let get_host req = let uri = Cohttp.Request.uri req in (* A host in the URI takes precedence over a host: header *) - match Uri.host uri, Cohttp.Header.get req.Cohttp.Request.headers "host" with + match + (Uri.host uri, Cohttp.Header.get req.Cohttp.Request.headers "host") + with | None, None -> - Log.warn (fun f -> f "HTTP request had no host in the URI nor in the host: header: %s" - (Sexplib.Sexp.to_string_hum - (Cohttp.Request.sexp_of_t req)) - ); - Error `Missing_host_header - | Some host, _ - | None, Some host -> - (* If the port is missing then it is assumed to be 80 *) - let port = match Uri.port uri with None -> 80 | Some p -> p in - Ok (host, port) - - let route ?(localhost_names=[]) ?(localhost_ips=[]) proxy exclude allow_enabled allow req = + Log.warn (fun f -> + f "HTTP request had no host in the URI nor in the host: header: %s" + (Sexplib.Sexp.to_string_hum (Cohttp.Request.sexp_of_t req))); + Error `Missing_host_header + | Some host, _ | None, Some host -> + (* If the port is missing then it is assumed to be 80 *) + let port = match Uri.port uri with None -> 80 | Some p -> p in + Ok (host, port) + + let route ?(localhost_names = []) ?(localhost_ips = []) proxy exclude + allow_enabled allow req = match get_host req with | Error x -> Lwt.return (Error x) - | Ok (host, port) -> - Log.debug (fun f -> f "host from request = %s:%d" host port); - if allow_enabled && not(Match.matches host allow) - then Lwt.return (Error (`Refused host)) - else - (* A proxy URL must have both a host and a port to be useful *) - let hostport_from_proxy = match proxy with - | None -> None - | Some uri -> - begin match Uri.host uri, Uri.port uri with - | Some host, Some port -> - Log.debug (fun f -> f "upstream proxy is %s:%d" host port); - Some (host, port) - | Some host, None -> - Log.warn (fun f -> f "HTTP proxy %s has no port number" host); - None - | _, _ -> - Log.warn (fun f -> f "HTTP proxy has no host"); - None - end in - let hostport_and_ty = match hostport_from_proxy with - (* No proxy means we must send to the origin server *) - | None -> Some ((host, port), `Origin) - (* If a proxy is configured it depends on whether the request matches the excludes *) - | Some proxy -> - if Match.matches host exclude - then Some ((host, port), `Origin) - else Some (proxy, `Proxy) in - begin match hostport_and_ty with - | None -> - Log.warn (fun f -> f "Failed to route request: %s" (Sexplib.Sexp.to_string_hum (Cohttp.Request.sexp_of_t req))); - Lwt.return (Error `Missing_host_header) - | Some ((next_hop_host, next_hop_port), ty) -> - let next_hop_host = - if List.mem (Dns.Name.of_string next_hop_host) localhost_names - then "localhost" - else next_hop_host in - Log.debug (fun f -> f "next_hop_address is %s:%d" next_hop_host next_hop_port); - resolve_ip next_hop_host - >>= function - | Error (`Msg m) -> - Lwt.return (Error (`Msg m)) - | Ok next_hop_ip -> - let next_hop_ip = - if List.mem next_hop_ip localhost_ips - then Ipaddr.(V4 V4.localhost) - else next_hop_ip in - let description outgoing = - Printf.sprintf "HTTP proxy %s %s:%d Host:%s:%d (%s)" - (if outgoing then "-->" else "<--") (Ipaddr.to_string next_hop_ip) next_hop_port host port - (match ty with `Origin -> "Origin" | `Proxy -> "Proxy") in - Lwt.return (Ok { next_hop_address = (next_hop_ip, next_hop_port); host; port; description; ty }) - end - - let fetch ?localhost_names ?localhost_ips ~flow proxy exclude allow_enabled allow allow_error_msg incoming req = + | Ok (host, port) -> ( + Log.debug (fun f -> f "host from request = %s:%d" host port); + if allow_enabled && not (Match.matches host allow) then + Lwt.return (Error (`Refused host)) + else + (* A proxy URL must have both a host and a port to be useful *) + let hostport_from_proxy = + match proxy with + | None -> None + | Some uri -> ( + match (Uri.host uri, Uri.port uri) with + | Some host, Some port -> + Log.debug (fun f -> f "upstream proxy is %s:%d" host port); + Some (host, port) + | Some host, None -> + Log.warn (fun f -> + f "HTTP proxy %s has no port number" host); + None + | _, _ -> + Log.warn (fun f -> f "HTTP proxy has no host"); + None) + in + let hostport_and_ty = + match hostport_from_proxy with + (* No proxy means we must send to the origin server *) + | None -> Some ((host, port), `Origin) + (* If a proxy is configured it depends on whether the request matches the excludes *) + | Some proxy -> + if Match.matches host exclude then Some ((host, port), `Origin) + else Some (proxy, `Proxy) + in + match hostport_and_ty with + | None -> + Log.warn (fun f -> + f "Failed to route request: %s" + (Sexplib.Sexp.to_string_hum (Cohttp.Request.sexp_of_t req))); + Lwt.return (Error `Missing_host_header) + | Some ((next_hop_host, next_hop_port), ty) -> ( + let next_hop_host = + if List.mem (Dns.Name.of_string next_hop_host) localhost_names + then "localhost" + else next_hop_host + in + Log.debug (fun f -> + f "next_hop_address is %s:%d" next_hop_host next_hop_port); + resolve_ip next_hop_host >>= function + | Error (`Msg m) -> Lwt.return (Error (`Msg m)) + | Ok next_hop_ip -> + let next_hop_ip = + if List.mem next_hop_ip localhost_ips then + Ipaddr.(V4 V4.localhost) + else next_hop_ip + in + let description outgoing = + Printf.sprintf "HTTP proxy %s %s:%d Host:%s:%d (%s)" + (if outgoing then "-->" else "<--") + (Ipaddr.to_string next_hop_ip) + next_hop_port host port + (match ty with `Origin -> "Origin" | `Proxy -> "Proxy") + in + Lwt.return + (Ok + { + next_hop_address = (next_hop_ip, next_hop_port); + host; + port; + description; + ty; + }))) + + let fetch ?localhost_names ?localhost_ips ~flow proxy exclude allow_enabled + allow allow_error_msg incoming req = let uri = Cohttp.Request.uri req in let meth = Cohttp.Request.meth req in route ?localhost_names ?localhost_ips proxy exclude allow_enabled allow req >>= function | Error `Missing_host_header -> - send_error "400" incoming "request must contain an absolute URI" - >>= fun () -> - Lwt.return false + send_error "400" incoming "request must contain an absolute URI" + >>= fun () -> Lwt.return false | Error (`Refused host) -> - send_error "403" incoming (Stringext.replace_all allow_error_msg ~pattern:"%s" ~with_:host) - >>= fun () -> - Lwt.return false + send_error "403" incoming + (Stringext.replace_all allow_error_msg ~pattern:"%s" ~with_:host) + >>= fun () -> Lwt.return false | Error (`Msg m) -> - send_error "503" incoming m - >>= fun () -> - Lwt.return false - | Ok { next_hop_address; host; port; description; ty } -> - Log.info (fun f -> - f "%s: %s %s" - (description true) - (Cohttp.(Code.string_of_method meth)) - (Uri.path uri)); - Log.debug (fun f -> - f "%s: received %s" - (description false) - (Sexplib.Sexp.to_string_hum - (Cohttp.Request.sexp_of_t req)) - ); - begin Remote.connect next_hop_address >>= function - | Error _ -> - let message = match ty with - | `Origin -> Printf.sprintf "unable to connect to %s. Do you need an HTTP proxy?" (string_of_address next_hop_address) - | `Proxy -> Printf.sprintf "unable to connect to HTTP proxy %s" (string_of_address next_hop_address) in - Log.warn (fun f -> f "%s: %s" (description true) message); - send_error "503" incoming message - >>= fun () -> - Lwt.return false - | Ok remote -> - Lwt.finalize (fun () -> - Log.info (fun f -> - f "%s: Successfully connected to %s" (description true) (string_of_address next_hop_address)); - let outgoing = Outgoing.C.create remote in - match ty, Cohttp.Request.meth req with - | `Origin, `CONNECT -> - (* return 200 OK and start a TCP proxy *) - let response = "HTTP/1.1 200 OK\r\n\r\n" in - Incoming.C.write_string incoming response 0 (String.length response); - begin Incoming.C.flush incoming >>= function - | Error _ -> - Log.warn (fun f -> f "%s: failed to return 200 OK" (description false)); - Lwt.return false - | Ok () -> - proxy_bytes ~incoming ~outgoing ~flow ~remote - >>= fun () -> - Log.debug (fun f -> f "%s: HTTP CONNECT complete" (description false)); - Lwt.return false - end - | _, _ -> - (* If the request is to an origin server we should convert back to a relative URI - and a Host: header. - If the request is to a proxy then the URI should be absolute and should match - the Host: header. - In all cases we should make sure the host header is correct. *) - let host_and_port = host ^ (match port with 80 -> "" | _ -> ":" ^ (string_of_int port)) in - let headers = Cohttp.Header.replace req.Cohttp.Request.headers "host" host_and_port in - (* If the request is to a proxy then we should add a Proxy-Authorization header *) - let headers = match proxy with - | None -> headers - | Some proxy -> add_proxy_authorization proxy headers in - let resource = match ty, Cohttp.Request.meth req with - | `Origin, _ -> Uri.path_and_query uri - | `Proxy, `CONNECT -> host_and_port - | `Proxy, _ -> Uri.with_scheme (Uri.with_host (Uri.with_port uri (Some port)) (Some host)) (Some "http") |> Uri.to_string in - let req = { req with Cohttp.Request.headers; resource } in - Log.debug (fun f -> f "%s: sending %s" - (description false) - (Sexplib.Sexp.to_string_hum - (Cohttp.Request.sexp_of_t req)) - ); - proxy_request ~description ~incoming ~outgoing ~flow ~remote ~req - ) (fun () -> Remote.close remote) - end + send_error "503" incoming m >>= fun () -> Lwt.return false + | Ok { next_hop_address; host; port; description; ty } -> ( + Log.info (fun f -> + f "%s: %s %s" (description true) + Cohttp.(Code.string_of_method meth) + (Uri.path uri)); + Log.debug (fun f -> + f "%s: received %s" (description false) + (Sexplib.Sexp.to_string_hum (Cohttp.Request.sexp_of_t req))); + Remote.connect next_hop_address >>= function + | Error _ -> + let message = + match ty with + | `Origin -> + Printf.sprintf + "unable to connect to %s. Do you need an HTTP proxy?" + (string_of_address next_hop_address) + | `Proxy -> + Printf.sprintf "unable to connect to HTTP proxy %s" + (string_of_address next_hop_address) + in + Log.warn (fun f -> f "%s: %s" (description true) message); + send_error "503" incoming message >>= fun () -> Lwt.return false + | Ok remote -> + Lwt.finalize + (fun () -> + Log.info (fun f -> + f "%s: Successfully connected to %s" (description true) + (string_of_address next_hop_address)); + let outgoing = Outgoing.C.create remote in + match (ty, Cohttp.Request.meth req) with + | `Origin, `CONNECT -> ( + (* return 200 OK and start a TCP proxy *) + let response = "HTTP/1.1 200 OK\r\n\r\n" in + Incoming.C.write_string incoming response 0 + (String.length response); + Incoming.C.flush incoming >>= function + | Error _ -> + Log.warn (fun f -> + f "%s: failed to return 200 OK" (description false)); + Lwt.return false + | Ok () -> + proxy_bytes ~incoming ~outgoing ~flow ~remote + >>= fun () -> + Log.debug (fun f -> + f "%s: HTTP CONNECT complete" (description false)); + Lwt.return false) + | _, _ -> + (* If the request is to an origin server we should convert back to a relative URI + and a Host: header. + If the request is to a proxy then the URI should be absolute and should match + the Host: header. + In all cases we should make sure the host header is correct. *) + let host_and_port = + host + ^ + match port with 80 -> "" | _ -> ":" ^ string_of_int port + in + let headers = + Cohttp.Header.replace req.Cohttp.Request.headers "host" + host_and_port + in + (* If the request is to a proxy then we should add a Proxy-Authorization header *) + let headers = + match proxy with + | None -> headers + | Some proxy -> add_proxy_authorization proxy headers + in + let resource = + match (ty, Cohttp.Request.meth req) with + | `Origin, _ -> Uri.path_and_query uri + | `Proxy, `CONNECT -> host_and_port + | `Proxy, _ -> + Uri.with_scheme + (Uri.with_host + (Uri.with_port uri (Some port)) + (Some host)) + (Some "http") + |> Uri.to_string + in + let req = { req with Cohttp.Request.headers; resource } in + Log.debug (fun f -> + f "%s: sending %s" (description false) + (Sexplib.Sexp.to_string_hum + (Cohttp.Request.sexp_of_t req))); + proxy_request ~description ~incoming ~outgoing ~flow ~remote + ~req) + (fun () -> Remote.close remote)) (* A regular, non-transparent HTTP proxy implementation. If [proxy] is [None] then requests will be sent to origin servers; otherwise they will be sent to the upstream proxy. *) - let explicit_proxy ~localhost_names ~localhost_ips proxy exclude allow_enabled allow allow_error_msg () = + let explicit_proxy ~localhost_names ~localhost_ips proxy exclude allow_enabled + allow allow_error_msg () = let listeners _port = Log.debug (fun f -> f "HTTP TCP handshake complete"); let process flow = Lwt.catch (fun () -> - Lwt.finalize (fun () -> + Lwt.finalize + (fun () -> let incoming = Incoming.C.create flow in let rec loop () = Incoming.Request.read incoming >>= function | `Eof -> Lwt.return_unit | `Invalid x -> - Log.warn (fun f -> - f "HTTP proxy failed to parse HTTP request: %s" - x); - Lwt.return_unit - | `Ok req -> - fetch ~localhost_names ~localhost_ips ~flow proxy exclude allow_enabled allow allow_error_msg incoming req - >>= function - | true -> - (* keep the connection open, read more requests *) - loop () - | false -> - Log.debug (fun f -> f "HTTP session complete, closing connection"); - Lwt.return_unit in - loop () - ) (fun () -> Tcp.close flow) - ) (fun e -> - Log.warn (fun f -> f "explicit_proxy caught exception: %s" (Printexc.to_string e)); - Lwt.return_unit - ) + Log.warn (fun f -> + f "HTTP proxy failed to parse HTTP request: %s" x); + Lwt.return_unit + | `Ok req -> ( + fetch ~localhost_names ~localhost_ips ~flow proxy exclude + allow_enabled allow allow_error_msg incoming req + >>= function + | true -> + (* keep the connection open, read more requests *) + loop () + | false -> + Log.debug (fun f -> + f "HTTP session complete, closing connection"); + Lwt.return_unit) + in + loop ()) + (fun () -> Tcp.close flow)) + (fun e -> + Log.warn (fun f -> + f "explicit_proxy caught exception: %s" (Printexc.to_string e)); + Lwt.return_unit) in Some process in Lwt.return listeners - let transparent_http ~dst ~localhost_names ~localhost_ips proxy exclude allow_enabled allow allow_error_msg = + let transparent_http ~dst ~localhost_names ~localhost_ips proxy exclude + allow_enabled allow allow_error_msg = let listeners _port = Log.debug (fun f -> f "HTTP TCP handshake complete"); let process flow = Lwt.catch (fun () -> - Lwt.finalize (fun () -> - let incoming = Incoming.C.create flow in - let rec loop () = - Incoming.Request.read incoming >>= function - | `Eof -> Lwt.return_unit - | `Invalid x -> - Log.warn (fun f -> - f "Failed to parse HTTP request on port %a:80: %s" - Ipaddr.V4.pp dst x); - Lwt.return_unit - | `Ok req -> - (* If there is no Host: header or host in the URI then add a - Host: header with the destination IP address -- this is not perfect - but better than nothing and the majority of people will supply a Host: - header these days because otherwise virtual hosts don't work *) - let req = - match get_host req with - | Error `Missing_host_header -> - { req with Cohttp.Request.headers = Cohttp.Header.replace req.headers "host" (Ipaddr.V4.to_string dst) } - | Ok _ -> req in - fetch ~localhost_names ~localhost_ips ~flow (Some proxy) exclude allow_enabled allow allow_error_msg incoming req - >>= function - | true -> - (* keep the connection open, read more requests *) - loop () - | false -> - Log.debug (fun f -> f "HTTP session complete, closing connection"); - Lwt.return_unit in - loop () - ) (fun () -> Tcp.close flow) - ) (fun e -> - Log.warn (fun f -> f "transparent_http caught exception: %s" (Printexc.to_string e)); - Lwt.return_unit - ) - in Some process + Lwt.finalize + (fun () -> + let incoming = Incoming.C.create flow in + let rec loop () = + Incoming.Request.read incoming >>= function + | `Eof -> Lwt.return_unit + | `Invalid x -> + Log.warn (fun f -> + f "Failed to parse HTTP request on port %a:80: %s" + Ipaddr.V4.pp dst x); + Lwt.return_unit + | `Ok req -> ( + (* If there is no Host: header or host in the URI then add a + Host: header with the destination IP address -- this is not perfect + but better than nothing and the majority of people will supply a Host: + header these days because otherwise virtual hosts don't work *) + let req = + match get_host req with + | Error `Missing_host_header -> + { + req with + Cohttp.Request.headers = + Cohttp.Header.replace req.headers "host" + (Ipaddr.V4.to_string dst); + } + | Ok _ -> req + in + fetch ~localhost_names ~localhost_ips ~flow (Some proxy) + exclude allow_enabled allow allow_error_msg incoming req + >>= function + | true -> + (* keep the connection open, read more requests *) + loop () + | false -> + Log.debug (fun f -> + f "HTTP session complete, closing connection"); + Lwt.return_unit) + in + loop ()) + (fun () -> Tcp.close flow)) + (fun e -> + Log.warn (fun f -> + f "transparent_http caught exception: %s" (Printexc.to_string e)); + Lwt.return_unit) + in + Some process in Lwt.return listeners - let transparent_proxy_handler ~localhost_names ~localhost_ips ~dst:(ip, port) ~t = - match t.http, t.https with - | Some proxy, _ when List.mem port t.transparent_http_ports -> Some (transparent_http ~dst:ip ~localhost_names ~localhost_ips proxy t.exclude t.allow_enabled t.allow t.allow_error_msg) + let transparent_proxy_handler ~localhost_names ~localhost_ips ~dst:(ip, port) + ~t = + match (t.http, t.https) with + | Some proxy, _ when List.mem port t.transparent_http_ports -> + Some + (transparent_http ~dst:ip ~localhost_names ~localhost_ips proxy + t.exclude t.allow_enabled t.allow t.allow_error_msg) | _, Some proxy when List.mem port t.transparent_https_ports -> - if Match.matches (Ipaddr.V4.to_string ip) t.exclude - then None - else Some (tunnel_https_over_connect ~localhost_names ~localhost_ips ~dst:ip proxy) + if Match.matches (Ipaddr.V4.to_string ip) t.exclude then None + else + Some + (tunnel_https_over_connect ~localhost_names ~localhost_ips ~dst:ip + proxy) | _, _ -> None let explicit_proxy_handler ~localhost_names ~localhost_ips ~dst:(_, port) ~t = - match port, t.http, t.https with - | 3128, proxy, _ - | 3129, _, proxy -> Some (explicit_proxy ~localhost_names ~localhost_ips proxy t.exclude t.allow_enabled t.allow t.allow_error_msg ()) + match (port, t.http, t.https) with + | 3128, proxy, _ | 3129, _, proxy -> + Some + (explicit_proxy ~localhost_names ~localhost_ips proxy t.exclude + t.allow_enabled t.allow t.allow_error_msg ()) (* For other ports, refuse the connection *) | _, _, _ -> None end File "src/hostnet_test/forwarding.ml", line 1, characters 0-0: diff --git a/_build/default/src/hostnet_test/forwarding.ml b/_build/default/src/hostnet_test/.formatted/forwarding.ml index ef2533f..2d03f17 100644 --- a/_build/default/src/hostnet_test/forwarding.ml +++ b/_build/default/src/hostnet_test/.formatted/forwarding.ml @@ -7,202 +7,217 @@ let src = module Log = (val Logs.src_log src : Logs.LOG) -let (>>*=) m f = m >>= function - | Ok x -> f x - | Error (`Msg m) -> failwith m +let ( >>*= ) m f = m >>= function Ok x -> f x | Error (`Msg m) -> failwith m -let run ?(timeout=Duration.of_sec 60) t = +let run ?(timeout = Duration.of_sec 60) t = let timeout = - Host.Time.sleep_ns timeout >>= fun () -> - Lwt.fail_with "timeout" + Host.Time.sleep_ns timeout >>= fun () -> Lwt.fail_with "timeout" in Host.Main.run @@ Lwt.pick [ timeout; t ] -module Channel = Mirage_channel.Make(Host.Sockets.Stream.Tcp) +module Channel = Mirage_channel.Make (Host.Sockets.Stream.Tcp) module ForwardServer = struct (** Accept connections, read the forwarding header and run a proxy. This is a minimal "vpnkit-forwarder" *) - module Mux = Forwarder.Multiplexer.Make(Host.Sockets.Stream.Tcp) + module Mux = Forwarder.Multiplexer.Make (Host.Sockets.Stream.Tcp) module Proxy = - Mirage_flow_combinators.Proxy - (Mclock)(Mux.Channel)(Host.Sockets.Stream.Tcp) + Mirage_flow_combinators.Proxy (Mclock) (Mux.Channel) + (Host.Sockets.Stream.Tcp) let accept flow = let forever, _u = Lwt.task () in - let _mux = Mux.connect flow "ForwardServer" - (fun client_flow destination -> - let open Forwarder.Frame.Destination in - Log.info (fun f -> f "ForwardServer.connect to %s" (to_string destination)); - match destination with - | `Tcp(ip, port) -> begin - Host.Sockets.Stream.Tcp.connect (ip, port) >>= function - | Error (`Msg x) -> failwith x - | Ok remote -> - Lwt.finalize (fun () -> - Proxy.proxy client_flow remote >>= function - | Error e -> Fmt.kstr failwith "%a" Proxy.pp_error e - | Ok (_l_stats, _r_stats) -> Lwt.return () - ) (fun () -> - Host.Sockets.Stream.Tcp.close remote - ) - end - | `Udp(ip, port) -> begin - Host.Sockets.Datagram.Udp.connect (ip, port) >>= function - | Error (`Msg x) -> failwith x - | Ok remote -> - let from_vsock_buffer = Cstruct.create (Constants.max_udp_length + Forwarder.Frame.Udp.max_sizeof) in - (* A NAT table with one entry *) - let from = ref None in - let rec vsock2internet () = - let read_into flow buf = - Mux.Channel.read_into flow buf >>= function - | Ok `Eof -> Lwt.fail End_of_file - | Error e -> Fmt.kstr Lwt.fail_with "%a" Mux.Channel.pp_error e - | Ok (`Data ()) -> Lwt.return () in - let read_next () = - read_into client_flow (Cstruct.sub from_vsock_buffer 0 2) >>= fun () -> - let frame_length = Cstruct.LE.get_uint16 from_vsock_buffer 0 in - if frame_length > (Cstruct.length from_vsock_buffer) then begin - Log.err (fun f -> - f "UDP encapsulated frame length is %d but buffer has length %d: \ - dropping" frame_length (Cstruct.length from_vsock_buffer)); - Lwt.return None - end else begin - let rest = Cstruct.sub from_vsock_buffer 2 (frame_length - 2) in - read_into client_flow rest >|= fun () -> - let udp, payload = Forwarder.Frame.Udp.read from_vsock_buffer in - Some (payload, (udp.Forwarder.Frame.Udp.ip, udp.Forwarder.Frame.Udp.port)) - end in - read_next () - >>= function - | None -> vsock2internet () - | Some (payload, (ip, port)) -> - from := Some (ip, port); - Host.Sockets.Datagram.Udp.write remote payload - >>= function - | Error _ -> Lwt.return_unit - | Ok () -> - vsock2internet () in - let write_header_buffer = Cstruct.create (Constants.max_udp_length + Forwarder.Frame.Udp.max_sizeof) in - let rec internet2vsock () = - let write flow buf = - Mux.Channel.write flow buf >>= function - | Error `Closed -> Lwt.fail End_of_file - | Error e -> Fmt.kstr Lwt.fail_with "%a" Mux.Channel.pp_write_error e - | Ok () -> Lwt.return () in - Host.Sockets.Datagram.Udp.read remote - >>= function - | Ok `Eof -> Lwt.return_unit - | Error _ -> Lwt.return_unit - | Ok (`Data buf) -> - begin match !from with - | None -> - Log.info (fun f -> f "ForwardServer dropping datagram, no from address"); - internet2vsock () - | Some (ip, port) -> - let udp = Forwarder.Frame.Udp.({ - ip; port; - payload_length = Cstruct.length buf; - }) in - let header = Forwarder.Frame.Udp.write_header udp write_header_buffer in - write client_flow header - >>= fun () -> - write client_flow buf - >>= fun () -> - internet2vsock () - end in - Lwt.pick [ vsock2internet (); internet2vsock () ] - end - | `Unix _ -> failwith "We don't simulate Unix paths" - ) in + let _mux = + Mux.connect flow "ForwardServer" (fun client_flow destination -> + let open Forwarder.Frame.Destination in + Log.info (fun f -> + f "ForwardServer.connect to %s" (to_string destination)); + match destination with + | `Tcp (ip, port) -> ( + Host.Sockets.Stream.Tcp.connect (ip, port) >>= function + | Error (`Msg x) -> failwith x + | Ok remote -> + Lwt.finalize + (fun () -> + Proxy.proxy client_flow remote >>= function + | Error e -> Fmt.kstr failwith "%a" Proxy.pp_error e + | Ok (_l_stats, _r_stats) -> Lwt.return ()) + (fun () -> Host.Sockets.Stream.Tcp.close remote)) + | `Udp (ip, port) -> ( + Host.Sockets.Datagram.Udp.connect (ip, port) >>= function + | Error (`Msg x) -> failwith x + | Ok remote -> + let from_vsock_buffer = + Cstruct.create + (Constants.max_udp_length + Forwarder.Frame.Udp.max_sizeof) + in + (* A NAT table with one entry *) + let from = ref None in + let rec vsock2internet () = + let read_into flow buf = + Mux.Channel.read_into flow buf >>= function + | Ok `Eof -> Lwt.fail End_of_file + | Error e -> + Fmt.kstr Lwt.fail_with "%a" Mux.Channel.pp_error e + | Ok (`Data ()) -> Lwt.return () + in + let read_next () = + read_into client_flow (Cstruct.sub from_vsock_buffer 0 2) + >>= fun () -> + let frame_length = + Cstruct.LE.get_uint16 from_vsock_buffer 0 + in + if frame_length > Cstruct.length from_vsock_buffer then ( + Log.err (fun f -> + f + "UDP encapsulated frame length is %d but buffer \ + has length %d: dropping" + frame_length + (Cstruct.length from_vsock_buffer)); + Lwt.return None) + else + let rest = + Cstruct.sub from_vsock_buffer 2 (frame_length - 2) + in + read_into client_flow rest >|= fun () -> + let udp, payload = + Forwarder.Frame.Udp.read from_vsock_buffer + in + Some + ( payload, + ( udp.Forwarder.Frame.Udp.ip, + udp.Forwarder.Frame.Udp.port ) ) + in + read_next () >>= function + | None -> vsock2internet () + | Some (payload, (ip, port)) -> ( + from := Some (ip, port); + Host.Sockets.Datagram.Udp.write remote payload + >>= function + | Error _ -> Lwt.return_unit + | Ok () -> vsock2internet ()) + in + let write_header_buffer = + Cstruct.create + (Constants.max_udp_length + Forwarder.Frame.Udp.max_sizeof) + in + let rec internet2vsock () = + let write flow buf = + Mux.Channel.write flow buf >>= function + | Error `Closed -> Lwt.fail End_of_file + | Error e -> + Fmt.kstr Lwt.fail_with "%a" Mux.Channel.pp_write_error + e + | Ok () -> Lwt.return () + in + Host.Sockets.Datagram.Udp.read remote >>= function + | Ok `Eof -> Lwt.return_unit + | Error _ -> Lwt.return_unit + | Ok (`Data buf) -> ( + match !from with + | None -> + Log.info (fun f -> + f + "ForwardServer dropping datagram, no from \ + address"); + internet2vsock () + | Some (ip, port) -> + let udp = + Forwarder.Frame.Udp. + { + ip; + port; + payload_length = Cstruct.length buf; + } + in + let header = + Forwarder.Frame.Udp.write_header udp + write_header_buffer + in + write client_flow header >>= fun () -> + write client_flow buf >>= fun () -> + internet2vsock ()) + in + Lwt.pick [ vsock2internet (); internet2vsock () ]) + | `Unix _ -> failwith "We don't simulate Unix paths") + in forever let port = Host.Sockets.Stream.Tcp.bind (Ipaddr.V4 Ipaddr.V4.localhost, 0) >>= fun server -> - Host.Sockets.Stream.Tcp.getsockname server - >>= fun (_, local_port) -> + Host.Sockets.Stream.Tcp.getsockname server >>= fun (_, local_port) -> Host.Sockets.Stream.Tcp.listen server accept; Lwt.return local_port - type t = { - local_port: int; - server: Host.Sockets.Stream.Tcp.server; - } + type t = { local_port : int; server : Host.Sockets.Stream.Tcp.server } end -module Forward = Forward.Make(Mclock)(struct - include Host.Sockets.Stream.Tcp +module Forward = + Forward.Make + (Mclock) + (struct + include Host.Sockets.Stream.Tcp + open Lwt.Infix - open Lwt.Infix - - let connect () = - ForwardServer.port >>= fun port -> - Host.Sockets.Stream.Tcp.connect (Ipaddr.V4 Ipaddr.V4.localhost, port) - >>= function - | Error (`Msg m) -> failwith m - | Ok x -> Lwt.return x - end)(Host.Sockets) + let connect () = + ForwardServer.port >>= fun port -> + Host.Sockets.Stream.Tcp.connect (Ipaddr.V4 Ipaddr.V4.localhost, port) + >>= function + | Error (`Msg m) -> failwith m + | Ok x -> Lwt.return x + end) + (Host.Sockets) let localhost = Ipaddr.V4.localhost module PortsServer = struct - module Ports = Active_list.Make(Forward) - module Server = Protocol_9p.Server.Make(Log)(Host.Sockets.Stream.Tcp)(Ports) + module Ports = Active_list.Make (Forward) + + module Server = + Protocol_9p.Server.Make (Log) (Host.Sockets.Stream.Tcp) (Ports) let with_server f = let ports = Ports.make () in - Host.Sockets.Stream.Tcp.bind (Ipaddr.V4 localhost, 0) - >>= fun server -> - Host.Sockets.Stream.Tcp.getsockname server - >>= fun (_, port) -> - Host.Sockets.Stream.Tcp.listen server - (fun conn -> - Server.connect ports conn () - >>= function - | Error (`Msg m) -> - Log.err (fun f -> f "failed to establish 9P connection: %s" m); - Lwt.return () - | Ok server -> - Server.after_disconnect server - ); - f port - >>= fun () -> - Host.Sockets.Stream.Tcp.shutdown server + Host.Sockets.Stream.Tcp.bind (Ipaddr.V4 localhost, 0) >>= fun server -> + Host.Sockets.Stream.Tcp.getsockname server >>= fun (_, port) -> + Host.Sockets.Stream.Tcp.listen server (fun conn -> + Server.connect ports conn () >>= function + | Error (`Msg m) -> + Log.err (fun f -> f "failed to establish 9P connection: %s" m); + Lwt.return () + | Ok server -> Server.after_disconnect server); + f port >>= fun () -> Host.Sockets.Stream.Tcp.shutdown server end module LocalTCPClient = struct let connect (ip, port) = - Host.Sockets.Stream.Tcp.connect (Ipaddr.V4 ip, port) - >>= function + Host.Sockets.Stream.Tcp.connect (Ipaddr.V4 ip, port) >>= function | Ok fd -> Lwt.return fd | Error (`Msg m) -> failwith m + let disconnect fd = Host.Sockets.Stream.Tcp.close fd end let read_http ch = let rec loop acc = Channel.read_line ch >>= function - | Ok `Eof - | Error _ -> Lwt.return acc + | Ok `Eof | Error _ -> Lwt.return acc | Ok (`Data bufs) -> - let txt = Cstruct.(to_string (concat bufs)) in - if txt = "" - then Lwt.return acc - else loop (acc ^ txt) + let txt = Cstruct.(to_string (concat bufs)) in + if txt = "" then Lwt.return acc else loop (acc ^ txt) in loop "" module LocalUDPClient = struct let connect (ip, port) = Log.info (fun f -> f "LocalUDPClient.connect to port %d" port); - Host.Sockets.Datagram.Udp.connect (Ipaddr.V4 ip, port) - >>= function + Host.Sockets.Datagram.Udp.connect (Ipaddr.V4 ip, port) >>= function | Ok fd -> Lwt.return fd | Error (`Msg m) -> failwith m + let disconnect fd = Host.Sockets.Datagram.Udp.close fd end @@ -214,73 +229,62 @@ let udp_echo t len = let sender () = let rec loop () = Log.info (fun f -> f "Sending UDP echo"); - Host.Sockets.Datagram.Udp.write t pattern - >>= function + Host.Sockets.Datagram.Udp.write t pattern >>= function | Error _ -> Lwt.fail_with "Datagram.Udp.write error" - | Ok () -> - Host.Time.sleep_ns (Duration.of_sec 1) - >>= fun () -> - loop () in - loop () in + | Ok () -> Host.Time.sleep_ns (Duration.of_sec 1) >>= fun () -> loop () + in + loop () + in let receiver () = - Host.Sockets.Datagram.Udp.read t - >>= function + Host.Sockets.Datagram.Udp.read t >>= function | Ok (`Data buf) -> - Log.info (fun f -> f "Received UDP echo"); - if Cstruct.compare pattern buf <> 0 then begin - Printf.printf "pattern = \n"; - Cstruct.hexdump pattern; - Printf.printf "buf =\n"; - Cstruct.hexdump buf; - Lwt.fail_with "udp echo corrupt" - end else Lwt.return_unit - | Ok `Eof -> - Lwt.fail_with "Datagram.Udp.read `Eof" - | Error _ -> - Lwt.fail_with "Datagram.Udp.read Error" in + Log.info (fun f -> f "Received UDP echo"); + if Cstruct.compare pattern buf <> 0 then ( + Printf.printf "pattern = \n"; + Cstruct.hexdump pattern; + Printf.printf "buf =\n"; + Cstruct.hexdump buf; + Lwt.fail_with "udp echo corrupt") + else Lwt.return_unit + | Ok `Eof -> Lwt.fail_with "Datagram.Udp.read `Eof" + | Error _ -> Lwt.fail_with "Datagram.Udp.read Error" + in let timeout () = - Host.Time.sleep_ns (Duration.of_sec 5) - >>= fun () -> - Lwt.fail_with "udp_echo timeout" in + Host.Time.sleep_ns (Duration.of_sec 5) >>= fun () -> + Lwt.fail_with "udp_echo timeout" + in Lwt.pick [ sender (); receiver (); timeout () ] module LocalTCPServer = struct - type t = { - local_port: int; - server: Host.Sockets.Stream.Tcp.server; - } + type t = { local_port : int; server : Host.Sockets.Stream.Tcp.server } let accept flow = let ch = Channel.create flow in read_http ch >>= fun request -> - if not(Astring.String.is_prefix ~affix:"GET" request) - then failwith (Printf.sprintf "unrecognised HTTP GET: [%s]" request); + if not (Astring.String.is_prefix ~affix:"GET" request) then + failwith (Printf.sprintf "unrecognised HTTP GET: [%s]" request); let response = "HTTP/1.0 404 Not found\r\ncontent-length: 0\r\n\r\n" in Channel.write_string ch response 0 (String.length response); Channel.flush ch >|= function - | Ok () -> () + | Ok () -> () | Error e -> Fmt.kstr failwith "%a" Channel.pp_write_error e let create () = - Host.Sockets.Stream.Tcp.bind (Ipaddr.V4 localhost, 0) - >>= fun server -> - Host.Sockets.Stream.Tcp.getsockname server - >|= fun (_, local_port) -> + Host.Sockets.Stream.Tcp.bind (Ipaddr.V4 localhost, 0) >>= fun server -> + Host.Sockets.Stream.Tcp.getsockname server >|= fun (_, local_port) -> Host.Sockets.Stream.Tcp.listen server accept; { local_port; server } let to_string t = Printf.sprintf "tcp:127.0.0.1:%d" t.local_port let destroy t = Host.Sockets.Stream.Tcp.shutdown t.server + let with_server f = create () >>= fun server -> Lwt.finalize (fun () -> f server) (fun () -> destroy server) end module LocalUDPServer = struct - type t = { - local_port: int; - server: Host.Sockets.Datagram.Udp.server; - } + type t = { local_port : int; server : Host.Sockets.Datagram.Udp.server } let echo server = let from_internet_buffer = Cstruct.create Constants.max_udp_length in @@ -290,50 +294,45 @@ module LocalUDPServer = struct >>= fun (len, address) -> Log.info (fun f -> f "LocalUDPServer received len = %d" len); let buf = Cstruct.sub from_internet_buffer 0 len in - Host.Sockets.Datagram.Udp.sendto server address buf - >>= fun () -> + Host.Sockets.Datagram.Udp.sendto server address buf >>= fun () -> Log.info (fun f -> f "LocalUDPServer received len = %d" len); - loop () in - Lwt.async - (fun () -> - Lwt.catch loop - (fun _e -> - Log.info (fun f -> f "LocalUDPServer echo shutting down"); - Lwt.return_unit - ) - ) + loop () + in + Lwt.async (fun () -> + Lwt.catch loop (fun _e -> + Log.info (fun f -> f "LocalUDPServer echo shutting down"); + Lwt.return_unit)) let create () = - Host.Sockets.Datagram.Udp.bind (Ipaddr.V4 localhost, 0) - >>= fun server -> - Host.Sockets.Datagram.Udp.getsockname server - >|= fun (_, local_port) -> + Host.Sockets.Datagram.Udp.bind (Ipaddr.V4 localhost, 0) >>= fun server -> + Host.Sockets.Datagram.Udp.getsockname server >|= fun (_, local_port) -> Log.info (fun f -> f "UDP local_port=%d" local_port); echo server; { local_port; server } let to_string t = Printf.sprintf "udp:127.0.0.1:%d" t.local_port let destroy t = Host.Sockets.Datagram.Udp.shutdown t.server + let with_server f = create () >>= fun server -> - Lwt.finalize (fun () -> f server) (fun () -> Log.info (fun f -> f "LocalUDPServer closing server socket"); destroy server) + Lwt.finalize + (fun () -> f server) + (fun () -> + Log.info (fun f -> f "LocalUDPServer closing server socket"); + destroy server) end module ForwardControl = struct module Log = (val Logs.src_log Logs.default) - module Client = Protocol_9p.Client.Make(Log)(Host.Sockets.Stream.Tcp) + module Client = Protocol_9p.Client.Make (Log) (Host.Sockets.Stream.Tcp) - type t = { - ninep: Client.t - } + type t = { ninep : Client.t } let connect ports_port = Host.Sockets.Stream.Tcp.connect (Ipaddr.V4 localhost, ports_port) >>= function | Error (`Msg m) -> failwith m - | Ok flow -> - Client.connect flow () >>*= fun ninep -> - Lwt.return { ninep } + | Ok flow -> Client.connect flow () >>*= fun ninep -> Lwt.return { ninep } let disconnect { ninep } = Client.disconnect ninep @@ -342,49 +341,49 @@ module ForwardControl = struct Lwt.finalize (fun () -> f c) (fun () -> disconnect c) type forward = { - t: t; - fid: Protocol_9p.Types.Fid.t; - ip: Ipaddr.V4.t; - port: int; + t : t; + fid : Protocol_9p.Types.Fid.t; + ip : Ipaddr.V4.t; + port : int; } let create t string = - let mode = Protocol_9p.Types.FileMode.make ~is_directory:true - ~owner:[`Read; `Write; `Execute] ~group:[`Read; `Execute] - ~other:[`Read; `Execute ] () in - Client.mkdir t.ninep [] string mode - >>*= fun () -> - Client.LowLevel.allocate_fid t.ninep - >>*= fun fid -> - Client.walk_from_root t.ninep fid [ string; "ctl" ] - >>*= fun _walk -> + let mode = + Protocol_9p.Types.FileMode.make ~is_directory:true + ~owner:[ `Read; `Write; `Execute ] + ~group:[ `Read; `Execute ] + ~other:[ `Read; `Execute ] + () + in + Client.mkdir t.ninep [] string mode >>*= fun () -> + Client.LowLevel.allocate_fid t.ninep >>*= fun fid -> + Client.walk_from_root t.ninep fid [ string; "ctl" ] >>*= fun _walk -> Client.LowLevel.openfid t.ninep fid Protocol_9p.Types.OpenMode.read_write >>*= fun _open -> let buf = Cstruct.create (String.length string) in Cstruct.blit_from_string string 0 buf 0 (String.length string); - Client.LowLevel.write t.ninep fid 0L buf - >>*= fun _write -> - Client.LowLevel.read t.ninep fid 0L 1024l - >>*= fun read -> + Client.LowLevel.write t.ninep fid 0L buf >>*= fun _write -> + Client.LowLevel.read t.ninep fid 0L 1024l >>*= fun read -> let response = Cstruct.to_string read.Protocol_9p.Response.Read.data in - if Astring.String.is_prefix ~affix:"OK " response then begin + if Astring.String.is_prefix ~affix:"OK " response then let line = String.sub response 3 (String.length response - 3) in (* tcp:127.0.0.1:64500:tcp:127.0.0.1:64499 *) match Astring.String.cuts ~sep:":" line with | ("tcp" | "udp") :: ip :: port :: _ -> - let port = int_of_string port in - let ip = Ipaddr.V4.of_string_exn ip in - Lwt.return { t; fid; ip; port } + let port = int_of_string port in + let ip = Ipaddr.V4.of_string_exn ip in + Lwt.return { t; fid; ip; port } | _ -> failwith ("failed to parse response: " ^ line) - end else failwith response + else failwith response + let destroy { t; fid; _ } = - Client.LowLevel.clunk t.ninep fid - >>*= fun _clunk -> - Lwt.return () + Client.LowLevel.clunk t.ninep fid >>*= fun _clunk -> Lwt.return () + let with_forward t string f = - create t string - >>= fun forward -> - Lwt.finalize (fun () -> f forward.ip forward.port) (fun () -> destroy forward) + create t string >>= fun forward -> + Lwt.finalize + (fun () -> f forward.ip forward.port) + (fun () -> destroy forward) end let http_get flow = @@ -393,110 +392,106 @@ let http_get flow = Channel.write_string ch message 0 (String.length message); Channel.flush ch >>= function | Error e -> Fmt.kstr failwith "%a" Channel.pp_write_error e - | Ok () -> - Host.Sockets.Stream.Tcp.shutdown_write flow - >>= fun () -> - read_http ch - >|= fun response -> - if not(Astring.String.is_prefix ~affix:"HTTP" response) - then failwith (Printf.sprintf "unrecognised HTTP response: [%s]" response) + | Ok () -> + Host.Sockets.Stream.Tcp.shutdown_write flow >>= fun () -> + read_http ch >|= fun response -> + if not (Astring.String.is_prefix ~affix:"HTTP" response) then + failwith (Printf.sprintf "unrecognised HTTP response: [%s]" response) let test_one_tcp_forward () = - let t = LocalTCPServer.with_server (fun server -> - PortsServer.with_server (fun ports_port -> - ForwardControl.with_connection ports_port (fun connection -> - let name = "tcp:127.0.0.1:0:" ^ LocalTCPServer.to_string server in - ForwardControl.with_forward connection name (fun ip port -> - LocalTCPClient.connect (ip, port) - >>= fun client -> - http_get client - >>= fun () -> - LocalTCPClient.disconnect client - ) - ) - ) - ) in + let t = + LocalTCPServer.with_server (fun server -> + PortsServer.with_server (fun ports_port -> + ForwardControl.with_connection ports_port (fun connection -> + let name = + "tcp:127.0.0.1:0:" ^ LocalTCPServer.to_string server + in + ForwardControl.with_forward connection name (fun ip port -> + LocalTCPClient.connect (ip, port) >>= fun client -> + http_get client >>= fun () -> + LocalTCPClient.disconnect client)))) + in run t let test_one_udp_forward () = - let t = LocalUDPServer.with_server (fun server -> - PortsServer.with_server (fun ports_port -> - ForwardControl.with_connection ports_port (fun connection -> - let name = "udp:127.0.0.1:0:" ^ LocalUDPServer.to_string server in - ForwardControl.with_forward connection name (fun ip port -> - LocalUDPClient.connect (ip, port) - >>= fun client -> - udp_echo client 512 - >>= fun () -> - LocalUDPClient.disconnect client - ) - ) - ) - ) in + let t = + LocalUDPServer.with_server (fun server -> + PortsServer.with_server (fun ports_port -> + ForwardControl.with_connection ports_port (fun connection -> + let name = + "udp:127.0.0.1:0:" ^ LocalUDPServer.to_string server + in + ForwardControl.with_forward connection name (fun ip port -> + LocalUDPClient.connect (ip, port) >>= fun client -> + udp_echo client 512 >>= fun () -> + LocalUDPClient.disconnect client)))) + in run t -let interesting_sizes = [ - (* on macOS the maximum we can send is given by $(sysctl net.inet.udp.maxdgram) - which seems to be 9216 for me *) - 1; 4; 511; 1023; 2034; 2035; 4095; 8191; 9215; 9216; -] +let interesting_sizes = + [ + (* on macOS the maximum we can send is given by $(sysctl net.inet.udp.maxdgram) + which seems to be 9216 for me *) + 1; + 4; + 511; + 1023; + 2034; + 2035; + 4095; + 8191; + 9215; + 9216; + ] let test_large_udp_forwards () = - let t = LocalUDPServer.with_server (fun server -> - PortsServer.with_server (fun ports_port -> - ForwardControl.with_connection ports_port (fun connection -> - let name = "udp:127.0.0.1:0:" ^ LocalUDPServer.to_string server in - ForwardControl.with_forward connection name (fun ip port -> - LocalUDPClient.connect (ip, port) - >>= fun client -> - Lwt_list.iter_s - (fun size -> - udp_echo client size - ) interesting_sizes - >>= fun () -> - LocalUDPClient.disconnect client - ) - ) - ) - ) in + let t = + LocalUDPServer.with_server (fun server -> + PortsServer.with_server (fun ports_port -> + ForwardControl.with_connection ports_port (fun connection -> + let name = + "udp:127.0.0.1:0:" ^ LocalUDPServer.to_string server + in + ForwardControl.with_forward connection name (fun ip port -> + LocalUDPClient.connect (ip, port) >>= fun client -> + Lwt_list.iter_s + (fun size -> udp_echo client size) + interesting_sizes + >>= fun () -> LocalUDPClient.disconnect client)))) + in run t let test_10_tcp_connections () = - let t = LocalTCPServer.with_server (fun server -> - PortsServer.with_server (fun ports_port -> - ForwardControl.with_connection ports_port (fun connection -> - let name = "tcp:127.0.0.1:0:" ^ LocalTCPServer.to_string server in - ForwardControl.with_forward connection name (fun ip port -> - let rec loop = function - | 0 -> Lwt.return () - | n -> - LocalTCPClient.connect (ip, port) - >>= fun client -> - http_get client - >>= fun () -> - LocalTCPClient.disconnect client - >>= fun () -> - loop (n - 1) - in - let start = Unix.gettimeofday () in - loop 10 - >>= fun () -> - let time = Unix.gettimeofday () -. start in - (* NOTE(djs55): on my MBP this is almost immediate *) - if time > 1. then - Fmt.kstr failwith "10 connections took %.02f (> 1) \ - seconds" time; - Lwt.return () - ) - ) - ) - ) in + let t = + LocalTCPServer.with_server (fun server -> + PortsServer.with_server (fun ports_port -> + ForwardControl.with_connection ports_port (fun connection -> + let name = + "tcp:127.0.0.1:0:" ^ LocalTCPServer.to_string server + in + ForwardControl.with_forward connection name (fun ip port -> + let rec loop = function + | 0 -> Lwt.return () + | n -> + LocalTCPClient.connect (ip, port) >>= fun client -> + http_get client >>= fun () -> + LocalTCPClient.disconnect client >>= fun () -> + loop (n - 1) + in + let start = Unix.gettimeofday () in + loop 10 >>= fun () -> + let time = Unix.gettimeofday () -. start in + (* NOTE(djs55): on my MBP this is almost immediate *) + if time > 1. then + Fmt.kstr failwith + "10 connections took %.02f (> 1) seconds" time; + Lwt.return ())))) + in run t -let run_test ?(timeout=Duration.of_sec 60) t = +let run_test ?(timeout = Duration.of_sec 60) t = let timeout = - Host.Time.sleep_ns timeout >>= fun () -> - Lwt.fail_with "timeout" + Host.Time.sleep_ns timeout >>= fun () -> Lwt.fail_with "timeout" in Host.Main.run @@ Lwt.pick [ timeout; t ] @@ -505,78 +500,89 @@ let run ?timeout ~pcap t = run_test ?timeout (Slirp_stack.with_stack ~pcap t) (* Test the --tcpv4-forwards gateway forwarding option *) let test_tcpv4_forwarded_configuration () = let t _ stack = - Host.Sockets.Stream.Tcp.bind (Ipaddr.V4 Ipaddr.V4.localhost, Slirp_stack.local_tcpv4_forwarded_port) + Host.Sockets.Stream.Tcp.bind + (Ipaddr.V4 Ipaddr.V4.localhost, Slirp_stack.local_tcpv4_forwarded_port) >>= fun server -> Lwt.finalize (fun () -> Host.Sockets.Stream.Tcp.listen server LocalTCPServer.accept; let open Slirp_stack in - Client.TCPV4.create_connection (Client.tcpv4 stack.Client.t) (primary_dns_ip, local_tcpv4_forwarded_port) + Client.TCPV4.create_connection + (Client.tcpv4 stack.Client.t) + (primary_dns_ip, local_tcpv4_forwarded_port) >>= function | Error _ -> - Log.err (fun f -> f "Failed to connect to gateway:%d" local_tcpv4_forwarded_port); - failwith "http_fetch" - | Ok flow -> - Log.info (fun f -> f "Connected to gateway:%d" local_tcpv4_forwarded_port); - let page = Io_page.(to_cstruct (get 1)) in - let http_get = "GET / HTTP/1.0\nHost: dave.recoil.org\n\n" in - Cstruct.blit_from_string http_get 0 page 0 (String.length http_get); - let buf = Cstruct.sub page 0 (String.length http_get) in - Client.TCPV4.write flow buf >>= function - | Error `Closed -> - Log.err (fun f -> - f "EOF writing HTTP request to gateway:%d" local_tcpv4_forwarded_port); - failwith "EOF on writing HTTP GET" - | Error _ -> Log.err (fun f -> - f "Failure writing HTTP request to gateway:%d" local_tcpv4_forwarded_port); - failwith "Failure on writing HTTP GET" - | Ok () -> - let rec loop total_bytes = - Client.TCPV4.read flow >>= function - | Ok `Eof -> Lwt.return total_bytes - | Error _ -> + f "Failed to connect to gateway:%d" local_tcpv4_forwarded_port); + failwith "http_fetch" + | Ok flow -> ( + Log.info (fun f -> + f "Connected to gateway:%d" local_tcpv4_forwarded_port); + let page = Io_page.(to_cstruct (get 1)) in + let http_get = "GET / HTTP/1.0\nHost: dave.recoil.org\n\n" in + Cstruct.blit_from_string http_get 0 page 0 (String.length http_get); + let buf = Cstruct.sub page 0 (String.length http_get) in + Client.TCPV4.write flow buf >>= function + | Error `Closed -> Log.err (fun f -> - f "Failure read HTTP response from gateway:%d" local_tcpv4_forwarded_port); - failwith "Failure on reading HTTP GET" - | Ok (`Data buf) -> - Log.info (fun f -> - f "Read %d bytes from gateway:%d" (Cstruct.length buf) local_tcpv4_forwarded_port); - Log.info (fun f -> f "%s" (Cstruct.to_string buf)); - loop (total_bytes + (Cstruct.length buf)) - in - loop 0 >|= fun total_bytes -> - Log.info (fun f -> f "Response had %d total bytes" total_bytes); - ) (fun () -> - Host.Sockets.Stream.Tcp.shutdown server - ) - in - run ~pcap:"test_tcpv4_forwarded_configuration" t - - -let tests = [ - "Ports: 1 TCP port forward", - [ "Perform an HTTP GET through a port forward", - `Quick, - test_one_tcp_forward ]; - - "Ports: 10 TCP port forwards", - [ "Perform 10 HTTP GETs through a port forward", - `Quick, - test_10_tcp_connections ]; - - "Ports: 1 UDP port forward", - [ "Send a UDP packet through a port forward", - `Quick, - test_one_udp_forward ]; - - "Ports: large UDP packets through a port forward", - [ "Send large UDP packets through a port forward", - `Quick, - test_large_udp_forwards ]; - - "Ports: check --tcpv4-forwards option", - [ "Connect to a local server", - `Quick, - test_tcpv4_forwarded_configuration ]; -] + f "EOF writing HTTP request to gateway:%d" + local_tcpv4_forwarded_port); + failwith "EOF on writing HTTP GET" + | Error _ -> + Log.err (fun f -> + f "Failure writing HTTP request to gateway:%d" + local_tcpv4_forwarded_port); + failwith "Failure on writing HTTP GET" + | Ok () -> + let rec loop total_bytes = + Client.TCPV4.read flow >>= function + | Ok `Eof -> Lwt.return total_bytes + | Error _ -> + Log.err (fun f -> + f "Failure read HTTP response from gateway:%d" + local_tcpv4_forwarded_port); + failwith "Failure on reading HTTP GET" + | Ok (`Data buf) -> + Log.info (fun f -> + f "Read %d bytes from gateway:%d" (Cstruct.length buf) + local_tcpv4_forwarded_port); + Log.info (fun f -> f "%s" (Cstruct.to_string buf)); + loop (total_bytes + Cstruct.length buf) + in + loop 0 >|= fun total_bytes -> + Log.info (fun f -> f "Response had %d total bytes" total_bytes))) + (fun () -> Host.Sockets.Stream.Tcp.shutdown server) + in + run ~pcap:"test_tcpv4_forwarded_configuration" t + +let tests = + [ + ( "Ports: 1 TCP port forward", + [ + ( "Perform an HTTP GET through a port forward", + `Quick, + test_one_tcp_forward ); + ] ); + ( "Ports: 10 TCP port forwards", + [ + ( "Perform 10 HTTP GETs through a port forward", + `Quick, + test_10_tcp_connections ); + ] ); + ( "Ports: 1 UDP port forward", + [ + ( "Send a UDP packet through a port forward", + `Quick, + test_one_udp_forward ); + ] ); + ( "Ports: large UDP packets through a port forward", + [ + ( "Send large UDP packets through a port forward", + `Quick, + test_large_udp_forwards ); + ] ); + ( "Ports: check --tcpv4-forwards option", + [ + ("Connect to a local server", `Quick, test_tcpv4_forwarded_configuration); + ] ); + ] File "src/hostnet/host.ml", line 1, characters 0-0: diff --git a/_build/default/src/hostnet/host.ml b/_build/default/src/hostnet/.formatted/host.ml index 3f29b45..6bb6f0b 100644 --- a/_build/default/src/hostnet/host.ml +++ b/_build/default/src/hostnet/.formatted/host.ml @@ -33,9 +33,8 @@ let parse_sockaddr sockaddr = let string_of_address (dst, dst_port) = Ipaddr.to_string dst ^ ":" ^ string_of_int dst_port -let ( >>*= ) m f = m >>= function - | Error (`Msg m) -> Lwt.fail_with m - | Ok x -> f x +let ( >>*= ) m f = + m >>= function Error (`Msg m) -> Lwt.fail_with m | Ok x -> f x module Common = struct (** FLOW boilerplate *) @@ -303,8 +302,7 @@ module Sockets = struct Connection_limit.register_no_limit "udp" in return (Ok (idx, label, udp)))))) - >>*= fun (idx, label, udp) -> - Lwt.return (make ~idx ~label udp) + >>*= fun (idx, label, udp) -> Lwt.return (make ~idx ~label udp) let getsockname { fd; _ } = Luv_lwt.in_luv (fun return -> @@ -314,8 +312,7 @@ module Sockets = struct match parse_sockaddr sockaddr with | Error err -> return (Error (`Msg (Luv.Error.strerror err))) | Ok (ip, port) -> return (Ok (ip, port)))) - >>*= fun x -> - Lwt.return x + >>*= fun x -> Lwt.return x let shutdown server = if not server.closed then ( @@ -360,8 +357,7 @@ module Sockets = struct return (Error (`Msg (Luv.Error.strerror err))) | Ok () -> return (Ok (Luv.Buffer.size buf, address))) ))) - >>*= fun (size, address) -> - Lwt.return (size, address) + >>*= fun (size, address) -> Lwt.return (size, address) let listen t flow_cb = let rec loop () = @@ -574,17 +570,23 @@ module Sockets = struct else Lwt.return_unit let read_into t buf = - if t.closed - then (Log.info (fun f -> f "read_into %s already closed: EOF" t.description); Lwt.return (Ok `Eof)) + if t.closed then ( + Log.info (fun f -> f "read_into %s already closed: EOF" t.description); + Lwt.return (Ok `Eof)) else read_into t.fd buf + let read t = - if t.closed - then (Log.info (fun f -> f "read %s already closed: EOF" t.description); Lwt.return (Ok `Eof)) + if t.closed then ( + Log.info (fun f -> f "read %s already closed: EOF" t.description); + Lwt.return (Ok `Eof)) else read t.fd + let writev t bufs = - if t.closed (* || t.shutdown *) - then (Log.info (fun f -> f "writev %s already closed: EPIPE" t.description); Lwt.return (Error (`Msg "EPIPE"))) + if t.closed (* || t.shutdown *) then ( + Log.info (fun f -> f "writev %s already closed: EPIPE" t.description); + Lwt.return (Error (`Msg "EPIPE"))) else writev t.fd bufs + let write t buf = writev t [ buf ] let close t = @@ -675,26 +677,26 @@ module Sockets = struct let bind ?description (ip, requested_port) = bind_one ?description (ip, requested_port) >>*= fun (idx, _label, fd, bound_port) -> - (* On some systems localhost will resolve to ::1 first and this can - cause performance problems (particularly on Windows). Perform a - best-effort bind to the ::1 address. *) - Lwt.catch - (fun () -> - if - Ipaddr.compare ip (Ipaddr.V4 Ipaddr.V4.localhost) = 0 - || Ipaddr.compare ip (Ipaddr.V4 Ipaddr.V4.any) = 0 - then ( - Log.debug (fun f -> - f "Attempting a best-effort bind of ::1:%d" bound_port); - bind_one (Ipaddr.(V6 V6.localhost), bound_port) - >>*= fun (idx, _, fd, _) -> - Lwt.return [ (idx, (ip, bound_port), fd) ]) - else Lwt.return []) - (fun e -> - Log.debug (fun f -> - f "Ignoring failed bind to ::1:%d (%a)" bound_port Fmt.exn e); - Lwt.return []) - >|= fun extra -> make ip ((idx, (ip, bound_port), fd) :: extra) + (* On some systems localhost will resolve to ::1 first and this can + cause performance problems (particularly on Windows). Perform a + best-effort bind to the ::1 address. *) + Lwt.catch + (fun () -> + if + Ipaddr.compare ip (Ipaddr.V4 Ipaddr.V4.localhost) = 0 + || Ipaddr.compare ip (Ipaddr.V4 Ipaddr.V4.any) = 0 + then ( + Log.debug (fun f -> + f "Attempting a best-effort bind of ::1:%d" bound_port); + bind_one (Ipaddr.(V6 V6.localhost), bound_port) + >>*= fun (idx, _, fd, _) -> + Lwt.return [ (idx, (ip, bound_port), fd) ]) + else Lwt.return []) + (fun e -> + Log.debug (fun f -> + f "Ignoring failed bind to ::1:%d (%a)" bound_port Fmt.exn e); + Lwt.return []) + >|= fun extra -> make ip ((idx, (ip, bound_port), fd) :: extra) let shutdown server = let fds = server.listening_fds in @@ -890,17 +892,23 @@ module Sockets = struct else Lwt.return_unit let read_into t buf = - if t.closed - then (Log.info (fun f -> f "read_into %s already closed: EOF" t.description); Lwt.return (Ok `Eof)) + if t.closed then ( + Log.info (fun f -> f "read_into %s already closed: EOF" t.description); + Lwt.return (Ok `Eof)) else read_into t.fd buf + let read t = - if t.closed - then (Log.info (fun f -> f "read %s already closed: EOF" t.description); Lwt.return (Ok `Eof)) + if t.closed then ( + Log.info (fun f -> f "read %s already closed: EOF" t.description); + Lwt.return (Ok `Eof)) else read t.fd + let writev t bufs = - if t.closed (* || t.shutdown *) - then (Log.info (fun f -> f "writev %s already closed: EPIPE" t.description); Lwt.return (Error (`Msg "EPIPE"))) + if t.closed (* || t.shutdown *) then ( + Log.info (fun f -> f "writev %s already closed: EPIPE" t.description); + Lwt.return (Error (`Msg "EPIPE"))) else writev t.fd bufs + let write t buf = writev t [ buf ] let close t = @@ -944,8 +952,7 @@ module Sockets = struct closed = false; disable_connection_tracking = false; }))))) - >>*= fun x -> - Lwt.return x + >>*= fun x -> Lwt.return x let getsockname server = Luv_lwt.in_luv (fun return -> return (Luv.Pipe.getsockname server.fd)) @@ -1075,10 +1082,9 @@ module TestServer (F : ClientServer) = struct let connected = Lwt_mvar.create_empty () in F.listen server (fun flow -> Lwt_mvar.put connected () >>= fun () -> F.close flow); - F.connect address - >>*= fun flow -> - with_flow flow (fun () -> - Lwt_mvar.take connected >>= fun () -> Lwt.return_unit))) + F.connect address >>*= fun flow -> + with_flow flow (fun () -> + Lwt_mvar.take connected >>= fun () -> Lwt.return_unit))) let stream_data () = Luv_lwt.run @@ -1100,35 +1106,33 @@ module TestServer (F : ClientServer) = struct loop () >>= fun () -> Lwt.return Sha1.(to_hex @@ finalize sha)) >>= fun digest -> Lwt_mvar.put received digest); - F.connect address - >>*= fun flow -> - with_flow flow (fun () -> - let buf = Cstruct.create 1048576 in - let sha = Sha1.init () in - let rec loop = function - | 0 -> Lwt.return_unit - | n -> ( - let len = Random.int (Cstruct.length buf - 1) in - let subbuf = Cstruct.sub buf 0 len in - for i = 0 to Cstruct.length subbuf - 1 do - Cstruct.set_uint8 subbuf i (Random.int 256) - done; - let ba = Cstruct.to_bigarray subbuf in - Sha1.update_buffer sha ba; - F.writev flow [ subbuf ] >>= function - | Error `Closed -> Lwt.fail End_of_file - | Error _ -> Lwt.fail_with "write error" - | Ok () -> loop (n - 1)) - in - loop 10 >>= fun () -> - Lwt.return Sha1.(to_hex @@ finalize sha)) - >>= fun sent_digest -> - Lwt_mvar.take received >>= fun received_digest -> - if received_digest <> sent_digest then - failwith - (Printf.sprintf "received digest (%s) <> sent digest (%s)" - received_digest sent_digest); - Lwt.return_unit)) + F.connect address >>*= fun flow -> + with_flow flow (fun () -> + let buf = Cstruct.create 1048576 in + let sha = Sha1.init () in + let rec loop = function + | 0 -> Lwt.return_unit + | n -> ( + let len = Random.int (Cstruct.length buf - 1) in + let subbuf = Cstruct.sub buf 0 len in + for i = 0 to Cstruct.length subbuf - 1 do + Cstruct.set_uint8 subbuf i (Random.int 256) + done; + let ba = Cstruct.to_bigarray subbuf in + Sha1.update_buffer sha ba; + F.writev flow [ subbuf ] >>= function + | Error `Closed -> Lwt.fail End_of_file + | Error _ -> Lwt.fail_with "write error" + | Ok () -> loop (n - 1)) + in + loop 10 >>= fun () -> Lwt.return Sha1.(to_hex @@ finalize sha)) + >>= fun sent_digest -> + Lwt_mvar.take received >>= fun received_digest -> + if received_digest <> sent_digest then + failwith + (Printf.sprintf "received digest (%s) <> sent digest (%s)" + received_digest sent_digest); + Lwt.return_unit)) end let%test_module "Sockets.Stream.Unix" = @@ -1201,8 +1205,7 @@ module Files = struct match Luv.FS_event.stop w.h with | Error err -> return (Error (`Msg (Luv.Error.strerror err))) | Ok () -> return (Ok ())) - >>*= fun () -> - Lwt.return_unit + >>*= fun () -> Lwt.return_unit let watch_file path callback = Luv_lwt.in_luv (fun return -> @@ -1253,8 +1256,7 @@ module Time = struct with | Error err -> return (Error (`Msg (Luv.Error.strerror err))) | Ok () -> ())) - >>*= fun() -> - Lwt.return_unit + >>*= fun () -> Lwt.return_unit let%test "Time.sleep_ns wakes up" = let start = Unix.gettimeofday () in File "src/hostnet_test/test_http.ml", line 1, characters 0-0: diff --git a/_build/default/src/hostnet_test/test_http.ml b/_build/default/src/hostnet_test/.formatted/test_http.ml index 6098a00..d12943c 100644 --- a/_build/default/src/hostnet_test/test_http.ml +++ b/_build/default/src/hostnet_test/.formatted/test_http.ml @@ -8,7 +8,6 @@ let src = module Log = (val Logs.src_log src : Logs.LOG) module Match = struct - let test_ip_match () = let exclude = Hostnet_http.Match.of_string "10.0.0.1" in assert (Hostnet_http.Match.matches "10.0.0.1" exclude) @@ -19,1119 +18,1346 @@ module Match = struct let test_cidr_no_match () = let exclude = Hostnet_http.Match.of_string "10.0.0.0/24" in - assert (not(Hostnet_http.Match.matches - "192.168.0.1" - exclude)) + assert (not (Hostnet_http.Match.matches "192.168.0.1" exclude)) let test_domain_match () = let exclude = Hostnet_http.Match.of_string "mit.edu" in - assert (Hostnet_http.Match.matches - "dave.mit.edu" - exclude) + assert (Hostnet_http.Match.matches "dave.mit.edu" exclude) let test_domain_star_match () = let exclude = Hostnet_http.Match.of_string "*.mit.edu" in - assert (Hostnet_http.Match.matches - "dave.mit.edu" - exclude) + assert (Hostnet_http.Match.matches "dave.mit.edu" exclude) let test_domain_dot_match () = let exclude = Hostnet_http.Match.of_string ".mit.edu" in - assert (Hostnet_http.Match.matches - "dave.mit.edu" - exclude) + assert (Hostnet_http.Match.matches "dave.mit.edu" exclude) let test_domain_no_match () = let exclude = Hostnet_http.Match.of_string "mit.edu" in - assert (not(Hostnet_http.Match.matches - "www.mobyproject.org" - exclude)) + assert (not (Hostnet_http.Match.matches "www.mobyproject.org" exclude)) let test_list () = let exclude = Hostnet_http.Match.of_string "*.local, 169.254.0.0/16" in - assert (Hostnet_http.Match.matches - "dave.local" - exclude); - assert (Hostnet_http.Match.matches - "169.254.0.1" - exclude); - assert (not(Hostnet_http.Match.matches - "10.0.0.1" - exclude)); - assert (not(Hostnet_http.Match.matches - "www.mobyproject.org" - exclude)) + assert (Hostnet_http.Match.matches "dave.local" exclude); + assert (Hostnet_http.Match.matches "169.254.0.1" exclude); + assert (not (Hostnet_http.Match.matches "10.0.0.1" exclude)); + assert (not (Hostnet_http.Match.matches "www.mobyproject.org" exclude)) - let tests = [ - "HTTP: no_proxy IP match", [ "", `Quick, test_ip_match ]; - "HTTP: no_proxy CIDR match", [ "", `Quick, test_cidr_match ]; - "HTTP: no_proxy CIDR no match", [ "", `Quick, test_cidr_no_match ]; - "HTTP: no_proxy domain match", [ "", `Quick, test_domain_match ]; - "HTTP: no_proxy domain no match", [ "", `Quick, test_domain_no_match ]; - "HTTP: no_proxy domain star match", [ "", `Quick, test_domain_star_match ]; - "HTTP: no_proxy domain dot match", [ "", `Quick, test_domain_dot_match ]; - "HTTP: no_proxy list", [ "", `Quick, test_list ]; - ] + let tests = + [ + ("HTTP: no_proxy IP match", [ ("", `Quick, test_ip_match) ]); + ("HTTP: no_proxy CIDR match", [ ("", `Quick, test_cidr_match) ]); + ("HTTP: no_proxy CIDR no match", [ ("", `Quick, test_cidr_no_match) ]); + ("HTTP: no_proxy domain match", [ ("", `Quick, test_domain_match) ]); + ("HTTP: no_proxy domain no match", [ ("", `Quick, test_domain_no_match) ]); + ( "HTTP: no_proxy domain star match", + [ ("", `Quick, test_domain_star_match) ] ); + ( "HTTP: no_proxy domain dot match", + [ ("", `Quick, test_domain_dot_match) ] ); + ("HTTP: no_proxy list", [ ("", `Quick, test_list) ]); + ] end module Server = struct - type t = { - server: Host.Sockets.Stream.Tcp.server; - port: int; - } + type t = { server : Host.Sockets.Stream.Tcp.server; port : int } + let create on_accept = Host.Sockets.Stream.Tcp.bind (Ipaddr.V4 Ipaddr.V4.localhost, 0) >>= fun server -> - Host.Sockets.Stream.Tcp.getsockname server - >>= fun (_, port) -> + Host.Sockets.Stream.Tcp.getsockname server >>= fun (_, port) -> Host.Sockets.Stream.Tcp.listen server on_accept; Lwt.return { server; port } - let destroy t = - Host.Sockets.Stream.Tcp.shutdown t.server + + let destroy t = Host.Sockets.Stream.Tcp.shutdown t.server end + let with_server on_accept f = - Server.create on_accept - >>= fun server -> + Server.create on_accept >>= fun server -> Lwt.finalize (fun () -> f server) (fun () -> Server.destroy server) module Outgoing = struct - module C = Mirage_channel.Make(Slirp_stack.Client.TCPV4) - module IO = Cohttp_mirage_io.Make(C) - module Request = Cohttp.Request.Make(IO) - module Response = Cohttp.Response.Make(IO) + module C = Mirage_channel.Make (Slirp_stack.Client.TCPV4) + module IO = Cohttp_mirage_io.Make (C) + module Request = Cohttp.Request.Make (IO) + module Response = Cohttp.Response.Make (IO) end + module Incoming = struct - module C = Mirage_channel.Make(Host.Sockets.Stream.Tcp) - module IO = Cohttp_mirage_io.Make(C) - module Request = Cohttp.Request.Make(IO) - module Response = Cohttp.Response.Make(IO) + module C = Mirage_channel.Make (Host.Sockets.Stream.Tcp) + module IO = Cohttp_mirage_io.Make (C) + module Request = Cohttp.Request.Make (IO) + module Response = Cohttp.Response.Make (IO) end let send_http_request stack (ip, port) request = let open Slirp_stack in - Client.TCPV4.create_connection (Client.tcpv4 stack) (ip, port) - >>= function + Client.TCPV4.create_connection (Client.tcpv4 stack) (ip, port) >>= function | Ok flow -> - Log.info (fun f -> f "Connected to %s:80" (Ipaddr.V4.to_string ip)); - let oc = Outgoing.C.create flow in - Outgoing.Request.write ~flush:true (fun _writer -> Lwt.return_unit) - request oc + Log.info (fun f -> f "Connected to %s:80" (Ipaddr.V4.to_string ip)); + let oc = Outgoing.C.create flow in + Outgoing.Request.write ~flush:true + (fun _writer -> Lwt.return_unit) + request oc | Error _ -> - Log.err (fun f -> f "Failed to connect to %s:80" (Ipaddr.V4.to_string ip)); - failwith "http_fetch" + Log.err (fun f -> f "Failed to connect to %s:80" (Ipaddr.V4.to_string ip)); + failwith "http_fetch" let intercept ~pcap ?(port = 80) proxy request = let forwarded, forwarded_u = Lwt.task () in Slirp_stack.with_stack ~pcap (fun _ stack -> - with_server (fun flow -> + with_server + (fun flow -> let ic = Incoming.C.create flow in Incoming.Request.read ic >>= function | `Eof -> - Log.err (fun f -> f "Failed to request"); - failwith "Failed to read request" + Log.err (fun f -> f "Failed to request"); + failwith "Failed to read request" | `Invalid x -> - Log.err (fun f -> f "Failed to parse request: %s" x); - failwith ("Failed to parse request: " ^ x) + Log.err (fun f -> f "Failed to parse request: %s" x); + failwith ("Failed to parse request: " ^ x) | `Ok req -> - (* parse the response *) - Lwt.wakeup_later forwarded_u req; - Lwt.return_unit - ) (fun server -> + (* parse the response *) + Lwt.wakeup_later forwarded_u req; + Lwt.return_unit) + (fun server -> let json = - Ezjsonm.from_string (" { \"http\": \"" ^ proxy ^ ":" ^ - (string_of_int server.Server.port) ^ "\" }") + Ezjsonm.from_string + (" { \"http\": \"" ^ proxy ^ ":" + ^ string_of_int server.Server.port + ^ "\" }") in - Slirp_stack.Slirp_stack.Debug.update_http_json json () - >>= function + Slirp_stack.Slirp_stack.Debug.update_http_json json () >>= function | Error (`Msg m) -> failwith ("Failed to enable HTTP proxy: " ^ m) | Ok () -> - send_http_request stack.t (Ipaddr.V4.of_string_exn "127.0.0.1", port) - request - >>= fun () -> - Lwt.pick [ - (Host.Time.sleep_ns (Duration.of_sec 100) >|= fun () -> - `Timeout); - (forwarded >>= fun x -> Lwt.return (`Result x)) - ] - ) + send_http_request stack.t + (Ipaddr.V4.of_string_exn "127.0.0.1", port) + request + >>= fun () -> + Lwt.pick + [ + ( Host.Time.sleep_ns (Duration.of_sec 100) >|= fun () -> + `Timeout ); + (forwarded >>= fun x -> Lwt.return (`Result x)); + ]) >|= function - | `Timeout -> failwith "HTTP interception failed" - | `Result x -> x - ) + | `Timeout -> failwith "HTTP interception failed" + | `Result x -> x) (* Test that HTTP interception works at all *) let test_interception proxy () = - Host.Main.run begin - let request = - Cohttp.Request.make - (Uri.make ~scheme:"http" ~host:"www.mobyproject.org" ~path:"/" ()) - in - intercept ~pcap:"test_interception.pcap" proxy request >>= fun result -> - Log.info (fun f -> - f "original was: %s" - (Sexplib.Sexp.to_string_hum (Cohttp.Request.sexp_of_t request))); - Log.info (fun f -> - f "proxied was: %s" - (Sexplib.Sexp.to_string_hum (Cohttp.Request.sexp_of_t result))); - Alcotest.check Alcotest.string "method" - (Cohttp.Code.string_of_method request.Cohttp.Request.meth) - (Cohttp.Code.string_of_method result.Cohttp.Request.meth); - Alcotest.check Alcotest.string "version" - (Cohttp.Code.string_of_version request.Cohttp.Request.version) - (Cohttp.Code.string_of_version result.Cohttp.Request.version); - (* a request to a proxy must have an absolute URI *) - Alcotest.check Alcotest.string "uri" - "http://www.mobyproject.org:80/" - result.Cohttp.Request.resource; - Alcotest.check Alcotest.(list(pair string string)) "headers" - (Cohttp.Header.to_list request.Cohttp.Request.headers) - (Cohttp.Header.to_list result.Cohttp.Request.headers); - Lwt.return () - end + Host.Main.run + (let request = + Cohttp.Request.make + (Uri.make ~scheme:"http" ~host:"www.mobyproject.org" ~path:"/" ()) + in + intercept ~pcap:"test_interception.pcap" proxy request >>= fun result -> + Log.info (fun f -> + f "original was: %s" + (Sexplib.Sexp.to_string_hum (Cohttp.Request.sexp_of_t request))); + Log.info (fun f -> + f "proxied was: %s" + (Sexplib.Sexp.to_string_hum (Cohttp.Request.sexp_of_t result))); + Alcotest.check Alcotest.string "method" + (Cohttp.Code.string_of_method request.Cohttp.Request.meth) + (Cohttp.Code.string_of_method result.Cohttp.Request.meth); + Alcotest.check Alcotest.string "version" + (Cohttp.Code.string_of_version request.Cohttp.Request.version) + (Cohttp.Code.string_of_version result.Cohttp.Request.version); + (* a request to a proxy must have an absolute URI *) + Alcotest.check Alcotest.string "uri" "http://www.mobyproject.org:80/" + result.Cohttp.Request.resource; + Alcotest.check + Alcotest.(list (pair string string)) + "headers" + (Cohttp.Header.to_list request.Cohttp.Request.headers) + (Cohttp.Header.to_list result.Cohttp.Request.headers); + Lwt.return ()) (* Test that a relative URI becomes absolute *) let test_uri_relative proxy () = - Host.Main.run begin - let request = - Cohttp.Request.make - (Uri.make ~scheme:"http" ~host:"www.mobyproject.org" ~path:"/" ()) - in - intercept ~pcap:"test_uri_relative.pcap" proxy request >>= fun result -> - Log.info (fun f -> - f "original was: %s" - (Sexplib.Sexp.to_string_hum (Cohttp.Request.sexp_of_t request))); - Log.info (fun f -> - f "proxied was: %s" - (Sexplib.Sexp.to_string_hum (Cohttp.Request.sexp_of_t result))); - let uri = Uri.of_string result.Cohttp.Request.resource in - Alcotest.check Alcotest.(option string) "scheme" - (Some "http") (Uri.scheme uri); - Lwt.return () - end + Host.Main.run + (let request = + Cohttp.Request.make + (Uri.make ~scheme:"http" ~host:"www.mobyproject.org" ~path:"/" ()) + in + intercept ~pcap:"test_uri_relative.pcap" proxy request >>= fun result -> + Log.info (fun f -> + f "original was: %s" + (Sexplib.Sexp.to_string_hum (Cohttp.Request.sexp_of_t request))); + Log.info (fun f -> + f "proxied was: %s" + (Sexplib.Sexp.to_string_hum (Cohttp.Request.sexp_of_t result))); + let uri = Uri.of_string result.Cohttp.Request.resource in + Alcotest.check + Alcotest.(option string) + "scheme" (Some "http") (Uri.scheme uri); + Lwt.return ()) (* Test that an absolute URI is preserved. This is expected when the client explicitly uses us as a proxy rather than being transparent. *) let test_uri_absolute proxy () = - Host.Main.run begin - let request = - Cohttp.Request.make - (Uri.make ~host:"www.mobyproject.org" ~path:"/" ()) - in - intercept ~pcap:"test_uri_absolute.pcap" proxy request >>= fun result -> - Log.info (fun f -> - f "original was: %s" - (Sexplib.Sexp.to_string_hum (Cohttp.Request.sexp_of_t request))); - Log.info (fun f -> - f "proxied was: %s" - (Sexplib.Sexp.to_string_hum (Cohttp.Request.sexp_of_t result))); - let uri = Uri.of_string result.Cohttp.Request.resource in - Alcotest.check Alcotest.(option string) "scheme" - (Some "http") (Uri.scheme uri); - Lwt.return () - end + Host.Main.run + (let request = + Cohttp.Request.make (Uri.make ~host:"www.mobyproject.org" ~path:"/" ()) + in + intercept ~pcap:"test_uri_absolute.pcap" proxy request >>= fun result -> + Log.info (fun f -> + f "original was: %s" + (Sexplib.Sexp.to_string_hum (Cohttp.Request.sexp_of_t request))); + Log.info (fun f -> + f "proxied was: %s" + (Sexplib.Sexp.to_string_hum (Cohttp.Request.sexp_of_t result))); + let uri = Uri.of_string result.Cohttp.Request.resource in + Alcotest.check + Alcotest.(option string) + "scheme" (Some "http") (Uri.scheme uri); + Lwt.return ()) (* Verify that a custom X- header is preserved *) let test_x_header_preserved proxy () = - Host.Main.run begin - let headers = - Cohttp.Header.add (Cohttp.Header.init ()) "X-dave-is-cool" "true" - in - let request = - Cohttp.Request.make ~headers - (Uri.make ~scheme:"http" ~host:"www.mobyproject.org" ~path:"/" ()) - in - intercept ~pcap:"test_x_header_preserved.pcap" proxy request >>= fun result -> - Log.info (fun f -> - f "original was: %s" - (Sexplib.Sexp.to_string_hum (Cohttp.Request.sexp_of_t request))); - Log.info (fun f -> - f "proxied was: %s" - (Sexplib.Sexp.to_string_hum (Cohttp.Request.sexp_of_t result))); - Alcotest.check Alcotest.(option string) "X-header" - (Some "true") - (Cohttp.Header.get result.Cohttp.Request.headers "X-dave-is-cool"); - Lwt.return () - end + Host.Main.run + (let headers = + Cohttp.Header.add (Cohttp.Header.init ()) "X-dave-is-cool" "true" + in + let request = + Cohttp.Request.make ~headers + (Uri.make ~scheme:"http" ~host:"www.mobyproject.org" ~path:"/" ()) + in + intercept ~pcap:"test_x_header_preserved.pcap" proxy request + >>= fun result -> + Log.info (fun f -> + f "original was: %s" + (Sexplib.Sexp.to_string_hum (Cohttp.Request.sexp_of_t request))); + Log.info (fun f -> + f "proxied was: %s" + (Sexplib.Sexp.to_string_hum (Cohttp.Request.sexp_of_t result))); + Alcotest.check + Alcotest.(option string) + "X-header" (Some "true") + (Cohttp.Header.get result.Cohttp.Request.headers "X-dave-is-cool"); + Lwt.return ()) (* Verify that the user-agent is preserved. In particular we don't want our http library to leak here. *) let test_user_agent_preserved proxy () = - Host.Main.run begin - let headers = - Cohttp.Header.add (Cohttp.Header.init ()) "user-agent" "whatever" - in - let request = - Cohttp.Request.make ~headers - (Uri.make ~scheme:"http" ~host:"www.mobyproject.org" ~path:"/" ()) - in - intercept ~pcap:"test_user_agent_preserved.pcap" proxy request >>= fun result -> - Log.info (fun f -> - f "original was: %s" - (Sexplib.Sexp.to_string_hum (Cohttp.Request.sexp_of_t request))); - Log.info (fun f -> - f "proxied was: %s" - (Sexplib.Sexp.to_string_hum (Cohttp.Request.sexp_of_t result))); - Alcotest.check Alcotest.(option string) "user-agent" (Some "whatever") - (Cohttp.Header.get result.Cohttp.Request.headers "user-agent"); - Lwt.return () - end + Host.Main.run + (let headers = + Cohttp.Header.add (Cohttp.Header.init ()) "user-agent" "whatever" + in + let request = + Cohttp.Request.make ~headers + (Uri.make ~scheme:"http" ~host:"www.mobyproject.org" ~path:"/" ()) + in + intercept ~pcap:"test_user_agent_preserved.pcap" proxy request + >>= fun result -> + Log.info (fun f -> + f "original was: %s" + (Sexplib.Sexp.to_string_hum (Cohttp.Request.sexp_of_t request))); + Log.info (fun f -> + f "proxied was: %s" + (Sexplib.Sexp.to_string_hum (Cohttp.Request.sexp_of_t result))); + Alcotest.check + Alcotest.(option string) + "user-agent" (Some "whatever") + (Cohttp.Header.get result.Cohttp.Request.headers "user-agent"); + Lwt.return ()) (* Verify that authorizations are preserved *) let test_authorization_preserved proxy () = - Host.Main.run begin - let headers = - Cohttp.Header.add (Cohttp.Header.init ()) "authorization" "basic foobar" - in - let request = - Cohttp.Request.make ~headers - (Uri.make ~scheme:"http" ~host:"www.mobyproject.org" ~path:"/" ()) - in - intercept ~pcap:"test_authorization_preserved.pcap" proxy request >>= fun result -> - Log.info (fun f -> - f "original was: %s" - (Sexplib.Sexp.to_string_hum (Cohttp.Request.sexp_of_t request))); - Log.info (fun f -> - f "proxied was: %s" - (Sexplib.Sexp.to_string_hum (Cohttp.Request.sexp_of_t result))); - Alcotest.check Alcotest.(option string) "authorization" (Some "basic foobar") - (Cohttp.Header.get result.Cohttp.Request.headers "authorization"); - Lwt.return () - end + Host.Main.run + (let headers = + Cohttp.Header.add (Cohttp.Header.init ()) "authorization" "basic foobar" + in + let request = + Cohttp.Request.make ~headers + (Uri.make ~scheme:"http" ~host:"www.mobyproject.org" ~path:"/" ()) + in + intercept ~pcap:"test_authorization_preserved.pcap" proxy request + >>= fun result -> + Log.info (fun f -> + f "original was: %s" + (Sexplib.Sexp.to_string_hum (Cohttp.Request.sexp_of_t request))); + Log.info (fun f -> + f "proxied was: %s" + (Sexplib.Sexp.to_string_hum (Cohttp.Request.sexp_of_t result))); + Alcotest.check + Alcotest.(option string) + "authorization" (Some "basic foobar") + (Cohttp.Header.get result.Cohttp.Request.headers "authorization"); + Lwt.return ()) (* Verify that necessary proxy authorizations are present *) let test_proxy_authorization proxy () = - Host.Main.run begin - let headers = - Cohttp.Header.add (Cohttp.Header.init ()) "authorization" "basic foobar" - in - let request = - Cohttp.Request.make ~headers - (Uri.make ~scheme:"http" ~host:"www.mobyproject.org" ~path:"/" ()) - in - intercept ~pcap:"test_proxy_authorization.pcap" proxy request >>= fun result -> - Log.info (fun f -> - f "original was: %s" - (Sexplib.Sexp.to_string_hum (Cohttp.Request.sexp_of_t request))); - Log.info (fun f -> - f "proxied was: %s" - (Sexplib.Sexp.to_string_hum (Cohttp.Request.sexp_of_t result))); - (* If the proxy uses auth, then there has to be a Proxy-Authorization - header. If theres no auth, there should be no header. *) - let proxy_authorization = "proxy-authorization" in - let proxy' = Uri.of_string proxy in - begin match Uri.user proxy', Uri.password proxy' with - | Some username, Some password -> - Alcotest.check Alcotest.(list string) proxy_authorization - [ "Basic " ^ (Base64.encode_exn (username ^ ":" ^ password)) ] - (Cohttp.Header.get_multi result.Cohttp.Request.headers proxy_authorization) - | _, _ -> - Alcotest.check Alcotest.(list string) proxy_authorization - [ ] - (Cohttp.Header.get_multi result.Cohttp.Request.headers proxy_authorization) - end; - Lwt.return () - end + Host.Main.run + (let headers = + Cohttp.Header.add (Cohttp.Header.init ()) "authorization" "basic foobar" + in + let request = + Cohttp.Request.make ~headers + (Uri.make ~scheme:"http" ~host:"www.mobyproject.org" ~path:"/" ()) + in + intercept ~pcap:"test_proxy_authorization.pcap" proxy request + >>= fun result -> + Log.info (fun f -> + f "original was: %s" + (Sexplib.Sexp.to_string_hum (Cohttp.Request.sexp_of_t request))); + Log.info (fun f -> + f "proxied was: %s" + (Sexplib.Sexp.to_string_hum (Cohttp.Request.sexp_of_t result))); + (* If the proxy uses auth, then there has to be a Proxy-Authorization + header. If theres no auth, there should be no header. *) + let proxy_authorization = "proxy-authorization" in + let proxy' = Uri.of_string proxy in + (match (Uri.user proxy', Uri.password proxy') with + | Some username, Some password -> + Alcotest.check + Alcotest.(list string) + proxy_authorization + [ "Basic " ^ Base64.encode_exn (username ^ ":" ^ password) ] + (Cohttp.Header.get_multi result.Cohttp.Request.headers + proxy_authorization) + | _, _ -> + Alcotest.check + Alcotest.(list string) + proxy_authorization [] + (Cohttp.Header.get_multi result.Cohttp.Request.headers + proxy_authorization)); + Lwt.return ()) let err_flush e = Fmt.kstr failwith "%a" Incoming.C.pp_write_error e let test_http_connect_tunnel proxy () = let test_dst_ip = Ipaddr.V4.of_string_exn "1.2.3.4" in - Host.Main.run begin - Slirp_stack.with_stack ~pcap:"test_http_connect.pcap" (fun _ stack -> - with_server (fun flow -> - let ic = Incoming.C.create flow in - Incoming.Request.read ic >>= function - | `Eof -> - Log.err (fun f -> f "Failed to request"); - failwith "Failed to read request" - | `Invalid x -> - Log.err (fun f -> f "Failed to parse request: %s" x); - failwith ("Failed to parse request: " ^ x) - | `Ok req -> - Log.info (fun f -> - f "received: %s" - (Sexplib.Sexp.to_string_hum (Cohttp.Request.sexp_of_t req))); - Alcotest.check Alcotest.string "method" - (Cohttp.Code.string_of_method `CONNECT) - (Cohttp.Code.string_of_method req.Cohttp.Request.meth); - let uri = Cohttp.Request.uri req in - Alcotest.check Alcotest.(option string) "host" - (Some (Ipaddr.V4.to_string test_dst_ip)) (Uri.host uri); - Alcotest.check Alcotest.(option int) "port" (Some 443) - (Uri.port uri); - Alcotest.check Alcotest.(option string) "host" - (Some (Ipaddr.V4.to_string test_dst_ip ^ ":443")) - (Cohttp.Header.get req.Cohttp.Request.headers "host"); - Alcotest.check Alcotest.string "resource" - (Ipaddr.V4.to_string test_dst_ip ^ ":443") - req.Cohttp.Request.resource; - (* If the proxy uses auth, then there has to be a Proxy-Authorization - header. If theres no auth, there should be no header. *) - let proxy_authorization = "proxy-authorization" in - begin match Uri.user proxy, Uri.password proxy with - | Some username, Some password -> - Alcotest.check Alcotest.(list string) proxy_authorization - [ "Basic " ^ (Base64.encode_exn (username ^ ":" ^ password)) ] - (Cohttp.Header.get_multi req.Cohttp.Request.headers proxy_authorization) - | _, _ -> - Alcotest.check Alcotest.(list string) proxy_authorization - [ ] - (Cohttp.Header.get_multi req.Cohttp.Request.headers proxy_authorization) - end; - (* Unfortunately cohttp always adds transfer-encoding: chunked - so we write the header ourselves *) - Incoming.C.write_line ic "HTTP/1.0 200 OK\r"; - Incoming.C.write_line ic "\r"; - Incoming.C.flush ic >>= function - | Error e -> err_flush e - | Ok () -> - Incoming.C.write_line ic "hello"; - Incoming.C.flush ic >|= function - | Error e -> err_flush e - | Ok () -> () - ) (fun server -> - Slirp_stack.Slirp_stack.Debug.update_http - ~https:(Uri.(to_string @@ with_port proxy (Some server.Server.port))) () - >>= function - | Error (`Msg m) -> failwith ("Failed to enable HTTP proxy: " ^ m) - | Ok () -> - let open Slirp_stack in - Client.TCPV4.create_connection (Client.tcpv4 stack.t) - (test_dst_ip, 443) - >>= function - | Error _ -> - Log.err (fun f -> - f "TCPV4.create_connection %a:443 failed" - Ipaddr.V4.pp test_dst_ip); - failwith "TCPV4.create_connection" - | Ok flow -> - let ic = Outgoing.C.create flow in - Outgoing.C.read_some ~len:5 ic >>= function - | Error e -> Fmt.kstr failwith "%a" Outgoing.C.pp_error e - | Ok `Eof -> failwith "EOF" - | Ok (`Data buf) -> - let txt = Cstruct.to_string buf in - Alcotest.check Alcotest.string "message" "hello" txt; - Lwt.return_unit - ) - ) - end + Host.Main.run + (Slirp_stack.with_stack ~pcap:"test_http_connect.pcap" (fun _ stack -> + with_server + (fun flow -> + let ic = Incoming.C.create flow in + Incoming.Request.read ic >>= function + | `Eof -> + Log.err (fun f -> f "Failed to request"); + failwith "Failed to read request" + | `Invalid x -> + Log.err (fun f -> f "Failed to parse request: %s" x); + failwith ("Failed to parse request: " ^ x) + | `Ok req -> ( + Log.info (fun f -> + f "received: %s" + (Sexplib.Sexp.to_string_hum + (Cohttp.Request.sexp_of_t req))); + Alcotest.check Alcotest.string "method" + (Cohttp.Code.string_of_method `CONNECT) + (Cohttp.Code.string_of_method req.Cohttp.Request.meth); + let uri = Cohttp.Request.uri req in + Alcotest.check + Alcotest.(option string) + "host" + (Some (Ipaddr.V4.to_string test_dst_ip)) + (Uri.host uri); + Alcotest.check + Alcotest.(option int) + "port" (Some 443) (Uri.port uri); + Alcotest.check + Alcotest.(option string) + "host" + (Some (Ipaddr.V4.to_string test_dst_ip ^ ":443")) + (Cohttp.Header.get req.Cohttp.Request.headers "host"); + Alcotest.check Alcotest.string "resource" + (Ipaddr.V4.to_string test_dst_ip ^ ":443") + req.Cohttp.Request.resource; + (* If the proxy uses auth, then there has to be a Proxy-Authorization + header. If theres no auth, there should be no header. *) + let proxy_authorization = "proxy-authorization" in + (match (Uri.user proxy, Uri.password proxy) with + | Some username, Some password -> + Alcotest.check + Alcotest.(list string) + proxy_authorization + [ + "Basic " ^ Base64.encode_exn (username ^ ":" ^ password); + ] + (Cohttp.Header.get_multi req.Cohttp.Request.headers + proxy_authorization) + | _, _ -> + Alcotest.check + Alcotest.(list string) + proxy_authorization [] + (Cohttp.Header.get_multi req.Cohttp.Request.headers + proxy_authorization)); + (* Unfortunately cohttp always adds transfer-encoding: chunked + so we write the header ourselves *) + Incoming.C.write_line ic "HTTP/1.0 200 OK\r"; + Incoming.C.write_line ic "\r"; + Incoming.C.flush ic >>= function + | Error e -> err_flush e + | Ok () -> ( + Incoming.C.write_line ic "hello"; + Incoming.C.flush ic >|= function + | Error e -> err_flush e + | Ok () -> ()))) + (fun server -> + Slirp_stack.Slirp_stack.Debug.update_http + ~https: + Uri.(to_string @@ with_port proxy (Some server.Server.port)) + () + >>= function + | Error (`Msg m) -> failwith ("Failed to enable HTTP proxy: " ^ m) + | Ok () -> ( + let open Slirp_stack in + Client.TCPV4.create_connection (Client.tcpv4 stack.t) + (test_dst_ip, 443) + >>= function + | Error _ -> + Log.err (fun f -> + f "TCPV4.create_connection %a:443 failed" Ipaddr.V4.pp + test_dst_ip); + failwith "TCPV4.create_connection" + | Ok flow -> ( + let ic = Outgoing.C.create flow in + Outgoing.C.read_some ~len:5 ic >>= function + | Error e -> Fmt.kstr failwith "%a" Outgoing.C.pp_error e + | Ok `Eof -> failwith "EOF" + | Ok (`Data buf) -> + let txt = Cstruct.to_string buf in + Alcotest.check Alcotest.string "message" "hello" txt; + Lwt.return_unit))))) - let test_http_connect_forward proxy () = - (* Run a proxy, send an HTTP CONNECT to it, check the forwarded request *) - let proxy_port = ref 0 in - Host.Main.run begin - Slirp_stack.with_stack ~pcap:"test_http_connect_forward.pcap" (fun _ stack -> - with_server (fun flow -> - let ic = Incoming.C.create flow in - Incoming.Request.read ic >>= function - | `Eof -> - Log.err (fun f -> f "Failed to request"); - failwith "Failed to read request" - | `Invalid x -> - Log.err (fun f -> f "Failed to parse request: %s" x); - failwith ("Failed to parse request: " ^ x) - | `Ok req -> - Log.info (fun f -> - f "received: %s" - (Sexplib.Sexp.to_string_hum (Cohttp.Request.sexp_of_t req))); - Alcotest.check Alcotest.string "method" - (Cohttp.Code.string_of_method `CONNECT) - (Cohttp.Code.string_of_method req.Cohttp.Request.meth); - Printf.fprintf stderr "Headers =\n %s\n%!" (String.concat "\n " (List.map (fun (k, v) -> k ^ ": " ^ v) (Cohttp.Header.to_list req.Cohttp.Request.headers))); - Alcotest.check Alcotest.(option string) "host" - (Some ("localhost:" ^ (string_of_int !proxy_port))) - (Cohttp.Header.get req.Cohttp.Request.headers "host"); - Alcotest.check Alcotest.string "resource" - ("localhost:" ^ (string_of_int !proxy_port)) - req.Cohttp.Request.resource; - (* If the proxy uses auth, then there has to be a Proxy-Authorization - header. If theres no auth, there should be no header. *) - let proxy_authorization = "proxy-authorization" in - begin match Uri.user proxy, Uri.password proxy with - | Some username, Some password -> - Alcotest.check Alcotest.(list string) proxy_authorization - [ "Basic " ^ (Base64.encode_exn (username ^ ":" ^ password)) ] - (Cohttp.Header.get_multi req.Cohttp.Request.headers proxy_authorization) - | _, _ -> - Alcotest.check Alcotest.(list string) proxy_authorization - [ ] - (Cohttp.Header.get_multi req.Cohttp.Request.headers proxy_authorization) - end; - (* Unfortunately cohttp always adds transfer-encoding: chunked - so we write the header ourselves *) - Incoming.C.write_line ic "HTTP/1.0 200 OK\r"; - Incoming.C.write_line ic "\r"; - Incoming.C.flush ic >>= function - | Error e -> err_flush e - | Ok () -> - Incoming.C.write_line ic "hello"; - Incoming.C.flush ic >|= function - | Error e -> err_flush e - | Ok () -> () - ) (fun server -> - proxy_port := server.Server.port; - Slirp_stack.Slirp_stack.Debug.update_http - ~https:(Uri.(to_string @@ with_port proxy (Some server.Server.port))) () - >>= function - | Error (`Msg m) -> failwith ("Failed to enable HTTP proxy: " ^ m) - | Ok () -> - let open Slirp_stack in - Client.TCPV4.create_connection (Client.tcpv4 stack.t) - (primary_dns_ip, 3129) - >>= function - | Error _ -> - Log.err (fun f -> - f "TCPV4.create_connection %s:%d failed" - (Ipaddr.V4.to_string primary_dns_ip) 3129); - failwith "TCPV4.create_connection" - | Ok flow -> - let oc = Outgoing.C.create flow in - let request = - let connect = Cohttp.Request.make ~meth:`CONNECT (Uri.make ()) in - let resource = Fmt.str "localhost:%d" server.Server.port in - let headers = Cohttp.Header.replace connect.Cohttp.Request.headers "host" resource in - { connect with Cohttp.Request.resource; headers } - in - Outgoing.Request.write ~flush:true (fun _writer -> Lwt.return_unit) request oc - >>= fun () -> - Outgoing.Response.read oc - >>= function - | `Eof -> - failwith "test_http_connect_forward: EOF on HTTP CONNECT" - | `Invalid x -> - failwith ("test_http_connect_forward: Invalid HTTP response: " ^ x) - | `Ok res -> - if res.Cohttp.Response.status <> `OK - then failwith "test_http_connect_forward: HTTP CONNECT failed"; - Outgoing.C.read_some ~len:5 oc >>= function - | Error e -> Fmt.kstr failwith "%a" Outgoing.C.pp_error e - | Ok `Eof -> failwith "EOF" - | Ok (`Data buf) -> - let txt = Cstruct.to_string buf in - Alcotest.check Alcotest.string "message" "hello" txt; - Lwt.return_unit - ) - ) - end +let test_http_connect_forward proxy () = + (* Run a proxy, send an HTTP CONNECT to it, check the forwarded request *) + let proxy_port = ref 0 in + Host.Main.run + (Slirp_stack.with_stack ~pcap:"test_http_connect_forward.pcap" + (fun _ stack -> + with_server + (fun flow -> + let ic = Incoming.C.create flow in + Incoming.Request.read ic >>= function + | `Eof -> + Log.err (fun f -> f "Failed to request"); + failwith "Failed to read request" + | `Invalid x -> + Log.err (fun f -> f "Failed to parse request: %s" x); + failwith ("Failed to parse request: " ^ x) + | `Ok req -> ( + Log.info (fun f -> + f "received: %s" + (Sexplib.Sexp.to_string_hum + (Cohttp.Request.sexp_of_t req))); + Alcotest.check Alcotest.string "method" + (Cohttp.Code.string_of_method `CONNECT) + (Cohttp.Code.string_of_method req.Cohttp.Request.meth); + Printf.fprintf stderr "Headers =\n %s\n%!" + (String.concat "\n " + (List.map + (fun (k, v) -> k ^ ": " ^ v) + (Cohttp.Header.to_list req.Cohttp.Request.headers))); + Alcotest.check + Alcotest.(option string) + "host" + (Some ("localhost:" ^ string_of_int !proxy_port)) + (Cohttp.Header.get req.Cohttp.Request.headers "host"); + Alcotest.check Alcotest.string "resource" + ("localhost:" ^ string_of_int !proxy_port) + req.Cohttp.Request.resource; + (* If the proxy uses auth, then there has to be a Proxy-Authorization + header. If theres no auth, there should be no header. *) + let proxy_authorization = "proxy-authorization" in + (match (Uri.user proxy, Uri.password proxy) with + | Some username, Some password -> + Alcotest.check + Alcotest.(list string) + proxy_authorization + [ + "Basic " ^ Base64.encode_exn (username ^ ":" ^ password); + ] + (Cohttp.Header.get_multi req.Cohttp.Request.headers + proxy_authorization) + | _, _ -> + Alcotest.check + Alcotest.(list string) + proxy_authorization [] + (Cohttp.Header.get_multi req.Cohttp.Request.headers + proxy_authorization)); + (* Unfortunately cohttp always adds transfer-encoding: chunked + so we write the header ourselves *) + Incoming.C.write_line ic "HTTP/1.0 200 OK\r"; + Incoming.C.write_line ic "\r"; ...TRUNCATED BY DUNE... - >>= fun () -> - forwarded - >>= fun result -> - Log.info (fun f -> - f "original was: %s" - (Sexplib.Sexp.to_string_hum (Cohttp.Request.sexp_of_t request))); - Log.info (fun f -> - f "proxied was: %s" - (Sexplib.Sexp.to_string_hum (Cohttp.Request.sexp_of_t result))); - Alcotest.check Alcotest.string "method" - (Cohttp.Code.string_of_method request.Cohttp.Request.meth) - (Cohttp.Code.string_of_method result.Cohttp.Request.meth); - Alcotest.check Alcotest.string "version" - (Cohttp.Code.string_of_version request.Cohttp.Request.version) - (Cohttp.Code.string_of_version result.Cohttp.Request.version); - Alcotest.check Alcotest.(option string) "URI.host" - (Cohttp.Request.uri request |> Uri.host) - (Cohttp.Request.uri result |> Uri.host); - Alcotest.check Alcotest.(list string) "host headers" - (Cohttp.Header.to_list request.Cohttp.Request.headers |> List.filter (fun (x, _) -> x = "host") |> List.map snd) - (Cohttp.Header.to_list result.Cohttp.Request.headers |> List.filter (fun (x, _) -> x = "host") |> List.map snd); - Lwt.return_unit - ) - ) - end - - - let test_http_proxy_head () = - Host.Main.run begin - Slirp_stack.with_stack ~pcap:"test_http_proxy_head.pcap" (fun _ stack -> - let open Slirp_stack in - Client.TCPV4.create_connection (Client.tcpv4 stack.t) (primary_dns_ip, 3128) - >>= function - | Error _ -> - Log.err (fun f -> f "Failed to connect to %s:3128" (Ipaddr.V4.to_string primary_dns_ip)); - failwith "test_proxy_head: connect failed" - | Ok flow -> - Log.info (fun f -> f "Connected to %s:3128" (Ipaddr.V4.to_string primary_dns_ip)); - let oc = Outgoing.C.create flow in - let host = "neverssl.com" in - let request = Cohttp.Request.make ~meth:`HEAD (Uri.make ~host ()) in - Outgoing.Request.write ~flush:true (fun _writer -> Lwt.return_unit) request oc - >>= fun () -> - Outgoing.Response.read oc - >>= function - | `Eof -> - failwith "test_proxy_head: EOF on HTTP HEAD" - | `Invalid x -> - failwith ("test_proxy_head: Invalid HTTP response: " ^ x) - | `Ok _ -> - (* any valid HTTP response will do *) - (* Now try another request to see if the channel still works *) - let request = Cohttp.Request.make ~meth:`GET (Uri.make ~host ()) in - Outgoing.Request.write ~flush:true (fun _writer -> Lwt.return_unit) request oc - >>= fun () -> - let t = - Outgoing.Response.read oc - >>= function - | `Eof -> - failwith "test_proxy_head: EOF on HTTP GET after HEAD" - | `Invalid x -> - failwith ("test_proxy_head: Invalid HTTP response: " ^ x) - | `Ok _ -> - (* any HTTP response will do *) - Lwt.return `Ok in - Lwt.pick [ - (Host.Time.sleep_ns (Duration.of_sec 100) >|= fun () -> `Timeout); - t - ] >>= function - | `Timeout -> failwith "test_proxy_head timed out" - | `Ok -> Lwt.return_unit - ) - end - - let test_transparent_http_proxy_exclude () = - Host.Main.run begin - let forwarded, forwarded_u = Lwt.task () in - Slirp_stack.with_stack ~pcap:"test_transparent_http_proxy_exclude.pcap" (fun _ stack -> - (* Start a web server (not a proxy) *) - with_server (fun flow -> - let ic = Incoming.C.create flow in - Incoming.Request.read ic >>= function - | `Eof -> - Log.err (fun f -> f "Failed to request"); - failwith "Failed to read request" - | `Invalid x -> - Log.err (fun f -> f "Failed to parse request: %s" x); - failwith ("Failed to parse request: " ^ x) - | `Ok req -> - (* parse the response *) - Lwt.wakeup_later forwarded_u req; - Lwt.return_unit - ) (fun server -> - let host = "127.0.0.1" in - let port = server.Server.port in - Log.info (fun f -> f "HTTP server is on %s:%d" host port); - let open Slirp_stack in - Slirp_stack.Debug.update_http - ~exclude:"localhost" - ~http:(Printf.sprintf "http://localhost:%d" (port + 1)) - ~transparent_http_ports:[port] - () - >>= function - | Error (`Msg m) -> failwith ("Failed to enable HTTP proxy: " ^ m) - | Ok () -> - (* Create a regular HTTP connection, this should be caught by the transparent - proxy *) - Client.TCPV4.create_connection (Client.tcpv4 stack.t) (Ipaddr.V4.of_string_exn host, port) - >>= function - | Error _ -> - Log.err (fun f -> f "Failed to connect to %s:%d" host port); - failwith "test_transparent_http_proxy_exclude: connect failed" - | Ok flow -> - Log.info (fun f -> f "Connected to %s:%d" host port); - let oc = Outgoing.C.create flow in - let host = "localhost" in - (* Add Host: localhost so the request should bypass the proxy *) - let headers = - Cohttp.Header.add (Cohttp.Header.init ()) "Host" ("localhost:" ^ (string_of_int port)) - in - let request = Cohttp.Request.make ~meth:`GET ~headers (Uri.make ~host ()) in - Outgoing.Request.write ~flush:true (fun _writer -> Lwt.return_unit) request oc - >>= fun () -> - Lwt.pick [ - (Host.Time.sleep_ns (Duration.of_sec 100) >|= fun () -> `Timeout); - forwarded >|= fun request -> - Log.info (fun f -> - f "Successfully received: %s" - (Sexplib.Sexp.to_string_hum (Cohttp.Request.sexp_of_t request))); - `Ok - ] >>= function - | `Timeout -> failwith "test_transparent_http_proxy_exclude timed out" - | `Ok -> Lwt.return_unit - ) - ) - end - - -let proxy_urls = [ - "http://127.0.0.1"; - "http://user:password@127.0.0.1"; - "http://localhost"; -] @ (List.map (fun name -> - Printf.sprintf "http://%s" (Dns.Name.to_string name) -) Slirp_stack.names_for_localhost) - -let tests = [ - "HTTP: interception", - [ "", `Quick, test_interception "http://127.0.0.1" ]; - - "HTTP proxy: CONNECT", - [ "check that HTTP CONNECT requests through the proxy", `Quick, test_http_proxy_connect ]; - - "HTTP proxy: CONNECT rejected", - [ "check that HTTP CONNECT requests must match the allow list", `Quick, test_http_proxy_connect_rejected ]; +let test_http_proxy_connect_fail () = + Host.Main.run + (Slirp_stack.with_stack ~pcap:"test_http_proxy_connect_fail.pcap" + (fun _ stack -> + let json = Ezjsonm.from_string "{ }" in + Slirp_stack.Slirp_stack.Debug.update_http_json json () >>= function + | Error (`Msg m) -> failwith ("Failed to enable HTTP proxy: " ^ m) + | Ok () -> ( + let open Slirp_stack in + Client.TCPV4.create_connection (Client.tcpv4 stack.t) + (primary_dns_ip, 3128) + >>= function + | Error _ -> + Log.err (fun f -> + f "Failed to connect to %s:3128" + (Ipaddr.V4.to_string primary_dns_ip)); + failwith "test_proxy_connect_fail: connect failed" + | Ok flow -> ( + Log.info (fun f -> + f "Connected to %s:3128" + (Ipaddr.V4.to_string primary_dns_ip)); + let oc = Outgoing.C.create flow in + let request = + let connect = + Cohttp.Request.make ~meth:`CONNECT (Uri.make ()) + in + (* Assume port 25 (SMTP) is free *) + let resource = "localhost:25" in + { connect with Cohttp.Request.resource } + in + Outgoing.Request.write ~flush:true + (fun _writer -> Lwt.return_unit) + request oc + >>= fun () -> + Outgoing.Response.read oc >>= function + | `Eof -> + failwith "test_proxy_connect_fail: EOF on HTTP CONNECT" + | `Invalid x -> + failwith + ("test_proxy_connect_fail: Invalid HTTP response: " ^ x) + | `Ok res -> + if res.Cohttp.Response.status = `OK then + failwith + "test_proxy_connect_fail: HTTP CONNECT succeeded \ + unexpectedly"; + if res.Cohttp.Response.status <> `Service_unavailable then + failwith + "test_proxy_connect_fail: HTTP CONNECT failed with an \ + unexpected code"; + Lwt.return_unit)))) - "HTTP proxy: CONNECT fails", - [ "check that HTTP CONNECT fails if the port is not found", `Quick, test_http_proxy_connect_fail ]; +let test_http_proxy_get_dns () = + Host.Main.run + (Slirp_stack.with_stack ~pcap:"test_http_proxy_get_dns.pcap" (fun _ stack -> + let open Slirp_stack in + Client.TCPV4.create_connection (Client.tcpv4 stack.t) + (primary_dns_ip, 3128) + >>= function + | Error _ -> + Log.err (fun f -> + f "Failed to connect to %s:3128" + (Ipaddr.V4.to_string primary_dns_ip)); + failwith "test_proxy_get_dns: connect failed" + | Ok flow -> ( + Log.info (fun f -> + f "Connected to %s:3128" (Ipaddr.V4.to_string primary_dns_ip)); + let oc = Outgoing.C.create flow in + let host = "does.not.exist.recoil.org" in + let request = Cohttp.Request.make ~meth:`GET (Uri.make ~host ()) in + Outgoing.Request.write ~flush:true + (fun _writer -> Lwt.return_unit) + request oc + >>= fun () -> + Outgoing.Response.read oc >>= function + | `Eof -> failwith "test_proxy_get_dns: EOF on HTTP GET" + | `Invalid x -> + failwith ("test_proxy_get_dns: Invalid HTTP response: " ^ x) + | `Ok res -> + if res.Cohttp.Response.status = `OK then + failwith + "test_proxy_get_dns: HTTP GET to non-existent host \ + succeeded unexpectedly"; + if res.Cohttp.Response.status <> `Service_unavailable then + failwith + "test_proxy_get_dns: HTTP GET to non-existent host failed \ + with an unexpected code"; + Lwt.return_unit))) - "HTTP proxy: GET to bad host", - [ "check that HTTP GET fails if the DNS doesn't resolve", `Quick, test_http_proxy_get_dns ]; +let test_http_proxy_get () = + Host.Main.run + (Slirp_stack.with_stack ~pcap:"test_http_proxy_get.pcap" (fun _ stack -> + let open Slirp_stack in + Client.TCPV4.create_connection (Client.tcpv4 stack.t) + (primary_dns_ip, 3128) + >>= function + | Error _ -> + Log.err (fun f -> + f "Failed to connect to %s:3128" + (Ipaddr.V4.to_string primary_dns_ip)); + failwith "test_proxy_get: connect failed" + | Ok flow -> ( + Log.info (fun f -> + f "Connected to %s:3128" (Ipaddr.V4.to_string primary_dns_ip)); + let oc = Outgoing.C.create flow in + let host = "neverssl.com" in + let request = Cohttp.Request.make ~meth:`GET (Uri.make ~host ()) in + Outgoing.Request.write ~flush:true + (fun _writer -> Lwt.return_unit) + request oc + >>= fun () -> + Outgoing.Response.read oc >>= function + | `Eof -> failwith "test_proxy_get: EOF on HTTP GET" + | `Invalid x -> + failwith ("test_proxy_get: Invalid HTTP response: " ^ x) + | `Ok _ -> + (* any response is ok. We'll probably get a "301 Moved Permanently" *) + Lwt.return_unit))) - "HTTP proxy: GET to good host", - [ "check that HTTP GET succeeds normally", `Quick, test_http_proxy_get ]; +let test_http_proxy_headers () = + Host.Main.run + (let forwarded, forwarded_u = Lwt.task () in + Slirp_stack.with_stack ~pcap:"test_http_proxy_headers.pcap" (fun _ stack -> + with_server + (fun flow -> + let ic = Incoming.C.create flow in + Incoming.Request.read ic >>= function + | `Eof -> + Log.err (fun f -> f "Failed to request"); + failwith "Failed to read request" + | `Invalid x -> + Log.err (fun f -> f "Failed to parse request: %s" x); + failwith ("Failed to parse request: " ^ x) + | `Ok req -> + (* parse the response *) + Lwt.wakeup_later forwarded_u req; + Lwt.return_unit) + (fun server -> + let host = "127.0.0.1" in + let port = server.Server.port in + let open Slirp_stack in + Client.TCPV4.create_connection (Client.tcpv4 stack.t) + (primary_dns_ip, 3128) + >>= function + | Error _ -> + Log.err (fun f -> + f "Failed to connect to %s:3128" + (Ipaddr.V4.to_string primary_dns_ip)); + failwith "test_proxy_get: connect failed" + | Ok flow -> + Log.info (fun f -> + f "Connected to %s:3128" + (Ipaddr.V4.to_string primary_dns_ip)); + let oc = Outgoing.C.create flow in + let request = + Cohttp.Request.make ~meth:`GET (Uri.make ~host ~port ()) + in + Outgoing.Request.write ~flush:true + (fun _writer -> Lwt.return_unit) + request oc + >>= fun () -> + forwarded >>= fun result -> + Log.info (fun f -> + f "original was: %s" + (Sexplib.Sexp.to_string_hum + (Cohttp.Request.sexp_of_t request))); + Log.info (fun f -> + f "proxied was: %s" + (Sexplib.Sexp.to_string_hum + (Cohttp.Request.sexp_of_t result))); + Alcotest.check Alcotest.string "method" + (Cohttp.Code.string_of_method request.Cohttp.Request.meth) + (Cohttp.Code.string_of_method result.Cohttp.Request.meth); + Alcotest.check Alcotest.string "version" + (Cohttp.Code.string_of_version request.Cohttp.Request.version) + (Cohttp.Code.string_of_version result.Cohttp.Request.version); + Alcotest.check + Alcotest.(option string) + "URI.host" + (Cohttp.Request.uri request |> Uri.host) + (Cohttp.Request.uri result |> Uri.host); + Alcotest.check + Alcotest.(list string) + "host headers" + (Cohttp.Header.to_list request.Cohttp.Request.headers + |> List.filter (fun (x, _) -> x = "host") + |> List.map snd) + (Cohttp.Header.to_list result.Cohttp.Request.headers + |> List.filter (fun (x, _) -> x = "host") + |> List.map snd); + Lwt.return_unit))) - "HTTP proxy: GET has good headers", - [ "check that HTTP GET headers are correct", `Quick, test_http_proxy_headers ]; +let test_connection_close explicit_close () = + let body = "Hello\n" in + Host.Main.run + (Slirp_stack.with_stack ~pcap:"test_connection_close.pcap" (fun _ stack -> + with_server + (fun flow -> + let ic = Incoming.C.create flow in + Incoming.Request.read ic >>= function + | `Eof -> + Log.err (fun f -> f "Failed to request"); + failwith "Failed to read request" + | `Invalid x -> + Log.err (fun f -> f "Failed to parse request: %s" x); + failwith ("Failed to parse request: " ^ x) + | `Ok _ -> ( + let response = + if explicit_close then + "HTTP/1.0 200 OK\r\nConnection:close\r\n\r\n" ^ body + else "HTTP/1.0 200 OK\r\n\r\n" ^ body + in + Incoming.C.write_string ic response 0 (String.length response); + Incoming.C.flush ic >>= function + | Error _ -> + failwith "test_connection_close: flush returned error" + | Ok () -> + (* Connection will be closed here *) + Lwt.return_unit)) + (fun origin_server -> + let host = "127.0.0.1" in + let port = origin_server.Server.port in + Log.info (fun f -> f "HTTP origin server is on %s:%d" host port); + let open Slirp_stack in + (* Disable the proxy so the builtin proxy will have to fetch from the origin server *) + Slirp_stack.Debug.update_http () >>= function + | Error (`Msg m) -> failwith ("Failed to disable HTTP proxy: " ^ m) + | Ok () -> ( + (* Connect to the builtin HTTP Proxy *) + Client.TCPV4.create_connection (Client.tcpv4 stack.t) + (primary_dns_ip, 3128) + >>= function + | Error _ -> + Log.err (fun f -> + f "Failed to connect to %s:3128" + (Ipaddr.V4.to_string primary_dns_ip)); + failwith "test_connection_close: connect failed" + | Ok flow -> + Log.info (fun f -> + f "Connected to %a:3128" Ipaddr.V4.pp primary_dns_ip); + let oc = Outgoing.C.create flow in + let request = + let uri = + Uri.make ~scheme:"http" ~host:"localhost" ~port () + in + Cohttp.Request.make ~meth:`GET uri + in + Outgoing.Request.write ~flush:true + (fun _writer -> Lwt.return_unit) + request oc + >>= fun () -> + let response = + Outgoing.Response.read oc >>= function + | `Eof -> + failwith "test_connection_close: EOF on HTTP GET" + | `Invalid x -> + failwith + ("test_connection_close: Invalid HTTP response: " + ^ x) + | `Ok res -> + if res.Cohttp.Response.status <> `OK then + failwith "test_connection_close: HTTP GET failed"; + let reader = + Outgoing.Response.make_body_reader res oc + in + let buf = Buffer.create 100 in + let rec loop () = + let open Cohttp.Transfer in + Outgoing.Response.read_body_chunk reader + >>= function + | Done -> Lwt.return_unit + | Final_chunk x -> + Buffer.add_string buf x; + Lwt.return_unit + | Chunk x -> + Buffer.add_string buf x; + loop () + in + loop () >>= fun () -> + let txt = Buffer.contents buf in + Alcotest.check Alcotest.string "body" body txt; + Lwt.return (`Result ()) + in + Lwt.pick + [ + ( Host.Time.sleep_ns (Duration.of_sec 100) >|= fun () -> + `Timeout ); + response; + ])) + >|= function + | `Timeout -> failwith "HTTP interception failed" + | `Result () -> ())) - "HTTP proxy: GET to localhost works", - [ "check that HTTP GET to localhost via IP", `Quick, test_http_proxy_localhost (Ipaddr.V4.to_string Slirp_stack.localhost_ip) ]; +let test_http_proxy_localhost host_or_ip () = + Host.Main.run + (let forwarded, forwarded_u = Lwt.task () in + Slirp_stack.with_stack ~pcap:"test_http_proxy_localhost.pcap" + (fun _ stack -> + with_server + (fun flow -> + let ic = Incoming.C.create flow in + Incoming.Request.read ic >>= function + | `Eof -> + Log.err (fun f -> f "Failed to request"); + failwith "Failed to read request" + | `Invalid x -> + Log.err (fun f -> f "Failed to parse request: %s" x); + failwith ("Failed to parse request: " ^ x) + | `Ok req -> + (* parse the response *) + Lwt.wakeup_later forwarded_u req; + Lwt.return_unit) + (fun server -> + let host = host_or_ip in + let port = server.Server.port in + let open Slirp_stack in + Client.TCPV4.create_connection (Client.tcpv4 stack.t) + (primary_dns_ip, 3128) + >>= function + | Error _ -> + Log.err (fun f -> + f "Failed to connect to %s:3128" + (Ipaddr.V4.to_string primary_dns_ip)); + failwith "test_proxy_get: connect failed" + | Ok flow -> + Log.info (fun f -> + f "Connected to %s:3128" + (Ipaddr.V4.to_string primary_dns_ip)); + let oc = Outgoing.C.create flow in + let request = + Cohttp.Request.make ~meth:`GET (Uri.make ~host ~port ()) + in + Outgoing.Request.write ~flush:true + (fun _writer -> Lwt.return_unit) + request oc + >>= fun () -> + forwarded >>= fun result -> + Log.info (fun f -> + f "original was: %s" + (Sexplib.Sexp.to_string_hum + (Cohttp.Request.sexp_of_t request))); + Log.info (fun f -> + f "proxied was: %s" + (Sexplib.Sexp.to_string_hum + (Cohttp.Request.sexp_of_t result))); + Alcotest.check Alcotest.string "method" + (Cohttp.Code.string_of_method request.Cohttp.Request.meth) + (Cohttp.Code.string_of_method result.Cohttp.Request.meth); + Alcotest.check Alcotest.string "version" + (Cohttp.Code.string_of_version request.Cohttp.Request.version) + (Cohttp.Code.string_of_version result.Cohttp.Request.version); + Alcotest.check + Alcotest.(option string) + "URI.host" + (Cohttp.Request.uri request |> Uri.host) + (Cohttp.Request.uri result |> Uri.host); + Alcotest.check + Alcotest.(list string) + "host headers" + (Cohttp.Header.to_list request.Cohttp.Request.headers + |> List.filter (fun (x, _) -> x = "host") + |> List.map snd) + (Cohttp.Header.to_list result.Cohttp.Request.headers + |> List.filter (fun (x, _) -> x = "host") + |> List.map snd); + Lwt.return_unit))) - "HTTP proxy: transparent proxy respects excludes", - [ "check that the transparent proxy will inspect and respect the Host: header", `Quick, test_transparent_http_proxy_exclude ]; +let test_http_proxy_head () = + Host.Main.run + (Slirp_stack.with_stack ~pcap:"test_http_proxy_head.pcap" (fun _ stack -> + let open Slirp_stack in + Client.TCPV4.create_connection (Client.tcpv4 stack.t) + (primary_dns_ip, 3128) + >>= function + | Error _ -> + Log.err (fun f -> + f "Failed to connect to %s:3128" + (Ipaddr.V4.to_string primary_dns_ip)); + failwith "test_proxy_head: connect failed" + | Ok flow -> ( + Log.info (fun f -> + f "Connected to %s:3128" (Ipaddr.V4.to_string primary_dns_ip)); + let oc = Outgoing.C.create flow in + let host = "neverssl.com" in + let request = + Cohttp.Request.make ~meth:`HEAD (Uri.make ~host ()) + in + Outgoing.Request.write ~flush:true + (fun _writer -> Lwt.return_unit) + request oc + >>= fun () -> + Outgoing.Response.read oc >>= function + | `Eof -> failwith "test_proxy_head: EOF on HTTP HEAD" + | `Invalid x -> + failwith ("test_proxy_head: Invalid HTTP response: " ^ x) + | `Ok _ -> ( + (* any valid HTTP response will do *) + (* Now try another request to see if the channel still works *) + let request = + Cohttp.Request.make ~meth:`GET (Uri.make ~host ()) + in + Outgoing.Request.write ~flush:true + (fun _writer -> Lwt.return_unit) + request oc + >>= fun () -> + let t = + Outgoing.Response.read oc >>= function + | `Eof -> + failwith "test_proxy_head: EOF on HTTP GET after HEAD" + | `Invalid x -> + failwith ("test_proxy_head: Invalid HTTP response: " ^ x) + | `Ok _ -> + (* any HTTP response will do *) + Lwt.return `Ok + in + Lwt.pick + [ + ( Host.Time.sleep_ns (Duration.of_sec 100) >|= fun () -> + `Timeout ); + t; + ] + >>= function + | `Timeout -> failwith "test_proxy_head timed out" + | `Ok -> Lwt.return_unit)))) - "HTTP proxy: respect connection: close", - [ "check that the transparent proxy will respect connection: close headers from origin servers", `Quick, test_connection_close true ]; +let test_transparent_http_proxy_exclude () = + Host.Main.run + (let forwarded, forwarded_u = Lwt.task () in + Slirp_stack.with_stack ~pcap:"test_transparent_http_proxy_exclude.pcap" + (fun _ stack -> + (* Start a web server (not a proxy) *) + with_server + (fun flow -> + let ic = Incoming.C.create flow in + Incoming.Request.read ic >>= function + | `Eof -> + Log.err (fun f -> f "Failed to request"); + failwith "Failed to read request" + | `Invalid x -> + Log.err (fun f -> f "Failed to parse request: %s" x); + failwith ("Failed to parse request: " ^ x) + | `Ok req -> + (* parse the response *) + Lwt.wakeup_later forwarded_u req; + Lwt.return_unit) + (fun server -> + let host = "127.0.0.1" in + let port = server.Server.port in + Log.info (fun f -> f "HTTP server is on %s:%d" host port); + let open Slirp_stack in + Slirp_stack.Debug.update_http ~exclude:"localhost" + ~http:(Printf.sprintf "http://localhost:%d" (port + 1)) + ~transparent_http_ports:[ port ] () + >>= function + | Error (`Msg m) -> failwith ("Failed to enable HTTP proxy: " ^ m) + | Ok () -> ( + (* Create a regular HTTP connection, this should be caught by the transparent + proxy *) + Client.TCPV4.create_connection (Client.tcpv4 stack.t) + (Ipaddr.V4.of_string_exn host, port) + >>= function + | Error _ -> + Log.err (fun f -> f "Failed to connect to %s:%d" host port); + failwith + "test_transparent_http_proxy_exclude: connect failed" + | Ok flow -> ( + Log.info (fun f -> f "Connected to %s:%d" host port); + let oc = Outgoing.C.create flow in + let host = "localhost" in + (* Add Host: localhost so the request should bypass the proxy *) + let headers = + Cohttp.Header.add (Cohttp.Header.init ()) "Host" + ("localhost:" ^ string_of_int port) + in + let request = + Cohttp.Request.make ~meth:`GET ~headers + (Uri.make ~host ()) + in + Outgoing.Request.write ~flush:true + (fun _writer -> Lwt.return_unit) + request oc + >>= fun () -> + Lwt.pick + [ + ( Host.Time.sleep_ns (Duration.of_sec 100) >|= fun () -> + `Timeout ); + ( forwarded >|= fun request -> + Log.info (fun f -> + f "Successfully received: %s" + (Sexplib.Sexp.to_string_hum + (Cohttp.Request.sexp_of_t request))); + `Ok ); + ] + >>= function + | `Timeout -> + failwith + "test_transparent_http_proxy_exclude timed out" + | `Ok -> Lwt.return_unit))))) - "HTTP proxy: respect HTTP/1.0 implicit connection: close", - [ "check that the transparent proxy will respect HTTP/1.0 implicit connection: close headers from origin servers", `Quick, test_connection_close true ]; +let proxy_urls = + [ "http://127.0.0.1"; "http://user:password@127.0.0.1"; "http://localhost" ] + @ List.map + (fun name -> Printf.sprintf "http://%s" (Dns.Name.to_string name)) + Slirp_stack.names_for_localhost -] @ (List.map (fun name -> - "HTTP proxy: GET to localhost", - [ "check that HTTP GET to localhost via hostname", `Quick, test_http_proxy_localhost (Dns.Name.to_string name) ] - ) Slirp_stack.names_for_localhost -) @ (List.concat @@ List.map (fun proxy -> [ - - "HTTP: URI", - [ "check that relative URIs are rewritten", `Quick, test_uri_relative proxy ]; - - "HTTP: absolute URI", - [ "check that absolute URIs from proxies are preserved", `Quick, test_uri_absolute proxy ]; - - "HTTP: custom header", - ["check that custom headers are preserved", `Quick, test_x_header_preserved proxy ]; - - "HTTP: user-agent", - [ "check that user-agent is preserved", `Quick, test_user_agent_preserved proxy ]; - - "HTTP: authorization", - [ "check that authorization is preserved", `Quick, test_authorization_preserved proxy ]; - - "HTTP: proxy-authorization", - [ "check that proxy-authorization is present when proxy = " ^ proxy, `Quick, test_proxy_authorization proxy ]; - - "HTTP: CONNECT tunnel though " ^ proxy, - [ "check that HTTP CONNECT tunnelling works for HTTPS with proxy " ^ proxy, `Quick, test_http_connect_tunnel (Uri.of_string proxy) ]; - - "HTTP: CONNECT forwarded to " ^ proxy, - [ "check that HTTP CONNECT are forwarded correctly to proxy " ^ proxy, `Quick, test_http_connect_forward (Uri.of_string proxy) ]; - - ]) proxy_urls) @ [ - "HTTP: HEAD", - [ "check that HTTP HEAD doesn't block the connection", `Quick, test_http_proxy_head ]; -] \ No newline at end of file +let tests = + [ + ( "HTTP: interception", + [ ("", `Quick, test_interception "http://127.0.0.1") ] ); + ( "HTTP proxy: CONNECT", + [ + ( "check that HTTP CONNECT requests through the proxy", + `Quick, + test_http_proxy_connect ); + ] ); + ( "HTTP proxy: CONNECT rejected", + [ + ( "check that HTTP CONNECT requests must match the allow list", + `Quick, + test_http_proxy_connect_rejected ); + ] ); + ( "HTTP proxy: CONNECT fails", + [ + ( "check that HTTP CONNECT fails if the port is not found", + `Quick, + test_http_proxy_connect_fail ); + ] ); + ( "HTTP proxy: GET to bad host", + [ + ( "check that HTTP GET fails if the DNS doesn't resolve", + `Quick, + test_http_proxy_get_dns ); + ] ); + ( "HTTP proxy: GET to good host", + [ ("check that HTTP GET succeeds normally", `Quick, test_http_proxy_get) ] + ); + ( "HTTP proxy: GET has good headers", + [ + ( "check that HTTP GET headers are correct", + `Quick, + test_http_proxy_headers ); + ] ); + ( "HTTP proxy: GET to localhost works", + [ + ( "check that HTTP GET to localhost via IP", + `Quick, + test_http_proxy_localhost + (Ipaddr.V4.to_string Slirp_stack.localhost_ip) ); + ] ); + ( "HTTP proxy: transparent proxy respects excludes", + [ + ( "check that the transparent proxy will inspect and respect the Host: \ + header", + `Quick, + test_transparent_http_proxy_exclude ); + ] ); + ( "HTTP proxy: respect connection: close", + [ + ( "check that the transparent proxy will respect connection: close \ + headers from origin servers", + `Quick, + test_connection_close true ); + ] ); + ( "HTTP proxy: respect HTTP/1.0 implicit connection: close", + [ + ( "check that the transparent proxy will respect HTTP/1.0 implicit \ + connection: close headers from origin servers", + `Quick, + test_connection_close true ); + ] ); + ] + @ List.map + (fun name -> + ( "HTTP proxy: GET to localhost", + [ + ( "check that HTTP GET to localhost via hostname", + `Quick, + test_http_proxy_localhost (Dns.Name.to_string name) ); + ] )) + Slirp_stack.names_for_localhost + @ (List.concat + @@ List.map + (fun proxy -> + [ + ( "HTTP: URI", + [ + ( "check that relative URIs are rewritten", + `Quick, + test_uri_relative proxy ); + ] ); + ( "HTTP: absolute URI", + [ + ( "check that absolute URIs from proxies are preserved", + `Quick, + test_uri_absolute proxy ); + ] ); + ( "HTTP: custom header", + [ + ( "check that custom headers are preserved", + `Quick, + test_x_header_preserved proxy ); + ] ); + ( "HTTP: user-agent", + [ + ( "check that user-agent is preserved", + `Quick, + test_user_agent_preserved proxy ); + ] ); + ( "HTTP: authorization", + [ + ( "check that authorization is preserved", + `Quick, + test_authorization_preserved proxy ); + ] ); + ( "HTTP: proxy-authorization", + [ + ( "check that proxy-authorization is present when proxy = " + ^ proxy, + `Quick, + test_proxy_authorization proxy ); + ] ); + ( "HTTP: CONNECT tunnel though " ^ proxy, + [ + ( "check that HTTP CONNECT tunnelling works for HTTPS with \ + proxy " ^ proxy, + `Quick, + test_http_connect_tunnel (Uri.of_string proxy) ); + ] ); + ( "HTTP: CONNECT forwarded to " ^ proxy, + [ + ( "check that HTTP CONNECT are forwarded correctly to proxy " + ^ proxy, + `Quick, + test_http_connect_forward (Uri.of_string proxy) ); + ] ); + ]) + proxy_urls) + @ [ + ( "HTTP: HEAD", + [ + ( "check that HTTP HEAD doesn't block the connection", + `Quick, + test_http_proxy_head ); + ] ); + ] File "src/hostnet/slirp.ml", line 1, characters 0-0: diff --git a/_build/default/src/hostnet/slirp.ml b/_build/default/src/hostnet/.formatted/slirp.ml index ec7daaf..3ec0c11 100644 --- a/_build/default/src/hostnet/slirp.ml +++ b/_build/default/src/hostnet/.formatted/slirp.ml @@ -7,108 +7,121 @@ let src = module Log = (val Logs.src_log src : Logs.LOG) -module IPMap = Map.Make(struct +module IPMap = Map.Make (struct type t = Ipaddr.V4.t * Ipaddr.V4.t + let compare (a, c) (b, d) = let x = Ipaddr.V4.compare a b in if x <> 0 then x else Ipaddr.V4.compare c d - end) +end) (* When forwarding TCP, the connection is proxied so the MTU/MSS is link-local. When forwarding UDP, the datagram on the internal link is the same size as the corresponding datagram on the external link, so we have to be careful to respect the Do Not Fragment bit. *) -let safe_outgoing_mtu = 1452 (* packets above this size with DNF set - will get ICMP errors *) +let safe_outgoing_mtu = 1452 +(* packets above this size with DNF set + will get ICMP errors *) let log_exception_continue description f = Lwt.catch (fun () -> f ()) (fun e -> - Log.debug (fun f -> f "%s: caught %a" description Fmt.exn e); - Lwt.return () - ) + Log.debug (fun f -> f "%s: caught %a" description Fmt.exn e); + Lwt.return ()) let failf fmt = Fmt.kstr Lwt.fail_with fmt let or_failwith name m = m >>= function | Error _ -> failf "Failed to connect %s device" name - | Ok x -> Lwt.return x + | Ok x -> Lwt.return x type pcap = (string * int64 option) option let print_pcap = function -| None -> "disabled" -| Some (file, None) -> Fmt.str "capturing to %s with no limit" file -| Some (file, Some limit) -> - Fmt.str "capturing to %s but limited to %Ld" file limit + | None -> "disabled" + | Some (file, None) -> Fmt.str "capturing to %s with no limit" file + | Some (file, Some limit) -> + Fmt.str "capturing to %s but limited to %Ld" file limit type arp_table = { - mutex: Lwt_mutex.t; - mutable table: (Ipaddr.V4.t * Macaddr.t) list; + mutex : Lwt_mutex.t; + mutable table : (Ipaddr.V4.t * Macaddr.t) list; } type uuid_table = { - mutex: Lwt_mutex.t; - table: (Uuidm.t, Ipaddr.V4.t * int) Hashtbl.t; + mutex : Lwt_mutex.t; + table : (Uuidm.t, Ipaddr.V4.t * int) Hashtbl.t; } module Make - (Vmnet: Sig.VMNET) - (Dns_policy: Sig.DNS_POLICY) - (Clock: Mirage_clock.MCLOCK) - (Random: Mirage_random.S) + (Vmnet : Sig.VMNET) + (Dns_policy : Sig.DNS_POLICY) + (Clock : Mirage_clock.MCLOCK) + (Random : Mirage_random.S) (Vnet : Vnetif.BACKEND with type macaddr = Macaddr.t) = struct (* module Tcpip_stack = Tcpip_stack.Make(Vmnet)(Host.Time) *) type stack = { - configuration: Configuration.t; - global_arp_table: arp_table; - client_uuids: uuid_table; - vnet_switch: Vnet.t; + configuration : Configuration.t; + global_arp_table : arp_table; + client_uuids : uuid_table; + vnet_switch : Vnet.t; } - module Filteredif = Filter.Make(Vmnet) - module Netif = Capture.Make(Filteredif) - module Recorder = (Netif: Sig.RECORDER with type t = Netif.t) - module Switch = Mux.Make(Netif) - module Dhcp = Hostnet_dhcp.Make(Clock)(Switch) + module Filteredif = Filter.Make (Vmnet) + module Netif = Capture.Make (Filteredif) + module Recorder : Sig.RECORDER with type t = Netif.t = Netif + module Switch = Mux.Make (Netif) + module Dhcp = Hostnet_dhcp.Make (Clock) (Switch) (* This ARP implementation will respond to the VM: *) - module Global_arp_ethif = Ethernet.Make(Switch) - module Global_arp = Static_arp.Make(Global_arp_ethif) + module Global_arp_ethif = Ethernet.Make (Switch) + module Global_arp = Static_arp.Make (Global_arp_ethif) (* This stack will attach to a switch port and represent a single remote IP *) - module Stack_ethif = Ethernet.Make(Switch.Port) - module Stack_arpv4 = Static_arp.Make(Stack_ethif) - module Stack_ipv4 = Static_ipv4.Make(Random)(Clock)(Stack_ethif)(Stack_arpv4) - module Stack_icmpv4 = Icmpv4.Make(Stack_ipv4) - module Stack_tcp_wire = Tcp.Wire.Make(Stack_ipv4) - module Stack_udp = Udp.Make(Stack_ipv4)(Random) + module Stack_ethif = Ethernet.Make (Switch.Port) + module Stack_arpv4 = Static_arp.Make (Stack_ethif) + + module Stack_ipv4 = + Static_ipv4.Make (Random) (Clock) (Stack_ethif) (Stack_arpv4) + + module Stack_icmpv4 = Icmpv4.Make (Stack_ipv4) + module Stack_tcp_wire = Tcp.Wire.Make (Stack_ipv4) + module Stack_udp = Udp.Make (Stack_ipv4) (Random) + module Stack_tcp = struct - include Tcp.Flow.Make(Stack_ipv4)(Host.Time)(Clock)(Random) + include Tcp.Flow.Make (Stack_ipv4) (Host.Time) (Clock) (Random) + let shutdown_read _flow = (* No change to the TCP PCB: all this means is that I've got my finders in my ears and am nolonger listening to what you say. *) Lwt.return () + let shutdown_write = close + (* Disable Nagle's algorithm *) let write = write_nodelay end module Dns_forwarder = - Hostnet_dns.Make(Stack_ipv4)(Stack_udp)(Stack_tcp)(Host.Sockets)(Host.Dns) - (Host.Time)(Clock)(Recorder) + Hostnet_dns.Make (Stack_ipv4) (Stack_udp) (Stack_tcp) (Host.Sockets) + (Host.Dns) + (Host.Time) + (Clock) + (Recorder) + module Http_forwarder = - Hostnet_http.Make(Stack_ipv4)(Stack_udp)(Stack_tcp)(Forwards.Stream.Tcp)(Host.Dns) + Hostnet_http.Make (Stack_ipv4) (Stack_udp) (Stack_tcp) (Forwards.Stream.Tcp) + (Host.Dns) + + module Udp_nat = Hostnet_udp.Make (Host.Sockets) (Clock) (Host.Time) + module Icmp_nat = Hostnet_icmp.Make (Host.Sockets) (Clock) (Host.Time) - module Udp_nat = Hostnet_udp.Make(Host.Sockets)(Clock)(Host.Time) - module Icmp_nat = Hostnet_icmp.Make(Host.Sockets)(Clock)(Host.Time) - let dns_forwarder ~local_address ~builtin_names = Dns_forwarder.create ~local_address ~builtin_names (Dns_policy.config ()) @@ -116,36 +129,43 @@ struct let dns = let ip = Ipaddr.V4 Configuration.default_gateway_ip in let local_address = { Dns_forward.Config.Address.ip; port = 0 } in - ref ( - dns_forwarder ~local_address ~builtin_names:[] - ) + ref (dns_forwarder ~local_address ~builtin_names:[]) (* Global variable containing the global HTTP proxy configuration *) - let http = - ref None + let http = ref None - let is_dns = let open Frame in function + let is_dns = + let open Frame in + function | Ethernet { payload = Ipv4 { payload = Udp { src = 53; _ }; _ }; _ } | Ethernet { payload = Ipv4 { payload = Udp { dst = 53; _ }; _ }; _ } | Ethernet { payload = Ipv4 { payload = Tcp { src = 53; _ }; _ }; _ } | Ethernet { payload = Ipv4 { payload = Tcp { dst = 53; _ }; _ }; _ } -> - true + true | _ -> false - let is_ntp = let open Frame in function + let is_ntp = + let open Frame in + function | Ethernet { payload = Ipv4 { payload = Udp { src = 123; _ }; _ }; _ } | Ethernet { payload = Ipv4 { payload = Udp { dst = 123; _ }; _ }; _ } -> - true + true | _ -> false - let is_icmp = let open Frame in function + let is_icmp = + let open Frame in + function | Ethernet { payload = Ipv4 { payload = Icmp _; _ }; _ } -> true | _ -> false - let is_http_proxy = let open Frame in function - | Ethernet { payload = Ipv4 { payload = Tcp { src = (3128 | 3129); _ }; _ }; _ } - | Ethernet { payload = Ipv4 { payload = Tcp { dst = (3128 | 3129); _ }; _ }; _ } -> - true + let is_http_proxy = + let open Frame in + function + | Ethernet + { payload = Ipv4 { payload = Tcp { src = 3128 | 3129; _ }; _ }; _ } + | Ethernet + { payload = Ipv4 { payload = Tcp { dst = 3128 | 3129; _ }; _ }; _ } -> + true | _ -> false let string_of_id id = @@ -153,48 +173,45 @@ struct let src_port = Stack_tcp_wire.src_port id in let dst = Stack_tcp_wire.dst id in let dst_port = Stack_tcp_wire.dst_port id in - Fmt.str "TCP %a:%d > %a:%d" - Ipaddr.V4.pp dst dst_port - Ipaddr.V4.pp src src_port + Fmt.str "TCP %a:%d > %a:%d" Ipaddr.V4.pp dst dst_port Ipaddr.V4.pp src + src_port module Tcp = struct - module Id = struct module M = struct type t = Stack_tcp_wire.t + let compare id1 id2 = - let dst_ip1 = Stack_tcp_wire.dst id1 in + let dst_ip1 = Stack_tcp_wire.dst id1 in let dst_port1 = Stack_tcp_wire.dst_port id1 in - let dst_ip2 = Stack_tcp_wire.dst id2 in + let dst_ip2 = Stack_tcp_wire.dst id2 in let dst_port2 = Stack_tcp_wire.dst_port id2 in - let src_ip1 = Stack_tcp_wire.src id1 in + let src_ip1 = Stack_tcp_wire.src id1 in let src_port1 = Stack_tcp_wire.src_port id1 in - let src_ip2 = Stack_tcp_wire.src id2 in + let src_ip2 = Stack_tcp_wire.src id2 in let src_port2 = Stack_tcp_wire.src_port id2 in - let dst_ip' = Ipaddr.V4.compare dst_ip1 dst_ip2 in + let dst_ip' = Ipaddr.V4.compare dst_ip1 dst_ip2 in let dst_port' = compare dst_port1 dst_port2 in - let src_ip' = Ipaddr.V4.compare src_ip1 src_ip2 in + let src_ip' = Ipaddr.V4.compare src_ip1 src_ip2 in let src_port' = compare src_port1 src_port2 in - if dst_port' <> 0 - then dst_port' - else if dst_ip' <> 0 - then dst_ip' - else if src_port' <> 0 - then src_port' + if dst_port' <> 0 then dst_port' + else if dst_ip' <> 0 then dst_ip' + else if src_port' <> 0 then src_port' else src_ip' end + include M - module Set = Set.Make(M) - module Map = Map.Make(M) + module Set = Set.Make (M) + module Map = Map.Make (M) end module Flow = struct (** An established flow *) type t = { - id: Stack_tcp_wire.t; - mutable socket: Forwards.Stream.Tcp.flow option; - mutable last_active_time_ns: int64; + id : Stack_tcp_wire.t; + mutable socket : Forwards.Stream.Tcp.flow option; + mutable last_active_time_ns : int64; } (* Consider the case when a computer is sleep for several hours and then powered on. @@ -202,13 +219,14 @@ struct and possibly terminate them. If we use a monotonic clock driven from a CPU counter: the clock will be paused while the computer is asleep so we will conclude the flows are still active. *) - let idle_time t : Duration.t = Int64.sub (Clock.elapsed_ns ()) t.last_active_time_ns + let idle_time t : Duration.t = + Int64.sub (Clock.elapsed_ns ()) t.last_active_time_ns let to_string t = - Printf.sprintf "%s socket = %s last_active = %s" - (string_of_id t.id) + Printf.sprintf "%s socket = %s last_active = %s" (string_of_id t.id) (match t.socket with None -> "closed" | _ -> "open") - (Duration.pp Format.str_formatter (idle_time t); Format.flush_str_formatter ()) + (Duration.pp Format.str_formatter (idle_time t); + Format.flush_str_formatter ()) (* Global table of active flows *) let all : t Id.Map.t ref = ref Id.Map.empty @@ -223,74 +241,86 @@ struct let t = { id; socket; last_active_time_ns } in all := Id.Map.add id t !all; t + let close id t = (* Closing the socket should cause the proxy to exit cleanly *) - begin match t.socket with + match t.socket with | Some socket -> - t.socket <- None; - Forwards.Stream.Tcp.close socket + t.socket <- None; + Forwards.Stream.Tcp.close socket | None -> - (* If we have a Tcp.Flow still in the table, there should still be an - active socket, otherwise the state has gotten out-of-sync *) - Log.warn (fun f -> f "%s: no socket registered, possible socket leak" (string_of_id id)); - Lwt.return_unit - end - let remove id = - all := Id.Map.remove id !all + (* If we have a Tcp.Flow still in the table, there should still be an + active socket, otherwise the state has gotten out-of-sync *) + Log.warn (fun f -> + f "%s: no socket registered, possible socket leak" + (string_of_id id)); + Lwt.return_unit + + let remove id = all := Id.Map.remove id !all let mem id = Id.Map.mem id !all let find id = Id.Map.find id !all + let touch id = - if Id.Map.mem id !all then begin + if Id.Map.mem id !all then let flow = Id.Map.find id !all in flow.last_active_time_ns <- Clock.elapsed_ns () - end end end module Endpoint = struct - type t = { - recorder: Recorder.t; - netif: Switch.Port.t; - ethif: Stack_ethif.t; - arp: Stack_arpv4.t; - ipv4: Stack_ipv4.t; - icmpv4: Stack_icmpv4.t; - udp4: Stack_udp.t; - tcp4: Stack_tcp.t; - remote: Ipaddr.V4.t; - mtu: int; - mutable pending: Tcp.Id.Set.t; - mutable last_active_time_ns: int64; + recorder : Recorder.t; + netif : Switch.Port.t; + ethif : Stack_ethif.t; + arp : Stack_arpv4.t; + ipv4 : Stack_ipv4.t; + icmpv4 : Stack_icmpv4.t; + udp4 : Stack_udp.t; + tcp4 : Stack_tcp.t; + remote : Ipaddr.V4.t; + mtu : int; + mutable pending : Tcp.Id.Set.t; + mutable last_active_time_ns : int64; (* Used to shutdown connections when the endpoint is removed from the switch. *) - mutable established: Tcp.Id.Set.t; + mutable established : Tcp.Id.Set.t; } (** A generic TCP/IP endpoint *) - let touch t = - t.last_active_time_ns <- Clock.elapsed_ns () + let touch t = t.last_active_time_ns <- Clock.elapsed_ns () - let idle_time t : Duration.t = Int64.sub (Clock.elapsed_ns ()) t.last_active_time_ns + let idle_time t : Duration.t = + Int64.sub (Clock.elapsed_ns ()) t.last_active_time_ns let create recorder switch arp_table remote local mtu = let netif = Switch.port switch remote in Stack_ethif.connect netif >>= fun ethif -> - Stack_arpv4.connect ~table:arp_table ethif |>fun arp -> + Stack_arpv4.connect ~table:arp_table ethif |> fun arp -> Stack_ipv4.connect ~cidr:(Ipaddr.V4.Prefix.of_addr remote) - ~gateway:local - ethif arp + ~gateway:local ethif arp >>= fun ipv4 -> Stack_icmpv4.connect ipv4 >>= fun icmpv4 -> Stack_udp.connect ipv4 >>= fun udp4 -> Stack_tcp.connect ipv4 >>= fun tcp4 -> - let pending = Tcp.Id.Set.empty in let last_active_time_ns = Clock.elapsed_ns () in let established = Tcp.Id.Set.empty in let tcp_stack = - { recorder; netif; ethif; arp; ipv4; icmpv4; udp4; tcp4; remote; mtu; pending; - last_active_time_ns; established } + { + recorder; + netif; + ethif; + arp; + ipv4; + icmpv4; + udp4; + tcp4; + remote; + mtu; + pending; + last_active_time_ns; + established; + } in Lwt.return tcp_stack @@ -299,20 +329,23 @@ struct let close_flow t ~id reason = Log.debug (fun f -> f "%s: close_flow" (string_of_id id)); (* The flow might have been completely closed already *) - if Tcp.Flow.mem id then begin + if Tcp.Flow.mem id then ( let tcp = Tcp.Flow.find id in - begin match reason with + (match reason with | `Port_disconnect -> - Log.warn (fun f -> f "%s closing flow due to idle port disconnection" (string_of_id id)) + Log.warn (fun f -> + f "%s closing flow due to idle port disconnection" + (string_of_id id)) | `Reset -> - Log.debug (fun f -> f "%s: closing flow due to TCP RST" (string_of_id id)) + Log.debug (fun f -> + f "%s: closing flow due to TCP RST" (string_of_id id)) | `Fin -> - Log.debug (fun f -> f "%s: closing flow due to TCP FIN" (string_of_id id)) - end; + Log.debug (fun f -> + f "%s: closing flow due to TCP FIN" (string_of_id id))); Tcp.Flow.remove id; t.established <- Tcp.Id.Set.remove id t.established; - Tcp.Flow.close id tcp - end else Lwt.return_unit + Tcp.Flow.close id tcp) + else Lwt.return_unit let destroy t = let all = Tcp.Id.Set.fold (fun id acc -> id :: acc) t.established [] in @@ -321,106 +354,95 @@ struct t.established <- Tcp.Id.Set.empty; Lwt.return_unit - let intercept_tcp t ~id ~syn ~rst on_syn_callback (buf: Cstruct.t) = + let intercept_tcp t ~id ~syn ~rst on_syn_callback (buf : Cstruct.t) = (* Note that we must cleanup even when the connection is reset before it is fully established. *) - ( if rst - then close_flow t ~id `Reset - else Lwt.return_unit ) - >>= fun () -> - if syn then begin - if Tcp.Id.Set.mem id t.pending then begin + (if rst then close_flow t ~id `Reset else Lwt.return_unit) >>= fun () -> + if syn then + if Tcp.Id.Set.mem id t.pending then ( (* This can happen if the `connect` blocks for a few seconds *) - Log.debug (fun - f -> f "%s: connection in progress, ignoring duplicate \ - SYN" (string_of_id id)); - Lwt.return_unit - end else if Tcp.Flow.mem id then begin + Log.debug (fun f -> + f "%s: connection in progress, ignoring duplicate SYN" + (string_of_id id)); + Lwt.return_unit) + else if Tcp.Flow.mem id then ( (* This can happen when receiving a retransmitted SYN. Simply drop it. In many cases, it will be recovered by our SYN+ACK retransmission. *) - Log.debug (fun - f -> f "%s: old connection, ignoring duplicate \ - SYN" (string_of_id id)); - Lwt.return_unit - end else begin + Log.debug (fun f -> + f "%s: old connection, ignoring duplicate SYN" (string_of_id id)); + Lwt.return_unit) + else ( t.pending <- Tcp.Id.Set.add id t.pending; t.established <- Tcp.Id.Set.add id t.established; Lwt.finalize (fun () -> - on_syn_callback () - >>= fun cb -> - (* here source is the remote peer *) - let src_port = Stack_tcp_wire.src_port id in - begin match cb src_port with - | Some handler -> - (* TODO: consider whether this hashtable is leaking *) - Stack_tcp.listen t.tcp4 ~port:src_port ?keepalive:None handler - | None -> () - end; - let src = Stack_tcp_wire.dst id in - let dst = Stack_tcp_wire.src id in - Stack_tcp.input t.tcp4 ~src ~dst buf - ) (fun () -> - let src_port = Stack_tcp_wire.src_port id in - Stack_tcp.unlisten t.tcp4 ~port:src_port; - t.pending <- Tcp.Id.Set.remove id t.pending; - Lwt.return_unit; - ) - end - end else begin + on_syn_callback () >>= fun cb -> + (* here source is the remote peer *) + let src_port = Stack_tcp_wire.src_port id in + (match cb src_port with + | Some handler -> + (* TODO: consider whether this hashtable is leaking *) + Stack_tcp.listen t.tcp4 ~port:src_port ?keepalive:None handler + | None -> ()); + let src = Stack_tcp_wire.dst id in + let dst = Stack_tcp_wire.src id in + Stack_tcp.input t.tcp4 ~src ~dst buf) + (fun () -> + let src_port = Stack_tcp_wire.src_port id in + Stack_tcp.unlisten t.tcp4 ~port:src_port; + t.pending <- Tcp.Id.Set.remove id t.pending; + Lwt.return_unit)) + else ( Tcp.Flow.touch id; (* non-SYN packets are injected into the stack as normal *) let src = Stack_tcp_wire.dst id in let dst = Stack_tcp_wire.src id in - Stack_tcp.input t.tcp4 ~src ~dst buf - end + Stack_tcp.input t.tcp4 ~src ~dst buf) module Proxy = - Mirage_flow_combinators.Proxy(Clock)(Stack_tcp)(Forwards.Stream.Tcp) + Mirage_flow_combinators.Proxy (Clock) (Stack_tcp) (Forwards.Stream.Tcp) let forward_via_tcp_socket t ~id (ip, port) () = - Forwards.Stream.Tcp.connect (ip, port) - >>= function + Forwards.Stream.Tcp.connect (ip, port) >>= function | Error (`Msg m) -> - Log.debug (fun f -> - f "%a:%d: failed to connect, sending RST: %s" - Ipaddr.pp ip port m); - Lwt.return (fun _ -> None) - | Ok socket -> - let tcp = Tcp.Flow.create id socket in - let listeners port = Log.debug (fun f -> - f "%a:%d handshake complete" Ipaddr.pp ip port); - let f flow = - match tcp.Tcp.Flow.socket with - | None -> - Log.err (fun f -> - f "%s callback called on closed socket" - (Tcp.Flow.to_string tcp)); - Lwt.return_unit - | Some socket -> - Lwt.finalize (fun () -> - Proxy.proxy flow socket - >>= function - | Error e -> - Log.debug (fun f -> - f "%s proxy failed with %a" - (Tcp.Flow.to_string tcp) Proxy.pp_error e); - Lwt.return_unit - | Ok (_l_stats, _r_stats) -> + f "%a:%d: failed to connect, sending RST: %s" Ipaddr.pp ip port m); + Lwt.return (fun _ -> None) + | Ok socket -> + let tcp = Tcp.Flow.create id socket in + let listeners port = + Log.debug (fun f -> f "%a:%d handshake complete" Ipaddr.pp ip port); + let f flow = + match tcp.Tcp.Flow.socket with + | None -> + Log.err (fun f -> + f "%s callback called on closed socket" + (Tcp.Flow.to_string tcp)); Lwt.return_unit - ) (fun () -> - Log.debug (fun f -> f "%s proxy terminated" (Tcp.Flow.to_string tcp)); - close_flow t ~id `Fin - ) + | Some socket -> + Lwt.finalize + (fun () -> + Proxy.proxy flow socket >>= function + | Error e -> + Log.debug (fun f -> + f "%s proxy failed with %a" + (Tcp.Flow.to_string tcp) Proxy.pp_error e); + Lwt.return_unit + | Ok (_l_stats, _r_stats) -> Lwt.return_unit) + (fun () -> + Log.debug (fun f -> + f "%s proxy terminated" (Tcp.Flow.to_string tcp)); + close_flow t ~id `Fin) + in + Some f in - Some f - in - Lwt.return listeners + Lwt.return listeners - let input_tcp t ~id ~syn ~rst (ip, port) (buf: Cstruct.t) = - intercept_tcp t ~id ~syn ~rst (forward_via_tcp_socket t ~id (ip, port)) buf + let input_tcp t ~id ~syn ~rst (ip, port) (buf : Cstruct.t) = + intercept_tcp t ~id ~syn ~rst + (forward_via_tcp_socket t ~id (ip, port)) + buf (* Send an ICMP destination reachable message in response to the given packet. This can be used to indicate the packet would @@ -435,46 +457,48 @@ struct (* this field is unused for icmp destination unreachable *) set_icmpv4_id header 0x00; set_icmpv4_seq header safe_outgoing_mtu; - let icmp_payload = match ip_payload with - | Some ip_payload -> - if (Cstruct.length ip_payload > 8) then begin - let ip_payload = Cstruct.sub ip_payload 0 8 in - Cstruct.append ip_header ip_payload - end else Cstruct.append ip_header ip_payload - | None -> ip_header + let icmp_payload = + match ip_payload with + | Some ip_payload -> + if Cstruct.length ip_payload > 8 then + let ip_payload = Cstruct.sub ip_payload 0 8 in + Cstruct.append ip_header ip_payload + else Cstruct.append ip_header ip_payload + | None -> ip_header in set_icmpv4_csum header - (Tcpip_checksum.ones_complement_list [ header; - icmp_payload ]); + (Tcpip_checksum.ones_complement_list [ header; icmp_payload ]); let icmp_packet = Cstruct.append header icmp_payload in icmp_packet in - let reply = would_fragment + let reply = + would_fragment ~ip_header:(Cstruct.sub raw 0 (ihl * 4)) - ~ip_payload:(Some (Cstruct.sub raw (ihl * 4) 8)) in + ~ip_payload:(Some (Cstruct.sub raw (ihl * 4) 8)) + in (* Rather than silently unset the do not fragment bit, we respond with an ICMP error message which will hopefully prompt the other side to send messages we can forward *) - Log.warn (fun f -> f - "Sending icmp-dst-unreachable in response to UDP %s:%d -> \ - %s:%d with DNF set IPv4 " - (Ipaddr.V4.to_string src) src_port - (Ipaddr.V4.to_string dst) dst_port - ); + Log.warn (fun f -> + f + "Sending icmp-dst-unreachable in response to UDP %s:%d -> %s:%d \ + with DNF set IPv4 " + (Ipaddr.V4.to_string src) src_port (Ipaddr.V4.to_string dst) + dst_port); Stack_ipv4.write t.ipv4 src `ICMP (fun _buf -> 0) [ reply ] end type connection = { - vnet_client_id: Vnet.id; - after_disconnect: unit Lwt.t; - interface: Netif.t; - switch: Switch.t; - mutable endpoints: Endpoint.t IPMap.t; - endpoints_m: Lwt_mutex.t; - udp_nat: Udp_nat.t; - icmp_nat: Icmp_nat.t option; - all_traffic: Netif.rule; + vnet_client_id : Vnet.id; + after_disconnect : unit Lwt.t; + interface : Netif.t; + switch : Switch.t; + mutable endpoints : Endpoint.t IPMap.t; + endpoints_m : Lwt_mutex.t; + udp_nat : Udp_nat.t; + icmp_nat : Icmp_nat.t option; + all_traffic : Netif.rule; } let after_disconnect t = t.after_disconnect @@ -482,327 +506,441 @@ struct open Frame let pp_error ppf = function - | `Udp e -> Stack_udp.pp_error ppf e - | `Ipv4 e -> Stack_ipv4.pp_error ppf e - - let lift_ipv4_error = function - | Ok _ as x -> x - | Error e -> Error (`Ipv4 e) - - let lift_udp_error = function - | Ok _ as x -> x - | Error e -> Error (`Udp e) + | `Udp e -> Stack_udp.pp_error ppf e + | `Ipv4 e -> Stack_ipv4.pp_error ppf e + let lift_ipv4_error = function Ok _ as x -> x | Error e -> Error (`Ipv4 e) + let lift_udp_error = function Ok _ as x -> x | Error e -> Error (`Udp e) let ok () = Ok () module Localhost = struct type t = { - endpoint: Endpoint.t; - udp_nat: Udp_nat.t; - dns_ips: Ipaddr.t list; + endpoint : Endpoint.t; + udp_nat : Udp_nat.t; + dns_ips : Ipaddr.t list; } (** Proxies connections to services on localhost on the host *) (** Handle IPv4 datagrams by proxying them to a remote system *) - let input_ipv4 t ipv4 = match ipv4 with - - (* Respond to ICMP *) - | Ipv4 { raw; payload = Icmp _; _ } -> - let none ~src:_ ~dst:_ _ = Lwt.return_unit in - let default ~proto ~src ~dst buf = match proto with - | 1 (* ICMP *) -> - Stack_icmpv4.input t.endpoint.Endpoint.icmpv4 ~src ~dst buf - | _ -> - Lwt.return_unit in - Stack_ipv4.input t.endpoint.Endpoint.ipv4 ~tcp:none ~udp:none ~default raw - >|= ok - - (* UDP to localhost *) - | Ipv4 { src; dst; ihl; dnf; raw; ttl; - payload = Udp { src = src_port; dst = dst_port; len; - payload = Payload payload; _ }; _ } -> - let description = - Fmt.str "%a:%d -> %a:%d" Ipaddr.V4.pp src src_port Ipaddr.V4.pp - dst dst_port - in - if Cstruct.length payload < len then begin - Log.warn (fun f -> f "%s: dropping because reported len %d actual len %d" - description len (Cstruct.length payload)); - Lwt.return (Ok ()) - end else if dnf && (Cstruct.length payload > safe_outgoing_mtu) then begin - Endpoint.send_icmp_dst_unreachable t.endpoint ~src ~dst ~src_port - ~dst_port ~ihl raw - >|= lift_ipv4_error - end else begin - (* [1] For UDP to our local address, rewrite the destination - to localhost. This is the inverse of the rewrite - below[2] *) - let datagram = - { Hostnet_udp.src = Ipaddr.V4 src, src_port; - dst = Ipaddr.(V4 V4.localhost), dst_port; - intercept = Ipaddr.(V4 V4.localhost), dst_port; - payload } - in - Udp_nat.input ~t:t.udp_nat ~datagram ~ttl () - >|= ok - end - - (* TCP to local ports *) - | Ipv4 { src; dst; - payload = Tcp { src = src_port; dst = dst_port; syn; rst; raw; - payload = Payload _; _ }; _ } -> - let id = - Stack_tcp_wire.v ~src_port:dst_port ~dst:src ~src:dst ~dst_port:src_port - in - Endpoint.input_tcp t.endpoint ~id ~syn ~rst - (Ipaddr.V4 Ipaddr.V4.localhost, dst_port) raw - >|= ok - | _ -> - Lwt.return (Ok ()) + let input_ipv4 t ipv4 = + match ipv4 with + (* Respond to ICMP *) + | Ipv4 { raw; payload = Icmp _; _ } -> + let none ~src:_ ~dst:_ _ = Lwt.return_unit in + let default ~proto ~src ~dst buf = + match proto with + | 1 (* ICMP *) -> + Stack_icmpv4.input t.endpoint.Endpoint.icmpv4 ~src ~dst buf + | _ -> Lwt.return_unit + in + Stack_ipv4.input t.endpoint.Endpoint.ipv4 ~tcp:none ~udp:none ~default + raw + >|= ok + (* UDP to localhost *) + | Ipv4 + { + src; + dst; + ihl; + dnf; + raw; + ttl; + payload = + Udp + { + src = src_port; + dst = dst_port; + len; + payload = Payload payload; + _; + }; + _; + } -> + let description = + Fmt.str "%a:%d -> %a:%d" Ipaddr.V4.pp src src_port Ipaddr.V4.pp dst + dst_port + in + if Cstruct.length payload < len then ( + Log.warn (fun f -> + f "%s: dropping because reported len %d actual len %d" + description len (Cstruct.length payload)); + Lwt.return (Ok ())) + else if dnf && Cstruct.length payload > safe_outgoing_mtu then + Endpoint.send_icmp_dst_unreachable t.endpoint ~src ~dst ~src_port + ~dst_port ~ihl raw + >|= lift_ipv4_error + else + (* [1] For UDP to our local address, rewrite the destination + to localhost. This is the inverse of the rewrite + below[2] *) + let datagram = + { + Hostnet_udp.src = (Ipaddr.V4 src, src_port); + dst = (Ipaddr.(V4 V4.localhost), dst_port); + intercept = (Ipaddr.(V4 V4.localhost), dst_port); + payload; + } + in + Udp_nat.input ~t:t.udp_nat ~datagram ~ttl () >|= ok + (* TCP to local ports *) + | Ipv4 + { + src; + dst; + payload = + Tcp + { + src = src_port; + dst = dst_port; + syn; + rst; + raw; + payload = Payload _; + _; + }; + _; + } -> + let id = + Stack_tcp_wire.v ~src_port:dst_port ~dst:src ~src:dst + ~dst_port:src_port + in + Endpoint.input_tcp t.endpoint ~id ~syn ~rst + (Ipaddr.V4 Ipaddr.V4.localhost, dst_port) + raw + >|= ok + | _ -> Lwt.return (Ok ()) let create endpoint udp_nat dns_ips = let tcp_stack = { endpoint; udp_nat; dns_ips } in let open Lwt.Infix in (* Wire up the listeners to receive future packets: *) - Switch.Port.listen ~header_size:Ethernet.Packet.sizeof_ethernet endpoint.Endpoint.netif - (fun buf -> - let open Frame in - match parse [ buf ] with - | Ok (Ethernet { payload = Ipv4 ipv4; _ }) -> - Endpoint.touch endpoint; - (input_ipv4 tcp_stack (Ipv4 ipv4) >|= function - | Ok () -> () - | Error e -> - Log.err (fun l -> - l "error while reading IPv4 input: %a" pp_error e)) - | _ -> - Lwt.return_unit - ) + Switch.Port.listen ~header_size:Ethernet.Packet.sizeof_ethernet + endpoint.Endpoint.netif (fun buf -> + let open Frame in + match parse [ buf ] with + | Ok (Ethernet { payload = Ipv4 ipv4; _ }) -> ( + Endpoint.touch endpoint; + input_ipv4 tcp_stack (Ipv4 ipv4) >|= function + | Ok () -> () + | Error e -> + Log.err (fun l -> + l "error while reading IPv4 input: %a" pp_error e)) + | _ -> Lwt.return_unit) >|= function - | Ok () -> Ok tcp_stack + | Ok () -> Ok tcp_stack | Error _ as e -> e - end let with_no_keepalive handler port = - match handler port with - | None -> None - | Some process -> Some process + match handler port with None -> None | Some process -> Some process module Gateway = struct type t = { - endpoint: Endpoint.t; - udp_nat: Udp_nat.t; - dns_ips: Ipaddr.V4.t list; - localhost_names: Dns.Name.t list; - localhost_ips: Ipaddr.t list; + endpoint : Endpoint.t; + udp_nat : Udp_nat.t; + dns_ips : Ipaddr.V4.t list; + localhost_names : Dns.Name.t list; + localhost_ips : Ipaddr.t list; } (** Services offered by vpnkit to the internal network *) - let input_ipv4 t ipv4 = match ipv4 with - - (* Respond to ICMP *) - | Ipv4 { raw; payload = Icmp _; _ } -> - let none ~src:_ ~dst:_ _ = Lwt.return_unit in - let default ~proto ~src ~dst buf = match proto with - | 1 (* ICMP *) -> - Stack_icmpv4.input t.endpoint.Endpoint.icmpv4 ~src ~dst buf - | _ -> - Lwt.return_unit in - Stack_ipv4.input t.endpoint.Endpoint.ipv4 ~tcp:none ~udp:none ~default raw - >|= ok - - (* UDP to forwarded elsewhere *) - | Ipv4 { src; dst; ttl; - payload = Udp { src = src_port; dst = dst_port; - payload = Payload payload; _ }; _ } when Gateway_forwards.Udp.mem dst_port -> - let intercept_ipv4, intercept_port = Gateway_forwards.Udp.find dst_port in - let datagram = - { Hostnet_udp.src = Ipaddr.V4 src, src_port; - dst = Ipaddr.V4 dst, dst_port; - intercept = Ipaddr.V4 intercept_ipv4, intercept_port; payload } - in - (* Need to use a different UDP NAT with a different reply IP address *) - Udp_nat.input ~t:t.udp_nat ~datagram ~ttl () - >|= ok - - (* TCP to be forwarded elsewhere *) - | Ipv4 { src; dst; - payload = Tcp { src = src_port; dst = dst_port; syn; rst; raw; - payload = Payload _; _ }; _ } when Gateway_forwards.Tcp.mem dst_port -> - let id = - Stack_tcp_wire.v ~src_port:dst_port ~dst:src ~src:dst ~dst_port:src_port - in - let forward_ip, forward_port = Gateway_forwards.Tcp.find dst_port in - Endpoint.input_tcp t.endpoint ~id ~syn ~rst - (Ipaddr.V4 forward_ip, forward_port) raw - >|= ok - - (* UDP on port 53 -> DNS forwarder *) - | Ipv4 { src; dst; - payload = Udp { src = src_port; dst = 53; - payload = Payload payload; _ }; _ } -> - let udp = t.endpoint.Endpoint.udp4 in - !dns >>= fun t -> - Dns_forwarder.handle_udp ~t ~udp ~src ~dst ~src_port payload - >|= lift_udp_error - - (* TCP to port 53 -> DNS forwarder *) - | Ipv4 { src; dst; - payload = Tcp { src = src_port; dst = 53; syn; rst; raw; - payload = Payload _; _ }; _ } -> - let id = - Stack_tcp_wire.v ~src_port:53 ~dst:src ~src:dst ~dst_port:src_port - in - Endpoint.intercept_tcp t.endpoint ~id ~syn ~rst (fun () -> + let input_ipv4 t ipv4 = + match ipv4 with + (* Respond to ICMP *) + | Ipv4 { raw; payload = Icmp _; _ } -> + let none ~src:_ ~dst:_ _ = Lwt.return_unit in + let default ~proto ~src ~dst buf = + match proto with + | 1 (* ICMP *) -> + Stack_icmpv4.input t.endpoint.Endpoint.icmpv4 ~src ~dst buf + | _ -> Lwt.return_unit + in + Stack_ipv4.input t.endpoint.Endpoint.ipv4 ~tcp:none ~udp:none ~default + raw + >|= ok + (* UDP to forwarded elsewhere *) + | Ipv4 + { + src; + dst; + ttl; + payload = + Udp + { src = src_port; dst = dst_port; payload = Payload payload; _ }; + _; + } + when Gateway_forwards.Udp.mem dst_port -> + let intercept_ipv4, intercept_port = + Gateway_forwards.Udp.find dst_port + in + let datagram = + { + Hostnet_udp.src = (Ipaddr.V4 src, src_port); + dst = (Ipaddr.V4 dst, dst_port); + intercept = (Ipaddr.V4 intercept_ipv4, intercept_port); + payload; + } + in + (* Need to use a different UDP NAT with a different reply IP address *) + Udp_nat.input ~t:t.udp_nat ~datagram ~ttl () >|= ok + (* TCP to be forwarded elsewhere *) + | Ipv4 + { + src; + dst; + payload = + Tcp + { + src = src_port; + dst = dst_port; + syn; + rst; ...TRUNCATED BY DUNE... Global_arp.connect ~table:global_arp_table.table global_arp_ethif |> Lwt.return) - end - >>= fun arp -> - Global_arp.input arp (Cstruct.shift buf Ethernet.Packet.sizeof_ethernet) - | Ok (Ethernet { payload = Ipv4 ({ src; dst; _ } as ipv4 ); _ }) -> - (* For any new IP destination, create a stack to proxy for - the remote system *) - let localhost_ips = - if Ipaddr.V4.(compare unspecified c.Configuration.host_ip) = 0 - then [] - else [ Ipaddr.V4 c.Configuration.host_ip ] in - if dst = c.Configuration.gateway_ip then begin - begin - let open Lwt_result.Infix in - find_endpoint (dst, src) >>= fun endpoint -> + >>= fun arp -> + Global_arp.input arp + (Cstruct.shift buf Ethernet.Packet.sizeof_ethernet) + | Ok (Ethernet { payload = Ipv4 ({ src; dst; _ } as ipv4); _ }) -> ( + (* For any new IP destination, create a stack to proxy for + the remote system *) + let localhost_ips = + if Ipaddr.V4.(compare unspecified c.Configuration.host_ip) = 0 + then [] + else [ Ipaddr.V4 c.Configuration.host_ip ] + in + if dst = c.Configuration.gateway_ip then + (let open Lwt_result.Infix in + find_endpoint (dst, src) >>= fun endpoint -> Log.debug (fun f -> f "creating gateway TCP/IP proxy for %a" Ipaddr.V4.pp dst); (* The default Udp_nat instance doesn't work for us because @@ -1287,90 +1476,107 @@ struct let open Lwt.Infix in function | { Hostnet_udp.dst = Ipaddr.V6 ipv6, _; _ } -> - Log.err (fun f -> f "Failed to write an IPv6 UDP datagram to: %a" Ipaddr.V6.pp ipv6); - Lwt.return_unit - | { Hostnet_udp.src = _, src_port; dst = Ipaddr.V4 dst, dst_port; payload; _ } -> - begin find_endpoint (c.Configuration.gateway_ip, src) - >>= function - | Error (`Msg m) -> - Log.err (fun f -> f "%s" m); + Log.err (fun f -> + f "Failed to write an IPv6 UDP datagram to: %a" + Ipaddr.V6.pp ipv6); Lwt.return_unit - | Ok endpoint -> - Stack_udp.write ~src_port ~dst ~dst_port endpoint.Endpoint.udp4 payload - >|= function - | Error e -> Log.err (fun f -> f "Failed to write an IPv4 packet: %a" Stack_udp.pp_error e) - | Ok () -> () - end in + | { + Hostnet_udp.src = _, src_port; + dst = Ipaddr.V4 dst, dst_port; + payload; + _; + } -> ( + find_endpoint (c.Configuration.gateway_ip, src) >>= function + | Error (`Msg m) -> + Log.err (fun f -> f "%s" m); + Lwt.return_unit + | Ok endpoint -> ( + Stack_udp.write ~src_port ~dst ~dst_port + endpoint.Endpoint.udp4 payload + >|= function + | Error e -> + Log.err (fun f -> + f "Failed to write an IPv4 packet: %a" + Stack_udp.pp_error e) + | Ok () -> ())) + in Udp_nat.set_send_reply ~t:udp_nat ~send_reply; - Gateway.create endpoint udp_nat [ c.Configuration.gateway_ip ] - c.Configuration.host_names localhost_ips - end >>= function - | Error e -> - Log.err (fun f -> - f "Failed to create a TCP/IP stack: %a" Switch.Port.pp_error e); - Lwt.return_unit - | Ok tcp_stack -> - (* inject the ethernet frame into the new stack *) - Gateway.input_ipv4 tcp_stack (Ipv4 ipv4) >|= function - | Ok () -> () + Gateway.create endpoint udp_nat + [ c.Configuration.gateway_ip ] + c.Configuration.host_names localhost_ips) + >>= function | Error e -> - Log.err (fun f -> f "failed to read TCP/IP input: %a" pp_error e); - end else if dst = c.Configuration.host_ip && Ipaddr.V4.(compare unspecified c.Configuration.host_ip <> 0) then begin - begin - let open Lwt_result.Infix in + Log.err (fun f -> + f "Failed to create a TCP/IP stack: %a" + Switch.Port.pp_error e); + Lwt.return_unit + | Ok tcp_stack -> ( + (* inject the ethernet frame into the new stack *) + Gateway.input_ipv4 tcp_stack (Ipv4 ipv4) + >|= function + | Ok () -> () + | Error e -> + Log.err (fun f -> + f "failed to read TCP/IP input: %a" pp_error e)) + else if + dst = c.Configuration.host_ip + && Ipaddr.V4.(compare unspecified c.Configuration.host_ip <> 0) + then + (let open Lwt_result.Infix in find_endpoint (dst, src) >>= fun endpoint -> Log.debug (fun f -> f "creating localhost TCP/IP proxy for %a" Ipaddr.V4.pp dst); - Localhost.create endpoint udp_nat localhost_ips - end >>= function - | Error e -> - Log.err (fun f -> - f "Failed to create a TCP/IP stack: %a" Switch.Port.pp_error e); - Lwt.return_unit - | Ok tcp_stack -> - (* inject the ethernet frame into the new stack *) - Localhost.input_ipv4 tcp_stack (Ipv4 ipv4) >|= function - | Ok () -> () + Localhost.create endpoint udp_nat localhost_ips) + >>= function | Error e -> - Log.err (fun f -> f "failed to read TCP/IP input: %a" pp_error e); - end else begin - begin - let open Lwt_result.Infix in + Log.err (fun f -> + f "Failed to create a TCP/IP stack: %a" + Switch.Port.pp_error e); + Lwt.return_unit + | Ok tcp_stack -> ( + (* inject the ethernet frame into the new stack *) + Localhost.input_ipv4 tcp_stack (Ipv4 ipv4) + >|= function + | Ok () -> () + | Error e -> + Log.err (fun f -> + f "failed to read TCP/IP input: %a" pp_error e)) + else + (let open Lwt_result.Infix in find_endpoint (dst, src) >>= fun endpoint -> Log.debug (fun f -> f "create remote TCP/IP proxy for %a" Ipaddr.V4.pp dst); - Remote.create endpoint udp_nat icmp_nat - c.Configuration.host_names localhost_ips - end >>= function - | Error e -> - Log.err (fun f -> - f "Failed to create a TCP/IP stack: %a" - Switch.Port.pp_error e); - Lwt.return_unit - | Ok tcp_stack -> - (* inject the ethernet frame into the new stack *) - Remote.input_ipv4 tcp_stack (Ipv4 ipv4) >|= function - | Ok () -> () + Remote.create endpoint udp_nat icmp_nat c.Configuration.host_names + localhost_ips) + >>= function | Error e -> - Log.err (fun l -> - l "error while reading remote IPv4 input: %a" - Stack_ipv4.pp_error e) - end - | _ -> - Lwt.return_unit - ) + Log.err (fun f -> + f "Failed to create a TCP/IP stack: %a" + Switch.Port.pp_error e); + Lwt.return_unit + | Ok tcp_stack -> ( + (* inject the ethernet frame into the new stack *) + Remote.input_ipv4 tcp_stack (Ipv4 ipv4) + >|= function + | Ok () -> () + | Error e -> + Log.err (fun l -> + l "error while reading remote IPv4 input: %a" + Stack_ipv4.pp_error e))) + | _ -> Lwt.return_unit) >>= function | Error e -> - Log.err (fun f -> f "TCP/IP not ready: %a" Switch.pp_error e); - Lwt.fail_with "not ready" + Log.err (fun f -> f "TCP/IP not ready: %a" Switch.pp_error e); + Lwt.fail_with "not ready" | Ok () -> - Log.info (fun f -> f "TCP/IP ready"); - Lwt.return t + Log.info (fun f -> f "TCP/IP ready"); + Lwt.return t let update_dns c = - let config = match c.Configuration.resolver, c.Configuration.dns with - | `Upstream, servers -> `Upstream servers - | `Host, _ -> `Host + let config = + match (c.Configuration.resolver, c.Configuration.dns) with + | `Upstream, servers -> `Upstream servers + | `Host, _ -> `Host in Log.info (fun f -> f "Updating resolvers to %s" (Hostnet_dns.Config.to_string config)); @@ -1382,391 +1588,412 @@ struct { Dns_forward.Config.Address.ip = Ipaddr.V4 local_ip; port = 0 } in let builtin_names = - (List.map (fun name -> name, Ipaddr.V4 c.Configuration.gateway_ip) c.Configuration.gateway_names) - @ (List.map (fun name -> name, Ipaddr.V4 c.Configuration.host_ip) c.Configuration.host_names) + List.map + (fun name -> (name, Ipaddr.V4 c.Configuration.gateway_ip)) + c.Configuration.gateway_names + @ List.map + (fun name -> (name, Ipaddr.V4 c.Configuration.host_ip)) + c.Configuration.host_names (* FIXME: what to do if there are multiple VMs? *) - @ (List.map (fun name -> name, Ipaddr.V4 c.Configuration.lowest_ip) c.Configuration.vm_names) in + @ List.map + (fun name -> (name, Ipaddr.V4 c.Configuration.lowest_ip)) + c.Configuration.vm_names + in dns := dns_forwarder ~local_address ~builtin_names let update_dhcp c = Log.info (fun f -> - f "Update DHCP configuration to %s" - (match c.Configuration.dhcp_configuration with - | None -> "None" - | Some x -> Configuration.Dhcp_configuration.to_string x) - ); + f "Update DHCP configuration to %s" + (match c.Configuration.dhcp_configuration with + | None -> "None" + | Some x -> Configuration.Dhcp_configuration.to_string x)); Hostnet_dhcp.update_global_configuration c.Configuration.dhcp_configuration; Lwt.return_unit - let update_http c = match c.Configuration.http_intercept with + let update_http c = + match c.Configuration.http_intercept with | None -> - Log.info (fun f -> f "Disabling HTTP proxy"); - http := None; - Lwt.return_unit - | Some x -> - Http_forwarder.of_json x - >>= function - | Error (`Msg m) -> - Log.err (fun f -> f "Failed to decode HTTP proxy configuration json: %s" m); - Lwt.return_unit - | Ok t -> - http := Some t; - Log.info (fun f -> - f "Updating HTTP proxy configuration: %s" (Http_forwarder.to_string t) - ); + Log.info (fun f -> f "Disabling HTTP proxy"); + http := None; Lwt.return_unit + | Some x -> ( + Http_forwarder.of_json x >>= function + | Error (`Msg m) -> + Log.err (fun f -> + f "Failed to decode HTTP proxy configuration json: %s" m); + Lwt.return_unit + | Ok t -> + http := Some t; + Log.info (fun f -> + f "Updating HTTP proxy configuration: %s" + (Http_forwarder.to_string t)); + Lwt.return_unit) let create_common vnet_switch c = (* If a `dns_path` is provided then watch it for updates *) let read_dns_file path = Log.info (fun f -> f "Reading DNS configuration from %s" path); - Host.Files.read_file path - >>= function + Host.Files.read_file path >>= function | Error (`Msg m) -> - Log.err (fun f -> f "Failed to read DNS configuration file %s: %s. Disabling current configuration." path m); - update_dns { c with dns = Configuration.no_dns_servers } - | Ok contents -> - begin match Configuration.Parse.dns contents with - | None -> - Log.err (fun f -> f "Failed to parse DNS configuration file %s. Disabling current configuration." path); + Log.err (fun f -> + f + "Failed to read DNS configuration file %s: %s. Disabling \ + current configuration." + path m); update_dns { c with dns = Configuration.no_dns_servers } - | Some dns -> - Log.info (fun f -> f "Updating DNS configuration to %s" (Dns_forward.Config.to_string dns)); - update_dns { c with dns } - end in - ( match c.dns_path with - | None -> Lwt.return_unit - | Some path -> - begin Host.Files.watch_file path - (fun () -> + | Ok contents -> ( + match Configuration.Parse.dns contents with + | None -> + Log.err (fun f -> + f + "Failed to parse DNS configuration file %s. Disabling \ + current configuration." + path); + update_dns { c with dns = Configuration.no_dns_servers } + | Some dns -> + Log.info (fun f -> + f "Updating DNS configuration to %s" + (Dns_forward.Config.to_string dns)); + update_dns { c with dns }) + in + (match c.dns_path with + | None -> Lwt.return_unit + | Some path -> ( + Host.Files.watch_file path (fun () -> Log.info (fun f -> f "DNS configuration file %s has changed" path); Lwt.async (fun () -> - log_exception_continue "Parsing DNS configuration" - (fun () -> - read_dns_file path - ) - ) - ) + log_exception_continue "Parsing DNS configuration" (fun () -> + read_dns_file path))) >>= function | Error (`Msg m) -> - Log.err (fun f -> f "Failed to watch DNS configuration file %s for changes: %s" path m); - Lwt.return_unit + Log.err (fun f -> + f "Failed to watch DNS configuration file %s for changes: %s" + path m); + Lwt.return_unit | Ok _watch -> - Log.info (fun f -> f "Watching DNS configuration file %s for changes" path); - Lwt.return_unit - end - ) >>= fun () -> - + Log.info (fun f -> + f "Watching DNS configuration file %s for changes" path); + Lwt.return_unit)) + >>= fun () -> let read_http_intercept_file path = Log.info (fun f -> f "Reading HTTP proxy configuration from %s" path); - Host.Files.read_file path - >>= function + Host.Files.read_file path >>= function | Error (`Msg m) -> - Log.err (fun f -> f "Failed to read HTTP proxy configuration from %s: %s. Disabling HTTP proxy." path m); - update_http { c with http_intercept = None } - | Ok txt -> - begin match Ezjsonm.from_string txt with - | exception _ -> - Log.err (fun f -> f "Failed to parse HTTP proxy configuration json: %s" txt); + Log.err (fun f -> + f + "Failed to read HTTP proxy configuration from %s: %s. \ + Disabling HTTP proxy." + path m); update_http { c with http_intercept = None } - | http_intercept -> - update_http { c with http_intercept = Some http_intercept } - end in - ( match c.http_intercept_path with + | Ok txt -> ( + match Ezjsonm.from_string txt with + | exception _ -> + Log.err (fun f -> + f "Failed to parse HTTP proxy configuration json: %s" txt); + update_http { c with http_intercept = None } + | http_intercept -> + update_http { c with http_intercept = Some http_intercept }) + in + (match c.http_intercept_path with | None -> Lwt.return_unit - | Some path -> - begin Host.Files.watch_file path - (fun () -> - Log.info (fun f -> f "HTTP proxy configuration file %s has changed" path); - Lwt.async (fun () -> - log_exception_continue "Parsing HTTP proxy configuration" - (fun () -> - read_http_intercept_file path - ) - ) - ) - >>= function - | Error (`Msg m) -> - Log.err (fun f -> f "Failed to watch HTTP proxy configuration file %s for changes: %s" path m); - Lwt.return_unit - | Ok _watch -> - Log.info (fun f -> f "Watching HTTP proxy configuration file %s for changes" path); - Lwt.return_unit - end - ) >>= fun () -> - + | Some path -> ( + Host.Files.watch_file path (fun () -> + Log.info (fun f -> + f "HTTP proxy configuration file %s has changed" path); + Lwt.async (fun () -> + log_exception_continue "Parsing HTTP proxy configuration" + (fun () -> read_http_intercept_file path))) + >>= function + | Error (`Msg m) -> + Log.err (fun f -> + f + "Failed to watch HTTP proxy configuration file %s for \ + changes: %s" + path m); + Lwt.return_unit + | Ok _watch -> + Log.info (fun f -> + f "Watching HTTP proxy configuration file %s for changes" path); + Lwt.return_unit)) + >>= fun () -> Hostnet_dhcp.update_global_configuration c.Configuration.dhcp_configuration; let read_dhcp_json_file path = Log.info (fun f -> f "Reading DHCP configuration file from %s" path); - Host.Files.read_file path - >>= function + Host.Files.read_file path >>= function | Error (`Msg m) -> - Log.err (fun f -> f "Failed to read DHCP configuration from %s: %s. Disabling DHCP server." path m); - update_dhcp { c with dhcp_configuration = None } + Log.err (fun f -> + f + "Failed to read DHCP configuration from %s: %s. Disabling DHCP \ + server." + path m); + update_dhcp { c with dhcp_configuration = None } | Ok txt -> - update_dhcp { c with dhcp_configuration = Configuration.Dhcp_configuration.of_string txt } - in - ( match c.dhcp_json_path with + update_dhcp + { + c with + dhcp_configuration = + Configuration.Dhcp_configuration.of_string txt; + } + in + (match c.dhcp_json_path with | None -> Lwt.return_unit - | Some path -> - begin Host.Files.watch_file path - (fun () -> - Log.info (fun f -> f "DHCP configuration file %s has changed" path); - Lwt.async (fun () -> - log_exception_continue "Parsing DHCP configuration" - (fun () -> - read_dhcp_json_file path - ) - ) - ) - >>= function - | Error (`Msg m) -> - Log.err (fun f -> f "Failed to watch DHCP configuration file %s for changes: %s" path m); - Lwt.return_unit - | Ok _watch -> - Log.info (fun f -> f "Watching DHCP configuration file %s for changes" path); - Lwt.return_unit - end - ) >>= fun () -> - + | Some path -> ( + Host.Files.watch_file path (fun () -> + Log.info (fun f -> f "DHCP configuration file %s has changed" path); + Lwt.async (fun () -> + log_exception_continue "Parsing DHCP configuration" (fun () -> + read_dhcp_json_file path))) + >>= function + | Error (`Msg m) -> + Log.err (fun f -> + f "Failed to watch DHCP configuration file %s for changes: %s" + path m); + Lwt.return_unit + | Ok _watch -> + Log.info (fun f -> + f "Watching DHCP configuration file %s for changes" path); + Lwt.return_unit)) + >>= fun () -> (* Set the static forwarding table before watching for changes on the dynamic table *) - Gateway_forwards.set_static (c.Configuration.udpv4_forwards @ c.Configuration.tcpv4_forwards); + Gateway_forwards.set_static + (c.Configuration.udpv4_forwards @ c.Configuration.tcpv4_forwards); let read_gateway_forwards_file path = Log.info (fun f -> f "Reading gateway forwards file from %s" path); - Host.Files.read_file path - >>= function + Host.Files.read_file path >>= function | Error (`Msg "ENOENT") -> - Log.info (fun f -> f "Not reading gateway forwards file %s becuase it does not exist" path); - Lwt.return_unit - | Error (`Msg m) -> - Log.err (fun f -> f "Failed to read gateway forwards from %s: %s." path m); - Gateway_forwards.update []; - Lwt.return_unit - | Ok txt -> - match Gateway_forwards.of_string txt with - | Ok xs -> - Gateway_forwards.update xs; + Log.info (fun f -> + f "Not reading gateway forwards file %s becuase it does not exist" + path); Lwt.return_unit - | Error (`Msg m) -> - Log.err (fun f -> f "Failed to parse gateway forwards from %s: %s." path m); + | Error (`Msg m) -> + Log.err (fun f -> + f "Failed to read gateway forwards from %s: %s." path m); + Gateway_forwards.update []; Lwt.return_unit - in - ( match c.gateway_forwards_path with + | Ok txt -> ( + match Gateway_forwards.of_string txt with + | Ok xs -> + Gateway_forwards.update xs; + Lwt.return_unit + | Error (`Msg m) -> + Log.err (fun f -> + f "Failed to parse gateway forwards from %s: %s." path m); + Lwt.return_unit) + in + (match c.gateway_forwards_path with | None -> Lwt.return_unit - | Some path -> - begin Host.Files.watch_file path - (fun () -> - Log.info (fun f -> f "Gateway forwards file %s has changed" path); - Lwt.async (fun () -> - log_exception_continue "Parsing gateway forwards" - (fun () -> - read_gateway_forwards_file path - ) - ) - ) - >>= function - | Error (`Msg "ENOENT") -> - Log.info (fun f -> f "Not watching gateway forwards file %s because it does not exist" path); - Lwt.return_unit - | Error (`Msg m) -> - Log.err (fun f -> f "Failed to watch gateway forwards file %s for changes: %s" path m); - Lwt.return_unit - | Ok _watch -> - Log.info (fun f -> f "Watching gateway forwards file %s for changes" path); - Lwt.return_unit - end - ) >>= fun () -> - + | Some path -> ( + Host.Files.watch_file path (fun () -> + Log.info (fun f -> f "Gateway forwards file %s has changed" path); + Lwt.async (fun () -> + log_exception_continue "Parsing gateway forwards" (fun () -> + read_gateway_forwards_file path))) + >>= function + | Error (`Msg "ENOENT") -> + Log.info (fun f -> + f + "Not watching gateway forwards file %s because it does not \ + exist" + path); + Lwt.return_unit + | Error (`Msg m) -> + Log.err (fun f -> + f "Failed to watch gateway forwards file %s for changes: %s" + path m); + Lwt.return_unit + | Ok _watch -> + Log.info (fun f -> + f "Watching gateway forwards file %s for changes" path); + Lwt.return_unit)) + >>= fun () -> let read_forwards_file path = Log.info (fun f -> f "Reading forwards file from %s" path); - Host.Files.read_file path - >>= function + Host.Files.read_file path >>= function | Error (`Msg "ENOENT") -> - Log.info (fun f -> f "Not reading forwards file %s becuase it does not exist" path); - Lwt.return_unit - | Error (`Msg m) -> - Log.err (fun f -> f "Failed to read forwards from %s: %s." path m); - Forwards.update []; - Lwt.return_unit - | Ok txt -> - match Forwards.of_string txt with - | Ok xs -> - Forwards.update xs; + Log.info (fun f -> + f "Not reading forwards file %s becuase it does not exist" path); Lwt.return_unit - | Error (`Msg m) -> - Log.err (fun f -> f "Failed to parse forwards from %s: %s." path m); + | Error (`Msg m) -> + Log.err (fun f -> f "Failed to read forwards from %s: %s." path m); + Forwards.update []; Lwt.return_unit - in - ( match c.forwards_path with + | Ok txt -> ( + match Forwards.of_string txt with + | Ok xs -> + Forwards.update xs; + Lwt.return_unit + | Error (`Msg m) -> + Log.err (fun f -> + f "Failed to parse forwards from %s: %s." path m); + Lwt.return_unit) + in + (match c.forwards_path with | None -> Lwt.return_unit - | Some path -> - begin Host.Files.watch_file path - (fun () -> - Log.info (fun f -> f "Forwards file %s has changed" path); - Lwt.async (fun () -> - log_exception_continue "Parsing forwards" - (fun () -> - read_forwards_file path - ) - ) - ) - >>= function - | Error (`Msg "ENOENT") -> - Log.info (fun f -> f "Not watching forwards file %s because it does not exist" path); - Lwt.return_unit - | Error (`Msg m) -> - Log.err (fun f -> f "Failed to watch forwards file %s for changes: %s" path m); - Lwt.return_unit - | Ok _watch -> - Log.info (fun f -> f "Watching forwards file %s for changes" path); - Lwt.return_unit - end - ) >>= fun () -> - + | Some path -> ( + Host.Files.watch_file path (fun () -> + Log.info (fun f -> f "Forwards file %s has changed" path); + Lwt.async (fun () -> + log_exception_continue "Parsing forwards" (fun () -> + read_forwards_file path))) + >>= function + | Error (`Msg "ENOENT") -> + Log.info (fun f -> + f "Not watching forwards file %s because it does not exist" path); + Lwt.return_unit + | Error (`Msg m) -> + Log.err (fun f -> + f "Failed to watch forwards file %s for changes: %s" path m); + Lwt.return_unit + | Ok _watch -> + Log.info (fun f -> f "Watching forwards file %s for changes" path); + Lwt.return_unit)) + >>= fun () -> Log.info (fun f -> f "Configuration %s" (Configuration.to_string c)); - let global_arp_table : arp_table = { - mutex = Lwt_mutex.create(); - table = - (c.Configuration.gateway_ip, c.Configuration.server_macaddr) - :: (if Ipaddr.V4.(compare unspecified c.Configuration.host_ip) = 0 then [] - else [c.Configuration.host_ip, c.Configuration.server_macaddr ]); - } in - let client_uuids : uuid_table = { - mutex = Lwt_mutex.create(); - table = Hashtbl.create 50; - } in - let t = { - configuration = c; - global_arp_table; - client_uuids; - vnet_switch; - } in + let global_arp_table : arp_table = + { + mutex = Lwt_mutex.create (); + table = + (c.Configuration.gateway_ip, c.Configuration.server_macaddr) + :: + (if Ipaddr.V4.(compare unspecified c.Configuration.host_ip) = 0 then + [] + else [ (c.Configuration.host_ip, c.Configuration.server_macaddr) ]); + } + in + let client_uuids : uuid_table = + { mutex = Lwt_mutex.create (); table = Hashtbl.create 50 } + in + let t = + { configuration = c; global_arp_table; client_uuids; vnet_switch } + in Lwt.return t let create_static vnet_switch c = - update_http c - >>= fun () -> - update_dns c - >>= fun () -> - create_common vnet_switch c + update_http c >>= fun () -> + update_dns c >>= fun () -> create_common vnet_switch c - let connect_client_by_uuid_ip t (uuid:Uuidm.t) (preferred_ip:Ipaddr.V4.t option) = + let connect_client_by_uuid_ip t (uuid : Uuidm.t) + (preferred_ip : Ipaddr.V4.t option) = Lwt_mutex.with_lock t.client_uuids.mutex (fun () -> - if (Hashtbl.mem t.client_uuids.table uuid) then begin + if Hashtbl.mem t.client_uuids.table uuid then ( (* uuid already used, get config *) - let (ip, vnet_client_id) = (Hashtbl.find t.client_uuids.table uuid) in - let mac = (Vnet.mac t.vnet_switch vnet_client_id) in - Log.info (fun f-> - f "Reconnecting MAC %s with IP %s" - (Macaddr.to_string mac) (Ipaddr.V4.to_string ip)); + let ip, vnet_client_id = Hashtbl.find t.client_uuids.table uuid in + let mac = Vnet.mac t.vnet_switch vnet_client_id in + Log.info (fun f -> + f "Reconnecting MAC %s with IP %s" (Macaddr.to_string mac) + (Ipaddr.V4.to_string ip)); match preferred_ip with | None -> Lwt_result.return mac | Some preferred_ip -> - let old_ip,_ = Hashtbl.find t.client_uuids.table uuid in - if (Ipaddr.V4.compare old_ip preferred_ip) != 0 then - Lwt_result.fail (`Msg "UUID already assigned to a different IP than the IP requested by the client") - else - Lwt_result.return mac - end else begin (* new uuid, register in bridge *) + let old_ip, _ = Hashtbl.find t.client_uuids.table uuid in + if Ipaddr.V4.compare old_ip preferred_ip != 0 then + Lwt_result.fail + (`Msg + "UUID already assigned to a different IP than the IP \ + requested by the client") + else Lwt_result.return mac) + else + (* new uuid, register in bridge *) (* register new client on bridge *) - Lwt.catch (fun () -> - let vnet_client_id = match Vnet.register t.vnet_switch with - | Ok x -> Ok x - | Error e -> Error e - in - or_failwith "vnet_switch" @@ Lwt.return vnet_client_id - >>= fun vnet_client_id -> - let client_macaddr = (Vnet.mac t.vnet_switch vnet_client_id) in - - let used_ips = - Hashtbl.fold (fun _ v l -> - let ip, _ = v in - l @ [ip]) t.client_uuids.table [] - in - - (* check if a specific IP is requested *) - let preferred_ip = - match preferred_ip with - | None -> None - | Some preferred_ip -> - Log.info (fun f -> - f "Client requested IP %s" (Ipaddr.V4.to_string preferred_ip)); - let preferred_ip_int32 = Ipaddr.V4.to_int32 preferred_ip in - let highest_ip_int32 = Ipaddr.V4.to_int32 t.configuration.Configuration.highest_ip in - let lowest_ip_int32 = Ipaddr.V4.to_int32 t.configuration.Configuration.lowest_ip in - if (preferred_ip_int32 > highest_ip_int32) - || (preferred_ip_int32 < lowest_ip_int32) - then begin - failwith "Preferred IP address out of range." - end; - if not (List.mem preferred_ip used_ips) then begin - Some preferred_ip - end else begin - Fmt.kstr failwith "Preferred IP address %s already used." - (Ipaddr.V4.to_string preferred_ip) - end - in - - (* look for a new unique IP *) - let rec next_unique_ip next_ip = - if (Ipaddr.V4.to_int32 next_ip) > (Ipaddr.V4.to_int32 t.configuration.Configuration.highest_ip) - then begin - failwith "No IP addresses available." - end; - if not (List.mem next_ip used_ips) then begin - next_ip - end else begin - let next_ip = - Ipaddr.V4.of_int32 (Int32.succ (Ipaddr.V4.to_int32 next_ip)) - in - next_unique_ip next_ip - end - in - - let client_ip = match preferred_ip with - | None -> next_unique_ip t.configuration.Configuration.lowest_ip - | Some ip -> ip - in - - (* Add IP to global ARP table *) - Lwt_mutex.with_lock t.global_arp_table.mutex (fun () -> - t.global_arp_table.table <- (client_ip, client_macaddr) - :: t.global_arp_table.table; - Lwt.return_unit) >>= fun () -> - - (* add to client table and return mac *) - Hashtbl.replace t.client_uuids.table uuid (client_ip, vnet_client_id); - Lwt_result.return client_macaddr) (fun e -> - match e with - | Failure msg -> Lwt_result.fail (`Msg msg) - | e -> raise e) (* re-raise other exceptions *) - end - ) + Lwt.catch + (fun () -> + let vnet_client_id = + match Vnet.register t.vnet_switch with + | Ok x -> Ok x + | Error e -> Error e + in + or_failwith "vnet_switch" @@ Lwt.return vnet_client_id + >>= fun vnet_client_id -> + let client_macaddr = Vnet.mac t.vnet_switch vnet_client_id in + + let used_ips = + Hashtbl.fold + (fun _ v l -> + let ip, _ = v in + l @ [ ip ]) + t.client_uuids.table [] + in + + (* check if a specific IP is requested *) + let preferred_ip = + match preferred_ip with + | None -> None + | Some preferred_ip -> + Log.info (fun f -> + f "Client requested IP %s" + (Ipaddr.V4.to_string preferred_ip)); + let preferred_ip_int32 = Ipaddr.V4.to_int32 preferred_ip in + let highest_ip_int32 = + Ipaddr.V4.to_int32 + t.configuration.Configuration.highest_ip + in + let lowest_ip_int32 = + Ipaddr.V4.to_int32 t.configuration.Configuration.lowest_ip + in + if + preferred_ip_int32 > highest_ip_int32 + || preferred_ip_int32 < lowest_ip_int32 + then failwith "Preferred IP address out of range."; + if not (List.mem preferred_ip used_ips) then + Some preferred_ip + else + Fmt.kstr failwith "Preferred IP address %s already used." + (Ipaddr.V4.to_string preferred_ip) + in + + (* look for a new unique IP *) + let rec next_unique_ip next_ip = + if + Ipaddr.V4.to_int32 next_ip + > Ipaddr.V4.to_int32 t.configuration.Configuration.highest_ip + then failwith "No IP addresses available."; + if not (List.mem next_ip used_ips) then next_ip + else + let next_ip = + Ipaddr.V4.of_int32 (Int32.succ (Ipaddr.V4.to_int32 next_ip)) + in + next_unique_ip next_ip + in + + let client_ip = + match preferred_ip with + | None -> next_unique_ip t.configuration.Configuration.lowest_ip + | Some ip -> ip + in + + (* Add IP to global ARP table *) + Lwt_mutex.with_lock t.global_arp_table.mutex (fun () -> + t.global_arp_table.table <- + (client_ip, client_macaddr) :: t.global_arp_table.table; + Lwt.return_unit) + >>= fun () -> + (* add to client table and return mac *) + Hashtbl.replace t.client_uuids.table uuid + (client_ip, vnet_client_id); + Lwt_result.return client_macaddr) + (fun e -> + match e with + | Failure msg -> Lwt_result.fail (`Msg msg) + | e -> raise e) (* re-raise other exceptions *)) let get_client_ip_id t uuid = Lwt_mutex.with_lock t.client_uuids.mutex (fun () -> - Lwt.return (Hashtbl.find t.client_uuids.table uuid) - ) + Lwt.return (Hashtbl.find t.client_uuids.table uuid)) let connect t client = Log.debug (fun f -> f "accepted vmnet connection"); - begin - Vmnet.of_fd - ~connect_client_fn:(connect_client_by_uuid_ip t) - ~server_macaddr:t.configuration.Configuration.server_macaddr - ~mtu:t.configuration.Configuration.mtu client - >>= function - | Error (`Msg x) -> - Lwt.fail_with ("rejected ethernet connection: " ^ x) - | Ok x -> + Vmnet.of_fd + ~connect_client_fn:(connect_client_by_uuid_ip t) + ~server_macaddr:t.configuration.Configuration.server_macaddr + ~mtu:t.configuration.Configuration.mtu client + >>= function + | Error (`Msg x) -> Lwt.fail_with ("rejected ethernet connection: " ^ x) + | Ok x -> let client_macaddr = Vmnet.get_client_macaddr x in let client_uuid = Vmnet.get_client_uuid x in - get_client_ip_id t client_uuid - >>= fun (client_ip, vnet_client_id) -> - connect x t.vnet_switch vnet_client_id - client_macaddr { t.configuration with lowest_ip = client_ip } + get_client_ip_id t client_uuid >>= fun (client_ip, vnet_client_id) -> + connect x t.vnet_switch vnet_client_id client_macaddr + { t.configuration with lowest_ip = client_ip } t.global_arp_table - end - end dune build @fmt failed "/usr/bin/env" "bash" "-c" "opam exec -- dune build @fmt --ignore-promoted-rules || (echo "dune build @fmt failed"; exit 2)" failed with exit status 2 2024-10-25 18:30.07: Job failed: Failed: Build failed