Source file http1.ml

(*----------------------------------------------------------------------------
 * Copyright (c) 2019-2020, António Nuno Monteiro
 * 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 copyright holder nor the names of its
 *    contributors may be used to endorse or promote products derived from
 *    this software without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 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 COPYRIGHT HOLDER 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.
 *---------------------------------------------------------------------------*)

open Import
module Piaf_body = Body

module type BODY = Body.Raw.BODY

module Body :
  BODY
  with type Reader.t = Httpun.Body.Reader.t
   and type Writer.t = Httpun.Body.Writer.t = struct
  module Reader = Httpun.Body.Reader
  module Writer = Httpun.Body.Writer
end

module MakeHTTP1 (Runtime_scheme : Scheme.Runtime.SCHEME) :
  Http_intf.HTTP1
  with type Client.t = Httpun_eio.Client.t
   and type Body.Reader.t = Httpun.Body.Reader.t
   and type Body.Writer.t = Httpun.Body.Writer.t
   and type scheme = Runtime_scheme.t = struct
  type scheme = Runtime_scheme.t

  let scheme = Runtime_scheme.scheme

  module Body = Body

  module Client = struct
    include Httpun_eio.Client

    (* Error handler for HTTP/1 connections isn't used *)
    let create_connection ~config ~error_handler:_ ~sw fd =
      let t =
        create_connection ~sw ~config:(Config.to_http1_config config) fd
      in
      t, t.runtime

    let request
        t
        ~flush_headers_immediately
        ~error_handler
        ~response_handler
        req
      =
      let response_handler response body =
        let request_method =
          match req.Request.meth with
          | #Method.standard as meth -> meth
          | `Other _ ->
            (* XXX(anmonteiro): for methods defined outside of RFC7231, or
             * custom methods, just assume `GET`.
             *
             * The only case where getting this wrong could matter is
             * potentially assuming that the request method was CONNECT and it
             * sent one of the forbidden headers according to RFC7231§4.3.6:
             *
             *   A server MUST NOT send any Transfer-Encoding or Content-Length
             *   header fields in a 2xx (Successful) response to CONNECT.
             *)
            `GET
        in
        (* TODO: revisit whether this is necessary. *)
        if request_method = `HEAD then Body.Reader.close body;
        let body =
          Piaf_body.Raw.to_response_body
            (module Body.Reader : Piaf_body.Raw.Reader
              with type t = Httpun.Body.Reader.t)
            ~body_length:
              (Httpun.Response.body_length ~request_method response
                :> Piaf_body.length)
            body
        in
        response_handler (Response.of_http1 ~body response)
      in
      let error_handler error =
        let error : Error.client =
          match error with
          | `Invalid_response_body_length { Httpun.Response.status; headers; _ }
            ->
            `Invalid_response_body_length
              ((status :> H2.Status.t), Headers.of_http1 headers)
          | (`Exn _ | `Malformed_response _) as other -> other
        in
        (* All HTTP/1.1 errors cause the connection to close. *)
        error_handler ~kind:`Connection error
      in
      request
        t
        ~flush_headers_immediately
        ~error_handler
        ~response_handler
        (Request.to_http1 req)
  end

  module Server = struct
    let request_of_http1 = Request.of_http1 ~scheme:Runtime_scheme.scheme

    include Httpun_eio.Server

    module Reqd :
      Http_intf.Reqd
      with type t = Httpun.Reqd.t
       and type write_body = Body.Writer.t = struct
      include Httpun.Reqd

      type write_body = Body.Writer.t

      let respond_with_string t response string =
        respond_with_string t (Response.to_http1 response) string

      let respond_with_bigstring t response bs =
        respond_with_bigstring t (Response.to_http1 response) bs

      let respond_with_streaming t ?flush_headers_immediately response =
        respond_with_streaming
          t
          ?flush_headers_immediately
          (Response.to_http1 response)

      let respond_with_upgrade t headers upgrade_handler =
        respond_with_upgrade t (Headers.to_http1 headers) upgrade_handler
    end

    module HttpServer = struct
      module Reqd = Reqd
      module Body = Body
    end

    let make_error_handler ~fd error_handler :
        Eio.Net.Sockaddr.stream -> Httpun.Server_connection.error_handler
      =
     fun client_addr ?request error start_response ->
      let start_response headers = start_response (Headers.to_http1 headers) in
      Http_server_impl.handle_error
        ?request:(Option.map request_of_http1 request)
        (module HttpServer)
        ~fd
        ~scheme:Runtime_scheme.scheme
        ~version:
          (Option.value
             ~default:HTTP_1_1
             (Option.map
                (fun (request : Httpun.Request.t) ->
                   Versions.HTTP.Raw.to_version_exn request.version)
                request))
        ~error_handler
        ~start_response
        client_addr
        (error :> Error.server)

    let make_request_handler ~sw ~config ~fd handler :
        Eio.Net.Sockaddr.stream -> Httpun.Reqd.t Gluten.reqd -> unit
      =
     fun client_addr reqd ->
      let { Gluten.reqd; upgrade } = reqd in
      let arg =
        let request = Httpun.Reqd.request reqd in
        let request_body =
          let body_length = Httpun.Request.body_length request in
          Piaf_body.Raw.to_request_body
            (module Body.Reader : Piaf_body.Raw.Reader
              with type t = Httpun.Body.Reader.t)
            ~body_length:(body_length :> Piaf_body.length)
            ~on_eof:(fun t ->
              Option.iter
                (fun error ->
                   t.error_received :=
                     Promise.create_resolved (error :> Error.t))
                (Httpun.Reqd.error_code reqd))
            (Httpun.Reqd.request_body reqd)
        in
        { Server_intf.Handler.ctx =
            { Request_info.client_address = client_addr
            ; scheme = Runtime_scheme.scheme
            ; version = Versions.HTTP.Raw.to_version_exn request.version
            ; sw
            }
        ; request = request_of_http1 ~body:request_body request
        }
      in
      Http_server_impl.handle_request
        (module HttpServer)
        ~config
        ~upgrade
        ~fd
        ~handler
        ~arg
        reqd

    let create_connection_handler ~config ~request_handler ~error_handler :
        Server_intf.connection_handler
      =
     fun ~sw fd sockaddr ->
      let request_handler =
        make_request_handler ~sw ~config ~fd request_handler
      in
      let error_handler = make_error_handler ~fd error_handler in
      create_connection_handler
        ~config:(Server_config.to_http1_config config)
        ~request_handler
        ~error_handler
        ~sw
        sockaddr
        fd
  end
end

module HTTP : Http_intf.HTTP = MakeHTTP1 (Scheme.Runtime.HTTP)
module HTTPS : Http_intf.HTTPS = MakeHTTP1 (Scheme.Runtime.HTTPS)