├── .gitignore ├── .ocamlformat ├── CHANGES.md ├── LICENSE ├── Makefile ├── README.md ├── curly.opam ├── dune-project ├── examples ├── dune └── readme_example.ml ├── flake.lock ├── flake.nix ├── src ├── curly.ml ├── curly.mli ├── dune ├── http.mli └── http.mll └── test ├── dune └── test_curly.ml /.gitignore: -------------------------------------------------------------------------------- 1 | *.install 2 | _build 3 | _opam 4 | *.merlin 5 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | version=0.26.0 2 | profile=janestreet 3 | ocaml-version=4.08.0 4 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | 0.3.0 (2023-01-20) 2 | ------------------ 3 | 4 | * Passthrough case-insensitive PATH and SYSTEMROOT on Windows (@emillon, 5 | @jonahbeckford, #6, #8) 6 | * Passthrough PATH to Unixes too. (@bikal, #12) 7 | * Add `?follow_redirects` argument to `run` and related functions 8 | (@rawleyfowler, #5). 9 | 10 | 0.2.0 (07/09/2020) 11 | ------------------ 12 | 13 | * Upgrade from jbuilder to dune (@shonfeder, fixes #3) 14 | 15 | 0.1.0 (08/08/2017) 16 | ------------------ 17 | 18 | * Initial release 19 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | ISC License 2 | 3 | Copyright (c) 2017 Rudi Grinberg 4 | 5 | Permission to use, copy, modify, and/or 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 WITH 10 | REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY 11 | AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, 12 | INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM 13 | LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR 14 | OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR 15 | PERFORMANCE OF THIS SOFTWARE. 16 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all clean test 2 | 3 | BUILD=dune build 4 | RUNTEST=dune runtest -j1 --no-buffer 5 | 6 | all: 7 | @$(BUILD) @install @DEFAULT 8 | 9 | test: 10 | @$(RUNTEST) 11 | 12 | clean: 13 | @dune clean 14 | 15 | REPO=../opam-repository 16 | PACKAGES=$(REPO)/packages 17 | 18 | opam-release: 19 | dune-release distrib --skip-build --skip-lint --skip-tests 20 | # See https://github.com/ocamllabs/dune-release/issues/206 21 | DUNE_RELEASE_DELEGATE=github-dune-release-delegate dune-release publish distrib --verbose 22 | dune-release opam pkg 23 | dune-release opam submit 24 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Curly - The Dumbest Http Client 2 | 3 | Curly is a brain dead wrapper around the curl command line utility designed to 4 | provide a 0 dependency solution for applications that want to create some very 5 | simple HTTP requests. It is not blazing fast, or async, but at least it involves 6 | no C bindings, it's trivial to vendor, and the API can be learned in 5 minutes. 7 | 8 | Here's a simple example: 9 | 10 | ```ocaml 11 | 12 | match Curly.(run (Request.make ~url:"https://opam.ocaml.org" ~meth:`GET ())) with 13 | | Ok x -> 14 | Format.printf "status: %d\n" x.Curly.Response.code; 15 | Format.printf "headers: %a\n" Curly.Header.pp x.Curly.Response.headers; 16 | Format.printf "body: %s\n" x.Curly.Response.body 17 | | Error e -> 18 | Format.printf "Failed: %a" Curly.Error.pp e 19 | ``` 20 | 21 | There's not much more to it than this. Consult curly.mli to see how to construct 22 | various requests and read responses, 23 | or [read the online documentation](https://rgrinberg.github.io/curly/). 24 | -------------------------------------------------------------------------------- /curly.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: 4 | "Curly is a brain dead wrapper around the curl command line utility" 5 | maintainer: ["rudi.grinberg@gmail.com"] 6 | authors: ["Rudi Grinberg"] 7 | license: "ISC" 8 | homepage: "https://github.com/rgrinberg/curly" 9 | bug-reports: "https://github.com/rgrinberg/curly/issues" 10 | depends: [ 11 | "dune" {>= "2.7"} 12 | "ocaml" {>= "4.08"} 13 | "base-unix" 14 | "alcotest" {with-test} 15 | "cohttp-lwt-unix" {with-test} 16 | "odoc" {with-doc} 17 | ] 18 | build: [ 19 | ["dune" "subst"] {dev} 20 | [ 21 | "dune" 22 | "build" 23 | "-p" 24 | name 25 | "-j" 26 | jobs 27 | "@install" 28 | "@runtest" {with-test} 29 | "@doc" {with-doc} 30 | ] 31 | ] 32 | dev-repo: "git+https://github.com/rgrinberg/curly.git" 33 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.7) 2 | (name curly) 3 | 4 | (generate_opam_files true) 5 | 6 | (authors "Rudi Grinberg") 7 | (maintainers "rudi.grinberg@gmail.com") 8 | (license ISC) 9 | (source (github rgrinberg/curly)) 10 | 11 | (package 12 | (name curly) 13 | (synopsis "Curly is a brain dead wrapper around the curl command line utility") 14 | (depends 15 | (ocaml (>= 4.08)) 16 | base-unix 17 | 18 | (alcotest :with-test) 19 | (cohttp-lwt-unix :with-test) 20 | (odoc :with-doc))) 21 | -------------------------------------------------------------------------------- /examples/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name readme_example) 3 | (libraries curly)) 4 | 5 | (alias 6 | (name DEFAULT) 7 | (deps readme_example.exe)) 8 | -------------------------------------------------------------------------------- /examples/readme_example.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | match Curly.(run (Request.make ~url:"https://opam.ocaml.org" ~meth:`GET ())) with 3 | | Ok x -> 4 | Format.printf "status: %d\n" x.Curly.Response.code; 5 | Format.printf "headers: %a\n" Curly.Header.pp x.Curly.Response.headers; 6 | Format.printf "body: %s\n" x.Curly.Response.body 7 | | Error e -> Format.printf "Failed: %a" Curly.Error.pp e 8 | ;; 9 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "flake-utils": { 4 | "inputs": { 5 | "systems": "systems" 6 | }, 7 | "locked": { 8 | "lastModified": 1694529238, 9 | "narHash": "sha256-zsNZZGTGnMOf9YpHKJqMSsa0dXbfmxeoJ7xHlrt+xmY=", 10 | "owner": "numtide", 11 | "repo": "flake-utils", 12 | "rev": "ff7b65b44d01cf9ba6a71320833626af21126384", 13 | "type": "github" 14 | }, 15 | "original": { 16 | "owner": "numtide", 17 | "repo": "flake-utils", 18 | "type": "github" 19 | } 20 | }, 21 | "nix-filter": { 22 | "locked": { 23 | "lastModified": 1694857738, 24 | "narHash": "sha256-bxxNyLHjhu0N8T3REINXQ2ZkJco0ABFPn6PIe2QUfqo=", 25 | "owner": "numtide", 26 | "repo": "nix-filter", 27 | "rev": "41fd48e00c22b4ced525af521ead8792402de0ea", 28 | "type": "github" 29 | }, 30 | "original": { 31 | "owner": "numtide", 32 | "repo": "nix-filter", 33 | "type": "github" 34 | } 35 | }, 36 | "nixpkgs": { 37 | "locked": { 38 | "lastModified": 1697324377, 39 | "narHash": "sha256-ZUQm6gt3LwKg2vCytq0aEgAygLtiArRGV3QwNWE+Ujc=", 40 | "owner": "nixos", 41 | "repo": "nixpkgs", 42 | "rev": "6b835f255748bc0b2d1f9ba211fcdae44f562603", 43 | "type": "github" 44 | }, 45 | "original": { 46 | "owner": "nixos", 47 | "repo": "nixpkgs", 48 | "type": "github" 49 | } 50 | }, 51 | "root": { 52 | "inputs": { 53 | "flake-utils": "flake-utils", 54 | "nix-filter": "nix-filter", 55 | "nixpkgs": "nixpkgs" 56 | } 57 | }, 58 | "systems": { 59 | "locked": { 60 | "lastModified": 1681028828, 61 | "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", 62 | "owner": "nix-systems", 63 | "repo": "default", 64 | "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", 65 | "type": "github" 66 | }, 67 | "original": { 68 | "owner": "nix-systems", 69 | "repo": "default", 70 | "type": "github" 71 | } 72 | } 73 | }, 74 | "root": "root", 75 | "version": 7 76 | } 77 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | description = "Curly Nix Flake"; 3 | 4 | inputs.nix-filter.url = "github:numtide/nix-filter"; 5 | inputs.flake-utils.url = "github:numtide/flake-utils"; 6 | inputs.nixpkgs.url = "github:nixos/nixpkgs"; 7 | 8 | outputs = { self, nixpkgs, flake-utils, nix-filter }: 9 | flake-utils.lib.eachDefaultSystem (system: 10 | let 11 | pkgs = nixpkgs.legacyPackages."${system}"; 12 | inherit (pkgs.ocamlPackages) buildDunePackage; 13 | in 14 | rec { 15 | packages = rec { 16 | default = curly; 17 | curly = buildDunePackage { 18 | pname = "curly"; 19 | version = "n/a"; 20 | src = ./.; 21 | duneVersion = "3"; 22 | propagatedBuildInputs = with pkgs.ocamlPackages; [ pkgs.curl ]; 23 | checkInputs = with pkgs.ocamlPackages; [ alcotest cohttp-lwt-unix lwt ]; 24 | doCheck = true; 25 | }; 26 | }; 27 | devShells.default = pkgs.mkShell { 28 | inputsFrom = pkgs.lib.attrValues packages; 29 | buildInputs = with pkgs.ocamlPackages; [ ocaml-lsp pkgs.ocamlformat ]; 30 | }; 31 | }); 32 | } 33 | -------------------------------------------------------------------------------- /src/curly.ml: -------------------------------------------------------------------------------- 1 | module List = ListLabels 2 | 3 | module Result = struct 4 | include Result 5 | 6 | let ( >>= ) : type a b e. (a, e) result -> (a -> (b, e) result) -> (b, e) result = 7 | fun r f -> 8 | match r with 9 | | Ok x -> f x 10 | | Error _ as e -> e 11 | ;; 12 | end 13 | 14 | open Result 15 | 16 | module Meth = struct 17 | type t = 18 | [ `GET 19 | | `POST 20 | | `HEAD 21 | | `PUT 22 | | `DELETE 23 | | `OPTIONS 24 | | `TRACE 25 | | `CONNECT 26 | | `PATCH 27 | | `Other of string 28 | ] 29 | 30 | let to_string = function 31 | | `GET -> "GET" 32 | | `POST -> "POST" 33 | | `HEAD -> "HEAD" 34 | | `PUT -> "PUT" 35 | | `DELETE -> "DELETE" 36 | | `OPTIONS -> "OPTIONS" 37 | | `TRACE -> "TRACE" 38 | | `CONNECT -> "CONNECT" 39 | | `PATCH -> "PATCH" 40 | | `Other s -> s 41 | ;; 42 | 43 | let pp fmt t = Format.fprintf fmt "%s" (to_string t) 44 | end 45 | 46 | module Header = struct 47 | type t = (string * string) list 48 | 49 | let empty = [] 50 | 51 | let to_cmd t = 52 | t |> List.map ~f:(fun (k, v) -> [ "-H"; Printf.sprintf "%s: %s" k v ]) |> List.concat 53 | ;; 54 | 55 | let pp fmt t = 56 | Format.pp_print_list 57 | ~pp_sep:Format.pp_print_newline 58 | (fun fmt (k, v) -> Format.fprintf fmt "%s: %s\n" k v) 59 | fmt 60 | t 61 | ;; 62 | end 63 | 64 | module Response = struct 65 | type t = Http.response = 66 | { code : int 67 | ; headers : Header.t 68 | ; body : string 69 | } 70 | 71 | let default = { code = 0; headers = []; body = "" } 72 | 73 | let of_stdout s = 74 | let lexbuf = Lexing.from_string s in 75 | try Ok (Http.response default lexbuf) with 76 | | e -> Error e 77 | ;; 78 | 79 | let pp fmt t = 80 | Format.fprintf 81 | fmt 82 | "{code=%d;@ headers=%a;@ body=\"%s\"}" 83 | t.code 84 | Header.pp 85 | t.headers 86 | t.body 87 | ;; 88 | end 89 | 90 | module Process_result = struct 91 | type t = 92 | { status : Unix.process_status 93 | ; stderr : string 94 | ; stdout : string 95 | } 96 | 97 | let pp_process_status fmt (exit : Unix.process_status) = 98 | match exit with 99 | | WEXITED n -> Format.fprintf fmt "Exit code %d" n 100 | | WSIGNALED n -> Format.fprintf fmt "Signal %d" n 101 | | WSTOPPED n -> Format.fprintf fmt "Stopped %d" n 102 | ;; 103 | 104 | let pp fmt t = 105 | Format.fprintf 106 | fmt 107 | "{status=%a;@ stderr=\"%s\";@ stdout=\"%s\"}" 108 | pp_process_status 109 | t.status 110 | t.stderr 111 | t.stdout 112 | ;; 113 | end 114 | 115 | module Error = struct 116 | type t = 117 | | Invalid_request of string 118 | | Bad_exit of Process_result.t 119 | | Failed_to_read_response of exn * Process_result.t 120 | | Exn of exn 121 | 122 | let pp fmt = function 123 | | Bad_exit p -> 124 | Format.fprintf 125 | fmt 126 | "Non 0 exit code %a@.%a" 127 | Process_result.pp_process_status 128 | p.status 129 | Process_result.pp 130 | p 131 | | Failed_to_read_response (e, _) -> 132 | Format.fprintf fmt "Couldn't read response:@ %s" (Printexc.to_string e) 133 | | Invalid_request r -> Format.fprintf fmt "Invalid request: %s" r 134 | | Exn e -> Format.fprintf fmt "Exception: %s" (Printexc.to_string e) 135 | ;; 136 | end 137 | 138 | module Request = struct 139 | type t = 140 | { meth : Meth.t 141 | ; url : string 142 | ; headers : Header.t 143 | ; body : string 144 | } 145 | 146 | let make ?(headers = Header.empty) ?(body = "") ~url ~meth () = 147 | { meth; url; headers; body } 148 | ;; 149 | 150 | let has_body t = String.length t.body > 0 151 | 152 | let validate t = 153 | if has_body t && List.mem t.meth ~set:[ `GET; `HEAD ] 154 | then Error (Error.Invalid_request "No body is allowed with GET/HEAD methods") 155 | else Ok t 156 | ;; 157 | 158 | let to_cmd_args t = 159 | List.concat 160 | [ [ "-X"; Meth.to_string t.meth ] 161 | ; Header.to_cmd t.headers 162 | ; [ t.url ] 163 | ; (if has_body t then [ "--data-binary"; "@-" ] else []) 164 | ] 165 | ;; 166 | 167 | let pp fmt t = 168 | Format.fprintf 169 | fmt 170 | "{@ meth=%a;@ url=\"%s\";@ headers=\"%a\";@ body=\"%s\"@ }" 171 | Meth.pp 172 | t.meth 173 | t.url 174 | Header.pp 175 | t.headers 176 | t.body 177 | ;; 178 | end 179 | 180 | let result_of_process_result (t : Process_result.t) = 181 | match t.status with 182 | | Unix.WEXITED 0 -> Ok t 183 | | _ -> Error (Error.Bad_exit t) 184 | ;; 185 | 186 | let array_filter f a = Array.to_list a |> List.filter ~f |> Array.of_list 187 | 188 | let is_prefix_ci s ~prefix = 189 | let s_len = String.length s in 190 | let prefix_len = String.length prefix in 191 | let s_lc = String.lowercase_ascii s in 192 | let prefix_lc = String.lowercase_ascii prefix in 193 | s_len >= prefix_len && String.equal (String.sub s_lc 0 prefix_len) prefix_lc 194 | ;; 195 | 196 | let var_in_ci vars env_string = 197 | List.exists ~f:(fun var -> is_prefix_ci ~prefix:(var ^ "=") env_string) vars 198 | ;; 199 | 200 | let curl_env () = 201 | let kept_variables = [ "PATH"; "SYSTEMROOT" ] in 202 | Unix.environment () |> array_filter (var_in_ci kept_variables) 203 | ;; 204 | 205 | let run prog args stdin_str = 206 | let stdout, stdin, stderr = 207 | let args = Array.of_list args in 208 | Unix.open_process_args_full prog args (curl_env ()) 209 | in 210 | if String.length stdin_str > 0 then output_string stdin stdin_str; 211 | (try close_out stdin with 212 | | _ -> ()); 213 | let stdout_fd = Unix.descr_of_in_channel stdout in 214 | let stderr_fd = Unix.descr_of_in_channel stderr in 215 | let in_buf, err_buf = Buffer.(create 128, create 128) in 216 | let read_buf_len = 512 in 217 | let read_buf = Bytes.create read_buf_len in 218 | let input ch = 219 | match input ch read_buf 0 read_buf_len with 220 | | 0 -> Error `Eof 221 | | s -> Ok s 222 | in 223 | let rec loop = function 224 | | [] -> () 225 | | read_list -> 226 | let can_read, _, _ = Unix.select read_list [] [] 1.0 in 227 | let to_remove = 228 | List.fold_left 229 | ~init:[] 230 | ~f:(fun to_remove fh -> 231 | let rr, buf = 232 | if fh = stderr_fd then input stderr, err_buf else input stdout, in_buf 233 | in 234 | match rr with 235 | | Ok len -> 236 | Buffer.add_subbytes buf read_buf 0 len; 237 | to_remove 238 | | Error `Eof -> fh :: to_remove) 239 | can_read 240 | in 241 | read_list |> List.filter ~f:(fun fh -> not (List.mem fh ~set:to_remove)) |> loop 242 | in 243 | ignore (loop [ stdout_fd; stderr_fd ]); 244 | let status = Unix.close_process_full (stdout, stdin, stderr) in 245 | { Process_result.status 246 | ; stdout = Buffer.contents in_buf 247 | ; stderr = Buffer.contents err_buf 248 | } 249 | ;; 250 | 251 | let is_informational_code status = 100 <= status && status <= 199 252 | let is_redirect_code status = status <= 308 && status >= 300 253 | 254 | let run ?(exe = "curl") ?(args = []) ?(follow_redirects = false) req = 255 | Request.validate req 256 | >>= fun req -> 257 | let args = ("-si" :: Request.to_cmd_args req) @ args in 258 | let args = if follow_redirects then "-L" :: args else args in 259 | (* the first argument of args is always the executable name *) 260 | let args = exe :: args in 261 | let res = 262 | try result_of_process_result (run exe args req.body) with 263 | | e -> Error (Error.Exn e) 264 | in 265 | let rec handle_res (res : Process_result.t) = 266 | match Response.of_stdout res.stdout with 267 | | Ok r -> 268 | (* One or more informational responses may precede the main response 269 | from the server. They may safely by ignored. See 270 | https://datatracker.ietf.org/doc/html/rfc7231#section-6.2. *) 271 | if is_informational_code r.code || (follow_redirects && is_redirect_code r.code) 272 | then handle_res { res with stdout = r.body } 273 | else Ok r 274 | | Error e -> Error (Error.Failed_to_read_response (e, res)) 275 | in 276 | res >>= handle_res 277 | ;; 278 | 279 | let get ?exe ?args ?headers ?follow_redirects url = 280 | run ?exe ?args ?follow_redirects (Request.make ?headers ~url ~meth:`GET ()) 281 | ;; 282 | 283 | let head ?exe ?args ?headers ?follow_redirects url = 284 | run ?exe ?args ?follow_redirects (Request.make ?headers ~url ~meth:`HEAD ()) 285 | ;; 286 | 287 | let delete ?exe ?args ?headers ?follow_redirects url = 288 | run ?exe ?args ?follow_redirects (Request.make ?headers ~url ~meth:`DELETE ()) 289 | ;; 290 | 291 | let post ?exe ?args ?headers ?body ?follow_redirects url = 292 | run ?exe ?args ?follow_redirects (Request.make ?body ?headers ~url ~meth:`POST ()) 293 | ;; 294 | 295 | let put ?exe ?args ?headers ?body ?follow_redirects url = 296 | run ?exe ?args ?follow_redirects (Request.make ?body ?headers ~url ~meth:`PUT ()) 297 | ;; 298 | -------------------------------------------------------------------------------- /src/curly.mli: -------------------------------------------------------------------------------- 1 | module Meth : sig 2 | type t = 3 | [ `GET 4 | | `POST 5 | | `HEAD 6 | | `PUT 7 | | `DELETE 8 | | `OPTIONS 9 | | `TRACE 10 | | `CONNECT 11 | | `PATCH 12 | | `Other of string 13 | ] 14 | 15 | val pp : Format.formatter -> t -> unit 16 | end 17 | 18 | module Header : sig 19 | type t = (string * string) list 20 | 21 | val pp : Format.formatter -> t -> unit 22 | end 23 | 24 | module Response : sig 25 | type t = 26 | { code : int 27 | ; headers : Header.t 28 | ; body : string 29 | } 30 | 31 | val pp : Format.formatter -> t -> unit 32 | end 33 | 34 | module Request : sig 35 | type t = 36 | { meth : Meth.t 37 | ; url : string 38 | ; headers : Header.t 39 | ; body : string 40 | } 41 | 42 | val make : ?headers:Header.t -> ?body:string -> url:string -> meth:Meth.t -> unit -> t 43 | val to_cmd_args : t -> string list 44 | val pp : Format.formatter -> t -> unit 45 | end 46 | 47 | module Process_result : sig 48 | type t = 49 | { status : Unix.process_status 50 | ; stderr : string 51 | ; stdout : string 52 | } 53 | 54 | val pp : Format.formatter -> t -> unit 55 | end 56 | 57 | module Error : sig 58 | type t = 59 | | Invalid_request of string 60 | | Bad_exit of Process_result.t 61 | | Failed_to_read_response of exn * Process_result.t 62 | | Exn of exn 63 | 64 | val pp : Format.formatter -> t -> unit 65 | end 66 | 67 | val run 68 | : ?exe:string 69 | -> ?args:string list 70 | -> ?follow_redirects:bool 71 | -> Request.t 72 | -> (Response.t, Error.t) result 73 | 74 | (** Specialized version of {!run} for method [`GET] 75 | @since 0.2.0 *) 76 | val get 77 | : ?exe:string 78 | -> ?args:string list 79 | -> ?headers:Header.t 80 | -> ?follow_redirects:bool 81 | -> string 82 | -> (Response.t, Error.t) result 83 | 84 | (** Specialized version of {!run} for method [`HEAD] 85 | @since 0.2.0 *) 86 | val head 87 | : ?exe:string 88 | -> ?args:string list 89 | -> ?headers:Header.t 90 | -> ?follow_redirects:bool 91 | -> string 92 | -> (Response.t, Error.t) result 93 | 94 | (** Specialized version of {!run} for method [`DELETE] 95 | @since 0.2.0 *) 96 | val delete 97 | : ?exe:string 98 | -> ?args:string list 99 | -> ?headers:Header.t 100 | -> ?follow_redirects:bool 101 | -> string 102 | -> (Response.t, Error.t) result 103 | 104 | (** Specialized version of {!run} for method [`POST] 105 | @since 0.2.0 *) 106 | val post 107 | : ?exe:string 108 | -> ?args:string list 109 | -> ?headers:Header.t 110 | -> ?body:string 111 | -> ?follow_redirects:bool 112 | -> string 113 | -> (Response.t, Error.t) result 114 | 115 | (** Specialized version of {!run} for method [`PUT] 116 | @since 0.2.0 *) 117 | val put 118 | : ?exe:string 119 | -> ?args:string list 120 | -> ?headers:Header.t 121 | -> ?body:string 122 | -> ?follow_redirects:bool 123 | -> string 124 | -> (Response.t, Error.t) result 125 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (ocamllex http) 2 | 3 | (library 4 | (name curly) 5 | (public_name curly) 6 | (libraries unix)) 7 | -------------------------------------------------------------------------------- /src/http.mli: -------------------------------------------------------------------------------- 1 | (* The purpose of this module isn't to be a full blown http parser but rather to 2 | only parse whatever curl otputs *) 3 | type response = 4 | { code : int 5 | ; headers : (string * string) list 6 | ; body : string 7 | } 8 | 9 | val response : response -> Lexing.lexbuf -> response 10 | -------------------------------------------------------------------------------- /src/http.mll: -------------------------------------------------------------------------------- 1 | { 2 | 3 | type response = 4 | { code: int 5 | ; headers: (string * string) list 6 | ; body: string 7 | } 8 | 9 | let add_code t code = 10 | { t with code = int_of_string code } 11 | 12 | let add_header t key val_ = 13 | { t with headers = (key, (String.trim val_)) :: t.headers } 14 | 15 | let add_body t b = { t with body=Buffer.contents b } 16 | 17 | let set_lexeme_length buf n = 18 | let open Lexing in 19 | if n < 0 then 20 | invalid_arg "set_lexeme_length: offset should be positive"; 21 | if n > buf.lex_curr_pos - buf.lex_start_pos then 22 | invalid_arg "set_lexeme_length: offset larger than lexeme"; 23 | buf.lex_curr_pos <- buf.lex_start_pos + n; 24 | buf.lex_curr_p <- { 25 | buf.lex_start_p 26 | with pos_cnum = buf.lex_abs_pos + buf.lex_curr_pos 27 | } 28 | } 29 | 30 | let space = [' ' '\t'] 31 | 32 | rule response resp = parse 33 | | [^ ' ']+ { code resp lexbuf } 34 | and code resp = parse 35 | | space+ (['0' - '9']+ as code) { status (add_code resp code) lexbuf } 36 | and status resp = parse 37 | | space+ { status resp lexbuf } 38 | | [^ '\n']+ '\n' { header_start resp lexbuf } 39 | and header_start resp = parse 40 | | "\r\n" { body resp (Buffer.create 128) lexbuf } 41 | | space+ { header_start resp lexbuf } 42 | | _ { 43 | set_lexeme_length lexbuf 0; 44 | header_key resp lexbuf 45 | } 46 | and header_key resp = parse 47 | | space* ([^ ':']+ as key) space* ':' space* { header_val resp key lexbuf } 48 | and header_val resp key = parse 49 | | ([^ '\n']+ as v) '\n' { header_start (add_header resp key v) lexbuf } 50 | and body resp b = parse 51 | | eof { add_body resp b } 52 | | _ as c { Buffer.add_char b c; body resp b lexbuf } 53 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_curly) 3 | (libraries curly alcotest cohttp-lwt-unix lwt.unix)) 4 | -------------------------------------------------------------------------------- /test/test_curly.ml: -------------------------------------------------------------------------------- 1 | open Result 2 | open Lwt.Infix 3 | module Request = Cohttp.Request 4 | module Header = Cohttp.Header 5 | module Server = Cohttp_lwt_unix.Server 6 | 7 | let sprintf = Printf.sprintf 8 | let port = 12297 9 | let simple_get_body = "curly" 10 | 11 | let callback req body = function 12 | | [ "simple_get" ] -> Server.respond_string ~status:`OK ~body:simple_get_body () 13 | | [ "read_header" ] -> 14 | Server.respond_string 15 | ~status:`OK 16 | ~body: 17 | (match Header.get (Request.headers req) "x-curly" with 18 | | None -> failwith "x-curly header not present" 19 | | Some v -> v) 20 | () 21 | | [ "write_body" ] -> Server.respond_string ~status:`OK ~body () 22 | | _ -> failwith (sprintf "Not found: %s" (Request.resource req)) 23 | ;; 24 | 25 | let test_server () = 26 | let stop, stopper = Lwt.task () in 27 | Server.make 28 | ~callback:(fun _ req body -> 29 | let uri_parts = 30 | req 31 | |> Request.uri 32 | |> Uri.path 33 | (* path starts with /, so first element is empty *) 34 | |> String.split_on_char '/' 35 | |> List.tl 36 | in 37 | Cohttp_lwt.Body.to_string body >>= fun body -> callback req body uri_parts) 38 | () 39 | |> Server.create ~mode:(`TCP (`Port port)) ~stop 40 | |> Lwt.ignore_result; 41 | stopper 42 | ;; 43 | 44 | open Curly 45 | 46 | let base = 47 | { Request.meth = `GET 48 | ; headers = [] 49 | ; url = Printf.sprintf "http://0.0.0.0:%d" port 50 | ; body = "" 51 | } 52 | ;; 53 | 54 | let t_response = Alcotest.testable Response.pp ( = ) 55 | let t_error = Alcotest.testable Error.pp ( = ) 56 | let t_result = Alcotest.result t_response t_error 57 | let with_path p = { base with Request.url = base.Request.url ^ "/" ^ p } 58 | let body_header b = [ "content-length", string_of_int (String.length b) ] 59 | 60 | let run_simple_get _ = 61 | Alcotest.check 62 | t_result 63 | "simple_get" 64 | (Ok { Response.code = 200; body = "curly"; headers = body_header simple_get_body }) 65 | (Curly.run (with_path "simple_get")) 66 | ;; 67 | 68 | let read_header _ = 69 | let k, v = "x-curly", "header value" in 70 | Alcotest.check 71 | t_result 72 | "read_header" 73 | (Ok { Response.code = 200; body = v; headers = body_header v }) 74 | (Curly.run { (with_path "read_header") with Request.headers = [ k, v ] }) 75 | ;; 76 | 77 | let write_body _ = 78 | let body = {| 79 | foo bar Baez 80 | sample body 81 | 82 | the quick brown fox 83 | |} in 84 | Alcotest.check 85 | t_result 86 | "write_body" 87 | (Ok { Response.code = 200; body; headers = body_header body }) 88 | (Curly.run { (with_path "write_body") with Request.body; meth = `POST }) 89 | ;; 90 | 91 | let () = 92 | let stopper = test_server () in 93 | let tests_done = 94 | Lwt_preemptive.detach 95 | (fun () -> 96 | Alcotest.run 97 | "curly" 98 | [ ( "curly" 99 | , [ "simple_get", `Quick, run_simple_get 100 | ; "read_header", `Quick, read_header 101 | ; "write_body", `Quick, write_body 102 | ] ) 103 | ]) 104 | () 105 | in 106 | tests_done >|= (fun () -> Lwt.wakeup stopper ()) |> Lwt_main.run 107 | ;; 108 | --------------------------------------------------------------------------------