+3 -1

lib/html5_checker/checker_registry.ml

··· 37 37 Hashtbl.replace reg "option" Option_checker.checker; 38 38 Hashtbl.replace reg "language" Language_checker.checker; 39 39 Hashtbl.replace reg "microdata" Microdata_checker.checker; 40 40 - (* Hashtbl.replace reg "table" Table_checker.checker; *) 40 40 + Hashtbl.replace reg "importmap" Importmap_checker.checker; 41 41 + Hashtbl.replace reg "table" Table_checker.checker; 42 42 + Hashtbl.replace reg "mime-type" Mime_type_checker.checker; 41 43 (* Hashtbl.replace reg "heading" Heading_checker.checker; *) 42 44 (* Hashtbl.replace reg "content" Content_checker.checker; *) 43 45 reg

+336

lib/html5_checker/specialized/importmap_checker.ml

··· 1 1 + (** Importmap validation checker. 2 2 + 3 3 + Validates that <script type="importmap"> elements contain valid JSON 4 4 + and conform to importmap structural requirements. *) 5 5 + 6 6 + type state = { 7 7 + mutable in_importmap : bool; 8 8 + content : Buffer.t; 9 9 + } 10 10 + 11 11 + let create () = { 12 12 + in_importmap = false; 13 13 + content = Buffer.create 256; 14 14 + } 15 15 + 16 16 + let reset state = 17 17 + state.in_importmap <- false; 18 18 + Buffer.clear state.content 19 19 + 20 20 + (** Simple JSON value representation *) 21 21 + type json = 22 22 + | JNull 23 23 + | JBool of bool 24 24 + | JNumber of float 25 25 + | JString of string 26 26 + | JArray of json list 27 27 + | JObject of (string * json) list 28 28 + 29 29 + (** Simple JSON parser *) 30 30 + let parse_json s_orig = 31 31 + let s = String.trim s_orig in 32 32 + let len = String.length s in 33 33 + if len = 0 then Error "Empty JSON" 34 34 + else 35 35 + let pos = ref 0 in 36 36 + 37 37 + let skip_ws () = 38 38 + while !pos < len && (s.[!pos] = ' ' || s.[!pos] = '\t' || s.[!pos] = '\n' || s.[!pos] = '\r') do 39 39 + incr pos 40 40 + done 41 41 + in 42 42 + 43 43 + let peek () = if !pos < len then Some s.[!pos] else None in 44 44 + let consume () = let c = s.[!pos] in incr pos; c in 45 45 + 46 46 + let rec parse_value () = 47 47 + skip_ws (); 48 48 + match peek () with 49 49 + | None -> Error "Unexpected end of input" 50 50 + | Some '{' -> parse_object () 51 51 + | Some '[' -> parse_array () 52 52 + | Some '"' -> parse_string () 53 53 + | Some 't' -> parse_true () 54 54 + | Some 'f' -> parse_false () 55 55 + | Some 'n' -> parse_null () 56 56 + | Some c when c = '-' || (c >= '0' && c <= '9') -> parse_number () 57 57 + | Some _ -> Error "Unexpected character" 58 58 + 59 59 + and parse_object () = 60 60 + ignore (consume ()); (* consume { *) 61 61 + skip_ws (); 62 62 + match peek () with 63 63 + | Some '}' -> ignore (consume ()); Ok (JObject []) 64 64 + | _ -> 65 65 + let rec parse_members acc = 66 66 + skip_ws (); 67 67 + match parse_string () with 68 68 + | Error e -> Error e 69 69 + | Ok (JString key) -> 70 70 + skip_ws (); 71 71 + (match peek () with 72 72 + | Some ':' -> 73 73 + ignore (consume ()); 74 74 + (match parse_value () with 75 75 + | Error e -> Error e 76 76 + | Ok value -> 77 77 + skip_ws (); 78 78 + let acc' = (key, value) :: acc in 79 79 + match peek () with 80 80 + | Some ',' -> ignore (consume ()); parse_members acc' 81 81 + | Some '}' -> ignore (consume ()); Ok (JObject (List.rev acc')) 82 82 + | _ -> Error "Expected ',' or '}'") 83 83 + | _ -> Error "Expected ':'") 84 84 + | Ok _ -> Error "Expected string key" 85 85 + in 86 86 + parse_members [] 87 87 + 88 88 + and parse_array () = 89 89 + ignore (consume ()); (* consume [ *) 90 90 + skip_ws (); 91 91 + match peek () with 92 92 + | Some ']' -> ignore (consume ()); Ok (JArray []) 93 93 + | _ -> 94 94 + let rec parse_elements acc = 95 95 + match parse_value () with 96 96 + | Error e -> Error e 97 97 + | Ok value -> 98 98 + skip_ws (); 99 99 + let acc' = value :: acc in 100 100 + match peek () with 101 101 + | Some ',' -> ignore (consume ()); parse_elements acc' 102 102 + | Some ']' -> ignore (consume ()); Ok (JArray (List.rev acc')) 103 103 + | _ -> Error "Expected ',' or ']'" 104 104 + in 105 105 + parse_elements [] 106 106 + 107 107 + and parse_string () = 108 108 + skip_ws (); 109 109 + match peek () with 110 110 + | Some '"' -> 111 111 + ignore (consume ()); 112 112 + let buf = Buffer.create 32 in 113 113 + let rec read () = 114 114 + match peek () with 115 115 + | None -> Error "Unterminated string" 116 116 + | Some '"' -> ignore (consume ()); Ok (JString (Buffer.contents buf)) 117 117 + | Some '\\' -> 118 118 + ignore (consume ()); 119 119 + (match peek () with 120 120 + | None -> Error "Unterminated escape" 121 121 + | Some c -> ignore (consume ()); Buffer.add_char buf c; read ()) 122 122 + | Some c -> ignore (consume ()); Buffer.add_char buf c; read () 123 123 + in 124 124 + read () 125 125 + | _ -> Error "Expected string" 126 126 + 127 127 + and parse_number () = 128 128 + let start = !pos in 129 129 + if peek () = Some '-' then incr pos; 130 130 + while !pos < len && s.[!pos] >= '0' && s.[!pos] <= '9' do incr pos done; 131 131 + if !pos < len && s.[!pos] = '.' then begin 132 132 + incr pos; 133 133 + while !pos < len && s.[!pos] >= '0' && s.[!pos] <= '9' do incr pos done 134 134 + end; 135 135 + if !pos < len && (s.[!pos] = 'e' || s.[!pos] = 'E') then begin 136 136 + incr pos; 137 137 + if !pos < len && (s.[!pos] = '+' || s.[!pos] = '-') then incr pos; 138 138 + while !pos < len && s.[!pos] >= '0' && s.[!pos] <= '9' do incr pos done 139 139 + end; 140 140 + let num_str = String.sub s start (!pos - start) in 141 141 + match float_of_string_opt num_str with 142 142 + | Some f -> Ok (JNumber f) 143 143 + | None -> Error "Invalid number" 144 144 + 145 145 + and parse_true () = 146 146 + if !pos + 4 <= len && String.sub s !pos 4 = "true" then 147 147 + (pos := !pos + 4; Ok (JBool true)) 148 148 + else Error "Expected 'true'" 149 149 + 150 150 + and parse_false () = 151 151 + if !pos + 5 <= len && String.sub s !pos 5 = "false" then 152 152 + (pos := !pos + 5; Ok (JBool false)) 153 153 + else Error "Expected 'false'" 154 154 + 155 155 + and parse_null () = 156 156 + if !pos + 4 <= len && String.sub s !pos 4 = "null" then 157 157 + (pos := !pos + 4; Ok JNull) 158 158 + else Error "Expected 'null'" 159 159 + in 160 160 + 161 161 + match parse_value () with 162 162 + | Error e -> Error e 163 163 + | Ok v -> 164 164 + skip_ws (); 165 165 + if !pos = len then Ok v 166 166 + else Error "Unexpected content after JSON" 167 167 + 168 168 + (** Validate importmap structure *) 169 169 + type importmap_error = 170 170 + | InvalidJSON of string 171 171 + | EmptyKey of string (* property name where empty key was found *) 172 172 + | NotObject of string (* property name that should be object but isn't *) 173 173 + | NotString of string (* property name that should be string but isn't *) 174 174 + | ForbiddenProperty of string 175 175 + | SlashKeyWithoutSlashValue of string (* property name where slash key doesn't have slash value *) 176 176 + | InvalidScopeKey (* scope key is not a valid URL *) 177 177 + | InvalidScopeValue of string (* scope value is not a valid URL *) 178 178 + 179 179 + (** Check if a string looks like a valid URL-like specifier for importmaps *) 180 180 + let is_valid_url_like s = 181 181 + if String.length s = 0 then false 182 182 + else 183 183 + (* Valid URL-like: starts with /, ./, ../, or has a scheme followed by :// or : *) 184 184 + let starts_with_slash = s.[0] = '/' in 185 185 + let starts_with_dot_slash = String.length s >= 2 && s.[0] = '.' && s.[1] = '/' in 186 186 + let starts_with_dot_dot_slash = String.length s >= 3 && s.[0] = '.' && s.[1] = '.' && s.[2] = '/' in 187 187 + let has_scheme = 188 188 + match String.index_opt s ':' with 189 189 + | None -> false 190 190 + | Some pos when pos > 0 -> 191 191 + (* Check that characters before : are valid scheme characters *) 192 192 + let scheme = String.sub s 0 pos in 193 193 + String.length scheme > 0 && 194 194 + String.for_all (fun c -> 195 195 + (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || 196 196 + (c >= '0' && c <= '9') || c = '+' || c = '-' || c = '.' 197 197 + ) scheme 198 198 + | _ -> false 199 199 + in 200 200 + starts_with_slash || starts_with_dot_slash || starts_with_dot_dot_slash || has_scheme 201 201 + 202 202 + let validate_importmap s = 203 203 + match parse_json s with 204 204 + | Error msg -> [InvalidJSON msg] 205 205 + | Ok json -> 206 206 + let errors = ref [] in 207 207 + let add_error e = errors := e :: !errors in 208 208 + 209 209 + (match json with 210 210 + | JObject members -> 211 211 + List.iter (fun (key, value) -> 212 212 + (* Check for forbidden top-level properties *) 213 213 + if key <> "imports" && key <> "scopes" && key <> "integrity" then 214 214 + add_error (ForbiddenProperty key); 215 215 + 216 216 + (* Check imports *) 217 217 + if key = "imports" then begin 218 218 + match value with 219 219 + | JObject import_members -> 220 220 + List.iter (fun (ikey, ivalue) -> 221 221 + if ikey = "" then add_error (EmptyKey "imports"); 222 222 + (* Check slash-ending consistency *) 223 223 + let key_ends_with_slash = String.length ikey > 0 && ikey.[String.length ikey - 1] = '/' in 224 224 + match ivalue with 225 225 + | JString v -> 226 226 + if key_ends_with_slash then begin 227 227 + let val_ends_with_slash = String.length v > 0 && v.[String.length v - 1] = '/' in 228 228 + if not val_ends_with_slash then 229 229 + add_error (SlashKeyWithoutSlashValue "imports") 230 230 + end 231 231 + | JNull -> () (* null is allowed *) 232 232 + | _ -> add_error (NotString ("imports[" ^ ikey ^ "]")) 233 233 + ) import_members 234 234 + | _ -> add_error (NotObject "imports") 235 235 + end; 236 236 + 237 237 + (* Check scopes *) 238 238 + if key = "scopes" then begin 239 239 + match value with 240 240 + | JObject scope_members -> 241 241 + List.iter (fun (skey, svalue) -> 242 242 + if skey = "" then add_error (EmptyKey "scopes"); 243 243 + (* Check that scope key is a valid URL *) 244 244 + if skey <> "" && not (is_valid_url_like skey) then 245 245 + add_error InvalidScopeKey; 246 246 + match svalue with 247 247 + | JObject scope_imports -> 248 248 + List.iter (fun (sikey, sivalue) -> 249 249 + if sikey = "" then add_error (EmptyKey ("scopes[" ^ skey ^ "]")); 250 250 + match sivalue with 251 251 + | JString v -> 252 252 + (* Check that scope value is a valid URL *) 253 253 + if not (is_valid_url_like v) then 254 254 + add_error (InvalidScopeValue sikey) 255 255 + | JNull -> () 256 256 + | _ -> add_error (NotString ("scopes[" ^ skey ^ "][" ^ sikey ^ "]")) 257 257 + ) scope_imports 258 258 + | _ -> add_error (NotObject ("scopes[" ^ skey ^ "]")) 259 259 + ) scope_members 260 260 + | _ -> add_error (NotObject "scopes") 261 261 + end 262 262 + ) members 263 263 + | _ -> add_error (NotObject "root")); 264 264 + 265 265 + List.rev !errors 266 266 + 267 267 + let start_element state ~name ~namespace ~attrs _collector = 268 268 + if namespace <> None then () 269 269 + else begin 270 270 + let name_lower = String.lowercase_ascii name in 271 271 + if name_lower = "script" then begin 272 272 + (* Check if type="importmap" *) 273 273 + let type_attr = List.find_opt (fun (n, _) -> 274 274 + String.lowercase_ascii n = "type" 275 275 + ) attrs in 276 276 + match type_attr with 277 277 + | Some (_, v) when String.lowercase_ascii v = "importmap" -> 278 278 + state.in_importmap <- true; 279 279 + Buffer.clear state.content 280 280 + | _ -> () 281 281 + end 282 282 + end 283 283 + 284 284 + let error_to_message = function 285 285 + | InvalidJSON _ -> 286 286 + "A script \xe2\x80\x9cscript\xe2\x80\x9d with a \xe2\x80\x9ctype\xe2\x80\x9d attribute whose value is \xe2\x80\x9cimportmap\xe2\x80\x9d must have valid JSON content." 287 287 + | EmptyKey prop -> 288 288 + Printf.sprintf "A specifier map defined in a \xe2\x80\x9c%s\xe2\x80\x9d property within the content of a \xe2\x80\x9cscript\xe2\x80\x9d element with a \xe2\x80\x9ctype\xe2\x80\x9d attribute whose value is \xe2\x80\x9cimportmap\xe2\x80\x9d must only contain non-empty keys." prop 289 289 + | NotObject prop -> 290 290 + Printf.sprintf "The value of the \xe2\x80\x9c%s\xe2\x80\x9d property within the content of a \xe2\x80\x9cscript\xe2\x80\x9d element with a \xe2\x80\x9ctype\xe2\x80\x9d attribute whose value is \xe2\x80\x9cimportmap\xe2\x80\x9d must be a JSON object." prop 291 291 + | NotString _ -> 292 292 + "A specifier map defined in a \xe2\x80\x9cimports\xe2\x80\x9d property within the content of a \xe2\x80\x9cscript\xe2\x80\x9d element with a \xe2\x80\x9ctype\xe2\x80\x9d attribute whose value is \xe2\x80\x9cimportmap\xe2\x80\x9d must only contain string values." 293 293 + | ForbiddenProperty prop -> 294 294 + Printf.sprintf "The \xe2\x80\x9c%s\xe2\x80\x9d property within the content of a \xe2\x80\x9cscript\xe2\x80\x9d element with a \xe2\x80\x9ctype\xe2\x80\x9d attribute whose value is \xe2\x80\x9cimportmap\xe2\x80\x9d is not an allowed property." prop 295 295 + | SlashKeyWithoutSlashValue prop -> 296 296 + Printf.sprintf "A specifier map defined in a \xe2\x80\x9c%s\xe2\x80\x9d property within the content of a \xe2\x80\x9cscript\xe2\x80\x9d element with a \xe2\x80\x9ctype\xe2\x80\x9d attribute whose value is \xe2\x80\x9cimportmap\xe2\x80\x9d must have values that end with \xe2\x80\x9c/\xe2\x80\x9d when its corresponding key ends with \xe2\x80\x9c/\xe2\x80\x9d." prop 297 297 + | InvalidScopeKey -> 298 298 + "The value of the \xe2\x80\x9cscopes\xe2\x80\x9d property within the content of a \xe2\x80\x9cscript\xe2\x80\x9d element with a \xe2\x80\x9ctype\xe2\x80\x9d attribute whose value is \xe2\x80\x9cimportmap\xe2\x80\x9d must be a JSON object whose keys are valid URL strings." 299 299 + | InvalidScopeValue _ -> 300 300 + "A specifier map defined in a \xe2\x80\x9cscopes\xe2\x80\x9d property within the content of a \xe2\x80\x9cscript\xe2\x80\x9d element with a \xe2\x80\x9ctype\xe2\x80\x9d attribute whose value is \xe2\x80\x9cimportmap\xe2\x80\x9d must only contain valid URL values." 301 301 + 302 302 + let end_element state ~name ~namespace collector = 303 303 + if namespace <> None then () 304 304 + else begin 305 305 + let name_lower = String.lowercase_ascii name in 306 306 + if name_lower = "script" && state.in_importmap then begin 307 307 + let content = Buffer.contents state.content in 308 308 + let errors = validate_importmap content in 309 309 + List.iter (fun err -> 310 310 + Message_collector.add_error collector 311 311 + ~message:(error_to_message err) 312 312 + ~code:"importmap-invalid" 313 313 + ~element:"script" 314 314 + ~attribute:"type" 315 315 + () 316 316 + ) errors; 317 317 + state.in_importmap <- false 318 318 + end 319 319 + end 320 320 + 321 321 + let characters state text _collector = 322 322 + if state.in_importmap then 323 323 + Buffer.add_string state.content text 324 324 + 325 325 + let end_document _state _collector = () 326 326 + 327 327 + let checker = 328 328 + (module struct 329 329 + type nonrec state = state 330 330 + let create = create 331 331 + let reset = reset 332 332 + let start_element = start_element 333 333 + let end_element = end_element 334 334 + let characters = characters 335 335 + let end_document = end_document 336 336 + end : Checker.S)

+5

lib/html5_checker/specialized/importmap_checker.mli

··· 1 1 + (** Importmap validation checker. 2 2 + 3 3 + Validates that <script type="importmap"> elements contain valid JSON. *) 4 4 + 5 5 + val checker : Checker.t

+60 -46

lib/html5_checker/specialized/microdata_checker.ml

··· 67 67 let is_url s = 68 68 String.contains s ':' 69 69 70 70 - (** Validate that a URL is a valid absolute URL for itemtype. 71 71 - itemtype must be an absolute URL per the HTML5 spec. 72 72 - http/https URLs require :// but other schemes like mailto:, data:, javascript: don't. *) 73 73 - let validate_itemtype_url url = 74 74 - let url = String.trim url in 75 75 - if String.length url = 0 then 76 76 - Error "itemtype must not be empty" 70 70 + (** Validate that a URL is a valid absolute URL for itemtype/itemid. 71 71 + Uses the comprehensive URL validation from Url_checker. *) 72 72 + let validate_microdata_url url element attr_name = 73 73 + let url_trimmed = String.trim url in 74 74 + if String.length url_trimmed = 0 then 75 75 + Some (Printf.sprintf 76 76 + "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 absolute URL: Must be non-empty." 77 77 + url attr_name element) 77 78 else 78 78 - match String.index_opt url ':' with 79 79 - | None -> Error "Expected a slash (\"/\")." 80 80 - | Some colon_pos -> 81 81 - if colon_pos = 0 then 82 82 - Error "Expected a slash (\"/\")." 83 83 - else 84 84 - let scheme = String.lowercase_ascii (String.sub url 0 colon_pos) in 85 85 - (* Schemes that require :// for itemtype validation 86 86 - Note: The Nu validator only enforces :// for http, https, and ftp *) 87 87 - let special_schemes = [ 88 88 - "http"; "https"; "ftp" 89 89 - ] in 90 90 - if List.mem scheme special_schemes then begin 91 91 - if colon_pos + 2 >= String.length url then 92 92 - Error "Expected a slash (\"/\")." 93 93 - else if url.[colon_pos + 1] <> '/' || url.[colon_pos + 2] <> '/' then 94 94 - Error "Expected a slash (\"/\")." 95 95 - else 96 96 - Ok () 97 97 - end else 98 98 - (* Other schemes (mailto:, data:, javascript:, etc.) are valid as-is *) 99 99 - Ok () 79 79 + (* First check if it has a scheme (required for absolute URL) *) 80 80 + match Url_checker.extract_scheme url_trimmed with 81 81 + | None -> 82 82 + Some (Printf.sprintf 83 83 + "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 absolute URL: The string \xe2\x80\x9c%s\xe2\x80\x9d is not an absolute URL." 84 84 + url attr_name element url) 85 85 + | Some _ -> 86 86 + (* Has a scheme - do comprehensive URL validation *) 87 87 + match Url_checker.validate_url url element attr_name with 88 88 + | None -> None 89 89 + | Some error_msg -> 90 90 + (* Replace "Bad URL:" with "Bad absolute URL:" for microdata *) 91 91 + let error_msg = Str.global_replace (Str.regexp "Bad URL:") "Bad absolute URL:" error_msg in 92 92 + Some error_msg 100 93 101 94 (** Check if itemprop value is valid. *) 102 95 let validate_itemprop_value value = ··· 125 118 let itemref_opt = get_attr attrs "itemref" in 126 119 let itemprop_opt = get_attr attrs "itemprop" in 127 120 128 128 - (* Check itemid requires itemscope and itemtype *) 121 121 + (* Check itemid requires itemscope and itemtype, and validate URL *) 129 122 begin match itemid_opt with 130 130 - | Some _itemid -> 123 123 + | Some itemid -> 131 124 if not has_itemscope then 132 125 Message_collector.add_error collector 133 126 ~message:"itemid attribute requires itemscope attribute" ··· 143 136 ?location 144 137 ~element 145 138 ~attribute:"itemid" 146 146 - () 139 139 + (); 140 140 + (* Validate itemid as URL (note: itemid can be relative, unlike itemtype) *) 141 141 + (match Url_checker.validate_url itemid element "itemid" with 142 142 + | None -> () 143 143 + | Some error_msg -> 144 144 + Message_collector.add_error collector 145 145 + ~message:error_msg 146 146 + ~code:"microdata-invalid-itemid" 147 147 + ?location 148 148 + ~element 149 149 + ~attribute:"itemid" 150 150 + ()) 147 151 | None -> () 148 152 end; 149 153 ··· 184 188 else begin 185 189 (* Validate each itemtype URL (can be space-separated) *) 186 190 let types = split_whitespace itemtype in 187 187 - List.iter (fun url -> 188 188 - match validate_itemtype_url url with 189 189 - | Ok () -> () 190 190 - | Error msg -> 191 191 - Message_collector.add_error collector 192 192 - ~message:(Printf.sprintf 193 193 - "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9citemtype\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad absolute URL: %s" 194 194 - url element msg) 195 195 - ~code:"microdata-invalid-itemtype" 196 196 - ?location 197 197 - ~element 198 198 - ~attribute:"itemtype" 199 199 - () 200 200 - ) types 191 191 + if types = [] then 192 192 + (* Empty itemtype is an error *) 193 193 + Message_collector.add_error collector 194 194 + ~message:(Printf.sprintf 195 195 + "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9citemtype\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d." 196 196 + itemtype element) 197 197 + ~code:"microdata-invalid-itemtype" 198 198 + ?location 199 199 + ~element 200 200 + ~attribute:"itemtype" 201 201 + () 202 202 + else 203 203 + List.iter (fun url -> 204 204 + match validate_microdata_url url element "itemtype" with 205 205 + | None -> () 206 206 + | Some error_msg -> 207 207 + Message_collector.add_error collector 208 208 + ~message:error_msg 209 209 + ~code:"microdata-invalid-itemtype" 210 210 + ?location 211 211 + ~element 212 212 + ~attribute:"itemtype" 213 213 + () 214 214 + ) types 201 215 end 202 216 | None -> () 203 217 end;

+189

lib/html5_checker/specialized/mime_type_checker.ml

··· 1 1 + (** MIME type validation checker. 2 2 + 3 3 + Validates MIME type values in type attributes. *) 4 4 + 5 5 + (** Validate a MIME type value. Returns error message or None. *) 6 6 + let validate_mime_type value element attr_name = 7 7 + let len = String.length value in 8 8 + if len = 0 then 9 9 + Some (Printf.sprintf 10 10 + "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: Empty value." 11 11 + value attr_name element) 12 12 + else if value.[len - 1] = ' ' || value.[len - 1] = '\t' then 13 13 + Some (Printf.sprintf 14 14 + "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: Extraneous trailing whitespace." 15 15 + value attr_name element) 16 16 + else if len > 0 && (value.[0] = ' ' || value.[0] = '\t') then 17 17 + Some (Printf.sprintf 18 18 + "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: Expected a token character but saw \xe2\x80\x9c \xe2\x80\x9d instead." 19 19 + value attr_name element) 20 20 + else 21 21 + (* Parse type/subtype *) 22 22 + let slash_pos = try Some (String.index value '/') with Not_found -> None in 23 23 + match slash_pos with 24 24 + | None -> 25 25 + (* No slash found - check if it looks like a type without subtype *) 26 26 + let semicolon_pos = try Some (String.index value ';') with Not_found -> None in 27 27 + (match semicolon_pos with 28 28 + | Some _ -> 29 29 + Some (Printf.sprintf 30 30 + "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: Subtype missing." 31 31 + value attr_name element) 32 32 + | None -> 33 33 + Some (Printf.sprintf 34 34 + "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: Subtype missing." 35 35 + value attr_name element)) 36 36 + | Some slash_pos -> 37 37 + (* Check for empty subtype *) 38 38 + let after_slash = String.sub value (slash_pos + 1) (len - slash_pos - 1) in 39 39 + let subtype_end = 40 40 + try String.index after_slash ';' 41 41 + with Not_found -> String.length after_slash 42 42 + in 43 43 + let subtype = String.sub after_slash 0 subtype_end in 44 44 + let subtype_trimmed = String.trim subtype in 45 45 + if subtype_trimmed = "" then 46 46 + Some (Printf.sprintf 47 47 + "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: Subtype missing." 48 48 + value attr_name element) 49 49 + else if String.length subtype > 0 && subtype.[String.length subtype - 1] = ' ' then 50 50 + (* Space before semicolon - also check parameter format *) 51 51 + let semicolon_pos = try Some (String.index value ';') with Not_found -> None in 52 52 + (match semicolon_pos with 53 53 + | Some semi_pos -> 54 54 + (* Check what comes after semicolon *) 55 55 + let params = String.sub value (semi_pos + 1) (len - semi_pos - 1) in 56 56 + let params_trimmed = String.trim params in 57 57 + if params_trimmed = "" then 58 58 + Some (Printf.sprintf 59 59 + "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: Semicolon seen but there was no parameter following it." 60 60 + value attr_name element) 61 61 + else 62 62 + (* Check for param_name=value format *) 63 63 + let eq_pos = try Some (String.index params '=') with Not_found -> None in 64 64 + (match eq_pos with 65 65 + | None -> 66 66 + Some (Printf.sprintf 67 67 + "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: Parameter value missing." 68 68 + value attr_name element) 69 69 + | Some _ -> None) 70 70 + | None -> None) 71 71 + else 72 72 + (* Check parameters after semicolon *) 73 73 + let semicolon_pos = try Some (String.index value ';') with Not_found -> None in 74 74 + (match semicolon_pos with 75 75 + | None -> None (* No parameters - OK *) 76 76 + | Some semi_pos -> 77 77 + let params = String.sub value (semi_pos + 1) (len - semi_pos - 1) in 78 78 + let params_trimmed = String.trim params in 79 79 + if params_trimmed = "" then 80 80 + Some (Printf.sprintf 81 81 + "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: Semicolon seen but there was no parameter following it." 82 82 + value attr_name element) 83 83 + else 84 84 + (* Check for param_name=value format *) 85 85 + let eq_pos = try Some (String.index params '=') with Not_found -> None in 86 86 + (match eq_pos with 87 87 + | None -> 88 88 + Some (Printf.sprintf 89 89 + "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: Parameter value missing." 90 90 + value attr_name element) 91 91 + | Some eq_pos -> 92 92 + let param_value = String.sub params (eq_pos + 1) (String.length params - eq_pos - 1) in 93 93 + let param_value_trimmed = String.trim param_value in 94 94 + if param_value_trimmed = "" then 95 95 + Some (Printf.sprintf 96 96 + "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: Parameter value missing." 97 97 + value attr_name element) 98 98 + else if param_value_trimmed.[0] = '"' then 99 99 + (* Quoted string - check for closing quote *) 100 100 + let quote_end = try Some (String.index_from param_value_trimmed 1 '"') with 101 101 + | Not_found -> None 102 102 + | Invalid_argument _ -> None 103 103 + in 104 104 + (match quote_end with 105 105 + | Some _ -> None (* Properly quoted *) 106 106 + | None -> 107 107 + (* Check for escaped quote at end *) 108 108 + let has_backslash_at_end = 109 109 + String.length param_value_trimmed >= 2 && 110 110 + param_value_trimmed.[String.length param_value_trimmed - 1] = '\\' 111 111 + in 112 112 + if has_backslash_at_end then 113 113 + Some (Printf.sprintf 114 114 + "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: Unfinished quoted string." 115 115 + value attr_name element) 116 116 + else 117 117 + Some (Printf.sprintf 118 118 + "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: Unfinished quoted string." 119 119 + value attr_name element)) 120 120 + else 121 121 + None)) 122 122 + 123 123 + (** Elements and attributes that contain MIME types. *) 124 124 + let mime_type_attrs = [ 125 125 + ("link", ["type"]); 126 126 + ("style", ["type"]); 127 127 + ("script", ["type"]); 128 128 + ("source", ["type"]); 129 129 + ("embed", ["type"]); 130 130 + ("object", ["type"]); 131 131 + ] 132 132 + 133 133 + type state = unit 134 134 + 135 135 + let create () = () 136 136 + let reset _state = () 137 137 + 138 138 + let get_attr_value name attrs = 139 139 + List.find_map (fun (k, v) -> 140 140 + if String.lowercase_ascii k = String.lowercase_ascii name then Some v else None 141 141 + ) attrs 142 142 + 143 143 + let start_element _state ~name ~namespace ~attrs collector = 144 144 + if namespace <> None then () 145 145 + else begin 146 146 + let name_lower = String.lowercase_ascii name in 147 147 + match List.assoc_opt name_lower mime_type_attrs with 148 148 + | None -> () 149 149 + | Some type_attrs -> 150 150 + List.iter (fun attr_name -> 151 151 + match get_attr_value attr_name attrs with 152 152 + | None -> () 153 153 + | Some value -> 154 154 + (* Don't validate empty type attributes or special script types *) 155 155 + if value = "" then () 156 156 + else if name_lower = "script" then 157 157 + (* script type can be module, importmap, etc. - skip validation for non-MIME types *) 158 158 + let value_lower = String.lowercase_ascii value in 159 159 + if value_lower = "module" || value_lower = "importmap" || 160 160 + not (String.contains value '/') then () 161 161 + else 162 162 + match validate_mime_type value name attr_name with 163 163 + | None -> () 164 164 + | Some err -> 165 165 + Message_collector.add_error collector 166 166 + ~message:err ~code:"bad-mime-type" ~element:name ~attribute:attr_name () 167 167 + else 168 168 + match validate_mime_type value name attr_name with 169 169 + | None -> () 170 170 + | Some err -> 171 171 + Message_collector.add_error collector 172 172 + ~message:err ~code:"bad-mime-type" ~element:name ~attribute:attr_name () 173 173 + ) type_attrs 174 174 + end 175 175 + 176 176 + let end_element _state ~name:_ ~namespace:_ _collector = () 177 177 + let characters _state _text _collector = () 178 178 + let end_document _state _collector = () 179 179 + 180 180 + let checker = 181 181 + (module struct 182 182 + type nonrec state = state 183 183 + let create = create 184 184 + let reset = reset 185 185 + let start_element = start_element 186 186 + let end_element = end_element 187 187 + let characters = characters 188 188 + let end_document = end_document 189 189 + end : Checker.S)

+5

lib/html5_checker/specialized/mime_type_checker.mli

··· 1 1 + (** MIME type validation checker. 2 2 + 3 3 + Validates MIME type values in type attributes. *) 4 4 + 5 5 + val checker : Checker.t

+42 -40

lib/html5_checker/specialized/table_checker.ml

··· 767 767 768 768 let reset state = state.tables := [] 769 769 770 770 + let is_html_namespace = function 771 771 + | None -> true (* HTML mode - no namespace specified *) 772 772 + | Some ns -> ns = html_ns (* XHTML mode - check namespace *) 773 773 + 770 774 let start_element state ~name ~namespace ~attrs collector = 771 771 - match namespace with 772 772 - | Some ns when ns = html_ns -> ( 773 773 - match name with 774 774 - | "table" -> 775 775 - (* Push a new table onto the stack *) 776 776 - state.tables := make_table () :: !(state.tables) 777 777 - | _ -> ( 778 778 - match !(state.tables) with 779 779 - | [] -> () 780 780 - | table :: _ -> ( 781 781 - match name with 782 782 - | "td" -> start_cell table false attrs collector 783 783 - | "th" -> start_cell table true attrs collector 784 784 - | "tr" -> start_row table collector 785 785 - | "tbody" | "thead" | "tfoot" -> start_row_group table name collector 786 786 - | "col" -> start_col table attrs collector 787 787 - | "colgroup" -> start_colgroup table attrs collector 788 788 - | _ -> ()))) 789 789 - | _ -> () 775 775 + if is_html_namespace namespace then ( 776 776 + let name_lower = String.lowercase_ascii name in 777 777 + match name_lower with 778 778 + | "table" -> 779 779 + (* Push a new table onto the stack *) 780 780 + state.tables := make_table () :: !(state.tables) 781 781 + | _ -> ( 782 782 + match !(state.tables) with 783 783 + | [] -> () 784 784 + | table :: _ -> ( 785 785 + match name_lower with 786 786 + | "td" -> start_cell table false attrs collector 787 787 + | "th" -> start_cell table true attrs collector 788 788 + | "tr" -> start_row table collector 789 789 + | "tbody" | "thead" | "tfoot" -> start_row_group table name collector 790 790 + | "col" -> start_col table attrs collector 791 791 + | "colgroup" -> start_colgroup table attrs collector 792 792 + | _ -> ()))) 790 793 791 794 let end_element state ~name ~namespace collector = 792 792 - match namespace with 793 793 - | Some ns when ns = html_ns -> ( 794 794 - match name with 795 795 - | "table" -> ( 796 796 - match !(state.tables) with 797 797 - | [] -> failwith "Bug: end table but no table on stack" 798 798 - | table :: rest -> 799 799 - end_table table collector; 800 800 - state.tables := rest) 801 801 - | _ -> ( 802 802 - match !(state.tables) with 803 803 - | [] -> () 804 804 - | table :: _ -> ( 805 805 - match name with 806 806 - | "td" | "th" -> end_cell table 807 807 - | "tr" -> end_row table collector 808 808 - | "tbody" | "thead" | "tfoot" -> end_row_group_handler table collector 809 809 - | "col" -> end_col table 810 810 - | "colgroup" -> end_colgroup table 811 811 - | _ -> ()))) 812 812 - | _ -> () 795 795 + if is_html_namespace namespace then ( 796 796 + let name_lower = String.lowercase_ascii name in 797 797 + match name_lower with 798 798 + | "table" -> ( 799 799 + match !(state.tables) with 800 800 + | [] -> () (* End tag without start - ignore *) 801 801 + | table :: rest -> 802 802 + end_table table collector; 803 803 + state.tables := rest) 804 804 + | _ -> ( 805 805 + match !(state.tables) with 806 806 + | [] -> () 807 807 + | table :: _ -> ( 808 808 + match name_lower with 809 809 + | "td" | "th" -> end_cell table 810 810 + | "tr" -> end_row table collector 811 811 + | "tbody" | "thead" | "tfoot" -> end_row_group_handler table collector 812 812 + | "col" -> end_col table 813 813 + | "colgroup" -> end_colgroup table 814 814 + | _ -> ()))) 813 815 814 816 let characters _state _text _collector = () 815 817

+1 -1

test/debug_check.ml

··· 1 1 let () = 2 2 - let test_file = "validator/tests/html/microdata/itemtype/scheme-https-no-slash-novalid.html" in 2 2 + let test_file = "validator/tests/html/mime-types/004-novalid.html" in 3 3 let ic = open_in test_file in 4 4 let html = really_input_string ic (in_channel_length ic) in 5 5 close_in ic;