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

30
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,9 +36,19 @@ 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"
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 $ W.requestHeaders env
cookies' = parseCookiesText reqCookie cookies' = parseCookiesText reqCookie
acceptLang = lookup "Accept-Language" $ W.requestHeaders env acceptLang = lookup "Accept-Language" $ W.requestHeaders env
@ -52,13 +62,11 @@ parseWaiRequest env session' key' = do
langs''' = case join $ lookup langKey gets' of langs''' = case join $ lookup langKey gets' of
Nothing -> langs'' Nothing -> langs''
Just x -> x : langs'' Just x -> x : langs''
nonce <- case (key', lookup nonceKey session') of gets'' = map (second $ fromMaybe "") gets'
(Nothing, _) -> return Nothing nonce = case (key', lookup nonceKey session') of
(_, Just x) -> return $ Just x (Nothing, _) -> Nothing
_ -> Just . pack . randomString 10 <$> newStdGen (_, Just x) -> Just x
let gets'' = map (second $ fromMaybe "") gets' _ -> Just $ pack $ randomString 10 gen
return $ Request gets'' cookies' env langs''' nonce
where
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'