;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: wol -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: project.lisp ;;;; Purpose: Project handler for wol library ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: July 2003 ;;;; ;;;; $Id$ ;;;; ;;;; This file and Wol are Copyright (c) 2001-2003 by Kevin M. Rosenberg ;;;; ************************************************************************* (in-package #:wol) (defun wol-project (name &key (project-prefix "/") map index (sessions t) (session-lifetime 18000) (reap-interval 300) server (connector :modlisp) timeout) (unless server (setq server (ecase connector (:modlisp ml:*ml-server*) (:aserve net.aserve:*wserver*)))) (unless server (warn "Can't start project without server") (return-from wol-project nil)) (multiple-value-bind (project found) (gethash name *active-projects*) (unless found (setq project (make-instance 'wol-project)) (setf (gethash name *active-projects*) project)) (setf (project-name project) name) (setf (project-prefix project) project-prefix) (setf (project-map project) map) (setf (project-index project) index) (setf (project-server project) server) (setf (project-connector project) connector) (setf (lifetime (session-master project)) session-lifetime) (setf (cookie-name (session-master project)) name) (let ((hash (make-hash-table :size (length map) :test 'equal))) (dolist (map-item map) (setf (gethash (first map-item) hash) (cdr map-item))) (setf (project-hash-map project) hash)) (ecase connector (:modlisp (setf (ml::processor server) 'wol-ml-processor)) (:aserve (net.aserve:publish-prefix :prefix project-prefix :server server :function 'wol-aserve-processor :timeout timeout))) (if sessions (when (null (sessions (session-master project))) (setf (sessions (session-master project)) (make-hash-table :test 'eq))) (when (sessions (session-master project)) (setf (sessions (session-master project)) nil))) (setq *reap-interval* reap-interval) (when (and sessions (null *reaper-process*)) (setq *reaper-process* (start-reaper))))) (defun wol-ml-processor (command) "Processes an incoming modlisp command" (let* ((req (command->request command :ml-server *ml-server*)) (ent (make-entity-for-request req))) (if ent (dispatch-request req ent) (no-url-handler req ent)))) (defun wol-aserve-processor (as-req as-ent) "Processes an incoming modlisp command" (multiple-value-bind (req ent) (make-request/ent-from-aserve as-req as-ent) (if (entity-project ent) (dispatch-request req ent) (no-url-handler req ent)))) (defun make-request/ent-from-aserve (as-req as-ent) (let* ((req (make-instance 'http-request :method (net.aserve:request-method as-req) ;;:host (net.aserve:request-host as-req) :raw-request (net.aserve::request-raw-request as-req) :raw-uri (puri:intern-uri (net.uri:render-uri (net.aserve:request-raw-uri as-req) nil)) :decoded-uri-path (net.aserve::request-decoded-uri-path as-req) :uri (puri:intern-uri (net.uri:render-uri (net.aserve:request-uri as-req) nil)) :protocol (net.aserve:request-protocol as-req) :protocol-string (net.aserve:request-protocol-string as-req) :posted-content (net.aserve::request-request-body as-req) :socket (net.aserve:request-socket as-req) :headers (net.aserve::request-headers as-req) :aserve-server net.aserve:*wserver* :aserve-request as-req)) (project (find-project-for-request req)) (ent (make-instance 'entity :project project :aserve-entity as-ent))) (values req ent))) (defun command->request (command &key ml-server) "Convert a cl-modlisp command into a wol request" (let ((req (make-instance 'http-request :host (header-value command :host) :raw-request (header-value command :url) :raw-uri (puri:intern-uri (header-value command :url)) :uri (puri:intern-uri (command->uri command)) :protocol (ensure-keyword (header-value command :server-protocol)) :protocol-string (header-value command :server-protocol) :method (ensure-keyword (header-value command :method)) :posted-content (header-value command :posted-content) :headers command :socket *modlisp-socket* :ml-server ml-server))) (awhen (request-raw-uri req) (setf (request-decoded-uri-path req) (puri:uri-path it))) req)) (defun header-slot-value (req slot) (header-value (request-headers req) slot)) (defun command->uri (command) (format nil "http://~A:~D~A" (header-value command :host) (header-value command :server-ip-port) (header-value command :url))) (defun is-index-request (req ent) (string= (request-decoded-uri-path req) (project-prefix (entity-project ent)))) (defun set-cookie (req ent) (let ((session (websession-from-req req))) (when (and session (websession-key session) (not (eq :url (websession-method session)))) (let ((proj (entity-project ent))) (ecase (project-connector proj) (:aserve (net.aserve:set-cookie-header (aserve-request req) :name (project-name (entity-project ent)) :expires :never :secure nil :domain ".kpe.io" :value (websession-key (websession-from-req req)) :path "/")) (:modlisp ;; fixme )))))) (defun redirect-entity (page req ent &optional plist) (let ((proj (entity-project ent)) (url (render-uri (copy-uri (request-uri req) :path (make-wol-url page req ent plist)) nil))) (ecase (project-connector proj) (:aserve (net.aserve:with-http-response ((aserve-request req) (entity-aserve-entity ent) :response net.aserve:*response-temporary-redirect*) (set-cookie req ent) (net.aserve:with-http-body ((aserve-request req) (entity-aserve-entity ent) :headers `((:location . ,url)))))) (:modlisp (redirect-to-location url))))) (defun dispatch-request (req ent) (setq *req* req) (setq *ent* ent) (let ((proj (entity-project ent))) (if (is-index-request req ent) (redirect-entity (project-index proj) req ent) (progn (compute-uris req ent) (dispatch-to-handler req ent))))) (defun make-entity (&key project) (make-instance 'entity :project project)) (defun make-entity-for-request (req) (awhen (find-project-for-request req) (make-entity :project it))) (defun find-project-for-request (req) (maphash (lambda (name project) (declare (ignore name)) (when (and (eq (project-server project) (or (request-aserve-server req) (request-ml-server req))) (request-matches-prefix req (project-prefix project))) (return-from find-project-for-request project))) *active-projects*)) (defun request-matches-prefix (req prefix) "Returns project if request matches project" (string-starts-with prefix (request-decoded-uri-path req))) (defun dispatch-to-handler (req ent) (let ((handlers (request-find-handlers req ent)) (*wol-stream* (request-socket req))) (if handlers (handle-request handlers req ent) (no-url-handler req ent)))) (defun request-find-handlers (req ent) (nth-value 0 (gethash (request-page req) (project-hash-map (entity-project ent))))) (defun handle-request (handlers req ent) (typecase handlers (null (setf (entity-generators ent) nil) nil) (list (let ((next-handler (first handlers))) (setf (entity-generators ent) (cdr handlers)) (when (and (symbolp next-handler) (not (fboundp next-handler))) (cmsg "handler given a symbol without a function ~S" next-handler) (return-from handle-request nil)) (let ((next-page (funcall next-handler req ent))) (typecase next-page (string (setf (entity-generators ent) nil) (redirect-entity next-page req ent)) (cons (setf (entity-generators ent) nil) (redirect-entity (car next-page) req ent (cadr next-page))) (keyword (if (eq :continue next-page) (handle-request (cdr handlers) req ent) (add-log-entry "Invalid return keyword ~S" next-page))) (null t) (t (cmsg "handler should return nil or a string, not ~S" next-page)))) t)) (string (cmsg "string handler not supported: ~A" handler) nil) (t (cmsg "unknown handler type: ~S" handler) nil))) (defun wol-version-string () (format nil "~{~D~^.~}" *wol-version*)) (defun alist-key->keyword (alist) (loop for a in alist collect (cons (kmrcl:ensure-keyword (car a)) (cdr a)))) (defun request-query (req &key (uri t) (post t)) (aif (aserve-request req) (alist-key->keyword (net.aserve:request-query it :uri uri :post post)) (let ((desired (cons uri post))) (if (equal desired (request-desired-query req)) ;; Same desired as cached (request-query-alist req) (progn (setf (request-desired-query req) desired) (setf (request-query-alist req) (append (when (and uri (request-uri-query req)) (query-to-alist (request-uri-query req))) (when (and post (request-posted-content req)) (query-to-alist (request-posted-content req)))))))))) (defun request-query-value (key req &key (uri t) (post t)) (aif (aserve-request req) (net.aserve:request-query-value (string key) it :uri uri :post post) (cdr (assoc key (request-query req :uri uri :post post) :test 'equal)))) (defun websession-variable (ws name) (when ws (gethash name (websession-variables ws)))) (defun (setf websession-variable) (value ws name) (when ws (setf (gethash name (websession-variables ws)) value))) (defmacro with-wol-page ((req ent &key (format :html) (precompute t) headers (response-code 200) timeout) &body body) `(if (request-aserve-server ,req) (net.aserve:with-http-response ((aserve-request ,req) (entity-aserve-entity ,ent) :content-type (ml::format->string ,format) :timeout ,timeout :response (case ,response-code (302 net.aserve::*response-moved-permanently*) (307 net.aserve::*response-temporary-redirect*) (404 net.aserve::*response-not-found*) (otherwise net.aserve::*response-ok*))) (set-cookie ,req ,ent) (net.aserve:with-http-body ((aserve-request ,req) (entity-aserve-entity ,ent) :headers ,headers) (let ((*html-stream* net.html.generator:*html-stream*)) ,@body))) (%with-wol-page (,req ,ent :format ,format :precompute ,precompute :headers ,headers :response-string (case ,response-code (302 "302 Moved Permanently") (307 "307 Temporary Redirect") (404 "404 Not Found") (otherwise "200 OK"))) ,@body))) (defmacro %with-wol-page ((req ent &key (format :html) (precompute t) headers (response-string "200 OK")) &body body) (declare (ignore req ent)) (let ((fmt (gensym "FMT-")) (precomp (gensym "PRE-")) (result (gensym "RES-")) (outstr (gensym "STR-")) (stream (gensym "STRM-")) (hdr (gensym "HDR-"))) `(let ((,fmt ,format) (,precomp ,precompute) ,result ,outstr ,stream) (declare (ignorable ,stream)) (write-header-line "Status" ,response-string) (write-header-line "Content-Type" (ml::format->string ,fmt)) (dolist (,hdr ,headers) (write-header-line (car ,hdr) (cdr ,hdr))) (unless ,precomp (write-string "end" *wol-stream*) (write-char #\NewLine *wol-stream*)) (setq ,outstr (with-output-to-string (,stream) (let ((*html-stream* (if ,precomp ,stream *wol-stream*)) (*wol-stream* (if ,precomp ,stream *wol-stream*))) (setq ,result (progn ,@body))))) (cond (,precomp (write-header-line "Content-Length" (write-to-string (length ,outstr))) (write-header-line "Keep-Socket" "1") (write-header-line "Connection" "Keep-Alive") (write-string "end" *wol-stream*) (write-char #\NewLine *wol-stream*) (write-string ,outstr *wol-stream*) (finish-output *wol-stream*) (setq *close-modlisp-socket* nil)) (t (finish-output *wol-stream*) (setq *close-modlisp-socket* t))) ,result))) (defun no-url-handler (req ent) (with-wol-page (req ent :response-code 404) (html (:html (:head (:title "404 - NotFound")) (:body (:h1 "Not Found") (:p "The request for " (:b (:write-string (render-uri (request-uri req) nil))) " was not found on this server.") (:hr) (:div (:i "WOL " (:write-string (wol-version-string)))))))))