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