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.1 2003/07/16 16:02:21 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 dispatch-request (req)
  94   (let ((ent (find-entity-for-request req)))
  95     (when ent
  96       (let ((proj (entity-project ent)))
  97         (if (is-index-request req ent)
  98             (progn
  99               (redirect-to-location
 100                (format nil "~A~A"
 101                        (project-prefix proj)
 102                        (project-index proj)))
 103               t)
 104           (progn
 105             (request-decompile-uri req ent)
 106             (compute-session req ent)
 107             (dispatch-entity req ent))))
 108       ent)))
 109
 110 (defun make-entity (&key project)
 111   (make-instance 'entity :project project))
 112
 113 (defun find-entity-for-request (req)
 114   (maphash (lambda (name project)
 115              (declare (ignore name))
 116              (when (request-matches-prefix req (project-prefix project))
 117                (return-from find-entity-for-request
 118                  (make-entity :project project))))
 119            *active-projects*))
 120
 121 (defun request-matches-prefix (req prefix)
 122   "Returns project if request matches project"
 123   (string-starts-with prefix (request-raw-uri req)))
 124
 125
 126 (defun dispatch-entity (req ent)
 127   (let ((handler (request-find-handler req ent)))
 128     (if handler
 129         (handle-request handler req ent)
 130       (no-url-handler req))))
 131
 132 (defun request-find-handler (req ent)
 133   (nth-value 0 (gethash (request-page req)
 134                         (project-hash-map (entity-project ent)))))
 135
 136 (defun action-redirect (page req ent)
 137   (cmsg "redirect to ~A" page))
 138
 139 (defun handle-request (handler req ent)
 140   (typecase handler
 141     (null
 142      nil)
 143     ((or symbol function)
 144      (when (and (symbolp handler)
 145                 (not (fboundp handler)))
 146        (cmsg "handler given a symbol without a function ~S" handler)
 147        (return-from handle-request nil))
 148      (let ((res (funcall handler req ent)))
 149        (typecase res
 150          (string
 151           (action-redirect res req ent))
 152          (null
 153           t)
 154          (t
 155           (cmsg "handler should return nil or a string"))))
 156      t)
 157     (string
 158      (cmsg "string handler not supported: ~A" handler)
 159      nil)
 160     (t
 161      (cmsg "unknown handler type: ~S" handler)
 162      nil)))
 163
 164 (defun no-url-handler (req)
 165   (print (request-socket req))
 166   (with-ml-page ()
 167     (html-stream
 168      *modlisp-socket*
 169      (:html
 170       (:head
 171        (:title "404 - NotFound"))
 172       (:body
 173        (:h1 "Not Found")
 174        (:p "The request for "
 175            (:b (:write-string (request-uri req)))
 176            " was not found on this server.")
 177        (:hr)
 178        (:div (:i "WOL "
 179                  (:write-string *wol-version*))))))))
 180
 181
 182 (defun request-query (req &key (uri t) (post t))
 183   (append
 184     (when (and uri (request-uri-query req))
 185       (aif (request-query-alist req)
 186          it
 187          (setf (request-query-alist req)
 188            (query-to-alist (request-uri-query req)))))
 189     (when (and post (request-posted-content req))
 190       (query-to-alist (request-posted-content req)))))
 191
 192 (defun websession-variable (ws name)
 193   (when ws
 194     (gethash name (websession-variables ws))))
 195
 196 (defun (setf websession-variable) (value ws name)
 197   (when ws
 198     (setf (gethash name (websession-variables ws)) value)))