From fddfd9bcf1a3b77cd7e92023efb67fd7dcfab683 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 24 Jan 2011 06:22:45 +0200 Subject: [PATCH] Yesod.Internal.Request --- Yesod/Core.hs | 45 +------------------------------- Yesod/Internal/Request.hs | 55 +++++++++++++++++++++++++++++++++++++++ Yesod/Request.hs | 3 +-- yesod-core.cabal | 1 + 4 files changed, 58 insertions(+), 46 deletions(-) create mode 100644 Yesod/Internal/Request.hs diff --git a/Yesod/Core.hs b/Yesod/Core.hs index 8ddfad1a..e098aadf 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -40,6 +40,7 @@ import Yesod.Request import qualified Network.Wai as W import Yesod.Internal import Yesod.Internal.Session +import Yesod.Internal.Request import Web.ClientSession (getKey, defaultKeyFile) import qualified Web.ClientSession as CS import qualified Data.ByteString as S @@ -56,9 +57,6 @@ import Text.Blaze (preEscapedLazyText) import Data.Text.Lazy.Builder (toLazyText) import Data.Text.Lazy.Encoding (encodeUtf8) import Data.Maybe (fromMaybe) -import System.Random (randomR, newStdGen) -import Control.Arrow (first, (***)) -import qualified Network.Wai.Parse as NWP import Control.Monad.IO.Class (liftIO) import Web.Cookie (parseCookies) import qualified Data.Map as Map @@ -577,44 +575,3 @@ yesodRender y u qs = (urlRenderOverride y u) where (ps, qs') = formatPathSegments (getSite' y) u - -parseWaiRequest :: W.Request - -> [(String, String)] -- ^ session - -> Maybe a - -> IO Request -parseWaiRequest env session' key' = do - let gets' = map (bsToChars *** bsToChars) - $ NWP.parseQueryString $ W.queryString env - let reqCookie = fromMaybe S.empty $ lookup "Cookie" - $ W.requestHeaders env - cookies' = map (bsToChars *** bsToChars) $ parseCookies reqCookie - acceptLang = lookup "Accept-Language" $ W.requestHeaders env - langs = map bsToChars $ 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 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 - (_, Nothing) -> do - g <- newStdGen - return $ Just $ fst $ randomString 10 g - return $ Request gets' cookies' env langs''' nonce - where - randomString len = - first (map toChar) . sequence' (replicate len (randomR (0, 61))) - sequence' [] g = ([], g) - sequence' (f:fs) g = - let (f', g') = f g - (fs', g'') = sequence' fs g' - in (f' : fs', g'') - toChar i - | i < 26 = toEnum $ i + fromEnum 'A' - | i < 52 = toEnum $ i + fromEnum 'a' - 26 - | otherwise = toEnum $ i + fromEnum '0' - 52 diff --git a/Yesod/Internal/Request.hs b/Yesod/Internal/Request.hs new file mode 100644 index 00000000..08a4a4e0 --- /dev/null +++ b/Yesod/Internal/Request.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE OverloadedStrings #-} +module Yesod.Internal.Request + ( parseWaiRequest + ) where + +import Yesod.Request +import Control.Arrow (first, (***)) +import qualified Network.Wai.Parse as NWP +import Data.Maybe (fromMaybe) +import Yesod.Internal +import qualified Network.Wai as W +import qualified Data.ByteString as S +import System.Random (randomR, newStdGen) +import Web.Cookie (parseCookies) + +parseWaiRequest :: W.Request + -> [(String, String)] -- ^ session + -> Maybe a + -> IO Request +parseWaiRequest env session' key' = do + let gets' = map (bsToChars *** bsToChars) + $ NWP.parseQueryString $ W.queryString env + let reqCookie = fromMaybe S.empty $ lookup "Cookie" + $ W.requestHeaders env + cookies' = map (bsToChars *** bsToChars) $ parseCookies reqCookie + acceptLang = lookup "Accept-Language" $ W.requestHeaders env + langs = map bsToChars $ 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 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 + (_, Nothing) -> do + g <- newStdGen + return $ Just $ fst $ randomString 10 g + return $ Request gets' cookies' env langs''' nonce + where + randomString len = + first (map toChar) . sequence' (replicate len (randomR (0, 61))) + sequence' [] g = ([], g) + sequence' (f:fs) g = + let (f', g') = f g + (fs', g'') = sequence' fs g' + in (f' : fs', g'') + toChar i + | i < 26 = toEnum $ i + fromEnum 'A' + | i < 52 = toEnum $ i + fromEnum 'a' - 26 + | otherwise = toEnum $ i + fromEnum '0' - 52 diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 9856d2fe..cd5717e0 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -71,8 +71,7 @@ class Monad m => RequestReader m where -- -- * Accept-Language HTTP header. -- --- This is handled by the parseWaiRequest function in Yesod.Dispatch (not --- exposed). +-- This is handled by parseWaiRequest (not exposed). languages :: RequestReader m => m [String] languages = reqLangs `liftM` getRequest diff --git a/yesod-core.cabal b/yesod-core.cabal index db06e436..c43720f0 100644 --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -56,6 +56,7 @@ library Yesod.Widget other-modules: Yesod.Internal Yesod.Internal.Session + Yesod.Internal.Request Paths_yesod_core ghc-options: -Wall