project.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: wol -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          project.lisp
   6 ;;;; Purpose:       Project handler for wol library
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  July 2003
   9 ;;;;
  10 ;;;; $Id: project.lisp,v 1.2 2003/07/16 20:40:43 kevin Exp $
  11 ;;;;
  12 ;;;; This file and Wol are Copyright (c) 2001-2003 by Kevin M. Rosenberg
  13 ;;;; *************************************************************************
  14
  15 (in-package #:wol)
  16
  17 (defun wol-project (name &key (project-prefix "/") map index
  18                               (sessions t) (session-lifetime 18000)
  19                               (reap-interval 300) (server *ml-server*))
  20   (unless server
  21     (warn "Can't start project without server")
  22     (return-from wol-project nil))
  23
  24   (multiple-value-bind (project found) (gethash name *active-projects*)
  25     (unless found
  26       (setq project (make-instance 'wol-project))
  27       (setf (gethash name *active-projects*) project))
  28
  29     (setf (project-name project) name)
  30     (setf (project-prefix project) project-prefix)
  31     (setf (project-map project) map)
  32     (setf (project-index project) index)
  33     (setf (project-server project) server)
  34     (setf (lifetime (session-master project)) session-lifetime)
  35     (setf (cookie-name (session-master project)) name)
  36
  37     (let ((hash (make-hash-table :size (length map) :test 'equal)))
  38       (dolist (map-item map)
  39         (setf (gethash (first map-item) hash) (second map-item)))
  40       (setf (project-hash-map project) hash))
  41
  42     (setf (ml::processor server) 'wol-ml-processor)
  43
  44     (if sessions
  45         (when (null (sessions (session-master project)))
  46           (setf (sessions (session-master project))
  47             (make-hash-table :test 'eq)))
  48       (when (sessions (session-master project))
  49         (setf (sessions (session-master project)) nil)))
  50
  51     (setq *reap-interval* reap-interval)
  52     (when (and sessions (null *reaper-process*))
  53       (setq *reaper-process* (start-reaper)))))
  54
  55 (defun wol-ml-processor (command)
  56   "Processes an incoming modlisp command"
  57   (let ((req (command->request command
  58                                :ml-server *ml-server*)))
  59     (unless (dispatch-request req)
  60       (no-url-handler req))))
  61
  62
  63 (defun command->request (command &key ml-server)
  64   "Convert a cl-modlisp command into a wol request"
  65   (let ((req
  66          (make-instance 'http-request
  67            :vhost (header-value command :host)
  68            :raw-uri (header-value command :url)
  69            :uri (create-uri (header-value command :host)
  70                             (awhen (header-value
  71                                   command :server-ip-port)
  72                                  (parse-integer it))
  73                             (header-value command :url))
  74            :protocol (ensure-keyword (header-value command :server-protocol))
  75            :protocol-string (header-value command :server-protocol)
  76            :method (ensure-keyword (header-value command :method))
  77            :posted-content (header-value command :posted-content)
  78            :headers command
  79            :socket *modlisp-socket*
  80            :ml-server ml-server)))
  81     req))
  82
  83 (defun header-slot-value (req slot)
  84   (header-value (request-headers req) slot))
  85
  86 (defun create-uri (host port page)
  87   (format nil "http://~A:~D~A" host port page))
  88
  89 (defun is-index-request (req ent)
  90   (string= (request-raw-uri req)
  91            (project-prefix (entity-project ent))))
  92
  93 (defun redirect-entity (page ent)
  94   (redirect-to-location
  95    (format nil "~A~A" (project-prefix (entity-project ent)) page)))
  96
  97 (defun dispatch-request (req)
  98   (let ((ent (find-entity-for-request req)))
  99     (when ent
 100       (let ((proj (entity-project ent)))
 101         (if (is-index-request req ent)
 102             (progn
 103               (redirect-entity (project-index proj) ent)
 104               t)
 105           (progn
 106             (request-decompile-uri req ent)
 107             (compute-session req ent)
 108             (dispatch-entity req ent))))
 109       ent)))
 110
 111 (defun make-entity (&key project)
 112   (make-instance 'entity :project project))
 113
 114 (defun find-entity-for-request (req)
 115   (maphash (lambda (name project)
 116              (declare (ignore name))
 117              (when (request-matches-prefix req (project-prefix project))
 118                (return-from find-entity-for-request
 119                  (make-entity :project project))))
 120            *active-projects*))
 121
 122 (defun request-matches-prefix (req prefix)
 123   "Returns project if request matches project"
 124   (string-starts-with prefix (request-raw-uri req)))
 125
 126
 127 (defun dispatch-entity (req ent)
 128   (let ((handler (request-find-handler req ent)))
 129     (if handler
 130         (handle-request handler req ent)
 131       (no-url-handler req))))
 132
 133 (defun request-find-handler (req ent)
 134   (nth-value 0 (gethash (request-page req)
 135                         (project-hash-map (entity-project ent)))))
 136
 137 (defun handle-request (handler req ent)
 138   (typecase handler
 139     (null
 140      nil)
 141     ((or symbol function)
 142      (when (and (symbolp handler)
 143                 (not (fboundp handler)))
 144        (cmsg "handler given a symbol without a function ~S" handler)
 145        (return-from handle-request nil))
 146      (let ((next-page (funcall handler req ent)))
 147        (typecase next-page
 148          (string
 149           (redirect-entity next-page ent))
 150          (null
 151           t)
 152          (t
 153           (cmsg "handler should return nil or a string, not ~S" next-page))))
 154      t)
 155     (string
 156      (cmsg "string handler not supported: ~A" handler)
 157      nil)
 158     (t
 159      (cmsg "unknown handler type: ~S" handler)
 160      nil)))
 161
 162 (defun no-url-handler (req)
 163   (print (request-socket req))
 164   (with-ml-page ()
 165     (html-stream
 166      *modlisp-socket*
 167      (:html
 168       (:head
 169        (:title "404 - NotFound"))
 170       (:body
 171        (:h1 "Not Found")
 172        (:p "The request for "
 173            (:b (:write-string (request-uri req)))
 174            " was not found on this server.")
 175        (:hr)
 176        (:div (:i "WOL "
 177                  (:write-string *wol-version*))))))))
 178
 179
 180 (defun request-query (req &key (uri t) (post t))
 181   (append
 182     (when (and uri (request-uri-query req))
 183       (aif (request-query-alist req)
 184          it
 185          (setf (request-query-alist req)
 186            (query-to-alist (request-uri-query req)))))
 187     (when (and post (request-posted-content req))
 188       (query-to-alist (request-posted-content req)))))
 189
 190 (defun websession-variable (ws name)
 191   (when ws
 192     (gethash name (websession-variables ws))))
 193
 194 (defun (setf websession-variable) (value ws name)
 195   (when ws
 196     (setf (gethash name (websession-variables ws)) value)))