seppo/test/t_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 Seppo_lib

module Form = struct
  let test_of_channel () =
    let ic = "data/cgi_" ^ "2022-04-05T125146.post" |> open_in in
    let fv = ic |> Html.Form.of_channel 141 in
    ic |> close_in;
    (match fv with
     | [ (k0, [ v0 ]); (k1, [ v1 ]); (k2, [ v2 ]); (k3, [ v3 ]) ] ->
       k0 |> Assrt.equals_string __LOC__ "login";
       v0 |> Assrt.equals_string __LOC__ "demo";
       k1 |> Assrt.equals_string __LOC__ "password";
       v1 |> Assrt.equals_string __LOC__ "demodemodemo";
       k2 |> Assrt.equals_string __LOC__ "token";
       v2
       |> Assrt.equals_string __LOC__
         "ff13e7eaf9541ca2ba30fd44e864c3ff014d2bc9";
       k3 |> Assrt.equals_string __LOC__ "returnurl";
       v3
       |> Assrt.equals_string __LOC__ "https://demo.mro.name/shaarligo/o/p/";
       assert true
     | _ -> failwith __LOC__);
    (* match
       fv
       |> Http.Form.filter_sort_keys
         [ "login"; "password"; "token"; "returnurl" ]
       with
       | [ (k0, [ v0 ]); (k1, [ v1 ]); (k2, [ v2 ]); (k3, [ v3 ]) ] ->
       k0 |> Assrt.equals_string __LOC__ "login";
       v0 |> Assrt.equals_string __LOC__ "demo";
       k1 |> Assrt.equals_string __LOC__ "password";
       v1 |> Assrt.equals_string __LOC__ "demodemodemo";
       k2 |> Assrt.equals_string __LOC__ "returnurl";
       v2
       |> Assrt.equals_string __LOC__ "https://demo.mro.name/shaarligo/o/p/";
       k3 |> Assrt.equals_string __LOC__ "token";
       v3
       |> Assrt.equals_string __LOC__
         "ff13e7eaf9541ca2ba30fd44e864c3ff014d2bc9";
       assert true
       | _ -> failwith __LOC__ *);
    assert true

  let test_to_html () =
    let defs = [
      ("ka", (Ok "va", "text", [("autofocus",""); ("pattern", {|^\S+$|})]));
    ] in
    (match List.assoc_opt "ka" defs with
     | Some (Ok v,_,_) -> v
     | _ -> "foo")
    |> Assrt.equals_string __LOC__ "va";
    assert true

  let test_validate () =
    Logr.info (fun m -> m "%s.%s" "http" "test_validate");
    (match Html.Form.string
             ("uid","text",["required","required"; "pattern","^[a-z]+$"])
             ["uid",["hu1"]] with
    | Error ("uid", "pattern mismatch") -> ()
    | _ -> failwith __LOC__);
    (match Html.Form.validate "uid" "text" (Ok "hu1") ("pattern","^[a-z]+$") with
     | Error ("uid", "pattern mismatch") -> ()
     | _ -> failwith __LOC__);
    (match Html.Form.validate "uid" "text" (Ok "abcd") ("minlength","4") with
     | Ok "abcd" -> ()
     | _ -> failwith __LOC__);
    (match Html.Form.validate "uid" "text" (Ok "abcd") ("minlength","5") with
     | Error ("uid","shorter than minlength") -> ()
     | _ -> failwith __LOC__);
    (match Html.Form.validate "uid" "text" (Ok "abcd") ("minlength","_") with
     | Error ("uid","invalid minlength") -> ()
     | _ -> failwith __LOC__);
    ()

  let test_from_html () =
    let pred ty valu (na,va) =
      Result.bind
        valu
        (fun v ->
           match v with
           | None -> Ok None
           | Some v as vv ->
             match ty,na with
             | _,"pattern" ->
               Logr.debug (fun m -> m "    '%s' ~ /%s/" v va);
               Ok vv
             | _ ->
               Logr.debug (fun m -> m "    ignored %s='%s'" na va);
               Ok vv)
    in
    let string (name,(ty,preds)) vals =
      let v = Option.bind
          (List.assoc_opt name vals)
          (fun v -> Some (v |> String.concat "")) in
      List.fold_left (pred ty) (Ok v) preds in
    let _validate defs vals =
      Logr.debug (fun m -> m "Form.validate");
      let field init (name,(ty,preds)) =
        match string (name,(ty,preds)) vals with
        | Error _ as inp ->
          (match init with
           | Error a -> Error (inp :: a)
           | Ok a    -> Error (inp :: a)
          )
        | Ok _ as inp ->
          (match init with
           | Error a -> Error (inp :: a)
           | Ok a    -> Ok    (inp :: a)
          )
      in
      List.fold_left field (Ok []) defs
    in
    let def0 = ("ka", ("text", [("autofocus",""); ("pattern", {|^\S+$|})])) in
    let _defs = [ def0; ] in
    let vals = [
      ("ka", ["vb"]);
    ] in
    (* match _validate defs vals with
       | Ok res -> List.assoc_opt "ka" res
                 |> Option.value ~default:(Ok None)
                 |> Result.get_ok
                 |> Option.get
                 |> Assrt.equals_string __LOC__ "vb"
       | _ -> failwith __LOC__); *)
    let ( let* ) = Result.bind in
    let run () =
      let* k = string def0 vals in
      Ok k in
    (match run() with
     | Ok (Some v)   -> v |> Assrt.equals_string __LOC__ "vb"
     | _ -> assert true);
    assert true

  let test_from_html1 () =
    let i0 : Html.Form.input = ("k0", "text", [
        ("autofocus", "autofocus");
        ("required",  "required");
        ("pattern",   {|^[a-z][0-9]+$|});
      ]) in
    let i1 = ("k1", "text", [
        ("required",  "required");
        ("minlength", "1");
        ("maxlength", "50");
        ("pattern",   {|^v.$|});
      ]) in
    let vals : Html.Form.t = [
      ("k0", ["v0"]);
      ("k1", ["v1"]);
    ] in
    let ( let* ) = Result.bind in
    let run () =
      let* v0 = vals |> Html.Form.string i0 in
      let* v1 = Html.Form.string i1 vals in
      v0 |> Assrt.equals_string __LOC__ "v0";
      v1 |> Assrt.equals_string __LOC__ "v1";
      Ok () in
    (match run() with
     | Error (_,e) -> e |> Assrt.equals_string __LOC__ ""
     | _    -> ())
end

let test_add_class () =
  let l = [
    (("","name"),"foo");
    (("","type"),"text");
  ] in
  (match "b" |> Html.add_class l with
   | [
     (("","name"),"foo");
     (("","type"),"text");
     (("","class"),"b");
   ] -> ()
   | _ -> failwith __LOC__);
  ();
  let l = [
    (("","name"),"foo");
    (("","class"),"clz");
    (("","type"),"text");
  ] in
  (match "b" |> Html.add_class l with
   | [
     (("","name"),"foo");
     (("","class"),"b clz");
     (("","type"),"text");
   ] -> ()
   | _ -> failwith __LOC__);
  ();
  let l = [
    (("","name"),"foo");
    (("","class"),"a b clz");
    (("","type"),"text");
  ] in
  (match "b" |> Html.add_class l with
   | [
     (("","name"),"foo");
     (("","class"),"a b clz");
     (("","type"),"text");
   ] -> ()
   | _ -> failwith __LOC__);
  ()

let soup_test () =
  let open Soup in (* https://aantron.github.io/lambdasoup/ *)
  let mention a =
    let local = a |> texts |> String.concat "" in
    (* check txt starting with @ and not having a host *)
    let href = R.attribute "href" a |> Uri.of_string in
    let host = href |> Uri.host_with_default ~default:"-" in
    let txt = local ^ "@" ^ host in
    txt |> create_text
  in
  let proc n =
    let p = "div" |> create_element in
    append_child p n;
    p
    |> select "a[href]"
    |> iter (fun a ->
        print_endline (R.attribute "href" a);
        a |> mention |> replace a
      );
    p
  in
  {|Hello, world!|} |> parse |> proc |> to_string |> Assrt.equals_string __LOC__ {|<div>Hello, world!</div>|};
  {|Hello, <a href="https://example.com/user/12345">@world</a>!|} |> parse |> proc |> to_string |> Assrt.equals_string __LOC__ {|<div>Hello, @world@example.com!</div>|};
  ()

let test_to_plain () =
  Logr.info (fun m -> m "%s" "test_to_plain");
  let a (x,me,ha) =
    let prt l = l |> List.iter (fun (s,href) -> Format.asprintf "%s -> %a" s Uri.pp_hum href |> prerr_endline) in
    me |> prt;
    ha |> prt;
    x in
  let load_note_content fn =
    let fn = "data/ap/inbox/create/note/" ^ fn in
    fn
    |> File.in_channel
      (fun ic ->
         match ic |> Ezjsonm.from_channel |> As2_vocab.Activitypub.Decode.obj with
         | Error _ -> failwith "failed to load note"
         | Ok o -> match o with
           | `Create { obj = `Note obj; _ } ->
             let _,co = obj.content_map |> List.hd in
             co
           | _ -> failwith "strange type")
  in
  {|Hello, world!|} |> Html.to_plain |> a |> Assrt.equals_string __LOC__ {|Hello, world!|};
  {|Hello, <a href="https://example.com">@world</a>!|} |> Html.to_plain |> a |> Assrt.equals_string __LOC__ {|Hello, @world@example.com!|};
  {|Hello, <a href="https://example.com">world</a>!|} |> Html.to_plain |> a |> Assrt.equals_string __LOC__ {|Hello, world[1]!

[1]: https://example.com|};
  {|Hello, <a href="https://example.com">example.com</a>!|} |> Html.to_plain |> a |> Assrt.equals_string __LOC__ {|Hello, https://example.com!|};
  "note-PZkn02gIUSk.json" |> load_note_content |> Assrt.equals_string __LOC__ {|<p><span class="h-card" translate="no"><a href="https://mastodon.social/@johnleonard" class="u-url mention">@<span>johnleonard</span></a></span> cat&#39;s out of the bag.  Stop wasting effort.</p>|};
  "note-PZkn02gIUSk.json" |> load_note_content |> Html.to_plain |> a |> Assrt.equals_string __LOC__ {|@johnleonard@mastodon.social cat's out of the bag.  Stop wasting effort.|};
  "note-Hjcb9bqwCgk.json" |> load_note_content |> Assrt.equals_string __LOC__ {|<p><span class="h-card" translate="no"><a href="https://floss.social/@wschenk" class="u-url mention">@<span>wschenk</span></a></span> <span class="h-card" translate="no"><a href="https://mstdn.social/@geoglyphentropy" class="u-url mention">@<span>geoglyphentropy</span></a></span> <span class="h-card" translate="no"><a href="https://mstdn.social/@nus" class="u-url mention">@<span>nus</span></a></span> <span class="h-card" translate="no"><a href="https://tooot.im/@DavidKafri" class="u-url mention">@<span>DavidKafri</span></a></span> <span class="h-card" translate="no"><a href="https://me.dm/@thetechtutor" class="u-url mention">@<span>thetechtutor</span></a></span> After the Goat refused to explain what military action in response to the <a href="https://mastodon.social/tags/alaqsaflood" class="mention hashtag" rel="tag">#<span>alaqsaflood</span></a> would&#39;ve been moral he lost all priveleges with me, although he eventually admitted that nothing would meet his standards.  Eventually he blocked me, although he seems to have somehow replied to me.</p><p>I&#39;m inferring that this has something to with the Goat, but have no idea.  Guess I&#39;ll never know what it was about.</p>|};
  "note-Hjcb9bqwCgk.json" |> load_note_content |> Html.to_plain |> a |> Assrt.equals_string __LOC__ {|@wschenk@floss.social @geoglyphentropy@mstdn.social @nus@mstdn.social @DavidKafri@tooot.im @thetechtutor@me.dm After the Goat refused to explain what military action in response to the #alaqsaflood[1] would've been moral he lost all priveleges with me, although he eventually admitted that nothing would meet his standards.  Eventually he blocked me, although he seems to have somehow replied to me.

I'm inferring that this has something to with the Goat, but have no idea.  Guess I'll never know what it was about.

[1]: https://mastodon.social/tags/alaqsaflood|};
  (* *)
  "note-OZcAekXDY1A.json" |> load_note_content |> Html.to_plain |> a |> Assrt.equals_string __LOC__ {|Trotz Mücken abends draußen sitzen: 6 Tipps gegen die Mückenplage - Utopia.de
https://utopia.de/ratgeber/trotz-muecken-abends-draussen-sitzen-6-tipps-gegen-die-mueckenplage_372661/
Ich weis ja nicht warum man mich mit Teebaum-Öl gequält hat. »Um #Mücke[1] n zu vertreiben, muss der erste Griff nicht zum #Mückenspray[2] gehen. Mücken sind sehr geruchsempfindlich, weshalb du viele natürliche #Gerüche[3] gegen sie einsetzen kannst.«
#Shaarli[4]💫 📱
https://ripf.de/m/b26xarb

[1]: https://social.wohlfarth.name/tags/M%C3%BCcke
[2]: https://social.wohlfarth.name/tags/M%C3%BCckenspray
[3]: https://social.wohlfarth.name/tags/Ger%C3%BCche
[4]: https://social.wohlfarth.name/tags/Shaarli|};
  ();
  "note-Gyuo6v3wVRY.json" |> load_note_content |> Html.to_plain |> a |> Assrt.equals_string __LOC__ {|@kura@noc.social Yeah it's fustrating, but I also just don't care enough to go to iPlayer/Pay for something to watch the olympics

Like they are cool events, but they are just so hostile to watch (I assume football is like this as well) that it does not cross over the effort/reward.

I dunno how this is not considered a larger existential problem for them. Then again, if the overall press vibe is right they have bigger existential crisis-es ongoing|};
  ()


let test_to_plain_2 () =
  Logr.info (fun m -> m "%s" "test_to_plain_2");
  (*
test/data/ap/inbox/create/note/note-OZcAekXDY1A.json
  *)
  ()

let () =
  Logr.info (fun m -> m "html_test");
  Unix.chdir "../../../test/";
  Form.test_of_channel ();
  Form.test_to_html ();
  Form.test_validate ();
  Form.test_from_html ();
  Form.test_from_html1 ();
  test_add_class ();
  soup_test ();
  test_to_plain ();
  test_to_plain_2 ();
  ()