From 0c55d369ae0884d4b127745bd19ee00d323897c8 Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <code@mail.matthias.benkard.de>
Date: Tue, 22 Mar 2011 00:52:03 +0100
Subject: Use the Accept-Language HTTP header to determine preferred user
 languages.

---
 mulkcms-hunchentoot.lisp |  5 ++++-
 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")
-- 
cgit v1.2.3