haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Pure and testable parseWaiRequest.

Browse Source
This commit is contained in:
Björn Buckwalter 2011-09-16 11:36:00 +08:00
parent da11ddc1c1
commit 884c363ebf
1 changed files with 31 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
yesod-core/Yesod/Internal/Request.hs
View File

@ -11,7 +11,7 @@ import Control.Arrow (second)
import qualified Network.Wai.Parse as NWP
import Yesod.Internal
import qualified Network.Wai as W
import System.Random (randomRs, newStdGen)
import System.Random (RandomGen, newStdGen, randomRs)
import Web.Cookie (parseCookiesText)
import Data.Monoid (mempty)
import qualified Data.ByteString.Char8 as S8
@ -36,29 +36,37 @@ parseWaiRequest :: W.Request
-> [(Text, Text)] -- ^ session
-> Maybe a
-> IO Request
parseWaiRequest env session' key' = do
let gets' = queryToQueryText $ W.queryString env
let reqCookie = fromMaybe mempty $ lookup "Cookie"
$ W.requestHeaders env
cookies' = parseCookiesText reqCookie
acceptLang = lookup "Accept-Language" $ W.requestHeaders env
langs = map (pack . S8.unpack) $ maybe [] NWP.parseHttpAccept acceptLang
langs' = case lookup langKey session' of
Nothing -> langs
Just x -> x : langs
langs'' = case lookup langKey cookies' of
Nothing -> langs'
Just x -> x : langs'
langs''' = case join $ lookup langKey gets' of
Nothing -> langs''
Just x -> x : langs''
nonce <- case (key', lookup nonceKey session') of
(Nothing, _) -> return Nothing
(_, Just x) -> return $ Just x
_ -> Just . pack . randomString 10 <$> newStdGen
let gets'' = map (second $ fromMaybe "") gets'
return $ Request gets'' cookies' env langs''' nonce
parseWaiRequest env session' key' = parseWaiRequest' env session' key'
<$> newStdGen
parseWaiRequest' :: RandomGen g
=> W.Request
-> [(Text, Text)] -- ^ session
-> Maybe a
-> g
-> Request
parseWaiRequest' env session' key' gen = Request gets'' cookies' env langs''' nonce
where
gets' = queryToQueryText $ W.queryString env
reqCookie = fromMaybe mempty $ lookup "Cookie"
$ W.requestHeaders env
cookies' = parseCookiesText reqCookie
acceptLang = lookup "Accept-Language" $ W.requestHeaders env
langs = map (pack . S8.unpack) $ maybe [] NWP.parseHttpAccept acceptLang
langs' = case lookup langKey session' of
Nothing -> langs
Just x -> x : langs
langs'' = case lookup langKey cookies' of
Nothing -> langs'
Just x -> x : langs'
langs''' = case join $ lookup langKey gets' of
Nothing -> langs''
Just x -> x : langs''
gets'' = map (second $ fromMaybe "") gets'
nonce = case (key', lookup nonceKey session') of
(Nothing, _) -> Nothing
(_, Just x) -> Just x
_ -> Just $ pack $ randomString 10 gen
randomString len = take len . map toChar . randomRs (0, 61)
toChar i
| i < 26 = toEnum $ i + fromEnum 'A'