$string_input ~input_type:`Text ~name:n1 ()$
$string_input ~input_type:`Text ~name:n2 ()$
$string_input ~input_type:`Submit ~value:"Click" ()$
>>
let constform = register_service ["constform"] unit
(fun () () ->
let f = get_form Eliom_testsuite1.constfix create_form in
return
(html
(head (title (pcdata "")) [])
(body [h1 [pcdata "Hallo"];
f ])))
(* Suffix and other service at same URL *)
let su2 =
register_service
~path:["fuffix";""]
~get_params:(suffix (all_suffix_string "s"))
(fun s () ->
return
(html
(head (title (pcdata "")) [])
(body [h1
[pcdata s];
p [pcdata "Try page fuffix/a/b"]])))
let su =
register_service
~path:["fuffix";"a";"b"]
~get_params:unit
(fun () () ->
return
(html
(head (title (pcdata "")) [])
(body [h1 [pcdata "Try another suffix"]])))
let su3 =
register_service
~path:["fuffix";""]
~get_params:unit
(fun () () ->
return
(html
(head (title (pcdata "")) [])
(body [h1 [pcdata "Try another suffix"]])))
let su4 =
register_service
~path:["fuffix";""]
~get_params:(suffix (string "s" ** suffix_const "CONST" ** string "ss"))
~priority:1
(fun (s, ((), ss)) () ->
return
(html
(head (title (pcdata "")) [])
(body [h1
[pcdata s];
p [pcdata "I am a suffix service with a constant part, registered after the generic suffix service, but I have a priority, so that you can see me!"]])))
let create_suffixform_su2 s =
let module Html5 = Eliom_content.Html5.F in
<:html5list<
let ll =
List.map
(fun (a,s) -> <:html5< ($str:a$, $str:s$) >>) l
in
let sl =
List.map
(fun s -> <:html5< $str:s$ >>) suf
in
return
(html
(head (title (pcdata "")) [])
(body [p [pcdata "All characters must be displayed correctly, including ampersand or unicode"];
p sl;
p ll
])))
(* menu with preapplied services *)
let preappl = preapply coucou_params (3,(4,"cinq"))
let preappl2 = preapply uasuffix (1999,01)
let mymenu current =
let module Html5 = Eliom_content.Html5.F in
Eliom_tools.F.menu ~classe:["menuprincipal"]
[(coucou, <:html5list< coucou >>);
(preappl, <:html5list< params >>);
(preappl2, <:html5list< params and suffix >>);
] ~service:current ()
let preappmenu =
register_service
~path:["menu"]
~get_params:unit
(fun () () ->
return
(html
(head (title (pcdata "")) [])
(body [h1 [pcdata "Hallo"];
mymenu coucou ])))
(* GET Non-attached coservice *)
let nonatt = coservice' ~get_params:(string "e") ()
(* GET coservice with preapplied fallback *)
(* + Non-attached coservice on a pre-applied coservice *)
(* + Non-attached coservice on a non-attached coservice *)
let f s =
(html
(head (title (pcdata "")) [])
(body [h1 [pcdata s];
p [a nonatt [pcdata "clic"] "nonon"];
get_form nonatt
(fun string_name ->
[p [pcdata "Non attached coservice: ";
string_input ~input_type:`Text ~name:string_name ();
string_input ~input_type:`Submit ~value:"Click" ()]])
]))
let getco = register_coservice
~fallback:preappl
~get_params:(int "i" ** string "s")
(fun (i,s) () -> return (f s))
let _ = register nonatt (fun s () -> return (f s))
let getcoex =
register_service
~path:["getco"]
~get_params:unit
(fun () () ->
return
(html
(head (title (pcdata "")) [])
(body [p [a getco [pcdata "clic"] (22,"eee") ];
get_form getco
(fun (number_name,string_name) ->
[p [pcdata "Write an int: ";
int_input ~input_type:`Text ~name:number_name ();
pcdata "Write a string: ";
string_input ~input_type:`Text ~name:string_name ();
string_input ~input_type:`Submit ~value:"Click" ()]])
])))
(* POST service with preapplied fallback are not possible: *)
(*
let my_service_with_post_params =
register_post_service
~fallback:preappl
~post_params:(string "value")
(fun () value -> return
(html
(head (title (pcdata "")) [])
(body [h1 [pcdata value]])))
*)
(* GET coservice with coservice fallback: not possible *)
(*
let preappl3 = preapply getco (777,"ooo")
let getco2 =
register_coservice
~fallback:preappl3
~get_params:(int "i2" ** string "s2")
(fun (i,s) () ->
return
(html
(head (title (pcdata "")) [])
(body [h1 [pcdata s]])))
*)
(* POST service with coservice fallback *)
let my_service_with_post_params =
register_post_service
~fallback:getco
~post_params:(string "value")
(fun (i,s) value -> return
(html
(head (title (pcdata "")) [])
(body [h1 [pcdata (s^" "^value)]])))
let postcoex = register_service ["postco"] unit
(fun () () ->
let f =
(post_form my_service_with_post_params
(fun chaine ->
[p [pcdata "Write a string: ";
string_input ~input_type:`Text ~name:chaine ()]])
(222,"ooo")) in
return
(html
(head (title (pcdata "form")) [])
(body [f])))
(* action on GET attached coservice *)
let v = ref 0
let getact =
service
~path:["getact"]
~get_params:(int "p")
()
let act = Eliom_registration.Action.register_coservice
~fallback:(preapply getact 22)
~get_params:(int "bip")
(fun g p -> v := g; return ())
(* action on GET non-attached coservice on GET coservice page *)
let naact = Eliom_registration.Action.register_coservice'
~get_params:(int "bop")
(fun g p -> v := g; return ())
let naunit = Eliom_registration.Unit.register_coservice'
~get_params:(int "bap")
(fun g p -> v := g; return ())
let _ =
register
getact
(fun aa () ->
return
(html
(head (title (pcdata "getact")) [])
(body [h1 [pcdata ("v = "^(string_of_int !v))];
p [pcdata ("p = "^(string_of_int aa))];
p [a getact [pcdata "link to myself"] 0;
br ();
a act [pcdata "an attached action to change v"]
(Random.int 100);
br ();
a naact [pcdata "a non attached action to change v"]
(100 + Random.int 100);
pcdata " (Actually if called after the previous one, v won't change. More precisely, it will change and turn back to the former value because the attached coservice is reloaded after action)";
br ();
a naunit [pcdata "a non attached \"Unit\" page to change v"]
(200 + Random.int 100);
pcdata " (Reload after clicking here)"
]])))
(* Many cookies *)
let cookiename = "c"
let cookies2 = service ["c";""] (suffix (all_suffix_string "s")) ()
let _ = Eliom_registration.Html5.register cookies2
(fun s () ->
let now = Unix.time () in
Eliom_state.set_cookie
~path:[] ~exp:(now +. 10.) ~name:(cookiename^"6")
~value:(string_of_int (Random.int 100)) ~secure:true ();
Eliom_state.set_cookie
~path:[] ~exp:(now +. 10.) ~name:(cookiename^"7")
~value:(string_of_int (Random.int 100)) ~secure:true ();
Eliom_state.set_cookie
~path:["c";"plop"] ~name:(cookiename^"8")
~value:(string_of_int (Random.int 100)) ();
Eliom_state.set_cookie
~path:["c";"plop"] ~name:(cookiename^"9")
~value:(string_of_int (Random.int 100)) ();
Eliom_state.set_cookie
~path:["c";"plop"] ~name:(cookiename^"10")
~value:(string_of_int (Random.int 100)) ~secure:true ();
Eliom_state.set_cookie
~path:["c";"plop"] ~name:(cookiename^"11")
~value:(string_of_int (Random.int 100)) ~secure:true ();
Eliom_state.set_cookie
~path:["c";"plop"] ~name:(cookiename^"12")
~value:(string_of_int (Random.int 100)) ~secure:true ();
if CookiesTable.mem (cookiename^"1") (Eliom_request_info.get_cookies ())
then
(Eliom_state.unset_cookie ~name:(cookiename^"1") ();
Eliom_state.unset_cookie ~name:(cookiename^"2") ())
else begin
Eliom_state.set_cookie
~name:(cookiename^"1") ~value:(string_of_int (Random.int 100))
~secure:true ();
Eliom_state.set_cookie
~name:(cookiename^"2") ~value:(string_of_int (Random.int 100)) ();
Eliom_state.set_cookie
~name:(cookiename^"3") ~value:(string_of_int (Random.int 100)) ()
end;
Lwt.return
(html
(head (title (pcdata "")) [])
(body [p
(CookiesTable.fold
(fun n v l ->
(pcdata (n^"="^v))::
(br ())::l
)
(Eliom_request_info.get_cookies ())
[a cookies2 [pcdata "send other cookies"] ""; br ();
a cookies2 [pcdata "send other cookies and see the url /c/plop"] "plop"]
)]))
)
(* Send file *)
let sendfileex =
register_service
~path:["files";""]
~get_params:unit
(fun () () ->
return
(html
(head (title (pcdata "")) [])
(body [h1 [pcdata "With a suffix, that page will send a file"]])))
let sendfile2 =
Eliom_registration.File.register_service
~path:["files";""]
~get_params:(suffix (all_suffix "filename"))
(fun s () ->
return ("/var/www/ocsigen/"^(Url.string_of_url_path ~encode:false s)))
let sendfileexception =
register_service
~path:["files";"exception"]
~get_params:unit
(fun () () ->
return
(html
(head (title (pcdata "")) [])
(body [h1 [pcdata "With another suffix, that page will send a file"]])))
(* Complex suffixes *)
let suffix2 =
service
~path:["suffix2";""]
~get_params:(suffix (string "suff1" ** int "ii" ** all_suffix "ee"))
()
let _ =
register suffix2
(fun (suf1, (ii, ee)) () ->
return
(html
(head (title (pcdata "")) [])
(body
[p [pcdata "The suffix of the url is ";
strong [pcdata (suf1^", "^(string_of_int ii)^", "^
(Url.string_of_url_path ~encode:false ee))]];
p [a suffix2 [pcdata "link to myself"] ("a", (2, []))]])))
let suffix3 =
register_service
~path:["suffix3";""]
~get_params:(suffix_prod
(string "suff1" ** int "ii" **
all_suffix_user int_of_string string_of_int "ee")
(string "a" ** int "b"))
(fun ((suf1, (ii, ee)), (a, b)) () ->
return
(html
(head (title (pcdata "")) [])
(body
[p [pcdata "The parameters in the url are ";
strong [pcdata (suf1^", "^(string_of_int ii)^", "^
(string_of_int ee)^", "^
a^", "^(string_of_int b))]]])))
let create_suffixform2 (suf1, (ii, ee)) =
let module Html5 = Eliom_content.Html5.F in
<:html5list< Write a string:
$string_input ~input_type:`Text ~name:suf1 ()$
Write an int: $int_input ~input_type:`Text ~name:ii ()$
Write a string: $user_type_input
(Url.string_of_url_path ~encode:false)
~input_type:`Text ~name:ee ()$
$string_input ~input_type:`Submit ~value:"Click" ()$
>>
let suffixform2 = register_service ["suffixform2"] unit
(fun () () ->
let f = get_form suffix2 create_suffixform2 in
return
(html
(head (title (pcdata "")) [])
(body [h1 [pcdata "Hallo"];
f ])))
let create_suffixform3 ((suf1, (ii, ee)), (a, b)) =
let module Html5 = Eliom_content.Html5.F in
<:html5list< Write a string:
$string_input ~input_type:`Text ~name:suf1 ()$
Write an int: $int_input ~input_type:`Text ~name:ii ()$
Write an int: $int_input ~input_type:`Text ~name:ee ()$
Write a string: $string_input ~input_type:`Text ~name:a ()$
Write an int: $int_input ~input_type:`Text ~name:b ()$
$string_input ~input_type:`Submit ~value:"Click" ()$
>>
let suffixform3 = register_service ["suffixform3"] unit
(fun () () ->
let f = get_form suffix3 create_suffixform3 in
return
(html
(head (title (pcdata "")) [])
(body [h1 [pcdata "Hallo"];
f ])))
let suffix5 =
register_service
~path:["suffix5"]
~get_params:(suffix (all_suffix "s"))
(fun s () ->
return
(html
(head (title (pcdata "")) [])
(body
[p [pcdata "This is a page with suffix ";
strong [pcdata (Url.string_of_url_path
~encode:false s)]]])))
let nosuffix =
register_service
~path:["suffix5";"notasuffix"]
~get_params:unit
(fun () () ->
return
(html
(head (title (pcdata "")) [])
(body
[p [pcdata "This is a page without suffix. Replace ";
code [pcdata "notasuffix"];
pcdata " in the URL by something else."
]])))
(* Send file with regexp *)
let sendfileregexp =
register_service
~path:["files2";""]
~get_params:unit
(fun () () ->
return
(html
(head (title (pcdata "")) [])
(body [h1 [pcdata "With a suffix, that page will send a file"]])))
let r = Netstring_pcre.regexp "~([^/]*)(.*)"
let sendfile2 =
Eliom_registration.File.register_service
~path:["files2";""]
(* ~get_params:(regexp r "/home/$1/public_html$2" "filename") *)
~get_params:(suffix ~redirect_if_not_suffix:false
(all_suffix_regexp r "$u($1)/public_html$2"
~to_string:(fun s -> s) "filename"))
(fun s () -> return s)
(* Here I am using redirect_if_not_suffix:false because
otherwise I would need to write a more sophisticated to_string function *)
(*
let sendfile2 =
Files.register_service
~path:["files2";""]
~get_params:(suffix
(all_suffix_regexp r "/home/$1/public_html$2" "filename"))
(* ~get_params:(suffix (all_suffix_regexp r "$$u($1)$2" "filename")) *)
(fun s () -> return s)
*)
let create_suffixform4 n =
let module Html5 = Eliom_content.Html5.F in
<:html5list< Write the name of the file:
$string_input ~input_type:`Text ~name:n ()$
$string_input ~input_type:`Submit ~value:"Click" ()$
>>
let suffixform4 = register_service ["suffixform4"] unit
(fun () () ->
let f = get_form sendfile2 create_suffixform4 in
return
(html
(head (title (pcdata "")) [])
(body [h1 [pcdata "Hallo"];
f ])))
(* Advanced use of any *)
let any2 = register_service
~path:["any2"]
~get_params:(int "i" ** any)
(fun (i,l) () ->
let module Html5 = Eliom_content.Html5.F in
let ll =
List.map
(fun (a,s) -> <:html5< ($str:a$, $str:s$) >>) l
in
return
<:html5<
You sent:
$list:ll$
i = $str:(string_of_int i)$
>>)
(* the following will not work because s is taken in any. (not checked) *)
let any3 = register_service
~path:["any3"]
~get_params:(int "i" ** any ** string "s")
(fun (i,(l,s)) () ->
let module Html5 = Eliom_content.Html5.F in
let ll =
List.map
(fun (a,s) -> <:html5< ($str:a$, $str:s$) >>) l
in
return
<:html5<
You sent:
$list:ll$
i = $str:(string_of_int i)$
s = $str:s$
>>)
(* any cannot be in suffix: (not checked) *)
let any4 = register_service
~path:["any4"]
~get_params:(suffix any)
(fun l () ->
let module Html5 = Eliom_content.Html5.F in
let ll =
List.map
(fun (a,s) -> <:html5< ($str:a$, $str:s$) >>) l
in
return
<:html5<
You sent:
$list:ll$
>>)
let any5 = register_service
~path:["any5"]
~get_params:(suffix_prod (string "s") any)
(fun (s, l) () ->
let module Html5 = Eliom_content.Html5.F in
let ll =
List.map
(fun (a,s) -> <:html5< ($str:a$, $str:s$) >>) l
in
return
<:html5<
You sent $str:s$ and :
$list:ll$
>>)
(* list in suffix *)
let sufli = service
~path:["sufli"]
~get_params:(suffix (list "l" (string "s" ** int "i")))
()
let _ = register sufli
(fun l () ->
let module Html5 = Eliom_content.Html5.F in
let ll =
List.map
(fun (s, i) -> <:html5< $str:(s^string_of_int i)$ >>) l
in
return
<:html5<
You sent:
$list:ll$
$a sufli [pcdata "myself"] [("a", 2)]$,
$a sufli [pcdata "myself (empty list)"] []$
>>)
let create_sufliform f =
let l =
f.it (fun (sn, iname) v init ->
(tr [td [pcdata ("Write a string: ")];
td [string_input ~input_type:`Text ~name:sn ()];
td [pcdata ("Write an integer: ")];
td [int_input ~input_type:`Text ~name:iname ()];
])::init)
["one";"two";"three"]
[]
in
[table (List.hd l) (List.tl l);
p [string_input ~input_type:`Submit ~value:"Click" ()]]
let sufliform = register_service ["sufliform"] unit
(fun () () ->
let f = get_form sufli create_sufliform in
return
(html
(head (title (pcdata "")) [])
(body [h1 [pcdata "Hallo"];
f ])))
(*
(* mmmh ... disabled dynamically for now *)
let sufli2 = service
~path:["sufli2"]
~get_params:(suffix ((list "l" (int "i")) ** int "j"))
()
let _ = register sufli2
(fun (l, j) () ->
let ll =
List.map (fun i -> <:html5< $str:(string_of_int i)$ >>) l
in
return
<:html5<
You sent:
$list:ll$,
and
j=$str:string_of_int j$.
$a sufli2 [pcdata "myself"] ([1; 2], 3)$,
$a sufli2 [pcdata "myself (empty list)"] ([], 1)$
>>)
*)
let sufliopt = service
~path:["sufliopt"]
~get_params:(suffix (list "l" (opt (string "s"))))
()
let _ = register sufliopt
(fun l () ->
let module Html5 = Eliom_content.Html5.F in
let ll =
List.map
(function None -> pcdata ""
| Some s -> <:html5< $str:s$ >>) l
in
return
<:html5<
You sent:
$list:ll$
$a sufliopt [pcdata "myself"] [Some "a"; None; Some "po"; None; None; Some "k"; None]$,
$a sufliopt [pcdata "myself (empty list)"] []$
$a sufliopt [pcdata "myself (list [None; None])"] [None; None]$
$a sufliopt [pcdata "myself (list [None])"] [None]$
>>)
let sufliopt2 = service
~path:["sufliopt2"]
~get_params:(suffix (list "l" (opt (string "s" ** string "ss"))))
()
let _ = register sufliopt2
(fun l () ->
let module Html5 = Eliom_content.Html5.F in
let ll =
List.map
(function None -> pcdata ""
| Some (s, ss) -> <:html5< ($str:s$, $str:ss$) >>) l
in
return
<:html5<
You sent:
$list:ll$
$a sufliopt2 [pcdata "myself"] [Some ("a", "jj"); None; Some ("po", "jjj"); None; None; Some ("k", "pp"); None]$,
$a sufliopt2 [pcdata "myself (empty list)"] []$
$a sufliopt2 [pcdata "myself (list [None; None])"] [None; None]$
$a sufliopt2 [pcdata "myself (list [None])"] [None]$
>>)
(* set in suffix *)
let sufset = register_service
~path:["sufset"]
~get_params:(suffix (Eliom_parameter.set string "s"))
(fun l () ->
let module Html5 = Eliom_content.Html5.F in
let ll =
List.map
(fun s -> <:html5< $str:s$ >>) l
in
return
<:html5<
You sent:
$list:ll$
>>)
(* form to any2 *)
let any2form = register_service
~path:["any2form"]
~get_params:unit
(fun () () ->
return
(html
(head (title (pcdata "")) [])
(body [h1 [pcdata "Any Form"];
get_form any2
(fun (iname,grr) ->
[p [pcdata "Form to any2: ";
int_input ~input_type:`Text ~name:iname ();
raw_input ~input_type:`Text ~name:"plop" ();
raw_input ~input_type:`Text ~name:"plip" ();
raw_input ~input_type:`Text ~name:"plap" ();
string_input ~input_type:`Submit ~value:"Click" ()]])
])))
(* bool list *)
let boollist = register_service
~path:["boollist"]
~get_params:(list "a" (bool "b"))
(fun l () ->
let ll =
List.map (fun b ->
(strong [pcdata (if b then "true" else "false")])) l in
return
(html
(head (title (pcdata "")) [])
(body
[p ((pcdata "You sent: ")::ll)]
)))
let create_listform f =
(* Here, f.it is an iterator like List.map,
but it must be applied to a function taking 2 arguments
(and not 1 as in map), the first one being the name of the parameter.
The last parameter of f.it is the code that must be appended at the
end of the list created
*)
let l =
f.it (fun boolname v init ->
(tr[td [pcdata ("Write the value for "^v^": ")];
td [bool_checkbox ~name:boolname ()]])::init)
["one";"two";"three"]
[]
in
[table (List.hd l) (List.tl l);
p [raw_input ~input_type:`Submit ~value:"Click" ()]]
let boollistform = register_service ["boolform"] unit
(fun () () ->
let f = get_form boollist create_listform in return
(html
(head (title (pcdata "")) [])
(body [f])))
(********)
let coucoucou =
register_service
~path:["coucoucou"]
~get_params:unit
(fun () () ->
return
(html
(head (title (pcdata "")) [])
(body [h1 [pcdata "Hallo!"]])))
(* any with POST *)
let any = register_post_service
~fallback:coucoucou
~post_params:any
(fun () l ->
let module Html5 = Eliom_content.Html5.F in
let ll =
List.map
(fun (a,s) -> <:html5< ($str:a$, $str:s$) >>) l
in
return
<:html5<
You sent:
$list:ll$
>>)
(* form to any *)
let anypostform = register_service
~path:["anypostform"]
~get_params:unit
(fun () () ->
return
(html
(head (title (pcdata "")) [])
(body [h1 [pcdata "Any Form"];
post_form any
(fun () ->
[p [pcdata "Empty form to any: ";
string_input ~input_type:`Submit ~value:"Click" ()]])
()
])))
(**********)
(* upload *)
(* ce qui suit ne doit pas fonctionner. Mais il faudrait l'interdire *)
let get_param_service =
register_service
~path:["uploadget"]
~get_params:(string "name" ** file "file")
(fun (name,file) () ->
let to_display =
let newname = "/tmp/fichier" in
(try
Unix.unlink newname;
with _ -> ());
Unix.link (Eliom_request_info.get_tmp_filename file) newname;
let fd_in = open_in newname in
try
let line = input_line fd_in in close_in fd_in; line (*end*)
with End_of_file -> close_in fd_in; "vide"
in
return
(html
(head (title (pcdata name)) [])
(body [h1 [pcdata to_display]])))
let uploadgetform = register_service ["uploadget"] unit
(fun () () ->
let f =
(* ARG (post_form ~a:[(Html5.F.a_enctype "multipart/form-data")] fichier2 *)
(get_form ~a:[(Html5.F.a_enctype "multipart/form-data")] ~service:get_param_service
(*post_form my_service_with_post_params *)
(fun (str, file) ->
[p [pcdata "Write a string: ";
string_input ~input_type:`Text ~name:str ();
br ();
file_input ~name:file ()]])) in return
(html
(head (title (pcdata "form")) [])
(body [f])))
(*******)
(* Actions that raises an exception *)
let exn_act = Eliom_registration.Action.register_coservice'
~get_params:unit
(fun g p -> fail Not_found)
let exn_act_main =
register_service
~path:["exnact"]
~get_params:unit
(fun () () ->
return
(html
(head (title (pcdata "exnact")) [])
(body [h1 [pcdata "Hello"];
p [a exn_act [pcdata "Do the action"] ();
pcdata "It will raise an exception, and you will receive an error 500."
]])))
let action_example2_scope =
`Session (Eliom_common.create_scope_hierarchy "action_example2")
(* close sessions from outside *)
let close_from_outside =
register_service
~path:["close_from_outside"]
~get_params:unit
(fun () () ->
lwt () = discard_all ~scope:persistent_session_scope () in
lwt () = discard_all ~scope:action_example2_scope () in
return
(html
(head (title (pcdata "")) [])
(body [h1 [pcdata "all sessions called \"persistent_sessions\" and \"action_example2\" closed"];
p [a persist_session_example [pcdata "try"] ()]])))
(* setting timeouts *)
let set_timeout =
register_service
~path:["set_timeout"]
~get_params:(int "t" ** (bool "recompute" ** bool "overrideconfig"))
(fun (t, (recompute, override_configfile)) () ->
set_global_persistent_data_state_timeout
~override_configfile
~cookie_scope:persistent_session_scope
~recompute_expdates:recompute (Some (float_of_int t));
set_global_volatile_state_timeout
~override_configfile
~cookie_scope:action_example2_scope
~recompute_expdates:recompute (Some (float_of_int t));
return
(html
(head (title (pcdata "")) [])
(body [h1 [pcdata "Setting timeout"];
p [
if recompute
then pcdata ("The timeout for sessions called \"persistent_sessions\" and \"action_example2\" has been set to "^(string_of_int t)^" seconds (all expiration dates updated).")
else pcdata ("From now, the timeout for sessions called \"persistent_sessions\" and \"action_example2\" will be "^(string_of_int t)^" seconds (expiration dates not updated)."); br ();
a persist_session_example [pcdata "Try"] ()]])))
let create_form =
(fun (number_name, (bool1name, bool2name)) ->
[p [pcdata "New timeout: ";
Html5.D.int_input ~input_type:`Text ~name:number_name ();
br ();
pcdata "Check the box if you want to recompute all timeouts: ";
Html5.D.bool_checkbox ~name:bool1name ();
br ();
pcdata "Check the box if you want to override configuration file: ";
Html5.D.bool_checkbox ~name:bool2name ();
Html5.D.string_input ~input_type:`Submit ~value:"Submit" ()]])
let set_timeout_form =
register_service
["set_timeout"]
unit
(fun () () ->
let f = Html5.D.get_form set_timeout create_form in
return
(html
(head (title (pcdata "")) [])
(body [f])))
(******************************************************************)
let sraise =
register_service
~path:["raise"]
~get_params:unit
(fun () () -> failwith "Bad use of exceptions")
let sfail =
register_service
~path:["fail"]
~get_params:unit
(fun () () -> Lwt.fail (Failure "Service raising an exception"))
(*****************************************************************************)
(* 2011/08/02 Vincent - Volatile group data
removing group data or not when no session in the group?*)
(*zap* *)
open Html5.F
(*zap* *)
let scope_hierarchy = Eliom_common.create_scope_hierarchy "session_group_data_example_state"
let session = `Session scope_hierarchy
let group = `Session_group scope_hierarchy
(* *zap*)
(* -------------------------------------------------------- *)
(* We create one main service and two (POST) actions *)
(* (for connection and disconnection) *)
let connect_example_gd =
Eliom_service.service
~path:["sessgrpdata"]
~get_params:unit
()
let connect_action =
Eliom_service.post_coservice'
~name:"connectiongd"
~post_params:(string "login")
()
(* disconnect action and box: *)
let disconnect_action =
Eliom_registration.Action.register_post_coservice'
~name:"disconnectiongd"
~post_params:Eliom_parameter.unit
(fun () () -> Eliom_state.discard ~scope:session ())
let disconnect_box s =
Html5.D.post_form disconnect_action
(fun _ -> [p [Html5.D.string_input
~input_type:`Submit ~value:s ()]]) ()
(* The following eref is true if the connection has action failed: *)
let bad_user = Eliom_reference.eref ~scope:Eliom_common.request_scope false
let my_group_data = Eliom_reference.eref ~scope:group None
let change_gd =
Eliom_registration.Action.register_post_coservice'
~name:"changegd"
~post_params:Eliom_parameter.unit
(fun () () -> Eliom_reference.set my_group_data (Some (1000 + Random.int 1000)))
(* -------------------------------------------------------- *)
(* new login box: *)
let login_box session_expired bad_u action =
Html5.D.post_form action
(fun loginname ->
let l =
[pcdata "login: ";
Html5.D.string_input ~input_type:`Text ~name:loginname ()]
in
[p (if bad_u
then (pcdata "Wrong user")::(br ())::l
else
if session_expired
then (pcdata "Session expired")::(br ())::l
else l)
])
()
(* -------------------------------------------------------- *)
(* Handler for the "connect_example" service (main page): *)
let connect_example_handler () () =
(* The following function tests whether the session has expired: *)
let status = Eliom_state.volatile_data_state_status (*zap* *) ~scope:session (* *zap*) ()
in
let group =
Eliom_state.get_volatile_data_session_group (*zap* *) ~scope:session (* *zap*) ()
in
Eliom_reference.get bad_user >>= fun bad_u ->
Eliom_reference.get my_group_data >>= fun my_group_data ->
Lwt.return
(html
(head (title (pcdata "")) [])
(body
(match group, status with
| Some name, _ ->
[p [pcdata ("Hello "^name); br ();
(match my_group_data with
| None -> pcdata "You have no group data."
| Some i -> pcdata ("Your group data is "^string_of_int i^"."))];
Html5.D.post_form change_gd
(fun () -> [p [Html5.D.string_input
~input_type:`Submit
~value:"Change group data" ()]]) ();
p [pcdata "Check that several sessions have the same group data."];
p [pcdata "Volatile group data are currently discarded when all group disappear. This is weird and not coherent with persistent group data. But I don't really see a correct use of volatile group data. Is there any? And there is a risk of memory leak if we keep them. Besides, volatile sessions are (hopefully) going to disappear soon."];
disconnect_box "Close session"]
| None, Eliom_state.Expired_state ->
[login_box true bad_u connect_action;
p [em [pcdata "The only user is 'toto'."]]]
| _ ->
[login_box false bad_u connect_action;
p [em [pcdata "The only user is 'toto'."]]]
)))
(* -------------------------------------------------------- *)
(* Handler for connect_action (user logs in): *)
let connect_action_handler () login =
lwt () = Eliom_state.discard ~scope:session () in
if login = "toto" (* Check user and password :-) *)
then begin
Eliom_state.set_volatile_data_session_group ~set_max:4 (*zap* *) ~scope:session (* *zap*) login;
Eliom_reference.get my_group_data >>= fun mgd ->
(if mgd = None
then Eliom_reference.set my_group_data (Some (Random.int 1000))
else Lwt.return ()) >>= fun () ->
Eliom_registration.Redirection.send Eliom_service.void_hidden_coservice'
end
else
Eliom_reference.set bad_user true >>= fun () ->
Eliom_registration.Action.send ()
(* -------------------------------------------------------- *)
(* Registration of main services: *)
let () =
Eliom_registration.Html5.register ~service:connect_example_gd connect_example_handler;
Eliom_registration.Any.register ~service:connect_action connect_action_handler
(*****************************************************************************)
(* 2011/08/02 Vincent - Persistent group data
removing group data or not when no session in the group? *)
(*zap* *)
open Html5.F
(*zap* *)
let scope_hierarchy = Eliom_common.create_scope_hierarchy "pers_session_group_data_example_state"
let session = `Session scope_hierarchy
let group = `Session_group scope_hierarchy
(* *zap*)
(* -------------------------------------------------------- *)
(* We create one main service and two (POST) actions *)
(* (for connection and disconnection) *)
let connect_example_pgd =
Eliom_service.service
~path:["psessgrpdata"]
~get_params:unit
()
let connect_action =
Eliom_service.post_coservice'
~name:"connectionpgd"
~post_params:(string "login")
()
(* disconnect action and box: *)
let disconnect_action =
Eliom_registration.Action.register_post_coservice'
~name:"disconnectionpgd"
~post_params:Eliom_parameter.unit
(fun () () -> Eliom_state.discard ~scope:session ())
let disconnect_box s =
Html5.D.post_form disconnect_action
(fun _ -> [p [Html5.D.string_input
~input_type:`Submit ~value:s ()]]) ()
(* The following eref is true if the connection has action failed: *)
let bad_user = Eliom_reference.eref ~scope:Eliom_common.request_scope false
let my_group_data = Eliom_reference.eref ~persistent:"pgd" ~scope:group None
let change_gd =
Eliom_registration.Action.register_post_coservice'
~name:"changepgd"
~post_params:Eliom_parameter.unit
(fun () () -> Eliom_reference.set my_group_data (Some (1000 + Random.int 1000)))
(* -------------------------------------------------------- *)
(* new login box: *)
let login_box session_expired bad_u action =
Html5.D.post_form action
(fun loginname ->
let l =
[pcdata "login: ";
Html5.D.string_input ~input_type:`Text ~name:loginname ()]
in
[p (if bad_u
then (pcdata "Wrong user")::(br ())::l
else
if session_expired
then (pcdata "Session expired")::(br ())::l
else l)
])
()
(* -------------------------------------------------------- *)
(* Handler for the "connect_example" service (main page): *)
let connect_example_handler () () =
(* The following function tests whether the session has expired: *)
let status = Eliom_state.volatile_data_state_status (*zap* *) ~scope:session (* *zap*) ()
in
let group =
Eliom_state.get_volatile_data_session_group (*zap* *) ~scope:session (* *zap*) ()
in
Eliom_reference.get bad_user >>= fun bad_u ->
Eliom_reference.get my_group_data >>= fun my_group_data ->
Lwt.return
(html
(head (title (pcdata "")) [])
(body
(match group, status with
| Some name, _ ->
[p [pcdata ("Hello "^name); br ();
(match my_group_data with
| None -> pcdata "You have no group data."
| Some i -> pcdata ("Your group data is "^string_of_int i^"."));
];
Html5.D.post_form change_gd
(fun () -> [p [Html5.D.string_input
~input_type:`Submit
~value:"Change group data" ()]]) ();
p [pcdata "Check that several sessions have the same group data."];
p [pcdata "Check that persistent group data do not disappear when all sessions from the group are closed."];
p [pcdata "Persistent group data are used as a basic database, for example to store user information (email, etc)."];
disconnect_box "Close session"]
| None, Eliom_state.Expired_state ->
[login_box true bad_u connect_action;
p [em [pcdata "The only user is 'toto'."]]]
| _ ->
[login_box false bad_u connect_action;
p [em [pcdata "The only user is 'toto'."]]]
)))
(* -------------------------------------------------------- *)
(* Handler for connect_action (user logs in): *)
let connect_action_handler () login =
lwt () = Eliom_state.discard ~scope:session () in
if login = "toto" (* Check user and password :-) *)
then begin
Eliom_state.set_volatile_data_session_group ~set_max:4 (*zap* *) ~scope:session (* *zap*) login;
Eliom_reference.get my_group_data >>= fun mgd ->
(if mgd = None
then Eliom_reference.set my_group_data (Some (Random.int 1000))
else Lwt.return ()) >>= fun () ->
Eliom_registration.Redirection.send Eliom_service.void_hidden_coservice'
end
else
Eliom_reference.set bad_user true >>= fun () ->
Eliom_registration.Action.send ()
(* -------------------------------------------------------- *)
(* Registration of main services: *)
let () =
Eliom_registration.Html5.register ~service:connect_example_pgd connect_example_handler;
Eliom_registration.Any.register ~service:connect_action connect_action_handler
(*****************************************************************************)
(* Actions with `NoReload option *)
let noreload_ref = ref 0
let noreload_action =
Eliom_registration.Action.register_coservice'
~options:`NoReload
~get_params:unit
(fun () () -> noreload_ref := !noreload_ref + 1; Lwt.return ())
let noreload =
register_service
~path:["noreload"]
~get_params:unit
(fun () () ->
return
(html
(head (title (pcdata "counter")) [])
(body [p [pcdata (string_of_int (!noreload_ref)); br ();
Html5.D.a ~service:noreload_action
[pcdata "Click to increment the counter."] ();
br ();
pcdata "You should not see the result if you do not reload the page."
]])))
(*****************************************************************************)
(* neopt, by Dario Teixeira *)
let neopt_handler ((a, b), (c, d)) () =
Lwt.return
(html
(head (title (pcdata "Coucou")) [])
(body [
p [pcdata "Coucou:"];
p [pcdata (Printf.sprintf "a: %s" a)];
p [pcdata (Printf.sprintf "b: %s" (match b with Some b -> string_of_int b | None -> "(none)"))];
p [pcdata (Printf.sprintf "c: %s" (match c with Some c -> string_of_float c | None -> "(none)"))];
p [pcdata (Printf.sprintf "d: %s" (match d with Some d -> d | None -> "(none)"))];
]))
let neopt_service =
Eliom_registration.Html5.register_service
~path: ["neopt"]
~get_params: (suffix_prod
(Eliom_parameter.string "a" ** neopt (Eliom_parameter.int "b"))
(neopt (Eliom_parameter.float "c") ** neopt (Eliom_parameter.string "d")))
neopt_handler
let neopt_form ((e_a, e_b), (e_c, e_d)) =
[
fieldset
[
label ~a:[a_for e_a] [pcdata "Enter string 'a':"];
Html5.D.string_input ~a:[a_id "e_a"] ~input_type:`Text ~name:e_a ();
br ();
label ~a:[a_for e_b] [pcdata "Enter int 'b' (neopt):"];
Html5.D.int_input ~a:[a_id "e_b"] ~input_type:`Text ~name:e_b ();
br ();
label ~a:[a_for e_c] [pcdata "Enter float 'c' (neopt):"];
Html5.D.float_input ~a:[a_id "e_c"] ~input_type:`Text ~name:e_c ();
br ();
label ~a:[a_for e_d] [pcdata "Enter string 'd' (neopt):"];
Html5.D.string_input ~a:[a_id "e_d"] ~input_type:`Text ~name:e_d ();
br ();
Html5.D.button ~button_type:`Submit [pcdata "Apply"];
]
]
let main_neopt_handler () () =
Lwt.return
(html
(head (title (pcdata "Main")) [])
(body [
p [
pcdata "Here's a ";
Html5.D.a neopt_service [pcdata "link"] (("foo", None), (None, None));
pcdata " to the neopt service"
];
p [
pcdata "Here's another ";
Html5.D.a neopt_service [pcdata "link"] (("foo", Some 1), (None, None));
pcdata " to the neopt service"
];
p [
pcdata "Here's yet another ";
Html5.D.a neopt_service [pcdata "link"] (("foo", None), (Some 2.0, Some "Olá!"));
pcdata " to the neopt service"
];
p [
pcdata "Here's the final ";
Html5.D.a neopt_service [pcdata "link"] (("foo", Some 1), (Some 2.0, Some "Olá!"));
pcdata " to the neopt service"
];
Html5.D.get_form neopt_service neopt_form;
]))
let main_neopt_service =
Eliom_registration.Html5.register_service
~path: ["neopt0"]
~get_params: Eliom_parameter.unit
main_neopt_handler
eliom-3.0.3/tests/eliom_testsuite1.ml 0000644 0000000 0000000 00000217660 12062377521 016024 0 ustar 00 0000000 0000000 (* Eliom test suite, part 1 *)
(* TODO: extract the tests from the manual or vice versa.
Take the code in the manual, not here! (and remove duplicates here) *)
(* TODO: include some missing parts in the manual *)
open Eliom_lib
open Eliom_content
open Lwt
open Html5.F
open Ocsigen_cookies
open Eliom_service
open Eliom_parameter
open Eliom_state
open Eliom_registration.Html5
let coucou =
register_service
~path:["coucou"]
~get_params:unit
(fun () () ->
return
(html
(head (title (pcdata "")) [])
(body [h1 [pcdata "Hallo!"]])))
let coucou1 =
register_service
~path:["coucou1"]
~get_params:Eliom_parameter.unit
(fun () () ->
let module Html5 = Eliom_content.Html5.F in
return
<<
Coucou
>>)
(*
let coucou_xhtml =
let open XHTML.M in
Eliom_output.Xhtml.register_service
~path:["coucou_xhtml"]
~get_params:unit
(fun () () ->
return
(html
(head (title (pcdata "")) [])
(body [h1 [pcdata "Hallo!"]])))
*)
(*
let coucou1_xthml =
Eliom_output.Html5.register_service
~path:["coucou1_xhtml"]
~get_params:Eliom_parameter.unit
(fun () () ->
let module Html5 = Eliom_content.Html5.F in
return
<:xhtml<
Coucou
>>)
*)
let coucoutext =
Eliom_registration.Html_text.register_service
~path:["coucoutext"]
~get_params:Eliom_parameter.unit
(fun () () ->
return
("n'importe quoi "^
(Eliom_content.Html_text.a coucou "clic" ())^
""))
(*wiki*
Page generation may have side-effects:
*wiki*)
let count =
let next =
let c = ref 0 in
(fun () -> c := !c + 1; !c)
in
register_service
~path:["count"]
~get_params:unit
(fun () () ->
return
(html
(head (title (pcdata "counter")) [])
(body [p [pcdata (string_of_int (next ()))]])))
(*wiki*
As usual in OCaml, you can forget labels when the application
is total:
*wiki*)
let hello =
register_service
["dir";"hello"] (* the url dir/hello *)
unit
(fun () () ->
return
(html
(head (title (pcdata "Hello")) [])
(body [h1 [pcdata "Hello"]])))
(*wiki*
The following example shows how to define the default page for
a directory. (Note that %% means
the default page of the directory %%)
*wiki*)
let default = register_service ["rep";""] unit
(fun () () ->
return
(html
(head (title (pcdata "")) [])
(body [p [pcdata "default page. rep is redirected to rep/"]])))
let writeparams (i1, (i2, s1)) () =
return
(html
(head (title (pcdata "")) [])
(body [p [pcdata "You sent: ";
strong [pcdata (string_of_int i1)];
pcdata ", ";
strong [pcdata (string_of_int i2)];
pcdata " and ";
strong [pcdata s1]]]))
(*zap* you can register twice the same service, with different parameter names
*zap*)
let coucou_params = register_service
~path:["coucou"]
~get_params:(int "i" ** (int "ii" ** string "s"))
writeparams
(*zap* If you register twice exactly the same URL, the server won't start
*zap*)
(*wiki*
*wiki*)
let uasuffix =
register_service
~path:["uasuffix"]
~get_params:(suffix (int "year" ** int "month"))
(fun (year, month) () ->
return
(html
(head (title (pcdata "")) [])
(body
[p [pcdata "The suffix of the url is ";
strong [pcdata ((string_of_int year)^"/"
^(string_of_int month))];
pcdata ", your user-agent is ";
strong [pcdata (Eliom_request_info.get_user_agent ())];
pcdata ", your IP is ";
strong [pcdata (Eliom_request_info.get_remote_ip ())]]])))
(*wiki*
*wiki*)
let isuffix =
register_service
~path:["isuffix"]
~get_params:(suffix_prod (int "suff" ** all_suffix "endsuff") (int "i"))
(fun ((suff, endsuff), i) () ->
return
(html
(head (title (pcdata "")) [])
(body
[p [pcdata "The suffix of the url is ";
strong [pcdata (string_of_int suff)];
pcdata " followed by ";
strong [pcdata (Url.string_of_url_path ~encode:false endsuff)];
pcdata " and i is equal to ";
strong [pcdata (string_of_int i)]]])))
(*wiki*
*wiki*)
let constfix =
register_service
~path:["constfix"]
~get_params:(suffix (string "s1" ** (Eliom_parameter.suffix_const "toto" ** string "s2")))
(fun (s1, ((), s2)) () ->
return
(html
(head (title (pcdata "")) [])
(body [h1
[pcdata "Suffix with constants"];
p [pcdata ("Parameters are "^s1^" and "^s2)]])))
(*wiki*
*wiki*)
type mysum = A | B
let mysum_of_string = function
| "A" -> A
| "B" -> B
| _ -> raise (Failure "mysum_of_string")
let string_of_mysum = function
| A -> "A"
| B -> "B"
let mytype =
Eliom_registration.Html5.register_service
~path:["mytype"]
~get_params:
(Eliom_parameter.user_type mysum_of_string string_of_mysum "valeur")
(fun x () ->
let v = string_of_mysum x in
return
(html
(head (title (pcdata "")) [])
(body [p [pcdata (v^" is valid. Now try with another value.")]])))
(*wiki*
*wiki*)
let raw_serv =
register_service
~path:["any"]
~get_params:Eliom_parameter.any
(fun l () ->
let module Html5 = Eliom_content.Html5.F in
let ll =
List.map
(fun (a,s) -> <:html5< ($str:a$, $str:s$) >>) l
in
return
<:html5<
You sent:
$list:ll$
>>)
(*wiki*
*wiki*)
let catch = register_service
~path:["catch"]
~get_params:(int "i")
~error_handler:(fun l ->
return
(html
(head (title (pcdata "")) [])
(body [p [pcdata ("i is not an integer.")]])))
(fun i () ->
let v = string_of_int i in
return
(html
(head (title (pcdata "")) [])
(body [p [pcdata ("i is an integer: "^v)]])))
(*wiki*
*wiki*)
let links = register_service ["rep";"links"] unit
(fun () () ->
return
(html
(head (title (pcdata "Links")) [])
(body
[p
[Html5.D.a coucou [pcdata "coucou"] (); br ();
Html5.D.a hello [pcdata "hello"] (); br ();
Html5.D.a default
[pcdata "default page of the dir"] (); br ();
Html5.D.a uasuffix
[pcdata "uasuffix"] (2007,06); br ();
Html5.D.a coucou_params
[pcdata "coucou_params"] (42,(22,"ciao")); br ();
Html5.D.a raw_serv
[pcdata "raw_serv"] [("sun","yellow");("sea","blue and pink")]; br ();
Html5.D.a
(external_service
~prefix:"http://fr.wikipedia.org"
~path:["wiki";""]
~get_params:(suffix (all_suffix "suff"))
())
[pcdata "OCaml on wikipedia"]
["OCaml"]; br ();
Html5.F.Raw.a
~a:[a_href (Xml.uri_of_string "http://en.wikipedia.org/wiki/OCaml")]
[pcdata "OCaml on wikipedia"]
]])))
(*zap*
Note that to create a link we need to know the current url, because:
the link from toto/titi to toto/tata is "tata" and not "toto/tata"
*zap*)
(*wiki*
*wiki*)
let linkrec = Eliom_service.service ["linkrec"] unit ()
let _ = Eliom_registration.Html5.register linkrec
(fun () () ->
return
(html
(head (title (pcdata "")) [])
(body [p [a linkrec [pcdata "click"] ()]])))
(*zap* If some url are not registered, the server will not start:
let essai =
new_url
~path:["essai"]
~server_params:no_server_param
~get_params:no_get_param
()
*zap*)
(*zap* pour les reload : le serveur ne s'éteint pas mais ajoute un message sur les services non enregistrés dans son log *zap*)
(*wiki*
*wiki*)
let create_form =
(fun (number_name, (number2_name, string_name)) ->
[p [pcdata "Write an int: ";
Html5.D.int_input ~input_type:`Text ~name:number_name ();
pcdata "Write another int: ";
Html5.D.int_input ~input_type:`Text ~name:number2_name ();
pcdata "Write a string: ";
Html5.D.string_input ~input_type:`Text ~name:string_name ();
Html5.D.string_input ~input_type:`Submit ~value:"Click" ()]])
let form = register_service ["form"] unit
(fun () () ->
let f = Html5.D.get_form coucou_params create_form in
return
(html
(head (title (pcdata "")) [])
(body [f])))
(*wiki*
*wiki*)
let raw_form = register_service
~path:["anyform"]
~get_params:unit
(fun () () ->
return
(html
(head (title (pcdata "")) [])
(body
[h1 [pcdata "Any Form"];
Html5.D.get_form raw_serv
(fun () ->
[p [pcdata "Form to raw_serv: ";
Html5.D.raw_input ~input_type:`Text ~name:"plop" ();
Html5.D.raw_input ~input_type:`Text ~name:"plip" ();
Html5.D.raw_input ~input_type:`Text ~name:"plap" ();
Html5.D.string_input ~input_type:`Submit ~value:"Click" ()]])
])))
(*wiki*
*wiki*)
let no_post_param_service =
register_service
~path:["post"]
~get_params:unit
(fun () () ->
return
(html
(head (title (pcdata "")) [])
(body [h1 [pcdata
"Version of the page without POST parameters"]])))
let my_service_with_post_params =
register_post_service
~fallback:no_post_param_service
~post_params:(string "value")
(fun () value ->
return
(html
(head (title (pcdata "")) [])
(body [h1 [pcdata value]])))
(*wiki*
Services may take both GET and POST parameters:
*wiki*)
let get_no_post_param_service =
register_service
~path:["post2"]
~get_params:(int "i")
(fun i () ->
return
(html
(head (title (pcdata "")) [])
(body [p [pcdata "No POST parameter, i:";
em [pcdata (string_of_int i)]]])))
let my_service_with_get_and_post = register_post_service
~fallback:get_no_post_param_service
~post_params:(string "value")
(fun i value ->
return
(html
(head (title (pcdata "")) [])
(body [p [pcdata "Value: ";
em [pcdata value];
pcdata ", i: ";
em [pcdata (string_of_int i)]]])))
(*wiki*
POST forms
*wiki*)
let form2 = register_service ["form2"] unit
(fun () () ->
let f =
(Html5.D.post_form my_service_with_post_params
(fun chaine ->
[p [pcdata "Write a string: ";
string_input ~input_type:`Text ~name:chaine ()]]) ()) in
return
(html
(head (title (pcdata "form")) [])
(body [f])))
let form3 = register_service ["form3"] unit
(fun () () ->
let module Html5 = Eliom_content.Html5.F in
let f =
(Eliom_content.Html5.D.post_form my_service_with_get_and_post
(fun chaine ->
<:html5list< Write a string:
$string_input ~input_type:`Text ~name:chaine ()$
>>)
222) in
return
<:html5<
$f$ >>)
let form4 = register_service ["form4"] unit
(fun () () ->
let module Html5 = Eliom_content.Html5.F in
let f =
(Eliom_content.Html5.D.post_form
(external_post_service
~prefix:"http://www.petizomverts.com"
~path:["zebulon"]
~get_params:(int "i")
~post_params:(string "chaine") ())
(fun chaine ->
<:html5list< Write a string:
$string_input ~input_type:`Text ~name:chaine ()$
>>)
222) in
return
(html
(head (title (pcdata "form")) [])
(body [f])))
(*wiki*
Lwt
%
Unix.sleep 5;
return
(html
(head (title (pcdata "")) [])
(body [h1 [pcdata "Ok now, you can read the page."]])))
>%
*wiki*)
let looong =
register_service
~path:["looong"]
~get_params:unit
(fun () () ->
Lwt_unix.sleep 5.0 >>= fun () ->
return
(html
(head (title (pcdata "")) [])
(body [h1 [pcdata
"Ok now, you can read the page."]])))
(*wiki*
*wiki*)
let looong2 =
register_service
~path:["looong2"]
~get_params:unit
(fun () () ->
Lwt_preemptive.detach Unix.sleep 5 >>= fun () ->
return
(html
(head (title (pcdata "")) [])
(body [h1 [pcdata
"Ok now, you can read the page."]])))
(*wiki*
*wiki*)
(************************************************************)
(************ Connection of users, version 1 ****************)
(************************************************************)
(*zap* *)
let scope_hierarchy = Eliom_common.create_scope_hierarchy "session_data"
let session = `Session scope_hierarchy
(* *zap*)
(* "my_table" will be the structure used to store
the session data (namely the login name): *)
let my_table = Eliom_state.create_volatile_table (*zap* *) ~scope:session (* *zap*) ()
(* -------------------------------------------------------- *)
(* Create services, but do not register them yet: *)
let session_data_example =
Eliom_service.service
~path:["sessdata"]
~get_params:Eliom_parameter.unit
()
let session_data_example_with_post_params =
Eliom_service.post_service
~fallback:session_data_example
~post_params:(Eliom_parameter.string "login")
()
let session_data_example_close =
Eliom_service.service
~path:["close"]
~get_params:Eliom_parameter.unit
()
(* -------------------------------------------------------- *)
(* Handler for the "session_data_example" service: *)
let session_data_example_handler _ _ =
let sessdat = Eliom_state.get_volatile_data ~table:my_table () in
return
(html
(head (title (pcdata "")) [])
(body
[
match sessdat with
| Eliom_state.Data name ->
p [pcdata ("Hello "^name);
br ();
Html5.D.a
session_data_example_close
[pcdata "close session"] ()]
| Eliom_state.Data_session_expired
| Eliom_state.No_data ->
Html5.D.post_form
session_data_example_with_post_params
(fun login ->
[p [pcdata "login: ";
Html5.D.string_input
~input_type:`Text ~name:login ()]]) ()
]))
(* -------------------------------------------------------- *)
(* Handler for the "session_data_example_with_post_params" *)
(* service with POST params: *)
let session_data_example_with_post_params_handler _ login =
lwt () = Eliom_state.discard (*zap* *) ~scope:session (* *zap*) () in
Eliom_state.set_volatile_data ~table:my_table login;
return
(html
(head (title (pcdata "")) [])
(body
[p [pcdata ("Welcome " ^ login ^ ". You are now connected.");
br ();
Html5.D.a session_data_example
[pcdata "Try again"] ()
]]))
(* -------------------------------------------------------- *)
(* Handler for the "session_data_example_close" service: *)
let session_data_example_close_handler () () =
let sessdat = Eliom_state.get_volatile_data ~table:my_table () in
lwt () = Eliom_state.discard (*zap* *) ~scope:session (* *zap*) () in
return
(html
(head (title (pcdata "Disconnect")) [])
(body [
(match sessdat with
| Eliom_state.Data_session_expired -> p [pcdata "Your session has expired."]
| Eliom_state.No_data -> p [pcdata "You were not connected."]
| Eliom_state.Data _ -> p [pcdata "You have been disconnected."]);
p [Html5.D.a session_data_example [pcdata "Retry"] () ]]))
(* -------------------------------------------------------- *)
(* Registration of main services: *)
let () =
Eliom_registration.Html5.register
session_data_example_close session_data_example_close_handler;
Eliom_registration.Html5.register
session_data_example session_data_example_handler;
Eliom_registration.Html5.register
session_data_example_with_post_params
session_data_example_with_post_params_handler
(*zap* *)
let () = set_default_global_service_state_timeout
~cookie_level:`Session (Some 600.)
let () = set_default_global_persistent_data_state_timeout
~cookie_level:`Session (Some 3600.)
(* *zap*)
(************************************************************)
(************ Connection of users, version 2 ****************)
(************************************************************)
(*zap* *)
let scope_hierarchy = Eliom_common.create_scope_hierarchy "session_services"
let session = `Session scope_hierarchy
(* *zap*)
(* -------------------------------------------------------- *)
(* Create services, but do not register them yet: *)
let session_services_example =
Eliom_service.service
~path:["sessionservices"]
~get_params:Eliom_parameter.unit
()
let session_services_example_with_post_params =
Eliom_service.post_service
~fallback:session_services_example
~post_params:(Eliom_parameter.string "login")
()
let session_services_example_close =
Eliom_service.service
~path:["close2"]
~get_params:Eliom_parameter.unit
()
(* ------------------------------------------------------------- *)
(* Handler for the "session_services_example" service: *)
(* It displays the main page of our site, with a login form. *)
let session_services_example_handler () () =
let f =
Html5.D.post_form
session_services_example_with_post_params
(fun login ->
[p [pcdata "login: ";
string_input ~input_type:`Text ~name:login ()]]) ()
in
return
(html
(head (title (pcdata "")) [])
(body [f]))
(* ------------------------------------------------------------- *)
(* Handler for the "session_services_example_close" service: *)
let session_services_example_close_handler () () =
lwt () = Eliom_state.discard (*zap* *) ~scope:session (* *zap*) () in
return
(html
(head (title (pcdata "Disconnect")) [])
(body [p [pcdata "You have been disconnected. ";
a session_services_example
[pcdata "Retry"] ()
]]))
(*wiki*
When the page is called with login parameters,
it runs the function %%
that replaces some services already defined by new ones:
*wiki*)
(* ------------------------------------------------------------- *)
(* Handler for the "session_services_example_with_post_params" *)
(* service: *)
let launch_session () login =
(* New handler for the main page: *)
let new_main_page () () =
return
(html
(head (title (pcdata "")) [])
(body [p [pcdata "Welcome ";
pcdata login;
pcdata "!"; br ();
a coucou [pcdata "coucou"] (); br ();
a hello [pcdata "hello"] (); br ();
a links [pcdata "links"] (); br ();
a session_services_example_close
[pcdata "close session"] ()]]))
in
(* If a session was opened, we close it first! *)
lwt () = Eliom_state.discard ~scope:session () in
(* Now we register new versions of main services in the
session service table: *)
Eliom_registration.Html5.register ~scope:session
~service:session_services_example
(* service is any public service already registered,
here the main page of our site *)
new_main_page;
Eliom_registration.Html5.register ~scope:session
~service:coucou
(fun () () ->
return
(html
(head (title (pcdata "")) [])
(body [p [pcdata "Coucou ";
pcdata login;
pcdata "!"]])));
Eliom_registration.Html5.register ~scope:session
~service:hello
(fun () () ->
return
(html
(head (title (pcdata "")) [])
(body [p [pcdata "Ciao ";
pcdata login;
pcdata "!"]])));
new_main_page () ()
(* -------------------------------------------------------- *)
(* Registration of main services: *)
let () =
Eliom_registration.Html5.register
~service:session_services_example
session_services_example_handler;
Eliom_registration.Html5.register
~service:session_services_example_close
session_services_example_close_handler;
Eliom_registration.Html5.register
~service:session_services_example_with_post_params
launch_session
(*zap* Registering for session during initialisation is forbidden:
let _ = register ~scope:`Session
~path:coucou1
%<
humhum
>%
*zap*)
(*wiki*
*wiki*)
(************************************************************)
(************** Coservices. Basic examples ******************)
(************************************************************)
(* -------------------------------------------------------- *)
(* We create one main service and two coservices: *)
let coservices_example =
Eliom_service.service
~path:["coserv"]
~get_params:Eliom_parameter.unit
()
let coservices_example_post =
Eliom_service.post_coservice
~fallback:coservices_example
~post_params:Eliom_parameter.unit
()
let coservices_example_get =
Eliom_service.coservice
~fallback:coservices_example
~get_params:Eliom_parameter.unit
()
(* -------------------------------------------------------- *)
(* The three of them display the same page, *)
(* but the coservices change the counter. *)
let _ =
let c = ref 0 in
let page () () =
let l3 = Html5.D.post_form coservices_example_post
(fun _ -> [p [Html5.D.string_input
~input_type:`Submit
~value:"incr i (post)" ()]]) ()
in
let l4 = Html5.D.get_form coservices_example_get
(fun _ -> [p [Html5.D.string_input
~input_type:`Submit
~value:"incr i (get)" ()]])
in
return
(html
(head (title (pcdata "")) [])
(body [p [pcdata "i is equal to ";
pcdata (string_of_int !c); br ();
a coservices_example [pcdata "reload"] (); br ();
a coservices_example_get [pcdata "incr i"] ()];
l3;
l4]))
in
Eliom_registration.Html5.register coservices_example page;
let f () () = c := !c + 1; page () () in
Eliom_registration.Html5.register coservices_example_post f;
Eliom_registration.Html5.register coservices_example_get f
(*wiki*
%%
%
%). The style of programming used by Eliom
is closer to //Continuation Passing Style// (CPS), and has the
advantage that it does not need control operators, and fits
very well Web programming.
Coservices allow to create dynamically
new continuations that depend on previous interactions with users
([[manual/dev/2#p2calc|See the %
% example below]]).
Such a behaviour is difficult to simulate with traditional Web
programming.
>%
*wiki*)
(*zap* Queinnec example: *zap*)
(************************************************************)
(*************** calc: sum of two integers ******************)
(************************************************************)
(*zap* *)
let calc_example_scope_hierarchy = Eliom_common.create_scope_hierarchy "calc_example"
let session = `Session calc_example_scope_hierarchy
let session_group = `Session_group calc_example_scope_hierarchy
(* *zap*)
(* -------------------------------------------------------- *)
(* We create two main services on the same URL, *)
(* one with a GET integer parameter: *)
let calc =
service
~path:["calc"]
~get_params:unit
()
let calc_i =
service
~path:["calc"]
~get_params:(int "i")
()
(* -------------------------------------------------------- *)
(* The handler for the service without parameter. *)
(* It displays a form where you can write an integer value: *)
let calc_handler () () =
let create_form intname =
[p [pcdata "Write a number: ";
Html5.D.int_input ~input_type:`Text ~name:intname ();
br ();
Html5.D.string_input ~input_type:`Submit ~value:"Send" ()]]
in
let f = Html5.D.get_form calc_i create_form in
return
(html
(head (title (pcdata "")) [])
(body [f]))
(* -------------------------------------------------------- *)
(* The handler for the service with parameter. *)
(* It creates dynamically and registers a new coservice *)
(* with one GET integer parameter. *)
(* This new coservice depends on the first value (i) *)
(* entered by the user. *)
let calc_i_handler i () =
let create_form is =
(fun entier ->
[p [pcdata (is^" + ");
int_input ~input_type:`Text ~name:entier ();
br ();
string_input ~input_type:`Submit ~value:"Sum" ()]])
in
let is = string_of_int i in
let calc_result =
register_coservice ~scope:Eliom_common.default_session_scope
~fallback:calc
~get_params:(int "j")
(fun j () ->
let js = string_of_int j in
let ijs = string_of_int (i+j) in
return
(html
(head (title (pcdata "")) [])
(body
[p [pcdata (is^" + "^js^" = "^ijs)]])))
in
let f = get_form calc_result (create_form is) in
return
(html
(head (title (pcdata "")) [])
(body [f]))
(* -------------------------------------------------------- *)
(* Registration of main services: *)
let () =
Eliom_registration.Html5.register calc calc_handler;
Eliom_registration.Html5.register calc_i calc_i_handler
(*wiki*
*wiki*)
(************************************************************)
(************ Connection of users, version 3 ****************)
(************************************************************)
(*zap* *)
let connect_example3_scope_hierarchy = Eliom_common.create_scope_hierarchy "connect_example3"
let session = `Session connect_example3_scope_hierarchy
let session_group = `Session_group connect_example3_scope_hierarchy
let my_table = Eliom_state.create_volatile_table (*zap* *) ~scope:session (* *zap*) ()
(* *zap*)
(* -------------------------------------------------------- *)
(* We create one main service and two (POST) actions *)
(* (for connection and disconnection) *)
let connect_example3 =
Eliom_service.service
~path:["action"]
~get_params:Eliom_parameter.unit
()
let connect_action =
Eliom_service.post_coservice'
~name:"connect3"
~post_params:(Eliom_parameter.string "login")
()
(* As the handler is very simple, we register it now: *)
let disconnect_action =
Eliom_registration.Action.register_post_coservice'
~name:"disconnect3"
~post_params:Eliom_parameter.unit
(fun () () ->
Eliom_state.discard (*zap* *) ~scope:session (* *zap*) ())
(* -------------------------------------------------------- *)
(* login ang logout boxes: *)
let disconnect_box s =
Html5.D.post_form disconnect_action
(fun _ -> [p [Html5.D.string_input
~input_type:`Submit ~value:s ()]]) ()
let login_box () =
Html5.D.post_form connect_action
(fun loginname ->
[p
(let l = [pcdata "login: ";
Html5.D.string_input
~input_type:`Text ~name:loginname ()]
in l)
])
()
(* -------------------------------------------------------- *)
(* Handler for the "connect_example3" service (main page): *)
let connect_example3_handler () () =
let sessdat = Eliom_state.get_volatile_data ~table:my_table () in
return
(html
(head (title (pcdata "")) [])
(body
(match sessdat with
| Eliom_state.Data name ->
[p [pcdata ("Hello "^name); br ()];
disconnect_box "Close session"]
| Eliom_state.Data_session_expired
| Eliom_state.No_data -> [login_box ()]
)))
(* -------------------------------------------------------- *)
(* Handler for connect_action (user logs in): *)
let connect_action_handler () login =
lwt () = Eliom_state.discard (*zap* *) ~scope:session (* *zap*) () in
Eliom_state.set_volatile_data ~table:my_table login;
return ()
(* -------------------------------------------------------- *)
(* Registration of main services: *)
let () =
Eliom_registration.Html5.register ~service:connect_example3 connect_example3_handler;
Eliom_registration.Action.register ~service:connect_action connect_action_handler
(*wiki*
*wiki*)
let divpage =
Eliom_registration.Flow5.register_service
~path:["div"]
~get_params:unit
(fun () () ->
return
[div [h2 [pcdata "Hallo"];
p [pcdata "Blablablabla"] ]])
(*wiki*
*wiki*)
let redir1 = Eliom_registration.Redirection.register_service
~path:["redir"]
~get_params:Eliom_parameter.unit
(fun () () -> Lwt.return coucou)
(*wiki*
*wiki*)
let redir = Eliom_registration.Redirection.register_service
~path:["redir"]
~get_params:(int "o")
(fun o () ->
Lwt.return
(Eliom_service.preapply coucou_params (o,(22,"ee"))))
(*wiki*
*wiki*)
let send_any =
Eliom_registration.Any.register_service
~path:["sendany"]
~get_params:(string "type")
(fun s () ->
if s = "valid"
then
Eliom_registration.Html5.send
(html
(head (title (pcdata "")) [])
(body [p [pcdata
"This page has been statically typechecked.
If you change the parameter in the URL you will get an unchecked text page"]]))
else
Eliom_registration.Html_text.send
"It is not a valid page. Put type=\"valid\" in the URL to get a typechecked page.
"
)
(*wiki*
Cookies
*wiki*)
let cookiename = "mycookie"
let cookies = service ["cookies"] unit ()
let _ = Eliom_registration.Html5.register cookies
(fun () () ->
Eliom_state.set_cookie
~name:cookiename ~value:(string_of_int (Random.int 100)) ();
Lwt.return
(html
(head (title (pcdata "")) [])
(body [p [pcdata (try
"cookie value: "^
(CookiesTable.find
cookiename (Eliom_request_info.get_cookies ()))
with _ -> "");
br ();
a cookies [pcdata "send other cookie"] ()]])))
(*wiki*
*wiki*)
let mystore = Ocsipersist.open_store "eliomexamplestore2"
let count2 =
let next =
let cthr = Ocsipersist.make_persistent mystore "countpage" 0 in
let mutex = Lwt_mutex.create () in
(fun () ->
cthr >>= fun c ->
Lwt_mutex.lock mutex >>= fun () ->
Ocsipersist.get c >>= fun oldc ->
let newc = oldc + 1 in
Ocsipersist.set c newc >>= fun () ->
Lwt_mutex.unlock mutex;
Lwt.return newc)
in
register_service
~path:["count2"]
~get_params:unit
(fun () () ->
next () >>=
(fun n ->
return
(html
(head (title (pcdata "counter")) [])
(body [p [pcdata (string_of_int n)]]))))
(*wiki*
*wiki*)
(************************************************************)
(************ Connection of users, version 4 ****************)
(**************** (persistent sessions) *********************)
(************************************************************)
(*zap* *)
let persistent_sessions_scope_hierarchy = Eliom_common.create_scope_hierarchy "persistent_sessions"
let session = `Session persistent_sessions_scope_hierarchy
let session_group = `Session_group persistent_sessions_scope_hierarchy
let persistent_session_scope = session
(* *zap*)
let my_persistent_table =
create_persistent_table (*zap* *) ~scope:session (* *zap*) "eliom_example_table"
(* -------------------------------------------------------- *)
(* We create one main service and two (POST) actions *)
(* (for connection and disconnection) *)
let persist_session_example =
Eliom_service.service
~path:["persist"]
~get_params:unit
()
let persist_session_connect_action =
Eliom_service.post_coservice'
~name:"connect4"
~post_params:(string "login")
()
(* disconnect_action, login_box and disconnect_box have been
defined in the section about actions *)
(*zap* *)
(* -------------------------------------------------------- *)
(* Actually, no. It's a lie because we don't use the
same session name :-) *)
(* new disconnect action and box: *)
let disconnect_action =
Eliom_registration.Action.register_post_coservice'
~name:"disconnect4"
~post_params:Eliom_parameter.unit
(fun () () ->
Eliom_state.discard ~scope:session ())
let disconnect_box s =
Html5.D.post_form disconnect_action
(fun _ -> [p [Html5.D.string_input
~input_type:`Submit ~value:s ()]]) ()
let bad_user_key = Polytables.make_key ()
let get_bad_user table =
try Polytables.get ~table ~key:bad_user_key with Not_found -> false
(* -------------------------------------------------------- *)
(* new login box: *)
let login_box session_expired action =
Html5.D.post_form action
(fun loginname ->
let l =
[pcdata "login: ";
string_input ~input_type:`Text ~name:loginname ()]
in
[p (if get_bad_user (Eliom_request_info.get_request_cache ())
then (pcdata "Wrong user")::(br ())::l
else
if session_expired
then (pcdata "Session expired")::(br ())::l
else l)
])
()
(* *zap*)
(* ----------------------------------------------------------- *)
(* Handler for "persist_session_example" service (main page): *)
let persist_session_example_handler () () =
Eliom_state.get_persistent_data
~table:my_persistent_table () >>= fun sessdat ->
return
(html
(head (title (pcdata "")) [])
(body
(match sessdat with
| Eliom_state.Data name ->
[p [pcdata ("Hello "^name); br ()];
disconnect_box "Close session"]
| Eliom_state.Data_session_expired ->
[login_box true persist_session_connect_action;
p [em [pcdata "The only user is 'toto'."]]]
| Eliom_state.No_data ->
[login_box false persist_session_connect_action;
p [em [pcdata "The only user is 'toto'."]]]
)))
(* ----------------------------------------------------------- *)
(* Handler for persist_session_connect_action (user logs in): *)
let persist_session_connect_action_handler () login =
lwt () = Eliom_state.discard (*zap* *) ~scope:session (* *zap*) () in
if login = "toto" (* Check user and password :-) *)
then
Eliom_state.set_persistent_data ~table:my_persistent_table login
else ((*zap* *)Polytables.set (Eliom_request_info.get_request_cache ()) bad_user_key true;(* *zap*)return ())
(* -------------------------------------------------------- *)
(* Registration of main services: *)
let () =
Eliom_registration.Html5.register
~service:persist_session_example
persist_session_example_handler;
Eliom_registration.Action.register
~service:persist_session_connect_action
persist_session_connect_action_handler
(*wiki*
*wiki*)
(************************************************************)
(************ Connection of users, version 6 ****************)
(************************************************************)
(*zap* *)
let scope_hierarchy = Eliom_common.create_scope_hierarchy "connect_example6"
let session = `Session scope_hierarchy
let session_group = `Session_group scope_hierarchy
(* *zap*)
(* -------------------------------------------------------- *)
(* We create one main service and two (POST) actions *)
(* (for connection and disconnection) *)
let connect_example6 =
Eliom_service.service
~path:["action2"]
~get_params:unit
()
let connect_action =
Eliom_service.post_coservice'
~name:"connect6"
~post_params:(string "login")
()
(* new disconnect action and box: *)
let disconnect_action =
Eliom_registration.Action.register_post_coservice'
~name:"disconnect6"
~post_params:Eliom_parameter.unit
(fun () () ->
Eliom_state.discard (*zap* *) ~scope:session (* *zap*) ())
let disconnect_box s =
Html5.D.post_form disconnect_action
(fun _ -> [p [Html5.D.string_input
~input_type:`Submit ~value:s ()]]) ()
let bad_user_key = Polytables.make_key ()
let get_bad_user table =
try Polytables.get ~table ~key:bad_user_key with Not_found -> false
(* -------------------------------------------------------- *)
(* new login box: *)
let login_box session_expired action =
Html5.D.post_form action
(fun loginname ->
let l =
[pcdata "login: ";
string_input ~input_type:`Text ~name:loginname ()]
in
[p (if get_bad_user (Eliom_request_info.get_request_cache ())
then (pcdata "Wrong user")::(br ())::l
else
if session_expired
then (pcdata "Session expired")::(br ())::l
else l)
])
()
(* -------------------------------------------------------- *)
(* Handler for the "connect_example6" service (main page): *)
let connect_example6_handler () () =
let status = Eliom_state.volatile_data_state_status (*zap* *) ~scope:session (* *zap*) ()
in
let group =
Eliom_state.get_volatile_data_session_group (*zap* *) ~scope:session (* *zap*) ()
in
return
(html
(head (title (pcdata "")) [])
(body
(match group, status with
| Some name, _ ->
[p [pcdata ("Hello "^name); br ()];
disconnect_box "Close session"]
| None, Eliom_state.Expired_state ->
[login_box true connect_action;
p [em [pcdata "The only user is 'toto'."]]]
| _ ->
[login_box false connect_action;
p [em [pcdata "The only user is 'toto'."]]]
)))
(* -------------------------------------------------------- *)
(* New handler for connect_action (user logs in): *)
let connect_action_handler () login =
lwt () = Eliom_state.discard (*zap* *) ~scope:session (* *zap*) () in
if login = "toto" (* Check user and password :-) *)
then begin
Eliom_state.set_volatile_data_session_group ~set_max:4
(*zap* *) ~scope:session (* *zap*) login;
return ()
end
else begin
Polytables.set (Eliom_request_info.get_request_cache ()) bad_user_key true;
return ()
end
(* -------------------------------------------------------- *)
(* Registration of main services: *)
let () =
Eliom_registration.Html5.register ~service:connect_example6 connect_example6_handler;
Eliom_registration.Action.register ~service:connect_action connect_action_handler
(*wiki*
*wiki*)
let disposable = service ["disposable"] unit ()
let _ = register disposable
(fun () () ->
let disp_coservice =
coservice ~max_use:2 ~fallback:disposable ~get_params:unit ()
in
register ~scope:Eliom_common.default_session_scope ~service:disp_coservice
(fun () () ->
return
(html
(head (title (pcdata "")) [])
(body [p [pcdata "I am a disposable coservice";
br ();
a disp_coservice [pcdata "Try me once again"] ()]]))
);
return
(html
(head (title (pcdata "")) [])
(body [p [(if Eliom_request_info.get_link_too_old ()
then pcdata "Your link was outdated. I am the fallback. I just created a new disposable coservice. You can use it only twice."
else
pcdata "I just created a disposable coservice. You can use it only twice.");
br ();
a disp_coservice [pcdata "Try it!"] ()]])))
(*wiki*
*wiki*)
let timeout = service ["timeout"] unit ()
let _ =
let page () () =
let timeoutcoserv =
register_coservice ~scope:session
~fallback:timeout ~get_params:unit ~timeout:5.
(fun _ _ ->
return
(html
(head (title (pcdata "Coservices with timeouts")) [])
(body [p
[pcdata "I am a coservice with timeout."; br ();
pcdata "Try to reload the page!"; br ();
pcdata "I will disappear after 5 seconds of inactivity." ];
])))
in
return
(html
(head (title (pcdata "Coservices with timeouts")) [])
(body [p
[pcdata "I just created a coservice with 5 seconds timeout."; br ();
a timeoutcoserv [pcdata "Try it"] (); ];
]))
in
register timeout page
(*wiki*
*wiki*)
let publiccoduringsess = service ["publiccoduringsess"] unit ()
let _ =
let page () () =
let timeoutcoserv =
register_coservice
~fallback:publiccoduringsess ~get_params:unit ~timeout:5.
(fun _ _ ->
return
(html
(head (title (pcdata "Coservices with timeouts")) [])
(body [p
[pcdata "I am a public coservice with timeout."; br ();
pcdata "I will disappear after 5 seconds of inactivity." ];
])))
in
return
(html
(head (title (pcdata "Public coservices with timeouts")) [])
(body [p
[pcdata "I just created a public coservice with 5 seconds timeout."; br ();
a timeoutcoserv [pcdata "Try it"] (); ];
]))
in
register publiccoduringsess page
(*wiki*
*wiki*)
let _ = Eliom_registration.set_exn_handler
(fun e -> match e with
| Eliom_common.Eliom_404 ->
Eliom_registration.Html5.send ~code:404
(html
(head (title (pcdata "")) [])
(body [h1 [pcdata "Eliom tutorial"];
p [pcdata "Page not found"]]))
(* | Eliom_common.Eliom_Wrong_parameter ->
Eliom_registration.Html5.send
(html
(head (title (pcdata "")) [])
(body [h1 [pcdata "Eliom tutorial"];
p [pcdata "Wrong parameters"]])) *)
| e -> fail e)
(*wiki*
*wiki*)
let my_nl_params =
Eliom_parameter.make_non_localized_parameters
~prefix:"tutoeliom"
~name:"mynlparams"
(Eliom_parameter.int "a" ** Eliom_parameter.string "s")
let nlparams = service ~path:["nlparams"] ~get_params:(int "i") ()
let make_body () =
[p [a ~service:nlparams [pcdata "without nl params"] 4];
p [a ~service:nlparams
~nl_params:(Eliom_parameter.add_nl_parameter
Eliom_parameter.empty_nl_params_set
my_nl_params
(22, "oh")
)
[pcdata "with nl params"]
5];
get_form
~service:nlparams
~nl_params:(Eliom_parameter.add_nl_parameter
Eliom_parameter.empty_nl_params_set
my_nl_params
(22, "oh")
)
(fun iname ->
[p [pcdata "form with hidden nl params";
Html5.D.int_input
~input_type:`Text ~name:iname ();
Html5.D.string_input
~input_type:`Submit ~value:"Send" ()]]);
get_form
~service:nlparams
(fun iname ->
let (aname, sname) =
Eliom_parameter.get_nl_params_names my_nl_params
in
[p [pcdata "form with nl params fiels";
Html5.D.int_input
~input_type:`Text ~name:iname ();
Html5.D.int_input
~input_type:`Text ~name:aname ();
Html5.D.string_input
~input_type:`Text ~name:sname ();
Html5.D.string_input
~input_type:`Submit ~value:"Send" ()]]);
]
let _ = register
nlparams
(fun i () ->
Lwt.return
(html
(head (title (pcdata "")) [])
(body ((p [pcdata "i = ";
strong [pcdata (string_of_int i)]])::
(match Eliom_parameter.get_non_localized_get_parameters
my_nl_params
with
| None ->
p [pcdata "I do not have my non localized parameters"]
| Some (a, s) ->
p [pcdata "I have my non localized parameters, ";
pcdata ("with values a = "^string_of_int a^
" and s = "^s^".")]
)::make_body ())))
)
(*wiki*
*wiki*)
let tonlparams = register_service
~path:["nlparams"]
~get_params:unit
(fun () () ->
Lwt.return
(html
(head (title (pcdata "")) [])
(body (make_body ()))))
(*wiki*
*wiki*)
let nlparams_with_nlp =
Eliom_service.add_non_localized_get_parameters my_nl_params nlparams
(*wiki*
*wiki*)
(************************************************************)
(************ Connection of users, version 5 ****************)
(************************************************************)
(*zap* *)
let scope_hierarchy = Eliom_common.create_scope_hierarchy "connect_example5"
let session = `Session scope_hierarchy
let session_group = `Session_group scope_hierarchy
(* *zap*)
(* -------------------------------------------------------- *)
(* We create one main service and two (POST) actions *)
(* (for connection and disconnection) *)
let connect_example5 =
Eliom_service.service
~path:["groups"]
~get_params:Eliom_parameter.unit
()
let connect_action =
Eliom_service.post_coservice'
~name:"connect5"
~post_params:(Eliom_parameter.string "login")
()
(* As the handler is very simple, we register it now: *)
let disconnect_action =
Eliom_registration.Action.register_post_coservice'
~name:"disconnect5"
~post_params:Eliom_parameter.unit
(fun () () ->
Eliom_state.discard (*zap* *) ~scope:session (* *zap*) ())
(* -------------------------------------------------------- *)
(* login ang logout boxes: *)
let disconnect_box s =
Html5.D.post_form disconnect_action
(fun _ -> [p [Html5.D.string_input
~input_type:`Submit ~value:s ()]]) ()
let login_box () =
Html5.D.post_form connect_action
(fun loginname ->
[p
(let l = [pcdata "login: ";
Html5.D.string_input
~input_type:`Text ~name:loginname ()]
in l)
])
()
(* -------------------------------------------------------- *)
(* Handler for the "connect_example5" service (main page): *)
let connect_example5_handler () () =
let sessdat = Eliom_state.get_volatile_data_session_group (*zap* *) ~scope:session (* *zap*) () in
return
(html
(head (title (pcdata "")) [])
(body
(match sessdat with
| Some name ->
[p [pcdata ("Hello "^name); br ()];
disconnect_box "Close session"]
| None -> [login_box ()]
)))
(* -------------------------------------------------------- *)
(* Handler for connect_action (user logs in): *)
let connect_action_handler () login =
Eliom_state.discard (*zap* *) ~scope:session (* *zap*) () >>= fun () ->
Eliom_state.set_volatile_data_session_group ~set_max:4 (*zap* *) ~scope:session (* *zap*) login;
return ()
(* -------------------------------------------------------- *)
(* Registration of main services: *)
let () =
Eliom_registration.Html5.register ~service:connect_example5 connect_example5_handler;
Eliom_registration.Action.register ~service:connect_action connect_action_handler
(*wiki*
*wiki*)
(************************************************************)
(********************* Group tables *************************)
(************************************************************)
(*zap* *)
let scope_hierarchy = Eliom_common.create_scope_hierarchy "group_tables"
let session = `Session scope_hierarchy
let session_group = `Session_group scope_hierarchy
(* *zap*)
let my_table =
Eliom_state.create_volatile_table
~scope:session_group ()
(* -------------------------------------------------------- *)
(* We create one main service and two (POST) actions *)
(* (for connection and disconnection) *)
let group_tables_example =
Eliom_service.service
~path:["grouptables"]
~get_params:Eliom_parameter.unit
()
let connect_action =
Eliom_service.post_coservice'
~name:"connect7"
~post_params:(Eliom_parameter.string "login")
()
let disconnect_action =
Eliom_registration.Action.register_post_coservice'
~name:"disconnectgt"
~post_params:Eliom_parameter.unit
(fun () () ->
Eliom_state.discard ~scope:session ())
let disconnect_g_action =
Eliom_registration.Action.register_post_coservice'
~name:"disconnectgtg"
~post_params:Eliom_parameter.unit
(fun () () ->
Eliom_state.discard ~scope:session_group ())
(* -------------------------------------------------------- *)
(* login ang logout boxes: *)
let disconnect_box () =
div [
Html5.D.post_form disconnect_action
(fun _ -> [p [Html5.D.string_input
~input_type:`Submit ~value:"Close session" ()]]) ();
Html5.D.post_form disconnect_g_action
(fun _ -> [p [Html5.D.string_input
~input_type:`Submit ~value:"Close group" ()]]) ()
]
let login_box () =
Html5.D.post_form connect_action
(fun loginname ->
[p
(let l = [pcdata "login: ";
Html5.D.string_input
~input_type:`Text ~name:loginname ()]
in l)
])
()
(* -------------------------------------------------------- *)
(* Handler for the "group_tables_example" service (main page): *)
let group_tables_example_handler () () =
let sessdat = Eliom_state.get_volatile_data_session_group (*zap* *) ~scope:session (* *zap*) () in
let groupdata = Eliom_state.get_volatile_data
~table:my_table ()
in
let group_info name =
match groupdata with
| Eliom_state.Data_session_expired
| Eliom_state.No_data ->
let d = string_of_int (Random.int 1000) in
Eliom_state.set_volatile_data ~table:my_table d;
d
| Eliom_state.Data d -> d
in
return
(html
(head (title (pcdata "")) [])
(body
(match sessdat with
| Some name ->
[p [pcdata ("Hello "^name); br ()];
(let d = group_info name in
p [pcdata "Your group data is: ";
pcdata d;
pcdata ". It is common to all the sessions for the same user ";
pcdata name;
pcdata ". Try with another browser!"
]);
p [pcdata "Check that all sessions with same user name share the value."];
p [pcdata "Check that the value disappears when all sessions from the group are closed."];
p [pcdata "Check that the all sessions are closed when clicking on \"close group\" button."];
disconnect_box ()]
| None -> [login_box ()]
)))
(* -------------------------------------------------------- *)
(* Handler for connect_action (user logs in): *)
let connect_action_handler () login =
lwt () = Eliom_state.discard (*zap* *) ~scope:session (* *zap*) () in
Eliom_state.set_volatile_data_session_group ~set_max:4 (*zap* *) ~scope:session (* *zap*) login;
return ()
(* -------------------------------------------------------- *)
(* Registration of main services: *)
let () =
Eliom_registration.Html5.register ~service:group_tables_example group_tables_example_handler;
Eliom_registration.Action.register ~service:connect_action connect_action_handler
(*zap* *)
(************************************************************)
(**************** Persistent group tables *******************)
(************************************************************)
let scope_hierarchy = Eliom_common.create_scope_hierarchy "pgroup_tables"
let session = `Session scope_hierarchy
let session_group = `Session_group scope_hierarchy
let my_table =
Eliom_state.create_persistent_table
~scope:session_group "pgroup_table"
(* -------------------------------------------------------- *)
(* We create one main service and two (POST) actions *)
(* (for connection and disconnection) *)
let pgroup_tables_example =
Eliom_service.service
~path:["pgrouptables"]
~get_params:Eliom_parameter.unit
()
let connect_action =
Eliom_service.post_coservice'
~name:"connect8"
~post_params:(Eliom_parameter.string "login")
()
let disconnect_action =
Eliom_registration.Action.register_post_coservice'
~name:"pdisconnectgt"
~post_params:Eliom_parameter.unit
(fun () () -> Eliom_state.discard ~scope:session ())
let disconnect_g_action =
Eliom_registration.Action.register_post_coservice'
~name:"pdisconnectgtg"
~post_params:Eliom_parameter.unit
(fun () () ->
Eliom_state.discard ~scope:session_group ())
(* -------------------------------------------------------- *)
(* login ang logout boxes: *)
let disconnect_box () =
div [
Html5.D.post_form disconnect_action
(fun _ -> [p [Html5.D.string_input
~input_type:`Submit ~value:"Close session" ()]]) ();
Html5.D.post_form disconnect_g_action
(fun _ -> [p [Html5.D.string_input
~input_type:`Submit ~value:"Close group" ()]]) ()
]
let login_box () =
Html5.D.post_form connect_action
(fun loginname ->
[p
(let l = [pcdata "login: ";
Html5.D.string_input
~input_type:`Text ~name:loginname ()]
in l)
])
()
(* -------------------------------------------------------- *)
(* Handler for the "group_tables_example" service (main page): *)
let group_tables_example_handler () () =
Eliom_state.get_persistent_data_session_group ~scope:session ()
>>= fun sessdat ->
Eliom_state.get_persistent_data ~table:my_table ()
>>= fun groupdata ->
let group_info name =
match groupdata with
| Eliom_state.Data_session_expired
| Eliom_state.No_data ->
let d = string_of_int (Random.int 1000) in
Eliom_state.set_persistent_data ~table:my_table d
>>= fun r -> Lwt.return d
| Eliom_state.Data d -> Lwt.return d
in
(match sessdat with
| Some name ->
(group_info name >>= fun d ->
Lwt.return
[p [pcdata ("Hello "^name); br ()];
(p [pcdata "Your persistent group data is: ";
pcdata d;
pcdata ". It is common to all the sessions for the same user ";
pcdata name;
pcdata ". Try with another browser!"
]);
p [pcdata "Check that all sessions with same user name share the value."];
p [pcdata "Check that the value disappears when all sessions from the group are closed."];
p [pcdata "Check that the all sessions are closed when clicking on \"close group\" button."];
p [pcdata "Check that the value is preserved after relaunching the server."];
disconnect_box ()])
| None -> Lwt.return [login_box ()]) >>= fun l ->
Lwt.return
(html
(head (title (pcdata "")) [])
(body l))
(* -------------------------------------------------------- *)
(* Handler for connect_action (user logs in): *)
let connect_action_handler () login =
lwt () = Eliom_state.discard ~scope:session () in
Eliom_state.set_persistent_data_session_group
~set_max:(Some 4) ~scope:session login
(* -------------------------------------------------------- *)
(* Registration of main services: *)
let () =
Eliom_registration.Html5.register ~service:pgroup_tables_example group_tables_example_handler;
Eliom_registration.Action.register ~service:connect_action connect_action_handler
(* *zap*)
(*wiki*
*wiki*)
let csrf_scope_hierarchy = Eliom_common.create_scope_hierarchy "csrf"
let csrf_scope = `Session csrf_scope_hierarchy
let csrfsafe_example =
Eliom_service.service
~path:["csrf"]
~get_params:Eliom_parameter.unit
()
let csrfsafe_example_post =
Eliom_service.post_coservice
~csrf_safe:true
~csrf_scope
~csrf_secure:true
~timeout:10.
~max_use:1
~https:true
~fallback:csrfsafe_example
~post_params:Eliom_parameter.unit
()
let _ =
let page () () =
let l3 = Html5.D.post_form csrfsafe_example_post
(fun _ -> [p [Html5.D.string_input
~input_type:`Submit
~value:"Click" ()]]) ()
in
return
(html
(head (title (pcdata "CSRF safe service example")) [])
(body [p [pcdata "A new coservice will be created each time this form is displayed"];
l3]))
in
Eliom_registration.Html5.register csrfsafe_example page;
Eliom_registration.Html5.register csrfsafe_example_post
(fun () () ->
Lwt.return
(html
(head (title (pcdata "CSRF safe service")) [])
(body [p [pcdata "This is a CSRF safe service"]])))
(*wiki*
%
return
(html
(head (title (pcdata "")) [])
(body [p [pcdata g]])))
>%
*wiki*)
(*zap* *)
let myregexp = Netstring_pcre.regexp "\\[(.*)\\]"
let regexpserv =
Eliom_registration.Html5.register_service
~path:["regexp"]
~get_params:(regexp myregexp "\\1" (fun s -> s) "myparam")
(fun g () ->
return
(html
(head (title (pcdata "")) [])
(body [p [pcdata g]])))
(* *zap*)
(*wiki*
*wiki*)
(* Form with bool checkbox: *)
let bool_params = register_service
~path:["bool"]
~get_params:(bool "case")
(fun case () ->
let module Html5 = Eliom_content.Html5.F in
return
<:html5<
$pcdata (if case then "checked" else "not checked")$
>>)
let create_form_bool casename =
let module Html5 = Eliom_content.Html5.F in
<:html5list< check? $bool_checkbox ~name:casename ()$
$string_input ~input_type:`Submit ~value:"Click" ()$
>>
let form_bool = register_service ["formbool"] unit
(fun () () ->
let module Html5 = Eliom_content.Html5.F in
let f = get_form bool_params create_form_bool in
return
<:html5<
$f$
>>)
(*wiki*
*wiki*)
let set = register_service
~path:["set"]
~get_params:(set string "s")
(fun l () ->
let module Html5 = Eliom_content.Html5.F in
let ll =
List.map
(fun s -> <:html5< $str:s$ >>) l
in
let module Html5 = Eliom_content.Html5.F in
return
<:html5<
You sent:
$list:ll$
>>)
(*wiki*
*wiki*)
(* form to set *)
let setform = register_service
~path:["setform"]
~get_params:unit
(fun () () ->
return
(html
(head (title (pcdata "")) [])
(body [h1 [pcdata "Set Form"];
get_form set
(fun n ->
[p [pcdata "Form to set: ";
string_checkbox ~name:n ~value:"box1" ();
string_checkbox
~name:n ~value:"box2" ~checked:true ();
string_checkbox ~name:n ~value:"box3" ();
string_checkbox ~name:n ~value:"box4" ();
string_input ~input_type:`Submit ~value:"Click" ()]])
])))
(*wiki*
*wiki*)
let select_example_result = register_service
~path:["select"]
~get_params:(string "s")
(fun g () ->
return
(html
(head (title (pcdata "")) [])
(body [p [pcdata "You selected: ";
strong [pcdata g]]])))
let create_select_form =
(fun select_name ->
[p [pcdata "Select something: ";
Html5.D.string_select ~name:select_name
(Html5.D.Option ([] (* attributes *),
"Bob" (* value *),
None (* Content, if different from value *),
false (* not selected *))) (* first line *)
[Html5.D.Option ([], "Marc", None, false);
(Html5.D.Optgroup
([],
"Girls",
([], "Karin", None, false),
[([a_disabled `Disabled], "Juliette", None, false);
([], "Alice", None, true);
([], "Germaine", Some (pcdata "Bob's mother"), false)]))]
;
Html5.D.string_input ~input_type:`Submit ~value:"Send" ()]])
let select_example = register_service ["select"] unit
(fun () () ->
let f =
Html5.D.get_form
select_example_result create_select_form
in
return
(html
(head (title (pcdata "")) [])
(body [f])))
(*wiki*
*wiki*)
let coord = register_service
~path:["coord"]
~get_params:(coordinates "coord")
(fun c () ->
let module Html5 = Eliom_content.Html5.F in
return
<:html5<
You clicked on coordinates:
($str:(string_of_int c.abscissa)$, $str:(string_of_int c.ordinate)$)
>>)
(* form to image *)
let imageform = register_service
~path:["imageform"]
~get_params:unit
(fun () () ->
return
(html
(head (title (pcdata "")) [])
(body [h1 [pcdata "Image Form"];
get_form coord
(fun n ->
[p [image_input
~src:(make_uri ~service:(static_dir ()) ["ocsigen5.png"])
~name:n
()]])
])))
(*wiki*
*wiki*)
let coord2 = register_service
~path:["coord2"]
~get_params:(int_coordinates "coord")
(fun (i, c) () ->
let module Html5 = Eliom_content.Html5.F in
return
<:html5<
You clicked on coordinates:
($str:(string_of_int c.abscissa)$, $str:(string_of_int c.ordinate)$)
>>)
(* form to image *)
let imageform2 = register_service
~path:["imageform2"]
~get_params:unit
(fun () () ->
return
(html
(head (title (pcdata "")) [])
(body [h1 [pcdata "Image Form"];
get_form coord2
(fun n ->
[p [int_image_input
~src:(make_uri ~service:(static_dir ()) ["ocsigen5.png"])
~name:n
~value:3
()]])
])))
(*wiki*
*wiki*)
(* lists *)
let coucou_list = register_service
~path:["coucou"]
~get_params:(list "a" (string "str"))
(fun l () ->
let module Html5 = Eliom_content.Html5.F in
let ll =
List.map (fun s -> <:html5< $str:s$ >>) l in
return
<:html5<
You sent:
$list:ll$
>>)
(*wiki*
*wiki*)
(*zap* Note:
Actually almost all services will be overwritten by new versions,
but not those with user_type parameters for example
(because the type description contains functions)
*zap*)
(* Form with list: *)
let create_listform f =
(* Here, f.it is an iterator like List.map,
but it must be applied to a function taking 3 arguments
(unlike 1 in map), the first one being the name of the parameter,
and the second one the element of list.
The last parameter of f.it is the code that must be appended at the
end of the list created
*)
let module Html5 = Eliom_content.Html5.F in
f.it (fun stringname v init ->
<:html5list< Write the value for $str:v$:
$string_input ~input_type:`Text ~name:stringname ()$
>>@init)
["one";"two";"three";"four"]
<:html5list< $string_input ~input_type:`Submit ~value:"Click" ()$
>>
let listform = register_service ["listform"] unit
(fun () () ->
let module Html5 = Eliom_content.Html5.F in
let f = get_form coucou_list create_listform in
return
<:html5<
$f$
>>)
(*wiki*
*wiki*)
(* Form for service with suffix: *)
let create_suffixform ((suff, endsuff),i) =
let module Html5 = Eliom_content.Html5.F in
<:html5list<
Write the suffix (integer):
$int_input ~input_type:`Text ~name:suff ()$
Write a string:
$user_type_input (Url.string_of_url_path ~encode:false) ~input_type:`Text ~name:endsuff ()$
Write an int: $int_input ~input_type:`Text ~name:i ()$
$string_input ~input_type:`Submit ~value:"Click" ()$
>>
let suffixform = register_service ["suffixform"] unit
(fun () () ->
let f = get_form isuffix create_suffixform in
let module Html5 = Eliom_content.Html5.F in
return
<:html5<
$f$
>>)
(*wiki*
*wiki*)
let upload = service
~path:["upload"]
~get_params:unit
()
let upload2 = register_post_service
~fallback:upload
~post_params:(file "file")
(fun () file ->
let to_display =
let newname = "/tmp/thefile" in
(try
Unix.unlink newname;
with _ -> ());
Ocsigen_messages.console2 (Eliom_request_info.get_tmp_filename file);
Unix.link (Eliom_request_info.get_tmp_filename file) newname;
let fd_in = open_in newname in
try
let line = input_line fd_in in close_in fd_in; line (*end*)
with End_of_file -> close_in fd_in; "vide"
in
return
(html
(head (title (pcdata "Upload")) [])
(body [h1 [pcdata to_display]])))
let uploadform = register upload
(fun () () ->
let f =
(post_form upload2
(fun file ->
[p [file_input ~name:file ();
br ();
string_input ~input_type:`Submit ~value:"Send" ()
]]) ()) in
return
(html
(head (title (pcdata "form")) [])
(body [f])))
(*wiki*
*wiki*)
(* Hierarchical menu *)
open Eliom_tools
let hier1 = service ~path:["hier1"] ~get_params:unit ()
let hier2 = service ~path:["hier2"] ~get_params:unit ()
let hier3 = service ~path:["hier3"] ~get_params:unit ()
let hier4 = service ~path:["hier4"] ~get_params:unit ()
let hier5 = service ~path:["hier5"] ~get_params:unit ()
let hier6 = service ~path:["hier6"] ~get_params:unit ()
let hier7 = service ~path:["hier7"] ~get_params:unit ()
let hier8 = service ~path:["hier8"] ~get_params:unit ()
let hier9 = service ~path:["hier9"] ~get_params:unit ()
let hier10 = service ~path:["hier10"] ~get_params:unit ()
let mymenu : (_, Eliom_service.registrable, _) hierarchical_site =
(
(Main_page hier1),
[([pcdata "page 1"], Site_tree (Main_page hier1, []));
([pcdata "page 2"], Site_tree (Main_page hier2, []));
([pcdata "submenu 4"],
Site_tree
(Default_page hier4,
[([pcdata "submenu 3"],
Site_tree
(Not_clickable,
[([pcdata "page 3"], Site_tree (Main_page hier3, []));
([pcdata "page 4"], Site_tree (Main_page hier4, []));
([pcdata "page 5"], Site_tree (Main_page hier5, []))]
)
);
([pcdata "page 6"], Site_tree (Main_page hier6, []))]
)
);
([pcdata "page 7"],
Site_tree (Main_page hier7, []));
([pcdata "disabled"], Disabled);
([pcdata "submenu 8"],
Site_tree
(Main_page hier8,
[([pcdata "page 9"], Site_tree (Main_page hier9, []));
([pcdata "page 10"], Site_tree (Main_page hier10, []))]
)
)
]
)
let f i s () () =
return
(html
(head (title (pcdata ""))
((style ~a:[a_mime_type "text/css"]
[cdata_style
"a {color: red;}\n
li.eliomtools_current > a {color: blue;}\n
.breadthmenu li {\n
display: inline;\n
padding: 0px 1em;\n
margin: 0px;\n
border-right: solid 1px black;}\n
.breadthmenu li.eliomtools_last {border: none;}\n
"])::
Eliom_tools.F.structure_links mymenu ~service:s ())
)
(body [h1 [pcdata ("Page "^string_of_int i)];
h2 [pcdata "Depth first, whole tree:"];
div
(Eliom_tools.F.hierarchical_menu_depth_first
~whole_tree:true mymenu ~service:s ());
h2 [pcdata "Depth first, only current submenu:"];
div (Eliom_tools.F.hierarchical_menu_depth_first mymenu ~service:s ());
h2 [pcdata "Breadth first:"];
div
(Eliom_tools.F.hierarchical_menu_breadth_first
~classe:["breadthmenu"] mymenu ~service:s ())]))
let _ =
register hier1 (f 1 hier1);
register hier2 (f 2 hier2);
register hier3 (f 3 hier3);
register hier4 (f 4 hier4);
register hier5 (f 5 hier5);
register hier6 (f 6 hier6);
register hier7 (f 7 hier7);
register hier8 (f 8 hier8);
register hier9 (f 9 hier9);
register hier10 (f 10 hier10)
eliom-3.0.3/tests/atom_example.ml 0000644 0000000 0000000 00000005575 12062377521 015200 0 ustar 00 0000000 0000000 (*
* Copyright (C) 2010 Archibald Pontier
*
* This source file is part of Ocsigen < http://ocsigen.org/ >
*
* atom is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* atom 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
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License along
* with atom; if not, write to the Free Software Foundation, Inc.,
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
*)
module M = Xhtml.M
module Html5 = Eliom_content.Html5.F
open Atom_feed
open CalendarLib
let f () = Lwt.return (
let r2 = Calendar.make 2009 11 22 13 54 21 in
let d2 = Calendar.make 2010 7 1 18 12 1 in
let d3 = Calendar.make 2012 12 11 16 14 36 in
(* let's build the feed *)
feed ~updated:r2 ~id:"http://test.org" ~title:(plain "Un flux Atom")
(* the optional fields *)
~fields:[ authors [author "Tyruiop"]; subtitle (xhtml [M.pcdata "Voilà un exemple du flux atom généré avec Ocsigen !"]);
links [link ~elt:[`Rel ("alternate"); `Type ("text/html") ] "http://test.org"]]
(* the entry list *)
[entry ~updated:r2 ~id:"http://test.org/1" ~title:(plain "Article 1")
(* the entry optional fields *)
[authors [author ~elt:[uri "http://tyruiop.org"] "Tyruiop"];
links [link "http://test.org/1"];
summary (plain "Un petit résumé de l'article 1, avec un lien.");
inlineC ["Un exemple de text content"]];
entry ~updated:d2 ~id:"http://test.org/2" ~title:(plain "Article 2")
[authors [author "Tyruiop"];
summary (plain "Un petit résumé de l'article 2");
published d2;
xhtmlC [M.pcdata "un exemple de content en xHTML !"]];
entry ~updated:d3 ~id:"http://test.org/3" ~title:(plain "Article 3")
[authors [author "bépo"];
summary
(html5
[Html5.pcdata "Un petit résumé de l'article 3 en ";
Html5.a
~service:Eliom_testsuite_base.main
[Html5.pcdata "Html5"]
();
]
);
published d3;
html5C [Html5.pcdata "un exemple de content en HTML5 !"]];
]
)
(*(* let's register the feed *)
let s = Eliom_atom.Reg.register_new_service ~path:["test"] ~get_params:Eliom_parameter.unit f
*)
let s = Eliom_atom.register_feed ~path:["test"] ~hubs:["http://tyruiop.org:8888"; "http://pubsubhubbub.appspot.com"] "http://tyruiop.org:8080/test/test" f
eliom-3.0.3/tests/_client/ 0000755 0000000 0000000 00000000000 12062377521 013574 5 ustar 00 0000000 0000000 eliom-3.0.3/tests/_server/ 0000755 0000000 0000000 00000000000 12062377521 013624 5 ustar 00 0000000 0000000 eliom-3.0.3/tests/miniforum/ 0000755 0000000 0000000 00000000000 12062377521 014164 5 ustar 00 0000000 0000000 eliom-3.0.3/tests/miniforum/Makefile 0000644 0000000 0000000 00000002542 12062377521 015627 0 ustar 00 0000000 0000000 # Write here all the findlib packages you need, for example:
# PACKAGES= ,extlib,netstring
# Write here all your .ml files, in dependency order (default: all)
FILES=services.ml mylib.ml forum0.ml forum1.ml forum2.ml
CAMLC = ocamlfind ocamlc -g -thread $(LIB)
CAMLOPT = ocamlfind ocamlopt -thread $(LIB)
CAMLDOC = ocamlfind ocamldoc $(LIB)
CAMLDEP = ocamlfind ocamldep
OCSIGENREP = `ocamlfind query ocsigen`
#OCSIGENREP = ../ocsigen/lib
LIB = -package lwt.unix,ocsigen$(PACKAGES) -I $(OCSIGENREP)
# If you use the syntax extension:
# PP = -pp "camlp4o $(OCSIGENREP)/xhtmlsyntax.cma"
# otherwise
PP =
OBJS = $(FILES:.ml=.cmo)
CMA = v0/site0.cma v1/site1.cma v2/site2.cma
.PHONY: $(CMA)
all: depend $(CMA) install
#$(CMA): $(OBJS)
# $(CAMLC) -a -o $(CMA) $(OBJS)
v0/site0.cma:
$(MAKE) -C v0 site0.cma
v1/site1.cma:
$(MAKE) -C v1 site1.cma
v2/site2.cma:
$(MAKE) -C v2 site2.cma
install:
chmod a+r $(CMA)
.SUFFIXES:
.SUFFIXES: .ml .mli .cmo .cmi .cmx
.PHONY: doc
.ml.cmo:
$(CAMLC) $(PP) -c $<
.mli.cmi:
$(CAMLC) -c $<
.ml.cmx:
$(CAMLOPT) $(PP) -c $<
doc:
# $(CAMLDOC) -d doc -html db.mli
clean:
-rm -f *.cm[ioxa] *~ $(NAME)
$(MAKE) -C v0 clean
$(MAKE) -C v1 clean
$(MAKE) -C v2 clean
depend:
$(CAMLDEP) $(PP) $(LIB) $(FILES:.ml=.mli) $(FILES) > .depend
$(MAKE) -C v0 depend
$(MAKE) -C v1 depend
$(MAKE) -C v2 depend
FORCE:
-include .depend
eliom-3.0.3/tests/miniforum/ocsigen.conf 0000644 0000000 0000000 00000001446 12062377521 016467 0 ustar 00 0000000 0000000
8081
/tmp
/tmp
/tmp/ocsigen_command
eliom-3.0.3/tests/miniforum/v0/ 0000755 0000000 0000000 00000000000 12062377521 014511 5 ustar 00 0000000 0000000 eliom-3.0.3/tests/miniforum/v0/Makefile 0000644 0000000 0000000 00000002375 12062377521 016160 0 ustar 00 0000000 0000000 # Write here all the findlib packages you need, for example:
# PACKAGES= ,extlib,netstring
# Write here all your .ml files, in dependency order (default: all)
FILES=services.ml mylib.ml forum0.ml forum1.ml forum2.ml
CAMLC = ocamlfind ocamlc -g -thread $(LIB)
CAMLOPT = ocamlfind ocamlopt -thread $(LIB)
CAMLDOC = ocamlfind ocamldoc $(LIB)
CAMLDEP = ocamlfind ocamldep
OCSIGENREP = `ocamlfind query ocsigen`
#OCSIGENREP = ../ocsigen/lib
LIB = -package lwt.unix,ocsigen$(PACKAGES) -I $(OCSIGENREP)
# If you use the syntax extension:
PP = -pp "camlp4o $(OCSIGENREP)/xhtmlsyntax.cma"
# otherwise
#PP =
OBJS = $(FILES:.ml=.cmo)
CMA = site0.cma site1.cma site2.cma
all: depend $(CMA) install
#$(CMA): $(OBJS)
# $(CAMLC) -a -o $(CMA) $(OBJS)
site0.cma: mylib.cmo forum.cmo
$(CAMLC) -a -o $@ $^
site1.cma: mylib.cmo forum.cmo
$(CAMLC) -a -o $@ $^
site2.cma: services.cmo mylib.cmo forum.cmo
$(CAMLC) -a -o $@ $^
install:
chmod a+r $(CMA)
.SUFFIXES:
.SUFFIXES: .ml .mli .cmo .cmi .cmx
.PHONY: doc
.ml.cmo:
$(CAMLC) $(PP) -c $<
.mli.cmi:
$(CAMLC) -c $<
.ml.cmx:
$(CAMLOPT) $(PP) -c $<
doc:
# $(CAMLDOC) -d doc -html db.mli
clean:
-rm -f *.cm[ioxa] *~ $(NAME)
depend:
$(CAMLDEP) $(PP) $(LIB) $(FILES:.ml=.mli) $(FILES) > .depend
FORCE:
-include .depend
eliom-3.0.3/tests/miniforum/v0/mylib.ml 0000644 0000000 0000000 00000002144 12062377521 016160 0 ustar 00 0000000 0000000 open Eliom_predefmod.Xhtml
open XHTML.M
open Eliom_service
let create_page sp mytitle mycontent =
Lwt.return
<<
$str:mytitle$
$str:mytitle$
$list:mycontent$
>>
let create_page2 sp mytitle mycontent =
Lwt.return
(html
(head (title (pcdata mytitle)) [])
(body ((h1 [pcdata mytitle])::mycontent)))
(* Messages database *)
(* For the example, I'm storing messages in memory.
I should use a database instead.
Here are some predefined messages: *)
let table = ref ["Welcome to Eliom's world.";
"Hello! This is the second message.";
"I am the third message of the forum."]
let display_message_list () =
match !table with
| [] -> p [em [pcdata "No message"]]
| m::l ->
ul
(li [pcdata m])
(List.map (fun m -> li [pcdata m]) l)
let display_message n =
try
let m = List.nth !table n in
p [pcdata m]
with
| Failure _
| Invalid_argument _ -> p [em [pcdata "no such message"]]
let register_message msg = table := !table@[msg]
eliom-3.0.3/tests/miniforum/v0/forum.ml 0000644 0000000 0000000 00000000754 12062377521 016201 0 ustar 00 0000000 0000000 open XHTML.M
open Eliom_service
open Eliom_parameter
open Eliom_predefmod
let mainpage = new_service ~path:[] ~get_params:unit ()
let msgpage = new_service ~path:[] ~get_params:(int "n") ()
let () = Xhtml.register mainpage
(fun sp () () ->
Mylib.create_page sp
"Messages"
[Mylib.display_message_list ()])
let () = Xhtml.register msgpage
(fun sp n () ->
Mylib.create_page sp
("Message "^(string_of_int n))
[Mylib.display_message n])
eliom-3.0.3/tests/miniforum/v0/forum0.ml 0000644 0000000 0000000 00000000446 12062377521 016257 0 ustar 00 0000000 0000000 open XHTML.M
open Eliomservices
open Eliomparameters
open Eliompredefmod
open Eliompredefmod.Xhtml
let mainpage = new_service ~path:[] ~get_params:unit ()
let () = register mainpage
(fun sp () () ->
Mylib.create_page sp
"Messages"
[Mylib.display_message_list ()])
eliom-3.0.3/tests/miniforum/static/ 0000755 0000000 0000000 00000000000 12062377521 015453 5 ustar 00 0000000 0000000 eliom-3.0.3/tests/miniforum/static/style.css 0000644 0000000 0000000 00000000617 12062377521 017331 0 ustar 00 0000000 0000000 h1{
background-color: #2233aa;
text-align: center;
color: white;
margin: 2px;
}
body{
margin: 0px;
padding: 10px;
border: 5px solid #333333;
}
div.box{
border: 1px solid #555555;
}
div.colonnegauche{
float: left;
width: 200px;
}
div.colonnedroite{
margin-left: 210px;
}
li{
border: 2px solid white;
padding: 4px;
background-color: #99ccff;
list-style: none;
}
eliom-3.0.3/tests/miniforum/v2/ 0000755 0000000 0000000 00000000000 12062377521 014513 5 ustar 00 0000000 0000000 eliom-3.0.3/tests/miniforum/v2/Makefile 0000644 0000000 0000000 00000002376 12062377521 016163 0 ustar 00 0000000 0000000 # Write here all the findlib packages you need, for example:
# PACKAGES= ,extlib,netstring
# Write here all your .ml files, in dependency order (default: all)
FILES=services.ml mylib.ml forum0.ml forum1.ml forum2.ml
CAMLC = ocamlfind ocamlc -g -thread $(LIB)
CAMLOPT = ocamlfind ocamlopt -thread $(LIB)
CAMLDOC = ocamlfind ocamldoc $(LIB)
CAMLDEP = ocamlfind ocamldep
OCSIGENREP = `ocamlfind query ocsigen`
#OCSIGENREP = ../ocsigen/lib
LIB = -package lwt.unix,ocsigen$(PACKAGES) -I $(OCSIGENREP)
# If you use the syntax extension:
# PP = -pp "camlp4o $(OCSIGENREP)/xhtmlsyntax.cma"
# otherwise
PP =
OBJS = $(FILES:.ml=.cmo)
CMA = site0.cma site1.cma site2.cma
all: depend $(CMA) install
#$(CMA): $(OBJS)
# $(CAMLC) -a -o $(CMA) $(OBJS)
site0.cma: mylib.cmo forum.cmo
$(CAMLC) -a -o $@ $^
site1.cma: mylib.cmo forum.cmo
$(CAMLC) -a -o $@ $^
site2.cma: services.cmo mylib.cmo forum.cmo
$(CAMLC) -a -o $@ $^
install:
chmod a+r $(CMA)
.SUFFIXES:
.SUFFIXES: .ml .mli .cmo .cmi .cmx
.PHONY: doc
.ml.cmo:
$(CAMLC) $(PP) -c $<
.mli.cmi:
$(CAMLC) -c $<
.ml.cmx:
$(CAMLOPT) $(PP) -c $<
doc:
# $(CAMLDOC) -d doc -html db.mli
clean:
-rm -f *.cm[ioxa] *~ $(NAME)
depend:
$(CAMLDEP) $(PP) $(LIB) $(FILES:.ml=.mli) $(FILES) > .depend
FORCE:
-include .depend
eliom-3.0.3/tests/miniforum/v2/mylib.ml 0000644 0000000 0000000 00000003773 12062377521 016173 0 ustar 00 0000000 0000000 open XHTML.M
open Eliom_predefmod.Xhtml
open Eliom_service
(* Messages database *)
(* For the example, I'm storing messages in memory.
I should use a database instead.
Here are some predefined messages: *)
let table = ref ["Welcome to Eliom's world.";
"Hello! This is the second message.";
"I am the third message of the forum."]
let display_message_list sp =
let f m i =
[pcdata m;
pcdata " ";
a Services.msgpage sp [pcdata "read"] i]
in
match !table with
| [] -> p [em [pcdata "No message"]]
| m::l ->
ul
(li (f m 0))
(snd
(List.fold_right
(fun m (i, l) ->
(i+1,
(li (f m i))::l))
l
(0, [])))
let display_message n =
try
let m = List.nth !table n in
p [pcdata m]
with
| Failure _
| Invalid_argument _ -> p [em [pcdata "no such message"]]
let register_message msg = table := !table@[msg]
let disconnect_box sp s =
post_form Services.disconnect_action sp
(fun _ -> [p [Eliom_predefmod.Xhtml.string_input
~input_type:`Submit ~value:s ()]]) ()
let login_box sp =
post_form Services.connect_action sp
(fun loginname ->
[p
(let l = [pcdata "login: ";
Eliom_predefmod.Xhtml.string_input
~input_type:`Text ~name:loginname ()]
in l)
])
()
let userbox ~sp =
let sessdat = Eliom_sessions.get_volatile_data_session_group ~sp () in
(match sessdat with
| Eliom_sessions.Data name ->
div
[p [pcdata ("Hello "^name); br ()];
disconnect_box sp "Close session"]
| Eliom_sessions.Data_session_expired
| Eliom_sessions.No_data -> login_box sp
)
(*****)
let create_page sp mytitle mycontent =
Lwt.return
(html
(head
(title (pcdata mytitle))
[css_link (make_uri ~service:(static_dir sp) ~sp ["style.css"]) ()])
(body ((h1 [pcdata mytitle])::(userbox sp)::mycontent)))
eliom-3.0.3/tests/miniforum/v2/services.ml 0000644 0000000 0000000 00000000762 12062377521 016675 0 ustar 00 0000000 0000000 open Eliom_service
open Eliom_parameter
let mainpage = new_service ~path:[] ~get_params:unit ()
let msgpage = new_service ~path:[] ~get_params:(int "n") ()
let addmsgpage =
new_post_service ~fallback:mainpage ~post_params:(string "msg") ()
let newmsgpage = new_service ~path:["newmessage"] ~get_params:unit ()
let connect_action =
new_post_coservice' ~name:"connect" ~post_params:(string "login") ()
let disconnect_action =
new_post_coservice' ~name:"disconnect" ~post_params:unit ()
eliom-3.0.3/tests/miniforum/v2/forum.ml 0000644 0000000 0000000 00000003247 12062377521 016203 0 ustar 00 0000000 0000000 open Lwt
open XHTML.M
open Eliom_predefmod
open Eliom_service
open Eliom_parameter
open Eliom_predefmod.Xhtml
open Services
let () = register mainpage
(fun sp () () ->
Mylib.create_page sp
"Messages"
[Mylib.display_message_list sp;
p [a newmsgpage sp [pcdata "Create a new message"] ()]])
let () = register msgpage
(fun sp n () ->
Mylib.create_page sp
("Message "^(string_of_int n))
[Mylib.display_message n])
let () = register addmsgpage
(fun sp () msg ->
let ok =
new_coservice ~max_use:1 ~fallback:mainpage ~get_params:unit ()
in
Actions.register ~sp ~service:ok
(fun sp () () ->
Mylib.register_message msg;
Lwt.return []);
Mylib.create_page sp
"Confirm this Message?"
[p [pcdata msg];
p [
a ok sp [pcdata "Yes"] (); pcdata " ";
a mainpage sp [pcdata "Cancel"] ()]
]
)
let () = register newmsgpage
(fun sp () () ->
Mylib.create_page sp
"New Message"
[post_form addmsgpage sp
(fun fieldname ->
[p [pcdata "Write your message: "; br ();
textarea ~name:fieldname ~rows:10 ~cols:80 (); br ();
string_input ~input_type:`Submit ~value:"Enter" ()]]) ()])
let () = Actions.register disconnect_action
(fun sp () () ->
Eliom_sessions.close_session ~sp () >>= fun () ->
Lwt.return [])
let () = Actions.register connect_action
(fun sp () login ->
Eliom_sessions.close_session ~sp () >>= fun () ->
Eliom_sessions.set_volatile_data_session_group
~set_max:(Some 10) ~sp login;
Lwt.return [])
eliom-3.0.3/tests/miniforum/v1/ 0000755 0000000 0000000 00000000000 12062377521 014512 5 ustar 00 0000000 0000000 eliom-3.0.3/tests/miniforum/v1/Makefile 0000644 0000000 0000000 00000002376 12062377521 016162 0 ustar 00 0000000 0000000 # Write here all the findlib packages you need, for example:
# PACKAGES= ,extlib,netstring
# Write here all your .ml files, in dependency order (default: all)
FILES=services.ml mylib.ml forum0.ml forum1.ml forum2.ml
CAMLC = ocamlfind ocamlc -g -thread $(LIB)
CAMLOPT = ocamlfind ocamlopt -thread $(LIB)
CAMLDOC = ocamlfind ocamldoc $(LIB)
CAMLDEP = ocamlfind ocamldep
OCSIGENREP = `ocamlfind query ocsigen`
#OCSIGENREP = ../ocsigen/lib
LIB = -package lwt.unix,ocsigen$(PACKAGES) -I $(OCSIGENREP)
# If you use the syntax extension:
# PP = -pp "camlp4o $(OCSIGENREP)/xhtmlsyntax.cma"
# otherwise
PP =
OBJS = $(FILES:.ml=.cmo)
CMA = site0.cma site1.cma site2.cma
all: depend $(CMA) install
#$(CMA): $(OBJS)
# $(CAMLC) -a -o $(CMA) $(OBJS)
site0.cma: mylib.cmo forum.cmo
$(CAMLC) -a -o $@ $^
site1.cma: mylib.cmo forum.cmo
$(CAMLC) -a -o $@ $^
site2.cma: services.cmo mylib.cmo forum.cmo
$(CAMLC) -a -o $@ $^
install:
chmod a+r $(CMA)
.SUFFIXES:
.SUFFIXES: .ml .mli .cmo .cmi .cmx
.PHONY: doc
.ml.cmo:
$(CAMLC) $(PP) -c $<
.mli.cmi:
$(CAMLC) -c $<
.ml.cmx:
$(CAMLOPT) $(PP) -c $<
doc:
# $(CAMLDOC) -d doc -html db.mli
clean:
-rm -f *.cm[ioxa] *~ $(NAME)
depend:
$(CAMLDEP) $(PP) $(LIB) $(FILES:.ml=.mli) $(FILES) > .depend
FORCE:
-include .depend
eliom-3.0.3/tests/miniforum/v1/mylib.ml 0000644 0000000 0000000 00000001763 12062377521 016167 0 ustar 00 0000000 0000000 open Eliom_predefmod.Xhtml
open XHTML.M
open Eliom_service
let create_page sp mytitle mycontent =
Lwt.return
(html
(head
(title (pcdata mytitle))
[css_link (make_uri ~service:(static_dir sp) ~sp ["style.css"]) ()])
(body ((h1 [pcdata mytitle])::mycontent)))
(* Messages database *)
(* For the example, I'm storing messages in memory.
I should use a database instead.
Here are some predefined messages: *)
let table = ref ["Welcome to Eliom's world.";
"Hello! This is the second message.";
"I am the third message of the forum."]
let display_message_list () =
match !table with
| [] -> p [em [pcdata "No message"]]
| m::l ->
ul
(li [pcdata m])
(List.map (fun m -> li [pcdata m]) l)
let display_message n =
try
let m = List.nth !table n in
p [pcdata m]
with
| Failure _
| Invalid_argument _ -> p [em [pcdata "no such message"]]
let register_message msg = table := !table@[msg]
eliom-3.0.3/tests/miniforum/v1/forum.ml 0000644 0000000 0000000 00000003154 12062377521 016177 0 ustar 00 0000000 0000000 open XHTML.M
open Eliom_service
open Eliom_parameter
open Eliom_predefmod
open Eliom_predefmod.Xhtml
let mainpage = new_service ~path:[] ~get_params:unit ()
let msgpage = new_service ~path:[] ~get_params:(int "n") ()
let addmsgpage =
new_post_service ~fallback:mainpage ~post_params:(string "msg") ()
let newmsgpage = new_service ~path:["newmessage"] ~get_params:unit ()
let () = register mainpage
(fun sp () () ->
Mylib.create_page sp
"Messages"
[Mylib.display_message_list ();
p [a newmsgpage sp [pcdata "Create a new message"] ()]])
let () = register msgpage
(fun sp n () ->
Mylib.create_page sp
("Message "^(string_of_int n))
[Mylib.display_message n])
let () = register addmsgpage
(fun sp () msg ->
let ok =
new_coservice ~max_use:1 ~fallback:mainpage ~get_params:unit ()
in
register ~sp ~service:ok
(fun sp () () ->
Mylib.register_message msg;
Mylib.create_page sp
"Message added"
[Mylib.display_message_list ()]);
Mylib.create_page sp
"Confirm this Message?"
[p [pcdata msg];
p [
a ok sp [pcdata "Yes"] (); pcdata " ";
a mainpage sp [pcdata "Cancel"] ()]
]
)
let () = register newmsgpage
(fun sp () () ->
Mylib.create_page sp
"New Message"
[post_form addmsgpage sp
(fun fieldname ->
[p [pcdata "Write your message: "; br ();
textarea ~name:fieldname ~rows:10 ~cols:80 (); br ();
string_input ~input_type:`Submit ~value:"Enter" ()]]) ()])
eliom-3.0.3/tests/miniwiki/ 0000755 0000000 0000000 00000000000 12062377521 013777 5 ustar 00 0000000 0000000 eliom-3.0.3/tests/miniwiki/Makefile 0000644 0000000 0000000 00000001672 12062377521 015445 0 ustar 00 0000000 0000000 include ../../Makefile.config
## Use local files
## (tests do not require global installation of Eliom)
export OCAMLPATH := ${SRC}/src/files:${OCAMLPATH}
export PATH := ${SRC}/src/tools:${PATH}
LIBS := -I ..
ELIOMC := eliomc${BYTEDBG}
ELIOMOPT := eliomopt ${OPTDBG}
ELIOMDEP := eliomdep
ifeq "${NATDYNLINK}" "YES"
all: byte opt
else
all: byte
endif
### Library
FILES := miniwiki.ml
byte:: miniwiki.cma
opt:: miniwiki.cmxs
miniwiki.cma: ${FILES:.ml=.cmo}
${ELIOMC} -a -o $@ $^
miniwiki.cmxa: ${FILES:.ml=.cmx}
${ELIOMOPT} -a -o $@ $^
############
%.cmi: %.mli
$(ELIOMC) ${LIBS} -c $<
%.cmo: %.ml
$(ELIOMC) ${LIBS} -c $<
%.cmx: %.ml
$(ELIOMOPT) ${LIBS} -c $<
%.cmxs: %.cmxa
$(ELIOMOPT) -shared -linkall -o $@ $<
## Clean up
clean:
-rm -f *.cm[ioax] *.cmxa *.cmxs *.o *.a *.annot
-rm -f _server/*
distclean: clean
-rm -f *~ \#* .\#*
## Dependencies
depend:
$(ELIOMDEP) -server ${LIBS} *.ml *.mli > .depend
FORCE:
-include .depend eliom-3.0.3/tests/miniwiki/README 0000644 0000000 0000000 00000002040 12062377521 014653 0 ustar 00 0000000 0000000 Miniwiki
---------
Miniwiki is a simple wiki written for Ocsigen by Janne Hellsten
(jjhellst@gmail.com). It's primary purpose is to server as a code
example for Ocsigen module developers.
Compiling & running
-------------------
Miniwiki should be compiled and install with Ocsigen.
The default config file usually contains miniwiki preconfigured.
If not, adapt files/miniwiki.conf and start Ocsigen with Miniwiki by running
ocsigen -c examples/miniwiki/files/miniwiki.conf
4. Point your browser to localhost:9999/
Implementation
--------------
Wiki page storage
Each wiki page is a file in the wiki storage directory
(/var/lib/ocsigen/miniwiki/wikidata/ is the default). A wiki page "Foo"
corresponds to a file called "Foo.wiki" in the "wikidata" directory.
Character encoding
Wiki pages are stored as UTF-8 text files. If the site is properly
configured, the wiki properly allows the use of UTF-8 content in wiki
pages. Since wiki page names map directly to filenames on disk, page
names containing non 7-bit ASCII might not work well.
eliom-3.0.3/tests/miniwiki/.depend 0000644 0000000 0000000 00000000056 12062377521 015240 0 ustar 00 0000000 0000000 _server/miniwiki.cmo :
_server/miniwiki.cmx :
eliom-3.0.3/tests/miniwiki/miniwiki.ml 0000644 0000000 0000000 00000026135 12062377521 016160 0 ustar 00 0000000 0000000 (* Ocsigen
* http://www.ocsigen.org
* Module miniwiki.ml
* Copyright (C) 2007 Janne Hellsten
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exception;
* either version 2.1 of the License, or (at your option) any later version.
*
* This program 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
* GNU Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
(* open Eliom_pervasives *)
open Eliom_lib
open Eliom_content
open Eliom_content.Html5.F
open Eliom_service
open Eliom_parameter
open Eliom_state
open Simplexmlparser
open Lwt
open Lwt_chan
module P = Printf
let (>>) f g = g f
let wiki_view_page = service [] (suffix (string "p")) ()
let wiki_edit_page = service ["edit"] (string "p") ()
let wiki_start = Eliom_registration.Redirection.register_service [] unit
(fun _ _ ->
Lwt.return (Eliom_service.preapply wiki_view_page "WikiStart"))
let finally_ handler f x =
catch
(fun () -> f x)
(fun e -> handler() >>= fun () -> fail e)
>>= fun r ->
handler () >>= fun () ->
return r
let fold_read_lines f accum inchnl =
let line () =
catch
(fun () -> Lwt_chan.input_line inchnl >>= fun line -> return (Some line))
(function End_of_file -> return None | e -> fail e)
in
let rec loop accum =
line () >>= fun l ->
match l with
| Some e -> loop (f accum e)
| None -> return accum
in
loop accum
let with_open_out fname f =
Lwt_chan.open_out fname >>= fun oc ->
finally_
(fun () -> Lwt_chan.flush oc >>= (fun () -> Lwt_chan.close_out oc))
f oc
let with_open_in fname f =
Lwt_chan.open_in fname >>= fun ic ->
finally_
(fun () -> Lwt_chan.close_in ic)
f ic
let wiki_file_dir =
let rec find_wikidata = function
[Element ("wikidata", [("dir", s)],_)] -> s
| _ -> raise (Ocsigen_extensions.Error_in_config_file ("Unexpected content inside Miniwiki config"))
in
let c = Eliom_config.get_config () in
find_wikidata c
let wiki_page_filename page =
wiki_file_dir ^ "/" ^ page ^ ".wiki"
let wiki_page_exists page =
Sys.file_exists (wiki_page_filename page)
let save_wiki_page page text =
with_open_out
(wiki_page_filename page)
(fun chnl -> output_string chnl text)
let load_wiki_page page =
with_open_in
(wiki_page_filename page)
(fun chnl ->
fold_read_lines (fun acc line -> line::acc) [] chnl >>= fun l ->
return (List.rev l))
let h1_re = Pcre.regexp "^=(.*)=([ \n\r]*)?$"
let h2_re = Pcre.regexp "^==(.*)==([ \n\r]*)?$"
let h3_re = Pcre.regexp "^===(.*)===([ \n\r]*)?$"
let list_re = Pcre.regexp "^[ ]?([*]+) (.*)([ \n\r]*)?$"
let match_pcre_option rex s =
try Some (Pcre.extract ~rex s) with Not_found -> None
let is_list s =
match_pcre_option list_re s
let open_pre_re = Pcre.regexp "^(|{{{)[ \n\r]+$"
let close_pre_re = Pcre.regexp "^(|}}})[ \n\r]+$"
let take_while pred lines =
let rec loop acc = function
(x::xs) as lst ->
if pred x then
loop (x::acc) xs
else
(lst, List.rev acc)
| [] ->
([], List.rev acc) in
loop [] lines
let comp_re = Pcre.regexp ~flags:[`ANCHORED]
let accepted_chars_ = "a-zA-Z\128-\2550-9_!\"§°#%&/\\(\\)=\\?\\+\\.,;:{}'@\\$\\^\\*`´<>"
let accepted_chars_sans_ws = "["^accepted_chars_^"-]+"
let accepted_chars = "["^accepted_chars_^" -]+"
let text_re = comp_re ("("^accepted_chars_sans_ws^")")
let wikilink_re = comp_re "([A-Z][a-z]+([A-Z][a-z]+)+)"
let wikilinkanum_re =
comp_re
("(\\[(wiki|file|http):("^accepted_chars_sans_ws^")[ ]+("^accepted_chars^")\\])")
let wikilinkanum_no_text_re =
comp_re ("(\\[(wiki|file|http):("^accepted_chars_sans_ws^")\\])")
let translate_list items =
let add_ul t lst =
t @ [ul lst] in
let rec loop = function
((nesting1,text1)::(nesting2,text2)::xs) as lst ->
if nesting1 = nesting2 then
(li text1)::loop (List.tl lst)
else if nesting1 < nesting2 then (* enter *)
let (next_same_level,same_or_higher) =
take_while (fun (n,_) -> n >= nesting2) (List.tl lst) in
(li (add_ul text1 (loop same_or_higher)))::loop next_same_level
else (* leave *)
loop (List.tl lst)
| (nesting,text)::[] ->
[(li text)]
| [] -> [] in
let list_items = loop items in
ul list_items
let parse_lines lines =
let wikilink scheme page text =
if scheme = "wiki" || scheme = "" then
let t = if text = "" then page else text in
if wiki_page_exists page then
a wiki_view_page [pcdata t] page
else
a ~a:[a_class ["missing_page"]] ~service:wiki_view_page [pcdata t]
page
else (* External link *)
let url = scheme^":"^page in
let t = if text = "" then url else text in
Html5.F.Raw.a ~a:[a_href (Html5.F.uri_of_string (fun () -> url))]
[pcdata t]
in
let rec pcre_first_match str pos =
let rec loop = function
(rex,f)::xs ->
(try Some (Pcre.extract ~rex ~pos str, f) with Not_found -> loop xs)
| [] -> None in
loop in
(* Parse a line of text *)
let rec parse_text acc s =
let len = String.length s in
let add_html html_acc html =
html::html_acc in
let parse_wikilink acc r charpos =
(add_html acc (wikilink "" r.(1) r.(1)), charpos+(String.length r.(0))) in
let parse_wikilinkanum acc r charpos =
let scheme = r.(2) in
let page = r.(3) in
let text = r.(4) in
let fm_len = String.length r.(0) in
(add_html acc (wikilink scheme page text), charpos+fm_len) in
let parse_wikilinkanum_no_text acc r charpos =
let scheme = r.(2) in
let page = r.(3) in
let text = "" in
let fm_len = String.length r.(0) in
(add_html acc (wikilink scheme page text), charpos+fm_len) in
let parse_text acc r charpos =
(add_html acc (pcdata r.(1)), charpos+(String.length r.(0))) in
let text_patterns =
[(wikilink_re, parse_wikilink);
(wikilinkanum_re, parse_wikilinkanum);
(wikilinkanum_no_text_re, parse_wikilinkanum_no_text);
(text_re, parse_text)] in
let rec loop acc charpos =
if charpos >= len then
acc
else
if s.[charpos] = '\t' then
let m = "\t" in
loop (add_html acc (pcdata m)) (charpos+1)
else if s.[charpos] = ' ' then
let m = " " in
loop (add_html acc (pcdata m)) (charpos+1)
else if s.[charpos] = '\r' || s.[charpos] = '\n' then
acc
else
begin
match pcre_first_match s charpos text_patterns with
Some (r,f) ->
let (acc',charpos') = f acc r charpos in
loop acc' charpos'
| None ->
let s = (String.sub s charpos ((String.length s)-charpos)) in
add_html acc
(span
[span ~a:[a_class ["error"]]
[pcdata "WIKI SYNTAX ERROR IN INPUT: "];
pcdata s])
end
in
List.rev (loop acc 0) in
(* Line-by-line wiki parser *)
let rec loop acc = function
(x::xs) as lst ->
let parse_list r =
(* Grab all lines starting with '*': *)
let (after_bullets,bullets) =
take_while (fun e -> is_list e <> None) lst in
let list_items =
List.map
(fun e ->
match is_list e with
Some r ->
let n_stars = String.length r.(1) in
(n_stars, parse_text [] r.(2))
| None -> assert false) bullets in
loop ((translate_list list_items)::acc) after_bullets in
let parse_verbatim r =
(* Handle ..
, {{{..}}} *)
let (after_pre,contents) =
take_while
(fun x -> match_pcre_option close_pre_re x = None)
lst in
let p =
(pre [pcdata (String.concat "\n" (List.tl contents))]) in
loop (p::acc) (List.tl after_pre) in
let wiki_pats =
[(h3_re, (fun r -> loop ((h3 [pcdata r.(1)])::acc) xs));
(h2_re, (fun r -> loop ((h2 [pcdata r.(1)])::acc) xs));
(h1_re, (fun r -> loop ((h1 [pcdata r.(1)])::acc) xs));
(list_re, parse_list);
(open_pre_re, parse_verbatim)] in
begin
match pcre_first_match x 0 wiki_pats with
Some (res, action) -> action res
| None ->
loop ((p (parse_text [] x))::acc) xs
end
| [] -> List.rev acc in
return (loop [] lines)
let wikiml_to_html page =
if wiki_page_exists page then
load_wiki_page page >>= parse_lines
else
return []
(* Use this as the basis for all pages. Includes CSS etc. *)
let html_stub body_html =
return
(html
(head (title (pcdata ""))
[css_link (make_uri ~service:(static_dir ()) ["style.css"]) ()])
(body body_html))
let wiki_page_menu_html page content =
[div ~a:[a_id "navbar"]
[div ~a:[a_id "akmenu"]
[p
[span ~a:[a_class ["nwikilogo"]] [(pcdata "MiniWiki")];
a ~service:wiki_view_page
~a:[a_accesskey 'h'; a_class ["ak"]]
[pcdata "Home"] "WikiStart";
a ~service:wiki_edit_page ~a:[a_accesskey 'e'; a_class ["ak"]]
[pcdata "Edit page"] page; br ()]]];
div ~a:[a_id "content"]
content]
let wiki_page_contents_html page ?(content=[]) () =
wikiml_to_html page >>= fun p ->
return (wiki_page_menu_html page (content @ p))
let view_page page =
wiki_page_contents_html page () >>= fun p ->
html_stub p
(* Save page as a result of /edit?p=Page *)
let service_save_page_post =
Eliom_registration.Html5.register_post_service
~fallback:wiki_view_page
~post_params:(string "value")
(fun page value ->
(* Save wiki page from POST value: *)
save_wiki_page page value >>= fun () ->
view_page page)
(* /edit?p=Page *)
let _ =
Eliom_registration.Html5.register wiki_edit_page
(fun page () ->
(if wiki_page_exists page then
load_wiki_page page >>= fun s -> return (String.concat "\n" s)
else
return "")
>>= fun wikitext ->
let f =
post_form service_save_page_post
(fun chain ->
[(p [string_input ~input_type:`Submit ~value:"Save" (); br ();
textarea ~name:chain ~value:wikitext ()])])
page
in
wiki_page_contents_html page ~content:[f] () >>= fun c ->
html_stub c)
(* /view?p=Page *)
let _ =
Eliom_registration.Html5.register wiki_view_page
(fun page () ->
if not (wiki_page_exists page) then
let f =
a wiki_edit_page [pcdata "Create new page"] page in
html_stub
(wiki_page_menu_html page [f])
else
view_page page)
eliom-3.0.3/tests/miniwiki/wikidata/ 0000755 0000000 0000000 00000000000 12062377521 015574 5 ustar 00 0000000 0000000 eliom-3.0.3/tests/miniwiki/wikidata/TestPage.wiki 0000644 0000000 0000000 00000001645 12062377521 020203 0 ustar 00 0000000 0000000 = Test page =
== Lists ==
* Test links [http://www.google.fi Google] and [http://www.google.fi]
** Nested under Foo
** Still nested under Foo
* Top-level
* TodoListForNwiki
** Foobar
** Barfoo
*** sdf
* Hoax
* Poax
=== Heading 3 ===
One item:
* List
Two items:
* Item 1
* Item 2
Three items, one nested
* Item 1
* Item 2
** Nested Item 1
Four items, one nested
* Item 1
* Item 2
** Nested Item 1
* Item 3
foo
Another line of verbatim text
foo
== Paragraphs of text ==
Paragraphs of text. Paragraphs: My habanero started to flower a few weeks ago, and now, November 1st, it has produced a couple of pods as well. Quite surprising given the amount of light we have.
Paragraphs of text. Paragraphs: My habanero started to flower a few weeks ago, and now, November 1st, it has produced a couple of pods as well. Quite surprising given the amount of light we have.
eliom-3.0.3/tests/miniwiki/wikidata/WikiStart.wiki 0000644 0000000 0000000 00000000254 12062377521 020403 0 ustar 00 0000000 0000000 = Start Page of Miniwiki =
== What is Miniwiki? ==
Miniwiki is a very simple wiki written as an example for Ocsigen.
== Testing ==
See TestPage
coucou
tata
eliom-3.0.3/tests/miniwiki/_server/ 0000755 0000000 0000000 00000000000 12062377521 015444 5 ustar 00 0000000 0000000 eliom-3.0.3/doc/ 0000755 0000000 0000000 00000000000 12062377521 011562 5 ustar 00 0000000 0000000 eliom-3.0.3/doc/Makefile 0000644 0000000 0000000 00000000357 12062377521 013227 0 ustar 00 0000000 0000000
doc: server.doc client.doc
server.doc:
${MAKE} -C server doc
client.doc:
${MAKE} -C client doc
clean:
${MAKE} -C server clean
${MAKE} -C client clean
-rm -f *~ \#* .\#*
install:
${MAKE} -C server install
${MAKE} -C client install eliom-3.0.3/doc/index.wiki 0000644 0000000 0000000 00000000413 12062377521 013554 0 ustar 00 0000000 0000000 = Eliom -- API reference
[[wiki:mindmap.pdf|A mindmap to get an overview on the most important modules of Eliom]]
<<| in /var/www/data/site-ocsimore/eliom >>
<>
<>
eliom-3.0.3/doc/server/ 0000755 0000000 0000000 00000000000 12062377521 013070 5 ustar 00 0000000 0000000 eliom-3.0.3/doc/server/Makefile 0000644 0000000 0000000 00000002203 12062377521 014525 0 ustar 00 0000000 0000000 include ../../Makefile.config
include ../../src/server/Makefile.filelist
OCAMLDOC := ${OCAMLFIND} ocamldoc
ODOC := $(addprefix ../../src/server/,$(DOC:.mli=.odoc))
doc: odoc api-html/index.html api-man/Eliom_lib.server.3o
wikidoc: odoc api-wiki/index.wiki
odoc:
${MAKE} -C ../../src/server odoc
api-html/index.html: indexdoc ${ODOC}
mkdir -p api-html
$(OCAMLDOC) ${LIBS} -d api-html -intro indexdoc $(addprefix -load ,${ODOC}) -html
api-man/Eliom_lib.server.3o: ${ODOC}
mkdir -p api-man
$(OCAMLDOC) ${LIBS} -d api-man -man-mini $(addprefix -load ,${ODOC}) -man \
-man-section 3o -man-suffix server.3o
api-wiki/index.wiki: indexdoc ${ODOC}
mkdir -p api-wiki
ODOC_WIKI_SUBPROJECT=server $(OCAMLDOC) -d api-wiki -intro indexdoc \
-i $(shell ocamlfind query wikidoc) -g odoc_wiki.cma \
-colorize-code $(addprefix -load ,${ODOC})
install:
${INSTALL} -d -m 755 $(TEMPROOT)$(DOCDIR)/server
$(INSTALL) -m 644 api-html/* $(TEMPROOT)$(DOCDIR)/server
$(INSTALL) -m 755 -d $(TEMPROOT)$(MANDIR)/man3
$(INSTALL) -m 755 api-man/* $(TEMPROOT)$(MANDIR)/man3
clean:
-rm -f api-html/*
-rm -f api-man/*
-rm -f api-wiki/*
-rm -f *~ \#* .\#*
eliom-3.0.3/doc/server/indexdoc 0000644 0000000 0000000 00000001273 12062377521 014613 0 ustar 00 0000000 0000000 {1 Server API}
{!modules:
Eliom_pervasives
Eliom_lib
Eliom_common
Eliom_config
Eliom_request_info
Eliom_reference
Eliom_state
}
{2 Content and form creation}
{!modules:
Eliom_content
Eliom_content.Html5
Eliom_content.Svg
Eliom_content.Xml
Eliom_tools
}
{2 Services creation}
{!modules:
Eliom_service
Eliom_parameter
Eliom_registration
Eliom_registration.Html5
Eliom_registration.Action
Eliom_registration.Ocaml
Eliom_registration.App
Eliom_registration.File
Eliom_registration.Any
Eliom_registration.Redirection
}
{2 Client/server communication}
{!modules:
Eliom_bus
Eliom_comet
Eliom_react
}
{2 Extensions}
{!modules:
Eliom_atom
Atom_feed
Eliom_openid
Eliom_s2s
}
{2 Index}
{!indexlist}
eliom-3.0.3/doc/manual-wiki/ 0000755 0000000 0000000 00000000000 12062377521 014000 5 ustar 00 0000000 0000000 eliom-3.0.3/doc/manual-wiki/server-security.wiki 0000644 0000000 0000000 00000015543 12062377521 020050 0 ustar 00 0000000 0000000 ==How to write secure applications with Eliom==
Eliom and Ocsigen server are taking in charge a lot of security issues automatically. This unburdens the programmer from having to think about most of security problems. This page details various possible designs flaws of web applications, how Eliom and Ocsigen server (possibly) protects you against a possible exploitation of these flaws, and where you should be careful. //Please help us maintaining this page, by sending us any comments.// <<|For more details on the various flaws, see e.g. [[http://www.amazon.fr/Web-Application-Hackers-Handbook-Discovering/dp/0470170778/|this book]].>>
=== The application only does client-side verification
This is probably the biggest (and most dangerous) possible mistake. As the user has an entire control over the data sent to the server, **never** assume that the data sent by the client has been verified (even if there some checking function in Javascript or O'Browser).
Instead, reimplement all verifications server side.
* As a (small) mitigating factor, Eliom automatically checks that the type of the parameters is correct.
* Suggested approach: use permissions to control if the user is allowed to perform an action. Then,
** when creating a form, check if the user has the required permission (if not, you will usually display a message //insufficient permissions// instead of the form)
** in the service that answers to the form, perform the exact same check
However, note that incorrect data will never crash the server.
=== Incorrect access controls
This typically happens if authentication is badly implemented, or altogether missing in some places.
* each URL should implement user verification. Never assume that the user
comes from a trusted url, for example because the url is secret.
* use a programmatic, layered model, which encodes the various user rights (for ex: admin/moderators/editors/connected users/anonymous).
Thus a compromised login will not compromise the entire application
* Do not leak information through erroneous login (such as //this login does not exist//). Always answer //Bad login or password//, using always the same string
* Do not permit too many near-simultaneous login attempts, either for the same login, or from the same IP. You can use the module Lwt_throttle to delay login, if too many connections are started.
=== [[http://en.wikipedia.org/wiki/Code_injection|Code injection]]
* Eliom modules are written in OCaml, which is a compiled language. This prevents all code injection possible with script languages.
* No sql injection is possible if you use Macaque or PGOCaml, which use PostgreSQL prepared statements.
* No Html injection is possible, as unsafe HTML characters are always escaped before being written.
=== [[http://en.wikipedia.org/wiki/Directory_traversal|Path traversal]]
* The module <> can be used to prevent access to files or entire directories, from both Staticmod and Eliom.
* Even if <> is activated, users can only expose their own files; see the {{{localpath}}} option for details.
* Occurrences of the {{{'..'}}} pattern appearing in Urls are automatically removed by the server
* Ocsigen automatically decode HTML entities in URLs, which protects against attacks based on quoted characters
=== [[http://en.wikipedia.org/wiki/Session_fixation|Session fixation]]
* Ocsigen cookies are cryptographically generated, and cannot be guessed by the attacker. Thus the attacker cannot control, or supply, the cookie of the client.
* To be completely safe, do not issue tokens to anonymous users, or issue a new token as soon as a login/logout takes place
<<|Vincent : le dernier truc est mal expliqué et je ne comprends pas trop ce qu'il a voulu dire. Il faut expliquer pourquoi les cookies de Eliom sont sûrs de ce point de vue, et dire comment éviter un pb avec des cookies que l'on pose soi-même. token = ?>>
=== [[http://en.wikipedia.org/wiki/Cross-site_scripting|Cross-site scripting (XSS)]]
* most XSS attacks require code injection, from which you are automatically protected (see above)
* However, avoid at all costs to put user-supplied text in sensitive tags, including:
** {{{"
type for_attrib = string
let make_for_attrib name = "for=\""^name^"\""
end
include Eliom_mkforms.MakeForms(Forms_base)
end
eliom-3.0.3/src/server/Makefile.filelist 0000644 0000000 0000000 00000002566 12062377521 016375 0 ustar 00 0000000 0000000
INTF := eliom_lib.cmi \
eliom_content_core.cmi \
eliom_content.cmi \
eliom_cookie.cmi \
eliom_common.cmi \
eliom_types.cmi \
eliom_parameter.cmi \
eliom_service.cmi \
eliom_config.cmi \
eliom_request_info.cmi \
eliom_state.cmi \
eliom_uri.cmi \
eliom_mkforms.cmi \
eliom_registration.cmi \
eliom_comet.cmi \
eliom_react.cmi \
eliom_bus.cmi \
eliom_wrap.cmi \
\
eliom_tools_common.cmi \
eliom_tools.cmi \
eliom_mkreg.cmi \
eliom_reference.cmi \
eliom_extension.cmi \
eliom_pervasives.cmi \
\
extensions/eliom_s2s.cmi \
extensions/eliom_openid.cmi \
extensions/atom_feed.cmi \
extensions/eliom_atom.cmi \
NO_MLI := eliom_pervasives_base.cmi
IMPL := eliom.cma \
NATIMPL := eliom.cmxa eliom.a
ifeq "$(NATDYNLINK)" "YES"
NATIMPL += eliom.cmxs
endif
NOP4 := eliom_lib.mli
DOC := ${subst .cmi,.mli, ${filter-out ${NO_MLI}, ${INTF}}} \
eliom_types_base.mli \
eliom_comet_base.mli \
eliom-3.0.3/src/server/eliom_comet.ml 0000644 0000000 0000000 00000062671 12062377521 015754 0 ustar 00 0000000 0000000 (* Ocsigen
* http://www.ocsigen.org
* Copyright (C) 2010-2011
* Raphaël Proust
* Pierre Chambart
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exception;
* either version 2.1 of the License, or (at your option) any later version.
*
* This program 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
* GNU Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
(* TODO: handle ended stream ( and on client side too ) *)
open Eliom_lib
(* Shortening names of modules *)
module OFrame = Ocsigen_http_frame
module OStream = Ocsigen_stream
module OMsg = Ocsigen_messages
module Ecb = Eliom_comet_base
type chan_id = string
let encode_downgoing s =
Eliom_comet_base.Json_answer.to_string
(Eliom_comet_base.Stateful_messages (Array.of_list s))
let encode_global_downgoing s =
Eliom_comet_base.Json_answer.to_string
(Eliom_comet_base.Stateless_messages (Array.of_list s))
let timeout_msg =
Eliom_comet_base.Json_answer.to_string Eliom_comet_base.Timeout
let process_closed_msg =
Eliom_comet_base.Json_answer.to_string Eliom_comet_base.Process_closed
let error_msg s =
Eliom_comet_base.Json_answer.to_string (Eliom_comet_base.Comet_error s)
let json_content_type = "application/json"
exception New_connection
module Comet_param =
struct
type page = string
let translate content = Lwt.return (content,json_content_type)
end
module Comet =
Eliom_registration.Customize ( Eliom_registration.String ) ( Comet_param )
let comet_path = ["__eliom_comet__"]
let comet_global_path = ["__eliom_comet_global__"]
let fallback_service =
Eliom_common.lazy_site_value_from_fun
(fun () -> Comet.register_service ~path:comet_path
~get_params:Eliom_parameter.unit
(fun () () -> Lwt.return process_closed_msg))
let fallback_global_service =
Eliom_common.lazy_site_value_from_fun
(fun () -> Comet.register_service ~path:comet_global_path
~get_params:Eliom_parameter.unit
(fun () () -> Lwt.return (error_msg "request with no post parameters or there isn't any registered site comet channel")))
let new_id = make_cryptographic_safe_string
(* ocsigenserver needs to be modified for this to be configurable:
the connection is closed after a fixed time if the server does not send anything.
By default it is 30 seconds *)
let timeout = 20.
module Stateless : sig
type channel
val create : ?name:string -> size:int -> string Lwt_stream.t -> channel
val get_id : channel -> string
val get_service : unit -> Ecb.comet_service
val get_kind : newest:bool -> channel -> Ecb.stateless_kind
val chan_id_of_string : string -> 'a Ecb.chan_id
end =
struct
type channel_id = string
module Dlist = Ocsigen_cache.Dlist
type channel = {
ch_id : channel_id;
mutable ch_index : int; (* the number of messages already added to the channel *)
ch_content : (string * int) Dlist.t;
ch_wakeup : unit Lwt_condition.t; (* condition broadcasted when there is a new message *)
}
module Channel_hash =
struct
type t = channel
let equal c1 c2 = c1.ch_id = c2.ch_id
let hash c = Hashtbl.hash c.ch_id
end
module Weak_channel_table = Weak.Make(Channel_hash)
let channels = Weak_channel_table.create 0
let find_channel =
let dummy_channel =
{ ch_id = "";
ch_index = 0;
ch_content = Dlist.create 1;
ch_wakeup = Lwt_condition.create (); }
in
fun ch_id ->
let dummy = { dummy_channel with ch_id = ch_id } in
try
Some (Weak_channel_table.find channels dummy)
with
| Not_found ->
None
let wakeup_waiters channel =
Lwt_condition.broadcast channel.ch_wakeup ()
(* fill the channel with messages from the stream *)
let run_channel channel stream =
let channel' = Weak.create 1 in
Weak.set channel' 0 (Some channel);
let channel = channel' in
(* hide non weak reference to be sure not to keep a strong reference *)
let f msg =
match Weak.get channel 0 with
| None ->
raise_lwt Not_found
(* terminates the loop: remove reference on the stream, etc ... *)
| Some channel ->
channel.ch_index <- succ channel.ch_index;
ignore (Dlist.add (msg,channel.ch_index) channel.ch_content: 'a option);
wakeup_waiters channel;
Lwt.return ()
in
ignore (Lwt_stream.iter_s f stream:unit Lwt.t)
let make_name name = "stateless:"^name
let chan_id_of_string name = Ecb.chan_id_of_string (make_name name)
let create ?(name=new_id ()) ~size stream =
let name = make_name name in
let channel =
{ ch_id = name;
ch_index = 0;
ch_content = Dlist.create size;
ch_wakeup = Lwt_condition.create () }
in
run_channel channel stream;
match find_channel name with
| Some _ ->
failwith (Printf.sprintf "can't create channel %s: a channel with the same name already exists" name)
| None ->
Weak_channel_table.add channels channel;
channel
let get_channel (ch_id,position) =
match find_channel ch_id with
| Some channel -> Left (channel,position)
| None -> Right ch_id
exception Finished of (channel_id * (string * int) Ecb.channel_data) list
let queue_take channel last =
try
Dlist.fold
(fun l (v,index) ->
if index >= last
then (channel.ch_id,Ecb.Data (v,index))::l
else raise (Finished l))
[]
channel.ch_content
with
| Finished l -> l
let get_available_data = function
| Right ch_id -> [ch_id,Ecb.Closed]
| Left (channel,position) ->
match position with
(* the first request of the client should be with i = 1 *)
(* when the client is requesting the newest data, only return
one if he don't already have it *)
| Ecb.Newest i when i > channel.ch_index -> []
| Ecb.Newest _
| Ecb.Last None -> (* initialisation of external newest channels *)
(match Dlist.newest channel.ch_content with
| None -> [] (* should not happen *)
| Some node ->
[channel.ch_id,Ecb.Data (Dlist.value node)])
(* when the client is requesting the data after index i return
all data with index gretter or equal to i*)
| Ecb.After i when i > channel.ch_index -> []
(* if the requested value is not in the queue anymore, tell
the client that its request was dropped *)
| Ecb.After i when i <= channel.ch_index - (Dlist.size channel.ch_content) ->
[channel.ch_id,Ecb.Full]
| Ecb.After i ->
queue_take channel i
| Ecb.Last (Some n) ->
let i = channel.ch_index - (min (Dlist.size channel.ch_content) n) in
queue_take channel i
let has_data = function
| Right _ -> true (* a channel was closed: need to tell it to the client *)
| Left (channel,position) ->
match position with
| Ecb.Newest i when i > channel.ch_index -> false
| Ecb.Newest i -> true
| Ecb.After i when i > channel.ch_index -> false
| Ecb.After i -> true
| Ecb.Last n when (Dlist.size channel.ch_content) > 0 -> true
| Ecb.Last n -> false
let really_wait_data requests =
let rec make_list = function
| [] -> []
| (Left (channel,_))::q -> (Lwt_condition.wait channel.ch_wakeup)::(make_list q)
| (Right _)::q -> assert false (* closed channels are considered to have data *)
in
Lwt.pick (make_list requests)
let wait_data requests =
if List.exists has_data requests
then Lwt.return ()
else
Lwt_unix.with_timeout timeout
(fun () -> really_wait_data requests)
let handle_request () = function
| Ecb.Stateful _ -> failwith "attempting to request data on stateless service with a stateful request"
| Ecb.Stateless requests ->
let requests = List.map get_channel (Array.to_list requests) in
lwt res =
try_lwt
lwt () = wait_data requests in
Lwt.return (List.flatten (List.map get_available_data requests))
with
| Lwt_unix.Timeout -> Lwt.return []
in
Lwt.return (encode_global_downgoing res)
let global_service =
Eliom_common.lazy_site_value_from_fun
(fun () -> Comet.register_post_service
~fallback:(Eliom_common.force_lazy_site_value fallback_global_service)
~post_params:Ecb.comet_request_param
handle_request)
let get_service () =
Eliom_common.force_lazy_site_value global_service
let get_id {ch_id} = ch_id
let get_kind ~newest {ch_index} =
if newest
then Ecb.Newest_kind (ch_index + 1)
else Ecb.After_kind (ch_index + 1)
end
module Stateful :
(** String channels on wich is build the module Channel *)
sig
type t
val create : ?scope:Eliom_common.client_process_scope ->
?name:chan_id -> string Ecb.channel_data Lwt_stream.t -> t
val get_id : t -> string
type comet_service = Ecb.comet_service
val get_service : t -> comet_service
val close_channel : t -> unit
val wait_timeout : ?scope:Eliom_common.client_process_scope ->
float -> unit Lwt.t
end = struct
type chan_id = string
type comet_service = Ecb.comet_service
type internal_comet_service = Ecb.internal_comet_service
type end_request_waiters = unit Lwt.u
type activity =
| Active of end_request_waiters list
(** There is currently a request from the client *)
| Inactive of float
(** The last request from the client completed at that time *)
type handler =
{
hd_scope : Eliom_common.client_process_scope;
(* id : int; pour tester que ce sont des service differents... *)
mutable hd_active_streams : ( chan_id * ( string Ecb.channel_data Lwt_stream.t ) ) list;
(** streams that are currently sent to client *)
mutable hd_unregistered_streams : ( chan_id * ( string Ecb.channel_data Lwt_stream.t ) ) list;
(** streams that are created on the server side, but client did not register *)
mutable hd_registered_chan_id : chan_id list;
(** the fusion of all the streams from hd_active_streams *)
mutable hd_update_streams : unit Lwt.t;
(** thread that wakeup when there are new active streams. *)
mutable hd_update_streams_w : unit Lwt.u;
hd_service : internal_comet_service;
mutable hd_last : string * int;
(** the last message sent to the client, if he sends a request
with the same number, this message is immediately sent
back.*)
mutable hd_activity : activity;
}
exception Connection_closed
let set_active handler =
match handler.hd_activity with
| Active _ -> ()
| Inactive _ -> handler.hd_activity <- Active []
let set_inactive handler =
match handler.hd_activity with
| Active l ->
handler.hd_activity <- Inactive (Unix.gettimeofday ());
List.iter (fun waiter -> Lwt.wakeup waiter ()) l
| Inactive _ -> ()
let update_inactive handler =
match handler.hd_activity with
| Active _ -> ()
| Inactive _ ->
handler.hd_activity <- Inactive (Unix.gettimeofday ())
let wait_handler_timeout handler t =
let rec run () =
match handler.hd_activity with
| Active l ->
let waiter,waker = Lwt.task () in
let t =
lwt () = waiter in
lwt () = Lwt_unix.sleep t in
run ()
in
handler.hd_activity <- Active (waker::l);
t
| Inactive inactive_time ->
let now = Unix.gettimeofday () in
if now -. inactive_time > t
then Lwt.return ()
else
lwt () = Lwt_unix.sleep (t -. (now -. inactive_time)) in
run ()
in
run ()
(** called when a connection is opened, it makes the other
connection terminate with no data. That way there is at most one
opened connection to the service. There are new connection
opened when the client wants to listen to new channels for
instance. *)
let new_connection handler =
let t,w = Lwt.task () in
let wakener = handler.hd_update_streams_w in
handler.hd_update_streams <- t;
handler.hd_update_streams_w <- w;
set_active handler;
Lwt.wakeup_exn wakener New_connection
(** called when a new channel is made active. It restarts the thread
wainting for inputs ( wait_data ) such that it can receive the messages from
the new channel *)
let signal_update handler =
let t,w = Lwt.task () in
let wakener = handler.hd_update_streams_w in
handler.hd_update_streams <- t;
handler.hd_update_streams_w <- w;
Lwt.wakeup wakener ()
let wait_streams streams =
Lwt.pick (List.map (fun (_,s) -> Lwt_stream.peek s) streams)
(** read up to [n] messages in the list of streams [streams] without blocking. *)
let read_streams n streams =
let rec aux acc n streams =
match streams with
| [] -> acc
| (id,stream)::other_streams ->
match n with
| 0 -> acc
| _ ->
let l = Lwt_stream.get_available_up_to n stream in
let l' = List.map (fun v -> id,v) l in
let rest = n - (List.length l) in
aux (l'@acc) rest other_streams
in
aux [] n streams
(** wait for data on any channel that the client asks. It correcly
handles new channels the server creates after that the client
registered them *)
let rec wait_data handler =
Lwt.choose
[ Lwt.protected (wait_streams handler.hd_active_streams) >>= ( fun _ -> Lwt.return `Data );
Lwt.protected (handler.hd_update_streams) >>= ( fun _ -> Lwt.return `Update ) ]
>>= ( function
| `Data -> Lwt.return ()
| `Update -> wait_data handler )
let launch_stream handler (chan_id,stream) =
handler.hd_active_streams <- (chan_id,stream)::handler.hd_active_streams;
signal_update handler
let register_channel handler chan_id =
OMsg.debug2 (Printf.sprintf "eliom: comet: register channel %s" chan_id);
if not (List.mem_assoc chan_id handler.hd_active_streams)
then
try
let stream = List.assoc chan_id handler.hd_unregistered_streams in
handler.hd_unregistered_streams <-
List.remove_assoc chan_id handler.hd_unregistered_streams;
launch_stream handler (chan_id,stream)
with
| Not_found ->
handler.hd_registered_chan_id <- chan_id::handler.hd_registered_chan_id
let close_channel' handler chan_id =
OMsg.debug2 (Printf.sprintf "eliom: comet: close channel %s" chan_id);
handler.hd_active_streams <- List.remove_assoc chan_id handler.hd_active_streams;
handler.hd_unregistered_streams <- List.remove_assoc chan_id handler.hd_unregistered_streams;
handler.hd_registered_chan_id <- List.filter ((<>) chan_id) handler.hd_registered_chan_id;
signal_update handler
let wait_closed_connection () =
let ri = Eliom_request_info.get_ri () in
lwt () = ri.Ocsigen_extensions.ri_connection_closed in
raise_lwt Connection_closed
(* register the service handler.hd_service *)
let run_handler handler =
let f () req =
match req with
| Ecb.Stateless _ ->
failwith "attempting to request data on stateful service with a stateless request"
| Ecb.Stateful (Ecb.Request_data number) ->
OMsg.debug2 (Printf.sprintf "eliom: comet: received request %i" number);
(* if a new connection occurs for a service, we reply
immediately to the previous with no data. *)
new_connection handler;
if snd handler.hd_last = number
then Lwt.return (fst handler.hd_last)
else
Lwt.catch
( fun () -> Lwt_unix.with_timeout timeout
(fun () ->
lwt () = Lwt.choose
[ wait_closed_connection ();
wait_data handler ] in
let messages = read_streams 100 handler.hd_active_streams in
let message = encode_downgoing messages in
handler.hd_last <- (message,number);
set_inactive handler;
Lwt.return message ) )
( function
| New_connection -> Lwt.return (encode_downgoing [])
(* happens if an other connection has been opened on that service *)
(* CCC in this case, it would be beter to return code 204: no content *)
| Lwt_unix.Timeout ->
set_inactive handler;
Lwt.return timeout_msg
| Connection_closed ->
set_inactive handler;
(* it doesn't matter what we do here *)
raise_lwt Connection_closed
| e ->
set_inactive handler;
Lwt.fail e )
| Ecb.Stateful (Ecb.Commands commands) ->
update_inactive handler;
List.iter (function
| Ecb.Register channel -> register_channel handler channel
| Ecb.Close channel -> close_channel' handler channel)
(Array.to_list commands);
(* command connections are replied immediately by an
empty answer *)
Lwt.return (encode_downgoing [])
in
Comet.register
~scope:handler.hd_scope
~service:handler.hd_service
f
(** For each scope there is a reference containing the handler. The
reference itself are stocked in [handler_ref_table]. This table
is never cleaned, but it is supposed that this won't be a
problem as scope should be used in limited number *)
(* as of now only `Client_process scope are handled: so we only stock scope_hierarchy *)
type handler_ref_table = (Eliom_common.scope_hierarchy,handler option Eliom_reference.eref) Hashtbl.t
let handler_ref_table : handler_ref_table = Hashtbl.create 1
(* this is a hack for the create function not to return 'a Lwt.t
type: This is needed because bus and react create the channel at
wrapping time, where it is impossible to block *)
let get_ref eref =
match Lwt.state (Eliom_reference.get eref) with
| Lwt.Return v -> v
| _ ->
failwith "Eliom_comet: accessing channel references should not be blocking: this is an eliom bug"
let set_ref eref v =
match Lwt.state (Eliom_reference.set eref v) with
| Lwt.Return () -> ()
| _ ->
failwith "Eliom_comet: accessing channel references should not be blocking: this is an eliom bug"
let get_handler_eref scope =
let scope_hierarchy = Eliom_common_base.scope_hierarchy_of_scope scope in
try
Hashtbl.find handler_ref_table scope_hierarchy
with
| Not_found ->
let eref = Eliom_reference.eref ~scope:(`Client_process scope_hierarchy) None in
Hashtbl.add handler_ref_table scope_hierarchy eref;
eref
let get_handler scope =
let eref = get_handler_eref scope in
match get_ref eref with
| Some t -> t
| None ->
begin
let hd_service =
(* CCC ajouter possibilité d'https *)
Eliom_service.post_coservice
~fallback:(Eliom_common.force_lazy_site_value fallback_service)
(*~name:"comet" (* CCC faut il mettre un nom ? *)*)
~post_params:Ecb.comet_request_param
()
in
let hd_update_streams,hd_update_streams_w = Lwt.task () in
let handler = {
hd_scope = scope;
hd_active_streams = [];
hd_unregistered_streams = [];
hd_registered_chan_id = [];
hd_service;
hd_update_streams;
hd_update_streams_w;
hd_last = "", -1;
hd_activity = Inactive (Unix.gettimeofday ());
}
in
set_ref eref (Some handler);
run_handler handler;
handler
end
let wait_timeout ?(scope=Eliom_common.comet_client_process_scope) t =
let hd = get_handler scope in
wait_handler_timeout hd t
type t =
{
ch_handler : handler;
ch_id : chan_id;
ch_stream : string Ecb.channel_data Lwt_stream.t;
}
let close_channel chan =
close_channel' chan.ch_handler chan.ch_id
let name_of_scope (scope:Eliom_common.user_scope) =
let sp = Eliom_common.get_sp () in
let name = Eliom_common.make_full_state_name
~sp ~secure:false (*VVV secure? *) ~scope in
let pref = match scope with
| `Session_group _ -> "sessiongroup:"
| `Session _ -> "session:"
| `Client_process _ -> "clientprocess:"
in
Eliom_common.make_full_cookie_name pref name
let create ?(scope=Eliom_common.comet_client_process_scope)
?(name=new_id ()) stream =
let name = (name_of_scope (scope:>Eliom_common.user_scope)) ^ name in
let handler = get_handler scope in
OMsg.debug2 (Printf.sprintf "eliom: comet: create channel %s" name);
if List.mem name handler.hd_registered_chan_id
then
begin
handler.hd_registered_chan_id <-
List.filter ((<>) name) handler.hd_registered_chan_id;
launch_stream handler (name,stream)
end
else
handler.hd_unregistered_streams <- (name,stream)::handler.hd_unregistered_streams;
{ ch_handler = handler;
ch_stream = stream;
ch_id = name; }
let get_id {ch_id} =
ch_id
let get_service chan =
(chan.ch_handler.hd_service:>comet_service)
end
module Channel :
sig
type 'a t
type comet_scope =
[ Eliom_common.site_scope
| Eliom_common.client_process_scope ]
val create : ?scope:[< comet_scope ] ->
?name:string -> ?size:int -> 'a Lwt_stream.t -> 'a t
val create_unlimited : ?scope:Eliom_common.client_process_scope ->
?name:string -> 'a Lwt_stream.t -> 'a t
val create_newest : ?name:string -> 'a Lwt_stream.t -> 'a t
val get_wrapped : 'a t -> 'a Ecb.wrapped_channel
val external_channel : ?history:int -> ?newest:bool ->
prefix:string -> name:string -> unit -> 'a t
val wait_timeout : ?scope:Eliom_common.client_process_scope ->
float -> unit Lwt.t
end = struct
type 'a channel =
| Stateless of Stateless.channel
| Stateless_newest of Stateless.channel
| Stateful of Stateful.t
| External of 'a Ecb.wrapped_channel
type 'a t = {
channel : 'a channel;
channel_mark : 'a t Eliom_common.wrapper;
}
let get_wrapped t =
match t.channel with
| Stateful channel ->
Ecb.Stateful_channel
(Stateful.get_service channel,
Ecb.chan_id_of_string (Stateful.get_id channel))
| Stateless channel ->
Ecb.Stateless_channel
(Stateless.get_service (),
Ecb.chan_id_of_string (Stateless.get_id channel),
Stateless.get_kind ~newest:false channel)
| Stateless_newest channel ->
Ecb.Stateless_channel
(Stateless.get_service (),
Ecb.chan_id_of_string (Stateless.get_id channel),
Stateless.get_kind ~newest:true channel)
| External wrapped -> wrapped
let internal_wrap c =
(get_wrapped c,Eliom_common.make_unwrapper Eliom_common.comet_channel_unwrap_id)
let channel_mark () = Eliom_common.make_wrapper internal_wrap
exception Halt
(* TODO close on full *)
let limit_stream ~size s =
let open Lwt in
let full = ref false in
let closed = ref false in
let count = ref 0 in
let str, push = Lwt_stream.create () in
let stopper,wake_stopper = wait () in
let rec loop () =
( Lwt_stream.get s stopper ) >>= function
| Some x ->
if !count >= size
then (full := true;
ignore (Lwt_stream.get_available str);
(* flush the channel *)
return ())
else (incr count; push (Some ( Ecb.Data x )); loop ())
| None ->
return ()
in
ignore (loop ():'a Lwt.t);
let res = Lwt_stream.from (fun () ->
if !full
then
if !closed
then return None
else ( closed := true;
return (Some Ecb.Full) )
else (decr count;
Lwt_stream.get str)) in
Gc.finalise (fun _ -> wakeup_exn wake_stopper Halt) res;
res
let marshal (v:'a) =
let wrapped = Eliom_wrap.wrap v in
let value : 'a Eliom_types.eliom_comet_data_type = wrapped in
(Url.encode ~plus:false
(Marshal.to_string value []))
let create_stateful_channel ?scope ?name stream =
Stateful
(Stateful.create ?scope ?name
(Lwt_stream.map
(function
| Ecb.Closed ->
OMsg.debug2 (Printf.sprintf "eliom: closed in stateful channels: this is an error: this should not be possible");
Ecb.Closed
| Ecb.Full -> Ecb.Full
| Ecb.Data s -> Ecb.Data (marshal s)) stream))
let create_stateless_channel ?name ~size stream =
Stateless
(Stateless.create ?name ~size
(Lwt_stream.map marshal stream))
let create_stateless_newest_channel ?name stream =
Stateless_newest
(Stateless.create ?name ~size:1
(Lwt_stream.map marshal stream))
let create_stateful ?scope ?name ?(size=1000) stream =
let stream = limit_stream ~size stream in
{ channel = create_stateful_channel ?scope ?name stream;
channel_mark = channel_mark () }
let create_unlimited ?scope ?name stream =
let stream = Lwt_stream.map (fun x -> Ecb.Data x) stream in
{ channel = create_stateful_channel ?scope ?name stream;
channel_mark = channel_mark () }
let create_stateless ?name ?(size=1000) stream =
{ channel = create_stateless_channel ?name ~size stream;
channel_mark = channel_mark () }
let create_newest ?name stream =
{ channel = create_stateless_newest_channel ?name stream;
channel_mark = channel_mark () }
type comet_scope =
[ Eliom_common.site_scope
| Eliom_common.client_process_scope ]
let create ?scope ?name ?(size=1000) stream =
match scope with
| None -> create_stateful ?name ~size stream
| Some ((`Client_process n) as scope) -> create_stateful ~scope ?name ~size stream
| Some `Site -> create_stateless ?name ~size stream
let external_channel ?(history=1) ?(newest=false) ~prefix ~name () =
let service = Eliom_service.external_post_service
~prefix
~path:comet_global_path
~get_params:Eliom_parameter.unit
~post_params:Ecb.comet_request_param
()
in
let last = if newest then None else Some history in
{ channel = External (Ecb.Stateless_channel
(service,
Stateless.chan_id_of_string name,
Ecb.Last_kind last));
channel_mark = channel_mark () }
let wait_timeout = Stateful.wait_timeout
end
eliom-3.0.3/src/server/eliom_extension.ml 0000644 0000000 0000000 00000003276 12062377521 016655 0 ustar 00 0000000 0000000 (* Ocsigen
* http://www.ocsigen.org
* Copyright (C) 2008 Vincent Balat
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exception;
* either version 2.1 of the License, or (at your option) any later version.
*
* This program 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
* GNU Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
(*****************************************************************************)
(*****************************************************************************)
(** Run Ocsigen extensions that can access Eliom data *)
(*****************************************************************************)
(*****************************************************************************)
let (>>=) = Lwt.bind
type eliom_extension_sig =
unit -> Ocsigen_extensions.answer Lwt.t
let module_action : eliom_extension_sig ref =
ref (fun _ -> failwith "Eliommod_extension")
let register_eliom_extension f =
module_action := f
let get_eliom_extension () = !module_action
let run_eliom_extension (fext : eliom_extension_sig) now info sitedata =
let sp = Eliom_common.make_server_params sitedata info None None in
Lwt.with_value Eliom_common.sp_key (Some sp) fext
eliom-3.0.3/src/server/eliom_tools_common.mli 0000644 0000000 0000000 00000005556 12062377521 017525 0 ustar 00 0000000 0000000 (* Ocsigen
* Copyright (C) 2005 Vincent Balat
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exception;
* either version 2.1 of the License, or (at your option) any later version.
*
* This program 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
* GNU Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
open Eliom_service
open Eliom_parameter
open Eliom_state
(** {2 Menus } *)
type ('a, 'b, 'c) one_page =
(unit, unit,
'a,
[ `WithoutSuffix ],
unit, unit,
'b, 'c) service
constraint 'c = [< Eliom_registration.non_caml_service ]
type get_page =
(Eliom_service.get_service_kind,
Eliom_service.registrable,
Eliom_registration.non_caml_service) one_page
(** {2 Hierchical sites } *)
type ('a, 'b, 'c) hierarchical_site_item =
| Disabled
| Site_tree of ('a, 'b, 'c) hierarchical_site
constraint 'b = [< Eliom_service.registrable ]
and ('a, 'b) main_page =
| Main_page of ('a, 'b, Eliom_registration.non_caml_service) one_page
| Default_page of ('a, 'b, Eliom_registration.non_caml_service) one_page
| Not_clickable
constraint 'b = [< Eliom_service.registrable ]
and ('a, 'b, 'c) hierarchical_site =
(('a, 'b) main_page *
('c * ('a, 'b, 'c) hierarchical_site_item) list)
constraint 'b = [< Eliom_service.registrable ]
(** The type of hierarchical sites.
A hierarchical site is a pair (main page, subpages).
The difference between
[Main_page], [Default_page] and [Not_clickable] is a bit subtle:
- [Main_page] is when you want to create a main page for your
subsite. All the subpages are subsections of that page.
- [Default_page] is like [Main_page] but is not taken into account
for computing which is the current page in the menu.
Use it for example when there is no main page, but you want
one of the subpages to be the default page for your subsite.
The service you use as default page
must appear another time in the subtree!
- [Not_clickable] is when you do not want the menu entry to be a link
but you want subpages.
Each subpage is defined by the text to be displayed in menus
and a [hierarchical_site_item].
If the latter is [Disabled], the menu entry is disabled.
*)
(**/**)
val menu_class : string
val last_class : string
val current_class : string
val current_path_class : string
val disabled_class : string
val first_class : string
val level_class : string
eliom-3.0.3/src/server/eliom_mkreg.mli 0000644 0000000 0000000 00000004352 12062377521 016113 0 ustar 00 0000000 0000000 (* Ocsigen
* http://www.ocsigen.org
* Module Eliom_mkreg
* Copyright (C) 2007 Vincent Balat
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exception;
* either version 2.1 of the License, or (at your option) any later version.
*
* This program 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
* GNU Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
(** This module defines the functor to use to creates modules
generating functions to register services for your own types of pages.
It is used for example in {!Eliom_registration}.
*)
open Eliom_lib
open Ocsigen_extensions
open Eliom_state
open Eliom_parameter
open Eliom_service
(** {2 Creating modules to register services for one type of pages} *)
module type REG_PARAM = "sigs/eliom_reg_param.mli"
module MakeRegister(Pages: REG_PARAM) : sig
include "sigs/eliom_reg.mli" subst type page := Pages.page
and type options := Pages.options
and type return := Pages.return
and type result := Pages.result
end
(** {2 Creating modules to register services for one type of parametrised pages} *)
module type REG_PARAM_ALPHA_RETURN =
sig
type ('a, 'b) page
type 'a return
type ('a, 'b) result
include "sigs/eliom_reg_param.mli"
subst type page := ('a, 'b) page
and type return := 'b return
and type result := ('a, 'b) result
end
module MakeRegister_AlphaReturn(Pages: REG_PARAM_ALPHA_RETURN) : sig
include "sigs/eliom_reg_alpha_return.mli"
subst type page := ('a, 'b) Pages.page
and type options := Pages.options
and type return := 'b Pages.return
and type result := ('a, 'b) Pages.result
end
(**/**)
val suffix_redir_uri_key : string Polytables.key
eliom-3.0.3/src/server/eliom_parameter.ml 0000644 0000000 0000000 00000044062 12062377521 016617 0 ustar 00 0000000 0000000 (* Ocsigen
* http://www.ocsigen.org
* Module eliom_parameter.ml
* Copyright (C) 2007 Vincent Balat
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exception;
* either version 2.1 of the License, or (at your option) any later version.
*
* This program 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
* GNU Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
open Eliom_lib
include Eliom_parameter_base
type suff = [ `WithoutSuffix | `WithSuffix | `Endsuffix ]
open Ocsigen_extensions
type anon_params_type = int
let anonymise_params_type (t : ('a, 'b, 'c) params_type) : anon_params_type =
Hashtbl.hash_param 1000 1000 t
(*****************************************************************************)
(* types available only on server side (no pcre on browser) *)
let regexp reg dest ~to_string n =
user_type
(fun s ->
match Netstring_pcre.string_match reg s 0 with
| Some _ ->
begin
try
Ocsigen_extensions.replace_user_dir reg
(Ocsigen_extensions.parse_user_dir dest) s
with Ocsigen_extensions.NoSuchUser ->
raise (Failure "User does not exist")
end
| _ -> raise (Failure "Regexp not matching"))
to_string
n
let all_suffix_regexp reg dest ~(to_string : 'a -> string) (n : string) :
(string, [`Endsuffix], [ `One of string ] param_name) params_type =
all_suffix_user
(fun s ->
match Netstring_pcre.string_match reg s 0 with
| Some _ ->
begin
try
Ocsigen_extensions.replace_user_dir reg
(Ocsigen_extensions.parse_user_dir dest) s
with Ocsigen_extensions.NoSuchUser ->
raise (Failure "User does not exist")
end
| _ -> raise (Failure "Regexp not matching"))
to_string
n
(******************************************************************)
(* The following function reconstructs the value of parameters
from expected type and GET or POST parameters *)
type 'a res_reconstr_param =
| Res_ of ('a *
(string * string) list *
(string * file_info) list)
| Errors_ of ((string * string * exn) list *
(string * string) list *
(string * file_info) list)
let reconstruct_params_
req
(typ : ('a, [<`WithSuffix|`WithoutSuffix], 'b) params_type)
params files nosuffixversion urlsuffix : 'a =
let rec parse_suffix typ suff =
match (typ, suff) with
| TESuffix _, l -> Obj.magic l, []
(*VVV encode=false? *)
| TESuffixs _, l -> Obj.magic (Url.string_of_url_path ~encode:false l), []
| TESuffixu (_, of_string, to_string), l ->
(try
(*VVV encode=false? *)
Obj.magic (of_string (Url.string_of_url_path ~encode:false l)), []
with e ->
raise (Eliom_common.Eliom_Typing_Error [("", e)]))
| TOption t, [] -> Obj.magic None, []
| TOption t, ""::l -> Obj.magic None, l
| TOption t, l ->
let r, ll = parse_suffix t l in
Obj.magic (Some r), ll
| TNEOption t, [] -> Obj.magic None, []
| TNEOption t, ""::l -> Obj.magic None, l
| TNEOption t, l ->
let r, ll = parse_suffix t l in
Obj.magic (Some r), ll
| TList _, [] | TSet _, [] -> Obj.magic [], []
| TList (_, t), l | TSet t, l ->
let b, l = Obj.magic (parse_suffix t l) in
(match l with
| [] -> raise Eliom_common.Eliom_Wrong_parameter
| [""] -> Obj.magic [b], []
| _ ->
let c, l = Obj.magic (parse_suffix typ l) in
Obj.magic (b::c), l)
| TProd (TList _, _), _
| TProd (TSet _, _), _ ->
failwith "Lists or sets in suffixes must be last parameters"
| TProd (t1, t2), l ->
(match parse_suffix t1 l with
| _, [] -> raise Eliom_common.Eliom_Wrong_parameter
| r, l ->
let rr, ll = parse_suffix t2 l in
Obj.magic (r, rr), ll)
| TString _, v::l -> Obj.magic v, l
| TInt name, v::l ->
(try Obj.magic (int_of_string v), l
with e ->
raise (Eliom_common.Eliom_Typing_Error [("", e)]))
| TInt32 name, v::l ->
(try Obj.magic (Int32.of_string v), l
with e ->
raise (Eliom_common.Eliom_Typing_Error [("", e)]))
| TInt64 name, v::l ->
(try Obj.magic (Int64.of_string v), l
with e ->
raise (Eliom_common.Eliom_Typing_Error [("", e)]))
| TFloat name, v::l ->
(try Obj.magic (float_of_string v), l
with e ->
raise (Eliom_common.Eliom_Typing_Error [("", e)]))
| TUnit, v::l ->
(if v="" then Obj.magic (), l
else raise Eliom_common.Eliom_Wrong_parameter)
| TBool name, v::l ->
(try Obj.magic (bool_of_string v), l
with e ->
raise (Eliom_common.Eliom_Typing_Error [("", e)]))
| TUserType (name, of_string, string_of), v::l ->
(try Obj.magic (of_string v), l
with e ->
raise (Eliom_common.Eliom_Typing_Error [("", e)]))
| TTypeFilter (t, None), _ -> failwith "Type filter without filter"
| TTypeFilter (t, Some check), l ->
let (v, _) as a = parse_suffix t l in
check v;
a
| TConst value, v::l ->
if v = value
then Obj.magic (), l
else raise Eliom_common.Eliom_Wrong_parameter
| TSum (t1, t2), l ->
(try parse_suffix t1 l
with Eliom_common.Eliom_Wrong_parameter -> parse_suffix t2 l)
| TCoord _, l ->
(match Obj.magic (parse_suffix (TInt "") l) with
| _, [] -> raise Eliom_common.Eliom_Wrong_parameter
| r, l ->
let rr, ll = Obj.magic (parse_suffix (TInt "") l) in
Obj.magic {abscissa = r; ordinate=rr}, ll)
| TCoordv (t, _), l ->
let a, l = parse_suffix t l in
(match Obj.magic (parse_suffix (TInt "") l) with
| _, [] -> raise Eliom_common.Eliom_Wrong_parameter
| r, l ->
let rr, ll = Obj.magic (parse_suffix (TInt "") l) in
Obj.magic (a, {abscissa = r; ordinate=rr}), ll)
| TNLParams _, _ ->
failwith "It is not possible to have non localized parameters in suffix"
| TJson (_, Some typ), v::l -> Deriving_Json.from_string typ v, l
| TJson (_, None), v::l -> assert false (* client side only *)
| TAny _, _ ->
failwith "It is not possible to use any in suffix. May be try with all_suffix ?"
| _ -> raise Eliom_common.Eliom_Wrong_parameter
in
let aux2 typ params =
let rec aux_list t params files name pref suff =
let rec aa i lp fl pref =
let rec end_of_list len = function
| [] -> true
| (a, _)::_ when
(try (String.sub a 0 len) = pref
with Invalid_argument _ -> false) -> false
| _::l -> end_of_list len l
in
if end_of_list (String.length pref) lp
then Res_ ((Obj.magic []), lp, fl)
else
match aux t lp fl pref (make_list_suffix i) with
| Res_ (v, lp2, f) ->
(match aa (i+1) lp2 f pref with
| Res_ (v2,lp3,f2) -> Res_ ((Obj.magic (v::v2)),lp3,f2)
| err -> err)
| Errors_ (errs, l, f) -> Errors_ (errs, l, f)
in
aa 0 params files (pref^name^suff^".")
and aux (typ : ('a, [<`WithSuffix|`WithoutSuffix|`Endsuffix], 'b) params_type)
params files pref suff : 'a res_reconstr_param =
match typ with
| TNLParams (_, _, _, t) -> aux t params files pref suff
| TProd (t1, t2) ->
(match aux t1 params files pref suff with
| Res_ (v1, l1, f) ->
(match aux t2 l1 f pref suff with
| Res_ (v2, l2, f2) -> Res_ ((Obj.magic (v1, v2)), l2, f2)
| err -> err)
| Errors_ (errs, l, f) ->
(match aux t2 l f pref suff with
| Res_ (_, ll, ff) -> Errors_ (errs, ll, ff)
| Errors_ (errs2, ll, ff) -> Errors_ ((errs2@errs), ll, ff)))
| TOption t ->
(try
(match aux t params files pref suff with
| Res_ (v, l, f) -> Res_ ((Obj.magic (Some v)), l, f)
| err -> err)
with Not_found -> Res_ ((Obj.magic None), params, files))
| TNEOption t ->
(try
(match aux t params files pref suff with
| Res_ (v, l, f) ->
if (Obj.tag (Obj.repr v) = Obj.string_tag) && (String.length (Obj.magic v : string) = 0) (* Is the value an empty string? *)
then Res_ ((Obj.magic None), l, f)
else Res_ ((Obj.magic (Some v)), l, f)
| Errors_ ([(_,"",_)], ll, ff) -> Res_ ((Obj.magic None), ll, ff)
| err -> err)
with Not_found -> Res_ ((Obj.magic None), params, files))
| TBool name ->
(try
let v,l = (List.assoc_remove (pref^name^suff) params) in
Res_ ((Obj.magic true),l,files)
with Not_found -> Res_ ((Obj.magic false), params, files))
| TList (n, t) -> Obj.magic (aux_list t params files n pref suff)
| TSet t ->
let rec aux_set params files =
try
match aux t params files pref suff with
| Res_ (vv, ll, ff) ->
(match aux_set ll ff with
| Res_ (vv2, ll2, ff2) ->
Res_ (Obj.magic (vv::vv2), ll2, ff2)
| err -> err)
| Errors_ (errs, ll, ff) ->
(match aux_set ll ff with
| Res_ (_, ll2, ff2) -> Errors_ (errs, ll2, ff2)
| Errors_ (errs2, ll2, ff2) -> Errors_ (errs@errs2, ll2, ff2))
with Not_found -> Res_ (Obj.magic [], params, files)
in Obj.magic (aux_set params files)
| TSum (t1, t2) ->
(try
match aux t1 params files pref suff with
| Res_ (v,l,files) -> Res_ ((Obj.magic (Inj1 v)),l,files)
| err -> err
with Not_found ->
(match aux t2 params files pref suff with
| Res_ (v,l,files) -> Res_ ((Obj.magic (Inj2 v)),l,files)
| err -> err))
| TString name ->
let v,l = List.assoc_remove (pref^name^suff) params in
Res_ ((Obj.magic v),l,files)
| TInt name ->
let v,l = (List.assoc_remove (pref^name^suff) params) in
(try (Res_ ((Obj.magic (int_of_string v)), l, files))
with e -> Errors_ ([(pref^name^suff),v,e], l, files))
| TInt32 name ->
let v,l = (List.assoc_remove (pref^name^suff) params) in
(try (Res_ ((Obj.magic (Int32.of_string v)),l,files))
with e -> Errors_ ([(pref^name^suff),v,e], l, files))
| TInt64 name ->
let v,l = (List.assoc_remove (pref^name^suff) params) in
(try (Res_ ((Obj.magic (Int64.of_string v)),l,files))
with e -> Errors_ ([(pref^name^suff),v,e], l, files))
| TFloat name ->
let v,l = (List.assoc_remove (pref^name^suff) params) in
(try (Res_ ((Obj.magic (float_of_string v)),l,files))
with e -> Errors_ ([(pref^name^suff),v,e], l, files))
| TFile name ->
let v,f = List.assoc_remove (pref^name^suff) files in
Res_ ((Obj.magic v), params, f)
| TCoord name ->
let r1 =
let v, l = (List.assoc_remove (pref^name^suff^".x") params) in
(try (Res_ ((int_of_string v), l, files))
with e -> Errors_ ([(pref^name^suff^".x"), v, e], l, files))
in
(match r1 with
| Res_ (x1, l1, f) ->
let v, l = (List.assoc_remove (pref^name^suff^".y") l1) in
(try (Res_ (
(Obj.magic
{abscissa= x1;
ordinate= int_of_string v}), l, f))
with e -> Errors_ ([(pref^name^suff^".y"), v, e], l, f))
| Errors_ (errs, l1, f) ->
let v, l = (List.assoc_remove (pref^name^suff^".y") l1) in
(try
ignore (int_of_string v);
Errors_ (errs, l, f)
with e -> Errors_ (((pref^name^suff^".y"), v, e)::errs, l, f)))
| TCoordv (t, name) ->
aux (TProd (t, TCoord name)) params files pref suff
| TUserType (name, of_string, string_of) ->
let v,l = (List.assoc_remove (pref^name^suff) params) in
(try (Res_ ((Obj.magic (of_string v)),l,files))
with e -> Errors_ ([(pref^name^suff),v,e], l, files))
| TTypeFilter (t, None) -> failwith "Type filter without filter"
| TTypeFilter (t, Some check) ->
(match aux t params files pref suff with
| Res_ (v, l, files) as a -> (try check v; a
with e -> Errors_ (["","<>",e], l, files))
| a -> a)
| TUnit -> Res_ ((Obj.magic ()), params, files)
| TAny -> Res_ ((Obj.magic params), [], files)
| TConst _ ->
Res_ ((Obj.magic ()), params, files)
| TESuffix n ->
let v,l = List.assoc_remove n params in
(* cannot have prefix or suffix *)
Res_ ((Obj.magic (Neturl.split_path v)), l, files)
| TESuffixs n ->
let v,l = List.assoc_remove n params in
(* cannot have prefix or suffix *)
Res_ ((Obj.magic v), l, files)
| TESuffixu (n, of_string, to_string) ->
let v,l = List.assoc_remove n params in
(* cannot have prefix or suffix *)
(try Res_ ((Obj.magic (of_string v)), l, files)
with e -> Errors_ ([(pref^n^suff), v, e], l, files))
| TSuffix (_, s) ->
(match urlsuffix with
| None ->
if nosuffixversion
(* the special page name "nosuffix" is present *)
then aux s params files pref suff
else raise Eliom_common.Eliom_Wrong_parameter
| Some urlsuffix ->
(match parse_suffix s urlsuffix with
| p, [] -> Res_ (p, params, files)
| _ -> raise Eliom_common.Eliom_Wrong_parameter))
| TJson (name, Some typ) ->
let v,l = List.assoc_remove (pref^name^suff) params in
Res_ ((of_json ~typ v),l,files)
| TJson (name, None) -> assert false
(* Never unmarshal server side without type! *)
| TRaw_post_data -> raise Eliom_common.Eliom_Wrong_parameter
in
match Obj.magic (aux typ params files "" "") with
| Res_ (v, l, files) ->
if (l, files) = ([], [])
then v
else raise Eliom_common.Eliom_Wrong_parameter
| Errors_ (errs, l, files) ->
if (l, files) = ([], [])
then raise (Eliom_common.Eliom_Typing_Error (List.map (fun (v,l,e) -> (v,e)) errs))
else raise Eliom_common.Eliom_Wrong_parameter
in
try Obj.magic (aux2 typ params) with
| Not_found -> raise Eliom_common.Eliom_Wrong_parameter
let reconstruct_params ~sp typ params files nosuffixversion urlsuffix =
match typ, params, files with
| TRaw_post_data, None, None ->
let ri = Eliom_request_info.get_ri_sp sp in
Lwt.return
(Obj.magic
(ri.Ocsigen_extensions.ri_content_type,
ri.Ocsigen_extensions.ri_http_frame.Ocsigen_http_frame.frame_content))
| _, None, None ->
(try
Lwt.return
(reconstruct_params_
sp.Eliom_common.sp_request
typ [] [] nosuffixversion urlsuffix)
with e -> Lwt.fail e)
| _, Some params, Some files ->
params >>= fun params ->
files >>= fun files ->
(try
Lwt.return
(reconstruct_params_
sp.Eliom_common.sp_request
typ params files nosuffixversion urlsuffix)
with e -> Lwt.fail e)
| _ -> Lwt.fail Eliom_common.Eliom_Wrong_parameter
(*****************************************************************************)
(* Non localized parameters *)
let get_non_localized_parameters params getorpost ~sp
(name, _, keys, paramtype) =
(* non localized parameters are parsed only once,
and cached in request_cache *)
let key = getorpost keys in
(try
(* first, look in cache: *)
Polytables.get
~table:sp.Eliom_common.sp_request.Ocsigen_extensions.request_info.Ocsigen_extensions.ri_request_cache
~key
with Not_found ->
let p =
try
Some
(let params = String.Table.find name params in
reconstruct_params_
sp.Eliom_common.sp_request paramtype params [] false None)
with Eliom_common.Eliom_Wrong_parameter | Not_found -> None
in
(* add in cache: *)
Polytables.set
~table:sp.Eliom_common.sp_request.Ocsigen_extensions.request_info.Ocsigen_extensions.ri_request_cache
~key
~value:p;
p)
let get_non_localized_get_parameters p =
let sp = Eliom_common.get_sp () in
get_non_localized_parameters
sp.Eliom_common.sp_si.Eliom_common.si_nl_get_params fst ~sp p
let get_non_localized_post_parameters p =
let sp = Eliom_common.get_sp () in
get_non_localized_parameters
sp.Eliom_common.sp_si.Eliom_common.si_nl_post_params snd ~sp p
eliom-3.0.3/src/server/eliom_content_core.ml 0000644 0000000 0000000 00000057451 12062377521 017327 0 ustar 00 0000000 0000000 (* Ocsigen
* http://www.ocsigen.org
* Copyright (C) 2012 Vincent Balat, Benedikt Becker
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exception;
* either version 2.1 of the License, or (at your option) any later version.
*
* This program 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
* GNU Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
open Eliom_lib
(* This the core of [Eliom_content] without its dependencies to [Eliom_service] et al.
Its name is not [Eliom_content_base] because this would suggest the sharing
between server and client. *)
(*****************************************************************************)
module Xml = struct
include RawXML
type econtent =
| Empty
| Comment of string
| EncodedPCDATA of string
| PCDATA of string
| Entity of string
| Leaf of ename * attrib list
| Node of ename * attrib list * elt list
and recontent =
| RELazy of econtent Eliom_lazy.request
| RE of econtent
and elt' = {
recontent : recontent;
node_id : node_id;
unwrapper_mark: Eliom_wrap.unwrapper;
}
(** Values of type [elt] are wrapped values of type [elt']. *)
and elt = {
elt : elt';
wrapper_mark : elt Eliom_wrap.wrapper
}
let content { elt } = match elt.recontent with
| RE e -> e
| RELazy e -> Eliom_lazy.force e
module Node_id_set = Set.Make (struct type t = node_id let compare : t -> t -> int = compare end)
let node_ids_in_content = ref Node_id_set.empty
let wrapper_mark =
Eliom_wrap.create_wrapper
(fun { elt } ->
if Node_id_set.mem elt.node_id !node_ids_in_content then
{ elt with recontent = RE Empty }
else elt)
let wrap page value =
let node_ids = ref [] in
let rec collect_node_ids ({ elt = { node_id }} as elt) =
if node_id <> NoId then
node_ids := node_id :: !node_ids;
match content elt with
| Empty | Comment _ | EncodedPCDATA _
| PCDATA _ | Entity _ | Leaf _ -> ()
| Node (_, _, children) -> List.iter collect_node_ids children
in
collect_node_ids page;
node_ids_in_content := List.fold_right Node_id_set.add !node_ids Node_id_set.empty;
let res = Eliom_wrap.wrap value in
node_ids_in_content := Node_id_set.empty;
res
let rcontent { elt } = elt.recontent
let get_node_id { elt } = elt.node_id
let tyxml_unwrap_id = Eliom_wrap.id_of_int tyxml_unwrap_id_int
let make elt =
{ elt =
{ recontent = RE elt;
node_id = NoId;
unwrapper_mark = Eliom_wrap.create_unwrapper tyxml_unwrap_id };
wrapper_mark }
let make_lazy elt =
{ elt =
{ recontent = RELazy elt;
node_id = NoId;
unwrapper_mark = Eliom_wrap.create_unwrapper tyxml_unwrap_id };
wrapper_mark }
let empty () = make Empty
let comment c = make (Comment c)
let pcdata d = make (PCDATA d)
let encodedpcdata d = make (EncodedPCDATA d)
let entity e = make (Entity e)
let leaf ?(a = []) name = make (Leaf (name, a))
let node ?(a = []) name children = make (Node (name, a, children))
let lazy_node ?(a = []) name children =
make_lazy (Eliom_lazy.from_fun (fun () -> (Node (name, a, Eliom_lazy.force children))))
let caml_event_handler cf =
let crypto = make_cryptographic_safe_string () in
CE_registered_closure (crypto, Eliom_lib.client_value_server_repr cf)
let event_handler cf =
Caml (caml_event_handler cf)
let cdata s = (* GK *)
(* For security reasons, we do not allow "]]>" inside CDATA
(as this string is to be considered as the end of the cdata)
*)
let s' = "\n") "" s)
^"\n]]>\n" in
encodedpcdata s'
let cdata_script s = (* GK *)
(* For security reasons, we do not allow "]]>" inside CDATA
(as this string is to be considered as the end of the cdata)
*)
let s' = "\n//") "" s)
^"\n//]]>\n" in
encodedpcdata s'
let cdata_style s = (* GK *)
(* For security reasons, we do not allow "]]>" inside CDATA
(as this string is to be considered as the end of the cdata)
*)
let s' = "\n/* ") "" s)
^"\n/* ]]> */\n" in
encodedpcdata s'
let make_node_name ~global () =
(if global then "global_" else "")
^ "server_" ^ make_cryptographic_safe_string ()
let make_process_node ?(id = make_node_name ~global:true ()) elt' =
{ elt' with elt = { elt'.elt with node_id = ProcessId id } }
let make_request_node elt' =
{ elt' with elt = { elt'.elt with node_id = RequestId (make_node_name ~global:false ()) } }
(** Ref tree *)
let cons_attrib att acc = match racontent att with
| RACamlEventHandler (CE_registered_closure (closure_id, cv)) ->
ClosureMap.add closure_id cv acc
| _ -> acc
let make_event_handler_table elt =
let rec aux closure_acc elt =
let make attribs =
List.fold_right cons_attrib attribs closure_acc
in
match content elt with
| Empty | EncodedPCDATA _ | PCDATA _
| Entity _ | Comment _ -> closure_acc
| Leaf (_, attribs) -> make attribs
| Node (_, attribs, elts) ->
List.fold_left aux (make attribs) elts
in
aux ClosureMap.empty elt
let set_classes node_id = function
| Empty
| Comment _
| EncodedPCDATA _
| PCDATA _
| Entity _ as e -> e
| Leaf (ename, attribs) ->
Leaf (ename, filter_class_attribs node_id attribs)
| Node (ename, attribs, sons) ->
Node (ename, filter_class_attribs node_id attribs, sons)
let content { elt } =
let c = match elt.recontent with
| RE e -> e
| RELazy e -> Eliom_lazy.force e
in
set_classes elt.node_id c
end
module Eliom_xml = Xml
module Svg = struct
module D = Svg_f.Make(struct
include Xml
let make elt = make_request_node (make elt)
let make_lazy elt = make_request_node (make_lazy elt)
let empty () = make Empty
let comment c = make (Comment c)
let pcdata d = make (PCDATA d)
let encodedpcdata d = make (EncodedPCDATA d)
let entity e = make (Entity e)
let leaf ?(a = []) name = make (Leaf (name, a))
let node ?(a = []) name children = make (Node (name, a, children))
let lazy_node ?(a = []) name children =
make_lazy (Eliom_lazy.from_fun (fun () -> (Node (name, a, Eliom_lazy.force children))))
end)
module F = Svg_f.Make(Xml)
type +'a elt = 'a F.elt
type +'a attrib = 'a F.attrib
type uri = F.uri
module Id = struct
type 'a id = string (* FIXME invariant type parameter ? *)
let new_elt_id: ?global:bool -> unit -> 'a id =
fun ?(global=true) () -> Xml.make_node_name ~global ()
let create_named_elt ~(id : 'a id) elt =
D.tot (Xml.make_process_node ~id (D.toelt elt))
let create_global_elt elt =
D.tot (Xml.make_process_node (D.toelt elt))
end
module Printer = Xml_print.Make_typed_simple(Xml)(F)
end
module Html5 = struct
module D = struct
(* This is [Eliom_content.Xml] adapted such that request nodes are produced *)
module Xml' = struct
include Eliom_xml
let make elt = make_request_node (make elt)
let make_lazy elt = make_request_node (make_lazy elt)
let empty () = make Empty
let comment c = make (Comment c)
let pcdata d = make (PCDATA d)
let encodedpcdata d = make (EncodedPCDATA d)
let entity e = make (Entity e)
let leaf ?(a = []) name = make (Leaf (name, a))
let node ?(a = []) name children = make (Node (name, a, children))
let lazy_node ?(a = []) name children =
make_lazy (Eliom_lazy.from_fun (fun () -> (Node (name, a, Eliom_lazy.force children))))
end
module Raw = Html5_f.Make(Xml')(Svg.D)
include Raw
type ('a, 'b, 'c) lazy_plus =
?a: (('a attrib) list) -> 'b elt Eliom_lazy.request -> ('b elt) list Eliom_lazy.request -> 'c elt
let lazy_form ?(a = []) elt1 elts =
tot (Xml'.lazy_node ~a:(to_xmlattribs a) "form"
(Eliom_lazy.from_fun
(fun () ->
toelt (Eliom_lazy.force elt1)
:: toeltl (Eliom_lazy.force elts))))
let a_onabort ev = Raw.a_onabort (Eliom_xml.event_handler ev)
let a_onafterprint ev = Raw.a_onafterprint (Eliom_xml.event_handler ev)
let a_onbeforeprint ev = Raw.a_onbeforeprint (Eliom_xml.event_handler ev)
let a_onbeforeunload ev = Raw.a_onbeforeunload (Eliom_xml.event_handler ev)
let a_onblur ev = Raw.a_onblur (Eliom_xml.event_handler ev)
let a_oncanplay ev = Raw.a_oncanplay (Eliom_xml.event_handler ev)
let a_oncanplaythrough ev = Raw.a_oncanplaythrough (Eliom_xml.event_handler ev)
let a_onchange ev = Raw.a_onchange (Eliom_xml.event_handler ev)
let a_onclick (ev : (Dom_html.mouseEvent Js.t -> unit) Eliom_lib.client_value) =
Raw.a_onclick (Eliom_xml.event_handler (Obj.magic ev)) (* Typed by the syntax extension. *)
let a_oncontextmenu (ev : (Dom_html.mouseEvent Js.t -> unit) Eliom_lib.client_value) =
Raw.a_oncontextmenu (Eliom_xml.event_handler (Obj.magic ev)) (* Typed with the syntax extension *)
let a_ondblclick (ev : (Dom_html.mouseEvent Js.t -> unit) Eliom_lib.client_value) =
Raw.a_ondblclick (Eliom_xml.event_handler (Obj.magic ev)) (* Typed with the syntax extension *)
let a_ondrag (ev : (Dom_html.mouseEvent Js.t -> unit) Eliom_lib.client_value) =
Raw.a_ondrag (Eliom_xml.event_handler (Obj.magic ev)) (* Typed with the syntax extension *)
let a_ondragend (ev : (Dom_html.mouseEvent Js.t -> unit) Eliom_lib.client_value) =
Raw.a_ondragend (Eliom_xml.event_handler (Obj.magic ev)) (* Typed with the syntax extension *)
let a_ondragenter (ev : (Dom_html.mouseEvent Js.t -> unit) Eliom_lib.client_value) =
Raw.a_ondragenter (Eliom_xml.event_handler (Obj.magic ev)) (* Typed with the syntax extension *)
let a_ondragleave (ev : (Dom_html.mouseEvent Js.t -> unit) Eliom_lib.client_value) =
Raw.a_ondragleave (Eliom_xml.event_handler (Obj.magic ev)) (* Typed with the syntax extension *)
let a_ondragover (ev : (Dom_html.mouseEvent Js.t -> unit) Eliom_lib.client_value) =
Raw.a_ondragover (Eliom_xml.event_handler (Obj.magic ev)) (* Typed with the syntax extension *)
let a_ondragstart (ev : (Dom_html.mouseEvent Js.t -> unit) Eliom_lib.client_value) =
Raw.a_ondragstart (Eliom_xml.event_handler (Obj.magic ev)) (* Typed with the syntax extension *)
let a_ondrop (ev : (Dom_html.mouseEvent Js.t -> unit) Eliom_lib.client_value) =
Raw.a_ondrop (Eliom_xml.event_handler (Obj.magic ev)) (* Typed with the syntax extension *)
let a_ondurationchange ev = Raw.a_ondurationchange (Eliom_xml.event_handler ev)
let a_onemptied ev = Raw.a_onemptied (Eliom_xml.event_handler ev)
let a_onended ev = Raw.a_onended (Eliom_xml.event_handler ev)
let a_onerror ev = Raw.a_onerror (Eliom_xml.event_handler ev)
let a_onfocus ev = Raw.a_onfocus (Eliom_xml.event_handler ev)
let a_onformchange ev = Raw.a_onformchange (Eliom_xml.event_handler ev)
let a_onforminput ev = Raw.a_onforminput (Eliom_xml.event_handler ev)
let a_onhashchange ev = Raw.a_onhashchange (Eliom_xml.event_handler ev)
let a_oninput ev = Raw.a_oninput (Eliom_xml.event_handler ev)
let a_oninvalid ev = Raw.a_oninvalid (Eliom_xml.event_handler ev)
let a_onmousedown (ev : (Dom_html.mouseEvent Js.t -> unit) Eliom_lib.client_value) =
Raw.a_onmousedown (Eliom_xml.event_handler (Obj.magic ev)) (* Typed with the syntax extension *)
let a_onmouseup (ev : (Dom_html.mouseEvent Js.t -> unit) Eliom_lib.client_value) =
Raw.a_onmouseup (Eliom_xml.event_handler (Obj.magic ev)) (* Typed with the syntax extension *)
let a_onmouseover (ev : (Dom_html.mouseEvent Js.t -> unit) Eliom_lib.client_value) =
Raw.a_onmouseover (Eliom_xml.event_handler (Obj.magic ev)) (* Typed with the syntax extension *)
let a_onmousemove (ev : (Dom_html.mouseEvent Js.t -> unit) Eliom_lib.client_value) =
Raw.a_onmousemove (Eliom_xml.event_handler (Obj.magic ev)) (* Typed with the syntax extension *)
let a_onmouseout (ev : (Dom_html.mouseEvent Js.t -> unit) Eliom_lib.client_value) =
Raw.a_onmouseout (Eliom_xml.event_handler (Obj.magic ev)) (* Typed with the syntax extension *)
let a_onmousewheel ev = Raw.a_onmousewheel (Eliom_xml.event_handler ev)
let a_onoffline ev = Raw.a_onoffline (Eliom_xml.event_handler ev)
let a_ononline ev = Raw.a_ononline (Eliom_xml.event_handler ev)
let a_onpause ev = Raw.a_onpause (Eliom_xml.event_handler ev)
let a_onplay ev = Raw.a_onplay (Eliom_xml.event_handler ev)
let a_onplaying ev = Raw.a_onplaying (Eliom_xml.event_handler ev)
let a_onpagehide ev = Raw.a_onpagehide (Eliom_xml.event_handler ev)
let a_onpageshow ev = Raw.a_onpageshow (Eliom_xml.event_handler ev)
let a_onpopstate ev = Raw.a_onpopstate (Eliom_xml.event_handler ev)
let a_onprogress ev = Raw.a_onprogress (Eliom_xml.event_handler ev)
let a_onratechange ev = Raw.a_onratechange (Eliom_xml.event_handler ev)
let a_onreadystatechange ev = Raw.a_onreadystatechange (Eliom_xml.event_handler ev)
let a_onredo ev = Raw.a_onredo (Eliom_xml.event_handler ev)
let a_onresize ev = Raw.a_onresize (Eliom_xml.event_handler ev)
let a_onscroll ev = Raw.a_onscroll (Eliom_xml.event_handler ev)
let a_onseeked ev = Raw.a_onseeked (Eliom_xml.event_handler ev)
let a_onseeking ev = Raw.a_onseeking (Eliom_xml.event_handler ev)
let a_onselect ev = Raw.a_onselect (Eliom_xml.event_handler ev)
let a_onshow ev = Raw.a_onshow (Eliom_xml.event_handler ev)
let a_onstalled ev = Raw.a_onstalled (Eliom_xml.event_handler ev)
let a_onstorage ev = Raw.a_onstorage (Eliom_xml.event_handler ev)
let a_onsubmit ev = Raw.a_onsubmit (Eliom_xml.event_handler ev)
let a_onsuspend ev = Raw.a_onsuspend (Eliom_xml.event_handler ev)
let a_ontimeupdate ev = Raw.a_ontimeupdate (Eliom_xml.event_handler ev)
let a_onundo ev = Raw.a_onundo (Eliom_xml.event_handler ev)
let a_onunload ev = Raw.a_onunload (Eliom_xml.event_handler ev)
let a_onvolumechange ev = Raw.a_onvolumechange (Eliom_xml.event_handler ev)
let a_onwaiting ev = Raw.a_onwaiting (Eliom_xml.event_handler ev)
let a_onkeypress (ev : (Dom_html.keyboardEvent Js.t -> unit) Eliom_lib.client_value) =
Raw.a_onkeypress (Eliom_xml.event_handler (Obj.magic ev)) (* Typed with the syntax extension *)
let a_onkeydown (ev : (Dom_html.keyboardEvent Js.t -> unit) Eliom_lib.client_value) =
Raw.a_onkeydown (Eliom_xml.event_handler (Obj.magic ev)) (* Typed with the syntax extension *)
let a_onkeyup (ev : (Dom_html.keyboardEvent Js.t -> unit) Eliom_lib.client_value) =
Raw.a_onkeyup (Eliom_xml.event_handler (Obj.magic ev)) (* Typed with the syntax extension *)
let a_onload ev = Raw.a_onload (Eliom_xml.event_handler ev)
let a_onloadeddata ev = Raw.a_onloadeddata (Eliom_xml.event_handler ev)
let a_onloadedmetadata ev = Raw.a_onloadedmetadata (Eliom_xml.event_handler ev)
let a_onloadstart ev = Raw.a_onloadstart (Eliom_xml.event_handler ev)
let a_onmessage ev = Raw.a_onmessage (Eliom_xml.event_handler ev)
end
module F = struct
module Raw = Html5_f.Make(Xml)(Svg.F)
include Raw
type ('a, 'b, 'c) lazy_plus =
?a: (('a attrib) list) -> 'b elt Eliom_lazy.request -> ('b elt) list Eliom_lazy.request -> 'c elt
let lazy_form ?(a = []) elt1 elts =
tot (Eliom_xml.lazy_node ~a:(to_xmlattribs a) "form"
(Eliom_lazy.from_fun
(fun () ->
toelt (Eliom_lazy.force elt1)
:: toeltl (Eliom_lazy.force elts))))
let a_onabort ev = a_onabort (Eliom_xml.event_handler ev)
let a_onafterprint ev = a_onafterprint (Eliom_xml.event_handler ev)
let a_onbeforeprint ev = a_onbeforeprint (Eliom_xml.event_handler ev)
let a_onbeforeunload ev = a_onbeforeunload (Eliom_xml.event_handler ev)
let a_onblur ev = a_onblur (Eliom_xml.event_handler ev)
let a_oncanplay ev = a_oncanplay (Eliom_xml.event_handler ev)
let a_oncanplaythrough ev = a_oncanplaythrough (Eliom_xml.event_handler ev)
let a_onchange ev = a_onchange (Eliom_xml.event_handler ev)
let a_onclick (ev : (Dom_html.mouseEvent Js.t -> unit) Eliom_lib.client_value) =
a_onclick (Eliom_xml.event_handler (Obj.magic ev)) (* Typed by the syntax extension. *)
let a_oncontextmenu (ev : (Dom_html.mouseEvent Js.t -> unit) Eliom_lib.client_value) =
a_oncontextmenu (Eliom_xml.event_handler (Obj.magic ev)) (* Typed with the syntax extension *)
let a_ondblclick (ev : (Dom_html.mouseEvent Js.t -> unit) Eliom_lib.client_value) =
a_ondblclick (Eliom_xml.event_handler (Obj.magic ev)) (* Typed with the syntax extension *)
let a_ondrag (ev : (Dom_html.mouseEvent Js.t -> unit) Eliom_lib.client_value) =
a_ondrag (Eliom_xml.event_handler (Obj.magic ev)) (* Typed with the syntax extension *)
let a_ondragend (ev : (Dom_html.mouseEvent Js.t -> unit) Eliom_lib.client_value) =
a_ondragend (Eliom_xml.event_handler (Obj.magic ev)) (* Typed with the syntax extension *)
let a_ondragenter (ev : (Dom_html.mouseEvent Js.t -> unit) Eliom_lib.client_value) =
a_ondragenter (Eliom_xml.event_handler (Obj.magic ev)) (* Typed with the syntax extension *)
let a_ondragleave (ev : (Dom_html.mouseEvent Js.t -> unit) Eliom_lib.client_value) =
a_ondragleave (Eliom_xml.event_handler (Obj.magic ev)) (* Typed with the syntax extension *)
let a_ondragover (ev : (Dom_html.mouseEvent Js.t -> unit) Eliom_lib.client_value) =
a_ondragover (Eliom_xml.event_handler (Obj.magic ev)) (* Typed with the syntax extension *)
let a_ondragstart (ev : (Dom_html.mouseEvent Js.t -> unit) Eliom_lib.client_value) =
a_ondragstart (Eliom_xml.event_handler (Obj.magic ev)) (* Typed with the syntax extension *)
let a_ondrop (ev : (Dom_html.mouseEvent Js.t -> unit) Eliom_lib.client_value) =
a_ondrop (Eliom_xml.event_handler (Obj.magic ev)) (* Typed with the syntax extension *)
let a_ondurationchange ev = a_ondurationchange (Eliom_xml.event_handler ev)
let a_onemptied ev = a_onemptied (Eliom_xml.event_handler ev)
let a_onended ev = a_onended (Eliom_xml.event_handler ev)
let a_onerror ev = a_onerror (Eliom_xml.event_handler ev)
let a_onfocus ev = a_onfocus (Eliom_xml.event_handler ev)
let a_onformchange ev = a_onformchange (Eliom_xml.event_handler ev)
let a_onforminput ev = a_onforminput (Eliom_xml.event_handler ev)
let a_onhashchange ev = a_onhashchange (Eliom_xml.event_handler ev)
let a_oninput ev = a_oninput (Eliom_xml.event_handler ev)
let a_oninvalid ev = a_oninvalid (Eliom_xml.event_handler ev)
let a_onmousedown (ev : (Dom_html.mouseEvent Js.t -> unit) Eliom_lib.client_value) =
a_onmousedown (Eliom_xml.event_handler (Obj.magic ev)) (* Typed with the syntax extension *)
let a_onmouseup (ev : (Dom_html.mouseEvent Js.t -> unit) Eliom_lib.client_value) =
a_onmouseup (Eliom_xml.event_handler (Obj.magic ev)) (* Typed with the syntax extension *)
let a_onmouseover (ev : (Dom_html.mouseEvent Js.t -> unit) Eliom_lib.client_value) =
a_onmouseover (Eliom_xml.event_handler (Obj.magic ev)) (* Typed with the syntax extension *)
let a_onmousemove (ev : (Dom_html.mouseEvent Js.t -> unit) Eliom_lib.client_value) =
a_onmousemove (Eliom_xml.event_handler (Obj.magic ev)) (* Typed with the syntax extension *)
let a_onmouseout (ev : (Dom_html.mouseEvent Js.t -> unit) Eliom_lib.client_value) =
a_onmouseout (Eliom_xml.event_handler (Obj.magic ev)) (* Typed with the syntax extension *)
let a_onmousewheel ev = a_onmousewheel (Eliom_xml.event_handler ev)
let a_onoffline ev = a_onoffline (Eliom_xml.event_handler ev)
let a_ononline ev = a_ononline (Eliom_xml.event_handler ev)
let a_onpause ev = a_onpause (Eliom_xml.event_handler ev)
let a_onplay ev = a_onplay (Eliom_xml.event_handler ev)
let a_onplaying ev = a_onplaying (Eliom_xml.event_handler ev)
let a_onpagehide ev = a_onpagehide (Eliom_xml.event_handler ev)
let a_onpageshow ev = a_onpageshow (Eliom_xml.event_handler ev)
let a_onpopstate ev = a_onpopstate (Eliom_xml.event_handler ev)
let a_onprogress ev = a_onprogress (Eliom_xml.event_handler ev)
let a_onratechange ev = a_onratechange (Eliom_xml.event_handler ev)
let a_onreadystatechange ev = a_onreadystatechange (Eliom_xml.event_handler ev)
let a_onredo ev = a_onredo (Eliom_xml.event_handler ev)
let a_onresize ev = a_onresize (Eliom_xml.event_handler ev)
let a_onscroll ev = a_onscroll (Eliom_xml.event_handler ev)
let a_onseeked ev = a_onseeked (Eliom_xml.event_handler ev)
let a_onseeking ev = a_onseeking (Eliom_xml.event_handler ev)
let a_onselect ev = a_onselect (Eliom_xml.event_handler ev)
let a_onshow ev = a_onshow (Eliom_xml.event_handler ev)
let a_onstalled ev = a_onstalled (Eliom_xml.event_handler ev)
let a_onstorage ev = a_onstorage (Eliom_xml.event_handler ev)
let a_onsubmit ev = a_onsubmit (Eliom_xml.event_handler ev)
let a_onsuspend ev = a_onsuspend (Eliom_xml.event_handler ev)
let a_ontimeupdate ev = a_ontimeupdate (Eliom_xml.event_handler ev)
let a_onundo ev = a_onundo (Eliom_xml.event_handler ev)
let a_onunload ev = a_onunload (Eliom_xml.event_handler ev)
let a_onvolumechange ev = a_onvolumechange (Eliom_xml.event_handler ev)
let a_onwaiting ev = a_onwaiting (Eliom_xml.event_handler ev)
let a_onkeypress (ev : (Dom_html.keyboardEvent Js.t -> unit) Eliom_lib.client_value) =
a_onkeypress (Eliom_xml.event_handler (Obj.magic ev)) (* Typed with the syntax extension *)
let a_onkeydown (ev : (Dom_html.keyboardEvent Js.t -> unit) Eliom_lib.client_value) =
a_onkeydown (Eliom_xml.event_handler (Obj.magic ev)) (* Typed with the syntax extension *)
let a_onkeyup (ev : (Dom_html.keyboardEvent Js.t -> unit) Eliom_lib.client_value) =
a_onkeyup (Eliom_xml.event_handler (Obj.magic ev)) (* Typed with the syntax extension *)
let a_onload ev = a_onload (Eliom_xml.event_handler ev)
let a_onloadeddata ev = a_onloadeddata (Eliom_xml.event_handler ev)
let a_onloadedmetadata ev = a_onloadedmetadata (Eliom_xml.event_handler ev)
let a_onloadstart ev = a_onloadstart (Eliom_xml.event_handler ev)
let a_onmessage ev = a_onmessage (Eliom_xml.event_handler ev)
end
type +'a elt = 'a F.elt
type +'a attrib = 'a F.attrib
type uri = F.uri
module Id = struct
type 'a id = string (* FIXME invariant type parameter ? *)
let new_elt_id: ?global:bool -> unit -> 'a id =
fun ?(global=true) () -> Xml.make_node_name ~global ()
let create_named_elt ~(id : 'a id) elt =
D.tot (Xml.make_process_node ~id (D.toelt elt))
let create_global_elt elt =
D.tot (Xml.make_process_node (D.toelt elt))
let have_id name elt = Xml.get_node_id (D.toelt elt) = Xml.ProcessId name
end
module Custom_data = struct
type 'a t = {
name : string;
to_string : 'a -> string;
of_string : string -> 'a;
default : 'a option;
}
let create ~name ?default ~to_string ~of_string () =
{ name ; of_string ; to_string; default }
let create_json ~name ?default typ =
{ name ; of_string = of_json ~typ ; to_string = to_json ~typ; default }
let attrib custom_data value =
F.a_user_data
custom_data.name
(custom_data.to_string value)
end
module Printer = Xml_print.Make_typed_simple(Xml)(F)
end
eliom-3.0.3/src/server/eliom_comet.mli 0000644 0000000 0000000 00000011425 12062377521 016114 0 ustar 00 0000000 0000000 (* Ocsigen
* http://www.ocsigen.org
* Copyright (C) 2010-2011
* Raphaël Proust
* Pierre Chambart
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exception;
* either version 2.1 of the License, or (at your option) any later version.
*
* This program 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
* GNU Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
(** Primitives to push data to the client, without explicit request. *)
(** Basic primitives needed for server push. *)
module Channel : sig
(** [v t] is the type of server-to-client communication channels
transporting data of type [v] *)
type 'a t
type comet_scope =
[ Eliom_common.site_scope
| Eliom_common.client_process_scope ]
(** [create s] returns a channel sending values from [s].
There are two kind of channels created depending on the given
scope (defaults to [Eliom_common.comet_client_process]).
With scope {!Eliom_common.site} all users knowing the name of
the channel can access it. Only one message queue is created: it
is what we call a stateless channel in the sense that the memory
used by the channel does not depend on the number of users. The
channel can be reclaimed by the GC when there is no more reference to it.
The buffer channel has a limited buffer of size [size] (default:
1000). If the client requests too old messages, exception
[Eliom_coment.Channel_full] will be raised (on client side).
With a scope of level {!Eliom_common.client_process_scope} the
channel can only be accessed by the user who created it. It
can only be created when client process data is
available (that is: during a request).
The eliom service created to communicate with the
client is only available in the scope of the client process. To
avoid memory leak when the client do not read sent data,
the channel has a limited [size]. When a channel is full, no
data can be read from it anymore.
A channel can be used only once on client side. To be able
to receive the same data multiple times on client side, use
[create (Lwt_stream.clone s)] every time.
To enforce the limit on the buffer size, the data is read into
[stream] as soon as possible: If you want a channel that reads
data on the stream only when the client requests it, use
[create_unlimited] instead, but be careful of memory leaks. *)
val create : ?scope:[< comet_scope ] ->
?name:string -> ?size:int -> 'a Lwt_stream.t -> 'a t
(** [create_unlimited s] creates a channel which does not read
immediately on the stream. It is read only when the client
requests it: use it if the data you send depends on the time of
the request (for instance the number of unread mails). Be
careful, the size of this stream is not limited: if the size of
the stream increases and your clients don't read it, you may have
memory leaks. *)
val create_unlimited : ?scope:Eliom_common.client_process_scope ->
?name:string -> 'a Lwt_stream.t -> 'a t
(** [create_newest s] is similar to [create
~scope:Eliom_common.site s] but only the last message is
returned to the client. *)
val create_newest : ?name:string -> 'a Lwt_stream.t -> 'a t
(** [external_channel ~prefix ~name ()] declares an external
channel. The channel was created by an instance of Eliom serving
the prefix [prefix] (the prefix configured in the tag of
the configuration file). The channel was named by [name]. Both
servers must run the exact same version of Eliom.
The optional [newest] parameters tells whether the channel is a
new one. If the channel is not new, [history] is the maximum
number of messages retrieved at the first request. The default
is [1]. *)
val external_channel : ?history:int -> ?newest:bool ->
prefix:string -> name:string -> unit -> 'a t
(** [wait_timeout ~scope time] waits for a period of inactivity of
length [time] in the [scope]. Only activity on stateful
channels is taken into accounts.
The default [scope] is [Eliom_common.comet_client_process]. *)
val wait_timeout : ?scope:Eliom_common.client_process_scope ->
float -> unit Lwt.t
(**/**)
val get_wrapped : 'a t -> 'a Eliom_comet_base.wrapped_channel
end
eliom-3.0.3/src/server/eliom_config.ml 0000644 0000000 0000000 00000005001 12062377521 016072 0 ustar 00 0000000 0000000 (* Ocsigen
* http://www.ocsigen.org
* Copyright (C) 2010 Vincent Balat
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exception;
* either version 2.1 of the License, or (at your option) any later version.
*
* This program 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
* GNU Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
let get_default_hostname () =
let sitedata = Eliom_request_info.find_sitedata "get_default_hostname" in
sitedata.Eliom_common.config_info.Ocsigen_extensions.default_hostname
let get_default_port () =
let sitedata = Eliom_request_info.find_sitedata "get_default_port" in
sitedata.Eliom_common.config_info.Ocsigen_extensions.default_httpport
let get_default_sslport () =
let sitedata = Eliom_request_info.find_sitedata "get_default_sslport" in
sitedata.Eliom_common.config_info.Ocsigen_extensions.default_httpsport
let get_default_links_xhr () =
let sitedata = Eliom_request_info.find_sitedata "get_default_links_xhr" in
sitedata.Eliom_common.default_links_xhr#get
let set_default_links_xhr ?override_configfile v =
let sitedata = Eliom_request_info.find_sitedata "set_default_links_xhr" in
sitedata.Eliom_common.default_links_xhr#set v
let get_config_default_charset_sp sp =
Ocsigen_charset_mime.default_charset
sp.Eliom_common.sp_request.Ocsigen_extensions.request_config.Ocsigen_extensions.charset_assoc
let get_config_default_charset () =
let sp = Eliom_common.get_sp () in
get_config_default_charset_sp sp
let get_config_info_sp sp =
sp.Eliom_common.sp_request.Ocsigen_extensions.request_config
let get_config_info () =
let sp = Eliom_common.get_sp () in
get_config_info_sp sp
let get_config () =
match Eliom_common.global_register_allowed () with
| Some _ -> !Eliommod.config
| None ->
raise (Eliom_common.Eliom_site_information_not_available
"Eliom_config.get_config")
let parse_config ?pcdata ?other_elements elements =
Ocsigen_extensions.Configuration.process_elements
~in_tag:"eliom" ?pcdata ?other_elements ~elements (get_config ())
eliom-3.0.3/src/server/eliom_config.mli 0000644 0000000 0000000 00000006614 12062377521 016256 0 ustar 00 0000000 0000000 (* Ocsigen
* http://www.ocsigen.org
* Copyright (C) 2010 Vincent Balat
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exception;
* either version 2.1 of the License, or (at your option) any later version.
*
* This program 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
* GNU Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
(** The function [get_default_hostname ()]returns the hostname
declared in the config file ([]) or
the default machine hostname. *)
val get_default_hostname : unit -> string
(** The function [get_default_port ()] returns the port number
declared in the config file ([]) or
80 if undeclared.
*)
val get_default_port : unit -> int
(** The function [get_default_sslport ()] returns the https port
number declared in the config file ([]) or 443 if undeclared.
*)
val get_default_sslport : unit -> int
(** The function [get_config_default_charset ()] returns the default
charset for this site. *)
val get_config_default_charset : unit -> string
(** The provided value serves as a default value for the optional parameter
[~xhr] in the functions [Eliom_registration.*.{a, get_form, post_form,
lwt_get_form, lwt_post_form}] (cf. {!Eliom_registration.Html5.a} et al.).
This value can also be set in the
{{:http://ocsigen.org/eliom/dev/manual/config#h5o-25}config file}. *)
val set_default_links_xhr : ?override_configfile:bool -> bool -> unit
(**/**)
val get_default_links_xhr : unit -> bool
(**/**)
(** The function [get_config ()] returns the information of the
configuration file concerning that site (between [] and
[] or [] and []).
{e Warning: You must call that function during the initialisation of
your module (not during a Lwt thread or a service)
otherwise it will raise the exception
{!Eliom_common.Eliom_site_information_not_available}.
If you want to build a statically linkable module, you must call this
function inside the initialisation function given to
{!Eliom_service.register_eliom_module}.}
*)
val get_config : unit -> Simplexmlparser.xml list
(** Process the configuration {% <> %}
by a give specification (cf. {% <> %}) *)
val parse_config : ?pcdata:(string -> unit) -> ?other_elements:(string -> (string * string) list -> Simplexmlparser.xml list -> unit) -> Ocsigen_extensions.Configuration.element list -> unit
(** The function [get_config_info ()] returns the information
concerning the request from the configuration files. *)
val get_config_info : unit -> Ocsigen_extensions.config_info
(**/**)
val get_config_info_sp :
Eliom_common.server_params -> Ocsigen_extensions.config_info
val get_config_default_charset_sp :
Eliom_common.server_params -> string
eliom-3.0.3/src/server/eliom_react.ml 0000644 0000000 0000000 00000017316 12062377521 015737 0 ustar 00 0000000 0000000 (* Ocsigen
* http://www.ocsigen.org
* Copyright (C) 2010
* Raphaël Proust
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exception;
* either version 2.1 of the License, or (at your option) any later version.
*
* This program 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
* GNU Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
(* Module for event wrapping and related functions *)
open Lwt_react
module Down =
struct
type 'a stateful =
{throttling: float option;
scope: Eliom_common.client_process_scope option;
react: 'a E.t;
name: string option;
size: int option;}
type 'a stateless = 'a Eliom_comet.Channel.t
type 'a t' =
| Stateful of 'a stateful
| Stateless of 'a stateless
type 'a t =
{t : 'a t';
react_down_mark: 'a t Eliom_common.wrapper;}
let wrap_stateful
{throttling=t; scope; react=e; name; size} =
let ee =
(match t with
| None -> e
| Some t -> E.limit (fun () -> Lwt_unix.sleep t) e)
in
let stream = E.to_stream ee in
let channel = Eliom_comet.Channel.create ?scope ?name ?size stream in
(channel,Eliom_common.make_unwrapper Eliom_common.react_down_unwrap_id)
let wrap_stateless channel =
(channel,Eliom_common.make_unwrapper Eliom_common.react_down_unwrap_id)
let internal_wrap = function
| { t = Stateful v } -> wrap_stateful v
| { t = Stateless v } -> wrap_stateless v
let react_down_mark () = Eliom_common.make_wrapper internal_wrap
let stateful ?scope ?throttling ?name ?size (e : 'a E.t) =
Stateful
{throttling=throttling;
scope;
react=e;
name=name;
size=size;
}
let stateless ?throttling ?name ?size (e : 'a E.t) =
let ee =
(match throttling with
| None -> e
| Some t -> E.limit (fun () -> Lwt_unix.sleep t) e)
in
let stream = E.to_stream ee in
Stateless (Eliom_comet.Channel.create ~scope:`Site ?name ?size stream)
let of_react ?scope ?throttling ?name ?size (e : 'a E.t) =
let t =
match scope with
| Some `Site -> stateless ?throttling ?name ?size e
| None -> stateful ?throttling ?name ?size e
| Some ((`Client_process n) as scope) ->
stateful ~scope ?throttling ?name ?size e
in
{ t; react_down_mark=react_down_mark () }
end
module Up =
struct
type 'a t =
{ event : 'a E.t;
service :
(unit,
'a,
[ `Nonattached of [ `Post ] Eliom_service.na_s ],
[ `WithoutSuffix ],
unit,
[ `One of 'a Eliom_parameter.caml ] Eliom_parameter.param_name,
[ `Registrable ],
Eliom_registration.Action.return)
Eliom_service.service;
wrapper : 'a t Eliom_common.wrapper }
let to_react t = t.event
let internal_wrap t = (t.service, Eliom_common.make_unwrapper Eliom_common.react_up_unwrap_id)
let up_event_wrapper () = Eliom_common.make_wrapper internal_wrap
(* An event is created along with a service responsible for it's occurences.
* function takes a param_type *)
let create ?scope ?name post_params =
let (e, push) = E.create () in
let sp = Eliom_common.get_sp_option () in
let scope = match sp, scope with
| _, Some l -> l
| None, _ -> `Site
| _ -> (Eliom_common.comet_client_process_scope :> Eliom_common.scope)
in
let e_writer = Eliom_service.post_coservice' ?name ~post_params () in
Eliom_registration.Action.register
~scope
~options:`NoReload
~service:e_writer
(fun () value -> push value ; Lwt.return ());
{ event = e;
service = e_writer;
wrapper = up_event_wrapper () }
end
module S =
struct
module Down =
struct
type 'a stateful =
{throttling: float option;
scope: Eliom_common.client_process_scope option;
signal: 'a S.t;
name: string option;}
type 'a stateless =
{channel: 'a Eliom_comet.Channel.t;
stream: 'a Lwt_stream.t; (* avoid garbage collection *)
sl_signal: 'a S.t}
type 'a t' =
| Stateful of 'a stateful
| Stateless of 'a stateless
type 'a t =
{ t : 'a t';
signal_down_mark: 'a t Eliom_common.wrapper; }
type 'a store =
{ s : unit S.t Lazy.t; (* to avoid signal GC *)
mutable value : 'a;
mutable read : bool;
condition : unit Lwt_condition.t; }
let make_store signal =
let rec store =
{ s = s';
value = S.value signal;
read = false;
condition = Lwt_condition.create (); }
and s' = lazy (
S.map (fun v ->
store.read <- false;
store.value <- v;
Lwt_condition.broadcast store.condition ();
()) signal)
in
ignore (Lazy.force store.s);
store
let read_store store =
let rec aux () =
if store.read
then
begin
lwt () = Lwt_condition.wait store.condition in
aux ()
end
else
begin
store.read <- true;
Lwt.return (Some store.value)
end
in
aux
let wrap_stateful
{throttling=t;
scope;
signal=s;
name=name} =
let s : 'a S.t =
(match t with
| None -> s
| Some t -> S.limit (fun () -> Lwt_unix.sleep t) s)
in
let store = make_store s in
let stream = Lwt_stream.from (read_store store) in
let channel = Eliom_comet.Channel.create_unlimited ?scope ?name stream in
let value : 'a = S.value s in
(channel,value,Eliom_common.make_unwrapper Eliom_common.signal_down_unwrap_id)
let wrap_stateful
{throttling=t;
signal=s;
name=name} =
let s : 'a S.t =
(match t with
| None -> s
| Some t -> S.limit (fun () -> Lwt_unix.sleep t) s)
in
let store = make_store s in
let stream = Lwt_stream.from (read_store store) in
let channel = Eliom_comet.Channel.create_unlimited ?name stream in
let value : 'a = S.value s in
(channel,value,Eliom_common.make_unwrapper Eliom_common.signal_down_unwrap_id)
let wrap_stateless
{sl_signal=s;
channel} =
let value : 'a = S.value s in
(channel,value,Eliom_common.make_unwrapper Eliom_common.signal_down_unwrap_id)
let internal_wrap = function
| { t = Stateful v } -> wrap_stateful v
| { t = Stateless v } -> wrap_stateless v
let signal_down_mark () = Eliom_common.make_wrapper internal_wrap
let stateful ?scope
?throttling ?name (s : 'a S.t) =
Stateful
{throttling=throttling;
scope;
signal=s;
name=name;}
let stateless ?throttling ?name (s : 'a S.t) =
let s =
match throttling with
| None -> s
| Some t -> S.limit (fun () -> Lwt_unix.sleep t) s
in
let e = S.changes s in
let stream = E.to_stream e in
Stateless
{channel = Eliom_comet.Channel.create_newest ?name stream;
stream;
sl_signal = s}
let of_react
?scope
?throttling ?name (s : 'a S.t) =
let t =
match scope with
| Some `Site -> stateless ?throttling ?name s
| None -> stateful ?throttling ?name s
| Some ((`Client_process n) as scope) ->
stateful ~scope ?throttling ?name s
in
{ t; signal_down_mark=signal_down_mark () }
end
end
eliom-3.0.3/src/server/eliom_bus.ml 0000644 0000000 0000000 00000007464 12062377521 015435 0 ustar 00 0000000 0000000 (* Ocsigen
* http://www.ocsigen.org
* Copyright (C) 2010
* Raphaël Proust
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exception;
* either version 2.1 of the License, or (at your option) any later version.
*
* This program 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
* GNU Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
module Ecb = Eliom_comet_base
type 'a t = {
stream : 'a Lwt_stream.t;
scope : Eliom_comet.Channel.comet_scope;
name : string option;
channel : 'a Eliom_comet.Channel.t option;
write : ('a -> unit);
service : 'a Ecb.bus_send_service;
service_registered : bool Eliom_state.volatile_table option;
size : int option;
bus_mark : 'a t Eliom_common.wrapper; (* must be the last field ! *)
}
let register_sender scope service write =
Eliom_registration.Action.register
~scope
~options:`NoReload
~service
(fun () x -> List.iter write x ; Lwt.return ())
let internal_wrap (bus: 'a t) : 'a Ecb.wrapped_bus * Eliom_common.unwrapper =
let channel =
match bus.channel with
| None ->
Eliom_comet.Channel.create ~scope:bus.scope ?name:bus.name ?size:bus.size
(Lwt_stream.clone bus.stream)
| Some c -> c
in
begin
match bus.service_registered with
| None -> ()
| Some table ->
match Eliom_state.get_volatile_data ~table () with
| Eliom_state.Data true -> ()
| _ ->
register_sender bus.scope
(bus.service:>
('h, 'a list, [ Eliom_service.internal_service_kind ], 'f, 'c, 'd, 'e, 'g)
Eliom_service.service)
bus.write;
Eliom_state.set_volatile_data ~table true
end;
( ( Eliom_comet.Channel.get_wrapped channel,
bus.service ),
Eliom_common.make_unwrapper Eliom_common.bus_unwrap_id )
let bus_mark () = Eliom_common.make_wrapper internal_wrap
let deriving_to_list : 'a Deriving_Json.t -> 'a list Deriving_Json.t = fun (type typ) typ ->
let (typ_list:typ list Deriving_Json.t) =
let module M = Deriving_Json.Json_list(Deriving_Json.Defaults''(struct
type a = typ
let t = typ
end)) in
M.t
in
typ_list
let create ?scope ?name ?size typ =
(*The stream*)
let (stream, push) = Lwt_stream.create () in
let push x = push (Some x) in
let scope =
match scope with
| None
| Some `Site -> `Site
| Some `Client_process n -> `Client_process n
in
let channel =
match scope with
| `Site ->
Some (Eliom_comet.Channel.create ~scope ?name ?size
(Lwt_stream.clone stream))
| `Client_process _ -> None
in
let typ_list = deriving_to_list typ in
(*The service*)
let post_params =
(Eliom_parameter.caml "bus_write" typ_list
: ('a, 'aa, 'aaa) Eliom_parameter.params_type)
in
let distant_write = Eliom_service.post_coservice' ?name ~post_params () in
let service_registered =
match scope with
| `Site ->
register_sender scope distant_write push;
None
| `Client_process _ as scope ->
Some (Eliom_state.create_volatile_table ~scope ()) in
(*The bus*)
let bus =
{ stream;
channel;
scope;
name;
write = push;
service = distant_write;
service_registered;
bus_mark = bus_mark ();
size = size }
in
bus
let stream bus =
match bus.scope with
| `Site -> Lwt_stream.clone bus.stream
| `Client_process _ -> bus.stream
let write bus x = bus.write x
eliom-3.0.3/src/server/eliom_common.ml 0000644 0000000 0000000 00000144447 12062377521 016137 0 ustar 00 0000000 0000000 (* Ocsigen
* http://www.ocsigen.org
* Copyright (C) 2007 Vincent Balat
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exception;
* either version 2.1 of the License, or (at your option) any later version.
*
* This program 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
* GNU Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
open Eliom_lib
open Ocsigen_cookies
include Eliom_common_base
exception Eliom_Wrong_parameter (** Service called with wrong parameter names *)
exception Eliom_Session_expired
exception Eliom_Typing_Error of (string * exn) list
exception Eliom_duplicate_registration of string
exception Eliom_there_are_unregistered_services of
(string list * string list list * na_key_serv list)
exception Eliom_site_information_not_available of string
exception Eliom_page_erasing of string
exception Eliom_error_while_loading_site of string
exception Eliom_404
exception Eliom_do_redirection of string
exception Eliom_do_half_xhr_redirection of string
type 'a tenable_value = < get : 'a ; set : ?override_tenable:bool -> 'a -> unit >
let tenable_value ~name v = object
val mutable value = v
val mutable tenable = false
method get = value
method set ?(override_tenable=false) v =
if not tenable || override_tenable then (
value <- v;
tenable <- override_tenable
) else
Ocsigen_messages.warning ("Ignored setting tenable value \""^name^"\".")
end
(*****************************************************************************)
(*VVV Do not forget to change the version number
when the internal format change!!! *)
let persistent_cookie_table_version = "_v5"
(* v2 introduces session groups *)
(* v3 introduces tab sessions *)
(* v4 introduces group tables *)
(* v5 removes secure scopes *)
let eliom_persistent_cookie_table =
"eliom_persist_cookies"^persistent_cookie_table_version
let datacookiename = "eliomdatasession|"
let servicecookiename = "eliomservicesession|"
(* must not be a prefix of the following and vice versa (idem for data) *)
let persistentcookiename = "eliompersistentsession|"
(*****************************************************************************)
let eliom_link_too_old : bool Polytables.key = Polytables.make_key ()
(** The coservice does not exist any more *)
let eliom_service_session_expired :
(full_state_name list * full_state_name list) Polytables.key =
Polytables.make_key ()
(** If present in request data, means that
the service session cookies does not exist any more.
The string lists are the list of names of expired sessions
*)
let found_stop_key = Polytables.make_key ()
(*****************************************************************************)
type 'a session_cookie =
| SCNo_data
| SCData_session_expired
| SC of 'a
type cookie_exp =
| CENothing (** nothing to set (keep current value) *)
| CEBrowser (** expires at browser close *)
| CESome of float (** expiration date *)
type timeout =
| TGlobal (** see global setting *)
| TNone (** explicitely set no timeout *)
| TSome of float (** timeout duration in seconds *)
(* The table of tables for each session. Keys are cookies *)
module SessionCookies =
Hashtbl.Make(struct
type t = string
let equal = (=)
let hash = Hashtbl.hash
end)
(* session groups *)
type 'a sessgrp =
(string * cookie_level * (string, Ip_address.t) leftright)
(* The full session group is the triple
(site_dir_string, scope, session group name).
The scope is the scope of group members (`Session by default).
If there is no session group,
we limit the number of sessions by IP address. *)
type perssessgrp = string (* same triple, marshaled *)
let make_persistent_full_group_name ~cookie_level site_dir_string = function
| None -> None
| Some g ->
Some (Marshal.to_string
(site_dir_string, cookie_level, Left g) [])
let getperssessgrp a = Marshal.from_string a 0
let string_of_perssessgrp = id
(* cookies information during page generation: *)
type 'a one_service_cookie_info =
(* service sessions: *)
{sc_value:string (* current value *);
sc_table:'a ref (* service session table
ref towards cookie table
*);
sc_timeout:timeout ref (* user timeout -
ref towards cookie table
*);
sc_exp:float option ref (* expiration date ref
(server side) -
None = never
ref towards cookie table
*);
sc_cookie_exp:cookie_exp ref (* cookie expiration date to set *);
sc_session_group: cookie_level sessgrp ref
(* session group *);
mutable sc_session_group_node:string Ocsigen_cache.Dlist.node;
}
type one_data_cookie_info =
(* in memory data sessions: *)
{dc_value:string (* current value *);
dc_timeout:timeout ref (* user timeout -
ref towards cookie table
*);
dc_exp:float option ref (* expiration date ref (server side) -
None = never
ref towards cookie table
*);
dc_cookie_exp:cookie_exp ref (* cookie expiration date to set *);
dc_session_group: cookie_level sessgrp ref (* session group *);
mutable dc_session_group_node:string Ocsigen_cache.Dlist.node;
}
type one_persistent_cookie_info =
{pc_value:string (* current value *);
pc_timeout:timeout ref (* user timeout *);
pc_cookie_exp:cookie_exp ref (* cookie expiration date to set *);
pc_session_group:perssessgrp option ref (* session group *)
}
(*VVV heavy *)
type 'a cookie_info1 =
(* service sessions: *)
(string option (* value sent by the browser *)
(* None = new cookie
(not sent by the browser) *)
*
'a one_service_cookie_info session_cookie ref
(* SCNo_data = the session has been closed
SCData_session_expired = the cookie has not been found in the table.
For both of them, ask the browser to remove the cookie.
*)
)
(* This one is not lazy because we must check all service sessions
at each request to find the services *)
Full_state_name_table.t ref (* The key is the full session name *) *
(* in memory data sessions: *)
(string option (* value sent by the browser *)
(* None = new cookie
(not sent by the browser) *)
*
one_data_cookie_info session_cookie ref
(* SCNo_data = the session has been closed
SCData_session_expired = the cookie has not been found in the table.
For both of them, ask the browser to remove the cookie.
*)
) Lazy.t
(* Lazy because we do not want to ask the browser to unset the cookie
if the cookie has not been used, otherwise it is impossible to
write a message "Your session has expired" *)
Full_state_name_table.t ref (* The key is the full session name *) *
(* persistent sessions: *)
((string (* value sent by the browser *) *
timeout (* timeout at the beginning of the request *) *
float option (* (server side) expdate
at the beginning of the request
None = no exp *) *
perssessgrp option (* session group at beginning of request *))
option
(* None = new cookie
(not sent by the browser) *)
*
one_persistent_cookie_info session_cookie ref
(* SCNo_data = the session has been closed
SCData_session_expired = the cookie has not been found in the table.
For both of them, ask the browser to remove the cookie.
*)
) Lwt.t Lazy.t
Full_state_name_table.t ref
type 'a cookie_info =
'a cookie_info1 (* unsecure *) *
'a cookie_info1 option (* secure, if https *)
(* non persistent cookies for services *)
type 'a servicecookiestablecontent =
(full_state_name *
'a (* session table *) *
float option ref (* expiration date by timeout
(server side) *) *
timeout ref (* user timeout *) *
cookie_level sessgrp ref (* session group *) *
string Ocsigen_cache.Dlist.node (* session group node *))
type 'a servicecookiestable = 'a servicecookiestablecontent SessionCookies.t
(* the table contains:
- the table of services
- the expiration date (by timeout), changed at each access to the table
(float option) None -> no expiration
- the timeout for the user (float option option) None -> see global config
Some None -> no timeout
- the group to which belongs the session
*)
(* non persistent cookies for in memory data *)
type datacookiestablecontent =
(full_state_name *
float option ref (* expiration date by timeout
(server side) *) *
timeout ref (* user timeout *) *
cookie_level sessgrp ref (* session group *) *
string Ocsigen_cache.Dlist.node (* session group node *))
type datacookiestable = datacookiestablecontent SessionCookies.t
(*****************************************************************************)
let ipv4mask = ref 0b11111111111111110000000000000000l (* /16 *)
let ipv6mask = ref (0b1111111111111111111111111111111111111111111111111111111100000000L, 0L) (* /56 (???) *)
let get_mask4 m =
match fst m with
| Some m -> m
| None -> !ipv4mask
let get_mask6 m =
match fst m with
| Some m -> m
| None -> !ipv6mask
module Net_addr_Hashtbl =
(* keys are IP address modulo "network equivalence" *)
(struct
include Hashtbl.Make(struct
type t = Ip_address.t
let equal = (=)
let hash = Hashtbl.hash
end)
let add m4 m6 t k v =
add t (Ip_address.network_of_ip k (get_mask4 m4) (get_mask6 m6)) v
let remove m4 m6 t k =
remove t (Ip_address.network_of_ip k (get_mask4 m4) (get_mask6 m6))
let find m4 m6 t k =
find t (Ip_address.network_of_ip k (get_mask4 m4) (get_mask6 m6))
let find_all m4 m6 t k =
find_all t (Ip_address.network_of_ip k (get_mask4 m4) (get_mask6 m6))
let replace m4 m6 t k v =
replace t (Ip_address.network_of_ip k (get_mask4 m4) (get_mask6 m6)) v
let mem m4 m6 t k =
mem t (Ip_address.network_of_ip k (get_mask4 m4) (get_mask6 m6))
end : sig
type key = Ip_address.t
type 'a t
val create : int -> 'a t
val clear : 'a t -> unit
val copy : 'a t -> 'a t
val add :
int32 option * 'bb -> (int64 * int64) option * 'bb -> 'a t -> key -> 'a -> unit
val remove : int32 option * 'bb -> (int64 * int64) option * 'bb -> 'a t -> key -> unit
val find : int32 option * 'bb -> (int64 * int64) option * 'bb -> 'a t -> key -> 'a
val find_all :
int32 option * 'bb -> (int64 * int64) option * 'bb -> 'a t -> key -> 'a list
val replace :
int32 option * 'bb -> (int64 * int64) option * 'bb -> 'a t -> key -> 'a -> unit
val mem : int32 option * 'bb -> (int64 * int64) option * 'bb -> 'a t -> key -> bool
val iter : (key -> 'a -> unit) -> 'a t -> unit
val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
val length : 'a t -> int
end)
let create_dlist_ip_table = Net_addr_Hashtbl.create
let find_dlist_ip_table = Net_addr_Hashtbl.find
(*****************************************************************************)
type page_table_key =
{key_state : att_key_serv * att_key_serv;
key_kind: Ocsigen_http_frame.Http_header.http_method}
module Serv_Table = Map.Make(struct
type t = page_table_key
let compare = compare
end)
module NAserv_Table = Map.Make(struct
type t = na_key_serv
let compare = compare
end)
type anon_params_type = int
type node_info = {
ni_id : node_ref;
mutable ni_sent : bool;
}
module Hier_set = String.Set
type server_params =
{sp_request: Ocsigen_extensions.request;
sp_si: sess_info;
sp_sitedata: sitedata (* data for the whole site *);
sp_cookie_info: tables cookie_info;
sp_tab_cookie_info: tables cookie_info;
mutable sp_user_cookies: Ocsigen_cookies.cookieset;
(* cookies (un)set by the user during service *)
mutable sp_user_tab_cookies: Ocsigen_cookies.cookieset;
mutable sp_client_appl_name: string option; (* The application name,
as sent by the browser *)
sp_suffix: Url.path option (* suffix *);
sp_full_state_name: full_state_name option
(* the name of the session
to which belong the service that answered
(if it is a session service) *);
sp_client_process_info: client_process_info;
}
and page_table = page_table_content Serv_Table.t
and page_table_content =
Ptc of
(page_table ref * page_table_key, na_key_serv) leftright
Ocsigen_cache.Dlist.node option
(* for limitation of number of dynamic anonymous coservices *) *
((anon_params_type * anon_params_type)
(* unique_id, computed from parameters type.
must be the same even if the actual service reference
is different (after reloading the site)
so that it replaces the former one
*) *
(int ref option (* max_use *) *
(float * float ref) option
(* timeout and expiration date for the service *) *
(bool -> server_params -> Ocsigen_http_frame.result Lwt.t)
)) list
and naservice_table_content =
(int (* generation (= number of reloads of sites
after which that service has been created) *) *
int ref option (* max_use *) *
(float * float ref) option (* timeout and expiration date *) *
(server_params -> Ocsigen_http_frame.result Lwt.t) *
(page_table ref * page_table_key, na_key_serv) leftright
Ocsigen_cache.Dlist.node option
(* for limitation of number of dynamic coservices *)
)
and naservice_table =
| AVide
| ATable of naservice_table_content NAserv_Table.t
and dircontent =
| Vide
| Table of direlt ref String.Table.t
and direlt =
| Dir of dircontent ref
| File of page_table ref
and tables =
{mutable table_services : (int (* generation *) *
int (* priority *) *
dircontent ref) list;
table_naservices : naservice_table ref;
(* ref, and not mutable field because it simpler to use
recursively with Dir of dircontent ref *)
(* Information for the GC: *)
mutable table_contains_services_with_timeout : bool;
(* true if dircontent contains services with timeout *)
mutable table_contains_naservices_with_timeout : bool;
(* true if naservice_table contains services with timeout *)
mutable csrf_get_or_na_registration_functions :
(sp:server_params -> string) Int.Table.t;
mutable csrf_post_registration_functions :
(sp:server_params -> att_key_serv -> string) Int.Table.t;
(* These two table are used for CSRF safe services:
We associate to each service unique id the function that will
register a new anonymous coservice each time we create a link or form.
Attached POST coservices may have both a GET and POST
registration function. That's why there are two tables.
The functions associated to each service may be different for
each session. That's why we use these table, and not a field in
the service record.
*)
service_dlist_add :
?sp:server_params ->
(page_table ref * page_table_key, na_key_serv) leftright ->
(page_table ref * page_table_key, na_key_serv) leftright
Ocsigen_cache.Dlist.node
(* Add in a dlist
for limiting the number of dynamic anonymous coservices in each table
(and avoid DoS).
There is one dlist for each session, and one for each IP
in global tables.
The dlist parameter is the table and coservice number
for attached coservices,
and the coservice number for non-attached ones.
*)
}
and sitedata =
{site_dir: Url.path;
site_dir_string: string;
config_info: Ocsigen_extensions.config_info;
default_links_xhr : bool tenable_value;
(* Timeouts:
- default for site (browser sessions)
- default for site (tab sessions)
- then default for each full session name
The booleans means "has been set from config file"
*)
mutable servtimeout:
(float option * bool) option *
(float option * bool) option *
((full_state_name * (float option * bool)) list);
mutable datatimeout:
(float option * bool) option *
(float option * bool) option *
((full_state_name * (float option * bool)) list);
mutable perstimeout:
(float option * bool) option *
(float option * bool) option *
((full_state_name * (float option * bool)) list);
site_value_table : Polytables.t; (* table containing evaluated
lazy site values *)
mutable registered_scope_hierarchies: Hier_set.t;
(* All services, and state data are stored in these tables,
for scopes session and client process.
The scope is registered in the full session name. *)
global_services: tables; (* global service table *)
session_services: tables servicecookiestable;
(* cookie table for services (tab and browser sessions) *)
session_data: datacookiestable; (* cookie table for in memory session data
(tab and browser sessions)
contains the information about the cookie
(expiration, group ...).
*)
group_of_groups: [ `Session_group ] sessgrp Ocsigen_cache.Dlist.t;
(* Limitation of the number of groups per site *)
mutable remove_session_data: string -> unit;
mutable not_bound_in_data_tables: string -> bool;
mutable exn_handler: exn -> Ocsigen_http_frame.result Lwt.t;
mutable unregistered_services: Url.path list;
mutable unregistered_na_services: na_key_serv list;
mutable max_volatile_data_sessions_per_group : int * bool;
mutable max_volatile_data_sessions_per_subnet : int * bool;
mutable max_volatile_data_tab_sessions_per_group : int * bool;
mutable max_service_sessions_per_group : int * bool;
mutable max_service_sessions_per_subnet : int * bool;
mutable max_service_tab_sessions_per_group : int * bool;
mutable max_persistent_data_sessions_per_group : int option * bool;
mutable max_persistent_data_tab_sessions_per_group : int option * bool;
mutable max_anonymous_services_per_session : int * bool;
mutable max_anonymous_services_per_subnet : int * bool;
dlist_ip_table : dlist_ip_table;
mutable ipv4mask : int32 option * bool;
mutable ipv6mask : (int64 * int64) option * bool;
}
and dlist_ip_table = (page_table ref * page_table_key, na_key_serv)
leftright Ocsigen_cache.Dlist.t Net_addr_Hashtbl.t
(*****************************************************************************)
let make_full_cookie_name cookieprefix (cookie_scope, secure, site_dir_string) =
let scope_hier = scope_hierarchy_of_scope cookie_scope in
let secure = if secure then "S|" else "|" in
let hier1, hiername = match scope_hier with
| User_hier hiername -> "||", hiername
| Default_ref_hier -> "|ref|", ""
| Default_comet_hier -> "|comet|", ""
in
let s = String.concat ""
[cookieprefix; secure; site_dir_string; hier1; hiername]
in
s
let make_full_state_name2
site_dir_string secure ~(scope:[< user_scope ]) : full_state_name =
(* The information in the cookie name, without the kind of session *)
((scope :> user_scope),
secure,
site_dir_string)
let make_full_state_name ~sp ~secure ~(scope:[< user_scope ]) =
make_full_state_name2 sp.sp_sitedata.site_dir_string secure scope
let get_cookie_info sp = function
| `Session -> sp.sp_cookie_info
| `Client_process -> sp.sp_tab_cookie_info
(*****************************************************************************)
(** Create server parameters record *)
let make_server_params
sitedata
(ri, si, all_cookie_info, all_tab_cookie_info, user_tab_cookies)
suffix
full_state_name =
let appl_name =
try
Some
(CookiesTable.find appl_name_cookie_name si.si_tab_cookies)
(* It is an XHR from the client application, or an internal form *)
with Not_found -> None
in
let cpi =
match si.si_client_process_info with
| Some cpi -> cpi
| None ->
let request_info = ri.Ocsigen_extensions.request_info in
{ cpi_ssl = request_info.Ocsigen_extensions.ri_ssl;
cpi_hostname = Ocsigen_extensions.get_hostname ri;
cpi_server_port = Ocsigen_extensions.get_port ri;
cpi_original_full_path =
request_info.Ocsigen_extensions.ri_original_full_path;
}
in
{ sp_request = ri;
sp_si = si;
sp_sitedata = sitedata;
sp_cookie_info = all_cookie_info;
sp_tab_cookie_info = all_tab_cookie_info;
sp_user_cookies = Ocsigen_cookies.empty_cookieset;
sp_user_tab_cookies = user_tab_cookies;
sp_client_appl_name = appl_name;
sp_suffix = suffix;
sp_full_state_name = full_state_name;
sp_client_process_info = cpi;
}
let sp_key = Lwt.new_key ()
let get_sp_option () = Lwt.get sp_key
let get_sp () =
match Lwt.get sp_key with
| Some sp -> sp
| None -> failwith "That function cannot be called here because it needs information about the request or the site."
let sp_of_option sp =
match sp with
| None -> get_sp ()
| Some sp -> sp
(*****************************************************************************)
(* Scope registration *)
(*****************************************************************************)
let global_scope : global_scope = `Global
let site_scope : site_scope = `Site
let default_group_scope : session_group_scope = `Session_group Default_ref_hier
let default_session_scope : session_scope = `Session Default_ref_hier
let default_process_scope : client_process_scope = `Client_process Default_ref_hier
let comet_client_process_scope : client_process_scope = `Client_process Default_comet_hier
let request_scope : request_scope = `Request
let registered_scope_hierarchies = ref Hier_set.empty
let register_scope_hierarchy (name:string) =
match get_sp_option () with
| None ->
if Hier_set.mem name !registered_scope_hierarchies
then failwith (Printf.sprintf "the scope hierarchy %s has already been registered" name)
else registered_scope_hierarchies :=
Hier_set.add name !registered_scope_hierarchies
| Some sp ->
if Hier_set.mem name !registered_scope_hierarchies ||
Hier_set.mem name sp.sp_sitedata.registered_scope_hierarchies
then failwith (Printf.sprintf "the scope hierarchy %s has already been registered" name)
else sp.sp_sitedata.registered_scope_hierarchies <-
Hier_set.add name sp.sp_sitedata.registered_scope_hierarchies
let create_scope_hierarchy name : scope_hierarchy =
register_scope_hierarchy name;
User_hier name
let list_scope_hierarchies () =
let sp = get_sp () in
Default_comet_hier::Default_ref_hier::
(List.map (fun s -> User_hier s)
(Hier_set.elements !registered_scope_hierarchies)
@ List.map (fun s -> User_hier s)
(Hier_set.elements sp.sp_sitedata.registered_scope_hierarchies) )
(*****************************************************************************)
(* The current registration directory *)
let absolute_change_sitedata,
get_current_sitedata,
end_current_sitedata =
let f2 : sitedata list ref = ref [] in
let popf2 () =
match !f2 with
| _::t -> f2 := t
| [] -> f2 := []
in
((fun sitedata -> f2 := sitedata::!f2) (* absolute_change_sitedata *),
(fun () -> match !f2 with
| [] -> raise (Eliom_site_information_not_available
"get_current_sitedata")
| sd::_ -> sd) (* get_current_sitedata *),
(fun () -> popf2 ()) (* end_current_sitedata *))
(* Warning: these functions are used only during the initialisation
phase, which is not threaded ... That's why it works, but ...
it is not really clean ... public registration relies on this
directory (defined for each site in the config file)
*)
(*****************************************************************************)
let add_unregistered sitedata a =
sitedata.unregistered_services <- a::sitedata.unregistered_services
let add_unregistered_na sitedata a =
sitedata.unregistered_na_services <- a::sitedata.unregistered_na_services
let remove_unregistered sitedata a =
sitedata.unregistered_services <-
List.remove_first_if_any a sitedata.unregistered_services
let remove_unregistered_na sitedata a =
sitedata.unregistered_na_services <-
List.remove_first_if_any a sitedata.unregistered_na_services
let verify_all_registered sitedata =
match sitedata.unregistered_services, sitedata.unregistered_na_services with
| [], [] -> ()
| l1, l2 ->
raise (Eliom_there_are_unregistered_services (sitedata.site_dir, l1, l2))
let during_eliom_module_loading,
begin_load_eliom_module,
end_load_eliom_module =
let during_eliom_module_loading_ = ref false in
((fun () -> !during_eliom_module_loading_),
(fun () -> during_eliom_module_loading_ := true),
(fun () -> during_eliom_module_loading_ := false))
let global_register_allowed () =
if (Ocsigen_extensions.during_initialisation ())
&& (during_eliom_module_loading ())
then Some get_current_sitedata
else None
let get_site_data () =
match get_sp_option () with
| Some sp ->
sp.sp_sitedata
| None ->
if during_eliom_module_loading () then
get_current_sitedata ()
else
failwith "get_site_data"
(*****************************************************************************)
(* Lazy site value: each site have a different value *)
(* Evaluated values are never collected by the GC, the table always
keeps a reference on it. *)
(* there is no test for cycles *)
type 'a lazy_site_value =
{ lazy_sv_fun : unit -> 'a;
lazy_sv_key : 'a Polytables.key }
let force_lazy_site_value v =
let sitedata =
match get_sp_option () with
| Some sp -> sp.sp_sitedata
| None ->
match global_register_allowed () with
| Some f -> f ()
| None ->
raise (Eliom_site_information_not_available
"force_lazy_site_value")
in
try Polytables.get
~table:sitedata.site_value_table
~key:v.lazy_sv_key
with
| Not_found ->
let value = v.lazy_sv_fun () in
Polytables.set
~table:sitedata.site_value_table
~key:v.lazy_sv_key
~value;
value
let lazy_site_value_from_fun f =
{ lazy_sv_key = Polytables.make_key ();
lazy_sv_fun = f }
(*****************************************************************************)
(*****************************************************************************)
(* The table of dynamic pages for each virtual server, and naservices *)
(* Each node contains either a list of nodes (case directory)
or a table of "answers" (functions that will generate the page) *)
let empty_page_table () = Serv_Table.empty
let empty_dircontent () = Vide
let empty_naservice_table () = AVide
let service_tables_are_empty t =
!(t.table_naservices) = AVide
&& ((* !(t.table_services) = [] <---- probably enough? *)
List.for_all (fun (_, _, r) -> !r = Vide) t.table_services)
let remove_naservice_table at k =
match at with
| AVide -> AVide
| ATable t -> ATable (NAserv_Table.remove k t)
let dlist_finaliser na_table_ref node =
(* If the node disappears from the dlist,
we remove the service from the service table *)
match Ocsigen_cache.Dlist.value node with
| Left (page_table_ref, page_table_key) ->
page_table_ref := Serv_Table.remove page_table_key !page_table_ref
| Right na_key_serv ->
na_table_ref := remove_naservice_table !na_table_ref na_key_serv
let dlist_finaliser_ip sitedata ip na_table_ref node =
dlist_finaliser na_table_ref node;
match Ocsigen_cache.Dlist.list_of node with
| Some cl ->
if Ocsigen_cache.Dlist.size cl = 1
then
(try
Net_addr_Hashtbl.remove
sitedata.ipv4mask sitedata.ipv6mask sitedata.dlist_ip_table ip
with Not_found -> ())
| None -> ()
let add_dlist_ dlist v =
ignore (Ocsigen_cache.Dlist.add v dlist);
match Ocsigen_cache.Dlist.newest dlist with
| Some a -> a
| None -> assert false
let empty_tables max forsession =
let t1 = [] in
let t2 = ref (empty_naservice_table ()) in
{table_services = t1;
table_naservices = t2;
table_contains_services_with_timeout = false;
table_contains_naservices_with_timeout = false;
csrf_get_or_na_registration_functions = Int.Table.empty;
csrf_post_registration_functions = Int.Table.empty;
service_dlist_add =
if forsession
then
let dlist = Ocsigen_cache.Dlist.create max in
Ocsigen_cache.Dlist.set_finaliser_before (dlist_finaliser t2) dlist;
fun ?sp v -> add_dlist_ dlist v
else
fun ?sp v ->
let ip, max, sitedata =
match sp with
| None ->
Ip_address.inet6_addr_loopback, max,
(match global_register_allowed () with
| None ->
failwith "global tables created outside initialisation"
| Some get -> get ())
| Some sp ->
((Lazy.force
sp.sp_request.Ocsigen_extensions.request_info.Ocsigen_extensions.ri_remote_ip_parsed),
(fst sp.sp_sitedata.max_anonymous_services_per_subnet),
sp.sp_sitedata
)
in
let dlist =
try
Net_addr_Hashtbl.find
sitedata.ipv4mask sitedata.ipv6mask sitedata.dlist_ip_table ip
with Not_found ->
let dlist = Ocsigen_cache.Dlist.create max in
Net_addr_Hashtbl.add
sitedata.ipv4mask sitedata.ipv6mask sitedata.dlist_ip_table ip dlist;
Ocsigen_cache.Dlist.set_finaliser_before
(dlist_finaliser_ip sitedata ip t2)
dlist;
dlist
in
add_dlist_ dlist v
}
let new_service_session_tables sitedata =
empty_tables
(fst sitedata.max_anonymous_services_per_session)
true
let get_mask4 sitedata = get_mask4 sitedata.ipv4mask
let get_mask6 sitedata = get_mask6 sitedata.ipv6mask
(*****************************************************************************)
open Lwt
(* Split parameter list, removing those whose name starts with pref *)
let split_prefix_param pref l =
let len = String.length pref in
List.partition (fun (n,_) ->
try
(String.sub n 0 len) = pref
with Invalid_argument _ -> false) l
(* Special version for non localized parameters *)
let split_nl_prefix_param =
let prefixlength = String.length nl_param_prefix in
let prefixlengthminusone = prefixlength - 1 in
fun l ->
let rec aux other map = function
| [] -> (map, other)
| ((n, v) as a)::l ->
if String.first_diff
n nl_param_prefix 0 prefixlengthminusone = prefixlength
then
try
let last = String.index_from n prefixlength '.' in
let nl_param_name =
String.sub n prefixlength (last - prefixlength)
in
let previous =
try String.Table.find nl_param_name map
with Not_found -> []
in
aux
other
(String.Table.add nl_param_name (a::previous) map)
l
with Invalid_argument _ | Not_found -> aux (a::other) map l
else aux (a::other) map l
in
aux [] String.Table.empty l
(* The cookie name is
sessionkind|S?|sitedirstring|"ref" ou "comet" ou ""|hiername
*)
let full_state_name_of_cookie_name cookie_level cookiename =
let pref, cookiename = Ocsigen_lib.String.sep '|' cookiename in
let secure, cookiename = Ocsigen_lib.String.sep '|' cookiename in
let sitedirstring, cookiename = Ocsigen_lib.String.sep '|' cookiename in
let hier1, hiername = Ocsigen_lib.String.sep '|' cookiename in
let secure = secure = "S" in
let sc_hier = match hier1 with
| "" -> Eliom_common_base.User_hier hiername
| "ref" -> Eliom_common_base.Default_ref_hier
| "comet" -> Eliom_common_base.Default_comet_hier
| _ -> raise Not_found
in
match cookie_level with
| `Session -> (`Session sc_hier, secure, sitedirstring)
| `Client_process -> (`Client_process sc_hier, secure, sitedirstring)
let getcookies secure cookie_level cookienamepref cookies =
let length = String.length cookienamepref in
let last = length - 1 in
CookiesTable.fold
(fun name value beg ->
if String.first_diff cookienamepref name 0 last = length
then
try
let (_, sec, _) as expcn =
full_state_name_of_cookie_name cookie_level name in
if sec = secure
then Full_state_name_table.add expcn value beg
else beg
with Not_found -> beg
else beg
)
cookies
Full_state_name_table.empty
(* Remove all parameters whose name starts with pref *)
let remove_prefixed_param pref l =
let len = String.length pref in
let rec aux = function
| [] -> []
| ((n,v) as a)::l ->
try
if (String.sub n 0 len) = pref then
aux l
else a::(aux l)
with Invalid_argument _ -> a::(aux l)
in aux l
(* After an action, we do not take into account actual get params,
but these ones: *)
let eliom_params_after_action = Polytables.make_key ()
(* After an ction, we get tab_cookies info from rc: *)
let tab_cookie_action_info_key = Polytables.make_key ()
type cpi = client_process_info = {
cpi_ssl : bool;
cpi_hostname : string;
cpi_server_port : int;
cpi_original_full_path : string list;
} deriving (Json)
let get_session_info req previous_extension_err =
let req_whole = req
and ri = req.Ocsigen_extensions.request_info
and ci = req.Ocsigen_extensions.request_config in
(* *)
let rc = ri.Ocsigen_extensions.ri_request_cache in
let no_post_param, p =
match ri.Ocsigen_extensions.ri_post_params with
| None -> true, Lwt.return []
| Some f -> false, f ci
in
p >>= fun post_params ->
let (previous_tab_cookies_info, tab_cookies, post_params) =
try
let (tci, utc, tc) =
Polytables.get ~table:rc ~key:tab_cookie_action_info_key
in
Polytables.remove ~table:rc ~key:tab_cookie_action_info_key;
(Some (tci, utc), tc, post_params)
with Not_found ->
let tab_cookies, post_params =
try
(* Tab cookies are found in HTTP headers,
but also sometimes in POST params (when we do not want to do an XHR
because we want to stop the client side process).
It should never be both.
*)
let (tc, pp) =
List.assoc_remove tab_cookies_param_name post_params
in
let tc = Json.from_string<(string * string) list> tc in
(List.fold_left (fun t (k,v) -> CookiesTable.add k v t) CookiesTable.empty tc, pp)
(*Marshal.from_string (Ocsigen_lib.decode tc) 0, pp*)
with Not_found ->
try (* looking for tab cookies in headers *)
let tc = Ocsigen_headers.find tab_cookies_header_name
ri.Ocsigen_extensions.ri_http_frame
in
let tc = Json.from_string<(string * string) list> tc in
(List.fold_left (fun t (k,v) -> CookiesTable.add k v t) CookiesTable.empty tc,
post_params)
with Not_found -> CookiesTable.empty, post_params
in
(None, tab_cookies, post_params)
in
let cpi =
try (* looking for client process info in headers *)
let cpi =
Ocsigen_headers.find
tab_cpi_header_name
ri.Ocsigen_extensions.ri_http_frame in
Some (Json.from_string cpi)
with Not_found -> None
in
let epd =
lazy (try (* looking in headers *)
let epd = Ocsigen_headers.find
expecting_process_page_name
ri.Ocsigen_extensions.ri_http_frame
in
Json.from_string epd
with Not_found -> false)
in
let post_params, get_params, to_be_considered_as_get =
try
([],
Lazy.force ri.Ocsigen_extensions.ri_get_params
@snd (List.assoc_remove
to_be_considered_as_get_param_name post_params),
true)
(* It was a POST request to be considered as GET *)
with Not_found ->
(post_params, Lazy.force ri.Ocsigen_extensions.ri_get_params, false)
in
(*204FORMS* old implementation of forms with 204 and change_page_event
let get_params, internal_form =
try
(snd (List.assoc_remove internal_form_full_name get_params),
true)
with Not_found -> (get_params, false)
in
*)
let get_params0 = get_params in
let post_params0 = post_params in
let get_params, post_params,
(all_get_params, all_post_params,
nl_get_params, nl_post_params,
all_get_but_nl (*204FORMS*, internal_form *)) =
try
(get_params,
post_params,
Polytables.get
~table:ri.Ocsigen_extensions.ri_request_cache
~key:eliom_params_after_action)
with Not_found ->
let nl_get_params, get_params = split_nl_prefix_param get_params0 in
let nl_post_params, post_params = split_nl_prefix_param post_params0 in
let all_get_but_nl = get_params in
get_params, post_params,
(get_params0, (if no_post_param then None else Some post_params0),
nl_get_params, nl_post_params, all_get_but_nl (*204FORMS*, internal_form *))
in
let browser_cookies = Lazy.force ri.Ocsigen_extensions.ri_cookies in
let data_cookies = getcookies false `Session datacookiename browser_cookies in
let service_cookies = getcookies false `Session servicecookiename browser_cookies in
let persistent_cookies = getcookies false `Session persistentcookiename browser_cookies in
let secure_cookie_info =
if ri.Ocsigen_extensions.ri_ssl
then
let sdata_cookies = getcookies true `Session datacookiename browser_cookies in
let sservice_cookies = getcookies true `Session servicecookiename browser_cookies in
let spersistent_cookies =
getcookies true `Session persistentcookiename browser_cookies
in
Some (sservice_cookies, sdata_cookies, spersistent_cookies)
else None
in
let naservice_info,
(get_state, post_state),
(get_params, other_get_params),
na_get_params,
post_params =
let post_naservice_name, na_post_params =
try
let n, pp =
List.assoc_remove naservice_num post_params
in (RNa_post' n, pp)
with Not_found ->
try
let n, pp =
List.assoc_remove naservice_name post_params
in (RNa_post_ n, pp)
with Not_found -> (RNa_no, [])
in
match post_naservice_name with
| RNa_post_ _
| RNa_post' _ -> (* POST non attached coservice *)
(post_naservice_name,
(RAtt_no, RAtt_no),
([], get_params),
(lazy
(try
(try
(naservice_name, List.assoc naservice_name get_params)
with Not_found ->
(naservice_num, List.assoc naservice_num get_params))
::(fst (split_prefix_param na_co_param_prefix get_params))
with Not_found -> [])
),
na_post_params)
| _ ->
let get_naservice_name,
na_name_num,
(na_get_params, other_get_params) =
try
let n, gp =
List.assoc_remove naservice_num get_params
in (RNa_get' n,
[(naservice_num, n)],
(split_prefix_param na_co_param_prefix gp))
with Not_found ->
try
let n, gp =
List.assoc_remove naservice_name get_params
in (RNa_get_ n,
[(naservice_name, n)],
(split_prefix_param na_co_param_prefix gp))
with Not_found -> (RNa_no, [], ([], get_params))
in
match get_naservice_name with
| RNa_get_ _
| RNa_get' _ -> (* GET non attached coservice *)
(get_naservice_name,
(RAtt_no, RAtt_no),
(na_get_params, other_get_params),
(lazy (na_name_num@na_get_params)),
[])
(* Not possible to have POST parameters
without naservice_num
if there is a GET naservice_num
*)
| _ ->
let post_state, post_params =
try
let s, pp =
List.assoc_remove
post_numstate_param_name post_params
in (RAtt_anon s, pp)
with
Not_found ->
try
let s, pp =
List.assoc_remove
post_state_param_name post_params
in (RAtt_named s, pp)
with
Not_found -> (RAtt_no, post_params)
in
let get_state, (get_params, other_get_params) =
try
let s, gp =
List.assoc_remove
get_numstate_param_name get_params
in ((RAtt_anon s),
(split_prefix_param co_param_prefix gp))
with Not_found ->
try
let s, gp =
List.assoc_remove
get_state_param_name get_params
in ((RAtt_named s),
(split_prefix_param co_param_prefix gp))
with Not_found -> (RAtt_no, (get_params, []))
in
(RNa_no,
(get_state, post_state),
(get_params, other_get_params),
(lazy (na_name_num@na_get_params)),
post_params)
in
let persistent_nl_get_params =
lazy
(String.Table.fold
(fun k a t -> if nl_is_persistent k
then String.Table.add k a t
else t)
nl_get_params String.Table.empty)
in
let data_cookies_tab = getcookies false `Client_process datacookiename tab_cookies in
let service_cookies_tab = getcookies false `Client_process servicecookiename tab_cookies in
let persistent_cookies_tab = getcookies false `Client_process persistentcookiename tab_cookies in
let secure_cookie_info_tab =
if ri.Ocsigen_extensions.ri_ssl
then
let sdata_cookies = getcookies true `Client_process datacookiename tab_cookies in
let sservice_cookies = getcookies true `Client_process servicecookiename tab_cookies in
let spersistent_cookies = getcookies true `Client_process persistentcookiename tab_cookies in
Some (sservice_cookies, sdata_cookies, spersistent_cookies)
else None
in
let get_params_string, url_string =
(*204FORMS* old implementation of forms with 204 and change_page_event
if internal_form
then
let gps = Url.make_encoded_parameters all_get_params in
let uri = ri.Ocsigen_extensions.ri_full_path_string in
((if gps = "" then None else Some gps),
String.may_append uri ~sep:"?" gps)
else *)
(ri.Ocsigen_extensions.ri_get_params_string,
ri.Ocsigen_extensions.ri_url_string)
in
let ri', sess =
(*VVV 2011/02/15 TODO: I think we'd better not change ri here.
Keep ri for original values and use si for Eliom's values?
*)
{ri with
Ocsigen_extensions.ri_url_string = url_string;
Ocsigen_extensions.ri_get_params_string = get_params_string;
Ocsigen_extensions.ri_method =
(if
(ri.Ocsigen_extensions.ri_method =
Ocsigen_http_frame.Http_header.HEAD) ||
to_be_considered_as_get
then Ocsigen_http_frame.Http_header.GET
else ri.Ocsigen_extensions.ri_method);
(* Here we modify ri, instead of putting service parameters in si.
Thus it works better after actions:
the request can be taken by other extensions, with new parameters.
Initial parameters are kept in si.
*)
Ocsigen_extensions.ri_get_params = lazy get_params;
Ocsigen_extensions.ri_post_params =
if no_post_param
then None
else Some (fun _ -> Lwt.return post_params)},
{si_service_session_cookies= service_cookies;
si_data_session_cookies= data_cookies;
si_persistent_session_cookies= persistent_cookies;
si_secure_cookie_info= secure_cookie_info;
si_service_session_cookies_tab= service_cookies_tab;
si_data_session_cookies_tab= data_cookies_tab;
si_persistent_session_cookies_tab= persistent_cookies_tab;
si_secure_cookie_info_tab= secure_cookie_info_tab;
si_tab_cookies= tab_cookies;
si_nonatt_info= naservice_info;
si_state_info= (get_state, post_state);
si_other_get_params= other_get_params;
si_all_get_params= all_get_params;
si_all_post_params= all_post_params;
si_previous_extension_error= previous_extension_err;
si_na_get_params= na_get_params;
si_nl_get_params= nl_get_params;
si_nl_post_params= nl_post_params;
si_persistent_nl_get_params= persistent_nl_get_params;
si_all_get_but_nl= all_get_but_nl;
si_all_get_but_na_nl=
lazy
(List.remove_assoc naservice_name
(List.remove_assoc naservice_num
(remove_prefixed_param na_co_param_prefix all_get_but_nl)));
si_client_process_info= cpi;
si_expect_process_data= epd;
(*204FORMS* si_internal_form= internal_form; *)
}
in
Lwt.return
({ req_whole with Ocsigen_extensions.request_info = ri' }, sess,
previous_tab_cookies_info)
type ('a, 'b) foundornot = Found of 'a | Notfound of 'b
(*****************************************************************************)
type info =
(Ocsigen_extensions.request *
sess_info *
tables cookie_info (* current browser cookie info *) *
tables cookie_info (* current tab cookie info *) *
Ocsigen_cookies.cookieset (* current user tab cookies *))
exception Eliom_retry_with of info
(*****************************************************************************)
(* Each persistent table created by sites correspond to a file on the disk.
We save the names of the currently opened tables in this table: *)
module Perstables =
struct
let empty = []
let add v t = v::t
let fold = List.fold_left
end
let perstables = ref Perstables.empty
let create_persistent_table name =
perstables := Perstables.add name !perstables;
Ocsipersist.open_table name
let persistent_cookies_table :
(full_state_name * float option * timeout * perssessgrp option)
Ocsipersist.table Lazy.t =
lazy (create_persistent_table eliom_persistent_cookie_table)
(* Another tables, containing the session info for each cookie *)
(* the table contains:
- the expiration date (by timeout), changed at each access to the table
(float option) None -> no expiration
- the timeout for the user (float option option) None -> see global config
Some None -> no timeout
*)
(* It is lazy, because we must delay the creation of the table until
the initialization of eliom in case we use static linking with
sqlite backend ... *)
(** removes the entry from all opened tables *)
let remove_from_all_persistent_tables key =
Perstables.fold (* could be replaced by a parallel map *)
(fun thr t -> thr >>= fun () ->
Ocsipersist.remove (Ocsipersist.open_table t) key >>= Lwt_unix.yield)
(return ())
!perstables
(**** Wrapper type shared by client/server side ***)
type 'a wrapper = 'a Eliom_wrap.wrapper
let make_wrapper f = Eliom_wrap.create_wrapper f
let empty_wrapper () = Eliom_wrap.empty_wrapper
type unwrap_id = Eliom_wrap.unwrap_id
type unwrapper = Eliom_wrap.unwrapper
let make_unwrapper = Eliom_wrap.create_unwrapper
let empty_unwrapper = Eliom_wrap.empty_unwrapper
let react_up_unwrap_id : unwrap_id = Eliom_wrap.id_of_int react_up_unwrap_id_int
let react_down_unwrap_id : unwrap_id = Eliom_wrap.id_of_int react_down_unwrap_id_int
let signal_down_unwrap_id : unwrap_id = Eliom_wrap.id_of_int signal_down_unwrap_id_int
let comet_channel_unwrap_id : unwrap_id = Eliom_wrap.id_of_int comet_channel_unwrap_id_int
let bus_unwrap_id : unwrap_id = Eliom_wrap.id_of_int bus_unwrap_id_int
(* HACK: Remove the 'nl_get_appl_parameter' used to avoid confusion
between XHR and classical request in App. *)
let patch_request_info req =
if List.mem_assoc nl_get_appl_parameter
(Lazy.force req.Ocsigen_extensions.request_info.Ocsigen_extensions.ri_get_params)
then
{ req with
Ocsigen_extensions.request_info =
let get_params =
List.remove_assoc nl_get_appl_parameter
(Lazy.force req.Ocsigen_extensions.request_info.Ocsigen_extensions.ri_get_params)
in
{ req.Ocsigen_extensions.request_info with
Ocsigen_extensions.
ri_get_params = lazy get_params;
ri_get_params_string =
if get_params = []
then None
else Some (Url.make_encoded_parameters get_params);
} }
else
req
eliom-3.0.3/src/server/eliom_wrap.ml 0000644 0000000 0000000 00000012375 12062377521 015612 0 ustar 00 0000000 0000000 (* Ocsigen
* Copyright (C) 2011 Pierre Chambart
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exception;
* either version 2.1 of the License, or (at your option) any later version.
*
* This program 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
* GNU Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
type poly
type 'a wrapped_value = poly * 'a
module AddrType =
struct
type t = Obj.t
let hash v =
let v = Obj.repr v in
if Obj.is_block v
(* The returned hash must contain the 'int' bit. The division
enforces that without loosing too much information. *)
then (Obj.obj v / 2)
else failwith ("not a block "^(string_of_int (Obj.obj v)))
let equal = (==)
end
module T = Hashtbl.Make(AddrType)
let with_no_heap_move f v =
let gc_control = Gc.get () in
(* disable heap compaction *)
Gc.set { gc_control with Gc.max_overhead = max_int };
(* promote all remaining parts of v to the major heap *)
Gc.minor ();
(* from now on, memory addresses of parts of v won't change *)
let res =
try `Data (f v)
with e -> `Exn e
in
(* reset gc settings *)
Gc.set gc_control;
match res with
| `Data v -> v
| `Exn e -> raise e
module Mark :
sig
type t
val wrap_mark : t
val do_nothing_mark: t
val unwrap_mark : t
end =
struct
type t = string
let wrap_mark = "wrap_mark"
let do_nothing_mark = "do_nothing_mark"
let unwrap_mark = "unwrap_mark"
end
type marked_value =
{ mark : Mark.t;
f : ( Obj.t -> Obj.t ) option; }
let make_mark f mark =
{ mark; f }
let is_marked (mark:Mark.t) o =
let is_mark o =
if (Obj.tag o = 0 && Obj.size o = 2 && Obj.field o 0 == (Obj.repr mark))
then (let f = (Obj.field o 1) in
assert (Obj.tag f = 0); (* The case None should not happen here *)
assert (Obj.size f = 1);
assert (let tag = Obj.tag (Obj.field f 0) in tag = Obj.infix_tag || tag = Obj.closure_tag);
true)
else false
in
if (Obj.tag o = 0 && Obj.size o >= 2)
(* WARNING: we only allow block values with tag = 0 to be wrapped.
It is easier: we do not have to do another test to know if the
value is a function *)
then
begin
let potential_mark = (Obj.field o (Obj.size o - 1)) in
if is_mark potential_mark
then Some (Obj.obj potential_mark:marked_value)
else None
end
else None
type action =
| Set_field of ( Obj.t * int )
| Replace of Obj.t
| Return
type stack =
| Do of (Obj.t * action)
| Wrap of ((Obj.t -> Obj.t) * Obj.t)
let find t v =
if Obj.tag v < Obj.no_scan_tag
then
try
Some (T.find t v)
with
| Not_found -> None
else Some v
let search_and_replace v =
let t = T.create 1 in
let rec loop = function
| [] -> assert false
| (Wrap (f,v))::q ->
let new_v = f v in
(* f v is not guaranted to be in the major head: we need to move
it before adding to the table *)
Gc.minor ();
loop ((Do (new_v,Replace v))::q)
| (Do (v,action))::q as s ->
match find t v with
| Some r ->
(match action with
| Set_field (o,i) ->
Obj.set_field o i r;
loop q
| Replace o -> T.replace t o r;
loop q
| Return -> r)
| None ->
match is_marked Mark.wrap_mark v with
| Some { f = Some f } ->
let stack = (Wrap (f,v))::s in
loop stack
| Some { f = None } -> assert false
| None ->
let tag = Obj.tag v in
if tag = Obj.closure_tag || tag = Obj.infix_tag || tag = Obj.lazy_tag || tag = Obj.object_tag
then
( if tag = Obj.lazy_tag then failwith "lazy values must be forced before wrapping";
if tag = Obj.object_tag then failwith "cannot wrap object values";
if tag = Obj.closure_tag then failwith "cannot wrap functional values";
failwith "cannot wrap functional values: infix tag" )
else
begin
let size = Obj.size v in
let new_v = Obj.new_block tag size in
T.add t v new_v;
(* It is ok to do this because tag < no_scan_tag and it is
not a closure ( either infix, normal or lazy ) *)
let stack = ref s in
for i = 0 to size - 1 do
stack := (Do ((Obj.field v i),Set_field (new_v,i))) :: !stack;
done;
loop !stack
end
in
with_no_heap_move loop [Do (v,Return)]
type +'a wrapper = marked_value
let create_wrapper (f: 'a -> 'b) : 'a wrapper =
make_mark (Some (fun x -> Obj.repr (f (Obj.obj x)))) Mark.wrap_mark
let empty_wrapper : 'a wrapper =
make_mark None Mark.do_nothing_mark
type unwrap_id = int
let id_of_int x = x
type unwrapper =
(* WARNING Must be the same as Eliom_unwrap.unwrapper *)
{ id : unwrap_id;
umark : Mark.t; }
let create_unwrapper id =
{ id = id;
umark = Mark.unwrap_mark }
let empty_unwrapper =
{ id = -1;
umark = Mark.do_nothing_mark }
let wrap v =
Obj.magic Mark.unwrap_mark, Obj.obj (search_and_replace (Obj.repr v))
eliom-3.0.3/src/server/eliom_mkreg.ml 0000644 0000000 0000000 00000065064 12062377521 015751 0 ustar 00 0000000 0000000 (* Ocsigen
* http://www.ocsigen.org
* Module Eliom_mkreg
* Copyright (C) 2007 Vincent Balat
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exception;
* either version 2.1 of the License, or (at your option) any later version.
*
* This program 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
* GNU Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
open Eliom_lib
open Lwt
open Ocsigen_extensions
open Eliom_state
open Eliom_parameter
open Eliom_service
open Lazy
let suffix_redir_uri_key = Polytables.make_key ()
(****************************************************************************)
type ('options,'page,'result) param =
{ send :
?options:'options ->
?charset:string ->
?code: int ->
?content_type:string ->
?headers: Http_headers.t ->
'page ->
Ocsigen_http_frame.result Lwt.t;
send_appl_content : Eliom_service.send_appl_content;
(** Whether the service is capable to send application content when
required. This field is usually [Eliom_service.XNever]. This
value is recorded inside each service just after
registration. *)
result_of_http_result : Ocsigen_http_frame.result -> 'result; }
(* If it is an xmlHTTPrequest who asked for an internal application
service but the current service
does not belong to the same application,
we ask the browser to stop the program and do a redirection.
This can happen for example after an action,
when the fallback service does not belong to the application.
We can not do a regular redirection because
it is an XHR. We use our own redirections.
*)
(*VVV
An alternative, to avoid the redirection with rc,
would be to answer the full page and to detect on client side
that it is not the answer of an XRH (using content-type)
and ask the browser to act as if it were a regular request.
Is it possible to do that?
Drawback: The URL will be wrong
Other solution: send the page and ask the browser to put it in the cache
during a few seconds. Then redirect. But can we trust the browser cache?
*)
(* the test to know before page generation if the page can contain
application data. This test is not exhaustif: services declared as
XAlways can contain classical content, but we can't know it at this
point: we must wait for the page to be generated and then see if it
is effectively application content. *)
let check_before name service =
match Eliom_service.get_send_appl_content service
(* the appl name of the service *)
with
| Eliom_service.XSame_appl (an, _)
when (an = name)
-> (* Same appl, it is ok *) false
| Eliom_service.XAlways -> (* It is an action *) false
| _ -> true
(* This test check if there is a header set only by
Eliom_registration.App. This test is sufficient, but it is better
to stop page generation as soon as we know that the content won't
be needed: hence we test what we can before page generation. *)
let check_after name result =
try
let appl_name = Http_headers.find
(Http_headers.name Eliom_common_base.appl_name_header_name)
result.Ocsigen_http_frame.res_headers
in
not (appl_name = name)
with
(* not an application content *)
| Not_found -> true
let check_process_redir sp f param =
let redir =
if Eliom_request_info.expecting_process_page ()
then
match sp.Eliom_common.sp_client_appl_name with
(* the appl name as sent by browser *)
| None -> false (* should not happen *)
| Some anr -> f anr param
(* the browser asked application eliom data
(content only) for application anr *)
else false
in
if redir
then
let ri = Eliom_request_info.get_ri_sp sp in
raise_lwt
(* we answer to the xhr
by asking an HTTP redirection *)
(Eliom_common.Eliom_do_half_xhr_redirection
("/"^
String.may_concat
ri.Ocsigen_extensions.ri_original_full_path_string
~sep:"?"
(Eliom_parameter.construct_params_string
(Lazy.force
ri.Ocsigen_extensions.ri_get_params)
)))
(* We do not put hostname and port.
It is ok with half or full xhr redirections. *)
(* If an action occured before,
it may have removed some get params form ri *)
else Lwt.return ()
let send_with_cookies
sp
pages
?options
?charset
?code
?content_type
?headers
content =
lwt result =
pages.send
?options
?charset
?code
?content_type
?headers
content
in
lwt () = check_process_redir sp check_after result in
lwt tab_cookies =
Eliommod_cookies.compute_cookies_to_send
sp.Eliom_common.sp_sitedata
sp.Eliom_common.sp_tab_cookie_info
sp.Eliom_common.sp_user_tab_cookies
in
(* TODO: do not add header when no cookies *)
let tab_cookies = Eliommod_cookies.cookieset_to_json tab_cookies in
Lwt.return
{ result with
Ocsigen_http_frame.res_cookies =
Ocsigen_cookies.add_cookies
(Eliom_request_info.get_user_cookies ())
result.Ocsigen_http_frame.res_cookies;
res_headers = Http_headers.add
(Http_headers.name Eliom_common_base.set_tab_cookies_header_name)
tab_cookies
result.Ocsigen_http_frame.res_headers; }
let register_aux pages
?options
?charset
?code
?content_type
?headers
table
~service
?(error_handler = fun l -> raise (Eliom_common.Eliom_Typing_Error l))
page_generator =
Eliom_service.set_send_appl_content service (pages.send_appl_content);
begin
match get_kind_ service with
| `Attached attser ->
let key_kind = get_or_post_ attser in
let attserget = get_get_name_ attser in
let attserpost = get_post_name_ attser in
let suffix_with_redirect = get_redirect_suffix_ attser in
let priority = get_priority_ attser in
let sgpt = get_get_params_type_ service in
let sppt = get_post_params_type_ service in
let f table ((attserget, attserpost) as attsernames) =
Eliommod_services.add_service
priority
table
(get_sub_path_ attser)
{Eliom_common.key_state = attsernames;
Eliom_common.key_kind = key_kind}
((if attserget = Eliom_common.SAtt_no
|| attserpost = Eliom_common.SAtt_no
then (anonymise_params_type sgpt,
anonymise_params_type sppt)
else (0, 0)),
((match get_max_use_ service with
| None -> None
| Some i -> Some (ref i)),
(match get_timeout_ service with
| None -> None
| Some t -> Some (t, ref (t +. Unix.time ()))),
(fun nosuffixversion sp ->
Lwt.with_value Eliom_common.sp_key (Some sp)
(fun () ->
let ri = Eliom_request_info.get_ri_sp sp
and suff = Eliom_request_info.get_suffix_sp sp in
(catch (fun () ->
reconstruct_params
~sp
sgpt
(Some (Lwt.return (force ri.ri_get_params)))
(Some (Lwt.return []))
nosuffixversion
suff
>>= fun g ->
let post_params =
Eliom_request_info.get_post_params_sp sp
in
let files =
Eliom_request_info.get_files_sp sp
in
reconstruct_params
~sp
sppt
post_params
files
false
None
>>= fun p ->
(* GRGR TODO: avoid
Eliom_uri.make_string_uri_. But we need to
"downcast" the type of service to the
correct "get service". *)
(if Eliom_request_info.get_http_method () =
Ocsigen_http_frame.Http_header.GET
&& nosuffixversion && suffix_with_redirect
then
(* it is a suffix service in version
without suffix. We redirect. *)
if not (Eliom_request_info.expecting_process_page ())
then
let redir_uri =
Eliom_uri.make_string_uri_
~absolute:true
~service:
(service :
('a, 'b, [< Eliom_service.internal_service_kind ],
[< Eliom_service.suff ], 'c, 'd, [ `Registrable ],
'return) Eliom_service.service :>
('a, 'b, Eliom_service.service_kind,
[< Eliom_service.suff ], 'c, 'd,
[< Eliom_service.registrable ], 'return)
Eliom_service.service)
g
in
Lwt.fail
(Eliom_common.Eliom_do_redirection redir_uri)
else begin
(* It is an internal application form.
We don't redirect but we set this
special information for url to be displayed
by the browser
(see Eliom_request_info.rebuild_uri_without_iternal_form_info_)
*)
let redir_uri =
Eliom_uri.make_string_uri_
~absolute:false
~absolute_path:true
~service:
(service :
('a, 'b, [< Eliom_service.internal_service_kind ],
[< Eliom_service.suff ], 'c, 'd, [ `Registrable ],
'return) Eliom_service.service :>
('a, 'b, Eliom_service.service_kind,
[< Eliom_service.suff ], 'c, 'd,
[< Eliom_service.registrable ], 'return)
Eliom_service.service)
g
in
let redir_uri =
if String.length redir_uri > 0
then String.sub redir_uri 1
(String.length redir_uri - 1)
else redir_uri
in
let rc = Eliom_request_info.get_request_cache_sp sp in
Polytables.set ~table:rc ~key:suffix_redir_uri_key ~value:redir_uri;
Lwt.return ()
end
else Lwt.return ())
>>= fun () ->
check_process_redir sp check_before service >>= fun () ->
page_generator g p)
(function
| Eliom_common.Eliom_Typing_Error l ->
error_handler l
| e -> fail e)
>>= fun content ->
send_with_cookies sp pages
?options
?charset
?code
?content_type
?headers
content)))))
in
(match (key_kind, attserget, attserpost) with
| (Ocsigen_http_frame.Http_header.POST, _,
Eliom_common.SAtt_csrf_safe (id, scope, secure_session)) ->
let tablereg, forsession =
match table with
| Left globtbl -> globtbl, false
| Right (sp, ct, sec) ->
if secure_session <> sec || scope <> ct
then raise
Wrong_session_table_for_CSRF_safe_coservice;
!(Eliom_state.get_session_service_table
?secure:secure_session ~scope ~sp ()),
true
in
Eliom_service.set_delayed_post_registration_function
tablereg
id
(fun ~sp attserget ->
let n = Eliom_service.new_state () in
let attserpost = Eliom_common.SAtt_anon n in
let table =
if forsession
then tablereg
else
(* we do not register in global table,
but in the table specified while creating
the csrf safe service *)
!(Eliom_state.get_session_service_table
?secure:secure_session
~scope ~sp ())
in
f table (attserget, attserpost);
n)
| (Ocsigen_http_frame.Http_header.GET,
Eliom_common.SAtt_csrf_safe (id, scope, secure_session),
_) ->
let tablereg, forsession =
match table with
| Left globtbl -> globtbl, false
| Right (sp, ct, sec) ->
if secure_session <> sec || ct <> scope
then raise
Wrong_session_table_for_CSRF_safe_coservice;
!(Eliom_state.get_session_service_table
?secure:secure_session ~scope ~sp ()), true
in
Eliom_service.set_delayed_get_or_na_registration_function
tablereg
id
(fun ~sp ->
let n = Eliom_service.new_state () in
let attserget = Eliom_common.SAtt_anon n in
let table =
if forsession
then tablereg
else
(* we do not register in global table,
but in the table specified while creating
the csrf safe service *)
!(Eliom_state.get_session_service_table
?secure:secure_session ~scope ~sp ())
in
f table (attserget, attserpost);
n)
| _ ->
let tablereg =
match table with
| Left globtbl -> globtbl
| Right (sp, scope, secure_session) ->
!(Eliom_state.get_session_service_table
?secure:secure_session ~scope ~sp ())
in
f tablereg (attserget, attserpost))
| `Nonattached naser ->
let na_name = get_na_name_ naser in
let f table na_name =
Eliommod_naservices.add_naservice
table
na_name
((match get_max_use_ service with
| None -> None
| Some i -> Some (ref i)),
(match get_timeout_ service with
| None -> None
| Some t -> Some (t, ref (t +. Unix.time ()))),
(fun sp ->
Lwt.with_value Eliom_common.sp_key (Some sp)
(fun () ->
let ri = Eliom_request_info.get_ri_sp sp in
catch
(fun () ->
reconstruct_params
~sp
(get_get_params_type_ service)
(Some (Lwt.return (force ri.ri_get_params)))
(Some (Lwt.return []))
false
None
>>= fun g ->
let post_params =
Eliom_request_info.get_post_params_sp sp
in
let files = Eliom_request_info.get_files_sp sp in
reconstruct_params
~sp
(get_post_params_type_ service)
post_params
files
false
None
>>= fun p ->
check_process_redir sp check_before service >>= fun () ->
page_generator g p)
(function
| Eliom_common.Eliom_Typing_Error l ->
error_handler l
| e -> fail e) >>= fun content ->
send_with_cookies sp pages
?options
?charset
?code
?content_type
?headers
content)
))
in
match na_name with
| Eliom_common.SNa_get_csrf_safe (id, scope, secure_session) ->
(* CSRF safe coservice: we'll do the registration later *)
let tablereg, forsession =
match table with
| Left globtbl -> globtbl, false
| Right (sp, ct, sec) ->
if secure_session <> sec || ct <> scope
then raise
Wrong_session_table_for_CSRF_safe_coservice;
!(Eliom_state.get_session_service_table
?secure:secure_session ~scope ~sp ()), true
in
set_delayed_get_or_na_registration_function
tablereg
id
(fun ~sp ->
let n = Eliom_service.new_state () in
let na_name = Eliom_common.SNa_get' n in
let table =
if forsession
then tablereg
else
(* we do not register in global table,
but in the table specified while creating
the csrf safe service *)
!(Eliom_state.get_session_service_table
?secure:secure_session ~scope ~sp ())
in
f table na_name;
n)
| Eliom_common.SNa_post_csrf_safe (id, scope, secure_session) ->
(* CSRF safe coservice: we'll do the registration later *)
let tablereg, forsession =
match table with
| Left globtbl -> globtbl, false
| Right (sp, ct, sec) ->
if secure_session <> sec || ct <> scope
then raise
Wrong_session_table_for_CSRF_safe_coservice;
!(Eliom_state.get_session_service_table
?secure:secure_session ~scope ~sp ()), true
in
set_delayed_get_or_na_registration_function
tablereg
id
(fun ~sp ->
let n = Eliom_service.new_state () in
let na_name = Eliom_common.SNa_post' n in
let table =
if forsession
then tablereg
else
(* we do not register in global table,
but in the table specified while creating
the csrf safe service *)
!(Eliom_state.get_session_service_table
?secure:secure_session ~scope ~sp ())
in
f table na_name;
n)
| _ ->
let tablereg =
match table with
| Left globtbl -> globtbl
| Right (sp, scope, secure_session) ->
!(Eliom_state.get_session_service_table
?secure:secure_session ~scope ~sp ())
in
f tablereg na_name
end
let send pages
?options
?charset
?code
?content_type
?headers
content =
lwt result =
pages.send
?options
?charset
?code
?content_type
?headers
content
in
Lwt.return (pages.result_of_http_result result)
let register pages
?scope
?options
?charset
?code
?content_type
?headers
?secure_session
~service
?error_handler
page_gen =
let sp = Eliom_common.get_sp_option () in
match scope, sp with
| None, None
| Some `Site, None ->
(match Eliom_common.global_register_allowed () with
| Some get_current_sitedata ->
let sitedata = get_current_sitedata () in
(match get_kind_ service with
| `Attached attser ->
Eliom_common.remove_unregistered
sitedata (get_sub_path_ attser)
| `Nonattached naser ->
Eliom_common.remove_unregistered_na
sitedata (get_na_name_ naser));
register_aux pages
?options
?charset
?code
?content_type
?headers
(Left sitedata.Eliom_common.global_services)
~service ?error_handler page_gen
| _ -> raise
(Eliom_common.Eliom_site_information_not_available
"register"))
| None, Some sp
| Some `Site, Some sp ->
register_aux pages
?options
?charset
?code
?content_type
?headers
?error_handler
(Left (get_global_table ()))
~service
page_gen
| _, None ->
raise (failwith "Missing sp while registering service")
| Some (#Eliom_common.user_scope as scope), Some sp ->
register_aux pages
?options
?charset
?code
?content_type
?headers
?error_handler
(Right (sp, scope, secure_session))
~service page_gen
(* WARNING: if we create a new service without registering it,
we can have a link towards a page that does not exist!!! :-(
That's why I impose to register all service during init.
The only other way I see to avoid this is to impose a syntax extension
like "let rec" for service...
*)
let register_service pages
?scope
?options
?charset
?code
?content_type
?headers
?secure_session
?https
?priority
~path
~get_params
?error_handler
page =
let u = service ?https ?priority ~path ~get_params () in
register pages
?scope
?options
?charset
?code
?content_type
?headers
?secure_session
~service:u ?error_handler page;
u
let register_coservice pages
?scope
?options
?charset
?code
?content_type
?headers
?secure_session
?name
?csrf_safe
?csrf_scope
?csrf_secure
?max_use
?timeout
?https
~fallback
~get_params
?error_handler
page =
let u =
coservice ?name
?csrf_safe
?csrf_scope:(csrf_scope:>Eliom_common.user_scope option)
?csrf_secure
?max_use ?timeout ?https
~fallback ~get_params ()
in
register pages
?scope
?options
?charset
?code
?content_type
?headers
?secure_session
~service:u ?error_handler page;
u
let register_coservice' pages
?scope
?options
?charset
?code
?content_type
?headers
?secure_session
?name
?csrf_safe
?csrf_scope
?csrf_secure
?max_use
?timeout
?https
~get_params
?error_handler
page =
let u =
coservice'
?name
?csrf_safe
?csrf_scope:(csrf_scope:>Eliom_common.user_scope option)
?csrf_secure
?max_use ?timeout ?https ~get_params ()
in
register pages
?scope
?options
?charset
?code
?content_type
?headers
?secure_session
~service:u ?error_handler page;
u
let register_post_service pages
?scope
?options
?charset
?code
?content_type
?headers
?secure_session
?https
?priority
~fallback
~post_params
?error_handler
page_gen =
let u = post_service ?https ?priority
~fallback:fallback ~post_params:post_params () in
register pages
?scope
?options
?charset
?code
?content_type
?headers
?secure_session
~service:u ?error_handler page_gen;
u
let register_post_coservice pages
?scope
?options
?charset
?code
?content_type
?headers
?secure_session
?name
?csrf_safe
?csrf_scope
?csrf_secure
?max_use
?timeout
?https
~fallback
~post_params
?error_handler
page_gen =
let u =
post_coservice ?name
?csrf_safe
?csrf_scope:(csrf_scope:>Eliom_common.user_scope option)
?csrf_secure
?max_use ?timeout ?https
~fallback ~post_params () in
register pages
?scope
?options
?charset
?code
?content_type
?headers
?secure_session
~service:u ?error_handler page_gen;
u
let register_post_coservice' pages
?scope
?options
?charset
?code
?content_type
?headers
?secure_session
?name
?csrf_safe
?csrf_scope
?csrf_secure
?max_use
?timeout
?keep_get_na_params
?https
~post_params
?error_handler
page_gen =
let u =
post_coservice'
?name
?csrf_safe
?csrf_scope:(csrf_scope:>Eliom_common.user_scope option)
?csrf_secure
?keep_get_na_params
?max_use
?timeout
?https
~post_params ()
in
register pages
?scope
?options
?charset
?code
?content_type
?headers
?secure_session
~service:u ?error_handler page_gen;
u
module type REG_PARAM = "sigs/eliom_reg_param.mli"
module MakeRegister(Pages : REG_PARAM) = struct
type page = Pages.page
type options = Pages.options
type return = Pages.return
type result = Pages.result
let pages =
{ send = Pages.send;
send_appl_content = Pages.send_appl_content;
result_of_http_result = Pages.result_of_http_result; }
let send ?options = send pages ?options
let register ?scope = register pages ?scope
let register_service ?scope = register_service pages ?scope
let register_coservice ?scope = register_coservice pages ?scope
let register_coservice' ?scope = register_coservice' pages ?scope
let register_post_service ?scope = register_post_service pages ?scope
let register_post_coservice ?scope = register_post_coservice pages ?scope
let register_post_coservice' ?scope = register_post_coservice' pages ?scope
end
module type REG_PARAM_ALPHA_RETURN =
sig
type ('a, 'b) page
type 'a return
type ('a, 'b) result
include "sigs/eliom_reg_param.mli"
subst type page := ('a, 'b) page
and type return := 'b return
and type result := ('a, 'b) result
end
module MakeRegister_AlphaReturn(Pages : REG_PARAM_ALPHA_RETURN) = struct
type ('a, 'b) page = ('a, 'b) Pages.page
type options = Pages.options
type 'b return = 'b Pages.return
type ('a, 'b) result = ('a, 'b) Pages.result
let pages =
{ send = Pages.send;
send_appl_content = Pages.send_appl_content;
result_of_http_result = Pages.result_of_http_result; }
let send ?options = send pages ?options
let register ?scope = register pages ?scope
let register_service ?scope = register_service pages ?scope
let register_coservice ?scope = register_coservice pages ?scope
let register_coservice' ?scope = register_coservice' pages ?scope
let register_post_service ?scope = register_post_service pages ?scope
let register_post_coservice ?scope = register_post_coservice pages ?scope
let register_post_coservice' ?scope = register_post_coservice' pages ?scope
end
eliom-3.0.3/src/server/eliom_reference.mli 0000644 0000000 0000000 00000020513 12062377521 016741 0 ustar 00 0000000 0000000 (* Ocsigen
* http://www.ocsigen.org
* Copyright (C) 2010 Vincent Balat
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exception;
* either version 2.1 of the License, or (at your option) any later version.
*
* This program 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
* GNU Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
(** {2 Server side state data, a.k.a Eliom references} *)
(** Eliom references come in two flavors: they may be stored persistently or
the may be volatile. The module [Volatile] allows creation of
references which can be, get, set, modify, and unset volatile references
through {e non-Lwt} functions. *)
type ('a, +'storage) eref'
(** The type of Eliom references whose content is of type ['a]. *)
type 'a eref = ('a, [ `Volatile | `Persistent ]) eref'
(** Exception raised when trying to access an eref
that has not been initaliazed, when we don't want to initialize it. *)
exception Eref_not_intialized
(** The function [eref ~scope value] creates an Eliom reference for
the given [scope] and initialize it with [value]. See the Eliom
manual for more information about {% <>%}.
Use the optional parameter [?persistent] if you want the data to
survive after relaunching the server. You must give an unique name
to the table in which it will be stored on the hard disk (using
Ocsipersist). Be very careful to use unique names, and to change
the name if you change the type of the data, otherwise the server
may crash (unsafe unmarshaling). This parameter has no effect for
scope {!Eliom_common.request}.
Use the optional parameter [~secure:true] if you want the data to
be available only using HTTPS. This parameter has no effect for
scopes {!Eliom_common.global}, {!Eliom_common.site}, and
{!Eliom_common.request}.
{e Warning: Eliom references of scope {!Eliom_common.global}, {!Eliom_common.site} or
{!Eliom_common.request} may be created at any time ; but for other
scopes, they must be created when the site information is
available to Eliom, that is, either during the initialization
phase of the server (while reading the configuration file) or
during a request. Otherwise, it will raise the exception
{!Eliom_common.Eliom_site_information_not_available}. If you are
using static linking, you must delay the call to this function
until the configuration file is read, using
{!Eliom_service.register_eliom_module}. Otherwise you will also
get this exception.}
*)
val eref :
scope:[< Eliom_common.all_scope ] ->
?secure:bool ->
?persistent:string ->
'a ->
'a eref
(** The function [eref_from_fun] works like the above {!Eliom_reference.eref},
but instead of providing a value for the initial content, a function [f] for
{e creating the initial content} is provided (cf. also {!Lazy.lazy_from_fun}).
In each scope, the function [f] is called for creating the value of the
reference the first time the reference is read (by {!Eliom_reference.get}),
if the value has not been set explicitly before (by {!Eliom_reference.set});
or if the reference was reset (by {!Eliom_reference.reset}) before.
*)
val eref_from_fun :
scope:[< Eliom_common.all_scope ] ->
?secure:bool ->
?persistent:string ->
(unit -> 'a) ->
'a eref
(** The function [get eref] returns the current value of the Eliom
reference [eref].
{e Warning: this function cannot be used outside of a service
handler when [eref] has been created with a scope different of
{!Eliom_common.global}; it can neither be used outside of an
Eliom module when [eref] has been created with scope
{!Eliom_common.site}}
*)
val get : 'a eref -> 'a Lwt.t
(* That function introduces a Lwt cooperation point only for persistent
references. *)
(** The function [set eref v] set [v] as current value of the Eliom
reference [eref].
{e Warning: this function could not be used outside af a service
handler when [eref] has been created with a scope different of
{!Eliom_common.global}; it can neither be used outside of an
Eliom module when [eref] has been created with scope
{!Eliom_common.site}}
*)
val set : 'a eref -> 'a -> unit Lwt.t
(* That function introduces a Lwt cooperation point only for persistent
references. *)
(** The function [modify eref f] modifies the content of the Eliom
reference [eref] by applying the function [f] on it.
{e Warning: this function could not be used outside af a service
handler when [eref] has been created with a scope different of
{!Eliom_common.global}; it can neither be used outside of an
Eliom module when [eref] has been created with scope
{!Eliom_common.site}}
*)
val modify : 'a eref -> ('a -> 'a) -> unit Lwt.t
(* That function introduces a Lwt cooperation point only for persistent
references. *)
(** The function [unset eref] reset the content of the Eliom reference
[eref] to its initial value.
{e Warning: this function could not be used outside af a service
handler when [eref] has been created with a scope different of
{!Eliom_common.global}; it can neither be used outside of an
Eliom module when [eref] has been created with scope
{!Eliom_common.site}}
*)
val unset : 'a eref -> unit Lwt.t
(* That function introduces a Lwt cooperation point only for persistent
references. *)
(** Same functions as in [Eliom_reference] but a non-Lwt interface
for non-persistent Eliom references. *)
module Volatile : sig
(** The type of volatile Eliom references.
Note that [('a Eliom_reference.Volatile.eref :> 'a Eliom_reference.eref)], i.e. whereever you can use an ['a
Eliom_reference.eref] you can also use an ['a Eliom_reference.Volatile.eref :> 'a Eliom_reference.eref]. *)
type 'a eref = ('a, [`Volatile]) eref'
val eref : scope:[< Eliom_common.all_scope] -> ?secure:bool -> 'a -> 'a eref
val eref_from_fun : scope:[< Eliom_common.all_scope] -> ?secure:bool -> (unit -> 'a) -> 'a eref
val get : 'a eref -> 'a
val set : 'a eref -> 'a -> unit
val modify : 'a eref -> ('a -> 'a) -> unit
val unset : 'a eref -> unit
module Ext : sig
(** This module allows access to volatile references for other groups,
sessions, or client processes.
Use it in conjunction with functions like
{!Eliom_state.Ext.iter_on_all_volatile_data_sessions_from_group}
to get the sessions from a group (or the processes from a session).
*)
(** get the value of a reference from outside the state.
If the value has not been set yet for this state,
it will raise exception [Eref_not_intialized].
*)
val get : ([< `Session_group | `Session | `Client_process ],
[< `Data ]) Eliom_state.Ext.state ->
'a eref -> 'a
val set : ([< `Session_group | `Session | `Client_process ],
[< `Data ]) Eliom_state.Ext.state ->
'a eref -> 'a -> unit
(** Warning: the function will be executed with the current context *)
val modify :
([< `Session_group | `Session | `Client_process ],
[< `Data ]) Eliom_state.Ext.state ->
'a eref -> ('a -> 'a) -> unit
val unset :
([< `Session_group | `Session | `Client_process ],
[< `Data ]) Eliom_state.Ext.state ->
'a eref -> unit
end
end
module Ext : sig
val get : ([< `Session_group | `Session | `Client_process ],
[< `Data | `Pers ]) Eliom_state.Ext.state ->
'a eref -> 'a Lwt.t
val set :
([< `Session_group | `Session | `Client_process ],
[< `Data | `Pers ]) Eliom_state.Ext.state ->
'a eref -> 'a -> unit Lwt.t
val modify :
([< `Session_group | `Session | `Client_process ],
[< `Data | `Pers ]) Eliom_state.Ext.state ->
'a eref -> ('a -> 'a) -> unit Lwt.t
val unset :
([< `Session_group | `Session | `Client_process ],
[< `Data | `Pers ]) Eliom_state.Ext.state ->
'a eref -> unit Lwt.t
end
eliom-3.0.3/src/server/eliom_service.ml 0000644 0000000 0000000 00000052252 12062377521 016277 0 ustar 00 0000000 0000000 (* Ocsigen
* http://www.ocsigen.org
* Copyright (C) 2007 Vincent Balat
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exception;
* either version 2.1 of the License, or (at your option) any later version.
*
* This program 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
* GNU Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
open Eliom_lib
open Eliom_content_core
open Eliom_state
open Eliom_parameter
open Lwt
open Lazy
(* Manipulation of services - this code can be use only on server side. *)
include Eliom_service_base
exception Wrong_session_table_for_CSRF_safe_coservice
(*********)
(* If there is a client side process, we do an XHR with tab cookies *)
let xhr_with_cookies s =
if is_external s then
None
else
match s.send_appl_content with
| XAlways -> Some None
| XNever -> None (* actually this will be tested again later
in get_onload_form_creators *)
| XSame_appl (_, tmpl) -> Some tmpl (* Some an = current_page_appl_name *)
(* for now we do not know the current_page_appl_name.
We will know it only after calling send.
In case it is not the same name, we will not send the
onload_form_creator_info.
*)
(**********)
let new_state = Eliommod_cookies.make_new_session_id
(* WAS:
(* This does not need to be cryptographickly robust.
We just want to avoid the same values when the server is relaunched.
*)
let c = ref (Int64.bits_of_float (Unix.gettimeofday ())) in
fun () ->
c := Int64.add !c Int64.one ;
(Printf.sprintf "%x" (Random.int 0xFFFF))^(Printf.sprintf "%Lx" !c)
But I turned this into cryptographickly robust version
to implement CSRF-safe services.
*)
let get_or_post_ s = match s.get_or_post with
| `Get -> Ocsigen_http_frame.Http_header.GET
| `Post -> Ocsigen_http_frame.Http_header.POST
(*****************************************************************************)
(*****************************************************************************)
(* Registration of static module initialization functions *)
(*****************************************************************************)
(*****************************************************************************)
let register_eliom_module name f =
Ocsigen_loader.set_module_init_function name f
(*****************************************************************************)
(*****************************************************************************)
(* Page registration, handling of links and forms *)
(*****************************************************************************)
(*****************************************************************************)
let uniqueid =
let r = ref (-1) in
fun () -> r := !r + 1; !r
(****************************************************************************)
(****************************************************************************)
(** Definition of services *)
let service_aux
~https
~path
?redirect_suffix
?keep_nl_params
?priority
~get_params =
let sp = Eliom_common.get_sp_option () in
match sp with
| None ->
(match Eliom_common.global_register_allowed () with
| Some get_current_sitedata ->
let sitedata = get_current_sitedata () in
let path =
Url.remove_internal_slash
(Url.change_empty_list
(Url.remove_slash_at_beginning path))
in
let u = service_aux_aux
~https
~prefix:""
~path
~site_dir: sitedata.Eliom_common.site_dir
~kind:(`Internal `Service)
~getorpost:`Get
?redirect_suffix
?keep_nl_params
?priority
~get_params
~post_params:unit
()
in
Eliom_common.add_unregistered sitedata path;
u
| None ->
raise (Eliom_common.Eliom_site_information_not_available
"service"))
| Some sp ->
let path =
Url.remove_internal_slash
(Url.change_empty_list
(Url.remove_slash_at_beginning path))
in
service_aux_aux
~https
~prefix:""
~path:path
~site_dir:(Eliom_request_info.get_site_dir_sp sp)
~kind:(`Internal `Service)
~getorpost:`Get
?redirect_suffix
?keep_nl_params
?priority
~get_params
~post_params:unit
()
let service
?(https = false)
~path
?keep_nl_params
?priority
~get_params
() =
let suffix = contains_suffix get_params in
service_aux
~https
~path:(match suffix with
| None -> path
| _ -> path@[Eliom_common.eliom_suffix_internal_name])
?keep_nl_params
?redirect_suffix:suffix
?priority
~get_params
let default_csrf_scope = function
(* We do not use the classical syntax for default
value. Otherwise, the type for csrf_scope was:
[< Eliom_common.user_scope > `Session] *)
| None -> `Session Eliom_common_base.Default_ref_hier
| Some c -> (c :> [Eliom_common.user_scope])
let coservice
?name
?(csrf_safe = false)
?csrf_scope
?csrf_secure
?max_use
?timeout
?(https = false)
~fallback
?keep_nl_params
~get_params
() =
let csrf_scope = default_csrf_scope csrf_scope in
let `Attached k = fallback.kind in
(* (match Eliom_common.global_register_allowed () with
| Some _ -> Eliom_common.add_unregistered k.path;
| _ -> ()); *)
{fallback with
max_use= max_use;
timeout= timeout;
get_params_type = add_pref_params Eliom_common.co_param_prefix get_params;
kind = `Attached
{k with
get_name =
(if csrf_safe
then Eliom_common.SAtt_csrf_safe (uniqueid (),
(csrf_scope:>Eliom_common.user_scope),
csrf_secure)
else
(match name with
| None -> Eliom_common.SAtt_anon (new_state ())
| Some name -> Eliom_common.SAtt_named name));
att_kind = `Internal `Coservice;
get_or_post = `Get;
};
https = https || fallback.https;
keep_nl_params = match keep_nl_params with
| None -> fallback.keep_nl_params | Some k -> k;
}
(* Warning: here no GET parameters for the fallback.
Preapply services if you want fallbacks with GET parameters *)
let coservice'
?name
?(csrf_safe = false)
?csrf_scope
?csrf_secure
?max_use
?timeout
?(https = false)
?(keep_nl_params = `Persistent)
~get_params
() =
let csrf_scope = default_csrf_scope csrf_scope in
(* (match Eliom_common.global_register_allowed () with
| Some _ -> Eliom_common.add_unregistered_na n;
| _ -> () (* Do we accept unregistered non-attached coservices? *)); *)
(* (* Do we accept unregistered non-attached named coservices? *)
match sp with
| None ->
...
*)
{
(*VVV allow timeout and max_use for named coservices? *)
max_use= max_use;
timeout= timeout;
pre_applied_parameters = String.Table.empty, [];
get_params_type =
add_pref_params Eliom_common.na_co_param_prefix get_params;
post_params_type = unit;
kind = `Nonattached
{na_name =
(if csrf_safe
then Eliom_common.SNa_get_csrf_safe (uniqueid (),
(csrf_scope:>Eliom_common.user_scope),
csrf_secure)
else
match name with
| None -> Eliom_common.SNa_get' (new_state ())
| Some name -> Eliom_common.SNa_get_ name);
na_kind = `Get;
};
https = https;
keep_nl_params = keep_nl_params;
send_appl_content = XNever;
service_mark = service_mark ();
}
(****************************************************************************)
(* Create a service with post parameters in the server *)
let post_service_aux ~https ~fallback
?(keep_nl_params = `None) ?(priority = default_priority) ~post_params =
(* Create a main service (not a coservice) internal, post only *)
(* ici faire une vérification "duplicate parameter" ? *)
let `Attached k1 = fallback.kind in
let `Internal k = k1.att_kind in
{
pre_applied_parameters = fallback.pre_applied_parameters;
get_params_type = fallback.get_params_type;
post_params_type = post_params;
max_use= None;
timeout= None;
kind = `Attached
{prefix = k1.prefix;
subpath = k1.subpath;
fullpath = k1.fullpath;
att_kind = `Internal k;
get_or_post = `Post;
get_name = k1.get_name;
post_name = Eliom_common.SAtt_no;
redirect_suffix = false;
priority;
};
https = https;
keep_nl_params = keep_nl_params;
send_appl_content = XNever;
service_mark = service_mark ();
}
let post_service ?(https = false) ~fallback
?keep_nl_params ?priority ~post_params () =
(* POST service without POST parameters means
that the service will answer to a POST request only.
*)
let `Attached k1 = fallback.kind in
let `Internal kind = k1.att_kind in
let path = k1.subpath in
let sp = Eliom_common.get_sp_option () in
let u = post_service_aux
~https ~fallback ?keep_nl_params ?priority ~post_params in
match sp with
| None ->
(match Eliom_common.global_register_allowed () with
| Some get_current_sitedata ->
Eliom_common.add_unregistered (get_current_sitedata ()) path;
u
| None ->
if kind = `Service
then
raise (Eliom_common.Eliom_site_information_not_available
"post_service")
else u)
| _ -> u
(* if the fallback is a coservice, do we get a coservice or a service? *)
let post_coservice
?name
?(csrf_safe = false)
?csrf_scope
?csrf_secure
?max_use
?timeout
?(https = false)
~fallback
?keep_nl_params
~post_params
() =
let csrf_scope = default_csrf_scope csrf_scope in
let `Attached k1 = fallback.kind in
(* (match Eliom_common.global_register_allowed () with
| Some _ -> Eliom_common.add_unregistered k1.path;
| _ -> ()); *)
{fallback with
post_params_type = post_params;
max_use= max_use;
timeout= timeout;
kind = `Attached
{k1 with
att_kind = `Internal `Coservice;
get_or_post = `Post;
post_name =
(if csrf_safe
then Eliom_common.SAtt_csrf_safe (uniqueid (),
(csrf_scope:>Eliom_common.user_scope),
csrf_secure)
else
(match name with
| None -> Eliom_common.SAtt_anon (new_state ())
| Some name -> Eliom_common.SAtt_named name));
};
https = https;
keep_nl_params = match keep_nl_params with
| None -> fallback.keep_nl_params | Some k -> k;
}
(* It is not possible to make a post_coservice function
with an optional ?fallback parameter
because the type 'get of the result depends on the 'get of the
fallback. Or we must impose 'get = unit ...
*)
let post_coservice'
?name
?(csrf_safe = false)
?csrf_scope
?csrf_secure
?max_use ?timeout
?(https = false)
?(keep_nl_params = `All)
?(keep_get_na_params = true)
~post_params () =
let csrf_scope = default_csrf_scope csrf_scope in
(* match Eliom_common.global_register_allowed () with
| Some _ -> Eliom_common.add_unregistered None
| _ -> () *)
{
(*VVV allow timeout and max_use for named coservices? *)
max_use= max_use;
timeout= timeout;
pre_applied_parameters = String.Table.empty, [];
get_params_type = unit;
post_params_type = post_params;
kind = `Nonattached
{na_name =
(if csrf_safe
then Eliom_common.SNa_post_csrf_safe (uniqueid (),
(csrf_scope:>Eliom_common.user_scope),
csrf_secure)
else
(match name with
| None ->
Eliom_common.SNa_post' (new_state ())
| Some name -> Eliom_common.SNa_post_ name));
na_kind = `Post keep_get_na_params;
};
https = https;
keep_nl_params = keep_nl_params;
send_appl_content = XNever;
service_mark = service_mark ();
}
(*****************************************************************************)
let add_service = Eliommod_services.add_service
let add_naservice = Eliommod_naservices.add_naservice
(*****************************************************************************)
exception Unregistered_CSRF_safe_coservice
let register_delayed_get_or_na_coservice ~sp (k, scope, secure) =
let f =
try
let table = !(Eliom_state.get_session_service_table_if_exists ~sp
~scope:(scope:>Eliom_common.user_scope) ?secure ())
in
Int.Table.find
k table.Eliom_common.csrf_get_or_na_registration_functions
with Not_found ->
let table = Eliom_state.get_global_table () in
try
Int.Table.find
k table.Eliom_common.csrf_get_or_na_registration_functions
with Not_found -> raise Unregistered_CSRF_safe_coservice
in
f ~sp
let register_delayed_post_coservice ~sp (k, scope, secure) getname =
let f =
try
let table = !(Eliom_state.get_session_service_table_if_exists ~sp
~scope:(scope:>Eliom_common.user_scope) ?secure ())
in
Int.Table.find
k table.Eliom_common.csrf_post_registration_functions
with Not_found ->
let table = Eliom_state.get_global_table () in
try
Int.Table.find
k table.Eliom_common.csrf_post_registration_functions
with Not_found -> raise Unregistered_CSRF_safe_coservice
in
f ~sp getname
let set_delayed_get_or_na_registration_function tables k f =
tables.Eliom_common.csrf_get_or_na_registration_functions <-
Int.Table.add
k
f
tables.Eliom_common.csrf_get_or_na_registration_functions
let set_delayed_post_registration_function tables k f =
tables.Eliom_common.csrf_post_registration_functions <-
Int.Table.add
k
f
tables.Eliom_common.csrf_post_registration_functions
(*****************************************************************************)
let remove_service table service =
match get_kind_ service with
| `Attached attser ->
let key_kind = get_or_post_ attser in
let attserget = get_get_name_ attser in
let attserpost = get_post_name_ attser in
let sgpt = get_get_params_type_ service in
let sppt = get_post_params_type_ service in
Eliommod_services.remove_service table
(get_sub_path_ attser)
{Eliom_common.key_state = (attserget, attserpost);
Eliom_common.key_kind = key_kind}
(if attserget = Eliom_common.SAtt_no
|| attserpost = Eliom_common.SAtt_no
then (anonymise_params_type sgpt,
anonymise_params_type sppt)
else (0, 0))
| `Nonattached naser ->
let na_name = get_na_name_ naser in
Eliommod_naservices.remove_naservice table na_name
let unregister ?scope ?secure service =
let sp = Eliom_common.get_sp_option () in
match scope with
| None
| Some `Site ->
let table =
match sp with
| None ->
(match Eliom_common.global_register_allowed () with
| Some get_current_sitedata ->
let sitedata = get_current_sitedata () in
sitedata.Eliom_common.global_services
| _ -> raise
(Eliom_common.Eliom_site_information_not_available
"unregister"))
| Some sp -> get_global_table ()
in
remove_service table service
| Some (#Eliom_common.user_scope as scope) ->
match sp with
| None ->
raise (failwith "Unregistering service for non global scope must be done during a request")
| Some sp ->
let table =
!(Eliom_state.get_session_service_table ~sp ?secure ~scope ())
in
remove_service table service
(*****************************************************************************)
let pre_wrap s =
{s with
get_params_type = Eliom_parameter.wrap_param_type s.get_params_type;
post_params_type = Eliom_parameter.wrap_param_type s.post_params_type;
}
(* let wrap s = Eliom_types.wrap_parameters (pre_wrap s) *)
(******************************************************************************)
(* Global data *)
let get_global_data, modify_global_data =
(* We have to classify global data from ocsigen extensions (no site
available) and eliommodules (site data available).
Furthermore, the Eliom services must only send global data from
ocsigen extensions and their own site. *)
let global_data = ref String_map.empty in
let site_data = Eliom_reference.Volatile.eref ~scope:Eliom_common.site_scope String_map.empty in
let is_site_available () =
(* Matches valid states for Eliom_common.get_site_data *)
Eliom_common.(get_sp_option () <> None || during_eliom_module_loading ())
in
let get () =
if is_site_available () then
String_map.merge
(fun compilation_unit_id global site ->
match global, site with
| None, None -> assert false
| Some data, None | None, Some data -> Some data
| Some _, Some site_data ->
Printf.ksprintf Ocsigen_messages.errlog
"Compilation unit %s linked globally AND as Eliom module"
compilation_unit_id;
Some site_data)
!global_data
(Eliom_reference.Volatile.get site_data)
else
!global_data
in
let modify f =
if is_site_available () then
Eliom_reference.Volatile.modify site_data f
else
global_data := f !global_data
in
get, modify
let current_server_section_data = ref []
let get_compilation_unit_global_data compilation_unit_id =
if not (String_map.mem compilation_unit_id (get_global_data ())) then
( let data = { server_sections_data = Queue.create (); client_sections_data = Queue.create () } in
ignore (modify_global_data (String_map.add compilation_unit_id data)) );
String_map.find compilation_unit_id (get_global_data ())
let close_server_section ~compilation_unit_id =
let { server_sections_data } =
get_compilation_unit_global_data compilation_unit_id
in
Queue.push (List.rev !current_server_section_data)
server_sections_data;
current_server_section_data := []
let close_client_section ~compilation_unit_id injection_data =
let { client_sections_data } =
get_compilation_unit_global_data compilation_unit_id
in
let injection_datum (injection_id, injection_value) =
{ injection_id; injection_value }
in
Queue.push (List.map injection_datum injection_data)
client_sections_data
let get_global_data () =
let on_injection_datum injection_datum =
let injection_value = injection_datum.injection_value () in
{ injection_datum with injection_value }
in
String_map.map
(fun compilation_unit_global_data ->
let client_sections_data = Queue.create () in
Queue.iter
(fun injection_data ->
Queue.push (List.map on_injection_datum injection_data)
client_sections_data)
compilation_unit_global_data.client_sections_data;
{ compilation_unit_global_data with client_sections_data })
(get_global_data ())
(* Request data *)
let request_data : request_data Eliom_reference.Volatile.eref =
Eliom_reference.Volatile.eref ~scope:Eliom_common.request_scope []
let get_request_data () =
List.rev (Eliom_reference.Volatile.get request_data)
(* Register data *)
let is_global = ref false
let register_client_value_data ~closure_id ~instance_id ~args =
let client_value_datum = { closure_id; instance_id; args } in
if !is_global then
if Eliom_common.get_sp_option () = None then
current_server_section_data :=
client_value_datum :: !current_server_section_data
else
raise (Client_value_creation_invalid_context closure_id)
else
Eliom_reference.Volatile.modify request_data
(fun sofar -> client_value_datum :: sofar)
(* Syntax helpers *)
module Syntax_helpers = struct
let escaped_value = Eliom_lib.escaped_value
let client_value closure_id args =
let instance_id = Eliom_lib.fresh_ix () in
register_client_value_data ~closure_id ~instance_id ~args:(to_poly args);
create_client_value
(Client_value_server_repr.create closure_id instance_id)
let close_server_section compilation_unit_id =
close_server_section ~compilation_unit_id
let close_client_section compilation_unit_id =
close_client_section ~compilation_unit_id
let set_global b = is_global := b
end
eliom-3.0.3/src/server/eliom_types.mli 0000644 0000000 0000000 00000004020 12062377521 016142 0 ustar 00 0000000 0000000 (* Ocsigen
* http://www.ocsigen.org
* Module eliom_client_types.ml
* Copyright (C) 2010 Vincent Balat
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exception;
* either version 2.1 of the License, or (at your option) any later version.
*
* This program 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
* GNU Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
(** Types shared by client and server. *)
open Eliom_lib
open Eliom_content_core
type sitedata = {
site_dir: string list;
site_dir_string: string;
}
type server_params
val sp : server_params
(**/**)
type eliom_js_page_data = {
ejs_global_data: global_data option;
ejs_request_data: request_data;
(* Event handlers *)
ejs_event_handler_table: Xml.event_handler_table;
(* Session info *)
ejs_sess_info: Eliom_common.sess_info;
}
type 'a eliom_caml_service_data = {
ecs_request_data: request_data;
ecs_data: 'a;
}
(* the data sent on channels *)
type 'a eliom_comet_data_type = 'a Eliom_wrap.wrapped_value
(*SGO* Server generated onclicks/onsubmits
val a_closure_id : int
val a_closure_id_string : string
val get_closure_id : int
val get_closure_id_string : string
val post_closure_id : int
val post_closure_id_string : string
val eliom_temporary_form_node_name : string
*)
(*POSTtabcookies* forms with tab cookies in POST params:
val add_tab_cookies_to_get_form_id : int
val add_tab_cookies_to_get_form_id_string : string
val add_tab_cookies_to_post_form_id : int
val add_tab_cookies_to_post_form_id_string : string
*)
val encode_eliom_data : 'a -> string
eliom-3.0.3/src/server/eliom_state.mli 0000644 0000000 0000000 00000110204 12062377521 016120 0 ustar 00 0000000 0000000 (* Ocsigen
* http://www.ocsigen.org
* Copyright (C) 2007 Vincent Balat
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exception;
* either version 2.1 of the License, or (at your option) any later version.
*
* This program 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
* GNU Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
(**
Manage server-side state.
{% <>%}
*)
open Eliom_lib
open Ocsigen_extensions
(*****************************************************************************)
(** {2 Managing the state of an application} *)
(** {3 Closing sessions, removing state data and services} *)
(** Delete server-side (vatile and persistent) state data and services
for a session,
a group of sessions, a client process or a request.
Use that function to close a session (using scope [Eliom_common.session]).
Closing a group of sessions will close all sessions in the group.
By default will remove both secure and unsecure data and services, but
if [~secure] is present.
{e Warning: you may also want to unset some request-scoped Eliom references
when discarding a state.}
*)
val discard :
scope:[< Eliom_common.user_scope | Eliom_common.request_scope ] ->
?secure:bool ->
unit ->
unit Lwt.t
(* Discard services and (volatile and persistent) data
for all user and request scopes *)
val discard_all_scopes :
?secure:bool ->
unit ->
unit Lwt.t
(** Remove current state data.
If the optional parameter [?persistent] is not present, will
remove both volatile and persistent data. Otherwise only volatile
or persistent data.
*)
val discard_data :
?persistent:bool ->
scope:[< Eliom_common.user_scope | Eliom_common.request_scope ] ->
?secure:bool ->
unit ->
unit Lwt.t
(** Remove all services registered for the given scope (the default beeing
[`Session]). *)
val discard_services :
scope:[< Eliom_common.user_scope ] ->
?secure:bool ->
unit ->
unit
(*****************************************************************************)
(** {3 State status} *)
(** The following functions return the current state of the state for a given
scope:
- [Alive_state] means that data has been recorded for this scope
- [Empty_state] means that there is no data for this scope
- [Expired_state] means that data for this scope has been removed
because the timeout has been reached.
The default scope is [`Session].
*)
type state_status = Alive_state | Empty_state | Expired_state
val service_state_status :
scope:[< Eliom_common.user_scope ] ->
?secure:bool ->
unit -> state_status
val volatile_data_state_status :
scope:[< Eliom_common.user_scope ] ->
?secure:bool ->
unit -> state_status
val persistent_data_state_status :
scope:[< Eliom_common.user_scope ] ->
?secure:bool ->
unit -> state_status Lwt.t
(*****************************************************************************)
(** {3 User cookies}
If you want to store a client-side state, and ask the browser to
send it back with each request, you can set manually your own cookies.
Usual cookies correspond to scope [`Session] (that is, one browser).
The browser send them with each request to the same Web site.
But Eliom also implements client-side process cookies
(scope [`Client_process]), that behave in the same way,
but for one instance of the client-side Eliom program (if there is one).
Cookies can be limited to a subsite using the [?path] optional
parameter. This path is relative to the main path of your Web site.
(It is not possible to set a cookie for a subsite larger than your current
Web site).
Cookies can have an expiration date, specified (in seconds
since the 1st of January 1970) in the optional parameter [?exp].
If the parameter is not set,
the expiration date will be when the browser is closed.
Secure cookies are sent by the browser only with HTTPS (default: [false]).
*)
(** Ask the browser to record a cookie. *)
val set_cookie :
?cookie_level:Eliom_common.cookie_level ->
?path:string list ->
?exp:float ->
?secure:bool -> name:string -> value:string -> unit -> unit
(** Ask the browser to remove a cookie. *)
val unset_cookie :
?cookie_level:Eliom_common.cookie_level ->
?path:string list ->
name:string -> unit -> unit
(*****************************************************************************)
(** {2 Session groups} *)
(** If your Web site has users,
it is a good idea to group together all the sessions for one user.
Otherwise, you may want to group sessions according to another
criterion.
Session groups may be used for example to limit
the number of sessions one user can open at the same time, or to implement
a "close all your sessions" feature.
Usually, the group is the user name.
*)
(** {3 Putting a session in a group, removing a session from a group} *)
(** sets the group to which belong the service session.
If the optional [?set_max] parameter is present, also sets the
maximum number of sessions in the group. Default: follow current
configuration for the group or default configuration if the group
does not exist.
If [~secure] is false when the protocol is https, it will affect
the unsecure session. Otherwise, il will affect the secure session in
https, the unsecure one in http.
*)
val set_service_session_group :
?set_max: int ->
?scope:Eliom_common.session_scope ->
?secure:bool ->
string ->
unit
(** Remove the session from its group.
Will not close the session if it contains data. *)
val unset_service_session_group :
?set_max: int ->
?scope:Eliom_common.session_scope ->
?secure:bool ->
unit ->
unit
(** returns the group to which belong the service session.
If the session does not belong to any group,
or if no session is opened, return [None].
*)
val get_service_session_group :
?scope:Eliom_common.session_scope ->
?secure:bool ->
unit ->
string option
(** returns the number of sessions in the group. If he session does not
belong to any group or if no session is opened, returns [None] *)
val get_service_session_group_size :
?scope:Eliom_common.session_scope ->
?secure:bool ->
unit ->
int option
(** sets the group to which belong the volatile data session.
If the optional [?set_max] parameter is present, also sets the maximum
number of sessions in the group.
Default: follow current configuration for the group
or default configuration if the group does not exist.
*)
val set_volatile_data_session_group :
?set_max: int ->
?scope:Eliom_common.session_scope ->
?secure:bool ->
string ->
unit
(** Remove the session from its group.
Will not close the session if it contains data. *)
val unset_volatile_data_session_group :
?set_max: int ->
?scope:Eliom_common.session_scope ->
?secure:bool ->
unit ->
unit
(** returns the group to which belong the data session.
If the session does not belong to any group, or if no session is opened,
return [None].
*)
val get_volatile_data_session_group :
?scope:Eliom_common.session_scope ->
?secure:bool ->
unit ->
string option
(** returns the number of sessions in the group. If he session does not
belong to any group or if no session is opened, returns [None] *)
val get_volatile_data_session_group_size :
?scope:Eliom_common.session_scope ->
?secure:bool ->
unit ->
int option
(** sets the group to which belong the persistent session.
If the optional [?set_max] parameter is present, also sets the
maximum number of sessions in the group. When [~set_max:None] is
present, the number of session is unlimited. Default: follow
current configuration for the group or default configuration if
the group does not exist.
*)
val set_persistent_data_session_group :
?set_max: int option ->
?scope:Eliom_common.session_scope ->
?secure:bool ->
string ->
unit Lwt.t
(** Remove the session from its group.
Will not close the session if it contains data. *)
val unset_persistent_data_session_group :
?scope:Eliom_common.session_scope ->
?secure:bool ->
unit ->
unit Lwt.t
(** returns the group to which belong the persistent session.
If the session does not belong to any group, or if no session is opened,
return [None].
*)
val get_persistent_data_session_group :
?scope:Eliom_common.session_scope ->
?secure:bool ->
unit ->
string option Lwt.t
(** {3 Maximum group size} *)
(** The following functions of this section set the maximum number of
sessions in a session group, for the different kinds of session.
This won't modify existing groups.
That value will be used only as default value if you do not specify the
optional parameter [?set_max] of function
{!Eliom_state.set_volatile_data_session_group}.
If there is no group, the number of sessions is limitated by sub network
(which can be a problem for example if the server is behind a
reverse proxy).
It is highly recommended to use session groups!
- Default number of sessions in a group: 5
- Default number of sessions in a sub network: 1000000
- Default IPV4 sub network: /16
- Default IPV6 sub network: /56
These default can be changed from configuration file and/or
using these functions.
If [~override_configfile] is [true] (default ([false]),
then the function will set the value even if it has been
modified in the configuration file.
It means that by default, these functions have no effect
if there is a value in the configuration file.
This gives the ability to override the values chosen by the module
in the configuration file.
Use [~override_configfile:true] for example if your
Eliom module wants to change the values afterwards
(for example in the site configuration Web interface).
*)
(** Sets the maximum number of service sessions in a session group
(see above).
*)
val set_default_max_service_sessions_per_group :
?override_configfile:bool -> int -> unit
(** Sets the maximum number of volatile data sessions in a session
group (see above).
*)
val set_default_max_volatile_data_sessions_per_group :
?override_configfile:bool -> int -> unit
(** Sets the maximum number of persistent data sessions in a session
group (see above). [None] means "no limitation".
*)
val set_default_max_persistent_data_sessions_per_group :
?override_configfile:bool -> int option -> unit
(** Sets the maximum number of volatile sessions (data and service) in a session
group (see above).
*)
val set_default_max_volatile_sessions_per_group :
?override_configfile:bool -> int -> unit
(** Sets the maximum number of service sessions in a subnet (see above).
*)
val set_default_max_service_sessions_per_subnet :
?override_configfile:bool -> int -> unit
(** Sets the maximum number of volatile data sessions in a subnet (see above).
*)
val set_default_max_volatile_data_sessions_per_subnet :
?override_configfile:bool -> int -> unit
(** Sets the maximum number of volatile sessions (data and service)
in a subnet (see above).
*)
val set_default_max_volatile_sessions_per_subnet :
?override_configfile:bool -> int -> unit
(** Sets the maximum number of tab service sessions in a session group
(see above).
*)
val set_default_max_service_tab_sessions_per_group :
?override_configfile:bool -> int -> unit
(** Sets the maximum number of volatile data tab sessions in a session
group (see above).
*)
val set_default_max_volatile_data_tab_sessions_per_group :
?override_configfile:bool -> int -> unit
(** Sets the maximum number of persistent data tab sessions in a session
group (see above).
*)
val set_default_max_persistent_data_tab_sessions_per_group :
?override_configfile:bool -> int option -> unit
(** Sets the maximum number of volatile tab sessions (data and service)
in a session group (see above).
*)
val set_default_max_volatile_tab_sessions_per_group :
?override_configfile:bool -> int -> unit
(** Sets the mask for subnet (IPV4). *)
val set_ipv4_subnet_mask :
?override_configfile:bool -> int32 -> unit
(** Sets the mask for subnet (IPV6). *)
val set_ipv6_subnet_mask :
?override_configfile:bool -> int64 * int64 -> unit
(** Sets the maximum number of service sessions in the current session
group (or for the client sub network, if there is no group).
*)
val set_max_service_states_for_group_or_subnet :
scope:Eliom_common.user_scope ->
?secure:bool ->
int ->
unit
(** Sets the maximum number of volatile data sessions in the current session
group (or for the client sub network, if there is no group).
*)
val set_max_volatile_data_states_for_group_or_subnet :
scope:Eliom_common.user_scope ->
?secure:bool ->
int ->
unit
(** Sets the maximum number of volatile sessions
(both data and service sessions) in the current
group (or for the client sub network, if there is no group).
*)
val set_max_volatile_states_for_group_or_subnet :
scope:Eliom_common.user_scope ->
?secure:bool ->
int ->
unit
(** {2 Expiration of cookies and timeouts} *)
(** {3 Cookie expiration} *)
(** The functions in this section ask the browser to set the state cookie
expiration date, for the different kinds of session, in seconds,
since the 1st of January 1970. [None] means the cookie will expire
when the browser is closed. Note: there is no way to set cookies
for an infinite time on browsers.
By default, it will affect regular browser cookies (sessions).
But if you set [~cookie_level:`Client_process],
it will only affect the client-side Eliom process (if there is one),
which simulates some kind of "tab cookies".
*)
(** Sets the cookie expiration date for the current service state
(see above).
*)
val set_service_cookie_exp_date :
cookie_scope:Eliom_common.cookie_scope ->
?secure:bool ->
float option ->
unit
(** Sets the cookie expiration date for the current data state (see
above).
*)
val set_volatile_data_cookie_exp_date :
cookie_scope:Eliom_common.cookie_scope ->
?secure:bool ->
float option ->
unit
(** Sets the cookie expiration date for the persistent state (see
above).
*)
val set_persistent_data_cookie_exp_date :
cookie_scope:Eliom_common.cookie_scope ->
?secure:bool ->
float option ->
unit Lwt.t
(** {3 Global configuration of state timeouts} *)
(** The following functions set the timeout for states, for the
different kinds of states. States will be closed after
this amount of time of inactivity from the user. [None] means no
timeout.
The optional parameter [?recompute_expdates] is [false] by
default. If you set it to [true], the expiration dates for all
states in the table will be recomputed with the new timeout.
That is, the difference between the new timeout and the old one
will be added to their expiration dates (asynchronously,
by another Lwt thread, as this can take a long time).
States whose timeout has been set individually with
functions like
{!Eliom_state.set_volatile_data_state_timeout} won't be affected.
If [~scope_hierarchy] is not present,
it is the default for all scope hierarchies,
and in that case [recompute_expdates] is ignored. [~scope_hierarchy:None]
means the default scope hierarchy.
If [~override_configfile] is [true] (default ([false]),
then the function will set the timeout even if it has been
modified in the configuration file.
It means that by default, these functions have no effect
if there is a value in the configuration file.
This gives the ability to override the values chosen by the module
in the configuration file.
Use [~override_configfile:true] for example if your
Eliom module wants to change the values afterwards
(for example in the site configuration Web interface).
*)
(** Sets the (server side) timeout for volatile (= "in memory") sessions (both
service session and volatile data session).
*)
val set_global_volatile_state_timeout :
cookie_scope:[< Eliom_common.cookie_scope ] ->
?secure: bool ->
?recompute_expdates:bool ->
?override_configfile:bool ->
float option -> unit
val set_default_global_service_state_timeout :
cookie_level:[< Eliom_common.cookie_level ] ->
?override_configfile:bool ->
float option -> unit
(** Sets the (server side) timeout for service states.
*)
val set_global_service_state_timeout :
cookie_scope:[< Eliom_common.cookie_scope ] ->
?secure: bool ->
?recompute_expdates:bool ->
?override_configfile:bool ->
float option -> unit
val set_default_global_service_state_timeout :
cookie_level:[< Eliom_common.cookie_level ] ->
?override_configfile:bool ->
float option -> unit
(** Sets the (server side) timeout for volatile (= "in memory") data states.
*)
val set_global_volatile_data_state_timeout :
cookie_scope:[< Eliom_common.cookie_scope ] ->
?secure: bool ->
?recompute_expdates:bool ->
?override_configfile:bool ->
float option -> unit
val set_default_global_volatile_data_state_timeout :
cookie_level:[< Eliom_common.cookie_level ] ->
?override_configfile:bool ->
float option -> unit
(** Sets the (server side) timeout for persistent states.
*)
val set_global_persistent_data_state_timeout :
cookie_scope:[< Eliom_common.cookie_scope ] ->
?secure: bool ->
?recompute_expdates:bool ->
?override_configfile:bool ->
float option -> unit
val set_default_global_persistent_data_state_timeout :
cookie_level:[< Eliom_common.cookie_level ] ->
?override_configfile:bool ->
float option -> unit
(** Returns the (server side) timeout for service states.
*)
val get_global_service_state_timeout :
?secure: bool ->
cookie_scope:[< Eliom_common.cookie_scope ] ->
unit -> float option
(** Returns the (server side) timeout for "volatile data" states.
*)
val get_global_volatile_data_state_timeout :
?secure: bool ->
cookie_scope:[< Eliom_common.cookie_scope ] ->
unit -> float option
(** Returns the (server side) timeout for persistent states.
*)
val get_global_persistent_data_state_timeout :
?secure: bool ->
cookie_scope:[< Eliom_common.cookie_scope ] ->
unit -> float option
(** {3 Personalizing timeouts for current state} *)
(** sets the timeout for service state (server side) for current user,
in seconds. [None] = no timeout *)
val set_service_state_timeout :
cookie_scope:Eliom_common.cookie_scope ->
?secure:bool ->
float option -> unit
(** remove the service state timeout for current user
(and turn back to the default). *)
val unset_service_state_timeout :
cookie_scope:[< Eliom_common.cookie_scope ] ->
?secure:bool ->
unit -> unit
(** returns the timeout for current service state.
[None] = no timeout
*)
val get_service_state_timeout :
cookie_scope:[< Eliom_common.cookie_scope ] ->
?secure:bool ->
unit -> float option
(** sets the (server side) timeout for volatile data state for current user,
in seconds. [None] = no timeout *)
val set_volatile_data_state_timeout :
cookie_scope:[< Eliom_common.cookie_scope ] ->
?secure:bool ->
float option -> unit
(** remove the "volatile data" state timeout for current user
(and turn back to the default). *)
val unset_volatile_data_state_timeout :
cookie_scope:[< Eliom_common.cookie_scope ] ->
?secure:bool ->
unit -> unit
(** returns the timeout for current volatile data state.
[None] = no timeout
*)
val get_volatile_data_state_timeout :
cookie_scope:[< Eliom_common.cookie_scope ] ->
?secure:bool ->
unit -> float option
(** sets the (server side) timeout for persistent state for current user,
in seconds. [None] = no timeout *)
val set_persistent_data_state_timeout :
cookie_scope:[< Eliom_common.cookie_scope ] ->
?secure:bool ->
float option -> unit Lwt.t
(** remove the persistent state timeout for current user
(and turn back to the default). *)
val unset_persistent_data_state_timeout :
cookie_scope:[< Eliom_common.cookie_scope ] ->
?secure:bool ->
unit -> unit Lwt.t
(** returns the persistent state timeout for current user.
[None] = no timeout *)
val get_persistent_data_state_timeout :
cookie_scope:[< Eliom_common.cookie_scope ] ->
?secure:bool ->
unit -> float option Lwt.t
(*****************************************************************************)
(** {2 Administrating server side state} *)
(** {e Warning: Most these functions must be called when the site
information is available, that is, either
during a request or during the initialisation phase of the site.
Otherwise, it will raise the exception
{!Eliom_common.Eliom_site_information_not_available}.
If you are using static linking, you must delay the call to this function
until the configuration file is read, using
{!Eliom_service.register_eliom_module}. Otherwise you will also get
this exception.}
*)
(** The type of (volatile) state data tables. *)
type 'a volatile_table
(** The type of persistent state data tables. *)
type 'a persistent_table
(** Discard all services and persistent and volatile data for every scopes. *)
val discard_everything : unit -> unit Lwt.t
(*CCC missing ~secure? *)
(** Discard all services and persistent and volatile data for one scope. *)
val discard_all :
scope:Eliom_common.user_scope ->
?secure:bool ->
unit ->
unit Lwt.t
(*VVV missing: scope group *)
(*VVV missing ~secure? *)
(** Discard server side data for all clients, for the given scope.
If the optional parameter [?persistent] is not present,
both the persistent and volatile data will be removed.
*)
val discard_all_data :
?persistent:bool ->
scope:Eliom_common.user_scope ->
?secure:bool ->
unit ->
unit Lwt.t
(*VVV missing: scope group *)
(*VVV missing ~secure? *)
(** Remove all services registered for clients for the given scope. *)
val discard_all_services :
scope:Eliom_common.user_scope ->
?secure:bool ->
unit ->
unit Lwt.t
(*VVV missing: scope group *)
(*VVV missing ~secure? *)
module Ext : sig
(** Type used to describe session timeouts *)
type timeout =
| TGlobal (** see global setting *)
| TNone (** explicitly set no timeout *)
| TSome of float (** timeout duration in seconds *)
(** These types are used to get or set information about browser
or process cookies (like timeouts). *)
type service_cookie_info
type data_cookie_info
type persistent_cookie_info
(** The type of states. The first parameter corresponds to the scope level
and the second one to the kind of state (volatile or persistent data,
or service state) *)
type (+'a, +'b) state
(** [volatile_data_group_state ~scope n] returns the state corresponding to
the group named [n] in scope [scope]. *)
val volatile_data_group_state :
?scope:Eliom_common.session_group_scope -> string ->
([> `Session_group ], [> `Data ]) state
(** Same for persistent data *)
val persistent_data_group_state :
?scope:Eliom_common.session_group_scope -> string ->
([> `Session_group ], [> `Pers ]) state
(** Same for services *)
val service_group_state :
?scope:Eliom_common.session_group_scope -> string ->
([> `Session_group ], [> `Service ]) state
(** [current_volatile_session_state ~scope] returns the state corresponding
to current session in scope [scope]. *)
val current_volatile_session_state :
?secure:bool ->
?scope:Eliom_common.session_scope ->
unit ->
([< `Session ], [< `Data ]) state
(** Same for persistent data *)
val current_persistent_session_state :
?secure:bool ->
?scope:Eliom_common.session_scope ->
unit ->
([< `Session ], [< `Pers ]) state Lwt.t
(** Same for services *)
val current_service_session_state :
?secure:bool ->
?scope:Eliom_common.session_scope ->
unit ->
([< `Session ], [< `Service ]) state
(** Discard external states *)
val discard_state : state : ('a, 'b) state -> unit Lwt.t
(** Fold all sessions in a groups, or all client processes in a session. *)
val fold_volatile_sub_states :
state : ([< `Session_group | `Session ],
[< `Data | `Service ] as 'k) state ->
('a -> ([< `Session | `Client_process ], 'k) state -> 'a) ->
'a -> 'a
(** Iter on all sessions in a groups, or all client processes in a session. *)
val iter_volatile_sub_states :
state: ([< `Session_group | `Session ],
[< `Data | `Service ] as 'k) state ->
(([< `Session | `Client_process ], 'k) state -> unit) ->
unit
(** Fold all sessions in a groups, or all client processes in a session. *)
val fold_sub_states :
state : ([< `Session_group | `Session ],
[< `Data | `Pers | `Service ] as 'k) state ->
('a -> ([< `Session | `Client_process ], 'k) state -> 'a Lwt.t) ->
'a -> 'a Lwt.t
(** Iter on all sessions in a groups, or all client processes in a session. *)
val iter_sub_states :
state: ([< `Session_group | `Session ], 'k) state ->
(([< `Session | `Client_process ], 'k) state -> unit Lwt.t) ->
unit Lwt.t
module Low_level : sig
(** Functions to access table data.
Prefer using Eliom references. *)
(** Raises [Not_found] if no data in the table for the cookie. *)
val get_volatile_data :
state:([< `Session_group | `Session | `Client_process ],
[< `Data ]) state ->
table:'a volatile_table ->
'a
(** Fails with lwt exception [Not_found]
if no data in the table for the cookie. *)
val get_persistent_data :
state:([< `Session_group | `Session | `Client_process ],
[< `Pers ]) state ->
table:'a persistent_table ->
'a Lwt.t
val set_volatile_data :
state:([< `Session_group | `Session | `Client_process ],
[< `Data ]) state ->
table:'a volatile_table ->
'a -> unit
(** Fails with lwt exception [Not_found]
if no data in the table for the cookie. *)
val set_persistent_data :
state:([< `Session_group | `Session | `Client_process ],
[< `Pers ]) state ->
table:'a persistent_table ->
'a -> unit Lwt.t
val remove_volatile_data :
state:([< `Session_group | `Session | `Client_process ],
[< `Data ]) state ->
table:'a volatile_table -> unit
val remove_persistent_data :
state:([< `Session_group | `Session | `Client_process ],
[< `Pers ]) state ->
table:'a persistent_table -> unit Lwt.t
end
(** Get the infomration about cookies (timeouts, etc.) *)
val get_service_cookie_info :
([< Eliom_common.cookie_level ], [ `Service ]) state -> service_cookie_info
val get_volatile_data_cookie_info :
([< Eliom_common.cookie_level ], [ `Data ]) state -> data_cookie_info
val get_persistent_cookie_info :
([< Eliom_common.cookie_level ], [ `Pers ]) state ->
persistent_cookie_info Lwt.t
val get_service_cookie_scope :
cookie:service_cookie_info -> Eliom_common.user_scope
val get_volatile_data_cookie_scope : cookie:data_cookie_info ->
Eliom_common.user_scope
val get_persistent_data_cookie_scope :
cookie:persistent_cookie_info -> Eliom_common.user_scope
val set_service_cookie_timeout :
cookie:service_cookie_info -> float option -> unit
val set_volatile_data_cookie_timeout :
cookie:data_cookie_info -> float option -> unit
val set_persistent_data_cookie_timeout :
cookie:persistent_cookie_info -> float option -> unit Lwt.t
val get_service_cookie_timeout :
cookie:service_cookie_info -> timeout
val get_volatile_data_cookie_timeout :
cookie:data_cookie_info -> timeout
val get_persistent_data_cookie_timeout :
cookie:persistent_cookie_info -> timeout
val unset_service_cookie_timeout :
cookie:service_cookie_info -> unit
val unset_volatile_data_cookie_timeout :
cookie:data_cookie_info -> unit
val unset_persistent_data_cookie_timeout :
cookie:persistent_cookie_info -> unit Lwt.t
(** Returns a list containing the names of all session group
that are available for this site. *)
val get_session_group_list : unit -> string list
(** Iterator on all active service cookies.
[Lwt_unix.yield] is called automatically after each iteration.
*)
val iter_service_cookies :
(service_cookie_info -> unit Lwt.t) -> unit Lwt.t
(** Iterator on data cookies. [Lwt_unix.yield] is called automatically
after each iteration.
*)
val iter_volatile_data_cookies :
(data_cookie_info -> unit Lwt.t) -> unit Lwt.t
(** Iterator on persistent cookies. [Lwt_unix.yield] is called automatically
after each iteration. *)
val iter_persistent_data_cookies :
(persistent_cookie_info -> unit Lwt.t) -> unit Lwt.t
(** Iterator on service cookies. [Lwt_unix.yield] is called automatically
after each iteration.
*)
val fold_service_cookies :
(service_cookie_info -> 'b -> 'b Lwt.t) -> 'b -> 'b Lwt.t
(** Iterator on data cookies. [Lwt_unix.yield] is called automatically
after each iteration.
*)
val fold_volatile_data_cookies :
(data_cookie_info -> 'b -> 'b Lwt.t) -> 'b -> 'b Lwt.t
(** Iterator on persistent cookies. [Lwt_unix.yield] is called automatically
after each iteration. *)
val fold_persistent_data_cookies :
(persistent_cookie_info -> 'b -> 'b Lwt.t) -> 'b -> 'b Lwt.t
(**/**)
val untype_state : ('a, 'b) state -> ('c, 'd) state
end
(*****************************************************************************)
(**/**)
(** {3 Session data (deprecated interface)} *)
(** This is the low level interface (deprecated). Use now Eliom references. *)
(** The type used for getting data from a state. *)
type 'a state_data =
| No_data
| Data_session_expired
| Data of 'a
(** {4 In memory state data} *)
(** creates a table in memory where you can store the session data for
all users. (low level)
{e Warning: This functions must be called when the site
information is available, that is, either
during a request or during the initialisation phase of the site.
Otherwise, it will raise the exception
{!Eliom_common.Eliom_site_information_not_available}.
If you are using static linking, you must delay the call to this function
until the configuration file is read, using
{!Eliom_service.register_eliom_module}. Otherwise you will also get
this exception.}
*)
val create_volatile_table :
scope:Eliom_common.user_scope ->
?secure:bool ->
unit -> 'a volatile_table
(** gets session data for the current session (if any). (low level) *)
val get_volatile_data :
table:'a volatile_table ->
unit ->
'a state_data
(** sets session data for the current session. (low level) *)
val set_volatile_data :
table:'a volatile_table ->
'a ->
unit
(** removes session data for the current session
(but does not close the session).
If the session does not exist, does nothing.
(low level)
*)
val remove_volatile_data :
table:'a volatile_table ->
unit ->
unit
(**/**)
(**/**)
(** {4 Persistent state data} *)
(** creates a table on hard disk where you can store the session data for
all users. It uses {!Ocsipersist}. (low level) *)
val create_persistent_table :
scope:Eliom_common.user_scope ->
?secure:bool ->
string -> 'a persistent_table
(** gets persistent session data for the current persistent session (if any).
(low level) *)
val get_persistent_data :
table:'a persistent_table ->
unit ->
'a state_data Lwt.t
(** sets persistent session data for the current persistent session.
(low level) *)
val set_persistent_data :
table:'a persistent_table ->
'a ->
unit Lwt.t
(** removes session data for the current persistent session
(but does not close the session).
If the session does not exist, does nothing.
(low level)
*)
val remove_persistent_data :
table:'a persistent_table ->
unit ->
unit Lwt.t
(**/**)
(*
(** {3 Default timeouts} *)
(** returns the default timeout for service sessions (server side).
The default timeout is common for all sessions for which no other value
has been set. At the beginning of the server, it is taken from the
configuration file, (or set to default value).
[None] = no timeout.
*)
val get_default_service_session_timeout : unit -> float option
(** returns the default timeout for "volatile data" sessions (server side).
The default timeout is common for all sessions for which no other value
has been set. At the beginning of the server, it is taken from the
configuration file, (or set to default value).
[None] = no timeout.
*)
val get_default_volatile_data_session_timeout : unit -> float option
(** returns the default timeout for sessions (server side).
The default timeout is common for all sessions for which no other value
has been set. At the beginning of the server, it is taken from the
configuration file, (or set to default value).
[None] = no timeout.
*)
val get_default_persistent_data_session_timeout : unit -> float option
(** sets the default timeout for volatile (= "in memory")
sessions (i.e. both service session and volatile data session)
(server side).
[None] = no timeout.
Warning: this function sets the default for all sites. You should
probably use [set_global_volatile_session_timeout] instead.
*)
val set_default_volatile_session_timeout : float option -> unit
(** sets the default timeout for service sessions.
[None] = no timeout.
Warning: this function sets the default for all sites. You should
probably use [set_global_service_session_timeout] instead.
*)
val set_default_service_session_timeout : float option -> unit
(** sets the default timeout for "volatile data" sessions (server side).
[None] = no timeout.
Warning: this function sets the default for all sites. You should
probably use [set_global_volatile_data_session_timeout] instead.
*)
val set_default_volatile_data_session_timeout : float option -> unit
(** sets the default timeout for sessions (server side).
[None] = no timeout.
Warning: this function sets the default for all sites. You should
probably use [set_global_persistent_data_session_timeout] instead.
*)
val set_default_persistent_data_session_timeout : float option -> unit
*)
(*****************************************************************************)
(**/**)
(** {3 Other low level functions}
You probably don't need these functions. *)
(** returns the value of the Eliom's cookies for one persistent session.
Returns [None] is no session is active.
*)
val get_persistent_data_cookie :
cookie_scope:Eliom_common.cookie_scope ->
?secure:bool ->
unit -> string option Lwt.t
(** returns the value of Eliom's cookies for one service session.
Returns [None] is no session is active.
*)
val get_service_cookie :
cookie_scope:Eliom_common.cookie_scope ->
?secure:bool ->
unit -> string option
(** returns the value of Eliom's cookies for one "volatile data" session.
Returns [None] is no session is active.
*)
val get_volatile_data_cookie :
cookie_scope:Eliom_common.cookie_scope ->
?secure:bool ->
unit -> string option
(**/**)
(**/**)
(*****************************************************************************)
val number_of_service_cookies : unit -> int
val number_of_volatile_data_cookies : unit -> int
val number_of_tables : unit -> int
val number_of_table_elements : unit -> int list
val number_of_persistent_data_cookies : unit -> int Lwt.t
val number_of_persistent_tables : unit -> int
val number_of_persistent_table_elements : unit -> (string * int) list Lwt.t
(* Because of Dbm implementation, the result may be less than the expected
result in some case (with a version of ocsipersist based on Dbm) *)
val get_global_table : unit -> Eliom_common.tables
val get_session_service_table :
sp:Eliom_common.server_params ->
scope:Eliom_common.user_scope ->
?secure:bool ->
unit ->
Eliom_common.tables ref
val get_session_service_table_if_exists :
sp:Eliom_common.server_params ->
scope:Eliom_common.user_scope ->
?secure:bool ->
unit ->
Eliom_common.tables ref
val create_volatile_table_during_session_ :
scope:Eliom_common.user_scope ->
secure:bool ->
Eliom_common.sitedata ->
'a volatile_table
eliom-3.0.3/src/server/eliom_lib.ml 0000644 0000000 0000000 00000006226 12062377521 015405 0 ustar 00 0000000 0000000
include Ocsigen_lib
include (Eliom_lib_base : module type of Eliom_lib_base
with type 'a Int64_map.t = 'a Eliom_lib_base.Int64_map.t
with type 'a String_map.t = 'a Eliom_lib_base.String_map.t
with type 'a Int_map.t = 'a Eliom_lib_base.Int_map.t
with type escaped_value = Eliom_lib_base.escaped_value
with type +'a Client_value_server_repr.t = 'a Eliom_lib_base.Client_value_server_repr.t
with type client_value_datum = Eliom_lib_base.client_value_datum
with type 'a injection_datum = 'a Eliom_lib_base.injection_datum
with type 'a compilation_unit_global_data = 'a Eliom_lib_base.compilation_unit_global_data
with type 'a global_data := 'a Eliom_lib_base.global_data
with type request_data = Eliom_lib_base.request_data)
let escaped_value_escaped_value = fst
let debug f = Printf.ksprintf (fun s -> Printf.eprintf "%s\n%!" s) f
let to_json ?typ v =
match typ with
| Some typ -> Deriving_Json.to_string typ v
| None -> assert false (* implemented only client side *)
let of_json ?typ s =
match typ with
| Some typ -> Deriving_Json.from_string typ s
| None -> assert false (* implemented only client side *)
type file_info = Ocsigen_extensions.file_info
let string_escape s =
let l = String.length s in
let b = Buffer.create (4 * l) in
let conv = "0123456789abcdef" in
for i = 0 to l - 1 do
let c = s.[i] in
match c with
'\000' when i = l - 1 || s.[i + 1] < '0' || s.[i + 1] > '9' ->
Buffer.add_string b "\\0"
| '\b' ->
Buffer.add_string b "\\b"
| '\t' ->
Buffer.add_string b "\\t"
| '\n' ->
Buffer.add_string b "\\n"
(*| '\011' -> (* IE<9 doesn't like vertical tab \v *)
Buffer.add_string b "\\v"*)
| '\012' ->
Buffer.add_string b "\\f"
| '\r' ->
Buffer.add_string b "\\r"
| '\'' ->
Buffer.add_string b "\\'"
| '\\' ->
Buffer.add_string b "\\\\"
| '\000' .. '\031' | '\127' .. '\255' | '&' | '<' | '>' ->
let c = Char.code c in
Buffer.add_string b "\\x";
Buffer.add_char b conv.[c lsr 4];
Buffer.add_char b conv.[c land 0xf]
| _ ->
Buffer.add_char b c
done;
Buffer.contents b
let jsmarshal v = string_escape (Marshal.to_string v [])
let wrap_and_marshall_poly : poly -> string =
fun poly ->
string_escape (Marshal.to_string (Eliom_wrap.wrap poly) [])
type 'a client_value =
'a Client_value_server_repr.t * Eliom_wrap.unwrapper
let create_client_value cv =
cv, Eliom_wrap.create_unwrapper
(Eliom_wrap.id_of_int
Eliom_lib_base.client_value_unwrap_id_int)
let client_value_server_repr = fst
exception Client_value_creation_invalid_context of int64
let escaped_value value : escaped_value (* * Eliom_wrap.unwrapper *) =
to_poly value
type global_data = poly Eliom_lib_base.global_data * Eliom_wrap.unwrapper
let global_data_unwrapper =
Eliom_wrap.create_unwrapper
(Eliom_wrap.id_of_int global_data_unwrap_id_int)
eliom-3.0.3/src/server/eliom_extension_template.ml 0000644 0000000 0000000 00000003222 12062377521 020537 0 ustar 00 0000000 0000000 (* Ocsigen
* http://www.ocsigen.org
* Module extensiontemplate.ml
* Copyright (C) 2007 Vincent Balat
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exception;
* either version 2.1 of the License, or (at your option) any later version.
*
* This program 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
* GNU Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
(*****************************************************************************)
(*****************************************************************************)
(* This is an example of extension for Ocsigen *)
(* Take this as a template for writing your own Eliom based
extensions to the Web server *)
(*****************************************************************************)
(*****************************************************************************)
let _ =
Eliom_extension.register_eliom_extension
(fun sp ->
Lwt.return
(Ocsigen_extensions.Ext_found
(fun () ->
let content = "Eliom Extension template page" in
Ocsigen_senders.Text_content.result_of_content
(content, "text/plain"))))
eliom-3.0.3/src/server/eliom_content.mli 0000644 0000000 0000000 00000024010 12062377521 016451 0 ustar 00 0000000 0000000 (* Ocsigen
* http://www.ocsigen.org
* Copyright (C) 2012 Vincent Balat, Benedikt Becker
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exception;
* either version 2.1 of the License, or (at your option) any later version.
*
* This program 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
* GNU Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
(** This module provides the creation of valid XML content, i.e. XML, SVG,
and (X)HTML5.
XML tree manipulation within Eliom is based on the TyXML library
but use a custom representation for XML values (see
{!Xml}). Then, [Eliom_content] redefines the three high level
interfaces ({!Svg}, {!Html5}) that are provided by
TyXML for valid XML tree creation and printing.
Modules {!Eliom_content.Html5}, {!Eliom_content.Svg} contain two
implementing sub-modules: {!Eliom_content.Html5.F} and {!Eliom_content.Html5.D}.
{5 Functional semantics}
The [F] modules provide functions to create elements with {e f}unctional
semantics: On the one hand side, those values do not have an identifier,
which means utilizations of those values are independent of each other.
On the other hand side, they cannot be referred to, neither by client code
when created on the server, nor for usage in the functions of
{% <> %} and
{% <> %}.
{5 DOM semantics}
The [D] modules provide functions to create elements with {e D}OM semantics:
Firstly, they behave like DOM nodes, e.g. they can only be added once to the
DOM tree even when appended several times.
Secondly, those values have an identifier,
which means they can be referred to
on the client side (by [%variable]) or used with the functions in
{% <> %} and
{% <> %}.
In case of doubt, use the modules with DOM-like semantics {!Eliom_content.Html5.D}.
*)
(** Abstract signature for links and forms creation functions. For
concrete instance see {!Html5}, or {!Html_text}. *)
module type Forms = "sigs/eliom_forms.mli"
(** Low-level XML manipulation. *)
module Xml : module type of Eliom_content_core.Xml
with type uri = Eliom_content_core.Xml.uri
and type attrib = Eliom_content_core.Xml.attrib
and type elt = Eliom_content_core.Xml.elt
and type event_handler = Eliom_content_core.Xml.event_handler
and type event_handler_table = Eliom_content_core.Xml.event_handler_table
and type -'a caml_event_handler = 'a Eliom_content_core.Xml.caml_event_handler
(** Building and pretty-printing valid SVG tree. *)
module Svg : module type of Eliom_content_core.Svg
with type uri = Eliom_content_core.Svg.uri
and type 'a attrib = 'a Eliom_content_core.Svg.attrib
and type +'a elt = 'a Eliom_content_core.Svg.elt
(** Building and printing valid (X)HTML5 tree. *)
module Html5 : sig
(** See the Eliom manual for more information on {% <> %} for HTML5 tree manipulated by client/server
application. *)
type +'a elt = 'a Eliom_content_core.Html5.elt
type +'a attrib = 'a Eliom_content_core.Html5.attrib
type uri = Eliom_content_core.Html5.uri
(** Creation of {b F}unctional HTML5 content (copy-able but not referable, see also {% <> %}). *)
module F : sig
(** {2 Content creation}
See {% <> %} *)
open Pervasives
include module type of Eliom_content_core.Html5.F
with type Xml.uri = Xml.uri
and type Xml.event_handler = Xml.event_handler
and type Xml.attrib = Xml.attrib
and type Xml.elt = Xml.elt
with type +'a elt = 'a elt
and type 'a attrib = 'a attrib
and type uri = uri
include "sigs/eliom_html5_forms.mli"
(** Creates an untyped form. *)
val raw_form : ([< Html5_types.form_attrib ], [< Html5_types.form_content_fun ], [> Html5_types.form ]) plus
(** This is an alias to {% <> %}
to avoid the untyped [Eliom_content_core.Html5.F.form]. *)
val form : ?absolute:bool -> ?absolute_path:bool -> ?https:bool -> ?a:Html5_types.form_attrib attrib list ->
service:('get, unit, [< get_service_kind ], [
?hostname:string -> ?port:int -> ?fragment:string -> ?keep_nl_params:[ `All | `Persistent | `None ] ->
?nl_params: Eliom_parameter.nl_params_set -> ?xhr:bool ->
('gn -> Html5_types.form_content elt list) -> [> Html5_types.form ] elt
(** This is an alias to {% <>
%} to avoid the untyped [Eliom_content_core.Html5.F.input]. *)
val input : ?a:Html5_types.input_attrib attrib list -> input_type:[<
| `Url | `Tel | `Text | `Time | `Search | `Password | `Checkbox | `Range | `Radio | `Submit | `Reset | `Number | `Hidden
| `Month | `Week | `File | `Email | `Image | `Datetime_local | `Datetime | `Date | `Color | `Button]
-> ?name:[< string setoneradio ] param_name -> ?value:string -> unit -> [> Html5_types.input ] elt
(** This is an alias to
{% <> %}
to avoid the untyped [Eliom_content_core.Html5.F.select]. *)
val select : ?a:Html5_types.select_attrib attrib list -> name:[< `One of string ] param_name -> string select_opt -> string select_opt list -> [> Html5_types.select ] elt
end
(** Creation of HTML5 content with {b D}OM semantics (referable, see also {% <> %}). *)
module D : sig
(** {2 Content creation}
See {% <> %} *)
open Pervasives
include module type of Eliom_content_core.Html5.D
with type Xml.uri = Xml.uri
and type Xml.event_handler = Xml.event_handler
and type Xml.attrib = Xml.attrib
and type Xml.elt = Xml.elt
with type +'a elt = 'a elt
and type 'a attrib = 'a attrib
and type uri = uri
include "sigs/eliom_html5_forms.mli"
(** Creates an untyped form. *)
val raw_form : ([< Html5_types.form_attrib ], [< Html5_types.form_content_fun ], [> Html5_types.form ]) plus
(** This is an alias to {% <> %}
to avoid the untyped [Eliom_content_core.Html5.D.form]. *)
val form : ?absolute:bool -> ?absolute_path:bool -> ?https:bool -> ?a:Html5_types.form_attrib attrib list ->
service:('get, unit, [< get_service_kind ], [
?hostname:string -> ?port:int -> ?fragment:string -> ?keep_nl_params:[ `All | `Persistent | `None ] ->
?nl_params: Eliom_parameter.nl_params_set -> ?xhr:bool ->
('gn -> Html5_types.form_content elt list) -> [> Html5_types.form ] elt
(** This is an alias to
{% <> %}
to avoid the untyped [Eliom_content_core.Html5.D.input]. *)
val input : ?a:Html5_types.input_attrib attrib list -> input_type:[<
| `Url | `Tel | `Text | `Time | `Search | `Password | `Checkbox | `Range | `Radio | `Submit | `Reset | `Number | `Hidden
| `Month | `Week | `File | `Email | `Image | `Datetime_local | `Datetime | `Date | `Color | `Button]
-> ?name:[< string setoneradio ] param_name -> ?value:string -> unit -> [> Html5_types.input ] elt
(** This is an alias to
{% <> %}
to avoid the untyped [Eliom_content_core.Html5.D.select]. *)
val select : ?a:Html5_types.select_attrib attrib list -> name:[< `One of string ] param_name -> string select_opt -> string select_opt list -> [> Html5_types.select ] elt
end
(** Node identifiers *)
module Id : module type of Eliom_content_core.Html5.Id
with type +'a id = 'a Eliom_content_core.Html5.Id.id
module Custom_data : module type of Eliom_content_core.Html5.Custom_data
with type 'a t = 'a Eliom_content_core.Html5.Custom_data.t
module Printer : module type of Eliom_content_core.Html5.Printer
end
module Html_text : sig
include "sigs/eliom_forms.mli"
subst type uri := string
and type pcdata_elt := string
and type form_elt := string
and type form_content_elt := string
and type form_content_elt_list := string
and type form_attrib_t := string
and type 'a a_elt := string
and type 'a a_content_elt := string
and type 'a a_content_elt_list := string
and type a_attrib_t := string
and type link_elt := string
and type link_attrib_t := string
and type script_elt := string
and type script_attrib_t := string
and type textarea_elt := string
and type textarea_attrib_t := string
and type input_elt := string
and type input_attrib_t := string
and type select_elt := string
and type select_attrib_t := string
and type button_elt := string
and type button_content_elt := string
and type button_content_elt_list := string
and type button_attrib_t := string
and type optgroup_attrib_t := string
and type option_attrib_t := string
and type input_type_t := string
and type button_type_t := string
and type for_attrib := string
end
eliom-3.0.3/src/server/eliom_pervasives.mli 0000644 0000000 0000000 00000004366 12062377521 017202 0 ustar 00 0000000 0000000
open Eliom_pervasives_base
(** This module is automatically open by {v eliomc v} and {v js_of_eliom v}. *)
(** {2 Client values}
See the {% <> %}. *)
(** Client values on the server are created by the syntax [{typ{ expr }}]
in the server section (cf. {% <> %}). They are abstract, but
become concrete once sent to the client. See also {% <> %}. *)
type 'a client_value = 'a Eliom_lib.client_value
(** {2 RPC / Server functions}
See the {% <> %}.*)
(** A value of type [('a, 'b) server_function] is created on the server from a
function ['a -> 'b Lwt.t] and provides a given function on the client side.
See also {% <> %}. *)
type ('a, 'b) server_function
(** [server_function argument_type f] creates a value of type {%
<> %}. This allows
to call [f] from the client. The first argument [argument_type] is
an instance of [Deriving_Json] for the type of the argument. It is
used to safely encode and decode the argument sent to the server.
The optional parameters correspond directly to the optional
parameters of {% <> %}.
See also the {% <> %}.
*)
(* BBB This is not in Eliom_service because it depends on Eliom_registration *)
val server_function :
?scope:[< Eliom_common.scope ] ->
?options:unit ->
?charset:string ->
?code:int ->
?content_type:string ->
?headers:Http_headers.t ->
?secure_session:bool ->
?name:string ->
?csrf_safe:bool ->
?csrf_scope:[< Eliom_common.user_scope ] ->
?csrf_secure:bool ->
?max_use:int ->
?timeout:float ->
?https:bool ->
?error_handler:((string * exn) list -> 'b Lwt.t) ->
'a Deriving_Json.t -> ('a -> 'b Lwt.t) -> ('a, 'b) server_function
eliom-3.0.3/src/server/eliom_wrap.mli 0000644 0000000 0000000 00000003345 12062377521 015760 0 ustar 00 0000000 0000000 (* Ocsigen
* Copyright (C) 2011 Pierre Chambart
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exception;
* either version 2.1 of the License, or (at your option) any later version.
*
* This program 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
* GNU Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
type 'a wrapped_value
(** ['a wrapper] is the type of values to include into a value of type 'a for
it to be wraped specificaly *)
type +'a wrapper
(** [create f] create a new tag that can be included into a value. if
[wrap] is called on a father of a value [v] containing a tag, the
value [v] will be replaced by [f v] before marshaling. *)
val create_wrapper : ( 'a -> 'b ) -> 'a wrapper
(** marshal a value, taking into account the tags. *)
(* == Internals
[wrap v] traverses the OCaml structure of the value [v], replacing
all included values [w] whose last object field (cf. [Obj.field])
is a wrapper created by [create_wrapper f] by [f w].
*)
val wrap : 'a -> 'a wrapped_value
(** a wrapper that do not change the value *)
val empty_wrapper : 'a wrapper
(** unwrap **)
type unwrap_id
type unwrapper
val create_unwrapper : unwrap_id -> unwrapper
val empty_unwrapper : unwrapper
val id_of_int : int -> unwrap_id
eliom-3.0.3/src/server/eliom_content_core.mli 0000644 0000000 0000000 00000025755 12062377521 017502 0 ustar 00 0000000 0000000 (* Ocsigen
* http://www.ocsigen.org
* Copyright (C) 2012 Vincent Balat, Benedikt Becker
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exception;
* either version 2.1 of the License, or (at your option) any later version.
*
* This program 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
* GNU Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
(** See {% <> %} for complete module. *)
(** Low-level XML manipulation. *)
module Xml : sig
(** {2 Base functions}
Cf. {% <> %}. *)
include Xml_sigs.Iterable
(** {2 Unique nodes } *)
(** Unique nodes are XML nodes that are manipulated 'by reference'
when sent to the client part of an Eliom-application: the
created element is allocated only one time in each instance of
an application. See {% <>%} for more
details. *)
(** Event handlers *)
(** Values of type ['a caml_event_handler] represents event handler
build with the [{{ ... }}] syntax (see the Eliom manual for more
information on {% <>%}). Such values are expected
by functions like {!Eliom_service.on_load} or
{!Eliom_content.Html5.a_onclick}. The type parameter is the
type of the javascript event expected by the handler, for
example {% <>%} or {% <>%}. *)
type -'a caml_event_handler constraint 'a = #Dom_html.event
(**/**)
val make_process_node : ?id:string -> elt -> elt
val make_request_node : elt -> elt
val uri_of_fun: (unit -> string) -> uri
(* Building ref tree. *)
type event_handler_table (* Concrete on client-side only. *)
type node_id
val get_node_id : elt -> node_id
val make_event_handler_table : elt -> event_handler_table
val event_handler_of_string : string -> event_handler
val string_of_event_handler : event_handler -> string
val event_handler_of_service :
( [ `A | `Form_get | `Form_post ]
* (bool * string list) option
* string option) option Eliom_lazy.request -> event_handler
val caml_event_handler : ((#Dom_html.event as 'a) Js.t -> unit) Eliom_lib.client_value -> 'a caml_event_handler
val event_handler : (Dom_html.event Js.t -> unit) Eliom_lib.client_value -> event_handler
type racontent =
| RA of acontent
| RACamlEventHandler of Dom_html.event caml_event_handler
| RALazyStr of string Eliom_lazy.request
| RALazyStrL of separator * string Eliom_lazy.request list
val racontent : attrib -> racontent
val lazy_node : ?a:(attrib list) -> ename -> elt list Eliom_lazy.request -> elt
(**/**)
(** [Eliom_content.Xml.wrap page v] is like [Eliom_wrap.wrap v] but
it makes sure that all [elt]s in [v] which are included in
[page] are sent with empty content. This is safe because such
elements will be taken from the DOM on the client either
ways. *)
val wrap : elt -> 'a -> 'a Eliom_wrap.wrapped_value
end
(**/**)
module Eliom_xml : module type of Xml
with type uri = Xml.uri
and type separator = Xml.separator
and type acontent = Xml.acontent
and type attrib = Xml.attrib
and type elt = Xml.elt
and type -'a caml_event_handler = 'a Xml.caml_event_handler
(**/**)
(** Building and pretty-printing valid SVG tree. *)
module Svg : sig
(** See the Eliom manual for more information on{% <> %} for SVG tree manipulated by client/server
application. *)
type +'a elt
type 'a attrib
type uri = Xml.uri
(** Typed interface for building valid SVG tree (functional
semantics). See {% <> %}. *)
module F : Svg_sigs.T with type Xml.uri = Xml.uri
and type Xml.event_handler = Xml.event_handler
and type Xml.attrib = Xml.attrib
and type Xml.elt = Xml.elt
with type 'a elt = 'a elt
and type 'a attrib = 'a attrib
and type uri = uri
(** Typed interface for building valid SVG tree (DOM semantics). See
{% <> %}. *)
module D : Svg_sigs.T with type Xml.uri = Xml.uri
and type Xml.event_handler = Xml.event_handler
and type Xml.attrib = Xml.attrib
and type Xml.elt = Xml.elt
with type 'a elt = 'a elt
and type 'a attrib = 'a attrib
and type uri = uri
(** Node identifiers. *)
module Id : sig
(** The type of global SVG element identifier. *)
type +'a id
(** The function [new_elt_id ()] creates a new HTML5 element
identifier. (see the Eliom manual for more information on {%
<>%}).*)
val new_elt_id: ?global:bool -> unit -> 'a id
(** The function [create_named_elt ~id elt] create a copy of the
element [elt] that will be accessible through the name [id]. *)
val create_named_elt: id:'a id -> 'a elt -> 'a elt
(** The function [create_named_elt elt] is equivalent to
[create_named_elt ~id:(new_elt_id ()) elt]. *)
val create_global_elt: 'a elt -> 'a elt
end
(** SVG printer.
See {% <> %}. *)
module Printer : Xml_sigs.Typed_simple_printer with type 'a elt := 'a F.elt
and type doc := F.doc
end
(** Building and printing valid (X)HTML5 tree. *)
module Html5 : sig
(** See the Eliom manual for more information on {% <> %} for HTML5 tree manipulated by client/server
application. *)
type +'a elt
type +'a attrib
type uri = Xml.uri
(** Typed interface for building valid HTML5 tree (functional
semantics). *)
module F : sig
(** Cf. {% <> %}. *)
module Raw : Html5_sigs.T
with type Xml.uri = Xml.uri
and type Xml.event_handler = Xml.event_handler
and type Xml.attrib = Xml.attrib
and type Xml.elt = Xml.elt
with module Svg := Svg.F
with type +'a elt = 'a elt
and type 'a attrib = 'a attrib
and type uri = uri
include module type of Raw (*BB TODO Hide untyped [input]. *)
(** {2 Event handlers} *)
(** Redefine event handler attributes to simplify their usage. *)
include "sigs/eliom_html5_event_handler.mli"
(**/**)
type ('a, 'b, 'c) lazy_plus =
?a: (('a attrib) list) -> 'b elt Eliom_lazy.request -> ('b elt) list Eliom_lazy.request -> 'c elt
val lazy_form:
([< Html5_types.form_attrib ], [< Html5_types.form_content_fun ], [> Html5_types.form ]) lazy_plus
end
(** Typed interface for building valid HTML5 tree (DOM semantics). *)
module D : sig
(** Cf. {% <> %}. *)
module Raw : Html5_sigs.T
with type Xml.uri = Xml.uri
and type Xml.event_handler = Xml.event_handler
and type Xml.attrib = Xml.attrib
and type Xml.elt = Xml.elt
with module Svg := Svg.D
with type +'a elt = 'a elt
and type 'a attrib = 'a attrib
and type uri = uri
include module type of Raw (*BB TODO Hide untyped [input]. *)
(** {2 Event handlers} *)
(** Redefine event handler attributes to simplify their usage. *)
include "sigs/eliom_html5_event_handler.mli"
(**/**)
type ('a, 'b, 'c) lazy_plus =
?a: (('a attrib) list) -> 'b elt Eliom_lazy.request -> ('b elt) list Eliom_lazy.request -> 'c elt
val lazy_form:
([< Html5_types.form_attrib ], [< Html5_types.form_content_fun ], [> Html5_types.form ]) lazy_plus
end
(** Node identifiers *)
module Id : sig
(** The type of global HTML5 element identifier. *)
type +'a id
(** The function [new_elt_id ()] creates a new global HTML5 element
identifier (see the Eliom manual for more information on {%
<>%}).*)
val new_elt_id: ?global:bool -> unit -> 'a id
(** The function [create_named_elt ~id elt] create a copy of the
element [elt] that will be sent to client with the reference
[id]. *)
val create_named_elt: id:'a id -> 'a elt -> 'a elt
(** The function [create_named_elt elt] is equivalent to
[create_named_elt ~id:(new_elt_id ()) elt]. *)
val create_global_elt: 'a elt -> 'a elt
(**/**)
val have_id: 'a id -> 'b elt -> bool
end
(** Type-safe custom data for HTML5. See the {% <> %}. *)
module Custom_data : sig
(** Custom data with values of type ['a]. *)
type 'a t
(** Create a custom data field by providing string conversion functions.
If the [default] is provided, calls to {% <> %} return that instead of throwing an
exception [Not_found]. *)
val create : name:string -> ?default:'a -> to_string:('a -> string) -> of_string:(string -> 'a) -> unit -> 'a t
(** Create a custom data from a Json-deriving type. *)
val create_json : name:string -> ?default:'a -> 'a Deriving_Json.t -> 'a t
(** [attrib my_data value ] creates a HTML5 attribute for the custom-data
type [my_data] with value [value] for injecting it into an a HTML5 tree
({% <> %}). *)
val attrib : 'a t -> 'a -> [> | `User_data ] attrib
end
(** {{:http://dev.w3.org/html5/html-xhtml-author-guide/}"Polyglot"} HTML5 printer.
See {% <> %}. *)
module Printer : Xml_sigs.Typed_simple_printer with type 'a elt := 'a F.elt
and type doc := F.doc
end
eliom-3.0.3/src/server/eliom_validate_forms.eliom 0000644 0000000 0000000 00000027127 12062377521 020336 0 ustar 00 0000000 0000000 (* Eliom_validate_forms
* Copyright (C) 20010 Simon Castellan
* For ocsigen
* http://www.ocsigen.org
* Laboratoire PPS - CNRS Université Paris Diderot
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exception;
* either version 2.1 of the License, or (at your option) any later version.
*
* This program 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
* GNU Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
(* Eliom_validate_forms
Automatic validation of forms.
This modules provides a form validation system client-side.
It does not replace a check on the server, as data coming
from the client should not be strusted.
The idea is to reuse the information parameters (Eliom_parameter.params_type)
to check whether a form's value is "valid".
So you should enforce verification on the parameters via the user_type parameter.
*)
(* XX: maybe some things should be factorized out of the example. *)
(** Here is a small example : a login box
{[
open Eliom_validate_forms
module App =
Eliom_predefmod.App (
struct
let application_name = "eliom_validate_forms_example"
let params =
{Eliom_predefmod.default_appl_params with
Eliom_predefmod.ap_title = "eliom_validate_forms_example";
Eliom_predefmod.ap_headers =
[XHTML.M.link ~a:[a_href (uri_of_string "style.css"); a_rel [`Stylesheet]] ()];
Eliom_predefmod.ap_container =
Some (None,
fun div -> [div])
}
end)
;;
module Forms = ValidateForms (App)
let login_form = new_service
~path:["test"]
~get_params: unit
()
let string_guard f = user_type ~to_string:(fun s -> s)
~of_string: (fun s -> if not (f s) then failwith "invalid"; s)
let args = (string_guard ((=) "test") "nick" ** string_guard (fun s -> String.length s >= 8) "password")
let validate = App.register_new_service
~path:["validate"]
~get_params: args
(fun sp _ number ->
return
[div [pcdata "You passed!"]])
;;
{client{
let replace_child node new_children =
let rec remove_children () = match Js.Opt.to_option (node##firstChild) with
| Some child -> Dom.removeChild node child; remove_children ()
| None -> ()
in
remove_children ();
List.iter (Dom.appendChild node) new_children
}}
;;
let popup ~sp cl content container =
{{
let container = lookup $ magic: container $ in
Lwt.return
(replace_child container (XHTML.M.toeltl
[span ~a:[a_class $ magic : cl $] [pcdata $ magic : content $]]))
}}
let entry gen_input ?value ?delay ?a ?server_listen ?server_check ~prompt ~sp ~input_type ~name ~id f =
label
[pcdata prompt;
gen_input ?value ?delay ?a ~input_type ?server_listen ?server_check (fun x -> f x id) name;
span ~a:[a_id id] []; br ()]
let _ = App.register
~service:login_form
(fun sp () () ->
let form = Forms.gen_form (fun ~service ~sp f -> App.get_form ~service ~sp f)
(validate, (args, unit)) ~sp
~on_fail: (popup ~sp ["bad"] "Invalid form" "result")
(fun gen_input (nick, password) ->
let entry = entry gen_input ~server_listen: [a_onchange] in
[fieldset ~a:[a_id "fieldset"]
[div ~a:[a_id "result"][];
entry ~prompt: "Nickname:" ~sp ~input_type: `Text ~name: nick ~id: "nick"
~server_check: (fun _ param ->
Lwt_unix.sleep 2. >>= (fun () -> return (param = "asmanur")))
(function
| `Success -> popup ~sp ["ok"] "Nickname correct"
| `Failure -> popup ~sp ["bad"] "Invalid nickname"
| `Loading -> popup ~sp [] "Waiting…");
entry ~prompt: "Password:" ~sp ~input_type: `Password ~name: password ~id: "password"
(function
| `Success -> popup ~sp ["ok"] "valid"
| `Failure -> popup ~sp ["bad"] "Invalid password (must be >= 8 characters long)"
| `Loading -> popup ~sp [] "");
App.string_input ~input_type: `Submit ~value: "Submit" ()]])
in
return [div [form]])
]}
*)
open Lwt
open XHTML.M
open Eliom_parameter
{client{
open Lwt
open Dom_html
open Eliom_client
let lookup ?error name =
Js.Opt.get
(document##getElementById (Js.string name))
(fun () -> failwith (match error with Some s -> s | None -> name))
let coerce f arg =
Js.Opt.get (f arg) (fun () -> failwith "Invalid element")
(* We store some data about the forms in the page, client-side. *)
(* For each form, we have a list of (param_name, validation_code),
that is used when we check that the form is valid before submission. *)
let inputs = ref []
(* Adds a field to the input. Called in [gen_input] *)
let set_field (form: string) (field: string) valid =
let found = ref false in
inputs := List.map (fun (form', l) ->
if form' = form then
(found := true; (form', (field, valid) :: l))
else
(form', l)) !inputs;
if not !found then
inputs := (form, [field, valid]) :: !inputs
(* For a given form, returns the list of
the inputs that are not valid *)
let get_invalids form_name =
Lwt_list.filter_p (fun (name, valid) -> Js.Unsafe.variable valid >|= not)
(try List.assoc form_name !inputs with Not_found -> [])
>|= List.map fst
}}
module ValidateForms (Appl : Eliom_predefmod.XHTMLFORMSSIG ) = struct
(** Status of a validation :
- Loading : used to display a nice message for validation
that may take time : should be empty for fast checks.
- Success : when the input is valid
- Failure : when the input is invalid
*)
module Appl = struct include Appl end
type status = [ `Loading | `Success | `Failure ]
(** Generate a form with automatic validation.
Arguments :
- on_fail : an optional javascript code (of type unit Lwt.t) that is
executed when the whole form is checked but that there is some invalid inputs.
- form_name : an optional name to distinguish between several forms in the same page.
You should specify one if there is more that one form in your page !
- create : the function from Appl to build the form (post_form or get_form)
- a pair (service, args) where service is an eliom service and args
are the post parameters of the service
- the server params
- a function that is called to build the form. In the same way
than Eliom_predefmod.X.post_form takes a function that builds the form
gen_form does the same, except that the function does take on top of the
parameter names, a function, [gen_input] used to generate an input checking its contents.
gen_input takes several arguments :
- the optional value of the input
- delay : optional time (defaults to 100 ms) to wait before checking an input's validity.
- an optional list of attributes
- a mandatory input_type
- an optional list of events to listen on for server-side check (eg. a_onchange, etc.)
- an optional function, checking the contents to see if it is valid. It default
to the function specified in the arguments of the service. But sometimes, you want
to do something that takes time : for instance checking that an user exists in database.
- A function f (server-side) that takes a status and should generate the corresponding
javascript code (of type unit Lwt.t).
- name : the parameter name.
*)
(* TODO:
- provides support for client-side check. We need to wait for
a better support of the inline javascript code
- for now the form checking is done by clicking on a link
because we can't listen on the onsubmit event of a form
thanks to eliom
- We use Eliom_service.set_on_load that means we can be replaced by any user
script and that we may erase one of his, eliom doesn't provide a add_on_load function
- We use some getElementById to get an input's contents. This generates htmlcode with
a lot of useless id's. This should be changed as we can express things like that
{{ fun evt self -> ... }}
- Do some wrappers : gen_get_form, gen_lwt_get_form, ...
*)
let get_id =
let k = ref 0 in fun () -> incr k; !k
let gen_form ?on_fail ?(form_name = "form") create
(service, (get, post)) ~sp form_contents =
let args = get ** post in
let submit = {{
get_invalids $ magic : form_name $ >>= fun invalids ->
if invalids <> [] then
(match $ magic : on_fail $ with
| Some s -> Firebug.console##log (String.concat " " invalids);
Js.Unsafe.variable s
| None -> return ())
else return ()
}}
in
(* List of javascript code to execute on startup.
Basically it fills the inputs list below
*)
let scripts = ref [] in
let gen_input ?value ?(delay = 0.1) ?(a = []) ~input_type
?(server_listen = []) ?server_check f name =
let id = "__eliom_form_" ^ form_name ^ "__" ^
string_of_int (get_id ()) in
let from_string, to_string =
match walk_parameter_tree (Obj.magic name) args with
| Some a -> a
| None -> failwith "Invalid name"
in
let check = match server_check with
| Some f -> f
| None ->
fun _ arg -> return (try ignore (from_string arg); true with _ -> false)
in
(* We generate a service dedicated to checking that this parameter is valid.
It may not be the better way to do this, but eh.
*)
let service = Eliom_predefmod.Ocaml.register_new_post_coservice'
~post_params: (string "params")
~sp
(fun sp _ arg -> check sp arg)
in
(* We use a trick to provide client-side functions in javascript code.
As we need to evaluate [f] on only three values, we do this on the server
and send the resulting javacsript code to the client.
We should use client functions as they are available *)
let handler =
let onloading, onsuccess, onfailure = f `Loading, f `Success, f `Failure in
{{
let elem = coerce CoerceTo.input (lookup $ magic : id $) in
let exec s = Js.Unsafe.variable s in
exec $ magic:onloading $ >>= fun () ->
Lwt_js.sleep $ magic: delay $ >>= (fun () ->
call_caml_service ~service: $ magic:service $ ~sp: $ sp:sp $ ()
(Js.to_string elem##value) >>= (fun b ->
Lwt.catch
(fun () -> if b then exec $ magic : onsuccess $ else exec $ magic : onfailure $)
(fun e -> return ())
>>= (fun _ -> return b)))
}}
in
let () =
scripts :=
{{ set_field $ magic : form_name $ $ magic : name $ $ magic : handler $ }} ::
!scripts in
let a = a_id id :: List.map (fun x -> x handler) server_listen @ a in
Appl.user_type_input to_string ?value ~input_type ~a ~name ()
in
let form_contents = form_contents gen_input in
let form = create
~service
~sp
form_contents
in (* so that side-effects (scripts-filling) take place *)
let _ = Eliom_service.set_on_load ~sp
(String.concat ";\n" !scripts)
in
div [XHTML.M.a ~a:[a_href (uri_of_string "#"); a_onclick submit] [pcdata "Check the form"] ;
form]
;;
end
eliom-3.0.3/src/server/eliom_react.mli 0000644 0000000 0000000 00000007715 12062377521 016112 0 ustar 00 0000000 0000000 (* Ocsigen
* http://www.ocsigen.org
* Copyright (C) 2010
* Raphaël Proust
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exception;
* either version 2.1 of the License, or (at your option) any later version.
*
* This program 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
* GNU Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
(** Propagate events
occurrences from the server to the client and the other way
around. Occurrence propagation is done asynchronously.
The use of this module is pretty much useless without it's client counter
part. *)
(* These two dual files are to be modified together
with compatibility issues in mind. *)
(** Event from server to client. *)
module Down : sig
(** A "Down event" (AKA down-going event) is an event which occurrences are
transmitted asynchronously to the client. Even if they are named "events",
it might be better to consider them as asynchronous server-to-client
edges in the react events dependency graph.
To use this, call function [of_react] on server side,
and just use the returned value as a react event on client side.
Example:
[let e = of_react ... in ... {{ ... React.E.map f %e; ... }}]
*)
(** The abstract type of down events. *)
type 'a t
(** [of_react ?scope ?throttling ?name e] create an
asynchronous edge originating from [e]. The parameters are: [throttling]
for the limit to event propagation rate, [name] for named edges,
[size] for the size of the server side buffer. [scope]
tell which kind of channel this rely on (See [Eliom_comet.create]). *)
val of_react :
?scope:[ ?throttling:float
-> ?name:string
-> ?size:int
-> 'a React.E.t
-> 'a t
end
(** Event from client to server. *)
module Up :
sig
(** Up events are quite different from Down events. Because of the
asymmetrical nature of web programming and because of the reactive model
used, an Up event must be created on the server and wrapped into a
callback (or something the client can build a callback with).
Example of use:
[let e_up = Eliom_react.Up.create
(Eliom_parameter.caml "a" Json.t)
in
... {{ ignore ( %e_up "A") }} ...
]
*)
(** The type of events that, while being "on the server", are triggered by
clients. On the server such an event is /primitive/ (hence the [create]
function) whereas it is /effect-full/ on the client. *)
type 'a t
(** [to_react e] injects the up events [e] into react events so that it can
be manipulated as a standard event. *)
val to_react : 'a t -> 'a React.E.t
(** [create param] creates an Up event.
If [~name] is present, the coservice used to transmit the event will
always have the same name, even if the server is restarted.
[~scope] describes the visibility of the event. By default, it is
[`Site] if it is called during initialisation,
[`Client_process] otherwise.
*)
val create :
?scope:Eliom_common.scope
-> ?name:string
-> ('a, [ `WithoutSuffix ],
[ `One of 'a Eliom_parameter.caml ] Eliom_parameter.param_name)
Eliom_parameter.params_type
-> 'a t
end
module S : sig
module Down : sig
(** The abstract type of down signals. *)
type 'a t
val of_react :
?scope:[ ?throttling:float
-> ?name:string
-> 'a React.S.t
-> 'a t
end
end
eliom-3.0.3/src/server/.depend 0000644 0000000 0000000 00000044243 12062377521 014361 0 ustar 00 0000000 0000000 eliom_bus.cmo : eliom_state.cmi eliom_service.cmi eliom_registration.cmi \
eliom_parameter.cmi eliom_common.cmi eliom_comet_base.cmi eliom_comet.cmi \
eliom_bus.cmi
eliom_bus.cmx : eliom_state.cmx eliom_service.cmx eliom_registration.cmx \
eliom_parameter.cmx eliom_common.cmx eliom_comet_base.cmx eliom_comet.cmx \
eliom_bus.cmi
eliom_bus.cmi : eliom_comet.cmi
eliom_comet_base.cmo : eliom_service.cmi eliom_registration.cmi \
eliom_parameter.cmi eliom_comet_base.cmi
eliom_comet_base.cmx : eliom_service.cmx eliom_registration.cmx \
eliom_parameter.cmx eliom_comet_base.cmi
eliom_comet_base.cmi : eliom_service.cmi eliom_registration.cmi \
eliom_parameter.cmi
eliom_comet.cmo : eliom_wrap.cmi eliom_types.cmi eliom_service.cmi \
eliom_request_info.cmi eliom_registration.cmi eliom_reference.cmi \
eliom_parameter.cmi eliom_lib.cmi eliom_common_base.cmo eliom_common.cmi \
eliom_comet_base.cmi eliom_comet.cmi
eliom_comet.cmx : eliom_wrap.cmx eliom_types.cmx eliom_service.cmx \
eliom_request_info.cmx eliom_registration.cmx eliom_reference.cmx \
eliom_parameter.cmx eliom_lib.cmx eliom_common_base.cmx eliom_common.cmx \
eliom_comet_base.cmx eliom_comet.cmi
eliom_comet.cmi : eliom_common.cmi eliom_comet_base.cmi
eliom_common_base.cmo : eliom_lib_base.cmi eliom_lib.cmi
eliom_common_base.cmx : eliom_lib_base.cmx eliom_lib.cmx
eliom_common.cmo : eliom_wrap.cmi eliom_lib.cmi eliom_common_base.cmo \
eliom_common.cmi
eliom_common.cmx : eliom_wrap.cmx eliom_lib.cmx eliom_common_base.cmx \
eliom_common.cmi
eliom_common.cmi : eliom_wrap.cmi eliom_lib.cmi eliom_common_base.cmo
eliom_config.cmo : private/eliommod.cmo eliom_request_info.cmi \
eliom_common.cmi eliom_config.cmi
eliom_config.cmx : private/eliommod.cmx eliom_request_info.cmx \
eliom_common.cmx eliom_config.cmi
eliom_config.cmi : eliom_common.cmi
eliom_content_core.cmo : eliom_wrap.cmi eliom_lib.cmi eliom_lazy.cmi \
eliom_content_core.cmi
eliom_content_core.cmx : eliom_wrap.cmx eliom_lib.cmx eliom_lazy.cmx \
eliom_content_core.cmi
eliom_content_core.cmi : eliom_wrap.cmi eliom_lib.cmi eliom_lazy.cmi
eliom_content.cmo : eliom_service.cmi eliom_registration_base.cmi \
eliom_parameter.cmi eliom_mkforms.cmi eliom_lib.cmi eliom_lazy.cmi \
eliom_content_core.cmi eliom_content.cmi
eliom_content.cmx : eliom_service.cmx eliom_registration_base.cmx \
eliom_parameter.cmx eliom_mkforms.cmx eliom_lib.cmx eliom_lazy.cmx \
eliom_content_core.cmx eliom_content.cmi
eliom_content.cmi : eliom_service.cmi eliom_parameter.cmi eliom_lib.cmi \
eliom_content_core.cmi
eliom_cookie.cmo : eliom_lib.cmi eliom_cookie.cmi
eliom_cookie.cmx : eliom_lib.cmx eliom_cookie.cmi
eliom_cookie.cmi : eliom_lib.cmi
eliom_cookies_base.cmo : eliom_lib.cmi
eliom_cookies_base.cmx : eliom_lib.cmx
eliom_error_pages.cmo : eliom_lib.cmi eliom_content_core.cmi
eliom_error_pages.cmx : eliom_lib.cmx eliom_content_core.cmx
eliom_extension.cmo : eliom_common.cmi eliom_extension.cmi
eliom_extension.cmx : eliom_common.cmx eliom_extension.cmi
eliom_extension.cmi : eliom_common.cmi
eliom_extension_template.cmo : eliom_extension.cmi
eliom_extension_template.cmx : eliom_extension.cmx
eliom_lazy.cmo : eliom_wrap.cmi eliom_lazy.cmi
eliom_lazy.cmx : eliom_wrap.cmx eliom_lazy.cmi
eliom_lazy.cmi :
eliom_lib_base.cmo : eliom_lazy.cmi eliom_lib_base.cmi
eliom_lib_base.cmx : eliom_lazy.cmx eliom_lib_base.cmi
eliom_lib_base.cmi : eliom_lazy.cmi
eliom_lib.cmo : eliom_wrap.cmi eliom_lib_base.cmi eliom_lib.cmi
eliom_lib.cmx : eliom_wrap.cmx eliom_lib_base.cmx eliom_lib.cmi
eliom_lib.cmi : eliom_wrap.cmi eliom_lib_base.cmi
eliom_mkforms.cmo : eliom_uri.cmi eliom_service.cmi eliom_parameter.cmi \
eliom_lib.cmi eliom_lazy.cmi eliom_common.cmi eliom_mkforms.cmi
eliom_mkforms.cmx : eliom_uri.cmx eliom_service.cmx eliom_parameter.cmx \
eliom_lib.cmx eliom_lazy.cmx eliom_common.cmx eliom_mkforms.cmi
eliom_mkforms.cmi : eliom_service.cmi eliom_parameter.cmi eliom_lib.cmi \
eliom_lazy.cmi
eliom_mkreg.cmo : private/eliommod_services.cmi \
private/eliommod_naservices.cmi private/eliommod_cookies.cmi \
eliom_uri.cmi eliom_state.cmi eliom_service.cmi eliom_request_info.cmi \
eliom_parameter.cmi eliom_lib.cmi eliom_common_base.cmo eliom_common.cmi \
eliom_mkreg.cmi
eliom_mkreg.cmx : private/eliommod_services.cmx \
private/eliommod_naservices.cmx private/eliommod_cookies.cmx \
eliom_uri.cmx eliom_state.cmx eliom_service.cmx eliom_request_info.cmx \
eliom_parameter.cmx eliom_lib.cmx eliom_common_base.cmx eliom_common.cmx \
eliom_mkreg.cmi
eliom_mkreg.cmi : eliom_state.cmi eliom_service.cmi eliom_parameter.cmi \
eliom_lib.cmi eliom_common.cmi
eliom_parameter_base.cmo : eliom_lib.cmi eliom_common.cmi
eliom_parameter_base.cmx : eliom_lib.cmx eliom_common.cmx
eliom_parameter.cmo : eliom_request_info.cmi eliom_parameter_base.cmo \
eliom_lib.cmi eliom_common.cmi eliom_parameter.cmi
eliom_parameter.cmx : eliom_request_info.cmx eliom_parameter_base.cmx \
eliom_lib.cmx eliom_common.cmx eliom_parameter.cmi
eliom_parameter.cmi : eliom_lib.cmi eliom_common.cmi
eliom_pervasives_base.cmo : eliom_service.cmi eliom_parameter.cmi
eliom_pervasives_base.cmx : eliom_service.cmx eliom_parameter.cmx
eliom_pervasives.cmo : eliom_wrap.cmi eliom_registration.cmi \
eliom_pervasives_base.cmo eliom_parameter.cmi eliom_lib.cmi \
eliom_common_base.cmo eliom_pervasives.cmi
eliom_pervasives.cmx : eliom_wrap.cmx eliom_registration.cmx \
eliom_pervasives_base.cmx eliom_parameter.cmx eliom_lib.cmx \
eliom_common_base.cmx eliom_pervasives.cmi
eliom_pervasives.cmi : eliom_pervasives_base.cmo eliom_lib.cmi \
eliom_common.cmi
eliom_process.cmo :
eliom_process.cmx :
eliom_react.cmo : eliom_service.cmi eliom_registration.cmi \
eliom_parameter.cmi eliom_common.cmi eliom_comet.cmi eliom_react.cmi
eliom_react.cmx : eliom_service.cmx eliom_registration.cmx \
eliom_parameter.cmx eliom_common.cmx eliom_comet.cmx eliom_react.cmi
eliom_react.cmi : eliom_parameter.cmi eliom_common.cmi eliom_comet.cmi
eliom_reference.cmo : eliom_state.cmi eliom_request_info.cmi \
eliom_common.cmi eliom_reference.cmi
eliom_reference.cmx : eliom_state.cmx eliom_request_info.cmx \
eliom_common.cmx eliom_reference.cmi
eliom_reference.cmi : eliom_state.cmi eliom_common.cmi
eliom_registration_base.cmo : eliom_uri.cmi eliom_service.cmi \
eliom_parameter.cmi eliom_mkforms.cmi eliom_lib.cmi eliom_lazy.cmi \
eliom_content_core.cmi eliom_config.cmi eliom_registration_base.cmi
eliom_registration_base.cmx : eliom_uri.cmx eliom_service.cmx \
eliom_parameter.cmx eliom_mkforms.cmx eliom_lib.cmx eliom_lazy.cmx \
eliom_content_core.cmx eliom_config.cmx eliom_registration_base.cmi
eliom_registration_base.cmi : eliom_service.cmi eliom_parameter.cmi \
eliom_lib.cmi eliom_content_core.cmi
eliom_registration.cmo : private/eliommod_pagegen.cmi \
private/eliommod_cookies.cmi private/eliommod_cli.cmi eliom_types.cmi \
eliom_state.cmi eliom_service.cmi eliom_request_info.cmi \
eliom_registration_base.cmi eliom_reference.cmi eliom_parameter.cmi \
eliom_mkreg.cmi eliom_lib.cmi eliom_content_core.cmi eliom_content.cmi \
eliom_config.cmi eliom_common_base.cmo eliom_common.cmi \
eliom_registration.cmi
eliom_registration.cmx : private/eliommod_pagegen.cmx \
private/eliommod_cookies.cmx private/eliommod_cli.cmx eliom_types.cmx \
eliom_state.cmx eliom_service.cmx eliom_request_info.cmx \
eliom_registration_base.cmx eliom_reference.cmx eliom_parameter.cmx \
eliom_mkreg.cmx eliom_lib.cmx eliom_content_core.cmx eliom_content.cmx \
eliom_config.cmx eliom_common_base.cmx eliom_common.cmx \
eliom_registration.cmi
eliom_registration.cmi : eliom_service.cmi eliom_parameter.cmi eliom_lib.cmi \
eliom_content_core.cmi eliom_content.cmi eliom_common.cmi
eliom_request_info.cmo : eliom_lib.cmi eliom_common.cmi \
eliom_request_info.cmi
eliom_request_info.cmx : eliom_lib.cmx eliom_common.cmx \
eliom_request_info.cmi
eliom_request_info.cmi : eliom_lib.cmi eliom_common.cmi
eliom_service_base.cmo : eliom_request_info.cmi eliom_parameter.cmi \
eliom_lib.cmi eliom_common.cmi
eliom_service_base.cmx : eliom_request_info.cmx eliom_parameter.cmx \
eliom_lib.cmx eliom_common.cmx
eliom_service.cmo : private/eliommod_services.cmi \
private/eliommod_naservices.cmi private/eliommod_cookies.cmi \
eliom_state.cmi eliom_service_base.cmo eliom_request_info.cmi \
eliom_reference.cmi eliom_parameter.cmi eliom_lib.cmi \
eliom_content_core.cmi eliom_common_base.cmo eliom_common.cmi \
eliom_service.cmi
eliom_service.cmx : private/eliommod_services.cmx \
private/eliommod_naservices.cmx private/eliommod_cookies.cmx \
eliom_state.cmx eliom_service_base.cmx eliom_request_info.cmx \
eliom_reference.cmx eliom_parameter.cmx eliom_lib.cmx \
eliom_content_core.cmx eliom_common_base.cmx eliom_common.cmx \
eliom_service.cmi
eliom_service.cmi : eliom_parameter.cmi eliom_lib_base.cmi eliom_lib.cmi \
eliom_content_core.cmi eliom_common.cmi
eliom_state.cmo : private/eliommod_timeouts.cmi \
private/eliommod_sessiongroups.cmi private/eliommod_sessexpl.cmi \
private/eliommod_sessadmin.cmi private/eliommod_sersess.cmi \
private/eliommod_persess.cmi private/eliommod_datasess.cmi \
eliom_request_info.cmi eliom_lib.cmi eliom_common.cmi eliom_state.cmi
eliom_state.cmx : private/eliommod_timeouts.cmx \
private/eliommod_sessiongroups.cmx private/eliommod_sessexpl.cmx \
private/eliommod_sessadmin.cmx private/eliommod_sersess.cmx \
private/eliommod_persess.cmx private/eliommod_datasess.cmx \
eliom_request_info.cmx eliom_lib.cmx eliom_common.cmx eliom_state.cmi
eliom_state.cmi : eliom_lib.cmi eliom_common.cmi
eliom_tools_common.cmo : eliom_service.cmi eliom_registration.cmi \
eliom_tools_common.cmi
eliom_tools_common.cmx : eliom_service.cmx eliom_registration.cmx \
eliom_tools_common.cmi
eliom_tools_common.cmi : eliom_state.cmi eliom_service.cmi \
eliom_registration.cmi eliom_parameter.cmi
eliom_tools.cmo : eliom_tools_common.cmi eliom_service.cmi \
eliom_request_info.cmi eliom_registration.cmi eliom_reference.cmi \
eliom_lib.cmi eliom_content.cmi eliom_common.cmi eliom_tools.cmi
eliom_tools.cmx : eliom_tools_common.cmx eliom_service.cmx \
eliom_request_info.cmx eliom_registration.cmx eliom_reference.cmx \
eliom_lib.cmx eliom_content.cmx eliom_common.cmx eliom_tools.cmi
eliom_tools.cmi : eliom_tools_common.cmi eliom_state.cmi eliom_service.cmi \
eliom_registration.cmi eliom_parameter.cmi eliom_lib.cmi \
eliom_content.cmi
eliom_types_base.cmo : eliom_wrap.cmi eliom_lib.cmi eliom_content_core.cmi \
eliom_common.cmi eliom_types_base.cmi
eliom_types_base.cmx : eliom_wrap.cmx eliom_lib.cmx eliom_content_core.cmx \
eliom_common.cmx eliom_types_base.cmi
eliom_types_base.cmi : eliom_wrap.cmi eliom_lib.cmi eliom_content_core.cmi \
eliom_common.cmi
eliom_types.cmo : eliom_wrap.cmi eliom_types_base.cmi eliom_lib.cmi \
eliom_types.cmi
eliom_types.cmx : eliom_wrap.cmx eliom_types_base.cmx eliom_lib.cmx \
eliom_types.cmi
eliom_types.cmi : eliom_wrap.cmi eliom_lib.cmi eliom_content_core.cmi \
eliom_common.cmi
eliom_uri.cmo : eliom_service.cmi eliom_request_info.cmi eliom_parameter.cmi \
eliom_lib.cmi eliom_config.cmi eliom_common.cmi eliom_uri.cmi
eliom_uri.cmx : eliom_service.cmx eliom_request_info.cmx eliom_parameter.cmx \
eliom_lib.cmx eliom_config.cmx eliom_common.cmx eliom_uri.cmi
eliom_uri.cmi : eliom_service.cmi eliom_parameter.cmi eliom_lib.cmi \
eliom_common.cmi
eliom_wrap.cmo : eliom_wrap.cmi
eliom_wrap.cmx : eliom_wrap.cmi
eliom_wrap.cmi :
extensions/atom_feed.cmo : eliom_lib.cmi eliom_content.cmi \
extensions/atom_feed.cmi
extensions/atom_feed.cmx : eliom_lib.cmx eliom_content.cmx \
extensions/atom_feed.cmi
extensions/atom_feed.cmi : eliom_lib.cmi eliom_content.cmi
extensions/eliom_atom.cmo : eliom_service.cmi eliom_registration.cmi \
eliom_parameter.cmi eliom_mkreg.cmi eliom_lib.cmi \
extensions/atom_feed.cmi extensions/eliom_atom.cmi
extensions/eliom_atom.cmx : eliom_service.cmx eliom_registration.cmx \
eliom_parameter.cmx eliom_mkreg.cmx eliom_lib.cmx \
extensions/atom_feed.cmx extensions/eliom_atom.cmi
extensions/eliom_atom.cmi : eliom_service.cmi eliom_registration.cmi \
eliom_parameter.cmi eliom_lib.cmi eliom_common.cmi \
extensions/atom_feed.cmi
extensions/eliom_openid.cmo : eliom_state.cmi eliom_service.cmi \
extensions/eliom_s2s.cmi eliom_request_info.cmi eliom_registration.cmi \
eliom_parameter.cmi eliom_lib.cmi eliom_content.cmi eliom_common.cmi \
extensions/eliom_openid.cmi
extensions/eliom_openid.cmx : eliom_state.cmx eliom_service.cmx \
extensions/eliom_s2s.cmx eliom_request_info.cmx eliom_registration.cmx \
eliom_parameter.cmx eliom_lib.cmx eliom_content.cmx eliom_common.cmx \
extensions/eliom_openid.cmi
extensions/eliom_openid.cmi : eliom_registration.cmi eliom_lib.cmi
extensions/eliom_s2s.cmo : eliom_lib.cmi extensions/eliom_s2s.cmi
extensions/eliom_s2s.cmx : eliom_lib.cmx extensions/eliom_s2s.cmi
extensions/eliom_s2s.cmi :
private/eliommod_cli.cmo : eliom_types.cmi eliom_request_info.cmi \
eliom_lib.cmi eliom_common.cmi private/eliommod_cli.cmi
private/eliommod_cli.cmx : eliom_types.cmx eliom_request_info.cmx \
eliom_lib.cmx eliom_common.cmx private/eliommod_cli.cmi
private/eliommod_cli.cmi : eliom_types.cmi eliom_lib.cmi eliom_common.cmi
private/eliommod_cookies.cmo : private/eliommod_sessiongroups.cmi \
eliom_lib.cmi eliom_cookies_base.cmo eliom_common.cmi \
private/eliommod_cookies.cmi
private/eliommod_cookies.cmx : private/eliommod_sessiongroups.cmx \
eliom_lib.cmx eliom_cookies_base.cmx eliom_common.cmx \
private/eliommod_cookies.cmi
private/eliommod_cookies.cmi : eliom_lib.cmi eliom_common.cmi
private/eliommod_datasess.cmo : private/eliommod_sessiongroups.cmi \
private/eliommod_cookies.cmi eliom_request_info.cmi eliom_common.cmi \
private/eliommod_datasess.cmi
private/eliommod_datasess.cmx : private/eliommod_sessiongroups.cmx \
private/eliommod_cookies.cmx eliom_request_info.cmx eliom_common.cmx \
private/eliommod_datasess.cmi
private/eliommod_datasess.cmi : eliom_common.cmi
private/eliommod_gc.cmo : private/eliommod_sessiongroups.cmi \
private/eliommod_persess.cmi eliom_lib.cmi eliom_common.cmi \
private/eliommod_gc.cmi
private/eliommod_gc.cmx : private/eliommod_sessiongroups.cmx \
private/eliommod_persess.cmx eliom_lib.cmx eliom_common.cmx \
private/eliommod_gc.cmi
private/eliommod_gc.cmi : eliom_common.cmi
private/eliommod.cmo : private/eliommod_timeouts.cmi \
private/eliommod_sessiongroups.cmi private/eliommod_pagegen.cmi \
private/eliommod_gc.cmi private/eliommod_cookies.cmi eliom_lib.cmi \
eliom_extension.cmi eliom_common_base.cmo eliom_common.cmi
private/eliommod.cmx : private/eliommod_timeouts.cmx \
private/eliommod_sessiongroups.cmx private/eliommod_pagegen.cmx \
private/eliommod_gc.cmx private/eliommod_cookies.cmx eliom_lib.cmx \
eliom_extension.cmx eliom_common_base.cmx eliom_common.cmx
private/eliommod_naservices.cmo : eliom_lib.cmi eliom_common.cmi \
private/eliommod_naservices.cmi
private/eliommod_naservices.cmx : eliom_lib.cmx eliom_common.cmx \
private/eliommod_naservices.cmi
private/eliommod_naservices.cmi : eliom_common.cmi
private/eliommod_pagegen.cmo : private/eliommod_timeouts.cmi \
private/eliommod_services.cmi private/eliommod_persess.cmi \
private/eliommod_naservices.cmi private/eliommod_cookies.cmi \
eliom_lib.cmi eliom_extension.cmi eliom_error_pages.cmo \
eliom_content_core.cmi eliom_common.cmi private/eliommod_pagegen.cmi
private/eliommod_pagegen.cmx : private/eliommod_timeouts.cmx \
private/eliommod_services.cmx private/eliommod_persess.cmx \
private/eliommod_naservices.cmx private/eliommod_cookies.cmx \
eliom_lib.cmx eliom_extension.cmx eliom_error_pages.cmx \
eliom_content_core.cmx eliom_common.cmx private/eliommod_pagegen.cmi
private/eliommod_pagegen.cmi : eliom_extension.cmi eliom_common.cmi
private/eliommod_persess.cmo : private/eliommod_sessiongroups.cmi \
private/eliommod_cookies.cmi eliom_common.cmi \
private/eliommod_persess.cmi
private/eliommod_persess.cmx : private/eliommod_sessiongroups.cmx \
private/eliommod_cookies.cmx eliom_common.cmx \
private/eliommod_persess.cmi
private/eliommod_persess.cmi : eliom_common.cmi
private/eliommod_sersess.cmo : private/eliommod_sessiongroups.cmi \
private/eliommod_cookies.cmi eliom_request_info.cmi eliom_common.cmi \
private/eliommod_sersess.cmi
private/eliommod_sersess.cmx : private/eliommod_sessiongroups.cmx \
private/eliommod_cookies.cmx eliom_request_info.cmx eliom_common.cmx \
private/eliommod_sersess.cmi
private/eliommod_sersess.cmi : eliom_common.cmi
private/eliommod_services.cmo : eliom_lib.cmi eliom_common.cmi \
private/eliommod_services.cmi
private/eliommod_services.cmx : eliom_lib.cmx eliom_common.cmx \
private/eliommod_services.cmi
private/eliommod_services.cmi : eliom_lib.cmi eliom_common.cmi
private/eliommod_sessadmin.cmo : private/eliommod_sessiongroups.cmi \
private/eliommod_persess.cmi eliom_common.cmi \
private/eliommod_sessadmin.cmi
private/eliommod_sessadmin.cmx : private/eliommod_sessiongroups.cmx \
private/eliommod_persess.cmx eliom_common.cmx \
private/eliommod_sessadmin.cmi
private/eliommod_sessadmin.cmi : eliom_common.cmi
private/eliommod_sessexpl.cmo : private/eliommod_persess.cmi \
private/eliommod_datasess.cmi eliom_request_info.cmi eliom_common.cmi \
private/eliommod_sessexpl.cmi
private/eliommod_sessexpl.cmx : private/eliommod_persess.cmx \
private/eliommod_datasess.cmx eliom_request_info.cmx eliom_common.cmx \
private/eliommod_sessexpl.cmi
private/eliommod_sessexpl.cmi : eliom_common.cmi
private/eliommod_sessiongroups.cmo : eliom_lib.cmi eliom_common.cmi \
private/eliommod_sessiongroups.cmi
private/eliommod_sessiongroups.cmx : eliom_lib.cmx eliom_common.cmx \
private/eliommod_sessiongroups.cmi
private/eliommod_sessiongroups.cmi : eliom_lib.cmi eliom_common.cmi
private/eliommod_timeouts.cmo : private/eliommod_sessadmin.cmi eliom_lib.cmi \
eliom_common.cmi private/eliommod_timeouts.cmi
private/eliommod_timeouts.cmx : private/eliommod_sessadmin.cmx eliom_lib.cmx \
eliom_common.cmx private/eliommod_timeouts.cmi
private/eliommod_timeouts.cmi : eliom_common.cmi
eliom-3.0.3/src/server/eliom_lib.mli 0000644 0000000 0000000 00000006033 12062377521 015552 0 ustar 00 0000000 0000000 (* Ocsigen
* http://www.ocsigen.org
* Copyright (C) 2011 Grégoire Henry
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exception;
* either version 2.1 of the License, or (at your option) any later version.
*
* This program 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
* GNU Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
(** See {% <> %} *)
include module type of Ocsigen_lib
with type poly = Ocsigen_lib.poly
and type yesnomaybe = Ocsigen_lib.yesnomaybe
and type ('a, 'b) leftright = ('a, 'b) Ocsigen_lib.leftright
and type 'a Clist.t = 'a Ocsigen_lib.Clist.t
and type 'a Clist.node = 'a Ocsigen_lib.Clist.node
and type Ip_address.t = Ocsigen_lib.Ip_address.t
include module type of Eliom_lib_base
with type 'a Int64_map.t = 'a Eliom_lib_base.Int64_map.t
with type 'a String_map.t = 'a Eliom_lib_base.String_map.t
with type 'a Int_map.t = 'a Eliom_lib_base.Int_map.t
with type escaped_value = Eliom_lib_base.escaped_value
with type +'a Client_value_server_repr.t = 'a Eliom_lib_base.Client_value_server_repr.t
with type client_value_datum = Eliom_lib_base.client_value_datum
with type 'a injection_datum = 'a Eliom_lib_base.injection_datum
with type 'a compilation_unit_global_data = 'a Eliom_lib_base.compilation_unit_global_data
with type 'a global_data := 'a Eliom_lib_base.global_data
with type request_data = Eliom_lib_base.request_data
(** See {% <> %}. *)
type 'a client_value
(** Raised if a client value of the given closure ID is created at a
point in time where it is neither global (i.e. during the
initialization of the server program), nor request (i.e. during
the processing of a request).
*)
exception Client_value_creation_invalid_context of int64
exception Eliom_Internal_Error of string
type file_info = Ocsigen_extensions.file_info
val to_json : ?typ:'a Deriving_Json.t -> 'a -> string
val of_json : ?typ:'a Deriving_Json.t -> string -> 'a
val debug: ('a, unit, string, unit) format4 -> 'a
(** Marshal an OCaml value into a string. All characters are escaped *)
val jsmarshal : 'a -> string
(**/**)
val create_client_value : 'a Client_value_server_repr.t -> 'a client_value
val client_value_server_repr : 'a client_value -> 'a Client_value_server_repr.t
val escaped_value : 'a -> escaped_value (* * Eliom_wrap.unwrapper *)
val string_escape : string -> string
type global_data = poly Eliom_lib_base.global_data * Eliom_wrap.unwrapper
val global_data_unwrapper : Eliom_wrap.unwrapper
(**/**)
eliom-3.0.3/src/server/eliom_request_info.mli 0000644 0000000 0000000 00000032147 12062377521 017514 0 ustar 00 0000000 0000000 (* Ocsigen
* http://www.ocsigen.org
* Module eliomsessions.mli
* Copyright (C) 2007 Vincent Balat
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exception;
* either version 2.1 of the License, or (at your option) any later version.
*
* This program 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
* GNU Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
(** This module contains the functions you need to get (or set)
information about current request.
*)
open Eliom_lib
open Ocsigen_extensions
open Ocsigen_cookies
(** {2 Getting information about the request} *)
(** returns the HTTP method used for the request (usually GET or POST). *)
val get_http_method : unit -> Ocsigen_http_frame.Http_header.http_method
(** returns the name of the user agent that did the request
(usually the name of the browser). *)
val get_user_agent : unit -> string
(** returns the full URL as a string *)
val get_full_url : unit -> string
(** returns the internet address of the client as a string *)
val get_remote_ip : unit -> string
(** returns the internet address of the client,
using the type [Unix.inet_addr] (defined in OCaml's standard library). *)
val get_remote_inet_addr : unit -> Unix.inet_addr
(** returns the full path of the URL as a string. *)
val get_current_full_path_string : unit -> string
(** returns the full path of the URL using the type [Url.path] *)
val get_current_full_path : unit -> Url.path
(** returns the full path of the URL as first sent by the browser
(not changed by previous extensions like rewritemod) *)
val get_original_full_path_string : unit -> string
(** returns the full path of the URL as first sent by the browser
(not changed by previous extensions like rewritemod) *)
val get_original_full_path : unit -> Url.path
(** returns the sub path of the URL as a string.
The sub-path is the full path without the path of the site (set in the
configuration file).
*)
val get_current_sub_path_string : unit -> string
(** returns the sub path of the URL using the type [Url.path].
The sub-path is the full path without the path of the site (set in the
configuration file).
*)
val get_current_sub_path : unit -> Url.path
(** returns the hostname that has been sent by the user agent.
For HTTP/1.0, the Host field is not mandatory in the request.
*)
val get_header_hostname : unit -> string option
(** returns the hostname used for absolute links.
It is either the [Host] header sent by the browser or the default hostname
set in the configuration file, depending on server configuration
([] option).
*)
val get_hostname : unit -> string
(** returns the port of the server.
It is either the default port in the configuration file
(if [] is present is the configuration file),
or the port in the Host header of the request (if present),
or the port on which the request has been done (otherwise).
*)
val get_server_port : unit -> int
(** returns true if https is used, false if http. *)
val get_ssl : unit -> bool
(** returns the suffix of the current URL *)
val get_suffix : unit -> Url.path option
(** returns the cookies sent by the browser *)
val get_cookies : ?cookie_level:Eliom_common.cookie_level ->
unit -> string CookiesTable.t
(** returns an Unix timestamp associated to the request *)
val get_timeofday : unit -> float
(** returns an unique id associated to the request *)
val get_request_id : unit -> int64
(** {3 Exceptions and fallbacks} *)
(** returns a table in which you can store all the data you want during a
request. It can also be used to send information after an action.
Keep an eye on this information to know what
succeeded before the current service was called
(failed connection, timeout ...)
The table is created at the beginning of the request.
*)
val get_request_cache : unit -> Polytables.t
(** Remove all data from the request cache *)
val clean_request_cache : unit -> unit
(** returns [true] if the coservice called has not been found.
In that case, the current service is the fallback.
*)
val get_link_too_old : unit -> bool
(** returns the list of names of service sessions expired for the current
request, for browser sessions and tab sessions. *)
val get_expired_service_sessions :
unit -> (Eliom_common.full_state_name list *
Eliom_common.full_state_name list)
(** returns the HTTP error code sent by the Ocsigen extension
that tried to answer to the request before Eliom.
It is 404 by default.
*)
val get_previous_extension_error_code : unit -> int
(*****************************************************************************)
(** {2 Getting information about files uploaded} *)
(** Warning: The files uploaded are automatically erased by Ocsigen
just after the request has been fulfilled.
If you want to keep them, create a new hard link yourself during
the service (or make a copy).
*)
(** returns the filename used by Ocsigen for the uploaded file. *)
val get_tmp_filename : file_info -> string
(** returns the size of the file. *)
val get_filesize : file_info -> int64
(** returns the name the file had on the client when it has been sent. *)
val get_original_filename : file_info -> string
(** returns the root of the site. *)
val get_site_dir : unit -> Url.path
(*****************************************************************************)
(** {2 Getting parameters (low level)} *)
(** The usual way to get parameters with Eliom is to use the second
and third parameters of the service handlers.
These are low level functions you may need for more advanced use.
*)
(** returns the parameters of the URL (GET parameters)
that concern the running service.
For example in the case of a non-attached coservice called from
a page with GET parameters, only the parameters of that non-attached
coservice are returned (even if the other are still in the URL).
*)
val get_get_params : unit -> (string * string) list
(** returns current parameters of the URL (GET parameters)
(even those that are for subsequent services, but not previous actions) *)
val get_all_current_get_params : unit -> (string * string) list
(** returns all parameters of the URL (GET parameters)
as sent initially by the browser *)
val get_initial_get_params : unit -> (string * string) list
(** returns the parameters of the URL (GET parameters)
that do not concern the running service. *)
val get_other_get_params : unit -> (string * string) list
(** returns non localized parameters in the URL. *)
val get_nl_get_params :
unit -> (string * string) list String.Table.t
(** returns persistent non localized parameters in the URL. *)
val get_persistent_nl_get_params :
unit -> (string * string) list String.Table.t
(** returns non localized POST parameters. *)
val get_nl_post_params :
unit -> (string * string) list String.Table.t
(** returns the parameters in the body of the HTTP request (POST parameters)
that concern the running service. None means that POST data where
neither urlencoded form data or multipart data. *)
val get_post_params : unit -> (string * string) list Lwt.t option
(** returns all parameters in the body of the HTTP request (POST parameters)
(even those that are for another service) *)
val get_all_post_params : unit -> (string * string) list option
(*****************************************************************************)
(** {2 Other low level functions} *)
(** You probably don't need these functions. *)
(** returns all the information about the request. *)
val get_ri : unit -> Ocsigen_extensions.request_info
(** returns all the information about the request and config. *)
val get_request : unit -> request
(** returns the name of the sessions to which belongs the running service
([None] if it is not a session service)
*)
val get_state_name : unit -> Eliom_common.full_state_name option
(** returns the values of the Eliom's cookies for persistent sessions
sent by the browser. *)
val get_persistent_cookies :
unit -> string Eliom_common.Full_state_name_table.t
(** returns the values of Eliom's cookies for non persistent sessions
sent by the browser. *)
val get_data_cookies :
unit -> string Eliom_common.Full_state_name_table.t
(** Returns the http error code of the request before Eliom was called *)
val get_previous_extension_error_code :unit -> int
(** Returns [true] if the request was done by a client side Eliom program,
which was expecting to receive a new HTML page to display inside
the process. *)
val expecting_process_page : unit -> bool
(*****************************************************************************)
(** {3 Getting information about the URL of the client side process (csp)}
Warning: it is different from the URL to which the request has been made.
*)
(** returns the full path of the URL where the client-side process is running.
If there is no client side process, same as
{!get_original_full_path}.
*)
val get_csp_original_full_path : unit -> Url.path
(** returns the hostname used for absolute links, computed
when launching the client side process for the first time.
If there is no client side process,
same as {!get_hostname}.
It is either the [Host] header sent by the browser or the default hostname
set in the configuration file, depending on server configuration
([] option).
*)
val get_csp_hostname : unit -> string
(** returns the port of the server, used when launching the client side process
(not the current request). It corresponds to the port in the URL of
the browser.
If there is no client side process, same as
{!get_server_port}.
*)
val get_csp_server_port : unit -> int
(** returns true if https is used in the URL of the browser, false if http.
If there is no client side process, same as {!get_ssl}.
*)
val get_csp_ssl : unit -> bool
(**/**)
val get_csp_original_full_path_sp : Eliom_common.server_params -> Url.path
val get_csp_hostname_sp : Eliom_common.server_params -> string
val get_csp_server_port_sp : Eliom_common.server_params -> int
val get_csp_ssl_sp : Eliom_common.server_params -> bool
(*****************************************************************************)
val get_sitedata_sp : sp:Eliom_common.server_params -> Eliom_common.sitedata
val get_sitedata : unit -> Eliom_common.sitedata
(*
(** returns the cookie expiration date for the session,
in seconds, since the 1st of january 1970.
must have been set just before (not saved server side).
*)
val get_cookie_exp_date : ?state_name:string -> unit ->
unit -> float option
(** returns the cookie expiration date for the persistent session,
in seconds, since the 1st of january 1970.
must have been set just before (not saved server side).
*)
val get_persistent_cookie_exp_date : ?state_name:string ->
unit -> unit -> float option
*)
val find_sitedata : string -> Eliom_common.sitedata
val get_si : Eliom_common.server_params -> Eliom_common.sess_info
val get_user_cookies : unit -> Ocsigen_cookies.cookieset
val get_user_tab_cookies : unit -> Ocsigen_cookies.cookieset
val get_sp_client_appl_name : unit -> string option
val get_sp_client_process_info_sp :
Eliom_common.server_params -> Eliom_common.client_process_info
val get_sp_client_process_info : unit -> Eliom_common.client_process_info
val set_site_handler : Eliom_common.sitedata ->
(exn -> Ocsigen_http_frame.result Lwt.t) -> unit
val get_request_sp : Eliom_common.server_params -> request
val get_site_dir_sp : Eliom_common.server_params -> Url.path
val get_hostname_sp : Eliom_common.server_params -> string
val get_full_url_sp : Eliom_common.server_params -> string
val get_other_get_params_sp : Eliom_common.server_params -> (string * string) list
val get_nl_get_params_sp :
Eliom_common.server_params -> (string * string) list String.Table.t
val get_persistent_nl_get_params_sp :
Eliom_common.server_params -> (string * string) list String.Table.t
val get_nl_post_params_sp :
Eliom_common.server_params -> (string * string) list String.Table.t
val get_original_full_path_sp : Eliom_common.server_params -> Url.path
val get_original_full_path_string_sp : Eliom_common.server_params -> string
val get_server_port_sp : Eliom_common.server_params -> int
val get_ssl_sp : Eliom_common.server_params -> bool
val get_ri_sp : Eliom_common.server_params -> Ocsigen_extensions.request_info
val get_post_params_sp : Eliom_common.server_params -> (string * string) list Lwt.t option
val get_files_sp : Eliom_common.server_params -> (string * file_info) list Lwt.t option
val get_suffix_sp : Eliom_common.server_params -> Url.path option
val get_request_cache_sp : Eliom_common.server_params -> Polytables.t
val get_request_id_sp : Eliom_common.server_params -> int64
eliom-3.0.3/src/server/eliom_tools_common.ml 0000644 0000000 0000000 00000003746 12062377521 017353 0 ustar 00 0000000 0000000 (* Ocsigen
* Copyright (C) 2005 Vincent Balat
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exception;
* either version 2.1 of the License, or (at your option) any later version.
*
* This program 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
* GNU Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
open Eliom_service
type ('a, 'b, 'c) one_page =
(unit, unit,
'a,
[ `WithoutSuffix ],
unit, unit,
'b, 'c) service
constraint 'c = [< Eliom_registration.non_caml_service ]
type get_page =
(Eliom_service.get_service_kind,
Eliom_service.registrable,
Eliom_registration.non_caml_service) one_page
(* constraint 'c = [ ] *)
let menu_class = "eliomtools_menu"
let last_class = "eliomtools_last"
let current_class = "eliomtools_current"
let current_path_class = "eliomtools_current_path"
let disabled_class = "eliomtools_disabled"
let first_class = "eliomtools_first"
let level_class = "eliomtools_level"
type ('a, 'b, 'c) hierarchical_site_item =
| Disabled
| Site_tree of ('a, 'b, 'c) hierarchical_site
constraint 'b = [< Eliom_service.registrable ]
and ('a, 'b) main_page =
| Main_page of ('a, 'b, Eliom_registration.non_caml_service) one_page
| Default_page of ('a, 'b, Eliom_registration.non_caml_service) one_page
| Not_clickable
constraint 'b = [< Eliom_service.registrable ]
and ('a, 'b, 'c) hierarchical_site =
(('a, 'b) main_page *
('c * ('a, 'b, 'c) hierarchical_site_item) list)
constraint 'b = [< Eliom_service.registrable ]
eliom-3.0.3/src/server/eliom_reference.ml 0000644 0000000 0000000 00000021272 12062377521 016573 0 ustar 00 0000000 0000000 (* Ocsigen
* http://www.ocsigen.org
* Copyright (C) 2010 Vincent Balat
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exception;
* either version 2.1 of the License, or (at your option) any later version.
*
* This program 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
* GNU Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
(*****************************************************************************)
(** {2 Eliom references} *)
open Eliom_state
let (>>=) = Lwt.bind
let pers_ref_store = Ocsipersist.open_store "eliom__persistent_refs"
type 'a eref_kind =
| Req of 'a Polytables.key
| Sit of 'a Polytables.key
| Ref of 'a lazy_t ref (* Ocaml reference *)
| Vol of 'a volatile_table Lazy.t (* Vol. table (group, session, process) *)
| Ocsiper of 'a option Ocsipersist.t Lwt.t (* Global persist. table *)
| Ocsiper_sit of 'a Ocsipersist.table (* Persist. table for site *)
| Per of 'a persistent_table (* Persist. table for group session or process *)
type volatile = [ `Volatile ]
type persistent = [ `Persistent ]
type ('a, 'storage) eref' = (unit -> 'a) * 'a eref_kind
type 'a eref = ('a, [ volatile | persistent ]) eref'
exception Eref_not_intialized
module Volatile = struct
type 'a eref = ('a, volatile) eref'
(* TODO With GADTs, drop the [assert false] and [failwith] statements below! *)
let eref_from_fun ~scope ?secure f : 'a eref =
f, match scope with
| `Request -> Req (Polytables.make_key ())
| `Global -> Ref (ref (Lazy.lazy_from_fun f))
| `Site -> Sit (Polytables.make_key ())
| (#Eliom_common.user_scope as scope) ->
Vol (lazy (create_volatile_table ~scope ?secure ()))
let eref ~scope ?secure v =
eref_from_fun ~scope ?secure (fun () -> v)
let get (f, table : _ eref) =
match table with
| Req key ->
let table = Eliom_request_info.get_request_cache () in
(try Polytables.get ~table ~key
with Not_found ->
let value = f () in
Polytables.set ~table ~key ~value;
value)
| Sit key ->
let table = Eliom_common.((get_site_data ()).site_value_table) in
(try Polytables.get ~table ~key
with Not_found ->
let value = f () in
Polytables.set ~table ~key ~value;
value)
| Vol t ->
(match get_volatile_data ~table:(Lazy.force t) () with
| Data d -> d
| _ ->
(let value = f () in
set_volatile_data ~table:(Lazy.force t) value;
value))
| Ref r -> Lazy.force !r
| _ -> assert false
let set (_, table : _ eref) value =
match table with
| Req key ->
let table = Eliom_request_info.get_request_cache () in
Polytables.set ~table ~key ~value;
| Sit key ->
let table = Eliom_common.((get_site_data ()).site_value_table) in
Polytables.set ~table ~key ~value
| Vol t -> set_volatile_data ~table:(Lazy.force t) value;
| Ref r -> r := Lazy.lazy_from_val value
| _ -> assert false
let modify eref f =
set eref (f (get eref))
let unset (f, table : _ eref) =
match table with
| Req key ->
let table = Eliom_request_info.get_request_cache () in
Polytables.remove ~table ~key;
| Sit key ->
let table = Eliom_common.((get_site_data ()).site_value_table) in
Polytables.remove ~table ~key
| Vol t -> remove_volatile_data ~table:(Lazy.force t) ();
| Ref r -> r := Lazy.lazy_from_fun f
| _ -> assert false
module Ext = struct
let get state (f, table) =
match table with
| Vol t ->
(try Eliom_state.Ext.Low_level.get_volatile_data
~state ~table:(Lazy.force t)
with Not_found ->
(* I don't want to run f in the wrong context -> I fail *)
raise Eref_not_intialized)
| _ -> failwith "wrong eref for this function"
let set state (_, table) value =
match table with
| Vol t ->
Eliom_state.Ext.Low_level.set_volatile_data
~state ~table:(Lazy.force t) value
| _ -> failwith "wrong eref for this function"
let modify state eref f =
set state eref (f (get state eref))
let unset state (f, table : _ eref) =
match table with
| Vol t -> Eliom_state.Ext.Low_level.remove_volatile_data
~state ~table:(Lazy.force t);
| _ -> failwith "wrong eref for this function"
end
end
let eref_from_fun ~scope ?secure ?persistent f : 'a eref =
match (scope:[
(Volatile.eref_from_fun ~scope ?secure f :> _ eref)
| `Global ->
begin
match persistent with
| None -> (Volatile.eref_from_fun ~scope ?secure f :> _ eref)
| Some name ->
(f, Ocsiper (Ocsipersist.make_persistent ~store:pers_ref_store ~name ~default:None))
end
| `Site ->
begin
match persistent with
| None -> (Volatile.eref_from_fun ~scope ?secure f :> _ eref)
| Some name ->
(*VVV!!! ??? CHECK! *)
(f, Ocsiper_sit (Ocsipersist.open_table name))
end
| (#Eliom_common.user_scope as scope) ->
match persistent with
| None ->
(Volatile.eref_from_fun ~scope ?secure f :> _ eref)
| Some name ->
(f, Per (create_persistent_table ~scope ?secure name))
let eref ~scope ?secure ?persistent v =
eref_from_fun ~scope ?secure ?persistent (fun () -> v)
let get_site_id () =
let sd = Eliom_common.get_site_data () in
sd.Eliom_common.config_info.Ocsigen_extensions.default_hostname
^ ":" ^ sd.Eliom_common.site_dir_string
let get (f, table as eref) =
match table with
| Per t ->
(get_persistent_data ~table:t () >>= function
| Data d -> Lwt.return d
| _ ->
let value = f () in
set_persistent_data ~table:t value >>= fun () ->
Lwt.return value)
| Ocsiper r ->
(r >>= fun r -> Ocsipersist.get r >>= function
| Some v -> Lwt.return v
| None ->
let value = f () in
Ocsipersist.set r (Some value) >>= fun () ->
Lwt.return value)
| Ocsiper_sit t ->
(let site_id = get_site_id () in
try_lwt Ocsipersist.find t site_id
with Not_found ->
let value = f () in
Ocsipersist.add t site_id value >>= fun () ->
Lwt.return value)
| _ -> Lwt.return (Volatile.get eref)
let set (_, table as eref) value =
match table with
| Per t -> set_persistent_data ~table:t value
| Ocsiper r -> r >>= fun r -> Ocsipersist.set r (Some value)
| Ocsiper_sit t ->
Ocsipersist.add t (get_site_id ()) value
| _ -> Lwt.return (Volatile.set eref value)
let modify eref f =
get eref >>= fun x -> set eref (f x)
let unset (f, table as eref) =
match table with
| Per t -> remove_persistent_data ~table:t ()
| Ocsiper r -> r >>= fun r -> Ocsipersist.set r None
| Ocsiper_sit t ->
Ocsipersist.remove t (get_site_id ())
| _ -> Lwt.return (Volatile.unset eref)
module Ext = struct
let get state ((_, table) as r) =
let state = Eliom_state.Ext.untype_state state in
match table with
| Vol _ -> Lwt.return (Volatile.Ext.get state r)
| Per t ->
(Lwt.catch
(fun () -> Eliom_state.Ext.Low_level.get_persistent_data
~state ~table:t)
(function
| Not_found -> Lwt.fail Eref_not_intialized
| e -> Lwt.fail e))
| _ -> failwith "wrong eref for this function"
let set state ((_, table) as r) value =
let state = Eliom_state.Ext.untype_state state in
match table with
| Vol _ -> Lwt.return (Volatile.Ext.set state r value)
| Per t ->
Eliom_state.Ext.Low_level.set_persistent_data
~state ~table:t value
| _ -> Lwt.fail (Failure "wrong eref for this function")
let modify state eref f =
get state eref >>= fun v ->
set state eref (f v)
let unset state ((_, table) as r) =
let state = Eliom_state.Ext.untype_state state in
match table with
| Vol _ -> Lwt.return (Volatile.Ext.unset state r)
| Per t -> Eliom_state.Ext.Low_level.remove_persistent_data
~state ~table:t
| _ -> failwith "wrong eref for this function"
end
eliom-3.0.3/src/server/eliom_request_info.ml 0000644 0000000 0000000 00000024053 12062377521 017340 0 ustar 00 0000000 0000000 (* Ocsigen
* http://www.ocsigen.org
* Copyright (C) 2010 Vincent Balat
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exception;
* either version 2.1 of the License, or (at your option) any later version.
*
* This program 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
* GNU Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
open Eliom_lib
open Lwt
open Ocsigen_extensions
(*****************************************************************************)
let find_sitedata fun_name =
match Eliom_common.get_sp_option () with
| Some sp -> sp.Eliom_common.sp_sitedata
| None ->
match Eliom_common.global_register_allowed () with
| Some get_current_sitedata -> get_current_sitedata ()
| _ ->
raise
(Eliom_common.Eliom_site_information_not_available fun_name)
(*****************************************************************************)
let get_http_method () =
let sp = Eliom_common.get_sp () in
sp.Eliom_common.sp_request.request_info.ri_method
let get_user_agent () =
let sp = Eliom_common.get_sp () in
sp.Eliom_common.sp_request.request_info.ri_user_agent
let get_full_url_sp sp =
sp.Eliom_common.sp_request.request_info.ri_url_string
let get_full_url () =
let sp = Eliom_common.get_sp () in
get_full_url_sp sp
let get_remote_ip () =
let sp = Eliom_common.get_sp () in
sp.Eliom_common.sp_request.request_info.ri_remote_ip
let get_remote_inet_addr () =
let sp = Eliom_common.get_sp () in
sp.Eliom_common.sp_request.request_info.ri_remote_inet_addr
let get_get_params () =
let sp = Eliom_common.get_sp () in
Lazy.force sp.Eliom_common.sp_request.request_info.ri_get_params
let get_all_current_get_params_sp sp =
sp.Eliom_common.sp_si.Eliom_common.si_all_get_params
let get_all_current_get_params () =
let sp = Eliom_common.get_sp () in
get_all_current_get_params_sp sp
let get_initial_get_params () =
let sp = Eliom_common.get_sp () in
Lazy.force sp.Eliom_common.sp_request.request_info.ri_initial_get_params
let get_get_params_string () =
let sp = Eliom_common.get_sp () in
sp.Eliom_common.sp_request.request_info.ri_get_params_string
let get_post_params_sp sp =
match sp.Eliom_common.sp_request.request_info.ri_post_params with
| None -> None
| Some f -> Some (f sp.Eliom_common.sp_request.request_config)
let get_post_params () =
let sp = Eliom_common.get_sp () in
get_post_params_sp sp
let get_files_sp sp =
match sp.Eliom_common.sp_request.request_info.ri_files with
| None -> None
| Some f -> Some (f sp.Eliom_common.sp_request.request_config)
let get_all_post_params () =
let sp = Eliom_common.get_sp () in
sp.Eliom_common.sp_si.Eliom_common.si_all_post_params
let get_original_full_path_string_sp sp =
sp.Eliom_common.sp_request.request_info.ri_original_full_path_string
let get_original_full_path_string () =
let sp = Eliom_common.get_sp () in
get_original_full_path_string_sp sp
let get_original_full_path_sp sp =
sp.Eliom_common.sp_request.request_info.ri_original_full_path
let get_original_full_path () =
let sp = Eliom_common.get_sp () in
get_original_full_path_sp sp
let get_current_full_path () =
let sp = Eliom_common.get_sp () in
sp.Eliom_common.sp_request.request_info.ri_full_path
let get_current_full_path_string () =
let sp = Eliom_common.get_sp () in
sp.Eliom_common.sp_request.request_info.ri_full_path_string
let get_current_sub_path () =
let sp = Eliom_common.get_sp () in
sp.Eliom_common.sp_request.request_info.ri_sub_path
let get_current_sub_path_string () =
let sp = Eliom_common.get_sp () in
sp.Eliom_common.sp_request.request_info.ri_sub_path_string
let get_header_hostname () =
let sp = Eliom_common.get_sp () in
sp.Eliom_common.sp_request.request_info.ri_host
let get_timeofday_sp sp =
sp.Eliom_common.sp_request.request_info.ri_timeofday
let get_request_id_sp sp = Int64.bits_of_float (get_timeofday_sp sp)
let get_timeofday () =
let sp = Eliom_common.get_sp () in
get_timeofday_sp sp
let get_request_id () = Int64.bits_of_float (get_timeofday ())
let get_hostname_sp sp =
Ocsigen_extensions.get_hostname sp.Eliom_common.sp_request
let get_hostname () =
let sp = Eliom_common.get_sp () in
get_hostname_sp sp
let get_server_port_sp sp =
Ocsigen_extensions.get_port sp.Eliom_common.sp_request
let get_server_port () =
let sp = Eliom_common.get_sp () in
get_server_port_sp sp
let get_ssl_sp sp =
sp.Eliom_common.sp_request.request_info.ri_ssl
let get_ssl () =
let sp = Eliom_common.get_sp () in
get_ssl_sp sp
let get_other_get_params () =
let sp = Eliom_common.get_sp () in
sp.Eliom_common.sp_si.Eliom_common.si_other_get_params
let get_nl_get_params () =
let sp = Eliom_common.get_sp () in
sp.Eliom_common.sp_si.Eliom_common.si_nl_get_params
let get_persistent_nl_get_params () =
let sp = Eliom_common.get_sp () in
Lazy.force sp.Eliom_common.sp_si.Eliom_common.si_persistent_nl_get_params
let get_nl_post_params () =
let sp = Eliom_common.get_sp () in
sp.Eliom_common.sp_si.Eliom_common.si_nl_post_params
let get_other_get_params_sp sp =
sp.Eliom_common.sp_si.Eliom_common.si_other_get_params
let get_nl_get_params_sp sp =
sp.Eliom_common.sp_si.Eliom_common.si_nl_get_params
let get_persistent_nl_get_params_sp sp =
Lazy.force sp.Eliom_common.sp_si.Eliom_common.si_persistent_nl_get_params
let get_nl_post_params_sp sp =
sp.Eliom_common.sp_si.Eliom_common.si_nl_post_params
let get_suffix_sp sp =
sp.Eliom_common.sp_suffix
let get_suffix () =
let sp = Eliom_common.get_sp () in
get_suffix_sp sp
let get_state_name () =
let sp = Eliom_common.get_sp () in
sp.Eliom_common.sp_full_state_name
let get_request_cache_sp sp =
sp.Eliom_common.sp_request.request_info.ri_request_cache
let get_request_cache () =
let sp = Eliom_common.get_sp () in
get_request_cache_sp sp
let clean_request_cache () =
let sp = Eliom_common.get_sp () in
sp.Eliom_common.sp_request.request_info.ri_request_cache <-
Polytables.create ()
let get_link_too_old () =
let sp = Eliom_common.get_sp () in
try
Polytables.get
~table:sp.Eliom_common.sp_request.request_info.ri_request_cache
~key:Eliom_common.eliom_link_too_old
with Not_found -> false
let get_expired_service_sessions () =
let sp = Eliom_common.get_sp () in
try
Polytables.get
~table:sp.Eliom_common.sp_request.request_info.ri_request_cache
~key:Eliom_common.eliom_service_session_expired
with Not_found -> ([], [])
let get_cookies ?(cookie_level = `Session) () =
let sp = Eliom_common.get_sp () in
match cookie_level with
| `Session ->
Lazy.force sp.Eliom_common.sp_request.request_info.ri_cookies
| `Client_process ->
sp.Eliom_common.sp_si.Eliom_common.si_tab_cookies
let get_data_cookies () =
let sp = Eliom_common.get_sp () in
sp.Eliom_common.sp_si.Eliom_common.si_data_session_cookies
let get_persistent_cookies () =
let sp = Eliom_common.get_sp () in
sp.Eliom_common.sp_si.Eliom_common.si_persistent_session_cookies
let get_previous_extension_error_code () =
let sp = Eliom_common.get_sp () in
sp.Eliom_common.sp_si.Eliom_common.si_previous_extension_error
let get_si sp = sp.Eliom_common.sp_si
let get_user_cookies () =
let sp = Eliom_common.get_sp () in
sp.Eliom_common.sp_user_cookies
let get_user_tab_cookies () =
let sp = Eliom_common.get_sp () in
sp.Eliom_common.sp_user_tab_cookies
(****)
let get_sp_client_appl_name () =
let sp = Eliom_common.get_sp () in
sp.Eliom_common.sp_client_appl_name
let get_sp_client_process_info_sp sp =
sp.Eliom_common.sp_client_process_info
let get_sp_client_process_info () =
let sp = Eliom_common.get_sp () in
get_sp_client_process_info_sp sp
let expecting_process_page () =
let sp = Eliom_common.get_sp () in
Lazy.force sp.Eliom_common.sp_si.Eliom_common.si_expect_process_data
let get_csp_original_full_path () =
let cpi = get_sp_client_process_info () in
cpi.Eliom_common.cpi_original_full_path
let get_csp_hostname () =
let cpi = get_sp_client_process_info () in
cpi.Eliom_common.cpi_hostname
let get_csp_server_port () =
let cpi = get_sp_client_process_info () in
cpi.Eliom_common.cpi_server_port
let get_csp_ssl () =
let cpi = get_sp_client_process_info () in
cpi.Eliom_common.cpi_ssl
let get_csp_original_full_path_sp sp =
let cpi = get_sp_client_process_info_sp sp in
cpi.Eliom_common.cpi_original_full_path
let get_csp_hostname_sp sp =
let cpi = get_sp_client_process_info_sp sp in
cpi.Eliom_common.cpi_hostname
let get_csp_server_port_sp sp =
let cpi = get_sp_client_process_info_sp sp in
cpi.Eliom_common.cpi_server_port
let get_csp_ssl_sp sp =
let cpi = get_sp_client_process_info_sp sp in
cpi.Eliom_common.cpi_ssl
(* *)
let get_site_dir () =
let sitedata = find_sitedata "Eliom_request_info.get_site_dir" in
sitedata.Eliom_common.site_dir
let get_site_dir_sp sp =
sp.Eliom_common.sp_sitedata.Eliom_common.site_dir
let get_site_dir_string () =
let sitedata = find_sitedata "Eliom_request_info.get_site_dir_string" in
sitedata.Eliom_common.site_dir_string
let get_request () =
let sp = Eliom_common.get_sp () in
sp.Eliom_common.sp_request
let get_request_sp sp =
sp.Eliom_common.sp_request
let get_ri_sp sp =
sp.Eliom_common.sp_request.Ocsigen_extensions.request_info
let get_ri () =
let sp = Eliom_common.get_sp () in
get_ri_sp sp
let get_tmp_filename fi = fi.tmp_filename
let get_filesize fi = fi.filesize
let get_original_filename fi = fi.original_basename
let get_sitedata () =
let sp = Eliom_common.get_sp () in
sp.Eliom_common.sp_sitedata
let get_sitedata_sp ~sp = sp.Eliom_common.sp_sitedata
(***)
(*VVV ici ? pour des raisons de typage... *)
let set_site_handler sitedata handler =
sitedata.Eliom_common.exn_handler <- handler
eliom-3.0.3/src/server/eliom_process.ml 0000644 0000000 0000000 00000001755 12062377521 016317 0 ustar 00 0000000 0000000 (* Ocsigen
* http://www.ocsigen.org
* Copyright (C) 2010 Vincent Balat
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exception;
* either version 2.1 of the License, or (at your option) any later version.
*
* This program 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
* GNU Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
exception Server_side_process_closed
(** returns None on server side *)
let get_application_name () = None
(** false on server side *)
let client_side = false
eliom-3.0.3/src/server/eliom_error_pages.ml 0000644 0000000 0000000 00000006012 12062377521 017140 0 ustar 00 0000000 0000000 (* Ocsigen
* Copyright (C) 2005 Vincent Balat
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exception;
* either version 2.1 of the License, or (at your option) any later version.
*
* This program 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
* GNU Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
open Eliom_lib
open Eliom_content_core
open Html5.F
let page_error_param_type l =
let s = match l with
[] -> [pcdata "Wrong type for parameter"]
| [(n,_)] -> [pcdata "Wrong type for parameter ";em [pcdata n];pcdata "."]
| (n,_)::ll ->
(pcdata "Wrong type for parameters ")::
(List.fold_left (fun deb (n,_) -> (em [pcdata n])::(pcdata ", ")::deb)
[em [pcdata n];pcdata "."] ll)
in
html
(head (title (pcdata "")) [])
(body
[h1 s]
)
let page_bad_param after_action gl pl =
let s = "Wrong parameters" in
html
(head (title (pcdata s)) [])
(body
((h1 [pcdata s])::
(if Ocsigen_config.get_debugmode ()
then
[h2 [pcdata "Debugging information:"];
(if after_action
then
(p [pcdata "An action occurred successfully. But Eliom was unable to find the service for displaying the page."])
else
(p [pcdata "Eliom was unable to find a service matching these parameters."]));
(match gl with
| [] -> p [pcdata "No GET parameters have been given to services."]
| (n, a)::l ->
p ((pcdata "GET parameters given to services: ")::
[em
((pcdata n)::(pcdata "=")::(pcdata a)::
(List.fold_right
(fun (n, a) b ->
(pcdata "&")::
(pcdata n)::(pcdata "=")::(pcdata a)::b)
l [pcdata "."]))]));
(match pl with
| [] -> p [pcdata "No POST parameters have been given to services."]
| a::l ->
p ((pcdata "Names of POST parameters given to services: ")::
(em [pcdata a])::
(List.fold_right
(fun n b -> (pcdata ", ")::(em [pcdata n])::b)
l [pcdata "."])))]
else [])
)
)
let page_session_expired =
let s = "Session expired" in
html
(head (title (pcdata s)) [])
(body
[h1 [pcdata s]]
)
eliom-3.0.3/src/server/eliom_bus.mli 0000644 0000000 0000000 00000004456 12062377521 015604 0 ustar 00 0000000 0000000 (* Ocsigen
* http://www.ocsigen.org
* Copyright (C) 2010-2011
* Raphaël Proust
* Pierre Chambart
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exception;
* either version 2.1 of the License, or (at your option) any later version.
*
* This program 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
* GNU Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
(** Broadcasting facilities between clients and server *)
(** The type of bus's carrying values of type ['a]. Bus's are values
that can be easily shared among clients. Each of these clients
along with the server can send a value on the bus. Values can be
received by each of the participants as a stream. Note that no
effort is put to order message receptions on the different
participants. *)
type 'a t
(** [create ?scope ?name ?size] makes a fresh bus. The [name] optional
parameter can be used to make persistent (as in server restart
persistent) bus's. The [scope] parameter is used to chose the kind
of channel on which the bus rely (See [Eliom_comet.create] for
more information). The [?name] argument allow one to make bus's
persistent over server restart. The [size] argument behaves like
the one on {!Eliom_comet.Channel.create} *)
val create :
?scope:[< Eliom_comet.Channel.comet_scope ] -> ?name:string -> ?size:int
-> 'a Deriving_Json.t
-> 'a t
(** [stream b] returns the stream of datas sent to bus [b]. Notice you
sould not use that function multiple times on the same bus, it will
return the same stream. If you want to receive multiple times the
same datas, you sould copy the stream with [Lwt_stream.clone] *)
val stream : 'a t -> 'a Lwt_stream.t
(** [write b x] sends the value [x] on the bus [b]. Every participant,
including the server, will receive [x]. *)
val write : 'a t -> 'a -> unit
eliom-3.0.3/src/server/eliom_extension.mli 0000644 0000000 0000000 00000003160 12062377521 017016 0 ustar 00 0000000 0000000 (* Ocsigen
* http://www.ocsigen.org
* Copyright (C) 2008 Vincent Balat
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exception;
* either version 2.1 of the License, or (at your option) any later version.
*
* This program 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
* GNU Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
(** Allows Ocsigen's extension to access Eliom data. See the Eliom
manual for more information about {% <>%} *)
(** Type of the function that must be registered to declare an eliom extension. *)
type eliom_extension_sig = unit -> Ocsigen_extensions.answer Lwt.t
val register_eliom_extension : eliom_extension_sig -> unit
(**/**)
val get_eliom_extension : unit -> eliom_extension_sig
val run_eliom_extension :
eliom_extension_sig ->
float ->
(Ocsigen_extensions.request *
Eliom_common.sess_info *
Eliom_common.tables Eliom_common.cookie_info *
Eliom_common.tables Eliom_common.cookie_info *
Ocsigen_cookies.cookieset) ->
Eliom_common.sitedata ->
Ocsigen_extensions.answer Lwt.t
eliom-3.0.3/src/server/eliom_common.mli 0000644 0000000 0000000 00000061165 12062377521 016303 0 ustar 00 0000000 0000000 (* Ocsigen
* http://www.ocsigen.org
* Module eliom_common.mli
* Copyright (C) 2005 Vincent Balat
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exception;
* either version 2.1 of the License, or (at your option) any later version.
*
* This program 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
* GNU Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
(** Low level functions for Eliom, exceptions and types. *)
open Ocsigen_extensions
open Ocsigen_cookies
open Eliom_lib
(** {2 Scopes} *)
(* those types are not available to the user, a scope must be created using
create_..._scope functions *)
type scope_hierarchy = Eliom_common_base.scope_hierarchy
type cookie_scope = [ `Session of scope_hierarchy
| `Client_process of scope_hierarchy ]
type user_scope = [ `Session_group of scope_hierarchy
| cookie_scope ]
type scope = [ `Site
| user_scope ]
type all_scope = [ scope
| `Global
| `Request ]
type cookie_level = [ `Session | `Client_process ]
type user_level = [ `Session_group | cookie_level ]
val cookie_scope_of_user_scope : [< user_scope ] -> [> cookie_scope ]
val cookie_level_of_user_scope : [< user_scope ] -> [> cookie_level ]
val level_of_user_scope : [< user_scope ] -> [> user_level ]
(** Eliom is using regular (browser) cookies but can also use its own
browser tab cookies (only if you are using a client side Eliom application).
It is possible to define Eliom references or services for one
(browser) session, for one tab, or for one group of sessions.
Using [`Global] scope means you want the data or service to
be available to any client. [`Site] is limited to current sub-site
(if you have several sites on the same server).
If you want to restrict the visibility of an Eliom reference or
a service:
* to a browser session, use [~scope:Eliom_common.default_session_scope],
* to a group of sessions, use [~scope:Eliom_common.default_group_scope],
* to a client process, use [~scope:Eliom_common.default_process_scope].
If you have a client side Eliom program running, and you want to restrict
the visibility of the service to this instance of the program,
use [~scope:Eliom_common.default_process_scope].
You can create new scope
hierachies with {!Eliom_common.create_scope_hierarchy}.
Thus it is possible to have for example several sessions that can
be opened or closed independently. They use different cookies.
Secure scopes are associated to secure cookies (that is, cookies sent
by browsers only if the protocol is https).
*)
type global_scope = [`Global]
type site_scope = [`Site]
type session_group_scope = [`Session_group of scope_hierarchy]
type session_scope = [`Session of scope_hierarchy]
type client_process_scope = [`Client_process of scope_hierarchy]
type request_scope = [`Request]
val global_scope : global_scope
val site_scope : site_scope
val default_group_scope : session_group_scope
val default_session_scope : session_scope
val default_process_scope : client_process_scope
val comet_client_process_scope : client_process_scope
val request_scope : request_scope
val create_scope_hierarchy : string -> scope_hierarchy
val list_scope_hierarchies : unit -> scope_hierarchy list
(** {2 Exception and error handling} *)
(** Page not found *)
exception Eliom_404
(** Service called with wrong parameter names *)
exception Eliom_Wrong_parameter
exception Eliom_Session_expired
(** The service (GET or POST) parameters do not match expected type *)
exception Eliom_Typing_Error of (string * exn) list
(** That function cannot be used when the site information is not available,
that is, outside a request or the initialisation phase of your Eliom module
(while reading the configuration file).
In particular, you cannot use the function before the configuration file
is read for example when you are using {e static linking}.
In that case you must
delay the function call using {!Eliom_service.register_eliom_module}.
*)
exception Eliom_site_information_not_available of string
type full_state_name =
user_scope * bool (* secure *) * string (* site_dir_string *)
module Full_state_name_table : Map.S with type key = full_state_name
(** If present and true in request data, it means that
the previous coservice does not exist any more *)
val eliom_link_too_old : bool Polytables.key
(** If present in request data, means that
the service session cookies does not exist any more.
The string lists are the list of names of expired sessions
*)
val eliom_service_session_expired :
(full_state_name list * full_state_name list) Polytables.key
(**/**)
(*VVV Warning: raising these exceptions will NOT send cookies!
Do not use them inside services! *)
exception Eliom_do_redirection of string
(* Used to redirect to the suffix version of the service *)
exception Eliom_do_half_xhr_redirection of string
(** A [(v:tenable_value)] captures a value, which is available through [v#get].
The value can be be set to by [v#set]. However, once set by [v#set
~override_tenable:true] it can only be overridden by further calls to [v#set
~override_tenable:true]. Other attempts will be ignored. *)
type 'a tenable_value = < get : 'a ; set : ?override_tenable:bool -> 'a -> unit >
(** Create a named {!type:Eliom_common.tenable_value} with the given initial
value. The name will only be used for warnings when setting a strong value
isn't possible. *)
val tenable_value : name:string -> 'a -> 'a tenable_value
(* Service kinds: *)
type att_key_serv =
| SAtt_no (* regular service *)
| SAtt_named of string (* named coservice *)
| SAtt_anon of string (* anonymous coservice *)
| SAtt_csrf_safe of (int * user_scope * bool option)
(* CSRF safe anonymous coservice *)
(* CSRF safe service registration delayed until form/link creation *)
(* the int is an unique id,
the user_scope is used for delayed registration
(if the service is registered in the global table),
the bool option is the ?secure parameter for delayed registration
(if the service is registered in the global table) *)
type na_key_serv =
| SNa_no (* no na information *)
| SNa_void_keep (* void coservice that keeps GET na parameters *)
| SNa_void_dontkeep (* void coservice that does not keep GET na parameters *)
| SNa_get_ of string (* named *)
| SNa_post_ of string (* named *)
| SNa_get' of string (* anonymous *)
| SNa_post' of string (* anonymous *)
| SNa_get_csrf_safe of (int * user_scope * bool option)
(* CSRF safe anonymous coservice *)
| SNa_post_csrf_safe of (int * user_scope * bool option)
(* CSRF safe anonymous coservice *)
(* the same, for incoming requests: *)
type att_key_req =
| RAtt_no (* no coservice information *)
| RAtt_named of string (* named coservice *)
| RAtt_anon of string (* anonymous coservice *)
type na_key_req =
| RNa_no (* no na information *)
| RNa_get_ of string (* named *)
| RNa_post_ of string (* named *)
| RNa_get' of string (* anonymous *)
| RNa_post' of string (* anonymous *)
exception Eliom_duplicate_registration of string
exception Eliom_there_are_unregistered_services of
(string list * string list list * na_key_serv list)
exception Eliom_page_erasing of string
exception Eliom_error_while_loading_site of string
val defaultpagename : string
val eliom_suffix_name : string
val eliom_suffix_internal_name : string
val eliom_nosuffix_page : string
val naservice_num : string
val naservice_name : string
val get_state_param_name : string
val post_state_param_name : string
val get_numstate_param_name : string
val post_numstate_param_name : string
val co_param_prefix : string
val na_co_param_prefix : string
val nl_param_prefix : string
val eliom_internal_nlp_prefix : string
val pnl_param_prefix : string
val npnl_param_prefix : string
(*204FORMS* old implementation of forms with 204 and change_page_event
val internal_form_name : string
val internal_form_bool_name : string
*)
val datacookiename : string
val servicecookiename : string
val persistentcookiename : string
val persistent_cookie_table_version : string
val eliom_persistent_cookie_table : string
val inline_class_name : string
val nodisplay_class_name : string
val appl_name_cookie_name : string
val tab_cookies_param_name : string
val to_be_considered_as_get_param_name : string
val full_xhr_redir_header : string
val half_xhr_redir_header : string
val default_group_name : string
type client_process_info = {
cpi_ssl : bool;
cpi_hostname : string;
cpi_server_port : int;
cpi_original_full_path : Url.path;
}
type sess_info = {
si_other_get_params : (string * string) list;
si_all_get_params : (string * string) list;
si_all_post_params : (string * string) list option;
si_service_session_cookies : string Full_state_name_table.t;
si_data_session_cookies : string Full_state_name_table.t;
si_persistent_session_cookies : string Full_state_name_table.t;
si_secure_cookie_info:
(string Full_state_name_table.t *
string Full_state_name_table.t *
string Full_state_name_table.t) option;
si_service_session_cookies_tab: string Full_state_name_table.t;
si_data_session_cookies_tab: string Full_state_name_table.t;
si_persistent_session_cookies_tab: string Full_state_name_table.t;
si_secure_cookie_info_tab:
(string Full_state_name_table.t *
string Full_state_name_table.t *
string Full_state_name_table.t) option;
si_tab_cookies: string CookiesTable.t;
si_nonatt_info : na_key_req;
si_state_info: (att_key_req * att_key_req);
si_previous_extension_error : int;
si_na_get_params: (string * string) list Lazy.t;
si_nl_get_params: (string * string) list String.Table.t;
si_nl_post_params: (string * string) list String.Table.t;
si_persistent_nl_get_params: (string * string) list String.Table.t Lazy.t;
si_all_get_but_na_nl: (string * string) list Lazy.t;
si_all_get_but_nl: (string * string) list;
si_client_process_info: client_process_info option;
si_expect_process_data : bool Lazy.t;
(*204FORMS* si_internal_form: bool; *)
}
module SessionCookies : Hashtbl.S with type key = string
(* session groups *)
type 'a sessgrp =
(string * cookie_level
* (string, Ip_address.t) leftright)
(* The full session group is the triple
(site_dir_string, scope, session group name).
The scope is the scope of group members (`Session by default).
If there is no session group,
we limit the number of sessions by IP address. *)
type perssessgrp (* the same triple, marshaled *)
val make_persistent_full_group_name :
cookie_level:cookie_level -> string -> string option -> perssessgrp option
val getperssessgrp : perssessgrp ->
(string * cookie_level *
(string, Ip_address.t) leftright)
val string_of_perssessgrp : perssessgrp -> string
type 'a session_cookie = SCNo_data | SCData_session_expired | SC of 'a
type cookie_exp =
| CENothing (* keep current browser value *)
| CEBrowser (* ask to remove the cookie when the browser is closed *)
| CESome of float (* date (not duration!) *)
type timeout = TGlobal | TNone | TSome of float
type 'a one_service_cookie_info = {
sc_value : string;
sc_table : 'a ref;
sc_timeout : timeout ref;
sc_exp : float option ref;
sc_cookie_exp : cookie_exp ref;
sc_session_group: cookie_level sessgrp ref (* session group *);
mutable sc_session_group_node:string Ocsigen_cache.Dlist.node;
}
type one_data_cookie_info = {
dc_value : string;
dc_timeout : timeout ref;
dc_exp : float option ref;
dc_cookie_exp : cookie_exp ref;
dc_session_group: cookie_level sessgrp ref (* session group *);
mutable dc_session_group_node:string Ocsigen_cache.Dlist.node;
}
type one_persistent_cookie_info = {
pc_value : string;
pc_timeout : timeout ref;
pc_cookie_exp : cookie_exp ref;
pc_session_group : perssessgrp option ref;
}
type 'a cookie_info1 =
(string option * 'a one_service_cookie_info session_cookie ref)
Full_state_name_table.t ref *
(string option * one_data_cookie_info session_cookie ref) Lazy.t
Full_state_name_table.t ref *
((string * timeout * float option *
perssessgrp option)
option * one_persistent_cookie_info session_cookie ref)
Lwt.t Lazy.t Full_state_name_table.t ref
type 'a cookie_info =
'a cookie_info1 (* unsecure *) *
'a cookie_info1 option (* secure, if https *)
type 'a servicecookiestablecontent =
full_state_name * 'a * float option ref * timeout ref *
cookie_level sessgrp ref *
string Ocsigen_cache.Dlist.node
type 'a servicecookiestable =
'a servicecookiestablecontent SessionCookies.t
type datacookiestablecontent =
full_state_name * float option ref * timeout ref *
cookie_level sessgrp ref *
string Ocsigen_cache.Dlist.node
type datacookiestable =
datacookiestablecontent SessionCookies.t
type page_table_key = {
key_state : att_key_serv * att_key_serv;
key_kind : Ocsigen_http_frame.Http_header.http_method;
}
module NAserv_Table : Map.S with type key = na_key_serv
module Serv_Table : Map.S with type key = page_table_key
type dlist_ip_table
type anon_params_type = int
type node_ref = string
type node_info = {
ni_id : node_ref;
mutable ni_sent : bool;
}
module Hier_set : Set.S
type server_params = {
sp_request : Ocsigen_extensions.request;
sp_si : sess_info;
sp_sitedata : sitedata;
sp_cookie_info : tables cookie_info;
sp_tab_cookie_info : tables cookie_info;
mutable sp_user_cookies: Ocsigen_cookies.cookieset;
(* cookies (un)set by the user during service *)
mutable sp_user_tab_cookies: Ocsigen_cookies.cookieset;
mutable sp_client_appl_name: string option; (* The application name,
as sent by the browser *)
sp_suffix : Url.path option;
sp_full_state_name : full_state_name option;
sp_client_process_info: client_process_info;
(* Contains the base URL information from which the client process
has been launched (if any). All relative links and forms will be
created with respect to this information (if present - from
current URL otherwise). It is taken form a client process state
if the application has been launched before (and not timeouted on
server side). Otherwise, it is created and registered in a
server side state the first time we need it. *)
}
and page_table = page_table_content Serv_Table.t
and page_table_content =
Ptc of
(page_table ref * page_table_key, na_key_serv) leftright
Ocsigen_cache.Dlist.node option
(* for limitation of number of dynamic anonymous coservices *) *
((anon_params_type * anon_params_type)
(* unique_id, computed from parameters type.
must be the same even if the actual service reference
is different (after reloading the site)
so that it replaces the former one
*) *
(int ref option (* max_use *) *
(float * float ref) option
(* timeout and expiration date for the service *) *
(bool -> server_params -> Ocsigen_http_frame.result Lwt.t)
)) list
and naservice_table_content =
(int (* generation (= number of reloads of sites
after which that service has been created) *) *
int ref option (* max_use *) *
(float * float ref) option (* timeout and expiration date *) *
(server_params -> Ocsigen_http_frame.result Lwt.t) *
(page_table ref * page_table_key, na_key_serv) leftright
Ocsigen_cache.Dlist.node option
(* for limitation of number of dynamic coservices *)
)
and naservice_table =
| AVide
| ATable of naservice_table_content NAserv_Table.t
and dircontent = Vide | Table of direlt ref String.Table.t
and direlt = Dir of dircontent ref | File of page_table ref
and tables =
{mutable table_services : (int (* generation *) *
int (* priority *) *
dircontent ref) list;
table_naservices : naservice_table ref;
(* Information for the GC: *)
mutable table_contains_services_with_timeout : bool;
(* true if dircontent contains services with timeout *)
mutable table_contains_naservices_with_timeout : bool;
(* true if naservice_table contains services with timeout *)
mutable csrf_get_or_na_registration_functions :
(sp:server_params -> string) Int.Table.t;
mutable csrf_post_registration_functions :
(sp:server_params -> att_key_serv -> string) Int.Table.t;
(* These two table are used for CSRF safe services:
We associate to each service unique id the function that will
register a new anonymous coservice each time we create a link or form.
Attached POST coservices may have both a GET and POST
registration function. That's why there are two tables.
The functions associated to each service may be different for
each session. That's why we use these table, and not a field in
the service record.
*)
service_dlist_add :
?sp:server_params ->
(page_table ref * page_table_key, na_key_serv) leftright ->
(page_table ref * page_table_key, na_key_serv) leftright
Ocsigen_cache.Dlist.node
(* Add in a dlist
for limiting the number of dynamic anonymous coservices in each table
(and avoid DoS).
There is one dlist for each session, and one for each IP
in global tables.
The dlist parameter is the table and coservice number
for attached coservices,
and the coservice number for non-attached ones.
*)
}
and sitedata = {
site_dir : Url.path;
site_dir_string : string;
config_info: Ocsigen_extensions.config_info;
default_links_xhr : bool tenable_value;
(* Timeouts:
- default for site (browser sessions)
- default for site (tab sessions)
- then default for each full state name
The booleans means "has been set from config file"
*)
mutable servtimeout:
(float option * bool) option *
(float option * bool) option *
((full_state_name * (float option * bool)) list);
mutable datatimeout:
(float option * bool) option *
(float option * bool) option *
((full_state_name * (float option * bool)) list);
mutable perstimeout:
(float option * bool) option *
(float option * bool) option *
((full_state_name * (float option * bool)) list);
site_value_table : Polytables.t; (* table containing evaluated
lazy site values *)
mutable registered_scope_hierarchies: Hier_set.t;
global_services : tables;
session_services : tables servicecookiestable;
session_data : datacookiestable;
group_of_groups: [ `Session_group ] sessgrp Ocsigen_cache.Dlist.t;
(* Limitation of the number of groups per site *)
mutable remove_session_data : string -> unit;
mutable not_bound_in_data_tables : string -> bool;
mutable exn_handler : exn -> Ocsigen_http_frame.result Lwt.t;
mutable unregistered_services : Url.path list;
mutable unregistered_na_services : na_key_serv list;
mutable max_volatile_data_sessions_per_group : int * bool;
mutable max_volatile_data_sessions_per_subnet : int * bool;
mutable max_volatile_data_tab_sessions_per_group : int * bool;
mutable max_service_sessions_per_group : int * bool;
mutable max_service_sessions_per_subnet : int * bool;
mutable max_service_tab_sessions_per_group : int * bool;
mutable max_persistent_data_sessions_per_group : int option * bool;
mutable max_persistent_data_tab_sessions_per_group : int option * bool;
mutable max_anonymous_services_per_session : int * bool;
mutable max_anonymous_services_per_subnet : int * bool;
dlist_ip_table : dlist_ip_table;
mutable ipv4mask : int32 option * bool;
mutable ipv6mask : (int64 * int64) option * bool;
}
type 'a lazy_site_value (** lazy site values, are lazy values with
content available only in the context of a
site: the closure one time for each site (
requesting it ) *)
val force_lazy_site_value : 'a lazy_site_value -> 'a
val lazy_site_value_from_fun : ( unit -> 'a ) -> 'a lazy_site_value
type info =
(Ocsigen_extensions.request * sess_info *
tables cookie_info * tables cookie_info * Ocsigen_cookies.cookieset)
exception Eliom_retry_with of info
val make_server_params :
sitedata ->
info ->
Url.path option ->
full_state_name option -> server_params
val empty_page_table : unit -> page_table
val empty_dircontent : unit -> dircontent
val empty_naservice_table : unit -> naservice_table
val service_tables_are_empty : tables -> bool
val empty_tables : int -> bool -> tables
val new_service_session_tables : sitedata -> tables
val split_prefix_param :
string -> (string * 'a) list -> (string * 'a) list * (string * 'a) list
val get_session_info :
Ocsigen_extensions.request ->
int -> (Ocsigen_extensions.request * sess_info *
(tables cookie_info * Ocsigen_cookies.cookieset) option) Lwt.t
type ('a, 'b) foundornot = Found of 'a | Notfound of 'b
val make_full_cookie_name : string -> full_state_name -> string
val make_full_state_name :
sp:server_params -> secure:bool -> scope:[< user_scope ] -> full_state_name
val make_full_state_name2 :
string -> bool -> scope:[< user_scope ] -> full_state_name
module Perstables :
sig
val empty : 'a list
val add : 'a -> 'a list -> 'a list
val fold : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a
end
val perstables : string list ref
val create_persistent_table : string -> 'a Ocsipersist.table
val persistent_cookies_table :
(full_state_name * float option * timeout * perssessgrp option)
Ocsipersist.table Lazy.t
val remove_from_all_persistent_tables : string -> unit Lwt.t
val absolute_change_sitedata : sitedata -> unit
val get_current_sitedata : unit -> sitedata
val end_current_sitedata : unit -> unit
val add_unregistered : sitedata -> Url.path -> unit
val add_unregistered_na : sitedata -> na_key_serv -> unit
val remove_unregistered : sitedata -> Url.path -> unit
val remove_unregistered_na : sitedata -> na_key_serv -> unit
val verify_all_registered : sitedata -> unit
val during_eliom_module_loading : unit -> bool
val begin_load_eliom_module : unit -> unit
val end_load_eliom_module : unit -> unit
val global_register_allowed : unit -> (unit -> sitedata) option
(** Get the site data, which is only available {e during the loading of eliom
modules, and during a request.} *)
val get_site_data : unit -> sitedata
val eliom_params_after_action :
((string * string) list * (string * string) list option *
(string * string) list String.Table.t *
(string * string) list String.Table.t *
(string * string) list (*204FORMS* * bool *))
Polytables.key
val att_key_serv_of_req : att_key_req -> att_key_serv
val na_key_serv_of_req : na_key_req -> na_key_serv
val remove_naservice_table :
naservice_table -> NAserv_Table.key -> naservice_table
val get_mask4 : sitedata -> int32
val get_mask6 : sitedata -> (int64 * int64)
val ipv4mask : int32 ref
val ipv6mask : (int64 * int64) ref
val create_dlist_ip_table : int -> dlist_ip_table
val find_dlist_ip_table :
int32 option * 'a ->
(int64 * int64) option * 'a ->
dlist_ip_table -> Ip_address.t ->
(page_table ref * page_table_key, na_key_serv)
leftright Ocsigen_cache.Dlist.t
val get_cookie_info : server_params -> [< cookie_level ] -> tables cookie_info
val tab_cookie_action_info_key : (tables cookie_info *
Ocsigen_cookies.cookieset *
string CookiesTable.t) Polytables.key
val sp_key : server_params Lwt.key
val get_sp_option : unit -> server_params option
val get_sp : unit -> server_params
val sp_of_option : server_params option -> server_params
val found_stop_key : unit Polytables.key
(**** Wrapper type shared by client/server side ***)
type 'a wrapper = 'a Eliom_wrap.wrapper
val make_wrapper : ('a -> 'b) -> 'a wrapper
val empty_wrapper : unit -> 'a wrapper
type unwrapper = Eliom_wrap.unwrapper
type unwrap_id = Eliom_wrap.unwrap_id
val make_unwrapper : unwrap_id -> unwrapper
val empty_unwrapper : unwrapper
val react_up_unwrap_id : unwrap_id
val react_down_unwrap_id : unwrap_id
val signal_down_unwrap_id : unwrap_id
val comet_channel_unwrap_id : unwrap_id
val bus_unwrap_id : unwrap_id
val nl_get_appl_parameter: string
val patch_request_info: Ocsigen_extensions.request -> Ocsigen_extensions.request
eliom-3.0.3/src/server/eliom_registration.mli 0000644 0000000 0000000 00000045700 12062377521 017522 0 ustar 00 0000000 0000000 (* Ocsigen
* http://www.ocsigen.org
* Module Eliom_registration
* Copyright (C) 2007 Vincent Balat
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exception;
* either version 2.1 of the License, or (at your option) any later version.
*
* This program 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
* GNU Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
(** Eliom services registration for various kinds of
page content: Eliom application, valid {!Html5},
actions, redirections, static files, … *)
(** See the Eliom manual for
more information on {% <>%} and {% <>%}. *)
(** {% <> %}*)
open Eliom_lib
open Eliom_content_core
(** {2 Type definitions} *)
(** The type [kind] is an abstract type for the HTTP frame returned by
a service. The type parameters are phantom types describing the
content of the frame:
- The second parameter is the same as the last type parameters of
the corresponding {!type:Eliom_service.service}. Currently, one of the
following types:
{ul {- {!Eliom_registration.appl_service}}
{- {!Eliom_registration.http_service}}
{- {!Eliom_parameter.caml}} }
- The first parameter is a refinement of the second
parameter. Currently, one of the following types:
{ul {- {!application_content}}
{- {!browser_content}}
{- {!block_content}}
{- {!unknown_content}}
{- {!caml_content}}}
*)
type ('a, 'b) kind
(** {3 Return types for {!type:Eliom_service.service} } *)
(** {4 Classical content} *)
(** The type [http_service] is used as a phantom type parameters for
{!Eliom_service.service} and {!Eliom_registration.kind}. It means the
returned content is classical HTTP content described by the
content type header. See {!Eliom_registration.kind} for a list of others
return types. *)
type http_service = [ `Http ]
(** The type [browser_content] is a refinement of {!http_service} to
be used as a phantom type parameters for {!Eliom_registration.kind}. It
means the returned content must be interpreted in the browser as
stated by the content-type header. This is most common return type
for an eliom service, see for example {!Html5},
{!CssText}, {!File}, {!Redirection}, ….*)
type browser_content = [ `Browser ]
(** The type [block_content] is a refinement of {!http_service} to be
used as a phantom type parameters for {!Eliom_registration.kind}. It
means the returned content is a subtree of an XML value. See for
example {!Block5} or {!Make_typed_xml_registration}. *)
type block_content
(** The type [unknown_content] is a refinement of {!http_service} to
be used as a phantom type parameters for {!Eliom_registration.kind} when
the content-type can't be determined staticaly. See {!Text} or
{!Any}. *)
type unknown_content
(** {4 Application content} *)
(** The type [appl_service] is used as a phantom type parameters for
{!Eliom_service.service} and {!Eliom_registration.kind}. It means the
service is part of an Eliom application. See {!Eliom_registration.kind}
for a list of others return types. *)
type appl_service = [ `Appl ]
(** The type [application_content] is a refinement of {!appl_service}
to be used as a phantom type parameters for {!Eliom_registration.kind}. The
parameter ['a] is phantom type that is unique for a given
application. *)
type 'a application_content = [ `Appl of 'a ]
(**/**)
type 'a application_name
(**/**)
(** {4 OCaml content} *)
(** The type [caml_content] is an synomyn for {!Eliom_parameter.caml}
to be used as a phantom type parameters for {!Eliom_registration.kind}. See
{!Ocaml}. *)
type 'a caml_content
(** The type [non_caml_service] is used as phantom type parameters for
the {!Eliom_registration.kind}. It used to type functions that operates
over service that do not returns OCaml values, like
{!appl_self_redirect}. *)
type non_caml_service = [ appl_service | http_service ]
(** {3 Module signature} *)
(** Abstract signature for service registration functions. For
concrete instance see {!Html5}, {!CssText}, {!File},
{!Redirection}, … *)
module type Registration = sig
type page
type options
type return
type result
include "sigs/eliom_reg_simpl.mli"
end
(** {2 Using HTML5 with services } *)
(** Eliom service registration for services that returns HTML5
page. This is a subset of the {!Html5} module and an instance of
the {!Registration} abstract signature. *)
module Html5_registration : "sigs/eliom_html5_reg.mli"
(** Eliom service registration for HTML5 page. This
an instance the {!modtype:Registration} abstract signatures. *)
module Html5 : sig
include "sigs/eliom_html5_reg.mli"
end
(** {2 Eliom client/server applications} *)
(** Signature for application creation. *)
module type APPL_PARAMS = sig
(** Name of the application.
Two distincts applications must have distincts names.
*)
val application_name : string
end
(** Type for the options of an Eliom application service.
If you set [do_not_launch] to [true] when creating an application
service, it will send the page without launching the client side
program. However, if the program is already lanched, the client
side process won't be stopped. Use this if some of your pages are
not using the client side program and you want to make them load
faster.
*)
type appl_service_options =
{
do_not_launch : bool;
(** Do not launch the client side program if it is not already
launched. Default: [false]. *)
}
(** The default options record for an eliom service. See
{!appl_service_options}. *)
val default_appl_service_options : appl_service_options
module type ELIOM_APPL = sig
(** The function [application_name ()] returns a ["
end
(****************************************************************************)
(****************************************************************************)
module Textforms = MakeForms(Textforms_)
module Textreg = MakeRegister(Textreg_)
module Text = struct
include Textforms
include Textreg
end
eliom-3.0.3/src/legacy/oldocsigenmod/ocsigenboxes.mli 0000644 0000000 0000000 00000002306 12062377521 021072 0 ustar 00 0000000 0000000 (** Predefined boxes for Ocsigenmod *)
val menu : ?classe:XHTML.F.nmtoken list ->
((unit,unit, [<`Internal_Service of [<`Public_Service | `Local_Service] | `External_Service],[<`WithSuffix|`WithoutSuffix] as 'tipo,unit Ocsigen.param_name, unit Ocsigen.param_name)
Ocsigen.service * Xhtmltypes.a_content XHTML.F.elt list)
->
((unit,unit, [<`Internal_Service of [<`Public_Service | `Local_Service] | `External_Service],[<`WithSuffix|`WithoutSuffix] as 'tipo,unit Ocsigen.param_name, unit Ocsigen.param_name)
Ocsigen.service * Xhtmltypes.a_content XHTML.F.elt list)
list ->
(unit,unit, [<`Internal_Service of [<`Public_Service | `Local_Service] | `External_Service],'tipo, unit Ocsigen.param_name, unit Ocsigen.param_name) Ocsigen.service ->
Ocsigen.server_params -> [> `Ul ] XHTML.F.elt
(** Creates a menu
Example:
[menu ~classe:["mainmenu"]
[
(home, <:xmllist< Home >>);
(infos, <:xmllist< More infos >>)
] current sp]
Tip: How to make a menu with different kinds of services (external, internal...)?
You need to coerce each of them. For example
[(home :> (('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, Ocsigen.service_kind) service))]
*)
eliom-3.0.3/src/legacy/oldocsigenmod/ocsigenduce.ml 0000644 0000000 0000000 00000016062 12062377521 020525 0 ustar 00 0000000 0000000 (* Ocsigen
* http://www.ocsigen.org
* Module ocsigenduce.ml
* Copyright (C) 2007 Vincent Balat, Alain Frisch
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exception;
* either version 2.1 of the License, or (at your option) any later version.
*
* This program 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
* GNU Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
open Ocsigen_http_frame
open Ocsigen_http_com
open Lwt
open Ocsigen_senders
open Xhtmltypes_duce
let add_css (a : html) : html =
let css =
{{