diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/generics.lisp | 27 | ||||
| -rw-r--r-- | src/headers.lisp | 126 | ||||
| -rw-r--r-- | src/session-object.lisp | 18 |
3 files changed, 171 insertions, 0 deletions
diff --git a/src/generics.lisp b/src/generics.lisp new file mode 100644 index 0000000..3e96641 --- /dev/null +++ b/src/generics.lisp @@ -0,0 +1,27 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :org-ckons-session) + +(defgeneric populate-headers (header-register headers) + (:documentation "Copies the headers defined in the `headers' list +into `header-register'.")) + +(defgeneric ship-headers (header-register) + (:documentation "Sends the data in `header-register' out to the +reply.")) + +(defgeneric headers-get-cookie (header-register name) + (:documentation "Returns two values: the value of the cookie and a +boolean indicating whether the cookie exists in the hashtable.")) + +(defgeneric headers-set-cookie (header-register cookie) + (:documentation "Sets a `cookie' object into `header-reigster'.")) + +(defgeneric get-sessionid-cookie (header-register) + (:documentation "Gets the sessionid cookie from the +`header-register'.")) + +(defgeneric set-sessionid-cookie (header-register sessionid) + (:documentation "Registers the sessionid cookie.")) + diff --git a/src/headers.lisp b/src/headers.lisp new file mode 100644 index 0000000..8b28b08 --- /dev/null +++ b/src/headers.lisp @@ -0,0 +1,126 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(defpackage :org-ckons-session + (:use :cl)) + +(in-package :org-ckons-session) + +(defparameter *session-cookie-name* "SESSIONID" + "The lookup name of the sessionid cookie.") + +(defvar *session-timeout* (* 4 60 60) + "The length of time in seconds that an inactive session has before +being garbage collected.") + +(defvar *gc-interval* 15 + "The minimum length of time in seconds that must elapse between +successive garbage collection cycles. Without this interval enforced, +garbage collection would occur upon every page request.") + +(defvar *gc-last-cycle-timestamp* (- (get-universal-time) *gc-interval* 1) + "Holds the timestamp of the last garbage collection cycle. Compared +against `*gc-interval*' to determine if it's time to allow another +cycle to run. Used to limit the frequency of garbage collection +cycles. Initially set far enough back to ensure a GC when the app is +first started.") + +(defclass header-register () + ((content-type :initarg :content-type + :initform "text/html; charset=utf-8" + :accessor content-type) + (content-length :initarg :content-length + :initform nil + :accessor content-length) + (content-disposition :initarg :content-disposition + :initform nil + :accessor content-disposition) + (expires :initarg :expires + :initform nil + :accessor expires) + (cache-control :initarg :cache-control + :initform nil + :accessor cache-control) + (location :initarg :location + :initform nil + :accessor location) + (refresh :initarg :refresh + :initform nil + :accessor refresh) + (pragma :initarg :pragma + :initform nil + :accessor pragma) + (cookies :initarg :cookies + :initform (make-hash-table :test 'equal) + :accessor cookies) + (conditional :initarg :conditional + :initform nil + :accessor conditional) + (www-authenticate :initarg :www-authenticate + :initform nil + :accessor www-authenticate) + (extra-http-headers :initarg :extra-http-headers + :initform nil + :accessor extra-http-headers) + (last-modified :initarg :last-modified + :initform nil + :accessor last-modified) + (response-text :initarg :response-text + :initform nil + :accessor response-text) + (response-code :initarg :response-code + :initform nil + :accessor response-code)) + (:documentation "A collection of registers to hold headers that we +wish to write.")) + +(defparameter *header-names* (org-ckons-core::map-slot-names (make-instance 'header-register))) + +(defmethod populate-headers ((header-register header-register) headers) + (loop for name in *header-names* do + (let ((kword (intern (symbol-name name) :keyword))) + (when (getf headers kword) + (setf (slot-value header-register name) (getf headers kword)))))) + +(defmethod ship-headers ((header-register header-register)) + (loop for name in *header-names* do + (if (eq name 'cookies) + (maphash (lambda (cookie-name cookie) + (declare (ignore cookie-name)) + (hunchentoot::set-cookie* cookie)) + (slot-value header-register name)) + (let ((value (slot-value header-register name))) + (when value + (setf (hunchentoot::header-out name) value)))))) + +(defmethod headers-get-cookie ((header-register header-register) name) + (gethash name (cookies header-register))) + +(defmethod headers-set-cookie ((header-register header-register) cookie) + (setf (gethash (hunchentoot::cookie-name cookie) (cookies header-register)) cookie)) + +(defmethod get-sessionid-cookie ((header-register header-register)) + (headers-get-cookie header-register *session-cookie-name*)) + +(defmethod set-sessionid-cookie ((header-register header-register) sessionid) + (org-ckons-core::logger (format nil "Writing session cookie: ~a~%" sessionid)) + (headers-set-cookie header-register (make-cookie *session-cookie-name* sessionid))) + +(defun make-cookie (name value &key (path "/") (domain (first (ppcre:split ":" (third (ppcre:split "/" (hunchentoot::request-uri*))))))) + (make-instance 'hunchentoot::cookie + :name name + :value value + :path path + :domain domain)) + +(defun get-sessionid-from-request () + (hunchentoot::cookie-in *session-cookie-name*)) + +(defun generate-sessionid () + (let ((entropic-value (make-array '(24) :element-type '(unsigned-byte 8)))) + (with-open-file (urandom-file "/dev/urandom" :direction :input :element-type '(unsigned-byte 8)) + (loop for i from 0 to 23 do + (setf (elt entropic-value i) (read-byte urandom-file)))) + (let ((digest (ironclad:make-digest 'ironclad:sha256))) + (ironclad:update-digest digest entropic-value) + (ironclad:byte-array-to-hex-string (ironclad:produce-digest digest))))) diff --git a/src/session-object.lisp b/src/session-object.lisp new file mode 100644 index 0000000..480cf6f --- /dev/null +++ b/src/session-object.lisp @@ -0,0 +1,18 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :org-ckons-session) + +(defclass session-object () + ((*session-key :initarg :*session-key + :initform (error 'org-ckons-condition::handled-error :text "Subclasses of `session-object' must supply an initform for the *SESSION-KEY slot.") + :accessor *session-key + :documentation "The key to the user_session_objects table.")) + (:documentation "Superclass for all session objects. +`session-object' is involved in multiple inheritance. Every +`session-object' is also a `record'. It must have a `*where-expresion' +of id = ~a.")) + +(defmethod sanitize-json ((session-object session-object)) + (setf (*session-key session-object) nil) + (call-next-method)) |