ahrefs · c-cube · Aug 22, 2024 · Aug 29, 2024 · Aug 25, 2026 · Aug 25, 2026
diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml
@@ -8,24 +8,15 @@ jobs:
       fail-fast: false
       matrix:
         ocaml:
-        - 4.13.1
-        - 4.12.1
-        - 4.11.2
-        - 4.10.2
-        - 4.09.1
-        - 4.08.1
-        - 4.07.1
-        - 4.06.1
-        - 4.05.0
-        - 4.04.2
-        - 4.03.0
+        - 5.4.1
+        - 4.14.2
 
     steps:
-    - uses: actions/checkout@v2
-    - uses: ocaml/setup-ocaml@v2
+    - uses: actions/checkout@v4
+    - uses: ocaml/setup-ocaml@v3
       with:
         ocaml-compiler: ${{matrix.ocaml}}
-    - run: sudo apt-get install python-bs4
+    - run: sudo apt-get install python3-bs4
     - run: opam install --deps-only --with-test . --yes
     - run: opam install js_of_ocaml --yes
 
@@ -34,7 +25,7 @@ jobs:
     - run: opam exec -- make dependency-test
     - run: opam lint
 
-    - if: ${{matrix.ocaml == '4.13.1'}}
+    - if: ${{matrix.ocaml == '5.4.1'}}
       env:
         COVERALLS_REPO_TOKEN: ${{secrets.GITHUB_TOKEN}}
         PULL_REQUEST_NUMBER: ${{github.event.number}}

diff --git a/.gitignore b/.gitignore
@@ -1,6 +1,9 @@
 scratch/
 _opam/
 _build/
+_build-*/
+_fuzz/
+_tools/
 bisect*.out
 _coverage
 *.install

diff --git a/Makefile b/Makefile
@@ -2,22 +2,108 @@
 build :
 	dune build -p markup,markup-lwt
 
+.PHONY : format
+format :
+	dune build @src/lite/fmt @test/lite/fmt --auto-promote || dune build @src/lite/fmt
+
 # This is not part of the ordinary build process. The output file, entities.ml,
 # is checked into git.
 .PHONY : entities
 entities :
-	dune exec src/translate_entities/translate_entities.exe \
-	  > src/entities.ml
+	dune exec src/entities/translate_entities/translate_entities.exe \
+	  > src/entities/entities.ml
+
+.PHONY : lite-ragel
+lite-ragel :
+	cd src/lite && ragel-ocaml -L -F1 \
+	  -o ragel_html_tokenizer.ml ragel_html_tokenizer.ml.rl
+	python3 -c 'from pathlib import Path; p = Path("src/lite/ragel_html_tokenizer.ml"); p.write_text("\n".join(line.rstrip() for line in p.read_text().splitlines()) + "\n")'
+	rm -f src/lite/ragel_html_tokenizer.ri
 
 .PHONY : test
 test :
 	dune runtest
 
+LITE_TEST_EXE := _build/default/test/lite/lite_diff_corpus.exe
+LITE_COUNT_TEST_EXE := _build/default/test/lite/lite_count_corpus.exe
+LITE_PARSER_TEST_EXE := _build/default/test/lite/lite_parser_diff_corpus.exe
+LITE_WRITER_TEST_EXE := _build/default/test/lite/lite_writer_diff_corpus.exe
+LITE_TEST_CORPUS ?= big_tests
+
+.PHONY : test-lite
+test-lite :
+	dune build --profile release test/lite/lite_diff_corpus.exe \
+	  test/lite/lite_count_corpus.exe \
+	  test/lite/lite_parser_diff_corpus.exe \
+	  test/lite/lite_writer_diff_corpus.exe
+	$(LITE_TEST_EXE) $(LITE_TEST_CORPUS)
+	$(LITE_COUNT_TEST_EXE) $(LITE_TEST_CORPUS)
+	$(LITE_PARSER_TEST_EXE) $(LITE_TEST_CORPUS)
+	$(LITE_WRITER_TEST_EXE) $(LITE_TEST_CORPUS)
+
+LITE_AFL_MODE ?= diff
+ifeq ($(LITE_AFL_MODE),diff)
+LITE_AFL_TARGET := test/fuzz/lite_diff_fuzz.exe
+LITE_AFL_EXE := _build-afl/default/test/fuzz/lite_diff_fuzz.exe
+LITE_AFL_DEFAULT_OUTPUT := _fuzz/lite
+else ifeq ($(LITE_AFL_MODE),native)
+LITE_AFL_TARGET := test/fuzz/lite_native_fuzz.exe
+LITE_AFL_EXE := _build-afl/default/test/fuzz/lite_native_fuzz.exe
+LITE_AFL_DEFAULT_OUTPUT := _fuzz/lite-native
+else
+$(error LITE_AFL_MODE must be diff or native)
+endif
+LITE_AFL_OUTPUT ?= $(LITE_AFL_DEFAULT_OUTPUT)
+AFL_FUZZ ?= $(if $(wildcard _tools/AFLplusplus/afl-fuzz),_tools/AFLplusplus/afl-fuzz,afl-fuzz)
+AFL_WHATSUP ?= $(if $(wildcard _tools/AFLplusplus/afl-whatsup),_tools/AFLplusplus/afl-whatsup,afl-whatsup)
+J ?= 4
+
+.PHONY : test-lite-afl
+test-lite-afl :
+	@command -v $(AFL_FUZZ) >/dev/null || { \
+	  echo "$(AFL_FUZZ) not found; install AFL or set AFL_FUZZ" >&2; exit 1; }
+	dune build --build-dir _build-afl --profile afl $(LITE_AFL_TARGET)
+	@set -eu; \
+	echo "fuzzing mode: $(LITE_AFL_MODE)"; \
+	case "$(J)" in ''|*[!0-9]*|0) echo "J must be a positive integer" >&2; exit 2;; esac; \
+	mkdir -p $(LITE_AFL_OUTPUT); \
+	pids=''; \
+	cleanup () { \
+	  trap - EXIT INT TERM; \
+	  if test -n "$$pids"; then kill $$pids 2>/dev/null || true; fi; \
+	  wait 2>/dev/null || true; \
+	}; \
+	trap cleanup EXIT INT TERM; \
+	i=0; \
+	while test $$i -lt $(J); do \
+	  id=$$(printf 'fuzzer%02d' $$i); \
+	  if test $$i -eq 0; then role=-M; else role=-S; fi; \
+	  input=test/fuzz/seeds; \
+	  if test -d $(LITE_AFL_OUTPUT)/$$id/queue; then input=-; fi; \
+	  echo "starting AFL worker $$id"; \
+	  AFL_NO_UI=1 AFL_NO_AFFINITY=1 AFL_SKIP_CPUFREQ=1 \
+	    AFL_I_DONT_CARE_ABOUT_MISSING_CRASHES=1 \
+	    $(AFL_FUZZ) -i $$input -o $(LITE_AFL_OUTPUT) \
+	      -x test/fuzz/html.dict $$role $$id -- $(LITE_AFL_EXE) \
+	      >$(LITE_AFL_OUTPUT)/$$id.log 2>&1 & \
+	  pids="$$pids $$!"; \
+	  i=$$((i + 1)); \
+	done; \
+	wait
+
+.PHONY : test-lite-afl-native
+test-lite-afl-native :
+	$(MAKE) test-lite-afl LITE_AFL_MODE=native
+
+.PHONY : test-lite-afl-report
+test-lite-afl-report :
+	$(AFL_WHATSUP) -d $(LITE_AFL_OUTPUT)
+
 .PHONY : coverage
 coverage :
 	find . -name '*.coverage' | xargs rm -f
 	dune runtest --instrument-with bisect_ppx --force
-	bisect-ppx-report html --expect src/ --do-not-expect src/translate_entities/
+	bisect-ppx-report html --expect src/ --do-not-expect src/entities/translate_entities/
 	bisect-ppx-report summary
 	@echo See _coverage/index.html
 

diff --git a/dune b/dune
@@ -0,0 +1,4 @@
+(env
+ (afl
+  (flags
+   (:standard -warn-error -A))))
diff --git a/markup-lwt.opam b/markup-lwt.opam
@@ -16,7 +16,7 @@ depends: [
   "dune" {>= "2.7.0"}
   "lwt"
   "markup"
-  "ocaml" {>= "4.03.0"}
+  "ocaml" {>= "4.14.0"}
 ]
 
 build: [

diff --git a/markup.opam b/markup.opam
@@ -13,11 +13,13 @@ dev-repo: "git+https://github.com/aantron/markup.ml.git"
 
 depends: [
   "dune" {>= "2.7.0"}
-  "ocaml" {>= "4.03.0"}
+  "ocaml" {>= "4.14.0"}
   "uchar"
   "uutf" {>= "1.0.0"}
 
   "bisect_ppx" {dev & >= "2.5.0"}
+  "containers" {with-test}
+  "devkit" {with-test}
   "ounit2" {dev}
 ]
 # Markup.ml implicitly requires OCaml 4.02.3, as this is a contraint of Dune.

diff --git a/src/.ocamlformat-ignore b/src/.ocamlformat-ignore
@@ -0,0 +1,6 @@
+*.ml
+*.mli
+common/**
+entities/**
+lwt/**
+lwt_unix/**
diff --git a/src/common.ml → src/baseline/common.ml b/src/common.ml → src/baseline/common.ml
@@ -4,21 +4,18 @@
 type 'a cont = 'a -> unit
 type 'a cps = exn cont -> 'a cont -> unit
 
-type location = int * int
+type location = Markup_common.location
 
-let compare_locations (line, column) (line', column') =
-  match line - line' with
-  | 0 -> column - column'
-  | order -> order
+let compare_locations = Markup_common.compare_locations
 
-type name = string * string
+type name = Markup_common.name
 
-let xml_ns = "http://www.w3.org/XML/1998/namespace"
-let xmlns_ns = "http://www.w3.org/2000/xmlns/"
-let xlink_ns = "http://www.w3.org/1999/xlink"
-let html_ns = "http://www.w3.org/1999/xhtml"
-let svg_ns = "http://www.w3.org/2000/svg"
-let mathml_ns = "http://www.w3.org/1998/Math/MathML"
+let xml_ns = Markup_common.Ns.xml
+let xmlns_ns = Markup_common.Ns.xmlns
+let xlink_ns = Markup_common.Ns.xlink
+let html_ns = Markup_common.Ns.html
+let svg_ns = Markup_common.Ns.svg
+let mathml_ns = Markup_common.Ns.mathml
 
 module Token_tag =
 struct
@@ -28,26 +25,21 @@ struct
      self_closing : bool}
 end
 
-type xml_declaration =
-  {version    : string;
-   encoding   : string option;
-   standalone : bool option}
-
-type doctype =
-  {doctype_name      : string option;
-   public_identifier : string option;
-   system_identifier : string option;
-   raw_text          : string option;
-   force_quirks      : bool}
-
-type signal =
-  [ `Start_element of name * (name * string) list
-  | `End_element
-  | `Text of string list
-  | `Xml of xml_declaration
-  | `Doctype of doctype
-  | `PI of string * string
-  | `Comment of string ]
+type xml_declaration = Markup_common.xml_declaration = {
+  version : string;
+  encoding : string option;
+  standalone : bool option;
+}
+
+type doctype = Markup_common.doctype = {
+  doctype_name : string option;
+  public_identifier : string option;
+  system_identifier : string option;
+  raw_text : string option;
+  force_quirks : bool;
+}
+
+type signal = Markup_common.signal
 
 type general_token =
   [ `Xml of xml_declaration
@@ -147,64 +139,7 @@ let is_valid_xml_char c =
   || is_in_range 0xE000 0xFFFD c
   || is_in_range 0x10000 0x10FFFF c
 
-let signal_to_string = function
-  | `Comment s ->
-    Printf.sprintf "<!--%s-->" s
-
-  | `Doctype d ->
-    let text =
-      match d.doctype_name with
-      | None ->
-        begin match d.raw_text with
-        | None -> ""
-        | Some s -> " " ^ s
-        end
-      | Some name ->
-        match d.public_identifier, d.system_identifier with
-        | None, None -> " " ^ name
-        | Some p, None -> Printf.sprintf " %s PUBLIC \"%s\"" name p
-        | None, Some s -> Printf.sprintf " %s SYSTEM \"%s\"" name s
-        | Some p, Some s -> Printf.sprintf " %s PUBLIC \"%s\" \"%s\"" name p s
-    in
-    Printf.sprintf "<!DOCTYPE%s>" text
-
-  | `Start_element (name, attributes) ->
-    let name_to_string = function
-      | "", local_name -> local_name
-      | ns, local_name -> ns ^ ":" ^ local_name
-    in
-    let attributes =
-      attributes
-      |> List.map (fun (name, value) ->
-        Printf.sprintf " %s=\"%s\"" (name_to_string name) value)
-      |> String.concat ""
-    in
-    Printf.sprintf "<%s%s>" (name_to_string name) attributes
-
-  | `End_element ->
-    "</...>"
-
-  | `Text ss ->
-    String.concat "" ss
-
-  | `Xml x ->
-    let s = Printf.sprintf "<?xml version=\"%s\">" x.version in
-    let s =
-      match x.encoding with
-      | None -> s
-      | Some encoding -> Printf.sprintf "%s encoding=\"%s\"" s encoding
-    in
-    let s =
-      match x.standalone with
-      | None -> s
-      | Some standalone ->
-        Printf.sprintf
-          "%s standalone=\"%s\"" s (if standalone then "yes" else "no")
-    in
-    s ^ "?>"
-
-  | `PI (target, s) ->
-    Printf.sprintf "<?%s %s?>" target s
+let signal_to_string = Markup_common.signal_to_string
 
 let token_to_string = function
   | `Xml x ->

diff --git a/src/detect.ml → src/baseline/detect.ml b/src/detect.ml → src/baseline/detect.ml
diff --git a/src/detect.mli → src/baseline/detect.mli b/src/detect.mli → src/baseline/detect.mli
diff --git a/src/dune → src/baseline/dune b/src/dune → src/baseline/dune
@@ -4,7 +4,7 @@
  (synopsis "Error-recovering functional HTML5 and XML parsers")
  (instrumentation
   (backend bisect_ppx))
- (libraries devkit uutf)
+ (libraries uutf markup.common markup.entities)
  (flags
   (:standard -w -9)))
 
diff --git a/src/encoding.ml → src/baseline/encoding.ml b/src/encoding.ml → src/baseline/encoding.ml
diff --git a/src/baseline/entities.ml b/src/baseline/entities.ml
@@ -0,0 +1,6 @@
+(* This file is part of Markup.ml, released under the MIT license. See
+   LICENSE.md for details, or visit https://github.com/aantron/markup.ml. *)
+
+(* The entity table lives in the markup.entities library. *)
+
+include Markup_entities.Entities
diff --git a/src/baseline/error.ml b/src/baseline/error.ml
@@ -0,0 +1,16 @@
+(* This file is part of Markup.ml, released under the MIT license. See
+   LICENSE.md for details, or visit https://github.com/aantron/markup.ml. *)
+
+include Markup_common.Error
+
+open Common
+
+type 'a handler = 'a -> t -> unit cps
+type parse_handler = location handler
+type write_handler = (signal * int) handler
+
+let ignore_errors _ _ _ resume = resume ()
+
+let report_if report condition location detail throw k =
+  if condition then report location (detail ()) throw k
+  else k ()