;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- ;;; $Header: src/misc.lisp $ ;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package :claw-as) (defconstant +buffer-length+ 8192 "Length of buffers used for internal purposes.") (eval-when (:compile-toplevel :execute :load-toplevel) (defvar *claw-server* nil "The current serving claw-server instance") (defvar *session-manager* nil "The SESSION-MANAGER used by the *claw-server*") (defvar *apache-http-port* 80 "Default apache http port when claw is running in mod_lisp mode, or behind mod_proxy") (defvar *apache-https-port* 443 "Default apache https port when claw is running in mod_lisp mode, or behind mod_proxy") (defvar *claw-default-server-address* nil "Default host address given as default server address for lisplets used on redirections") (defvar *claw-libraries-resources* () "Global variable to hold exposed web resources") (defvar *claw-current-realm* 'claw "The realm under which the request has been sent. A realm is used to group resources under a common 'place', and is used for registered web applications to have different or common sessions for a give user.") (defvar *claw-current-lisplet* nil "The liplet currently serving") (defvar *claw-session* nil "The session bound to the current request") (defvar *http-reason-phrase-map* (make-hash-table) "Used to map numerical return codes to reason phrases.") (defvar *day-names* '("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun") "The three-character names of the seven days of the week - needed for cookie date format.") (defvar *month-names* '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") "The three-character names of the twelve months - needed for cookie date format.") (defvar *root-path* nil "The eventually froxified lisplet path ") (defvar *server-path* nil "The eventually froxified claw server path ") (defmacro def-http-return-code (name value reason-phrase) "Shortcut to define constants for return codes. NAME is a Lisp symbol, VALUE is the numerical value of the return code, and REASON-PHRASE is the phrase \(a string) to be shown in the server's status line." `(eval-when (:compile-toplevel :execute :load-toplevel) (defconstant ,name ,value ,(format nil "HTTP return code \(~A) for '~A'." value reason-phrase)) (setf (gethash ,value *http-reason-phrase-map*) ,reason-phrase))) (defvar *http-reason-phrase-map* (make-hash-table) "Used to map numerical return codes to reason phrases.")) (def-http-return-code +http-continue+ 100 "Continue") (def-http-return-code +http-switching-protocols+ 101 "Switching Protocols") (def-http-return-code +http-ok+ 200 "OK") (def-http-return-code +http-created+ 201 "Created") (def-http-return-code +http-accepted+ 202 "Accepted") (def-http-return-code +http-non-authoritative-information+ 203 "Non-Authoritative Information") (def-http-return-code +http-no-content+ 204 "No Content") (def-http-return-code +http-reset-content+ 205 "Reset Content") (def-http-return-code +http-partial-content+ 206 "Partial Content") (def-http-return-code +http-multi-status+ 207 "Multi-Status") (def-http-return-code +http-multiple-choices+ 300 "Multiple Choices") (def-http-return-code +http-moved-permanently+ 301 "Moved Permanently") (def-http-return-code +http-moved-temporarily+ 302 "Moved Temporarily") (def-http-return-code +http-see-other+ 303 "See Other") (def-http-return-code +http-not-modified+ 304 "Not Modified") (def-http-return-code +http-use-proxy+ 305 "Use Proxy") (def-http-return-code +http-temporary-redirect+ 307 "Temporary Redirect") (def-http-return-code +http-bad-request+ 400 "Bad Request") (def-http-return-code +http-authorization-required+ 401 "Authorization Required") (def-http-return-code +http-payment-required+ 402 "Payment Required") (def-http-return-code +http-forbidden+ 403 "Forbidden") (def-http-return-code +http-not-found+ 404 "Not Found") (def-http-return-code +http-method-not-allowed+ 405 "Method Not Allowed") (def-http-return-code +http-not-acceptable+ 406 "Not Acceptable") (def-http-return-code +http-proxy-authentication-required+ 407 "Proxy Authentication Required") (def-http-return-code +http-request-time-out+ 408 "Request Time-out") (def-http-return-code +http-conflict+ 409 "Conflict") (def-http-return-code +http-gone+ 410 "Gone") (def-http-return-code +http-length-required+ 411 "Length Required") (def-http-return-code +http-precondition-failed+ 412 "Precondition Failed") (def-http-return-code +http-request-entity-too-large+ 413 "Request Entity Too Large") (def-http-return-code +http-request-uri-too-large+ 414 "Request-URI Too Large") (def-http-return-code +http-unsupported-media-type+ 415 "Unsupported Media Type") (def-http-return-code +http-requested-range-not-satisfiable+ 416 "Requested range not satisfiable") (def-http-return-code +http-expectation-failed+ 417 "Expectation Failed") (def-http-return-code +http-failed-dependency+ 424 "Failed Dependency") (def-http-return-code +http-internal-server-error+ 500 "Internal Server Error") (def-http-return-code +http-not-implemented+ 501 "Not Implemented") (def-http-return-code +http-bad-gateway+ 502 "Bad Gateway") (def-http-return-code +http-service-unavailable+ 503 "Service Unavailable") (def-http-return-code +http-gateway-time-out+ 504 "Gateway Time-out") (def-http-return-code +http-version-not-supported+ 505 "Version not supported") (defvar *approved-return-codes* '(#.+http-ok+ #.+http-no-content+ #.+http-multi-status+ #.+http-not-modified+) "A list of return codes the server should not treat as an error - see *HANDLE-HTTP-ERRORS-P*.") ;;-------------------------------------------------------------------------------------------- ;;---------------------------------------- WRAPPERS ----------------------------------------- ;;-------------------------------------------------------------------------------------------- (defun claw-request-method () "Wrapper function around claw-server-REQUEST-METHOD. Returns :GET or POST. respectively." (claw-server-request-method *claw-server*)) (defun claw-script-name () "Wrapper function around claw-server-SCRIPT-NAME. Returns the file name \(or path) component of the URI for request \(before the question mark)," (claw-server-script-name *claw-server*)) (defun claw-request-uri () "Wrapper function around claw-server-REQUEST-URI. Returns the URI for request." (claw-server-request-uri *claw-server*)) (defun claw-query-string () "Wrapper function around claw-server-QUERY-STRING. Returns the query component of the URI for request \(the part behing the question mark)" (claw-server-query-string *claw-server*)) (defun claw-get-parameter (name) "Wrapper function around claw-server-GET-PARAMETER. Returns the value of the GET parameter as a string \(or nil), identified by NAME \(a string too)" (claw-server-get-parameter *claw-server* name)) (defun claw-get-parameters () "Wrapper function around claw-server-GET-PARAMETERS. Returns an alist of all GET parameters." (claw-server-get-parameters *claw-server*)) (defun claw-post-parameter (name) "Wrapper function around claw-server-POST-PARAMETER. Returns the value of the POST parameter as a string \(or nil), identified by NAME \(a string too)" (claw-server-post-parameter *claw-server* name)) (defun claw-post-parameters () "Wrapper function around claw-server-POST-PARAMETERS. Returns an alist of all POST parameters." (claw-server-post-parameters *claw-server*)) (defun claw-parameter (name) "Wrapper function around claw-server-PARAMETER. Returns the value of the GET or POST parameter as a string \(or nil), identified by NAME \(a string too)" (claw-server-parameter *claw-server* name)) (defun claw-header-in (symbol) "Wrapper function around claw-server-HEADER-IN. Returns the incoming header named by the keyword SYMBOL, as a string." (claw-server-header-in *claw-server* symbol)) (defun claw-headers-in () "Wrapper function around claw-server-HEADERS-IN." (claw-server-headers-in *claw-server*)) (defun claw-authorization () "Wrapper function around claw-server-AUTHORIZATION. Returns as two values the user and password \(if any) from the incoming Authorization http header." (claw-server-authorization *claw-server*)) (defun claw-remote-addr () "Wrapper function around claw-server-REMOTE-ADDR. Returns the IP address \(as a string) of the client which sent the request." (claw-server-remote-addr *claw-server*)) (defun claw-remote-port () "Wrapper function around claw-server-REMOTE-PORT. Returns the IP port \(as a number) of the client which sent the request." (claw-server-remote-port *claw-server*)) (defun claw-real-remote-addr () "Wrapper function around claw-server-REAL-REMOTE-ADDR see it for more info." (claw-server-real-remote-addr *claw-server*)) (defun claw-server-addr () "Wrapper function around claw-server-SERVER-ADDR. Returns the IP address \(as a string) where the request came in." (claw-server-server-addr *claw-server*)) (defun claw-server-port () "Wrapper function around claw-server-SERVER-PORT. Returns the IP port \(as a number) where the request came in." (claw-server-server-port *claw-server*)) (defun claw-user-agent () "Wrapper function around claw-server-USER-AGENT. Returns the value of the incoming User-Agent http header." (claw-server-user-agent *claw-server*)) (defun claw-referer () "Wrapper function around claw-server-REFERER see it for more info." (claw-server-referer *claw-server*)) (defun claw-cookie-in (name) "Wrapper function around claw-server-COOKIE-IN. Returns the value \(a CLAW-COOKIE instance or nil) of the incoming cookie named by the string NAME." (claw-server-cookie-in *claw-server* name)) (defun claw-cookies-in () "Wrapper function around claw-server-COOKIES-IN. Returns the value \(as CLAW-COOKIE instance) of the incoming cookies." (claw-server-cookies-in *claw-server*)) (defun claw-aux-request-value (symbol) "Wrapper function around claw-server-AUX-REQUEST-VALUE. Returns values VALUE, PRESENTP. This accessor can be used to associate arbitrary data with the the symbol symbol in the REQUEST object request. present-p is true if such data was found, otherwise NIL" (claw-server-aux-request-value *claw-server* symbol)) (defun (setf claw-aux-request-value) (value symbol) "Wrapper function around (SETF claw-server-AUX-REQUEST-VALUE). This accessor can be used to associate arbitrary data with the the symbol symbol in the REQUEST object request." (setf (claw-server-aux-request-value *claw-server* symbol) value)) (defun claw-delete-aux-request-value (symbol) "Wrapper function around claw-server-DELETE-AUX-REQUEST-VALUE. Completely removes any data associated with the symbol symbol from the REQUEST object request." (claw-server-delete-aux-request-value *claw-server* symbol)) (defun claw-content-type () "Returns the outgoing Content-Type http header \(such as: \"text/html; charset=utf-8\")." (claw-server-content-type *claw-server*)) (defun (setf claw-content-type) (value) "Sets the outgoing Content-Type http header \(such as: \"text/html; charset=utf-8\")." (setf (claw-server-content-type *claw-server*) value)) (defun claw-content-length () "Returns the outgoing Content-Length http header" (claw-server-content-length *claw-server*)) (defun (setf claw-content-length) (value) "Sets the outgoing Content-Length http header" (setf (claw-server-content-length *claw-server*) value)) ;;--------------------------- (defun claw-header-out (symbol) "Wrapper function around claw-server-HEADER-OUT. Returns the outgoing http header named by the keyword name if there is one, otherwise NIL." (claw-server-header-out *claw-server* symbol)) (defun (setf claw-header-out) (value symbol) "Wrapper function around \(SETF claw-server-HEADER-OUT). SETF of HEADER-OUT changes the current value of the header named name \(name parameter must be a symbol). If no header named name exists it is created." (setf (claw-server-header-out *claw-server* symbol) value)) (defun claw-headers-out () "Wrapper function around claw-server-HEADERS-OUT. Returns an alist of all outgoing http parameters \(except for Set-Cookie, Content-Length, and Content-Type)." (claw-server-headers-out *claw-server*)) (defun claw-cookie-out (name) "Wrapper function around claw-server-COOKIE-OUT. Returns the outgoing cookie named by the string name \(or NIL if there ain't no cookie with this name)." (claw-server-cookie-out *claw-server* name)) (defun (setf claw-cookie-out) (cookie-instance name) "Wrapper function around \(SETF claw-server-COOKIE-OUT). Creates a CLAW-COOKIE object from the parameters provided to this function and adds it to the outgoing cookies of the REPLY object reply." (setf (claw-server-cookie-out *claw-server* name) cookie-instance)) (defun claw-cookies-out () "Wrapper function around claw-server-COOKIES-OUT. Returns the outgoing cookie named by the string name \(or NIL if there ain't no cookie with this name)." (claw-server-cookies-out *claw-server*)) (defun claw-return-code () "Wrapper function around claw-server-COOKIES-OUT. Returns the http return code of the reply. The return code of each REPLY object is initially set to 200 \(OK)" (claw-server-return-code *claw-server*)) (defun (setf claw-return-code) (value) "Wrapper function around \(SETF claw-server-COOKIES-OUT). Sets the http return code of the reply." (setf (claw-server-return-code *claw-server*) value)) (defun claw-reply-external-format-encoding () "Wrapper function around claw-server-REPLY-EXTERNAL-FORMAT-ENCODING. Returns the symbol of the reply charset encoding \(Such as UTF-8)." (claw-server-reply-external-format-encoding *claw-server*)) (defun (setf claw-reply-external-format-encoding) (value) "Wrapper function around (SETF claw-server-REPLY-EXTERNAL-FORMAT-ENCODING). Sets the symbol of the reply charset encoding \(Such as UTF-8)." (setf (claw-server-reply-external-format-encoding *claw-server*) value)) (defun claw-writer () "Wrapper function around claw-server-WRITER. Returns the output stream writer to generate replies. It's default to *standard-output*" (claw-server-writer *claw-server*)) (defun claw-redirect (target &key host port protocol add-session-id code) "Wrapper function around claw-server-REDIRECT. Sends back appropriate headers to redirect the client to target \(a string)." (claw-server-redirect *claw-server* target :host (or host (claw-host-name)) :port port :protocol protocol :add-session-id add-session-id :code code)) (defun claw-session-value (symbol) "Wrapper function around SESSION-MANAGER-SESSION-VALUE. Returns the value identified by SYMBOL, bounded to the user session." (session-manager-session-value (claw-server-session-manager *claw-server*) symbol)) (defun (setf claw-session-value) (value symbol) "Wrapper function around (SETF SESSION-MANAGER-SESSION-VALUE). Sets or modifies the value identified by SYMBOL, bounded to the user session" (setf (session-manager-session-value (claw-server-session-manager *claw-server*) symbol) value)) (defun claw-delete-session-value (symbol) "Wrapper function around SESSION-MANAGER-DELETE-SESSION-VALUE. Deletes the value identified by SYMBOL, bounded to the user session. This is different from setting the value to null." (session-manager-delete-session-value (claw-server-session-manager *claw-server*) symbol)) ;;-------------------------------------------------------------------------------------------- ;;---------------------------------------- WRAPPERS --------------------------------------END ;;-------------------------------------------------------------------------------------------- (defun duplicate-back-slashes (string) (regex-replace-all "\\" string "\\\\\\\\")) (defun sort-by-location (location-list) "Sorts a list of location items by their first element (the location itself)." (sort location-list #'(lambda (item1 item2) (string-not-lessp (first item1) (first item2))))) (defun sort-protected-resources (protected-resources) "Sorts a list of protected resources. A protected resource is a cons where the car is the url of the resource and the cdr is a list of roles allowhed to access that resource." (sort protected-resources #'(lambda (item1 item2) (string-lessp (car item1) (car item2))))) (defun remove-by-location (location location-list) "Removes an item from LOCATION-LIST checking its first element against the LOCATION parameter" (delete-if #'(lambda (item) (string= (first item) location)) location-list)) (defun pushnew-location (location-items location-list) "Isert a new location info items into a list, or replace the one that has the same location registered (its first element)." (let ((result (remove-by-location (first location-items) location-list))) (setf result (push location-items result)))) (defun claw-start-session (&key max-time domain) "Starts a session bound to the current lisplet base path" (session-manager-start-session (claw-server-session-manager *claw-server*) :path (format nil "~a/" *root-path*) :max-time max-time :domain domain)) (defun claw-remove-session () "Disposes user session if present" (session-manager-remove-session (claw-server-session-manager *claw-server*))) (defun current-principal () "Returns the principal(user) that logged into the application" (when *claw-session* (claw-session-value 'principal))) (defun (setf current-principal) (principal) "Setf the principal(user) that logged into the application" (unless *claw-session* (setf *claw-session* (claw-start-session))) (setf (claw-session-value 'principal) principal)) (defun user-in-role-p (roles) "Detects if current principal belongs to any of the expressed roles" (let ((principal (current-principal))) (when principal (loop for el in (principal-roles principal) thereis (member el roles :test #'string-equal))))) (defun current-config () "Returns the current configuration object for the realm of the request" (gethash *claw-current-realm* (claw-server-login-config *claw-server*))) (defun flatten (tree &optional result-list) "Traverses the tree in order, collecting even non-null leaves into a list." (let ((result result-list)) (loop for element in tree do (cond ((consp element) (setf result (append (nreverse (flatten element result-list)) result))) (t (push element result)))) (nreverse result))) (defun user-locale () "This function returns the user locale. If no locale was directly set, the browser default locale is used." (let ((locale (when *claw-session* (claw-session-value 'locale)))) (or locale (first (loop for str in (all-matches-as-strings "[A-Z|a-z|_]+" (regex-replace-all "-" (regex-replace-all ";.*" (claw-header-in 'ACCEPT-LANGUAGE) "") "_")) collect (if (> (length str) 2) (string-upcase str :start 2) str)))))) (defun (setf user-locale) (locale) "This function forces the locale for the current user, binding it to the user session, that is created if no session exists." (unless *claw-session* (setf *claw-session* (claw-start-session))) (setf (claw-session-value 'locale) locale)) (deftype unsigned-byte-8 () '(unsigned-byte 8)) (defun claw-handle-static-file (path &optional content-type (server *claw-server*)) "A function which acts like a Hunchentoot handler for the file denoted by PATH. Send a content type header corresponding to CONTENT-TYPE or \(if that is NIL) tries to determine the content type via the file's suffix." (unless (and (fad:file-exists-p path) (not (fad:directory-exists-p path))) ;; does not exist (setf (claw-return-code) 404) (throw 'handler-done nil)) (let ((time (or (file-write-date path) (get-universal-time))) (if-modified-since (claw-header-in :if-modified-since))) (setf (claw-content-type) (or content-type (mime-type path) "application/octet-stream")) (when (and if-modified-since (equal if-modified-since (rfc-1123-date time))) (setf (claw-return-code) +http-not-modified+) (throw 'handler-done nil)) (with-open-file (file path :direction :input :element-type 'unsigned-byte-8 :if-does-not-exist nil) (setf (claw-header-out "Last-Modified") (rfc-1123-date time) (claw-content-length) (file-length file)) (let ((out (claw-server-writer server))) (loop with buf = (make-array +buffer-length+ :element-type 'unsigned-byte-8) for pos = (read-sequence buf file) until (zerop pos) do (write-sequence buf out :end pos) (finish-output out)))))) (defun claw-write-response-string (content &key (content-type "text/html") last-modified) (when content (when last-modified (setf (claw-header-out "Last-Modified") (rfc-1123-date last-modified))) (setf (claw-content-length) (length content) (claw-content-type) content-type) (let ((out (claw-server-writer *claw-server*))) (write-sequence content out) (finish-output out)) content)) (defun register-library-resource (location resource-path &optional content-type) "Adds a RESOURCE \(a file or directory) as a library exposed resource to the given relative LOCATION." (unless (string= "/" (subseq location 0 1)) (setf location (concatenate 'string "/" location))) (setf *claw-libraries-resources* (sort-by-location (pushnew-location (cons location (if (directory-pathname-p resource-path) #'(lambda () (let ((resource-full-path (merge-pathnames (uri-to-pathname (subseq (claw-script-name) (+ (length (claw-server-base-path *claw-server*)) (length location)))) resource-path))) (claw-handle-static-file resource-full-path content-type))) #'(lambda () (claw-handle-static-file resource-path content-type)))) *claw-libraries-resources*)))) (defun uri-to-pathname (uri &optional (relative t)) "Convert an URI to a pathname" (let* ((splitted-uri (split-sequence #\/ uri)) (directory-list (butlast splitted-uri)) (file (first (last splitted-uri))) (pos (position #\. file :from-end t)) (file-name-and-type (if (and pos (> pos 0) (string-not-equal (subseq file (1+ pos)) "")) (list (subseq file 0 pos)(subseq file (1+ pos))) (list file)))) (make-pathname :directory (if relative (cons :relative directory-list) (cons :absolute directory-list)) :name (first file-name-and-type) :type (second file-name-and-type)))) (defun rfc-1123-date (&optional (time (get-universal-time))) "Generates a time string according to RFC 1123. Default is current time." (multiple-value-bind (second minute hour date month year day-of-week) (decode-universal-time time 0) (format nil "~A, ~2,'0d ~A ~4d ~2,'0d:~2,'0d:~2,'0d GMT" (nth day-of-week *day-names*) date (nth (1- month) *month-names*) year hour minute second))) (defun claw-host-name () "Extracts the host name from the HOST header-in parameter or the X-FORWARDED-HOST, if present" (first (split-sequence #\: (or (claw-header-in 'x-forwarded-host) (claw-header-in 'host))))) (defun claw-host-port () "Extracts the host port from the HOST header-in parameter or the X-FORWARDED-HOST, if present" (second (split-sequence #\: (or (claw-header-in 'x-forwarded-host) (claw-header-in 'host))))) (defun claw-host-protocol () "Return :HTTP or :HTTPS depending on the header HOST parameter" (let ((port (parse-integer (second (split-sequence #\: (claw-header-in 'host))))) (connector (claw-server-connector *claw-server*))) (if (= port (connector-port connector)) :http :https))) (defun claw-proxified-p () "Retrun a non NIL value when the request is handled by a proxy" (claw-header-in 'x-forwarded-host))