HTTP.ml 6.79 KB
Newer Older
Josh Kunz's avatar
Josh Kunz committed
1 2 3 4 5
open Lexing
open Parsing
open HTTPLex
open HTTPParse
open HTTPTypes
Josh Kunz's avatar
Josh Kunz committed
6
open Buffer
7

Josh Kunz's avatar
Josh Kunz committed
8 9
open Printf
open List
10

11
type uri = string
Josh Kunz's avatar
Josh Kunz committed
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
exception Header_not_found

module Header : sig
    val get_header : headers -> string -> string 
    val set_header : headers -> string -> string -> headers
    val del_header : headers -> string -> headers

    val string_of_header : header -> string
    val string_of_headers : headers -> string
end = struct
    let rec set_header (hs : headers) n v =
        match hs with
        | {name = n_; value = v_ } :: hs_ when n = n_ ->
            {name = n; value = v} :: hs_;
        | h :: hs_ -> h :: (set_header hs_ n v)
        | [] -> {name = n; value = v} :: [];;

    let rec get_header hs n =
        match hs with 
        | {name = n_; value = v} :: hs_ when n_ = n -> v
        | h :: hs_ -> (get_header hs_ n)
        | [] -> raise Header_not_found;;

    let rec del_header hs n =
        match hs with 
        | {name = n_; value = _} :: hs_ when n = n_ -> hs_
        | h :: hs_ -> h :: (del_header hs_ n)
        | [] -> raise Header_not_found;;

    let string_of_header h = 
        sprintf "%s: %s\r\n" h.name h.value;;

    let string_of_headers hs = 
        List.map string_of_header hs |> String.concat "";;

end;;

Josh Kunz's avatar
Josh Kunz committed
49 50 51 52 53 54 55
let http_1_1 = "HTTP/1.1";;

let read_body hdrs ic buf =
    try 
        let len = Header.get_header hdrs "Content-Length" |> int_of_string in
        let body = String.create len in
        let body_in_buffer = buf.lex_buffer_len - buf.lex_curr_pos in
Josh Kunz's avatar
Josh Kunz committed
56
        if body_in_buffer > 0 then 
Josh Kunz's avatar
Josh Kunz committed
57
            String.blit buf.lex_buffer buf.lex_curr_pos body 0 body_in_buffer;
Josh Kunz's avatar
Josh Kunz committed
58 59 60
        if len - body_in_buffer > 0 then
            really_input ic body body_in_buffer (len - body_in_buffer);
        body;
Josh Kunz's avatar
Josh Kunz committed
61 62 63
    with
    | Header_not_found -> "";;

Josh Kunz's avatar
Josh Kunz committed
64 65 66
exception Bad_request of string;;
exception Bad_response of string;;

67
module type HTTP_COMMON = sig
Josh Kunz's avatar
Josh Kunz committed
68 69 70
    type t
    val read : in_channel -> t
    val write : out_channel -> t -> unit
71 72
    val as_string : t -> string

Josh Kunz's avatar
Josh Kunz committed
73 74 75 76
    val set_header : t -> string -> string -> t
    val get_header : t -> string -> string 
end;;

77
module Request : sig
Josh Kunz's avatar
Josh Kunz committed
78
    type t = { meth: string;
79 80 81 82
               uri: uri; 
               version: string; 
               headers: headers;
               body: string};;
83 84 85 86 87 88 89 90 91 92 93
    include HTTP_COMMON with type t := t
    val make : string -> uri -> string -> t
end = struct
    type t = { meth: string;
               uri: uri; 
               version: string; 
               headers: headers;
               body: string};;
    let make meth uri body = 
        { meth = meth; uri = uri; version = http_1_1;
          headers = []; body = body };;
94

95
    let sheaders r h =
Josh Kunz's avatar
Josh Kunz committed
96 97 98
        { meth = r.meth; uri = r.uri; version = r.version;
          headers = h; body = r.body };;

99 100 101 102 103 104 105 106
    let get_header r n = 
        Header.get_header r.headers n;;

    let set_header r n v = 
        Header.set_header r.headers n v |> sheaders r

    let read ic = 
        let buf = Lexing.from_channel ic in
Josh Kunz's avatar
Josh Kunz committed
107 108
        try 
            let ((m, p, v), hdrs) = HTTPParse.request HTTPLex.http_token buf in
109
            { meth = m; uri = p; version = v; headers = hdrs; 
Josh Kunz's avatar
Josh Kunz committed
110
              body = read_body hdrs ic buf}
Josh Kunz's avatar
Josh Kunz committed
111
        with
112
        | Parse_error | Failure _ -> raise (Bad_request "Couldn't parse request.")
Josh Kunz's avatar
Josh Kunz committed
113 114 115 116 117 118 119 120
        | Header_not_found -> raise (Bad_request "No Content-Length header.")
        | End_of_file -> raise (Bad_request "Connection terminated early.");;

    let as_string r =
        sprintf "%s %s %s\r\n%s\r\n%s" 
        r.meth r.uri r.version
        (Header.string_of_headers r.headers)
        r.body;;
121

Josh Kunz's avatar
Josh Kunz committed
122
    let write oc r = as_string r |> output_string oc; flush oc;;
Josh Kunz's avatar
Josh Kunz committed
123
end;;
Josh Kunz's avatar
Josh Kunz committed
124

125 126 127 128 129 130 131
module Response : sig
    type t = { version: string;
               code: int;
               reason: string;
               headers: headers;
               body: string};;
    include HTTP_COMMON with type t := t
132 133
    val make : int -> string -> t
    val reason_for_code : int -> string
134
end = struct
135 136 137 138 139
    type t = { version: string;
               code: int;
               reason: string;
               headers: headers;
               body: string};;
Josh Kunz's avatar
Josh Kunz committed
140

141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185
    let codes = [
          (101, "Switching Protocols")
        ; (200, "OK")
        ; (201, "Created")
        ; (202, "Accepted")
        ; (203, "Non-Authoritative Information")
        ; (204, "No Content")
        ; (205, "Reset Content")
        ; (206, "Partial Content")
        ; (300, "Multiple Choices")
        ; (301, "Moved Permanently")
        ; (302, "Found")
        ; (303, "See Other")
        ; (304, "Not Modified")
        ; (305, "Use Proxy")
        ; (307, "Temporary Redirect")
        ; (400, "Bad Request")
        ; (401, "Unauthorized")
        ; (402, "Payment Required")
        ; (403, "Forbidden")
        ; (404, "Not Found")
        ; (405, "Method Not Allowed")
        ; (406, "Not Acceptable")
        ; (407, "Proxy Authentication Required")
        ; (408, "Request Timeout")
        ; (409, "Conflict")
        ; (410, "Gone")
        ; (411, "Length Required")
        ; (412, "Precondition Failed")
        ; (413, "Request Entity Too Large")
        ; (414, "Request-URI Too Long")
        ; (415, "Unsupported Media Type")
        ; (416, "Requested Range Not Satisfiable")
        ; (417, "Expectation Failed")
        ; (500, "Internal Server Error")
        ; (501, "Not Implemented")
        ; (502, "Bad Gateway")
        ; (503, "Service Unavailable")
        ; (504, "Gateway Timeout")
        ; (505, "HTTP Version Not Supported") ];;

    let reason_for_code c = List.assoc c codes;;

    let make code body = 
        { code = code; reason = reason_for_code code; version = http_1_1;
186
          headers = []; body = body };;
Josh Kunz's avatar
Josh Kunz committed
187

188
    let sheaders r h =
Josh Kunz's avatar
Josh Kunz committed
189 190
        { version = r.version; code = r.code; reason = r.reason;
          headers = h; body = r.body };;
Josh Kunz's avatar
Josh Kunz committed
191

192 193 194 195 196 197 198
    let get_header r n = 
        Header.get_header r.headers n;;
    let set_header r n v = 
        Header.set_header r.headers n v |> sheaders r

    let read ic =
        let buf = Lexing.from_channel ic in
Josh Kunz's avatar
Josh Kunz committed
199 200
        try 
            let ((v, c, r), hdrs) = HTTPParse.response HTTPLex.http_token buf in
201
            { version = v; code = c; reason = r; headers = hdrs; 
Josh Kunz's avatar
Josh Kunz committed
202
              body = read_body hdrs ic buf}
Josh Kunz's avatar
Josh Kunz committed
203
        with
204
        | Parse_error | Failure _ -> raise (Bad_response "Couldn't parse response.")
Josh Kunz's avatar
Josh Kunz committed
205 206 207 208 209 210
        | Header_not_found -> raise (Bad_response "No Content-Length header.")
        | End_of_file -> raise (Bad_response "Connection terminated early.");;

    let as_string r =
        sprintf "%s %d %s\r\n%s\r\n%s" 
        r.version r.code r.reason
211 212 213 214 215
        (if (String.length r.body) > 0 then
            set_header r "Content-Length" (String.length r.body |>
            string_of_int) |> fun x -> Header.string_of_headers x.headers
        else
            Header.string_of_headers r.headers)
Josh Kunz's avatar
Josh Kunz committed
216
        r.body;;
Josh Kunz's avatar
Josh Kunz committed
217

218
    let write oc r = as_string r |> output_string oc; flush oc;;
Josh Kunz's avatar
Josh Kunz committed
219
end;;