Fix merge conflict, exposed modules

scripts

@@ -1 +1 @@
-Subproject commit f56426fada59012329f23c928a2d7f9c3a515d75
+Subproject commit e791ced0395245e30d37b5098a27bba5e818ecb7

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
+parseWaiRequest env session' key' = parseWaiRequest' env session' key' <$> newStdGen
-    let gets' = queryToQueryText $ W.queryString env
+
-    let reqCookie = fromMaybe mempty $ lookup "Cookie"
+parseWaiRequest' :: RandomGen g
-                  $ W.requestHeaders env
+                 => W.Request
-        cookies' = parseCookiesText reqCookie
+                 -> [(Text, Text)] -- ^ session
-        acceptLang = lookup "Accept-Language" $ W.requestHeaders env
+                 -> Maybe a
-        langs = map (pack . S8.unpack) $ maybe [] NWP.parseHttpAccept acceptLang
+                 -> g
-        langs' = case lookup langKey session' of
+                 -> Request
-                    Nothing -> langs
+parseWaiRequest' env session' key' gen = Request gets'' cookies' env langs' nonce
-                    Just x -> x : langs
+  where
-        langs'' = case lookup langKey cookies' of
+    gets' = queryToQueryText $ W.queryString env
-                    Nothing -> langs'
+    gets'' = map (second $ fromMaybe "") gets'
-                    Just x -> x : langs'
+    reqCookie = lookup "Cookie" $ W.requestHeaders env
-        langs''' = case join $ lookup langKey gets' of
+    cookies' = maybe [] parseCookiesText reqCookie
-                     Nothing -> langs''
+    acceptLang = lookup "Accept-Language" $ W.requestHeaders env
-                     Just x -> x : langs''
+    langs = map (pack . S8.unpack) $ maybe [] NWP.parseHttpAccept acceptLang
-    nonce <- case (key', lookup nonceKey session') of
+    -- The language preferences are prioritized as follows:
-                (Nothing, _) -> return Nothing
+    langs' = catMaybes [ join $ lookup langKey gets' -- Query _LANG
-                (_, Just x) -> return $ Just x
+                       , lookup langKey cookies'     -- Cookie _LANG
-                (_, Nothing) -> do
+                       , lookup langKey session'     -- Session _LANG
-                    g <- newStdGen
+                       ] ++ langs                    -- Accept-Language(s)
-                    return $ Just $ pack $ fst $ randomString 10 g
+    -- If sessions are disabled nonces should not be used (any
-    let gets'' = map (second $ fromMaybe "") gets'
+    -- nonceKey present in the session is ignored). If sessions
-    return $ Request gets'' cookies' env langs''' nonce
+    -- 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

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')

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

yesod-core/test/main.hs

@@ -6,6 +6,7 @@ import Test.Widget
 import Test.Media
 import Test.Links
 import Test.NoOverloadedStrings
+import Test.InternalRequest
 
 main :: IO ()
 main = hspecX $ descriptions $
@@ -15,4 +16,5 @@ main = hspecX $ descriptions $
     , mediaTest
     , linksTest
     , noOverloadedTest
+    , internalRequestTest
     ]

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

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|<select ##{theId} name=#{name}>^{inside}|]) -- outside
     (\_theId _name isSel -> [WHAMLET|<option value=none :isSel:selected>_{MsgSelectNone}|]) -- onOpt
@@ -317,7 +320,7 @@ multiSelectField = multiSelectFieldHelper
 radioField :: (Eq a, RenderMessage master FormMessage) => [(Text, a)] -> Field sub master a
 radioField = radioField' . optionsPairs
 
-radioField' :: (Eq a, RenderMessage master FormMessage) => GGHandler sub master IO [Option a] -> Field sub master a
+radioField' :: (Eq a, RenderMessage master FormMessage) => GGHandler sub master IO (OptionList a) -> Field sub master a
 radioField' = selectFieldHelper
     (\theId _name inside -> [WHAMLET|<div ##{theId}>^{inside}|])
     (\theId name isSel -> [WHAMLET|
@@ -380,27 +383,38 @@ multiSelectFieldHelper outside inside opts = Field
     selectParser xs | not $ null (["", "none"] `intersect` xs) = Right Nothing
                     | otherwise = (Right . Just . map snd . catMaybes . map (\y -> lookup y pairs) . nub . map fst . rights . map Data.Text.Read.decimal) xs
 
+data OptionList a = OptionList
+    { olOptions :: [Option a]
+    , olReadExternal :: Text -> Maybe a
+    }
+
+mkOptionList :: [Option a] -> OptionList a
+mkOptionList os = OptionList
+    { olOptions = os
+    , olReadExternal = flip Map.lookup $ Map.fromList $ map (optionExternalValue &&& optionInternalValue) os
+    }
+
 data Option a = Option
     { optionDisplay :: Text
     , optionInternalValue :: a
     , optionExternalValue :: Text
     }
 
-optionsPairs :: [(Text, a)] -> GGHandler sub master IO [Option a]
+optionsPairs :: [(Text, a)] -> GGHandler sub master IO (OptionList a)
-optionsPairs = return . zipWith (\external (display, internal) -> Option
+optionsPairs = return . mkOptionList . zipWith (\external (display, internal) -> Option
     { optionDisplay = display
     , optionInternalValue = internal
     , optionExternalValue = pack $ show external
     }) [1 :: Int ..]
 
-optionsEnum :: (Show a, Enum a, Bounded a) => GGHandler sub master IO [Option a]
+optionsEnum :: (Show a, Enum a, Bounded a) => GGHandler sub master IO (OptionList a)
 optionsEnum = optionsPairs $ map (\x -> (pack $ show x, x)) [minBound..maxBound]
 
 optionsPersist :: ( YesodPersist master, PersistEntity a, PersistBackend (YesodPersistBackend master) (GGHandler sub master IO)
                   , SinglePiece (Key (YesodPersistBackend master) a)
                   )
-               => [Filter a] -> [SelectOpt a] -> (a -> Text) -> GGHandler sub master IO [Option (Key (YesodPersistBackend master) a, a)]
+               => [Filter a] -> [SelectOpt a] -> (a -> Text) -> GGHandler sub master IO (OptionList (Key (YesodPersistBackend master) a, a))
-optionsPersist filts ords toDisplay = do
+optionsPersist filts ords toDisplay = fmap mkOptionList $ do
     pairs <- runDB $ selectList filts ords
     return $ map (\(key, value) -> Option
         { optionDisplay = toDisplay value
@@ -413,13 +427,13 @@ selectFieldHelper
         => (Text -> Text -> GWidget sub master () -> GWidget sub master ())
         -> (Text -> Text -> Bool -> GWidget sub master ())
         -> (Text -> Text -> Text -> Bool -> Text -> GWidget sub master ())
-        -> GGHandler sub master IO [Option a] -> Field sub master a
+        -> GGHandler sub master IO (OptionList a) -> Field sub master a
 selectFieldHelper outside onOpt inside opts' = Field
     { fieldParse = \x -> do
         opts <- opts'
         return $ selectParser opts x
     , fieldView = \theId name val isReq -> do
-        opts <- lift $ liftIOHandler opts'
+        opts <- fmap olOptions $ lift $ liftIOHandler opts'
         outside theId name $ do
             unless isReq $ onOpt theId name $ not $ render opts val `elem` map optionExternalValue opts
             flip mapM_ opts $ \opt -> inside
@@ -436,9 +450,9 @@ selectFieldHelper outside onOpt inside opts' = Field
     selectParser opts (s:_) = case s of
             "" -> Right Nothing
             "none" -> Right Nothing
-            x -> case listToMaybe $ filter ((== x) . optionExternalValue) opts of
+            x -> case olReadExternal opts x of
                     Nothing -> Left $ SomeMessage $ MsgInvalidEntry x
-                    Just y -> Right $ Just $ optionInternalValue y
+                    Just y -> Right $ Just y
 
 fileAFormReq :: (RenderMessage master msg, RenderMessage master FormMessage) => FieldSettings msg -> AForm sub master FileInfo
 fileAFormReq fs = AForm $ \(master, langs) menvs ints -> do