debian/0000755000000000000000000000000012274220117007164 5ustar debian/watch0000644000000000000000000000065112131017746010223 0ustar version=3 opts=uversionmangle=s/(\d)[_\.\-\+]?((RC|rc|pre|dev|beta|alpha|b|a)[\-\.]?\d*)$/$1~$2/,\ downloadurlmangle=s%.*/([^/]*)/downloads/detail\?name=([^=&]*).*%http://$1.googlecode.com/files/$2%,filenamemangle=s/.*name=([^&]+).*/$1/ \ http://code.google.com/p/nurpawiki/downloads/list?can=1 .*=nurpawiki-(\d.*)\.(?:tgz|tbz2|txz|tar\.(?:gz|bz2|xz)|zip).* # Bart Martens Sat, 19 Jan 2013 13:20:56 +0000 debian/clean0000644000000000000000000000002011347443073010171 0ustar META version.ml debian/nurpawiki.install.in0000644000000000000000000000003512131017746013174 0ustar files/* usr/share/nurpawiki/ debian/nurpawiki.examples0000644000000000000000000000004312131017746012736 0ustar debian/ocsigenserver.conf.template debian/rules0000755000000000000000000000063112131017746010250 0ustar #!/usr/bin/make -f # -*- makefile -*- include /usr/share/ocaml/ocamlvars.mk # For ocamlfind export OCAMLFIND_DESTDIR := debian/nurpawiki/$(OCAML_STDLIB_DIR) %: dh $@ --with ocaml .PHONY: override_dh_auto_build override_dh_auto_build: make ifeq ($(OCAML_NATDYNLINK),yes) make nurpawiki.cmxs endif .PHONY: override_dh_auto_install override_dh_auto_install: install -d $(OCAMLFIND_DESTDIR) make install debian/README.Debian0000644000000000000000000000417112131017746011234 0ustar Nurpawiki for Debian -------------------- 1. Setting up Nurpawiki ~~~~~~~~~~~~~~~~~~~~~~~ To use Nurpwaki, you first need to set up a PostgreSQL database. With Wheezy's PostgreSQL (version 9.1), the steps on the SQL server are (as user postgres): 1. Create a user in the database: createuser ${DBUSER} 2. Create the database for Nurpawiki: createdb -O ${DBUSER} -E UTF-8 ${DBNAME} 3. Set a password for the user accessing the database: psql ${DBNAME} ${DBUSER} ALTER ROLE ${DBUSER} PASSWORD '${DBPASSWORD}'; \q You can take, for example, DBUSER=ocsigen and DBNAME=nurpawiki (beware of commands executed in psql shell). Nurpawiki will create the SQL schema itself if needed. A sample template for a configuration file is available in /usr/share/doc/nurpawiki/examples. Filling it with proper database user, database name and password will give you a that can be run with "ocsigenserver -c " (as root). Ocsigen will then be listening on port 8080, as user ocsigen, and be serving Nurpawiki only (at /). If satisfied, and if you don't use any other Ocsigen-based service, you can directly use that configuration file as /etc/ocsigenserver/ocsigenserver.conf and use the initscript to launch ocsigenserver. Of course, Nurpawiki can be used with other Ocsigen-based services, but you'll have to edit /etc/ocsigenserver/ocsigenserver.conf yourself. At installation, a wiki user "admin" with an empty password is created. 2. Websites ~~~~~~~~~~~ Tutorial on using Nurpawiki: http://code.google.com/p/nurpawiki/wiki/Tutorial Nurpawiki project page (use Issues tab for bug reporting): http://code.google.com/p/nurpawiki/ Ocsigen project page: http://ocsigen.org/ 3. Known limitations ~~~~~~~~~~~~~~~~~~~~ Ocsigen provides a /etc/ocsigenserver/conf.d directory for easy splitting of the configuration but the default /etc/ocsigenserver/ocsigenserver.conf provided by the ocsigenserver package makes it useless. This is the reason why the configuration part is still a bit tricky (this will hopefully be fixed in the future). -- Stéphane Glondu , Tue, 9 Apr 2013 15:50:35 +0200 debian/copyright0000644000000000000000000000360712131017746011131 0ustar Format: http://www.debian.org/doc/packaging-manuals/copyright-format/1.0/ Packaged-By: Stéphane Glondu Packaged-Date: Thu, 25 Sep 2008 13:53:53 +0200 Source: http://code.google.com/p/nurpawiki/ Files: * Copyright: © 2006-2008 Janne Hellsten License: GPL-2+ Files: files/jscalendar/* Copyright: © 2002-2005 Mihai Bazon, Dynarch.com License: LGPL-2.1+ Files: debian/* Copyright: © 2008 Stéphane Glondu License: GPL-2+ License: GPL-2+ This program 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. . 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 General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . . The complete text of the GNU General Public License can be found in `/usr/share/common-licenses/GPL-2'. License: LGPL-2.1+ Original website is at http://dynarch.com/mishoo/. . This library 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; either version 2.1 of the License, or (at your option) any later version. . This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. . The complete text of the GNU Lesser General Public License can be found in `/usr/share/common-licenses/LGPL-2.1'. debian/source/0000755000000000000000000000000011554531116010470 5ustar debian/source/format0000644000000000000000000000001411347443073011702 0ustar 3.0 (quilt) debian/ocsigenserver.conf.template0000644000000000000000000000203212131017746014524 0ustar 8080 /var/log/ocsigenserver /var/lib/ocsigenserver ocsigen ocsigen UTF-8 debian/patches/0000755000000000000000000000000012131017751010613 5ustar debian/patches/0001-Use-proper-connection-dependent-escaping.patch0000644000000000000000000001230312131017746022146 0ustar From: Stephane Glondu Date: Sat, 19 Sep 2009 13:19:01 +0200 Subject: Use proper connection-dependent escaping This patch needs postgresql-ocaml >= 1.12.1. Signed-off-by: Stephane Glondu --- database.ml | 48 ++++++++++++++++++++---------------------------- 1 file changed, 20 insertions(+), 28 deletions(-) diff --git a/database.ml b/database.ml index fa0d5bd..a08037e 100644 --- a/database.ml +++ b/database.ml @@ -101,16 +101,8 @@ let with_conn f = Lwt_preemptive.detach ConnectionPool.with_conn f (* Escape a string for SQL query *) -let escape s = - let b = Buffer.create (String.length s) in - String.iter - (function - '\\' -> Buffer.add_string b "\\\\" - | '\'' -> Buffer.add_string b "''" - | '"' -> Buffer.add_string b "\"" - | c -> Buffer.add_char b c) s; - Buffer.contents b - +let escape ~(conn:connection) s = conn#escape_string s + let todos_user_login_join = "FROM nw.todos LEFT OUTER JOIN nw.users ON nw.todos.user_id = nw.users.id" (* Use this tuple format when querying TODOs to be parsed by @@ -219,8 +211,8 @@ let update_todo_activation_date ~conn todo_id new_date = let update_todo_descr ~conn todo_id new_descr = - let sql = - "UPDATE nw.todos SET descr = '"^escape new_descr^"' WHERE id = "^ + let sql = + "UPDATE nw.todos SET descr = '"^escape ~conn new_descr^"' WHERE id = "^ (string_of_int todo_id) in ignore (guarded_exec ~conn sql) @@ -279,8 +271,8 @@ let query_upcoming_todos ~conn ~current_user_id date_criterion = let new_todo ~conn page_id user_id descr = (* TODO: could wrap this into BEGIN .. COMMIT if I knew how to return the data from the query! *) - let sql = - "INSERT INTO nw.todos(user_id,descr) values('"^(string_of_int user_id)^"','"^escape descr^"'); + let sql = + "INSERT INTO nw.todos(user_id,descr) values('"^(string_of_int user_id)^"','"^escape ~conn descr^"'); INSERT INTO nw.todos_in_pages(todo_id,page_id) values(CURRVAL('nw.todos_id_seq'), " ^string_of_int page_id^");"^ (insert_todo_activity ~user_id @@ -410,8 +402,8 @@ let down_task_priority id = offset_task_priority id 1 let new_wiki_page ~conn ~user_id page = - let sql = - "INSERT INTO nw.pages (page_descr) VALUES ('"^escape page^"'); + let sql = + "INSERT INTO nw.pages (page_descr) VALUES ('"^escape ~conn page^"'); INSERT INTO nw.wikitext (page_id,page_created_by_user_id,page_text) VALUES ((SELECT CURRVAL('nw.pages_id_seq')), "^string_of_int user_id^", ''); "^ @@ -424,7 +416,7 @@ let new_wiki_page ~conn ~user_id page = let save_wiki_page ~conn page_id ~user_id lines = let page_id_s = string_of_int page_id in let user_id_s = string_of_int user_id in - let escaped = escape (String.concat "\n" lines) in + let escaped = escape ~conn (String.concat "\n" lines) in (* Ensure no one else can update the head revision while we're modifying it Selecting for UPDATE means no one else can SELECT FOR UPDATE this row. If value (head_revision+1) is only computed and used @@ -458,8 +450,8 @@ COMMIT" in ignore (guarded_exec ~conn sql) let find_page_id ~conn descr = - let sql = - "SELECT id FROM nw.pages WHERE page_descr = '"^escape descr^"' LIMIT 1" in + let sql = + "SELECT id FROM nw.pages WHERE page_descr = '"^escape ~conn descr^"' LIMIT 1" in let r = guarded_exec ~conn sql in if r#ntuples = 0 then None else Some (int_of_string (r#get_tuple 0).(0)) @@ -549,8 +541,8 @@ let query_past_activity ~conn ~min_id ~max_id = (* Search features *) let search_wikipage ~conn str = - let escaped_ss = escape str in - let sql = + let escaped_ss = escape ~conn str in + let sql = "SELECT page_id,headline,page_descr FROM nw.findwikipage('"^escaped_ss^"') "^ "LEFT OUTER JOIN nw.pages on page_id = nw.pages.id ORDER BY rank DESC" in let r = guarded_exec ~conn sql in @@ -585,8 +577,8 @@ let query_users ~conn = let query_user ~conn username = - let sql = - user_query_string ^" WHERE login = '"^escape username^"' LIMIT 1" in + let sql = + user_query_string ^" WHERE login = '"^escape ~conn username^"' LIMIT 1" in let r = guarded_exec ~conn sql in if r#ntuples = 0 then None @@ -596,8 +588,8 @@ let query_user ~conn username = let add_user ~conn ~login ~passwd ~real_name ~email = let sql = "INSERT INTO nw.users (login,passwd,real_name,email) "^ - "VALUES ("^(String.concat "," - (List.map (fun s -> "'"^escape s^"'") + "VALUES ("^(String.concat "," + (List.map (fun s -> "'"^escape ~conn s^"'") [login; passwd; real_name; email]))^")" in ignore (guarded_exec ~conn sql) @@ -606,9 +598,9 @@ let update_user ~conn~user_id ~passwd ~real_name ~email = "UPDATE nw.users SET "^ (match passwd with None -> "" - | Some passwd -> "passwd = '"^escape passwd^"',")^ - "real_name = '"^escape real_name^"', - email = '"^escape email^"' + | Some passwd -> "passwd = '"^escape ~conn passwd^"',")^ + "real_name = '"^escape ~conn real_name^"', + email = '"^escape ~conn email^"' WHERE id = "^(string_of_int user_id) in ignore (guarded_exec ~conn sql) -- debian/patches/0002-Add-native-archive-to-META.patch0000644000000000000000000000075112131017746016761 0ustar From: Stephane Glondu Date: Sun, 20 Sep 2009 00:15:00 +0200 Subject: Add native archive to META Signed-off-by: Stephane Glondu --- META.in | 1 + 1 file changed, 1 insertion(+) diff --git a/META.in b/META.in index b66410c..cf27702 100644 --- a/META.in +++ b/META.in @@ -1,3 +1,4 @@ requires = "unix,extlib,postgresql,calendar,pcre,str" version = "%_NURPAWIKI_VERSION_%" archive(byte) = "nurpawiki.cma" +archive(native) = "nurpawiki.cmxs" -- debian/patches/0006-Port-to-Ocsigen-2-Eliom-3.patch0000644000000000000000000035737012131017746016535 0ustar From: Stephane Glondu Date: Tue, 9 Apr 2013 15:21:42 +0200 Subject: Port to Ocsigen 2 / Eliom 3 Summary of changes: * use of findlib package eliom.server instead of ocsigen * enable Lwt syntax * sp parameter has been removed (see Eliom 1.90 changelog): - page generation can no longer be done in preemptive threads, so all functions that were taking conn or sp parameters have been more deeply Lwt-ized * the "new_" prefix has been removed in service functions * drop final "s" in Eliom_{parameters,services} * registration functions in Eliom_registration * content creation functions in Eliom_content.Html5.F * XHTML.M => Raw * switch from XHTML to Html5: - and
    changed type from "plus" to "star" * session management: - use an Eliom reference to store credentials * ocsigen => ocsigenserver Signed-off-by: Stephane Glondu --- Makefile | 6 +- about.ml | 21 +-- config.ml | 5 +- database.ml | 114 ++++++++------ database.mli | 61 ++++---- database_schema.ml | 5 +- database_upgrade.ml | 19 ++- gen_ocsigen_config | 4 +- history.ml | 81 +++++----- html_util.ml | 104 ++++++------- main.ml | 413 +++++++++++++++++++++++++------------------------ ocsigen.conf.in | 46 ------ ocsigenserver.conf.in | 46 ++++++ page_revisions.ml | 40 +++-- privileges.ml | 16 +- scheduler.ml | 216 +++++++++++++------------- services.ml | 47 +++--- session.ml | 187 +++++++++++----------- user_editor.ml | 163 ++++++++++--------- 19 files changed, 807 insertions(+), 787 deletions(-) delete mode 100644 ocsigen.conf.in create mode 100644 ocsigenserver.conf.in diff --git a/Makefile b/Makefile index ef45e41..a222847 100644 --- a/Makefile +++ b/Makefile @@ -1,9 +1,9 @@ -LIB := -package threads,netstring,calendar,extlib,postgresql,ocsigen +LIB := -syntax camlp4o -package threads,netstring,calendar,extlib,postgresql,eliom.server,lwt.syntax CAMLC := ocamlfind ocamlc -thread -g $(LIB) CAMLOPT := ocamlfind ocamlopt -thread $(LIB) CAMLDOC := ocamlfind ocamldoc $(LIB) -CAMLDEP := ocamlfind ocamldep -CAMLBUILDOPTS := -ocamlc '$(CAMLC)' -ocamlopt '$(CAMLOPT)' +CAMLDEP := ocamlfind ocamldep $(LIB) +CAMLBUILDOPTS := -ocamlc '$(CAMLC)' -ocamlopt '$(CAMLOPT)' -ocamldep '$(CAMLDEP)' CAMLBUILD := ocamlbuild $(CAMLBUILDOPTS) CMA := nurpawiki.cma diff --git a/about.ml b/about.ml index 87561ae..4e44002 100644 --- a/about.ml +++ b/about.ml @@ -14,12 +14,7 @@ * If not, see . *) -open XHTML.M - -open Eliom_sessions -open Eliom_parameters -open Eliom_services -open Eliom_predefmod.Xhtml +open Eliom_content.Html5.F open Lwt @@ -34,15 +29,15 @@ let about_page_html = br (); br (); pcdata "See the "; - XHTML.M.a ~a:[a_href (uri_of_string "http://code.google.com/p/nurpawiki")] + Raw.a ~a:[a_href (uri_of_string (fun () -> "http://code.google.com/p/nurpawiki"))] [pcdata "project homepage"]; pcdata "."]] let _ = - register about_page - (fun sp () () -> - Session.with_guest_login sp - (fun cur_user sp -> + Eliom_registration.Html5.register about_page + (fun () () -> + Session.with_guest_login + (fun cur_user -> return - (Html_util.html_stub sp - (Html_util.navbar_html sp ~cur_user about_page_html)))) + (Html_util.html_stub + (Html_util.navbar_html ~cur_user about_page_html)))) diff --git a/config.ml b/config.ml index 1309cb2..95fc063 100644 --- a/config.ml +++ b/config.ml @@ -16,7 +16,6 @@ module P = Printf -open Eliom_sessions open Simplexmlparser type db_config = @@ -63,7 +62,7 @@ let dbcfg = find_dbcfg xs | [] -> raise (Ocsigen_extensions.Error_in_config_file ("Couldn't find database element from config")) in - find_dbcfg (get_config ()) + find_dbcfg (Eliom_config.get_config ()) let site = let rec find_site_cfg = function @@ -88,6 +87,6 @@ let site = cfg_allow_ro_guests = false; cfg_homepage = "WikiStart"; } in - let cfg = find_site_cfg (get_config ()) in + let cfg = find_site_cfg (Eliom_config.get_config ()) in Ocsigen_messages.warning (P.sprintf "read-only guests allowed %b" cfg.cfg_allow_ro_guests); cfg diff --git a/database.ml b/database.ml index a08037e..00a920e 100644 --- a/database.ml +++ b/database.ml @@ -17,14 +17,12 @@ open Types module Psql = Postgresql module P = Printf -open XHTML.M - -open Eliom_sessions open Config type connection = Psql.connection -let (>>) f g = g f + +let ( |> ) f g = g f module ConnectionPool = struct @@ -173,7 +171,7 @@ let insert_todo_activity ~user_id todo_id ?(page_ids=None) activity = user_id_s^", "^todo_id^"); "^ page_act_insert -let insert_save_page_activity ~conn ~user_id (page_id : int) = +let insert_save_page_activity ~user_id (page_id : int) = with_conn (fun conn -> let sql = "BEGIN; INSERT INTO nw.activity_log(activity_id, user_id) VALUES ("^(string_of_int (int_of_activity_type AT_edit_page))^ @@ -182,8 +180,9 @@ INSERT INTO nw.activity_in_pages(activity_log_id,page_id) VALUES (CURRVAL('nw.activity_log_id_seq'), "^string_of_int page_id^"); COMMIT" in ignore (guarded_exec ~conn sql) +) -let query_todos_by_ids ~conn todo_ids = +let query_todos_by_ids_raw todo_ids conn = if todo_ids <> [] then let ids = String.concat "," (List.map string_of_int todo_ids) in let r = @@ -193,31 +192,35 @@ let query_todos_by_ids ~conn todo_ids = else [] -let query_todo ~conn id = - match query_todos_by_ids ~conn [id] with +let query_todos_by_ids todo_ids = with_conn (query_todos_by_ids_raw todo_ids) + +let query_todo id = with_conn (fun conn -> + match query_todos_by_ids_raw [id] conn with [task] -> Some task | [] -> None | _ -> None +) -let todo_exists ~conn id = - match query_todo ~conn id with Some _ -> true | None -> false +let todo_exists id = + match_lwt query_todo id with Some _ -> Lwt.return true | None -> Lwt.return false - -let update_todo_activation_date ~conn todo_id new_date = +let update_todo_activation_date todo_id new_date = with_conn (fun conn -> let sql = "UPDATE nw.todos SET activation_date = '"^new_date^"' WHERE id = "^ (string_of_int todo_id) in ignore (guarded_exec ~conn sql) +) -let update_todo_descr ~conn todo_id new_descr = +let update_todo_descr todo_id new_descr = with_conn (fun conn -> let sql = "UPDATE nw.todos SET descr = '"^escape ~conn new_descr^"' WHERE id = "^ (string_of_int todo_id) in ignore (guarded_exec ~conn sql) +) -let update_todo_owner_id ~conn todo_id owner_id = +let update_todo_owner_id todo_id owner_id = with_conn (fun conn -> let owner_id_s = match owner_id with Some id -> string_of_int id @@ -226,6 +229,7 @@ let update_todo_owner_id ~conn todo_id owner_id = "UPDATE nw.todos SET user_id = "^owner_id_s^" WHERE id = "^ (string_of_int todo_id) in ignore (guarded_exec ~conn sql) +) let select_current_user id = @@ -235,15 +239,16 @@ let select_current_user id = " AND (user_id = "^string_of_int user_id^" OR user_id IS NULL) ") (* Query TODOs and sort by priority & completeness *) -let query_all_active_todos ~conn ~current_user_id () = +let query_all_active_todos ~current_user_id () = with_conn (fun conn -> let r = guarded_exec ~conn ("SELECT "^todo_tuple_format^" "^todos_user_login_join^" "^ "WHERE activation_date <= current_date AND completed = 'f' "^ select_current_user current_user_id^ "ORDER BY completed,priority,id") in List.map todo_of_row r#get_all_lst +) -let query_upcoming_todos ~conn ~current_user_id date_criterion = +let query_upcoming_todos ~current_user_id date_criterion = with_conn (fun conn -> let date_comparison = let dayify d = "'"^string_of_int d^" days'" in @@ -267,6 +272,7 @@ let query_upcoming_todos ~conn ~current_user_id date_criterion = select_current_user current_user_id^ " AND completed='f' ORDER BY activation_date,priority,id") in List.map todo_of_row r#get_all_lst +) let new_todo ~conn page_id user_id descr = (* TODO: could wrap this into BEGIN .. COMMIT if I knew how to @@ -284,7 +290,7 @@ let new_todo ~conn page_id user_id descr = (r#get_tuple 0).(0) (* Mapping from a todo_id to page list *) -let todos_in_pages ~conn todo_ids = +let todos_in_pages_raw todo_ids conn = (* Don't query if the list is empty: *) if todo_ids = [] then IMap.empty @@ -304,9 +310,11 @@ let todos_in_pages ~conn todo_ids = IMap.add todo_id ({ p_id = page_id; p_descr = page_descr }::lst) acc) IMap.empty rows +let todos_in_pages todo_ids = with_conn (todos_in_pages_raw todo_ids) + (* TODO must not query ALL activities. Later we only want to currently visible activities => pages available. *) -let query_activity_in_pages ~conn ~min_id ~max_id = +let query_activity_in_pages ~min_id ~max_id = with_conn (fun conn -> let sql = "SELECT activity_log_id,page_id,page_descr FROM nw.activity_in_pages,nw.pages @@ -322,28 +330,31 @@ let query_activity_in_pages ~conn ~min_id ~max_id = let lst = try IMap.find act_id acc with Not_found -> [] in IMap.add act_id ({ p_id = page_id; p_descr = page_descr }::lst) acc) IMap.empty (r#get_all_lst) +) (* Note: This function should only be used in contexts where there will be no concurrency issues. Automated sessions should be used for real ID inserts. In its current form, this function is used to get the highest activity log item ID in order to display history separated into multiple web pages. *) -let query_highest_activity_id ~conn = +let query_highest_activity_id () = with_conn (fun conn -> let sql = "SELECT last_value FROM nw.activity_log_id_seq" in let r = guarded_exec ~conn sql in int_of_string (r#get_tuple 0).(0) +) (* Collect todos in the current page *) -let query_page_todos ~conn page_id = +let query_page_todos page_id = with_conn (fun conn -> let sql = "SELECT "^todo_tuple_format^" "^todos_user_login_join^" WHERE nw.todos.id in "^ "(SELECT todo_id FROM nw.todos_in_pages WHERE page_id = "^string_of_int page_id^")" in let r = guarded_exec ~conn sql in parse_todo_result r +) (* Make sure todos are assigned to correct pages and that pages don't contain old todos moved to other pages or removed. *) -let update_page_todos ~conn page_id todos = +let update_page_todos page_id todos = with_conn (fun conn -> let page_id' = string_of_int page_id in let sql = "BEGIN; @@ -356,29 +367,31 @@ let update_page_todos ~conn page_id todos = todos)) ^ "COMMIT" in ignore (guarded_exec ~conn sql) +) (* Mark task as complete and set completion date for today *) -let complete_task_generic ~conn ~user_id id op = +let complete_task_generic ~user_id id op = with_conn (fun conn -> let (activity,task_complete_flag) = match op with `Complete_task -> (AT_complete_todo, "t") | `Resurrect_task -> (AT_uncomplete_todo, "f") in let page_ids = try - Some (List.map (fun p -> p.p_id) (IMap.find id (todos_in_pages ~conn [id]))) + Some (List.map (fun p -> p.p_id) (IMap.find id (todos_in_pages_raw [id] conn))) with Not_found -> None in let ids = string_of_int id in let sql = "BEGIN; UPDATE nw.todos SET completed = '"^task_complete_flag^"' where id="^ids^";"^ (insert_todo_activity ~user_id ids ~page_ids activity)^"; COMMIT" in ignore (guarded_exec ~conn sql) +) (* Mark task as complete and set completion date for today *) -let complete_task ~conn ~user_id id = - complete_task_generic ~conn ~user_id id `Complete_task +let complete_task ~user_id id = + complete_task_generic ~user_id id `Complete_task -let uncomplete_task ~conn ~user_id id = - complete_task_generic ~conn ~user_id id `Resurrect_task +let uncomplete_task ~user_id id = + complete_task_generic ~user_id id `Resurrect_task let query_task_priority ~conn id = let sql = "SELECT priority FROM nw.todos WHERE id = "^string_of_int id in @@ -388,12 +401,13 @@ let query_task_priority ~conn id = (* TODO offset_task_priority can probably be written in one query instead of two (i.e., first one SELECT and then UPDATE based on that. *) -let offset_task_priority ~conn id incr = +let offset_task_priority id incr = with_conn (fun conn -> let pri = min (max (query_task_priority ~conn id + incr) 1) 3 in let sql = "UPDATE nw.todos SET priority = '"^(string_of_int pri)^ "' where id="^string_of_int id in ignore (guarded_exec ~conn sql) +) let up_task_priority id = offset_task_priority id (-1) @@ -401,7 +415,7 @@ let up_task_priority id = let down_task_priority id = offset_task_priority id 1 -let new_wiki_page ~conn ~user_id page = +let new_wiki_page ~user_id page = with_conn (fun conn -> let sql = "INSERT INTO nw.pages (page_descr) VALUES ('"^escape ~conn page^"'); INSERT INTO nw.wikitext (page_id,page_created_by_user_id,page_text) @@ -410,10 +424,11 @@ let new_wiki_page ~conn ~user_id page = "SELECT CURRVAL('nw.pages_id_seq')" in let r = guarded_exec ~conn sql in int_of_string ((r#get_tuple 0).(0)) +) (* See WikiPageVersioning on docs wiki for more details on the SQL queries. *) -let save_wiki_page ~conn page_id ~user_id lines = +let save_wiki_page page_id ~user_id lines = with_conn (fun conn -> let page_id_s = string_of_int page_id in let user_id_s = string_of_int user_id in let escaped = escape ~conn (String.concat "\n" lines) in @@ -448,18 +463,21 @@ INSERT INTO nw.wikitext (page_id, page_created_by_user_id, page_revision, page_t COMMIT" in ignore (guarded_exec ~conn sql) +) -let find_page_id ~conn descr = +let find_page_id_raw descr conn = let sql = "SELECT id FROM nw.pages WHERE page_descr = '"^escape ~conn descr^"' LIMIT 1" in let r = guarded_exec ~conn sql in if r#ntuples = 0 then None else Some (int_of_string (r#get_tuple 0).(0)) -let page_id_of_page_name ~conn descr = - Option.get (find_page_id ~conn descr) +let find_page_id descr = with_conn (find_page_id_raw descr) + +let page_id_of_page_name descr = + with_conn (fun conn -> Option.get (find_page_id_raw descr conn)) -let wiki_page_exists ~conn page_descr = - find_page_id ~conn page_descr <> None +let wiki_page_exists page_descr = + with_conn (fun conn -> find_page_id_raw page_descr conn <> None) let is_legal_page_revision ~conn page_id_s rev_id = let sql = " @@ -470,7 +488,7 @@ SELECT page_id FROM nw.wikitext (* Load a certain revision of a wiki page. If the given revision is not known, default to head revision. *) -let load_wiki_page ~conn ?(revision_id=None) page_id = +let load_wiki_page ?(revision_id=None) page_id = with_conn (fun conn -> let page_id_s = string_of_int page_id in let head_rev_select = "(SELECT head_revision FROM nw.pages WHERE id = "^page_id_s^")" in @@ -488,9 +506,10 @@ SELECT page_text FROM nw.wikitext page_revision="^revision_s^" LIMIT 1" in let r = guarded_exec ~conn sql in (r#get_tuple 0).(0) +) -let query_page_revisions ~conn page_descr = - match find_page_id ~conn page_descr with +let query_page_revisions page_descr = with_conn (fun conn -> + match find_page_id_raw page_descr conn with None -> [] | Some page_id -> let option_of_empty s f = @@ -510,9 +529,10 @@ SELECT page_revision,nw.users.id,nw.users.login,date_trunc('second', page_create pr_created = List.nth r 3; }) (r#get_all_lst) +) -let query_past_activity ~conn ~min_id ~max_id = +let query_past_activity ~min_id ~max_id = with_conn (fun conn -> let sql = "SELECT nw.activity_log.id,activity_id,activity_timestamp,nw.todos.descr,nw.users.login FROM nw.activity_log @@ -524,7 +544,7 @@ let query_past_activity ~conn ~min_id ~max_id = AND nw.activity_log.id <= "^string_of_int max_id^") ORDER BY activity_timestamp DESC" in let r = guarded_exec ~conn sql in - r#get_all_lst >> + r#get_all_lst |> List.map (fun row -> let id = int_of_string (List.nth row 0) in @@ -538,15 +558,16 @@ let query_past_activity ~conn ~min_id ~max_id = a_todo_descr = if descr = "" then None else Some descr; a_changed_by = if user = "" then None else Some user }) +) (* Search features *) -let search_wikipage ~conn str = +let search_wikipage str = with_conn (fun conn -> let escaped_ss = escape ~conn str in let sql = "SELECT page_id,headline,page_descr FROM nw.findwikipage('"^escaped_ss^"') "^ "LEFT OUTER JOIN nw.pages on page_id = nw.pages.id ORDER BY rank DESC" in let r = guarded_exec ~conn sql in - r#get_all_lst >> + r#get_all_lst |> List.map (fun row -> let id = int_of_string (List.nth row 0) in @@ -555,6 +576,7 @@ let search_wikipage ~conn str = sr_headline = hl; sr_page_descr = Some (List.nth row 2); sr_result_type = SR_page }) +) let user_query_string = @@ -570,13 +592,14 @@ let user_of_sql_row row = user_email = (List.nth row 4); } -let query_users ~conn = +let query_users () = with_conn (fun conn -> let sql = user_query_string ^ " ORDER BY id" in let r = guarded_exec ~conn sql in - r#get_all_lst >> List.map user_of_sql_row + r#get_all_lst |> List.map user_of_sql_row +) -let query_user ~conn username = +let query_user username = with_conn (fun conn -> let sql = user_query_string ^" WHERE login = '"^escape ~conn username^"' LIMIT 1" in let r = guarded_exec ~conn sql in @@ -584,6 +607,7 @@ let query_user ~conn username = None else Some (user_of_sql_row (r#get_tuple_lst 0)) +) let add_user ~conn ~login ~passwd ~real_name ~email = let sql = diff --git a/database.mli b/database.mli index 5412b5b..b9f65cf 100644 --- a/database.mli +++ b/database.mli @@ -19,51 +19,48 @@ type connection 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 -val query_todos_by_ids : conn:connection -> int list -> Types.todo list -val query_todo : conn:connection -> int -> Types.todo option -val todo_exists : conn:connection -> int -> bool + user_id:int -> int -> unit Lwt.t +val query_todos_by_ids : int list -> Types.todo list Lwt.t +val query_todo : int -> Types.todo option Lwt.t +val todo_exists : int -> bool Lwt.t val update_todo_activation_date : - conn:connection -> int -> string -> unit -val update_todo_descr : conn:connection -> int -> string -> unit -val update_todo_owner_id : conn:connection -> int -> int option -> unit + int -> string -> unit Lwt.t +val update_todo_descr : int -> string -> unit Lwt.t +val update_todo_owner_id : int -> int option -> unit Lwt.t val query_all_active_todos : - conn:connection -> - current_user_id:int option -> unit -> Types.todo list + current_user_id:int option -> unit -> Types.todo list Lwt.t val query_upcoming_todos : - conn:connection -> - current_user_id:int option -> int option * int option -> Types.todo list + current_user_id:int option -> int option * int option -> Types.todo list Lwt.t val new_todo : conn:connection -> int -> int -> string -> string val todos_in_pages : - conn:connection -> int list -> Types.page list Types.IMap.t + int list -> Types.page list Types.IMap.t Lwt.t val query_activity_in_pages : - conn:connection -> - min_id:int -> max_id:int -> Types.page list Types.IMap.t -val query_highest_activity_id : conn:connection -> int -val query_page_todos : conn:connection -> int -> Types.todo Types.IMap.t -val update_page_todos : conn:connection -> int -> int list -> unit + min_id:int -> max_id:int -> Types.page list Types.IMap.t Lwt.t +val query_highest_activity_id : unit -> int Lwt.t +val query_page_todos : int -> Types.todo Types.IMap.t Lwt.t +val update_page_todos : int -> int list -> unit Lwt.t val complete_task : - conn:connection -> user_id:int -> Types.IMap.key -> unit + user_id:int -> Types.IMap.key -> unit Lwt.t val uncomplete_task : - conn:connection -> user_id:int -> Types.IMap.key -> unit -val up_task_priority : int -> conn:connection -> unit -val down_task_priority : int -> conn:connection -> unit -val new_wiki_page : conn:connection -> user_id:int -> string -> int + user_id:int -> Types.IMap.key -> unit Lwt.t +val up_task_priority : int -> unit Lwt.t +val down_task_priority : int -> unit Lwt.t +val new_wiki_page : user_id:int -> string -> int Lwt.t val save_wiki_page : - conn:connection -> int -> user_id:int -> string list -> unit -val find_page_id : conn:connection -> string -> int option -val page_id_of_page_name : conn:connection -> string -> int -val wiki_page_exists : conn:connection -> string -> bool + int -> user_id:int -> string list -> unit Lwt.t +val find_page_id : string -> int option Lwt.t +val page_id_of_page_name : string -> int Lwt.t +val wiki_page_exists : string -> bool Lwt.t val load_wiki_page : - conn:connection -> ?revision_id:int option -> int -> string + ?revision_id:int option -> int -> string Lwt.t val query_page_revisions : - conn:connection -> string -> Types.page_revision list + string -> Types.page_revision list Lwt.t val query_past_activity : - conn:connection -> min_id:int -> max_id:int -> Types.activity list + min_id:int -> max_id:int -> Types.activity list Lwt.t val search_wikipage : - conn:connection -> string -> Types.search_result list -val query_users : conn:connection -> Types.user list -val query_user : conn:connection -> string -> Types.user option + string -> Types.search_result list Lwt.t +val query_users : unit -> Types.user list Lwt.t +val query_user : string -> Types.user option Lwt.t val add_user : conn:connection -> login:string -> passwd:string -> real_name:string -> email:string -> unit diff --git a/database_schema.ml b/database_schema.ml index 6f55b1d..5387db2 100644 --- a/database_schema.ml +++ b/database_schema.ml @@ -17,7 +17,7 @@ module Psql = Postgresql open Database -let install_schema ~conn = +let install_schema () = with_conn (fun conn -> let sql = " -- -- PostgreSQL database dump @@ -163,4 +163,5 @@ ALTER TABLE ONLY wikitext " in ignore (guarded_exec ~conn sql); - ignore (Database_upgrade.upgrade_schema ~conn) + ignore (Database_upgrade.upgrade_schema_raw conn) +) diff --git a/database_upgrade.ml b/database_upgrade.ml index e810d72..df1e010 100644 --- a/database_upgrade.ml +++ b/database_upgrade.ml @@ -215,7 +215,7 @@ let upgrade_schema_from_2 ~conn logmsg = logged_exec ~conn logmsg "UPDATE nw.version SET schema_version = 3" (* TODO clean up *) -let db_schema_version ~conn = +let db_schema_version_raw conn = if table_exists ~conn ~schema:"nw" ~table:"version" then let r = guarded_exec ~conn "SELECT (nw.version.schema_version) FROM nw.version" in int_of_string (r#get_tuple 0).(0) @@ -226,31 +226,36 @@ let db_schema_version ~conn = let r = guarded_exec ~conn "SELECT (version.schema_version) FROM version" in int_of_string (r#get_tuple 0).(0) -let upgrade_schema ~conn = +let db_schema_version () = with_conn db_schema_version_raw + +let upgrade_schema_raw conn = (* First find out schema version.. *) let logmsg = Buffer.create 0 in - if db_schema_version ~conn = 0 then + if db_schema_version_raw conn = 0 then begin Buffer.add_string logmsg "Schema is at version 0\n"; upgrade_schema_from_0 ~conn logmsg end; - if db_schema_version ~conn = 1 then + if db_schema_version_raw conn = 1 then begin Buffer.add_string logmsg "Schema is at version 1\n"; upgrade_schema_from_1 ~conn logmsg end; - if db_schema_version ~conn = 2 then + if db_schema_version_raw conn = 2 then begin Buffer.add_string logmsg "Schema is at version 2\n"; upgrade_schema_from_2 ~conn logmsg end; - assert (db_schema_version ~conn == nurpawiki_schema_version); + assert (db_schema_version_raw conn == nurpawiki_schema_version); Buffer.contents logmsg +let upgrade_schema () = with_conn upgrade_schema_raw + (** Check whether the nurpawiki schema is properly installed on Psql *) -let is_schema_installed ~(conn : connection) = +let is_schema_installed () = with_conn (fun conn -> let sql = "SELECT * from pg_tables WHERE (schemaname = 'public' OR schemaname = 'nw') AND "^ "tablename = 'todos'" in let r = guarded_exec ~conn sql in r#ntuples <> 0 +) diff --git a/gen_ocsigen_config b/gen_ocsigen_config index 770f593..75d2822 100755 --- a/gen_ocsigen_config +++ b/gen_ocsigen_config @@ -36,7 +36,7 @@ cryptokit_path=`ocamlfind query cryptokit` # The way we find Ocsigen METAS directory is extremely hacky. I don't # know of a better way. See issue 56 in # http://code.google.com/p/nurpawiki/issues/list for more info. -ocsigen_metas_dir="`ocamlfind printconf stdlib`/../../ocsigen/METAS" +ocsigen_metas_dir="`ocamlfind printconf stdlib`" if [ "$DEBUG" != "" ]; then echo $str_path @@ -80,7 +80,7 @@ if [ "$DBPASSWD" = "" ]; then exit 1 fi -cat ocsigen.conf.in | \ +cat ocsigenserver.conf.in | \ sed -e "s|%_OCSIGEN_ROOT_%|$OCSIGEN_ROOT|g" | \ sed -e "s|%_STR_CMA_%|${str_path}/str.cma|g" | \ sed -e "s|%_NUMS_CMA_%|${nums_path}/nums.cma|g" | \ diff --git a/history.ml b/history.ml index 82fedfb..604ecb1 100644 --- a/history.ml +++ b/history.ml @@ -15,12 +15,10 @@ *) module P = Printf -open XHTML.M +open Eliom_content.Html5.F -open Eliom_sessions -open Eliom_parameters -open Eliom_services -open Eliom_predefmod.Xhtml +open Eliom_parameter +open Eliom_service open Lwt open ExtList @@ -34,6 +32,8 @@ open CalendarLib module Db = Database +let ( & ) f x = f x + let n_log_items_per_page = 300 let descr_of_activity_type = function @@ -119,7 +119,7 @@ let remove_duplicates strs = List.fold_left (fun acc e -> PSet.add e acc) PSet.empty strs in PSet.fold (fun e acc -> e::acc) s [] -let page_links sp cur_page max_pages = +let page_links cur_page max_pages = let links = ref [] in for i = 0 to max_pages do let p = string_of_int i in @@ -127,21 +127,21 @@ let page_links sp cur_page max_pages = if cur_page = i then strong [pcdata p] else - a ~sp ~service:history_page [pcdata p] (Some i) in + a ~service:history_page [pcdata p] (Some i) in links := link :: pcdata " " :: !links done; pcdata "More pages: " :: List.rev !links -let view_history_page sp ~conn ~cur_user ~nth_page = - let highest_log_id = Database.query_highest_activity_id ~conn in +let view_history_page ~cur_user ~nth_page = + lwt highest_log_id = Database.query_highest_activity_id () in (* max_id is inclusive, min_id exclusive, hence 1 and 0 *) let max_id = max 1 (highest_log_id - nth_page * n_log_items_per_page) in let min_id = max 0 (max_id - n_log_items_per_page) in let n_total_pages = highest_log_id / n_log_items_per_page in - let activity = - Database.query_past_activity ~conn ~min_id ~max_id in - let activity_in_pages = - Database.query_activity_in_pages ~conn ~min_id ~max_id in + lwt activity = + Database.query_past_activity ~min_id ~max_id in + lwt activity_in_pages = + Database.query_activity_in_pages ~min_id ~max_id in let prettify_date d = let d = date_of_date_time_string d in @@ -151,9 +151,10 @@ let view_history_page sp ~conn ~cur_user ~nth_page = let act_table = table ~a:[a_class ["todo_table"]] - (tr (th []) [th [pcdata "Activity"]; - th [pcdata "By"]; - th [pcdata "Details"]]) + (tr [th []; + th [pcdata "Activity"]; + th [pcdata "By"]; + th [pcdata "Details"]]) (List.rev (fst (RSMap.fold @@ -169,12 +170,12 @@ let view_history_page sp ~conn ~cur_user ~nth_page = List.rev (List.mapi (fun ndx (todo,changed_by,pages) -> - (tr (td []) - [td (if ndx = 0 then [pcdata ty] else []); - td ~a:[a_class ["todo_owner"]] [pcdata changed_by]; - td ([pcdata todo] @ - (Html_util.todo_page_links_of_pages - ~colorize:true sp pages))])) + (tr [td []; + td (if ndx = 0 then [pcdata ty] else []); + td ~a:[a_class ["todo_owner"]] [pcdata changed_by]; + td ([pcdata todo] @ + (Html_util.todo_page_links_of_pages + ~colorize:true pages))])) lst) in let created_todos = @@ -185,36 +186,34 @@ let view_history_page sp ~conn ~cur_user ~nth_page = todo_html "Resurrected" e.ag_resurrected_todos in let pages_html = if e.ag_edited_pages <> [] then - [tr (td []) - [td [pcdata "Edited"]; - td - ~a:[a_class ["todo_owner"]] - [pcdata (String.concat "," e.ag_page_editors)]; - td (Html_util.todo_page_links_of_pages sp - ~colorize:true ~insert_parens:false - (remove_duplicates e.ag_edited_pages))]] + [tr [td []; + td [pcdata "Edited"]; + td + ~a:[a_class ["todo_owner"]] + [pcdata (String.concat "," e.ag_page_editors)]; + td (Html_util.todo_page_links_of_pages + ~colorize:true ~insert_parens:false + (remove_duplicates e.ag_edited_pages))]] else [] in (* NOTE: 'tr' comes last as we're building the page in reverse order *) (pages_html @ created_todos @ completed_todos @ resurrected_todos @ - [tr (td ~a:[a_class ["no_break"; "h_date_heading"]] date_text) []] @ lst_acc, + [tr [td ~a:[a_class ["no_break"; "h_date_heading"]] date_text]] @ lst_acc, prettified_date)) activity_groups ([],"")))) in - Html_util.html_stub sp - (Html_util.navbar_html sp ~cur_user + return & Html_util.html_stub + (Html_util.navbar_html ~cur_user ([h1 [pcdata "Blast from the past"]] @ - (page_links sp nth_page n_total_pages) @ [br (); br ()] @ + (page_links nth_page n_total_pages) @ [br (); br ()] @ [act_table])) (* /history *) let _ = - register history_page - (fun sp nth_page () -> - Session.with_guest_login sp - (fun cur_user sp -> + Eliom_registration.Html5.register history_page + (fun nth_page () -> + Session.with_guest_login + (fun cur_user -> let page = Option.default 0 nth_page in - Db.with_conn - (fun conn -> - view_history_page sp ~conn ~cur_user ~nth_page:page))) + view_history_page ~cur_user ~nth_page:page)) diff --git a/html_util.ml b/html_util.ml index 0746be3..031b823 100644 --- a/html_util.ml +++ b/html_util.ml @@ -14,12 +14,10 @@ * If not, see . *) -open XHTML.M +open Eliom_content.Html5.F -open Eliom_sessions -open Eliom_parameters -open Eliom_services -open Eliom_predefmod.Xhtml +open Eliom_parameter +open Eliom_service open Lwt @@ -27,50 +25,50 @@ open Config open Types open Services -let make_static_uri sp name = - make_uri (static_dir sp) sp name +let make_static_uri name = + make_uri (static_dir ()) name -let disconnect_box sp s = - Eliom_predefmod.Xhtml.a ~service:disconnect_page ~sp [pcdata s] () +let disconnect_box s = + a ~service:disconnect_page [pcdata s] () (* Use this as the basis for all pages. Includes CSS etc. *) -let html_stub sp ?(javascript=[]) body_html = +let html_stub ?(javascript=[]) body_html = let script src = - js_script ~a:[a_defer `Defer] ~uri:(make_static_uri sp src) () in + js_script ~a:[a_defer `Defer] ~uri:(make_static_uri src) () in let scripts = script ["nurpawiki.js"] :: (List.map script javascript) in html ~a:[a_xmlns `W3_org_1999_xhtml] (head (title (pcdata "")) ((scripts) @ - [css_link ~a:[] ~uri:(make_uri ~service:(static_dir sp) ~sp + [css_link ~a:[] ~uri:(make_uri ~service:(static_dir ()) ["style.css"]) (); - css_link ~a:[] ~uri:(make_uri ~service:(static_dir sp) ~sp + css_link ~a:[] ~uri:(make_uri ~service:(static_dir ()) ["jscalendar"; "calendar-blue2.css"]) ()])) (body body_html) let is_guest user = user.user_login = "guest" -let navbar_html sp ~cur_user ?(top_info_bar=[]) ?(wiki_revisions_link=[]) ?(wiki_page_links=[]) ?(todo_list_table=[]) content = +let navbar_html ~cur_user ?(top_info_bar=[]) ?(wiki_revisions_link=[]) ?(wiki_page_links=[]) ?(todo_list_table=[]) content = let home_link link_text = a ~service:wiki_view_page - ~a:[a_accesskey 'h'; a_class ["ak"]] ~sp:sp link_text + ~a:[a_accesskey 'h'; a_class ["ak"]] link_text (Config.site.cfg_homepage, (None, (None, None))) in let scheduler_link = a ~service:scheduler_page - ~a:[a_accesskey 'r'; a_class ["ak"]] ~sp:sp - [img ~alt:"Scheduler" ~src:(make_static_uri sp ["calendar.png"]) (); + ~a:[a_accesskey 'r'; a_class ["ak"]] + [img ~alt:"Scheduler" ~src:(make_static_uri ["calendar.png"]) (); pcdata "Scheduler"] () in let history_link = a ~service:history_page - ~a:[a_accesskey 'r'; a_class ["ak"]] ~sp:sp - [img ~alt:"History" ~src:(make_static_uri sp ["home.png"]) (); + ~a:[a_accesskey 'r'; a_class ["ak"]] + [img ~alt:"History" ~src:(make_static_uri ["home.png"]) (); pcdata "History"] None in let search_input = - [get_form search_page sp - (fun (chain : ([`One of string] Eliom_parameters.param_name)) -> + [get_form search_page + (fun (chain : ([`One of string] param_name)) -> [p [string_input ~input_type:`Submit ~value:"Search" (); string_input ~input_type:`Text ~name:chain ()]])] in @@ -80,7 +78,7 @@ let navbar_html sp ~cur_user ?(top_info_bar=[]) ?(wiki_revisions_link=[]) ?(wiki if is_guest cur_user then [br(); br (); pcdata "To login as an existing user, click "; - a ~a:[a_class ["login_link_big"]]~sp ~service:wiki_view_page + a ~a:[a_class ["login_link_big"]] ~service:wiki_view_page [pcdata "here"] (Config.site.cfg_homepage,(None,(None, Some true))); pcdata "."; @@ -89,42 +87,42 @@ let navbar_html sp ~cur_user ?(top_info_bar=[]) ?(wiki_revisions_link=[]) ?(wiki else [] in - let disconnect_link sp = - if is_guest cur_user then [] else [disconnect_box sp "Logout"] in + let disconnect_link = + if is_guest cur_user then [] else [disconnect_box "Logout"] in - let my_preferences_link sp = + let my_preferences_link = if is_guest cur_user then [] else - [a ~service:edit_user_page ~sp [pcdata "My Preferences"] + [a ~service:edit_user_page [pcdata "My Preferences"] (None,cur_user.user_login)] in let edit_users_link = if Privileges.can_view_users cur_user then - [a ~service:user_admin_page ~sp [pcdata "Edit Users"] ()] + [a ~service:user_admin_page [pcdata "Edit Users"] ()] else [] in [div ~a:[a_id "topbar"] [table ~a:[a_class ["top_menu_size"]] (tr - (td ~a:[a_class ["top_menu_left_align"]] + [td ~a:[a_class ["top_menu_left_align"]] [table - (tr (td [home_link - [img ~alt:"Home" ~src:(make_static_uri sp ["home.png"]) (); - pcdata "Home"]]) - [td [scheduler_link]; - td [history_link]; - td wiki_page_links]) - []]) - [td ~a:[a_class ["top_menu_right_align"]] - ([a ~service:about_page ~sp [pcdata "About"] ()] @ + (tr [td [home_link + [img ~alt:"Home" ~src:(make_static_uri ["home.png"]) (); + pcdata "Home"]]; + td [scheduler_link]; + td [history_link]; + td wiki_page_links]) + []]; + td ~a:[a_class ["top_menu_right_align"]] + ([a ~service:about_page [pcdata "About"] ()] @ [pcdata " "] @ - my_preferences_link sp @ + my_preferences_link @ [pcdata " "] @ edit_users_link @ [pcdata " "] @ - disconnect_link sp)]) []]] + disconnect_link)]) []]] @ (if top_info_bar = [] then [] else [div ~a:[a_id "top_action_bar"] top_info_bar]) @ @@ -136,8 +134,8 @@ let navbar_html sp ~cur_user ?(top_info_bar=[]) ?(wiki_revisions_link=[]) ?(wiki let error text = span ~a:[a_class ["error"]] [pcdata text] -let error_page sp msg = - html_stub sp +let error_page msg = + html_stub [p [error msg]] @@ -155,7 +153,7 @@ let priority_css_class p = let css_palette_ndx_of_wikipage page_id = "palette"^(string_of_int (page_id mod 12)) -let todo_page_links_of_pages sp ?(colorize=false) ?(link_css_class=None) ?(insert_parens=true) pages = +let todo_page_links_of_pages ?(colorize=false) ?(link_css_class=None) ?(insert_parens=true) pages = let attrs page = let color_css = if colorize then [css_palette_ndx_of_wikipage page.p_id] else [] in @@ -163,7 +161,7 @@ let todo_page_links_of_pages sp ?(colorize=false) ?(link_css_class=None) ?(inser Some c -> [a_class ([c] @ color_css)] | None -> [a_class color_css] in let link page = - a ~a:(attrs page) ~service:wiki_view_page ~sp:sp [pcdata page.p_descr] + a ~a:(attrs page) ~service:wiki_view_page [pcdata page.p_descr] (page.p_descr,(None,(None,None))) in let rec insert_commas acc = function (x::_::xs) as lst -> @@ -182,22 +180,22 @@ let todo_page_links_of_pages sp ?(colorize=false) ?(link_css_class=None) ?(inser else [] -let todo_page_links sp todo_in_pages ?(colorize=false) ?(link_css_class=None) ?(insert_parens=true) id = +let todo_page_links todo_in_pages ?(colorize=false) ?(link_css_class=None) ?(insert_parens=true) id = let pages = try IMap.find id todo_in_pages with Not_found -> [] in - todo_page_links_of_pages ~colorize sp pages + todo_page_links_of_pages ~colorize pages -let todo_edit_img_link sp page_cont task_id = - [a ~a:[a_title "Edit"] ~service:edit_todo_get_page ~sp:sp +let todo_edit_img_link page_cont task_id = + [a ~a:[a_title "Edit"] ~service:edit_todo_get_page [img ~alt:"Edit" - ~src:(make_static_uri sp ["edit_small.png"]) ()] + ~src:(make_static_uri ["edit_small.png"]) ()] (page_cont, Some task_id)] -let complete_task_img_link sp task_id = +let complete_task_img_link task_id = let img_html = [img ~alt:"Mark complete" - ~src:(make_static_uri sp ["mark_complete.png"]) ()] in + ~src:(make_static_uri ["mark_complete.png"]) ()] in a ~service:task_side_effect_complete_action - ~a:[a_title "Mark as completed!"] ~sp img_html task_id + ~a:[a_title "Mark as completed!"] img_html task_id let todo_descr_html descr owner = match owner with @@ -208,7 +206,7 @@ let todo_descr_html descr owner = (* Use to create a "cancel" button for user submits *) -let cancel_link service sp params = - a ~a:[a_class ["cancel_edit"]] ~service:service ~sp:sp +let cancel_link service params = + a ~a:[a_class ["cancel_edit"]] ~service:service [pcdata "Cancel"] params diff --git a/main.ml b/main.ml index cf7ad86..8d9a1a1 100644 --- a/main.ml +++ b/main.ml @@ -14,12 +14,10 @@ * If not, see . *) -open XHTML.M +open Eliom_content.Html5.F -open Eliom_sessions -open Eliom_parameters -open Eliom_services -open Eliom_predefmod.Xhtml +open Eliom_parameter +open Eliom_service open Lwt open ExtList @@ -37,52 +35,60 @@ module P = Printf let matches_pcre rex s = try ignore (Pcre.extract ~rex s); true with Not_found -> false -let (>>) f g = g f +let ( |> ) f g = g f +let ( & ) f g = f g + +let rec filter_map f = function + | [] -> return [] + | x::xs -> + lwt ys = filter_map f xs in + match_lwt f x with + | Some y -> return & y::ys + | None -> return ys let newline_re = Pcre.regexp "\n" -let task_side_effect_complete sp task_id () = - Session.action_with_user_login sp +let task_side_effect_complete task_id () = + Session.action_with_user_login (fun user -> - Db.with_conn - (fun conn -> - if Privileges.can_complete_task ~conn task_id user then - begin - Db.complete_task ~conn ~user_id:user.user_id task_id; - let table = Eliom_sessions.get_request_cache sp in - Polytables.set ~table ~key:action_completed_task ~value:task_id - end)) - - -let task_side_effect_undo_complete sp task_id () = - Session.action_with_user_login sp + lwt b = Privileges.can_complete_task task_id user in + if b then + begin + Db.complete_task ~user_id:user.user_id task_id >> + let table = Eliom_request_info.get_request_cache () in + return & Polytables.set ~table ~key:action_completed_task ~value:task_id + end + else return ()) + + +let task_side_effect_undo_complete task_id () = + Session.action_with_user_login (fun user -> - Db.with_conn - (fun conn -> - if Privileges.can_complete_task ~conn task_id user then - Db.uncomplete_task ~conn ~user_id:user.user_id task_id)) + lwt b = Privileges.can_complete_task task_id user in + if b then Db.uncomplete_task ~user_id:user.user_id task_id + else return ()) -let task_side_effect_mod_priority sp (task_id, dir) () = - Session.action_with_user_login sp +let task_side_effect_mod_priority (task_id, dir) () = + Session.action_with_user_login (fun user -> - Db.with_conn - (fun conn -> - if Privileges.can_modify_task_priority ~conn task_id user then - begin - if dir = false then - Db.down_task_priority ~conn task_id - else - Db.up_task_priority ~conn task_id; - let table = Eliom_sessions.get_request_cache sp in - Polytables.set ~table ~key:action_task_priority_changed ~value:task_id - end)) + lwt b = Privileges.can_modify_task_priority task_id user in + if b then + begin + if dir = false then + Db.down_task_priority task_id + else + Db.up_task_priority task_id >> + let table = Eliom_request_info.get_request_cache () in + return & Polytables.set ~table ~key:action_task_priority_changed ~value:task_id + end + else return ()) let () = - Eliom_predefmod.Action.register + Eliom_registration.Action.register ~service:task_side_effect_complete_action task_side_effect_complete; - Eliom_predefmod.Action.register + Eliom_registration.Action.register ~service:task_side_effect_undo_complete_action task_side_effect_undo_complete; - Eliom_predefmod.Action.register + Eliom_registration.Action.register ~service:task_side_effect_mod_priority_action task_side_effect_mod_priority let make_static_uri = Html_util.make_static_uri @@ -185,42 +191,42 @@ module WikiML = preproc_lines) (* Todo item manipulation HTML *) - let complete_todo sp id = - [Html_util.complete_task_img_link sp id] + let complete_todo id = + [Html_util.complete_task_img_link id] - let priority_arrow sp ~conn id up_or_down = + let priority_arrow id up_or_down = let (title,arrow_img,dir) = if up_or_down then ("Raise priority!", "arrow_up.png", true) else ("Lower priority!", "arrow_down.png", false) in let arrow_img = - img ~alt:"Logo" ~src:(make_static_uri sp [arrow_img]) () in - Eliom_predefmod.Xhtml.a + img ~alt:"Logo" ~src:(make_static_uri [arrow_img]) () in + a ~a:[a_title title] ~service:task_side_effect_mod_priority_action - ~sp [arrow_img] (id,dir) + [arrow_img] (id, dir) - let mod_priorities sp ~conn pri id = - [priority_arrow sp ~conn id true; - priority_arrow sp ~conn id false] + let mod_priorities pri id = + [priority_arrow id true; + priority_arrow id false] - let todo_editor_link sp todo_id page = - Html_util.todo_edit_img_link sp (ET_view page) todo_id + let todo_editor_link todo_id page = + Html_util.todo_edit_img_link (ET_view page) todo_id - let todo_modify_buttons sp ~conn ~cur_user page todo_id todo = + let todo_modify_buttons ~cur_user page todo_id todo = let completed = todo.t_completed in span ~a:[a_class ["no_break"]] (if completed || not (Privileges.can_edit_task todo cur_user) then [] else - (todo_editor_link sp todo_id page @ - mod_priorities sp ~conn todo.t_priority todo_id @ - complete_todo sp todo_id)) + (todo_editor_link todo_id page @ + mod_priorities todo.t_priority todo_id @ + complete_todo todo_id)) let translate_list items = let add_ul t lst = - t @ [ul (List.hd lst) (List.tl lst)] in + t @ [ul lst] in let rec loop = function ((nesting1,text1)::(nesting2,text2)::xs) as lst -> if nesting1 = nesting2 then @@ -235,26 +241,27 @@ module WikiML = [(li text)] | [] -> [] in let list_items = loop items in - ul (List.hd list_items) (List.tl list_items) + ul list_items - let parse_lines sp ~conn ~cur_user cur_page (todo_data : todo IMap.t) preprocessed_lines = + let parse_lines ~cur_user cur_page (todo_data : todo IMap.t) preprocessed_lines = - let wikilink ~conn scheme page text = + let wikilink scheme page text = let ext_img = img ~alt:"External link" - ~src:(make_static_uri sp ["external_link.png"]) () in + ~src:(make_static_uri ["external_link.png"]) () in if scheme = "wiki" || scheme = "" then let t = if text = "" then page else text in - if Db.wiki_page_exists ~conn page then - a wiki_view_page sp [pcdata t] (page,(None,(None,None))) + lwt b = Db.wiki_page_exists page in + if b then + a wiki_view_page [pcdata t] (page, (None, (None, None))) |> return else a ~a:[a_class ["missing_page"]] - ~service:wiki_view_page ~sp:sp [pcdata t] - (page,(None,(None,None))) + ~service:wiki_view_page [pcdata t] + (page,(None,(None,None))) |> return else (* External link *) let url = scheme^":"^page in let t = if text = "" then url else text in - XHTML.M.a ~a:[a_href (uri_of_string url)] [pcdata t] in + return & Raw.a ~a:[a_href (uri_of_string (fun () -> url))] [pcdata t] in let add_html html_acc html = html::html_acc in @@ -271,7 +278,7 @@ module WikiML = else ["todo_descr"; Html_util.priority_css_class todo.t_priority] in span - [todo_modify_buttons sp ~conn ~cur_user cur_page todo_id todo; + [todo_modify_buttons ~cur_user cur_page todo_id todo; span ~a:[a_class style] (Html_util.todo_descr_html todo.t_descr todo.t_owner)] with Not_found -> (pcdata "UNKNOWN TODO ID!") in @@ -293,6 +300,7 @@ module WikiML = let wiki_error s charpos = let s = (String.sub s charpos ((String.length s)-charpos)) in + return & add_html acc (Html_util.error ("WIKI SYNTAX ERROR on line: '"^s^"'")) in @@ -300,7 +308,7 @@ module WikiML = let len = String.length s in let rec loop acc charpos = if charpos >= len then - acc + return acc else if s.[charpos] = '\t' then let m = "\t" in @@ -309,7 +317,7 @@ module WikiML = let m = " " in loop (add_html acc (pcdata m)) (charpos+1) else if s.[charpos] = '\r' || s.[charpos] = '\n' then - acc + return acc else seqmatch s charpos ~default:(fun () -> wiki_error s charpos) [(todo_re, @@ -325,19 +333,22 @@ module WikiML = let s = String.sub m 1 (String.length m - 1) in loop (add_html acc (pcdata s)) (charpos+(String.length m)) else - loop (add_html acc (wikilink ~conn "" m m)) (charpos+fmlen))); + lwt h = wikilink "" m m in + loop (add_html acc h) (charpos+fmlen))); (wikilinkanum_re, (fun fmlen r -> let scheme = r.(2) in let page = r.(3) in let text = r.(4) in - loop (add_html acc (wikilink ~conn scheme page text)) (charpos+fmlen))); + lwt h = wikilink scheme page text in + loop (add_html acc h) (charpos+fmlen))); (wikilinkanum_no_text_re, (fun fmlen r -> let scheme = r.(2) in let page = r.(3) in let text = "" in - loop (add_html acc (wikilink ~conn scheme page text)) (charpos+fmlen))); + lwt h = wikilink scheme page text in + loop (add_html acc h) (charpos+fmlen))); (italic_re, (fun fmlen r -> let h = em [pcdata r.(2)] in @@ -354,7 +365,7 @@ module WikiML = (fun fmlen r -> loop (add_html acc (pcdata r.(1))) (charpos+fmlen)))] in - List.rev (loop acc 0) in + loop acc 0 >>= wrap1 List.rev in let rec pcre_first_match str pos = let rec loop = function @@ -370,19 +381,20 @@ module WikiML = (* Grab all lines starting with '*': *) let (after_bullets,bullets) = take_while is_list_or_empty lst in - let list_items = - List.filter_map + lwt list_items = + filter_map (function (`Wiki e) as wl -> if matches_pcre ws_or_empty_re e then (* Empty line, ignore *) - None + return None else begin match is_list wl with Some r -> let n_stars = String.length r.(1) in - Some (n_stars, parse_text [] r.(2)) + lwt x = parse_text [] r.(2) in + return & Some (n_stars, x) | None -> assert false end @@ -400,41 +412,43 @@ module WikiML = match pcre_first_match x 0 wiki_pats with Some (res, action) -> action res | None -> - loop ((p (parse_text [] x))::acc) xs + lwt x = parse_text [] x in + loop ((p x)::acc) xs end | (`NoWiki x::xs) -> loop (pre [pcdata (String.concat "\n" x)]::acc) xs - | [] -> List.rev acc in + | [] -> return & List.rev acc in loop [] preprocessed_lines end -let load_wiki_page ~conn ~revision_id page_id = - Db.load_wiki_page ~conn~revision_id page_id >> - Pcre.split ~rex:newline_re >> WikiML.preprocess +let load_wiki_page ~revision_id page_id = + lwt page = Db.load_wiki_page ~revision_id page_id in + Pcre.split ~rex:newline_re page |> WikiML.preprocess |> return -let wikiml_to_html sp ~conn ~cur_user (page_id:int) (page_name:string) ~revision_id todo_data = - load_wiki_page ~conn page_id ~revision_id >> - WikiML.parse_lines sp ~conn ~cur_user page_name todo_data +let wikiml_to_html ~cur_user (page_id:int) (page_name:string) ~revision_id todo_data = + load_wiki_page page_id ~revision_id >>= + WikiML.parse_lines ~cur_user page_name todo_data -let todo_list_table_html sp ~conn ~cur_user cur_page todos = +let todo_list_table_html ~cur_user cur_page todos = (* Which pages contain TODOs, mapping from todo_id -> {pages} *) - let todo_in_pages = - Db.todos_in_pages ~conn (List.map (fun todo -> todo.t_id) todos) in + lwt todo_in_pages = + Db.todos_in_pages (List.map (fun todo -> todo.t_id) todos) in let todo_page_link todo = let descr = todo.t_descr in let page_links = let c = "wiki_pri_"^Html_util.string_of_priority todo.t_priority in - Html_util.todo_page_links sp todo_in_pages + Html_util.todo_page_links todo_in_pages ~link_css_class:(Some c) (todo.t_id) in Html_util.todo_descr_html descr todo.t_owner @ page_links in - let priority_changes = Session.any_task_priority_changes sp in + let priority_changes = Session.any_task_priority_changes () in + return & table ~a:[a_class ["todo_table"]] (tr - (th [pcdata "Id"]) [th [pcdata "Description"]]) + [th [pcdata "Id"]; th [pcdata "Description"]]) (List.map (fun todo -> let id = todo.t_id in @@ -451,33 +465,34 @@ let todo_list_table_html sp ~conn ~cur_user cur_page todos = else []) in (tr - (td ~a:[a_class row_class] [pcdata (string_of_int id)]) - [td ~a:[a_class row_class] (todo_page_link todo); - td [(WikiML.todo_modify_buttons sp ~conn ~cur_user cur_page id todo)]])) + [td ~a:[a_class row_class] [pcdata (string_of_int id)]; + td ~a:[a_class row_class] (todo_page_link todo); + td [(WikiML.todo_modify_buttons ~cur_user cur_page id todo)]])) todos) -let wiki_page_menu_html sp ~conn ~cur_user page content = +let wiki_page_menu_html ~cur_user page content = let edit_link = - [a ~service:wiki_edit_page ~sp:sp ~a:[a_accesskey '1'; a_class ["ak"]] - [img ~alt:"Edit" ~src:(make_static_uri sp ["edit.png"]) (); + [a ~service:wiki_edit_page ~a:[a_accesskey '1'; a_class ["ak"]] + [img ~alt:"Edit" ~src:(make_static_uri ["edit.png"]) (); pcdata "Edit page"] page] in let printable_link = - [a ~service:wiki_view_page ~sp:sp + [a ~service:wiki_view_page ~a:[a_accesskey 'p'; a_class ["ak"]] [pcdata "Print"] (page, (Some true,(None,None)))] in let revisions_link = - [a ~sp ~service:page_revisions_page [pcdata "View past versions"] page; + [a ~service:page_revisions_page [pcdata "View past versions"] page; br (); br ()] in let current_user_id = Some cur_user.user_id in - let todo_list = - todo_list_table_html sp ~conn ~cur_user page - (Db.query_all_active_todos ~conn ~current_user_id ()) in + lwt todo_list = + lwt x = Db.query_all_active_todos ~current_user_id () in + todo_list_table_html ~cur_user page x + in - let undo_task_id = Session.any_complete_undos sp in + let undo_task_id = Session.any_complete_undos () in let top_info_bar = match undo_task_id with None -> [] @@ -486,32 +501,31 @@ let wiki_page_menu_html sp ~conn ~cur_user page content = [pcdata ("Completed task "^string_of_int id^" "); a ~a:[a_class ["undo_link"]] ~service:task_side_effect_undo_complete_action - ~sp [pcdata "Undo"] id]] in + [pcdata "Undo"] id]] in - Html_util.navbar_html sp ~cur_user + return & Html_util.navbar_html ~cur_user ~wiki_page_links:(edit_link @ [pcdata " "] @ printable_link) ~wiki_revisions_link:revisions_link ~top_info_bar ~todo_list_table:[todo_list] content -let wiki_page_contents_html sp ~conn ~cur_user ~revision_id page_id page_name todo_data ?(content=[]) () = - wiki_page_menu_html sp ~conn ~cur_user page_name - (content @ - wikiml_to_html sp ~conn ~cur_user ~revision_id page_id page_name todo_data) +let wiki_page_contents_html ~cur_user ~revision_id page_id page_name todo_data ?(content=[]) () = + lwt h = wikiml_to_html ~cur_user ~revision_id page_id page_name todo_data in + wiki_page_menu_html ~cur_user page_name (content @ h) -let view_page sp ~conn ~cur_user ?(revision_id=None) page_id page_name ~printable = - let todos = Db.query_page_todos ~conn page_id in +let view_page ~cur_user ?(revision_id=None) page_id page_name ~printable = + lwt todos = Db.query_page_todos page_id in if printable <> None && Option.get printable = true then - let page_content = - wikiml_to_html sp ~conn ~cur_user page_id page_name ~revision_id todos in - Html_util.html_stub sp page_content + lwt page_content = + wikiml_to_html ~cur_user page_id page_name ~revision_id todos in + return & Html_util.html_stub page_content else - Html_util.html_stub sp + lwt page_content = (wiki_page_contents_html - sp - ~conn ~cur_user page_id page_name ~revision_id todos ()) + in + return & Html_util.html_stub page_content (* Parse existing todo's from the current to-be-saved wiki page and update the DB relation on what todos are on the page. @@ -519,7 +533,7 @@ let view_page sp ~conn ~cur_user ?(revision_id=None) page_id page_name ~printabl Todo descriptions are inspected and if they've been changed, modify them in the DB. It's also possible to resurrect completed tasks here by removing the '(x)' part from a task description. *) -let check_new_and_removed_todos ~conn ~cur_user page_id lines = +let check_new_and_removed_todos ~cur_user page_id lines = let search_forward ?groups pat s pos = let result = Pcre.exec ~rex:pat ~pos s in @@ -547,19 +561,19 @@ let check_new_and_removed_todos ~conn ~cur_user page_id lines = (* Query todos that reside on this page. Don't update DB for todos that did NOT change *) - let todos_on_page = Db.query_page_todos ~conn page_id in + lwt todos_on_page = Db.query_page_todos page_id in let completed_re = Pcre.regexp "^\\s*\\(x\\) (.*)$" in let remove_ws_re = Pcre.regexp "^\\s*(.*)$" in (* Update todo descriptions & resurrect completed tasks *) - List.iter + Lwt_list.iter_s (fun (id_s,descr) -> match descr with Some descr -> (match match_pcre_option completed_re descr with Some _ -> (* Task has already been completed, do nothing: *) - () + return () | None -> let id = int_of_string id_s in (* Update task description (if not empty): *) @@ -573,23 +587,26 @@ let check_new_and_removed_todos ~conn ~cur_user page_id lines = let todo = IMap.find id todos_on_page in (* Resurrect completed task *) if todo.t_completed then - Db.uncomplete_task ~conn ~user_id:cur_user.user_id id; + Db.uncomplete_task ~user_id:cur_user.user_id id + else return () >> if todo.t_descr <> new_descr then - Db.update_todo_descr ~conn id new_descr + Db.update_todo_descr id new_descr + else return () with Not_found -> (* Internal inconsistency, should not happen. *) - () + return () end - | None -> ())) - | None -> ()) page_todos; + | None -> return ())) + | None -> return ()) page_todos; - List.filter_map + filter_map (fun e -> let id = int_of_string (fst e) in - if Db.todo_exists ~conn id then Some id else None) page_todos >> + lwt b = Db.todo_exists id in + if b then return & Some id else return & None) page_todos >>= (* Update DB "todos in pages" relation *) - Db.update_page_todos ~conn page_id + Db.update_page_todos page_id let global_substitute ?groups pat subst s = Pcre.substitute_substrings ~rex:pat ~subst:(fun r -> subst r) s @@ -599,7 +616,7 @@ let new_todo_re = (* Insert new TODOs from the wiki ML into DB and replace [todo descr] by [todo:ID] *) -let convert_new_todo_items ~conn cur_user page = +let convert_new_todo_items cur_user page items = Db.with_conn (fun conn -> let owner_id = cur_user.user_id in List.map @@ -611,32 +628,31 @@ let convert_new_todo_items ~conn cur_user page = let id = Db.new_todo ~conn page owner_id descr in "[todo:"^id^" "^descr^"]") line) | (`NoWiki _) as x -> x) +items) (* Save page as a result of /edit?p=Page *) let service_save_page_post = - register_new_post_service + Eliom_registration.Html5.register_post_service ~fallback:wiki_view_page ~post_params:(string "value") - (fun sp (page,_) value -> - Session.with_user_login sp - (fun cur_user sp -> + (fun (page, _) value -> + Session.with_user_login + (fun cur_user -> (* Check if there are any new or removed [todo:#id] tags and updated DB page mappings accordingly: *) - let wikitext = Pcre.split ~rex:newline_re value >> WikiML.preprocess in + let wikitext = Pcre.split ~rex:newline_re value |> WikiML.preprocess in let user_id = cur_user.user_id in - Db.with_conn - (fun conn -> - let page_id = Db.page_id_of_page_name ~conn page in - check_new_and_removed_todos ~conn ~cur_user page_id wikitext; - (* Convert [todo Description] items into [todo:ID] format, save - descriptions to database and save the wiki page contents. *) - let wiki_plaintext = - convert_new_todo_items ~conn cur_user page_id wikitext >> - WikiML.wikitext_of_preprocessed_lines in - (* Log activity: *) - Db.insert_save_page_activity ~conn ~user_id page_id; - Db.save_wiki_page page_id ~conn ~user_id wiki_plaintext; - view_page sp ~conn ~cur_user page_id page ~printable:(Some false)))) + lwt page_id = Db.page_id_of_page_name page in + check_new_and_removed_todos ~cur_user page_id wikitext >> + (* Convert [todo Description] items into [todo:ID] format, save + descriptions to database and save the wiki page contents. *) + lwt wiki_plaintext = + convert_new_todo_items cur_user page_id wikitext >>= + wrap1 WikiML.wikitext_of_preprocessed_lines in + (* Log activity: *) + Db.insert_save_page_activity ~user_id page_id >> + Db.save_wiki_page page_id ~user_id wiki_plaintext >> + view_page ~cur_user page_id page ~printable:(Some false))) (* Convert [todo:ID] into [todo:ID 'Description'] before going into Wiki page edit textarea. *) @@ -660,76 +676,77 @@ let annotate_old_todo_items page page_todos (lines : WikiML.preproc_line list) = (* /edit?p=Page *) let _ = - let handle_edit ~conn ~cur_user sp page_name = - let (page_id,page_todos,preproc_wikitext) = - if Db.wiki_page_exists ~conn page_name then - let page_id = Db.page_id_of_page_name ~conn page_name in - let current_page_todos = Db.query_page_todos ~conn page_id in + let handle_edit ~cur_user page_name = + lwt (page_id, page_todos, preproc_wikitext) = + lwt b = Db.wiki_page_exists page_name in + if b then + lwt page_id = Db.page_id_of_page_name page_name in + lwt current_page_todos = Db.query_page_todos page_id in + lwt x = load_wiki_page page_id ~revision_id:None in + return & (page_id, current_page_todos, - load_wiki_page ~conn page_id ~revision_id:None >> - annotate_old_todo_items page_name current_page_todos) + annotate_old_todo_items page_name current_page_todos x) else begin - (Db.new_wiki_page ~conn ~user_id:cur_user.user_id page_name, - IMap.empty, []) + lwt x = Db.new_wiki_page ~user_id:cur_user.user_id page_name in + return (x, IMap.empty, []) end in let wikitext = String.concat "\n" (WikiML.wikitext_of_preprocessed_lines preproc_wikitext) in let f = - post_form service_save_page_post sp + post_form service_save_page_post (fun chain -> [(p [string_input ~input_type:`Submit ~value:"Save" (); - Html_util.cancel_link wiki_view_page sp + Html_util.cancel_link wiki_view_page (page_name,(None,(None,None))); br (); - textarea ~name:chain ~rows:30 ~cols:80 + textarea ~name:chain ~a:[a_rows 30; a_cols 80] ~value:wikitext ()])]) (page_name,(None,(None,None))) in - Html_util.html_stub sp - (wiki_page_contents_html sp ~conn ~cur_user + lwt h = + wiki_page_contents_html ~cur_user ~revision_id:None - page_id page_name page_todos ~content:[f] ()) in + page_id page_name page_todos ~content:[f] () in + return & Html_util.html_stub h + in - register wiki_edit_page - (fun sp page_name () -> - Session.with_user_login sp - (fun cur_user sp -> - Db.with_conn (fun conn -> handle_edit ~conn ~cur_user sp page_name))) + Eliom_registration.Html5.register wiki_edit_page + (fun page_name () -> + Session.with_user_login + (fun cur_user -> + handle_edit ~cur_user page_name)) -let view_wiki_page sp ~conn ~cur_user (page_name,(printable,(revision_id,_))) = - match Db.find_page_id ~conn page_name with +let view_wiki_page ~cur_user (page_name, (printable, (revision_id, _))) = + match_lwt Db.find_page_id page_name with Some page_id -> - view_page sp ~conn ~cur_user ~revision_id page_id page_name ~printable + view_page ~cur_user ~revision_id page_id page_name ~printable | None -> let f = - a wiki_edit_page sp [pcdata "Create new page"] page_name in - Html_util.html_stub sp - (wiki_page_menu_html sp ~conn ~cur_user page_name [f]) + a wiki_edit_page [pcdata "Create new page"] page_name in + lwt h = wiki_page_menu_html ~cur_user page_name [f] in + return & Html_util.html_stub h (* /view?p=Page *) let _ = - register wiki_view_page - (fun sp ((_,(_,(_,force_login))) as params) () -> + Eliom_registration.Html5.register wiki_view_page + (fun ((_, (_, (_, force_login))) as params) () -> (* If forced login is not requested, we'll let read-only guests in (if current configuration allows it) *) - let login = + let login f = match force_login with Some true -> - Session.with_user_login sp + Session.with_user_login f | Some _ | None -> - Session.with_guest_login sp in + Session.with_guest_login f in login - (fun cur_user sp -> - Db.with_conn - (fun conn -> - view_wiki_page sp ~conn ~cur_user params))) + (fun cur_user -> view_wiki_page ~cur_user params)) (* /benchmark?test=empty,one_db *) let _ = - let gen_html sp = function + let gen_html = function "empty" -> (html (head (title (pcdata "")) []) @@ -745,9 +762,9 @@ let _ = (head (title (pcdata "")) []) (body [p [pcdata "invalid 'test' param!"]])) in - register benchmark_page - (fun sp test_id () -> - return (gen_html sp test_id)) + Eliom_registration.Html5.register benchmark_page + (fun test_id () -> + return (gen_html test_id)) (* /search?q=[keyword list] *) let _ = @@ -768,30 +785,30 @@ let _ = (List.rev (List.fold_left (fun acc e -> (html_of_elem e)::acc) [] doc) )in - let render_results sp search_results = + let render_results search_results = List.flatten (List.map (fun sr -> match sr.sr_result_type with SR_page -> let link descr = - a ~a:[a_class ["sr_link"]] ~service:wiki_view_page ~sp:sp + a ~a:[a_class ["sr_link"]] ~service:wiki_view_page [pcdata descr] (descr,(None,(None,None))) in [p ([link (Option.get sr.sr_page_descr); br ()] @ html_of_headline sr.sr_headline)] | SR_todo -> assert false) search_results) in - let gen_search_page sp ~cur_user search_str = - Db.with_conn (fun conn -> Db.search_wikipage ~conn search_str) >>= fun search_results -> + let gen_search_page ~cur_user search_str = + lwt search_results = Db.search_wikipage search_str in return - (Html_util.html_stub sp - (Html_util.navbar_html sp ~cur_user - ([h1 [pcdata "Search results"]] @ (render_results sp search_results)))) + (Html_util.html_stub + (Html_util.navbar_html ~cur_user + ([h1 [pcdata "Search results"]] @ (render_results search_results)))) in - register search_page - (fun sp search_str () -> - Session.with_guest_login sp - (fun cur_user sp -> - gen_search_page sp cur_user search_str)) + Eliom_registration.Html5.register search_page + (fun search_str () -> + Session.with_guest_login + (fun cur_user -> + gen_search_page cur_user search_str)) diff --git a/ocsigen.conf.in b/ocsigen.conf.in deleted file mode 100644 index 2d9815c..0000000 --- a/ocsigen.conf.in +++ /dev/null @@ -1,46 +0,0 @@ - - - 8080 - ./var/log - ./var/lib - - UTF-8 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ./var/run/ocsigen_command - - - - diff --git a/ocsigenserver.conf.in b/ocsigenserver.conf.in new file mode 100644 index 0000000..dd2d6f8 --- /dev/null +++ b/ocsigenserver.conf.in @@ -0,0 +1,46 @@ + + + 8080 + ./var/log + ./var/lib + + UTF-8 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + ./var/run/ocsigen_command + + + + diff --git a/page_revisions.ml b/page_revisions.ml index 74218fe..95c45f4 100644 --- a/page_revisions.ml +++ b/page_revisions.ml @@ -14,12 +14,10 @@ * If not, see . *) -open XHTML.M +open Eliom_content.Html5.F -open Eliom_sessions -open Eliom_parameters -open Eliom_services -open Eliom_predefmod.Xhtml +open Eliom_parameter +open Eliom_service open Lwt open ExtList @@ -30,38 +28,38 @@ open Types module Db = Database -let revision_table sp page_descr = - Db.with_conn (fun conn -> Db.query_page_revisions ~conn page_descr) >>= fun revisions -> +let revision_table page_descr = + lwt revisions = Db.query_page_revisions page_descr in let page_link descr (rev:int) = - a ~sp ~service:wiki_view_page [pcdata ("Revision "^(string_of_int rev))] + a ~service:wiki_view_page [pcdata ("Revision "^(string_of_int rev))] (descr, (None, (Some rev, None))) in let rows = List.map (fun r -> - tr (td [page_link page_descr r.pr_revision]) - [td [pcdata r.pr_created]; - td [pcdata (Option.default "" r.pr_owner_login)]]) + tr [td [page_link page_descr r.pr_revision]; + td [pcdata r.pr_created]; + td [pcdata (Option.default "" r.pr_owner_login)]]) revisions in return [table - (tr (th [pcdata "Revision"]) [th [pcdata "When"]; th [pcdata "Changed by"]]) + (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 -> - revision_table sp page_descr >>= fun revisions -> +let view_page_revisions page_descr = + Session.with_guest_login + (fun cur_user -> + revision_table page_descr >>= fun revisions -> return - (Html_util.html_stub sp - (Html_util.navbar_html sp ~cur_user + (Html_util.html_stub + (Html_util.navbar_html ~cur_user (h1 [pcdata (page_descr ^ " Revisions")] :: revisions)))) (* /page_revisions?page_id= *) let _ = - register page_revisions_page - (fun sp page_descr () -> - view_page_revisions sp page_descr) + Eliom_registration.Html5.register page_revisions_page + (fun page_descr () -> + view_page_revisions page_descr) diff --git a/privileges.ml b/privileges.ml index 1eeac89..2169974 100644 --- a/privileges.ml +++ b/privileges.ml @@ -66,16 +66,16 @@ let user_owns_task_or_is_admin todo cur_user = let can_edit_task todo cur_user = user_owns_task_or_is_admin todo cur_user -let can_complete_task ~conn task_id cur_user = - let todo = Database.query_todo ~conn task_id in +let can_complete_task task_id cur_user = + lwt todo = Database.query_todo task_id in match todo with Some t -> - user_owns_task_or_is_admin t cur_user - | None -> false + Lwt.return (user_owns_task_or_is_admin t cur_user) + | None -> Lwt.return false -let can_modify_task_priority ~conn task_id cur_user = - let todo = Database.query_todo ~conn task_id in +let can_modify_task_priority task_id cur_user = + lwt todo = Database.query_todo task_id in match todo with Some t -> - user_owns_task_or_is_admin t cur_user - | None -> false + Lwt.return (user_owns_task_or_is_admin t cur_user) + | None -> Lwt.return false diff --git a/scheduler.ml b/scheduler.ml index 11fe041..d0e0336 100644 --- a/scheduler.ml +++ b/scheduler.ml @@ -14,12 +14,10 @@ * If not, see . *) -open XHTML.M +open Eliom_content.Html5.F -open Eliom_sessions -open Eliom_parameters -open Eliom_services -open Eliom_predefmod.Xhtml +open Eliom_parameter +open Eliom_service open Lwt open ExtList @@ -31,6 +29,8 @@ open Types open Util open CalendarLib +let ( & ) f x = f x + module Db = Database let clamp_date_to_today date = @@ -43,13 +43,13 @@ let clamp_date_to_today date = | _ -> assert false end -let wiki_page_links sp todo_in_pages todo = +let wiki_page_links todo_in_pages todo = let id = todo.t_id in let c = "wiki_pri_"^Html_util.string_of_priority todo.t_priority in - Html_util.todo_page_links sp todo_in_pages ~link_css_class:(Some c) id + Html_util.todo_page_links todo_in_pages ~link_css_class:(Some c) id -let view_scheduler_page sp ~conn ~cur_user = - let scheduler_page_internal sp ~conn ~cur_user = +let view_scheduler_page ~cur_user = + let scheduler_page_internal ~cur_user = let today = Date.today () in let prettify_activation_date d = let d = date_of_string d in @@ -61,7 +61,7 @@ let view_scheduler_page sp ~conn ~cur_user = | _ -> assert false end in - let todo_table_html sp todos todos_in_pages = + let todo_table_html todos todos_in_pages = let prev_heading = ref "" in let todo_rows = List.map @@ -71,40 +71,40 @@ let view_scheduler_page sp ~conn ~cur_user = if !prev_heading <> heading then begin prev_heading := heading; - [tr (td ~a:[a_class ["rm_table_heading"]] [pcdata heading]) []] + [tr [td ~a:[a_class ["rm_table_heading"]] [pcdata heading]]] end else [] in let pri_style = Html_util.priority_css_class todo.t_priority in let todo_row = tr - (td ~a:[a_class ["rm_edit"]] - (Html_util.todo_edit_img_link sp ET_scheduler todo.t_id)) - [td [raw_checkbox ~name:("t-"^ todo_id_s) ~value:"0" ()]; - td [Html_util.complete_task_img_link sp todo.t_id]; + [td ~a:[a_class ["rm_edit"]] + (Html_util.todo_edit_img_link ET_scheduler todo.t_id); + td [raw_checkbox ~name:("t-"^ todo_id_s) ~value:"0" ()]; + td [Html_util.complete_task_img_link todo.t_id]; (td ~a:[a_class ["no_break"; pri_style]] [pcdata (prettify_activation_date todo.t_activation_date)]); td ~a:[a_class [pri_style]] (Html_util.todo_descr_html - todo.t_descr todo.t_owner @ wiki_page_links sp todos_in_pages todo)] in + todo.t_descr todo.t_owner @ wiki_page_links todos_in_pages todo)] in heading_row @ [todo_row]) todos in List.flatten todo_rows in - let todo_section sp todos todos_in_pages = - (todo_table_html sp todos todos_in_pages) in + let todo_section todos todos_in_pages = + (todo_table_html todos todos_in_pages) in let query_todos = if Privileges.can_schedule_all_tasks cur_user || cur_user.user_login = "guest" then - Database.query_upcoming_todos ~conn ~current_user_id:None + Database.query_upcoming_todos ~current_user_id:None else (* Query this users's tasks only: *) - Database.query_upcoming_todos ~conn ~current_user_id:(Some cur_user.user_id) in + Database.query_upcoming_todos ~current_user_id:(Some cur_user.user_id) in - let upcoming_pending = query_todos (None,None) in - let upcoming_tomorrow = query_todos (None,Some 1) in - let upcoming_todos_7_days = query_todos (Some 1,Some 7) in - let upcoming_todos_14_days = query_todos (Some 7, Some 14) in - let upcoming_all = query_todos (Some 14, None) in + lwt upcoming_pending = query_todos (None,None) in + lwt upcoming_tomorrow = query_todos (None,Some 1) in + lwt upcoming_todos_7_days = query_todos (Some 1,Some 7) in + lwt upcoming_todos_14_days = query_todos (Some 7, Some 14) in + lwt upcoming_all = query_todos (Some 14, None) in let mark_todo_hdr h = List.map (fun e -> (h, e)) in let merged_todos = @@ -114,8 +114,8 @@ let view_scheduler_page sp ~conn ~cur_user = (mark_todo_hdr "Next 2 weeks" upcoming_todos_14_days) @ (mark_todo_hdr "Everything else" upcoming_all) in - let todos_in_pages = - Database.todos_in_pages ~conn (List.map (fun (_,todo) -> todo.t_id) merged_todos) in + lwt todos_in_pages = + Database.todos_in_pages (List.map (fun (_,todo) -> todo.t_id) merged_todos) in (* TODO merge this HTML generation with other pages. PROBLEM: don't know how to easily do that without duplicating the @@ -123,97 +123,95 @@ let view_scheduler_page sp ~conn ~cur_user = let table () = [p [raw_input ~input_type:`Submit ~value:"Mass edit" ()]; table - (tr (th []) [th []; th []; th [pcdata "Activates on"]; th [pcdata "Todo"]]) - (todo_section sp merged_todos todos_in_pages); + (tr [th []; th []; th []; th [pcdata "Activates on"]; th [pcdata "Todo"]]) + (todo_section merged_todos todos_in_pages); table (tr - (td [button + [td [button ~a:[a_class ["scheduler_check_button"]; a_id "button_select_all"] - ~button_type:`Button [pcdata "Select All"]]) + ~button_type:`Button [pcdata "Select All"]]; - [td [button + td [button ~a:[a_class ["scheduler_check_button"]; a_id "button_deselect_all"] ~button_type:`Button [pcdata "Unselect All"]]]) []] in let table' = - post_form edit_todo_page sp table (ET_scheduler, None) in + post_form edit_todo_page table (ET_scheduler, None) in - Html_util.html_stub sp ~javascript:[["nurpawiki_scheduler.js"]] - (Html_util.navbar_html sp ~cur_user + return & + Html_util.html_stub ~javascript:[["nurpawiki_scheduler.js"]] + (Html_util.navbar_html ~cur_user ([h1 [pcdata "Road ahead"]] @ [table'])) in - scheduler_page_internal sp ~conn ~cur_user + scheduler_page_internal ~cur_user -let render_edit_todo_cont_page sp ~conn ~cur_user = function +let render_edit_todo_cont_page ~cur_user = function ET_scheduler -> - view_scheduler_page sp ~conn ~cur_user + view_scheduler_page ~cur_user | ET_view wiki_page -> - Main.view_wiki_page sp ~conn ~cur_user (wiki_page,(None,(None,None))) + Main.view_wiki_page ~cur_user (wiki_page, (None, (None, None))) (* /scheduler *) let _ = - register scheduler_page - (fun sp todo_id () -> - Session.with_guest_login sp - (fun cur_user sp -> - Db.with_conn (fun conn -> view_scheduler_page sp ~conn ~cur_user))) + Eliom_registration.Html5.register scheduler_page + (fun todo_id () -> + Session.with_guest_login + (fun cur_user -> + view_scheduler_page ~cur_user)) let scheduler_page_discard_todo_id = - register_new_service + Eliom_registration.Html5.register_service ~path:["scheduler"] - ~get_params:((Eliom_parameters.user_type + ~get_params:((user_type et_cont_of_string string_of_et_cont "src_service")) - (fun sp (src_page_cont) () -> - Session.with_user_login sp - (fun cur_user sp -> - Db.with_conn - (fun conn -> render_edit_todo_cont_page sp ~conn ~cur_user src_page_cont))) + (fun src_page_cont () -> + Session.with_user_login + (fun cur_user -> + render_edit_todo_cont_page ~cur_user src_page_cont)) (* Save page as a result of /edit_todo?todo_id=ID *) let service_save_todo_item = - register_new_post_service + Eliom_registration.Html5.register_post_service ~fallback:scheduler_page_discard_todo_id ~post_params:(list "todos" ((int "todo_id") ** (string "activation_date") ** (string "descr") ** (string "owner_id"))) - (fun sp src_page_cont todos -> - Session.with_user_login sp - (fun cur_user sp -> - Db.with_conn - (fun conn -> - (* TODO security hole: would need to check user privileges - for these DB operations. *) - List.iter - (fun (todo_id,(activation_date,(descr,owner_id))) -> - Database.update_todo_descr ~conn todo_id descr; - let owner_id_opt = - if owner_id = "" then None else Some (int_of_string owner_id) in - Database.update_todo_owner_id ~conn todo_id owner_id_opt; - Database.update_todo_activation_date ~conn todo_id activation_date) - todos; - render_edit_todo_cont_page sp ~conn ~cur_user src_page_cont))) - -let rec render_todo_editor sp ~conn ~cur_user (src_page_cont, todos_to_edit) = - let users = Database.query_users ~conn in + (fun src_page_cont todos -> + Session.with_user_login + (fun cur_user -> + (* TODO security hole: would need to check user privileges + for these DB operations. *) + Lwt_list.iter_s + (fun (todo_id, (activation_date, (descr, owner_id))) -> + Database.update_todo_descr todo_id descr >> + let owner_id_opt = + if owner_id = "" then None else Some (int_of_string owner_id) in + Database.update_todo_owner_id todo_id owner_id_opt >> + Database.update_todo_activation_date todo_id activation_date) + todos >> + render_edit_todo_cont_page ~cur_user src_page_cont)) + +let rec render_todo_editor ~cur_user (src_page_cont, todos_to_edit) = + lwt users = Database.query_users () in let todos_str = String.concat "," (List.map string_of_int todos_to_edit) in - let todos = Database.query_todos_by_ids ~conn todos_to_edit in + lwt todos = Database.query_todos_by_ids todos_to_edit in - let f = - let todo_in_pages = - Database.todos_in_pages ~conn (List.map (fun todo -> todo.t_id) todos) in + lwt f = + lwt todo_in_pages = + Database.todos_in_pages (List.map (fun todo -> todo.t_id) todos) in let cancel_page cont = match cont with ET_scheduler -> - Html_util.cancel_link scheduler_page sp () + Html_util.cancel_link scheduler_page () | ET_view wiki -> - Html_util.cancel_link wiki_view_page sp (wiki,(None,(None,None))) in + Html_util.cancel_link wiki_view_page (wiki, (None, (None, None))) in let owner_selection chain todo = @@ -235,18 +233,18 @@ let rec render_todo_editor sp ~conn ~cur_user (src_page_cont, todos_to_edit) = details. *) let create_listform f = [table - (tr (th [pcdata "ID"]) - [th [pcdata "Description"]; th [pcdata "Activates on"]]) + (tr [th [pcdata "ID"]; + th [pcdata "Description"]; th [pcdata "Activates on"]]) (f.it (fun (tv_id,(tv_act_date,(tv_descr,tv_owner_id))) todo accu -> let pri_style = Html_util.priority_css_class todo.t_priority in (tr ~a:[a_class [pri_style]] - (td [pcdata (string_of_int todo.t_id)]) - [td (todo_descr tv_descr todo.t_descr :: - wiki_page_links sp todo_in_pages todo); + [td [pcdata (string_of_int todo.t_id)]; + td (todo_descr tv_descr todo.t_descr :: + wiki_page_links todo_in_pages todo); td ~a:[a_class ["no_break"]] - [string_input ~a:[a_readonly `Readonly; + [string_input ~a:[a_readonly `ReadOnly; a_id ("calendar_"^(string_of_int todo.t_id))] ~input_type:`Text ~name:tv_act_date ~value:todo.t_activation_date (); @@ -255,10 +253,11 @@ let rec render_todo_editor sp ~conn ~cur_user (src_page_cont, todos_to_edit) = td [owner_selection tv_owner_id todo; int_input ~name:tv_id ~input_type:`Hidden ~value:todo.t_id ()]])::accu) todos - [tr (td [string_input ~input_type:`Submit ~value:"Save" (); - cancel_page src_page_cont]) []])] in + [tr [td [string_input ~input_type:`Submit ~value:"Save" (); + cancel_page src_page_cont]]])] in - post_form ~service:service_save_todo_item ~sp create_listform src_page_cont in + return & + post_form ~service:service_save_todo_item create_listform src_page_cont in let heading = [pcdata ("Edit TODOs "^todos_str)] in let help_str = @@ -271,29 +270,30 @@ let rec render_todo_editor sp ~conn ~cur_user (src_page_cont, todos_to_edit) = ["nurpawiki_calendar.js"]] in - Html_util.html_stub sp ~javascript:calendar_js - (Html_util.navbar_html sp ~cur_user + return & + Html_util.html_stub ~javascript:calendar_js + (Html_util.navbar_html ~cur_user ((h1 heading)::[help_str; br(); f])) -let error_page sp msg = - Html_util.html_stub sp [h1 [pcdata ("ERROR: "^msg)]] +let error_page msg = + Html_util.html_stub [h1 [pcdata ("ERROR: "^msg)]] -let render_todo_get_page sp ~conn ~cur_user (src_page_cont, todo) = +let render_todo_get_page ~cur_user (src_page_cont, todo) = match todo with Some todo_id -> - render_todo_editor sp ~conn ~cur_user (src_page_cont, [todo_id]) + render_todo_editor ~cur_user (src_page_cont, [todo_id]) | None -> (* Bogus input as we didn't get any todos to edit.. But let's just take the user back to where he came from rather than issueing an error message. *) - render_edit_todo_cont_page sp ~conn ~cur_user src_page_cont + render_edit_todo_cont_page ~cur_user src_page_cont let _ = - register edit_todo_get_page - (fun sp get_params () -> - Session.with_user_login sp - (fun cur_user sp -> - Db.with_conn (fun conn -> render_todo_get_page sp ~conn ~cur_user get_params))) + Eliom_registration.Html5.register edit_todo_get_page + (fun get_params () -> + Session.with_user_login + (fun cur_user -> + render_todo_get_page ~cur_user get_params)) let todo_id_re = Pcre.regexp "^t-([0-9]+)$" @@ -312,15 +312,13 @@ let parse_todo_ids todo_ids = let _ = - register edit_todo_page - (fun sp (src_page_cont, single_tid) (todo_ids : (string * string) list) -> - Session.with_user_login sp - (fun cur_user sp -> - Db.with_conn - (fun conn -> - if todo_ids = [] then - render_todo_get_page sp ~conn ~cur_user (src_page_cont, single_tid) - else - render_todo_editor sp ~conn ~cur_user - (src_page_cont, (parse_todo_ids todo_ids))))) + Eliom_registration.Html5.register edit_todo_page + (fun (src_page_cont, single_tid) (todo_ids : (string * string) list) -> + Session.with_user_login + (fun cur_user -> + if todo_ids = [] then + render_todo_get_page ~cur_user (src_page_cont, single_tid) + else + render_todo_editor ~cur_user + (src_page_cont, (parse_todo_ids todo_ids)))) diff --git a/services.ml b/services.ml index 9fea92e..9c088c4 100644 --- a/services.ml +++ b/services.ml @@ -14,11 +14,9 @@ * If not, see . *) -open XHTML.M -open Eliom_sessions -open Eliom_parameters -open Eliom_services -open Eliom_predefmod.Xhtml +open Eliom_content.Html5.F +open Eliom_parameter +open Eliom_service open Config open Types @@ -26,52 +24,51 @@ open Types open Lwt let wiki_view_page = - new_service ["view"] ((string "p") + service ["view"] ((string "p") ** (opt (bool "printable")) ** (opt (int "r")) ** (opt (bool "force_login"))) () -let wiki_start = Eliom_predefmod.String_redirection.register_new_service [] unit - (fun sp _ _ -> return (make_uri ~absolute:true ~service:wiki_view_page ~sp (Config.site.cfg_homepage, (None, (None, None))))) +let wiki_start = Eliom_registration.Redirection.register_service [] unit + (fun () () -> return (preapply ~service:wiki_view_page (Config.site.cfg_homepage, (None, (None, None))))) -let wiki_edit_page = new_service ["edit"] (string "p") () +let wiki_edit_page = service ["edit"] (string "p") () -let scheduler_page = new_service ["scheduler"] unit () +let scheduler_page = service ["scheduler"] unit () -let edit_todo_get_page = new_service ["edit_todo"] - ((Eliom_parameters.user_type +let edit_todo_get_page = service ["edit_todo"] + ((user_type et_cont_of_string string_of_et_cont "src_service") ** (opt (int "tid"))) () let edit_todo_page = - new_post_service + post_service ~fallback:edit_todo_get_page ~post_params:any () -let history_page = new_service ["history"] (opt (int "nth_p")) () +let history_page = service ["history"] (opt (int "nth_p")) () -let search_page = new_service ["search"] (string "q") () +let search_page = service ["search"] (string "q") () -let benchmark_page = new_service ["benchmark"] (string "test") () +let benchmark_page = service ["benchmark"] (string "test") () -let user_admin_page = new_service ["user_admin"] unit () +let user_admin_page = service ["user_admin"] unit () -let edit_user_page = new_service ["edit_user"] +let edit_user_page = service ["edit_user"] (opt (string "caller") ** (string "user_to_edit")) () -let disconnect_page = new_service ["disconnect"] unit () +let disconnect_page = service ["disconnect"] unit () -let about_page = new_service ["about"] unit () +let about_page = service ["about"] unit () -let page_revisions_page = new_service ["page_revisions"] (string "p") () +let page_revisions_page = service ["page_revisions"] (string "p") () let task_side_effect_complete_action = - Eliom_services.new_coservice' ~get_params:(Eliom_parameters.int "task_id") () + coservice' ~get_params:(int "task_id") () let task_side_effect_undo_complete_action = - Eliom_services.new_coservice' ~get_params:(Eliom_parameters.int "task_id") () + coservice' ~get_params:(int "task_id") () let task_side_effect_mod_priority_action = - Eliom_services.new_coservice' ~get_params:((Eliom_parameters.int "task_id") ** - Eliom_parameters.bool "dir") () + coservice' ~get_params:((int "task_id") ** bool "dir") () diff --git a/session.ml b/session.ml index 7324557..118a9ae 100644 --- a/session.ml +++ b/session.ml @@ -15,11 +15,9 @@ *) open Lwt -open XHTML.M -open Eliom_services -open Eliom_parameters -open Eliom_sessions -open Eliom_predefmod.Xhtml +open Eliom_content.Html5.F +open Eliom_service +open Eliom_parameter open Services open Types @@ -31,43 +29,44 @@ module Dbu = Database_upgrade let seconds_in_day = 60.0 *. 60.0 *. 24.0 -let login_table = Eliom_sessions.create_persistent_table "login_table" +let scope_hierarchy = Eliom_common.create_scope_hierarchy "nurpawiki_session_data" +let scope = `Session scope_hierarchy + +let login_eref = Eliom_reference.eref + ~scope + ~persistent:"login_info" None (* Set password & login into session. We set the cookie expiration into 24h from now so that the user can even close his browser window, re-open it and still retain his logged in status. *) -let set_password_in_session sp login_info = - set_service_session_timeout ~sp None; - - set_persistent_data_session_timeout ~sp None >>= fun () -> - set_persistent_data_session_cookie_exp_date ~sp (Some 3153600000.0) >>= fun () -> - set_persistent_session_data ~table:login_table ~sp login_info +let set_password_in_session login_info = + let open Eliom_state in + let cookie_scope = scope in + set_service_state_timeout ~cookie_scope None; + set_persistent_data_state_timeout ~cookie_scope None >>= fun () -> + set_persistent_data_cookie_exp_date ~cookie_scope (Some 3153600000.0) >>= fun () -> + Eliom_reference.set login_eref (Some login_info) -let upgrade_page = new_service ["upgrade"] unit () +let upgrade_page = service ["upgrade"] unit () -let schema_install_page = new_service ["schema_install"] unit () +let schema_install_page = service ["schema_install"] unit () let connect_action = - Eliom_services.new_post_coservice' + post_coservice' ~post_params:((string "login") ** (string "passwd")) () let link_to_nurpawiki_main sp = - a ~sp ~service:wiki_view_page + a ~service:wiki_view_page [pcdata "Take me to Nurpawiki"] (Config.site.cfg_homepage,(None,(None,None))) (* Get logged in user as an option *) -let get_login_user sp = - Eliom_sessions.get_persistent_session_data login_table sp () >>= - fun session_data -> - match session_data with - Eliom_sessions.Data user -> Lwt.return (Some user) - | Eliom_sessions.No_data - | Eliom_sessions.Data_session_expired -> Lwt.return None - -let db_upgrade_warning sp = +let get_login_user () = + Eliom_reference.get login_eref + +let db_upgrade_warning () = [h1 [pcdata "Database Upgrade Warning!"]; p [pcdata "An error occured when Nurpawiki was trying to access database."; @@ -83,82 +82,80 @@ let db_upgrade_warning sp = pcdata "If you have valuable data in your DB, please take a backup of it before proceeding!"; br (); br (); - a ~service:upgrade_page ~sp [pcdata "Upgrade now!"] ()]] + a ~service:upgrade_page [pcdata "Upgrade now!"] ()]] -let db_installation_error sp = +let db_installation_error () = [div [h1 [pcdata "Database schema not installed"]; br (); p [pcdata "It appears you're using your Nurpawiki installation for the first time. "; br (); br (); pcdata "In order to complete Nurpawiki installation, your Nurpawiki database schema needs to be initialized."]; p [pcdata "Follow this link to complete installation:"; br (); br (); - a ~service:schema_install_page ~sp [pcdata "Install schema!"] ()]]] + a ~service:schema_install_page [pcdata "Install schema!"] ()]]] -let login_html sp ~err = +let login_html ~err = let help_text = [br (); br (); strong [pcdata "Please read "]; - XHTML.M.a ~a:[a_id "login_help_url"; a_href (uri_of_string "http://code.google.com/p/nurpawiki/wiki/Tutorial")] [pcdata "Nurpawiki tutorial"]; + Raw.a ~a:[a_id "login_help_url"; a_href (uri_of_string (fun () -> "http://code.google.com/p/nurpawiki/wiki/Tutorial"))] [pcdata "Nurpawiki tutorial"]; pcdata " if you're logging in for the first time."; br ()] in - Html_util.html_stub sp + Html_util.html_stub [div ~a:[a_id "login_outer"] [div ~a:[a_id "login_align_middle"] - [Eliom_predefmod.Xhtml.post_form connect_action sp + [post_form connect_action (fun (loginname,passwd) -> [table ~a:[a_class ["login_box"]] - (tr (td ~a:[a_class ["login_text"]] - (pcdata "Welcome to Nurpawiki!"::help_text)) []) - [tr (td [pcdata ""]) []; - tr (td ~a:[a_class ["login_text_descr"]] - [pcdata "Username:"]) []; - tr (td [string_input ~input_type:`Text ~name:loginname ()]) []; - tr (td ~a:[a_class ["login_text_descr"]] - [pcdata "Password:"]) []; - tr (td [string_input ~input_type:`Password ~name:passwd ()]) []; - tr (td [string_input ~input_type:`Submit ~value:"Login" ()]) []]; + (tr [td ~a:[a_class ["login_text"]] + (pcdata "Welcome to Nurpawiki!"::help_text)]) + [tr [td [pcdata ""]]; + tr [td ~a:[a_class ["login_text_descr"]] + [pcdata "Username:"]]; + tr [td [string_input ~input_type:`Text ~name:loginname ()]]; + tr [td ~a:[a_class ["login_text_descr"]] + [pcdata "Password:"]]; + tr [td [string_input ~input_type:`Password ~name:passwd ()]]; + tr [td [string_input ~input_type:`Submit ~value:"Login" ()]]]; p err]) ()]]] -let with_db_installed sp f = +let with_db_installed f = (* Check if the DB is installed. If so, check that it doesn't need an upgrade. *) - 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 () + lwt b = Dbu.is_schema_installed () in + if not b then + return (Html_util.html_stub (db_installation_error ())) + else + lwt v = Dbu.db_schema_version () in + if v < Db.nurpawiki_schema_version then + return (Html_util.html_stub (db_upgrade_warning ())) + else 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 with_user_login ?(allow_read_only=false) f = let login () = - get_login_user sp + get_login_user () >>= function | Some (login,passwd) -> begin - Db.with_conn (fun conn -> Db.query_user ~conn login) + Db.query_user 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 + (login_html [Html_util.error ("Wrong password given for user '"^login^"'")]) else - f user sp + f user | None -> return - (login_html sp + (login_html [Html_util.error ("Unknown user '"^login^"'")]) end | None -> @@ -171,32 +168,32 @@ let with_user_login ?(allow_read_only=false) sp f = user_real_name = "Guest"; user_email = ""; } in - f guest_user sp + f guest_user else - return (login_html sp []) + return (login_html []) in - with_db_installed sp login + with_db_installed login (* Either pretend to be logged in as 'guest' (if allowed by config options) or require a proper login. If logging in as 'guest', we setup a dummy user 'guest' that is not a real user. It won't have access to write to any tables. *) -let with_guest_login sp f = - with_user_login ~allow_read_only:true sp f +let with_guest_login f = + with_user_login ~allow_read_only:true f (* Same as with_user_login except that we can't generate HTML for any errors here. Neither can we present the user with a login box. If there are any errors, just bail out without doing anything harmful. *) -let action_with_user_login sp f = - Db.with_conn (fun conn -> Dbu.db_schema_version conn) >>= fun db_version -> +let action_with_user_login f = + lwt db_version = Dbu.db_schema_version () in if db_version = Db.nurpawiki_schema_version then - get_login_user sp + get_login_user () >>= function | Some (login,passwd) -> begin - Db.with_conn (fun conn -> Db.query_user ~conn login) + Db.query_user login >>= function | Some user -> let passwd_md5 = Digest.to_hex (Digest.string passwd) in @@ -213,17 +210,15 @@ let action_with_user_login sp f = return () -let update_session_password sp login new_password = - ignore - (Eliom_sessions.close_session ~sp () >>= fun () -> - set_password_in_session sp (login,new_password)) - +let update_session_password login new_password = + Eliom_state.discard ~scope () >>= fun () -> + set_password_in_session (login, new_password) (* Check session to see what happened during page servicing. If any actions were called, some of them might've set values into session that we want to use for rendering the current page. *) -let any_complete_undos sp = - let table = Eliom_sessions.get_request_cache sp in +let any_complete_undos () = + let table = Eliom_request_info.get_request_cache () in try Some (Polytables.get ~table ~key:action_completed_task) with Not_found -> @@ -231,50 +226,50 @@ let any_complete_undos sp = (* Same as any_complete_undos except we check for changed task priorities. *) -let any_task_priority_changes sp = - let table = Eliom_sessions.get_request_cache sp in +let any_task_priority_changes () = + let table = Eliom_request_info.get_request_cache () in try Some (Polytables.get ~table ~key:action_task_priority_changed) with Not_found -> None -let connect_action_handler sp () login_nfo = - Eliom_sessions.close_session ~sp () >>= fun () -> - set_password_in_session sp login_nfo >>= fun () -> +let connect_action_handler () login_nfo = + Eliom_state.discard ~scope () >>= fun () -> + set_password_in_session login_nfo >>= fun () -> return () let () = - Eliom_predefmod.Action.register ~service:connect_action connect_action_handler + Eliom_registration.Action.register ~service:connect_action connect_action_handler (* /schema_install initializes the database schema (if needed) *) let _ = - register schema_install_page - (fun sp () () -> - Db.with_conn (fun conn -> Database_schema.install_schema ~conn) >>= fun _ -> + Eliom_registration.Html5.register schema_install_page + (fun () () -> + Database_schema.install_schema () >> return - (Html_util.html_stub sp + (Html_util.html_stub [h1 [pcdata "Database installation completed"]; p [br (); - link_to_nurpawiki_main sp]])) + link_to_nurpawiki_main ()]])) (* /upgrade upgrades the database schema (if needed) *) let _ = - register upgrade_page - (fun sp () () -> - Db.with_conn (fun conn -> Dbu.upgrade_schema ~conn) >>= fun msg -> + Eliom_registration.Html5.register upgrade_page + (fun () () -> + lwt msg = Dbu.upgrade_schema () in return - (Html_util.html_stub sp + (Html_util.html_stub [h1 [pcdata "Upgrade DB schema"]; (pre [pcdata msg]); p [br (); - link_to_nurpawiki_main sp]])) + link_to_nurpawiki_main ()]])) let _ = - register disconnect_page - (fun sp () () -> - (Eliom_sessions.close_session ~sp () >>= fun () -> + Eliom_registration.Html5.register disconnect_page + (fun () () -> + Eliom_state.discard ~scope () >>= fun () -> return - (Html_util.html_stub sp + (Html_util.html_stub [h1 [pcdata "Logged out!"]; p [br (); - link_to_nurpawiki_main sp]]))) + link_to_nurpawiki_main ()]])) diff --git a/user_editor.ml b/user_editor.ml index 6e4a4b5..fa4a106 100644 --- a/user_editor.ml +++ b/user_editor.ml @@ -15,21 +15,17 @@ *) open Lwt -open XHTML.M -open Eliom_sessions -open Eliom_parameters -open Eliom_services -open Eliom_predefmod.Xhtml +open Eliom_content.Html5.F +open Eliom_parameter +open Eliom_service open Services open Types module Db = Database -let query_user login = Db.with_conn (fun conn -> Db.query_user ~conn login) - let service_create_new_user = - new_post_service + post_service ~fallback:user_admin_page ~post_params:((string "login") ** (string "pass") ** @@ -39,7 +35,7 @@ let service_create_new_user = () let service_save_user_edit = - new_post_service + post_service ~fallback:edit_user_page ~post_params:((string "pass") ** (string "pass2") ** (* re-type *) @@ -48,59 +44,58 @@ let service_save_user_edit = () -let rec view_user_admin_page sp ~err ~cur_user = - Db.with_conn (fun conn -> Db.query_users ~conn) >>= fun users -> +let rec view_user_admin_page ~err ~cur_user = + lwt users = Db.query_users () in let users_table = table (tr - (th - [pcdata "Id"]) - [th [pcdata "Login"]; + [th [pcdata "Id"]; + th [pcdata "Login"]; th [pcdata "Real Name"]; th [pcdata "E-mail"]]) (List.map (fun user -> tr - (td [pcdata (string_of_int user.user_id)]) - [td [pcdata user.user_login]; + [td [pcdata (string_of_int user.user_id)]; + td [pcdata user.user_login]; td [pcdata user.user_real_name]; td [pcdata user.user_email]; - td [a ~service:edit_user_page ~sp [pcdata "Edit"] + td [a ~service:edit_user_page [pcdata "Edit"] (Some "user_admin", user.user_login)]]) users) in return - (Html_util.html_stub sp - (Html_util.navbar_html sp ~cur_user + (Html_util.html_stub + (Html_util.navbar_html ~cur_user ([h1 [pcdata "Edit users"]; users_table] @ err @ - [post_form ~service:service_create_new_user ~sp + [post_form ~service:service_create_new_user (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 ()]]) + [td [pcdata "Login:"]; + td [string_input ~input_type:`Text ~name:login ()]]) [tr - (td [pcdata "Password:"]) - [td [string_input ~input_type:`Password ~name:passwd ()]]; + [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 ()]]; + [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 ()]]; + [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 ()]]; + [td [pcdata "E-mail address:"]; + td [string_input ~input_type:`Text ~name:email ()]]; tr - (td [string_input ~input_type:`Submit ~value:"Add User" ()]) - []])]) ()]))) + [td [string_input ~input_type:`Submit ~value:"Add User" ()]] + ])]) ()]))) (* Only allow certain types of login names to avoid surprises *) let sanitize_login_name name = @@ -113,7 +108,7 @@ let save_user ~update_user ~login ~passwd ~passwd2 ~real_name ~email = None -> return [Html_util.error ("Only alphanumeric chars are allowed in login name! Got '"^login^"'")] | Some login -> - query_user login >>= fun old_user -> + Db.query_user login >>= fun old_user -> if not update_user && old_user <> None then return [Html_util.error ("User '"^login^"' already exists!")] else if login = "guest" then @@ -146,59 +141,59 @@ let save_user ~update_user ~login ~passwd ~passwd2 ~real_name ~email = end let _ = - register service_create_new_user - (fun sp () (login,(passwd,(passwd2,(real_name, email)))) -> - Session.with_user_login sp - (fun cur_user sp -> + Eliom_registration.Html5.register service_create_new_user + (fun () (login, (passwd, (passwd2, (real_name, email)))) -> + Session.with_user_login + (fun cur_user -> Privileges.with_can_create_user cur_user (fun () -> 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 -> return (Html_util.error_page sp e)))) + view_user_admin_page ~err ~cur_user) + ~on_fail:(fun e -> return (Html_util.error_page e)))) let save_user_prefs c_passwd c_passwd2 (c_name,old_name) (c_email,old_email) = (table (tr - (td [pcdata "New Password:"]) - [td [string_input ~input_type:`Password ~name:c_passwd ()]; + [td [pcdata "New Password:"]; + td [string_input ~input_type:`Password ~name:c_passwd ()]; ]) [tr - (td [pcdata "Re-type Password:"]) - [td [string_input ~input_type:`Password ~name:c_passwd2 ()]]; + [td [pcdata "Re-type Password:"]; + td [string_input ~input_type:`Password ~name:c_passwd2 ()]]; tr - (td [pcdata "Name:"]) - [td [string_input ~input_type:`Text ~name:c_name + [td [pcdata "Name:"]; + td [string_input ~input_type:`Text ~name:c_name ~value:old_name ()]]; tr - (td [pcdata "E-mail Address:"]) - [td [string_input ~input_type:`Text ~name:c_email + [td [pcdata "E-mail Address:"]; + td [string_input ~input_type:`Text ~name:c_email ~value:old_email ()]]; tr - (td [string_input ~input_type:`Submit ~value:"Save User" ()]) - []]) + [td [string_input ~input_type:`Submit ~value:"Save User" ()]] + ]) let _ = - register user_admin_page - (fun sp _ () -> - Session.with_user_login sp - (fun cur_user sp -> + Eliom_registration.Html5.register user_admin_page + (fun _ () -> + Session.with_user_login + (fun cur_user -> Privileges.with_can_view_users cur_user (fun () -> - view_user_admin_page sp ~err:[] ~cur_user) - ~on_fail:(fun e -> return (Html_util.error_page sp e)))) + view_user_admin_page ~err:[] ~cur_user) + ~on_fail:(fun e -> return (Html_util.error_page e)))) -let rec view_edit_user_page sp caller ~err ~cur_user user_to_edit = - Html_util.html_stub sp - (Html_util.navbar_html sp ~cur_user +let rec view_edit_user_page caller ~err ~cur_user user_to_edit = + Html_util.html_stub + (Html_util.navbar_html ~cur_user ([h1 [pcdata "Edit User"]] @ err @ - [post_form ~service:service_save_user_edit ~sp + [post_form ~service:service_save_user_edit (fun (passwd,(passwd2,(name,email))) -> [h2 [pcdata ("Edit User '"^user_to_edit.user_login^"'")]; save_user_prefs passwd passwd2 @@ -208,11 +203,11 @@ let rec view_edit_user_page sp caller ~err ~cur_user user_to_edit = let _ = - register service_save_user_edit - (fun sp (caller,login) (passwd,(passwd2,(real_name, email))) -> - Session.with_user_login sp - (fun cur_user sp -> - query_user login + Eliom_registration.Html5.register service_save_user_edit + (fun (caller, login) (passwd, (passwd2, (real_name, email))) -> + Session.with_user_login + (fun cur_user -> + Db.query_user login >>= function | Some user_to_edit -> Privileges.with_can_edit_user cur_user user_to_edit @@ -223,38 +218,40 @@ let _ = ~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 -> + (if err = [] && passwd <> "" && cur_user.user_login = login + then Session.update_session_password login passwd + else return () + ) >>= fun () -> + Session.with_user_login + (fun cur_user -> match caller with Some "user_admin" -> - view_user_admin_page sp ~err ~cur_user + view_user_admin_page ~err ~cur_user | Some _ -> - return (Html_util.error_page sp ("Invalid caller service!")) + return (Html_util.error_page "Invalid caller service!") | None -> - query_user login + Db.query_user login >>= function | Some user -> - return (view_edit_user_page sp caller ~err ~cur_user user) + return (view_edit_user_page 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)) + return (Html_util.error_page "Invalid user!"))) + ~on_fail:(fun e -> return (Html_util.error_page e)) | None -> - return (Html_util.error_page sp ("Trying to edit unknown user '"^login^"'")))) + return (Html_util.error_page ("Trying to edit unknown user '"^login^"'")))) let _ = - register edit_user_page - (fun sp (caller,editing_login) () -> - Session.with_user_login sp - (fun cur_user sp -> - query_user editing_login + Eliom_registration.Html5.register edit_user_page + (fun (caller, editing_login) () -> + Session.with_user_login + (fun cur_user -> + Db.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)) + return (view_edit_user_page caller ~err:[] ~cur_user user_to_edit)) + ~on_fail:(fun e -> return (Html_util.error_page e)) | None -> - return (Html_util.error_page sp ("Unknown user '"^editing_login^"'")))) + return (Html_util.error_page ("Unknown user '"^editing_login^"'")))) -- debian/patches/0004-Install-.a-file-along-with-.cmxa.patch0000644000000000000000000000113512131017746020113 0ustar From: Stephane Glondu Date: Mon, 15 Mar 2010 15:37:45 +0100 Subject: Install .a file along with .cmxa Signed-off-by: Stephane Glondu --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 605cc42..ef45e41 100644 --- a/Makefile +++ b/Makefile @@ -46,4 +46,4 @@ clean: -rm -Rf _build META version.ml install: - ocamlfind install nurpawiki META $(foreach T,$(TARGETS),_build/$(T)) + ocamlfind install nurpawiki META $(foreach T,$(TARGETS),_build/$(T) $(if $(findstring .cmxa,$(T)),_build/$(T:.cmxa=.a))) -- debian/patches/series0000644000000000000000000000041112131017746012030 0ustar 0001-Use-proper-connection-dependent-escaping.patch 0002-Add-native-archive-to-META.patch 0003-Port-to-Ocsigen-1.3.patch 0004-Install-.a-file-along-with-.cmxa.patch 0005-Replace-ocsigen_ext-by-ocsigen.ext-in-conf-template.patch 0006-Port-to-Ocsigen-2-Eliom-3.patch debian/patches/0005-Replace-ocsigen_ext-by-ocsigen.ext-in-conf-template.patch0000644000000000000000000000223412131017746024077 0ustar From: Stephane Glondu Date: Tue, 16 Mar 2010 10:41:53 +0100 Subject: Replace ocsigen_ext by ocsigen.ext in conf template Signed-off-by: Stephane Glondu --- ocsigen.conf.in | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/ocsigen.conf.in b/ocsigen.conf.in index 6bfc1a1..2d9815c 100644 --- a/ocsigen.conf.in +++ b/ocsigen.conf.in @@ -7,7 +7,7 @@ UTF-8 - + @@ -20,8 +20,8 @@ - - + + -- debian/patches/0003-Port-to-Ocsigen-1.3.patch0000644000000000000000000001743212131017746015457 0ustar From: Stephane Glondu Date: Mon, 15 Mar 2010 15:19:49 +0100 Subject: Port to Ocsigen 1.3 Signed-off-by: Stephane Glondu --- main.ml | 28 ++++++++++++---------------- scheduler.ml | 6 +++--- services.ml | 2 +- session.ml | 34 ++++++++++++++++------------------ types.ml | 6 +++--- 5 files changed, 35 insertions(+), 41 deletions(-) diff --git a/main.ml b/main.ml index 897fd4d..cf7ad86 100644 --- a/main.ml +++ b/main.ml @@ -49,10 +49,9 @@ let task_side_effect_complete sp task_id () = if Privileges.can_complete_task ~conn task_id user then begin Db.complete_task ~conn ~user_id:user.user_id task_id; - [Action_completed_task task_id] - end - else - [])) + let table = Eliom_sessions.get_request_cache sp in + Polytables.set ~table ~key:action_completed_task ~value:task_id + end)) let task_side_effect_undo_complete sp task_id () = @@ -61,8 +60,7 @@ let task_side_effect_undo_complete sp task_id () = Db.with_conn (fun conn -> if Privileges.can_complete_task ~conn task_id user then - Db.uncomplete_task ~conn ~user_id:user.user_id task_id; - [])) + Db.uncomplete_task ~conn ~user_id:user.user_id task_id)) let task_side_effect_mod_priority sp (task_id, dir) () = Session.action_with_user_login sp @@ -75,18 +73,16 @@ let task_side_effect_mod_priority sp (task_id, dir) () = Db.down_task_priority ~conn task_id else Db.up_task_priority ~conn task_id; - [Action_task_priority_changed task_id] - end - else - [])) - + let table = Eliom_sessions.get_request_cache sp in + Polytables.set ~table ~key:action_task_priority_changed ~value:task_id + end)) let () = - Eliom_predefmod.Actions.register + Eliom_predefmod.Action.register ~service:task_side_effect_complete_action task_side_effect_complete; - Eliom_predefmod.Actions.register + Eliom_predefmod.Action.register ~service:task_side_effect_undo_complete_action task_side_effect_undo_complete; - Eliom_predefmod.Actions.register + Eliom_predefmod.Action.register ~service:task_side_effect_mod_priority_action task_side_effect_mod_priority let make_static_uri = Html_util.make_static_uri @@ -450,7 +446,7 @@ let todo_list_table_html sp ~conn ~cur_user cur_page todos = Html_util.priority_css_class todo.t_priority in let row_class = row_pri_style:: - (if List.mem id priority_changes then + (if priority_changes = Some id then ["todo_priority_changed"] else []) in @@ -688,7 +684,7 @@ let _ = (page_name,(None,(None,None))); br (); textarea ~name:chain ~rows:30 ~cols:80 - ~value:(pcdata wikitext) ()])]) + ~value:wikitext ()])]) (page_name,(None,(None,None))) in Html_util.html_stub sp (wiki_page_contents_html sp ~conn ~cur_user diff --git a/scheduler.ml b/scheduler.ml index cc72c60..11fe041 100644 --- a/scheduler.ml +++ b/scheduler.ml @@ -238,10 +238,10 @@ let rec render_todo_editor sp ~conn ~cur_user (src_page_cont, todos_to_edit) = (tr (th [pcdata "ID"]) [th [pcdata "Description"]; th [pcdata "Activates on"]]) (f.it - (fun (tv_id,(tv_act_date,(tv_descr,tv_owner_id))) todo -> + (fun (tv_id,(tv_act_date,(tv_descr,tv_owner_id))) todo accu -> let pri_style = Html_util.priority_css_class todo.t_priority in - [tr ~a:[a_class [pri_style]] + (tr ~a:[a_class [pri_style]] (td [pcdata (string_of_int todo.t_id)]) [td (todo_descr tv_descr todo.t_descr :: wiki_page_links sp todo_in_pages todo); @@ -253,7 +253,7 @@ let rec render_todo_editor sp ~conn ~cur_user (src_page_cont, todos_to_edit) = button ~a:[a_id ("cal_button_"^(string_of_int todo.t_id))] ~button_type:`Button [pcdata "..."]]; td [owner_selection tv_owner_id todo; - int_input ~name:tv_id ~input_type:`Hidden ~value:todo.t_id ()]]]) + int_input ~name:tv_id ~input_type:`Hidden ~value:todo.t_id ()]])::accu) todos [tr (td [string_input ~input_type:`Submit ~value:"Save" (); cancel_page src_page_cont]) []])] in diff --git a/services.ml b/services.ml index 3b27686..9fea92e 100644 --- a/services.ml +++ b/services.ml @@ -32,7 +32,7 @@ let wiki_view_page = ** (opt (bool "force_login"))) () let wiki_start = Eliom_predefmod.String_redirection.register_new_service [] unit - (fun sp _ _ -> return (make_full_uri wiki_view_page sp (Config.site.cfg_homepage, (None, (None, None))))) + (fun sp _ _ -> return (make_uri ~absolute:true ~service:wiki_view_page ~sp (Config.site.cfg_homepage, (None, (None, None))))) let wiki_edit_page = new_service ["edit"] (string "p") () diff --git a/session.ml b/session.ml index c7ee4cb..7324557 100644 --- a/session.ml +++ b/session.ml @@ -204,13 +204,13 @@ let action_with_user_login sp f = if passwd_md5 = user.user_passwd then f user else - return [] + return () | None -> - return [] + return () end - | None -> return [] + | None -> return () else - return [] + return () let update_session_password sp login new_password = @@ -223,30 +223,28 @@ let update_session_password sp login new_password = actions were called, some of them might've set values into session that we want to use for rendering the current page. *) let any_complete_undos sp = - List.fold_left - (fun acc e -> - match e with - Action_completed_task tid -> Some tid - | _ -> acc) - None (Eliom_sessions.get_exn sp) + let table = Eliom_sessions.get_request_cache sp in + try + Some (Polytables.get ~table ~key:action_completed_task) + with Not_found -> + None (* Same as any_complete_undos except we check for changed task priorities. *) let any_task_priority_changes sp = - List.fold_left - (fun acc e -> - match e with - Action_task_priority_changed tid -> tid::acc - | _ -> acc) - [] (Eliom_sessions.get_exn sp) + let table = Eliom_sessions.get_request_cache sp in + try + Some (Polytables.get ~table ~key:action_task_priority_changed) + with Not_found -> + None let connect_action_handler sp () login_nfo = Eliom_sessions.close_session ~sp () >>= fun () -> set_password_in_session sp login_nfo >>= fun () -> - return [] + return () let () = - Eliom_predefmod.Actions.register ~service:connect_action connect_action_handler + Eliom_predefmod.Action.register ~service:connect_action connect_action_handler (* /schema_install initializes the database schema (if needed) *) let _ = diff --git a/types.ml b/types.ml index 0f68cc8..7eaf1b1 100644 --- a/types.ml +++ b/types.ml @@ -17,9 +17,9 @@ module OrdInt = struct type t = int let compare a b = compare a b end module IMap = Map.Make (OrdInt) -(* Exceptions returned by Eliom actions *) -exception Action_completed_task of int -exception Action_task_priority_changed of int +(* Sides-effects of Eliom actions *) +let action_completed_task : int Polytables.key = Polytables.make_key () +let action_task_priority_changed : int Polytables.key = Polytables.make_key () type user = { -- debian/compat0000644000000000000000000000000211554522113010363 0ustar 8 debian/control0000644000000000000000000000225612131017746010600 0ustar Source: nurpawiki Priority: extra Maintainer: Debian OCaml Maintainers Uploaders: Stéphane Glondu Build-Depends: debhelper (>= 8), dh-ocaml (>= 0.9.5~), libeliom-ocaml-dev (>= 3), libcalendar-ocaml-dev (>= 2.01.1-6~), libextlib-ocaml-dev (>= 1.5.1-5~), libpostgresql-ocaml-dev (>= 1.12.1-2~), ocaml-nox (>= 3.11.1-3~) Standards-Version: 3.9.3 Section: web Homepage: http://code.google.com/p/nurpawiki/ Vcs-Browser: http://git.debian.org/?p=pkg-ocaml-maint/packages/nurpawiki.git Vcs-Git: git://git.debian.org/git/pkg-ocaml-maint/packages/nurpawiki.git Package: nurpawiki Architecture: any Depends: ocsigenserver, ${ocaml:Depends}, ${shlibs:Depends}, ${misc:Depends} Suggests: postgresql Description: Wiki with integrated to-do list and scheduler Nurpawiki is a personal information manager (PIM) application that combines a wiki, a to-do list and a simple scheduler to help you get organized. It aims to ease note taking and action planning. Actions (to-dos) are always associated with notes or plans (wiki pages). . Nurpawiki is available as an Eliom module for the Ocsigen web server, and uses PostgreSQL as backend. debian/gbp.conf0000644000000000000000000000003611347443073010612 0ustar [DEFAULT] pristine-tar = True debian/changelog0000644000000000000000000000701712274220117011043 0ustar nurpawiki (1.2.3-7build3) trusty; urgency=medium * Rebuild for new OCaml ABIs. -- Colin Watson Tue, 04 Feb 2014 17:15:59 +0000 nurpawiki (1.2.3-7build2) trusty; urgency=medium * Rebuild for new OCaml ABIs. -- Colin Watson Thu, 09 Jan 2014 15:14:29 +0000 nurpawiki (1.2.3-7build1) trusty; urgency=medium * Rebuild for ocaml-4.01. -- Matthias Klose Tue, 24 Dec 2013 09:01:03 +0000 nurpawiki (1.2.3-7) unstable; urgency=low * Upload to unstable -- Stéphane Glondu Fri, 10 May 2013 23:26:05 +0200 nurpawiki (1.2.3-6) experimental; urgency=low * Port to Ocsigen 2 / Eliom 3 - use ocsigenserver instead of ocsigen * Update README.Debian * Update debian/watch (contributed by Bart Martens) * Switch copyright file to format 1.0 * Bump Standards-Version to 3.9.3 * Remove obsolete README.source -- Stéphane Glondu Tue, 09 Apr 2013 15:51:56 +0200 nurpawiki (1.2.3-5) unstable; urgency=low * Replace ocsigen_ext by ocsigen.ext in conf templates * Build native plugin only if natdynlink is present * Bump debhelper compat level to 8 * Bump Standards-Version to 3.9.2 -- Stéphane Glondu Sat, 23 Apr 2011 12:34:19 +0200 nurpawiki (1.2.3-4) unstable; urgency=low * debian/patches: - 0003-Port-to-Ocsigen-1.3.patch - 0004-Install-.a-file-along-with-.cmxa.patch * debian/control: - bump versioned build-dependency on libocsigen-ocaml-dev - bump Standards-Version to 3.8.4 (no changes) -- Stéphane Glondu Tue, 16 Mar 2010 10:22:25 +0100 nurpawiki (1.2.3-3) unstable; urgency=low * Switch packaging to dh-ocaml 0.9 * Switch packaging to source format 3.0 (quilt) * Change build-dependency from ocsigen-dev to libocsigen-ocaml-dev, and add explicit dependency to ocsigen for the binary package -- Stéphane Glondu Wed, 04 Nov 2009 16:25:18 +0100 nurpawiki (1.2.3-2) unstable; urgency=low * Add some patches: - Use-proper-connection-dependent-escaping.patch - Add-native-archive-to-META.patch * Add build-dependency to quilt, add README.source * Update the versioned dependency to libpostgresql-ocaml-dev -- Stéphane Glondu Sat, 19 Sep 2009 23:52:52 +0200 nurpawiki (1.2.3-1) unstable; urgency=low * New Upstream Version: - remove 0001-Build-native-plugin.patch * debian/control: - remove dependency to quilt - update runtime dependencies - update my e-mail address and remove DMUA * Remove README.source, there is no patches anymore -- Stéphane Glondu Tue, 08 Sep 2009 23:06:08 +0200 nurpawiki (1.2.2-4) unstable; urgency=low * Patch upstream to build and install native plugin * Add dependency to quilt and README.source * Update Standards-Version to 3.8.2 * Add versioned dependency to ocsigen-dev to ease OCaml 3.11.1 transition -- Stephane Glondu Thu, 09 Jul 2009 23:42:46 +0200 nurpawiki (1.2.2-3) unstable; urgency=low * Add debian/gbp.conf to force use of pristine-tar * Update Standards-Version to 3.8.1 (no changes) -- Stephane Glondu Wed, 01 Apr 2009 23:28:50 +0200 nurpawiki (1.2.2-2) experimental; urgency=low * Fix generation of OCaml ABI dependency -- Stephane Glondu Fri, 12 Dec 2008 11:25:42 +0100 nurpawiki (1.2.2-1) experimental; urgency=low * Initial release (Closes: #500726) -- Stephane Glondu Fri, 14 Nov 2008 13:40:40 +0100