(* netcgi_modtpl.ml (C) 2005 Christophe Troestler This code may be used under either, the GNU GPL, or the same license as ocamlnet (see the file LICENSE). This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file LICENSE for more details. *) (* $Id: netcgi_modtpl.ml,v 1.4 2005/10/19 20:24:58 chris_77 Exp $ *) module Url = Netencoding.Url module Html = Netencoding.Html (* Escaping ***********************************************************************) type escape = EscapeNone | EscapeUrl | EscapeHtml | EscapeHtmlTag | EscapeHtmlTextarea let escape_html_textarea = Html.encode ~in_enc:`Enc_iso88591 ~unsafe_chars:Html.unsafe_chars_html4 () (* FIXME: The escaping functions below are limited -- they do not escape everything well. (?) *) let eol_re = Str.regexp "\r?\n" let escape_html str = let str = escape_html_textarea str in let str = Str.global_replace eol_re "<br/>" str in str let escape_html_tag str = let str = escape_html_textarea str in let str = Str.global_replace eol_re " " str in str let escape = function | EscapeNone -> (fun str -> str) | EscapeUrl -> (fun s -> Url.encode s) (* XXX http://... are not well escaped *) | EscapeHtml -> escape_html | EscapeHtmlTag -> escape_html_tag | EscapeHtmlTextarea -> escape_html_textarea (* Inputting files ***********************************************************************) let input_whole_chan chan = let buf = Buffer.create 4096 in try while true do Buffer.add_string buf (input_line chan); Buffer.add_char buf '\n'; done; assert false with End_of_file -> Buffer.contents buf let input_whole_file filename = let fh = open_in filename in let contents = input_whole_chan fh in close_in fh; contents (* Compile templates ***********************************************************************) type compiled = node list and node = | Plain of string (* Just some text. *) | Var of escape * string (* ::tag:: *) | If of string * compiled * compiled (* ::if(..):: .. ::else:: .. ::end:: *) | Table of string * compiled (* ::table(..):: .. ::end:: *) | Call of escape * string * string list (* [prepend_rev l1 l2] = [List.rev l1 @ l2] *) let rec prepend_rev l1 l2 = match l1, l2 with | [], _ -> l2 | a :: tl, _ -> prepend_rev tl (a :: l2) (* If name has the form "<name>_html" (or one of the similar cases), return bare name and the form of the escaping that needs to be applied. *) let get_var = let string_ends_with s sfx = let ls = String.length s and lsfx = String.length sfx in ls >= lsfx && String.sub s (ls - lsfx) lsfx = sfx in let suppress s sfx = String.sub s 0 (String.length s - String.length sfx) in fun name -> if string_ends_with name "_url" then Var(EscapeUrl, suppress name "_url") else if string_ends_with name "_html" then Var(EscapeHtml, suppress name "_html") else if string_ends_with name "_html_tag" then Var(EscapeHtmlTag, suppress name "_html_tag") else if string_ends_with name "_html_textarea" then Var(EscapeHtmlTextarea, suppress name "_html_textarea") else Var(EscapeNone, name) let delim_re = Str.regexp_string "::" let ident = "[ \t]*\\([a-zA-Z_]+[a-zA-Z0-9_]*\\)[ \t]*" let var_re = Str.regexp("::" ^ ident ^"::") let if_re = Str.regexp("::if(" ^ ident ^ ")::") let else_re = Str.regexp_string "::else::" let end_re = Str.regexp_string "::end::" let table_re = Str.regexp("::table(" ^ ident ^ ")::") let include_re = (* We do not allow white space in filenames because it is too easy to get mistaken. *) Str.regexp("::include([ \t\r\n]*\\([^(): \t\r\n]+\\)[ \t\r\n]*)::") let call_re = Str.regexp("::call(" ^ ident ^ "\\(\\([ \t]*,[ \t]*[a-zA-Z_]+[a-zA-Z0-9_]*\\)*\\)[ \t]*)" ^ "\\([_a-z]*\\)::") let comma_re = Str.regexp "[ \t]*,[ \t]*" (* The compiled templates are not mutable. We keep a list of templates associated to filenames to reuse them if necessary (e.g. when including headers and footers). *) let compiled_templates = Hashtbl.create 5 (* Type of delimiters that ends the current level of recursion. *) type closing = | Else (* ::else:: *) | End (* ::end:: *) | Eos (* End of string *) let rec compile_template ~filename source = match filename with | None -> let ct, _, _ = compile (Sys.getcwd()) Sys.executable_name source (String.length source) 0 [] in ct | Some f -> try Hashtbl.find compiled_templates f with Not_found -> let ct, _, _ = compile (Filename.dirname f) (Filename.basename f) source (String.length source) 0 [] in Hashtbl.add compiled_templates f ct; ct (* [compile basename source len i0 ct] returns [(ct', closing, i)] where [ct'] is the compiled template, [closing] is the "token" closing that part and [i] is the position right after that token. [ct] is the compiled template SO FAR in REVERSE order. *) and compile basename filename source len i0 ct = try if i0 >= len then raise Not_found; let i = Str.search_forward delim_re source i0 in let ct = if i > i0 then Plain(String.sub source i0 (i - i0)) :: ct else ct in (* Check if any of the recognized constructs follows *) if Str.string_match end_re source i then (List.rev ct, End, Str.match_end()) else if Str.string_match else_re source i then (List.rev ct, Else, Str.match_end()) else if Str.string_match var_re source i then let ct = get_var(Str.matched_group 1 source) :: ct in compile basename filename source len (Str.match_end()) ct else if Str.string_match if_re source i then let cond = Str.matched_group 1 source in let i_end = Str.match_end() in let (ct_then, cl, i) = compile basename filename source len i_end [] in match cl with | Else -> let (ct_else, cl, i) = compile basename filename source len i [] in begin match cl with | End -> compile basename filename source len i (If(cond, ct_then, ct_else) :: ct) | _ -> failwith(filename ^ ": Missing ::end:: for ::if(" ^ cond ^ "):: ... ::else::") end | End -> compile basename filename source len i (If(cond, ct_then, []) :: ct) | Eos -> failwith(filename ^ ": Missing ::end:: for ::if(" ^ cond ^ ")::") else if Str.string_match table_re source i then let table = Str.matched_group 1 source in let i_end = Str.match_end() in let (ct_rows, cl, i) = compile basename filename source len i_end [] in match cl with | End -> compile basename filename source len i (Table(table, ct_rows) :: ct) | _ -> failwith(filename ^ ": Missing ::end:: for ::table(" ^ table ^ ")::") else if Str.string_match call_re source i then let fname = Str.matched_group 1 source in let args = Str.matched_group 2 source in let esc = match Str.matched_group 4 source with | "_url" -> EscapeUrl | "_html" -> EscapeHtml | "_html_tag" -> EscapeHtmlTag | "_html_textarea" -> EscapeHtmlTextarea | _ -> EscapeNone in let i_end = Str.match_end() in let ct = Call(esc, fname, Str.split comma_re args) :: ct in compile basename filename source len i_end ct else if Str.string_match include_re source i then let i_filename = Str.matched_group 1 source in let i_end = Str.match_end() in let i_filename = if Filename.is_relative i_filename then Filename.concat basename i_filename else i_filename in let i_source = input_whole_file i_filename in let i_ct = compile_template ~filename:(Some i_filename) i_source in compile basename filename source len i_end (prepend_rev i_ct ct) else (* Skip "::" and look for the next one *) (* compile basename filename source len (i + 2) (Plain "::" :: ct) *) (* Error! *) failwith("Netcgi_modtpl (" ^ filename ^ "): Unrecognized " ^ (if i + 20 < String.length source then String.sub source i 20 ^ "..." else String.sub source i (String.length source - i))) with Not_found -> let ct = if len > i0 then Plain(String.sub source i0 (len - i0)) :: ct else ct in (List.rev ct, Eos, len) (* Set variables and output the template ***********************************************************************) type var = | VarString of string (* ::tag:: *) | VarTable of table_row list (* ::table(tag):: *) | VarConditional of bool (* ::if(tag):: *) | VarCallback of (string list -> string) (* ::call(f, x1,...):: *) and table_row = (string * var) list let find fname bindings k = try Hashtbl.find bindings k with Not_found -> failwith("Netcgi_modtpl (" ^ fname ^ "): tag/table ::" ^ k ^ ":: was not assigned any value.") class template ?filename source = let bindings = Hashtbl.create 5 in let fname = match filename with | None -> Sys.executable_name | Some f -> Filename.basename f in let resolve_variable name = match find fname bindings name with | VarString str -> str | _ -> failwith ("Netcgi_modtpl (" ^ fname ^ "): ::" ^ name ^ ":: should be a simple string tag.") and eval_condition name = match find fname bindings name with | VarConditional b -> b | _ -> failwith ("Netcgi_modtpl (" ^ fname ^ "): ::if(" ^ name ^ "):: should be a conditional tag.") and resolve_table name = match find fname bindings name with | VarTable tbl -> tbl | _ -> failwith ("Netcgi_modtpl (" ^ fname ^ "): ::table(" ^ name ^ "):: should be a table tag.") and resolve_callback name = match find fname bindings name with | VarCallback f -> f | _ -> failwith ("Netcgi_modtpl (" ^ fname ^ "): ::call(" ^ name ^ "[,...]):: should be a callback function.") in let rec substitute ct (out:string -> unit) = let out_node = function | Plain text -> out text | Var(esc, name) -> out(escape esc (resolve_variable name)) | If(cond, then_clause, else_clause) -> substitute (if eval_condition cond then then_clause else else_clause) out | Table(name, body) -> (* For each table [row], add the corresponding bindings, process the table body and then remove them. *) let process_row row = List.iter (fun (k, v) -> Hashtbl.add bindings k v) row; substitute body out; List.iter (fun (k, v) -> Hashtbl.remove bindings k) row; in List.iter process_row (resolve_table name); | Call(esc, fname, args) -> out(escape esc (resolve_callback fname args)) in List.iter out_node ct in let output = substitute (compile_template ?filename source) in object(self) method set name value = Hashtbl.add bindings name (VarString value) method table name tbl = Hashtbl.add bindings name (VarTable tbl) method conditional name cond = Hashtbl.add bindings name (VarConditional cond) method callback name f = Hashtbl.add bindings name (VarCallback f) method to_string = let buffer = Buffer.create 4096 in output (Buffer.add_string buffer); Buffer.contents buffer method to_channel chan = output (output_string chan) method source = source method output (cgi:Netcgi.cgi) = output (cgi#out_channel#output_string) end let template_from_string ?filename source = new template ?filename source let template_from_channel ?filename chan = template_from_string ?filename (input_whole_chan chan) let template filename = template_from_string ~filename (input_whole_file filename)