[nurpawiki commit] r462 - trunk
codesite...@google.com
Date: Wed Jan 14 09:05:25 2009
New Revision: 462
Modified:
trunk/about.ml
trunk/database.ml
trunk/database.mli
trunk/html_util.ml
trunk/main.ml
trunk/page_revisions.ml
trunk/session.ml
trunk/user_editor.ml
Log:
Lwt-ization
Modified: trunk/about.ml
==============================================================================
--- trunk/about.ml (original)
+++ trunk/about.ml Wed Jan 14 09:05:25 2009
@@ -43,5 +43,6 @@
(fun sp () () ->
Session.with_guest_login sp
(fun cur_user sp ->
- Html_util.html_stub sp
- (Html_util.navbar_html sp ~cur_user about_page_html)))
+ return
+ (Html_util.html_stub sp
+ (Html_util.navbar_html sp ~cur_user about_page_html))))
Modified: trunk/database.ml
==============================================================================
--- trunk/database.ml (original)
+++ trunk/database.ml Wed Jan 14 09:05:25 2009
@@ -96,7 +96,8 @@
end
-let with_conn = ConnectionPool.with_conn
+let with_conn f =
+ Lwt_preemptive.detach ConnectionPool.with_conn f
(* Escape a string for SQL query *)
let escape s =
Modified: trunk/database.mli
==============================================================================
--- trunk/database.mli (original)
+++ trunk/database.mli Wed Jan 14 09:05:25 2009
@@ -16,7 +16,7 @@
type connection
-val with_conn : (connection -> 'a) -> 'a
+val with_conn : (connection -> 'a) -> 'a Lwt.t
val guarded_exec : conn:connection -> string -> Postgresql.result
val insert_save_page_activity :
conn:connection -> user_id:int -> int -> unit
Modified: trunk/html_util.ml
==============================================================================
--- trunk/html_util.ml (original)
+++ trunk/html_util.ml Wed Jan 14 09:05:25 2009
@@ -39,17 +39,15 @@
js_script ~a:[a_defer `Defer] ~uri:(make_static_uri sp src) () in
let scripts =
script ["nurpawiki.js"] :: (List.map script javascript) in
- return
- (html ~a:[a_xmlns `W3_org_1999_xhtml]
- (head
- (title (pcdata ""))
- ((scripts) @
- [css_link ~a:[] ~uri:(make_uri ~service:(static_dir sp) ~sp
- ["style.css"]) ();
- css_link ~a:[] ~uri:(make_uri ~service:(static_dir sp) ~sp
- ["jscalendar"; "calendar-blue2.css"])
()]))
- (body
- body_html))
+ html ~a:[a_xmlns `W3_org_1999_xhtml]
+ (head
+ (title (pcdata ""))
+ ((scripts) @
+ [css_link ~a:[] ~uri:(make_uri ~service:(static_dir sp) ~sp
+ ["style.css"]) ();
+ css_link ~a:[] ~uri:(make_uri ~service:(static_dir sp) ~sp
+ ["jscalendar"; "calendar-blue2.css"])
()]))
+ (body body_html)
let is_guest user =
user.user_login = "guest"
Modified: trunk/main.ml
==============================================================================
--- trunk/main.ml (original)
+++ trunk/main.ml Wed Jan 14 09:05:25 2009
@@ -790,12 +790,13 @@
html_of_headline sr.sr_headline)]
| SR_todo -> assert false) search_results) in
let gen_search_page sp ~cur_user search_str =
- let search_results =
- Db.with_conn (fun conn -> Db.search_wikipage ~conn search_str) in
- Html_util.html_stub sp
- (Html_util.navbar_html sp ~cur_user
- ([h1 [pcdata "Search results"]] @ (render_results sp
search_results))) in
-
+ Db.with_conn (fun conn -> Db.search_wikipage ~conn search_str) >>= fun
search_results ->
+ return
+ (Html_util.html_stub sp
+ (Html_util.navbar_html sp ~cur_user
+ ([h1 [pcdata "Search results"]] @ (render_results sp
search_results))))
+ in
+
register search_page
(fun sp search_str () ->
Session.with_guest_login sp
Modified: trunk/page_revisions.ml
==============================================================================
--- trunk/page_revisions.ml (original)
+++ trunk/page_revisions.ml Wed Jan 14 09:05:25 2009
@@ -31,8 +31,7 @@
module Db = Database
let revision_table sp page_descr =
- let revisions =
- Db.with_conn (fun conn -> Db.query_page_revisions ~conn page_descr) in
+ Db.with_conn (fun conn -> Db.query_page_revisions ~conn page_descr) >>=
fun revisions ->
let page_link descr (rev:int) =
a ~sp ~service:wiki_view_page [pcdata ("Revision "^(string_of_int
rev))]
@@ -46,17 +45,20 @@
td [pcdata (Option.default "" r.pr_owner_login)]])
revisions in
- [table
- (tr (th [pcdata "Revision"]) [th [pcdata "When"]; th [pcdata "Changed
by"]])
- rows]
+ return
+ [table
+ (tr (th [pcdata "Revision"]) [th [pcdata "When"]; th
[pcdata "Changed by"]])
+ rows]
let view_page_revisions sp page_descr =
Session.with_guest_login sp
- (fun cur_user sp ->
- Html_util.html_stub sp
- (Html_util.navbar_html sp ~cur_user
- (h1 [pcdata (page_descr ^ " Revisions")] :: revision_table sp
page_descr)))
+ (fun cur_user sp ->
+ revision_table sp page_descr >>= fun revisions ->
+ return
+ (Html_util.html_stub sp
+ (Html_util.navbar_html sp ~cur_user
+ (h1 [pcdata (page_descr ^ " Revisions")] :: revisions))))
(* /page_revisions?page_id=<id> *)
let _ =
Modified: trunk/session.ml
==============================================================================
--- trunk/session.ml (original)
+++ trunk/session.ml Wed Jan 14 09:05:25 2009
@@ -125,42 +125,41 @@
let with_db_installed sp f =
(* Check if the DB is installed. If so, check that it doesn't need
an upgrade. *)
- let r =
- Db.with_conn
- (fun conn ->
- if not (Dbu.is_schema_installed ~conn) then
- Some (Html_util.html_stub sp (db_installation_error sp))
- else if Dbu.db_schema_version ~conn < Db.nurpawiki_schema_version
then
- Some (Html_util.html_stub sp (db_upgrade_warning sp))
- else None) in
- match r with
- Some x -> x
- | None -> f ()
-
+ Db.with_conn
+ (fun conn ->
+ if not (Dbu.is_schema_installed ~conn) then
+ Some (Html_util.html_stub sp (db_installation_error sp))
+ else if Dbu.db_schema_version ~conn < Db.nurpawiki_schema_version
then
+ Some (Html_util.html_stub sp (db_upgrade_warning sp))
+ else None)
+ >>= function
+ | Some x -> return x
+ | None -> f ()
+
(** Wrap page service calls inside with_user_login to have them
automatically check for user login and redirect to login screen if
not logged in. *)
let with_user_login ?(allow_read_only=false) sp f =
let login () =
- get_login_user sp >>= fun maybe_user ->
- match maybe_user with
- Some (login,passwd) ->
+ get_login_user sp
+ >>= function
+ | Some (login,passwd) ->
begin
- let u =
- Db.with_conn
- (fun conn -> Db.query_user ~conn login) in
- match u with
- Some user ->
- let passwd_md5 = Digest.to_hex (Digest.string passwd) in
- (* Autheticate user against his password *)
- if passwd_md5 <> user.user_passwd then
- login_html sp
- [Html_util.error ("Wrong password given for
user '"^login^"'")]
- else
- f user sp
- | None ->
- login_html sp
- [Html_util.error ("Unknown user '"^login^"'")]
+ Db.with_conn (fun conn -> Db.query_user ~conn login)
+ >>= function
+ | Some user ->
+ let passwd_md5 = Digest.to_hex (Digest.string passwd) in
+ (* Autheticate user against his password *)
+ if passwd_md5 <> user.user_passwd then
+ return
+ (login_html sp
+ [Html_util.error ("Wrong password given for
user '"^login^"'")])
+ else
+ f user sp
+ | None ->
+ return
+ (login_html sp
+ [Html_util.error ("Unknown user '"^login^"'")])
end
| None ->
if allow_read_only && Config.site.cfg_allow_ro_guests then
@@ -174,7 +173,8 @@
} in
f guest_user sp
else
- login_html sp [] in
+ return (login_html sp [])
+ in
with_db_installed sp login
(* Either pretend to be logged in as 'guest' (if allowed by config
@@ -190,27 +190,27 @@
there are any errors, just bail out without doing anything
harmful. *)
let action_with_user_login sp f =
- let db_version =
- Db.with_conn (fun conn -> Dbu.db_schema_version conn) in
+ Db.with_conn (fun conn -> Dbu.db_schema_version conn) >>= fun db_version
->
if db_version = Db.nurpawiki_schema_version then
- get_login_user sp >>= fun maybe_user ->
- (match maybe_user with
- Some (login,passwd) ->
- begin
- match (Db.with_conn (fun conn -> Db.query_user ~conn login))
with
- Some user ->
- let passwd_md5 = Digest.to_hex (Digest.string passwd) in
- (* Autheticate user against his password *)
- if passwd_md5 = user.user_passwd then
- return (f user)
- else
- return []
- | None ->
- return []
- end
- | None -> return [])
- else
- return []
+ get_login_user sp
+ >>= function
+ | Some (login,passwd) ->
+ begin
+ Db.with_conn (fun conn -> Db.query_user ~conn login)
+ >>= function
+ | Some user ->
+ let passwd_md5 = Digest.to_hex (Digest.string passwd) in
+ (* Autheticate user against his password *)
+ if passwd_md5 = user.user_passwd then
+ f user
+ else
+ return []
+ | None ->
+ return []
+ end
+ | None -> return []
+ else
+ return []
let update_session_password sp login new_password =
@@ -252,28 +252,31 @@
let _ =
register schema_install_page
(fun sp () () ->
- Db.with_conn (fun conn -> Database_schema.install_schema ~conn);
- Html_util.html_stub sp
- [h1 [pcdata "Database installation completed"];
- p [br ();
- link_to_nurpawiki_main sp]])
+ Db.with_conn (fun conn -> Database_schema.install_schema ~conn) >>=
fun _ ->
+ return
+ (Html_util.html_stub sp
+ [h1 [pcdata "Database installation completed"];
+ p [br ();
+ link_to_nurpawiki_main sp]]))
(* /upgrade upgrades the database schema (if needed) *)
let _ =
register upgrade_page
(fun sp () () ->
- let msg = Db.with_conn (fun conn -> Dbu.upgrade_schema ~conn) in
- Html_util.html_stub sp
- [h1 [pcdata "Upgrade DB schema"];
- (pre [pcdata msg]);
- p [br ();
- link_to_nurpawiki_main sp]])
+ Db.with_conn (fun conn -> Dbu.upgrade_schema ~conn) >>= fun msg ->
+ return
+ (Html_util.html_stub sp
+ [h1 [pcdata "Upgrade DB schema"];
+ (pre [pcdata msg]);
+ p [br ();
+ link_to_nurpawiki_main sp]]))
let _ =
register disconnect_page
(fun sp () () ->
(Eliom_sessions.close_session ~sp () >>= fun () ->
- Html_util.html_stub sp
- [h1 [pcdata "Logged out!"];
- p [br ();
- link_to_nurpawiki_main sp]]))
+ return
+ (Html_util.html_stub sp
+ [h1 [pcdata "Logged out!"];
+ p [br ();
+ link_to_nurpawiki_main sp]])))
Modified: trunk/user_editor.ml
==============================================================================
--- trunk/user_editor.ml (original)
+++ trunk/user_editor.ml Wed Jan 14 09:05:25 2009
@@ -14,6 +14,7 @@
* If not, see <http://www.gnu.org/licenses/>.
*)
+open Lwt
open XHTML.M
open Eliom_sessions
open Eliom_parameters
@@ -48,7 +49,7 @@
let rec view_user_admin_page sp ~err ~cur_user =
- let users = Db.with_conn (fun conn -> Db.query_users ~conn) in
+ Db.with_conn (fun conn -> Db.query_users ~conn) >>= fun users ->
let users_table =
table
(tr
@@ -68,37 +69,38 @@
(Some "user_admin", user.user_login)]])
users) in
- Html_util.html_stub sp
- (Html_util.navbar_html sp ~cur_user
- ([h1 [pcdata "Edit users"];
- users_table] @
- err @
- [post_form ~service:service_create_new_user ~sp
- (fun (login,(passwd,(passwd2,(name,email)))) ->
- [h2 [pcdata "Create a new user"];
- (table
- (tr
- (td [pcdata "Login:"])
- [td [string_input ~input_type:`Text ~name:login ()]])
- [tr
- (td [pcdata "Password:"])
- [td [string_input ~input_type:`Password ~name:passwd
()]];
-
- tr
- (td [pcdata "Re-type password:"])
- [td [string_input ~input_type:`Password
~name:passwd2 ()]];
-
- tr
- (td [pcdata "Name:"])
- [td [string_input ~input_type:`Text ~name:name ()]];
-
- tr
- (td [pcdata "E-mail address:"])
- [td [string_input ~input_type:`Text ~name:email ()]];
-
- tr
- (td [string_input ~input_type:`Submit ~value:"Add
User" ()])
- []])]) ()]))
+ return
+ (Html_util.html_stub sp
+ (Html_util.navbar_html sp ~cur_user
+ ([h1 [pcdata "Edit users"];
+ users_table] @
+ err @
+ [post_form ~service:service_create_new_user ~sp
+ (fun (login,(passwd,(passwd2,(name,email)))) ->
+ [h2 [pcdata "Create a new user"];
+ (table
+ (tr
+ (td [pcdata "Login:"])
+ [td [string_input ~input_type:`Text ~name:login
()]])
+ [tr
+ (td [pcdata "Password:"])
+ [td [string_input ~input_type:`Password
~name:passwd ()]];
+
+ tr
+ (td [pcdata "Re-type password:"])
+ [td [string_input ~input_type:`Password
~name:passwd2 ()]];
+
+ tr
+ (td [pcdata "Name:"])
+ [td [string_input ~input_type:`Text ~name:name
()]];
+
+ tr
+ (td [pcdata "E-mail address:"])
+ [td [string_input ~input_type:`Text ~name:email
()]];
+
+ tr
+ (td [string_input ~input_type:`Submit ~value:"Add
User" ()])
+ []])]) ()])))
(* Only allow certain types of login names to avoid surprises *)
let sanitize_login_name name =
@@ -109,15 +111,15 @@
let sanitized_login = sanitize_login_name login in
match sanitized_login with
None ->
- [Html_util.error ("Only alphanumeric chars are allowed in login
name! Got '"^login^"'")]
+ return [Html_util.error ("Only alphanumeric chars are allowed in
login name! Got '"^login^"'")]
| Some login ->
- let old_user = query_user login in
+ query_user login >>= fun old_user ->
if not update_user && old_user <> None then
- [Html_util.error ("User '"^login^"' already exists!")]
+ return [Html_util.error ("User '"^login^"' already exists!")]
else if login = "guest" then
- [Html_util.error ("Cannot create '"^login^"' user. The login
name 'guest' is reserved for internal use!")]
+ return [Html_util.error ("Cannot create '"^login^"' user. The
login name 'guest' is reserved for internal use!")]
else if passwd <> passwd2 then
- [Html_util.error "Re-typed password doesn't match your password!"]
+ return [Html_util.error "Re-typed password doesn't match your
password!"]
else
begin
let passwd_md5 = Digest.to_hex (Digest.string passwd) in
@@ -131,15 +133,16 @@
Db.with_conn
(fun conn ->
Db.update_user ~conn
- ~user_id:u.user_id ~passwd:new_passwd_md5
~real_name ~email);
+ ~user_id:u.user_id ~passwd:new_passwd_md5
~real_name ~email)
+ >>= fun _ -> return []
| None ->
assert false
end
else
- Db.with_conn
+ Db.with_conn
(fun conn ->
- Db.add_user ~conn ~login ~passwd:passwd_md5 ~real_name
~email);
- []
+ Db.add_user ~conn ~login ~passwd:passwd_md5 ~real_name
~email)
+ >>= fun _ -> return []
end
let _ =
@@ -149,10 +152,10 @@
(fun cur_user sp ->
Privileges.with_can_create_user cur_user
(fun () ->
- let err = save_user ~update_user:false
- ~login ~passwd ~passwd2 ~real_name ~email in
+ save_user ~update_user:false
+ ~login ~passwd ~passwd2 ~real_name ~email >>= fun err ->
view_user_admin_page sp ~err ~cur_user)
- ~on_fail:(fun e -> Html_util.error_page sp e)))
+ ~on_fail:(fun e -> return (Html_util.error_page sp e))))
let save_user_prefs c_passwd c_passwd2 (c_name,old_name)
(c_email,old_email) =
@@ -187,7 +190,7 @@
Privileges.with_can_view_users cur_user
(fun () ->
view_user_admin_page sp ~err:[] ~cur_user)
- ~on_fail:(fun e -> Html_util.error_page sp e)))
+ ~on_fail:(fun e -> return (Html_util.error_page sp e))))
let rec view_edit_user_page sp caller ~err ~cur_user user_to_edit =
@@ -209,35 +212,36 @@
(fun sp (caller,login) (passwd,(passwd2,(real_name, email))) ->
Session.with_user_login sp
(fun cur_user sp ->
- match query_user login with
- Some user_to_edit ->
- Privileges.with_can_edit_user cur_user user_to_edit
- (fun () ->
- let err =
- save_user
- ~update_user:true
- ~login:login
- ~passwd ~passwd2 ~real_name ~email in
- (* Update password in the session if we're editing
current
- user: *)
- if err = [] && passwd <> "" && cur_user.user_login =
login then
- Session.update_session_password sp login passwd;
- Session.with_user_login sp
- (fun cur_user sp ->
- match caller with
- Some "user_admin" ->
- view_user_admin_page sp ~err ~cur_user
- | Some _ ->
- Html_util.error_page sp ("Invalid caller
service!")
- | None ->
- match query_user login with
- Some user ->
- view_edit_user_page sp caller ~err
~cur_user user
+ query_user login
+ >>= function
+ | Some user_to_edit ->
+ Privileges.with_can_edit_user cur_user user_to_edit
+ (fun () ->
+ save_user
+ ~update_user:true
+ ~login:login
+ ~passwd ~passwd2 ~real_name ~email >>= fun err
->
+ (* Update password in the session if we're editing
current
+ user: *)
+ if err = [] && passwd <> "" && cur_user.user_login
= login then
+ Session.update_session_password sp login passwd;
+ Session.with_user_login sp
+ (fun cur_user sp ->
+ match caller with
+ Some "user_admin" ->
+ view_user_admin_page sp ~err ~cur_user
+ | Some _ ->
+ return (Html_util.error_page sp
("Invalid caller service!"))
| None ->
- Html_util.error_page sp ("Invalid
user!")))
- ~on_fail:(fun e -> Html_util.error_page sp e)
- | None ->
- Html_util.error_page sp ("Trying to edit unknown
user '"^login^"'")))
+ query_user login
+ >>= function
+ | Some user ->
+ return (view_edit_user_page sp
caller ~err ~cur_user user)
+ | None ->
+ return (Html_util.error_page sp
("Invalid user!"))))
+ ~on_fail:(fun e -> return (Html_util.error_page sp e))
+ | None ->
+ return (Html_util.error_page sp ("Trying to edit unknown
user '"^login^"'"))))
let _ =
@@ -245,11 +249,12 @@
(fun sp (caller,editing_login) () ->
Session.with_user_login sp
(fun cur_user sp ->
- match query_user editing_login with
- Some user_to_edit ->
- Privileges.with_can_edit_user cur_user user_to_edit
- (fun () ->
- view_edit_user_page sp caller ~err:[] ~cur_user
user_to_edit)
- ~on_fail:(fun e -> Html_util.error_page sp e)
- | None ->
- Html_util.error_page sp ("Unknown
user '"^editing_login^"'")))
+ query_user editing_login
+ >>= function
+ | Some user_to_edit ->
+ Privileges.with_can_edit_user cur_user user_to_edit
+ (fun () ->
+ return (view_edit_user_page sp caller ~err:[]
~cur_user user_to_edit))
+ ~on_fail:(fun e -> return (Html_util.error_page sp e))
+ | None ->
+ return (Html_util.error_page sp ("Unknown
user '"^editing_login^"'"))))