diff --git a/scripts b/scripts index f56426fa..e791ced0 160000 --- a/scripts +++ b/scripts @@ -1 +1 @@ -Subproject commit f56426fada59012329f23c928a2d7f9c3a515d75 +Subproject commit e791ced0395245e30d37b5098a27bba5e818ecb7 diff --git a/yesod-core/Yesod/Internal/Request.hs b/yesod-core/Yesod/Internal/Request.hs index d9ec7d74..263823d8 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,38 +39,42 @@ 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 + 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 sessions are disabled nonces should not be used (any + -- nonceKey present in the session is ignored). If sessions + -- are enabled and a 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 - 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 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 c7a7f2b3..1007919a 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -69,6 +69,7 @@ library Yesod.Widget Yesod.Message Yesod.Config + Yesod.Internal.TestApi other-modules: Yesod.Internal Yesod.Internal.Core Yesod.Internal.Session @@ -105,6 +106,7 @@ test-suite runtests ,shakespeare-js ,text ,http-types + , random ,HUnit ,QuickCheck >= 2 && < 3 ghc-options: -Wall diff --git a/yesod-form/Yesod/Form/Fields.hs b/yesod-form/Yesod/Form/Fields.hs index 32dfb93f..4d5bc805 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|