summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMatthias Andreas Benkard <code@mail.matthias.benkard.de>2011-03-22 00:52:03 +0100
committerMatthias Andreas Benkard <code@mail.matthias.benkard.de>2011-03-22 00:52:03 +0100
commit0c55d369ae0884d4b127745bd19ee00d323897c8 (patch)
treed928410c6b05bc0bf7e72f973ac5d483d5f1aed5
parent8f8182a67b5c846f9c09051ca5d38ff5c4dede8d (diff)
Use the Accept-Language HTTP header to determine preferred user languages.
-rw-r--r--mulkcms-hunchentoot.lisp5
-rw-r--r--mulkcms.lisp18
2 files changed, 20 insertions, 3 deletions
diff --git a/mulkcms-hunchentoot.lisp b/mulkcms-hunchentoot.lisp
index 5562fba..90d8d31 100644
--- a/mulkcms-hunchentoot.lisp
+++ b/mulkcms-hunchentoot.lisp
@@ -14,7 +14,10 @@
(defun dispatch-mulkcms-request (request)
(let* ((relative-path (subseq (script-name request) 1)))
- (mulkcms::find-request-handler relative-path (append (get-parameters*) (post-parameters*)))))
+ (mulkcms::find-request-handler relative-path
+ (append (get-parameters*)
+ (post-parameters*))
+ (header-in* :accept-language))))
(defun setup-handlers ()
(setq *dispatch-table*
diff --git a/mulkcms.lisp b/mulkcms.lisp
index afa818c..7c8bad5 100644
--- a/mulkcms.lisp
+++ b/mulkcms.lisp
@@ -1035,14 +1035,28 @@
(intern (string-upcase (format nil "~A" thing)) "KEYWORD"))
-(defun find-request-handler (path params)
+(defun parse-accept-language-header (accept-lang)
+ (let ((*read-eval* nil)
+ languages)
+ (ppcre:do-register-groups (lang quality)
+ ("\\b(\\w+)(?:-\\w+)?(?:;q=([0-9.]+))?\\b" accept-lang)
+ (push (cons lang (if quality
+ (read-from-string quality)
+ 1.0))
+ languages))
+ (mapcar (lambda (x) (list (cons "language" (car x))))
+ (stable-sort (reverse languages) #'> :key #'cdr))))
+
+
+(defun find-request-handler (path params accept-lang)
(let ((*requested-characteristics*
(or (when-let (langstr (or (cdr (assoc "lang" params :test #'equal))
(cdr (assoc "hl" params :test #'equal))))
(let ((langs (split-sequence #\| langstr)))
(mapcar (lambda (x) (list (cons "language" x)))
langs)))
- *default-characteristics-precedence-list*))
+ (append (parse-accept-language-header accept-lang)
+ *default-characteristics-precedence-list*)))
(*propagated-params* (remove-if-not (lambda (x)
(member (car x)
(list "lang" "hl")