Merge branch 'manual-language-switch'

Author: koterpillar

src/App.hs

@@ -4,6 +4,7 @@ module App where
 import Control.Monad.State
 
 import qualified Data.ByteString.Char8 as B
+import Data.Maybe
 import qualified Data.Text as T
 import Data.Time
 
@@ -66,8 +67,12 @@ dailyIndex = articleList . byDate
 languageHeaderM :: AppPart LanguagePreference
 languageHeaderM = do
     request <- askRq
-    let header = getHeader "Accept-Language" request
-    return $ languageHeader $ liftM B.unpack header
+    let header = B.unpack $ fromMaybe "" $ getHeader "Accept-Language" request
+    param <- looks "lang"
+    let langValue = listToMaybe $ catMaybes $ map notEmpty $ param ++ [header]
+    return $ languageHeader langValue
+    where notEmpty "" = Nothing
+          notEmpty x  = Just x
 
 html :: ToMessage a => a -> AppPart Response
 html = ok . toResponse

src/Language.hs

@@ -30,6 +30,9 @@ newtype LanguagePreference = LanguagePreference { unLanguagePreference :: Langua
 defaultLanguage :: Language
 defaultLanguage = EN
 
+singleLanguage :: Language -> LanguagePreference
+singleLanguage lang = LanguagePreference $ M.singleton lang 1
+
 rankLanguage :: Language -> LanguagePreference -> Float
 rankLanguage lang = fromMaybe 0 . M.lookup lang . unLanguagePreference
 

testsuite/Integration/Base.hs

@@ -44,27 +44,44 @@ assertContains needle haystack =
 -- Happstack doesn't make it easy
 mkRequest :: String -> IO Request
 mkRequest rPath = do
+    let (rUri, rParams) = splitUriParam rPath
     inputsBody <- newEmptyMVar
     rBody <- newMVar (Body LB.empty)
     return Request { rqSecure = False
                    , rqMethod = GET
-                   , rqPaths = filter (/= "") $ splitOn "/" rPath
+                   , rqPaths = filter (/= "") $ splitOn "/" rUri
                    , rqUri = rPath
-                   , rqQuery = ""
-                   , rqInputsQuery = []
+                   , rqQuery = "?" ++ rParams
+                   , rqInputsQuery = splitParams rParams
                    , rqInputsBody = inputsBody
                    , rqCookies = []
                    , rqVersion = HttpVersion 1 1
                    , rqHeaders = M.empty
                    , rqBody = rBody
                    , rqPeer = ("", 0)
                    }
+    where splitUriParam :: String -> (String, String)
+          splitUriParam rPath = case splitOn "?" rPath of
+              [rUri] -> (rUri, "")
+              [rUri, rParams] -> (rUri, rParams)
+          splitParams :: String -> [(String, Input)]
+          splitParams = map (mkParamTuple . splitOn "=") . filter (/= "") . splitOn "&"
+          mkParamTuple :: [String] -> (String, Input)
+          mkParamTuple [k, v] = (k, mkInputValue v)
+          mkParamTuple [k] = (k, mkInputValue "")
+          mkInputValue str = Input { inputValue = Right (LB.fromStrict $ U.fromString str)
+                                   , inputFilename = Nothing
+                                   , inputContentType = ContentType {ctType = "text", ctSubtype = "plain", ctParameters = []}
+                                   }
 
 withLang :: LanguagePreference -> Request -> Request
 withLang lang req = req { rqHeaders = newHeaders }
     where newHeaders = M.insert "accept-language" (HeaderPair "Accept-Language" [U.fromString pref]) (rqHeaders req)
           pref = show lang
 
+withLang1 :: Language -> Request -> Request
+withLang1 lang = withLang $ singleLanguage lang
+
 -- Extract contents from a response
 responseContent :: Response -> IO String
 responseContent r@(Response _ _ _ _ _) = return $ U.toString $ LB.toStrict $ rsBody r

testsuite/Integration/TestHome.hs

@@ -2,13 +2,29 @@
 
 module Integration.TestHome where
 
-import Integration.Base
+import Control.Monad
+
+import Data.LanguageCodes
 
 import Test.Framework
 
+import Integration.Base
+
 
 test_home = do
     req <- mkRequest "/"
     home <- testRequest req
     resp <- responseContent home
     assertContains "Test site" resp
+
+test_home_lang = do
+    req <- liftM (withLang1 RU) (mkRequest "/")
+    home <- testRequest req
+    resp <- responseContent home
+    assertContains "Главная" resp
+
+test_explicit_lang = do
+    req <- mkRequest "/?lang=ru"
+    home <- testRequest req
+    resp <- responseContent home
+    assertContains "Главная" resp