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 pp_status ppf status = Format.pp_print_string ppf (status |> Cohttp.Code.string_of_status)

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

(** subtract the base from path, so as Uri.resolve "" base x = path *)
let relpa base path =
  let rec f = function
    | _ :: [], p -> p
    | bh :: bt, ph :: pt when String.equal bh ph -> f (bt,pt)
    | _    -> []
  in
  let is_sep = Astring.Char.equal '/' in
  let ba = base |> Astring.String.fields ~is_sep
  and pa = path |> Astring.String.fields ~is_sep in
  f (ba,pa) |> Astring.String.concat ~sep:"/"

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 s411'  = (`Length_required,  [ H.ct_plain ], R.nobody)
let s411  = Error s411'
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 ], ("429: Too many requests." |> R.body))
let s500' = (`Internal_server_error, [ H.ct_plain ], R.nobody) (** HTTP 500 Internal Server error and empty body (camel) *)
let s500  = Error s500' (** HTTP 500 Internal Server error and empty body (camel) *)
let s501  = Error (`Not_implemented, [ H.ct_plain ], R.nobody)
let s502' ~(body : out_channel -> unit) = (`Bad_gateway, [ H.ct_plain ], body)
let s502 ~body = Error (s502' ~body)

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

(** Send a clob as is and 200 Ok *)
let clob_send _ ct clob =
  Ok (`OK, [H.content_type ct], clob |> Cgi.Response.body)

(*
 * 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 idiosyncratic 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 ->
               let s = Astring.String.of_char c in
               if c == '"'  (* quote more? *)
               then `Right s
               else `Left  s))
        (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 = Tyre.exec P.list_auth_param'

  (** the header value without escaping e.g. = or "" *)
  let encode =
    (*
        |> List.fold_left (fun init (k,v) -> Printf.sprintf {|%s="%s"|} k v :: init) []
        |> Astring.String.concat ~sep:"," in
        *)
    Tyre.eval P.list_auth_param

  (** add (request-target) iff request given *)
  let to_sign_string0 ~request h : string =
    let h = h |> Cohttp.Header.to_frames in
    (match request with
     | None -> h
     | Some (meth,uri) ->
       let s = Printf.sprintf "(request-target): %s %s"
           (meth |> Cohttp.Code.string_of_method |> String.lowercase_ascii)
           (uri |> Uri.path_and_query) in
       s :: h)
    |> Astring.String.concat ~sep:"\n"

  (**
     - key_id
     - pk
     - now *)
  type t_key = Uri.t * X509.Private_key.t * Ptime.t

  let mkey id pk t : t_key = (id,pk,t)

  (** build the string to sign *)
  let to_sign_string'
      (meth : Cohttp.Code.meth)
      (targ : Uri.t)
      (hdrs : (string * string) list) =
    let n,s = [],[] in
    let n,s = match hdrs |> List.assoc_opt "digest" with
      | None   -> n,s
      | Some d -> "digest" :: n,("digest",d) :: s in
    let n = "(request-target)" :: "host" :: "date" :: n in
    let s = ("(request-target)",Printf.sprintf "%s %s"
               (meth |> Cohttp.Code.string_of_method |> Astring.String.map Astring.Char.Ascii.lowercase)
               (targ |> Uri.path_and_query))
            :: ("host",targ |> Uri.host |> Option.get)
            :: ("date",hdrs |> List.assoc "date")
            :: s in
    n,s

  let to_sign_string meth targ hdrs =
    let n,l = to_sign_string' meth targ hdrs in
    n |> Astring.String.concat ~sep:" "
    ,
    l |> Cohttp.Header.of_list
    |> Cohttp.Header.to_frames
    |> Astring.String.concat ~sep:"\n"

  (**
      HTTP signature according https://tools.ietf.org/id/draft-cavage-http-signatures-12.html#rfc.appendix.C
  *)
  module RSA_SHA256 = struct
    let hash   = `SHA256
    and scheme = `RSA_PKCS1
    let name   = "rsa-sha256"
    and sign   = X509.Private_key.sign  hash ~scheme
    and verify = X509.Public_key.verify hash ~scheme
  end

  (**
      HTTP signature according https://tools.ietf.org/id/draft-cavage-http-signatures-12.html#rfc.appendix.C
  *)
  module HS2019 = struct
    let hash   = `SHA512
    and scheme = `RSA_PSS
    let name   = "hs2019"
    and sign   = X509.Private_key.sign  hash ~scheme
    and verify = X509.Public_key.verify hash ~scheme
  end

  let add
      (priv : X509.Private_key.t)
      (meth : Cohttp.Code.meth)
      (targ : Uri.t)
      (hdrs : (string * string) list) =
    assert (hdrs |> List.assoc_opt "date" |> Option.is_some);
    assert (targ |> Uri.host |> Option.is_some);
    assert (hdrs |> List.assoc_opt "host" |> Option.is_some);
    assert (hdrs |> List.assoc "host" |> Astring.String.equal (targ |> Uri.host_with_default ~default:""));
    let n,s = to_sign_string meth targ hdrs in
    (* build the signature header value *)
    match RSA_SHA256.(name,(sign priv (`Message (s |> Cstruct.of_string) ))) with
    | _,(Error _ as e) -> e
    | alg,Ok si ->
      let v = [
        "algorithm",alg;
        "headers"  ,n;
        "signature", si |> Cstruct.to_string |> Base64.encode_string;
      ]
        |> encode in
      Ok ( hdrs @ ["signature",v] )
end

(** 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,pk,date : Signature.t_key) 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) :: []
  ) in
  let meth,lst = match dige with
    | None   -> `GET, ""
    | Some _ -> `POST," digest"
  in
  (*
  let _n,tx_ = Signature.to_sign_string2 meth uri hdr in
  let tx_ = tx_ |> Cohttp.Header.of_list |> Cohttp.Header.to_frames |> Astring.String.concat ~sep:"\n" in
  assert (tx_ |> String.equal tx');
  *)
  let tx = hdr
           |> Cohttp.Header.of_list
           |> Signature.to_sign_string0 ~request:(Some (meth,uri)) in
  let sgna =
    Signature.RSA_SHA256.sign
      pk
      (`Message (Cstruct.of_string tx))
    |> Result.get_ok
    |> Cstruct.to_string
    |> Base64.encode_exn
  in
  ["keyId",     key_id |> Uri.to_string ;
   "algorithm", Signature.RSA_SHA256.name ;
   "headers",   "(request-target) host date" ^ lst ;
   "signature",  sgna ;
  ]
  |> Signature.encode
     (*
     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
       lst
       (sgna |> Cstruct.to_string |> Base64.encode_exn)
       *)
  |> Header.add (hdr |> Header.of_list) "signature"

(* 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 = 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.status in
    Logr.debug (fun m -> m "%s.%s %a %a" "Http" "get.follow_redirect" Uuidm.pp uuid pp_status sta);
    match sta with
    | #Cohttp.Code.redirection_status ->
      (* 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 %a location: %s" "Http" "get.follow_redirect" pp_status sta loc);
          (* The unconsumed body would leak memory *)
          let%lwt _ = Cohttp_lwt.Body.drain_body body in
          loc
          |> Uri.of_string
          |> reso ~base
          |> get_follow
        | None ->
          Logr.warn (fun m -> m "%s.%s missing location header %a" "Http" "get.follow_redirect" Uri.pp_hum base);
          Lwt.return (response, body) )
    |  _ ->
      (* here the http header signature validation could be done.
         But not for now: https://seppo.social/issues/23 *)
      Logr.debug (fun m -> m "%s.%s %a %a" "Http" "get" Uuidm.pp uuid Cohttp.Response.pp_hum response);
      Lwt.return (response, body)
  and f () = get_follow uri in
  Logr.debug (fun m -> m "%s.%s %a %a" "Http" "get" Uri.pp uri Cohttp.Header.pp_hum headers);
  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
  (* here the http header signature validation could be done.
     But no for now: https://seppo.social/issues/23 *)
  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 =
  Logr.debug (fun m -> m "%s.%s %a" "Http" "get_jsonv" Uri.pp uri);
  let err fmt msg =
    Error (Printf.sprintf fmt msg) in
  let%lwt p = get ~key ~seconds ~headers uri in
  match p with
  | Error _ as e -> Lwt.return e
  | Ok (resp, body) ->
    match resp.status with
    | #Cohttp.Code.success_status as sta ->
      Logr.debug (fun m -> m "%s.%s get %a %a" "Http" "get_jsonv" Uri.pp uri pp_status sta);
      let%lwt body = body |> Cohttp_lwt.Body.to_string in
      (* doesn't validate the digest https://seppo.social/issues/23 *)
      (try
         (resp, body |> Ezjsonm.value_from_string)
         |> fkt
       with
       | Ezjsonm.Parse_error (_,msg) ->
         err "parsing json: '%s'" msg
       | e ->
         err "parsing json: '%s'" (e |> Printexc.to_string) )
      |> Lwt.return
    | sta -> err "Gateway error: %s" (sta |> Cohttp.Code.string_of_status)
             |> Lwt.return


let err400 k =
  (`Bad_request,  [ H.ct_plain ], ("required input missing: " ^ k) |> R.body)

(** Extract one required parameter from a get query

    pq: typically Cgi.Request.path_and_query *)
let par1 ?(err = err400) pq k0 =
  let* v0 = k0 |> Uri.get_query_param pq |> Option.to_result ~none:(err k0) in
  Ok v0

(** Extract two required parameters from a get query

    pq: typically Cgi.Request.path_and_query *)
let par2 ?(err = err400) pq (k0,k1) =
  let* v0 = k0 |> Uri.get_query_param pq |> Option.to_result ~none:(err k0) in
  let* v1 = k1 |> Uri.get_query_param pq |> Option.to_result ~none:(err k1) in
  Ok (v0,v1)

(** run a value through a function *)
let f1 ?(f = Uri.of_string) v0 =
  Ok (v0 |> f)

(** run a tuple's values through a function *)
let f2 ?(f = Uri.of_string) (v0,v1) =
  Ok (v0 |> f,v1 |> f)