File: session.ml

package info (click to toggle)
nurpawiki 1.2.3-10
  • links: PTS, VCS
  • area: main
  • in suites: sid, stretch
  • size: 1,400 kB
  • ctags: 1,581
  • sloc: ml: 2,869; sh: 119; makefile: 54
file content (276 lines) | stat: -rw-r--r-- 9,760 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
(* Copyright (c) 2006-2008 Janne Hellsten <jjhellst@gmail.com> *)

(* 
 * 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 <http://www.gnu.org/licenses/>. 
 *)

open Lwt
open Eliom_content.Html5.F
open Eliom_service
open Eliom_service.Http
open Eliom_parameter

open Services
open Types

open Config

module Db = Database
module Dbu = Database_upgrade

let seconds_in_day = 60.0 *. 60.0 *. 24.0

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 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 = service ["upgrade"] unit ()

let schema_install_page = service ["schema_install"] unit ()

let connect_action = 
  post_coservice'
    ~post_params:((string "login") ** (string "passwd"))
    ()
    

let link_to_nurpawiki_main sp = 
  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 () =
  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.";
      br ();
      strong [
        pcdata "You might be seeing this for a couple of reasons:";
        br ()];
      br ();
      pcdata "1) You just installed Nurpawiki and this is the first time you're running Nurpawiki on your database!"; br ();
      pcdata "2) You have upgraded an existing Nurpawiki installation and this is the first time you're running it since upgrade."; br ();
      br ();
      pcdata "In order to continue, your DB needs to be upgraded. ";
      pcdata "If you have valuable data in your DB, please take a backup of it before proceeding!";
      br ();
      br ();
      a ~service:upgrade_page [pcdata "Upgrade now!"] ()]]

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 [pcdata "Install schema!"] ()]]]
     

let login_html ~err =
  let help_text = 
    [br (); br (); 
     strong [pcdata "Please read "];
     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
    [div ~a:[a_id "login_outer"]
       [div ~a:[a_id "login_align_middle"]
          [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" ()]]];
                 p err]) ()]]]


let with_db_installed f =
  (* Check if the DB is installed.  If so, check that it doesn't need
     an upgrade. *)
  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) f =
  let login () =
    get_login_user ()
    >>= function
      | Some (login,passwd) ->
          begin
            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
                         [Html_util.error ("Wrong password given for user '"^login^"'")])
                  else
                    f user
              | None ->
                  return
                    (login_html
                       [Html_util.error ("Unknown user '"^login^"'")])
          end
      | None ->
          if allow_read_only && Config.site.cfg_allow_ro_guests then
            let guest_user = 
              {
                user_id = 0;
                user_login = "guest";
                user_passwd = "";
                user_real_name = "Guest";
                user_email = "";
              } in
            f guest_user
          else 
            return (login_html [])
  in
  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 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 f =
  lwt db_version = Dbu.db_schema_version () in
  if db_version = Db.nurpawiki_schema_version then
    get_login_user ()
    >>= function
      | Some (login,passwd) ->
          begin
            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
                    f user
                  else
                    return ()
              | None ->
                  return ()
          end
      | None -> return ()
 else
   return ()


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 () =
  let table = Eliom_request_info.get_request_cache () 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 () =
  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 () login_nfo =
  Eliom_state.discard ~scope () >>= fun () ->
    set_password_in_session login_nfo >>= fun () ->
      return ()

let () =
  Eliom_registration.Action.register ~service:connect_action connect_action_handler

(* /schema_install initializes the database schema (if needed) *)
let _ =
  Eliom_registration.Html5.register schema_install_page
    (fun () () ->
       Database_schema.install_schema () >>
       return
         (Html_util.html_stub
            [h1 [pcdata "Database installation completed"];
             p [br ();
                link_to_nurpawiki_main ()]]))

(* /upgrade upgrades the database schema (if needed) *)
let _ =
  Eliom_registration.Html5.register upgrade_page
    (fun () () ->
       lwt msg = Dbu.upgrade_schema () in
       return
         (Html_util.html_stub
            [h1 [pcdata "Upgrade DB schema"];
             (pre [pcdata msg]);
             p [br ();
                link_to_nurpawiki_main ()]]))

let _ =
  Eliom_registration.Html5.register disconnect_page
    (fun () () ->
       Eliom_state.discard ~scope () >>= fun () ->
        return
          (Html_util.html_stub
             [h1 [pcdata "Logged out!"];
              p [br ();
                 link_to_nurpawiki_main ()]]))