From 1c6e47c25c25e4b197b0ea4a4d2bc8b827bdf260 Mon Sep 17 00:00:00 2001 From: Maciej Pasternacki Date: Wed, 22 Oct 2008 13:49:42 +0200 Subject: [PATCH] - New module: trane-passengers. --- src/passengers.lisp | 163 +++++++++++++++++++++++++++++++++++++++++++++++++++ trane-passengers.asd | 28 +++++++++ 2 files changed, 191 insertions(+) create mode 100644 src/passengers.lisp create mode 100644 trane-passengers.asd diff --git a/src/passengers.lisp b/src/passengers.lisp new file mode 100644 index 0000000..580fb7b --- /dev/null +++ b/src/passengers.lisp @@ -0,0 +1,163 @@ +;;; -*- lisp -*- passengers.lisp: users, registration, friendships and so on. + +;;;; Copyright (c) 2008, Maciej Pasternacki +;;;; All rights reserved. This file is available on the terms +;;;; detailed in COPYING file included with it. + +(defpackage :trane-passengers + (:use :common-lisp :postmodern #:trane-common) + (:export #:passenger #:id #:passenger-name #:passenger-active-p + #:passenger-parent #:passenger-email + #:passenger-password #:passenger-confirmed-p #:passenger-invitoations + #:setup-passenger-class-sql #:passenger-unauthorized-error + #:create-activation-ticket #:confirm-activation-ticket + #:register-passenger #:activate-passenger + #:passenger-cookie #:cookie-passenger)) +(in-package :trane-passengers) + +(defclass passenger (dirtiness-mixin) + ((id :col-type serial :reader id) + (passenger-name :col-type (or db-null (varchar 255)) :accessor passenger-name :initarg :name) + (passenger-active :col-type boolean :accessor passenger-active-p :initarg :active-p :initform t) + (passenger-parent :col-type (or db-null integer) + :accessor passenger-parent :initarg :parent :initform :null) + (passenger-email :col-type (varchar 255) :accessor passenger-email :initarg :email) + (passenger-password :col-type (or db-null (varchar 255)) :accessor passenger-password-base64 :initarg :password-base64) + (passenger-confirmed :col-type boolean :accessor passenger-confirmed-p :initarg :confirmed-p :initform nil) + (passenger-invitations :col-type integer :accessor passenger-invitations :initarg :invitations :initform 0)) + (:documentation "A basic, user-like object.") + (:metaclass dao-class) + (:keys id)) + +(defun passenger-class-activation-table (class) + "Table name of passenger class' activation ticket table." + (concatenate 'string (s-sql:to-sql-name (dao-table-name class)) "_activation")) + +(defun setup-passenger-class-sql + (class + &aux + (table (s-sql:to-sql-name (dao-table-name class))) + (activation-table (passenger-class-activation-table class)) + (activation-ticket-fn (concatenate 'string activation-table "_ticket_fn()") )) + "SQL statement list to initialize passenger class CLASS." + (list + (dao-table-definition class) + `(:alter-table ,table :add :foreign-key (passenger-parent) (,table id)) + `(:alter-table ,table :add :unique passenger-email) + (concatenate 'string "CREATE FUNCTION " activation-ticket-fn " RETURNS text + AS $$ +DECLARE + j int4; + result text; + allowed text; + allowed_len int4; +BEGIN + allowed := '1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ'; + allowed_len := length(allowed); + result := ''; + WHILE length(result) < 16 LOOP + j := int4(random() * allowed_len); + result := result || substr(allowed, j+1, 1); + END LOOP; + RETURN result; +END; +$$ + LANGUAGE plpgsql;") + `(:create-table ,activation-table + ((ticket :type (string 16) + :default (:raw ,activation-ticket-fn) + :unique t) + (passenger-id :type integer + :references (,table)) + (timestamp :type timestamp :default (now)) + (used :type (or db-null (varchar 255))))))) + + +(defun passenger-password (passenger) + (base64:base64-string-to-string (passenger-password-base64 passenger))) + +(defun (setf passenger-password) (new-password passenger) + (setf (passenger-password-base64 passenger) + (base64:string-to-base64-string new-password))) + +(define-condition passenger-unauthorized-error (error) + () + (:documentation "Error raised on authorization failure.")) + +(defun create-activation-ticket (passenger &optional (count 0)) + "Create new activation ticket for PASSENGER. + +Used in new user registration and in password recovery process. +Returns activation ticket as string." + (handler-case + (query (:insert-into (:raw (passenger-class-activation-table + (class-of passenger))) + :set 'passenger-id '$1 + :returning 'ticket) + (id passenger) :single) + (cl-postgres-error:unique-violation (e) + (if (< count 10) + (create-activation-ticket passenger (1+ count)) + (error "More than 10 unique violations in a row, afraid to carry on: ~A" e))))) + +(defun confirm-activation-ticket (class ticket &optional activation-info) + "Confirm activation ticket TICKET for passenger class CLASS. + +Returns valiated user ID (integer), or NIL if ticket is +invalid (i.e. nonexistent, already used, or more than 5 days old)." + (let ((uid (query (:update (:raw (passenger-class-activation-table class)) + :set 'used '$1 + :where (:and (:is-null 'used) + (:= ticket 'ticket) + (:> 'timestamp + (:- (:now) (:raw "interval '5 days'")))) + :returning 'passenger-id) + (format nil "~A GMT: ~A" + (simple-date:universal-time-to-timestamp + (get-universal-time)) + activation-info) + :single))) + uid)) + +(defun register-passenger (class &rest initargs) + "Register new passenger of CLASS. + +Thin wrapper arount MAKE-INSTANCE+INSERT-DAO. INITARGS are +MAKE-INSTANCE keyword arguments; if :PARENT initarg is given, parent's +ID is automatically calculated, so user DAO can be directly provided. +Returns new passenger's activation ticket and created DAO (already +inserted into database)." + (let ((parent (getf initargs :parent))) + (when parent + (setf (getf initargs :parent) (id parent)))) + (let ((new-passenger (apply #'make-instance class initargs))) + (insert-dao new-passenger) + (values (create-activation-ticket new-passenger) + new-passenger))) + +(defun activate-passenger (class ticket + &aux (uid (confirm-activation-ticket class ticket))) + "Activate passenger of CLASS, using TICKET. + +Thin wrapper on CONFIRM-ACTIVATION-TICKET, returns passenger DAO +instead of numerical ID, and signals UNAUTHORIZED-ERROR on invalid +TICKET." + (unless uid + (error 'unauthorized-error)) + (get-dao class uid)) + +(defun passenger-cookie (passenger &aux (salt (random-string))) + "Return authentication cookie for PASSENGER." + (format nil "~D,~A,~A" + (id passenger) salt + (salted-password salt (passenger-password passenger)))) + +(defun cookie-passenger (cookie class) + "Authorize passenger of CLASS, based on authentication cookie COOKIE." + (let* ((elements (split-sequence:split-sequence #\, cookie)) + (id (parse-integer (first elements) :junk-allowed t)) + (passenger (and id (get-dao class id)))) + (when (and passenger (passenger-active-p passenger)) + (when (string= (salted-password (second elements) (passenger-password passenger)) + (third elements)) + passenger)))) diff --git a/trane-passengers.asd b/trane-passengers.asd new file mode 100644 index 0000000..a79534b --- /dev/null +++ b/trane-passengers.asd @@ -0,0 +1,28 @@ +;;; -*- lisp -*- + +;;;; Copyright (c) 2008, Maciej Pasternacki +;;;; All rights reserved. This file is available on the terms +;;;; detailed in COPYING file included with it. + +(defpackage #:trane-passengers.system + (:use #:common-lisp #:asdf)) +(in-package #:trane-passengers.system) + +(defsystem #:trane-passengers + :name "Trane passengers" + :description "trane-passengers" + :author "Maciej Pasternacki " + :licence "BSD sans advertising clause, see file COPYING for details" + :components ((:module #:src :components ((:file "passengers")))) + :depends-on (#:postmodern #:cl-base64)) + +(defsystem #:trane-passengers.test + :description "Test suite for trane-passengers" + :components ((:module #:t :components ((:file "passengers")))) + :depends-on (#:trane-passengers #:fiveam)) + +(defmethod perform ((op asdf:test-op) + (system (eql (find-system :trane-passengers)))) + "Perform unit tests for trane-passengers" + (asdf:operate 'asdf:load-op :trane-passengers.test) + (funcall (intern (string :run!) (string :it.bese.fiveam)) :trane-passengers)) -- 2.11.4.GIT