initial commit

1 files changed, 126 insertions, 0 deletions

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)))))