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