1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
open B0_std
open Result.Syntax
module Http = struct
type method' =
[ `CONNECT | `DELETE | `GET | `HEAD | `OPTIONS | `Other of string
| `PATCH | `POST | `PUT | `TRACE ]
let method_to_string = function
| `GET -> "GET" | `HEAD -> "HEAD" | `POST -> "POST" | `PUT -> "PUT"
| `DELETE -> "DELETE" | `CONNECT -> "CONNECT" | `OPTIONS -> "OPTIONS"
| `TRACE -> "TRACE" | `PATCH -> "PATCH" | `Other s -> s
let (k, v) = String.concat "" [k; ": "; v]
module Request = struct
type t =
{ url : string;
method' : method';
headers : headers;
body : string; }
let make ?( = []) ?(body = "") method' ~url =
{ url; method'; headers; body }
let url r = r.url
let method' r = r.method'
let r = r.headers
let body r = r.body
let has_body r = not (String.is_empty r.body)
end
module Response = struct
type t =
{ status : int;
headers : headers;
body : string; }
let make ?( = []) ?(body = "") status = { status; headers; body }
let status r = r.status
let r = r.headers
let body r = r.body
let status_of_status_line l =
let err i = Fmt.error "%S: could not parse HTTP status code" i in
match String.split_all ~sep:" " l with
| (_ :: code :: _) ->
(try Ok (int_of_string code) with | Failure _ -> err code)
| _ -> err l
let headers_and_body_of_string s =
let rec loop acc s = match String.split_first ~sep:"\r\n" s with
| None -> Fmt.failwith "%S: could not find CRLF" s
| Some ("", body) -> Ok (List.rev acc, body)
| Some (h, rest) ->
match String.split_first ~sep:":" h with
| None -> Fmt.failwith "%S: could not parse HTTP header" h
| Some (k, v) ->
loop ((String.lowercase_ascii k, String.trim v) :: acc) rest
in
try loop [] s with Failure e -> Error e
let of_string resp = match String.split_first ~sep:"\r\n" resp with
| None -> Fmt.error "%S: could not parse status line" resp
| Some (status_line, rest) ->
let* status = status_of_status_line status_line in
let* , body = headers_and_body_of_string rest in
Ok { status; headers; body }
end
end
module Http_client = struct
type t = Cmd.t
let default = Cmd.tool "curl"
let make ?(insecure = false) ?search ?(cmd = default) () =
let* curl = Os.Cmd.get ?search cmd in
Ok (Cmd.(curl %% if' insecure (arg "--insecure")))
let find_location request response =
match List.assoc_opt "location" (Http.Response.headers response) with
| None -> Error "No 'location' header found in 3XX response"
| Some loc ->
let url = Http.Request.url request in
try match B0_url.kind loc with
| `Absolute -> Ok loc
| `Relative `Relative_path ->
begin match String.rindex_opt url '/' with
| None -> Ok (String.concat "/" [url; loc])
| Some i -> Ok (String.concat "/" [String.sub url 0 i; loc])
end
| `Relative `Absolute_path ->
begin match B0_url.scheme url with
| None -> raise Exit
| Some s ->
match B0_url.authority url with
| None -> raise Exit
| Some a -> Ok (String.concat "" [s; "://"; a; loc])
end
| `Relative _ -> raise Exit
with
| Exit ->
Fmt.error "Could not construct redirect from %s to %s" url loc
let redirect_response visited request response =
match Http.Response.status response with
| 301 | 302 | 303 | 305 | 307 ->
let* url = find_location request response in
if List.mem url visited then Error "Infinite redirection loop" else
Ok (Some { request with url })
| _ -> Ok None
let request curl ~follow request =
let rec loop follow visited request =
let method' = Http.Request.method' request in
let is_head = method' = `HEAD in
let follow = match method' with `GET | `HEAD -> follow | _ -> false in
let method' = Http.method_to_string method' in
let method' = Cmd.(arg "-X" % method' %% if' is_head (arg "--head")) in
let = Http.Request.headers request in
let = Cmd.of_list ~slip:"-H" Http.header_to_string headers in
let has_body = Http.Request.has_body request in
let body = Http.Request.body request in
let stdin = if has_body then Os.Cmd.in_string body else Os.Cmd.in_stdin in
let body = Cmd.(if' has_body (arg "--data-binary" % "@-")) in
let url = Http.Request.url request in
let base = Cmd.(arg "-s" % "-i" ) in
let args = Cmd.(base %% method' %% headers %% body % url) in
let* out = Os.Cmd.run_out ~trim:false ~stdin Cmd.(curl %% args) in
let* response = Http.Response.of_string out in
if not follow then Ok response else
let* redirect = redirect_response visited request response in
match redirect with
| None -> Ok response
| Some request -> loop follow (url :: visited) request
in
loop follow [] request
let curl ?docs ?env () =
let open Cmdliner in
let doc = "The curl command $(docv) to use." in
let cmd = Arg.conv' ~docv:"CMD" (B0_std.Cmd.of_string, B0_std.Cmd.pp_dump)in
Arg.(value & opt cmd default & info ["curl"] ~doc ?docs ?env ~docv:"CMD")
let curl_fetch_args ?(args = Cmd.empty) ~progress url file =
let progress = if progress then Cmd.arg "-#" else Cmd.arg "--silent" in
let outf = Cmd.(arg "-o" %% path file) in
Cmd.(arg "--fail" % "--show-error" %% progress % "-L" %% outf %% args % url)
end