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/>.
 *)

open Astring

(* https://seppo.social/S1037 *)
let cgi_bin = "/cgi-bin/"

(* cd to asset storage location if locked inside /cgi-bin/ (if the case).
 *
 * https://seppo.social/S1037
*)
let cd_cgi_bin_twin_path script_name =
  let is_sep = Char.equal '/'
  and sep = "/" in
  match script_name |> String.fields ~is_sep with
  | "" :: ("cgi-bin" :: _ as l) ->
    let l0 = l |> List.fold_left (fun init s ->
        match s with
        | "."         -> init
        | "seppo.cgi" -> init
        | ".."        -> ".." :: init
        | _           -> ".." :: init
      ) [] in
    l |> List.fold_left (fun init s ->
        match s with
        | "."
        | "cgi-bin"
        | "seppo.cgi" -> init
        | s           -> s :: init
      ) l0
    |> List.rev
    |> String.concat ~sep
  | _ -> (* sunshine case, not locked inside /cgi/bin/ *)
    "."

(** HTTP Request meta data. *)
module Request = struct
  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
  }

  let empty = {
    content_type   = "text/plain";
    content_length = None;
    host           = "127.0.0.1";
    http_cookie    = "";
    path_info      = "/";
    query_string   = "";
    remote_addr    = "127.0.0.1";
    request_method = "GET";
    scheme         = "http";
    script_name    = "";
    server_port    = "80";
    raw_string     = (fun _ -> None);
  }

  (** Request meta data. https://tools.ietf.org/html/rfc3875#section-4.1.13  *)

  (* https://tools.ietf.org/html/rfc3875 *)
  let hCONTENT_LENGTH  = "CONTENT_LENGTH"
  let hCONTENT_TYPE    = "CONTENT_TYPE"
  let hHTTP_COOKIE     = "HTTP_COOKIE"
  let hHTTP_HOST       = "HTTP_HOST"
  let hHTTP_USER_AGENT = "HTTP_USER_AGENT"
  let hHTTPS           = "HTTPS"
  let hPATH_INFO       = "PATH_INFO"
  let hQUERY_STRING    = "QUERY_STRING"
  let hREMOTE_ADDR     = "REMOTE_ADDR"
  let hREQUEST_METHOD  = "REQUEST_METHOD"
  let hREQUEST_URI     = "REQUEST_URI"
  let hSCRIPT_NAME     = "SCRIPT_NAME"
  let hSERVER_NAME     = "SERVER_NAME"
  let hSERVER_PORT     = "SERVER_PORT"
  let hHTTP_X_FORWARDED_FOR = "HTTP_X_FORWARDED_FOR"
  let hHTTP_X_FORWARDED_PROTO = "HTTP_X_FORWARDED_PROTO"

  (** Almost trivial. https://tools.ietf.org/html/rfc3875
   * Does no parsing or conversion. *)
  let from_env ?(getenv_opt=Sys.getenv_opt) () =
    try
      let env_opt ?(default = "") s = s |> getenv_opt |> Option.value ~default in
      let env_exc s =
        match s |> getenv_opt with
        | None   -> raise Not_found
        | Some v -> v in
      let r : t = {
        content_type   = hCONTENT_TYPE |> env_opt;
        content_length = Option.bind
            (hCONTENT_LENGTH |> getenv_opt)
            (fun s -> Option.bind
                (s |> int_of_string_opt)
                Option.some);
        host           = hHTTP_HOST    |> env_opt ~default:(hSERVER_NAME |> env_exc);
        http_cookie    = hHTTP_COOKIE  |> env_opt;
        path_info      = hPATH_INFO    |> env_opt;
        query_string   = hQUERY_STRING |> env_opt;
        request_method = hREQUEST_METHOD|>env_exc;
        remote_addr    = hREMOTE_ADDR  |> env_exc;
        (* request_uri = hREQUEST_URI  |> Os.getenv ; *)
        scheme = (match hHTTPS |> env_opt with
            | "on" -> "https"
            | _    -> "http");
        script_name    = hSCRIPT_NAME  |> env_exc;
        server_port    = hSERVER_PORT  |> env_exc;
        raw_string     = getenv_opt (* mybe we should limit and HTTP_ prefix the names *)
      }
      in Ok r
    with Not_found -> Error "Not Found."

  (** despite https://tools.ietf.org/html/rfc3875#section-4.1.13 1und1.de
      webhosting returns the script_name instead an empty or None 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')

  (** use remote_addr, scheme and server_port according to proxy *)
  let proxy req' =
    Result.bind req' (fun (req : t) ->
        match hHTTP_X_FORWARDED_FOR |> req.raw_string with
        | None             -> req'
        | Some remote_addr ->
          let req = {req with remote_addr} in
          match hHTTP_X_FORWARDED_PROTO |> req.raw_string with
          | None        -> Ok req
          | Some scheme ->
            let req = {req with scheme} in
            Ok (match scheme with
                | "https" -> {req with server_port = "443" }
                | "http"  -> {req with server_port = "80" }
                | _       -> req ))

  (** compute scheme, host, port *)
  let srvr r : Uri.t =
    let u = Uri.make
        ~scheme:r.scheme
        ~host:r.host
        () in
    let port = match r.scheme, r.server_port with
      | "http" ,  "80" -> None
      | "https", "443" -> None
      | _, p           -> Some (p |> int_of_string)
    in
    Uri.with_port u port

  let rx_cgi_bin = {|^/cgi-bin\(\(/.*\)seppo\.cgi\)|} |> Str.regexp
  let rx_script_name = {|^\(/cgi-bin\)?\(\(/\([^/]*/\)*\)\([^/]*\.cgi\)\)$|} |> Str.regexp

  let script_url s =
    Logr.debug (fun m -> m "%s.%s %s" "Cgi" "script_url" s);
    if Str.string_match rx_cgi_bin s 0
    then s |> Str.matched_group 1
    else s

  let script_url_dir s =
    Logr.debug (fun m -> m "%s.%s %s" "Cgi" "script_url_dir" s);
    let b = if Str.string_match rx_script_name s 0
      then s |> Str.matched_group 3
      else failwith __LOC__ in
    assert (b |>  St.is_suffix ~affix:"/");
    assert (not (b |>  St.is_suffix ~affix:"//"));
    assert (not (b |>  St.is_prefix ~affix:cgi_bin));
    b

  (** set script and path for a query_string. *)
  let path_and_query r =
    let path = (r.script_name |> script_url) ^ r.path_info in
    let u = Uri.make ~path () in
    match r.query_string with
    | "" -> u
    | q  -> q |> Uri.query_of_encoded |> Uri.with_query u

  let base' script_name srvr : Uri.t =
    assert (srvr |> Uri.path |> String.equal "");
    script_name
    |> script_url_dir
    |> Uri.with_path srvr

  let base r =
    r |> srvr |> base' r.script_name

  (** absolute request-uri, without /cgi-bin/ in case *)
  let abs r : Uri.t =
    let u = r |> srvr in
    let u = (r.script_name |> script_url) ^ r.path_info |> Uri.with_path u in
    match r.query_string with
    | "" -> u
    | q  -> q |> Uri.query_of_encoded |> Uri.with_query u

  (** fetch http header values and map from lowercase plus the special name (request-target) *)
  let header_get (r : t) = function
    | "(request-target)" ->  Printf.sprintf "%s %s"
                               (r.request_method |> String.Ascii.lowercase)
                               (r |> path_and_query |> Uri.to_string)
                             |> Option.some
    | k ->
      let toenv = String.map (function
          | '-' -> '_'
          | c   -> Char.Ascii.uppercase c) in
      match toenv k with
      | "CONTENT_LENGTH"
      | "CONTENT_TYPE" as k -> k |> r.raw_string
      | k                   -> ("HTTP_" ^ k) |> r.raw_string
end

module Response = struct
  (** return type of the Request handlers. *)
  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 ?(ee = "") b oc =
    output_string oc b;
    if ee != "" then (
      output_string oc "\n\n";
      output_string oc ee)

  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