;;; -*- mode: Lisp; Syntax: Common-Lisp; -*- ;;; ;;; Copyright (c) 2009 by the authors. ;;; ;;; See LICENCE for details. (in-package :hu.dwim.web-server) ;;;;;; ;;; request (def method close-request ((request http-request)) (map-request-parameters (lambda (name value) (declare (ignore name)) (when (typep value 'rfc2388-binary:mime-part) (delete-file (rfc2388-binary:content value)))) request) (values)) (def function accepts-encoding? (encoding-name) (not (null (assoc encoding-name (accept-encodings-of *request*) :test #'string=)))) (def method accept-encodings-of :around ((request http-request)) (if (slot-boundp request 'accept-encodings) (call-next-method) (setf (accept-encodings-of request) (aprog1 (parse-accept-header-value (or (header-value request +header/accept-encoding+) "")) (http.dribble "Parsed the accept-encoding field for the request: ~A" it))))) (def method cookies-of :around ((request http-request)) (if (slot-boundp request 'cookies) (call-next-method) (setf (cookies-of request) ;; if we called SAFE-PARSE-COOKIES here, then cookies that don't match the domain restrinctions were dropped. ;; instead we parse all cookies and let the users control what they will accept. (aprog1 (rfc2109:parse-cookies (header-value request "Cookie")) (http.dribble "Parsed the cookies for the request: ~A" it))))) (def (function e) parameter-value (name &optional default) (bind (((:values value found?) (request-parameter-value *request* name))) (values (if found? value default) found?))) (def (function e) map-parameters (visitor) (map-request-parameters visitor *request*)) (def (macro e) do-parameters ((name value) &body body) `(map-request-parameters (lambda (,name ,value) ,@body) *request*)) (def (function e) request-parameter-value (request name &optional default) (bind ((entry (assoc name (query-parameters-of request) :test #'string=)) (value (cdr entry))) (if entry (when (equal value "") (setf value nil)) (setf value default)) (values value (not (null entry))))) (def (function e) map-request-parameters (visitor request) (bind ((result (list))) (dolist ((name . value) (query-parameters-of request)) (push (funcall visitor name value) result)) (nreverse result))) ;;;;;; ;;; response (def (class* e) http-response (http-message response) ((headers-are-sent #f :type boolean) (external-format +default-external-format+ :type external-format :documentation "May or may not be used by some higher level functionalities"))) (def method close-response ((self http-response)) (values)) (def constructor http-response (setf (header-value -self- +header/status+) +http-ok+) (setf (cookies-of -self-) (list))) (def method encoding-name-of ((self response)) (aif (external-format-of self) (encoding-name-of it) (error "No external format for response ~A" self))) (def (function e) disallow-response-caching (response) "Sets the appropiate response headers that will instruct the clients not to cache this response." (disallow-response-caching-in-header-alist (headers-of response)) response) ;;;;;; ;;; primitive-response (def method send-headers ((response primitive-http-response)) (http.debug "Sending headers of ~A" response) (send-http-headers (headers-of response) (cookies-of response))) (def method send-response :around ((response primitive-http-response)) (store-response response) (call-next-method) ;; KLUDGE reconsider this. do we really need all this fooling around with dynamic external formats? #+nil (flet ((set-external-format (stream external-format) (etypecase stream (iolib.sockets:stream-socket (setf (iolib:external-format-of stream) external-format)) (flexi-streams:flexi-stream (setf (flexi-streams:flexi-stream-external-format stream) (if (typep external-format 'flexi-streams::external-format) external-format (flexi-streams:make-external-format external-format)))))) (get-external-format (stream) (etypecase stream (iolib.sockets:stream-socket (iolib:external-format-of stream)) (flexi-streams:flexi-stream (flexi-streams:flexi-stream-external-format stream))))) (bind ((client-stream (client-stream-of *request*)) (new-external-format (external-format-of response)) (original-external-format (get-external-format client-stream))) (http.debug "Sending primitive response ~A, new external-format ~A, original external-format ~A" response new-external-format original-external-format) (if new-external-format (unwind-protect (progn (set-external-format client-stream new-external-format) (call-next-method)) (set-external-format client-stream original-external-format)) (call-next-method))))) (def method send-response ((response primitive-http-response)) (assert (not (headers-are-sent-p response)) () "The headers of ~A have already been sent, this is a program error." response) (setf (headers-are-sent-p response) #t) (send-headers response)) ;;;;;; ;;; Cookies (def (macro e) do-cookies ((cookie message) &body forms) `(dolist (,cookie (cookies-of ,message)) ,@forms)) (def function find-cookies (cookie &key accepted-domains otherwise) (find-request-cookies *request* cookie :accepted-domains accepted-domains :otherwise otherwise)) (def function find-request-cookies (request cookie &key accepted-domains (otherwise '())) (setf accepted-domains (ensure-list accepted-domains)) (or (bind ((cookie-name (cond ((stringp cookie) cookie) ((rfc2109:cookie-p cookie) (rfc2109:cookie-name cookie)) (t (error "FIND-COOKIE only supports string and rfc2109:cookie struct as cookie name specifier")))) (result (list))) (do-cookies (candidate request) (when (and (string= cookie-name (rfc2109:cookie-name candidate)) (bind ((candidate-domain (rfc2109:cookie-domain candidate))) ;; normally request cookies should not have a domain parameter, but... (or (null accepted-domains) (null candidate-domain) (some (lambda (accepted-domain) (ends-with-subseq accepted-domain candidate-domain)) accepted-domains)))) (push candidate result))) (nreverse result)) (handle-otherwise/value otherwise))) (def (function e) cookie-value (cookie &key domain otherwise) "Return the uri-unescaped cookie value from *REQUEST* or OTHERWISE if not found." (request-cookie-value *request* cookie :domain domain :otherwise otherwise)) (def (function e) request-cookie-value (request cookie &key domain (otherwise nil)) "Return the uri-unescaped cookie value from REQUEST or OTHERWISE if not found." (aif (find-request-cookies request cookie :accepted-domains (ensure-list domain)) ;; we take the first one because cookies are in such an order that the one with the most specific path is at the head of the list ;; (this ordering does NOT apply to domains, and ff sends them in random order if the only difference is the domain! baaaaah... see comments at: http://www.nczonline.net/blog/2009/05/05/http-cookies-explained/ because of this the session id cookie of foo.com and dev.foo.com cannot be separated using a shared web server process) ;; normally we want the most specific one to be returned, otherwise use the more generic FIND-REQUEST-COOKIES call (hu.dwim.uri:percent-encoding/decode (rfc2109:cookie-value (first it))) (handle-otherwise/value otherwise))) (def (function e) add-cookie (cookie &optional (response *response*)) "Add cookie to the current response." (assert (rfc2109:cookie-p cookie)) (push cookie (cookies-of response))) #+nil ;; TODO (def method remote-address :around ((message http-message)) (declare (optimize speed)) (let ((physical-remote-address (call-next-method))) (if (and physical-remote-address (or (inet-address-private-p physical-remote-address) (local-address-p physical-remote-address))) ;; check if we are in a proxy setup and extract the real remote address if provided. ;; but do so only if the physical remote address is coming from a machine from the local net. ;; please note that X-Forwarded-For is not a realiable source for ip addresses! ;; that's why we only process them when the physical remote address is on the local net (let ((ip-as-string (header-value message "X-Forwarded-For"))) (when ip-as-string (let* ((real-remote-address (first (cl-ppcre:split "," ip-as-string :sharedp t))) (pieces (cl-ppcre:split "\\." real-remote-address :sharedp t))) (declare (type list pieces)) (if (= (length pieces) 4) (iter (with result = (make-array 4 :element-type '(unsigned-byte 8))) (for idx :from 0 :below 4) (for ip-address-part = (parse-integer (pop pieces))) (assert (<= 0 ip-address-part 255)) (setf (aref result idx) ip-address-part) (finally (return result))) (progn (http.info "Returning NIL instead of an invalid ip address: ~S" ip-as-string) nil))))) physical-remote-address))) ;;;;;; ;;; Response with html stream (def (class* e) response-with-html-stream (response) ((html-stream nil))) (def method html-stream-of :around ((self response-with-html-stream)) (bind ((result (call-next-method))) (or result (setf (html-stream-of self) (make-in-memory-output-stream :external-format (external-format-of self)))))) (def method send-response ((response response-with-html-stream)) (bind ((content nil)) (awhen (slot-value response 'html-stream) (http.dribble "Converting html stream of ~A" response) (setf content (babel-streams:get-output-stream-sequence it)) (assert (null (header-value response +header/content-length+))) (http.dribble "Setting Content-Length header of ~A" response) (setf (header-value response +header/content-length+) (integer-to-string (length content)))) (call-next-method) (when (and content (not (string= "HEAD" (http-method-of *request*)))) (http.dribble "Sending ~S (~D bytes) as body" content (length content)) (write-sequence content (client-stream-of response))))) ;;;;;; ;;; Functional response ;; TODO review the naming in this section... (def (class* e) functional-response (primitive-http-response) ((thunk :type (or symbol function)) (cleanup-thunk nil :type (or symbol function))) (:documentation "A primitive-response that sends the headers and then calls its thunk. Keep in mind that it will not do any buffering, so it uses up a worker thread while sending the response through the network.")) (def method send-response ((response functional-response)) (call-next-method) (funcall (thunk-of response))) (def (class* e) raw-functional-response (functional-response) () (:documentation "A response that does nothing else than calling its thunk.")) (def method send-response ((response raw-functional-response)) ;; override everything, including the sending of the headers... (funcall (thunk-of response))) (def method close-response :after ((self functional-response)) (awhen (cleanup-thunk-of self) (funcall it))) (def (function e) make-functional-response* (thunk &key headers cookies (raw #f) cleanup-thunk) (if raw (make-instance 'raw-functional-response :thunk thunk :cleanup-thunk cleanup-thunk :headers headers :cookies cookies) (make-instance 'functional-response :thunk thunk :cleanup-thunk cleanup-thunk :headers headers :cookies cookies))) (def function expand-make-functional-response (raw headers-as-plist cookie-list body) (with-unique-names (response) `(bind ((,response (make-functional-response* (named-lambda functional-response/body () ,@body) :raw ,raw))) (store-response ,response) ;; this way *response* is bound while evaluating the following (setf (headers-of ,response) (list ,@(iter (for (name value) :on headers-as-plist :by #'cddr) (collect `(cons ,name ,value))))) (setf (cookies-of ,response) (list ,@cookie-list)) ,response))) (def (macro e) make-functional-response ((&optional headers-as-plist cookie-list) &body body) (expand-make-functional-response #f headers-as-plist cookie-list body)) (def (macro e) make-raw-functional-response (() &body body) (expand-make-functional-response #t nil nil body)) (def (macro e) make-functional-html-response ((&optional headers-as-plist cookie-list) &body body) `(make-functional-response ((+header/content-type+ (content-type-for +html-mime-type+ +default-encoding+) ,@headers-as-plist) (,@cookie-list)) (emit-into-xml-stream (client-stream-of *request*) ,@body))) (def (macro e) make-buffered-functional-html-response ((&optional headers-as-plist cookie-list) &body body) (with-unique-names (response) `(bind ((,response (make-byte-vector-response* nil))) (store-response ,response) ;; set a default content type header. do it early, so that it's already set when the body is rendered (setf (header-value ,response +header/content-type+) ,(content-type-for +html-mime-type+ +default-encoding+)) (bind ((buffer (emit-into-xml-stream-buffer (:external-format +default-external-format+) ,@body))) (appendf (headers-of ,response) (list ,@(iter (for (name value) :on headers-as-plist :by #'cddr) (collect `(cons ,name ,value))))) (setf (cookies-of ,response) (list ,@cookie-list)) (setf (body-of ,response) buffer) ,response)))) ;;;;;; ;;; Byte vector response (def (class* e) byte-vector-response (primitive-http-response) ((last-modified-at nil) (body :type (or list vector)))) (def (function e) make-byte-vector-response* (bytes &key headers cookies last-modified-at seconds-until-expires content-type) (bind ((result (make-instance 'byte-vector-response :body bytes :headers headers :cookies cookies :last-modified-at last-modified-at :external-format nil))) (when seconds-until-expires (setf (header-value result +header/expires+) (local-time:to-rfc1123-timestring (local-time:adjust-timestamp (local-time:now) (offset :sec seconds-until-expires))))) (when content-type (setf (header-value result +header/content-type+) content-type)) result)) (def (macro e) make-byte-vector-response ((&optional headers-as-plist cookie-list) &body body) (with-unique-names (response) `(bind ((,response (make-byte-vector-response* nil))) (store-response ,response) ;; this way *response* is bound while evaluating the following (setf (headers-of ,response) (list ,@(iter (for (name value) :on headers-as-plist :by #'cddr) (collect `(cons ,name ,value))))) (setf (cookies-of ,response) (list ,@cookie-list)) (setf (body-of ,response) (babel-streams:with-output-to-sequence (*standard-output* :external-format :utf-8) ,@body)) ,response))) (def method send-response ((response byte-vector-response)) (serve-sequence (body-of response) :compress-content-with (unless (header-value response +header/content-encoding+) (default-response-compression)) :headers (headers-of response) :cookies (cookies-of response) :last-modified-at (last-modified-at-of response))) ;;;;;; ;;; Not found response (def class* not-found-response (primitive-http-response) ()) (def (function e) make-not-found-response () (aprog1 (make-instance 'not-found-response) (setf (header-value it +header/status+) +http-not-found+))) (def method send-response ((self not-found-response)) (emit-http-response/simple-html-document (:status +http-not-found+ :title "Page not found" :headers (headers-of self) :cookies (cookies-of self) :cacheable #f)
" was not found on this server">)) ;;;;;; ;;; Request echo response (def class* request-echo-response (primitive-http-response) () (:documentation "Render back the request details as a simple html page, mostly for debugging purposes.")) (def (function e) make-request-echo-response () (make-instance 'request-echo-response)) (def method send-response ((self request-echo-response)) (emit-http-response ((+header/content-type+ +html-mime-type+)) (render-request *request*))) (def (function e) render-request (request) (emit-html-document (:title "URL echo server")
>)>
|