lib/http.ml

   1 (*
   2  *    _  _   ____                         _
   3  *  _| || |_/ ___|  ___ _ __  _ __   ___ | |
   4  * |_  ..  _\___ \ / _ \ '_ \| '_ \ / _ \| |
   5  * |_      _|___) |  __/ |_) | |_) | (_) |_|
   6  *   |_||_| |____/ \___| .__/| .__/ \___/(_)
   7  *                     |_|   |_|
   8  *
   9  * Personal Social Web.
  10  *
  11  * Copyright (C) The #Seppo contributors. All rights reserved.
  12  *
  13  * This program is free software: you can redistribute it and/or modify
  14  * it under the terms of the GNU General Public License as published by
  15  * the Free Software Foundation, either version 3 of the License, or
  16  * (at your option) any later version.
  17  *
  18  * This program is distributed in the hope that it will be useful,
  19  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  20  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21  * GNU General Public License for more details.
  22  *
  23  * You should have received a copy of the GNU General Public License
  24  * along with this program.  If not, see <http://www.gnu.org/licenses/>.
  25  *)
  26
  27 let ( let* ) = Result.bind
  28 let ( let*% ) r f : ('b,'e) Lwt_result.t =
  29   (* https://discuss.ocaml.org/t/idiomatic-let-result-bind-and-lwt-bind/12554?u=mro *)
  30   match r with
  31   | Error _ as e -> Lwt.return e (* similar to Result.map_error but without unwrapping *)
  32   | Ok v         -> f v
  33
  34 let pp_status ppf status = Format.pp_print_string ppf (status |> Cohttp.Code.string_of_status)
  35
  36 let reso ~base url =
  37   Uri.resolve "https" base url
  38
  39 (** subtract the base from path, so as Uri.resolve "" base x = path *)
  40 let relpa base path =
  41   let rec f = function
  42     | _ :: [], p -> p
  43     | bh :: bt, ph :: pt when String.equal bh ph -> f (bt,pt)
  44     | _    -> []
  45   in
  46   let is_sep = Astring.Char.equal '/' in
  47   let ba = base |> Astring.String.fields ~is_sep
  48   and pa = path |> Astring.String.fields ~is_sep in
  49   f (ba,pa) |> Astring.String.concat ~sep:"/"
  50
  51 let abs_to_rel ~base url =
  52   match url |> Uri.host with
  53   | None -> url
  54   | Some _ as ho ->
  55     let url = if Option.equal String.equal (Uri.host base) ho
  56       then Uri.with_host url None
  57       else url in
  58     let url = if Option.equal String.equal (Uri.scheme base) (Uri.scheme url)
  59       then Uri.with_scheme url None
  60       else url in
  61     let url = if Option.equal Int.equal (Uri.port base) (Uri.port url)
  62       then Uri.with_port url None
  63       else url in
  64     let url = Uri.with_path url (relpa (Uri.path base) (Uri.path url)) in
  65     url
  66
  67 (* https://tools.ietf.org/html/rfc2616/#section-3.3.1
  68    https://tools.ietf.org/html/rfc1123#page-55
  69    https://tools.ietf.org/html/rfc822#section-5.1
  70 *)
  71 let to_rfc1123 (time : Ptime.t) =
  72   (* MIT License, Copyright 2021 Anton Bachin
  73      https://github.com/aantron/dream/blob/master/src/pure/formats.ml#L51 *)
  74   let weekday =
  75     match Ptime.weekday time with
  76     | `Sun -> "Sun"
  77     | `Mon -> "Mon"
  78     | `Tue -> "Tue"
  79     | `Wed -> "Wed"
  80     | `Thu -> "Thu"
  81     | `Fri -> "Fri"
  82     | `Sat -> "Sat"
  83   in
  84   let (y, m, d), ((hh, mm, ss), _tz_offset_s) = Ptime.to_date_time time in
  85   let month =
  86     match m with
  87     | 1 -> "Jan"
  88     | 2 -> "Feb"
  89     | 3 -> "Mar"
  90     | 4 -> "Apr"
  91     | 5 -> "May"
  92     | 6 -> "Jun"
  93     | 7 -> "Jul"
  94     | 8 -> "Aug"
  95     | 9 -> "Sep"
  96     | 10 -> "Oct"
  97     | 11 -> "Nov"
  98     | 12 -> "Dec"
  99     | _ -> failwith "Month < 1 or > 12 not allowed"
 100   in
 101   (* [Ptime.to_date_time] docs give range 0..60 for [ss], accounting for
 102      leap seconds. However, RFC 6265 §5.1.1 states:
 103      5.  Abort these steps and fail to parse the cookie-date if:
 104        *  the second-value is greater than 59.
 105        (Note that leap seconds cannot be represented in this syntax.)
 106      See https://tools.ietf.org/html/rfc6265#section-5.1.1.
 107      Even though [Ptime.to_date_time] time does not return leap seconds, in
 108      case I misunderstood the gmtime API, of system differences, or future
 109      refactoring, make sure no leap seconds creep into the output. *)
 110   Printf.sprintf "%s, %02i %s %04i %02i:%02i:%02i GMT" weekday d month y hh mm
 111     (min 59 ss)
 112
 113 module Mime = struct
 114   module C = As2_vocab.Constants.ContentType
 115   let _app_act_json= C._app_act_json
 116   let app_jlda     = C.app_jlda
 117   let app_jrd      = C.app_jrd
 118   let app_atom_xml = C.app_atom_xml
 119   let app_form_url = "application/x-www-form-urlencoded"
 120   let app_json     = C.app_json
 121   let img_jpeg     = "image/jpeg"
 122   let text_css     = "text/css; charset=utf8"
 123   let text_html    = "text/html; charset=utf8"
 124   let text_plain   = "text/plain; charset=utf8"
 125   let text_xml     = "text/xml"
 126   let text_xsl     = "text/xsl"
 127
 128   let is_app_json m =
 129     _app_act_json |> String.equal m
 130     || app_json |> String.equal m
 131 end
 132
 133 module H = struct
 134   type t = string * string
 135
 136   let add' h (n, v) = Cohttp.Header.add h n v
 137
 138   let acc_app_json        = ("Accept",       Mime.app_json)
 139   let acc_app_jrd         = ("Accept",       Mime.app_jrd)
 140   let acc_app_jlda        = ("Accept",       Mime.app_jlda)
 141   let agent               = ("User-Agent",   St.seppo_s)
 142
 143   let content_type ct : t = ("Content-Type", ct)
 144
 145   let ct_jlda             = content_type Mime.app_jlda
 146   let ct_html             = content_type Mime.text_html
 147   let ct_json             = content_type Mime.app_json
 148   let ct_plain            = content_type Mime.text_plain
 149   let ct_xml              = content_type Mime.text_xml
 150
 151   let content_length cl:t = ("Content-Length", cl |> string_of_int)
 152   let location url    : t = ("Location",     url)
 153   let retry_after t   : t = ("Retry-After",  t |> to_rfc1123)
 154   let set_cookie v    : t = ("Set-Cookie",   v)
 155   let max_age _       : t = assert false (* set via webserver config *)
 156   let x_request_id u  : t = ("X-Request-Id", Uuidm.to_string u)
 157 end
 158
 159 module R = Cgi.Response
 160 (** See also https://github.com/aantron/dream/blob/master/src/pure/status.ml
 161     RFC1945 demands absolute uris https://www.rfc-editor.org/rfc/rfc1945#section-10.11 *)
 162 let s302 ?(header = []) url = Error (`Found, [ H.ct_plain; H.location url ] @ header, R.nobody)
 163 let s400' = (`Bad_request,  [ H.ct_plain ], R.nobody)
 164 let s400  = Error s400'
 165 let s400x = Error (`Bad_request,  [ H.ct_xml ], R.nobody)
 166 let s401  = Error (`Unauthorized, [ H.ct_plain ], R.nobody)
 167 let s403' = (`Forbidden,    [ H.ct_plain ], R.nobody)
 168 let s403  = Error s403'
 169 let s404  = Error (`Not_found,    [ H.ct_plain ], R.nobody)
 170 let s405  = Error (`Method_not_allowed, [ H.ct_plain ], R.nobody)
 171 let s411'  = (`Length_required,  [ H.ct_plain ], R.nobody)
 172 let s411  = Error s411'
 173 let s413  = Error (`Code 413,  [ H.ct_plain ], R.nobody) (* Payload too large *)
 174 (* https://stackoverflow.com/a/42171674/349514 *)
 175 let s422' = (`Unprocessable_entity, [ H.ct_plain ], R.nobody)
 176 let s422  = Error s422'
 177 let s422x = Error (`Unprocessable_entity, [ H.ct_xml ], R.nobody)
 178 (* https://tools.ietf.org/html/rfc6585#section-4
 179    Retry-After https://tools.ietf.org/html/rfc2616#section-14.37
 180    HTTP-date https://tools.ietf.org/html/rfc1123
 181    https://github.com/inhabitedtype/ocaml-webmachine/blob/master/lib/rfc1123.ml
 182 *)
 183 let s429_t t = Error (`Too_many_requests, [ H.ct_plain; H.retry_after t ], ("429: Too many requests." |> R.body))
 184 let s500' = (`Internal_server_error, [ H.ct_plain ], R.nobody) (** HTTP 500 Internal Server error and empty body (camel) *)
 185 let s500  = Error s500' (** HTTP 500 Internal Server error and empty body (camel) *)
 186 let s501  = Error (`Not_implemented, [ H.ct_plain ], R.nobody)
 187 let s502' ~(body : out_channel -> unit) = (`Bad_gateway, [ H.ct_plain ], body)
 188 let s502 ~body = Error (s502' ~body)
 189
 190 let err500 ?(error = s500') ?(level = Logs.Error) msg e =
 191   Logr.msg level (fun m -> m "%s: %s" msg e);
 192   error
 193
 194 (** Send a clob as is and 200 Ok *)
 195 let clob_send _ ct clob =
 196   Ok (`OK, [H.content_type ct], clob |> Cgi.Response.body)
 197
 198 (*
 199  * https://datatracker.ietf.org/doc/html/draft-cavage-http-signatures-12
 200  * see also https://github.com/Gopiandcode/http_sig_ocaml/blob/254d464c16025e189ceb20190710fe50e9bd8d2b/http_sig.ml#L50
 201  *
 202  * Another list of k-v-pairs but in idiosyncratic encoding. Different from Cookie.
 203  *)
 204 module Signature = struct
 205   (* https://datatracker.ietf.org/doc/html/rfc7230#section-3.2.6 *)
 206   module P = struct
 207     open Tyre
 208 (*
 209     let _htab = char '\t'
 210     (* https://stackoverflow.com/a/52336696/349514 *)
 211     let _vchar = pcre {|[!-~]|}
 212     let _sp   = char ' '
 213
 214     (* https://datatracker.ietf.org/doc/html/rfc7230#section-3.2.6 *)
 215     let _tchar = pcre {|[!#$%&'*+-.^_`|~0-9a-zA-Z]|}
 216
 217     let _obs_text =  pcre {|€-ÿ|} (* %x80-FF *)
 218 *)
 219     (* https://datatracker.ietf.org/doc/html/rfc7230#section-3.2.6 *)
 220     let token = pcre {|[!#$%&'*+-.^_`|~0-9a-zA-Z]+|} (* rep1 tchar *)
 221
 222     let qdtext = pcre {|[\t !#-\[\]-~€-ÿ]|}
 223     (* htab (* HTAB *)
 224                <|> sp (* SP *)
 225                <|> char '!' (* %x21 *)
 226                <|> pcre {|[#-\[]|} (* %x23-5B *)
 227                <|> pcre {|[\]-~]|} (* %x5D-7E *)
 228                <|> obs_text
 229     *)
 230
 231     let dquote = char '"'
 232
 233     let quoted_pair = char '\\' *> pcre {|[\t !-~€-ÿ]|} (* (htab <|> sp <|> vchar <|> obs_text) *)
 234
 235     let quoted_string =
 236       conv
 237         (fun x ->
 238            let buf = Buffer.create 100 in
 239            x
 240            |> Seq.fold_left (fun bu u ->
 241                (match u with
 242                 | `Left  ch
 243                 | `Right ch -> ch)
 244                |> Buffer.add_string bu; bu) buf
 245            |> Buffer.contents)
 246         (fun x ->
 247            x
 248            |> String.to_seq
 249            |> Seq.map (fun c ->
 250                let s = Astring.String.of_char c in
 251                if c == '"'  (* quote more? *)
 252                then `Right s
 253                else `Left  s))
 254         (dquote *> (rep (qdtext <|> quoted_pair)) <* dquote)
 255
 256     let ows = pcre {|[ \t]*|}
 257     let bws = ows
 258
 259     (* https://datatracker.ietf.org/doc/html/rfc7235#section-2.1 *)
 260     let auth_param =
 261       conv
 262         (function
 263           | (t,`Left x)
 264           | (t,`Right x) -> t,x)
 265         (fun (t,s) ->
 266            (* TODO make s a token (`Left) if possible *)
 267            (t,`Right s))
 268         (token <* bws <* char '=' <* bws <&> (token <|> quoted_string))
 269
 270     let list_auth_param =
 271       (* implement production 'credentials' at https://datatracker.ietf.org/doc/html/rfc7235#appendix-C *)
 272       let sep = bws *> char ',' <* bws in
 273       start *> separated_list ~sep auth_param <* stop
 274
 275     (* https://gabriel.radanne.net/papers/tyre/tyre_paper.pdf#page=9 *)
 276     let list_auth_param' = compile list_auth_param
 277   end
 278
 279   (** https://datatracker.ietf.org/doc/html/draft-cavage-http-signatures-12#section-4.1 *)
 280   let decode = Tyre.exec P.list_auth_param'
 281
 282   (** the header value without escaping e.g. = or "" *)
 283   let encode =
 284     (*
 285         |> List.fold_left (fun init (k,v) -> Printf.sprintf {|%s="%s"|} k v :: init) []
 286         |> Astring.String.concat ~sep:"," in
 287         *)
 288     Tyre.eval P.list_auth_param
 289
 290   (** add (request-target) iff request given *)
 291   let to_sign_string0 ~request h : string =
 292     let h = h |> Cohttp.Header.to_frames in
 293     (match request with
 294      | None -> h
 295      | Some (meth,uri) ->
 296        let s = Printf.sprintf "(request-target): %s %s"
 297            (meth |> Cohttp.Code.string_of_method |> String.lowercase_ascii)
 298            (uri |> Uri.path_and_query) in
 299        s :: h)
 300     |> Astring.String.concat ~sep:"\n"
 301
 302   (**
 303      - key_id
 304      - pk
 305      - now *)
 306   type t_key = Uri.t * X509.Private_key.t * Ptime.t
 307
 308   let mkey id pk t : t_key = (id,pk,t)
 309
 310   (** build the string to sign *)
 311   let to_sign_string'
 312       (meth : Cohttp.Code.meth)
 313       (targ : Uri.t)
 314       (hdrs : (string * string) list) =
 315     let n,s = [],[] in
 316     let n,s = match hdrs |> List.assoc_opt "digest" with
 317       | None   -> n,s
 318       | Some d -> "digest" :: n,("digest",d) :: s in
 319     let n = "(request-target)" :: "host" :: "date" :: n in
 320     let s = ("(request-target)",Printf.sprintf "%s %s"
 321                (meth |> Cohttp.Code.string_of_method |> Astring.String.map Astring.Char.Ascii.lowercase)
 322                (targ |> Uri.path_and_query))
 323             :: ("host",targ |> Uri.host |> Option.get)
 324             :: ("date",hdrs |> List.assoc "date")
 325             :: s in
 326     n,s
 327
 328   let to_sign_string meth targ hdrs =
 329     let n,l = to_sign_string' meth targ hdrs in
 330     n |> Astring.String.concat ~sep:" "
 331     ,
 332     l |> Cohttp.Header.of_list
 333     |> Cohttp.Header.to_frames
 334     |> Astring.String.concat ~sep:"\n"
 335
 336   (**
 337       HTTP signature according https://tools.ietf.org/id/draft-cavage-http-signatures-12.html#rfc.appendix.C
 338   *)
 339   module RSA_SHA256 = struct
 340     let hash   = `SHA256
 341     and scheme = `RSA_PKCS1
 342     let name   = "rsa-sha256"
 343     and sign   = X509.Private_key.sign  hash ~scheme
 344     and verify = X509.Public_key.verify hash ~scheme
 345   end
 346
 347   (**
 348       HTTP signature according https://tools.ietf.org/id/draft-cavage-http-signatures-12.html#rfc.appendix.C
 349   *)
 350   module HS2019 = struct
 351     let hash   = `SHA512
 352     and scheme = `RSA_PSS
 353     let name   = "hs2019"
 354     and sign   = X509.Private_key.sign  hash ~scheme
 355     and verify = X509.Public_key.verify hash ~scheme
 356   end
 357
 358   let add
 359       (priv : X509.Private_key.t)
 360       (meth : Cohttp.Code.meth)
 361       (targ : Uri.t)
 362       (hdrs : (string * string) list) =
 363     assert (hdrs |> List.assoc_opt "date" |> Option.is_some);
 364     assert (targ |> Uri.host |> Option.is_some);
 365     assert (hdrs |> List.assoc_opt "host" |> Option.is_some);
 366     assert (hdrs |> List.assoc "host" |> Astring.String.equal (targ |> Uri.host_with_default ~default:""));
 367     let n,s = to_sign_string meth targ hdrs in
 368     (* build the signature header value *)
 369     match RSA_SHA256.(name,(sign priv (`Message (s |> Cstruct.of_string) ))) with
 370     | _,(Error _ as e) -> e
 371     | alg,Ok si ->
 372       let v = [
 373         "algorithm",alg;
 374         "headers"  ,n;
 375         "signature", si |> Cstruct.to_string |> Base64.encode_string;
 376       ]
 377         |> encode in
 378       Ok ( hdrs @ ["signature",v] )
 379 end
 380
 381 (** Create headers including a signature for a POST request.
 382
 383     https://blog.joinmastodon.org/2018/06/how-to-implement-a-basic-activitypub-server/#http-signatures
 384     https://socialhub.activitypub.rocks/t/help-needed-http-signatures/2458
 385     https://tools.ietf.org/id/draft-cavage-http-signatures-12.html
 386
 387     HTTP signature according https://tools.ietf.org/id/draft-cavage-http-signatures-12.html#rfc.appendix.C
 388     https://www.ietf.org/archive/id/draft-ietf-httpbis-message-signatures-10.html#name-creating-a-signature
 389     Digest http://tools.ietf.org/html/rfc3230#section-4.3.2
 390
 391     https://docs.joinmastodon.org/spec/security/#http
 392     https://w3id.org/security#publicKey
 393     https://w3id.org/security/v1
 394
 395     NOT: https://datatracker.ietf.org/doc/draft-ietf-httpbis-message-signatures/
 396 *)
 397 let signed_headers (key_id,pk,date : Signature.t_key) dige uri =
 398   let open Cohttp in
 399   let hdr = (
 400     ("host", uri |> Uri.host |> Option.value ~default:"-") ::
 401     ("date", date |> to_rfc1123) ::
 402     match dige with
 403     | None      -> []
 404     | Some dige -> ("digest", dige) :: []
 405   ) in
 406   let meth,lst = match dige with
 407     | None   -> `GET, ""
 408     | Some _ -> `POST," digest"
 409   in
 410   (*
 411   let _n,tx_ = Signature.to_sign_string2 meth uri hdr in
 412   let tx_ = tx_ |> Cohttp.Header.of_list |> Cohttp.Header.to_frames |> Astring.String.concat ~sep:"\n" in
 413   assert (tx_ |> String.equal tx');
 414   *)
 415   let tx = hdr
 416            |> Cohttp.Header.of_list
 417            |> Signature.to_sign_string0 ~request:(Some (meth,uri)) in
 418   let sgna =
 419     Signature.RSA_SHA256.sign
 420       pk
 421       (`Message (Cstruct.of_string tx))
 422     |> Result.get_ok
 423     |> Cstruct.to_string
 424     |> Base64.encode_exn
 425   in
 426   ["keyId",     key_id |> Uri.to_string ;
 427    "algorithm", Signature.RSA_SHA256.name ;
 428    "headers",   "(request-target) host date" ^ lst ;
 429    "signature",  sgna ;
 430   ]
 431   |> Signature.encode
 432      (*
 433      Printf.sprintf (* must be symmetric to Signature.decode *)
 434        "keyId=\"%s\",\
 435         algorithm=\"%s\",\
 436         headers=\"(request-target) host date%s\",\
 437         signature=\"%s\""
 438        (key_id |> Uri.to_string)
 439        algo
 440        lst
 441        (sgna |> Cstruct.to_string |> Base64.encode_exn)
 442        *)
 443   |> Header.add (hdr |> Header.of_list) "signature"
 444
 445 (* https://github.com/mirage/ocaml-cohttp#dealing-with-timeouts *)
 446 let timeout ~seconds ~f =
 447   try%lwt
 448     Lwt.pick
 449       [
 450         Lwt.map Result.ok (f ()) ;
 451         Lwt.map (fun () -> Error "Timeout") (Lwt_unix.sleep seconds);
 452       ]
 453   with
 454   | Failure s -> Lwt.return (Error s)
 455
 456 (* don't care about maximum redirects but rather enforce a timeout *)
 457 let get
 458     ?(key = None)
 459     ?(seconds = 5.0)
 460     ?(uuid_gen = () |> Random.State.make_self_init |> Uuidm.v4_gen)
 461     ?(headers = Cohttp.Header.init())
 462     uri =
 463   let t0 = Sys.time () in
 464   let uuid = () |> uuid_gen in
 465   let headers = H.agent |> H.add' headers in
 466   let headers = uuid |> H.x_request_id |> H.add' headers in
 467   (* based on https://github.com/mirage/ocaml-cohttp#dealing-with-redirects *)
 468   let rec get_follow uri =
 469     let headers = match key with
 470       | None     -> headers
 471       | Some key ->
 472         Cohttp.Header.(signed_headers key None uri |> to_list |> add_list headers) in
 473     let%lwt r = Cohttp_lwt_unix.Client.get ~headers uri in
 474     follow_redirect ~base:uri r
 475   and follow_redirect ~base (response, body) =
 476     let sta = response.status in
 477     Logr.debug (fun m -> m "%s.%s %a %a" "Http" "get.follow_redirect" Uuidm.pp uuid pp_status sta);
 478     match sta with
 479     | #Cohttp.Code.redirection_status ->
 480       (* should we ignore the status and just use location if present? *)
 481       ( match "location" |> Cohttp.Header.get (Cohttp.Response.headers response) with
 482         | Some loc ->
 483           Logr.debug (fun m -> m "%s.%s HTTP %a location: %s" "Http" "get.follow_redirect" pp_status sta loc);
 484           (* The unconsumed body would leak memory *)
 485           let%lwt _ = Cohttp_lwt.Body.drain_body body in
 486           loc
 487           |> Uri.of_string
 488           |> reso ~base
 489           |> get_follow
 490         | None ->
 491           Logr.warn (fun m -> m "%s.%s missing location header %a" "Http" "get.follow_redirect" Uri.pp_hum base);
 492           Lwt.return (response, body) )
 493     |  _ ->
 494       (* here the http header signature validation could be done.
 495          But not for now: https://seppo.mro.name/issues/23 *)
 496       Logr.debug (fun m -> m "%s.%s %a %a" "Http" "get" Uuidm.pp uuid Cohttp.Response.pp_hum response);
 497       Lwt.return (response, body)
 498   and f () = get_follow uri in
 499   Logr.debug (fun m -> m "%s.%s %a %a" "Http" "get" Uri.pp uri Cohttp.Header.pp_hum headers);
 500   let r = timeout ~seconds ~f in
 501   Logr.info (fun m -> m "%s.%s %a dt=%.3fs localhost -> %a" "Http" "get" Uuidm.pp uuid (Sys.time() -. t0) Uri.pp uri);
 502   r
 503
 504 let post
 505     ?(seconds = 5.0)
 506     ?(uuid_gen = () |> Random.State.make_self_init |> Uuidm.v4_gen)
 507     ~headers
 508     body
 509     uri : 'a Lwt.t =
 510   let t0 = Sys.time () in
 511   let uuid = () |> uuid_gen in
 512   let headers = uuid |> H.x_request_id |> H.add' headers in
 513   let headers = H.agent |> H.add' headers in
 514   let headers = body |> String.length |> H.content_length |> H.add' headers in
 515   let f () = Cohttp_lwt_unix.Client.post ~body:(`String body) ~headers uri
 516   (* here the http header signature validation could be done.
 517      But no for now: https://seppo.mro.name/issues/23 *)
 518   in
 519   let r = timeout ~seconds ~f in
 520   Logr.info (fun m -> m "%s.%s %a dt=%.3fs localhost -> %a" "Http" "post" Uuidm.pp uuid (Sys.time() -. t0) Uri.pp uri);
 521   Logr.debug (fun m -> m "%s.%s\n%s%s" "Http" "post" (headers |> Cohttp.Header.to_string) body);
 522   r
 523
 524 let get_jsonv
 525     ?(key = None)
 526     ?(seconds = 5.0)
 527     ?(headers = [ H.acc_app_jlda ] |> Cohttp.Header.of_list)
 528     fkt
 529     uri =
 530   Logr.debug (fun m -> m "%s.%s %a" "Http" "get_jsonv" Uri.pp uri);
 531   let err fmt msg =
 532     Error (Printf.sprintf fmt msg) in
 533   let%lwt p = get ~key ~seconds ~headers uri in
 534   match p with
 535   | Error _ as e -> Lwt.return e
 536   | Ok (resp, body) ->
 537     match resp.status with
 538     | #Cohttp.Code.success_status as sta ->
 539       Logr.debug (fun m -> m "%s.%s get %a %a" "Http" "get_jsonv" Uri.pp uri pp_status sta);
 540       let%lwt body = body |> Cohttp_lwt.Body.to_string in
 541       (* doesn't validate the digest https://seppo.mro.name/issues/23 *)
 542       (try
 543          (resp, body |> Ezjsonm.value_from_string)
 544          |> fkt
 545        with
 546        | Ezjsonm.Parse_error (_,msg) ->
 547          err "parsing json: '%s'" msg
 548        | e ->
 549          err "parsing json: '%s'" (e |> Printexc.to_string) )
 550       |> Lwt.return
 551     | sta -> err "Gateway error: %s" (sta |> Cohttp.Code.string_of_status)
 552              |> Lwt.return
 553
 554
 555 let err400 k =
 556   (`Bad_request,  [ H.ct_plain ], ("required input missing: " ^ k) |> R.body)
 557
 558 (** Extract one required parameter from a get query
 559
 560     pq: typically Cgi.Request.path_and_query *)
 561 let par1 ?(err = err400) pq k0 =
 562   let* v0 = k0 |> Uri.get_query_param pq |> Option.to_result ~none:(err k0) in
 563   Ok v0
 564
 565 (** Extract two required parameters from a get query
 566
 567     pq: typically Cgi.Request.path_and_query *)
 568 let par2 ?(err = err400) pq (k0,k1) =
 569   let* v0 = k0 |> Uri.get_query_param pq |> Option.to_result ~none:(err k0) in
 570   let* v1 = k1 |> Uri.get_query_param pq |> Option.to_result ~none:(err k1) in
 571   Ok (v0,v1)
 572
 573 (** run a value through a function *)
 574 let f1 ?(f = Uri.of_string) v0 =
 575   Ok (v0 |> f)
 576
 577 (** run a tuple's values through a function *)
 578 let f2 ?(f = Uri.of_string) (v0,v1) =
 579   Ok (v0 |> f,v1 |> f)
 580