test/t_html.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 open Seppo_lib
  27
  28 module Form = struct
  29   let test_of_channel () =
  30     let ic = "data/cgi_" ^ "2022-04-05T125146.post" |> open_in in
  31     let fv = ic |> Html.Form.of_channel 141 in
  32     ic |> close_in;
  33     (match fv with
  34      | [ (k0, [ v0 ]); (k1, [ v1 ]); (k2, [ v2 ]); (k3, [ v3 ]) ] ->
  35        k0 |> Assrt.equals_string __LOC__ "login";
  36        v0 |> Assrt.equals_string __LOC__ "demo";
  37        k1 |> Assrt.equals_string __LOC__ "password";
  38        v1 |> Assrt.equals_string __LOC__ "demodemodemo";
  39        k2 |> Assrt.equals_string __LOC__ "token";
  40        v2
  41        |> Assrt.equals_string __LOC__
  42          "ff13e7eaf9541ca2ba30fd44e864c3ff014d2bc9";
  43        k3 |> Assrt.equals_string __LOC__ "returnurl";
  44        v3
  45        |> Assrt.equals_string __LOC__ "https://demo.mro.name/shaarligo/o/p/";
  46        assert true
  47      | _ -> failwith __LOC__);
  48     (* match
  49        fv
  50        |> Http.Form.filter_sort_keys
  51          [ "login"; "password"; "token"; "returnurl" ]
  52        with
  53        | [ (k0, [ v0 ]); (k1, [ v1 ]); (k2, [ v2 ]); (k3, [ v3 ]) ] ->
  54        k0 |> Assrt.equals_string __LOC__ "login";
  55        v0 |> Assrt.equals_string __LOC__ "demo";
  56        k1 |> Assrt.equals_string __LOC__ "password";
  57        v1 |> Assrt.equals_string __LOC__ "demodemodemo";
  58        k2 |> Assrt.equals_string __LOC__ "returnurl";
  59        v2
  60        |> Assrt.equals_string __LOC__ "https://demo.mro.name/shaarligo/o/p/";
  61        k3 |> Assrt.equals_string __LOC__ "token";
  62        v3
  63        |> Assrt.equals_string __LOC__
  64          "ff13e7eaf9541ca2ba30fd44e864c3ff014d2bc9";
  65        assert true
  66        | _ -> failwith __LOC__ *);
  67     assert true
  68
  69   let test_to_html () =
  70     let defs = [
  71       ("ka", (Ok "va", "text", [("autofocus",""); ("pattern", {|^\S+$|})]));
  72     ] in
  73     (match List.assoc_opt "ka" defs with
  74      | Some (Ok v,_,_) -> v
  75      | _ -> "foo")
  76     |> Assrt.equals_string __LOC__ "va";
  77     assert true
  78
  79   let test_validate () =
  80     Logr.info (fun m -> m "%s.%s" "http" "test_validate");
  81     (match Html.Form.string
  82              ("uid","text",["required","required"; "pattern","^[a-z]+$"])
  83              ["uid",["hu1"]] with
  84     | Error ("uid", "pattern mismatch") -> ()
  85     | _ -> failwith __LOC__);
  86     (match Html.Form.validate "uid" "text" (Ok "hu1") ("pattern","^[a-z]+$") with
  87      | Error ("uid", "pattern mismatch") -> ()
  88      | _ -> failwith __LOC__);
  89     (match Html.Form.validate "uid" "text" (Ok "abcd") ("minlength","4") with
  90      | Ok "abcd" -> ()
  91      | _ -> failwith __LOC__);
  92     (match Html.Form.validate "uid" "text" (Ok "abcd") ("minlength","5") with
  93      | Error ("uid","shorter than minlength") -> ()
  94      | _ -> failwith __LOC__);
  95     (match Html.Form.validate "uid" "text" (Ok "abcd") ("minlength","_") with
  96      | Error ("uid","invalid minlength") -> ()
  97      | _ -> failwith __LOC__);
  98     ()
  99
 100   let test_from_html () =
 101     let pred ty valu (na,va) =
 102       Result.bind
 103         valu
 104         (fun v ->
 105            match v with
 106            | None -> Ok None
 107            | Some v as vv ->
 108              match ty,na with
 109              | _,"pattern" ->
 110                Logr.debug (fun m -> m "    '%s' ~ /%s/" v va);
 111                Ok vv
 112              | _ ->
 113                Logr.debug (fun m -> m "    ignored %s='%s'" na va);
 114                Ok vv)
 115     in
 116     let string (name,(ty,preds)) vals =
 117       let v = Option.bind
 118           (List.assoc_opt name vals)
 119           (fun v -> Some (v |> String.concat "")) in
 120       List.fold_left (pred ty) (Ok v) preds in
 121     let _validate defs vals =
 122       Logr.debug (fun m -> m "Form.validate");
 123       let field init (name,(ty,preds)) =
 124         match string (name,(ty,preds)) vals with
 125         | Error _ as inp ->
 126           (match init with
 127            | Error a -> Error (inp :: a)
 128            | Ok a    -> Error (inp :: a)
 129           )
 130         | Ok _ as inp ->
 131           (match init with
 132            | Error a -> Error (inp :: a)
 133            | Ok a    -> Ok    (inp :: a)
 134           )
 135       in
 136       List.fold_left field (Ok []) defs
 137     in
 138     let def0 = ("ka", ("text", [("autofocus",""); ("pattern", {|^\S+$|})])) in
 139     let _defs = [ def0; ] in
 140     let vals = [
 141       ("ka", ["vb"]);
 142     ] in
 143     (* match _validate defs vals with
 144        | Ok res -> List.assoc_opt "ka" res
 145                  |> Option.value ~default:(Ok None)
 146                  |> Result.get_ok
 147                  |> Option.get
 148                  |> Assrt.equals_string __LOC__ "vb"
 149        | _ -> failwith __LOC__); *)
 150     let ( let* ) = Result.bind in
 151     let run () =
 152       let* k = string def0 vals in
 153       Ok k in
 154     (match run() with
 155      | Ok (Some v)   -> v |> Assrt.equals_string __LOC__ "vb"
 156      | _ -> assert true);
 157     assert true
 158
 159   let test_from_html1 () =
 160     let i0 : Html.Form.input = ("k0", "text", [
 161         ("autofocus", "autofocus");
 162         ("required",  "required");
 163         ("pattern",   {|^[a-z][0-9]+$|});
 164       ]) in
 165     let i1 = ("k1", "text", [
 166         ("required",  "required");
 167         ("minlength", "1");
 168         ("maxlength", "50");
 169         ("pattern",   {|^v.$|});
 170       ]) in
 171     let vals : Html.Form.t = [
 172       ("k0", ["v0"]);
 173       ("k1", ["v1"]);
 174     ] in
 175     let ( let* ) = Result.bind in
 176     let run () =
 177       let* v0 = vals |> Html.Form.string i0 in
 178       let* v1 = Html.Form.string i1 vals in
 179       v0 |> Assrt.equals_string __LOC__ "v0";
 180       v1 |> Assrt.equals_string __LOC__ "v1";
 181       Ok () in
 182     (match run() with
 183      | Error (_,e) -> e |> Assrt.equals_string __LOC__ ""
 184      | _    -> ())
 185 end
 186
 187 let test_add_class () =
 188   let l = [
 189     (("","name"),"foo");
 190     (("","type"),"text");
 191   ] in
 192   (match "b" |> Html.add_class l with
 193    | [
 194      (("","name"),"foo");
 195      (("","type"),"text");
 196      (("","class"),"b");
 197    ] -> ()
 198    | _ -> failwith __LOC__);
 199   ();
 200   let l = [
 201     (("","name"),"foo");
 202     (("","class"),"clz");
 203     (("","type"),"text");
 204   ] in
 205   (match "b" |> Html.add_class l with
 206    | [
 207      (("","name"),"foo");
 208      (("","class"),"b clz");
 209      (("","type"),"text");
 210    ] -> ()
 211    | _ -> failwith __LOC__);
 212   ();
 213   let l = [
 214     (("","name"),"foo");
 215     (("","class"),"a b clz");
 216     (("","type"),"text");
 217   ] in
 218   (match "b" |> Html.add_class l with
 219    | [
 220      (("","name"),"foo");
 221      (("","class"),"a b clz");
 222      (("","type"),"text");
 223    ] -> ()
 224    | _ -> failwith __LOC__);
 225   ()
 226
 227 let soup_test () =
 228   let open Soup in (* https://aantron.github.io/lambdasoup/ *)
 229   let mention a =
 230     let local = a |> texts |> String.concat "" in
 231     (* check txt starting with @ and not having a host *)
 232     let href = R.attribute "href" a |> Uri.of_string in
 233     let host = href |> Uri.host_with_default ~default:"-" in
 234     let txt = local ^ "@" ^ host in
 235     txt |> create_text
 236   in
 237   let proc n =
 238     let p = "div" |> create_element in
 239     append_child p n;
 240     p
 241     |> select "a[href]"
 242     |> iter (fun a ->
 243         print_endline (R.attribute "href" a);
 244         a |> mention |> replace a
 245       );
 246     p
 247   in
 248   {|Hello, world!|} |> parse |> proc |> to_string |> Assrt.equals_string __LOC__ {|<div>Hello, world!</div>|};
 249   {|Hello, <a href="https://example.com/user/12345">@world</a>!|} |> parse |> proc |> to_string |> Assrt.equals_string __LOC__ {|<div>Hello, @world@example.com!</div>|};
 250   ()
 251
 252 let test_to_plain () =
 253   Logr.info (fun m -> m "%s" "test_to_plain");
 254   let a (x,me,ha) =
 255     let prt l = l |> List.iter (fun (s,href) -> Format.asprintf "%s -> %a" s Uri.pp_hum href |> prerr_endline) in
 256     me |> prt;
 257     ha |> prt;
 258     x in
 259   let load_note_content fn =
 260     let fn = "data/ap/inbox/create/note/" ^ fn in
 261     fn
 262     |> File.in_channel
 263       (fun ic ->
 264          match ic |> Ezjsonm.from_channel |> As2_vocab.Activitypub.Decode.obj with
 265          | Error _ -> failwith "failed to load note"
 266          | Ok o -> match o with
 267            | `Create { obj = `Note obj; _ } ->
 268              let _,co = obj.content_map |> List.hd in
 269              co
 270            | _ -> failwith "strange type")
 271   in
 272   {|Hello, world!|} |> Html.to_plain |> a |> Assrt.equals_string __LOC__ {|Hello, world!|};
 273   {|Hello, <a href="https://example.com">@world</a>!|} |> Html.to_plain |> a |> Assrt.equals_string __LOC__ {|Hello, @world@example.com!|};
 274   {|Hello, <a href="https://example.com">world</a>!|} |> Html.to_plain |> a |> Assrt.equals_string __LOC__ {|Hello, world[1]!
 275
 276 [1]: https://example.com|};
 277   {|Hello, <a href="https://example.com">example.com</a>!|} |> Html.to_plain |> a |> Assrt.equals_string __LOC__ {|Hello, https://example.com!|};
 278   "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>|};
 279   "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.|};
 280   "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>|};
 281   "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.
 282
 283 I'm inferring that this has something to with the Goat, but have no idea.  Guess I'll never know what it was about.
 284
 285 [1]: https://mastodon.social/tags/alaqsaflood|};
 286   (* *)
 287   "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
 288 https://utopia.de/ratgeber/trotz-muecken-abends-draussen-sitzen-6-tipps-gegen-die-mueckenplage_372661/
 289 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.«
 290 #Shaarli[4]💫 📱
 291 https://ripf.de/m/b26xarb
 292
 293 [1]: https://social.wohlfarth.name/tags/M%C3%BCcke
 294 [2]: https://social.wohlfarth.name/tags/M%C3%BCckenspray
 295 [3]: https://social.wohlfarth.name/tags/Ger%C3%BCche
 296 [4]: https://social.wohlfarth.name/tags/Shaarli|};
 297   ();
 298   "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
 299
 300 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.
 301
 302 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|};
 303   ()
 304
 305
 306 let test_to_plain_2 () =
 307   Logr.info (fun m -> m "%s" "test_to_plain_2");
 308   (*
 309 test/data/ap/inbox/create/note/note-OZcAekXDY1A.json
 310   *)
 311   ()
 312
 313 let () =
 314   Logr.info (fun m -> m "html_test");
 315   Unix.chdir "../../../test/";
 316   Form.test_of_channel ();
 317   Form.test_to_html ();
 318   Form.test_validate ();
 319   Form.test_from_html ();
 320   Form.test_from_html1 ();
 321   test_add_class ();
 322   soup_test ();
 323   test_to_plain ();
 324   test_to_plain_2 ();
 325   ()