+19

lib/htmlrw_check/attr_utils.ml

··· 1 1 + (** Common attribute utilities used across checkers. *) 2 2 + 3 3 + type attrs = (string * string) list 4 4 + 5 5 + let has_attr name attrs = 6 6 + List.exists (fun (n, _) -> String.lowercase_ascii n = name) attrs 7 7 + 8 8 + let get_attr name attrs = 9 9 + List.find_map (fun (n, v) -> 10 10 + if String.lowercase_ascii n = name then Some v else None 11 11 + ) attrs 12 12 + 13 13 + let get_attr_or name ~default attrs = 14 14 + Option.value ~default (get_attr name attrs) 15 15 + 16 16 + let is_non_empty_attr name attrs = 17 17 + match get_attr name attrs with 18 18 + | Some v -> String.trim v <> "" 19 19 + | None -> false

+2 -8

lib/htmlrw_check/datatype/dt_color.ml

··· 213 213 if String.length s = 0 then Error "Color value must not be empty" 214 214 else if List.mem s named_colors then Ok () 215 215 else if String.length s > 0 && s.[0] = '#' then validate_hex_color s 216 216 - else if 217 217 - String.length s > 4 218 218 - && (String.sub s 0 4 = "rgb(" || String.sub s 0 5 = "rgba(") 219 219 - then 216 216 + else if String.starts_with ~prefix:"rgb(" s || String.starts_with ~prefix:"rgba(" s then 220 217 (* Basic validation for rgb/rgba - just check balanced parens *) 221 218 if s.[String.length s - 1] = ')' then Ok () 222 219 else Error "rgb/rgba function must end with ')'" 223 223 - else if 224 224 - String.length s > 4 225 225 - && (String.sub s 0 4 = "hsl(" || String.sub s 0 5 = "hsla(") 226 226 - then 220 220 + else if String.starts_with ~prefix:"hsl(" s || String.starts_with ~prefix:"hsla(" s then 227 221 (* Basic validation for hsl/hsla - just check balanced parens *) 228 222 if s.[String.length s - 1] = ')' then Ok () 229 223 else Error "hsl/hsla function must end with ')'"

+2 -2

lib/htmlrw_check/datatype/dt_media_query.ml

··· 330 330 331 331 (* Get base feature name for error messages (strip min-/max- prefix) *) 332 332 let base_feature = 333 333 - if String.length feature > 4 && String.sub feature 0 4 = "min-" then 333 333 + if String.starts_with ~prefix:"min-" feature then 334 334 String.sub feature 4 (String.length feature - 4) 335 335 - else if String.length feature > 4 && String.sub feature 0 4 = "max-" then 335 335 + else if String.starts_with ~prefix:"max-" feature then 336 336 String.sub feature 4 (String.length feature - 4) 337 337 else 338 338 feature

+77 -102

lib/htmlrw_check/message_format.ml

··· 1 1 + (** Get effective system_id, preferring location's system_id over the passed one *) 2 2 + let get_system_id ?system_id loc_system_id = 3 3 + loc_system_id 4 4 + |> Option.fold ~none:system_id ~some:Option.some 5 5 + |> Option.value ~default:"input" 6 6 + 1 7 let format_text ?system_id messages = 2 8 let buf = Buffer.create 1024 in 3 3 - List.iter 4 4 - (fun msg -> 5 5 - let loc_str = 6 6 - match msg.Message.location with 7 7 - | Some loc -> ( 8 8 - let sid = 9 9 - match loc.Message.system_id with 10 10 - | Some s -> s 11 11 - | None -> ( 12 12 - match system_id with Some s -> s | None -> "input") 13 13 - in 14 14 - let col_info = 15 15 - match (loc.end_line, loc.end_column) with 16 16 - | Some el, Some ec when el = loc.line && ec > loc.column -> 17 17 - Printf.sprintf "%d.%d-%d" loc.line loc.column ec 18 18 - | Some el, Some ec when el > loc.line -> 19 19 - Printf.sprintf "%d.%d-%d.%d" loc.line loc.column el ec 20 20 - | _ -> Printf.sprintf "%d.%d" loc.line loc.column 21 21 - in 22 22 - Printf.sprintf "%s:%s" sid col_info) 23 23 - | None -> ( 24 24 - match system_id with Some s -> s | None -> "input") 25 25 - in 26 26 - let severity_str = Message.severity_to_string msg.Message.severity in 27 27 - let code_str = " [" ^ Message.error_code_to_string msg.Message.error_code ^ "]" in 28 28 - let elem_str = 29 29 - match msg.Message.element with 30 30 - | Some e -> " (element: " ^ e ^ ")" 31 31 - | None -> "" 32 32 - in 33 33 - let attr_str = 34 34 - match msg.Message.attribute with 35 35 - | Some a -> " (attribute: " ^ a ^ ")" 36 36 - | None -> "" 37 37 - in 38 38 - Buffer.add_string buf 39 39 - (Printf.sprintf "%s: %s%s: %s%s%s\n" loc_str severity_str code_str 40 40 - msg.Message.message elem_str attr_str)) 41 41 - messages; 9 9 + List.iter (fun msg -> 10 10 + let loc_str = match msg.Message.location with 11 11 + | Some loc -> 12 12 + let sid = get_system_id ?system_id loc.Message.system_id in 13 13 + let col_info = match loc.end_line, loc.end_column with 14 14 + | Some el, Some ec when el = loc.line && ec > loc.column -> 15 15 + Printf.sprintf "%d.%d-%d" loc.line loc.column ec 16 16 + | Some el, Some ec when el > loc.line -> 17 17 + Printf.sprintf "%d.%d-%d.%d" loc.line loc.column el ec 18 18 + | _ -> 19 19 + Printf.sprintf "%d.%d" loc.line loc.column 20 20 + in 21 21 + Printf.sprintf "%s:%s" sid col_info 22 22 + | None -> 23 23 + Option.value system_id ~default:"input" 24 24 + in 25 25 + let elem_str = Option.fold ~none:"" ~some:(Printf.sprintf " (element: %s)") msg.Message.element in 26 26 + let attr_str = Option.fold ~none:"" ~some:(Printf.sprintf " (attribute: %s)") msg.Message.attribute in 27 27 + Buffer.add_string buf (Printf.sprintf "%s: %s [%s]: %s%s%s\n" 28 28 + loc_str 29 29 + (Message.severity_to_string msg.Message.severity) 30 30 + (Message.error_code_to_string msg.Message.error_code) 31 31 + msg.Message.message 32 32 + elem_str 33 33 + attr_str) 34 34 + ) messages; 42 35 Buffer.contents buf 43 36 44 37 let format_gnu ?system_id messages = 45 38 let buf = Buffer.create 1024 in 46 46 - List.iter 47 47 - (fun msg -> 48 48 - let loc_str = 49 49 - match msg.Message.location with 50 50 - | Some loc -> ( 51 51 - let sid = 52 52 - match loc.Message.system_id with 53 53 - | Some s -> s 54 54 - | None -> ( 55 55 - match system_id with Some s -> s | None -> "input") 56 56 - in 57 57 - Printf.sprintf "%s:%d:%d" sid loc.line loc.column) 58 58 - | None -> ( 59 59 - match system_id with Some s -> s ^ ":0:0" | None -> "input:0:0") 60 60 - in 61 61 - let severity_str = Message.severity_to_string msg.Message.severity in 62 62 - let code_str = " [" ^ Message.error_code_to_string msg.Message.error_code ^ "]" in 63 63 - Buffer.add_string buf 64 64 - (Printf.sprintf "%s: %s%s: %s\n" loc_str severity_str code_str 65 65 - msg.Message.message)) 66 66 - messages; 39 39 + List.iter (fun msg -> 40 40 + let loc_str = match msg.Message.location with 41 41 + | Some loc -> 42 42 + Printf.sprintf "%s:%d:%d" 43 43 + (get_system_id ?system_id loc.Message.system_id) 44 44 + loc.line loc.column 45 45 + | None -> 46 46 + Option.value system_id ~default:"input" ^ ":0:0" 47 47 + in 48 48 + Buffer.add_string buf (Printf.sprintf "%s: %s [%s]: %s\n" 49 49 + loc_str 50 50 + (Message.severity_to_string msg.Message.severity) 51 51 + (Message.error_code_to_string msg.Message.error_code) 52 52 + msg.Message.message) 53 53 + ) messages; 67 54 Buffer.contents buf 68 55 69 56 let message_to_json ?system_id msg = 70 57 let open Jsont in 71 71 - let severity = String (Message.severity_to_string msg.Message.severity, Meta.none) in 72 72 - let message_text = String (msg.Message.message, Meta.none) in 73 73 - let base = [ (("type", Meta.none), severity); (("message", Meta.none), message_text) ] in 74 74 - let with_code = 75 75 - (("subType", Meta.none), String (Message.error_code_to_string msg.Message.error_code, Meta.none)) :: base 76 76 - in 77 77 - let with_location = 78 78 - match msg.Message.location with 58 58 + let str s = String (s, Meta.none) in 59 59 + let num n = Number (float_of_int n, Meta.none) in 60 60 + let field name value = ((name, Meta.none), value) in 61 61 + 62 62 + let base = [ 63 63 + field "type" (str (Message.severity_to_string msg.Message.severity)); 64 64 + field "message" (str msg.Message.message); 65 65 + field "subType" (str (Message.error_code_to_string msg.Message.error_code)); 66 66 + ] in 67 67 + 68 68 + let with_location = match msg.Message.location with 79 69 | Some loc -> 80 80 - let line = Number (float_of_int loc.Message.line, Meta.none) in 81 81 - let column = Number (float_of_int loc.Message.column, Meta.none) in 82 82 - let loc_fields = 83 83 - [ (("firstLine", Meta.none), line); (("firstColumn", Meta.none), column) ] 84 84 - in 85 85 - let loc_fields = 86 86 - match loc.Message.end_line with 87 87 - | Some el -> 88 88 - (("lastLine", Meta.none), Number (float_of_int el, Meta.none)) :: loc_fields 89 89 - | None -> loc_fields 90 90 - in 91 91 - let loc_fields = 92 92 - match loc.Message.end_column with 93 93 - | Some ec -> 94 94 - (("lastColumn", Meta.none), Number (float_of_int ec, Meta.none)) 95 95 - :: loc_fields 96 96 - | None -> loc_fields 97 97 - in 98 98 - let url = 99 99 - match loc.Message.system_id with 100 100 - | Some s -> s 101 101 - | None -> ( 102 102 - match system_id with Some s -> s | None -> "input") 103 103 - in 104 104 - (("url", Meta.none), String (url, Meta.none)) :: loc_fields @ with_code 70 70 + let url = get_system_id ?system_id loc.Message.system_id in 71 71 + let loc_fields = [ 72 72 + field "url" (str url); 73 73 + field "firstLine" (num loc.line); 74 74 + field "firstColumn" (num loc.column); 75 75 + ] in 76 76 + let loc_fields = Option.fold ~none:loc_fields 77 77 + ~some:(fun el -> field "lastLine" (num el) :: loc_fields) 78 78 + loc.Message.end_line in 79 79 + let loc_fields = Option.fold ~none:loc_fields 80 80 + ~some:(fun ec -> field "lastColumn" (num ec) :: loc_fields) 81 81 + loc.Message.end_column in 82 82 + loc_fields @ base 105 83 | None -> 106 106 - let url = 107 107 - match system_id with Some s -> s | None -> "input" 108 108 - in 109 109 - (("url", Meta.none), String (url, Meta.none)) :: with_code 84 84 + field "url" (str (Option.value system_id ~default:"input")) :: base 110 85 in 111 111 - let with_extract = 112 112 - match msg.Message.extract with 113 113 - | Some e -> (("extract", Meta.none), String (e, Meta.none)) :: with_location 114 114 - | None -> with_location 115 115 - in 86 86 + 87 87 + let with_extract = Option.fold ~none:with_location 88 88 + ~some:(fun e -> field "extract" (str e) :: with_location) 89 89 + msg.Message.extract in 90 90 + 116 91 Object (with_extract, Meta.none) 117 92 118 93 let format_json ?system_id messages =

+10 -10

lib/htmlrw_check/parse_error_bridge.ml

··· 14 14 | Html5rw.Parse_error_code.Tree_construction_error s -> 15 15 (* Check for control-character/noncharacter/surrogate with codepoint info *) 16 16 (try 17 17 - if String.length s > 28 && String.sub s 0 28 = "control-character-in-input-s" then 17 17 + if String.starts_with ~prefix:"control-character-in-input-s" s then 18 18 let colon_pos = String.index s ':' in 19 19 let cp_str = String.sub s (colon_pos + 1) (String.length s - colon_pos - 1) in 20 20 let cp = int_of_string ("0x" ^ cp_str) in 21 21 Printf.sprintf "Forbidden code point U+%04x." cp 22 22 - else if String.length s > 25 && String.sub s 0 25 = "noncharacter-in-input-str" then 22 22 + else if String.starts_with ~prefix:"noncharacter-in-input-str" s then 23 23 let colon_pos = String.index s ':' in 24 24 let cp_str = String.sub s (colon_pos + 1) (String.length s - colon_pos - 1) in 25 25 let cp = int_of_string ("0x" ^ cp_str) in 26 26 Printf.sprintf "Forbidden code point U+%04x." cp 27 27 - else if String.length s > 22 && String.sub s 0 22 = "surrogate-in-input-str" then 27 27 + else if String.starts_with ~prefix:"surrogate-in-input-str" s then 28 28 let colon_pos = String.index s ':' in 29 29 let cp_str = String.sub s (colon_pos + 1) (String.length s - colon_pos - 1) in 30 30 let cp = int_of_string ("0x" ^ cp_str) in 31 31 Printf.sprintf "Forbidden code point U+%04x." cp 32 32 (* Character reference errors *) 33 33 - else if String.length s > 28 && String.sub s 0 28 = "control-character-reference:" then 33 33 + else if String.starts_with ~prefix:"control-character-reference:" s then 34 34 let cp_str = String.sub s 28 (String.length s - 28) in 35 35 let cp = int_of_string ("0x" ^ cp_str) in 36 36 if cp = 0x0D then 37 37 "A numeric character reference expanded to carriage return." 38 38 else 39 39 Printf.sprintf "Character reference expands to a control character (U+%04x)." cp 40 40 - else if String.length s > 31 && String.sub s 0 31 = "noncharacter-character-referenc" then 40 40 + else if String.starts_with ~prefix:"noncharacter-character-referenc" s then 41 41 let colon_pos = String.index s ':' in 42 42 let cp_str = String.sub s (colon_pos + 1) (String.length s - colon_pos - 1) in 43 43 let cp = int_of_string ("0x" ^ cp_str) in ··· 49 49 Printf.sprintf "Character reference expands to an astral non-character (U+%05x)." cp 50 50 else 51 51 Printf.sprintf "Character reference expands to a non-character (U+%04x)." cp 52 52 - else if String.length s > 36 && String.sub s 0 36 = "character-reference-outside-unicode-" then 52 52 + else if String.starts_with ~prefix:"character-reference-outside-unicode-" s then 53 53 "Character reference outside the permissible Unicode range." 54 54 - else if String.length s > 27 && String.sub s 0 27 = "surrogate-character-referen" then 54 54 + else if String.starts_with ~prefix:"surrogate-character-referen" s then 55 55 let colon_pos = String.index s ':' in 56 56 let cp_str = String.sub s (colon_pos + 1) (String.length s - colon_pos - 1) in 57 57 let cp = int_of_string ("0x" ^ cp_str) in ··· 64 64 "End tag \xe2\x80\x9cbr\xe2\x80\x9d." 65 65 else if s = "expected-closing-tag-but-got-eof" then 66 66 "End of file seen and there were open elements." 67 67 - else if String.length s > 28 && String.sub s 0 28 = "bad-start-tag-in-head-noscri" then 67 67 + else if String.starts_with ~prefix:"bad-start-tag-in-head-noscri" s then 68 68 let colon_pos = String.index s ':' in 69 69 let element = String.sub s (colon_pos + 1) (String.length s - colon_pos - 1) in 70 70 Printf.sprintf "Bad start tag in \xe2\x80\x9c%s\xe2\x80\x9d in \xe2\x80\x9cnoscript\xe2\x80\x9d in \xe2\x80\x9chead\xe2\x80\x9d." element 71 71 - else if String.length s > 19 && String.sub s 0 19 = "unexpected-end-tag:" then 71 71 + else if String.starts_with ~prefix:"unexpected-end-tag:" s then 72 72 let element = String.sub s 19 (String.length s - 19) in 73 73 Printf.sprintf "Stray end tag \xe2\x80\x9c%s\xe2\x80\x9d." element 74 74 - else if String.length s > 19 && String.sub s 0 19 = "start-tag-in-table:" then 74 74 + else if String.starts_with ~prefix:"start-tag-in-table:" s then 75 75 let tag = String.sub s 19 (String.length s - 19) in 76 76 Printf.sprintf "Start tag \xe2\x80\x9c%s\xe2\x80\x9d seen in \xe2\x80\x9ctable\xe2\x80\x9d." tag 77 77 else

+17 -39

lib/htmlrw_check/semantic/autofocus_checker.ml

··· 3 3 Validates that only one element with autofocus attribute exists within 4 4 each dialog or popover context. *) 5 5 6 6 - (** Context for tracking autofocus elements. *) 7 6 type context_type = Dialog | Popover 8 7 9 8 type context = { ··· 26 25 state.context_stack <- []; 27 26 state.current_depth <- 0 28 27 29 29 - (** Check if an attribute list contains a specific attribute. *) 30 30 - let has_attr name attrs = 31 31 - List.exists (fun (attr_name, _) -> String.lowercase_ascii attr_name = name) attrs 32 32 - 33 33 - (** Get an attribute value from the list. *) 34 34 - let get_attr name attrs = 35 35 - List.find_map (fun (attr_name, value) -> 36 36 - if String.lowercase_ascii attr_name = name then Some value else None 37 37 - ) attrs 38 38 - 39 39 - (** Check if element has popover attribute. *) 40 40 - let has_popover attrs = 41 41 - List.exists (fun (attr_name, _) -> 42 42 - String.lowercase_ascii attr_name = "popover" 43 43 - ) attrs 44 44 - 45 28 let start_element state ~name ~namespace ~attrs collector = 46 46 - let name_lower = String.lowercase_ascii name in 47 47 - 48 48 - (* Track depth *) 49 29 state.current_depth <- state.current_depth + 1; 50 30 51 51 - if namespace = None then begin 31 31 + match namespace with 32 32 + | Some _ -> () 33 33 + | None -> 34 34 + let name_lower = String.lowercase_ascii name in 35 35 + 52 36 (* Check if we're entering a dialog or popover context *) 53 53 - let enters_context = 54 54 - if name_lower = "dialog" then Some Dialog 55 55 - else if has_popover attrs then Some Popover 56 56 - else None 37 37 + let enters_context = match name_lower with 38 38 + | "dialog" -> Some Dialog 39 39 + | _ when Attr_utils.has_attr "popover" attrs -> Some Popover 40 40 + | _ -> None 57 41 in 58 42 59 59 - (match enters_context with 60 60 - | Some ctx_type -> 43 43 + Option.iter (fun ctx_type -> 61 44 let ctx = { context_type = ctx_type; autofocus_count = 0; depth = state.current_depth } in 62 45 state.context_stack <- ctx :: state.context_stack 63 63 - | None -> ()); 46 46 + ) enters_context; 64 47 65 48 (* Check for autofocus attribute *) 66 66 - if has_attr "autofocus" attrs then begin 67 67 - (* Increment count in innermost context if any *) 49 49 + if Attr_utils.has_attr "autofocus" attrs then 68 50 match state.context_stack with 69 51 | ctx :: _ -> 70 52 ctx.autofocus_count <- ctx.autofocus_count + 1; 71 53 if ctx.autofocus_count > 1 then 72 54 Message_collector.add_typed collector (`Misc `Multiple_autofocus) 73 55 | [] -> () 74 74 - end 75 75 - end 76 56 77 57 let end_element state ~name ~namespace _collector = 78 78 - let name_lower = String.lowercase_ascii name in 79 79 - 80 80 - if namespace = None then begin 81 81 - (* Pop context if we're leaving one *) 58 58 + (match namespace with 59 59 + | Some _ -> () 60 60 + | None -> 61 61 + let name_lower = String.lowercase_ascii name in 82 62 match state.context_stack with 83 63 | ctx :: rest when ctx.depth = state.current_depth -> 84 84 - (* Verify this is the right element *) 85 64 let matches = 86 65 (name_lower = "dialog" && ctx.context_type = Dialog) || 87 66 (ctx.context_type = Popover) 88 67 in 89 68 if matches then state.context_stack <- rest 90 90 - | _ -> () 91 91 - end; 69 69 + | _ -> ()); 92 70 93 71 state.current_depth <- state.current_depth - 1 94 72

+1 -8

lib/htmlrw_check/semantic/form_checker.ml

··· 10 10 11 11 let reset _state = () 12 12 13 13 - (** Get the value of an attribute if present. *) 14 14 - let get_attr name attrs = 15 15 - List.find_map 16 16 - (fun (attr_name, value) -> 17 17 - if String.equal attr_name name then Some value else None) 18 18 - attrs 19 19 - 20 13 (** Check if autocomplete value contains webauthn token *) 21 14 let contains_webauthn value = 22 15 let lower = String.lowercase_ascii value in ··· 42 35 (* Check autocomplete attribute on form elements *) 43 36 match name with 44 37 | "input" | "select" | "textarea" -> 45 45 - (match get_attr "autocomplete" attrs with 38 38 + (match Attr_utils.get_attr "autocomplete" attrs with 46 39 | Some autocomplete_value -> 47 40 check_autocomplete_value autocomplete_value name collector 48 41 | None -> ())

+3 -8

lib/htmlrw_check/semantic/lang_detecting_checker.ml

··· 60 60 let n = String.lowercase_ascii name in 61 61 n = "svg" || n = "math" 62 62 63 63 - let get_attr name attrs = 64 64 - List.find_map (fun (n, v) -> 65 65 - if String.lowercase_ascii n = name then Some v else None 66 66 - ) attrs 67 67 - 68 63 let get_lang_code lang = 69 64 (* Extract primary language subtag *) 70 65 match String.split_on_char '-' lang with ··· 226 221 let ns = Option.value namespace ~default:"" in 227 222 228 223 if name_lower = "html" then begin 229 229 - state.html_lang <- get_attr "lang" attrs; 230 230 - state.html_dir <- get_attr "dir" attrs; 224 224 + state.html_lang <- Attr_utils.get_attr "lang" attrs; 225 225 + state.html_dir <- Attr_utils.get_attr "dir" attrs; 231 226 (* TODO: get line/column from locator *) 232 227 state.html_locator <- Some (1, 1) 233 228 end ··· 244 239 state.skip_depth <- state.skip_depth + 1 245 240 else begin 246 241 (* Check for different lang attribute *) 247 247 - match get_attr "lang" attrs with 242 242 + match Attr_utils.get_attr "lang" attrs with 248 243 | Some lang when state.html_lang <> Some lang -> 249 244 state.skip_depth <- state.skip_depth + 1 250 245 | _ -> ()

+1 -7

lib/htmlrw_check/semantic/option_checker.ml

··· 22 22 state.option_stack <- []; 23 23 state.in_template <- 0 24 24 25 25 - (** Get attribute value if present. *) 26 26 - let get_attr name attrs = 27 27 - List.find_map (fun (attr_name, value) -> 28 28 - if String.lowercase_ascii attr_name = name then Some value else None 29 29 - ) attrs 30 30 - 31 25 let start_element state ~name ~namespace ~attrs collector = 32 26 let name_lower = String.lowercase_ascii name in 33 27 ··· 36 30 if name_lower = "template" then 37 31 state.in_template <- state.in_template + 1 38 32 else if state.in_template = 0 && name_lower = "option" then begin 39 39 - let label_opt = get_attr "label" attrs in 33 33 + let label_opt = Attr_utils.get_attr "label" attrs in 40 34 let has_label = label_opt <> None in 41 35 let label_empty = match label_opt with 42 36 | Some v -> String.trim v = ""

+29 -40

lib/htmlrw_check/semantic/required_attr_checker.ml

··· 13 13 state._in_figure <- false; 14 14 state.in_a_with_href <- false 15 15 16 16 - (** Check if an attribute list contains a specific attribute. *) 17 17 - let has_attr name attrs = 18 18 - List.exists (fun (attr_name, _) -> String.equal attr_name name) attrs 19 19 - 20 20 - (** Get the value of an attribute if present. *) 21 21 - let get_attr name attrs = 22 22 - List.find_map 23 23 - (fun (attr_name, value) -> 24 24 - if String.equal attr_name name then Some value else None) 25 25 - attrs 26 26 - 27 16 let check_img_element state attrs collector = 28 17 (* Check for required src OR srcset attribute *) 29 29 - if not (has_attr "src" attrs) && not (has_attr "srcset" attrs) then 18 18 + if not (Attr_utils.has_attr "src" attrs) && not (Attr_utils.has_attr "srcset" attrs) then 30 19 Message_collector.add_typed collector (`Img `Missing_src_or_srcset); 31 20 32 21 (* Check for alt attribute - always required *) 33 33 - if not (has_attr "alt" attrs) then 22 22 + if not (Attr_utils.has_attr "alt" attrs) then 34 23 Message_collector.add_typed collector (`Img `Missing_alt); 35 24 36 25 (* Check ismap requires 'a' ancestor with href *) 37 37 - if has_attr "ismap" attrs && not state.in_a_with_href then 26 26 + if Attr_utils.has_attr "ismap" attrs && not state.in_a_with_href then 38 27 Message_collector.add_typed collector (`Img `Ismap_needs_href) 39 28 40 29 let check_area_element attrs collector = 41 30 (* area with href requires alt *) 42 42 - if has_attr "href" attrs && not (has_attr "alt" attrs) then 31 31 + if Attr_utils.has_attr "href" attrs && not (Attr_utils.has_attr "alt" attrs) then 43 32 Message_collector.add_typed collector 44 33 (`Attr (`Missing (`Elem "area", `Attr "alt"))) 45 34 46 35 let check_input_element attrs collector = 47 47 - match get_attr "type" attrs with 36 36 + match Attr_utils.get_attr "type" attrs with 48 37 | Some "image" -> 49 38 (* input[type=image] requires alt *) 50 50 - if not (has_attr "alt" attrs) then 39 39 + if not (Attr_utils.has_attr "alt" attrs) then 51 40 Message_collector.add_typed collector 52 41 (`Attr (`Missing (`Elem "input", `Attr "alt"))) 53 42 | Some "hidden" -> 54 43 (* input[type=hidden] should not have required attribute *) 55 55 - if has_attr "required" attrs then 44 44 + if Attr_utils.has_attr "required" attrs then 56 45 Message_collector.add_typed collector 57 46 (`Attr (`Not_allowed_when (`Attr "required", `Elem "input", `Condition "the type attribute is hidden"))) 58 47 | Some "file" -> 59 48 (* input[type=file] should not have value attribute *) 60 60 - if has_attr "value" attrs then 49 49 + if Attr_utils.has_attr "value" attrs then 61 50 Message_collector.add_typed collector 62 51 (`Attr (`Not_allowed_when (`Attr "value", `Elem "input", `Condition "the type attribute is file"))) 63 52 | _ -> () 64 53 65 54 let check_script_element attrs _collector = 66 55 (* script requires src OR text content *) 67 67 - if not (has_attr "src" attrs) then 56 56 + if not (Attr_utils.has_attr "src" attrs) then 68 57 (* We can't check for text content here; that would need to be done 69 58 in end_element or with state tracking *) 70 59 () ··· 76 65 - http-equiv AND content 77 66 - property AND content (RDFa) 78 67 - itemprop AND content (microdata) *) 79 79 - let has_charset = has_attr "charset" attrs in 80 80 - let has_name = has_attr "name" attrs in 81 81 - let has_content = has_attr "content" attrs in 82 82 - let has_http_equiv = has_attr "http-equiv" attrs in 83 83 - let has_property = has_attr "property" attrs in 84 84 - let has_itemprop = has_attr "itemprop" attrs in 68 68 + let has_charset = Attr_utils.has_attr "charset" attrs in 69 69 + let has_name = Attr_utils.has_attr "name" attrs in 70 70 + let has_content = Attr_utils.has_attr "content" attrs in 71 71 + let has_http_equiv = Attr_utils.has_attr "http-equiv" attrs in 72 72 + let has_property = Attr_utils.has_attr "property" attrs in 73 73 + let has_itemprop = Attr_utils.has_attr "itemprop" attrs in 85 74 86 75 let valid = 87 76 has_charset ··· 100 89 101 90 let check_link_element attrs collector = 102 91 (* link[rel="stylesheet"] requires href *) 103 103 - match get_attr "rel" attrs with 92 92 + match Attr_utils.get_attr "rel" attrs with 104 93 | Some rel when String.equal rel "stylesheet" -> 105 105 - if not (has_attr "href" attrs) then 94 94 + if not (Attr_utils.has_attr "href" attrs) then 106 95 Message_collector.add_typed collector (`Link `Missing_href) 107 96 | _ -> () 108 97 109 98 let check_a_element attrs collector = 110 99 (* a[download] requires href *) 111 111 - if has_attr "download" attrs && not (has_attr "href" attrs) then 100 100 + if Attr_utils.has_attr "download" attrs && not (Attr_utils.has_attr "href" attrs) then 112 101 Message_collector.add_typed collector 113 102 (`Attr (`Missing (`Elem "a", `Attr "href"))) 114 103 115 104 let check_map_element attrs collector = 116 105 (* map requires name *) 117 117 - if not (has_attr "name" attrs) then 106 106 + if not (Attr_utils.has_attr "name" attrs) then 118 107 Message_collector.add_typed collector 119 108 (`Attr (`Missing (`Elem "map", `Attr "name"))) 120 109 121 110 let check_object_element attrs collector = 122 111 (* object requires data attribute (or type attribute alone is not sufficient) *) 123 123 - let has_data = has_attr "data" attrs in 124 124 - let has_type = has_attr "type" attrs in 112 112 + let has_data = Attr_utils.has_attr "data" attrs in 113 113 + let has_type = Attr_utils.has_attr "type" attrs in 125 114 if not has_data && has_type then 126 115 Message_collector.add_typed collector 127 116 (`Attr (`Missing (`Elem "object", `Attr "data"))) 128 117 129 118 let check_popover_element element_name attrs collector = 130 119 (* popover attribute must have valid value *) 131 131 - match get_attr "popover" attrs with 120 120 + match Attr_utils.get_attr "popover" attrs with 132 121 | Some value -> 133 122 let value_lower = String.lowercase_ascii value in 134 123 (* Valid values: empty string, auto, manual, hint *) ··· 141 130 142 131 let check_meter_element attrs collector = 143 132 (* meter requires value attribute *) 144 144 - if not (has_attr "value" attrs) then 133 133 + if not (Attr_utils.has_attr "value" attrs) then 145 134 Message_collector.add_typed collector 146 135 (`Attr (`Missing (`Elem "meter", `Attr "value"))) 147 136 else begin 148 137 (* Validate min <= value constraint *) 149 149 - match get_attr "value" attrs, get_attr "min" attrs with 138 138 + match Attr_utils.get_attr "value" attrs, Attr_utils.get_attr "min" attrs with 150 139 | Some value_str, Some min_str -> 151 140 (try 152 141 let value = float_of_string value_str in ··· 162 151 163 152 let check_progress_element attrs collector = 164 153 (* Validate progress value constraints *) 165 165 - match get_attr "value" attrs with 154 154 + match Attr_utils.get_attr "value" attrs with 166 155 | None -> () (* value is optional *) 167 156 | Some value_str -> 168 157 (try 169 158 let value = float_of_string value_str in 170 170 - let max_val = match get_attr "max" attrs with 159 159 + let max_val = match Attr_utils.get_attr "max" attrs with 171 160 | None -> 1.0 (* default max is 1 *) 172 161 | Some max_str -> (try float_of_string max_str with _ -> 1.0) 173 162 in 174 163 if value > max_val then 175 164 let q s = "\xe2\x80\x9c" ^ s ^ "\xe2\x80\x9d" in 176 165 (* Check which message to use based on whether max is present *) 177 177 - if has_attr "max" attrs then 166 166 + if Attr_utils.has_attr "max" attrs then 178 167 Message_collector.add_typed collector 179 168 (`Generic ( 180 169 (* Note: double space before "value" matches Nu validator quirk *) ··· 198 187 | "link" -> check_link_element attrs collector 199 188 | "a" -> 200 189 check_a_element attrs collector; 201 201 - if has_attr "href" attrs then state.in_a_with_href <- true 190 190 + if Attr_utils.has_attr "href" attrs then state.in_a_with_href <- true 202 191 | "map" -> check_map_element attrs collector 203 192 | "object" -> check_object_element attrs collector 204 193 | "meter" -> check_meter_element attrs collector ··· 206 195 | "figure" -> state._in_figure <- true 207 196 | _ -> 208 197 (* Check popover attribute on any element *) 209 209 - if has_attr "popover" attrs then check_popover_element name attrs collector 198 198 + if Attr_utils.has_attr "popover" attrs then check_popover_element name attrs collector 210 199 211 200 let end_element state ~name ~namespace:_ _collector = 212 201 match name with

+1 -1

lib/htmlrw_check/specialized/aria_checker.ml

··· 491 491 if name_lower = "br" || name_lower = "wbr" then begin 492 492 List.iter (fun (attr_name, _) -> 493 493 let attr_lower = String.lowercase_ascii attr_name in 494 494 - if String.length attr_lower > 5 && String.sub attr_lower 0 5 = "aria-" && 494 494 + if String.starts_with ~prefix:"aria-" attr_lower && 495 495 attr_lower <> "aria-hidden" then 496 496 Message_collector.add_typed collector 497 497 (`Attr (`Not_allowed (`Attr attr_name, `Elem name)))

+116 -97

lib/htmlrw_check/specialized/attr_restrictions_checker.ml

··· 41 41 let create () = { is_xhtml = false } 42 42 let reset state = state.is_xhtml <- false 43 43 44 44 - (** Check if an attribute list contains a specific attribute. *) 45 45 - let has_attr name attrs = 46 46 - List.exists (fun (attr_name, _) -> String.lowercase_ascii attr_name = name) attrs 47 47 - 48 48 - (** Get an attribute value from the list. *) 49 49 - let get_attr name attrs = 50 50 - List.find_map (fun (attr_name, value) -> 51 51 - if String.lowercase_ascii attr_name = name then Some value else None 52 52 - ) attrs 53 53 - 54 44 (** Input types that allow the list attribute. *) 55 45 let input_types_allowing_list = [ 56 46 "color"; "date"; "datetime-local"; "email"; "month"; "number"; ··· 67 57 68 58 (* Detect XHTML mode from xmlns attribute on html element *) 69 59 if name_lower = "html" then begin 70 70 - let xmlns_value = get_attr "xmlns" attrs in 71 71 - match xmlns_value with 60 60 + match Attr_utils.get_attr "xmlns" attrs with 72 61 | Some "http://www.w3.org/1999/xhtml" -> state.is_xhtml <- true 73 62 | _ -> () 74 63 end; 75 64 76 65 (* Check HTML element attribute restrictions *) 77 77 - if namespace = None then begin 66 66 + (match namespace with 67 67 + | Some _ -> () 68 68 + | None -> 78 69 match List.assoc_opt name_lower disallowed_attrs_html with 79 70 | Some disallowed -> 80 71 List.iter (fun attr -> 81 81 - if has_attr attr attrs then 72 72 + if Attr_utils.has_attr attr attrs then 82 73 report_disallowed_attr name_lower attr collector 83 74 ) disallowed 84 84 - | None -> () 85 85 - end; 75 75 + | None -> ()); 86 76 87 77 (* Check for xml:base attribute - not allowed in HTML *) 88 88 - if namespace = None && name_lower = "html" then begin 89 89 - if has_attr "xml:base" attrs then 78 78 + (match namespace with 79 79 + | Some _ -> () 80 80 + | None when name_lower = "html" -> 81 81 + if Attr_utils.has_attr "xml:base" attrs then 90 82 report_disallowed_attr name_lower "xml:base" collector 91 91 - end; 83 83 + | None -> ()); 92 84 93 85 (* Check for xmlns:* prefixed attributes - not allowed in HTML *) 94 86 (* Standard xmlns declarations are allowed but custom prefixes are not *) 95 95 - if namespace = None then begin 87 87 + (match namespace with 88 88 + | Some _ -> () 89 89 + | None -> 96 90 List.iter (fun (attr_name, _) -> 97 91 let attr_lower = String.lowercase_ascii attr_name in 98 98 - if String.length attr_lower > 6 && String.sub attr_lower 0 6 = "xmlns:" then begin 92 92 + if String.starts_with ~prefix:"xmlns:" attr_lower then begin 99 93 let prefix = String.sub attr_lower 6 (String.length attr_lower - 6) in 100 94 (* Only xmlns:xlink (with correct value) and xmlns:xml are allowed *) 101 95 if prefix <> "xlink" && prefix <> "xml" then 102 96 Message_collector.add_typed collector 103 97 (`Attr (`Not_allowed_here (`Attr attr_name))) 104 98 end 105 105 - ) attrs 106 106 - end; 99 99 + ) attrs); 107 100 108 101 (* Check SVG element restrictions - works in both HTML-embedded and XHTML SVG *) 109 102 (* xml:id is never valid on SVG elements in HTML5 *) 110 103 if List.mem name_lower svg_no_xml_id then begin 111 111 - if has_attr "xml:id" attrs then 104 104 + if Attr_utils.has_attr "xml:id" attrs then 112 105 report_disallowed_attr name_lower "xml:id" collector 113 106 end; 114 107 115 108 (* SVG feConvolveMatrix requires order attribute *) 116 109 if name_lower = "feconvolvematrix" then begin 117 117 - if not (has_attr "order" attrs) then 110 110 + if not (Attr_utils.has_attr "order" attrs) then 118 111 Message_collector.add_typed collector 119 112 (`Svg (`Missing_attr (`Elem "feConvolveMatrix", `Attr "order"))) 120 113 end; 121 114 122 115 (* Validate style type attribute - must be "text/css" or omitted *) 123 123 - if namespace = None && name_lower = "style" then begin 116 116 + (match namespace with 117 117 + | Some _ -> () 118 118 + | None when name_lower = "style" -> 124 119 List.iter (fun (attr_name, attr_value) -> 125 120 let attr_lower = String.lowercase_ascii attr_name in 126 121 if attr_lower = "type" then begin ··· 129 124 Message_collector.add_typed collector (`Misc `Style_type_invalid) 130 125 end 131 126 ) attrs 132 132 - end; 127 127 + | None -> ()); 133 128 134 129 (* Validate object element requires data or type attribute *) 135 135 - if namespace = None && name_lower = "object" then begin 136 136 - let has_data = has_attr "data" attrs in 137 137 - let has_type = has_attr "type" attrs in 130 130 + (match namespace with 131 131 + | Some _ -> () 132 132 + | None when name_lower = "object" -> 133 133 + let has_data = Attr_utils.has_attr "data" attrs in 134 134 + let has_type = Attr_utils.has_attr "type" attrs in 138 135 if not has_data && not has_type then 139 136 Message_collector.add_typed collector 140 137 (`Attr (`Missing (`Elem "object", `Attr "data"))) 141 141 - end; 138 138 + | None -> ()); 142 139 143 140 (* Validate link imagesizes/imagesrcset attributes *) 144 144 - if namespace = None && name_lower = "link" then begin 145 145 - let has_imagesizes = has_attr "imagesizes" attrs in 146 146 - let has_imagesrcset = has_attr "imagesrcset" attrs in 147 147 - let rel_value = get_attr "rel" attrs in 148 148 - let as_value = get_attr "as" attrs in 141 141 + (match namespace with 142 142 + | Some _ -> () 143 143 + | None when name_lower = "link" -> 144 144 + let has_imagesizes = Attr_utils.has_attr "imagesizes" attrs in 145 145 + let has_imagesrcset = Attr_utils.has_attr "imagesrcset" attrs in 146 146 + let rel_value = Attr_utils.get_attr "rel" attrs in 147 147 + let as_value = Attr_utils.get_attr "as" attrs in 149 148 150 149 (* imagesizes requires imagesrcset *) 151 150 if has_imagesizes && not has_imagesrcset then ··· 175 174 if not rel_is_preload then 176 175 Message_collector.add_typed collector (`Link `As_requires_preload) 177 176 | None -> ()) 178 178 - end; 177 177 + | None -> ()); 179 178 180 179 (* Validate img usemap attribute - must be hash-name reference with content *) 181 181 - if namespace = None && name_lower = "img" then begin 180 180 + (match namespace with 181 181 + | Some _ -> () 182 182 + | None when name_lower = "img" -> 182 183 List.iter (fun (attr_name, attr_value) -> 183 184 let attr_lower = String.lowercase_ascii attr_name in 184 185 if attr_lower = "usemap" then begin ··· 189 190 attr_value attr_name name)))) 190 191 end 191 192 ) attrs 192 192 - end; 193 193 + | None -> ()); 193 194 194 195 (* Validate embed type attribute - must be valid MIME type *) 195 195 - if namespace = None && name_lower = "embed" then begin 196 196 + (match namespace with 197 197 + | Some _ -> () 198 198 + | None when name_lower = "embed" -> 196 199 List.iter (fun (attr_name, attr_value) -> 197 200 let attr_lower = String.lowercase_ascii attr_name in 198 201 if attr_lower = "type" then begin ··· 205 208 attr_value attr_name name msg)))) 206 209 end 207 210 ) attrs 208 208 - end; 211 211 + | None -> ()); 209 212 210 213 (* Validate width/height on embed and img - must be non-negative integers *) 211 211 - if namespace = None && (name_lower = "embed" || name_lower = "img" || 212 212 - name_lower = "video" || name_lower = "canvas" || 213 213 - name_lower = "iframe" || name_lower = "source") then begin 214 214 + let is_dimension_element = name_lower = "embed" || name_lower = "img" || 215 215 + name_lower = "video" || name_lower = "canvas" || 216 216 + name_lower = "iframe" || name_lower = "source" in 217 217 + (match namespace with 218 218 + | Some _ -> () 219 219 + | None when is_dimension_element -> 214 220 List.iter (fun (attr_name, attr_value) -> 215 221 let attr_lower = String.lowercase_ascii attr_name in 216 222 if attr_lower = "width" || attr_lower = "height" then begin ··· 255 261 end 256 262 end 257 263 ) attrs 258 258 - end; 264 264 + | None -> ()); 259 265 260 266 (* Validate area[shape=default] cannot have coords *) 261 261 - if namespace = None && name_lower = "area" then begin 262 262 - let shape_value = get_attr "shape" attrs in 263 263 - match shape_value with 267 267 + (match namespace with 268 268 + | Some _ -> () 269 269 + | None when name_lower = "area" -> 270 270 + (match Attr_utils.get_attr "shape" attrs with 264 271 | Some s when String.lowercase_ascii (String.trim s) = "default" -> 265 265 - if has_attr "coords" attrs then 272 272 + if Attr_utils.has_attr "coords" attrs then 266 273 Message_collector.add_typed collector 267 274 (`Attr (`Not_allowed (`Attr "coords", `Elem "area"))) 268 268 - | _ -> () 269 269 - end; 275 275 + | _ -> ()) 276 276 + | None -> ()); 270 277 271 278 (* Validate bdo element requires dir attribute, and dir cannot be "auto" *) 272 272 - if namespace = None && name_lower = "bdo" then begin 273 273 - let dir_value = get_attr "dir" attrs in 274 274 - match dir_value with 279 279 + (match namespace with 280 280 + | Some _ -> () 281 281 + | None when name_lower = "bdo" -> 282 282 + (match Attr_utils.get_attr "dir" attrs with 275 283 | None -> 276 284 Message_collector.add_typed collector (`Misc `Bdo_missing_dir) 277 285 | Some v when String.lowercase_ascii (String.trim v) = "auto" -> 278 286 Message_collector.add_typed collector (`Misc `Bdo_dir_auto) 279 279 - | _ -> () 280 280 - end; 287 287 + | _ -> ()) 288 288 + | None -> ()); 281 289 282 290 (* Validate input list attribute - only allowed for certain types *) 283 283 - if namespace = None && name_lower = "input" then begin 284 284 - if has_attr "list" attrs then begin 285 285 - let input_type = match get_attr "type" attrs with 286 286 - | Some t -> String.lowercase_ascii (String.trim t) 287 287 - | None -> "text" (* default type is text *) 288 288 - in 291 291 + (match namespace with 292 292 + | Some _ -> () 293 293 + | None when name_lower = "input" -> 294 294 + if Attr_utils.has_attr "list" attrs then begin 295 295 + let input_type = Attr_utils.get_attr_or "type" ~default:"text" attrs 296 296 + |> String.trim |> String.lowercase_ascii in 289 297 if not (List.mem input_type input_types_allowing_list) then 290 298 Message_collector.add_typed collector (`Input `List_not_allowed) 291 299 end 292 292 - end; 300 300 + | None -> ()); 293 301 294 302 (* Validate data-* attributes *) 295 295 - if namespace = None then begin 303 303 + (match namespace with 304 304 + | Some _ -> () 305 305 + | None -> 296 306 List.iter (fun (attr_name, _) -> 297 307 let attr_lower = String.lowercase_ascii attr_name in 298 308 (* Check if it starts with "data-" *) 299 299 - if String.length attr_lower >= 5 && String.sub attr_lower 0 5 = "data-" then begin 309 309 + if String.starts_with ~prefix:"data-" attr_lower then begin 300 310 let after_prefix = String.sub attr_lower 5 (String.length attr_lower - 5) in 301 311 (* Check if it's exactly "data-" with nothing after *) 302 312 if after_prefix = "" then ··· 306 316 Message_collector.add_typed collector 307 317 (`Attr (`Data_invalid_name (`Reason "must be XML 1.0 4th ed. plus Namespaces NCNames"))) 308 318 end 309 309 - ) attrs 310 310 - end; 319 319 + ) attrs); 311 320 312 321 (* Validate xml:lang must have matching lang attribute - only in HTML mode, not XHTML *) 313 313 - if namespace = None && not state.is_xhtml then begin 314 314 - let xmllang_value = get_attr "xml:lang" attrs in 315 315 - let lang_value = get_attr "lang" attrs in 316 316 - match xmllang_value with 322 322 + (match namespace with 323 323 + | Some _ -> () 324 324 + | None when not state.is_xhtml -> 325 325 + let xmllang_value = Attr_utils.get_attr "xml:lang" attrs in 326 326 + let lang_value = Attr_utils.get_attr "lang" attrs in 327 327 + (match xmllang_value with 317 328 | Some xmllang -> 318 329 (match lang_value with 319 330 | None -> 320 320 - (* xml:lang without lang attribute *) 321 331 Message_collector.add_typed collector (`I18n `Xml_lang_without_lang) 322 332 | Some lang when String.lowercase_ascii lang <> String.lowercase_ascii xmllang -> 323 323 - (* xml:lang and lang have different values - "lang present with same value" message *) 324 333 Message_collector.add_typed collector (`I18n `Xml_lang_without_lang) 325 334 | _ -> ()) 326 326 - | None -> () 327 327 - end; 335 335 + | None -> ()) 336 336 + | None -> ()); 328 337 329 338 (* Validate spellcheck attribute - must be "true" or "false" or empty *) 330 330 - if namespace = None then begin 339 339 + (match namespace with 340 340 + | Some _ -> () 341 341 + | None -> 331 342 List.iter (fun (attr_name, attr_value) -> 332 343 let attr_lower = String.lowercase_ascii attr_name in 333 344 if attr_lower = "spellcheck" then begin ··· 336 347 Message_collector.add_typed collector 337 348 (`Attr (`Bad_value (`Elem name, `Attr attr_name, `Value attr_value, `Reason ""))) 338 349 end 339 339 - ) attrs 340 340 - end; 350 350 + ) attrs); 341 351 342 352 (* Validate enterkeyhint attribute - must be one of specific values *) 343 343 - if namespace = None then begin 353 353 + (match namespace with 354 354 + | Some _ -> () 355 355 + | None -> 344 356 let valid_enterkeyhint = ["enter"; "done"; "go"; "next"; "previous"; "search"; "send"] in 345 357 List.iter (fun (attr_name, attr_value) -> 346 358 let attr_lower = String.lowercase_ascii attr_name in ··· 350 362 Message_collector.add_typed collector 351 363 (`Attr (`Bad_value (`Elem name, `Attr attr_name, `Value attr_value, `Reason ""))) 352 364 end 353 353 - ) attrs 354 354 - end; 365 365 + ) attrs); 355 366 356 367 (* Validate headingoffset attribute - must be a number between 0 and 8 *) 357 357 - if namespace = None then begin 368 368 + (match namespace with 369 369 + | Some _ -> () 370 370 + | None -> 358 371 List.iter (fun (attr_name, attr_value) -> 359 372 let attr_lower = String.lowercase_ascii attr_name in 360 373 if attr_lower = "headingoffset" then begin ··· 370 383 if not is_valid then 371 384 Message_collector.add_typed collector (`Misc `Headingoffset_invalid) 372 385 end 373 373 - ) attrs 374 374 - end; 386 386 + ) attrs); 375 387 376 388 (* Validate accesskey attribute - each key label must be a single code point *) 377 377 - if namespace = None then begin 389 389 + (match namespace with 390 390 + | Some _ -> () 391 391 + | None -> 378 392 List.iter (fun (attr_name, attr_value) -> 379 393 let attr_lower = String.lowercase_ascii attr_name in 380 394 if attr_lower = "accesskey" then begin ··· 419 433 in 420 434 find_duplicates [] keys 421 435 end 422 422 - ) attrs 423 423 - end; 436 436 + ) attrs); 424 437 425 438 (* Validate that command and popovertarget cannot have aria-expanded *) 426 426 - if namespace = None && name_lower = "button" then begin 427 427 - let has_command = has_attr "command" attrs in 428 428 - let has_popovertarget = has_attr "popovertarget" attrs in 429 429 - let has_aria_expanded = has_attr "aria-expanded" attrs in 439 439 + (match namespace with 440 440 + | Some _ -> () 441 441 + | None when name_lower = "button" -> 442 442 + let has_command = Attr_utils.has_attr "command" attrs in 443 443 + let has_popovertarget = Attr_utils.has_attr "popovertarget" attrs in 444 444 + let has_aria_expanded = Attr_utils.has_attr "aria-expanded" attrs in 430 445 431 446 if has_command && has_aria_expanded then 432 447 Message_collector.add_typed collector ··· 437 452 Message_collector.add_typed collector 438 453 (`Attr (`Not_allowed_when (`Attr "aria-expanded", `Elem name, 439 454 `Condition "a \xe2\x80\x9cpopovertarget\xe2\x80\x9d attribute"))) 440 440 - end; 455 455 + | None -> ()); 441 456 442 457 (* Note: data-* uppercase check requires XML parsing which preserves case. 443 458 The HTML5 parser normalizes attribute names to lowercase, so this check ··· 446 461 ignore state.is_xhtml; 447 462 448 463 (* Validate media attribute on link, style, source elements *) 449 449 - if namespace = None && (name_lower = "link" || name_lower = "style" || name_lower = "source") then begin 464 464 + let is_media_element = name_lower = "link" || name_lower = "style" || name_lower = "source" in 465 465 + (match namespace with 466 466 + | Some _ -> () 467 467 + | None when is_media_element -> 450 468 List.iter (fun (attr_name, attr_value) -> 451 469 let attr_lower = String.lowercase_ascii attr_name in 452 470 if attr_lower = "media" then begin ··· 462 480 end 463 481 end 464 482 ) attrs 465 465 - end; 483 483 + | None -> ()); 466 484 467 485 (* Validate RDFa prefix attribute - space-separated list of prefix:iri pairs *) 468 468 - if namespace = None then begin 486 486 + (match namespace with 487 487 + | Some _ -> () 488 488 + | None -> 469 489 List.iter (fun (attr_name, attr_value) -> 470 490 let attr_lower = String.lowercase_ascii attr_name in 471 491 if attr_lower = "prefix" then begin ··· 487 507 end 488 508 end 489 509 end 490 490 - ) attrs 491 491 - end 510 510 + ) attrs) 492 511 493 512 let end_element _state ~name:_ ~namespace:_ _collector = () 494 513 let characters _state _text _collector = ()

+5 -12

lib/htmlrw_check/specialized/base_checker.ml

··· 11 11 let reset state = 12 12 state.seen_link_or_script <- false 13 13 14 14 - (** Check if an attribute list contains a specific attribute. *) 15 15 - let has_attr name attrs = 16 16 - List.exists (fun (attr_name, _) -> String.lowercase_ascii attr_name = name) attrs 17 17 - 18 14 let start_element state ~name ~namespace ~attrs collector = 19 19 - if namespace <> None then () 20 20 - else begin 21 21 - let name_lower = String.lowercase_ascii name in 22 22 - match name_lower with 15 15 + match namespace with 16 16 + | Some _ -> () 17 17 + | None -> 18 18 + match String.lowercase_ascii name with 23 19 | "link" | "script" -> 24 20 state.seen_link_or_script <- true 25 21 | "base" -> 26 22 if state.seen_link_or_script then 27 23 Message_collector.add_typed collector (`Misc `Base_after_link_script); 28 24 (* base element must have href or target attribute *) 29 29 - let has_href = has_attr "href" attrs in 30 30 - let has_target = has_attr "target" attrs in 31 31 - if not has_href && not has_target then 25 25 + if not (Attr_utils.has_attr "href" attrs || Attr_utils.has_attr "target" attrs) then 32 26 Message_collector.add_typed collector (`Misc `Base_missing_href_or_target) 33 27 | _ -> () 34 34 - end 35 28 36 29 let end_element _state ~name:_ ~namespace:_ _collector = () 37 30 let characters _state _text _collector = ()

+1 -6

lib/htmlrw_check/specialized/dl_checker.ml

··· 57 57 | ctx :: _ -> Some ctx 58 58 | [] -> None 59 59 60 60 - let get_attr name attrs = 61 61 - List.find_map (fun (n, v) -> 62 62 - if String.lowercase_ascii n = name then Some v else None 63 63 - ) attrs 64 64 - 65 60 let start_element state ~name ~namespace ~attrs collector = 66 61 let name_lower = String.lowercase_ascii name in 67 62 ··· 115 110 Message_collector.add_typed collector 116 111 (`Element (`Not_allowed_as_child (`Child "div", `Parent "dl"))); 117 112 (* Check that role is only presentation or none *) 118 118 - (match get_attr "role" attrs with 113 113 + (match Attr_utils.get_attr "role" attrs with 119 114 | Some role_value -> 120 115 let role_lower = String.lowercase_ascii (String.trim role_value) in 121 116 if role_lower <> "presentation" && role_lower <> "none" then

+42 -76

lib/htmlrw_check/specialized/picture_checker.ml

··· 66 66 state.always_matching_is_media_all <- false; 67 67 state.always_matching_is_media_empty <- false 68 68 69 69 - (** Check if an attribute list contains a specific attribute. *) 70 70 - let has_attr name attrs = 71 71 - List.exists (fun (attr_name, _) -> String.lowercase_ascii attr_name = name) attrs 72 72 - 73 69 (** Report disallowed attribute error *) 74 70 let report_disallowed_attr element attr collector = 75 71 Message_collector.add_typed collector ··· 80 76 Message_collector.add_typed collector 81 77 (`Element (`Not_allowed_as_child (`Child child, `Parent parent))) 82 78 79 79 + let check_disallowed_attrs element disallowed_list attrs collector = 80 80 + List.iter (fun attr -> 81 81 + if Attr_utils.has_attr attr attrs then 82 82 + report_disallowed_attr element attr collector 83 83 + ) disallowed_list 84 84 + 83 85 let check_picture_attrs attrs collector = 84 84 - List.iter (fun disallowed -> 85 85 - if has_attr disallowed attrs then 86 86 - report_disallowed_attr "picture" disallowed collector 87 87 - ) disallowed_picture_attrs 86 86 + check_disallowed_attrs "picture" disallowed_picture_attrs attrs collector 88 87 89 88 let check_source_attrs_in_picture attrs collector = 90 90 - List.iter (fun disallowed -> 91 91 - if has_attr disallowed attrs then 92 92 - report_disallowed_attr "source" disallowed collector 93 93 - ) disallowed_source_attrs_in_picture; 94 94 - (* source in picture requires srcset *) 95 95 - if not (has_attr "srcset" attrs) then 96 96 - Message_collector.add_typed collector 97 97 - (`Srcset `Source_missing_srcset) 89 89 + check_disallowed_attrs "source" disallowed_source_attrs_in_picture attrs collector; 90 90 + if not (Attr_utils.has_attr "srcset" attrs) then 91 91 + Message_collector.add_typed collector (`Srcset `Source_missing_srcset) 98 92 99 93 let check_img_attrs attrs collector = 100 100 - List.iter (fun disallowed -> 101 101 - if has_attr disallowed attrs then 102 102 - report_disallowed_attr "img" disallowed collector 103 103 - ) disallowed_img_attrs 94 94 + check_disallowed_attrs "img" disallowed_img_attrs attrs collector 104 95 105 96 let start_element state ~name ~namespace ~attrs collector = 106 97 let name_lower = String.lowercase_ascii name in ··· 112 103 end; 113 104 114 105 (* Rest of checks only apply to HTML namespace elements *) 115 115 - if namespace = None then begin 116 116 - match name_lower with 106 106 + match namespace with 107 107 + | Some _ -> () 108 108 + | None -> 109 109 + (match name_lower with 117 110 | "picture" -> 118 111 (* Check if picture is in a disallowed parent context *) 119 112 (match state.parent_stack with ··· 124 117 check_picture_attrs attrs collector; 125 118 state.in_picture <- true; 126 119 state.has_img_in_picture <- false; 127 127 - state.picture_depth <- 0; (* Will be incremented to 1 at end of function *) 120 120 + state.picture_depth <- 0; 128 121 state.children_in_picture <- []; 129 122 state.last_was_img <- false; 130 123 state.has_source_after_img <- false; ··· 136 129 state.children_in_picture <- "source" :: state.children_in_picture; 137 130 if state.last_was_img then 138 131 state.has_source_after_img <- true; 139 139 - (* Check for always-matching source followed by another source *) 140 132 if state.has_always_matching_source then 141 133 state.source_after_always_matching <- true; 142 142 - (* A source is "always matching" if it has: 143 143 - - no media and no type attribute, OR 144 144 - - media attribute with empty/whitespace-only value, OR 145 145 - - media="all" (with optional whitespace) *) 146 146 - let media_value = List.find_map (fun (attr_name, v) -> 147 147 - if String.lowercase_ascii attr_name = "media" then Some v else None 148 148 - ) attrs in 149 149 - let has_type = has_attr "type" attrs in 134 134 + (* A source is "always matching" if it has no media/type, or media="" or media="all" *) 135 135 + let media_value = Attr_utils.get_attr "media" attrs in 136 136 + let has_type = Attr_utils.has_attr "type" attrs in 150 137 let is_media_all = match media_value with 151 138 | Some v -> String.lowercase_ascii (String.trim v) = "all" 152 152 - | None -> false 153 153 - in 139 139 + | None -> false in 154 140 let is_media_empty = match media_value with 155 141 | Some v -> String.trim v = "" 156 156 - | None -> false 157 157 - in 142 142 + | None -> false in 158 143 let is_always_matching = match media_value with 159 159 - | None -> not has_type (* no media, check if no type either *) 144 144 + | None -> not has_type 160 145 | Some v -> 161 146 let trimmed = String.trim v in 162 147 trimmed = "" || String.lowercase_ascii trimmed = "all" 163 148 in 164 149 if is_always_matching then begin 165 150 state.has_always_matching_source <- true; 166 166 - if is_media_all then 167 167 - state.always_matching_is_media_all <- true 168 168 - else if is_media_empty then 169 169 - state.always_matching_is_media_empty <- true 151 151 + (* Only set flags to true, never reset to false *) 152 152 + if is_media_all then state.always_matching_is_media_all <- true; 153 153 + if is_media_empty then state.always_matching_is_media_empty <- true 170 154 end 171 155 172 156 | "img" when state.in_picture && state.picture_depth = 1 -> ··· 174 158 state.has_img_in_picture <- true; 175 159 state.children_in_picture <- "img" :: state.children_in_picture; 176 160 state.last_was_img <- true; 177 177 - (* Check for multiple img elements *) 178 178 - let img_count = List.filter (fun c -> c = "img") state.children_in_picture |> List.length in 161 161 + let img_count = List.length (List.filter (( = ) "img") state.children_in_picture) in 179 162 if img_count > 1 then 180 163 report_disallowed_child "picture" "img" collector; 181 181 - (* Check if always-matching source is followed by img with srcset *) 182 182 - if state.has_always_matching_source && has_attr "srcset" attrs then begin 183 183 - if state.always_matching_is_media_all then 184 184 - Message_collector.add_typed collector (`Misc `Media_all) 185 185 - else if state.always_matching_is_media_empty then 186 186 - Message_collector.add_typed collector (`Misc `Media_empty) 187 187 - else 188 188 - Message_collector.add_typed collector (`Srcset `Source_needs_media_or_type) 189 189 - end 164 164 + if state.has_always_matching_source && Attr_utils.has_attr "srcset" attrs then 165 165 + Message_collector.add_typed collector 166 166 + (if state.always_matching_is_media_all then `Misc `Media_all 167 167 + else if state.always_matching_is_media_empty then `Misc `Media_empty 168 168 + else `Srcset `Source_needs_media_or_type) 190 169 191 170 | "script" when state.in_picture && state.picture_depth = 1 -> 192 171 state.children_in_picture <- "script" :: state.children_in_picture ··· 197 176 | "img" -> 198 177 check_img_attrs attrs collector 199 178 200 200 - | _ -> () 201 201 - end; 179 179 + | _ -> ()); 202 180 203 181 (* Track depth when inside picture *) 204 182 if state.in_picture then ··· 209 187 state.parent_stack <- name_lower :: state.parent_stack 210 188 211 189 let end_element state ~name ~namespace collector = 212 212 - if namespace <> None then () 213 213 - else begin 190 190 + match namespace with 191 191 + | Some _ -> () 192 192 + | None -> 214 193 let name_lower = String.lowercase_ascii name in 215 194 216 216 - (* Track depth *) 217 195 if state.in_picture then 218 196 state.picture_depth <- state.picture_depth - 1; 219 197 220 198 if name_lower = "picture" && state.picture_depth = 0 then begin 221 221 - (* Check if picture had img child *) 222 199 if not state.has_img_in_picture then 223 223 - Message_collector.add_typed collector 224 224 - (`Srcset `Picture_missing_img); 225 225 - (* Check for source after img *) 200 200 + Message_collector.add_typed collector (`Srcset `Picture_missing_img); 226 201 if state.has_source_after_img then 227 202 report_disallowed_child "picture" "source" collector; 228 228 - (* Check for source after always-matching source *) 229 229 - if state.source_after_always_matching then begin 230 230 - if state.always_matching_is_media_all then 231 231 - Message_collector.add_typed collector (`Misc `Media_all) 232 232 - else if state.always_matching_is_media_empty then 233 233 - Message_collector.add_typed collector (`Misc `Media_empty) 234 234 - else 235 235 - Message_collector.add_typed collector (`Srcset `Source_needs_media_or_type) 236 236 - end; 237 237 - 203 203 + if state.source_after_always_matching then 204 204 + Message_collector.add_typed collector 205 205 + (if state.always_matching_is_media_all then `Misc `Media_all 206 206 + else if state.always_matching_is_media_empty then `Misc `Media_empty 207 207 + else `Srcset `Source_needs_media_or_type); 238 208 state.in_picture <- false 239 209 end; 240 210 241 241 - (* Pop from parent stack *) 242 242 - state.parent_stack <- (match state.parent_stack with 243 243 - | _ :: rest -> rest 244 244 - | [] -> []) 245 245 - end 211 211 + state.parent_stack <- match state.parent_stack with _ :: rest -> rest | [] -> [] 246 212 247 213 let characters state text collector = 248 214 (* Text in picture element is not allowed *)

+4 -8

lib/htmlrw_check/specialized/source_checker.ml

··· 23 23 | ctx :: _ -> ctx 24 24 | [] -> Other 25 25 26 26 - (** Check if an attribute list contains a specific attribute. *) 27 27 - let has_attr name attrs = 28 28 - List.exists (fun (attr_name, _) -> String.lowercase_ascii attr_name = name) attrs 29 29 - 30 26 let start_element state ~name ~namespace ~attrs collector = 31 27 if namespace <> None then () 32 28 else begin ··· 42 38 let ctx = current_context state in 43 39 begin match ctx with 44 40 | Video | Audio -> 45 45 - if has_attr "srcset" attrs then 41 41 + if Attr_utils.has_attr "srcset" attrs then 46 42 Message_collector.add_typed collector 47 43 (`Attr (`Not_allowed (`Attr "srcset", `Elem "source"))); 48 48 - if has_attr "sizes" attrs then 44 44 + if Attr_utils.has_attr "sizes" attrs then 49 45 Message_collector.add_typed collector 50 46 (`Attr (`Not_allowed (`Attr "sizes", `Elem "source"))); 51 51 - if has_attr "width" attrs then 47 47 + if Attr_utils.has_attr "width" attrs then 52 48 Message_collector.add_typed collector 53 49 (`Attr (`Not_allowed (`Attr "width", `Elem "source"))); 54 54 - if has_attr "height" attrs then 50 50 + if Attr_utils.has_attr "height" attrs then 55 51 Message_collector.add_typed collector 56 52 (`Attr (`Not_allowed (`Attr "height", `Elem "source"))) 57 53 | Picture | Other -> ()

+3 -9

lib/htmlrw_check/specialized/srcset_sizes_checker.ml

··· 14 14 let create () = () 15 15 let reset _state = () 16 16 17 17 - (** Get attribute value *) 18 18 - let get_attr name attrs = 19 19 - List.find_map (fun (n, v) -> 20 20 - if String.lowercase_ascii n = name then Some v else None 21 21 - ) attrs 22 22 - 23 17 (** Split string on a character while respecting parentheses *) 24 18 let split_respecting_parens ~sep s = 25 19 let len = String.length s in ··· 971 965 972 966 (* SVG image elements should not have srcset *) 973 967 if namespace <> None && name_lower = "image" then begin 974 974 - if get_attr "srcset" attrs <> None then 968 968 + if Attr_utils.get_attr "srcset" attrs <> None then 975 969 Message_collector.add_typed collector 976 970 (`Attr (`Not_allowed (`Attr "srcset", `Elem "image"))) 977 971 end; ··· 980 974 else begin 981 975 (* Check sizes and srcset on img and source *) 982 976 if name_lower = "img" || name_lower = "source" then begin 983 983 - let sizes_value = get_attr "sizes" attrs in 984 984 - let srcset_value = get_attr "srcset" attrs in 977 977 + let sizes_value = Attr_utils.get_attr "sizes" attrs in 978 978 + let srcset_value = Attr_utils.get_attr "srcset" attrs in 985 979 let has_sizes = sizes_value <> None in 986 980 let has_srcset = srcset_value <> None in 987 981

+1 -2

lib/htmlrw_check/specialized/xhtml_content_checker.ml

··· 46 46 (* Check if data-* attribute has uppercase characters *) 47 47 let check_data_attr_case attrs collector = 48 48 List.iter (fun (attr_name, _) -> 49 49 - if String.length attr_name > 5 && 50 50 - String.sub attr_name 0 5 = "data-" then 49 49 + if String.starts_with ~prefix:"data-" attr_name then 51 50 let suffix = String.sub attr_name 5 (String.length attr_name - 5) in 52 51 if String.exists (fun c -> c >= 'A' && c <= 'Z') suffix then 53 52 Message_collector.add_typed collector (`Attr `Data_uppercase)