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