ocaml-html5rw / lib / htmlrw_check / specialized / attr_restrictions_checker.ml

(** Attribute restrictions checker - validates that certain attributes
    are not used on elements where they're not allowed. *)

(** List of (element, [disallowed attributes]) pairs for HTML elements. *)
let disallowed_attrs_html = [
  (* Elements that cannot have href attribute (RDFa misuses) *)
  ("img", ["href"]);
  ("p", ["href"]);
  ("div", ["href"]);
  (* a cannot have src or media *)
  ("a", ["src"; "media"]);
  (* area cannot have media *)
  ("area", ["media"]);
  (* Various elements cannot have srcset *)
  ("audio", ["srcset"]);
  ("video", ["srcset"]);
  ("object", ["srcset"]);
  ("link", ["srcset"]);  (* except when rel=preload and as=image *)
  ("track", ["srcset"]);
  ("input", ["srcset"]);  (* except type=image, but we check more strictly *)
  ("image", ["srcset"]);  (* SVG image element *)
]

(** SVG elements that cannot have xml:id attribute. *)
let svg_no_xml_id = [
  "rect"; "circle"; "ellipse"; "line"; "polyline"; "polygon"; "path";
  "text"; "tspan"; "textPath"; "image"; "use"; "symbol"; "defs"; "g";
  "svg"; "marker"; "pattern"; "clipPath"; "mask"; "linearGradient";
  "radialGradient"; "stop"; "filter"; "feBlend"; "feColorMatrix";
  "feComponentTransfer"; "feComposite"; "feConvolveMatrix"; "feDiffuseLighting";
  "feDisplacementMap"; "feDistantLight"; "feDropShadow"; "feFlood";
  "feFuncA"; "feFuncB"; "feFuncG"; "feFuncR"; "feGaussianBlur"; "feImage";
  "feMerge"; "feMergeNode"; "feMorphology"; "feOffset"; "fePointLight";
  "feSpecularLighting"; "feSpotLight"; "feTile"; "feTurbulence";
]

type state = {
  mutable is_xhtml : bool;  (* Track if we're in XHTML mode based on xmlns *)
}

let create () = { is_xhtml = false }
let reset state = state.is_xhtml <- false

(** Input types that allow the list attribute. *)
let input_types_allowing_list = [
  "color"; "date"; "datetime-local"; "email"; "month"; "number";
  "range"; "search"; "tel"; "text"; "time"; "url"; "week"
]

(** Report disallowed attribute error *)
let report_disallowed_attr element attr collector =
  Message_collector.add_typed collector
    (`Attr (`Not_allowed (`Attr attr, `Elem element)))

let start_element state ~element collector =
  match element.Element.tag with
  | Tag.Html _ ->
    let name = Tag.tag_to_string element.tag in
    let name_lower = String.lowercase_ascii name in
    let attrs = element.raw_attrs in

    (* Detect XHTML mode from xmlns attribute on html element *)
    if name_lower = "html" then begin
      match Attr_utils.get_attr "xmlns" attrs with
      | Some "http://www.w3.org/1999/xhtml" -> state.is_xhtml <- true
      | _ -> ()
    end;

    (* Check HTML element attribute restrictions *)
    (match List.assoc_opt name_lower disallowed_attrs_html with
    | Some disallowed ->
      List.iter (fun attr ->
        if Attr_utils.has_attr attr attrs then
          report_disallowed_attr name_lower attr collector
      ) disallowed
    | None -> ());

    (* Check for xml:base attribute - not allowed in HTML *)
    if name_lower = "html" then begin
      if Attr_utils.has_attr "xml:base" attrs then
        report_disallowed_attr name_lower "xml:base" collector
    end;

    (* Check for xmlns:* prefixed attributes - not allowed in HTML *)
    (* Standard xmlns declarations are allowed but custom prefixes are not *)
    List.iter (fun (attr_name, _) ->
      let attr_lower = String.lowercase_ascii attr_name in
      if String.starts_with ~prefix:"xmlns:" attr_lower then begin
        let prefix = String.sub attr_lower 6 (String.length attr_lower - 6) in
        (* Only xmlns:xlink (with correct value) and xmlns:xml are allowed *)
        if prefix <> "xlink" && prefix <> "xml" then
          Message_collector.add_typed collector
            (`Attr (`Not_allowed_here (`Attr attr_name)))
      end
    ) attrs;

    (* Check SVG element restrictions - works in both HTML-embedded and XHTML SVG *)
    (* xml:id is never valid on SVG elements in HTML5 *)
    if List.mem name_lower svg_no_xml_id then begin
      if Attr_utils.has_attr "xml:id" attrs then
        report_disallowed_attr name_lower "xml:id" collector
    end;

    (* SVG feConvolveMatrix requires order attribute *)
    if name_lower = "feconvolvematrix" then begin
      if not (Attr_utils.has_attr "order" attrs) then
        Message_collector.add_typed collector
          (`Svg (`Missing_attr (`Elem "feConvolveMatrix", `Attr "order")))
    end;

    (* Validate style type attribute - must be "text/css" or omitted *)
    if name_lower = "style" then begin
      List.iter (fun (attr_name, attr_value) ->
        let attr_lower = String.lowercase_ascii attr_name in
        if attr_lower = "type" then begin
          let value_lower = String.lowercase_ascii (String.trim attr_value) in
          if value_lower <> "text/css" then
            Message_collector.add_typed collector (`Misc `Style_type_invalid)
        end
      ) attrs
    end;

    (* Validate object element requires data or type attribute *)
    if name_lower = "object" then begin
      let has_data = Attr_utils.has_attr "data" attrs in
      let has_type = Attr_utils.has_attr "type" attrs in
      if not has_data && not has_type then
        Message_collector.add_typed collector
          (`Attr (`Missing (`Elem "object", `Attr "data")))
    end;

    (* Validate link imagesizes/imagesrcset attributes *)
    if name_lower = "link" then begin
      let has_imagesizes = Attr_utils.has_attr "imagesizes" attrs in
      let has_imagesrcset = Attr_utils.has_attr "imagesrcset" attrs in
      let rel_value = Attr_utils.get_attr "rel" attrs in
      let as_value = Attr_utils.get_attr "as" attrs in

      (* imagesizes requires imagesrcset *)
      if has_imagesizes && not has_imagesrcset then
        Message_collector.add_typed collector (`Srcset `Imagesizes_without_imagesrcset);

      (* imagesrcset requires as="image" *)
      if has_imagesrcset then begin
        let as_is_image = match as_value with
          | Some v -> String.lowercase_ascii (String.trim v) = "image"
          | None -> false
        in
        if not as_is_image then
          Message_collector.add_typed collector (`Link `Imagesrcset_requires_as_image)
      end;

      (* as attribute requires rel="preload" or rel="modulepreload" *)
      (match as_value with
      | Some _ ->
        let rel_is_preload = match rel_value with
          | Some v ->
            let rel_lower = String.lowercase_ascii (String.trim v) in
            String.length rel_lower > 0 &&
            (List.mem "preload" (String.split_on_char ' ' rel_lower) ||
             List.mem "modulepreload" (String.split_on_char ' ' rel_lower))
          | None -> false
        in
        if not rel_is_preload then
          Message_collector.add_typed collector (`Link `As_requires_preload)
      | None -> ())
    end;

    (* Validate img usemap attribute - must be hash-name reference with content *)
    if name_lower = "img" then begin
      List.iter (fun (attr_name, attr_value) ->
        let attr_lower = String.lowercase_ascii attr_name in
        if attr_lower = "usemap" then begin
          if attr_value = "#" then
            Message_collector.add_typed collector
              (`Attr (`Bad_value_generic (`Message (Printf.sprintf
                "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9c%s\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad hash-name reference: A hash-name reference must have at least one character after \xe2\x80\x9c#\xe2\x80\x9d."
                attr_value attr_name name))))
        end
      ) attrs
    end;

    (* Validate embed type attribute - must be valid MIME type *)
    if name_lower = "embed" then begin
      List.iter (fun (attr_name, attr_value) ->
        let attr_lower = String.lowercase_ascii attr_name in
        if attr_lower = "type" then begin
          match Dt_mime.validate_mime_type attr_value with
          | Ok () -> ()
          | Error msg ->
            Message_collector.add_typed collector
              (`Attr (`Bad_value_generic (`Message (Printf.sprintf
                "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9c%s\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad MIME type: %s"
                attr_value attr_name name msg))))
        end
      ) attrs
    end;

    (* Validate width/height on embed and img - must be non-negative integers *)
    let is_dimension_element = name_lower = "embed" || name_lower = "img" ||
                               name_lower = "video" || name_lower = "canvas" ||
                               name_lower = "iframe" || name_lower = "source" in
    if is_dimension_element then begin
      List.iter (fun (attr_name, attr_value) ->
        let attr_lower = String.lowercase_ascii attr_name in
        if attr_lower = "width" || attr_lower = "height" then begin
          (* Check for non-negative integer only *)
          let is_valid =
            String.length attr_value > 0 &&
            String.for_all (fun c -> c >= '0' && c <= '9') attr_value
          in
          if not is_valid then begin
            (* Determine specific error message *)
            let error_msg =
              if String.length attr_value = 0 then
                Printf.sprintf "Bad value \xe2\x80\x9c\xe2\x80\x9d for attribute \xe2\x80\x9c%s\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: The empty string is not a valid non-negative integer."
                  attr_name name
              else if String.contains attr_value '%' then
                Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9c%s\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad non-negative integer: Expected a digit but saw \xe2\x80\x9c%%\xe2\x80\x9d instead."
                  attr_value attr_name name
              else if String.length attr_value > 0 && attr_value.[0] = '-' then
                Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9c%s\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad non-negative integer: Expected a digit but saw \xe2\x80\x9c-\xe2\x80\x9d instead."
                  attr_value attr_name name
              else
                (* Find first non-digit character *)
                let bad_char =
                  try
                    let i = ref 0 in
                    while !i < String.length attr_value && attr_value.[!i] >= '0' && attr_value.[!i] <= '9' do
                      incr i
                    done;
                    if !i < String.length attr_value then Some attr_value.[!i] else None
                  with _ -> None
                in
                match bad_char with
                | Some c ->
                  Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9c%s\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad non-negative integer: Expected a digit but saw \xe2\x80\x9c%c\xe2\x80\x9d instead."
                    attr_value attr_name name c
                | None ->
                  Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9c%s\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad non-negative integer: Expected a digit."
                    attr_value attr_name name
            in
            Message_collector.add_typed collector
              (`Attr (`Bad_value_generic (`Message error_msg)))
          end
        end
      ) attrs
    end;

    (* Validate area[shape=default] cannot have coords *)
    if name_lower = "area" then begin
      match Attr_utils.get_attr "shape" attrs with
      | Some s when String.lowercase_ascii (String.trim s) = "default" ->
        if Attr_utils.has_attr "coords" attrs then
          Message_collector.add_typed collector
            (`Attr (`Not_allowed (`Attr "coords", `Elem "area")))
      | _ -> ()
    end;

    (* Validate bdo element requires dir attribute, and dir cannot be "auto" *)
    if name_lower = "bdo" then begin
      match Attr_utils.get_attr "dir" attrs with
      | None ->
        Message_collector.add_typed collector (`Misc `Bdo_missing_dir)
      | Some v when String.lowercase_ascii (String.trim v) = "auto" ->
        Message_collector.add_typed collector (`Misc `Bdo_dir_auto)
      | _ -> ()
    end;

    (* Validate input list attribute - only allowed for certain types *)
    if name_lower = "input" then begin
      if Attr_utils.has_attr "list" attrs then begin
        let input_type = Attr_utils.get_attr_or "type" ~default:"text" attrs
                         |> String.trim |> String.lowercase_ascii in
        if not (List.mem input_type input_types_allowing_list) then
          Message_collector.add_typed collector (`Input `List_not_allowed)
      end
    end;

    (* Validate data-* attributes *)
    List.iter (fun (attr_name, _) ->
      let attr_lower = String.lowercase_ascii attr_name in
      (* Check if it starts with "data-" *)
      if String.starts_with ~prefix:"data-" attr_lower then begin
        let after_prefix = String.sub attr_lower 5 (String.length attr_lower - 5) in
        (* Check if it's exactly "data-" with nothing after *)
        if after_prefix = "" then
          report_disallowed_attr name_lower attr_name collector
        (* Check if the name contains colon - not XML serializable *)
        else if String.contains after_prefix ':' then
          Message_collector.add_typed collector
            (`Attr (`Data_invalid_name (`Reason "must be XML 1.0 4th ed. plus Namespaces NCNames")))
      end
    ) attrs;

    (* Validate xml:lang must have matching lang attribute - only in HTML mode, not XHTML *)
    if not state.is_xhtml then begin
      let xmllang_value = Attr_utils.get_attr "xml:lang" attrs in
      let lang_value = Attr_utils.get_attr "lang" attrs in
      match xmllang_value with
      | Some xmllang ->
        (match lang_value with
         | None ->
           Message_collector.add_typed collector (`I18n `Xml_lang_without_lang)
         | Some lang when String.lowercase_ascii lang <> String.lowercase_ascii xmllang ->
           Message_collector.add_typed collector (`I18n `Xml_lang_without_lang)
         | _ -> ())
      | None -> ()
    end;

    (* Validate spellcheck attribute - must be "true" or "false" or empty *)
    List.iter (fun (attr_name, attr_value) ->
      let attr_lower = String.lowercase_ascii attr_name in
      if attr_lower = "spellcheck" then begin
        let value_lower = String.lowercase_ascii (String.trim attr_value) in
        if value_lower <> "" && value_lower <> "true" && value_lower <> "false" then
          Message_collector.add_typed collector
            (`Attr (`Bad_value (`Elem name, `Attr attr_name, `Value attr_value, `Reason "")))
      end
    ) attrs;

    (* Validate enterkeyhint attribute - must be one of specific values *)
    let valid_enterkeyhint = ["enter"; "done"; "go"; "next"; "previous"; "search"; "send"] in
    List.iter (fun (attr_name, attr_value) ->
      let attr_lower = String.lowercase_ascii attr_name in
      if attr_lower = "enterkeyhint" then begin
        let value_lower = String.lowercase_ascii (String.trim attr_value) in
        if not (List.mem value_lower valid_enterkeyhint) then
          Message_collector.add_typed collector
            (`Attr (`Bad_value (`Elem name, `Attr attr_name, `Value attr_value, `Reason "")))
      end
    ) attrs;

    (* Validate headingoffset attribute - must be a number between 0 and 8 *)
    List.iter (fun (attr_name, attr_value) ->
      let attr_lower = String.lowercase_ascii attr_name in
      if attr_lower = "headingoffset" then begin
        let trimmed = String.trim attr_value in
        let is_valid =
          String.length trimmed > 0 &&
          String.for_all (fun c -> c >= '0' && c <= '9') trimmed &&
          (try
            let n = int_of_string trimmed in
            n >= 0 && n <= 8
          with _ -> false)
        in
        if not is_valid then
          Message_collector.add_typed collector (`Misc `Headingoffset_invalid)
      end
    ) attrs;

    (* Validate accesskey attribute - each key label must be a single code point *)
    List.iter (fun (attr_name, attr_value) ->
      let attr_lower = String.lowercase_ascii attr_name in
      if attr_lower = "accesskey" then begin
        (* Split by whitespace to get key labels *)
        let keys = String.split_on_char ' ' attr_value |>
                   List.filter (fun s -> String.length (String.trim s) > 0) |>
                   List.map String.trim in
        (* Count Unicode code points in each key *)
        let count_codepoints s =
          let len = String.length s in
          let count = ref 0 in
          let i = ref 0 in
          while !i < len do
            let c = Char.code s.[!i] in
            if c < 0x80 then incr i
            else if c < 0xE0 then i := !i + 2
            else if c < 0xF0 then i := !i + 3
            else i := !i + 4;
            incr count
          done;
          !count
        in
        (* Check for multi-character keys *)
        List.iter (fun key ->
          if count_codepoints key > 1 then
            Message_collector.add_typed collector
              (`Attr (`Bad_value_generic (`Message (Printf.sprintf
                "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9c%s\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad key label list: Key label has multiple characters. Each key label must be a single character."
                attr_value attr_name name))))
        ) keys;
        (* Check for duplicate keys *)
        let rec find_duplicates seen = function
          | [] -> ()
          | k :: rest ->
            if List.mem k seen then
              Message_collector.add_typed collector
                (`Attr (`Bad_value_generic (`Message (Printf.sprintf
                  "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9c%s\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad key label list: Duplicate key label. Each key label must be unique."
                  attr_value attr_name name))))
            else
              find_duplicates (k :: seen) rest
        in
        find_duplicates [] keys
      end
    ) attrs;

    (* Validate that command and popovertarget cannot have aria-expanded *)
    if name_lower = "button" then begin
      let has_command = Attr_utils.has_attr "command" attrs in
      let has_popovertarget = Attr_utils.has_attr "popovertarget" attrs in
      let has_aria_expanded = Attr_utils.has_attr "aria-expanded" attrs in

      if has_command && has_aria_expanded then
        Message_collector.add_typed collector
          (`Attr (`Not_allowed_when (`Attr "aria-expanded", `Elem name,
            `Condition "a \xe2\x80\x9ccommand\xe2\x80\x9d attribute")));

      if has_popovertarget && has_aria_expanded then
        Message_collector.add_typed collector
          (`Attr (`Not_allowed_when (`Attr "aria-expanded", `Elem name,
            `Condition "a \xe2\x80\x9cpopovertarget\xe2\x80\x9d attribute")))
    end;

    (* Note: data-* uppercase check requires XML parsing which preserves case.
       The HTML5 parser normalizes attribute names to lowercase, so this check
       is only effective when the document is parsed as XML.
       Commenting out until we have XML parsing support. *)
    ignore state.is_xhtml;

    (* Validate media attribute on link, style, source elements *)
    let is_media_element = name_lower = "link" || name_lower = "style" || name_lower = "source" in
    if is_media_element then begin
      List.iter (fun (attr_name, attr_value) ->
        let attr_lower = String.lowercase_ascii attr_name in
        if attr_lower = "media" then begin
          let trimmed = String.trim attr_value in
          if trimmed <> "" then begin
            match Dt_media_query.validate_media_query_strict trimmed with
            | Ok () -> ()
            | Error msg ->
              Message_collector.add_typed collector
                (`Attr (`Bad_value_generic (`Message (Printf.sprintf
                  "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9c%s\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad media query: %s"
                  attr_value attr_name name msg))))
          end
        end
      ) attrs
    end;

    (* Validate RDFa prefix attribute - space-separated list of prefix:iri pairs *)
    List.iter (fun (attr_name, attr_value) ->
      let attr_lower = String.lowercase_ascii attr_name in
      if attr_lower = "prefix" then begin
        (* Parse prefix attribute value - format: "prefix1: iri1 prefix2: iri2 ..." *)
        let trimmed = String.trim attr_value in
        if trimmed <> "" then begin
          (* Check for empty prefix (starts with : or has space:) *)
          if String.length trimmed > 0 && trimmed.[0] = ':' then
            Message_collector.add_typed collector
              (`Attr (`Bad_value (`Elem name, `Attr attr_name, `Value attr_value, `Reason "")))
          else begin
            (* Check for invalid prefix names - must start with letter or underscore *)
            let is_ncname_start c =
              (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || c = '_'
            in
            if String.length trimmed > 0 && not (is_ncname_start trimmed.[0]) then
              Message_collector.add_typed collector
                (`Attr (`Bad_value (`Elem name, `Attr attr_name, `Value attr_value, `Reason "")))
          end
        end
      end
    ) attrs

  | _ -> () (* Skip non-HTML elements *)

let end_element _state ~tag:_ _collector = ()
let characters _state _text _collector = ()
let end_document _state _collector = ()

let checker =
  (module struct
    type nonrec state = state
    let create = create
    let reset = reset
    let start_element = start_element
    let end_element = end_element
    let characters = characters
    let end_document = end_document
  end : Checker.S)