File: netcgi_modtpl.ml

package info (click to toggle)
ocamlnet 4.1.2-1
  • links: PTS, VCS
  • area: main
  • in suites: stretch
  • size: 51,764 kB
  • ctags: 16,446
  • sloc: ml: 148,419; ansic: 10,989; sh: 1,885; makefile: 1,355
file content (341 lines) | stat: -rw-r--r-- 11,632 bytes parent folder | download | duplicates (7)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
(* 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 "&#13;&#10;" 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)