Skip to content

Commit

Permalink
Merge branch 'manual-language-switch'
Browse files Browse the repository at this point in the history
  • Loading branch information
koterpillar committed Feb 3, 2015
2 parents 97c7474 + c98a7b5 commit 4b1778a
Show file tree
Hide file tree
Showing 4 changed files with 47 additions and 6 deletions.
9 changes: 7 additions & 2 deletions src/App.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand Down Expand Up @@ -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
Expand Down
3 changes: 3 additions & 0 deletions src/Language.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand Down
23 changes: 20 additions & 3 deletions testsuite/Integration/Base.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
18 changes: 17 additions & 1 deletion testsuite/Integration/TestHome.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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

0 comments on commit 4b1778a

Please sign in to comment.