1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: wol -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
5 ;;;; Name: sessions.lisp
6 ;;;; Purpose: Session handler
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: July 2003
10 ;;;; $Id: sessions.lisp,v 1.2 2003/07/16 16:40:35 kevin Exp $
12 ;;;; This file and Wol are Copyright (c) 2003 by Kevin M. Rosenberg
13 ;;;; *************************************************************************
18 (defun make-new-session-id ()
19 (random-string :length 24 :set :lower-alphanumeric))
21 (defun ensure-websession (key req ent method)
22 "Find or make websession for key"
23 (let ((sessions (sessions (session-master (entity-project ent)))))
24 ;; if sessions doesn't exist, then project is not session enabled
28 (make-websession req ent method))
33 (when (equal key (websession-key v))
34 (setf (websession-lastref v) (get-universal-time))
35 (return-from ensure-websession v)))
37 (make-websession req ent method))))))
40 (defun make-websession (req ent method)
41 (let* ((key (random-string :length 24 :set :lower-alphanumeric))
42 (sess (make-instance 'websession
44 :lastref (get-universal-time)
45 :lifetime (lifetime (session-master (entity-project ent)))
47 (hash (sessions (session-master (entity-project ent)))))
49 (setf (gethash key hash) sess)
50 (setf (websession-from-req req) sess)
53 (defun compute-session (req ent)
54 (awhen (and (request-plist req)
55 (getf (request-plist req) :session-id))
56 (setf (websession-from-req req)
57 (ensure-websession it req ent :uri))))
61 ;;; Reap expired sessions
64 (defun start-reaper ()
65 (process-run-function "wol-reaper"
66 (lambda () (reap-sessions) (kmrcl::process-sleep *reap-interval*))))
68 (defun reap-sessions ()
69 (cmsg-c :debug "Reaping")
70 (dolist (expired (find-expired-sessions))
71 (flush-expired expired)))
73 (defun find-expired-sessions ()
74 (loop for s in (all-sessions)
75 when (is-session-expired (car s))
78 (defun all-sessions (&aux s)
79 (dolist (p *active-projects* s)
80 (let ((sm (session-master p))
81 (sessions (when sm (sessions sm))))
89 (defmethod flush-expired (s)
90 (let ((sessions (sessions (session-master (cdr s)))))
91 (remhash (car s) sessions)
92 (add-log-entry (cdr s) "flush expired session: key=~A" (websession-key (car s)))))
94 (defun is-session-expired (ws)
95 (> (get-universal-time) (+ (websession-lastref ws)
96 (websession-lifetime ws))))