123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132 |
- (*
- * _ _ ____ _
- * _| || |_/ ___| ___ _ __ _ __ ___ | |
- * |_ .. _\___ \ / _ \ '_ \| '_ \ / _ \| |
- * |_ _|___) | __/ |_) | |_) | (_) |_|
- * |_||_| |____/ \___| .__/| .__/ \___/(_)
- * |_| |_|
- *
- * 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
|