Source file req.ml

open Lwt.Syntax

type t = Opium_kernel.Request.t

let key : t Core.Ctx.key = Core.Ctx.create_key ()
let add_to_ctx req ctx = Core.Ctx.add key req ctx

let create_and_add_to_ctx ?(body = "") ?(uri = "/") ctx =
  let req =
    Opium.Std.Request.create
      ~body:(Cohttp_lwt.Body.of_string body)
      (Cohttp_lwt.Request.make (Uri.of_string uri))
  in
  add_to_ctx req ctx
;;

let get_req ctx =
  match Core.Ctx.find key ctx with
  | None -> raise (Http_core.Exception "No HTTP request found in context")
  | Some req -> req
;;

module Query = struct
  type t = (string * string list) list [@@deriving eq, show, yojson]
end

let is_get ctx =
  let req = get_req ctx in
  match Opium_kernel.Rock.Request.meth req with
  | `GET -> true
  | _ -> false
;;

let get_uri ctx =
  let req = get_req ctx in
  Opium_kernel.Request.uri req
;;

let contains substring string =
  let re = Str.regexp_string string in
  try
    ignore (Str.search_forward re substring 0);
    true
  with
  | Not_found -> false
;;

let accepts_html ctx =
  let req = get_req ctx in
  Cohttp.Header.get (Opium.Std.Request.headers req) "Accept"
  |> Option.map (contains "text/html")
  |> Option.value ~default:false
;;

let require_authorization_header ctx =
  let req = get_req ctx in
  match req |> Opium.Std.Request.headers |> Cohttp.Header.get_authorization with
  | None -> Error "No authorization header found"
  | Some token -> Ok token
;;

let cookie_data ctx ~key =
  let req = get_req ctx in
  let cookies = req |> Opium_kernel.Request.headers |> Cohttp.Cookie.Cookie_hdr.extract in
  cookies
  |> List.find_opt (fun (k, _) -> String.equal key k)
  |> Option.map (fun (_, v) -> Uri.pct_decode v)
;;

let get_header ctx key =
  let req = get_req ctx in
  Cohttp.Header.get (Opium.Std.Request.headers req) key
;;

let parse_token ctx =
  let ( let* ) = Option.bind in
  (* TODO make this more robust *)
  let* header = get_header ctx "authorization" in
  match String.split_on_char ' ' header with
  | [ _; token ] -> Some token
  | _ -> None
;;

let find_in_query key query =
  let ( let* ) = Option.bind in
  let* values =
    query
    |> List.find_opt (fun (k, _) -> String.equal k key)
    |> Option.map (fun (_, r) -> r)
  in
  try Some (List.hd values) with
  | _ -> None
;;

let get_query_string ctx =
  let req = get_req ctx in
  req |> Opium.Std.Request.uri |> Uri.query
;;

let query_opt ctx key = ctx |> get_query_string |> find_in_query key

let query ctx key =
  match query_opt ctx key with
  | None -> Error (Printf.sprintf "Please provide a key '%s'" key)
  | Some value -> Ok value
;;

let query2_opt ctx key1 key2 = query_opt ctx key1, query_opt ctx key2
let query2 ctx key1 key2 = query ctx key1, query ctx key2

let query3_opt ctx key1 key2 key3 =
  query_opt ctx key1, query_opt ctx key2, query_opt ctx key3
;;

let query3 ctx key1 key2 key3 = query ctx key1, query ctx key2, query ctx key3

let urlencoded_list ?body ctx =
  let req = get_req ctx in
  let* body =
    match body with
    | Some body -> Lwt.return body
    | None -> req |> Opium.Std.Request.body |> Opium.Std.Body.to_string
  in
  body |> Uri.pct_decode |> Uri.query_of_encoded |> Lwt.return
;;

let urlencoded ?body ctx key =
  let req = get_req ctx in
  (* we need to be able to pass in the body because Opium.Std.Request.body drains the body
     stream from the request *)
  let* body =
    match body with
    | Some body -> Lwt.return body
    | None -> req |> Opium.Std.Request.body |> Opium.Std.Body.to_string
  in
  match body |> Uri.pct_decode |> Uri.query_of_encoded |> find_in_query key with
  | None -> Lwt.return None
  | Some value -> Lwt.return @@ Some value
;;

let urlencoded2 ctx key1 key2 =
  let* body = ctx |> get_req |> Opium.Std.Request.body |> Opium.Std.Body.to_string in
  let* value1 = urlencoded ~body ctx key1 in
  let* value2 = urlencoded ~body ctx key2 in
  let both =
    match value1, value2 with
    | Some value1, Some value2 -> Some (value1, value2)
    | _ -> None
  in
  Lwt.return both
;;

let urlencoded3 ctx key1 key2 key3 =
  let* body = ctx |> get_req |> Opium.Std.Request.body |> Opium.Std.Body.to_string in
  let* value1 = urlencoded ~body ctx key1 in
  let* value2 = urlencoded ~body ctx key2 in
  let* value3 = urlencoded ~body ctx key3 in
  match value1, value2, value3 with
  | Some value1, Some value2, Some value3 -> Lwt.return @@ Some (value1, value2, value3)
  | _ -> Lwt.return None
;;

let urlencoded4 ctx key1 key2 key3 key4 =
  let* body = ctx |> get_req |> Opium.Std.Request.body |> Opium.Std.Body.to_string in
  let* value1 = urlencoded ~body ctx key1 in
  let* value2 = urlencoded ~body ctx key2 in
  let* value3 = urlencoded ~body ctx key3 in
  let* value4 = urlencoded ~body ctx key4 in
  match value1, value2, value3, value4 with
  | Some value1, Some value2, Some value3, Some value4 ->
    Lwt.return @@ Some (value1, value2, value3, value4)
  | _ -> Lwt.return None
;;

let urlencoded5 ctx key1 key2 key3 key4 key5 =
  let* body = ctx |> get_req |> Opium.Std.Request.body |> Opium.Std.Body.to_string in
  let* value1 = urlencoded ~body ctx key1 in
  let* value2 = urlencoded ~body ctx key2 in
  let* value3 = urlencoded ~body ctx key3 in
  let* value4 = urlencoded ~body ctx key4 in
  let* value5 = urlencoded ~body ctx key5 in
  match value1, value2, value3, value4, value5 with
  | Some value1, Some value2, Some value3, Some value4, Some value5 ->
    Lwt.return @@ Some (value1, value2, value3, value4, value5)
  | _ -> Lwt.return None
;;

let param ctx key =
  let req = get_req ctx in
  try Some (Opium.Std.param req key) with
  | _ -> None
;;

let param2 ctx key1 key2 =
  match param ctx key1, param ctx key2 with
  | Some a, Some b -> Some (a, b)
  | _ -> None
;;

let param3 ctx key1 key2 key3 =
  match param ctx key1, param ctx key2, param ctx key3 with
  | Some p1, Some p2, Some p3 -> Some (p1, p2, p3)
  | _ -> None
;;

let param4 ctx key1 key2 key3 key4 =
  match param ctx key1, param ctx key2, param ctx key3, param ctx key4 with
  | Some p1, Some p2, Some p3, Some p4 -> Some (p1, p2, p3, p4)
  | _ -> None
;;

let param5 ctx key1 key2 key3 key4 key5 =
  match
    param ctx key1, param ctx key2, param ctx key3, param ctx key4, param ctx key5
  with
  | Some p1, Some p2, Some p3, Some p4, Some p5 -> Some (p1, p2, p3, p4, p5)
  | _ -> None
;;

let require_body ctx decode =
  let* body = ctx |> get_req |> Opium.Std.Request.body |> Cohttp_lwt.Body.to_string in
  match body |> Utils.Json.parse with
  | Ok value -> Lwt.return @@ decode value
  | Error msg -> Lwt.return @@ Error msg
;;