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-invitoations
  12            #:setup-passenger-class-sql #:passenger-unauthorized-error
  13            #:create-activation-ticket #:confirm-activation-ticket
  14            #:register-passenger #:activate-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 (defun passenger-class-activation-table (class)
  33   "Table name of passenger class' activation ticket table."
  34   (concatenate 'string (s-sql:to-sql-name (dao-table-name class)) "_activation"))
  35
  36 (defun setup-passenger-class-sql
  37     (class
  38      &aux
  39      (table (s-sql:to-sql-name (dao-table-name class)))
  40      (activation-table (passenger-class-activation-table class))
  41      (activation-ticket-fn (concatenate 'string activation-table "_ticket_fn()") ))
  42   "SQL statement list to initialize passenger class CLASS."
  43   (list
  44    (dao-table-definition class)
  45    `(:alter-table ,table :add :foreign-key (passenger-parent) (,table id))
  46    `(:alter-table ,table :add :unique passenger-email)
  47    (concatenate 'string "CREATE FUNCTION " activation-ticket-fn " RETURNS text
  48     AS $$
  49 DECLARE
  50    j int4;
  51    result text;
  52    allowed text;
  53    allowed_len int4;
  54 BEGIN
  55    allowed := '1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ';
  56    allowed_len := length(allowed);
  57    result := '';
  58    WHILE length(result) < 16 LOOP
  59       j := int4(random() * allowed_len);
  60       result := result || substr(allowed, j+1, 1);
  61    END LOOP;
  62    RETURN result;
  63 END;
  64 $$
  65     LANGUAGE plpgsql;")
  66    `(:create-table ,activation-table
  67                    ((ticket :type (string 16)
  68                             :default (:raw ,activation-ticket-fn)
  69                             :unique t)
  70                     (passenger-id :type integer
  71                                   :references (,table))
  72                     (timestamp :type timestamp :default (now))
  73                     (used :type (or db-null (varchar 255)))))))
  74
  75
  76 (defun passenger-password (passenger)
  77   (base64:base64-string-to-string (passenger-password-base64 passenger)))
  78
  79 (defun (setf passenger-password) (new-password passenger)
  80   (setf (passenger-password-base64 passenger)
  81         (base64:string-to-base64-string new-password)))
  82
  83 (define-condition passenger-unauthorized-error (error)
  84   ()
  85   (:documentation "Error raised on authorization failure."))
  86
  87 (defun create-activation-ticket (passenger &optional (count 0))
  88   "Create new activation ticket for PASSENGER.
  89
  90 Used in new user registration and in password recovery process.
  91 Returns activation ticket as string."
  92   (handler-case
  93       (query (:insert-into (:raw (passenger-class-activation-table
  94                                   (class-of passenger)))
  95                            :set 'passenger-id '$1
  96                            :returning 'ticket)
  97              (id passenger) :single)
  98     (cl-postgres-error:unique-violation (e)
  99       (if (< count 10)
 100           (create-activation-ticket passenger (1+ count))
 101           (error "More than 10 unique violations in a row, afraid to carry on: ~A" e)))))
 102
 103 (defun confirm-activation-ticket (class ticket &optional activation-info)
 104   "Confirm activation ticket TICKET for passenger class CLASS.
 105
 106 Returns valiated user ID (integer), or NIL if ticket is
 107 invalid (i.e. nonexistent, already used, or more than 5 days old)."
 108   (let ((uid (query (:update (:raw (passenger-class-activation-table class))
 109                              :set 'used '$1
 110                              :where (:and (:is-null 'used)
 111                                           (:= ticket 'ticket)
 112                                           (:> 'timestamp
 113                                               (:- (:now) (:raw "interval '5 days'"))))
 114                              :returning 'passenger-id)
 115                     (format nil "~A GMT: ~A"
 116                             (simple-date:universal-time-to-timestamp
 117                              (get-universal-time))
 118                             activation-info)
 119                     :single)))
 120     uid))
 121
 122 (defun register-passenger (class &rest initargs)
 123   "Register new passenger of CLASS.
 124
 125 Thin wrapper arount MAKE-INSTANCE+INSERT-DAO.  INITARGS are
 126 MAKE-INSTANCE keyword arguments; if :PARENT initarg is given, parent's
 127 ID is automatically calculated, so user DAO can be directly provided.
 128 Returns new passenger's activation ticket and created DAO (already
 129 inserted into database)."
 130   (let ((parent (getf initargs :parent)))
 131     (when parent
 132       (setf (getf initargs :parent) (id parent))))
 133   (let ((new-passenger (apply #'make-instance class initargs)))
 134     (insert-dao new-passenger)
 135     (values (create-activation-ticket new-passenger)
 136             new-passenger)))
 137
 138 (defun activate-passenger (class ticket
 139                            &aux (uid (confirm-activation-ticket class ticket)))
 140   "Activate passenger of CLASS, using TICKET.
 141
 142 Thin wrapper on CONFIRM-ACTIVATION-TICKET, returns passenger DAO
 143 instead of numerical ID, and signals UNAUTHORIZED-ERROR on invalid
 144 TICKET."
 145   (unless uid
 146     (error 'unauthorized-error))
 147   (get-dao class uid))
 148
 149 (defun passenger-cookie (passenger &aux (salt (random-string)))
 150   "Return authentication cookie for PASSENGER."
 151   (format nil "~D,~A,~A"
 152           (id passenger) salt
 153           (salted-password salt (passenger-password passenger))))
 154
 155 (defun cookie-passenger (cookie class)
 156   "Authorize passenger of CLASS, based on authentication cookie COOKIE."
 157   (let* ((elements (split-sequence:split-sequence #\, cookie))
 158          (id (parse-integer (first elements) :junk-allowed t))
 159          (passenger (and id  (get-dao class id))))
 160     (when (and passenger (passenger-active-p passenger))
 161       (when (string= (salted-password (second elements) (passenger-password passenger))
 162                      (third elements))
 163         passenger))))