src/passengers.lisp

   1 ;;; -*- lisp -*- passengers.lisp: users, registration, friendships and so on.
   2
   3 ;;;; Copyright (c) 2008, Maciej Pasternacki <maciej@pasternacki.net>
   4 ;;;; All rights reserved.  This file is available on the terms
   5 ;;;; detailed in COPYING file included with it.
   6
   7 (defpackage :trane-passengers
   8   (:use :common-lisp :postmodern #:trane-common)
   9   (:export #:passenger #:id #:passenger-name #:passenger-active-p
  10            #:passenger-parent #:passenger-email
  11            #:passenger-password #:passenger-confirmed-p #:passenger-invitations
  12            #:setup-passenger-class-sql #:passenger-unauthorized-error
  13            #:create-activation-ticket #:try-activation-ticket #:confirm-activation-ticket
  14            #:register-passenger #:activate-passenger #:invite-passenger
  15            #:passenger-cookie #:cookie-passenger))
  16 (in-package :trane-passengers)
  17
  18 (defclass passenger (dirtiness-mixin)
  19   ((id :col-type serial :reader id)
  20    (passenger-name :col-type (or db-null (varchar 255)) :accessor passenger-name :initarg :name)
  21    (passenger-active :col-type boolean :accessor passenger-active-p :initarg :active-p :initform t)
  22    (passenger-parent :col-type (or db-null integer)
  23                      :accessor passenger-parent :initarg :parent :initform :null)
  24    (passenger-email :col-type (varchar 255) :accessor passenger-email :initarg :email)
  25    (passenger-password :col-type (or db-null (varchar 255)) :accessor passenger-password-base64 :initarg :password-base64)
  26    (passenger-confirmed :col-type boolean :accessor passenger-confirmed-p :initarg :confirmed-p :initform nil)
  27    (passenger-invitations :col-type integer :accessor passenger-invitations :initarg :invitations :initform 0))
  28   (:documentation "A basic, user-like object.")
  29   (:metaclass dao-class)
  30   (:keys id))
  31
  32 (defmethod print-object ((o passenger) s)
  33   (print-unreadable-object (o s :type t :identity t)
  34     (format s "~D ~S" (id o) (passenger-name o))))
  35
  36 (defun passenger-class-activation-table (class)
  37   "Table name of passenger class' activation ticket table."
  38   (concatenate 'string (s-sql:to-sql-name (dao-table-name class)) "_activation"))
  39
  40 (defun setup-passenger-class-sql
  41     (class
  42      &aux
  43      (table (s-sql:to-sql-name (dao-table-name class)))
  44      (activation-table (passenger-class-activation-table class))
  45      (activation-ticket-fn (concatenate 'string activation-table "_ticket_fn()") ))
  46   "SQL statement list to initialize passenger class CLASS."
  47   (list
  48    (dao-table-definition class)
  49    `(:alter-table ,table :add :foreign-key (passenger-parent) (,table id))
  50    `(:alter-table ,table :add :unique passenger-email)
  51    (concatenate 'string "CREATE FUNCTION " activation-ticket-fn " RETURNS text
  52     AS $$
  53 DECLARE
  54    j int4;
  55    result text;
  56    allowed text;
  57    allowed_len int4;
  58 BEGIN
  59    allowed := '1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ';
  60    allowed_len := length(allowed);
  61    result := '';
  62    WHILE length(result) < 16 LOOP
  63       j := int4(random() * allowed_len);
  64       result := result || substr(allowed, j+1, 1);
  65    END LOOP;
  66    RETURN result;
  67 END;
  68 $$
  69     LANGUAGE plpgsql;")
  70    `(:create-table ,activation-table
  71                    ((ticket :type (string 16)
  72                             :default (:raw ,activation-ticket-fn)
  73                             :unique t)
  74                     (passenger-id :type integer
  75                                   :references (,table))
  76                     (timestamp :type timestamp :default (now))
  77                     (used :type (or db-null (varchar 255)))))))
  78
  79
  80 (defun passenger-password (passenger)
  81   (base64:base64-string-to-string (passenger-password-base64 passenger)))
  82
  83 (defun (setf passenger-password) (new-password passenger)
  84   (setf (passenger-password-base64 passenger)
  85         (base64:string-to-base64-string new-password)))
  86
  87 (define-condition passenger-unauthorized-error (error)
  88   ()
  89   (:documentation "Error raised on authorization failure."))
  90
  91 (defun create-activation-ticket (passenger &optional (count 0))
  92   "Create new activation ticket for PASSENGER.
  93
  94 Used in new user registration and in password recovery process.
  95 Returns activation ticket as string."
  96   (handler-case
  97       (query (:insert-into (:raw (passenger-class-activation-table
  98                                   (class-of passenger)))
  99                            :set 'passenger-id '$1
 100                            :returning 'ticket)
 101              (id passenger) :single)
 102     (cl-postgres-error:unique-violation (e)
 103       (if (< count 10)
 104           (create-activation-ticket passenger (1+ count))
 105           (error "More than 10 unique violations in a row, afraid to carry on: ~A" e)))))
 106
 107 (defun try-activation-ticket (class ticket)
 108   "Try (but do not mark as already used) an activation ticket.
 109
 110 Returns ticket's passenger ID (integer), or NIL."
 111   (query (:select 'passenger-id
 112                   :from (:raw (passenger-class-activation-table class))
 113                   :where (:and (:is-null 'used)
 114                                (:= ticket 'ticket)
 115                                (:> 'timestamp
 116                                    (:- (:now) (:raw "interval '5 days'")))))
 117          :single))
 118
 119 (defun confirm-activation-ticket (class ticket &key activation-info (ticket-timeout 62))
 120   "Confirm activation ticket TICKET for passenger class CLASS.
 121
 122 ACTIVATION-INFO is additional information stored in the database.
 123 TICKET-TIMEOUT is number of days, after which activation ticket becomes invalid.
 124
 125 Returns valiated user ID (integer), or NIL if ticket is
 126 invalid (i.e. nonexistent, already used, or more than 5 days old)."
 127   (let ((uid (query (:update (:raw (passenger-class-activation-table class))
 128                              :set 'used '$1
 129                              :where (:and (:is-null 'used)
 130                                           (:= ticket 'ticket)
 131                                           (:> 'timestamp
 132                                               (:- (:now) (:raw (format nil "interval '~D days'" ticket-timeout)))))
 133                              :returning 'passenger-id)
 134                     (format nil "~A GMT: ~A"
 135                             (simple-date:universal-time-to-timestamp
 136                              (get-universal-time))
 137                             activation-info)
 138                     :single)))
 139     uid))
 140
 141 (defun register-passenger (class &rest initargs)
 142   "Register new passenger of CLASS.
 143
 144 Thin wrapper arount MAKE-INSTANCE+INSERT-DAO.  INITARGS are
 145 MAKE-INSTANCE keyword arguments; if :PARENT initarg is given, parent's
 146 ID is automatically calculated, so user DAO can be directly provided.
 147 Returns new passenger's activation ticket and created DAO (already
 148 inserted into database)."
 149   (let ((parent (getf initargs :parent)))
 150     (when parent
 151       (setf (getf initargs :parent) (id parent))))
 152   (let ((new-passenger (apply #'make-instance class initargs)))
 153     (insert-dao new-passenger)
 154     (values (create-activation-ticket new-passenger)
 155             new-passenger)))
 156
 157 (defun invite-passenger (parent email &rest initargs)
 158   "Let passenger PARENT invite new passenger at EMAIL."
 159   (unless (> (passenger-invitations parent) 0)
 160     (error 'unauthorized-error))
 161   (decf (passenger-invitations parent))
 162   (mark-as-dirty parent)
 163   (apply #'register-passenger (class-of parent)
 164          :parent parent :email email initargs))
 165
 166 (defun activate-passenger (class ticket
 167                            &aux (uid (confirm-activation-ticket class ticket)))
 168   "Activate passenger of CLASS, using TICKET.
 169
 170 Thin wrapper on CONFIRM-ACTIVATION-TICKET, returns passenger DAO
 171 instead of numerical ID, and signals UNAUTHORIZED-ERROR on invalid
 172 TICKET."
 173   (unless uid
 174     (error 'unauthorized-error))
 175   (let ((passenger (get-dao class uid)))
 176     (setf (passenger-confirmed-p passenger) t)
 177     (mark-as-dirty passenger)
 178     passenger))
 179
 180 (defun passenger-cookie (passenger &aux (salt (random-string)))
 181   "Return authentication cookie for PASSENGER."
 182   (format nil "~D,~A,~A"
 183           (id passenger) salt
 184           (salted-password salt (passenger-password passenger))))
 185
 186 (defun cookie-passenger (cookie class)
 187   "Authorize passenger of CLASS, based on authentication cookie COOKIE."
 188   (let* ((elements (split-sequence:split-sequence #\, cookie))
 189          (id (parse-integer (first elements) :junk-allowed t))
 190          (passenger (and id  (get-dao class id))))
 191     (when (and passenger (passenger-active-p passenger))
 192       (when (string= (salted-password (second elements) (passenger-password passenger))
 193                      (third elements))
 194         passenger))))