diff --git a/yesod-core/Yesod/Internal/Request.hs b/yesod-core/Yesod/Internal/Request.hs index d9ec7d74..8825d27e 100644 --- a/yesod-core/Yesod/Internal/Request.hs +++ b/yesod-core/Yesod/Internal/Request.hs @@ -1,23 +1,27 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} module Yesod.Internal.Request ( parseWaiRequest , Request (..) , RequestBodyContents , FileInfo (..) + -- The below are exported for testing. + , randomString + , parseWaiRequest' ) where -import Control.Arrow (first, second) +import Control.Applicative ((<$>)) +import Control.Arrow (second) import qualified Network.Wai.Parse as NWP import Yesod.Internal import qualified Network.Wai as W -import System.Random (randomR, newStdGen) +import System.Random (RandomGen, newStdGen, randomRs) import Web.Cookie (parseCookiesText) -import Data.Monoid (mempty) import qualified Data.ByteString.Char8 as S8 import Data.Text (Text, pack) import Network.HTTP.Types (queryToQueryText) import Control.Monad (join) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, catMaybes) import qualified Data.ByteString.Lazy as L -- | The parsed request information. @@ -35,42 +39,43 @@ 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 - (_, Nothing) -> do - g <- newStdGen - return $ Just $ pack $ fst $ randomString 10 g - 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 - 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 + gets' = queryToQueryText $ W.queryString env + gets'' = map (second $ fromMaybe "") gets' + reqCookie = lookup "Cookie" $ W.requestHeaders env + cookies' = maybe [] parseCookiesText reqCookie + acceptLang = lookup "Accept-Language" $ W.requestHeaders env + langs = map (pack . S8.unpack) $ maybe [] NWP.parseHttpAccept acceptLang + -- The language preferences are prioritized as follows: + langs' = catMaybes [ join $ lookup langKey gets' -- Query _LANG + , lookup langKey cookies' -- Cookie _LANG + , lookup langKey session' -- Session _LANG + ] ++ langs -- Accept-Language(s) + -- If the session is not secure a nonce should not be + -- used (any nonce present in the session is ignored). + -- If a secure session has no nonceKey a new one is + -- generated. + nonce = case (key', lookup nonceKey session') of + (Nothing, _) -> Nothing + (_, Just x) -> Just x + _ -> Just $ pack $ randomString 10 gen + +-- | Generate a random String of alphanumerical characters +-- (a-z, A-Z, and 0-9) of the given length using the given +-- random number generator. +randomString :: RandomGen g => Int -> g -> String +randomString len = take len . map toChar . randomRs (0, 61) + where + toChar i = (['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9']) !! i -- | A tuple containing both the POST parameters and submitted files. type RequestBodyContents = diff --git a/yesod-core/Yesod/Internal/TestApi.hs b/yesod-core/Yesod/Internal/TestApi.hs new file mode 100644 index 00000000..ffb1387e --- /dev/null +++ b/yesod-core/Yesod/Internal/TestApi.hs @@ -0,0 +1,11 @@ +-- +-- | WARNING: This module exposes internal interfaces solely for the +-- purpose of facilitating cabal-driven testing of said interfaces. +-- This module is NOT part of the public Yesod API and should NOT be +-- imported by library users. +-- +module Yesod.Internal.TestApi + ( randomString, parseWaiRequest' + ) where + +import Yesod.Internal.Request (randomString, parseWaiRequest') diff --git a/yesod-core/test/Test/InternalRequest.hs b/yesod-core/test/Test/InternalRequest.hs new file mode 100644 index 00000000..ba510cb5 --- /dev/null +++ b/yesod-core/test/Test/InternalRequest.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE OverloadedStrings #-} +module Test.InternalRequest (internalRequestTest) where + +import Data.List (nub) +import System.Random (StdGen, mkStdGen) + +import Network.Wai as W +import Network.Wai.Test +import Yesod.Internal.TestApi (randomString, parseWaiRequest') +import Yesod.Request (Request (..)) +import Test.Hspec + +randomStringSpecs :: [Spec] +randomStringSpecs = describe "Yesod.Internal.Request.randomString" + [ it "looks reasonably random" looksRandom + , it "does not repeat itself" $ noRepeat 10 100 + ] + +-- NOTE: this testcase may break on other systems/architectures if +-- mkStdGen is not identical everywhere (is it?). +looksRandom = randomString 20 (mkStdGen 0) == "VH9SkhtptqPs6GqtofVg" + +noRepeat len n = length (nub $ map (randomString len . mkStdGen) [1..n]) == n + + +-- For convenience instead of "(undefined :: StdGen)". +g :: StdGen +g = undefined + + +nonceSpecs :: [Spec] +nonceSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqNonce)" + [ it "is Nothing for unsecure sessions" noUnsecureNonce + , it "ignores pre-existing nonce for unsecure sessions" ignoreUnsecureNonce + , it "uses preexisting nonce for secure sessions" useOldNonce + , it "generates a new nonce for secure sessions without nonce" generateNonce + ] + +noUnsecureNonce = reqNonce r == Nothing where + r = parseWaiRequest' defaultRequest [] Nothing g + +ignoreUnsecureNonce = reqNonce r == Nothing where + r = parseWaiRequest' defaultRequest [("_NONCE", "old")] Nothing g + +useOldNonce = reqNonce r == Just "old" where + r = parseWaiRequest' defaultRequest [("_NONCE", "old")] (Just undefined) g + +generateNonce = reqNonce r /= Nothing where + r = parseWaiRequest' defaultRequest [("_NONCE", "old")] (Just undefined) g + + +langSpecs :: [Spec] +langSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqLangs)" + [ it "respects Accept-Language" respectAcceptLangs + , it "respects sessions" respectSessionLang + , it "respects cookies" respectCookieLang + , it "respects queries" respectQueryLang + , it "prioritizes correctly" prioritizeLangs + ] + +respectAcceptLangs = reqLangs r == ["accept1", "accept2"] where + r = parseWaiRequest' defaultRequest + { requestHeaders = [("Accept-Language", "accept1, accept2")] } [] Nothing g + +respectSessionLang = reqLangs r == ["session"] where + r = parseWaiRequest' defaultRequest [("_LANG", "session")] Nothing g + +respectCookieLang = reqLangs r == ["cookie"] where + r = parseWaiRequest' defaultRequest + { requestHeaders = [("Cookie", "_LANG=cookie")] + } [] Nothing g + +respectQueryLang = reqLangs r == ["query"] where + r = parseWaiRequest' defaultRequest { queryString = [("_LANG", Just "query")] } [] Nothing g + +prioritizeLangs = reqLangs r == ["query", "cookie", "session", "accept1", "accept2"] where + r = parseWaiRequest' defaultRequest + { requestHeaders = [ ("Accept-Language", "accept1, accept2") + , ("Cookie", "_LANG=cookie") + ] + , queryString = [("_LANG", Just "query")] + } [("_LANG", "session")] Nothing g + + +internalRequestTest :: [Spec] +internalRequestTest = descriptions [ randomStringSpecs + , nonceSpecs + , langSpecs + ] + +main = hspec internalRequestTest diff --git a/yesod-core/test/main.hs b/yesod-core/test/main.hs index afdaaa8e..00cff379 100644 --- a/yesod-core/test/main.hs +++ b/yesod-core/test/main.hs @@ -6,13 +6,15 @@ import Test.Widget import Test.Media import Test.Links import Test.NoOverloadedStrings +import Test.InternalRequest main :: IO () -main = hspecX $ descriptions $ +main = hspecX $ descriptions $ [ cleanPathTest , exceptionsTest , widgetTest , mediaTest , linksTest , noOverloadedTest + , internalRequestTest ] diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index b2b9bbe3..9e73aef9 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -65,6 +65,7 @@ library Yesod.Request Yesod.Widget Yesod.Message + Yesod.Internal.TestApi other-modules: Yesod.Internal Yesod.Internal.Core Yesod.Internal.Session @@ -101,6 +102,7 @@ test-suite runtests ,shakespeare-js ,text ,http-types + , random ,HUnit ,QuickCheck >= 2 && < 3 ghc-options: -Wall