unikernel/duniverse/httpun/lib/parse.ml

@@ -0,0 +1,382 @@
+(*----------------------------------------------------------------------------
+    Copyright (c) 2016 Inhabited Type LLC.
+
+    All rights reserved.
+
+    Redistribution and use in source and binary forms, with or without
+    modification, are permitted provided that the following conditions
+    are met:
+
+    1. Redistributions of source code must retain the above copyright
+       notice, this list of conditions and the following disclaimer.
+
+    2. Redistributions in binary form must reproduce the above copyright
+       notice, this list of conditions and the following disclaimer in the
+       documentation and/or other materials provided with the distribution.
+
+    3. Neither the name of the author nor the names of his contributors
+       may be used to endorse or promote products derived from this software
+       without specific prior written permission.
+
+    THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
+    OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+    WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+    DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
+    ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+    DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+    OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+    HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+    STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+    POSSIBILITY OF SUCH DAMAGE.
+  ----------------------------------------------------------------------------*)
+
+
+include Angstrom
+
+module P = struct
+  let is_space =
+    function | ' ' | '\t' -> true | _ -> false
+
+  let is_cr =
+    function | '\r' -> true | _ -> false
+
+  let is_space_or_colon =
+    function | ' ' | '\t' | ':' -> true | _ -> false
+
+  let is_hex =
+    function | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true | _ -> false
+
+  let is_digit =
+    function '0' .. '9' -> true | _ -> false
+
+  let is_separator =
+    function
+      | ')' | '(' | '<' | '>' | '@' | ',' | ';' | ':' | '\\' | '"'
+      | '/' | '[' | ']' | '?' | '=' | '{' | '}' | ' ' | '\t' -> true
+      | _ -> false
+
+  let is_token =
+    (* The commented-out ' ' and '\t' are not necessary because of the range at
+     * the top of the match. *)
+    function
+      | '\000' .. '\031' | '\127'
+      | ')' | '(' | '<' | '>' | '@' | ',' | ';' | ':' | '\\' | '"'
+      | '/' | '[' | ']' | '?' | '=' | '{' | '}' (* | ' ' | '\t' *) -> false
+      | _ -> true
+end
+
+let unit = return ()
+let token = take_while1 P.is_token
+let spaces = skip_while P.is_space
+
+let digit =
+  satisfy P.is_digit
+  >>| function
+    | '0' -> 0 | '1' -> 1 | '2' -> 2 | '3' -> 3 | '4' -> 4 | '5' -> 5
+    | '6' -> 6 | '7' -> 7 | '8' -> 8 | '9' -> 9 | _ -> assert false
+
+let eol = string "\r\n" <?> "eol"
+let hex str =
+  try return (Int64.of_string ("0x" ^ str)) with _ -> fail "hex"
+let skip_line = take_till P.is_cr *> eol
+
+let version =
+  string "HTTP/" *>
+  lift2 (fun major minor -> { Version.major; minor })
+    (digit <* char '.')
+    digit
+
+let header =
+  (* From RFC7230§3.2.4:
+
+       "No whitespace is allowed between the header field-name and colon.  In
+       the past, differences in the handling of such whitespace have led to
+       security vulnerabilities in request routing and response handling.  A
+       server MUST reject any received request message that contains whitespace
+       between a header field-name and colon with a response code of 400 (Bad
+       Request).  A proxy MUST remove any such whitespace from a response
+       message before forwarding the message downstream."
+
+    This can be detected by checking the message and marks in a parse failure,
+    which should look like this when serialized "... > header > :". *)
+  lift2 (fun key value -> (key, value))
+    (take_till P.is_space_or_colon <* char ':' <* spaces)
+    (take_till P.is_cr <* eol >>| String.trim)
+  <* commit
+  <?> "header"
+
+let headers =
+  let cons x xs = x :: xs in
+  fix (fun headers ->
+    let _emp = return [] in
+    let _rec = lift2 cons header headers in
+    peek_char_fail
+    >>= function
+      | '\r' -> _emp
+      | _    -> _rec)
+  >>| Headers.of_list
+
+let request =
+  let meth = take_till P.is_space >>| Method.of_string in
+  lift4 (fun meth target version headers ->
+    Request.create ~version ~headers meth target)
+    (meth                 <* char ' ')
+    (take_till P.is_space <* char ' ')
+    (version              <* eol <* commit)
+    (headers              <* eol)
+
+let response =
+  let status =
+    take_while P.is_digit
+    >>= fun str ->
+      if String.length str = 0
+      then fail "status-code empty"
+      else (
+        if String.length str > 3
+        then fail (Printf.sprintf "status-code too long: %S" str)
+        else return (Status.of_string str))
+  in
+  lift4 (fun version status reason headers ->
+    Response.create ~reason ~version ~headers status)
+    (version              <* char ' ')
+    (status               <* char ' ')
+    (take_till P.is_cr    <* eol <* commit)
+    (headers              <* eol)
+
+let finish body =
+  Body.Reader.close body;
+  commit
+
+let schedule_size body n =
+  let faraday = Body.Reader.unsafe_faraday body in
+  (* XXX(seliopou): performance regression due to switching to a single output
+   * format in Farady. Once a specialized operation is exposed to avoid the
+   * intemediate copy, this should be back to the original performance. *)
+  begin if Faraday.is_closed faraday
+  then advance n
+  else take_bigstring n >>| fun s -> Faraday.schedule_bigstring faraday s
+  end *> commit
+
+let body ~encoding body =
+  let rec fixed n ~unexpected =
+    if n = 0L
+    then unit
+    else
+      at_end_of_input
+      >>= function
+        | true -> commit *> fail unexpected
+        | false ->
+          available >>= fun m ->
+          let m' = Int64.(min (of_int m) n) in
+          let n' = Int64.sub n m' in
+          schedule_size body (Int64.to_int m') >>= fun () -> fixed n' ~unexpected
+  in
+  match encoding with
+  | `Fixed n ->
+    fixed n ~unexpected:"expected more from fixed body"
+    >>= fun () -> finish body
+  | `Chunked ->
+    (* XXX(seliopou): The [eol] in this parser should really parse a collection
+     * of "chunk extensions", as defined in RFC7230§4.1. These do not show up
+     * in the wild very frequently, and the httpun API has no way of exposing
+     * them to the suer, so for now the parser does not attempt to recognize
+     * them. This means that any chunked messages that contain chunk extensions
+     * will fail to parse. *)
+    fix (fun p ->
+      let _hex =
+        (take_while1 P.is_hex >>= fun size -> hex size)
+        (* swallows chunk-ext, if present, and CRLF *)
+        <* (eol *> commit)
+      in
+      _hex >>= fun size ->
+      if size = 0L
+      then eol >>= fun _eol -> finish body
+      else fixed size ~unexpected:"expected more from body chunk" *> eol *> p)
+  | `Close_delimited ->
+    fix (fun p ->
+      let _rec = (available >>= fun n -> schedule_size body n) *> p in
+      at_end_of_input
+      >>= function
+        | true  -> finish body
+        | false -> _rec)
+
+module Reader = struct
+  module AU = Angstrom.Unbuffered
+
+  type request_error = [
+    | `Bad_request of Request.t
+    | `Parse of string list * string ]
+
+  type response_error = [
+    | `Invalid_response_body_length of Response.t
+    | `Parse of string list * string ]
+
+  type 'error parse_state =
+    | Done
+    | Fail    of 'error
+    | Partial of (Bigstringaf.t -> off:int -> len:int -> AU.more -> (unit, 'error) result AU.state)
+
+  type 'error t =
+    { parser              : (unit, 'error) result Angstrom.t
+    ; mutable parse_state : 'error parse_state
+      (* The state of the parse for the current request *)
+    ; mutable closed      : bool
+      (* Whether the input source has left the building, indicating that no
+       * further input will be received. *)
+    ; mutable wakeup      : Optional_thunk.t
+    }
+
+  type request  = request_error t
+  type response = response_error t
+
+  let create parser =
+    { parser
+    ; parse_state = Done
+    ; closed      = false
+    ; wakeup      = Optional_thunk.none
+    }
+
+  let ok = return (Ok ())
+
+  let is_closed t =
+    t.closed
+
+  let on_wakeup t k =
+    if is_closed t
+    then failwith "on_wakeup on closed reader"
+    else if Optional_thunk.is_some t.wakeup
+    then failwith "on_wakeup: only one callback can be registered at a time"
+    else t.wakeup <- Optional_thunk.some k
+
+  let wakeup t =
+    let f = t.wakeup in
+    t.wakeup <- Optional_thunk.none;
+    Optional_thunk.call_if_some f
+
+  let request handler =
+    let rec parser t handler =
+      request <* commit >>= fun request ->
+        match Request.body_length request with
+      | `Error `Bad_request -> return (Error (`Bad_request request))
+      | `Fixed 0L  ->
+        handler request (Body.Reader.create_empty ());
+        ok
+      | `Fixed _ | `Chunked as encoding ->
+        let request_body =
+          Body.Reader.create
+            Bigstringaf.empty
+            ~when_ready_to_read:(Optional_thunk.some (fun () -> wakeup (Lazy.force t)))
+        in
+        handler request request_body;
+        body ~encoding request_body *> ok
+    and
+    t = lazy (create (parser t handler))
+    in
+    Lazy.force t
+
+  let response request_queue =
+    let parser t request_queue =
+      response <* commit >>= fun response ->
+      assert (not (Queue.is_empty request_queue));
+      let exception Local of Respd.t in
+      let respd = match
+        (Queue.iter (fun respd ->
+          if respd.Respd.state = Awaiting_response then
+            raise (Local respd)) request_queue)
+        with
+        | exception Local respd -> respd
+        | () -> assert false
+      in
+      let request = Respd.request respd in
+      let proxy = false in
+      match Response.body_length ~request_method:request.meth response with
+      | `Error `Bad_gateway           -> assert (not proxy); assert false
+      | `Error `Internal_server_error -> return (Error (`Invalid_response_body_length response))
+      | `Fixed 0L ->
+        respd.response_handler response (Body.Reader.create_empty ());
+        ok
+      | `Fixed _ | `Chunked | `Close_delimited as encoding ->
+        (* We do not trust the length provided in the [`Fixed] case, as the
+           client could DOS easily. *)
+        let response_body =
+          Body.Reader.create Bigstringaf.empty ~when_ready_to_read:(Optional_thunk.some (fun () ->
+            wakeup (Lazy.force t)))
+        in
+        respd.response_handler response response_body;
+        body ~encoding response_body *> ok
+    in
+    let rec t = lazy (create (parser t request_queue)) in
+    Lazy.force t
+  ;;
+
+
+  let transition t state =
+    match state with
+    | AU.Done(consumed, Ok ()) ->
+      t.parse_state <- Done;
+      consumed
+    | AU.Done(consumed, Error error) ->
+      t.parse_state <- Fail error;
+      consumed
+    | AU.Fail(consumed, marks, msg) ->
+      t.parse_state <- Fail (`Parse(marks, msg));
+      consumed
+    | AU.Partial { committed; continue } ->
+      t.parse_state <- Partial continue;
+      committed
+  and start t state =
+      match state with
+      | AU.Done _         -> failwith "httpun.Parse.unable to start parser"
+      | AU.Fail(0, marks, msg) ->
+        t.parse_state <- Fail (`Parse(marks, msg))
+      | AU.Partial { committed = 0; continue } ->
+        t.parse_state <- Partial continue
+      | _ -> assert false
+  ;;
+
+  let rec _read_with_more t bs ~off ~len more =
+    let initial = match t.parse_state with Done -> true | _ -> false in
+    let consumed =
+      match t.parse_state with
+      | Fail _ -> 0
+      (* Don't feed empty input when we're at a request boundary *)
+      | Done when len = 0 -> 0
+      | Done   ->
+        start t (AU.parse t.parser);
+        _read_with_more  t bs ~off ~len more;
+      | Partial continue ->
+        transition t (continue bs more ~off ~len)
+    in
+    (* Special case where the parser just started and was fed a zero-length
+     * bigstring. Avoid putting them parser in an error state in this scenario.
+     * If we were already in a `Partial` state, return the error. *)
+    if initial && len = 0 then t.parse_state <- Done;
+    match t.parse_state with
+    | Done when consumed < len ->
+      let off = off + consumed
+      and len = len - consumed in
+      consumed + _read_with_more t bs ~off ~len more
+    | _ -> consumed
+  ;;
+
+  let read_with_more t bs ~off ~len more =
+    let consumed = _read_with_more t bs ~off ~len more in
+    (match more with
+     | Complete ->
+       t.closed <- true
+     | Incomplete -> ());
+    consumed
+
+  let force_close t =
+    t.closed <- true;
+  ;;
+
+  let next t =
+    match t.parse_state with
+    | Fail failure -> `Error failure
+    | _ when t.closed -> `Close
+    | Done      -> `Start
+    | Partial _ -> `Read
+  ;;
+end