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