(in-package :araneida) (defclass handler () ()) (defclass dispatching-handler (handler) ((child-handlers :initform nil :accessor child-handlers))) (defmethod child-handlers ((handler handler)) "Return nil when there are no handlers" (declare (ignore handler)) nil) (define-condition response-sent (condition) ()) ;;; overall request handler (defgeneric handle-request (handler request) (:documentation "Handles authentication, authorization, getting the request response, logging, and signaling if unhandled")) ;;; default method for which calls the following "sub-handlers" (defgeneric handle-request-authentication (handler method request) (:documentation "Returns true if user is who the user says he is, signals an error if not")) (defgeneric handle-request-authorization (handler method request) (:documentation "Returns true if the user is authorized to see the resource, signals an error if not")) ;;; (default method calls request-authorized-p, request-not-authorized) (defgeneric request-authorized-p (handler method request)) (defgeneric request-not-authorized (handler method request) (:documentation "Called by default handle-request-authorization when a request is not authorized Signaling is handled by handle-request-authorization, so this is best used for logging and such")) (defgeneric handle-request-response (handler method request) (:documentation "Send headers and response back send the resource back, or do whever else is appropriate at this stage for the requested method. If -response returns (values NIL foo), we send a 404 and log the foo to a log stream, or to the browser if no log stream is set up")) (defgeneric handle-request-logging (handler method request) (:documentation "Can be used to write stuff to a log file, or some other cleanup action that may take place after the response to the client has gone (i.e. request stream may be closed by now")) (defmethod handle-request ((handler t) request) (etypecase handler (cons (apply (car handler) request (cdr handler))) (function (funcall handler request)) (symbol (funcall handler request)))) (defmethod handle-request ((handler handler) request) (let ((method (request-method request))) (handle-request-authentication handler method request) (handle-request-authorization handler method request) (multiple-value-bind (handled whynot) (handle-request-response handler method request) (handle-request-logging handler method request) (if handled handled (cond ((eql whynot :no-matching-method) (signal 'http-not-found :client-message "No matching method" :message "No matching method")) ((null whynot) (signal 'http-not-found :client-message "Handler declined to handle (returned nil)" :message "Handler declined to handle (returned nil)")) (t (signal 'http-not-found :client-message whynot :message whynot))))))) (defmethod handle-request-authentication ((handler handler) method request ) t) (defmethod handle-request-logging ((handler handler) method request ) t) (defmethod request-authorized-p ((handler handler) method request ) t) (defvar *log-stream* *trace-output*) ;;; we can't send a 40x here, because we don't know if the problem was failed ;;; http auth, missing cookie, blocked ip address, etc. So, realistically, ;;; "it is an error" to override request-authorized-p without also providing ;;; the corresponding request-not-authorized (defmethod request-not-authorized ((handler handler) method request ) (request-send-error request 500)) (defmethod handle-request-authorization ((handler handler) method request) (cond ((request-authorized-p handler method request) t) (t (request-not-authorized handler method request) (signal 'response-sent)))) ;;; dispatching handlers contain other handlers which they (as the ;;; name suggests, really) dispatch requests to again (defun matching-handler (handlers url) "Returns the first handler to match the string URL and the handler's associated discriminator" (declare (type (cons string (cons (or null handler) (cons (or null handler))))) (type string url)) (flet ((matcher (handler-descrip) (destructuring-bind (discrim loose exact) handler-descrip (cond ((and exact (equal url discrim)) (list exact discrim)) ((and loose (and (>= (length url) (length discrim)) (equal (subseq url 0 (length discrim)) discrim))) (list loose discrim)) (t nil))))) (let ((matched (first (remove-if #'null (mapcar #'matcher handlers))))) (values (first matched) (second matched))))) (defmethod handle-request-response ((handler dispatching-handler) method request) (let* ((handled-by (request-handled-by request)) (offset (or (second (first handled-by)) 0)) (urlstring (request-urlstring request)) (rest-of-url (request-unhandled-part request))) (multiple-value-bind (handler handlers-discriminator) (matching-handler (child-handlers handler) rest-of-url) (if handler (let ((new-offset (+ offset (length handlers-discriminator)))) (push (list handler new-offset) (request-handled-by request)) (setf (request-base-url request) (parse-urlstring (subseq urlstring 0 new-offset))) (handle-request handler request)) (values nil :no-matching-method))))) ;;; XXX nasty large amount of ought-to-be-refactorable cut&paste code follows (defgeneric install-handler (parent child discriminator exact-p) (:documentation "Install CHILD as a sub-handler of PARENT. DISCRIMINATOR should be a portion of request urlstring that the sub-handler should be selected for. EXACT-P controls whether CHILD will be selected only for requests that exactly match DISCRIMINATOR or for all requests prefixed with DISCRIMINATOR. Bugs: this docstring is completely incomprehensible")) (defmethod install-handler ((parent dispatching-handler) child discriminator exact-p) (let* ((discriminator (if (typep discriminator 'url) (urlstring discriminator) discriminator)) (existing (assoc discriminator (child-handlers parent) :test #'string=))) (if existing (if exact-p (setf (third existing) child) (setf (second existing) child)) (setf (child-handlers parent) (merge 'list (child-handlers parent) (list (list discriminator (if exact-p nil child) (if exact-p child nil))) #'string> :key #'car)))) (child-handlers parent)) (defgeneric find-handler (parent discriminator exact-p) (:documentation "Find the handler for DISCRIMINATOR, EXACT-P from the list of sub-handlers for PARENT")) (defmethod find-handler ((parent dispatching-handler) discriminator exact-p) (let ((existing (assoc discriminator (child-handlers parent) :test #'string=))) (when existing (if exact-p (third existing) (second existing) )))) (defgeneric uninstall-handler (parent discriminator exact-p) (:documentation "Remove the handler for DISCRIMINATOR, EXACT-P from the list of sub-handlers for PARENT")) (defmethod uninstall-handler ((parent dispatching-handler) discriminator exact-p) (let ((existing (assoc discriminator (child-handlers parent) :test #'string=))) (when existing (if exact-p (setf (third existing) nil) (setf (second existing) nil)) (when (and (null (second existing)) (null (third existing))) (setf (child-handlers parent) (remove existing (child-handlers parent))))) (child-handlers parent))) (defclass root-handler (araneida:dispatching-handler) ()) (defmethod handle-request-response ((handler root-handler) method request) (let* ((url (request-url request)) (url-as-string (urlstring url))) (flet ((hand-off (subhandler offset-length) (push (list subhandler offset-length) (request-handled-by request)) (setf (request-base-url request) (parse-urlstring (subseq (urlstring url) 0 offset-length))) (handle-request subhandler request))) (multiple-value-bind (subhandler subhandlers-discriminator) (matching-handler (child-handlers handler) url-as-string) (if subhandler (hand-off subhandler (length subhandlers-discriminator)) (let ((just-before-the-path (copy-url url))) (setf (url-path just-before-the-path) nil (url-query just-before-the-path) nil (url-fragment just-before-the-path) nil) (let* ((just-before-the-path-as-string (string-right-trim '(#\/) (urlstring just-before-the-path))) (just-the-path-as-string (subseq url-as-string (length just-before-the-path-as-string)))) (multiple-value-bind (subhandler subhandlers-discriminator) (matching-handler (child-handlers handler) just-the-path-as-string) (if subhandler (hand-off subhandler (+ (length just-before-the-path-as-string) (length subhandlers-discriminator))) (let ((without-the-beginning-slash (subseq just-the-path-as-string 1))) (multiple-value-bind (subhandler subhandlers-discriminator) (matching-handler (child-handlers handler) without-the-beginning-slash) (if subhandler (hand-off subhandler (+ (length just-before-the-path-as-string) 1 ; skip over the slash (length subhandlers-discriminator))) (values nil :no-matching-methods))))))))))))) (defun alist-handlers (handler) "Returns an alist of (match . handler) the handlers below handler. nil if it is a non-dispatching handler." (declare (type (or dispatching-handler handler) handler)) (mapcar (lambda (subhandler-descriptor) ; each handler in the child-handlers looks like: ("urlportion" handler handler) ; where there is one handler. If it's in the first position, it's inexact, if it's ; in the second, it's exact (let ((match (first subhandler-descriptor)) (match-handler (or (second subhandler-descriptor) (third subhandler-descriptor)))) (cons match match-handler))) (child-handlers handler)))