Commit d2d34492 authored by Josh Kunz's avatar Josh Kunz

See extended commit message:

    * Got HTTP functors working
    * Moved OCaml implicit rules to common/Makefile.implicit
    * Split the HTTP types out into a separate module
parent 036c0a71
%.cmo: %.ml
ocamlc $(OCAMLFLAGS) -c $<
%.cmx: %.ml
ocamlopt $(OCAMLFLAGS) -c $<
%.cmi: %.mli
ocamlc $(OCAMLFLAGS) -c $<
type header = {name: string; value: string}
type headers = header list
type uri = string
open Lexing
open Parsing
open HTTPLex
open HTTPParse
open HTTPTypes
module Parse = struct
type request_line = string * uri * string
type request = request_line * headers
open Printf
open List
type response_line = string * int * string
type response = response_line * headers
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;;
exception Bad_request of string;;
exception Bad_response of string;;
module type HTTP_IO = sig
type t
val read : in_channel -> t
val write : out_channel -> t -> unit
val from_string : string -> t
val as_string : t -> string
val set_header : t -> string -> string -> t
val get_header : t -> string -> string
end;;
module type HTTP_IO_Base = sig
type t
val _fheaders : t -> headers;;
val _sheaders : t -> headers -> t;;
val _read : Lexing.lexbuf -> (int -> int -> string) -> t
val as_string : t -> string
end;;
module Request = struct
type t = { meth: string;
module HTTPBase (R : HTTP_IO_Base) : (HTTP_IO with type t = R.t) = struct
type t = R.t
let get_header r n = Header.get_header (R._fheaders r) n;;
let set_header r n v =
Header.set_header (R._fheaders r) n v |> R._sheaders r
let from_string s =
let reader pos len = String.sub s pos len in
(Lexing.from_string s |> R._read) reader ;;
let as_string = R.as_string
let write oc r = as_string r |> output_string oc;;
let read ic =
let body = "" in
let reader pos len = really_input ic body 0 len; body in
(Lexing.from_channel ic |> R._read) reader;;
end;;
module Request : HTTP_IO = HTTPBase(struct
type t = { meth: string;
uri: uri;
version: string;
headers: headers;
body: string};;
end;;
module Response = struct
let _fheaders r = r.headers;;
let _sheaders r h =
{ meth = r.meth; uri = r.uri; version = r.version;
headers = h; body = r.body };;
let _read buf reader =
try
let ((m, p, v), hdrs) = HTTPParse.request HTTPLex.http_token buf in
let length = Header.get_header hdrs "Content-Length" |> int_of_string in
let body = reader buf.lex_curr_p.pos_cnum length in
{ meth = m; uri = p; version = v; headers = hdrs; body = body}
with
| Parse_error -> raise (Bad_request "Couldn't parse request.")
| 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;;
end);;
module Response : HTTP_IO = HTTPBase(struct
type t = { version: string;
code: int;
reason: string;
headers: headers;
body: string};;
end;;
let _fheaders r = r.headers;;
let _sheaders r h =
{ version = r.version; code = r.code; reason = r.reason;
headers = h; body = r.body };;
let _read buf reader =
try
let ((v, c, r), hdrs) = HTTPParse.response HTTPLex.http_token buf in
let length = Header.get_header hdrs "Content-Length" |> int_of_string in
let body = reader buf.lex_curr_p.pos_cnum length in
{ version = v; code = c; reason = r; headers = hdrs; body = body}
with
| Parse_error -> raise (Bad_response "Couldn't parse response.")
| 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
(Header.string_of_headers r.headers)
r.body;;
end);;
{
open HTTP
open HTTPTypes
open HTTPParse
open Printf
}
......@@ -52,7 +52,7 @@ let header = (token as n) ':' LWS? (field as v) LWS?
rule http_token = parse
| status_line { RESPONSE(v, (int_of_string c), r) }
| request_line { REQUEST(m, u, v) }
| header { HEADER({HTTP.name=n;
HTTP.value=v}) }
| header { HEADER({HTTPTypes.name=n;
HTTPTypes.value=v}) }
| CRLF { CRLF }
| ':' { COLON }
%{
open HTTP;;
open HTTPTypes;;
open Parsing;;
Parsing.set_trace true;;
%}
%token CRLF COLON LWS
%token<string> TOKEN FIELD
%token<HTTP.Parse.request_line> REQUEST
%token<HTTP.Parse.response_line> RESPONSE
%token<HTTP.header> HEADER
%token<HTTPTypes.Parse.request_line> REQUEST
%token<HTTPTypes.Parse.response_line> RESPONSE
%token<HTTPTypes.header> HEADER
%start request response
%type<HTTP.Parse.request> request
%type<HTTP.Parse.response> response
%type<HTTPTypes.Parse.request> request
%type<HTTPTypes.Parse.response> response
%%
response:
| RESPONSE CRLF message_headers CRLF { ($1, $3) }
......
type header = {name: string; value: string}
type headers = header list
type uri = string
module Parse = struct
type request_line = string * uri * string
type request = request_line * headers
type response_line = string * int * string
type response = response_line * headers
end;;
......@@ -2,7 +2,7 @@
OCAMLLEX_FLAGS =
OCAMLYACC_FLAGS =
OCAMLFLAGS =
OCAMLFLAGS =
bin = test
......@@ -13,7 +13,7 @@ libs = unix
interfaces = $(yacc_prefix).mli $(wildcard *.mli)
sources = $(yacc_prefix).ml $(lex_prefix).ml
sources += Test.ml
sources += HTTPTypes.ml HTTP.ml Test.ml
objects = $(patsubst %.ml,%.cmo,$(sources))
......@@ -33,22 +33,13 @@ $(lex_prefix).ml: $(par_prefix).mll
$(yacc_prefix).ml $(yacc_prefix).mli: $(par_prefix).mly
ocamlyacc $(OCAMLYACC_FLAGS) -b$(yacc_prefix) $<
%.cmo: %.ml
ocamlc $(OCAMLFLAGS) -c $<
%.cmx: %.ml
ocamlopt $(OCAMLFLAGS) -c $<
%.cmi: %.mli
ocamlc $(OCAMLFLAGS) -c $<
$(depfile): $(sources) $(interfaces)
ocamldep $(OCAMLFLAGS) $^ > $@
ocamldep $^ > $@
clean:
-rm -f $(bin) *.cmo *.cmi *.o *.cmx
-rm -f $(lex_prefix).ml $(wildcard $(yacc_prefix).ml*)
-rm -f $(depfile)
include ../common/Makefile.implicit
-include $(depfile)
......@@ -28,16 +28,8 @@ jsonm.ml jsonm.mli: $(jsonm_src)
$(depfile): $(source)
ocamldep $(OCAMLFLAGS) $^ > $@
-include $(depfile)
%.cmo: %.ml
ocamlc $(OCAMLFLAGS) -c $<
%.cmx: %.ml
ocamlopt $(OCAMLFLAGS) -c $<
%.cmi: %.mli
ocamlc $(OCAMLFLAGS) -c $<
clean:
-rm -f $(objects) $(interfaces) $(lib) $(depfile) $(source)
include ../common/Makefile.implicit
-include $(depfile)
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment