From 884c363ebfd22a55082979be4cedf3c531771aa1 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Bjo=CC=88rn=20Buckwalter?= <bjorn@buckwalter.se>
Date: Fri, 16 Sep 2011 11:36:00 +0800
Subject: [PATCH] Pure and testable parseWaiRequest.

---
 yesod-core/Yesod/Internal/Request.hs | 54 ++++++++++++++++------------
 1 file changed, 31 insertions(+), 23 deletions(-)

diff --git a/yesod-core/Yesod/Internal/Request.hs b/yesod-core/Yesod/Internal/Request.hs
index b1e242c1..c2265c24 100644
--- a/yesod-core/Yesod/Internal/Request.hs
+++ b/yesod-core/Yesod/Internal/Request.hs
@@ -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'