blob: 8b28b08d9c9af29109f13402f53cc728b002b67e (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
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)))))
|
