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 &optional activation-info)
 120   "Confirm activation ticket TICKET for passenger class CLASS.
 121
 122 Returns valiated user ID (integer), or NIL if ticket is
 123 invalid (i.e. nonexistent, already used, or more than 5 days old)."
 124   (let ((uid (query (:update (:raw (passenger-class-activation-table class))
 125                              :set 'used '$1
 126                              :where (:and (:is-null 'used)
 127                                           (:= ticket 'ticket)
 128                                           (:> 'timestamp
 129                                               (:- (:now) (:raw "interval '5 days'"))))
 130                              :returning 'passenger-id)
 131                     (format nil "~A GMT: ~A"
 132                             (simple-date:universal-time-to-timestamp
 133                              (get-universal-time))
 134                             activation-info)
 135                     :single)))
 136     uid))
 137
 138 (defun register-passenger (class &rest initargs)
 139   "Register new passenger of CLASS.
 140
 141 Thin wrapper arount MAKE-INSTANCE+INSERT-DAO.  INITARGS are
 142 MAKE-INSTANCE keyword arguments; if :PARENT initarg is given, parent's
 143 ID is automatically calculated, so user DAO can be directly provided.
 144 Returns new passenger's activation ticket and created DAO (already
 145 inserted into database)."
 146   (let ((parent (getf initargs :parent)))
 147     (when parent
 148       (setf (getf initargs :parent) (id parent))))
 149   (let ((new-passenger (apply #'make-instance class initargs)))
 150     (insert-dao new-passenger)
 151     (values (create-activation-ticket new-passenger)
 152             new-passenger)))
 153
 154 (defun invite-passenger (parent email &rest initargs)
 155   "Let passenger PARENT invite new passenger at EMAIL."
 156   (unless (> (passenger-invitations parent) 0)
 157     (error 'unauthorized-error))
 158   (decf (passenger-invitations parent))
 159   (mark-as-dirty parent)
 160   (apply #'register-passenger (class-of parent)
 161          :parent parent :email email initargs))
 162
 163 (defun activate-passenger (class ticket
 164                            &aux (uid (confirm-activation-ticket class ticket)))
 165   "Activate passenger of CLASS, using TICKET.
 166
 167 Thin wrapper on CONFIRM-ACTIVATION-TICKET, returns passenger DAO
 168 instead of numerical ID, and signals UNAUTHORIZED-ERROR on invalid
 169 TICKET."
 170   (unless uid
 171     (error 'unauthorized-error))
 172   (let ((passenger (get-dao class uid)))
 173     (setf (passenger-confirmed-p passenger) t)
 174     (mark-as-dirty passenger)
 175     passenger))
 176
 177 (defun passenger-cookie (passenger &aux (salt (random-string)))
 178   "Return authentication cookie for PASSENGER."
 179   (format nil "~D,~A,~A"
 180           (id passenger) salt
 181           (salted-password salt (passenger-password passenger))))
 182
 183 (defun cookie-passenger (cookie class)
 184   "Authorize passenger of CLASS, based on authentication cookie COOKIE."
 185   (let* ((elements (split-sequence:split-sequence #\, cookie))
 186          (id (parse-integer (first elements) :junk-allowed t))
 187          (passenger (and id  (get-dao class id))))
 188     (when (and passenger (passenger-active-p passenger))
 189       (when (string= (salted-password (second elements) (passenger-password passenger))
 190                      (third elements))
 191         passenger))))