sessions.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: wol -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          sessions.lisp
   6 ;;;; Purpose:       Session handler
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  July 2003
   9 ;;;;
  10 ;;;; $Id: sessions.lisp,v 1.3 2003/07/16 20:40:43 kevin Exp $
  11 ;;;;
  12 ;;;; This file and Wol are Copyright (c) 2003 by Kevin M. Rosenberg
  13 ;;;; *************************************************************************
  14
  15 (in-package #:wol)
  16
  17
  18 (defun make-new-session-id ()
  19   (random-string :length 24 :set :lower-alphanumeric))
  20
  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
  25     (when sessions
  26       (cond
  27        ((null key)
  28         (make-websession req ent method))
  29        (t
  30         (maphash
  31          (lambda (k v)
  32            (declare (ignore k))
  33            (when (equal key (websession-key v))
  34              (setf (websession-lastref v) (get-universal-time))
  35              (return-from ensure-websession v)))
  36          sessions)
  37         (make-websession req ent method))))))
  38
  39
  40 (defun make-websession (req ent method)
  41   (let* ((key (random-string :length 24 :set :lower-alphanumeric))
  42          (sess (make-instance 'websession
  43                  :key key
  44                  :lastref (get-universal-time)
  45                  :lifetime (lifetime (session-master (entity-project ent)))
  46                  :method method))
  47          (hash (sessions (session-master (entity-project ent)))))
  48     (when hash
  49       (setf (gethash key hash) sess)
  50       (setf (websession-from-req req) sess)
  51       sess)))
  52
  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))))
  58
  59
  60
  61 ;;; Reap expired sessions
  62
  63
  64 (defun start-reaper ()
  65   (process-run-function "wol-reaper"
  66     (lambda () (reap-sessions) (kmrcl::process-sleep *reap-interval*))))
  67
  68 (defun reap-sessions ()
  69   (cmsg-c :debug "Reaping")
  70   (dolist (expired (find-expired-sessions))
  71     (flush-expired expired)))
  72
  73 (defun find-expired-sessions ()
  74   (loop for s in (all-sessions)
  75         when (is-session-expired (car s))
  76         collect s))
  77
  78 (defun all-sessions (&aux s)
  79   (maphash
  80    (lambda (name proj)
  81      (declare (ignore name))
  82      (let* ((sm (session-master proj))
  83             (sessions (when sm (sessions sm))))
  84        (when sessions
  85          (maphash
  86           (lambda (k v)
  87             (declare (ignore k))
  88            (push (cons v proj) s))
  89           sessions))))
  90    *active-projects*)
  91   s)
  92
  93 (defmethod flush-expired (s)
  94   (let ((sessions (sessions (session-master (cdr s)))))
  95     (remhash (car s) sessions)
  96     (add-log-entry (cdr s) "flush expired session: key=~A" (websession-key (car s)))))
  97
  98 (defun is-session-expired (ws)
  99   (> (get-universal-time)  (+ (websession-lastref ws)
 100                               (websession-lifetime ws))))