diff options
| author | Matthias Andreas Benkard <code@mail.matthias.benkard.de> | 2011-03-22 00:52:03 +0100 |
|---|---|---|
| committer | Matthias Andreas Benkard <code@mail.matthias.benkard.de> | 2011-03-22 00:52:03 +0100 |
| commit | 0c55d369ae0884d4b127745bd19ee00d323897c8 (patch) | |
| tree | d928410c6b05bc0bf7e72f973ac5d483d5f1aed5 | |
| parent | 8f8182a67b5c846f9c09051ca5d38ff5c4dede8d (diff) | |
Use the Accept-Language HTTP header to determine preferred user languages.
| -rw-r--r-- | mulkcms-hunchentoot.lisp | 5 | ||||
| -rw-r--r-- | mulkcms.lisp | 18 |
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") |