From 864abd6ed1f7c4ef50b779af3a349546dd8af738 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bjo=CC=88rn=20Buckwalter?= Date: Mon, 12 Sep 2011 00:16:01 +0800 Subject: [PATCH 01/18] Clean up nonce generation. --- yesod-core/Yesod/Internal/Request.hs | 17 +++++------------ 1 file changed, 5 insertions(+), 12 deletions(-) diff --git a/yesod-core/Yesod/Internal/Request.hs b/yesod-core/Yesod/Internal/Request.hs index d9ec7d74..73b45e71 100644 --- a/yesod-core/Yesod/Internal/Request.hs +++ b/yesod-core/Yesod/Internal/Request.hs @@ -6,11 +6,12 @@ module Yesod.Internal.Request , FileInfo (..) ) 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 (randomRs, newStdGen) import Web.Cookie (parseCookiesText) import Data.Monoid (mempty) import qualified Data.ByteString.Char8 as S8 @@ -54,19 +55,11 @@ parseWaiRequest env session' key' = do 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 + _ -> Just . pack . randomString 10 <$> newStdGen let gets'' = map (second $ fromMaybe "") gets' 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'') + randomString len = map toChar . take len . randomRs (0, 61) toChar i | i < 26 = toEnum $ i + fromEnum 'A' | i < 52 = toEnum $ i + fromEnum 'a' - 26 From ffefbb41b9d7aa819fa1317613635e8a73c6b89d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bjo=CC=88rn=20Buckwalter?= Date: Thu, 15 Sep 2011 15:13:54 +0800 Subject: [PATCH 02/18] Aestetic reordering of composed functions. --- yesod-core/Yesod/Internal/Request.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-core/Yesod/Internal/Request.hs b/yesod-core/Yesod/Internal/Request.hs index 73b45e71..b1e242c1 100644 --- a/yesod-core/Yesod/Internal/Request.hs +++ b/yesod-core/Yesod/Internal/Request.hs @@ -59,7 +59,7 @@ parseWaiRequest env session' key' = do let gets'' = map (second $ fromMaybe "") gets' return $ Request gets'' cookies' env langs''' nonce where - randomString len = map toChar . take len . randomRs (0, 61) + randomString len = take len . map toChar . randomRs (0, 61) toChar i | i < 26 = toEnum $ i + fromEnum 'A' | i < 52 = toEnum $ i + fromEnum 'a' - 26 From 884c363ebfd22a55082979be4cedf3c531771aa1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bjo=CC=88rn=20Buckwalter?= Date: Fri, 16 Sep 2011 11:36:00 +0800 Subject: [PATCH 03/18] 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' From 4d55332afca2b4ae105a0aabde5e87e1b6a2b8dd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bjo=CC=88rn=20Buckwalter?= Date: Fri, 16 Sep 2011 11:44:03 +0800 Subject: [PATCH 04/18] Break out randomString for testing in isolation. --- yesod-core/Yesod/Internal/Request.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/yesod-core/Yesod/Internal/Request.hs b/yesod-core/Yesod/Internal/Request.hs index c2265c24..8db60f88 100644 --- a/yesod-core/Yesod/Internal/Request.hs +++ b/yesod-core/Yesod/Internal/Request.hs @@ -67,7 +67,13 @@ parseWaiRequest' env session' key' gen = Request gets'' cookies' env langs''' no (Nothing, _) -> Nothing (_, Just x) -> Just x _ -> Just $ pack $ randomString 10 gen - randomString len = take len . map toChar . randomRs (0, 61) + +-- | 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 | i < 26 = toEnum $ i + fromEnum 'A' | i < 52 = toEnum $ i + fromEnum 'a' - 26 From 817ab988e00a72cf6a66cb2a8741fb3228def7ef Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bjo=CC=88rn=20Buckwalter?= Date: Fri, 16 Sep 2011 12:01:15 +0800 Subject: [PATCH 05/18] Comment explaining the behavior of nonce. Someone should confirm that this the intended behavior! --- yesod-core/Yesod/Internal/Request.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/yesod-core/Yesod/Internal/Request.hs b/yesod-core/Yesod/Internal/Request.hs index 8db60f88..43040b45 100644 --- a/yesod-core/Yesod/Internal/Request.hs +++ b/yesod-core/Yesod/Internal/Request.hs @@ -63,6 +63,10 @@ parseWaiRequest' env session' key' gen = Request gets'' cookies' env langs''' no Nothing -> langs'' Just x -> x : langs'' gets'' = map (second $ fromMaybe "") gets' + -- 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 From b83029dc36fc40a939e654272dcf1836356dded0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bjo=CC=88rn=20Buckwalter?= Date: Fri, 16 Sep 2011 20:29:46 +0800 Subject: [PATCH 06/18] Add test suite for Yesod.Internal.Request. --- yesod-core/Yesod/Internal/Request.hs | 5 ++ yesod-core/test/Test/InternalRequest.hs | 89 +++++++++++++++++++++++++ 2 files changed, 94 insertions(+) create mode 100644 yesod-core/test/Test/InternalRequest.hs diff --git a/yesod-core/Yesod/Internal/Request.hs b/yesod-core/Yesod/Internal/Request.hs index 43040b45..49c3be18 100644 --- a/yesod-core/Yesod/Internal/Request.hs +++ b/yesod-core/Yesod/Internal/Request.hs @@ -1,9 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} module Yesod.Internal.Request ( parseWaiRequest , Request (..) , RequestBodyContents , FileInfo (..) +#ifdef TEST + , randomString + , parseWaiRequest' +#endif ) where import Control.Applicative ((<$>)) diff --git a/yesod-core/test/Test/InternalRequest.hs b/yesod-core/test/Test/InternalRequest.hs new file mode 100644 index 00000000..215d467a --- /dev/null +++ b/yesod-core/test/Test/InternalRequest.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE OverloadedStrings #-} +module Test.InternalRequest where + +import Data.List (nub) +import System.Random (StdGen, mkStdGen) +import Control.Applicative ((<$>)) + +import Blaze.ByteString.Builder + +import Yesod.Internal.Request +import Network.Wai as W +import Network.Wai.Test +import Web.Cookie (renderCookies) +import Test.Hspec +import Test.Hspec.HUnit + + +randomStringSpecs :: [Spec] +randomStringSpecs = describe "Yesod.Internal.Request.randomString" + [ it "does not repeat itself" $ noRepeat 10 100 + ] + +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" respectAcceptLang + , it "respects sessions" respectSessionLang + , it "respects cookies" respectCookieLang + , it "respects queries" respectQueryLang + , it "prioritizes correctly" prioritizeLangs + ] + +respectAcceptLang = 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", toByteString $ renderCookies [("_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", toByteString $ renderCookies [("_LANG", "cookie")]) + ] + , queryString = [("_LANG", Just "query")] + } [("_LANG", "session")] Nothing g + + +internalRequestTest :: [Spec] +internalRequestTest = descriptions [ randomStringSpecs + , nonceSpecs + , langSpecs + ] From f925fa28ecaed65060a75b044a4ccd4fa2a20c16 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bjo=CC=88rn=20Buckwalter?= Date: Sat, 17 Sep 2011 00:04:02 +0800 Subject: [PATCH 07/18] Manual cookies to reduce dependencies. --- yesod-core/test/Test/InternalRequest.hs | 20 ++++++++------------ 1 file changed, 8 insertions(+), 12 deletions(-) diff --git a/yesod-core/test/Test/InternalRequest.hs b/yesod-core/test/Test/InternalRequest.hs index 215d467a..57ed9799 100644 --- a/yesod-core/test/Test/InternalRequest.hs +++ b/yesod-core/test/Test/InternalRequest.hs @@ -1,19 +1,13 @@ {-# LANGUAGE OverloadedStrings #-} -module Test.InternalRequest where +module Test.InternalRequest (internalRequestTest) where import Data.List (nub) import System.Random (StdGen, mkStdGen) -import Control.Applicative ((<$>)) -import Blaze.ByteString.Builder - -import Yesod.Internal.Request import Network.Wai as W import Network.Wai.Test -import Web.Cookie (renderCookies) +import Yesod.Internal.TestApi import Test.Hspec -import Test.Hspec.HUnit - randomStringSpecs :: [Spec] randomStringSpecs = describe "Yesod.Internal.Request.randomString" @@ -51,14 +45,14 @@ generateNonce = reqNonce r /= Nothing where langSpecs :: [Spec] langSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqLangs)" - [ it "respects Accept-Language" respectAcceptLang + [ it "respects Accept-Language" respectAcceptLangs , it "respects sessions" respectSessionLang , it "respects cookies" respectCookieLang , it "respects queries" respectQueryLang , it "prioritizes correctly" prioritizeLangs ] -respectAcceptLang = reqLangs r == ["accept1", "accept2"] where +respectAcceptLangs = reqLangs r == ["accept1", "accept2"] where r = parseWaiRequest' defaultRequest { requestHeaders = [("Accept-Language", "accept1, accept2")] } [] Nothing g @@ -67,7 +61,7 @@ respectSessionLang = reqLangs r == ["session"] where respectCookieLang = reqLangs r == ["cookie"] where r = parseWaiRequest' defaultRequest - { requestHeaders = [("Cookie", toByteString $ renderCookies [("_LANG", "cookie")])] + { requestHeaders = [("Cookie", "_LANG=cookie")] } [] Nothing g respectQueryLang = reqLangs r == ["query"] where @@ -76,7 +70,7 @@ respectQueryLang = reqLangs r == ["query"] where prioritizeLangs = reqLangs r == ["query", "cookie", "session", "accept1", "accept2"] where r = parseWaiRequest' defaultRequest { requestHeaders = [ ("Accept-Language", "accept1, accept2") - , ("Cookie", toByteString $ renderCookies [("_LANG", "cookie")]) + , ("Cookie", "_LANG=cookie") ] , queryString = [("_LANG", Just "query")] } [("_LANG", "session")] Nothing g @@ -87,3 +81,5 @@ internalRequestTest = descriptions [ randomStringSpecs , nonceSpecs , langSpecs ] + +main = hspec internalRequestTest From 4ed740724ead428208bc920755cc12cd8ee550b2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bjo=CC=88rn=20Buckwalter?= Date: Sat, 17 Sep 2011 00:06:31 +0800 Subject: [PATCH 08/18] Yesod.Internal.TestApi exports internals for tests --- yesod-core/Yesod/Internal/Request.hs | 6 ++---- yesod-core/Yesod/Internal/TestApi.hs | 10 ++++++++++ yesod-core/test/main.hs | 4 +++- yesod-core/yesod-core.cabal | 2 ++ 4 files changed, 17 insertions(+), 5 deletions(-) create mode 100644 yesod-core/Yesod/Internal/TestApi.hs diff --git a/yesod-core/Yesod/Internal/Request.hs b/yesod-core/Yesod/Internal/Request.hs index 49c3be18..6470e3f9 100644 --- a/yesod-core/Yesod/Internal/Request.hs +++ b/yesod-core/Yesod/Internal/Request.hs @@ -5,10 +5,9 @@ module Yesod.Internal.Request , Request (..) , RequestBodyContents , FileInfo (..) -#ifdef TEST + -- The below are exported for testing. , randomString , parseWaiRequest' -#endif ) where import Control.Applicative ((<$>)) @@ -41,8 +40,7 @@ parseWaiRequest :: W.Request -> [(Text, Text)] -- ^ session -> Maybe a -> IO Request -parseWaiRequest env session' key' = parseWaiRequest' env session' key' - <$> newStdGen +parseWaiRequest env session' key' = parseWaiRequest' env session' key' <$> newStdGen parseWaiRequest' :: RandomGen g => W.Request diff --git a/yesod-core/Yesod/Internal/TestApi.hs b/yesod-core/Yesod/Internal/TestApi.hs new file mode 100644 index 00000000..2e0db12d --- /dev/null +++ b/yesod-core/Yesod/Internal/TestApi.hs @@ -0,0 +1,10 @@ +-- +-- | WARNING: This module exposes internal interfaces solely for the +-- purpose of facilitating unit testing with cabal install. Library +-- users should not import this module. +-- +module Yesod.Internal.TestApi + ( Request (..), randomString, parseWaiRequest' + ) where + +import Yesod.Internal.Request (Request (..), randomString, parseWaiRequest') 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 233b95c6..8ac3de66 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 From 33ee15d56facfc5204b5c4dbade95b44e428bc8b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bjo=CC=88rn=20Buckwalter?= Date: Sat, 17 Sep 2011 00:43:16 +0800 Subject: [PATCH 09/18] Shorter more readable toChar. --- yesod-core/Yesod/Internal/Request.hs | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/yesod-core/Yesod/Internal/Request.hs b/yesod-core/Yesod/Internal/Request.hs index 6470e3f9..d447b5ba 100644 --- a/yesod-core/Yesod/Internal/Request.hs +++ b/yesod-core/Yesod/Internal/Request.hs @@ -81,10 +81,7 @@ parseWaiRequest' env session' key' gen = Request gets'' cookies' env langs''' no randomString :: RandomGen g => Int -> g -> String randomString len = take len . map toChar . randomRs (0, 61) where - toChar i - | i < 26 = toEnum $ i + fromEnum 'A' - | i < 52 = toEnum $ i + fromEnum 'a' - 26 - | otherwise = toEnum $ i + fromEnum '0' - 52 + toChar i = (['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9']) !! i -- | A tuple containing both the POST parameters and submitted files. type RequestBodyContents = From 09017eb29a2d373b157a2b3fa83e6903d23346ef Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bjo=CC=88rn=20Buckwalter?= Date: Sat, 17 Sep 2011 01:02:26 +0800 Subject: [PATCH 10/18] Clearer language prioritization code. --- yesod-core/Yesod/Internal/Request.hs | 22 +++++++++------------- 1 file changed, 9 insertions(+), 13 deletions(-) diff --git a/yesod-core/Yesod/Internal/Request.hs b/yesod-core/Yesod/Internal/Request.hs index d447b5ba..4d275b76 100644 --- a/yesod-core/Yesod/Internal/Request.hs +++ b/yesod-core/Yesod/Internal/Request.hs @@ -22,7 +22,7 @@ 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. @@ -48,7 +48,7 @@ parseWaiRequest' :: RandomGen g -> Maybe a -> g -> Request -parseWaiRequest' env session' key' gen = Request gets'' cookies' env langs''' nonce +parseWaiRequest' env session' key' gen = Request gets'' cookies' env langs' nonce where gets' = queryToQueryText $ W.queryString env reqCookie = fromMaybe mempty $ lookup "Cookie" @@ -56,15 +56,11 @@ parseWaiRequest' env session' key' gen = Request gets'' cookies' env langs''' no 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'' + -- 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) gets'' = map (second $ fromMaybe "") gets' -- If the session is not secure a nonce should not be -- used (any nonce present in the session is ignored). @@ -72,8 +68,8 @@ parseWaiRequest' env session' key' gen = Request gets'' cookies' env langs''' no -- generated. nonce = case (key', lookup nonceKey session') of (Nothing, _) -> Nothing - (_, Just x) -> Just x - _ -> Just $ pack $ randomString 10 gen + (_, 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 From 5cec074cfbf450b96ce1de8a6fac161959700b40 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bjo=CC=88rn=20Buckwalter?= Date: Sat, 17 Sep 2011 01:19:03 +0800 Subject: [PATCH 11/18] Harmonize reqCookie and acceptLang. --- yesod-core/Yesod/Internal/Request.hs | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/yesod-core/Yesod/Internal/Request.hs b/yesod-core/Yesod/Internal/Request.hs index 4d275b76..8825d27e 100644 --- a/yesod-core/Yesod/Internal/Request.hs +++ b/yesod-core/Yesod/Internal/Request.hs @@ -17,7 +17,6 @@ import Yesod.Internal import qualified Network.Wai as W 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) @@ -51,9 +50,9 @@ parseWaiRequest' :: RandomGen g 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 + 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: @@ -61,7 +60,6 @@ parseWaiRequest' env session' key' gen = Request gets'' cookies' env langs' nonc , lookup langKey cookies' -- Cookie _LANG , lookup langKey session' -- Session _LANG ] ++ langs -- Accept-Language(s) - gets'' = map (second $ fromMaybe "") gets' -- 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 From 7b3d69f6579b7a376843a12aacdbaf198a7f9e0d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bjo=CC=88rn=20Buckwalter?= Date: Sat, 17 Sep 2011 01:48:02 +0800 Subject: [PATCH 12/18] TestApi: improve docs and remove Request (..). --- yesod-core/Yesod/Internal/TestApi.hs | 9 +++++---- yesod-core/test/Test/InternalRequest.hs | 3 ++- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/yesod-core/Yesod/Internal/TestApi.hs b/yesod-core/Yesod/Internal/TestApi.hs index 2e0db12d..ffb1387e 100644 --- a/yesod-core/Yesod/Internal/TestApi.hs +++ b/yesod-core/Yesod/Internal/TestApi.hs @@ -1,10 +1,11 @@ -- -- | WARNING: This module exposes internal interfaces solely for the --- purpose of facilitating unit testing with cabal install. Library --- users should not import this module. +-- 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 - ( Request (..), randomString, parseWaiRequest' + ( randomString, parseWaiRequest' ) where -import Yesod.Internal.Request (Request (..), randomString, parseWaiRequest') +import Yesod.Internal.Request (randomString, parseWaiRequest') diff --git a/yesod-core/test/Test/InternalRequest.hs b/yesod-core/test/Test/InternalRequest.hs index 57ed9799..c48df2e1 100644 --- a/yesod-core/test/Test/InternalRequest.hs +++ b/yesod-core/test/Test/InternalRequest.hs @@ -6,7 +6,8 @@ import System.Random (StdGen, mkStdGen) import Network.Wai as W import Network.Wai.Test -import Yesod.Internal.TestApi +import Yesod.Internal.TestApi (randomString, parseWaiRequest') +import Yesod.Request (Request (..)) import Test.Hspec randomStringSpecs :: [Spec] From c9cb50b34b141ab08c4f5f95a15e0242bc750a2a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bjo=CC=88rn=20Buckwalter?= Date: Sat, 17 Sep 2011 11:03:29 +0800 Subject: [PATCH 13/18] Spec for "reasonably random" appearance. --- yesod-core/test/Test/InternalRequest.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/yesod-core/test/Test/InternalRequest.hs b/yesod-core/test/Test/InternalRequest.hs index c48df2e1..ba510cb5 100644 --- a/yesod-core/test/Test/InternalRequest.hs +++ b/yesod-core/test/Test/InternalRequest.hs @@ -12,9 +12,14 @@ import Test.Hspec randomStringSpecs :: [Spec] randomStringSpecs = describe "Yesod.Internal.Request.randomString" - [ it "does not repeat itself" $ noRepeat 10 100 + [ 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 From d2e93341c0762e3996bd6bde28f5a268bd14fbc8 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 20 Sep 2011 10:25:26 +0300 Subject: [PATCH 14/18] OptionList --- yesod-form/Yesod/Form/Fields.hs | 32 +++++++++++++++++++++++--------- 1 file changed, 23 insertions(+), 9 deletions(-) diff --git a/yesod-form/Yesod/Form/Fields.hs b/yesod-form/Yesod/Form/Fields.hs index 32dfb93f..6ea1db92 100644 --- a/yesod-form/Yesod/Form/Fields.hs +++ b/yesod-form/Yesod/Form/Fields.hs @@ -35,6 +35,8 @@ module Yesod.Form.Fields , selectField' , radioField' , Option (..) + , OptionList (..) + , mkOptionList , optionsPersist , optionsPairs , optionsEnum @@ -76,6 +78,7 @@ import Yesod.Request (FileInfo) import Yesod.Core (toSinglePiece, GGHandler, SinglePiece) import Yesod.Persist (selectList, runDB, Filter, SelectOpt, YesodPersistBackend, Key, YesodPersist, PersistEntity, PersistBackend) +import Control.Arrow ((&&&)) #if __GLASGOW_HASKELL__ >= 700 #define WHAMLET whamlet @@ -303,7 +306,7 @@ urlField = Field selectField :: (Eq a, RenderMessage master FormMessage) => [(Text, a)] -> Field sub master a selectField = selectField' . optionsPairs -selectField' :: (Eq a, RenderMessage master FormMessage) => GGHandler sub master IO [Option a] -> Field sub master a +selectField' :: (Eq a, RenderMessage master FormMessage) => GGHandler sub master IO (OptionList a) -> Field sub master a selectField' = selectFieldHelper (\theId name inside -> [WHAMLET|