Two letter language codes (#195)

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.

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]

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 "<!DOCTYPE html>\n<html><head><title></title></head><body><h1>Test</h1><h2>http://test/whamlet</h2><h3>Adios</h3><h3>String</h3><h4>Embed</h4></body></html>" res
+
+case_two_letter_lang :: IO ()
+case_two_letter_lang = runner $ do
+    res <- request defaultRequest
+        { pathInfo = ["whamlet"]
+        , requestHeaders = [("Accept-Language", "es-ES")]
+        }
+    assertBody "<!DOCTYPE html>\n<html><head><title></title></head><body><h1>Test</h1><h2>http://test/whamlet</h2><h3>Adios</h3><h3>String</h3><h4>Embed</h4></body></html>" res