Source file ocsigen_request.ml

open Lwt.Infix

let post_data_of_body ~content_type b =
  Ocsigen_multipart.post_params ~content_type b

type content_type = Ocsigen_multipart.content_type

type file_info = Ocsigen_multipart.file_info =
  { tmp_filename : string
  ; filesize : int64
  ; raw_original_filename : string
  ; file_content_type : content_type option }

type post_data = Ocsigen_multipart.post_data
type body = [`Unparsed of Cohttp_lwt.Body.t | `Parsed of post_data Lwt.t]

(* Wrapper around Uri providing our derived fields.

   Is the laziness too fine-grained? *)
type uri =
  { u_uri : Uri.t Lazy.t
  ; u_get_params : (string * string list) list Lazy.t
  ; u_get_params_flat : (string * string) list Lazy.t
  ; u_path_string : string Lazy.t
  ; u_path : string list Lazy.t }

let unflatten_get_params l =
  let module M = Ocsigen_lib.String.Table in
  M.bindings
    (List.fold_left
       (fun acc (id, v) ->
          M.add id (try v :: M.find id acc with Not_found -> [v]) acc)
       M.empty l)

let flatten_get_params l =
  List.concat (List.map (fun (s, l) -> List.map (fun v -> s, v) l) l)

let remove_trailing_slash_string s =
  if String.length s > 0 && String.get s 0 = '/'
  then String.sub s 1 (String.length s - 1)
  else s

let make_uri u =
  let u_uri = lazy u
  and u_get_params = lazy (Uri.query u)
  and u_path_string = lazy (remove_trailing_slash_string (Uri.path u)) in
  let u_path = lazy (Ocsigen_lib.Url.split_path (Lazy.force u_path_string))
  and u_get_params_flat = lazy (flatten_get_params (Lazy.force u_get_params)) in
  {u_uri; u_get_params; u_get_params_flat; u_path; u_path_string}

type t =
  { r_address : Unix.inet_addr
  ; r_port : int
  ; r_ssl : bool
  ; r_filenames : string list ref
  ; r_sockaddr : Lwt_unix.sockaddr
  ; r_remote_ip : string Lazy.t
  ; r_remote_ip_parsed : Ipaddr.t Lazy.t
  ; r_forward_ip : string list
  ; r_uri : uri
  ; r_meth : Cohttp.Code.meth
  ; r_encoding : Cohttp.Transfer.encoding
  ; r_version : Cohttp.Code.version
  ; r_headers : Cohttp.Header.t
  ; r_body : body ref
  ; r_original_full_path : string option
  ; r_sub_path : string option
  ; r_cookies_override : string Ocsigen_cookie_map.Map_inner.t option
  ; mutable r_request_cache : Polytables.t
  ; mutable r_tries : int
  ; r_connection_closed : unit Lwt.t
  ; r_timeofday : float }

let make ?(forward_ip = []) ?sub_path ?original_full_path
    ?(request_cache = Polytables.create ()) ?cookies_override ~address ~port
    ~ssl ~filenames ~sockaddr ~body ~connection_closed request
  =
  let r_remote_ip =
    lazy
      (Unix.string_of_inet_addr (Ocsigen_lib.Ip_address.of_sockaddr sockaddr))
  in
  let r_remote_ip_parsed =
    lazy (Ipaddr.of_string_exn (Lazy.force r_remote_ip))
  in
  { r_address = address
  ; r_port = port
  ; r_ssl = ssl
  ; r_filenames = filenames
  ; r_sockaddr = sockaddr
  ; r_remote_ip
  ; r_remote_ip_parsed
  ; r_forward_ip = forward_ip
  ; r_uri = make_uri (Cohttp.Request.uri request)
  ; r_encoding = Cohttp.Request.encoding request
  ; r_meth = Cohttp.Request.meth request
  ; r_version = Cohttp.Request.version request
  ; r_headers = Cohttp.Request.headers request
  ; r_body = ref (`Unparsed body)
  ; r_sub_path = sub_path
  ; r_original_full_path = original_full_path
  ; r_cookies_override = cookies_override
  ; r_request_cache = request_cache
  ; r_tries = 0
  ; r_connection_closed = connection_closed
  ; r_timeofday = Unix.gettimeofday () }

let path_string {r_uri = {u_path_string; _}; _} = Lazy.force u_path_string
let path {r_uri = {u_path; _}; _} = Lazy.force u_path

let update ?ssl ?forward_ip ?remote_ip ?sub_path ?meth ?get_params_flat
    ?post_data ?cookies_override ?(full_rewrite = false) ?uri
    ({ r_ssl
     ; r_uri = {u_uri; _} as r_uri
     ; r_meth
     ; r_forward_ip
     ; r_remote_ip
     ; r_remote_ip_parsed
     ; r_cookies_override
     ; r_body
     ; r_sub_path
     ; r_original_full_path
     ; _ } as r)
  =
  let r_ssl = match ssl with Some ssl -> ssl | None -> r_ssl
  and r_forward_ip =
    match forward_ip with Some forward_ip -> forward_ip | None -> r_forward_ip
  and r_remote_ip, r_remote_ip_parsed =
    match remote_ip with
    | Some remote_ip -> lazy remote_ip, lazy (Ipaddr.of_string_exn remote_ip)
    | None -> r_remote_ip, r_remote_ip_parsed
  and r_sub_path = match sub_path with Some _ -> sub_path | None -> r_sub_path
  and r_body =
    match post_data with
    | Some (Some post_data) -> ref (`Parsed (Lwt.return post_data))
    | Some None -> ref (`Parsed (Lwt.return ([], [])))
    | None -> r_body
  and r_cookies_override =
    match cookies_override with
    | Some _ -> cookies_override
    | None -> r_cookies_override
  and r_meth = match meth with Some meth -> meth | None -> r_meth
  and r_original_full_path, r_uri =
    match uri with
    | Some uri ->
        ( (match full_rewrite, r_original_full_path with
          | true, _ -> None
          | false, Some _ -> r_original_full_path
          | false, _ -> Some (Uri.path (Lazy.force u_uri)))
        , make_uri uri )
    | None -> r_original_full_path, r_uri
  in
  let r_uri =
    match get_params_flat with
    | Some l ->
        let u_get_params = lazy (unflatten_get_params l) in
        let u_uri =
          lazy
            (Uri.with_query (Lazy.force r_uri.u_uri) (Lazy.force u_get_params))
        in
        {r_uri with u_uri; u_get_params; u_get_params_flat = lazy l}
    | None -> r_uri
  in
  { r with
    r_ssl
  ; r_uri
  ; r_meth
  ; r_forward_ip
  ; r_remote_ip
  ; r_remote_ip_parsed
  ; r_body
  ; r_cookies_override
  ; r_sub_path
  ; r_original_full_path }

let uri {r_uri = {u_uri; _}; _} = Lazy.force u_uri

let to_cohttp ({r_meth; r_encoding; r_version; r_headers; _} as r) =
  Cohttp.Request.make ~meth:r_meth ~encoding:r_encoding ~version:r_version
    ~headers:r_headers (uri r)

let body = function
  | {r_body = {contents = `Unparsed body; _}; _} -> body
  | _ -> failwith "Ocsigen_request.body: body has already been parsed"

let address {r_address; _} = r_address
let host {r_uri = {u_uri; _}; _} = Uri.host (Lazy.force u_uri)
let meth {r_meth; _} = r_meth
let port {r_port; _} = r_port
let ssl {r_ssl; _} = r_ssl
let version {r_version; _} = r_version
let query {r_uri = {u_uri; _}; _} = Uri.verbatim_query (Lazy.force u_uri)
let get_params {r_uri = {u_get_params; _}; _} = Lazy.force u_get_params

let get_params_flat {r_uri = {u_get_params_flat; _}; _} =
  Lazy.force u_get_params_flat

let sub_path_string req =
  remove_trailing_slash_string
    (match req with
    | {r_sub_path = Some r_sub_path; _} -> r_sub_path
    | r -> path_string r)

let sub_path r = Ocsigen_lib.Url.split_path (sub_path_string r)

let original_full_path_string = function
  | {r_original_full_path = Some r_original_full_path; _} ->
      r_original_full_path
  | r -> path_string r

let original_full_path r =
  Ocsigen_lib.Url.split_path (original_full_path_string r)

let header {r_headers; _} id =
  Cohttp.Header.get r_headers (Ocsigen_header.Name.to_string id)

let header_multi {r_headers; _} id =
  Cohttp.Header.get_multi r_headers (Ocsigen_header.Name.to_string id)

let add_header ({r_headers; _} as r) id v =
  { r with
    r_headers = Cohttp.Header.add r_headers (Ocsigen_header.Name.to_string id) v
  }

let parse_cookies s =
  let splitted = Ocsigen_lib.String.split ';' s in
  try
    List.fold_left
      (fun beg a ->
         try
           let n, v = Ocsigen_lib.String.sep '=' a in
           Ocsigen_cookie_map.Map_inner.add n v beg
         with Not_found -> beg)
      Ocsigen_cookie_map.Map_inner.empty splitted
  with _ -> Ocsigen_cookie_map.Map_inner.empty

let cookies = function
  | {r_cookies_override = Some cookies; _} -> cookies
  | r -> (
    match header r Ocsigen_header.Name.cookie with
    | Some cookies -> parse_cookies cookies
    | None -> Ocsigen_cookie_map.Map_inner.empty)

let content_type r =
  match header r Ocsigen_header.Name.content_type with
  | Some content_type -> Ocsigen_multipart.parse_content_type content_type
  | None -> None

let force_post_data ({r_body; _} as r) s i =
  match !r_body with
  | `Parsed post_data -> Some post_data
  | `Unparsed body -> (
    match content_type r with
    | Some content_type -> (
      match post_data_of_body ~content_type body with
      | Some f ->
          let v = f s i in
          r.r_body := `Parsed v;
          Some v
      | None -> None)
    | None -> None)

let post_params r s i =
  match force_post_data r s i with Some v -> Some (v >|= fst) | None -> None

let files r s i =
  match force_post_data r s i with Some v -> Some (v >|= snd) | None -> None

let remote_ip {r_remote_ip; _} = Lazy.force r_remote_ip
let remote_ip_parsed {r_remote_ip_parsed; _} = Lazy.force r_remote_ip_parsed
let forward_ip {r_forward_ip; _} = r_forward_ip
let request_cache {r_request_cache; _} = r_request_cache
let tries {r_tries; _} = r_tries
let incr_tries r = r.r_tries <- r.r_tries + 1
let connection_closed {r_connection_closed; _} = r_connection_closed
let timeofday {r_timeofday; _} = r_timeofday