/dylan/user.dylan

  1Module: %wiki
  2Synopsis: User account management.
  3
  4
  5// User data is stored in a separate git repository so that it can
  6// be maintained under stricter security than other data.
  7
  8define thread variable *user-username* = #f;
  9
 10define thread variable *authenticated-user* = #f;
 11
 12// The default "realm" value passed in the WWW-Authenticate header.
 13//
 14define variable *default-authentication-realm* :: <string> = "dylan-wiki";
 15
 16// Because clients (browsers) continue to send the Authentication header
 17// once an authentication has been accepted (at least until the browser
 18// is restarted, it seems) we need to keep track of the fact that a user
 19// has logged out by storing the auth values here.
 20//
 21// Also, note that if the server restarts and browsers resend the auth,
 22// the user is suddenly logged in again.  Yikes.
 23//
 24define variable *ignore-authorizations* = list();
 25define variable *ignore-logins* = list();
 26
 27
 28// TODO: options to specify which fields are visible to whom.  (acls)
 29//
 30define class <wiki-user> (<wiki-object>)
 31
 32  constant slot %user-real-name :: false-or(<string>) = #f,
 33    init-keyword: real-name:;
 34
 35  slot user-password :: <string>,
 36    required-init-keyword: password:;
 37
 38  slot user-email :: <string>,
 39    required-init-keyword: email:;
 40
 41  slot administrator? :: <boolean> = #f,
 42    init-keyword: administrator?:;
 43
 44  slot user-activation-key :: <string>,
 45    init-keyword: activation-key:;
 46
 47  slot user-activated? :: <boolean> = #f,
 48    init-keyword: activated?:;
 49end class <wiki-user>;
 50
 51define method initialize
 52    (user :: <wiki-user>, #key)
 53  next-method();
 54  if (~slot-initialized?(user, user-activation-key))
 55    user.user-activation-key := generate-activation-key(user);
 56  end;
 57end;
 58
 59
 60// back compat
 61define inline function user-name
 62    (user :: <wiki-user>) => (name :: <string>)
 63  user.object-name
 64end;
 65
 66// back compat
 67define inline function user-name-setter
 68    (new-name :: <string>, user :: <wiki-user>) => (new-name :: <string>)
 69  user.object-name := new-name
 70end;
 71
 72
 73define generic user-real-name
 74    (user :: <wiki-user>) => (real-name :: <string>);
 75
 76define method user-real-name
 77    (user :: <wiki-user>) => (real-name :: <string>)
 78  user.%user-real-name | user.user-name
 79end;
 80
 81define function find-user
 82    (name :: <string>, #key default)
 83 => (user :: false-or(<wiki-user>))
 84  element(*users*, name, default: default)
 85end;
 86
 87/* unused
 88define method user-exists?
 89    (name :: <string>) => (exists? :: <boolean>)
 90  find-user(name) & #t
 91end;
 92*/
 93
 94// This is set when the config file is loaded.
 95define variable *admin-user* :: false-or(<wiki-user>) = #f;
 96
 97define method generate-activation-key
 98    (user :: <wiki-user>)
 99 => (key :: <string>)
100  // temporary.  should be more secure.
101  base64-encode(concatenate(user.user-name, user.user-email))
102end;
103
104// What's this for?
105define method as (class == <string>, user :: <wiki-user>)
106 => (result :: <string>)
107  user.user-name;
108end;
109
110define function authenticated-user ()
111 => (user :: false-or(<wiki-user>))
112  authenticate();
113  *authenticated-user*
114end;
115
116define method \=
117    (user1 :: <wiki-user>, user2 :: <wiki-user>)
118 => (equal? :: <boolean>)
119  user1.user-name = user2.user-name
120end;
121
122define method login
123    (#key realm :: false-or(<string>))
124  let redirect-url = get-query-value("redirect");
125  let user = check-authorization();
126  if (~user)
127    require-authorization(realm: realm);
128  elseif (member?(user, *ignore-authorizations*, test: \=) &
129          member?(user, *ignore-logins*, test: \=))
130    *ignore-authorizations* := remove!(*ignore-authorizations*, user);
131    require-authorization(realm: realm);
132  elseif (~member?(user, *ignore-authorizations*, test: \=) &
133          member?(user, *ignore-logins*, test: \=))
134    *ignore-logins* := remove!(*ignore-logins*, user);
135    redirect-url & redirect-to(redirect-url);
136  else
137    redirect-url & redirect-to(redirect-url);
138  end if;
139end;
140
141define function logout ()
142  let user = check-authorization();
143  if (user)
144    *authenticated-user* := #f;
145    *ignore-authorizations* :=
146      add!(*ignore-authorizations*, user);
147    *ignore-logins* :=
148      add!(*ignore-logins*, user);
149  end if;
150  let redirect-url = get-query-value("redirect");
151  redirect-url & redirect-to(redirect-url);
152end;
153
154// TODO: this should signal an error, which we can handle in one place
155//       and redirect to a login page.
156define function check-authorization
157    () => (user :: false-or(<wiki-user>))
158  let authorization = get-header(current-request(), "Authorization", parsed: #t);
159  if (authorization)
160    let name = head(authorization);
161    let pass = tail(authorization);
162    let user = find-user(name);
163    if (user
164          & user.user-activated?
165          & user.user-password = pass)
166      user
167    end
168  end
169end function check-authorization;
170
171define function authenticate
172    () => (user :: false-or(<wiki-user>))
173  let user = check-authorization();
174  if (user)
175    *authenticated-user*
176      := if (~member?(user, *ignore-authorizations*, test: \=)
177               & ~member?(user, *ignore-logins*, test: \=))
178           user
179         end;
180  end
181end function authenticate;
182
183define function require-authorization
184    (#key realm :: false-or(<string>))
185  let realm = realm | *default-authentication-realm*;
186  let headers = current-response().raw-headers;
187  set-header(headers, "WWW-Authenticate", concatenate("Basic realm=\"", realm, "\""));
188  unauthorized-error(headers: headers);
189end;
190
191define wf/object-test (user) in wiki end;
192
193define wf/error-tests (username, password, email) in wiki end;
194
195
196define sideways method permanent-link
197    (user :: <wiki-user>) => (url :: <url>)
198  user-permanent-link(user.user-name);
199end;
200
201define method user-permanent-link
202    (username :: <string>)
203 => (uri :: <uri>)
204  let location = wiki-url("/user/view/%s", username);
205  transform-uris(request-url(current-request()), location, as: <url>);
206end;
207
208define sideways method redirect-to (user :: <wiki-user>)
209  redirect-to(permanent-link(user));
210end;
211
212
213define method send-new-account-email
214    (user :: <wiki-user>)
215  let url = account-activation-url(user);
216  // body contains "subject\n\n"...weird
217  let body = format-to-string(
218    "To: %s\nSubject: Confirmation for account %s on %s\n\n"
219    "This message is to confirm the account '%s' you registered on %s.  "
220    "Click the following URL to complete the registration process and  "
221    "activate your new account: %s\n",
222                              user.user-email, user.user-name, *site-name*,
223                              user.user-name, *site-name*, url);
224
225  // Try to send the message.
226  // Retry once if we get 451, to work around grey listing.
227  iterate loop (first? = #t)
228    let handler <transient-smtp-error> = method (ex, next-handler)
229                                           if (first? & ex.smtp-error-code = 451)
230                                             loop(#f);
231                                           else
232                                             next-handler();
233                                           end;
234                                         end;
235    send-smtp-message(host: *mail-host*,
236                      port: *mail-port*,
237                      recipients: list(user.user-email),
238                      from: *admin-user*.user-email,
239                      body: body);
240    log-info("Email verification sent to %s for user %s",
241             user.user-email, user.user-name);
242  end;
243end method send-new-account-email;
244
245define method account-activation-url
246    (user :: <wiki-user>)
247 => (url :: <string>)
248  let default = current-request().request-absolute-url;
249  let prefix = iff(*wiki-url-prefix*.size = 0,
250                   #(),
251                   split(*wiki-url-prefix*, "/", remove-if-empty?: #t));
252  as(<string>,
253     make(<url>,
254          scheme: "http",
255          host: default.uri-host,
256          port: default.uri-port,
257          path: concatenate(list(""),
258                            prefix,
259                            list("user", "activate", user.user-name,
260                                 user.user-activation-key))))
261end method account-activation-url;
262
263// This is pretty restrictive for now.  Easier to loosen the rules later
264// than to tighten them up.  The name has been pre-stripped and %-decoded.
265//
266define method validate-user-name
267    (name :: <string>) => (name :: <string>)
268  if (empty?(name))
269    error("A user name is required.");
270  elseif (~regex-search(compile-regex("^[A-Za-z0-9_-]+$"), name))
271    error("User names must contain only alphanumerics, hyphens and underscores.");
272  end;
273  name
274end;
275
276define method validate-password
277    (password :: <string>) => (password :: <string>)
278  if (password.size <= 3)
279    error("A password of four or more characters is required.");
280  end;
281  password
282end;
283
284define method validate-email
285    (email :: <string>) => (email :: <string>)
286  // Just checking some basic syntax for now.  Will eventually send mail
287  // to verify.
288  let parts = split(email, '@');
289  if (parts.size ~= 2
290        | parts[0].size = 0
291        | parts[1].size = 0
292        | ~member?('.', parts[1]))
293    error("Invalid email address syntax.");
294  end;
295  email
296end;
297
298
299
300//// List Users
301
302define class <list-users-page> (<wiki-dsp>)
303end;
304
305define method respond-to-get
306    (page :: <list-users-page>, #key)
307  let pc = page-context();
308  set-attribute(pc, "active-users",
309                map(method (user)
310                      make-table(<string-table>,
311                                 "name" => user.user-name,
312                                 "admin?" => user.administrator?)
313                    end,
314                    choose(user-activated?,
315                           load-all(*storage*, <wiki-user>))));
316  let active-user = authenticated-user();
317  set-attribute(pc, "active-user", active-user & active-user.user-name);
318  next-method();
319end;
320
321define method respond-to-post
322    (page :: <list-users-page>, #key)
323  let user-name = percent-decode(get-query-value("user-name"));
324  let user = find-user(user-name);
325  if (user)
326    respond-to-get(*view-user-page*, name: user-name);
327  else
328    add-field-error("user-name", "User '%s' not found.", user-name);
329    next-method();
330  end;
331end method respond-to-post;
332
333//// View User
334
335define class <view-user-page> (<wiki-dsp>)
336end;
337
338define method respond-to-get
339    (page :: <view-user-page>, #key name :: <string>)
340  let name = percent-decode(name);
341  let user = find-user(name);
342  if (user)
343    let pc = page-context();
344    set-attribute(pc, "user-name", user.user-name);
345    set-attribute(pc, "group-memberships",
346                  sort(map(group-name, user-groups(user))));
347    set-attribute(pc, "group-ownerships",
348                  sort(map(group-name, groups-owned-by-user(user))));
349    set-attribute(pc, "admin?", user.administrator?);
350    let active-user = authenticated-user();
351    set-attribute(pc, "user-email",
352                  if (active-user & (active-user = user
353                                       | administrator?(active-user)))
354                    user.user-email
355                  else
356                    "private"
357                  end);
358    next-method();
359  else
360    // should only get here via a manually typed-in URL
361    respond-to-get(*non-existing-user-page*, name: name);
362  end;
363end method respond-to-get;
364
365
366//// Registration Page
367
368// This is similar to Edit User except that the account MUST NOT exist yet.
369//
370define class <registration-page> (<wiki-dsp>)
371end;
372
373define method respond-to-get
374    (page :: <registration-page>, #key)
375  let active-user = authenticated-user();
376  if (active-user)
377    add-page-note("You are already logged in.  Log out to register a new account.");
378    respond-to-get(*view-user-page*, name: active-user.user-name);
379  else
380    next-method();
381  end;
382end method respond-to-get;
383
384define method respond-to-post
385    (page :: <registration-page>, #key)
386  let active-user = authenticated-user();
387  if (active-user)
388    add-page-note("You are already logged in.  Log out to register a new account.");
389    respond-to-get(*view-user-page*, name: active-user.user-name);
390  else
391    let new-name = validate-form-field("user-name", validate-user-name);
392    let email = validate-form-field("email", validate-email);
393    let password = validate-form-field("password", validate-password);
394    let password2 = validate-form-field("password2", validate-password);
395    if (password ~= password2)
396      add-field-error("password2", "Passwords don't match.");
397    end;
398
399    // Hold this user name, by adding it to *users*, while email is being sent.
400    // It will be removed if there are any further errors.
401    let user
402      = if (find-user(new-name))
403          add-field-error("user-name", "A user named %s already exists.", new-name);
404          #f
405        else
406          with-lock ($user-lock)
407            // check again with lock held
408            if (find-user(new-name))
409              add-field-error("user-name", "A user named %s already exists.", new-name);
410              #f
411            else
412              *users*[new-name] := make(<wiki-user>,
413                                        name: new-name,
414                                        real-name: #f,  // TODO
415                                        password: password,
416                                        email: email,
417                                        administrator?: #f);
418            end;
419          end;
420        end if;
421    if (user & ~page-has-errors?())
422      // Hannes commented in IRC 2009-06-12: this will probably block
423      // the responder thread while the mail is being delivered; and
424      // to circumvent greylisting you've to wait 5-10 minutes between
425      // the first and second attempt. I'd suggest a separate thread
426      // which cares about email notifications, and the responder
427      // thread to push a message to a queue which is popped by the
428      // email thread...
429      block ()
430        send-new-account-email(user);
431      exception (ex :: <serious-condition>)
432        log-error("Email failed to %s (for %s): %s",
433                  user.user-email, user.user-name, ex);
434        add-field-error("email",
435                        "Unable to send confirmation email to this address.");
436      end;
437    end;
438
439    // Check again for errors since sending mail may have failed.
440    if (page-has-errors?())
441      with-lock($user-lock)
442        remove-key!(*users*, new-name);
443      end;
444      next-method();
445    else
446      block ()
447        store(*storage*, user, user, "New user created",
448              standard-meta-data(user, "create"));
449        with-lock ($user-lock)
450          *users*[user.user-name] := user;
451        end;
452        add-page-note("User %s created.  Please follow the link in the confirmation "
453                      "email sent to %s to activate the account.",
454                      new-name, email);
455        respond-to-get(*view-user-page*, name: user.user-name);
456      exception (ex :: <serious-condition>)
457        with-lock($user-lock)
458          remove-key!(*users*, new-name);
459        end;
460      end;
461    end if;
462  end if;    
463end method respond-to-post;
464
465
466//// User activation/deactivation
467
468// Responder for the URL sent in confirmation email to activate the account.
469//
470define function respond-to-user-activation-request
471    (#key name :: <string>, key :: <string>)
472  let name = percent-decode(name);
473  let user = find-user(name);
474  if (user)
475    if (~user.user-activated?)
476      let key = percent-decode(key);
477      if (key = user.user-activation-key)
478        user.user-activated? := #t;
479        store(*storage*, user, *admin-user*, "Account activated",
480              standard-meta-data(user, "activate"));
481      end;
482    end;
483    if (user.user-activated?)
484      add-page-note("User %s activated.", name);
485    else
486      add-page-error("User activation failed.");
487    end;
488  else
489    add-page-error("User %s not found.", name);
490  end;
491  respond-to-get(*view-user-page*, name: name);
492end function respond-to-user-activation-request;
493
494define class <deactivate-user-page> (<wiki-dsp>)
495end;
496
497define method respond-to-get
498    (dsp :: <deactivate-user-page>, #key name :: <string>)
499  dynamic-bind (*user* = find-user(name))
500    next-method();
501  end;
502end;
503
504define method respond-to-post
505    (dsp :: <deactivate-user-page>, #key name :: <string>)
506  dynamic-bind (*user* = find-user(name))
507    let author = authenticated-user();
508    if (author
509        & (author = *user* | author.administrator?)
510        & (*user* ~= *admin-user*))
511      let comment = get-query-value("comment") | "Deactivated";
512      store(*storage*, *user*, author, comment,
513            standard-meta-data(*user*, "deactivate"));
514      *user*.user-activated? := #f;
515      add-page-note("User '%s' deactivated", *user*.user-name);
516      respond-to-get(*list-users-page*);
517    else
518      add-page-error("You don't have permission to deactivate this user.");
519      respond-to-get(*view-user-page*, name: name);
520    end;
521  end;
522end method respond-to-post;
523
524
525//// Edit User
526
527// This is similar to <registration-page> except the user MUST exist.
528//
529define class <edit-user-page> (<wiki-dsp>)
530end;
531
532define method respond-to-get
533    (page :: <edit-user-page>, #key name :: <string>)
534  let name = percent-decode(name);
535  let user = find-user(name);
536  let active-user = authenticated-user();
537  let pc = page-context();
538  set-attribute(pc, "user-name", name);
539  set-attribute(pc, "button-text", iff(user, "Save", "Create"));
540  set-attribute(pc, "active-user-is-admin?",
541                active-user & administrator?(active-user));
542  if (user & (active-user = user | (active-user & administrator?(active-user))))
543    set-attribute(pc, "password", user.user-password);
544    set-attribute(pc, "email", user.user-email);
545    set-attribute(pc, "admin?", user.administrator?);
546    next-method();
547  else
548    add-page-error("You don't have permission to change this user.");
549    respond-to-get(*view-user-page*, name: name);
550  end;
551end method respond-to-get;
552
553define method respond-to-post
554    (page :: <edit-user-page>, #key name :: <string>)
555  let name = percent-decode(name);
556  let user = find-user(name);
557  let active-user = authenticated-user();
558  if (user & (~active-user | ~(active-user = user | active-user.administrator?)))
559    add-page-error("You don't have permission to change this user.");
560    respond-to-get(*view-user-page*, name: name);
561  else
562    let new-name = validate-form-field("user-name", validate-user-name);
563    if (name ~= new-name & find-user(new-name))
564      add-field-error("user-name", "A user named %s already exists.", new-name);
565    end;
566    let email = validate-form-field("email", validate-email);
567    let password = validate-form-field("password", validate-password);
568    let admin? = get-query-value("admin?");
569    if (page-has-errors?())
570      next-method();  // redisplay page with errors
571    else
572      if (user)
573        let comments = make(<stretchy-vector>);
574        if (user.user-name ~= new-name)
575          let comment = sformat("Rename to %s", new-name);
576          rename-user(user, new-name, comment);
577          add!(comments, comment);
578        end;
579        if (user.user-password ~= password)
580          user.user-password := password;
581          add!(comments, "password changed");
582        end;
583        if (user.user-email ~= email)
584          user.user-email := email;
585          add!(comments, "email changed");
586        end;
587        if (user.administrator? ~= admin?)
588          user.administrator? := admin?;
589          add!(comments, format-to-string("%s admin status",
590                                          iff(admin?, "added", "removed")));
591        end;
592        store(*storage*, user, active-user, join(comments, ", "),
593              standard-meta-data(user, "edit"));
594        add-page-note("User %s updated.", new-name);
595      else
596        // new user
597        user := make(<wiki-user>,
598                     name: new-name,
599                     password: password,
600                     email: email,
601                     administrator?: admin?);
602        store(*storage*, user, active-user, "User created",
603              standard-meta-data(user, "create"));
604        with-lock ($user-lock)
605          *users*[new-name] := user;
606        end;
607        add-page-note("User %s created.", new-name);
608        login(realm: *wiki-realm*);
609      end;
610      redirect-to(user);
611    end if;
612  end if;    
613end method respond-to-post;
614
615define function rename-user
616    (user :: <wiki-user>, new-name :: <string>, comment :: <string>)
617 => ()
618  let author = authenticated-user();
619  let revision = rename(*storage*, user, new-name, author, comment,
620                        standard-meta-data(user, "rename"));
621  let old-name = user.user-name;
622  with-lock ($user-lock)
623    remove-key!(*users*, old-name);
624    *users*[new-name] := user;
625  end;
626  user.user-name := new-name;
627  // user.user-revision := revision;
628end function rename-user;
629
630/* unused
631define method redirect-to-user-or
632    (page :: <wiki-dsp>, #key username)
633  if (*user*)
634    respond-to-get(page);
635  else
636    redirect-to(user-permanent-link(percent-decode(username)));
637  end if;
638end;
639*/
640
641
642// tags
643
644define tag show-user-username in wiki (page :: <wiki-dsp>)
645    ()
646  output("%s", (*user* & escape-xml(*user*.user-name))
647               | get-query-value("username")
648               | *user-username*
649               | "");
650end;
651
652define tag show-user-email in wiki (page :: <wiki-dsp>)
653    ()
654  output("%s", (*user* & escape-xml(*user*.user-email))
655               | get-query-value("email")
656               | "");
657end;
658
659define tag show-user-permanent-link in wiki (page :: <wiki-dsp>)
660    (use-change :: <boolean>)
661  if (*user*)
662    output("%s", permanent-link(*user*))
663  end;
664end;
665
666
667// body tags
668
669define body tag list-users in wiki
670    (page :: <wiki-dsp>, do-body :: <function>)
671    ()
672  if (*users*.size == 0)
673    // todo -- quick hack.  replace wiki:list-users with dsp:do
674    output("<li>No users</li>");
675  else
676    for (user in *users*)
677      dynamic-bind(*user* = user)
678        do-body();
679      end;
680    end for;
681  end;
682end tag list-users;
683
684define body tag with-authenticated-user in wiki
685    (page :: <wiki-dsp>, do-body :: <function>)
686    ()
687  dynamic-bind(*user* = authenticated-user())
688    do-body();
689  end;
690end;
691
692// named methods
693
694define named-method logged-in? in wiki
695    (page :: <wiki-dsp>)
696  authenticated-user() ~= #f
697end;
698
699define named-method admin? in wiki (page :: <wiki-dsp>)
700  *user* & administrator?(*user*)
701end;
702
703define named-method user-group-names in wiki (page :: <wiki-dsp>)
704  if (*user*)
705    sort(map(group-name, user-groups(*user*)))
706  else
707    #[]
708  end;
709end;
710
711define named-method group-names-owned-by-user in wiki (page :: <wiki-dsp>)
712  if (*user*)
713    sort(map(group-name, groups-owned-by-user(*user*)))
714  else
715    #[]
716  end;
717end;
718
719define named-method can-modify-user?
720    (page :: <wiki-dsp>)
721  let user = authenticated-user();
722  user & (administrator?(user)
723            | begin
724                let user-name = get-attribute(page-context(), "user-name");
725                user-name & (find-user(percent-decode(user-name)) = user)
726              end)
727end;
728
729
730define tag show-login-url in wiki (page :: <dylan-server-page>)
731    (redirect :: type-union(<string>, <boolean>), current :: <boolean>)
732  let url = parse-url("/login");
733  if (redirect)
734    url.uri-query["redirect"] := if (current) 
735                                   build-uri(request-url(current-request()))
736                                 else 
737                                   redirect
738                                 end;
739  end if;
740  output("%s", url);
741end;
742
743define tag show-logout-url in wiki (page :: <dylan-server-page>)
744    (redirect :: type-union(<string>, <boolean>), current :: <boolean>)
745  let url = parse-url("/logout");
746  if (redirect)
747    url.uri-query["redirect"] := if (current) 
748                                   build-uri(request-url(current-request())) 
749                                 else
750                                   redirect
751                                 end;
752  end if;
753  output("%s", url);
754end;
755
756
757define named-method authenticated? in wiki (page :: <dylan-server-page>)
758  authenticated-user()
759end;
760
761