├── .github ├── dependabot.yml └── workflows │ ├── changelog.yml │ ├── nix.yml │ └── workflow.yml ├── .gitignore ├── .gitmodules ├── .ocamlformat ├── CHANGES.md ├── DESIGN.md ├── LICENSE.md ├── Makefile ├── README.md ├── cohttp-async.opam ├── cohttp-async.opam.template ├── cohttp-async ├── bin │ ├── cohttp_curl_async.ml │ ├── cohttp_server_async.ml │ └── dune ├── examples │ ├── dune │ ├── hello_world.ml │ ├── receive_post.ml │ └── s3_cp.ml ├── src │ ├── body.ml │ ├── body.mli │ ├── client.ml │ ├── client.mli │ ├── cohttp_async.ml │ ├── dune │ ├── input_channel.ml │ ├── input_channel.mli │ ├── io.ml │ ├── io.mli │ ├── server.ml │ └── server.mli └── test │ ├── cohttp_async_test │ └── src │ │ ├── cohttp_async_test.ml │ │ ├── cohttp_async_test.mli │ │ └── dune │ ├── dune │ └── test_async_integration.ml ├── cohttp-bench.opam ├── cohttp-bench.opam.template ├── cohttp-bench ├── async_server.ml ├── bench.ml ├── dune ├── eio_server.ml ├── latency.sh ├── lwt_unix_server.ml ├── lwt_unix_server_new.ml └── lwt_unix_server_new.mli ├── cohttp-curl-async.opam ├── cohttp-curl-async.opam.template ├── cohttp-curl-async ├── bin │ ├── curl.ml │ └── dune ├── src │ ├── cohttp_curl_async.ml │ ├── cohttp_curl_async.mli │ └── dune └── test │ ├── cohttp_curl_async_tests.ml │ └── dune ├── cohttp-curl-lwt.opam ├── cohttp-curl-lwt.opam.template ├── cohttp-curl-lwt ├── bin │ ├── curl.ml │ ├── curl.mli │ └── dune ├── src │ ├── cohttp_curl_lwt.ml │ ├── cohttp_curl_lwt.mli │ └── dune └── test │ ├── cohttp_curl_lwt_tests.ml │ └── dune ├── cohttp-curl.opam ├── cohttp-curl.opam.template ├── cohttp-curl └── src │ ├── cohttp_curl.ml │ ├── cohttp_curl.mli │ └── dune ├── cohttp-eio.opam ├── cohttp-eio.opam.template ├── cohttp-eio ├── examples │ ├── client1.ml │ ├── client_timeout.ml │ ├── client_tls.ml │ ├── docker_client.ml │ ├── dune │ ├── server1.ml │ └── server2.ml ├── src │ ├── body.ml │ ├── client.ml │ ├── client.mli │ ├── cohttp_eio.ml │ ├── dune │ ├── io.ml │ ├── io.mli │ ├── server.ml │ ├── server.mli │ └── utils.ml └── tests │ ├── dune │ └── test.ml ├── cohttp-lwt-jsoo.opam ├── cohttp-lwt-jsoo.opam.template ├── cohttp-lwt-jsoo ├── src │ ├── cohttp_lwt_jsoo.ml │ ├── cohttp_lwt_jsoo.mli │ └── dune └── test │ ├── package.json │ ├── src │ ├── cohttp_lwt_jsoo_test.ml │ ├── dune │ └── test.js │ └── yarn.lock ├── cohttp-lwt-unix.opam ├── cohttp-lwt-unix.opam.template ├── cohttp-lwt-unix ├── bin │ ├── cohttp_curl_lwt.ml │ ├── cohttp_proxy_lwt.ml │ ├── cohttp_server_lwt.ml │ └── dune ├── examples │ ├── client_lwt.ml │ ├── client_lwt_proxy.ml │ ├── client_lwt_timeout.ml │ ├── docker_lwt.ml │ ├── dune │ └── server_lwt.ml ├── src │ ├── cohttp_lwt_unix.ml │ ├── debug.ml │ ├── debug.mli │ ├── dune │ ├── input_channel.ml │ ├── io.ml │ ├── io.mli │ ├── net.ml │ ├── net.mli │ ├── server.ml │ └── server.mli └── test │ ├── cohttp_lwt_unix_test │ └── src │ │ ├── cohttp_lwt_unix_test.ml │ │ ├── cohttp_lwt_unix_test.mli │ │ └── dune │ ├── dune │ ├── test_body.ml │ ├── test_client.ml │ ├── test_parser.ml │ ├── test_sanity.ml │ └── test_sanity_noisy.ml ├── cohttp-lwt.opam ├── cohttp-lwt.opam.template ├── cohttp-lwt ├── src │ ├── body.ml │ ├── body.mli │ ├── bytebuffer.ml │ ├── client.ml │ ├── client.mli │ ├── cohttp_lwt.ml │ ├── connection.ml │ ├── connection_cache.ml │ ├── connection_cache.mli │ ├── dune │ ├── make.ml │ ├── s.ml │ ├── server.ml │ ├── server.mli │ ├── string_io.ml │ └── string_io.mli └── test │ └── bytebuffer_tests.ml ├── cohttp-mirage-CHANGES.md ├── cohttp-mirage.opam ├── cohttp-mirage.opam.template ├── cohttp-mirage └── src │ ├── client.ml │ ├── client.mli │ ├── cohttp_mirage.ml │ ├── dune │ ├── input_channel.ml │ ├── io.ml │ ├── io.mli │ ├── make.ml │ ├── make.mli │ ├── net.ml │ ├── net.mli │ ├── server.ml │ ├── server.mli │ ├── static.ml │ └── static.mli ├── cohttp-server-lwt-unix.opam ├── cohttp-server-lwt-unix.opam.template ├── cohttp-server-lwt-unix ├── src │ ├── cohttp_server_lwt_unix.ml │ ├── cohttp_server_lwt_unix.mli │ └── dune └── test │ ├── dune │ └── test.ml ├── cohttp-top.opam ├── cohttp-top.opam.template ├── cohttp-top └── src │ ├── cohttp_top.ml │ └── dune ├── cohttp.opam ├── cohttp.opam.template ├── cohttp ├── src │ ├── accept.ml │ ├── accept.mli │ ├── accept_lexer.mll │ ├── accept_parser.mly │ ├── accept_types.ml │ ├── auth.ml │ ├── auth.mli │ ├── body.ml │ ├── body.mli │ ├── client.ml │ ├── code.ml │ ├── code.mli │ ├── cohttp.ml │ ├── conf.mli │ ├── connection.ml │ ├── connection.mli │ ├── cookie.ml │ ├── cookie.mli │ ├── dune │ ├── header.ml │ ├── header.mli │ ├── header_io.ml │ ├── header_io.mli │ ├── link.ml │ ├── link.mli │ ├── path.ml │ ├── path.mli │ ├── request.ml │ ├── request.mli │ ├── response.ml │ ├── response.mli │ ├── s.ml │ ├── server.ml │ ├── string_io.ml │ ├── string_io.mli │ ├── transfer.ml │ ├── transfer.mli │ ├── transfer_io.ml │ └── transfer_io.mli └── test │ ├── dune │ ├── test_accept.ml │ ├── test_body.ml │ ├── test_header.ml │ ├── test_path.ml │ └── test_request.ml ├── dune ├── dune-project ├── flake.lock ├── flake.nix ├── http.opam ├── http.opam.template ├── http ├── fuzz │ ├── dune │ ├── fuzz_header.ml │ └── inputs │ │ └── input ├── src │ ├── bytebuffer │ │ ├── bytebuffer.ml │ │ ├── bytebuffer.mli │ │ └── dune │ ├── dune │ ├── http.ml │ └── http.mli └── test │ ├── bytebuffer │ ├── bytebuffer_tests.ml │ └── dune │ ├── dune │ ├── expect │ ├── dune │ └── http_tests.ml │ ├── test_header.ml │ ├── test_parser.ml │ ├── test_request.ml │ └── test_response.ml └── test_helpers ├── cohttp_server ├── cohttp_server.ml └── dune └── cohttp_test └── src ├── cohttp_test.ml ├── cohttp_test.mli └── dune /.github/dependabot.yml: -------------------------------------------------------------------------------- 1 | version: 2 2 | updates: 3 | - package-ecosystem: github-actions 4 | directory: / 5 | schedule: 6 | interval: weekly 7 | -------------------------------------------------------------------------------- /.github/workflows/changelog.yml: -------------------------------------------------------------------------------- 1 | name: Changelog check 2 | 3 | on: 4 | pull_request: 5 | branches: [master] 6 | types: [opened, synchronize, reopened, labeled, unlabeled] 7 | 8 | jobs: 9 | Changelog-Entry-Check: 10 | name: Check Changelog Action 11 | runs-on: ubuntu-latest 12 | steps: 13 | - uses: tarides/changelog-check-action@v3 14 | -------------------------------------------------------------------------------- /.github/workflows/nix.yml: -------------------------------------------------------------------------------- 1 | name: "Nix" 2 | on: 3 | pull_request: 4 | push: 5 | jobs: 6 | tests: 7 | runs-on: ubuntu-latest 8 | steps: 9 | - name: Checkout tree 10 | uses: actions/checkout@v4 11 | with: 12 | submodules: true 13 | - uses: cachix/install-nix-action@v30 14 | with: 15 | extra_nix_config: | 16 | extra-substituters = https://anmonteiro.nix-cache.workers.dev 17 | extra-trusted-public-keys = ocaml.nix-cache.com-1:/xI2h2+56rwFfKyyFVbkJSeGqSIYMC/Je+7XXqGKDIY= 18 | - run: nix develop -L .# -c dune build @runtest @check 19 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .*.swp 2 | _build/ 3 | *.install 4 | .merlin 5 | _opam/ 6 | node_modules 7 | dune.lock/ 8 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mirage/ocaml-cohttp/ca90e54281fdaec9765452ca753388f532f5c4cb/.gitmodules -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | version=0.27.0 2 | profile=conventional 3 | break-infix=fit-or-vertical 4 | parse-docstrings=true 5 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | (* 2 | * ISC License 3 | * 4 | * Copyright (c) 2009-2018 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | * 18 | *) 19 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: build clean test clean eio eio-shell eio-test fmt js-test 2 | 3 | build: 4 | dune build 5 | 6 | test: 7 | dune runtest 8 | 9 | js-test: 10 | dune build @runjstest 11 | 12 | clean: 13 | dune clean 14 | 15 | fmt: 16 | dune b @fmt --auto-promote 17 | 18 | eio: #build eio 19 | dune build cohttp-eio 20 | 21 | eio-test: 22 | dune runtest cohttp-eio 23 | 24 | eio-shell: # nix-shell for eio dev 25 | nix develop .#eio 26 | -------------------------------------------------------------------------------- /cohttp-async.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "CoHTTP implementation for the Async concurrency library" 4 | description: """ 5 | An implementation of an HTTP client and server using the Async 6 | concurrency library. See the `Cohttp_async` module for information 7 | on how to use this. The package also installs `cohttp-curl-async` 8 | and a `cohttp-server-async` binaries for quick uses of a HTTP(S) 9 | client and server respectively. 10 | """ 11 | maintainer: ["Anil Madhavapeddy "] 12 | authors: [ 13 | "Anil Madhavapeddy" 14 | "Stefano Zacchiroli" 15 | "David Sheets" 16 | "Thomas Gazagnaire" 17 | "David Scott" 18 | "Rudi Grinberg" 19 | "Andy Ray" 20 | "Anurag Soni" 21 | ] 22 | license: "ISC" 23 | homepage: "https://github.com/mirage/ocaml-cohttp" 24 | doc: "https://mirage.github.io/ocaml-cohttp/" 25 | bug-reports: "https://github.com/mirage/ocaml-cohttp/issues" 26 | depends: [ 27 | "dune" {>= "3.8"} 28 | "ocaml" {>= "4.14" & < "5.3.0"} 29 | "http" {= version} 30 | "cohttp" {= version} 31 | "async_kernel" {>= "v0.16.0"} 32 | "async_unix" {>= "v0.16.0"} 33 | "async" {>= "v0.16.0"} 34 | "base" {>= "v0.16.0"} 35 | "core" {with-test} 36 | "core_unix" {>= "v0.14.0"} 37 | "conduit-async" {>= "1.2.0"} 38 | "magic-mime" 39 | "digestif" {with-test} 40 | "logs" 41 | "fmt" {>= "0.8.2"} 42 | "sexplib0" 43 | "ppx_sexp_conv" {>= "v0.13.0"} 44 | "ounit2" {with-test} 45 | "uri" {>= "2.0.0"} 46 | "uri-sexp" 47 | "ipaddr" 48 | "odoc" {with-doc} 49 | ] 50 | dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git" 51 | build: [ 52 | ["dune" "subst"] {dev} 53 | [ 54 | "dune" 55 | "build" 56 | "-p" 57 | name 58 | "-j" 59 | jobs 60 | "@install" 61 | "@cohttp-async/runtest" {with-test} 62 | "@doc" {with-doc} 63 | ] 64 | ] 65 | available: arch != "s390x" 66 | x-maintenance-intent: [ "(latest)" ] 67 | -------------------------------------------------------------------------------- /cohttp-async.opam.template: -------------------------------------------------------------------------------- 1 | build: [ 2 | ["dune" "subst"] {dev} 3 | [ 4 | "dune" 5 | "build" 6 | "-p" 7 | name 8 | "-j" 9 | jobs 10 | "@install" 11 | "@cohttp-async/runtest" {with-test} 12 | "@doc" {with-doc} 13 | ] 14 | ] 15 | available: arch != "s390x" 16 | x-maintenance-intent: [ "(latest)" ] 17 | -------------------------------------------------------------------------------- /cohttp-async/bin/cohttp_curl_async.ml: -------------------------------------------------------------------------------- 1 | (*{{{ Copyright (c) 2014 Anil Madhavapeddy 2 | * 3 | * Permission to use, copy, modify, and distribute this software for any 4 | * purpose with or without fee is hereby granted, provided that the above 5 | * copyright notice and this permission notice appear in all copies. 6 | * 7 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | * 15 | }}}*) 16 | 17 | open Base 18 | open Async_kernel 19 | module Body = Cohttp_async.Body 20 | module Client = Cohttp_async.Client 21 | 22 | let show_headers h = 23 | Cohttp.Header.iter (fun k v -> Logs.info (fun m -> m "%s: %s%!" k v)) h 24 | 25 | let make_net_req uri meth' body () = 26 | let meth = Cohttp.Code.method_of_string meth' in 27 | let uri = Uri.of_string uri in 28 | let headers = Cohttp.Header.of_list [ ("connection", "close") ] in 29 | Client.call meth ~headers ~body:Body.(of_string body) uri 30 | >>= fun (res, body) -> 31 | show_headers (Http.Response.headers res); 32 | body 33 | |> Body.to_pipe 34 | |> Pipe.iter ~f:(fun b -> 35 | Stdlib.print_string b; 36 | return ()) 37 | 38 | let _ = 39 | (* enable logging to stdout *) 40 | Fmt_tty.setup_std_outputs (); 41 | Logs.set_level @@ Some Logs.Debug; 42 | Logs.set_reporter (Logs_fmt.reporter ()); 43 | let open Async_command in 44 | async_spec ~summary:"Fetch URL and print it" 45 | Spec.( 46 | empty 47 | +> anon ("url" %: string) 48 | +> flag "-X" (optional_with_default "GET" string) ~doc:" Set HTTP method" 49 | +> flag "data-binary" 50 | (optional_with_default "" string) 51 | ~doc:" Data to send when using POST") 52 | make_net_req 53 | |> Command_unix.run 54 | -------------------------------------------------------------------------------- /cohttp-async/bin/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names cohttp_curl_async cohttp_server_async) 3 | (libraries 4 | cohttp-async 5 | async_kernel 6 | async.async_command 7 | async_unix 8 | base 9 | cohttp 10 | cohttp_server 11 | fmt.tty 12 | core_unix.command_unix)) 13 | -------------------------------------------------------------------------------- /cohttp-async/examples/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names hello_world receive_post) 3 | (libraries 4 | digestif.c 5 | http 6 | cohttp-async 7 | base 8 | async_kernel 9 | core_unix.command_unix)) 10 | 11 | (alias 12 | (name runtest) 13 | (package cohttp-async) 14 | (deps hello_world.exe receive_post.exe)) 15 | -------------------------------------------------------------------------------- /cohttp-async/examples/hello_world.ml: -------------------------------------------------------------------------------- 1 | (* This file is in the public domain *) 2 | open Core 3 | open Async_kernel 4 | module Server = Cohttp_async.Server 5 | 6 | (* given filename: hello_world.ml compile with: 7 | $ corebuild hello_world.native -pkg cohttp.async 8 | *) 9 | 10 | let handler ~body:_ _sock req = 11 | let uri = Cohttp.Request.uri req in 12 | match Uri.path uri with 13 | | "/test" -> 14 | Uri.get_query_param uri "hello" 15 | |> Option.map ~f:(fun v -> "hello: " ^ v) 16 | |> Option.value ~default:"No param hello supplied" 17 | |> Server.respond_string 18 | | _ -> Server.respond_string ~status:`Not_found "Route not found" 19 | 20 | let start_server port () = 21 | Stdlib.Printf.eprintf "Listening for HTTP on port %d\n" port; 22 | Stdlib.Printf.eprintf "Try 'curl http://localhost:%d/test?hello=xyz'\n%!" port; 23 | Server.create ~on_handler_error:`Raise 24 | (Async.Tcp.Where_to_listen.of_port port) 25 | handler 26 | >>= fun server -> 27 | Deferred.forever () (fun () -> 28 | after Time_ns.Span.(of_sec 0.5) >>| fun () -> 29 | Async.Log.Global.printf "Active connections: %d" 30 | (Server.num_connections server)); 31 | Deferred.never () 32 | 33 | let () = 34 | let module Command = Async_command in 35 | Command.async_spec ~summary:"Start a hello world Async server" 36 | Command.Spec.( 37 | empty 38 | +> flag "-p" 39 | (optional_with_default 8080 int) 40 | ~doc:"int Source port to listen on") 41 | start_server 42 | |> Command_unix.run 43 | -------------------------------------------------------------------------------- /cohttp-async/examples/receive_post.ml: -------------------------------------------------------------------------------- 1 | (* This file is in the public domain *) 2 | open Base 3 | open Async_kernel 4 | module Body = Cohttp_async.Body 5 | module Server = Cohttp_async.Server 6 | 7 | (* compile with: $ corebuild receive_post.native -pkg cohttp.async *) 8 | 9 | let start_server port () = 10 | Stdlib.Printf.eprintf "Listening for HTTP on port %d\n" port; 11 | Stdlib.Printf.eprintf "Try 'curl -X POST -d 'foo bar' http://localhost:%d\n" 12 | port; 13 | Cohttp_async.Server.create ~on_handler_error:`Raise 14 | (Async.Tcp.Where_to_listen.of_port port) (fun ~body _ req -> 15 | match req |> Http.Request.meth with 16 | | `POST -> 17 | Body.to_string body >>= fun body -> 18 | Stdlib.Printf.eprintf "Body: %s" body; 19 | Server.respond `OK 20 | | _ -> Server.respond `Method_not_allowed) 21 | >>= fun _ -> Deferred.never () 22 | 23 | let () = 24 | let module Command = Async_command in 25 | Command.async_spec ~summary:"Simple http server that outputs body of POST's" 26 | Command.Spec.( 27 | empty 28 | +> flag "-p" 29 | (optional_with_default 8080 int) 30 | ~doc:"int Source port to listen on") 31 | start_server 32 | |> Command_unix.run 33 | -------------------------------------------------------------------------------- /cohttp-async/src/body.mli: -------------------------------------------------------------------------------- 1 | open! Base 2 | open! Async_kernel 3 | 4 | type t = [ Cohttp.Body.t | `Pipe of string Pipe.Reader.t ] [@@deriving sexp_of] 5 | 6 | include Cohttp.S.Body with type t := t 7 | 8 | val to_string : t -> string Deferred.t 9 | val to_string_list : t -> string list Deferred.t 10 | val to_pipe : t -> string Pipe.Reader.t 11 | val of_pipe : string Pipe.Reader.t -> t 12 | val map : t -> f:(string -> string) -> t 13 | val as_pipe : t -> f:(string Pipe.Reader.t -> string Pipe.Reader.t) -> t 14 | val to_form : t -> (string * string list) list Deferred.t 15 | val is_empty : t -> [ `True | `False | `Unknown ] 16 | 17 | module Private : sig 18 | val write_body : 19 | ('a -> string -> unit Deferred.t) -> t -> 'a -> unit Deferred.t 20 | 21 | val pipe_of_body : 22 | ('a -> Cohttp.Transfer.chunk Deferred.t) -> 'a -> string Pipe.Reader.t 23 | 24 | val disable_chunked_encoding : t -> (t * int64) Deferred.t 25 | val drain : t -> unit Deferred.t 26 | end 27 | -------------------------------------------------------------------------------- /cohttp-async/src/cohttp_async.ml: -------------------------------------------------------------------------------- 1 | module Body = Body 2 | module Body_raw = Body [@@deprecated "Use Body"] 3 | module Client = Client 4 | module Io = Io [@@deprecated "This module is not for public consumption"] 5 | module Request = Cohttp.Request [@@deprecated "Use Cohttp.Request directly"] 6 | module Response = Cohttp.Response [@@deprecated "Use Cohttp.Response directly"] 7 | module Server = Server 8 | -------------------------------------------------------------------------------- /cohttp-async/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name cohttp_async) 3 | (synopsis "Async backend") 4 | (public_name cohttp-async) 5 | (libraries 6 | logs.fmt 7 | base 8 | fmt 9 | async_unix 10 | async_kernel 11 | uri 12 | uri.services 13 | uri-sexp 14 | ipaddr.unix 15 | conduit-async 16 | magic-mime 17 | http 18 | http_bytebuffer 19 | cohttp) 20 | (preprocess 21 | (pps ppx_sexp_conv))) 22 | -------------------------------------------------------------------------------- /cohttp-async/src/input_channel.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | 4 | module Bytebuffer = struct 5 | module Bytebuffer = Http_bytebuffer.Bytebuffer 6 | include Bytebuffer 7 | 8 | include 9 | Bytebuffer.Make 10 | (Deferred) 11 | (struct 12 | type src = Reader.t 13 | 14 | let refill reader buf ~pos ~len = Reader.read reader ~pos ~len buf 15 | end) 16 | end 17 | 18 | type t = { buf : Bytebuffer.t; reader : Reader.t } 19 | 20 | let create ?(buf_len = 0x4000) reader = 21 | { buf = Bytebuffer.create buf_len; reader } 22 | 23 | let read_line_opt t = Bytebuffer.read_line t.buf t.reader 24 | let read t count = Bytebuffer.read t.buf t.reader count 25 | let refill t = Bytebuffer.refill t.buf t.reader 26 | 27 | let with_input_buffer t ~f = 28 | let buf = Bytebuffer.unsafe_buf t.buf in 29 | let pos = Bytebuffer.pos t.buf in 30 | let len = Bytebuffer.length t.buf in 31 | let res, consumed = 32 | f (Bytes.unsafe_to_string ~no_mutation_while_string_reachable:buf) ~pos ~len 33 | in 34 | Bytebuffer.drop t.buf consumed; 35 | res 36 | 37 | let is_closed t = Reader.is_closed t.reader 38 | let close t = Reader.close t.reader 39 | let close_finished t = Reader.close_finished t.reader 40 | 41 | let transfer t writer = 42 | let finished = Ivar.create () in 43 | upon (Pipe.closed writer) (fun () -> Ivar.fill_if_empty finished ()); 44 | let rec loop () = 45 | refill t >>> function 46 | | `Eof -> Ivar.fill_if_empty finished () 47 | | `Ok -> 48 | let payload = 49 | with_input_buffer t ~f:(fun buf ~pos ~len -> 50 | (String.sub buf ~pos ~len, len)) 51 | in 52 | Pipe.write writer payload >>> fun () -> loop () 53 | in 54 | loop (); 55 | Ivar.read finished 56 | 57 | let to_reader info ic = 58 | let reader, writer = Pipe.create () in 59 | ( transfer ic writer >>> fun () -> 60 | close ic >>> fun () -> Pipe.close writer ); 61 | Reader.of_pipe info reader 62 | -------------------------------------------------------------------------------- /cohttp-async/src/input_channel.mli: -------------------------------------------------------------------------------- 1 | open Async 2 | 3 | type t 4 | 5 | val create : ?buf_len:int -> Reader.t -> t 6 | val read_line_opt : t -> string option Deferred.t 7 | val read : t -> int -> string Deferred.t 8 | val refill : t -> [ `Eof | `Ok ] Deferred.t 9 | val with_input_buffer : t -> f:(string -> pos:int -> len:int -> 'a * int) -> 'a 10 | val is_closed : t -> bool 11 | val close : t -> unit Deferred.t 12 | val close_finished : t -> unit Deferred.t 13 | val to_reader : Base.Info.t -> t -> Reader.t Deferred.t 14 | -------------------------------------------------------------------------------- /cohttp-async/src/io.mli: -------------------------------------------------------------------------------- 1 | (*{{{ Copyright (c) 2013 Anil Madhavapeddy 2 | * 3 | * Permission to use, copy, modify, and distribute this software for 4 | * any purpose with or without fee is hereby granted, provided that the 5 | * above copyright notice and this permission notice appear in all 6 | * copies. THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS 7 | * ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED 8 | * WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE 9 | * AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL 10 | * DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA 11 | * OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER 12 | * TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR 13 | * PERFORMANCE OF THIS SOFTWARE. 14 | }}}*) 15 | 16 | module IO : 17 | Cohttp.S.IO 18 | with type 'a t = 'a Async_kernel.Deferred.t 19 | and type ic = Input_channel.t 20 | and type oc = Async_unix.Writer.t 21 | 22 | module Request : 23 | Cohttp.S.Http_io with type t := Http.Request.t and module IO := IO 24 | 25 | module Response : 26 | Cohttp.S.Http_io with type t := Http.Response.t and module IO := IO 27 | -------------------------------------------------------------------------------- /cohttp-async/test/cohttp_async_test/src/cohttp_async_test.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Async_kernel 3 | open OUnit 4 | module Server = Cohttp_async.Server 5 | module Body = Cohttp_async.Body 6 | 7 | type 'a io = 'a Deferred.t 8 | type ic = Async_unix.Reader.t 9 | type oc = Async_unix.Writer.t 10 | type body = Body.t 11 | 12 | type response_action = 13 | [ `Expert of Http.Response.t * (ic -> oc -> unit io) 14 | | `Response of Http.Response.t * body ] 15 | 16 | type spec = Http.Request.t -> body -> response_action io 17 | type async_test = unit -> unit io 18 | 19 | let response rsp = `Response rsp 20 | 21 | let expert ?(rsp = Cohttp.Response.make ()) f _req _body = 22 | return (`Expert (rsp, f)) 23 | 24 | let const rsp _req _body = rsp >>| response 25 | let response_sequence = Cohttp_test.response_sequence failwith 26 | 27 | let get_port = 28 | let port = ref 10_080 in 29 | fun () -> 30 | let v = !port in 31 | Int.incr port; 32 | v 33 | 34 | let temp_server ?port spec callback = 35 | let port = match port with None -> get_port () | Some p -> p in 36 | let uri = Uri.of_string ("http://0.0.0.0:" ^ Int.to_string port) in 37 | let server = 38 | Server.create_expert ~on_handler_error:`Raise 39 | (Async.Tcp.Where_to_listen.of_port port) (fun ~body _sock req -> 40 | spec req body) 41 | in 42 | server >>= fun server -> 43 | callback uri >>= fun res -> 44 | Server.close server >>| fun () -> res 45 | 46 | let test_server_s ?port ?(name = "Cohttp Server Test") spec f = 47 | temp_server ?port spec (fun uri -> 48 | Logs.info (fun m -> m "Test %s running on %s" name (Uri.to_string uri)); 49 | let tests = f uri in 50 | let results = 51 | tests 52 | |> Deferred.List.map ~how:`Sequential ~f:(fun (name, test) -> 53 | Logs.debug (fun m -> m "Running %s" name); 54 | let res = 55 | try_with test >>| function 56 | | Ok () -> `Ok 57 | | Error exn -> `Exn exn 58 | in 59 | res >>| fun res -> (name, res)) 60 | in 61 | results >>| fun results -> 62 | let ounit_tests = 63 | results 64 | |> List.map ~f:(fun (name, res) -> 65 | name >:: fun () -> match res with `Ok -> () | `Exn x -> raise x) 66 | in 67 | name >::: ounit_tests) 68 | 69 | let run_async_tests test = 70 | (* enable logging to stdout *) 71 | Fmt_tty.setup_std_outputs (); 72 | Logs.set_level @@ Some Logs.Debug; 73 | Logs.set_reporter (Logs_fmt.reporter ()); 74 | test >>| fun a -> a |> OUnit.run_test_tt_main 75 | -------------------------------------------------------------------------------- /cohttp-async/test/cohttp_async_test/src/cohttp_async_test.mli: -------------------------------------------------------------------------------- 1 | open Async_kernel 2 | 3 | include 4 | Cohttp_test.S 5 | with type 'a io = 'a Deferred.t 6 | and type body = Cohttp_async.Body.t 7 | and type ic = Async_unix.Reader.t 8 | and type oc = Async_unix.Writer.t 9 | 10 | val run_async_tests : OUnit.test io -> OUnit.test_result list Deferred.t 11 | -------------------------------------------------------------------------------- /cohttp-async/test/cohttp_async_test/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name cohttp_async_test) 3 | (libraries fmt.tty uri.services async_kernel cohttp_test cohttp-async)) 4 | -------------------------------------------------------------------------------- /cohttp-async/test/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test_async_integration) 3 | (libraries 4 | cohttp_async_test 5 | async_unix 6 | base 7 | core 8 | async_kernel 9 | ounit2 10 | cohttp-async)) 11 | 12 | (rule 13 | (alias runtest) 14 | (package cohttp-async) 15 | (action 16 | (run ./test_async_integration.exe))) 17 | -------------------------------------------------------------------------------- /cohttp-bench.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Benchmarks binaries for Cohttp" 4 | description: """ 5 | This package contains some benchmarks for http and cohttp. 6 | The benchmarks for the server latency will require wrk2 7 | (https://github.com/giltene/wrk2) to run. The latency graphs 8 | can then be generated with HdrHistogram plotter, also available 9 | online at https://hdrhistogram.github.io/HdrHistogram/plotFiles.html.""" 10 | maintainer: ["Anil Madhavapeddy "] 11 | authors: [ 12 | "Anil Madhavapeddy" 13 | "Stefano Zacchiroli" 14 | "David Sheets" 15 | "Thomas Gazagnaire" 16 | "David Scott" 17 | "Rudi Grinberg" 18 | "Andy Ray" 19 | "Anurag Soni" 20 | ] 21 | license: "ISC" 22 | homepage: "https://github.com/mirage/ocaml-cohttp" 23 | doc: "https://mirage.github.io/ocaml-cohttp/" 24 | bug-reports: "https://github.com/mirage/ocaml-cohttp/issues" 25 | depends: [ 26 | "dune" {>= "3.8"} 27 | "core" {>= "v0.13.0"} 28 | "core_bench" 29 | "eio" {>= "0.12"} 30 | "eio_main" 31 | "http" {= version} 32 | "cohttp" {= version} 33 | "cohttp-eio" {= version} 34 | "cohttp-lwt-unix" {= version} 35 | "cohttp-server-lwt-unix" {= version} 36 | "cohttp-async" {= version} 37 | "odoc" {with-doc} 38 | ] 39 | dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git" 40 | build: [ 41 | ["dune" "subst"] {dev} 42 | [ 43 | "dune" 44 | "build" 45 | "-p" 46 | name 47 | "-j" 48 | jobs 49 | "@install" 50 | "@cohttp-bench/runtest" {with-test} 51 | "@doc" {with-doc} 52 | ] 53 | ] 54 | x-maintenance-intent: [ "(latest)" ] 55 | -------------------------------------------------------------------------------- /cohttp-bench.opam.template: -------------------------------------------------------------------------------- 1 | build: [ 2 | ["dune" "subst"] {dev} 3 | [ 4 | "dune" 5 | "build" 6 | "-p" 7 | name 8 | "-j" 9 | jobs 10 | "@install" 11 | "@cohttp-bench/runtest" {with-test} 12 | "@doc" {with-doc} 13 | ] 14 | ] 15 | x-maintenance-intent: [ "(latest)" ] 16 | -------------------------------------------------------------------------------- /cohttp-bench/async_server.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Async 3 | module Server = Cohttp_async.Server 4 | 5 | let length = 2053 6 | let text = String.make length 'a' 7 | let headers = Cohttp.Header.of_list [ ("content-length", Int.to_string length) ] 8 | let handler ~body:_ _sock _req = Server.respond_string ~headers text 9 | 10 | let start_server port () = 11 | Cohttp_async.Server.create ~on_handler_error:`Raise 12 | (Tcp.Where_to_listen.of_port port) 13 | handler 14 | >>= fun server -> 15 | Deferred.forever () (fun () -> 16 | after Time_float.Span.(of_sec 0.5) >>| fun () -> 17 | Log.Global.printf "Active connections: %d" (Server.num_connections server)); 18 | Deferred.never () 19 | 20 | let () = 21 | let module Command = Async_command in 22 | Command.async_spec ~summary:"Start a hello world Async server" 23 | Command.Spec.( 24 | empty 25 | +> flag "-p" 26 | (optional_with_default 8080 int) 27 | ~doc:"int Source port to listen on") 28 | start_server 29 | |> Command_unix.run 30 | -------------------------------------------------------------------------------- /cohttp-bench/bench.ml: -------------------------------------------------------------------------------- 1 | module Command = Core.Command 2 | module Staged = Core.Staged 3 | open Core_bench 4 | 5 | let header_names = 6 | [ 7 | "Accept"; 8 | "Accept-Encoding"; 9 | "Accept-Language"; 10 | "Cache-Control"; 11 | "Connection"; 12 | "Host"; 13 | "If-Modified-Since"; 14 | "If-None-Match"; 15 | "Origin"; 16 | "Referer"; 17 | "Sec-Fetch-Dest"; 18 | "Sec-Fetch-Mode"; 19 | "Sec-Fetch-Site"; 20 | ] 21 | 22 | let header = 23 | header_names |> List.map (fun s -> (s, "value")) |> Http.Header.of_list 24 | 25 | let bench_header_mem = 26 | Bench.Test.create ~name:"Header.mem" (fun () -> 27 | List.iter (fun key -> assert (Http.Header.mem header key)) header_names) 28 | 29 | let () = Command_unix.run @@ Bench.make_command [ bench_header_mem ] 30 | -------------------------------------------------------------------------------- /cohttp-bench/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name bench) 3 | (modules bench) 4 | (libraries http core core_unix.command_unix core_bench)) 5 | 6 | (executable 7 | (name lwt_unix_server) 8 | (modules lwt_unix_server) 9 | (libraries cohttp-lwt-unix logs.fmt fmt.tty)) 10 | 11 | (executable 12 | (name async_server) 13 | (modules async_server) 14 | (libraries cohttp-async core_unix.command_unix logs.fmt fmt.tty)) 15 | 16 | (executable 17 | (name eio_server) 18 | (modules eio_server) 19 | (libraries cohttp-eio eio_main)) 20 | 21 | (rule 22 | (alias bench) 23 | (package cohttp-bench) 24 | (enabled_if %{arch_sixtyfour}) 25 | (action 26 | (run ./bench.exe time cycles))) 27 | 28 | (rule 29 | (alias latency) 30 | (deps lwt_unix_server.exe async_server.exe) 31 | (package cohttp-bench) 32 | (action 33 | (run ./latency.sh))) 34 | 35 | (executable 36 | (name lwt_unix_server_new) 37 | (modules lwt_unix_server_new) 38 | (libraries cohttp_server_lwt_unix lwt.unix lwt http unix)) 39 | -------------------------------------------------------------------------------- /cohttp-bench/eio_server.ml: -------------------------------------------------------------------------------- 1 | open Cohttp_eio 2 | 3 | let length = 2053 4 | let text = String.make length 'a' 5 | let headers = Cohttp.Header.of_list [ ("content-length", Int.to_string length) ] 6 | 7 | let server_callback _conn _req _body = 8 | Server.respond_string ~headers ~status:`OK ~body:text () 9 | 10 | let () = 11 | let port = ref 8080 in 12 | Arg.parse 13 | [ ("-p", Arg.Set_int port, " Listening port number(8080 by default)") ] 14 | ignore "An HTTP/1.1 server"; 15 | Eio_main.run @@ fun env -> 16 | Eio.Switch.run @@ fun sw -> 17 | let socket = 18 | Eio.Net.listen env#net ~sw ~backlog:11_000 ~reuse_addr:true 19 | (`Tcp (Eio.Net.Ipaddr.V4.loopback, !port)) 20 | and server = Cohttp_eio.Server.make ~callback:server_callback () in 21 | Cohttp_eio.Server.run socket server ~on_error:raise 22 | -------------------------------------------------------------------------------- /cohttp-bench/latency.sh: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env bash 2 | set -xe 3 | 4 | rm -rf output/* 5 | mkdir -p output 6 | 7 | for cmd in "lwt_unix_server" "async_server" "lwt_unix_server_new" "eio_server"; do 8 | ./$cmd.exe & 9 | running_pid=$! 10 | echo "Measuring latency of $cmd" 11 | sleep 2; 12 | wrk2 \ 13 | -t2 -c1000 -d5s \ 14 | --timeout 2000 \ 15 | -R 80000 --latency \ 16 | -H 'Connection: keep-alive' \ 17 | "http://localhost:8080" > output/run-$cmd.txt; 18 | kill ${running_pid}; 19 | sleep 1; 20 | done 21 | echo "The results are available in $PWD/output" 22 | -------------------------------------------------------------------------------- /cohttp-bench/lwt_unix_server.ml: -------------------------------------------------------------------------------- 1 | module Server = Cohttp_lwt_unix.Server 2 | 3 | let length = 2053 4 | let text = String.make length 'a' 5 | let headers = Cohttp.Header.of_list [ ("content-length", Int.to_string length) ] 6 | 7 | let server_callback _conn _req _body = 8 | Server.respond_string ~headers ~status:`OK ~body:text () 9 | 10 | let main () = 11 | Server.create ~backlog:11_000 (Server.make ~callback:server_callback ()) 12 | 13 | let () = 14 | Printexc.record_backtrace true; 15 | Logs.set_level (Some Info); 16 | Logs.set_reporter (Logs_fmt.reporter ()); 17 | ignore (Lwt_main.run (main ())) 18 | -------------------------------------------------------------------------------- /cohttp-bench/lwt_unix_server_new.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Syntax 2 | module Context = Cohttp_server_lwt_unix.Context 3 | module Body = Cohttp_server_lwt_unix.Body 4 | 5 | let text = String.make 2053 'a' 6 | 7 | let server_callback ctx = 8 | Lwt.join 9 | [ 10 | Context.discard_body ctx; 11 | Context.respond ctx (Http.Response.make ()) (Body.string text); 12 | ] 13 | 14 | let main () = 15 | let* _server = 16 | let listen_address = Unix.(ADDR_INET (inet_addr_loopback, 8080)) in 17 | let server = 18 | Cohttp_server_lwt_unix.create 19 | ~on_exn:(fun exn -> 20 | Format.eprintf "unexpected:@.%s@." (Printexc.to_string exn)) 21 | server_callback 22 | in 23 | Lwt_io.establish_server_with_client_address ~backlog:10_000 listen_address 24 | (fun _addr ch -> Cohttp_server_lwt_unix.handle_connection server ch) 25 | in 26 | let forever, _ = Lwt.wait () in 27 | forever 28 | 29 | let () = 30 | Printexc.record_backtrace true; 31 | ignore (Lwt_main.run (main ())) 32 | -------------------------------------------------------------------------------- /cohttp-bench/lwt_unix_server_new.mli: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mirage/ocaml-cohttp/ca90e54281fdaec9765452ca753388f532f5c4cb/cohttp-bench/lwt_unix_server_new.mli -------------------------------------------------------------------------------- /cohttp-curl-async.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Cohttp client using Curl & Async as the backend" 4 | description: """ 5 | An HTTP client that relies on Curl + Async for the backend. Does not require 6 | conduit for SSL.""" 7 | maintainer: ["Anil Madhavapeddy "] 8 | authors: [ 9 | "Anil Madhavapeddy" 10 | "Stefano Zacchiroli" 11 | "David Sheets" 12 | "Thomas Gazagnaire" 13 | "David Scott" 14 | "Rudi Grinberg" 15 | "Andy Ray" 16 | "Anurag Soni" 17 | ] 18 | license: "ISC" 19 | homepage: "https://github.com/mirage/ocaml-cohttp" 20 | doc: "https://mirage.github.io/ocaml-cohttp/" 21 | bug-reports: "https://github.com/mirage/ocaml-cohttp/issues" 22 | depends: [ 23 | "dune" {>= "3.8"} 24 | "ocurl" {>= "0.9.2"} 25 | "http" {= version} 26 | "stringext" 27 | "cohttp-curl" {= version} 28 | "core" {>= "v0.16.0"} 29 | "core_unix" {>= "v0.14.0"} 30 | "core_kernel" {with-test} 31 | "async_kernel" {with-test & >= "v0.17.0"} 32 | "async_unix" {with-test} 33 | "cohttp-async" {with-test & = version} 34 | "uri" {with-test & >= "4.2.0"} 35 | "fmt" {with-test} 36 | "ounit2" {with-test} 37 | "alcotest" {with-test & >= "1.7.0"} 38 | "odoc" {with-doc} 39 | ] 40 | dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git" 41 | build: [ 42 | ["dune" "subst"] {dev} 43 | [ 44 | "dune" 45 | "build" 46 | "-p" 47 | name 48 | "-j" 49 | jobs 50 | "@install" 51 | "@cohttp-curl-async/runtest" {with-test} 52 | "@doc" {with-doc} 53 | ] 54 | ] 55 | x-maintenance-intent: [ "(latest)" ] 56 | -------------------------------------------------------------------------------- /cohttp-curl-async.opam.template: -------------------------------------------------------------------------------- 1 | build: [ 2 | ["dune" "subst"] {dev} 3 | [ 4 | "dune" 5 | "build" 6 | "-p" 7 | name 8 | "-j" 9 | jobs 10 | "@install" 11 | "@cohttp-curl-async/runtest" {with-test} 12 | "@doc" {with-doc} 13 | ] 14 | ] 15 | x-maintenance-intent: [ "(latest)" ] 16 | -------------------------------------------------------------------------------- /cohttp-curl-async/bin/curl.ml: -------------------------------------------------------------------------------- 1 | open Cohttp 2 | module Curl = Cohttp_curl_async 3 | module Sexp = Sexplib0.Sexp 4 | open Async_kernel 5 | module Writer = Async_unix.Writer 6 | module Time = Core.Time_float 7 | 8 | let ( let* ) x f = Deferred.bind x ~f 9 | 10 | let client uri meth' () = 11 | let meth = Cohttp.Code.method_of_string meth' in 12 | let reply = 13 | let context = Curl.Context.create () in 14 | let request = 15 | Curl.Request.create ~timeout:(Time.Span.of_ms 5000.) meth ~uri 16 | ~input:Curl.Source.empty ~output:Curl.Sink.string 17 | in 18 | Curl.submit context request 19 | in 20 | let* resp, response_body = 21 | Deferred.both (Curl.Response.response reply) (Curl.Response.body reply) 22 | >>| function 23 | | Ok r, Ok b -> (r, b) 24 | | _, Error e | Error e, _ -> 25 | Format.eprintf "error: %s@.%!" (Curl.Error.message e); 26 | exit 1 27 | in 28 | Format.eprintf "response:%a@.%!" Sexp.pp_hum (Response.sexp_of_t resp); 29 | let status = Response.status resp in 30 | (match Code.is_success (Code.code_of_status status) with 31 | | false -> prerr_endline (Code.string_of_status status) 32 | | true -> ()); 33 | let output_body c = 34 | Writer.write c response_body; 35 | Writer.flushed c 36 | in 37 | output_body (Lazy.force Writer.stdout) 38 | 39 | let _ = 40 | let open Async_command in 41 | async_spec ~summary:"Fetch URL and print it" 42 | Spec.( 43 | empty 44 | +> anon ("url" %: string) 45 | +> flag "-X" (optional_with_default "GET" string) ~doc:" Set HTTP method") 46 | client 47 | |> Command_unix.run 48 | -------------------------------------------------------------------------------- /cohttp-curl-async/bin/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name curl) 3 | (libraries 4 | sexplib0 5 | cohttp 6 | cohttp_curl_async 7 | core_kernel 8 | async_unix 9 | async_kernel 10 | async.async_command 11 | core_unix.command_unix)) 12 | -------------------------------------------------------------------------------- /cohttp-curl-async/src/cohttp_curl_async.mli: -------------------------------------------------------------------------------- 1 | (** Curl & Async based client *) 2 | 3 | module Sink : sig 4 | (** A sink defines where the response body may be written *) 5 | 6 | type 'a t 7 | 8 | val string : string t 9 | val discard : unit t 10 | end 11 | 12 | module Source : sig 13 | (** A source defines where the request body is read from *) 14 | 15 | type t 16 | 17 | val empty : t 18 | val string : string -> t 19 | end 20 | 21 | module Context : sig 22 | (** A context shares the curl event handling logic for all curl requests 23 | associated to it *) 24 | 25 | type t 26 | 27 | val create : unit -> t 28 | end 29 | 30 | module Error : sig 31 | type t 32 | 33 | val message : t -> string 34 | val is_timeout : t -> bool 35 | end 36 | 37 | module Response : sig 38 | (** Response for the http requests *) 39 | 40 | type 'a t 41 | (** ['a t] represents a response for a request. ['a] determines how the 42 | response body is handled *) 43 | 44 | val response : 45 | _ t -> (Http.Response.t, Error.t) result Async_kernel.Deferred.t 46 | 47 | val body : 'a t -> ('a, Error.t) result Async_kernel.Deferred.t 48 | val cancel : _ t -> unit 49 | 50 | module Expert : sig 51 | val curl : _ t -> Curl.t 52 | end 53 | end 54 | 55 | module Request : sig 56 | (** Http requests *) 57 | 58 | type 'a t 59 | (** ['a t] represents an http request ['a] determines how the response body is 60 | handled. *) 61 | 62 | val create : 63 | ?timeout:Core.Time_float.Span.t (** timeout for the request *) -> 64 | ?headers:Http.Header.t (** http headers *) -> 65 | Http.Method.t (** http method *) -> 66 | uri:string (** uri *) -> 67 | input:Source.t (** request body *) -> 68 | output:'a Sink.t (** response body *) -> 69 | 'a t 70 | 71 | module Expert : sig 72 | val curl : _ t -> Curl.t 73 | end 74 | end 75 | 76 | val submit : Context.t -> 'a Request.t -> 'a Response.t 77 | (** [submit ctx request] submits a request and returns the response. Once a 78 | request is submitted, it may not be submitted again. *) 79 | -------------------------------------------------------------------------------- /cohttp-curl-async/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name cohttp_curl_async) 3 | (libraries http cohttp-curl core curl stringext async_kernel async_unix)) 4 | -------------------------------------------------------------------------------- /cohttp-curl-async/test/cohttp_curl_async_tests.ml: -------------------------------------------------------------------------------- 1 | module Server = Cohttp_async.Server 2 | module Body = Cohttp_async.Body 3 | module Deferred = Async_kernel.Deferred 4 | open Async_kernel 5 | 6 | let ( let+ ) x f = Deferred.map x ~f 7 | let ( let* ) x f = Deferred.bind x ~f 8 | 9 | let server = 10 | List.map Cohttp_async_test.const 11 | [ 12 | (let body : Body.t = Body.of_string "hello curl" in 13 | Server.respond `OK ~body); 14 | ] 15 | |> Cohttp_async_test.response_sequence 16 | 17 | let test = 18 | Cohttp_async_test.test_server_s ~port:25_290 server (fun uri -> 19 | [ 20 | ( "simple request", 21 | fun () -> 22 | let uri = Uri.to_string uri in 23 | let input = Cohttp_curl_async.Source.empty in 24 | let output = Cohttp_curl_async.Sink.string in 25 | let ctx = Cohttp_curl_async.Context.create () in 26 | let req = 27 | Cohttp_curl_async.Request.create `GET ~uri ~input ~output 28 | in 29 | let resp = Cohttp_curl_async.submit ctx req in 30 | let+ body = 31 | Cohttp_curl_async.Response.body resp >>| function 32 | | Ok s -> s 33 | | Error _ -> assert false 34 | in 35 | Alcotest.check Alcotest.string "test 1" body "hello curl" ); 36 | ]) 37 | 38 | let _ = 39 | let run = 40 | let* _ = Cohttp_async_test.run_async_tests test in 41 | Async_unix.Shutdown.exit 0 42 | in 43 | Deferred.don't_wait_for run; 44 | Core.never_returns (Async_unix.Scheduler.go ()) 45 | -------------------------------------------------------------------------------- /cohttp-curl-async/test/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name cohttp_curl_async_tests) 3 | (libraries 4 | http 5 | core_kernel 6 | async_unix 7 | uri 8 | async_kernel 9 | alcotest 10 | cohttp_async_test 11 | cohttp_curl_async) 12 | (package cohttp-curl-async)) 13 | -------------------------------------------------------------------------------- /cohttp-curl-lwt.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Cohttp client using Curl & Lwt as the backend" 4 | description: """ 5 | An HTTP client that relies on Curl + Lwt for the backend. Does not require 6 | conduit for SSL.""" 7 | maintainer: ["Anil Madhavapeddy "] 8 | authors: [ 9 | "Anil Madhavapeddy" 10 | "Stefano Zacchiroli" 11 | "David Sheets" 12 | "Thomas Gazagnaire" 13 | "David Scott" 14 | "Rudi Grinberg" 15 | "Andy Ray" 16 | "Anurag Soni" 17 | ] 18 | license: "ISC" 19 | homepage: "https://github.com/mirage/ocaml-cohttp" 20 | doc: "https://mirage.github.io/ocaml-cohttp/" 21 | bug-reports: "https://github.com/mirage/ocaml-cohttp/issues" 22 | depends: [ 23 | "dune" {>= "3.8"} 24 | "ocaml" {>= "4.08"} 25 | "ocurl" {>= "0.9.2"} 26 | "http" {= version} 27 | "cohttp-curl" {= version} 28 | "stringext" 29 | "lwt" {>= "5.3.0"} 30 | "uri" {with-test & >= "4.2.0"} 31 | "alcotest" {with-test & >= "1.7.0"} 32 | "cohttp-lwt-unix" {with-test & = version} 33 | "cohttp" {with-test & = version} 34 | "cohttp-lwt" {with-test & = version} 35 | "conduit-lwt" {with-test} 36 | "ounit2" {with-test} 37 | "odoc" {with-doc} 38 | ] 39 | dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git" 40 | build: [ 41 | ["dune" "subst"] {dev} 42 | [ 43 | "dune" 44 | "build" 45 | "-p" 46 | name 47 | "-j" 48 | jobs 49 | "@install" 50 | "@cohttp-curl-lwt/runtest" {with-test} 51 | "@doc" {with-doc} 52 | ] 53 | ] 54 | x-maintenance-intent: [ "(latest)" ] 55 | -------------------------------------------------------------------------------- /cohttp-curl-lwt.opam.template: -------------------------------------------------------------------------------- 1 | build: [ 2 | ["dune" "subst"] {dev} 3 | [ 4 | "dune" 5 | "build" 6 | "-p" 7 | name 8 | "-j" 9 | jobs 10 | "@install" 11 | "@cohttp-curl-lwt/runtest" {with-test} 12 | "@doc" {with-doc} 13 | ] 14 | ] 15 | x-maintenance-intent: [ "(latest)" ] 16 | -------------------------------------------------------------------------------- /cohttp-curl-lwt/bin/curl.mli: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mirage/ocaml-cohttp/ca90e54281fdaec9765452ca753388f532f5c4cb/cohttp-curl-lwt/bin/curl.mli -------------------------------------------------------------------------------- /cohttp-curl-lwt/bin/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name curl) 3 | (libraries 4 | sexplib0 5 | cohttp 6 | cohttp_curl_lwt 7 | lwt.unix 8 | lwt 9 | logs 10 | logs.cli 11 | uri 12 | fmt.tty 13 | cmdliner)) 14 | -------------------------------------------------------------------------------- /cohttp-curl-lwt/src/cohttp_curl_lwt.mli: -------------------------------------------------------------------------------- 1 | (** Curl based client *) 2 | 3 | module Sink : sig 4 | (** A sink defines where the response body may be written *) 5 | 6 | type 'a t 7 | 8 | val string : string t 9 | val discard : unit t 10 | end 11 | 12 | module Source : sig 13 | (** A source defines where the request body is read from *) 14 | 15 | type t 16 | 17 | val empty : t 18 | val string : string -> t 19 | end 20 | 21 | module Context : sig 22 | (** A context shares the curl event handling logic for all curl requests 23 | associated to it *) 24 | 25 | type t 26 | 27 | val create : unit -> t 28 | end 29 | 30 | module Error : sig 31 | type t 32 | 33 | val message : t -> string 34 | val is_timeout : t -> bool 35 | end 36 | 37 | module Response : sig 38 | (** Response for the http requests *) 39 | 40 | type 'a t 41 | (** ['a t] represents a response for a request. ['a] determines how the 42 | response body is handled *) 43 | 44 | val response : _ t -> (Http.Response.t, Error.t) result Lwt.t 45 | val body : 'a t -> ('a, Error.t) result Lwt.t 46 | 47 | module Expert : sig 48 | val curl : _ t -> Curl.t 49 | end 50 | end 51 | 52 | module Request : sig 53 | (** Http requests *) 54 | 55 | type 'a t 56 | (** ['a t] represents an http request ['a] determines how the response body is 57 | handled. *) 58 | 59 | val create : 60 | ?timeout_ms:int (** timeout for the request in milliseconds *) -> 61 | ?headers:Http.Header.t (** http headers *) -> 62 | Http.Method.t (** http method *) -> 63 | uri:string (** uri *) -> 64 | input:Source.t (** request body *) -> 65 | output:'a Sink.t (** response body *) -> 66 | 'a t 67 | 68 | module Expert : sig 69 | val curl : _ t -> Curl.t 70 | end 71 | end 72 | 73 | val submit : Context.t -> 'a Request.t -> 'a Response.t 74 | (** [submit ctx request] submits a request and returns the response. Once a 75 | request is submitted, it may not be submitted again. *) 76 | -------------------------------------------------------------------------------- /cohttp-curl-lwt/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name cohttp_curl_lwt) 3 | (public_name cohttp-curl-lwt) 4 | (libraries http cohttp-curl stringext lwt lwt.unix curl)) 5 | -------------------------------------------------------------------------------- /cohttp-curl-lwt/test/cohttp_curl_lwt_tests.ml: -------------------------------------------------------------------------------- 1 | module Server = Cohttp_lwt_unix.Server 2 | module Body = Cohttp_lwt.Body 3 | open Lwt.Syntax 4 | open Lwt.Infix 5 | 6 | let server = 7 | List.map Cohttp_lwt_unix_test.const 8 | [ 9 | (let body : Body.t = Body.of_string "hello curl" in 10 | Server.respond ~status:`OK ~body ()); 11 | ] 12 | |> Cohttp_lwt_unix_test.response_sequence 13 | 14 | let check_error = function Ok _ -> failwith "expected error" | Error _ -> () 15 | 16 | let without_error = function 17 | | Ok s -> s 18 | | Error e -> failwith (Cohttp_curl_lwt.Error.message e) 19 | 20 | let test = 21 | Cohttp_lwt_unix_test.test_server_s ~port:25_190 server (fun uri -> 22 | [ 23 | ( "simple request", 24 | fun () -> 25 | let uri = Uri.to_string uri in 26 | let input = Cohttp_curl_lwt.Source.empty in 27 | let output = Cohttp_curl_lwt.Sink.string in 28 | let ctx = Cohttp_curl_lwt.Context.create () in 29 | let req = Cohttp_curl_lwt.Request.create `GET ~uri ~input ~output in 30 | let resp = Cohttp_curl_lwt.submit ctx req in 31 | let+ body = Cohttp_curl_lwt.Response.body resp >|= without_error in 32 | Alcotest.check Alcotest.string "test 1" body "hello curl" ); 33 | ( "failing request", 34 | fun () -> 35 | let uri = "0.0.0.0:45_120" in 36 | let input = Cohttp_curl_lwt.Source.empty in 37 | let output = Cohttp_curl_lwt.Sink.string in 38 | let ctx = Cohttp_curl_lwt.Context.create () in 39 | let req = Cohttp_curl_lwt.Request.create `GET ~uri ~input ~output in 40 | let resp = Cohttp_curl_lwt.submit ctx req in 41 | let* http_resp = Cohttp_curl_lwt.Response.response resp in 42 | check_error http_resp; 43 | let+ body = Cohttp_curl_lwt.Response.body resp in 44 | check_error body ); 45 | ]) 46 | 47 | let _ = test |> Cohttp_lwt_unix_test.run_async_tests |> Lwt_main.run 48 | -------------------------------------------------------------------------------- /cohttp-curl-lwt/test/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name cohttp_curl_lwt_tests) 3 | (libraries http alcotest uri cohttp_lwt_unix_test cohttp_curl_lwt) 4 | (package cohttp-curl-lwt)) 5 | -------------------------------------------------------------------------------- /cohttp-curl.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Shared code between the individual cohttp-curl clients" 4 | description: "Use cohttp-curl-lwt or cohttp-curl-async" 5 | maintainer: ["Anil Madhavapeddy "] 6 | authors: [ 7 | "Anil Madhavapeddy" 8 | "Stefano Zacchiroli" 9 | "David Sheets" 10 | "Thomas Gazagnaire" 11 | "David Scott" 12 | "Rudi Grinberg" 13 | "Andy Ray" 14 | "Anurag Soni" 15 | ] 16 | license: "ISC" 17 | homepage: "https://github.com/mirage/ocaml-cohttp" 18 | doc: "https://mirage.github.io/ocaml-cohttp/" 19 | bug-reports: "https://github.com/mirage/ocaml-cohttp/issues" 20 | depends: [ 21 | "dune" {>= "3.8"} 22 | "ocaml" {>= "4.08"} 23 | "ocurl" {>= "0.9.2"} 24 | "http" {= version} 25 | "stringext" 26 | "odoc" {with-doc} 27 | ] 28 | dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git" 29 | build: [ 30 | ["dune" "subst"] {dev} 31 | [ 32 | "dune" 33 | "build" 34 | "-p" 35 | name 36 | "-j" 37 | jobs 38 | "@install" 39 | "@cohttp-curl/runtest" {with-test} 40 | "@doc" {with-doc} 41 | ] 42 | ] 43 | x-maintenance-intent: [ "(latest)" ] 44 | -------------------------------------------------------------------------------- /cohttp-curl.opam.template: -------------------------------------------------------------------------------- 1 | build: [ 2 | ["dune" "subst"] {dev} 3 | [ 4 | "dune" 5 | "build" 6 | "-p" 7 | name 8 | "-j" 9 | jobs 10 | "@install" 11 | "@cohttp-curl/runtest" {with-test} 12 | "@doc" {with-doc} 13 | ] 14 | ] 15 | x-maintenance-intent: [ "(latest)" ] 16 | -------------------------------------------------------------------------------- /cohttp-curl/src/cohttp_curl.mli: -------------------------------------------------------------------------------- 1 | module Private : sig 2 | module Error : sig 3 | type t 4 | 5 | val create : Curl.curlCode -> t 6 | val message : t -> string 7 | val is_timeout : t -> bool 8 | end 9 | 10 | module Sink : sig 11 | type 'a t 12 | 13 | val string : string t 14 | val discard : unit t 15 | end 16 | 17 | module Source : sig 18 | type t 19 | 20 | val empty : t 21 | val string : string -> t 22 | end 23 | 24 | module Request : sig 25 | type 'a t 26 | 27 | val curl : _ t -> Curl.t 28 | 29 | val body : 'a t -> 'a 30 | (** [body t] this must be called after curl completes the requests. it can 31 | only be called once *) 32 | 33 | val create : 34 | ?timeout_ms:int -> 35 | ?headers:Http.Header.t -> 36 | Http.Method.t -> 37 | uri:string -> 38 | input:Source.t -> 39 | output:'a Sink.t -> 40 | on_response:(Http.Response.t -> unit) -> 41 | 'a t 42 | end 43 | end 44 | -------------------------------------------------------------------------------- /cohttp-curl/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name cohttp_curl) 3 | (public_name cohttp-curl) 4 | (libraries http curl stringext)) 5 | -------------------------------------------------------------------------------- /cohttp-eio.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "CoHTTP implementation with eio backend" 4 | description: 5 | "A CoHTTP server and client implementation based on `eio` library. `cohttp-eio`features a multicore capable HTTP 1.1 server. The library promotes and is built with direct style of coding as opposed to a monadic." 6 | maintainer: ["Anil Madhavapeddy "] 7 | authors: [ 8 | "Anil Madhavapeddy" 9 | "Stefano Zacchiroli" 10 | "David Sheets" 11 | "Thomas Gazagnaire" 12 | "David Scott" 13 | "Rudi Grinberg" 14 | "Andy Ray" 15 | "Anurag Soni" 16 | ] 17 | license: "ISC" 18 | homepage: "https://github.com/mirage/ocaml-cohttp" 19 | doc: "https://mirage.github.io/ocaml-cohttp/" 20 | bug-reports: "https://github.com/mirage/ocaml-cohttp/issues" 21 | depends: [ 22 | "dune" {>= "3.8"} 23 | "alcotest" {with-test & >= "1.7.0"} 24 | "base-domains" 25 | "cohttp" {= version} 26 | "eio" {>= "0.12"} 27 | "eio_main" {with-test} 28 | "mdx" {with-test} 29 | "logs" 30 | "uri" 31 | "tls-eio" {with-test & >= "1.0.0"} 32 | "mirage-crypto-rng" {with-test & >= "1.2.0"} 33 | "ca-certs" {with-test & >= "1.0.0"} 34 | "fmt" 35 | "ptime" 36 | "http" {= version} 37 | "ppx_here" {with-test} 38 | "odoc" {with-doc} 39 | ] 40 | dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git" 41 | build: [ 42 | ["dune" "subst"] {dev} 43 | [ 44 | "dune" 45 | "build" 46 | "-p" 47 | name 48 | "-j" 49 | jobs 50 | "@install" 51 | "@cohttp-eio/runtest" {with-test} 52 | "@doc" {with-doc} 53 | ] 54 | ] 55 | x-maintenance-intent: [ "(latest)" ] 56 | -------------------------------------------------------------------------------- /cohttp-eio.opam.template: -------------------------------------------------------------------------------- 1 | build: [ 2 | ["dune" "subst"] {dev} 3 | [ 4 | "dune" 5 | "build" 6 | "-p" 7 | name 8 | "-j" 9 | jobs 10 | "@install" 11 | "@cohttp-eio/runtest" {with-test} 12 | "@doc" {with-doc} 13 | ] 14 | ] 15 | x-maintenance-intent: [ "(latest)" ] 16 | -------------------------------------------------------------------------------- /cohttp-eio/examples/client1.ml: -------------------------------------------------------------------------------- 1 | open Cohttp_eio 2 | 3 | let () = Logs.set_reporter (Logs_fmt.reporter ()) 4 | 5 | and () = 6 | (* The eio backend does not leverage domains yet, but might in the near future *) 7 | Logs_threaded.enable () 8 | 9 | and () = Logs.Src.set_level Cohttp_eio.src (Some Debug) 10 | 11 | let () = 12 | Eio_main.run @@ fun env -> 13 | let client = Client.make ~https:None env#net in 14 | Eio.Switch.run @@ fun sw -> 15 | let resp, body = Client.get ~sw client (Uri.of_string "http://example.com") in 16 | if Http.Status.compare resp.status `OK = 0 then 17 | print_string @@ Eio.Buf_read.(parse_exn take_all) body ~max_size:max_int 18 | else Fmt.epr "Unexpected HTTP status: %a" Http.Status.pp resp.status 19 | -------------------------------------------------------------------------------- /cohttp-eio/examples/client_timeout.ml: -------------------------------------------------------------------------------- 1 | open Cohttp_eio 2 | 3 | let () = 4 | Eio_main.run @@ fun env -> 5 | let client = Client.make ~https:None env#net in 6 | (* Increment/decrement this value to see success/failure. *) 7 | let timeout_s = 0.01 in 8 | Eio.Time.with_timeout env#clock timeout_s (fun () -> 9 | Eio.Switch.run @@ fun sw -> 10 | let _, body = 11 | Client.get client ~sw (Uri.of_string "http://www.example.org") 12 | in 13 | Eio.Buf_read.(of_flow ~max_size:max_int body |> take_all) |> Result.ok) 14 | |> function 15 | | Ok s -> print_string s 16 | | Error (`Fatal e) -> Fmt.epr "fatal error: %s@." e 17 | | Error `Timeout -> Fmt.epr "Connection timed out@." 18 | -------------------------------------------------------------------------------- /cohttp-eio/examples/client_tls.ml: -------------------------------------------------------------------------------- 1 | open Cohttp_eio 2 | 3 | let authenticator = 4 | match Ca_certs.authenticator () with 5 | | Ok x -> x 6 | | Error (`Msg m) -> 7 | Fmt.failwith "Failed to create system store X509 authenticator: %s" m 8 | 9 | let () = 10 | Logs.set_reporter (Logs_fmt.reporter ()); 11 | Logs_threaded.enable (); 12 | Logs.Src.set_level Cohttp_eio.src (Some Debug) 13 | 14 | let https ~authenticator = 15 | let tls_config = 16 | match Tls.Config.client ~authenticator () with 17 | | Error (`Msg msg) -> failwith ("tls configuration problem: " ^ msg) 18 | | Ok tls_config -> tls_config 19 | in 20 | fun uri raw -> 21 | let host = 22 | Uri.host uri 23 | |> Option.map (fun x -> Domain_name.(host_exn (of_string_exn x))) 24 | in 25 | Tls_eio.client_of_flow ?host tls_config raw 26 | 27 | let () = 28 | Eio_main.run @@ fun env -> 29 | Mirage_crypto_rng_unix.use_default (); 30 | let client = Client.make ~https:(Some (https ~authenticator)) env#net in 31 | Eio.Switch.run @@ fun sw -> 32 | let resp, body = 33 | Client.get ~sw client (Uri.of_string "https://example.com") 34 | in 35 | if Http.Status.compare resp.status `OK = 0 then 36 | print_string @@ Eio.Buf_read.(parse_exn take_all) body ~max_size:max_int 37 | else Fmt.epr "Unexpected HTTP status: %a" Http.Status.pp resp.status 38 | -------------------------------------------------------------------------------- /cohttp-eio/examples/docker_client.ml: -------------------------------------------------------------------------------- 1 | module Switch = Eio.Switch 2 | module Net = Eio.Net 3 | module Stdenv = Eio.Stdenv 4 | module Client = Cohttp_eio.Client 5 | module Response = Http.Response 6 | module Status = Http.Status 7 | 8 | let () = Logs.set_reporter (Logs_fmt.reporter ()) 9 | and () = Logs.Src.set_level Cohttp_eio.src (Some Debug) 10 | 11 | let () = 12 | Eio_main.run @@ fun env -> 13 | let client = Client.make ~https:None env#net in 14 | Eio.Switch.run @@ fun sw -> 15 | let response, body = 16 | Client.get client ~sw 17 | @@ Uri.make ~scheme:"httpunix" ~host:"/var/run/docker.sock" ~path:"/version" 18 | () 19 | in 20 | let code = response |> Response.status |> Status.to_int in 21 | Printf.printf "Response code: %d\n" code; 22 | Printf.printf "Headers: %s\n" 23 | (response |> Response.headers |> Http.Header.to_string); 24 | let body = Eio.Buf_read.(of_flow ~max_size:max_int body |> take_all) in 25 | Printf.printf "Body of length: %d\n" (String.length body); 26 | print_endline ("Received body\n" ^ body) 27 | -------------------------------------------------------------------------------- /cohttp-eio/examples/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names server1 server2 client1 docker_client client_timeout client_tls) 3 | (libraries 4 | cohttp-eio 5 | eio_main 6 | eio.unix 7 | fmt 8 | unix 9 | logs.fmt 10 | logs.threaded 11 | tls-eio 12 | ca-certs 13 | mirage-crypto-rng.unix)) 14 | 15 | (alias 16 | (name runtest) 17 | (package cohttp-eio) 18 | (deps server1.exe)) 19 | -------------------------------------------------------------------------------- /cohttp-eio/examples/server2.ml: -------------------------------------------------------------------------------- 1 | let () = Logs.set_reporter (Logs_fmt.reporter ()) 2 | and () = Logs.Src.set_level Cohttp_eio.src (Some Debug) 3 | 4 | let ( / ) = Eio.Path.( / ) 5 | 6 | (* To stream a file, we take the extra [writer] argument explicitly. 7 | This means that we stream the response while the function is still 8 | running and the file is still open. *) 9 | let handler dir _socket request _body writer = 10 | let path = 11 | Http.Request.resource request 12 | |> String.split_on_char '/' 13 | |> List.filter (( <> ) "") 14 | |> String.concat "/" 15 | in 16 | let path = if path = "" then "index.html" else path in 17 | Eio.Path.with_open_in (dir / path) @@ fun flow -> 18 | Cohttp_eio.Server.respond () ~status:`OK 19 | ~headers:(Http.Header.of_list [ ("content-type", "text/html") ]) 20 | ~body:flow writer 21 | 22 | let log_warning ex = Logs.warn (fun f -> f "%a" Eio.Exn.pp ex) 23 | 24 | let () = 25 | let port = ref 8080 in 26 | Arg.parse 27 | [ ("-p", Arg.Set_int port, " Listening port number(8080 by default)") ] 28 | ignore "An HTTP/1.1 server"; 29 | Eio_main.run @@ fun env -> 30 | Eio.Switch.run @@ fun sw -> 31 | (* Restrict to current directory: *) 32 | let htdocs = Eio.Stdenv.cwd env in 33 | let socket = 34 | Eio.Net.listen env#net ~sw ~backlog:128 ~reuse_addr:true 35 | (`Tcp (Eio.Net.Ipaddr.V4.loopback, !port)) 36 | and server = Cohttp_eio.Server.make ~callback:(handler htdocs) () in 37 | Cohttp_eio.Server.run socket server ~on_error:log_warning 38 | -------------------------------------------------------------------------------- /cohttp-eio/src/body.ml: -------------------------------------------------------------------------------- 1 | type t = Eio.Flow.source_ty Eio.Resource.t 2 | type 't Eio.Flow.read_method += String of ('t -> string) 3 | 4 | module String_source = struct 5 | type t = { s : string; mutable offset : int } 6 | 7 | let single_read t dst = 8 | if t.offset = String.length t.s then raise End_of_file; 9 | let len = min (Cstruct.length dst) (String.length t.s - t.offset) in 10 | Cstruct.blit_from_string t.s t.offset dst 0 len; 11 | t.offset <- t.offset + len; 12 | len 13 | 14 | let original_string t = t.s 15 | let read_methods = [ String original_string ] 16 | let create s = { s; offset = 0 } 17 | end 18 | 19 | let of_string = 20 | let ops = Eio.Flow.Pi.source (module String_source) in 21 | fun s -> Eio.Resource.T (String_source.create s, ops) 22 | -------------------------------------------------------------------------------- /cohttp-eio/src/client.mli: -------------------------------------------------------------------------------- 1 | open Eio.Std 2 | 3 | type t 4 | 5 | include 6 | Cohttp.Generic.Client.S 7 | with type 'a with_context = t -> sw:Switch.t -> 'a 8 | and type 'a io = 'a 9 | and type body = Body.t 10 | 11 | val make : 12 | https: 13 | (Uri.t -> [ `Generic ] Eio.Net.stream_socket_ty r -> _ Eio.Flow.two_way) 14 | option -> 15 | _ Eio.Net.t -> 16 | t 17 | (** [make ~https net] is a convenience wrapper around {!make_generic} that uses 18 | [net] to make connections. 19 | 20 | - URIs of the form "http://host:port/..." connect to the given TCP host and 21 | port. 22 | - URIs of the form "https://host:port/..." connect to the given TCP host and 23 | port, and are then wrapped by [https] (or rejected if that is [None]). 24 | - URIs of the form "httpunix://unix-path/http-path" connect to the given 25 | Unix path. *) 26 | 27 | val make_generic : (sw:Switch.t -> Uri.t -> _ Eio.Flow.two_way) -> t 28 | (** [make_generic connect] is an HTTP client that uses [connect] to get the 29 | connection to use for a given URI. *) 30 | -------------------------------------------------------------------------------- /cohttp-eio/src/cohttp_eio.ml: -------------------------------------------------------------------------------- 1 | module Body = Body 2 | module Client = Client 3 | module Server = Server 4 | 5 | module Private = struct 6 | module IO = Io.IO 7 | end 8 | 9 | let src = Utils.src 10 | -------------------------------------------------------------------------------- /cohttp-eio/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name cohttp_eio) 3 | (public_name cohttp-eio) 4 | (libraries cohttp eio fmt http logs ptime uri uri.services)) 5 | -------------------------------------------------------------------------------- /cohttp-eio/src/io.ml: -------------------------------------------------------------------------------- 1 | let src = Logs.Src.create "cohttp.eio.io" ~doc:"Cohttp Eio IO module" 2 | 3 | module Logs = (val Logs.src_log src : Logs.LOG) 4 | 5 | module IO = struct 6 | type 'a t = 'a 7 | 8 | let ( >>= ) v f = f v 9 | let return v = v 10 | 11 | type ic = Eio.Buf_read.t 12 | type oc = Eio.Buf_write.t 13 | type conn = Eio.Switch.t * Eio.Net.Sockaddr.stream 14 | 15 | let refill ic = 16 | try 17 | let () = Eio.Buf_read.(ensure ic (buffered_bytes ic + 1)) in 18 | `Ok 19 | with End_of_file -> `Eof 20 | 21 | let with_input_buffer ic ~f = 22 | let contents = Eio.Buf_read.peek ic in 23 | let res, consumed = 24 | f (Cstruct.to_string contents) ~pos:0 ~len:(Cstruct.length contents) 25 | in 26 | let () = Eio.Buf_read.consume ic consumed in 27 | res 28 | 29 | let read_line ic = 30 | try 31 | let line = Eio.Buf_read.line ic in 32 | let () = Logs.debug (fun f -> f "<<< %s" line) in 33 | Some line 34 | with End_of_file -> 35 | let () = Logs.debug (fun f -> f "<<< EOF") in 36 | None 37 | 38 | let read ic len = 39 | match Eio.Buf_read.ensure ic 1 with 40 | | exception End_of_file -> 41 | let () = Logs.debug (fun f -> f "<<< EOF") in 42 | "" 43 | | () -> 44 | let len = Int.min len (Eio.Buf_read.buffered_bytes ic) in 45 | let read = Eio.Buf_read.take len ic in 46 | let () = Logs.debug (fun f -> f "<<< %s" read) in 47 | read 48 | 49 | let write oc string = 50 | let () = Logs.debug (fun f -> f ">>> %s" (String.trim string)) in 51 | Eio.Buf_write.string oc string 52 | 53 | let flush = Eio.Buf_write.flush 54 | end 55 | 56 | module Request = Cohttp.Request.Private.Make (IO) 57 | module Response = Cohttp.Response.Private.Make (IO) 58 | module Transfer = Cohttp.Private.Transfer_io.Make (IO) 59 | -------------------------------------------------------------------------------- /cohttp-eio/src/io.mli: -------------------------------------------------------------------------------- 1 | module IO : 2 | Cohttp.S.IO 3 | with type 'a t = 'a 4 | and type conn = Eio.Switch.t * Eio.Net.Sockaddr.stream 5 | and type ic = Eio.Buf_read.t 6 | and type oc = Eio.Buf_write.t 7 | 8 | module Request : 9 | Cohttp.S.Http_io with type t := Http.Request.t and module IO := IO 10 | 11 | module Response : 12 | Cohttp.S.Http_io with type t := Http.Response.t and module IO := IO 13 | 14 | (* module Transfer : module type of Cohttp.Private.Transfer_io.Make (IO) *) 15 | -------------------------------------------------------------------------------- /cohttp-eio/src/server.mli: -------------------------------------------------------------------------------- 1 | type writer 2 | 3 | include 4 | Cohttp.Generic.Server.S 5 | with module IO = Io.IO 6 | and type body = Body.t 7 | and type response = writer -> unit 8 | 9 | val respond : 10 | ?headers:Http.Header.t -> 11 | status:Http.Status.t -> 12 | body:_ Eio.Flow.source -> 13 | unit -> 14 | response IO.t 15 | 16 | val run : 17 | ?max_connections:int -> 18 | ?additional_domains:_ Eio__Domain_manager.t * int -> 19 | ?stop:'a Eio.Promise.t -> 20 | on_error:(exn -> unit) -> 21 | _ Eio.Net.listening_socket -> 22 | t -> 23 | 'a 24 | -------------------------------------------------------------------------------- /cohttp-eio/src/utils.ml: -------------------------------------------------------------------------------- 1 | let src = Logs.Src.create "cohttp.eio" ~doc:"Cohttp Eio backend" 2 | 3 | module Logs = (val Logs.src_log src) 4 | 5 | module Reader_flow = struct 6 | type t = { 7 | read_body_chunk : unit -> Cohttp.Transfer.chunk; 8 | mutable buffered : (string * int) option; 9 | } 10 | 11 | let v read_body_chunk = { read_body_chunk; buffered = None } 12 | 13 | let single_read t output = 14 | let output_length = Cstruct.length output in 15 | let send buffer pos = 16 | let available = String.length buffer - pos in 17 | if output_length >= available then 18 | let () = Cstruct.blit_from_string buffer pos output 0 available 19 | and () = t.buffered <- None in 20 | available 21 | else 22 | let () = Cstruct.blit_from_string buffer 0 output 0 output_length 23 | and () = t.buffered <- Some (buffer, pos + output_length) in 24 | output_length 25 | in 26 | match t.buffered with 27 | | Some (buffer, pos) -> send buffer pos 28 | | None -> ( 29 | match t.read_body_chunk () with 30 | | Cohttp.Transfer.Done -> 31 | let () = Logs.debug (fun m -> m "end of inbound body") in 32 | raise End_of_file 33 | | Chunk data | Final_chunk data -> 34 | let () = 35 | Logs.debug (fun m -> 36 | m "received %d bytes of body" (String.length data)) 37 | in 38 | send data 0) 39 | 40 | let read_methods = [] 41 | end 42 | 43 | let flow_of_reader = 44 | let handler = Eio.Flow.Pi.source (module Reader_flow) in 45 | fun read_body_chunk -> Eio.Resource.T (Reader_flow.v read_body_chunk, handler) 46 | 47 | let flow_to_writer flow writer write_body = 48 | let input = Eio.Buf_read.of_flow ~max_size:max_int flow in 49 | let rec loop () = 50 | let () = 51 | let () = Eio.Buf_read.ensure input 1 in 52 | let contents = Eio.Buf_read.(take (buffered_bytes input) input) in 53 | let () = 54 | Logs.debug (fun m -> m "send %d bytes of body" (String.length contents)) 55 | in 56 | write_body writer contents 57 | in 58 | loop () 59 | in 60 | try loop () 61 | with End_of_file -> 62 | let () = Logs.debug (fun m -> m "end of outbound body") in 63 | () 64 | -------------------------------------------------------------------------------- /cohttp-eio/tests/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test) 3 | (libraries alcotest cohttp-eio eio eio.mock eio_main logs.fmt) 4 | (package cohttp-eio) 5 | (preprocess 6 | (pps ppx_here))) 7 | -------------------------------------------------------------------------------- /cohttp-lwt-jsoo.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "CoHTTP implementation for the Js_of_ocaml JavaScript compiler" 4 | description: """ 5 | An implementation of an HTTP client for JavaScript, but using the 6 | CoHTTP types. This lets you build HTTP clients that can compile 7 | natively (using one of the other Cohttp backends such as `cohttp-lwt-unix`) 8 | and also to native JavaScript via js_of_ocaml. 9 | """ 10 | maintainer: ["Anil Madhavapeddy "] 11 | authors: [ 12 | "Anil Madhavapeddy" 13 | "Stefano Zacchiroli" 14 | "David Sheets" 15 | "Thomas Gazagnaire" 16 | "David Scott" 17 | "Rudi Grinberg" 18 | "Andy Ray" 19 | "Anurag Soni" 20 | ] 21 | license: "ISC" 22 | homepage: "https://github.com/mirage/ocaml-cohttp" 23 | doc: "https://mirage.github.io/ocaml-cohttp/" 24 | bug-reports: "https://github.com/mirage/ocaml-cohttp/issues" 25 | depends: [ 26 | "dune" {>= "3.8"} 27 | "ocaml" {>= "4.08"} 28 | "http" {= version} 29 | "cohttp" {= version} 30 | "cohttp-lwt" {= version} 31 | "logs" 32 | "lwt" {>= "3.0.0"} 33 | "lwt_ppx" {with-test} 34 | "conf-npm" {with-test} 35 | "js_of_ocaml" {>= "3.3.0"} 36 | "js_of_ocaml-ppx" {>= "3.3.0"} 37 | "js_of_ocaml-lwt" {>= "3.5.0"} 38 | "odoc" {with-doc} 39 | ] 40 | dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git" 41 | build: [ 42 | ["dune" "subst"] {dev} 43 | [ 44 | "dune" 45 | "build" 46 | "-p" 47 | name 48 | "-j" 49 | jobs 50 | "@install" 51 | "@cohttp-lwt-jsoo/runtest" {with-test} 52 | "@doc" {with-doc} 53 | ] 54 | ] 55 | x-maintenance-intent: [ "(latest)" ] 56 | -------------------------------------------------------------------------------- /cohttp-lwt-jsoo.opam.template: -------------------------------------------------------------------------------- 1 | build: [ 2 | ["dune" "subst"] {dev} 3 | [ 4 | "dune" 5 | "build" 6 | "-p" 7 | name 8 | "-j" 9 | jobs 10 | "@install" 11 | "@cohttp-lwt-jsoo/runtest" {with-test} 12 | "@doc" {with-doc} 13 | ] 14 | ] 15 | x-maintenance-intent: [ "(latest)" ] 16 | -------------------------------------------------------------------------------- /cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.mli: -------------------------------------------------------------------------------- 1 | (*{{{ Copyright (c) 2014 Andy Ray 2 | * Copyright (c) 2012-2013 Anil Madhavapeddy 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | }}}*) 17 | 18 | (** {1 HTTP client for JavaScript using XMLHttpRequest.} 19 | 20 | The {!Logs} source name for this module's logger is ["cohttp.lwt.jsoo"]. To 21 | log the current warnings using the browser's console log, you can write a 22 | custom reporter or use: 23 | 24 | {[ 25 | let reporter = Logs_browser.console_reporter () in 26 | Logs.set_reporter reporter 27 | ]} *) 28 | 29 | (** Configuration parameters for the XmlHttpRequest engines *) 30 | module type Params = sig 31 | val chunked_response : bool 32 | (** Should the response body data be chunked? *) 33 | 34 | val chunk_size : int 35 | (** Size of chunks *) 36 | 37 | val convert_body_string : Js_of_ocaml.Js.js_string Js_of_ocaml.Js.t -> string 38 | (** JavaScript string to OCaml conversion. [Js.to_bytestring] or 39 | [Js.to_string] *) 40 | 41 | val with_credentials : bool 42 | (** Whether withCredentials property of XHR is set. *) 43 | end 44 | 45 | (** Build an asynchronous engine with chunked/unchucked response data treated as 46 | raw bytes or UTF *) 47 | module Make_client_async (_ : Params) : Cohttp_lwt.S.Client 48 | 49 | (** Build a synchronous engine with chunked/unchucked response data treated as 50 | raw bytes or UTF *) 51 | module Make_client_sync (_ : Params) : Cohttp_lwt.S.Client 52 | 53 | module Client : Cohttp_lwt.S.Client 54 | (** The [Client] module implements an HTTP client interface using asynchronous 55 | XmlHttpRequests. The response body is returned in chucked form with 128Kb / 56 | chunk. Body data is treated as raw bytes. withCredentials property of XHR is 57 | set to false. *) 58 | 59 | module Client_sync : Cohttp_lwt.S.Client 60 | (** The [Client_sync] module implements an HTTP client interface using 61 | synchronous XmlHttpRequests. The response is not chunked and treated as raw 62 | bytes. withCredentials property of XHR is set to false. *) 63 | -------------------------------------------------------------------------------- /cohttp-lwt-jsoo/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name cohttp_lwt_jsoo) 3 | (public_name cohttp-lwt-jsoo) 4 | (synopsis "XHR/Lwt based http client") 5 | (preprocess 6 | (pps js_of_ocaml-ppx)) 7 | (libraries js_of_ocaml cohttp-lwt logs)) 8 | -------------------------------------------------------------------------------- /cohttp-lwt-jsoo/test/package.json: -------------------------------------------------------------------------------- 1 | { 2 | "license": "ISC", 3 | "dependencies": { 4 | "xmlhttprequest": "1.8.0" 5 | } 6 | } 7 | -------------------------------------------------------------------------------- /cohttp-lwt-jsoo/test/src/cohttp_lwt_jsoo_test.ml: -------------------------------------------------------------------------------- 1 | module Client = Cohttp_lwt_jsoo.Client 2 | module Js = Js_of_ocaml.Js 3 | 4 | let _Promise = Js.Unsafe.global##._Promise 5 | let ( let* ) = Lwt.( >>= ) 6 | let ( let+ ) = Lwt.( >|= ) 7 | 8 | let promise_of_lwt lwt = 9 | new%js _Promise 10 | (Js.wrap_callback (fun resolve reject -> 11 | try%lwt 12 | let+ res = lwt () in 13 | Js.Unsafe.fun_call resolve [| Js.Unsafe.inject res |] 14 | with e -> 15 | let msg = Printexc.to_string e in 16 | Js.Unsafe.fun_call reject 17 | [| Js.Unsafe.inject (new%js Js.error_constr (Js.string msg)) |])) 18 | 19 | let () = 20 | Js.export_all 21 | (object%js 22 | method request uri = 23 | let f () = 24 | let uri = Uri.of_string (Js.to_string uri) in 25 | let* response, body = Client.get uri in 26 | let+ body = Cohttp_lwt.Body.to_string body in 27 | let status = 28 | Http.Response.status response |> Cohttp.Code.code_of_status 29 | in 30 | Js.array 31 | [| Js.Unsafe.inject status; Js.Unsafe.inject @@ Js.string body |] 32 | in 33 | promise_of_lwt f 34 | end) 35 | -------------------------------------------------------------------------------- /cohttp-lwt-jsoo/test/src/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name cohttp_lwt_jsoo_test) 3 | (modes js) 4 | (libraries http cohttp cohttp-lwt cohttp-lwt-jsoo lwt js_of_ocaml-lwt) 5 | (preprocess 6 | (pps lwt_ppx js_of_ocaml-ppx))) 7 | 8 | (rule 9 | (alias runjstest) 10 | (deps test.js cohttp_lwt_jsoo_test.bc.js) 11 | (action 12 | (setenv 13 | NODE_PATH 14 | "%{project_root}/cohttp-lwt-jsoo/test/node_modules" 15 | (run ./test.js)))) 16 | -------------------------------------------------------------------------------- /cohttp-lwt-jsoo/test/src/test.js: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env node 2 | 3 | const assert = require("assert"); 4 | const { XMLHttpRequest } = require("xmlhttprequest"); 5 | 6 | global.XMLHttpRequest = XMLHttpRequest; 7 | 8 | const tests = require("./cohttp_lwt_jsoo_test.bc.js"); 9 | 10 | async function main() { 11 | { 12 | const [status, _body] = await tests.request("https://mirage.io"); 13 | assert(status === 200); 14 | } 15 | { 16 | const [status, _body] = await tests.request( 17 | "https://this.domain.does.not.exist" 18 | ); 19 | assert(status === 0); 20 | } 21 | } 22 | 23 | main(); 24 | -------------------------------------------------------------------------------- /cohttp-lwt-jsoo/test/yarn.lock: -------------------------------------------------------------------------------- 1 | # THIS IS AN AUTOGENERATED FILE. DO NOT EDIT THIS FILE DIRECTLY. 2 | # yarn lockfile v1 3 | 4 | 5 | xmlhttprequest@1.8.0: 6 | version "1.8.0" 7 | resolved "https://registry.yarnpkg.com/xmlhttprequest/-/xmlhttprequest-1.8.0.tgz#67fe075c5c24fef39f9d65f5f7b7fe75171968fc" 8 | integrity sha1-Z/4HXFwk/vOfnWX197f+dRcZaPw= 9 | -------------------------------------------------------------------------------- /cohttp-lwt-unix.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "CoHTTP implementation for Unix and Windows using Lwt" 4 | description: """ 5 | An implementation of an HTTP client and server using the Lwt 6 | concurrency library. See the `Cohttp_lwt_unix` module for information 7 | on how to use this. The package also installs `cohttp-curl-lwt` 8 | and a `cohttp-server-lwt` binaries for quick uses of a HTTP(S) 9 | client and server respectively. 10 | 11 | Although the name implies that this only works under Unix, it 12 | should also be fine under Windows too. 13 | """ 14 | maintainer: ["Anil Madhavapeddy "] 15 | authors: [ 16 | "Anil Madhavapeddy" 17 | "Stefano Zacchiroli" 18 | "David Sheets" 19 | "Thomas Gazagnaire" 20 | "David Scott" 21 | "Rudi Grinberg" 22 | "Andy Ray" 23 | "Anurag Soni" 24 | ] 25 | license: "ISC" 26 | homepage: "https://github.com/mirage/ocaml-cohttp" 27 | doc: "https://mirage.github.io/ocaml-cohttp/" 28 | bug-reports: "https://github.com/mirage/ocaml-cohttp/issues" 29 | depends: [ 30 | "dune" {>= "3.8"} 31 | "ocaml" {>= "4.08"} 32 | "http" {= version} 33 | "cohttp" {= version} 34 | "cohttp-lwt" {= version} 35 | "cmdliner" {>= "1.1.0"} 36 | "lwt" {>= "3.0.0"} 37 | "conduit-lwt" {>= "7.1.0"} 38 | "conduit-lwt-unix" {>= "7.1.0"} 39 | "fmt" {>= "0.8.2"} 40 | "base-unix" 41 | "ppx_sexp_conv" {>= "v0.13.0"} 42 | "magic-mime" 43 | "logs" 44 | "ounit2" {with-test} 45 | "odoc" {with-doc} 46 | ] 47 | dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git" 48 | build: [ 49 | ["dune" "subst"] {dev} 50 | [ 51 | "dune" 52 | "build" 53 | "-p" 54 | name 55 | "-j" 56 | jobs 57 | "@install" 58 | "@cohttp-lwt-unix/runtest" {with-test} 59 | "@doc" {with-doc} 60 | ] 61 | ] 62 | x-maintenance-intent: [ "(latest)" ] 63 | -------------------------------------------------------------------------------- /cohttp-lwt-unix.opam.template: -------------------------------------------------------------------------------- 1 | build: [ 2 | ["dune" "subst"] {dev} 3 | [ 4 | "dune" 5 | "build" 6 | "-p" 7 | name 8 | "-j" 9 | jobs 10 | "@install" 11 | "@cohttp-lwt-unix/runtest" {with-test} 12 | "@doc" {with-doc} 13 | ] 14 | ] 15 | x-maintenance-intent: [ "(latest)" ] 16 | -------------------------------------------------------------------------------- /cohttp-lwt-unix/bin/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names cohttp_curl_lwt cohttp_proxy_lwt cohttp_server_lwt) 3 | (libraries 4 | cohttp-lwt-unix 5 | cohttp_server 6 | logs 7 | logs.lwt 8 | logs.fmt 9 | logs.cli 10 | cmdliner 11 | conduit-lwt 12 | fmt.tty)) 13 | -------------------------------------------------------------------------------- /cohttp-lwt-unix/examples/client_lwt.ml: -------------------------------------------------------------------------------- 1 | open Lwt 2 | open Cohttp 3 | open Cohttp_lwt_unix 4 | 5 | let body = 6 | Client.get (Uri.of_string "https://www.reddit.com/") >>= fun (resp, body) -> 7 | let code = resp |> Response.status |> Code.code_of_status in 8 | Printf.printf "Response code: %d\n" code; 9 | Printf.printf "Headers: %s\n" (resp |> Response.headers |> Header.to_string); 10 | body |> Cohttp_lwt.Body.to_string >|= fun body -> 11 | Printf.printf "Body of length: %d\n" (String.length body); 12 | body 13 | 14 | let () = 15 | let body = Lwt_main.run body in 16 | print_endline ("Received body\n" ^ body) 17 | -------------------------------------------------------------------------------- /cohttp-lwt-unix/examples/client_lwt_timeout.ml: -------------------------------------------------------------------------------- 1 | open Lwt 2 | open Cohttp 3 | open Cohttp_lwt_unix 4 | 5 | let compute ~time ~f = 6 | Lwt.pick 7 | [ 8 | (f () >|= fun v -> `Done v); (Lwt_unix.sleep time >|= fun () -> `Timeout); 9 | ] 10 | 11 | let body = 12 | let get () = Client.get (Uri.of_string "https://www.reddit.com/") in 13 | compute ~time:0.1 ~f:get >>= function 14 | | `Timeout -> failwith "Timeout expired" 15 | | `Done (resp, body) -> 16 | let code = resp |> Response.status |> Code.code_of_status in 17 | Printf.printf "Response code: %d\n" code; 18 | Printf.printf "Headers: %s\n" 19 | (resp |> Response.headers |> Header.to_string); 20 | body |> Cohttp_lwt.Body.to_string >|= fun body -> 21 | Printf.printf "Body of length: %d\n" (String.length body); 22 | body 23 | 24 | let () = 25 | let body = Lwt_main.run body in 26 | print_endline ("Received body\n" ^ body) 27 | -------------------------------------------------------------------------------- /cohttp-lwt-unix/examples/docker_lwt.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | let ctx = 4 | let resolver = 5 | let h = Hashtbl.create 1 in 6 | Hashtbl.add h "docker" (`Unix_domain_socket "/var/run/docker.sock"); 7 | Resolver_lwt_unix.static h 8 | in 9 | Cohttp_lwt_unix.Client.custom_ctx ~resolver () 10 | 11 | let t = 12 | Cohttp_lwt_unix.Client.get ~ctx (Uri.of_string "http://docker/version") 13 | >>= fun (resp, body) -> 14 | let open Cohttp in 15 | let code = resp |> Response.status |> Code.code_of_status in 16 | Printf.printf "Response code: %d\n" code; 17 | Printf.printf "Headers: %s\n" (resp |> Response.headers |> Header.to_string); 18 | body |> Cohttp_lwt.Body.to_string >|= fun body -> 19 | Printf.printf "Body of length: %d\n" (String.length body); 20 | print_endline ("Received body\n" ^ body) 21 | 22 | let _ = Lwt_main.run t 23 | -------------------------------------------------------------------------------- /cohttp-lwt-unix/examples/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names client_lwt client_lwt_timeout docker_lwt server_lwt client_lwt_proxy) 3 | (libraries cohttp-lwt-unix fmt.tty)) 4 | 5 | (alias 6 | (name runtest) 7 | (package cohttp-lwt-unix) 8 | (deps 9 | client_lwt.exe 10 | client_lwt_timeout.exe 11 | docker_lwt.exe 12 | server_lwt.exe 13 | client_lwt_proxy.exe)) 14 | -------------------------------------------------------------------------------- /cohttp-lwt-unix/examples/server_lwt.ml: -------------------------------------------------------------------------------- 1 | open Lwt 2 | open Cohttp 3 | open Cohttp_lwt_unix 4 | 5 | let server = 6 | let callback _conn req body = 7 | let uri = req |> Request.uri |> Uri.to_string in 8 | let meth = req |> Request.meth |> Code.string_of_method in 9 | let headers = req |> Request.headers |> Header.to_string in 10 | ( body |> Cohttp_lwt.Body.to_string >|= fun body -> 11 | Printf.sprintf "Uri: %s\nMethod: %s\nHeaders\nHeaders: %s\nBody: %s" uri 12 | meth headers body ) 13 | >>= fun body -> Server.respond_string ~status:`OK ~body () 14 | in 15 | Server.create ~mode:(`TCP (`Port 8000)) (Server.make ~callback ()) 16 | 17 | let () = ignore (Lwt_main.run server) 18 | -------------------------------------------------------------------------------- /cohttp-lwt-unix/src/cohttp_lwt_unix.ml: -------------------------------------------------------------------------------- 1 | (*{{{ Copyright (c) 2012 Anil Madhavapeddy 2 | * 3 | * Permission to use, copy, modify, and distribute this software for any 4 | * purpose with or without fee is hereby granted, provided that the above 5 | * copyright notice and this permission notice appear in all copies. 6 | * 7 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | * 15 | }}}*) 16 | 17 | module Request = struct 18 | include Cohttp.Request 19 | 20 | include ( 21 | Private.Make (Io) : module type of Private.Make (Io) with type t := t) 22 | end 23 | 24 | module Response = struct 25 | include Cohttp.Response 26 | 27 | include ( 28 | Private.Make (Io) : module type of Private.Make (Io) with type t := t) 29 | end 30 | 31 | module Connection = Cohttp_lwt.Connection.Make (Net) 32 | 33 | module Connection_cache = 34 | Cohttp_lwt.Connection_cache.Make 35 | (Connection) 36 | (struct 37 | (* : Mirage_time.S *) 38 | let sleep_ns ns = Lwt_unix.sleep (Int64.to_float ns /. 1_000_000_000.) 39 | end) 40 | 41 | module Connection_proxy = 42 | Cohttp_lwt.Connection_cache.Make_proxy 43 | (Connection) 44 | (struct 45 | (* : Mirage_time.S *) 46 | let sleep_ns ns = Lwt_unix.sleep (Int64.to_float ns /. 1_000_000_000.) 47 | end) 48 | 49 | module Client : sig 50 | (** The [Client] module implements the full UNIX HTTP client interface, 51 | including the UNIX-specific functions defined in {!C}. *) 52 | 53 | include Cohttp_lwt.S.Client with type ctx = Net.ctx 54 | 55 | val custom_ctx : 56 | ?ctx:Conduit_lwt_unix.ctx -> ?resolver:Resolver_lwt.t -> unit -> Net.ctx 57 | (** [custom_ctx ?ctx ?resolver ()] will return a context that is the same as 58 | the {!default_ctx}, but with either the connection handling or resolution 59 | module overridden with [ctx] or [resolver] respectively. This is useful to 60 | supply a {!Conduit_lwt_unix.ctx} with a custom source network interface, 61 | or a {!Resolver_lwt.t} with a different name resolution strategy (for 62 | instance to override a hostname to point it to a Unix domain socket). *) 63 | end = struct 64 | include Cohttp_lwt.Client.Make (Connection) 65 | 66 | let custom_ctx = Net.init 67 | end 68 | 69 | module Server = Server 70 | module Debug = Debug 71 | module Net = Net 72 | module IO = Io [@@deprecated "This module is not for public consumption"] 73 | 74 | module Private = struct 75 | module Input_channel = Input_channel 76 | module IO = Io 77 | end 78 | -------------------------------------------------------------------------------- /cohttp-lwt-unix/src/debug.ml: -------------------------------------------------------------------------------- 1 | (*{{{ Copyright (c) 2012-2014 Anil Madhavapeddy 2 | * 3 | * Permission to use, copy, modify, and distribute this software for any 4 | * purpose with or without fee is hereby granted, provided that the above 5 | * copyright notice and this permission notice appear in all copies. 6 | * 7 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | * 15 | }}}*) 16 | 17 | let _debug_active = ref false 18 | let debug_active () = !_debug_active 19 | 20 | open Lwt.Infix 21 | 22 | let reporter file_descr ppf = 23 | let ppf, flush = 24 | let buf = Buffer.create 0x100 in 25 | ( Fmt.with_buffer ~like:ppf buf, 26 | fun () -> 27 | let str = Buffer.contents buf in 28 | Buffer.reset buf; 29 | str ) 30 | in 31 | let report src level ~over k msgf = 32 | let k _ = 33 | let write () = 34 | let buf = Bytes.unsafe_of_string (flush ()) in 35 | let rec go off len = 36 | Lwt_unix.write file_descr buf off len >>= fun len' -> 37 | if len' = len then Lwt.return_unit else go (off + len') (len - len') 38 | in 39 | go 0 (Bytes.length buf) 40 | in 41 | let clean () = 42 | over (); 43 | Lwt.return_unit 44 | in 45 | Lwt.async (fun () -> 46 | Lwt.catch 47 | (fun () -> Lwt.finalize write clean) 48 | (fun exn -> 49 | Logs.warn (fun m -> 50 | m "Flushing error: %s." (Printexc.to_string exn)); 51 | Lwt.return_unit)); 52 | k () 53 | in 54 | let with_metadata header _tags k ppf fmt = 55 | Format.kfprintf k ppf 56 | ("%a[%a]: " ^^ fmt ^^ "\n%!") 57 | Logs_fmt.pp_header (level, header) 58 | Fmt.(styled `Magenta string) 59 | (Logs.Src.name src) 60 | in 61 | msgf @@ fun ?header ?tags fmt -> with_metadata header tags k ppf fmt 62 | in 63 | { Logs.report } 64 | 65 | let default_reporter = reporter Lwt_unix.stderr Fmt.stderr 66 | 67 | let set_logger = 68 | lazy 69 | (if 70 | (* If no reporter has been set by the application, set default one 71 | that prints to stderr *) 72 | Logs.reporter () == Logs.nop_reporter 73 | then Logs.set_reporter default_reporter) 74 | 75 | let activate_debug () = 76 | if not !_debug_active then ( 77 | _debug_active := true; 78 | Lazy.force set_logger; 79 | Logs.set_level ~all:true (Some Logs.Debug); 80 | Logs.debug (fun f -> f "Cohttp debugging output is active")) 81 | 82 | let () = 83 | try 84 | match Sys.getenv "COHTTP_DEBUG" with 85 | | "false" | "0" -> () 86 | | _ -> activate_debug () 87 | with Not_found -> () 88 | -------------------------------------------------------------------------------- /cohttp-lwt-unix/src/debug.mli: -------------------------------------------------------------------------------- 1 | (*{{{ Copyright (c) 2012-2014 Anil Madhavapeddy 2 | * 3 | * Permission to use, copy, modify, and distribute this software for any 4 | * purpose with or without fee is hereby granted, provided that the above 5 | * copyright notice and this permission notice appear in all copies. 6 | * 7 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | * 15 | }}}*) 16 | 17 | (** Debugging output for Cohttp Unix *) 18 | 19 | val default_reporter : Logs.reporter 20 | (** [default_reporter] provides a simple reporter that sends the logging output 21 | to stderr. For example, the code below enables logging at level [level] to 22 | stderr, using coloured output if possible. 23 | 24 | {[ 25 | Fmt_tty.setup_std_outputs (); 26 | Logs.set_level ~all:true (Some level); 27 | Logs.set_reporter Debug.default_reporter 28 | ]} *) 29 | 30 | val activate_debug : unit -> unit 31 | (** [activate_debug] enables debugging output that will be sent to standard 32 | error. *) 33 | 34 | val debug_active : unit -> bool 35 | (** [debug_active] returns true if [activate_debug] has been called and false 36 | otherwise *) 37 | 38 | (** {2 Selectively disable cohttp logging} *) 39 | 40 | (** It is possible to selectively disable cohttp internal logginb by filtering 41 | over the various modules logs names as follows. 42 | 43 | {[ 44 | (* Set log level v for all loggers, this does also affect cohttp internal loggers *) 45 | Logs.set_level ~all:true level; 46 | (* Disable all cohttp-lwt and cohttp-lwt-unix logs *) 47 | List.iter (fun src -> 48 | match Logs.Src.name src with 49 | | "cohttp.lwt.io" | "cohttp.lwt.server" -> Logs.Src.set_level src None 50 | | _ -> ()) 51 | @@ Logs.Src.list () 52 | ]} *) 53 | -------------------------------------------------------------------------------- /cohttp-lwt-unix/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name cohttp_lwt_unix) 3 | (public_name cohttp-lwt-unix) 4 | (synopsis "Lwt/Unix backend for Cohttp") 5 | (preprocess 6 | (pps ppx_sexp_conv)) 7 | (libraries 8 | fmt 9 | logs 10 | logs.lwt 11 | conduit-lwt 12 | magic-mime 13 | lwt.unix 14 | conduit-lwt-unix 15 | http 16 | cohttp 17 | cohttp-lwt 18 | logs.fmt)) 19 | -------------------------------------------------------------------------------- /cohttp-lwt-unix/src/input_channel.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | module Bytebuffer = Cohttp_lwt.Private.Bytebuffer 3 | 4 | type t = { buf : Bytebuffer.t; chan : Lwt_io.input_channel } 5 | 6 | let refill ic buf ~pos ~len = 7 | Lwt.catch 8 | (fun () -> 9 | Lwt_io.read_into ic buf pos len >|= fun c -> if c > 0 then `Ok c else `Eof) 10 | (function Lwt_io.Channel_closed _ -> Lwt.return `Eof | exn -> raise exn) 11 | 12 | let create ?(buf_len = 0x4000) chan = { buf = Bytebuffer.create buf_len; chan } 13 | let read_line_opt t = Bytebuffer.read_line t.buf (refill t.chan) 14 | let read t count = Bytebuffer.read t.buf (refill t.chan) count 15 | let refill t = Bytebuffer.refill t.buf (refill t.chan) 16 | 17 | let with_input_buffer t ~f = 18 | let buf = Bytebuffer.unsafe_buf t.buf in 19 | let pos = Bytebuffer.pos t.buf in 20 | let len = Bytebuffer.length t.buf in 21 | let res, consumed = f (Bytes.unsafe_to_string buf) ~pos ~len in 22 | Bytebuffer.drop t.buf consumed; 23 | res 24 | 25 | let close t = Lwt_io.close t.chan 26 | -------------------------------------------------------------------------------- /cohttp-lwt-unix/src/io.ml: -------------------------------------------------------------------------------- 1 | (*{{{ Copyright (c) 2012-2014 Anil Madhavapeddy 2 | * 3 | * Permission to use, copy, modify, and distribute this software for any 4 | * purpose with or without fee is hereby granted, provided that the above 5 | * copyright notice and this permission notice appear in all copies. 6 | * 7 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | * 15 | }}}*) 16 | 17 | exception IO_error of exn 18 | 19 | let () = 20 | Printexc.register_printer (function 21 | | IO_error e -> Some ("IO error: " ^ Printexc.to_string e) 22 | | _ -> None); 23 | if Sys.os_type <> "Win32" then Sys.(set_signal sigpipe Signal_ignore) 24 | 25 | type 'a t = 'a Lwt.t 26 | 27 | let ( >>= ) = Lwt.bind 28 | let return = Lwt.return 29 | 30 | type ic = Input_channel.t 31 | type oc = Lwt_io.output_channel 32 | type conn = Conduit_lwt_unix.flow 33 | 34 | let src = Logs.Src.create "cohttp.lwt.io" ~doc:"Cohttp Lwt IO module" 35 | 36 | module Log = (val Logs.src_log src : Logs.LOG) 37 | 38 | let wrap_read f ~if_closed = 39 | (* TODO Use [Lwt_io.is_closed] when available: 40 | https://github.com/ocsigen/lwt/pull/635 *) 41 | Lwt.catch f (function 42 | | Lwt_io.Channel_closed _ -> Lwt.return if_closed 43 | | Unix.Unix_error _ as e -> raise (IO_error e) 44 | | exn -> raise exn) 45 | 46 | let wrap_write f = 47 | Lwt.catch f (function 48 | | Unix.Unix_error _ as e -> raise (IO_error e) 49 | | exn -> raise exn) 50 | 51 | let read_line ic = 52 | wrap_read ~if_closed:None (fun () -> 53 | Input_channel.read_line_opt ic >>= function 54 | | None -> 55 | Log.debug (fun f -> f "<<< EOF"); 56 | Lwt.return_none 57 | | Some l as x -> 58 | Log.debug (fun f -> f "<<< %s" l); 59 | Lwt.return x) 60 | 61 | let read ic count = 62 | let count = min count Sys.max_string_length in 63 | wrap_read ~if_closed:"" (fun () -> 64 | Input_channel.read ic count >>= fun buf -> 65 | Log.debug (fun f -> f "<<<[%d] %s" count buf); 66 | Lwt.return buf) 67 | 68 | let refill ic = Input_channel.refill ic 69 | let with_input_buffer ic = Input_channel.with_input_buffer ic 70 | 71 | let write oc buf = 72 | wrap_write @@ fun () -> 73 | Log.debug (fun f -> f ">>> %s" (String.trim buf)); 74 | Lwt_io.write oc buf 75 | 76 | let flush oc = wrap_write @@ fun () -> Lwt_io.flush oc 77 | 78 | type error = exn 79 | 80 | let catch f = 81 | Lwt.try_bind f Lwt.return_ok (function 82 | | IO_error e -> Lwt.return_error e 83 | | ex -> Lwt.reraise ex) 84 | 85 | let pp_error = Fmt.exn 86 | -------------------------------------------------------------------------------- /cohttp-lwt-unix/src/io.mli: -------------------------------------------------------------------------------- 1 | (*{{{ Copyright (c) 2013 Anil Madhavapeddy 2 | * 3 | * Permission to use, copy, modify, and distribute this software for any 4 | * purpose with or without fee is hereby granted, provided that the above 5 | * copyright notice and this permission notice appear in all copies. 6 | * 7 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | * 15 | }}}*) 16 | 17 | (** The [Io] module contains the IO implementation for [cohttp-lwt-unix]. 18 | 19 | The {!Logs} source name for this module logger is ["cohttp.lwt.io"]. Refer 20 | to the {!Debug} module for further details.*) 21 | 22 | include 23 | Cohttp_lwt.S.IO 24 | with type ic = Input_channel.t 25 | and type oc = Lwt_io.output_channel 26 | and type conn = Conduit_lwt_unix.flow 27 | and type error = exn 28 | -------------------------------------------------------------------------------- /cohttp-lwt-unix/src/net.ml: -------------------------------------------------------------------------------- 1 | (*{{{ Copyright (c) 2012 Anil Madhavapeddy 2 | * 3 | * Permission to use, copy, modify, and distribute this software for any 4 | * purpose with or without fee is hereby granted, provided that the above 5 | * copyright notice and this permission notice appear in all copies. 6 | * 7 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | * 15 | }}}*) 16 | 17 | (* Miscellaneous net-helpers used by Cohttp. Ideally, these will disappear 18 | * into some connection-management framework such as andrenth/release *) 19 | 20 | open Lwt.Infix 21 | module IO = Io 22 | 23 | type ctx = { ctx : Conduit_lwt_unix.ctx; resolver : Resolver_lwt.t } 24 | [@@deriving sexp_of] 25 | 26 | let init ?(ctx = Lazy.force Conduit_lwt_unix.default_ctx) 27 | ?(resolver = Resolver_lwt_unix.system) () = 28 | { ctx; resolver } 29 | 30 | let default_ctx = 31 | lazy 32 | { 33 | resolver = Resolver_lwt_unix.system; 34 | ctx = Lazy.force Conduit_lwt_unix.default_ctx; 35 | } 36 | 37 | type endp = Conduit.endp 38 | type client = Conduit_lwt_unix.client 39 | 40 | let resolve ~ctx uri = Resolver_lwt.resolve_uri ~uri ctx.resolver 41 | 42 | let tunnel hostname (channels : IO.ic * IO.oc) : client = 43 | `TLS_tunnel (`Hostname hostname, (fst channels).chan, snd channels) 44 | 45 | let connect_client ~ctx:{ ctx; _ } client = 46 | Conduit_lwt_unix.connect ~ctx client >|= fun (flow, ic, oc) -> 47 | let ic = Input_channel.create ic in 48 | (flow, ic, oc) 49 | 50 | let connect_endp ~ctx endp = 51 | Conduit_lwt_unix.endp_to_client ~ctx:ctx.ctx endp >>= connect_client ~ctx 52 | 53 | let connect_uri ~ctx uri = resolve ~ctx uri >>= connect_endp ~ctx 54 | 55 | let close c = 56 | Lwt.catch 57 | (fun () -> Input_channel.close c) 58 | (fun e -> 59 | Logs.warn (fun f -> f "Closing channel failed: %s" (Printexc.to_string e)); 60 | Lwt.return_unit) 61 | 62 | let close_oc c = 63 | Lwt.catch 64 | (fun () -> Lwt_io.close c) 65 | (fun e -> 66 | Logs.warn (fun f -> f "Closing channel failed: %s" (Printexc.to_string e)); 67 | Lwt.return_unit) 68 | 69 | let close_in ic = Lwt.ignore_result (close ic) 70 | let close_out oc = Lwt.ignore_result (close_oc oc) 71 | let close ic oc = Lwt.ignore_result (close ic >>= fun () -> close_oc oc) 72 | -------------------------------------------------------------------------------- /cohttp-lwt-unix/src/net.mli: -------------------------------------------------------------------------------- 1 | (*{{{ Copyright (c) 2015 David Sheets 2 | * 3 | * Permission to use, copy, modify, and distribute this software for any 4 | * purpose with or without fee is hereby granted, provided that the above 5 | * copyright notice and this permission notice appear in all copies. 6 | * 7 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | * 15 | }}}*) 16 | 17 | (** Basic satisfaction of {!Cohttp_lwt.Net} *) 18 | 19 | type ctx = { ctx : Conduit_lwt_unix.ctx; resolver : Resolver_lwt.t } 20 | [@@deriving sexp_of] 21 | 22 | include 23 | Cohttp_lwt.S.Net 24 | with module IO = Io 25 | and type ctx := ctx 26 | and type endp = Conduit.endp 27 | and type client = Conduit_lwt_unix.client 28 | 29 | val init : ?ctx:Conduit_lwt_unix.ctx -> ?resolver:Resolver_lwt.t -> unit -> ctx 30 | (** [init ?ctx ?resolver ()] is a network context that is the same as the 31 | {!default_ctx}, but with either the connection handling or resolution module 32 | overridden with [ctx] or [resolver] respectively. This is useful to supply a 33 | {!Conduit_lwt_unix.resolver} with a custom source network interface, or a 34 | {!Resolver_lwt.t} with a different name resolution strategy (for instance to 35 | override a hostname to point it to a Unix domain socket). *) 36 | -------------------------------------------------------------------------------- /cohttp-lwt-unix/src/server.ml: -------------------------------------------------------------------------------- 1 | module Server_core = Cohttp_lwt.Make_server (Io) 2 | include Server_core 3 | open Lwt.Infix 4 | 5 | let src = 6 | Logs.Src.create "cohttp.lwt.server" ~doc:"Cohttp Lwt Unix server module" 7 | 8 | module Log = (val Logs.src_log src : Logs.LOG) 9 | 10 | let resolve_file ~docroot ~uri = Cohttp.Path.resolve_local_file ~docroot ~uri 11 | 12 | exception Isnt_a_file 13 | 14 | let respond_file ?headers ~fname () = 15 | Lwt.catch 16 | (fun () -> 17 | (* Check this isn't a directory first *) 18 | ( fname |> Lwt_unix.stat >>= fun s -> 19 | if Unix.(s.st_kind <> S_REG) then raise Isnt_a_file else Lwt.return_unit 20 | ) 21 | >>= fun () -> 22 | let count = 16384 in 23 | Lwt_io.open_file ~buffer:(Lwt_bytes.create count) ~mode:Lwt_io.input fname 24 | >>= fun ic -> 25 | Lwt_io.length ic >>= fun len -> 26 | let encoding = Http.Transfer.Fixed len in 27 | let stream = 28 | Lwt_stream.from (fun () -> 29 | Lwt.catch 30 | (fun () -> 31 | Lwt_io.read ~count ic >|= function 32 | | "" -> None 33 | | buf -> Some buf) 34 | (fun exn -> 35 | Log.warn (fun m -> 36 | m "Error resolving file %s (%s)" fname 37 | (Printexc.to_string exn)); 38 | Lwt.return_none)) 39 | in 40 | Lwt.on_success (Lwt_stream.closed stream) (fun () -> 41 | Lwt.ignore_result 42 | @@ Lwt.catch 43 | (fun () -> Lwt_io.close ic) 44 | (fun e -> 45 | Log.warn (fun f -> 46 | f "Closing channel failed: %s" (Printexc.to_string e)); 47 | Lwt.return_unit)); 48 | let body = Cohttp_lwt.Body.of_stream stream in 49 | let mime_type = Magic_mime.lookup fname in 50 | let headers = 51 | Http.Header.add_opt_unless_exists headers "content-type" mime_type 52 | in 53 | let res = Cohttp.Response.make ~status:`OK ~encoding ~headers () in 54 | Lwt.return (res, body)) 55 | (function 56 | | Unix.Unix_error (Unix.ENOENT, _, _) | Isnt_a_file -> 57 | respond_not_found () 58 | | exn -> Lwt.reraise exn) 59 | 60 | let log_on_exn = function 61 | | Unix.Unix_error (error, func, arg) -> 62 | Log.warn (fun m -> 63 | m "Client connection error %s: %s(%S)" (Unix.error_message error) func 64 | arg) 65 | | exn -> Log.err (fun m -> m "Unhandled exception: %a" Fmt.exn exn) 66 | 67 | let create ?timeout ?backlog ?stop ?(on_exn = log_on_exn) 68 | ?(ctx = Lazy.force Net.default_ctx) ?(mode = `TCP (`Port 8080)) spec = 69 | Conduit_lwt_unix.serve ?backlog ?timeout ?stop ~on_exn ~ctx:ctx.Net.ctx ~mode 70 | (fun flow ic oc -> 71 | let ic = Input_channel.create ic in 72 | callback spec flow ic oc) 73 | -------------------------------------------------------------------------------- /cohttp-lwt-unix/src/server.mli: -------------------------------------------------------------------------------- 1 | (** The [Server] module implements the full UNIX HTTP server interface, 2 | including the UNIX-specific functions defined in {!S}. 3 | 4 | The {!Logs} source name for this module logger is ["cohttp.lwt.server"]. 5 | Refer to the {!Debug} module for further details. *) 6 | 7 | include Cohttp_lwt.S.Server with module IO = Io 8 | 9 | val resolve_file : docroot:string -> uri:Uri.t -> string 10 | [@@deprecated "Please use Cohttp.Path.resolve_local_file. "] 11 | 12 | val respond_file : 13 | ?headers:Http.Header.t -> 14 | fname:string -> 15 | unit -> 16 | (Http.Response.t * Cohttp_lwt.Body.t) Lwt.t 17 | 18 | val create : 19 | ?timeout:int -> 20 | ?backlog:int -> 21 | ?stop:unit Lwt.t -> 22 | ?on_exn:(exn -> unit) -> 23 | ?ctx:Net.ctx -> 24 | ?mode:Conduit_lwt_unix.server -> 25 | t -> 26 | unit Lwt.t 27 | (** [create ?timeout ?backlog ?stop ?on_exn ?mode t] is a new HTTP server. 28 | 29 | The user can decide to start a simple HTTP server (without encryption) or 30 | one with TLS encryption. It depends on what the user gives as [mode] and how 31 | [conduit-unix] is configured. 32 | 33 | To create a simple HTTP server listening on port 8089: 34 | 35 | {[ 36 | let run = create (`TCP 8080) 37 | ]} 38 | 39 | When provided, the [stop] thread will terminate the server if it ever 40 | becomes determined. 41 | 42 | When provided, [backlog] will limit the number of open connections. 43 | 44 | Every connection will be served in a new lightweight thread that is invoked 45 | via the callback defined in [t]. If the callback raises an exception, it is 46 | passed to [on_exn] (by default, to a function that logs the exception using 47 | the {!Logs} library). *) 48 | -------------------------------------------------------------------------------- /cohttp-lwt-unix/test/cohttp_lwt_unix_test/src/cohttp_lwt_unix_test.ml: -------------------------------------------------------------------------------- 1 | open Lwt 2 | open OUnit 3 | open Cohttp_lwt_unix 4 | 5 | type 'a io = 'a Lwt.t 6 | type ic = Cohttp_lwt_unix.Private.Input_channel.t 7 | type oc = Lwt_io.output_channel 8 | type body = Cohttp_lwt.Body.t 9 | 10 | type response_action = 11 | [ `Expert of Http.Response.t * (ic -> oc -> unit io) 12 | | `Response of Http.Response.t * body ] 13 | 14 | type spec = Request.t -> body -> response_action io 15 | type async_test = unit -> unit Lwt.t 16 | 17 | let response rsp = `Response rsp 18 | 19 | let expert ?(rsp = Http.Response.make ()) f _req _body = 20 | return (`Expert (rsp, f)) 21 | 22 | let const rsp _req _body = rsp >|= response 23 | let response_sequence = Cohttp_test.response_sequence failwith 24 | let () = Debug.activate_debug () 25 | let () = Logs.set_level (Some Info) 26 | 27 | let temp_server ?port spec callback = 28 | let port = match port with None -> Cohttp_test.next_port () | Some p -> p in 29 | let server = 30 | Server.make_response_action ~callback:(fun _ req body -> spec req body) () 31 | in 32 | let uri = Uri.of_string ("http://localhost:" ^ string_of_int port) in 33 | let server_failed, server_failed_wake = Lwt.task () in 34 | let server = 35 | Lwt.catch 36 | (fun () -> Server.create ~backlog:40 ~mode:(`TCP (`Port port)) server) 37 | (function 38 | | Lwt.Canceled -> Lwt.return_unit 39 | | exn -> 40 | Lwt.wakeup_exn server_failed_wake exn; 41 | Lwt.reraise exn) 42 | in 43 | Lwt.pick [ Lwt_unix.with_timeout 5.0 (fun () -> callback uri); server_failed ] 44 | >|= fun res -> 45 | Lwt.cancel server; 46 | res 47 | 48 | let test_server_s ?port ?(name = "Cohttp Server Test") spec f = 49 | temp_server ?port spec (fun uri -> 50 | Logs.info (fun f -> f "Test %s running on %s" name (Uri.to_string uri)); 51 | let tests = f uri in 52 | let results = 53 | tests 54 | |> Lwt_list.map_s (fun (name, test) -> 55 | Logs.info (fun f -> f "Running %s" name); 56 | let res = 57 | Lwt.try_bind test 58 | (fun () -> return `Ok) 59 | (fun exn -> return (`Exn exn)) 60 | in 61 | res >|= fun res -> (name, res)) 62 | in 63 | results >|= fun results -> 64 | let ounit_tests = 65 | results 66 | |> List.map (fun (name, res) -> 67 | name >:: fun () -> match res with `Ok -> () | `Exn x -> raise x) 68 | in 69 | name >::: ounit_tests) 70 | 71 | let run_async_tests test = test >|= OUnit.run_test_tt_main 72 | -------------------------------------------------------------------------------- /cohttp-lwt-unix/test/cohttp_lwt_unix_test/src/cohttp_lwt_unix_test.mli: -------------------------------------------------------------------------------- 1 | include 2 | Cohttp_test.S 3 | with type 'a io = 'a Lwt.t 4 | and type body = Cohttp_lwt.Body.t 5 | and type ic = Cohttp_lwt_unix.Private.Input_channel.t 6 | and type oc = Lwt_io.output_channel 7 | -------------------------------------------------------------------------------- /cohttp-lwt-unix/test/cohttp_lwt_unix_test/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name cohttp_lwt_unix_test) 3 | (libraries conduit-lwt cohttp-lwt-unix cohttp_test ounit2)) 4 | -------------------------------------------------------------------------------- /cohttp-lwt-unix/test/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test_parser) 3 | (modules test_parser) 4 | (libraries cohttp-lwt-unix ounit2 lwt.unix)) 5 | 6 | (rule 7 | (alias runtest) 8 | (package cohttp-lwt-unix) 9 | (action 10 | (run ./test_parser.exe))) 11 | 12 | (executable 13 | (modules test_sanity) 14 | (name test_sanity) 15 | (libraries cohttp_lwt_unix_test cohttp-lwt-unix)) 16 | 17 | (executable 18 | (modules test_sanity_noisy) 19 | (name test_sanity_noisy) 20 | (libraries cohttp_lwt_unix_test cohttp-lwt-unix)) 21 | 22 | (rule 23 | (alias runtest) 24 | (package cohttp-lwt-unix) 25 | (action 26 | (run ./test_sanity.exe))) 27 | 28 | (rule 29 | (alias runtest) 30 | (package cohttp-lwt-unix) 31 | (action 32 | (run ./test_sanity_noisy.exe))) 33 | 34 | (executable 35 | (modules test_body) 36 | (name test_body) 37 | (libraries cohttp_lwt_unix_test cohttp-lwt-unix)) 38 | 39 | (rule 40 | (alias runtest) 41 | (package cohttp-lwt-unix) 42 | (action 43 | (run ./test_body.exe))) 44 | 45 | (executable 46 | (modules test_client) 47 | (name test_client) 48 | (libraries cohttp_lwt_unix_test cohttp-lwt-unix)) 49 | 50 | (rule 51 | (alias runtest) 52 | (package cohttp-lwt-unix) 53 | (action 54 | (run ./test_client.exe))) 55 | -------------------------------------------------------------------------------- /cohttp-lwt-unix/test/test_body.ml: -------------------------------------------------------------------------------- 1 | open Lwt 2 | open Lwt.Infix 3 | open OUnit 4 | module Body = Cohttp_lwt.Body 5 | 6 | let run_test f = 7 | Lwt.try_bind f (fun () -> return `Ok) (fun exn -> return (`Exn exn)) 8 | 9 | let test_empty_body () = 10 | Body.is_empty (`Stream (Lwt_stream.of_list [])) >|= fun res -> 11 | assert_equal true res 12 | 13 | let test_non_empty_stream () = 14 | Body.is_empty (`Stream (Lwt_stream.of_list [ "foo"; "bar" ])) >|= fun res -> 15 | assert_equal false res 16 | 17 | let test_stream_with_leading_empty_strings () = 18 | let s = Lwt_stream.of_list [ ""; ""; "foo"; ""; "bar" ] in 19 | Body.is_empty (`Stream s) >>= fun res -> 20 | assert_equal false res; 21 | Lwt_stream.to_list s >|= fun res -> 22 | assert_equal ~msg:"is_empty should consume leading spaces" 23 | [ "foo"; ""; "bar" ] res 24 | 25 | let test_stream_empty_strings () = 26 | Body.is_empty (`Stream (Lwt_stream.of_list [ ""; ""; "" ])) >|= fun res -> 27 | assert_equal true res 28 | 29 | let tests = 30 | [ 31 | ("Empty stream", test_empty_body); 32 | ("Non empty stream", test_non_empty_stream); 33 | ("Stream with leading empty strings", test_stream_with_leading_empty_strings); 34 | ("Stream with empty strings", test_stream_empty_strings); 35 | ] 36 | 37 | let test_suite = 38 | Lwt_list.map_s 39 | (fun (title, test) -> run_test test >|= fun res -> (title, res)) 40 | tests 41 | >|= fun results -> 42 | let tests = 43 | ListLabels.map results ~f:(fun (title, res) -> 44 | title >:: fun () -> match res with `Ok -> () | `Exn exn -> raise exn) 45 | in 46 | "Cohttp_Lwt.Body" >::: tests 47 | 48 | let _ = test_suite |> Cohttp_lwt_unix_test.run_async_tests |> Lwt_main.run 49 | -------------------------------------------------------------------------------- /cohttp-lwt-unix/test/test_sanity_noisy.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | open OUnit 3 | open Cohttp 4 | open Cohttp_lwt_unix 5 | open Cohttp_lwt_unix_test 6 | module Body = Cohttp_lwt.Body 7 | module IO = Cohttp_lwt_unix.Private.IO 8 | 9 | let chunk_body = [ "one"; ""; " "; "bar"; "" ] 10 | let () = Logs.set_level (Some Info) 11 | let () = Logs.set_reporter Logs.nop_reporter 12 | 13 | let check_logs test () = 14 | let old = Logs.(warn_count () + err_count ()) in 15 | test () >|= fun () -> 16 | let new_errs = Logs.(warn_count () + err_count ()) - old in 17 | if new_errs > 0 then 18 | Fmt.failwith "Test produced %d log messages at level >= warn" new_errs 19 | 20 | let server_noisy = 21 | List.map const 22 | [ 23 | (* empty_chunk *) 24 | Server.respond ~status:`OK ~body:(Body.of_string_list chunk_body) (); 25 | (* not modified *) 26 | Server.respond ~status:`Not_modified ~body:Body.empty (); 27 | ] 28 | @ [ 29 | (fun _ body -> 30 | (* Returns 500 on bad file *) 31 | Body.to_string body >>= fun fname -> 32 | Server.respond_file ~fname () >|= fun rsp -> `Response rsp); 33 | ] 34 | |> response_sequence 35 | 36 | let ts_noisy = 37 | Cohttp_lwt_unix_test.test_server_s ~port:10193 server_noisy (fun uri -> 38 | let ctx = Lazy.force Cohttp_lwt_unix.Net.default_ctx in 39 | let empty_chunk () = 40 | Client.get ~ctx uri >>= fun (_, body) -> 41 | body |> Body.to_string >|= fun body -> 42 | assert_equal body (String.concat "" chunk_body) 43 | in 44 | let not_modified_has_no_body () = 45 | Client.get ~ctx uri >>= fun (resp, body) -> 46 | assert_equal (Response.status resp) `Not_modified; 47 | let headers = Response.headers resp in 48 | assert_equal ~printer:Transfer.string_of_encoding 49 | Transfer.(Fixed 0L) 50 | (Header.get_transfer_encoding headers); 51 | body |> Body.is_empty >|= fun is_empty -> 52 | assert_bool "No body returned when not modified" is_empty 53 | in 54 | let unreadable_file_500 () = 55 | let fname = "unreadable500" in 56 | Lwt.finalize 57 | (fun () -> 58 | Lwt_io.open_file ~flags:[ Lwt_unix.O_CREAT ] ~perm:0o006 59 | ~mode:Lwt_io.Output fname 60 | >>= fun oc -> 61 | Lwt_io.write_line oc "never read" >>= fun () -> 62 | Lwt_io.close oc >>= fun () -> 63 | ( Client.post ~ctx uri ~body:(Body.of_string fname) 64 | >>= fun (resp, body) -> 65 | assert_equal ~printer:Code.string_of_status (Response.status resp) 66 | `Internal_server_error; 67 | Body.to_string body ) 68 | >|= fun body -> 69 | assert_equal 70 | ~printer:(fun x -> "'" ^ x ^ "'") 71 | body "Error: Internal Server Error") 72 | (fun () -> Lwt_unix.unlink fname) 73 | in 74 | [ 75 | ("empty chunk test", check_logs empty_chunk); 76 | ( "no body when response is not modified", 77 | check_logs not_modified_has_no_body ); 78 | ("unreadable file returns 500", unreadable_file_500); 79 | ]) 80 | 81 | let _ = ts_noisy |> run_async_tests |> Lwt_main.run 82 | -------------------------------------------------------------------------------- /cohttp-lwt.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "CoHTTP implementation using the Lwt concurrency library" 4 | description: """ 5 | This is a portable implementation of HTTP that uses the Lwt concurrency library 6 | to multiplex IO. It implements as much of the logic in an OS-independent way 7 | as possible, so that more specialised modules can be tailored for different 8 | targets. For example, you can install `cohttp-lwt-unix` or `cohttp-lwt-jsoo` 9 | for a Unix or JavaScript backend, or `cohttp-mirage` for the MirageOS unikernel 10 | version of the library. All of these implementations share the same IO logic 11 | from this module.""" 12 | maintainer: ["Anil Madhavapeddy "] 13 | authors: [ 14 | "Anil Madhavapeddy" 15 | "Stefano Zacchiroli" 16 | "David Sheets" 17 | "Thomas Gazagnaire" 18 | "David Scott" 19 | "Rudi Grinberg" 20 | "Andy Ray" 21 | "Anurag Soni" 22 | ] 23 | license: "ISC" 24 | homepage: "https://github.com/mirage/ocaml-cohttp" 25 | doc: "https://mirage.github.io/ocaml-cohttp/" 26 | bug-reports: "https://github.com/mirage/ocaml-cohttp/issues" 27 | depends: [ 28 | "dune" {>= "3.8"} 29 | "ocaml" {>= "4.08"} 30 | "http" {= version} 31 | "cohttp" {= version} 32 | "lwt" {>= "5.4.0"} 33 | "sexplib0" 34 | "ipaddr" {>= "5.6.0"} 35 | "ppx_sexp_conv" {>= "v0.13.0"} 36 | "logs" 37 | "uri" {>= "2.0.0"} 38 | "odoc" {with-doc} 39 | ] 40 | dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git" 41 | build: [ 42 | ["dune" "subst"] {dev} 43 | [ 44 | "dune" 45 | "build" 46 | "-p" 47 | name 48 | "-j" 49 | jobs 50 | "@install" 51 | "@cohttp-lwt/runtest" {with-test} 52 | "@doc" {with-doc} 53 | ] 54 | ] 55 | x-maintenance-intent: [ "(latest)" ] 56 | -------------------------------------------------------------------------------- /cohttp-lwt.opam.template: -------------------------------------------------------------------------------- 1 | build: [ 2 | ["dune" "subst"] {dev} 3 | [ 4 | "dune" 5 | "build" 6 | "-p" 7 | name 8 | "-j" 9 | jobs 10 | "@install" 11 | "@cohttp-lwt/runtest" {with-test} 12 | "@doc" {with-doc} 13 | ] 14 | ] 15 | x-maintenance-intent: [ "(latest)" ] 16 | -------------------------------------------------------------------------------- /cohttp-lwt/src/body.mli: -------------------------------------------------------------------------------- 1 | (*{{{ Copyright (c) 2012 Anil Madhavapeddy 2 | * 3 | * Permission to use, copy, modify, and distribute this software for any 4 | * purpose with or without fee is hereby granted, provided that the above 5 | * copyright notice and this permission notice appear in all copies. 6 | * 7 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | * 15 | }}}*) 16 | 17 | type t = [ Cohttp.Body.t | `Stream of string Lwt_stream.t ] [@@deriving sexp] 18 | 19 | include Cohttp.S.Body with type t := t 20 | 21 | val is_empty : t -> bool Lwt.t 22 | val to_string : t -> string Lwt.t 23 | val to_string_list : t -> string list Lwt.t 24 | val to_stream : t -> string Lwt_stream.t 25 | val of_stream : string Lwt_stream.t -> t 26 | val to_form : t -> (string * string list) list Lwt.t 27 | 28 | val create_stream : 29 | ('a -> Cohttp.Transfer.chunk Lwt.t) -> 'a -> string Lwt_stream.t 30 | 31 | val length : t -> (int64 * t) Lwt.t 32 | val write_body : (string -> unit Lwt.t) -> t -> unit Lwt.t 33 | val drain_body : t -> unit Lwt.t 34 | -------------------------------------------------------------------------------- /cohttp-lwt/src/bytebuffer.ml: -------------------------------------------------------------------------------- 1 | include Http_bytebuffer.Bytebuffer 2 | 3 | include 4 | Http_bytebuffer.Bytebuffer.Make 5 | (struct 6 | include Lwt 7 | 8 | let ( >>| ) x f = Lwt.map f x 9 | end) 10 | (struct 11 | type src = bytes -> pos:int -> len:int -> [ `Ok of int | `Eof ] Lwt.t 12 | 13 | let refill src = src 14 | end) 15 | -------------------------------------------------------------------------------- /cohttp-lwt/src/client.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | module Header = Cohttp.Header 3 | 4 | module Make (Connection : S.Connection) = struct 5 | module Net = Connection.Net 6 | module No_cache = Connection_cache.Make_no_cache (Connection) 7 | module Request = Make.Request (Net.IO) 8 | 9 | let cache = ref No_cache.(call (create ())) 10 | let set_cache c = cache := c 11 | 12 | type ctx = Net.ctx 13 | 14 | let cache ?ctx = 15 | match ctx with 16 | | None -> !cache 17 | | Some ctx -> No_cache.(call (create ~ctx ())) 18 | 19 | include 20 | Cohttp.Generic.Client.Make 21 | (struct 22 | type 'a io = 'a Lwt.t 23 | type body = Body.t 24 | type 'a with_context = ?ctx:ctx -> 'a 25 | 26 | let map_context v f ?ctx = f (v ?ctx) 27 | 28 | let call ?ctx ?headers ?body ?chunked meth uri = 29 | let add_transfer = 30 | Header.add_transfer_encoding 31 | (Option.value ~default:(Header.init ()) headers) 32 | in 33 | match chunked with 34 | | None -> cache ?ctx ?headers ?body meth uri 35 | | Some true -> 36 | let headers = add_transfer Cohttp.Transfer.Chunked in 37 | cache ?ctx ~headers ?body meth uri 38 | | Some false -> 39 | Option.value ~default:`Empty body |> Body.length 40 | >>= fun (length, body) -> 41 | let headers = add_transfer (Cohttp.Transfer.Fixed length) in 42 | cache ?ctx ~headers ~body meth uri 43 | end) 44 | (Connection.Net.IO) 45 | 46 | let post_form ?ctx ?headers ~params uri = 47 | let headers = 48 | Header.add_opt_unless_exists headers "content-type" 49 | "application/x-www-form-urlencoded" 50 | in 51 | let body = Body.of_string (Uri.encoded_of_query params) in 52 | post ?ctx ~chunked:false ~headers ~body uri 53 | 54 | let callv ?(ctx = Lazy.force Net.default_ctx) uri reqs = 55 | let mutex = Lwt_mutex.create () in 56 | Net.resolve ~ctx uri >>= Connection.connect ~ctx >>= fun connection -> 57 | Lwt.return 58 | @@ Lwt_stream.from 59 | @@ fun () -> 60 | Lwt_stream.get reqs >>= function 61 | | None -> 62 | Connection.close connection |> ignore; 63 | Lwt.return_none 64 | | Some (req, body) -> 65 | Lwt_mutex.with_lock mutex @@ fun () -> 66 | let headers, meth, uri, enc = 67 | Request.(headers req, meth req, uri req, encoding req) 68 | in 69 | let headers = Header.add_transfer_encoding headers enc in 70 | Connection.call connection ~headers ~body meth uri >|= Option.some 71 | end 72 | -------------------------------------------------------------------------------- /cohttp-lwt/src/client.mli: -------------------------------------------------------------------------------- 1 | (** The [Make] functor glues together a {!Cohttp.S.IO} implementation to send 2 | requests down a connection that is established by the {!Net} module. The 3 | resulting module satisfies the {!Client} module type. 4 | 5 | The {!Logs} source name for this module's logger is ["cohttp.lwt.client"]. 6 | When logging is enabled (at least {b warning} level), eventual body leaks 7 | will be logged and easier to track. *) 8 | 9 | module Make (Connection : S.Connection) : 10 | S.Client with type ctx = Connection.Net.ctx 11 | -------------------------------------------------------------------------------- /cohttp-lwt/src/cohttp_lwt.ml: -------------------------------------------------------------------------------- 1 | (*{{{ Copyright (c) 2012-2013 Anil Madhavapeddy 2 | * 3 | * Permission to use, copy, modify, and distribute this software for any 4 | * purpose with or without fee is hereby granted, provided that the above 5 | * copyright notice and this permission notice appear in all copies. 6 | * 7 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | * 15 | }}}*) 16 | 17 | module type IO = S.IO 18 | 19 | module Request = Cohttp.Request [@@deprecated "Use Cohttp.Request directly"] 20 | module Response = Cohttp.Response [@@deprecated "Use Cohttp.Response directly"] 21 | module Connection = Connection 22 | module Connection_cache = Connection_cache 23 | module Client = Client 24 | module Server = Server 25 | 26 | (** @deprecated use {!module:Client.Make} instead. *) 27 | module Make_client (IO : IO) (Net : S.Net with module IO = IO) = 28 | Client.Make (Connection.Make (Net)) 29 | 30 | module Make_server = Server.Make 31 | (** @deprecated use {!module:Server.Make} instead. *) 32 | 33 | module S = S 34 | module Body = Body 35 | 36 | module Private = struct 37 | module Bytebuffer = Bytebuffer 38 | module String_io = String_io 39 | end 40 | -------------------------------------------------------------------------------- /cohttp-lwt/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name cohttp_lwt) 3 | (public_name cohttp-lwt) 4 | (synopsis "Lwt backend") 5 | (preprocess 6 | (pps ppx_sexp_conv)) 7 | (libraries lwt uri uri.services http_bytebuffer cohttp logs logs.lwt ipaddr)) 8 | -------------------------------------------------------------------------------- /cohttp-lwt/src/make.ml: -------------------------------------------------------------------------------- 1 | module Request (IO : S.IO) = struct 2 | include Cohttp.Request 3 | 4 | include ( 5 | Private.Make (IO) : module type of Private.Make (IO) with type t := t) 6 | end 7 | 8 | module Response (IO : S.IO) = struct 9 | include Cohttp.Response 10 | 11 | include ( 12 | Private.Make (IO) : module type of Private.Make (IO) with type t := t) 13 | end 14 | -------------------------------------------------------------------------------- /cohttp-lwt/src/server.mli: -------------------------------------------------------------------------------- 1 | (** The [Make] functor glues together a {!Cohttp.S.IO} implementation to send 2 | requests down a connection that is established by the user. The resulting 3 | module satisfies the {!Server} module type. 4 | 5 | The {!Logs} source name for this module's logger is ["cohttp.lwt.server"].*) 6 | 7 | module Make (IO : S.IO) : S.Server with module IO = IO 8 | -------------------------------------------------------------------------------- /cohttp-lwt/src/string_io.ml: -------------------------------------------------------------------------------- 1 | (*{{{ Copyright (c) 2014 Andy Ray 2 | * Copyright (c) 2014 Anil Madhavapeddy 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | }}}*) 17 | 18 | type 'a t = 'a Lwt.t 19 | 20 | let return = Lwt.return 21 | let ( >>= ) = Lwt.bind 22 | 23 | module Sio = Cohttp.Private.String_io 24 | 25 | type ic = Sio.M.ic 26 | type oc = Sio.M.oc 27 | type conn = Sio.M.conn 28 | 29 | let refill ic = return (Sio.M.refill ic) 30 | let with_input_buffer ic ~f = Sio.M.with_input_buffer ic ~f 31 | let read_line ic = return (Sio.M.read_line ic) 32 | let read ic n = return (Sio.M.read ic n) 33 | let write oc str = return (Sio.M.write oc str) 34 | let flush oc = return (Sio.M.flush oc) 35 | -------------------------------------------------------------------------------- /cohttp-lwt/src/string_io.mli: -------------------------------------------------------------------------------- 1 | (*{{{ Copyright (c) 2014 Andy Ray 2 | * Copyright (c) 2014 Anil Madhavapeddy 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | }}}*) 17 | 18 | (** Lwt IO implementation that uses strings to marshal and unmarshal HTTP *) 19 | 20 | (** IO interface that uses {!Cohttp.Private.String_io.buf} for input data and 21 | queues output data into a {!Buffer.t}. Never actually blocks despite the Lwt 22 | use, although a future revision may yield when parsing large strings. *) 23 | include 24 | Cohttp.S.IO 25 | with type 'a t = 'a Lwt.t 26 | and type ic = Cohttp.Private.String_io.buf 27 | and type oc = Buffer.t 28 | -------------------------------------------------------------------------------- /cohttp-lwt/test/bytebuffer_tests.ml: -------------------------------------------------------------------------------- 1 | module Bytebuffer = Cohttp_lwt.Private.Bytebuffer 2 | 3 | let%expect_test "read" = 4 | let line = "foobar\r\n" in 5 | let test buf_size = 6 | let buf = Bytebuffer.create buf_size in 7 | let refill = 8 | let line_pos = ref 0 in 9 | let reads_left = ref 10 in 10 | fun buf ~pos ~len -> 11 | if !reads_left = 0 then raise Exit; 12 | decr reads_left; 13 | let available = String.length line - !line_pos in 14 | if available = 0 then Lwt.return `Eof 15 | else 16 | let read_len = min len available in 17 | BytesLabels.blit_string ~src:line ~src_pos:!line_pos ~dst:buf 18 | ~dst_pos:pos ~len:read_len; 19 | line_pos := !line_pos + read_len; 20 | Lwt.return (`Ok read_len) 21 | in 22 | let open Lwt.Syntax in 23 | Lwt_main.run 24 | @@ Lwt.catch 25 | (fun () -> 26 | let+ res = Bytebuffer.read_line buf refill in 27 | match res with 28 | | None -> print_endline "failed to read line" 29 | | Some line -> Printf.printf "read line: %S\n" line) 30 | (function 31 | | Exit -> Lwt.return @@ print_endline "failed to read" 32 | | _ -> assert false) 33 | in 34 | test (String.length line); 35 | [%expect {| read line: "foobar" |}]; 36 | test (String.length line - 1); 37 | [%expect {| read line: "foobar" |}] 38 | -------------------------------------------------------------------------------- /cohttp-mirage-CHANGES.md: -------------------------------------------------------------------------------- 1 | ### 3.2.0 2 | 3 | * Port to jbuilder 4 | 5 | ### 3.1.0 6 | 7 | * Add `Cohttp_mirage_static` module for serving static files from a 8 | read-only key-value store. Includes magic mime detection. 9 | * Improve the ocamldoc strings for the modules. 10 | * Constrain supported OCaml version to 4.03.0+ or higher, as with Mirage 3.0. 11 | 12 | ### 3.0.0 13 | 14 | * Port to MirageOS 3 CHANNEL interface. 15 | * Use Travis Docker for more multidistro testing. 16 | 17 | ### 2.5.3 (13-06-2016) 18 | 19 | * Switch to topkg (#25, @samoht) 20 | * Fix memory leak in the callback when an exception is raised (#24, @hannesm) 21 | 22 | ### 2.5.2 (13-04-2016) 23 | 24 | * Fix memory leak by closing channel when callback is executed 25 | (#23 via @hannesm) 26 | 27 | ### 2.5.1 (15-09-2015) 28 | 29 | * Add a preapplied server with conduit (#20, by @Drup) 30 | 31 | ### 2.5.0 (05-07-2015) 32 | 33 | * Depends on `channel` instead of the full `tcpip` stack 34 | 35 | ### 2.4.0 (10-06-2015) 36 | 37 | * Support cohttp 0.18 (#13, by @rgrinberg) 38 | 39 | ### 2.3.0 (29-05-2015) 40 | 41 | * Simplify the `Client` signature to be a simple module. It is not 42 | a functor depending on `Conduit` anymore and the context is now 43 | more explicit. 44 | * Expose type equalities for `IO.conn` in the `Server` functor 45 | * Adapt to conduit 0.8.4 46 | 47 | ### 2.2.0: (08-04-2015) 48 | 49 | * Do not user `lwt.syntax` 50 | * Rename `HTTP` to `Cohttp_Mirage` (#9) 51 | * Expose `Cohttp_mirage_io` 52 | * Expose a `Server` functor which depends only on mirage's `FLOW` (no dependency 53 | to `Conduit` anymore in this case) 54 | * Modernize Travis CI scripts 55 | 56 | ### 2.1.0 (05-12-2014): 57 | 58 | * Use the Conduit 0.7+ resolver API (provide `of_sexp` for context). 59 | * Do not link against `camlp4` in the `META` file and only use it during build. 60 | 61 | ### 2.0.0 (07-11-2014): 62 | 63 | * Use the Conduit 0.6+ resolver API. 64 | * Add a local `opam` file for the OPAM 1.2.0 workflow. 65 | 66 | ### 1.2.0 (03-05-2014): 67 | 68 | * Use the Cohttp.0.12.0 interface. 69 | 70 | ### 1.1.0 (05-02-2014): 71 | 72 | * Functorize the HTTP Mirage layer, so that the library is now 73 | OS-independent and compatible with Mirage 1.1.x signatures. 74 | 75 | ### 1.0.0 (18-01-2013): 76 | 77 | * Initial public release. 78 | -------------------------------------------------------------------------------- /cohttp-mirage.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "CoHTTP implementation for the MirageOS unikernel" 4 | description: """ 5 | This HTTP implementation uses the Cohttp portable implementation 6 | along with the Lwt threading library in order to provide a 7 | `Cohttp_mirage` functor that can be used in MirageOS unikernels 8 | to build very small and efficient HTTP clients and servers 9 | without having a hard dependency on an underlying operating 10 | system. 11 | 12 | Please see for a self-hosted explanation 13 | and instructions on how to use this library.""" 14 | maintainer: ["Anil Madhavapeddy "] 15 | authors: [ 16 | "Anil Madhavapeddy" 17 | "Stefano Zacchiroli" 18 | "David Sheets" 19 | "Thomas Gazagnaire" 20 | "David Scott" 21 | "Rudi Grinberg" 22 | "Andy Ray" 23 | "Anurag Soni" 24 | ] 25 | license: "ISC" 26 | homepage: "https://github.com/mirage/ocaml-cohttp" 27 | doc: "https://mirage.github.io/ocaml-cohttp/" 28 | bug-reports: "https://github.com/mirage/ocaml-cohttp/issues" 29 | depends: [ 30 | "dune" {>= "3.8"} 31 | "ocaml" {>= "4.08"} 32 | "mirage-flow" {>= "2.0.0"} 33 | "mirage-channel" {>= "4.0.0"} 34 | "conduit" {>= "8.0.0"} 35 | "conduit-mirage" {>= "8.0.0"} 36 | "mirage-kv" {>= "3.0.0"} 37 | "lwt" {>= "2.4.3"} 38 | "cohttp-lwt" {= version} 39 | "cstruct" {>= "6.0.0"} 40 | "fmt" {>= "0.8.7"} 41 | "astring" 42 | "magic-mime" 43 | "ppx_sexp_conv" {>= "v0.13.0"} 44 | "cohttp" {= version} 45 | "odoc" {with-doc} 46 | ] 47 | dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git" 48 | build: [ 49 | ["dune" "subst"] {dev} 50 | [ 51 | "dune" 52 | "build" 53 | "-p" 54 | name 55 | "-j" 56 | jobs 57 | "@install" 58 | "@cohttp-mirage/runtest" {with-test} 59 | "@doc" {with-doc} 60 | ] 61 | ] 62 | x-maintenance-intent: [ "(latest)" ] 63 | -------------------------------------------------------------------------------- /cohttp-mirage.opam.template: -------------------------------------------------------------------------------- 1 | build: [ 2 | ["dune" "subst"] {dev} 3 | [ 4 | "dune" 5 | "build" 6 | "-p" 7 | name 8 | "-j" 9 | jobs 10 | "@install" 11 | "@cohttp-mirage/runtest" {with-test} 12 | "@doc" {with-doc} 13 | ] 14 | ] 15 | x-maintenance-intent: [ "(latest)" ] 16 | -------------------------------------------------------------------------------- /cohttp-mirage/src/client.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2012-2015 Anil Madhavapeddy 3 | * Copyright (c) 2013-2015 Thomas Gazagnaire 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | * 17 | * %%NAME%% %%VERSION%% 18 | *) 19 | 20 | module Make (R : Resolver_mirage.S) (S : Conduit_mirage.S) = struct 21 | module Net = Net.Make (R) (S) 22 | module Connection = Cohttp_lwt.Connection.Make (Net) 23 | include Cohttp_lwt.Client.Make (Connection) 24 | 25 | let ctx ?authenticator resolver conduit = 26 | { Net.resolver; conduit = Some conduit; authenticator } 27 | 28 | let with_authenticator a ctx = { ctx with Net.authenticator = Some a } 29 | end 30 | -------------------------------------------------------------------------------- /cohttp-mirage/src/client.mli: -------------------------------------------------------------------------------- 1 | module Make (R : Resolver_mirage.S) (S : Conduit_mirage.S) : sig 2 | module Connection : Cohttp_lwt.S.Connection 3 | include Cohttp_lwt.S.Client with type ctx = Connection.Net.ctx 4 | 5 | val ctx : ?authenticator:X509.Authenticator.t -> R.t -> S.t -> ctx 6 | val with_authenticator : X509.Authenticator.t -> ctx -> ctx 7 | end 8 | -------------------------------------------------------------------------------- /cohttp-mirage/src/cohttp_mirage.ml: -------------------------------------------------------------------------------- 1 | (** IO modules *) 2 | 3 | module IO = Io.Make 4 | 5 | module Net = Net.Make 6 | (** The resulting {!modtype:Cohttp_lwt.S.Net} module can be used to build the 7 | low-level client interfaces with {!module:Cohttp_lwt.Connection.Make} and 8 | from that {!module:Cohttp_lwt.Connection_cache.Make}. *) 9 | 10 | (** client modules *) 11 | 12 | (** simple, high-level interface *) 13 | 14 | module Client = Client 15 | 16 | (** server modules *) 17 | 18 | module Static = Static 19 | (** Serve static HTTP sites from a Mirage key-value store. *) 20 | 21 | module Server = Server 22 | -------------------------------------------------------------------------------- /cohttp-mirage/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name cohttp_mirage) 3 | (public_name cohttp-mirage) 4 | (synopsis "Mirage backend for cohttp") 5 | (preprocess 6 | (pps ppx_sexp_conv)) 7 | (libraries 8 | conduit-mirage 9 | cohttp-lwt 10 | mirage-channel 11 | mirage-kv 12 | mirage-flow 13 | magic-mime 14 | astring)) 15 | -------------------------------------------------------------------------------- /cohttp-mirage/src/input_channel.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | module Bytebuffer = Cohttp_lwt.Private.Bytebuffer 3 | 4 | module Make (Channel : Mirage_channel.S) = struct 5 | exception Read_exn of Channel.error 6 | 7 | type t = { chan : Channel.t; buf : Bytebuffer.t } 8 | 9 | let refill chan buf ~pos ~len = 10 | Channel.read_some ~len chan >>= function 11 | | Ok (`Data v) -> 12 | let len = Cstruct.length v in 13 | Cstruct.blit_to_bytes v 0 buf pos len; 14 | Lwt.return (`Ok len) 15 | | Ok `Eof -> Lwt.return `Eof 16 | | Error e -> raise (Read_exn e) 17 | 18 | let create ?(buf_len = 0x4000) chan = 19 | { buf = Bytebuffer.create buf_len; chan } 20 | 21 | let read_line_opt t = Bytebuffer.read_line t.buf (refill t.chan) 22 | let read t count = Bytebuffer.read t.buf (refill t.chan) count 23 | let refill t = Bytebuffer.refill t.buf (refill t.chan) 24 | 25 | let with_input_buffer t ~f = 26 | let buf = Bytebuffer.unsafe_buf t.buf in 27 | let pos = Bytebuffer.pos t.buf in 28 | let len = Bytebuffer.length t.buf in 29 | let res, consumed = f (Bytes.unsafe_to_string buf) ~pos ~len in 30 | Bytebuffer.drop t.buf consumed; 31 | res 32 | 33 | let close t = Channel.close t.chan 34 | end 35 | -------------------------------------------------------------------------------- /cohttp-mirage/src/io.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2012-2015 Anil Madhavapeddy 3 | * Copyright (c) 2013-2015 Thomas Gazagnaire 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | * 17 | * %%NAME%% %%VERSION%% 18 | *) 19 | 20 | open Lwt.Infix 21 | 22 | module Make (Channel : Mirage_channel.S) = struct 23 | module Input_channel = Input_channel.Make (Channel) 24 | 25 | type error = 26 | | Read_error of Channel.error 27 | | Write_error of Channel.write_error 28 | 29 | let pp_error f = function 30 | | Read_error e -> Channel.pp_error f e 31 | | Write_error e -> Channel.pp_write_error f e 32 | 33 | type 'a t = 'a Lwt.t 34 | type ic = Input_channel.t 35 | type oc = Channel.t 36 | type conn = Channel.flow 37 | 38 | exception Write_exn of Channel.write_error 39 | 40 | let () = 41 | Printexc.register_printer (function 42 | | Input_channel.Read_exn e -> 43 | Some (Format.asprintf "IO read error: %a" Channel.pp_error e) 44 | | Write_exn e -> 45 | Some (Format.asprintf "IO write error: %a" Channel.pp_write_error e) 46 | | _ -> None) 47 | 48 | let read_line ic = Input_channel.read_line_opt ic 49 | let read ic len = Input_channel.read ic len 50 | let refill ic = Input_channel.refill ic 51 | let with_input_buffer ic ~f = Input_channel.with_input_buffer ic ~f 52 | 53 | let write oc buf = 54 | Channel.write_string oc buf 0 (String.length buf); 55 | Channel.flush oc >>= function 56 | | Ok () -> Lwt.return_unit 57 | | Error `Closed -> failwith "Trying to write on closed channel" 58 | | Error e -> raise (Write_exn e) 59 | 60 | let flush _ = 61 | (* NOOP since we flush in the normal writer functions above *) 62 | Lwt.return_unit 63 | 64 | let ( >>= ) = Lwt.( >>= ) 65 | let return = Lwt.return 66 | 67 | let catch f = 68 | Lwt.try_bind f Lwt.return_ok (function 69 | | Input_channel.Read_exn e -> Lwt.return_error (Read_error e) 70 | | Write_exn e -> Lwt.return_error (Write_error e) 71 | | ex -> Lwt.reraise ex) 72 | end 73 | -------------------------------------------------------------------------------- /cohttp-mirage/src/io.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2012-2015 Anil Madhavapeddy 3 | * Copyright (c) 2013-2015 Thomas Gazagnaire 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | * 17 | * %%NAME%% %%VERSION%% 18 | *) 19 | 20 | (** Cohttp IO implementation using Mirage channels. *) 21 | 22 | module Make (Channel : Mirage_channel.S) : 23 | Cohttp_lwt.S.IO 24 | with type ic = Input_channel.Make(Channel).t 25 | and type oc = Channel.t 26 | and type conn = Channel.flow 27 | -------------------------------------------------------------------------------- /cohttp-mirage/src/make.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | module Server (Flow : Mirage_flow.S) = struct 4 | module Channel = Mirage_channel.Make (Flow) 5 | module HTTP_IO = Io.Make (Channel) 6 | module Input_channel = Input_channel.Make (Channel) 7 | include Cohttp_lwt.Make_server (HTTP_IO) 8 | 9 | let listen spec flow = 10 | let ch = Channel.create flow in 11 | Lwt.finalize 12 | (fun () -> callback spec flow (Input_channel.create ch) ch) 13 | (fun () -> Channel.close ch >|= fun _ -> ()) 14 | end 15 | -------------------------------------------------------------------------------- /cohttp-mirage/src/make.mli: -------------------------------------------------------------------------------- 1 | (** HTTP server. *) 2 | module Server (Flow : Mirage_flow.S) : sig 3 | include Cohttp_lwt.S.Server with type IO.conn = Flow.flow 4 | 5 | val listen : t -> IO.conn -> unit Lwt.t 6 | end 7 | -------------------------------------------------------------------------------- /cohttp-mirage/src/net.ml: -------------------------------------------------------------------------------- 1 | module Make (R : Resolver_mirage.S) (S : Conduit_mirage.S) = struct 2 | module Channel = Mirage_channel.Make (S.Flow) 3 | module Input_channel = Input_channel.Make (Channel) 4 | module IO = Io.Make (Channel) 5 | open IO 6 | 7 | type ctx = { 8 | resolver : R.t; 9 | conduit : S.t option; 10 | authenticator : X509.Authenticator.t option; 11 | } 12 | 13 | let sexp_of_ctx { resolver; _ } = R.sexp_of_t resolver 14 | 15 | let default_ctx = 16 | lazy { resolver = R.localhost; conduit = None; authenticator = None } 17 | 18 | type endp = Conduit.endp 19 | type client 20 | 21 | let tunnel _ _ = failwith "Unimplemented" 22 | let connect_client ~ctx:_ _ = failwith "Unimplemented" 23 | let resolve ~ctx uri = R.resolve_uri ~uri ctx.resolver 24 | 25 | let connect_endp ~ctx endp = 26 | Conduit_mirage.Endpoint.client ?tls_authenticator:ctx.authenticator endp 27 | >>= fun client -> 28 | match ctx.conduit with 29 | | None -> failwith "conduit not initialised" 30 | | Some c -> 31 | S.connect c client >>= fun flow -> 32 | let ch = Channel.create flow in 33 | Lwt.return (flow, Input_channel.create ch, ch) 34 | 35 | let connect_uri ~ctx uri = resolve ~ctx uri >>= connect_endp ~ctx 36 | let close_in _ = () 37 | let close_out _ = () 38 | 39 | let close ic _oc = 40 | Lwt.ignore_result 41 | @@ Lwt.catch 42 | (fun () -> Input_channel.close ic) 43 | (fun e -> 44 | Logs.warn (fun f -> 45 | f "Closing channel failed: %s" (Printexc.to_string e)); 46 | Lwt.return @@ Ok ()) 47 | end 48 | -------------------------------------------------------------------------------- /cohttp-mirage/src/net.mli: -------------------------------------------------------------------------------- 1 | module Make (R : Resolver_mirage.S) (S : Conduit_mirage.S) : sig 2 | type ctx = { 3 | resolver : R.t; 4 | conduit : S.t option; 5 | authenticator : X509.Authenticator.t option; 6 | } 7 | 8 | include Cohttp_lwt.S.Net with type ctx := ctx 9 | end 10 | -------------------------------------------------------------------------------- /cohttp-mirage/src/server.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | module type S = sig 4 | include Cohttp_lwt.S.Server 5 | 6 | val callback : t -> IO.conn -> unit Lwt.t 7 | end 8 | 9 | module Flow (F : Mirage_flow.S) = struct 10 | module Channel = Mirage_channel.Make (F) 11 | module HTTP_IO = Io.Make (Channel) 12 | module Input_channel = Input_channel.Make (Channel) 13 | include Cohttp_lwt.Make_server (HTTP_IO) 14 | 15 | let callback spec flow = 16 | let ch = Channel.create flow in 17 | Lwt.finalize 18 | (fun () -> callback spec flow (Input_channel.create ch) ch) 19 | (fun () -> Channel.close ch >|= fun _ -> ()) 20 | end 21 | 22 | module Make (S : Conduit_mirage.S) = struct 23 | include Flow (S.Flow) 24 | 25 | let listen s conf t = S.listen s conf (callback t) 26 | end 27 | -------------------------------------------------------------------------------- /cohttp-mirage/src/server.mli: -------------------------------------------------------------------------------- 1 | (** HTTP server with conduit. *) 2 | 3 | module type S = sig 4 | include Cohttp_lwt.S.Server 5 | 6 | val callback : t -> IO.conn -> unit Lwt.t 7 | end 8 | 9 | module Flow (F : Mirage_flow.S) : S with type IO.conn = F.flow 10 | 11 | module Make (S : Conduit_mirage.S) : sig 12 | include S with type IO.conn = S.flow 13 | 14 | val callback : t -> S.flow -> unit Lwt.t 15 | val listen : S.t -> Conduit_mirage.server -> t -> unit Lwt.t 16 | end 17 | -------------------------------------------------------------------------------- /cohttp-mirage/src/static.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2012-2017 Anil Madhavapeddy 3 | * Copyright (c) 2013-2015 Thomas Gazagnaire 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | * 17 | * %%NAME%% %%VERSION%% 18 | *) 19 | 20 | (** Serve static HTTP sites from a Mirage key-value store. *) 21 | 22 | (** Plain HTTP file serving from a read-only key-value store. *) 23 | module HTTP (FS : Mirage_kv.RO) (S : Cohttp_lwt.S.Server) : sig 24 | (** [start http_port ?request_fn fs http] will start a static HTTP server 25 | listening on [http_port]. The files to serve will be looked up from the 26 | [fs] key-value store. 27 | 28 | If [request_fn] is supplied, the URI and default header set (including the 29 | MIME content-type header) will be passed to it and the response used as 30 | the response header set instead. *) 31 | 32 | val start : 33 | http_port:int -> 34 | ?request_fn:(Uri.t -> Http.Header.t -> Http.Header.t) -> 35 | FS.t -> 36 | ([> `TCP of int ] -> S.t -> 'a) -> 37 | 'a 38 | end 39 | -------------------------------------------------------------------------------- /cohttp-server-lwt-unix.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Lightweight Cohttp + Lwt based HTTP server" 4 | description: """ 5 | This server implementation is faster than cohttp-lwt-unix and is independent of 6 | conduit. 7 | """ 8 | maintainer: ["Anil Madhavapeddy "] 9 | authors: [ 10 | "Anil Madhavapeddy" 11 | "Stefano Zacchiroli" 12 | "David Sheets" 13 | "Thomas Gazagnaire" 14 | "David Scott" 15 | "Rudi Grinberg" 16 | "Andy Ray" 17 | "Anurag Soni" 18 | ] 19 | license: "ISC" 20 | homepage: "https://github.com/mirage/ocaml-cohttp" 21 | doc: "https://mirage.github.io/ocaml-cohttp/" 22 | bug-reports: "https://github.com/mirage/ocaml-cohttp/issues" 23 | depends: [ 24 | "dune" {>= "3.8"} 25 | "ocaml" {>= "4.08"} 26 | "http" {= version} 27 | "lwt" {>= "5.5.0"} 28 | "conduit-lwt-unix" {with-test} 29 | "cohttp-lwt-unix" {with-test & = version} 30 | "cohttp-lwt" {with-test & = version} 31 | "lwt" 32 | "odoc" {with-doc} 33 | ] 34 | dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git" 35 | build: [ 36 | ["dune" "subst"] {dev} 37 | [ 38 | "dune" 39 | "build" 40 | "-p" 41 | name 42 | "-j" 43 | jobs 44 | "@install" 45 | "@cohttp-server-lwt-unix/runtest" {with-test} 46 | "@doc" {with-doc} 47 | ] 48 | ] 49 | x-maintenance-intent: [ "(latest)" ] 50 | -------------------------------------------------------------------------------- /cohttp-server-lwt-unix.opam.template: -------------------------------------------------------------------------------- 1 | build: [ 2 | ["dune" "subst"] {dev} 3 | [ 4 | "dune" 5 | "build" 6 | "-p" 7 | name 8 | "-j" 9 | jobs 10 | "@install" 11 | "@cohttp-server-lwt-unix/runtest" {with-test} 12 | "@doc" {with-doc} 13 | ] 14 | ] 15 | x-maintenance-intent: [ "(latest)" ] 16 | -------------------------------------------------------------------------------- /cohttp-server-lwt-unix/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name cohttp_server_lwt_unix) 3 | (public_name cohttp-server-lwt-unix) 4 | (libraries lwt lwt.unix http http_bytebuffer)) 5 | -------------------------------------------------------------------------------- /cohttp-server-lwt-unix/test/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test) 3 | (package cohttp-server-lwt-unix) 4 | (libraries 5 | lwt.unix 6 | lwt 7 | http 8 | conduit-lwt-unix 9 | cohttp-lwt 10 | cohttp-lwt-unix 11 | cohttp-server-lwt-unix)) 12 | -------------------------------------------------------------------------------- /cohttp-server-lwt-unix/test/test.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Syntax 2 | 3 | let expected_response = "shutdown received" 4 | 5 | let http_server = 6 | let module Context = Cohttp_server_lwt_unix.Context in 7 | Cohttp_server_lwt_unix.create (fun ctx -> 8 | let* () = Context.discard_body ctx in 9 | let req = Context.request ctx in 10 | match Http.Request.resource req with 11 | | "/shutdown" -> 12 | let resp = Http.Response.make () in 13 | Context.respond ctx resp 14 | (Cohttp_server_lwt_unix.Body.string expected_response) 15 | | _ -> assert false) 16 | 17 | let fname = "test-lwt-unix" 18 | let delete_socket () = try Unix.unlink fname with Unix.Unix_error _ -> () 19 | 20 | let server () = 21 | delete_socket (); 22 | let sockaddr = Unix.ADDR_UNIX fname in 23 | Lwt_io.establish_server_with_client_address sockaddr (fun _ conn -> 24 | Cohttp_server_lwt_unix.handle_connection http_server conn) 25 | 26 | let client server = 27 | let uri = Uri.of_string "http://localhost/shutdown" in 28 | let ctx = 29 | let resolver = 30 | Resolver_lwt.init 31 | ~service:(fun _ -> 32 | Lwt.return_some { Resolver.name = "http"; port = 80; tls = false }) 33 | ~rewrites: 34 | [ ("localhost", fun _ _ -> Lwt.return (`Unix_domain_socket fname)) ] 35 | () 36 | in 37 | Cohttp_lwt_unix.Net.init ~resolver () 38 | in 39 | let* _, body = Cohttp_lwt_unix.Client.call ~ctx `GET uri in 40 | let* body = Cohttp_lwt.Body.to_string body in 41 | assert (String.equal body expected_response); 42 | Lwt_io.shutdown_server server 43 | 44 | let () = 45 | at_exit delete_socket; 46 | Lwt_main.run 47 | (let* server = server () in 48 | client server) 49 | -------------------------------------------------------------------------------- /cohttp-top.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "CoHTTP toplevel pretty printers for HTTP types" 4 | description: """ 5 | This library installs toplevel prettyprinters for CoHTTP 6 | types such as the `Request`, `Response` and `Types` modules. 7 | Once this library has been loaded, you can directly see the 8 | values of those types in toplevels such as `utop` or `ocaml`. 9 | """ 10 | maintainer: ["Anil Madhavapeddy "] 11 | authors: [ 12 | "Anil Madhavapeddy" 13 | "Stefano Zacchiroli" 14 | "David Sheets" 15 | "Thomas Gazagnaire" 16 | "David Scott" 17 | "Rudi Grinberg" 18 | "Andy Ray" 19 | "Anurag Soni" 20 | ] 21 | license: "ISC" 22 | homepage: "https://github.com/mirage/ocaml-cohttp" 23 | doc: "https://mirage.github.io/ocaml-cohttp/" 24 | bug-reports: "https://github.com/mirage/ocaml-cohttp/issues" 25 | depends: [ 26 | "dune" {>= "3.8"} 27 | "ocaml" {>= "4.08"} 28 | "cohttp" {= version} 29 | "odoc" {with-doc} 30 | ] 31 | dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git" 32 | build: [ 33 | ["dune" "subst"] {dev} 34 | [ 35 | "dune" 36 | "build" 37 | "-p" 38 | name 39 | "-j" 40 | jobs 41 | "@install" 42 | "@cohttp-top/runtest" {with-test} 43 | "@doc" {with-doc} 44 | ] 45 | ] 46 | x-maintenance-intent: [ "(latest)" ] 47 | -------------------------------------------------------------------------------- /cohttp-top.opam.template: -------------------------------------------------------------------------------- 1 | build: [ 2 | ["dune" "subst"] {dev} 3 | [ 4 | "dune" 5 | "build" 6 | "-p" 7 | name 8 | "-j" 9 | jobs 10 | "@install" 11 | "@cohttp-top/runtest" {with-test} 12 | "@doc" {with-doc} 13 | ] 14 | ] 15 | x-maintenance-intent: [ "(latest)" ] 16 | -------------------------------------------------------------------------------- /cohttp-top/src/cohttp_top.ml: -------------------------------------------------------------------------------- 1 | let printers = 2 | [ "Cohttp.Header.pp_hum"; "Cohttp.Request.pp_hum"; "Cohttp.Response.pp_hum" ] 3 | 4 | let eval_string ?(print_outcome = false) ?(err_formatter = Format.err_formatter) 5 | str = 6 | let lexbuf = Lexing.from_string str in 7 | let phrase = !Toploop.parse_toplevel_phrase lexbuf in 8 | Toploop.execute_phrase print_outcome err_formatter phrase 9 | 10 | let rec install_printers = function 11 | | [] -> true 12 | | printer :: printers -> 13 | let cmd = Printf.sprintf "#install_printer %s;;" printer in 14 | eval_string cmd && install_printers printers 15 | 16 | let () = 17 | if not (install_printers printers) then 18 | Format.eprintf "Problem installing Cohttp-printers@." 19 | -------------------------------------------------------------------------------- /cohttp-top/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name cohttp_top) 3 | (public_name cohttp-top) 4 | (libraries cohttp compiler-libs.toplevel)) 5 | -------------------------------------------------------------------------------- /cohttp.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "An OCaml library for HTTP clients and servers" 4 | description: """ 5 | Cohttp is an OCaml library for creating HTTP daemons. It has a portable 6 | HTTP parser, and implementations using various asynchronous programming 7 | libraries. 8 | 9 | See the cohttp-async, cohttp-lwt, cohttp-lwt-unix, cohttp-lwt-jsoo and 10 | cohttp-mirage libraries for concrete implementations for particular 11 | targets. 12 | 13 | You can implement other targets using the parser very easily. Look at the `IO` 14 | signature in `lib/s.mli` and implement that in the desired backend. 15 | 16 | You can activate some runtime debugging by setting `COHTTP_DEBUG` to any 17 | value, and all requests and responses will be written to stderr. Further 18 | debugging of the connection layer can be obtained by setting `CONDUIT_DEBUG` 19 | to any value. 20 | """ 21 | maintainer: ["Anil Madhavapeddy "] 22 | authors: [ 23 | "Anil Madhavapeddy" 24 | "Stefano Zacchiroli" 25 | "David Sheets" 26 | "Thomas Gazagnaire" 27 | "David Scott" 28 | "Rudi Grinberg" 29 | "Andy Ray" 30 | "Anurag Soni" 31 | ] 32 | license: "ISC" 33 | homepage: "https://github.com/mirage/ocaml-cohttp" 34 | doc: "https://mirage.github.io/ocaml-cohttp/" 35 | bug-reports: "https://github.com/mirage/ocaml-cohttp/issues" 36 | depends: [ 37 | "dune" {>= "3.8"} 38 | "http" {= version} 39 | "ocaml" {>= "4.08"} 40 | "re" {>= "1.9.0"} 41 | "uri" {>= "2.0.0"} 42 | "uri-sexp" 43 | "logs" 44 | "sexplib0" 45 | "ppx_sexp_conv" {>= "v0.13.0"} 46 | "stringext" 47 | "base64" {>= "3.1.0"} 48 | "fmt" {with-test} 49 | "alcotest" {with-test & >= "1.7.0"} 50 | "odoc" {with-doc} 51 | ] 52 | dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git" 53 | build: [ 54 | ["dune" "subst"] {dev} 55 | [ 56 | "dune" 57 | "build" 58 | "-p" 59 | name 60 | "-j" 61 | jobs 62 | "@install" 63 | "@cohttp/runtest" {with-test} 64 | "@doc" {with-doc} 65 | ] 66 | ] 67 | x-maintenance-intent: [ "(latest)" ] 68 | -------------------------------------------------------------------------------- /cohttp.opam.template: -------------------------------------------------------------------------------- 1 | build: [ 2 | ["dune" "subst"] {dev} 3 | [ 4 | "dune" 5 | "build" 6 | "-p" 7 | name 8 | "-j" 9 | jobs 10 | "@install" 11 | "@cohttp/runtest" {with-test} 12 | "@doc" {with-doc} 13 | ] 14 | ] 15 | x-maintenance-intent: [ "(latest)" ] 16 | -------------------------------------------------------------------------------- /cohttp/src/accept.mli: -------------------------------------------------------------------------------- 1 | (*{{{ Copyright (C) 2012, David Sheets 2 | 3 | Permission to use, copy, modify, and/or distribute this software for 4 | any purpose with or without fee is hereby granted, provided that the 5 | above copyright notice and this permission notice appear in all 6 | copies. 7 | 8 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL 9 | WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED 10 | WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE 11 | AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL 12 | DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA 13 | OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER 14 | TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR 15 | PERFORMANCE OF THIS SOFTWARE. 16 | }}}*) 17 | 18 | (** Accept-Encoding HTTP header parsing and generation *) 19 | 20 | type q = int [@@deriving sexp] 21 | (** Qualities are integers between 0 and 1000. A header with ["q=0.7"] 22 | corresponds to a quality of [700]. *) 23 | 24 | type 'a qlist = (q * 'a) list [@@deriving sexp] 25 | (** Lists, annotated with qualities. *) 26 | 27 | val qsort : 'a qlist -> 'a qlist 28 | (** Sort by quality, biggest first. Respect the initial ordering. *) 29 | 30 | type p = string * string [@@deriving sexp] 31 | 32 | type media_range = Accept_types.media_range = 33 | | MediaType of string * string 34 | | AnyMediaSubtype of string 35 | | AnyMedia 36 | [@@deriving sexp] 37 | 38 | type charset = Accept_types.charset = Charset of string | AnyCharset 39 | [@@deriving sexp] 40 | 41 | type encoding = Accept_types.encoding = 42 | | Encoding of string 43 | | Gzip 44 | | Compress 45 | | Deflate 46 | | Identity 47 | | AnyEncoding 48 | [@@deriving sexp] 49 | 50 | (** Basic language range tag. ["en-gb"] is represented as 51 | [Language ["en"; "gb"]]. 52 | 53 | @see the specification. 54 | *) 55 | type language = Accept_types.language = Language of string list | AnyLanguage 56 | [@@deriving sexp] 57 | 58 | val media_ranges : string option -> (media_range * p list) qlist 59 | val charsets : string option -> charset qlist 60 | val encodings : string option -> encoding qlist 61 | val languages : string option -> language qlist 62 | val string_of_media_range : media_range * p list -> q -> string 63 | val string_of_charset : charset -> q -> string 64 | val string_of_encoding : encoding -> q -> string 65 | val string_of_language : language -> q -> string 66 | val string_of_media_ranges : (media_range * p list) qlist -> string 67 | val string_of_charsets : charset qlist -> string 68 | val string_of_encodings : encoding qlist -> string 69 | val string_of_languages : language qlist -> string 70 | -------------------------------------------------------------------------------- /cohttp/src/accept_lexer.mll: -------------------------------------------------------------------------------- 1 | (*{{{ Copyright (C) 2012, David Sheets 2 | 3 | Permission to use, copy, modify, and/or distribute this software for 4 | any purpose with or without fee is hereby granted, provided that the 5 | above copyright notice and this permission notice appear in all 6 | copies. 7 | 8 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL 9 | WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED 10 | WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE 11 | AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL 12 | DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA 13 | OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER 14 | TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR 15 | PERFORMANCE OF THIS SOFTWARE. 16 | }}}*) 17 | { 18 | open Accept_parser 19 | } 20 | 21 | (* *) 22 | let token = [^'('')''<''>''@'','';'':''\\''"''/''['']''?''=''{''}'' ''\t'] 23 | 24 | rule header_value = parse 25 | | '*' { STAR } 26 | | '/' { SLASH } 27 | | ';' { SEMI } 28 | | ',' { COMMA } 29 | | '=' { EQUAL } 30 | | '\"' { QS (List.fold_right (^) (qs [] lexbuf) "") } 31 | | (token)+ as tok { TOK tok } 32 | | ' ' { header_value lexbuf } 33 | | eof { EOI } 34 | and qs sl = parse 35 | | "\\\"" { qs ("\""::sl) lexbuf } 36 | | "\"" { sl } 37 | | [^'"']+ as s { qs (s::sl) lexbuf } 38 | -------------------------------------------------------------------------------- /cohttp/src/accept_types.ml: -------------------------------------------------------------------------------- 1 | (*{{{ Copyright (C) 2012, David Sheets 2 | 3 | Permission to use, copy, modify, and/or distribute this software for 4 | any purpose with or without fee is hereby granted, provided that the 5 | above copyright notice and this permission notice appear in all 6 | copies. 7 | 8 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL 9 | WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED 10 | WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE 11 | AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL 12 | DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA 13 | OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER 14 | TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR 15 | PERFORMANCE OF THIS SOFTWARE. 16 | }}}*) 17 | 18 | (** Type definitions for the {!Accept} module *) 19 | 20 | open Sexplib0.Sexp_conv 21 | 22 | type p = string * string [@@deriving sexp] 23 | 24 | type media_range = 25 | | MediaType of string * string 26 | | AnyMediaSubtype of string 27 | | AnyMedia 28 | [@@deriving sexp] 29 | 30 | type charset = Charset of string | AnyCharset [@@deriving sexp] 31 | 32 | type encoding = 33 | | Encoding of string 34 | | Gzip 35 | | Compress 36 | | Deflate 37 | | Identity 38 | | AnyEncoding 39 | [@@deriving sexp] 40 | 41 | type language = Language of string list | AnyLanguage [@@deriving sexp] 42 | type q = int [@@deriving sexp] 43 | type 'a qlist = (q * 'a) list [@@deriving sexp] 44 | -------------------------------------------------------------------------------- /cohttp/src/auth.ml: -------------------------------------------------------------------------------- 1 | (*{{{ Copyright (c) 2012 Anil Madhavapeddy 2 | * 3 | * Permission to use, copy, modify, and distribute this software for any 4 | * purpose with or without fee is hereby granted, provided that the above 5 | * copyright notice and this permission notice appear in all copies. 6 | * 7 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | * 15 | }}}*) 16 | 17 | open Sexplib0.Sexp_conv 18 | open Printf 19 | 20 | type challenge = [ `Basic of string (* realm *) ] [@@deriving sexp] 21 | 22 | type credential = 23 | [ `Basic of string * string (* username, password *) | `Other of string ] 24 | [@@deriving sexp] 25 | 26 | let string_of_credential (cred : credential) = 27 | match cred with 28 | | `Basic (user, pass) -> 29 | "Basic " ^ Base64.encode_string (sprintf "%s:%s" user pass) 30 | | `Other buf -> buf 31 | 32 | let credential_of_string (buf : string) : credential = 33 | try 34 | let b64 = Scanf.sscanf buf "Basic %s" (fun b -> b) in 35 | match Stringext.split ~on:':' (Base64.decode_exn b64) ~max:2 with 36 | | [ user; pass ] -> `Basic (user, pass) 37 | | _ -> `Other buf 38 | with _ -> `Other buf 39 | 40 | let string_of_challenge (ty : challenge) = 41 | match ty with `Basic realm -> sprintf "Basic realm=\"%s\"" realm 42 | -------------------------------------------------------------------------------- /cohttp/src/auth.mli: -------------------------------------------------------------------------------- 1 | (*{{{ Copyright (c) 2012-2014 Anil Madhavapeddy 2 | * 3 | * Permission to use, copy, modify, and distribute this software for any 4 | * purpose with or without fee is hereby granted, provided that the above 5 | * copyright notice and this permission notice appear in all copies. 6 | * 7 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | * 15 | }}}*) 16 | 17 | (** HTTP Authentication and Authorization header parsing and generation *) 18 | 19 | type challenge = [ `Basic of string (** Basic authentication within a realm *) ] 20 | [@@deriving sexp] 21 | (** HTTP authentication challenge types *) 22 | 23 | type credential = 24 | [ `Basic of string * string 25 | (** Basic authorization with a username and password *) 26 | | `Other of string 27 | (** An unknown credential type that will be passed straight through to the 28 | application layer *) ] 29 | [@@deriving sexp] 30 | (** HTTP authorization credential types *) 31 | 32 | val string_of_credential : credential -> string 33 | (** [string_of_credential] converts the {!credential} to a string compatible 34 | with the HTTP/1.1 wire format for authorization credentials ("responses") *) 35 | 36 | val credential_of_string : string -> credential 37 | (** [credential_of_string cred_s] converts an HTTP response to an authentication 38 | challenge into a {!credential}. If the credential is not recognized, 39 | [`Other cred_s] is returned. *) 40 | 41 | val string_of_challenge : challenge -> string 42 | (** [string_of_challenge challenge] converts the {!challenge} to a string 43 | compatible with the HTTP/1.1 wire format for authentication challenges. 44 | 45 | For example, a [`Basic] challenge with realm ["foo"] will be marshalled to 46 | ["Basic realm=foo"], which can then be combined with a [www-authenticate] 47 | HTTP header and sent back to the client. There is a helper function 48 | {!Header.add_authorization_req} that does just this. *) 49 | -------------------------------------------------------------------------------- /cohttp/src/body.ml: -------------------------------------------------------------------------------- 1 | (*{{{ Copyright (c) 2014 Rudi Grinberg 2 | * 3 | * Permission to use, copy, modify, and distribute this software for any 4 | * purpose with or without fee is hereby granted, provided that the above 5 | * copyright notice and this permission notice appear in all copies. 6 | * 7 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | * 15 | }}}*) 16 | 17 | open Sexplib0.Sexp_conv 18 | 19 | type t = [ `Empty | `String of string | `Strings of string list ] 20 | [@@deriving sexp] 21 | 22 | let empty = `Empty 23 | 24 | let is_empty = function 25 | | `Empty | `String "" -> true 26 | | `String _ -> false 27 | | `Strings xs -> ( 28 | match List.filter (fun s -> s <> "") xs with [] -> true | _ -> false) 29 | 30 | let to_string = function 31 | | `Empty -> "" 32 | | `String s -> s 33 | | `Strings sl -> String.concat "" sl 34 | 35 | let to_string_list = function 36 | | `Empty -> [] 37 | | `String s -> [ s ] 38 | | `Strings sl -> sl 39 | 40 | let of_string s = `String s 41 | let of_string_list s = `Strings s 42 | 43 | let transfer_encoding = function 44 | | `Empty -> Transfer.Fixed 0L 45 | | `String s -> Transfer.Fixed (Int64.of_int (String.length s)) 46 | | `Strings _ -> Transfer.Chunked 47 | 48 | let length = function 49 | | `Empty -> 0L 50 | | `String s -> Int64.of_int (String.length s) 51 | | `Strings sl -> 52 | sl 53 | |> List.fold_left 54 | (fun a b -> b |> String.length |> Int64.of_int |> Int64.add a) 55 | 0L 56 | 57 | let map f = function 58 | | `Empty -> `Empty 59 | | `String s -> `String (f s) 60 | | `Strings sl -> `Strings (List.map f sl) 61 | 62 | let to_form t = Uri.query_of_encoded (to_string t) 63 | let of_form ?scheme f = Uri.encoded_of_query ?scheme f |> of_string 64 | 65 | (* TODO: maybe add a functor here that uses IO.S *) 66 | -------------------------------------------------------------------------------- /cohttp/src/body.mli: -------------------------------------------------------------------------------- 1 | (*{{{ Copyright (c) 2014 Rudi Grinberg 2 | * Copyright (c) 2014 Anil Madhavapeddy 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | }}}*) 17 | 18 | (** HTTP request and response body handling *) 19 | 20 | type t = [ `Empty | `String of string | `Strings of string list ] 21 | [@@deriving sexp] 22 | (** Every HTTP body can at least be an empty value or a [string] *) 23 | 24 | include S.Body with type t := t 25 | (** Signature for the core of HTTP body handling. Implementations will extend 26 | this signature to add more functions for streaming responses via 27 | backend-specific functionality. *) 28 | 29 | val length : t -> int64 30 | -------------------------------------------------------------------------------- /cohttp/src/client.ml: -------------------------------------------------------------------------------- 1 | (** The [Client] module is a collection of convenience functions for 2 | constructing and processing requests. *) 3 | module type BASE = sig 4 | type +'a io 5 | type 'a with_context 6 | type body 7 | 8 | val map_context : 'a with_context -> ('a -> 'b) -> 'b with_context 9 | 10 | val call : 11 | (?headers:Http.Header.t -> 12 | ?body:body -> 13 | ?chunked:bool -> 14 | Http.Method.t -> 15 | Uri.t -> 16 | (Http.Response.t * body) io) 17 | with_context 18 | (** [call ?headers ?body ?chunked meth uri] 19 | 20 | @return 21 | [(response, response_body)] Consume [response_body] in a timely fashion. 22 | Please see {!val:call} about how and why. 23 | @param chunked 24 | use chunked encoding if [true]. The default is [false] for compatibility 25 | reasons. *) 26 | end 27 | 28 | module type S = sig 29 | include BASE 30 | 31 | val head : 32 | (?headers:Http.Header.t -> Uri.t -> Http.Response.t io) with_context 33 | 34 | val get : 35 | (?headers:Http.Header.t -> Uri.t -> (Http.Response.t * body) io) 36 | with_context 37 | 38 | val delete : 39 | (?body:body -> 40 | ?chunked:bool -> 41 | ?headers:Http.Header.t -> 42 | Uri.t -> 43 | (Http.Response.t * body) io) 44 | with_context 45 | 46 | val post : 47 | (?body:body -> 48 | ?chunked:bool -> 49 | ?headers:Http.Header.t -> 50 | Uri.t -> 51 | (Http.Response.t * body) io) 52 | with_context 53 | 54 | val put : 55 | (?body:body -> 56 | ?chunked:bool -> 57 | ?headers:Http.Header.t -> 58 | Uri.t -> 59 | (Http.Response.t * body) io) 60 | with_context 61 | 62 | val patch : 63 | (?body:body -> 64 | ?chunked:bool -> 65 | ?headers:Http.Header.t -> 66 | Uri.t -> 67 | (Http.Response.t * body) io) 68 | with_context 69 | end 70 | 71 | module Make (Base : BASE) (IO : S.IO with type 'a t = 'a Base.io) = struct 72 | include Base 73 | open IO 74 | 75 | let call = 76 | map_context call (fun call ?headers ?body ?chunked meth uri -> 77 | let () = 78 | Logs.info (fun m -> m "%a %a" Http.Method.pp meth Uri.pp uri) 79 | in 80 | call ?headers ?body ?chunked meth uri) 81 | 82 | let delete = 83 | map_context call (fun call ?body ?chunked ?headers uri -> 84 | call ?body ?chunked ?headers `DELETE uri) 85 | 86 | let get = map_context call (fun call ?headers uri -> call ?headers `GET uri) 87 | 88 | let head = 89 | map_context call (fun call ?headers uri -> 90 | call ?headers `HEAD uri >>= fun (response, _body) -> return response) 91 | 92 | let patch = 93 | map_context call (fun call ?body ?chunked ?headers uri -> 94 | call ?body ?chunked ?headers `PATCH uri) 95 | 96 | let post = 97 | map_context call (fun call ?body ?chunked ?headers uri -> 98 | call ?body ?chunked ?headers `POST uri) 99 | 100 | let put = 101 | map_context call (fun call ?body ?chunked ?headers uri -> 102 | call ?body ?chunked ?headers `PUT uri) 103 | end 104 | -------------------------------------------------------------------------------- /cohttp/src/cohttp.ml: -------------------------------------------------------------------------------- 1 | module Accept = Accept 2 | module Auth = Auth 3 | module Body = Body 4 | module Conf = Conf 5 | module Connection = Connection [@@deprecated "Connection.t values are useless."] 6 | module Code = Code 7 | module Cookie = Cookie 8 | module Header = Header 9 | module Link = Link 10 | module Request = Request 11 | module Response = Response 12 | module S = S 13 | module Path = Path 14 | module Transfer = Transfer 15 | 16 | module Generic = struct 17 | module Client = Client 18 | module Server = Server 19 | end 20 | 21 | module Private = struct 22 | module Transfer_io = Transfer_io 23 | module String_io = String_io 24 | module Header_io = Header_io 25 | end 26 | -------------------------------------------------------------------------------- /cohttp/src/conf.mli: -------------------------------------------------------------------------------- 1 | (*{{{ Copyright (c) 2015 Christophe Troestler 2 | * Copyright (c) 2015 Anil Madhavapeddy 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | }}}*) 17 | 18 | (** Compile-time configuration variables *) 19 | 20 | val version : string 21 | (** The version number of this library. *) 22 | -------------------------------------------------------------------------------- /cohttp/src/connection.ml: -------------------------------------------------------------------------------- 1 | (*{{{ Copyright (c) 2012-2013 Anil Madhavapeddy 2 | * Copyright (c) 2013 Thomas Gazagnaire 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | }}}*) 17 | open Sexplib0.Sexp_conv 18 | 19 | type t = int [@@deriving sexp] 20 | 21 | let to_string = string_of_int 22 | let count = ref 0 23 | 24 | let create () = 25 | incr count; 26 | !count 27 | 28 | let compare (a : t) (b : t) = Stdlib.compare a b 29 | -------------------------------------------------------------------------------- /cohttp/src/connection.mli: -------------------------------------------------------------------------------- 1 | (*{{{ Copyright (c) 2012-2013 Anil Madhavapeddy 2 | * Copyright (c) 2013 Thomas Gazagnaire 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | }}}*) 17 | 18 | (** Connection identifiers. *) 19 | 20 | type t [@@deriving sexp] 21 | (** Abstract type for connection identifiers. *) 22 | 23 | val create : unit -> t 24 | (** Create a fresh connection identifier. *) 25 | 26 | val to_string : t -> string 27 | (** Pretty-print a connection identifier. *) 28 | 29 | val compare : t -> t -> int 30 | (** Comparison function for two identifiers. More recently constructed 31 | identifiers will be greater than older ones. *) 32 | -------------------------------------------------------------------------------- /cohttp/src/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (with-stdout-to 3 | conf.ml 4 | (echo "let version = \"%{version:cohttp}\""))) 5 | 6 | (library 7 | (name cohttp) 8 | (public_name cohttp) 9 | (synopsis "Co-operative Client/Server HTTP library.") 10 | (preprocess 11 | (pps ppx_sexp_conv)) 12 | (libraries 13 | base64 14 | logs 15 | (re_export http) 16 | re 17 | sexplib0 18 | stringext 19 | uri 20 | uri-sexp 21 | uri.services)) 22 | 23 | (ocamllex accept_lexer) 24 | 25 | (ocamlyacc accept_parser) 26 | -------------------------------------------------------------------------------- /cohttp/src/header_io.ml: -------------------------------------------------------------------------------- 1 | (*{{{ Copyright (c) 2012-2013 Anil Madhavapeddy 2 | * Copyright (c) 2011-2012 Martin Jambon 3 | * Copyright (c) 2010 Mika Illouz 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | * 17 | }}}*) 18 | 19 | let split_header str = 20 | match Stringext.split ~max:2 ~on:':' str with 21 | | [ x; y ] -> [ x; String.trim y ] 22 | | x -> x 23 | 24 | module Make (IO : S.IO) = struct 25 | open IO 26 | module Transfer_IO = Transfer_io.Make (IO) 27 | 28 | let parse ic = 29 | (* consume also trailing "^\r\n$" line *) 30 | let rec parse_headers' headers = 31 | read_line ic >>= function 32 | | Some "" | None -> return headers 33 | | Some line -> ( 34 | match split_header line with 35 | | [ hd; tl ] -> parse_headers' (Header.add headers hd tl) 36 | | _ -> return headers) 37 | in 38 | parse_headers' (Header.init ()) 39 | 40 | let write headers oc = IO.write oc (Header.to_string headers) 41 | end 42 | -------------------------------------------------------------------------------- /cohttp/src/header_io.mli: -------------------------------------------------------------------------------- 1 | (*{{{ Copyright (c) 2012-2013 Anil Madhavapeddy 2 | * 3 | * Permission to use, copy, modify, and distribute this software for any 4 | * purpose with or without fee is hereby granted, provided that the above 5 | * copyright notice and this permission notice appear in all copies. 6 | * 7 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | * 15 | }}}*) 16 | 17 | module Make (IO : S.IO) : sig 18 | val parse : IO.ic -> Header.t IO.t 19 | val write : Header.t -> IO.oc -> unit IO.t 20 | end 21 | -------------------------------------------------------------------------------- /cohttp/src/path.ml: -------------------------------------------------------------------------------- 1 | let resolve_local_file ~docroot ~uri = 2 | let path = Uri.(pct_decode (path (resolve "http" (of_string "/") uri))) in 3 | let rel_path = 4 | if String.length path > 0 then String.sub path 1 (String.length path - 1) 5 | else "" 6 | in 7 | Filename.concat docroot rel_path 8 | -------------------------------------------------------------------------------- /cohttp/src/path.mli: -------------------------------------------------------------------------------- 1 | val resolve_local_file : docroot:string -> uri:Uri.t -> string 2 | (** Resolve the given URI to a local file in the given docroot. 3 | 4 | This decodes and normalises the Uri. It strips out .. characters so that the 5 | request will not escape the docroot. The returned filepath is fully 6 | qualified iff the given docroot is fully qualified. *) 7 | -------------------------------------------------------------------------------- /cohttp/src/request.mli: -------------------------------------------------------------------------------- 1 | (*{{{ Copyright (c) 2012-2014 Anil Madhavapeddy 2 | * 3 | * Permission to use, copy, modify, and distribute this software for any 4 | * purpose with or without fee is hereby granted, provided that the above 5 | * copyright notice and this permission notice appear in all copies. 6 | * 7 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | * 15 | }}}*) 16 | 17 | (** HTTP/1.1 request handling *) 18 | 19 | include S.Request with type t = Http.Request.t 20 | (** This contains the metadata for a HTTP/1.x request header, including the 21 | {!field-headers}, {!field-version}, {!field-meth} and {!field-uri}. The body 22 | is handled by the separate {!S} module type, as it is dependent on the IO 23 | implementation. 24 | 25 | The interface exposes a [fieldslib] interface which provides individual 26 | accessor functions for each of the records below. It also provides [sexp] 27 | serializers to convert to-and-from an {!Core.Std.Sexp.t}. *) 28 | 29 | val has_body : t -> [ `No | `Unknown | `Yes ] 30 | 31 | val pp_hum : Format.formatter -> t -> unit 32 | (** Human-readable output, used by the toplevel printer *) 33 | 34 | module Make (IO : S.IO) : S.Http_io with type t = t and module IO = IO 35 | [@@deprecated "This functor is not part of the public API."] 36 | 37 | module Private : sig 38 | module Make (IO : S.IO) : S.Http_io with type t = t and module IO = IO 39 | end 40 | -------------------------------------------------------------------------------- /cohttp/src/response.mli: -------------------------------------------------------------------------------- 1 | (*{{{ Copyright (c) 2012 Anil Madhavapeddy 2 | * 3 | * Permission to use, copy, modify, and distribute this software for any 4 | * purpose with or without fee is hereby granted, provided that the above 5 | * copyright notice and this permission notice appear in all copies. 6 | * 7 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | * 15 | }}}*) 16 | 17 | (** HTTP/1.1 response handling *) 18 | 19 | include S.Response with type t = Http.Response.t 20 | (** This contains the metadata for a HTTP/1.1 response header, including the 21 | {!field-encoding}, {!field-headers}, {!field-version}, {!field-status} code 22 | and whether to flush the connection after every body chunk (useful for 23 | server-side events and other long-lived connection protocols). The body is 24 | handled by the separate {!S} module type, as it is dependent on the IO 25 | implementation. 26 | 27 | The interface exposes a [fieldslib] interface which provides individual 28 | accessor functions for each of the records below. It also provides [sexp] 29 | serializers to convert to-and-from an {!Core.Std.Sexp.t}. *) 30 | 31 | val has_body : t -> [ `No | `Unknown | `Yes ] 32 | 33 | val pp_hum : Format.formatter -> t -> unit 34 | (** Human-readable output, used by the toplevel printer *) 35 | 36 | module Make (IO : S.IO) : S.Http_io with type t = t and module IO = IO 37 | [@@deprecated "This functor is not part of the public API."] 38 | 39 | module Private : sig 40 | module Make (IO : S.IO) : S.Http_io with type t = t and module IO = IO 41 | end 42 | -------------------------------------------------------------------------------- /cohttp/src/server.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | module IO : S.IO 3 | 4 | type body 5 | type conn = IO.conn * Connection.t [@@warning "-3"] 6 | type response 7 | 8 | type response_action = 9 | [ `Expert of Http.Response.t * (IO.ic -> IO.oc -> unit IO.t) 10 | | `Response of response ] 11 | (** A request handler can respond in two ways: 12 | 13 | - Using [`Response], with a {!Response.t} and a {!body}. 14 | - Using [`Expert], with a {!Response.t} and an IO function that is 15 | expected to write the response body. The IO function has access to the 16 | underlying {!IO.ic} and {!IO.oc}, which allows writing a response body 17 | more efficiently, stream a response or to switch protocols entirely 18 | (e.g. websockets). Processing of pipelined requests continue after the 19 | [unit IO.t] is resolved. The connection can be closed by closing the 20 | {!IO.ic}. *) 21 | 22 | type t 23 | 24 | val make_response_action : 25 | ?conn_closed:(conn -> unit) -> 26 | callback:(conn -> Http.Request.t -> body -> response_action IO.t) -> 27 | unit -> 28 | t 29 | 30 | val make_expert : 31 | ?conn_closed:(conn -> unit) -> 32 | callback: 33 | (conn -> 34 | Http.Request.t -> 35 | body -> 36 | (Http.Response.t * (IO.ic -> IO.oc -> unit IO.t)) IO.t) -> 37 | unit -> 38 | t 39 | 40 | val make : 41 | ?conn_closed:(conn -> unit) -> 42 | callback:(conn -> Http.Request.t -> body -> response IO.t) -> 43 | unit -> 44 | t 45 | 46 | val respond : 47 | ?headers:Http.Header.t -> 48 | status:Http.Status.t -> 49 | body:body -> 50 | unit -> 51 | response IO.t 52 | (** [respond ?headers ~status ~body] will respond to an HTTP request with the 53 | given [status] code and response [body]. The transfer encoding will be 54 | detected from the [body] value and set to chunked encoding if it cannot be 55 | determined immediately. You can override the encoding by supplying an 56 | appropriate [Content-length] or [Transfer-encoding] in the [headers] 57 | parameter. *) 58 | 59 | val respond_string : 60 | ?headers:Http.Header.t -> 61 | status:Http.Status.t -> 62 | body:string -> 63 | unit -> 64 | response IO.t 65 | 66 | val callback : t -> IO.conn -> IO.ic -> IO.oc -> unit IO.t 67 | end 68 | -------------------------------------------------------------------------------- /cohttp/src/string_io.ml: -------------------------------------------------------------------------------- 1 | (*{{{ Copyright (c) 2014 Andy Ray 2 | * Copyright (c) 2014 Anil Madhavapeddy 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | }}}*) 17 | 18 | (* input channel type - a string with a (file) position and length *) 19 | type buf = { str : string; mutable pos : int; len : int } 20 | 21 | let open_in str = { str; pos = 0; len = String.length str } 22 | 23 | module M = struct 24 | type 'a t = 'a 25 | 26 | let return a = a 27 | 28 | type conn = buf 29 | 30 | let ( >>= ) = ( |> ) 31 | 32 | type ic = buf 33 | 34 | (* output channels are just buffers *) 35 | type oc = Buffer.t 36 | 37 | (* the following read/write logic has only been lightly tested... *) 38 | let read_rest x = 39 | let s = String.sub x.str x.pos (x.len - x.pos) in 40 | x.pos <- x.len; 41 | s 42 | 43 | let read_line' x = 44 | if x.pos < x.len then 45 | let start = x.pos in 46 | try 47 | while x.str.[x.pos] != '\n' do 48 | x.pos <- x.pos + 1 49 | done; 50 | let l = 51 | if x.pos > 0 && x.str.[x.pos - 1] = '\r' then x.pos - start - 1 52 | else x.pos - start 53 | in 54 | let s = String.sub x.str start l in 55 | x.pos <- x.pos + 1; 56 | Some s 57 | with _ -> Some (read_rest x) 58 | else None 59 | 60 | let read_line x = return (read_line' x) 61 | 62 | let read_exactly' x n = 63 | if x.len - x.pos < n then None 64 | else 65 | let s = String.sub x.str x.pos n in 66 | x.pos <- x.pos + n; 67 | Some s 68 | 69 | let refill _ = `Eof 70 | 71 | let with_input_buffer t ~f = 72 | let res, count = f t.str ~pos:t.pos ~len:(t.len - t.pos) in 73 | t.pos <- t.pos + count; 74 | res 75 | 76 | let read x n = 77 | match read_exactly' x n with 78 | | None when x.pos >= x.len -> raise End_of_file 79 | | None -> return (read_rest x) 80 | | Some x -> return x 81 | 82 | let write x s = 83 | Buffer.add_string x s; 84 | return () 85 | 86 | let flush _x = return () 87 | end 88 | -------------------------------------------------------------------------------- /cohttp/src/string_io.mli: -------------------------------------------------------------------------------- 1 | (*{{{ Copyright (c) 2014 Andy Ray 2 | * Copyright (c) 2014 Anil Madhavapeddy 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | }}}*) 17 | 18 | (** IO implementation that uses strings to marshal and unmarshal HTTP *) 19 | 20 | type buf = { str : string; mutable pos : int; len : int } 21 | (** The buffer structured used to keep track of where in the string the library 22 | is currently reading from *) 23 | 24 | val open_in : string -> buf 25 | (** [open_in s] will make the string [s] available as a [buf] that can be parsed 26 | via Cohttp *) 27 | 28 | (** IO interface that uses {!buf} for input data and queues output data into a 29 | {!Buffer.t} *) 30 | module M : S.IO with type 'a t = 'a and type ic = buf and type oc = Buffer.t 31 | -------------------------------------------------------------------------------- /cohttp/src/transfer.ml: -------------------------------------------------------------------------------- 1 | (*{{{ Copyright (c) 2012 Anil Madhavapeddy 2 | * 3 | * Permission to use, copy, modify, and distribute this software for any 4 | * purpose with or without fee is hereby granted, provided that the above 5 | * copyright notice and this permission notice appear in all copies. 6 | * 7 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | * 15 | }}}*) 16 | 17 | open Sexplib0.Sexp_conv 18 | 19 | type encoding = Http.Transfer.encoding = Chunked | Fixed of int64 | Unknown 20 | [@@deriving sexp] 21 | 22 | let pp_encoding fmt = function 23 | | Chunked -> Format.pp_print_string fmt "chunked" 24 | | Fixed size -> Format.fprintf fmt "fixed %Ld" size 25 | | Unknown -> Format.pp_print_string fmt "unknown" 26 | 27 | type chunk = Chunk of string | Final_chunk of string | Done [@@deriving sexp] 28 | 29 | let string_of_encoding = function 30 | | Chunked -> "chunked" 31 | | Fixed i -> Printf.sprintf "fixed[%Ld]" i 32 | | Unknown -> "unknown" 33 | 34 | let has_body = Http.Transfer.Private.has_body 35 | -------------------------------------------------------------------------------- /cohttp/src/transfer.mli: -------------------------------------------------------------------------------- 1 | (*{{{ Copyright (c) 2012-2014 Anil Madhavapeddy 2 | * 3 | * Permission to use, copy, modify, and distribute this software for any 4 | * purpose with or without fee is hereby granted, provided that the above 5 | * copyright notice and this permission notice appear in all copies. 6 | * 7 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | * 15 | }}}*) 16 | 17 | (** Read and write the HTTP/1.1 transfer-encoding formats. Currently supported 18 | are [chunked] and [content-length]. *) 19 | 20 | (** The encoding format detected from the [transfer-encoding] and 21 | [content-length] headers *) 22 | type encoding = Http.Transfer.encoding = 23 | | Chunked (** dynamic chunked encoding *) 24 | | Fixed of int64 (** fixed size content *) 25 | | Unknown (** unknown body size, which leads to best-effort *) 26 | [@@deriving sexp] 27 | 28 | val pp_encoding : Format.formatter -> encoding -> unit 29 | (** Human-readable output. *) 30 | 31 | (** A chunk of body that also signals if there to more to arrive *) 32 | type chunk = 33 | | Chunk of string (** chunk of data and not the end of stream *) 34 | | Final_chunk of string 35 | (** the last chunk of data, so no more should be read *) 36 | | Done (** no more body data is present *) 37 | [@@deriving sexp] 38 | 39 | val string_of_encoding : encoding -> string 40 | (** Convert the encoding format to a human-readable string *) 41 | 42 | val has_body : encoding -> [ `No | `Unknown | `Yes ] 43 | (** [has_body encoding] returns the appropriate variant that indicates whether 44 | the HTTP request or response has an associated body. It does not guess: 45 | instead [Unknown] is returned if there is no explicit association. *) 46 | -------------------------------------------------------------------------------- /cohttp/src/transfer_io.mli: -------------------------------------------------------------------------------- 1 | (*{{{ Copyright (c) 2012 Anil Madhavapeddy 2 | * 3 | * Permission to use, copy, modify, and distribute this software for any 4 | * purpose with or without fee is hereby granted, provided that the above 5 | * copyright notice and this permission notice appear in all copies. 6 | * 7 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | * 15 | }}}*) 16 | 17 | open Transfer 18 | 19 | module Make (IO : S.IO) : sig 20 | type reader 21 | type writer 22 | 23 | val make_reader : encoding -> IO.ic -> reader 24 | val make_writer : flush:bool -> encoding -> IO.oc -> writer 25 | val read : reader -> chunk IO.t 26 | val write : writer -> string -> unit IO.t 27 | end 28 | -------------------------------------------------------------------------------- /cohttp/test/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test_accept) 3 | (modules test_accept) 4 | (forbidden_libraries base) 5 | (libraries cohttp alcotest fmt)) 6 | 7 | (rule 8 | (alias runtest) 9 | (package cohttp) 10 | (action 11 | (run ./test_accept.exe))) 12 | 13 | (executable 14 | (name test_header) 15 | (modules test_header) 16 | (forbidden_libraries base) 17 | (libraries cohttp alcotest sexplib0)) 18 | 19 | (rule 20 | (alias runtest) 21 | (package cohttp) 22 | (action 23 | (run ./test_header.exe))) 24 | 25 | (executable 26 | (name test_request) 27 | (modules test_request) 28 | (forbidden_libraries base) 29 | (libraries alcotest cohttp fmt http_bytebuffer)) 30 | 31 | (rule 32 | (alias runtest) 33 | (package cohttp) 34 | (action 35 | (run ./test_request.exe))) 36 | 37 | (executable 38 | (name test_body) 39 | (modules test_body) 40 | (forbidden_libraries base) 41 | (libraries cohttp alcotest fmt)) 42 | 43 | (rule 44 | (alias runtest) 45 | (package cohttp) 46 | (action 47 | (run ./test_body.exe))) 48 | 49 | (executable 50 | (name test_path) 51 | (modules test_path) 52 | (forbidden_libraries base) 53 | (libraries cohttp alcotest fmt)) 54 | 55 | (rule 56 | (alias runtest) 57 | (package cohttp) 58 | (action 59 | (run ./test_path.exe))) 60 | -------------------------------------------------------------------------------- /cohttp/test/test_body.ml: -------------------------------------------------------------------------------- 1 | let test_if_body_empty () = 2 | let tests = 3 | Cohttp.Body. 4 | [ 5 | ("empty string", of_string "", true); 6 | ("empty list of strings", of_string_list [], true); 7 | ("list of strings with empty bytes", of_string_list [ ""; ""; "" ], true); 8 | ("non empty list of strings", of_string_list [ ""; "foo"; "bar" ], false); 9 | ] 10 | in 11 | List.iter 12 | (fun (name, body, expected) -> 13 | Alcotest.(check bool) name (Cohttp.Body.is_empty body) expected) 14 | tests 15 | 16 | let () = Printexc.record_backtrace true 17 | 18 | let () = 19 | Alcotest.run "test_body" 20 | [ 21 | ( "Query body information", 22 | [ ("Check if body is empty", `Quick, test_if_body_empty) ] ); 23 | ] 24 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | (dirs :standard \ node_modules) 2 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "flake-utils": { 4 | "inputs": { 5 | "systems": "systems" 6 | }, 7 | "locked": { 8 | "lastModified": 1731533236, 9 | "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=", 10 | "owner": "numtide", 11 | "repo": "flake-utils", 12 | "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b", 13 | "type": "github" 14 | }, 15 | "original": { 16 | "owner": "numtide", 17 | "repo": "flake-utils", 18 | "type": "github" 19 | } 20 | }, 21 | "nixpkgs": { 22 | "inputs": { 23 | "nixpkgs": "nixpkgs_2" 24 | }, 25 | "locked": { 26 | "lastModified": 1734153276, 27 | "narHash": "sha256-/cvtpMFp0HArEpFi0PrPMsheauc3IJ7qWpSHnw8so2M=", 28 | "owner": "nix-ocaml", 29 | "repo": "nix-overlays", 30 | "rev": "4247b28ce426ccdea09a1ec014fa52785bc7ba1d", 31 | "type": "github" 32 | }, 33 | "original": { 34 | "owner": "nix-ocaml", 35 | "repo": "nix-overlays", 36 | "type": "github" 37 | } 38 | }, 39 | "nixpkgs_2": { 40 | "locked": { 41 | "lastModified": 1734100912, 42 | "narHash": "sha256-93T/KB1ppdhnaV4u5uSwO6HutSq2RzcnkqVX9YKYslE=", 43 | "owner": "NixOS", 44 | "repo": "nixpkgs", 45 | "rev": "2a7ebf12140f6d97941d5f8cc38e9323212ecbad", 46 | "type": "github" 47 | }, 48 | "original": { 49 | "owner": "NixOS", 50 | "repo": "nixpkgs", 51 | "rev": "2a7ebf12140f6d97941d5f8cc38e9323212ecbad", 52 | "type": "github" 53 | } 54 | }, 55 | "root": { 56 | "inputs": { 57 | "flake-utils": "flake-utils", 58 | "nixpkgs": "nixpkgs" 59 | } 60 | }, 61 | "systems": { 62 | "locked": { 63 | "lastModified": 1681028828, 64 | "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", 65 | "owner": "nix-systems", 66 | "repo": "default", 67 | "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", 68 | "type": "github" 69 | }, 70 | "original": { 71 | "owner": "nix-systems", 72 | "repo": "default", 73 | "type": "github" 74 | } 75 | } 76 | }, 77 | "root": "root", 78 | "version": 7 79 | } 80 | -------------------------------------------------------------------------------- /http.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Type definitions of HTTP essentials" 4 | description: """ 5 | This package contains essential type definitions used in Cohttp. It is designed 6 | to have no dependencies and make it easy for other packages to easily 7 | interoperate with Cohttp.""" 8 | maintainer: ["Anil Madhavapeddy "] 9 | authors: [ 10 | "Anil Madhavapeddy" 11 | "Stefano Zacchiroli" 12 | "David Sheets" 13 | "Thomas Gazagnaire" 14 | "David Scott" 15 | "Rudi Grinberg" 16 | "Andy Ray" 17 | "Anurag Soni" 18 | ] 19 | license: "ISC" 20 | homepage: "https://github.com/mirage/ocaml-cohttp" 21 | doc: "https://mirage.github.io/ocaml-cohttp/" 22 | bug-reports: "https://github.com/mirage/ocaml-cohttp/issues" 23 | depends: [ 24 | "dune" {>= "3.8"} 25 | "ocaml" {>= "4.08"} 26 | "ppx_expect" {with-test & >= "v0.17.0"} 27 | "alcotest" {with-test & >= "1.7.0"} 28 | "base_quickcheck" {with-test} 29 | "ppx_assert" {with-test} 30 | "ppx_sexp_conv" {with-test} 31 | "ppx_compare" {with-test} 32 | "ppx_here" {with-test} 33 | "crowbar" {with-test & >= "0.2"} 34 | "sexplib0" {with-test} 35 | "odoc" {with-doc} 36 | ] 37 | dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git" 38 | build: [ 39 | ["dune" "subst"] {dev} 40 | [ 41 | "dune" 42 | "build" 43 | "-p" 44 | name 45 | "-j" 46 | jobs 47 | "@install" 48 | "@http/runtest" {with-test} 49 | "@doc" {with-doc} 50 | ] 51 | ] 52 | x-maintenance-intent: [ "(latest)" ] 53 | -------------------------------------------------------------------------------- /http.opam.template: -------------------------------------------------------------------------------- 1 | build: [ 2 | ["dune" "subst"] {dev} 3 | [ 4 | "dune" 5 | "build" 6 | "-p" 7 | name 8 | "-j" 9 | jobs 10 | "@install" 11 | "@http/runtest" {with-test} 12 | "@doc" {with-doc} 13 | ] 14 | ] 15 | x-maintenance-intent: [ "(latest)" ] 16 | -------------------------------------------------------------------------------- /http/fuzz/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name fuzz_header) 3 | (libraries crowbar http)) 4 | 5 | (rule 6 | (alias runtest) 7 | (package http) 8 | (action 9 | (run ./fuzz_header.exe))) 10 | 11 | (rule 12 | (alias fuzz) 13 | (deps 14 | (:exe fuzz_header.exe) 15 | (source_tree inputs)) 16 | (action 17 | (run afl-fuzz -i inputs -o findings -- ./%{exe} @@))) 18 | 19 | (rule 20 | (alias bun-fuzz) 21 | (locks %{project_root}/bun) 22 | (deps 23 | (:exe fuzz_me.exe) 24 | (source_tree input)) 25 | (action 26 | (run bun --input inputs --output findings -- ./%{exe}))) 27 | -------------------------------------------------------------------------------- /http/fuzz/inputs/input: -------------------------------------------------------------------------------- 1 | something -------------------------------------------------------------------------------- /http/src/bytebuffer/bytebuffer.mli: -------------------------------------------------------------------------------- 1 | (* Bytebuffer is split into three regions using two separate indices that are used 2 | to support read and write operations. 3 | +--------------------+---------------------------+----------------------------+ 4 | | Consumed Bytes | Bytes available to read | Empty space for writing | 5 | +--------------------+---------------------------+----------------------------+ 6 | | 0 <= pos_read <= pos_fill <= capacity 7 | 8 | Consumed Bytes: This is content that's already consumed via a get/read operation. 9 | This space can be safely reclaimed. 10 | 11 | Bytes available to read: This is the actual content that will be surfaced to users via 12 | get/read operations on the bytebuffer. 13 | 14 | Empty space for writing: This is space that will be filled by any set/write operations 15 | on the bytebuffer. 16 | *) 17 | type t 18 | 19 | val create : int -> t 20 | val unsafe_buf : t -> Bytes.t 21 | val pos : t -> int 22 | val compact : t -> unit 23 | val length : t -> int 24 | val drop : t -> int -> unit 25 | val to_string : t -> string 26 | 27 | module Make (IO : sig 28 | type 'a t 29 | 30 | val ( >>| ) : 'a t -> ('a -> 'b) -> 'b t 31 | val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t 32 | val return : 'a -> 'a t 33 | end) (Refill : sig 34 | type src 35 | 36 | val refill : src -> bytes -> pos:int -> len:int -> [ `Ok of int | `Eof ] IO.t 37 | end) : sig 38 | val refill : t -> Refill.src -> [ `Ok | `Eof ] IO.t 39 | val read_line : t -> Refill.src -> string option IO.t 40 | val read : t -> Refill.src -> int -> string IO.t 41 | end 42 | -------------------------------------------------------------------------------- /http/src/bytebuffer/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name http_bytebuffer) 3 | (package http)) 4 | -------------------------------------------------------------------------------- /http/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (synopsis "HTTP types designed for interoperability") 3 | (name http) 4 | (public_name http)) 5 | -------------------------------------------------------------------------------- /http/test/bytebuffer/bytebuffer_tests.ml: -------------------------------------------------------------------------------- 1 | module Bytebuffer = Http_bytebuffer.Bytebuffer 2 | 3 | module Src = struct 4 | type src = { str : string; mutable pos : int; mutable reads : int } 5 | 6 | let create str = { str; pos = 0; reads = 10 } 7 | 8 | let refill r buf ~pos ~len = 9 | if r.reads = 0 then raise Exit 10 | else ( 11 | r.reads <- r.reads - 1; 12 | let available = String.length r.str - r.pos in 13 | if available = 0 then `Eof 14 | else 15 | let read_len = min len available in 16 | BytesLabels.blit_string ~src:r.str ~src_pos:r.pos ~dst:buf ~dst_pos:pos 17 | ~len:read_len; 18 | r.pos <- r.pos + read_len; 19 | `Ok read_len) 20 | end 21 | 22 | module Refill = 23 | Bytebuffer.Make 24 | (struct 25 | type 'a t = 'a 26 | 27 | let ( >>| ) x f = f x 28 | let ( >>= ) x f = f x 29 | let return x = x 30 | end) 31 | (Src) 32 | 33 | let%expect_test "read line" = 34 | let test line buf_size = 35 | let src = Src.create line in 36 | let buf = Bytebuffer.create buf_size in 37 | let res = Refill.read_line buf src in 38 | match res with 39 | | None -> print_endline "failed to read line" 40 | | Some line -> Printf.printf "read line: %S\n" line 41 | | exception Exit -> print_endline "failed to read - infinite loop" 42 | in 43 | let line = "foobar\r\n" in 44 | test line (String.length line); 45 | [%expect {| read line: "foobar" |}]; 46 | test line (String.length line - 1); 47 | [%expect {| read line: "foobar" |}]; 48 | let line = "foobar\r\n" in 49 | test line (String.length line - 1); 50 | [%expect {| read line: "foobar" |}]; 51 | test line (String.length line); 52 | [%expect {| read line: "foobar" |}]; 53 | let line = "foobar\r" in 54 | test line (String.length line + 10); 55 | [%expect {| failed to read line |}]; 56 | test line (String.length line - 1); 57 | [%expect {| failed to read line |}] 58 | 59 | let%expect_test "read fixed" = 60 | let src = "foobar" in 61 | let src_len = String.length src in 62 | let test buf_size = 63 | let src = Src.create src in 64 | let buf = Bytebuffer.create buf_size in 65 | match Refill.read buf src src_len with 66 | | res -> 67 | Printf.printf "buf size=%d: reading %d bytes we get %d bytes\n" buf_size 68 | src_len (String.length res) 69 | | exception Exit -> print_endline "failed to read - infinite loop" 70 | in 71 | test src_len; 72 | [%expect {| buf size=6: reading 6 bytes we get 6 bytes |}]; 73 | test (src_len - 1); 74 | [%expect {| buf size=5: reading 6 bytes we get 5 bytes |}] 75 | -------------------------------------------------------------------------------- /http/test/bytebuffer/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name bytebuffer_tests) 3 | (libraries http_bytebuffer) 4 | (inline_tests) 5 | (preprocess 6 | (pps ppx_expect))) 7 | -------------------------------------------------------------------------------- /http/test/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test_header) 3 | (modules test_header) 4 | (forbidden_libraries base) 5 | (libraries http alcotest sexplib0)) 6 | 7 | (rule 8 | (alias runtest) 9 | (package http) 10 | (action 11 | (run ./test_header.exe))) 12 | 13 | (test 14 | (name test_parser) 15 | (modules test_parser) 16 | (package http) 17 | (preprocess 18 | (pps 19 | base_quickcheck.ppx_quickcheck 20 | ppx_assert 21 | ppx_sexp_conv 22 | ppx_compare 23 | ppx_here)) 24 | (libraries http base_quickcheck alcotest)) 25 | 26 | (test 27 | (name test_request) 28 | (modules test_request) 29 | (package http) 30 | (libraries http alcotest)) 31 | 32 | (test 33 | (name test_response) 34 | (modules test_response) 35 | (package http) 36 | (libraries http alcotest)) 37 | -------------------------------------------------------------------------------- /http/test/expect/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name http_tests) 3 | (libraries http) 4 | (inline_tests) 5 | (preprocess 6 | (pps ppx_expect))) 7 | -------------------------------------------------------------------------------- /http/test/expect/http_tests.ml: -------------------------------------------------------------------------------- 1 | module Parser = Http.Private.Parser 2 | 3 | let print_request = function 4 | | Error Parser.Partial -> print_endline "partial header" 5 | | Error (Msg m) -> print_endline m 6 | | Ok (req, n) -> 7 | Format.printf "%a@." Http.Request.pp req; 8 | if n > 0 then Format.printf "leftover: %d@." n 9 | 10 | let%expect_test "line folding" = 11 | let buf = 12 | "GET / HTTP/1.1\r\n\ 13 | Host: localhost:8080\r\n\ 14 | Line-Folded: foo\r\n\ 15 | \ bar\r\n\ 16 | \r\n\ 17 | foboar" 18 | in 19 | print_request (Parser.parse_request buf); 20 | [%expect {| partial header |}] 21 | -------------------------------------------------------------------------------- /http/test/test_request.ml: -------------------------------------------------------------------------------- 1 | open Http 2 | 3 | let aeb = Alcotest.check Alcotest.bool 4 | 5 | let requires_content_length_tests = 6 | let valid_meth () = 7 | [ `POST; `PUT; `PATCH ] 8 | |> List.map (fun meth -> 9 | Request.make ~meth "p" |> Request.requires_content_length) 10 | |> List.for_all Fun.id 11 | |> aeb "requires_content_length m = true, where m is `POST, `PUT or `PATCH" 12 | true 13 | in 14 | let invalid_meth () = 15 | [ `GET; `HEAD; `DELETE; `OPTIONS; `TRACE; `CONNECT; `Other "h" ] 16 | |> List.map (fun meth -> 17 | Request.make ~meth "p" |> Request.requires_content_length) 18 | |> List.for_all not 19 | |> aeb 20 | {| requires_content_length m = false, where m is `GET; `HEAD;`DELETE;`OPTIONS;`TRACE; `CONNECT;`Other "h" |} 21 | true 22 | in 23 | ( "requires_content_length", 24 | [ 25 | ("Valid meth", `Quick, valid_meth); ("Invalid meth", `Quick, invalid_meth); 26 | ] ) 27 | 28 | let content_length_tests = 29 | let some_x () = 30 | [ (`POST, "0"); (`PUT, "233"); (`PATCH, "012345") ] 31 | |> List.map (fun (meth, len) -> 32 | match 33 | Request.make ~meth 34 | ~headers:(Header.of_list [ ("Content-Length", len) ]) 35 | "p" 36 | |> Request.content_length 37 | with 38 | | Some x -> int_of_string len = x 39 | | None -> false) 40 | |> List.for_all Fun.id 41 | |> aeb "content_length t = Some x" true 42 | in 43 | 44 | let none () = 45 | [ (`POST, "-1"); (`PUT, "-233"); (`PATCH, "abc") ] 46 | |> List.map (fun (meth, len) -> 47 | match 48 | Request.make ~meth 49 | ~headers:(Header.of_list [ ("Content-Length", len) ]) 50 | "p" 51 | |> Request.content_length 52 | with 53 | | Some _ -> false 54 | | None -> true) 55 | |> List.for_all Fun.id 56 | |> aeb "content_length t = None" true 57 | in 58 | 59 | let method_ () = 60 | [ `GET; `HEAD; `DELETE; `OPTIONS; `TRACE; `CONNECT; `Other "h" ] 61 | |> List.map (fun meth -> 62 | match Request.make ~meth "p" |> Request.content_length with 63 | | Some _ -> false 64 | | None -> true) 65 | |> List.for_all Fun.id 66 | |> aeb "content_length t = None" true 67 | in 68 | ( "content_length", 69 | [ 70 | ("Some content_length", `Quick, some_x); 71 | ("None : Invalid content_length integer", `Quick, none); 72 | ("None : Method", `Quick, method_); 73 | ] ) 74 | 75 | let () = 76 | Alcotest.run "test_request" 77 | [ requires_content_length_tests; content_length_tests ] 78 | -------------------------------------------------------------------------------- /http/test/test_response.ml: -------------------------------------------------------------------------------- 1 | open Http 2 | 3 | let aeb = Alcotest.check Alcotest.bool 4 | let aeo = Alcotest.check Alcotest.(option int) 5 | let no_content_status = Response.make ~status:`No_content () 6 | let continue_status = Response.make ~status:`Continue () 7 | let ok_status = Response.make ~status:`OK () 8 | 9 | let chunked_transport_encoding = 10 | let headers = 11 | let headers = Http.Header.init () in 12 | Http.Header.add headers "Transfer-Encoding" "chunked" 13 | in 14 | Response.make ~status:`OK ~headers () 15 | 16 | let requires_content_length_tests = 17 | let no_content_status () = 18 | Response.requires_content_length no_content_status 19 | |> aeb "requires_content_length m = true, where s is `No_content (204)" 20 | false 21 | in 22 | let continue_status () = 23 | Response.requires_content_length continue_status 24 | |> aeb "requires_content_length m = true, where s is `Continue (100)" false 25 | in 26 | let ok_status () = 27 | Response.requires_content_length ok_status 28 | |> aeb "requires_content_length s = true, where s is `OK (200" true 29 | in 30 | let chunked_transport_encoding () = 31 | Response.requires_content_length chunked_transport_encoding 32 | |> aeb "requires_content_length s = true, where s is `OK (200" false 33 | in 34 | ( "requires_content_length", 35 | [ 36 | ("`No_content", `Quick, no_content_status); 37 | ("`Continue", `Quick, continue_status); 38 | ("`OK", `Quick, ok_status); 39 | ("Transport-Encoding: chunked", `Quick, chunked_transport_encoding); 40 | ] ) 41 | 42 | let content_length_tests = 43 | let ok_status () = 44 | Response. 45 | { 46 | ok_status with 47 | headers = Header.add ok_status.headers "Content-Length" "20"; 48 | } 49 | |> Response.content_length 50 | |> aeo "Some len" (Some 20) 51 | in 52 | let no_content_status () = 53 | Response.content_length no_content_status |> aeo "`No_content : None" None 54 | in 55 | 56 | ( "content_length", 57 | [ ("OK", `Quick, ok_status); ("`No_content", `Quick, no_content_status) ] ) 58 | 59 | let () = 60 | Alcotest.run "test_response" 61 | [ requires_content_length_tests; content_length_tests ] 62 | -------------------------------------------------------------------------------- /test_helpers/cohttp_server/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name cohttp_server) 3 | (libraries cohttp unix)) 4 | -------------------------------------------------------------------------------- /test_helpers/cohttp_test/src/cohttp_test.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | type 'a io 3 | type ic 4 | type oc 5 | type body 6 | 7 | type response_action = 8 | [ `Expert of Http.Response.t * (ic -> oc -> unit io) 9 | | `Response of Http.Response.t * body ] 10 | 11 | type spec = Http.Request.t -> body -> response_action io 12 | type async_test = unit -> unit io 13 | 14 | val response : Http.Response.t * body -> response_action 15 | val expert : ?rsp:Http.Response.t -> (ic -> oc -> unit io) -> spec 16 | val const : (Http.Response.t * body) io -> spec 17 | val response_sequence : spec list -> spec 18 | val temp_server : ?port:int -> spec -> (Uri.t -> 'a io) -> 'a io 19 | 20 | val test_server_s : 21 | ?port:int -> 22 | ?name:string -> 23 | spec -> 24 | (Uri.t -> (string * async_test) list) -> 25 | OUnit.test io 26 | 27 | val run_async_tests : OUnit.test io -> OUnit.test_results io 28 | end 29 | 30 | let port = 31 | Random.self_init (); 32 | ref (1024 + Random.int 40000) 33 | 34 | let next_port () = 35 | let current_port = !port in 36 | incr port; 37 | current_port 38 | 39 | let response_sequence fail responses = 40 | let xs = ref responses in 41 | fun req body -> 42 | match !xs with 43 | | x :: xs' -> 44 | xs := xs'; 45 | x req body 46 | | [] -> fail "response_sequence: Server exhausted responses" 47 | -------------------------------------------------------------------------------- /test_helpers/cohttp_test/src/cohttp_test.mli: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | type 'a io 3 | type ic 4 | type oc 5 | type body 6 | 7 | type response_action = 8 | [ `Expert of Http.Response.t * (ic -> oc -> unit io) 9 | | `Response of Http.Response.t * body ] 10 | 11 | type spec = Http.Request.t -> body -> response_action io 12 | (** A server that is being tested must be defined by providing a spec *) 13 | 14 | type async_test = unit -> unit io 15 | 16 | val response : Http.Response.t * body -> response_action 17 | val expert : ?rsp:Http.Response.t -> (ic -> oc -> unit io) -> spec 18 | 19 | val const : (Http.Response.t * body) io -> spec 20 | (** A constant handler that always returns its argument *) 21 | 22 | val response_sequence : spec list -> spec 23 | (** A server that process requests using the provided specs in sequence and 24 | crashes on further requests *) 25 | 26 | val temp_server : ?port:int -> spec -> (Uri.t -> 'a io) -> 'a io 27 | (** Create a temporary server according to spec that lives until the callback 28 | thread is determined. The uri provided in the callback should be the base 29 | uri for any requests made to the temp server *) 30 | 31 | val test_server_s : 32 | ?port:int -> 33 | ?name:string -> 34 | spec -> 35 | (Uri.t -> (string * async_test) list) -> 36 | OUnit.test io 37 | (** Create a test suite against a server defined by spec. Tests run 38 | sequentially. *) 39 | 40 | val run_async_tests : OUnit.test io -> OUnit.test_results io 41 | (** Run an async unit test and return and print the result *) 42 | end 43 | 44 | val next_port : unit -> int 45 | (** Internal API. Subject to breakage *) 46 | 47 | val response_sequence : 48 | (string -> 'a) -> ('b -> 'c -> 'a) list -> 'b -> 'c -> 'a 49 | -------------------------------------------------------------------------------- /test_helpers/cohttp_test/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name cohttp_test) 3 | (libraries cohttp ounit2)) 4 | --------------------------------------------------------------------------------