Source file `response.ml`

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
(*{{{ Copyright (c) 2012-2013 Anil Madhavapeddy <anil@recoil.org>
 *
 * Permission to use, copy, modify, and distribute this software for any
 * purpose with or without fee is hereby granted, provided that the above
 * copyright notice and this permission notice appear in all copies.
 *
 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 *
  }}}*)

type t = Http.Response.t = {
  headers : Header.t;
  version : Code.version;
  status : Code.status_code;
}
[@@deriving sexp]

let compare { headers; version; status } y =
  match Header.compare headers y.headers with
  | 0 -> (
      match Stdlib.compare status y.status with
      | 0 -> (
          match Stdlib.compare status y.status with
          | 0 -> Code.compare_version version y.version
          | i -> i)
      | i -> i)
  | i -> i

let headers t = t.headers
let encoding t = Header.get_transfer_encoding t.headers
let version t = t.version
let status t = t.status

let make ?(version = `HTTP_1_1) ?(status = `OK) ?(encoding = Transfer.Unknown)
    ?(headers = Header.init ()) () =
  let headers =
    match encoding with
    | Unknown -> (
        match Header.get_transfer_encoding headers with
        | Unknown -> Header.add_transfer_encoding headers Chunked
        | _ -> headers)
    | _ -> Header.add_transfer_encoding headers encoding
  in
  { headers; version; status }

let pp_hum ppf r =
  Format.fprintf ppf "%s" (r |> sexp_of_t |> Sexplib0.Sexp.to_string_hum)

let allowed_body response =
  (* rfc7230#section-5.7.1 *)
  match status response with
  | #Code.informational_status | `No_content | `Not_modified -> false
  | #Code.status_code -> true

let has_body response =
  if allowed_body response then Transfer.has_body (encoding response) else `No

type tt = t

module Make (IO : S.IO) = struct
  type t = tt

  module IO = IO
  module Header_IO = Header_io.Make (IO)
  module Transfer_IO = Transfer_io.Make (IO)

  type reader = Transfer_IO.reader
  type writer = Transfer_IO.writer

  open IO

  let parse_response_fst_line ic =
    let open Code in
    read_line ic >>= function
    | Some response_line -> (
        match String.split_on_char ' ' response_line with
        | version_raw :: code_raw :: _ -> (
            match version_of_string version_raw with
            | (`HTTP_1_0 | `HTTP_1_1) as v ->
                return (`Ok (v, status_of_code (int_of_string code_raw)))
            | `Other _ ->
                return (`Invalid ("Malformed response version: " ^ version_raw))
            )
        | _ ->
            return
              (`Invalid ("Malformed response first line: " ^ response_line)))
    | None -> return `Eof

  let read ic =
    parse_response_fst_line ic >>= function
    | `Eof -> return `Eof
    | `Invalid _reason as r -> return r
    | `Ok (version, status) ->
        Header_IO.parse ic >>= fun headers ->
        return (`Ok { headers; version; status })

  let make_body_reader t ic = Transfer_IO.make_reader (encoding t) ic
  let read_body_chunk = Transfer_IO.read

  let write_header res oc =
    write oc
      (Printf.sprintf "%s %s\r\n"
         (Code.string_of_version res.version)
         (Code.string_of_status res.status))
    >>= fun () ->
    let headers =
      if allowed_body res then
        Header.add_transfer_encoding res.headers (encoding res)
      else res.headers
    in
    Header_IO.write headers oc

  let make_body_writer ~flush t oc =
    Transfer_IO.make_writer ~flush (encoding t) oc

  let write_body = Transfer_IO.write

  let write_footer t oc =
    match encoding t with
    | Transfer.Chunked ->
        (* TODO Trailer header support *)
        IO.write oc "0\r\n\r\n"
    | Transfer.Fixed _ | Transfer.Unknown -> return ()

  let write ~flush fn req oc =
    write_header req oc >>= fun () ->
    let writer = make_body_writer ~flush req oc in
    fn writer >>= fun () -> write_footer req oc
end

module Private = struct
  module Make = Make
end