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

open Astring

let ( let* ) = Result.bind

module Form = struct
  type field = string * string list
  (** A single html form field content. Modeled after Uri.query *)

  type t     = field list
  (** Values of a html form *)

  let of_string s : t = s
                        |> String.trim
                        |> Uri.query_of_encoded
  (** application/x-www-form-urlencoded
   *
   * https://discuss.ocaml.org/t/decoding-x-www-form-urlencoded/4505/3?u=mro *)

  let of_channel n ic =  really_input_string ic n
                         |> of_string
  (** Read a fixed number of bytes and parse *)
(*
  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)
*)

  type constraint_ = string * string
  (** actually an input field attribute like pattern=".+"
   * 
   * https://www.w3.org/TR/xhtml-modularization/abstract_modules.html#s_extformsmodule 
  *)

  type input = string * string * constraint_ list
  (** name * type * constraint list.
   * 
   * https://www.w3.org/TR/xhtml-modularization/abstract_modules.html#s_extformsmodule 
   * and some more, e.g. pattern
  *)

  let validate name ty va (c_nam,c_cri)
  (** Validate one input field against one constraint from a form definition
  *) =
    let vali v =
      Logr.debug (fun m -> m "    validate %s='%s'" c_nam c_cri);
      match ty,c_nam with
      | _,"maxlength" ->
        (* http://www.w3.org/TR/html5/forms.html#the-maxlength-and-minlength-attributes
           https://wiki.selfhtml.org/wiki/HTML/Elemente/input *)
        (match c_cri |> 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" ->
        (* http://www.w3.org/TR/html5/forms.html#the-maxlength-and-minlength-attributes
           https://wiki.selfhtml.org/wiki/HTML/Elemente/input *)
        (match c_cri |> 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" ->
        (* https://html.spec.whatwg.org/multipage/input.html#attr-input-pattern *)
        (try
           let rx = Re.Pcre.regexp c_cri in
           if Re.execp rx v
           then Ok v
           else Error (name,"pattern mismatch")
         with | _ -> Error (name,"invalid pattern"))
      | _ -> Ok v
    in
    Result.bind va vali

  let string_opt (name,ty,constraints : input) (vals : t) : (string option, string * string) result =
    Logr.debug (fun m -> m "  <input name='%s' type='%s' ..." name ty);
    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

let add_class atts c =
  let rec f found (src,dst) =
    match src with
    | []       ->  [], if found
                   then dst
                   else (("","class"),c) :: dst
    | ((_,"class") as n,v) :: tl ->
      let is_sep = Char.equal ' ' in
      let vs = v |> String.fields ~is_sep in
      let vs = match vs |> List.find_opt (String.equal c) with
        | None   -> c :: vs
        | Some _ -> vs in
      f true (tl, (n,vs |> String.concat ~sep:" ") :: dst)
    | hd :: tl ->
      f found (tl, hd :: dst)
  in
  let _,r = f false (atts,[]) in
  r |> List.rev

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

let to_plain s =
  let open Soup in (* https://aantron.github.io/lambdasoup/ *)
  (* TODO care about :
   * - tags
  *)
  let at_mention a =
    let handle = a |> texts |> String.concat in
    if handle |> St.is_prefix ~affix:"@"
    then (
      (* @TODO check txt not having a host *)
      let href = R.attribute "href" a |> Uri.of_string in
      let host = href |> Uri.host_with_default ~default:"-" in
      let handle = handle ^ "@" ^ host in
      a |> delete_attribute "href";
      a |> clear;
      handle |> create_text |> append_child a;
      Some (handle,href)
    ) else
      None
  in
  let at_mention' l a =
    match a |> at_mention with
    | None   -> l
    | Some e -> e :: l
  in
  let p_br soup =
    soup |> select "br" |> iter (fun br -> create_text "\n" |> replace br);
    soup |> select "p"  |> iter (fun p  -> create_text "\n\n" |> append_child p);
    soup
  in
  (* ocaml 5.1+ *)
  let find_index predicate xs =
    let rec fi i = function
      | [] -> None
      | hd :: tl ->
        if hd |> predicate
        then Some i
        else fi (succ i) tl
    in
    fi 0 xs
  in
  let a_href_to_footnotes soup =
    let fns = ref [] in
    soup |> select "a[href]" |> iter (fun a ->
        let href = a |> R.attribute "href" in
        let href' = href |> Uri.of_string in
        let pred x = x |> Uri.of_string |> Uri.equal href' in
        let txt = a |> texts |> String.concat |> String.trim in
        if  txt |> pred
         || "http://" ^ txt |> pred
         || "https://" ^ txt |> pred
        then ( a |> clear;
               href |> create_text |> append_child a
             ) else (
          let no : int = match !fns |> find_index pred with
            | Some l -> succ l
            | None ->
              fns := href :: !fns;
              !fns |> List.length
          in
          let lbl = "[" ^ (no |> string_of_int) ^ "]" in
          lbl |> create_text |> insert_after a;
          Printf.sprintf "\n%s: %s" lbl href
          |> create_text
          |> append_root soup )
      );
    soup
  in
  let proc f css n =
    let m = n |> select css |> fold f [] in
    n,m
  in
  let _de_trunk so =
    let open Soup in
    so |> select ".ellipsis" |> iter ("…" |> create_text |> insert_after);
    so |> select ".invisible" |> iter delete;
    so
  in
  let s = "<div>" ^ s ^ "<br/></div>"
          |> parse
  in
  let s,me = s |> proc at_mention' "a[href]"
  and ha = []
  and rx_one = Str.regexp " +\n"
  and rx_many = Str.regexp "\n\n+"
  in
  s |> a_href_to_footnotes
  |> p_br
  |> texts
  |> String.concat
  (* replace superfluous whitespace? *)
  |> Str.global_replace rx_one "\n"
  |> Str.global_replace rx_many "\n\n"
  |> String.trim , me , ha