tiny_httpd/src/bin/http.mll

{

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 }