DouKaku?

let filter_attributes tagname attrlist =
  List.filter
    (fun (attrname, _) -> is_allowed_attribute tagname attrname)
    attrlist

let filter_input src = function
  | String _ as x -> x
  | SingleTag (tagname, attrs, p, q) ->
      if is_allowed_tag tagname then
        SingleTag(tagname, filter_attributes tagname attrs, p, q)
      else
        String (String.sub src p (q-p))
  | OpenTag (tagname, attrs, p, q) ->
      if tagname === "br" then
        SingleTag(tagname, [], p, q)
      else if is_allowed_tag tagname then
        OpenTag(tagname, filter_attributes tagname attrs, p, q)
      else
        String (String.sub src p (q-p))
  | CloseTag (tagname, p, q) as x ->
      if is_allowed_tag tagname then x else
        String (String.sub src p (q-p))
  | Eof -> Eof

let sanitizing_output buf string p q =
  for x = p to q-1 do
    match string.[x] with
      | '<' -> Buffer.add_string buf "&lt;"
      | '>' -> Buffer.add_string buf "&gt;"
      | '&' -> Buffer.add_string buf "&amp;"
      | '\n' -> Buffer.add_string buf "<br/>"
      | c -> Buffer.add_char buf c
  done

let output_attribute buf (attrname, value) =
  let quote = if String.contains value '"' then '\'' else '"' in
    Printf.bprintf buf " %s=%c%s%c" attrname quote value quote

let output_tag buf name attrs is_single =
  Printf.bprintf buf "<%s" name;
  List.iter (output_attribute buf) attrs;
  if is_single then Buffer.add_char buf '/';
  Buffer.add_char buf '>'

let output_text_fragment buf = function
  | String s ->
      sanitizing_output buf s 0 (String.length s)
  | SingleTag (s, attrs, _, _) ->
      output_tag buf s attrs true
  | OpenTag (s, attrs, _, _) ->
      output_tag buf s attrs false
  | CloseTag (s, _, _) ->
      Printf.bprintf buf "</%s>" s
  | Eof -> ()

let filter_text text =
  let list = parse_input text in
  let flist = List.map (filter_input text) list in
  let buf = Buffer.create (String.length text) in
    List.iter (output_text_fragment buf) flist;
    Buffer.contents buf
}