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

let ( let* ) = Result.bind
let ( let*% ) r f : ('b,'e) Lwt_result.t =
  (* https://discuss.ocaml.org/t/idiomatic-let-result-bind-and-lwt-bind/12554?u=mro *)
  match r with
  | Error _ as e -> Lwt.return e (* similar to Result.map_error but without unwrapping *)
  | Ok v         -> f v

let reso ~base url =
  Uri.resolve "https" base url

let relpa base path =
  let rec f = function
    | _ :: [], p -> p
    | bh :: bt, ph :: pt when String.equal bh ph -> f (bt,pt)
    | _    -> []
  in
  let ba = base |> String.split_on_char '/'
  and pa = path |> String.split_on_char '/' in
  f (ba,pa) |> String.concat "/"

let abs_to_rel ~base url =
  match url |> Uri.host with
  | None -> url
  | Some _ as ho ->
    let url = if Option.equal String.equal (Uri.host base) ho
      then Uri.with_host url None
      else url in
    let url = if Option.equal String.equal (Uri.scheme base) (Uri.scheme url)
      then Uri.with_scheme url None
      else url in
    let url = if Option.equal Int.equal (Uri.port base) (Uri.port url)
      then Uri.with_port url None
      else url in
    let url = Uri.with_path url (relpa (Uri.path base) (Uri.path url)) in
    url

(* https://tools.ietf.org/html/rfc2616/#section-3.3.1
   https://tools.ietf.org/html/rfc1123#page-55
   https://tools.ietf.org/html/rfc822#section-5.1
*)
let to_rfc1123 (time : Ptime.t) =
  (* MIT License, Copyright 2021 Anton Bachin
     https://github.com/aantron/dream/blob/master/src/pure/formats.ml#L51 *)
  let weekday =
    match Ptime.weekday time with
    | `Sun -> "Sun"
    | `Mon -> "Mon"
    | `Tue -> "Tue"
    | `Wed -> "Wed"
    | `Thu -> "Thu"
    | `Fri -> "Fri"
    | `Sat -> "Sat"
  in
  let (y, m, d), ((hh, mm, ss), _tz_offset_s) = Ptime.to_date_time time in
  let month =
    match m with
    | 1 -> "Jan"
    | 2 -> "Feb"
    | 3 -> "Mar"
    | 4 -> "Apr"
    | 5 -> "May"
    | 6 -> "Jun"
    | 7 -> "Jul"
    | 8 -> "Aug"
    | 9 -> "Sep"
    | 10 -> "Oct"
    | 11 -> "Nov"
    | 12 -> "Dec"
    | _ -> failwith "Month < 1 or > 12 not allowed"
  in
  (* [Ptime.to_date_time] docs give range 0..60 for [ss], accounting for
     leap seconds. However, RFC 6265 §5.1.1 states:
     5.  Abort these steps and fail to parse the cookie-date if:
       *  the second-value is greater than 59.
       (Note that leap seconds cannot be represented in this syntax.)
     See https://tools.ietf.org/html/rfc6265#section-5.1.1.
     Even though [Ptime.to_date_time] time does not return leap seconds, in
     case I misunderstood the gmtime API, of system differences, or future
     refactoring, make sure no leap seconds creep into the output. *)
  Printf.sprintf "%s, %02i %s %04i %02i:%02i:%02i GMT" weekday d month y hh mm
    (min 59 ss)

module Mime = struct
  module C = As2_vocab.Constants.ContentType
  let _app_act_json= C._app_act_json
  let app_jlda     = C.app_jlda
  let app_jrd      = C.app_jrd
  let app_atom_xml = C.app_atom_xml
  let app_form_url = "application/x-www-form-urlencoded"
  let app_json     = C.app_json
  let img_jpeg     = "image/jpeg"
  let text_css     = "text/css; charset=utf8"
  let text_html    = "text/html; charset=utf8"
  let text_plain   = "text/plain; charset=utf8"
  let text_xml     = "text/xml"
  let text_xsl     = "text/xsl"

  let is_app_json m =
    _app_act_json |> String.equal m
    || app_json |> String.equal m
end

module H = struct
  type t = string * string

  let add' h (n, v) = Cohttp.Header.add h n v

  let acc_app_json        = ("Accept",       Mime.app_json)
  let acc_app_jrd         = ("Accept",       Mime.app_jrd)
  let acc_app_jlda        = ("Accept",       Mime.app_jlda)
  let agent               = ("User-Agent",   St.seppo_s)

  let content_type ct : t = ("Content-Type", ct)

  let ct_jlda             = content_type Mime.app_jlda
  let ct_html             = content_type Mime.text_html
  let ct_json             = content_type Mime.app_json
  let ct_plain            = content_type Mime.text_plain
  let ct_xml              = content_type Mime.text_xml

  let content_length cl:t = ("Content-Length", cl |> string_of_int)
  let location url    : t = ("Location",     url)
  let retry_after t   : t = ("Retry-After",  t |> to_rfc1123)
  let set_cookie v    : t = ("Set-Cookie",   v)
  let max_age _       : t = assert false (* set via webserver config *)
  let x_request_id u  : t = ("X-Request-Id", Uuidm.to_string u)
end

module R = Cgi.Response
(* See also https://github.com/aantron/dream/blob/master/src/pure/status.ml *)
(* RFC1945 demands absolute uris https://www.rfc-editor.org/rfc/rfc1945#section-10.11 *)
let s302 ?(header = []) url = Error (`Found, [ H.ct_plain; H.location url ] @ header, R.nobody)
let s400' = (`Bad_request,  [ H.ct_plain ], R.nobody)
let s400  = Error s400'
let s400x = Error (`Bad_request,  [ H.ct_xml ], R.nobody)
let s401  = Error (`Unauthorized, [ H.ct_plain ], R.nobody)
let s403' = (`Forbidden,    [ H.ct_plain ], R.nobody)
let s403  = Error s403'
let s404  = Error (`Not_found,    [ H.ct_plain ], R.nobody)
let s405  = Error (`Method_not_allowed, [ H.ct_plain ], R.nobody)
let s413  = Error (`Code 413,  [ H.ct_plain ], R.nobody) (* Payload too large *)
(* https://stackoverflow.com/a/42171674/349514 *)
let s422' = (`Unprocessable_entity, [ H.ct_plain ], R.nobody)
let s422  = Error s422'
let s422x = Error (`Unprocessable_entity, [ H.ct_xml ], R.nobody)
(* https://tools.ietf.org/html/rfc6585#section-4
   Retry-After https://tools.ietf.org/html/rfc2616#section-14.37
   HTTP-date https://tools.ietf.org/html/rfc1123
   https://github.com/inhabitedtype/ocaml-webmachine/blob/master/lib/rfc1123.ml
*)
let s429_t t = Error (`Too_many_requests, [ H.ct_plain; H.retry_after t ], R.nobody )
let s500' = (`Internal_server_error, [ H.ct_plain ], R.nobody)
let s500  = Error s500'
let s501  = Error (`Not_implemented, [ H.ct_plain ], R.nobody)
let s502' = (`Bad_gateway, [ H.ct_plain ], R.nobody)
let s502  = Error s502'

let err500 ?(error = s500') ?(level = Logs.Error) msg e =
  Logr.msg level (fun m -> m "%s: %s" msg e);
  error

let clob_send _ mime clob =
  Ok (`OK, [H.content_type mime], fun oc -> output_string oc clob)

(*
 * https://datatracker.ietf.org/doc/html/draft-cavage-http-signatures-12
 * see also https://github.com/Gopiandcode/http_sig_ocaml/blob/254d464c16025e189ceb20190710fe50e9bd8d2b/http_sig.ml#L50
 *
 * Another list of k-v-pairs but in diiosyncratic encoding. Different from Cookie.
 *)
module Signature = struct
  (* https://datatracker.ietf.org/doc/html/rfc7230#section-3.2.6 *)
  module P = struct
    open Tyre
(*
    let _htab = char '\t'
    (* https://stackoverflow.com/a/52336696/349514 *)
    let _vchar = pcre {|[!-~]|}
    let _sp   = char ' '

    (* https://datatracker.ietf.org/doc/html/rfc7230#section-3.2.6 *)
    let _tchar = pcre {|[!#$%&'*+-.^_`|~0-9a-zA-Z]|}

    let _obs_text =  pcre {|€-ÿ|} (* %x80-FF *)
*)
    (* https://datatracker.ietf.org/doc/html/rfc7230#section-3.2.6 *)
    let token = pcre {|[!#$%&'*+-.^_`|~0-9a-zA-Z]+|} (* rep1 tchar *)

    let qdtext = pcre {|[\t !#-\[\]-~€-ÿ]|}
    (* htab (* HTAB *)
               <|> sp (* SP *)
               <|> char '!' (* %x21 *)
               <|> pcre {|[#-\[]|} (* %x23-5B *)
               <|> pcre {|[\]-~]|} (* %x5D-7E *)
               <|> obs_text
    *)

    let dquote = char '"'

    let quoted_pair = char '\\' *> pcre {|[\t !-~€-ÿ]|} (* (htab <|> sp <|> vchar <|> obs_text) *)

    let quoted_string =
      conv
        (fun x ->
           let buf = Buffer.create 100 in
           x
           |> Seq.fold_left (fun bu u ->
               (match u with
                | `Left  ch
                | `Right ch -> ch)
               |> Buffer.add_string bu; bu) buf
           |> Buffer.contents)
        (fun x ->
           x
           |> String.to_seq
           |> Seq.map (fun c ->
               if c == '"'  (* quote more? *)
               then `Right (String.init 1 (fun _ -> c))
               else `Left  (String.init 1 (fun _ -> c))))
        (dquote *> (rep (qdtext <|> quoted_pair)) <* dquote)

    let ows = pcre {|[ \t]*|}
    let bws = ows

    (* https://datatracker.ietf.org/doc/html/rfc7235#section-2.1 *)
    let auth_param =
      conv
        (function
          | (t,`Left x)
          | (t,`Right x) -> t,x)
        (fun (t,s) ->
           (* TODO make s a token (`Left) if possible *)
           (t,`Right s))
        (token <* bws <* char '=' <* bws <&> (token <|> quoted_string))

    let list_auth_param =
      (* implement production 'credentials' at https://datatracker.ietf.org/doc/html/rfc7235#appendix-C *)
      let sep = bws *> char ',' <* bws in
      start *> separated_list ~sep auth_param <* stop

    (* https://gabriel.radanne.net/papers/tyre/tyre_paper.pdf#page=9 *)
    let list_auth_param' = compile list_auth_param
  end

  (**) (* https://datatracker.ietf.org/doc/html/draft-cavage-http-signatures-12#section-4.1 *)
  let decode s =
    (* Logr.debug (fun m -> m "%s.%s %s" "Http.Signature" "parse" s); *)
    Tyre.exec P.list_auth_param' s

  let to_sign_string ~request h =
    let h = h |> Cohttp.Header.to_frames in
    (match request with
     | Some (meth,uri) ->
       let s = Printf.sprintf "(request-target): %s %s"
           (meth |> String.lowercase_ascii)
           (uri |> Uri.path_and_query) in
       h |> List.cons s
     | _ -> h)
    |> String.concat "\n"
end

type t_sign_k = Uri.t * (Cstruct.t-> string * Cstruct.t) * Ptime.t

(** Create headers including a signature for a POST request.
 *
 * https://blog.joinmastodon.org/2018/06/how-to-implement-a-basic-activitypub-server/#http-signatures
 * https://socialhub.activitypub.rocks/t/help-needed-http-signatures/2458
 * https://tools.ietf.org/id/draft-cavage-http-signatures-12.html
 *
 * HTTP signature according https://tools.ietf.org/id/draft-cavage-http-signatures-12.html#rfc.appendix.C
 * https://www.ietf.org/archive/id/draft-ietf-httpbis-message-signatures-10.html#name-creating-a-signature
 * Digest http://tools.ietf.org/html/rfc3230#section-4.3.2
 *
 * https://docs.joinmastodon.org/spec/security/#http
 * https://w3id.org/security#publicKey
 * https://w3id.org/security/v1
 *
 * NOT: https://datatracker.ietf.org/doc/draft-ietf-httpbis-message-signatures/
*)
let signed_headers (key_id,(fkt_sign : Cstruct.t -> string * Cstruct.t),date : t_sign_k) dige uri =
  let open Cohttp in
  let hdr = (
    ("host", uri |> Uri.host |> Option.value ~default:"-") ::
    ("date", date |> to_rfc1123) ::
    match dige with
    | None      -> []
    | Some dige -> ("digest", dige) :: []
  ) |> Header.of_list in
  let meth,dige = match dige with
    | None   -> "get", ""
    | Some _ -> "post"," digest"
  in
  let request = Some (meth,uri) in
  let algo,(sgna : Cstruct.t) = hdr
                                |> Signature.to_sign_string ~request
                                |> Cstruct.of_string
                                |> fkt_sign in
  Printf.sprintf (* must be symmetric to Signature.decode *)
    "keyId=\"%s\",\
     algorithm=\"%s\",\
     headers=\"(request-target) host date%s\",\
     signature=\"%s\""
    (key_id |> Uri.to_string)
    algo
    dige
    (sgna |> Cstruct.to_string |> Base64.encode_exn)
  |> Header.add hdr "signature"
(* Logr.debug (fun m -> m "%s.%s\n%s" "Http" "signed_headers" (r |> Header.to_string)); *)

(* https://github.com/mirage/ocaml-cohttp#dealing-with-timeouts *)
let timeout ~seconds ~f =
  try%lwt
    Lwt.pick
      [
        Lwt.map Result.ok (f ()) ;
        Lwt.map (fun () -> Error "Timeout") (Lwt_unix.sleep seconds);
      ]
  with
  | Failure s -> Lwt.return (Error s)

(* don't care about maximum redirects but rather enforce a timeout *)
let get
    ?(key : t_sign_k option = None)
    ?(seconds = 5.0)
    ?(headers = Cohttp.Header.init())
    uri =
  let t0 = Sys.time () in
  let uuid = Uuidm.v `V4 in
  let headers = H.agent |> H.add' headers in
  let headers = uuid |> H.x_request_id |> H.add' headers in
  (* based on https://github.com/mirage/ocaml-cohttp#dealing-with-redirects *)
  let rec get_follow uri =
    let headers = match key with
      | None     -> headers
      | Some key ->
        Cohttp.Header.(signed_headers key None uri |> to_list |> add_list headers) in
    let%lwt r = Cohttp_lwt_unix.Client.get ~headers uri in
    follow_redirect ~base:uri r
  and follow_redirect ~base (response, body) =
    let sta = response |> Cohttp.Response.status in
    Logr.debug (fun m -> m "%s.%s %a %s" "Http" "get" Uuidm.pp uuid (Cohttp.Code.string_of_status sta));
    match sta with
    | #Cohttp.Code.redirection_status as sta ->
      (* if response |> Cohttp.Response.status |> Cohttp.Code.code_of_status |> Cohttp.Code.is_redirection *)
      (* should we ignore the status and just use location if present? *)
      ( match "location" |> Cohttp.Header.get (Cohttp.Response.headers response) with
        | Some loc ->
          Logr.debug (fun m -> m "%s.%s HTTP %d location: %s" "Http" "get" (Cohttp.Code.code_of_status sta) loc);
          let loc = loc |> Uri.of_string |> reso ~base in
          let fol () = get_follow loc in
          (* The unconsumed body would leak memory *)
          let%lwt p = Cohttp_lwt.Body.drain_body body in
          fol p
        | None ->
          Logr.warn (fun m -> m "%s.%s missing location header %a" "Http" "get" Uri.pp_hum base);
          Lwt.return (response, body) )
    |  _ -> Lwt.return (response, body)
  and f () = get_follow uri in
  let r = timeout ~seconds ~f in
  Logr.info (fun m -> m "%s.%s %a dt=%.3fs localhost -> %a" "Http" "get" Uuidm.pp uuid (Sys.time() -. t0) Uri.pp uri);
  r

let post
    ?(seconds = 5.0)
    ~headers
    body
    uri : 'a Lwt.t =
  let t0 = Sys.time () in
  let uuid = Uuidm.v `V4 in
  let headers = uuid |> H.x_request_id |> H.add' headers in
  let headers = H.agent |> H.add' headers in
  let headers = body |> String.length |> H.content_length |> H.add' headers in
  let f () = Cohttp_lwt_unix.Client.post ~body:(`String body) ~headers uri in
  let r = timeout ~seconds ~f in
  Logr.info (fun m -> m "%s.%s %a dt=%.3fs localhost -> %a" "Http" "post" Uuidm.pp uuid (Sys.time() -. t0) Uri.pp uri);
  Logr.debug (fun m -> m "%s.%s\n%s%s" "Http" "post" (headers |> Cohttp.Header.to_string) body);
  r

let get_jsonv
    ?(key = None)
    ?(seconds = 5.0)
    ?(headers = [ H.acc_app_jlda ] |> Cohttp.Header.of_list)
    fkt
    uri =
  let%lwt p = get ~key ~seconds ~headers uri in
  match p with
  | Error _ as e -> Lwt.return e
  | Ok (_resp, body) ->
    let%lwt body = body |> Cohttp_lwt.Body.to_string in
    (try
       body
       |> Ezjsonm.value_from_string
       |> fkt
       |> Lwt.return
     with
     | Ezjsonm.Parse_error (_,msg) ->
       Error ("parsing as json: '" ^ msg ^ "'")
       |> Lwt.return
     | e ->
       Logr.err (fun m -> m "%s %s.%s: %s" E.e1013 "Http" "get_jsonv" body);
       raise e)

let get_jsonv'
    ?(key : t_sign_k option = None)
    ?(seconds = 5.0)
    ?(headers = [ H.acc_app_jlda ] |> Cohttp.Header.of_list)
    fkt
    uri =
  let%lwt p = get ~key ~seconds ~headers uri in
  match p with
  | Error _ as e -> Lwt.return e
  | Ok (resp, body) ->
    let%lwt body = body |> Cohttp_lwt.Body.to_string in
    let body = (try
                  body
                  |> Ezjsonm.value_from_string
                with _ ->
                  Logr.err (fun m -> m "%s %s.%s parsing as json: %s" E.e1014 "Http" "get_jsonv'" body);
                  `Null) in
    fkt (resp,body)
    |> Lwt.return

let plain2html s =
  s
  |> Lexing.from_string
  |> Plain2html.url (Buffer.create 100)
  |> Buffer.contents

module Form = struct
  type field = string * string list (* name and values *)
  type t     = field list

  (* https://discuss.ocaml.org/t/decoding-x-www-form-urlencoded/4505/3?u=mro *)
  (* application/x-www-form-urlencoded *)
  let of_string s : t = Uri.query_of_encoded s
  let of_channel ic = ic |> input_line |> of_string
(*
  let sort (l : t) : t =
    l |> List.sort (fun (a, _) (b, _) -> String.compare a b)

  let filter_sort f l = l |> List.filter f |> sort

  let filter_sort_keys (ks : string list) l =
    l |> filter_sort (fun (k, _) -> List.exists (String.equal k) ks)
*)

  (* define a form with fields & constraints (name,type, [(att,val)]) *)
  type input = string * string * (string * string) list

  let validate name ty v attr =
    let vali ty (an,av) v =
      match ty,an with
      | _,"maxlength" ->
        Logr.debug (fun m -> m "    validate %s='%s'" an av);
        (* http://www.w3.org/TR/html5/forms.html#the-maxlength-and-minlength-attributes
           https://wiki.selfhtml.org/wiki/HTML/Elemente/input *)
        (match av |> int_of_string_opt with
         | None -> Error (name,"invalid maxlength")
         | Some max -> if String.length v <= max
           then Ok v
           else Error (name,"longer than maxlength"))
      | _,"minlength" ->
        Logr.debug (fun m -> m "    validate %s='%s'" an av);
        (* http://www.w3.org/TR/html5/forms.html#the-maxlength-and-minlength-attributes
           https://wiki.selfhtml.org/wiki/HTML/Elemente/input *)
        (match av |> int_of_string_opt with
         | None -> Error (name,"invalid minlength")
         | Some min -> if String.length v >= min
           then Ok v
           else Error (name,"shorter than minlength"))
      | _,"pattern" ->
        Logr.debug (fun m -> m "    '%s' ~ /%s/" v av);
        (try
           let rx = Re.Pcre.regexp av in
           if Re.execp rx v
           then Ok v
           else Error (name,"pattern mismatch")
         with | _ -> Error (name,"invalid pattern"))
      | _ -> Ok v
    in
    Result.bind v (vali ty attr)

  let string_opt ((name,ty,constraints) : input) (vals : t) : (string option, string * string) result =
    Logr.debug (fun m -> m "  <input name='%s' ..." name);
    match List.assoc_opt name vals with
    | None   ->
      (match List.assoc_opt "required" constraints with
       | None   -> Ok None
       | Some _ -> Error (name, "required but missing"))
    | Some v ->
      let* s = List.fold_left
          (validate name ty)
          (v |> String.concat "" |> Result.ok)
          constraints in
      Ok (Some s)

  let string (name,ty,contraints) va : (string, string * string) result =
    match string_opt (name,ty,contraints) va with
    | Error _ as e -> e
    | Ok None      -> Logr.err (fun m -> m "%s Field '%s' must be 'required' to use 'string'" E.e1012 name);
      Error (name, "implicitly required but missing")
    | Ok (Some v)  -> Ok v
end