diff --git a/.gitmodules b/.gitmodules index f5f716b3..e69de29b 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,3 +0,0 @@ -[submodule "vendor/curly"] - path = vendor/curly - url = https://github.com/rgrinberg/curly.git diff --git a/src/bin/curly.ml b/src/bin/curly.ml deleted file mode 120000 index 635bfce9..00000000 --- a/src/bin/curly.ml +++ /dev/null @@ -1 +0,0 @@ -../../vendor/curly/src/curly.ml \ No newline at end of file diff --git a/src/bin/curly.ml b/src/bin/curly.ml new file mode 100644 index 00000000..5b938544 --- /dev/null +++ b/src/bin/curly.ml @@ -0,0 +1,237 @@ +module Result = struct + include Result + let (>>=) + : type a b e. (a, e) result -> (a -> (b, e) result) -> (b, e) result + = fun r f -> + match r with + | Ok x -> f x + | (Error _) as e -> e +end + +open Result + +module Meth = struct + type t = + [ `GET + | `POST + | `HEAD + | `PUT + | `DELETE + | `OPTIONS + | `TRACE + | `CONNECT + | `PATCH + | `Other of string + ] + + let to_string = function + | `GET -> "GET" + | `POST -> "POST" + | `HEAD -> "HEAD" + | `PUT -> "PUT" + | `DELETE -> "DELETE" + | `OPTIONS -> "OPTIONS" + | `TRACE -> "TRACE" + | `CONNECT -> "CONNECT" + | `PATCH -> "PATCH" + | `Other s -> s + + let pp fmt t = Format.fprintf fmt "%s" (to_string t) +end + +module Header = struct + type t = (string * string) list + + let empty = [] + + let to_cmd t = + t + |> List.map (fun (k, v) -> ["-H"; Printf.sprintf "%s: %s" k v]) + |> List.concat + + let pp fmt t = + Format.pp_print_list + ~pp_sep:Format.pp_print_newline + (fun fmt (k ,v) -> Format.fprintf fmt "%s: %s\n" k v) + fmt t +end + +module Response = struct + type t = Http.response = + { code: int + ; headers: Header.t + ; body: string + } + + let default = + { code = 0 + ; headers = [] + ; body = "" } + + let of_stdout s = + let lexbuf = Lexing.from_string s in + try Ok (Http.response default lexbuf) + with e -> Error e + + let pp fmt t = + Format.fprintf fmt "{code=%d;@ headers=%a;@ body=\"%s\"}" + t.code Header.pp t.headers t.body +end + +module Process_result = struct + type t = + { status: Unix.process_status + ; stderr: string + ; stdout: string + } + + let pp_process_status fmt = function + | Unix.WEXITED n -> Format.fprintf fmt "Exit code %d" n + | Unix.WSIGNALED n -> Format.fprintf fmt "Signal %d" n + | Unix.WSTOPPED n -> Format.fprintf fmt "Stopped %d" n + + let pp fmt t = + Format.fprintf fmt "{status=%a;@ stderr=\"%s\";@ stdout=\"%s\"}" + pp_process_status t.status t.stderr t.stdout +end + +module Error = struct + type t = + | Invalid_request of string + | Bad_exit of Process_result.t + | Failed_to_read_response of exn * Process_result.t + | Exn of exn + + let pp fmt = function + | Bad_exit p -> + Format.fprintf fmt "Non 0 exit code %a@.%a" + Process_result.pp_process_status p.Process_result.status + Process_result.pp p + | Failed_to_read_response (e, _) -> + Format.fprintf fmt "Couldn't read response:@ %s" (Printexc.to_string e) + | Invalid_request r -> Format.fprintf fmt "Invalid request: %s" r + | Exn e -> Format.fprintf fmt "Exception: %s" (Printexc.to_string e) +end + +module Request = struct + type t = + { meth: Meth.t + ; url: string + ; headers: Header.t + ; body: string + } + + let make ?(headers=Header.empty) ?(body="") ~url ~meth () = + { meth + ; url + ; headers + ; body } + + let has_body t = String.length t.body > 0 + + let validate t = + if has_body t && List.mem t.meth [`GET; `HEAD] then + Error (Error.Invalid_request "No body is allowed with GET/HEAD methods") + else + Ok t + + let to_cmd_args t = + List.concat + [ ["-X"; Meth.to_string t.meth] + ; Header.to_cmd t.headers + ; [t.url] + ; (if has_body t then + ["--data-binary"; "@-"] + else + []) + ] + + let pp fmt t = + Format.fprintf fmt + "{@ meth=%a;@ url=\"%s\";@ headers=\"%a\";@ body=\"%s\"@ }" + Meth.pp t.meth t.url Header.pp t.headers t.body +end + +let result_of_process_result t = + match t.Process_result.status with + | Unix.WEXITED 0 -> Ok t + | _ -> Error (Error.Bad_exit t) + +let run prog args stdin_str = + let (stdout, stdin, stderr) = + let prog = + prog :: (List.map Filename.quote args) + |> String.concat " " in + Unix.open_process_full prog [||] in + if String.length stdin_str > 0 then ( + output_string stdin stdin_str + ); + begin + try close_out stdin; + with _ -> () + end; + let stdout_fd = Unix.descr_of_in_channel stdout in + let stderr_fd = Unix.descr_of_in_channel stderr in + let (in_buf, err_buf) = Buffer.(create 128, create 128) in + let read_buf_len = 512 in + let read_buf = Bytes.create read_buf_len in + let input ch = + match input ch read_buf 0 read_buf_len with + | 0 -> Error `Eof + | s -> Ok s in + let rec loop = function + | [] -> () + | read_list -> + let can_read, _, _ = Unix.select read_list [] [] 1.0 in + let to_remove = + List.fold_left (fun to_remove fh -> + let (rr, buf) = + if fh = stderr_fd then ( + (input stderr, err_buf) + ) else ( + (input stdout, in_buf) + ) in + begin match rr with + | Ok len -> + Buffer.add_subbytes buf read_buf 0 len; + to_remove + | Error `Eof -> + fh :: to_remove + end + ) [] can_read in + read_list + |> List.filter (fun fh -> not (List.mem fh to_remove)) + |> loop + in + ignore (loop [ stdout_fd ; stderr_fd ]); + let status = Unix.close_process_full (stdout, stdin, stderr) in + { Process_result. + status + ; stdout = Buffer.contents in_buf + ; stderr = Buffer.contents err_buf + } + +let run ?(exe="curl") ?(args=[]) req = + Request.validate req >>= fun req -> + let args = "-si" :: (Request.to_cmd_args req) @ args in + let res = + try + result_of_process_result (run exe args req.Request.body) + with e -> + Error (Error.Exn e) + in + res >>= fun res -> + match Response.of_stdout res.Process_result.stdout with + | Ok r -> Ok r + | Error e -> Error (Error.Failed_to_read_response (e, res)) + +let get ?exe ?args ?headers url = + run ?exe ?args (Request.make ?headers ~url ~meth:`GET ()) +let head ?exe ?args ?headers url = + run ?exe ?args (Request.make ?headers ~url ~meth:`HEAD ()) +let delete ?exe ?args ?headers url = + run ?exe ?args (Request.make ?headers ~url ~meth:`DELETE ()) +let post ?exe ?args ?headers ?body url = + run ?exe ?args (Request.make ?body ?headers ~url ~meth:`POST ()) +let put ?exe ?args ?headers ?body url = + run ?exe ?args (Request.make ?body ?headers ~url ~meth:`PUT ()) diff --git a/src/bin/curly.mli b/src/bin/curly.mli deleted file mode 120000 index d0697dc6..00000000 --- a/src/bin/curly.mli +++ /dev/null @@ -1 +0,0 @@ -../../vendor/curly/src/curly.mli \ No newline at end of file diff --git a/src/bin/curly.mli b/src/bin/curly.mli new file mode 100644 index 00000000..d3898a75 --- /dev/null +++ b/src/bin/curly.mli @@ -0,0 +1,125 @@ +module Meth : sig + type t = + [ `GET + | `POST + | `HEAD + | `PUT + | `DELETE + | `OPTIONS + | `TRACE + | `CONNECT + | `PATCH + | `Other of string ] + + val pp : Format.formatter -> t -> unit +end + +module Header : sig + type t = (string * string) list + + val pp : Format.formatter -> t -> unit +end + +module Response : sig + type t = + { code: int + ; headers: Header.t + ; body:string + } + + val pp : Format.formatter -> t -> unit +end + +module Request : sig + type t = + { meth: Meth.t + ; url:string + ; headers: Header.t + ; body:string + } + + val make + : ?headers:Header.t + -> ?body:string + -> url:string + -> meth:Meth.t + -> unit + -> t + + val to_cmd_args : t -> string list + + val pp : Format.formatter -> t -> unit +end + +module Process_result : sig + type t = + { status: Unix.process_status + ; stderr:string + ; stdout:string + } + + val pp : Format.formatter -> t -> unit +end + +module Error : sig + type t = + | Invalid_request of string + | Bad_exit of Process_result.t + | Failed_to_read_response of exn * Process_result.t + | Exn of exn + + val pp : Format.formatter -> t -> unit +end + +val run + : ?exe:string + -> ?args:string list + -> Request.t + -> (Response.t, Error.t) Result.result + +val get + : ?exe:string + -> ?args:string list + -> ?headers:Header.t + -> string + -> (Response.t, Error.t) Result.result +(** Specialized version of {!run} for method [`GET] + @since 0.2.0 *) + +val head + : ?exe:string + -> ?args:string list + -> ?headers:Header.t + -> string + -> (Response.t, Error.t) Result.result +(** Specialized version of {!run} for method [`HEAD] + @since 0.2.0 *) + +val delete + : ?exe:string + -> ?args:string list + -> ?headers:Header.t + -> string + -> (Response.t, Error.t) Result.result +(** Specialized version of {!run} for method [`DELETE] + @since 0.2.0 *) + +val post + : ?exe:string + -> ?args:string list + -> ?headers:Header.t + -> ?body:string + -> string + -> (Response.t, Error.t) Result.result +(** Specialized version of {!run} for method [`POST] + @since 0.2.0 *) + +val put + : ?exe:string + -> ?args:string list + -> ?headers:Header.t + -> ?body:string + -> string + -> (Response.t, Error.t) Result.result +(** Specialized version of {!run} for method [`PUT] + @since 0.2.0 *) diff --git a/src/bin/http.mli b/src/bin/http.mli deleted file mode 120000 index b4c3203f..00000000 --- a/src/bin/http.mli +++ /dev/null @@ -1 +0,0 @@ -../../vendor/curly/src/http.mli \ No newline at end of file diff --git a/src/bin/http.mli b/src/bin/http.mli new file mode 100644 index 00000000..044d53a6 --- /dev/null +++ b/src/bin/http.mli @@ -0,0 +1,9 @@ +(* The purpose of this module isn't to be a full blown http parser but rather to + only parse whatever curl otputs *) +type response = + { code: int + ; headers: (string * string) list + ; body: string + } + +val response : response -> Lexing.lexbuf -> response diff --git a/src/bin/http.mll b/src/bin/http.mll deleted file mode 120000 index 492d4bed..00000000 --- a/src/bin/http.mll +++ /dev/null @@ -1 +0,0 @@ -../../vendor/curly/src/http.mll \ No newline at end of file diff --git a/src/bin/http.mll b/src/bin/http.mll new file mode 100644 index 00000000..6789aaac --- /dev/null +++ b/src/bin/http.mll @@ -0,0 +1,52 @@ +{ + +type response = + { code: int + ; headers: (string * string) list + ; body: string + } + +let add_code t code = + { t with code = int_of_string code } + +let add_header t key val_ = + { t with headers = (key, (String.trim val_)) :: t.headers } + +let add_body t b = { t with body=Buffer.contents b } + +let set_lexeme_length buf n = + let open Lexing in + if n < 0 then + invalid_arg "set_lexeme_length: offset should be positive"; + if n > buf.lex_curr_pos - buf.lex_start_pos then + invalid_arg "set_lexeme_length: offset larger than lexeme"; + buf.lex_curr_pos <- buf.lex_start_pos + n; + buf.lex_curr_p <- { + buf.lex_start_p + with pos_cnum = buf.lex_abs_pos + buf.lex_curr_pos + } +} + +let space = [' ' '\t'] + +rule response resp = parse + | [^ ' ']+ { code resp lexbuf } +and code resp = parse + | space+ (['0' - '9']+ as code) { status (add_code resp code) lexbuf } +and status resp = parse + | space+ { status resp lexbuf } + | [^ '\n']+ '\n' { header_start resp lexbuf } +and header_start resp = parse + | "\r\n" { body resp (Buffer.create 128) lexbuf } + | space+ { header_start resp lexbuf } + | _ { + set_lexeme_length lexbuf 0; + header_key resp lexbuf + } +and header_key resp = parse + | space* ([^ ':']+ as key) space* ':' space* { header_val resp key lexbuf } +and header_val resp key = parse + | ([^ '\n']+ as v) '\n' { header_start (add_header resp key v) lexbuf } +and body resp b = parse + | eof { add_body resp b } + | _ as c { Buffer.add_char b c; body resp b lexbuf } diff --git a/vendor/curly b/vendor/curly deleted file mode 160000 index 9417bd97..00000000 --- a/vendor/curly +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 9417bd97fdf293f469c38e726c169583638d5aa1