| 1 |
(in-package :bos.web) |
|---|
| 2 |
|
|---|
| 3 |
(enable-interpol-syntax) |
|---|
| 4 |
|
|---|
| 5 |
(define-persistent-class website-language () |
|---|
| 6 |
((code :read :index-type string-unique-index :index-reader language-with-code) |
|---|
| 7 |
(name :read :index-type string-unique-index))) |
|---|
| 8 |
|
|---|
| 9 |
(defun website-languages () |
|---|
| 10 |
(mapcar #'(lambda (language) (list (website-language-code language) |
|---|
| 11 |
(website-language-name language))) |
|---|
| 12 |
(class-instances 'website-language))) |
|---|
| 13 |
|
|---|
| 14 |
(defun website-supports-language (language) |
|---|
| 15 |
(find language (website-languages) :test #'string-equal :key #'car)) |
|---|
| 16 |
|
|---|
| 17 |
(defun language-from-url (path) |
|---|
| 18 |
(register-groups-bind (language) (#?r"^/(..)/" path) |
|---|
| 19 |
(when (website-supports-language language) |
|---|
| 20 |
language))) |
|---|
| 21 |
|
|---|
| 22 |
(defun find-browser-prefered-language () |
|---|
| 23 |
"Determine the language prefered by the user, as determined by the Accept-Language header |
|---|
| 24 |
present in the HTTP request. Header decoding is done according to RFC2616, considering individual |
|---|
| 25 |
language preference weights." |
|---|
| 26 |
(let ((accept-language (hunchentoot:header-in* :accept-language))) |
|---|
| 27 |
(dolist (language (mapcar #'car |
|---|
| 28 |
(sort (mapcar #'(lambda (language-spec-string) |
|---|
| 29 |
(if (find #\; language-spec-string) |
|---|
| 30 |
(destructuring-bind (language preference-string) |
|---|
| 31 |
(split #?r" *; *q=" language-spec-string) |
|---|
| 32 |
(cons language (read-from-string preference-string))) |
|---|
| 33 |
(cons language-spec-string 1))) |
|---|
| 34 |
(split #?r" *, *" accept-language)) |
|---|
| 35 |
#'> :key #'cdr))) |
|---|
| 36 |
(when (website-supports-language language) |
|---|
| 37 |
(return-from find-browser-prefered-language language)) |
|---|
| 38 |
(register-groups-bind (language variant) (#?r"^(.*)-(.*)$" language) |
|---|
| 39 |
(declare (ignore variant)) |
|---|
| 40 |
(when (website-supports-language language) |
|---|
| 41 |
(return-from find-browser-prefered-language language))))) |
|---|
| 42 |
nil) |
|---|
