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.5 2003/07/23 23:08:28 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
  20                     (connector :modlisp))
  21
  22   (unless server
  23     (setq server
  24           (ecase connector
  25             (:modlisp ml:*ml-server*)
  26             (:aserve net.aserve:*wserver*))))
  27
  28   (unless server
  29     (warn "Can't start project without server")
  30     (return-from wol-project nil))
  31
  32   (multiple-value-bind (project found) (gethash name *active-projects*)
  33     (unless found
  34       (setq project (make-instance 'wol-project))
  35       (setf (gethash name *active-projects*) project))
  36
  37     (setf (project-name project) name)
  38     (setf (project-prefix project) project-prefix)
  39     (setf (project-map project) map)
  40     (setf (project-index project) index)
  41     (setf (project-server project) server)
  42     (setf (project-connector project) connector)
  43     (setf (lifetime (session-master project)) session-lifetime)
  44     (setf (cookie-name (session-master project)) name)
  45
  46     (let ((hash (make-hash-table :size (length map) :test 'equal)))
  47       (dolist (map-item map)
  48         (setf (gethash (first map-item) hash) (second map-item)))
  49       (setf (project-hash-map project) hash))
  50
  51     (ecase connector
  52       (:modlisp
  53        (setf (ml::processor server) 'wol-ml-processor))
  54       (:aserve
  55        (net.aserve:publish-prefix :prefix project-prefix
  56                                   :server server
  57                                   :function 'wol-aserve-processor)))
  58
  59   (if sessions
  60         (when (null (sessions (session-master project)))
  61           (setf (sessions (session-master project))
  62             (make-hash-table :test 'eq)))
  63       (when (sessions (session-master project))
  64         (setf (sessions (session-master project)) nil)))
  65
  66     (setq *reap-interval* reap-interval)
  67     (when (and sessions (null *reaper-process*))
  68       (setq *reaper-process* (start-reaper)))))
  69
  70 (defun wol-ml-processor (command)
  71   "Processes an incoming modlisp command"
  72   (let* ((req (command->request command
  73                                 :ml-server *ml-server*))
  74          (ent (make-entity-for-request req)))
  75     (if ent
  76         (dispatch-request req ent)
  77         (no-url-handler req ent))))
  78
  79
  80 (defun wol-aserve-processor (as-req as-ent)
  81   "Processes an incoming modlisp command"
  82   (let* ((req (make-request-from-aserve as-req))
  83          (ent (make-entity-from-aserve req as-ent)))
  84     (dispatch-request req ent)))
  85
  86 (defun make-request-from-aserve (as-req)
  87   (make-instance 'http-request
  88                  :method (net.aserve:request-method as-req)
  89                  ;;:host (net.aserve:request-host as-req)
  90                  :raw-uri (puri:intern-uri
  91                            (net.uri:render-uri
  92                             (net.aserve:request-raw-uri as-req) nil))
  93                  :uri (puri:intern-uri
  94                        (net.uri:render-uri
  95                         (net.aserve:request-uri as-req) nil))
  96                  :protocol (net.aserve:request-protocol as-req)
  97                  :protocol-string
  98                  (net.aserve:request-protocol-string as-req)
  99                  :posted-content (net.aserve::request-request-body as-req)
 100                  :socket (net.aserve:request-socket as-req)
 101                  :aserve-server net.aserve:*wserver*
 102                  :aserve-request as-req))
 103
 104 (defun make-entity-from-aserve (req as-ent)
 105   (make-instance 'entity
 106                  :project (find-project-for-request req)
 107                  :aserve-entity as-ent))
 108
 109
 110 (defun command->request (command &key ml-server)
 111   "Convert a cl-modlisp command into a wol request"
 112   (let ((req
 113          (make-instance 'http-request
 114            :host (header-value command :host)
 115            :raw-uri (puri:intern-uri (header-value command :url))
 116            :uri (puri:intern-uri (command->uri command))
 117            :protocol (ensure-keyword
 118                       (header-value command :server-protocol))
 119            :protocol-string (header-value command :server-protocol)
 120            :method (ensure-keyword (header-value command :method))
 121            :posted-content (header-value command :posted-content)
 122            :headers command
 123            :socket *modlisp-socket*
 124            :ml-server ml-server)))
 125     req))
 126
 127 (defun header-slot-value (req slot)
 128   (header-value (request-headers req) slot))
 129
 130 (defun command->uri (command)
 131   (format nil "http://~A:~D~A"
 132           (header-value command :host)
 133           (awhen (header-value
 134                   command :server-ip-port)
 135                  (parse-integer it))
 136           (header-value command :url)))
 137
 138 (defun is-index-request (req ent)
 139   (string= (puri:uri-path (request-raw-uri req))
 140            (project-prefix (entity-project ent))))
 141
 142 (defun redirect-entity (page ent &optional plist)
 143   (redirect-to-location (apply #'make-wol-url page ent plist)))
 144
 145 (defun dispatch-request (req ent)
 146   (let ((proj (entity-project ent)))
 147     (if (is-index-request req ent)
 148         (redirect-entity (project-index proj) ent)
 149         (progn
 150           (request-decompile-uri req ent)
 151           (compute-session req ent)
 152           (dispatch-to-handler req ent)))))
 153
 154 (defun make-entity (&key project)
 155   (make-instance 'entity :project project))
 156
 157 (defun make-entity-for-request (req)
 158   (awhen (find-project-for-request req)
 159          (make-entity :project it)))
 160
 161 (defun find-project-for-request (req)
 162   (maphash (lambda (name project)
 163              (declare (ignore name))
 164              (when (request-matches-prefix req (project-prefix project))
 165                (return-from find-project-for-request project)))
 166            *active-projects*))
 167
 168 (defun request-matches-prefix (req prefix)
 169   "Returns project if request matches project"
 170   (string-starts-with prefix (puri:uri-path (request-raw-uri req))))
 171
 172
 173 (defun dispatch-to-handler (req ent)
 174   (let ((handler (request-find-handler req ent))
 175         (*wol-stream* (request-socket req)))
 176     (if handler
 177         (handle-request handler req ent)
 178       (no-url-handler req ent))))
 179
 180 (defun request-find-handler (req ent)
 181   (nth-value 0 (gethash (request-page req)
 182                         (project-hash-map (entity-project ent)))))
 183
 184 (defun handle-request (handler req ent)
 185   (typecase handler
 186     (null
 187      nil)
 188     ((or symbol function)
 189      (when (and (symbolp handler)
 190                 (not (fboundp handler)))
 191        (cmsg "handler given a symbol without a function ~S" handler)
 192        (return-from handle-request nil))
 193      (let ((next-page (funcall handler req ent)))
 194        (typecase next-page
 195          (string
 196           (redirect-entity next-page ent))
 197          (cons
 198           (redirect-entity (car next-page) ent (cadr next-page)))
 199          (null
 200           t)
 201          (t
 202           (cmsg "handler should return nil or a string, not ~S" next-page))))
 203      t)
 204     (string
 205      (cmsg "string handler not supported: ~A" handler)
 206      nil)
 207     (t
 208      (cmsg "unknown handler type: ~S" handler)
 209      nil)))
 210
 211
 212
 213 (defun wol-version-string ()
 214   (format nil "~{~D~^.~}" *wol-version*))
 215
 216 (defun request-query (req &key (uri t) (post t))
 217   (append
 218     (when (and uri (request-uri-query req))
 219       (aif (request-query-alist req)
 220          it
 221          (setf (request-query-alist req)
 222            (query-to-alist (request-uri-query req)))))
 223     (when (and post (request-posted-content req))
 224       (query-to-alist (request-posted-content req)))))
 225
 226 (defun request-query-value (key req &key (uri t) (post t))
 227   (cdr (assoc key (request-query req :uri uri :post post)
 228               :test 'equal)))
 229
 230 (defun websession-variable (ws name)
 231   (when ws
 232     (gethash name (websession-variables ws))))
 233
 234 (defun (setf websession-variable) (value ws name)
 235   (when ws
 236     (setf (gethash name (websession-variables ws)) value)))
 237
 238
 239 (defmacro with-wol-page ((req ent
 240                               &key (format :html) (precompute t) headers)
 241                          &body body)
 242   (let ((fmt (gensym "FMT-"))
 243         (precomp (gensym "PRE-"))
 244         (result (gensym "RES-"))
 245         (outstr (gensym "STR-"))
 246         (stream (gensym "STRM-"))
 247         (hdr (gensym "HDR-")))
 248     `(let ((,fmt ,format)
 249            (,precomp ,precompute)
 250            ,result ,outstr ,stream)
 251        (declare (ignorable ,stream))
 252        (write-header-line "Status" "200 OK")
 253        (write-header-line "Content-Type" (ml::format-string ,fmt))
 254        (dolist (,hdr ,headers)
 255          (write-header-line (car ,hdr) (cdr ,hdr)))
 256        (unless ,precomp
 257          (write-string "end" *wol-stream*)
 258          (write-char #\NewLine *wol-stream*))
 259        (setq ,outstr
 260          (with-output-to-string (,stream)
 261            (let ((*html-stream* (if ,precomp
 262                                    ,stream
 263                                    *wol-stream*))
 264                  (*wol-stream* (if ,precomp
 265                                    ,stream
 266                                    *wol-stream*)))
 267              (setq ,result (progn ,@body)))))
 268        (cond
 269         (,precomp
 270          (write-header-line "Content-Length"
 271                             (write-to-string (length ,outstr)))
 272          (write-header-line "Keep-Socket" "1")
 273          (write-header-line "Connection" "Keep-Alive")
 274          (write-string "end" *wol-stream*)
 275          (write-char #\NewLine *wol-stream*)
 276          (write-string ,outstr *wol-stream*)
 277          (finish-output *wol-stream*)
 278          (setq *close-modlisp-socket* nil))
 279         (t
 280          (finish-output *wol-stream*)
 281          (setq *close-modlisp-socket* t)))
 282        ,result)))
 283
 284
 285 (defun no-url-handler (req ent)
 286   (with-wol-page (req ent)
 287     (html
 288      (:html
 289       (:head
 290        (:title "404 - NotFound"))
 291       (:body
 292        (:h1 "Not Found")
 293        (:p "The request for "
 294            (:b (:write-string (request-uri req)))
 295            " was not found on this server.")
 296        (:hr)
 297        (:div (:i "WOL "
 298                  (:write-string (wol-version-string)))))))))