diff --git a/yesod-core/Yesod/Internal/Request.hs b/yesod-core/Yesod/Internal/Request.hs index 263823d8..9dec2262 100644 --- a/yesod-core/Yesod/Internal/Request.hs +++ b/yesod-core/Yesod/Internal/Request.hs @@ -23,6 +23,8 @@ import Network.HTTP.Types (queryToQueryText) import Control.Monad (join) import Data.Maybe (fromMaybe, catMaybes) import qualified Data.ByteString.Lazy as L +import qualified Data.Set as Set +import qualified Data.Text as T -- | The parsed request information. data Request = Request @@ -47,7 +49,7 @@ parseWaiRequest' :: RandomGen g -> Maybe a -> g -> Request -parseWaiRequest' env session' key' gen = Request gets'' cookies' env langs' nonce +parseWaiRequest' env session' key' gen = Request gets'' cookies' env langs'' nonce where gets' = queryToQueryText $ W.queryString env gets'' = map (second $ fromMaybe "") gets' @@ -60,6 +62,11 @@ parseWaiRequest' env session' key' gen = Request gets'' cookies' env langs' nonc , lookup langKey cookies' -- Cookie _LANG , lookup langKey session' -- Session _LANG ] ++ langs -- Accept-Language(s) + + -- Github issue #195. We want to add an extra two-letter version of any + -- language in the list. + langs'' = addTwoLetters (id, Set.empty) langs' + -- If sessions are disabled nonces should not be used (any -- nonceKey present in the session is ignored). If sessions -- are enabled and a session has no nonceKey a new one is @@ -69,6 +76,16 @@ parseWaiRequest' env session' key' gen = Request gets'' cookies' env langs' nonc (_, Just x) -> Just x _ -> Just $ pack $ randomString 10 gen +addTwoLetters :: ([Text] -> [Text], Set.Set Text) -> [Text] -> [Text] +addTwoLetters (toAdd, exist) [] = + filter (flip Set.notMember exist) $ toAdd [] +addTwoLetters (toAdd, exist) (l:ls) = + l : addTwoLetters (toAdd', exist') ls + where + (toAdd', exist') + | T.length l > 2 = (toAdd . (T.take 2 l:), exist) + | otherwise = (toAdd, Set.insert l exist) + -- | Generate a random String of alphanumerical characters -- (a-z, A-Z, and 0-9) of the given length using the given -- random number generator. diff --git a/yesod-core/test/YesodCoreTest/InternalRequest.hs b/yesod-core/test/YesodCoreTest/InternalRequest.hs index b3aa4044..b8c1a4db 100644 --- a/yesod-core/test/YesodCoreTest/InternalRequest.hs +++ b/yesod-core/test/YesodCoreTest/InternalRequest.hs @@ -65,32 +65,32 @@ langSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqLangs)" ] respectAcceptLangs :: Bool -respectAcceptLangs = reqLangs r == ["accept1", "accept2"] where +respectAcceptLangs = reqLangs r == ["en-US", "es", "en"] where r = parseWaiRequest' defaultRequest - { requestHeaders = [("Accept-Language", "accept1, accept2")] } [] Nothing g + { requestHeaders = [("Accept-Language", "en-US, es")] } [] Nothing g respectSessionLang :: Bool -respectSessionLang = reqLangs r == ["session"] where - r = parseWaiRequest' defaultRequest [("_LANG", "session")] Nothing g +respectSessionLang = reqLangs r == ["en"] where + r = parseWaiRequest' defaultRequest [("_LANG", "en")] Nothing g respectCookieLang :: Bool -respectCookieLang = reqLangs r == ["cookie"] where +respectCookieLang = reqLangs r == ["en"] where r = parseWaiRequest' defaultRequest - { requestHeaders = [("Cookie", "_LANG=cookie")] + { requestHeaders = [("Cookie", "_LANG=en")] } [] Nothing g respectQueryLang :: Bool -respectQueryLang = reqLangs r == ["query"] where - r = parseWaiRequest' defaultRequest { queryString = [("_LANG", Just "query")] } [] Nothing g +respectQueryLang = reqLangs r == ["en-US", "en"] where + r = parseWaiRequest' defaultRequest { queryString = [("_LANG", Just "en-US")] } [] Nothing g prioritizeLangs :: Bool -prioritizeLangs = reqLangs r == ["query", "cookie", "session", "accept1", "accept2"] where +prioritizeLangs = reqLangs r == ["en-QUERY", "en-COOKIE", "en-SESSION", "en", "es"] where r = parseWaiRequest' defaultRequest - { requestHeaders = [ ("Accept-Language", "accept1, accept2") - , ("Cookie", "_LANG=cookie") + { requestHeaders = [ ("Accept-Language", "en, es") + , ("Cookie", "_LANG=en-COOKIE") ] - , queryString = [("_LANG", Just "query")] - } [("_LANG", "session")] Nothing g + , queryString = [("_LANG", Just "en-QUERY")] + } [("_LANG", "en-SESSION")] Nothing g internalRequestTest :: [Spec] diff --git a/yesod-core/test/YesodCoreTest/Widget.hs b/yesod-core/test/YesodCoreTest/Widget.hs index acd86a1b..ae1e4699 100644 --- a/yesod-core/test/YesodCoreTest/Widget.hs +++ b/yesod-core/test/YesodCoreTest/Widget.hs @@ -73,6 +73,7 @@ widgetTest :: [Spec] widgetTest = describe "Test.Widget" [ it "addJuliusBody" case_addJuliusBody , it "whamlet" case_whamlet + , it "two letter lang codes" case_two_letter_lang ] runner :: Session () -> IO () @@ -90,3 +91,11 @@ case_whamlet = runner $ do , requestHeaders = [("Accept-Language", "es")] } assertBody "\n

Test

http://test/whamlet

Adios

String

Embed

" res + +case_two_letter_lang :: IO () +case_two_letter_lang = runner $ do + res <- request defaultRequest + { pathInfo = ["whamlet"] + , requestHeaders = [("Accept-Language", "es-ES")] + } + assertBody "\n

Test

http://test/whamlet

Adios

String

Embed

" res