Make RandomGen parameter optional

yesod-core/Yesod/Core/Run.hs

@@ -284,7 +284,11 @@ defaultYesodRunner YesodRunnerEnv {..} handler' req
     let dontSaveSession _ = return []
     (session, saveSession) <- liftIO $ do
         maybe (return (Map.empty, dontSaveSession)) (\sb -> sbLoadSession sb yreMaster req) yreSessionBackend
-    yreq <- liftIO $ parseWaiRequest req session (isJust yreSessionBackend) maxLen <$> newStdGen
+    let mkYesodReq = parseWaiRequest req session (isJust yreSessionBackend) maxLen
+    yreq <-
+        case mkYesodReq of
+            Left yreq -> return yreq
+            Right needGen -> liftIO $ needGen <$> newStdGen
     let ra = resolveApproot yreMaster req
     let log' = messageLoggerSource yreMaster yreLogger
         -- We set up two environments: the first one has a "safe" error handler

yesod-core/Yesod/Internal/Request.hs

@@ -72,21 +72,27 @@ parseWaiRequest :: RandomGen g
                 -> SessionMap
                 -> Bool
                 -> Word64 -- ^ max body size
-                -> g
-                -> YesodRequest
-parseWaiRequest env session useToken maxBodySize gen =
-    YesodRequest
+                -> (Either YesodRequest (g -> YesodRequest))
+parseWaiRequest env session useToken maxBodySize =
+    -- In most cases, we won't need to generate any random values. Therefore,
+    -- we split our results: if we need a random generator, return a Right
+    -- value, otherwise return a Left and avoid the relatively costly generator
+    -- acquisition.
+    case etoken of
+        Left token -> Left $ mkRequest token
+        Right mkToken -> Right $ mkRequest . mkToken
+  where
+    mkRequest token' = YesodRequest
         { reqGetParams  = gets
         , reqCookies    = cookies
         , reqWaiRequest = limitRequestBody maxBodySize env
         , reqLangs      = langs''
-        , reqToken      = token
+        , reqToken      = token'
         , reqSession    = if useToken
                             then Map.delete tokenKey session
                             else session
         , reqAccept     = httpAccept env
         }
-  where
     gets = map (second $ fromMaybe "")
          $ queryToQueryText
          $ W.queryString env
@@ -111,12 +117,14 @@ parseWaiRequest env session useToken maxBodySize gen =
     -- tokenKey present in the session is ignored). If sessions
     -- are enabled and a session has no tokenKey a new one is
     -- generated.
-    token = if not useToken
-              then Nothing
-              else Just $ maybe
-                            (pack $ randomString 10 gen)
-                            (decodeUtf8With lenientDecode)
-                            (Map.lookup tokenKey session)
+    etoken
+        | useToken =
+            case Map.lookup tokenKey session of
+                -- Already have a token, use it.
+                Just bs -> Left $ Just $ decodeUtf8With lenientDecode bs
+                -- Don't have a token, get a random generator and make a new one.
+                Nothing -> Right $ Just . pack . randomString 10
+        | otherwise = Left Nothing
 
 -- | Get the list of accepted content types from the WAI Request\'s Accept
 -- header.

yesod-core/test/YesodCoreTest/InternalRequest.hs

@@ -11,6 +11,8 @@ import Yesod.Request (YesodRequest (..))
 import Test.Hspec
 import Data.Monoid (mempty)
 import Data.Map (singleton)
+import Yesod.Core (SessionMap)
+import Data.Word (Word64)
 
 randomStringSpecs :: Spec
 randomStringSpecs = describe "Yesod.Internal.Request.randomString" $ do
@@ -30,6 +32,15 @@ noRepeat len n = length (nub $ map (randomString len . mkStdGen) [1..n]) == n
 g :: StdGen
 g = error "test/YesodCoreTest/InternalRequest.g"
 
+parseWaiRequest' :: Request
+                 -> SessionMap
+                 -> Bool
+                 -> Word64
+                 -> YesodRequest
+parseWaiRequest' a b c d =
+    case parseWaiRequest a b c d of
+        Left yreq -> yreq
+        Right needGen -> needGen g
 
 tokenSpecs :: Spec
 tokenSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqToken)" $ do
@@ -40,19 +51,19 @@ tokenSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqToken)" $ do
 
 noDisabledToken :: Bool
 noDisabledToken = reqToken r == Nothing where
-  r = parseWaiRequest defaultRequest mempty False 1000 g
+  r = parseWaiRequest' defaultRequest mempty False 1000
 
 ignoreDisabledToken :: Bool
 ignoreDisabledToken = reqToken r == Nothing where
-  r = parseWaiRequest defaultRequest (singleton "_TOKEN" "old") False 1000 g
+  r = parseWaiRequest' defaultRequest (singleton "_TOKEN" "old") False 1000
 
 useOldToken :: Bool
 useOldToken = reqToken r == Just "old" where
-  r = parseWaiRequest defaultRequest (singleton "_TOKEN" "old") True 1000 g
+  r = parseWaiRequest' defaultRequest (singleton "_TOKEN" "old") True 1000
 
 generateToken :: Bool
 generateToken = reqToken r /= Nothing where
-  r = parseWaiRequest defaultRequest (singleton "_TOKEN" "old") True 1000 g
+  r = parseWaiRequest' defaultRequest (singleton "_TOKEN" "old") True 1000
 
 
 langSpecs :: Spec
@@ -65,31 +76,31 @@ langSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqLangs)" $ do
 
 respectAcceptLangs :: Bool
 respectAcceptLangs = reqLangs r == ["en-US", "es", "en"] where
-  r = parseWaiRequest defaultRequest
-        { requestHeaders = [("Accept-Language", "en-US, es")] } mempty False 1000 g
+  r = parseWaiRequest' defaultRequest
+        { requestHeaders = [("Accept-Language", "en-US, es")] } mempty False 1000
 
 respectSessionLang :: Bool
 respectSessionLang = reqLangs r == ["en"] where
-  r = parseWaiRequest defaultRequest (singleton "_LANG" "en") False 1000 g
+  r = parseWaiRequest' defaultRequest (singleton "_LANG" "en") False 1000
 
 respectCookieLang :: Bool
 respectCookieLang = reqLangs r == ["en"] where
-  r = parseWaiRequest defaultRequest
+  r = parseWaiRequest' defaultRequest
         { requestHeaders = [("Cookie", "_LANG=en")]
-        } mempty False 1000 g
+        } mempty False 1000
 
 respectQueryLang :: Bool
 respectQueryLang = reqLangs r == ["en-US", "en"] where
-  r = parseWaiRequest defaultRequest { queryString = [("_LANG", Just "en-US")] } mempty False 1000 g
+  r = parseWaiRequest' defaultRequest { queryString = [("_LANG", Just "en-US")] } mempty False 1000
 
 prioritizeLangs :: Bool
 prioritizeLangs = reqLangs r == ["en-QUERY", "en-COOKIE", "en-SESSION", "en", "es"] where
-  r = parseWaiRequest defaultRequest
+  r = parseWaiRequest' defaultRequest
         { requestHeaders = [ ("Accept-Language", "en, es")
                            , ("Cookie", "_LANG=en-COOKIE")
                            ]
         , queryString = [("_LANG", Just "en-QUERY")]
-        } (singleton "_LANG" "en-SESSION") False 10000 g
+        } (singleton "_LANG" "en-SESSION") False 10000
 
 internalRequestTest :: Spec
 internalRequestTest = describe "Test.InternalRequestTest" $ do