seppo/lib/cgi.ml

(*
 *    _  _   ____                         _  
 *  _| || |_/ ___|  ___ _ __  _ __   ___ | | 
 * |_  ..  _\___ \ / _ \ '_ \| '_ \ / _ \| | 
 * |_      _|___) |  __/ |_) | |_) | (_) |_| 
 *   |_||_| |____/ \___| .__/| .__/ \___/(_) 
 *                     |_|   |_|             
 *
 * Personal Social Web.
 *
 * Copyright (C) The #Seppo contributors. All rights reserved.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program.  If not, see <http://www.gnu.org/licenses/>.
 *)

module Request = struct
  (** https://tools.ietf.org/html/rfc3875#section-4.1.13  *)
  type t = {
    content_type   : string;
    content_length : int option;
    host           : string;
    http_cookie    : string;
    path_info      : string;
    query_string   : string;
    remote_addr    : string;
    request_method : string;
    scheme         : string;
    script_name    : string;
    server_port    : string;
    raw_string     : string -> string option
  }

  (** Almost trivial. https://tools.ietf.org/html/rfc3875
   * Does no parsing or conversion. *)
  let from_env () =
    try
      let env ?(default = "") s = s |> Sys.getenv_opt |> Option.value ~default in
      let r : t = {
        content_type   = "CONTENT_TYPE" |> env;
        content_length = Option.bind
            ("CONTENT_LENGTH" |> Sys.getenv_opt)
            (fun s -> Option.bind
                (s |> int_of_string_opt)
                Option.some);
        host           = "HTTP_HOST"    |> env ~default:("SERVER_NAME" |> Sys.getenv);
        http_cookie    = "HTTP_COOKIE"  |> env ~default:"";
        path_info      = "PATH_INFO"    |> env ~default:"";
        query_string   = "QUERY_STRING" |> env ~default:"";
        request_method = "REQUEST_METHOD"|>Sys.getenv;
        remote_addr    = "REMOTE_ADDR"  |> Sys.getenv;
        (* request_uri = "REQUEST_URI"  |> Os.getenv ; *)
        scheme =
          (match "HTTPS" |> env with
           | "on" -> "https"
           | _    -> "http");
        script_name    = "SCRIPT_NAME"  |> Sys.getenv;
        server_port    = "SERVER_PORT"  |> Sys.getenv;
        raw_string     = Sys.getenv_opt (* mybe we should limit and HTTP_ prefix the names *)
      }
      in Ok r
    with Not_found -> Error "Not Found."

  (** set script and path for a query_string. *)
  let path_and_query req =
    req.script_name ^ req.path_info
    ^ match req.query_string with
    | "" -> ""
    | qs -> "?" ^ qs

  let srvr r : string =
    let prt = match r.scheme, r.server_port with
      | "http",   "80"
      | "https", "443" -> ""
      | _              -> ":" ^ r.server_port in
    r.scheme ^ "://" ^ r.host ^ prt

  let base r : Uri.t =
    let r = ((srvr r) ^ match r.script_name |> Filename.dirname with
      | "/" as s -> s
      | s -> s ^ "/") |> Uri.of_string in
    assert (r |> Uri.to_string |> St.ends_with ~suffix:"/");
    assert (not (r |> Uri.path |> St.ends_with ~suffix:"//"));
    r

  let abs r : string =
    (srvr r) ^ r.script_name ^ r.path_info ^ "?" ^ r.query_string

  (** despite https://tools.ietf.org/html/rfc3875#section-4.1.13 1und1.de
   * webhosting returns the script_name instead an empty or nonex path_info in
   * case *)
  let consolidate req' =
    Result.bind req' (fun (req : t) ->
        if String.equal req.path_info req.script_name
        then Ok {req with path_info = ""}
        else req')
end

module Response = struct
  type t = Cohttp.Code.status_code * (string * string) list * (out_channel -> unit)

  (* for ease of railway processing we use this strange type *)
  type t' = (t, t) result

  let body b oc = output_string oc b

  let nobody = St.camel |> body

  let flush uuid oc ((status, hdrs, f_body) : t) : int =
    Logr.debug (fun m -> m "%s.%s %a" "Cgi.Response" "flush" Uuidm.pp uuid);
    let single (k, v) = Printf.fprintf oc "%s: %s\r\n" k v in
    ("Status", status |> Cohttp.Code.string_of_status) |> single;
    hdrs |> List.iter single;
    ("X-Request-Id", uuid |> Uuidm.to_string) |> single;
    Printf.fprintf oc "\r\n";
    f_body oc;
    flush oc;
    match status with
    | #Cohttp.Code.server_error_status -> 1
    |  _                               -> 0
end