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.12 2003/08/10 07:38:37 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 stop-wol-project (name)
  70   (remhash name *active-projects*))
  71
  72 (defun wol-ml-processor (command)
  73   "Processes an incoming modlisp command"
  74   (let* ((req (command->request command
  75                                 :ml-server *ml-server*))
  76          (ent (make-entity-for-request req)))
  77     (if ent
  78         (dispatch-request req ent)
  79         (no-url-handler req ent))))
  80
  81
  82 (defun wol-aserve-processor (as-req as-ent)
  83   "Processes an incoming modlisp command"
  84   (multiple-value-bind (req ent) (make-request/ent-from-aserve as-req as-ent)
  85     (if (entity-project ent)
  86         (dispatch-request req ent)
  87       (no-url-handler req ent))))
  88
  89
  90 (defun make-request/ent-from-aserve (as-req as-ent)
  91   (let* ((req (make-instance
  92                'http-request
  93                :method (net.aserve:request-method as-req)
  94                ;;:host (net.aserve:request-host as-req)
  95                :raw-request (net.aserve::request-raw-request as-req)
  96                :raw-uri (puri:intern-uri
  97                          (net.uri:render-uri
  98                          (net.aserve:request-raw-uri as-req) nil))
  99                :decoded-uri-path
 100                (net.aserve::request-decoded-uri-path as-req)
 101                :uri (puri:intern-uri
 102                      (net.uri:render-uri
 103                      (net.aserve:request-uri as-req) nil))
 104                :protocol (net.aserve:request-protocol as-req)
 105                :protocol-string
 106                (net.aserve:request-protocol-string as-req)
 107                :posted-content (net.aserve::request-request-body as-req)
 108                :socket (net.aserve:request-socket as-req)
 109                :headers (net.aserve::request-headers as-req)
 110                :aserve-server net.aserve:*wserver*
 111                :aserve-request as-req))
 112          (project (find-project-for-request req))
 113          (ent (make-instance 'entity :project project
 114                              :aserve-entity as-ent)))
 115     (values req ent)))
 116
 117
 118 (defun command->request (command &key ml-server)
 119   "Convert a cl-modlisp command into a wol request"
 120   (let ((req
 121          (make-instance 'http-request
 122            :host (header-value command :host)
 123            :raw-request (header-value command :url)
 124            :raw-uri  (puri:intern-uri (header-value command :url))
 125            :uri (puri:intern-uri (command->uri command))
 126            :protocol (ensure-keyword
 127                       (header-value command :server-protocol))
 128            :protocol-string (header-value command :server-protocol)
 129            :method (ensure-keyword (header-value command :method))
 130            :posted-content (header-value command :posted-content)
 131            :headers command
 132            :socket *modlisp-socket*
 133            :ml-server ml-server)))
 134     (awhen (request-raw-uri req)
 135            (setf (request-decoded-uri-path req) (puri:uri-path it)))
 136     req))
 137
 138 (defun header-slot-value (req slot)
 139   (header-value (request-headers req) slot))
 140
 141 (defun command->uri (command)
 142   (format nil "http://~A:~D~A"
 143           (header-value command :host)
 144           (header-value command :server-ip-port)
 145           (header-value command :url)))
 146
 147 (defun is-index-request (req ent)
 148   (string= (request-decoded-uri-path req)
 149            (project-prefix (entity-project ent))))
 150
 151 (defun set-cookie (req ent)
 152   (let ((session (websession-from-req req)))
 153     (when (and session (websession-key session)
 154                (not (eq :url (websession-method session))))
 155       (let ((proj (entity-project ent)))
 156         (ecase (project-connector proj)
 157           (:aserve
 158            (net.aserve:set-cookie-header (aserve-request req)
 159                                          :name (project-name
 160                                                 (entity-project ent))
 161                                          :expires :never
 162                                          :secure nil
 163                                          :domain ".b9.com"
 164                                          :value (websession-key
 165                                                  (websession-from-req req))
 166                                          :path "/"))
 167           (:modlisp
 168            ;; fixme
 169            ))))))
 170
 171
 172 (defun redirect-entity (page req ent &optional plist)
 173   (let ((proj (entity-project ent))
 174         (url (render-uri
 175               (copy-uri (request-uri req)
 176                         :path (make-wol-url page req ent plist))
 177               nil)))
 178     (ecase (project-connector proj)
 179       (:aserve
 180        (net.aserve:with-http-response
 181            ((aserve-request req)
 182             (entity-aserve-entity ent)
 183             :response net.aserve:*response-temporary-redirect*)
 184          (set-cookie req ent)
 185          (net.aserve:with-http-body
 186              ((aserve-request req)
 187               (entity-aserve-entity ent)
 188               :headers `((:location . ,url))))))
 189       (:modlisp
 190        (redirect-to-location url)))))
 191
 192 (defun dispatch-request (req ent)
 193   (setq *req* req)
 194   (setq *ent* ent)
 195   (let ((proj (entity-project ent)))
 196     (if (is-index-request req ent)
 197         (redirect-entity (project-index proj) req ent)
 198         (progn
 199           (compute-uris req ent)
 200           (dispatch-to-handler req ent)))))
 201
 202 (defun make-entity (&key project)
 203   (make-instance 'entity :project project))
 204
 205 (defun make-entity-for-request (req)
 206   (awhen (find-project-for-request req)
 207          (make-entity :project it)))
 208
 209 (defun find-project-for-request (req)
 210   (maphash (lambda (name project)
 211              (declare (ignore name))
 212              (when (and (eq (project-server project)
 213                             (or (request-aserve-server req)
 214                                 (request-ml-server req)))
 215                         (request-matches-prefix
 216                          req (project-prefix project)))
 217                (return-from find-project-for-request project)))
 218            *active-projects*))
 219
 220 (defun request-matches-prefix (req prefix)
 221   "Returns project if request matches project"
 222   (string-starts-with prefix (request-decoded-uri-path req)))
 223
 224
 225 (defun dispatch-to-handler (req ent)
 226   (let ((handler (request-find-handler req ent))
 227         (*wol-stream* (request-socket req)))
 228     (if handler
 229         (handle-request handler req ent)
 230       (no-url-handler req ent))))
 231
 232 (defun request-find-handler (req ent)
 233   (nth-value 0 (gethash (request-page req)
 234                         (project-hash-map (entity-project ent)))))
 235
 236 (defun handle-request (handler req ent)
 237   (typecase handler
 238     (null
 239      nil)
 240     ((or symbol function)
 241      (when (and (symbolp handler)
 242                 (not (fboundp handler)))
 243        (cmsg "handler given a symbol without a function ~S" handler)
 244        (return-from handle-request nil))
 245      (let ((next-page (funcall handler req ent)))
 246        (typecase next-page
 247          (string
 248           (redirect-entity next-page req ent))
 249          (cons
 250           (redirect-entity (car next-page) req ent (cadr next-page)))
 251          (null
 252           t)
 253          (t
 254           (cmsg "handler should return nil or a string, not ~S" next-page))))
 255      t)
 256     (string
 257      (cmsg "string handler not supported: ~A" handler)
 258      nil)
 259     (t
 260      (cmsg "unknown handler type: ~S" handler)
 261      nil)))
 262
 263
 264
 265 (defun wol-version-string ()
 266   (format nil "~{~D~^.~}" *wol-version*))
 267
 268 (defun alist-key->keyword (alist)
 269   (loop for a in alist
 270       collect (cons (kmrcl:ensure-keyword (car a)) (cdr a))))
 271
 272 (defun request-query (req &key (uri t) (post t))
 273   (aif (aserve-request req)
 274        (alist-key->keyword
 275         (net.aserve:request-query it :uri uri :post post))
 276     (let ((desired (cons uri post)))
 277       (if (equal desired (request-desired-query req))
 278           ;; Same desired as cached
 279           (request-query-alist req)
 280         (progn
 281           (setf (request-desired-query req) desired)
 282           (setf (request-query-alist req)
 283             (append
 284              (when (and uri (request-uri-query req))
 285                (query-to-alist (request-uri-query req)))
 286              (when (and post (request-posted-content req))
 287                (query-to-alist (request-posted-content req))))))))))
 288
 289 (defun request-query-value (key req &key (uri t) (post t))
 290   (aif (aserve-request req)
 291        (net.aserve:request-query-value (string key) it :uri uri :post post)
 292        (cdr (assoc key (request-query req :uri uri :post post)
 293                    :test 'equal))))
 294
 295 (defun websession-variable (ws name)
 296   (when ws
 297     (gethash name (websession-variables ws))))
 298
 299 (defun (setf websession-variable) (value ws name)
 300   (when ws
 301     (setf (gethash name (websession-variables ws)) value)))
 302
 303
 304 (defmacro with-wol-page ((req ent
 305                           &key (format :html) (precompute t) headers
 306                                (response-code 200))
 307                          &body body)
 308   `(if (request-aserve-server ,req)
 309       (net.aserve:with-http-response
 310           ((aserve-request ,req)
 311            (entity-aserve-entity ,ent)
 312            :content-type (ml::format-string ,format)
 313            :response
 314            (case ,response-code
 315              (302 net.aserve::*response-moved-permanently*)
 316              (307 net.aserve::*response-temporary-redirect*)
 317              (404 net.aserve::*response-not-found*)
 318              (otherwise net.aserve::*response-ok*)))
 319         (set-cookie ,req ,ent)
 320           (net.aserve:with-http-body
 321               ((aserve-request ,req)
 322                (entity-aserve-entity ,ent)
 323                :headers ,headers)
 324             (let ((*html-stream* net.html.generator:*html-stream*))
 325               ,@body)))
 326      (%with-wol-page (,req ,ent :format ,format :precompute ,precompute
 327                            :headers ,headers
 328                            :response-string
 329                            (case ,response-code
 330                              (302 "302 Moved Permanently")
 331                              (307 "307 Temporary Redirect")
 332                              (404 "404 Not Found")
 333                               (otherwise "200 OK")))
 334                      ,@body)))
 335
 336
 337 (defmacro %with-wol-page ((req ent
 338                            &key (format :html) (precompute t) headers
 339                                 (response-string "200 OK"))
 340                          &body body)
 341   (declare (ignore req ent))
 342   (let ((fmt (gensym "FMT-"))
 343         (precomp (gensym "PRE-"))
 344         (result (gensym "RES-"))
 345         (outstr (gensym "STR-"))
 346         (stream (gensym "STRM-"))
 347         (hdr (gensym "HDR-")))
 348     `(let ((,fmt ,format)
 349            (,precomp ,precompute)
 350            ,result ,outstr ,stream)
 351        (declare (ignorable ,stream))
 352        (write-header-line "Status" ,response-string)
 353        (write-header-line "Content-Type" (ml::format-string ,fmt))
 354        (dolist (,hdr ,headers)
 355          (write-header-line (car ,hdr) (cdr ,hdr)))
 356        (unless ,precomp
 357          (write-string "end" *wol-stream*)
 358          (write-char #\NewLine *wol-stream*))
 359        (setq ,outstr
 360          (with-output-to-string (,stream)
 361            (let ((*html-stream* (if ,precomp
 362                                    ,stream
 363                                    *wol-stream*))
 364                  (*wol-stream* (if ,precomp
 365                                    ,stream
 366                                    *wol-stream*)))
 367              (setq ,result (progn ,@body)))))
 368        (cond
 369         (,precomp
 370          (write-header-line "Content-Length"
 371                             (write-to-string (length ,outstr)))
 372          (write-header-line "Keep-Socket" "1")
 373          (write-header-line "Connection" "Keep-Alive")
 374          (write-string "end" *wol-stream*)
 375          (write-char #\NewLine *wol-stream*)
 376          (write-string ,outstr *wol-stream*)
 377          (finish-output *wol-stream*)
 378          (setq *close-modlisp-socket* nil))
 379         (t
 380          (finish-output *wol-stream*)
 381          (setq *close-modlisp-socket* t)))
 382        ,result)))
 383
 384
 385 (defun no-url-handler (req ent)
 386   (with-wol-page (req ent :response-code 404)
 387     (html
 388      (:html
 389       (:head
 390        (:title "404 - NotFound"))
 391       (:body
 392        (:h1 "Not Found")
 393        (:p "The request for "
 394            (:b (:write-string (render-uri (request-uri req) nil)))
 395            " was not found on this server.")
 396        (:hr)
 397        (:div (:i "WOL "
 398                  (:write-string (wol-version-string)))))))))