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