/dylan/user.dylan
Unknown | 761 lines | 664 code | 97 blank | 0 comment | 0 complexity | 02231bf85ca84ab1b2261e4276d59d34 MD5 | raw file
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