Initial YesodRequest/YesodRespnse change
This commit is contained in:
parent
4f1a6b461e
commit
1bd193f642
@ -86,17 +86,37 @@ data ClientSessionDateCache =
|
||||
, csdcExpiresSerialized :: !ByteString
|
||||
} deriving (Eq, Show)
|
||||
|
||||
-- | The parsed request information.
|
||||
data Request = Request
|
||||
{ reqGetParams :: [(Text, Text)]
|
||||
, reqCookies :: [(Text, Text)]
|
||||
, reqWaiRequest :: W.Request
|
||||
-- | Languages which the client supports.
|
||||
, reqLangs :: [Text]
|
||||
-- | A random, session-specific token used to prevent CSRF attacks.
|
||||
, reqToken :: Maybe Text
|
||||
-- | The parsed request information. This type augments the standard WAI
|
||||
-- 'W.Request' with additional information.
|
||||
data YesodRequest = YesodRequest
|
||||
{ reqGetParams :: ![(Text, Text)]
|
||||
-- ^ Same as 'W.queryString', but decoded to @Text@.
|
||||
, reqCookies :: ![(Text, Text)]
|
||||
, reqWaiRequest :: !W.Request
|
||||
, reqLangs :: ![Text]
|
||||
-- ^ Languages which the client supports. This is an ordered list by preference.
|
||||
, reqToken :: !(Maybe Text)
|
||||
-- ^ A random, session-specific token used to prevent CSRF attacks.
|
||||
, reqSession :: !SessionMap
|
||||
-- ^ Initial session sent from the client.
|
||||
--
|
||||
-- Since 1.2.0
|
||||
, reqAccept :: ![ContentType]
|
||||
-- ^ An ordered list of the accepted content types.
|
||||
--
|
||||
-- Since 1.2.0
|
||||
, reqOnError :: !(ErrorResponse -> YesodApp)
|
||||
-- ^ How to respond when an error is thrown internally.
|
||||
--
|
||||
-- Since 1.2.0
|
||||
}
|
||||
|
||||
-- | An augmented WAI 'W.Response'. This can either be a standard @Response@,
|
||||
-- or a higher-level data structure which Yesod will turn into a @Response@.
|
||||
data YesodResponse
|
||||
= YRWai W.Response
|
||||
| YRPlain H.Status [Header] ContentType Content SessionMap
|
||||
|
||||
-- | A tuple containing both the POST parameters and submitted files.
|
||||
type RequestBodyContents =
|
||||
( [(Text, Text)]
|
||||
@ -150,7 +170,7 @@ type Texts = [Text]
|
||||
newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application }
|
||||
|
||||
data HandlerData sub master = HandlerData
|
||||
{ handlerRequest :: Request
|
||||
{ handlerRequest :: YesodRequest
|
||||
, handlerSub :: sub
|
||||
, handlerMaster :: master
|
||||
, handlerRoute :: Maybe (Route sub)
|
||||
@ -178,18 +198,7 @@ data GHState = GHState
|
||||
-- | An extension of the basic WAI 'W.Application' datatype to provide extra
|
||||
-- features needed by Yesod. Users should never need to use this directly, as
|
||||
-- the 'GHandler' monad and template haskell code should hide it away.
|
||||
newtype YesodApp = YesodApp
|
||||
{ unYesodApp
|
||||
:: (ErrorResponse -> YesodApp)
|
||||
-> Request
|
||||
-> [ContentType]
|
||||
-> SessionMap
|
||||
-> ResourceT IO YesodAppResult
|
||||
}
|
||||
|
||||
data YesodAppResult
|
||||
= YARWai W.Response
|
||||
| YARPlain H.Status [Header] ContentType Content SessionMap
|
||||
type YesodApp = YesodRequest -> ResourceT IO YesodResponse
|
||||
|
||||
-- | A generic widget, allowing specification of both the subsite and master
|
||||
-- site datatypes. While this is simply a @WriterT@, we define a newtype for
|
||||
|
||||
@ -106,7 +106,7 @@ module Yesod.Handler
|
||||
, cacheDelete
|
||||
-- * Internal Yesod
|
||||
, runHandler
|
||||
, YesodApp (..)
|
||||
, YesodApp
|
||||
, runSubsiteGetter
|
||||
, toMasterHandler
|
||||
, toMasterHandlerDyn
|
||||
@ -114,7 +114,6 @@ module Yesod.Handler
|
||||
, localNoCurrent
|
||||
, HandlerData
|
||||
, ErrorResponse (..)
|
||||
, YesodAppResult (..)
|
||||
, handlerToYAR
|
||||
, yarToResponse
|
||||
, headerToPair
|
||||
@ -146,10 +145,9 @@ import qualified Data.Text.Lazy as TL
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.ByteString as S
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import Network.Wai.Parse (parseHttpAccept)
|
||||
|
||||
import Yesod.Content
|
||||
import Data.Maybe (fromMaybe, mapMaybe)
|
||||
import Data.Maybe (mapMaybe)
|
||||
import Web.Cookie (SetCookie (..), renderSetCookie)
|
||||
import Control.Arrow ((***))
|
||||
import qualified Network.Wai.Parse as NWP
|
||||
@ -255,7 +253,7 @@ toMasterHandlerMaybe :: (Route sub -> Route master)
|
||||
-> GHandler sub' master a
|
||||
toMasterHandlerMaybe tm ts route = local (handlerSubDataMaybe tm ts route)
|
||||
|
||||
getRequest :: GHandler s m Request
|
||||
getRequest :: GHandler s m YesodRequest
|
||||
getRequest = handlerRequest `liftM` ask
|
||||
|
||||
hcError :: ErrorResponse -> GHandler sub master a
|
||||
@ -415,8 +413,7 @@ runHandler :: HasReps c
|
||||
-> (W.RequestBodyLength -> FileUpload)
|
||||
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
|
||||
-> YesodApp
|
||||
runHandler handler mrender sroute tomr master sub upload log' =
|
||||
YesodApp $ \eh rr cts initSession -> do
|
||||
runHandler handler mrender sroute tomr master sub upload log' req = do
|
||||
let toErrorHandler e =
|
||||
case fromException e of
|
||||
Just (HCError x) -> x
|
||||
@ -429,7 +426,7 @@ runHandler handler mrender sroute tomr master sub upload log' =
|
||||
, ghsHeaders = mempty
|
||||
}
|
||||
let hd = HandlerData
|
||||
{ handlerRequest = rr
|
||||
{ handlerRequest = req
|
||||
, handlerSub = sub
|
||||
, handlerMaster = master
|
||||
, handlerRoute = sroute
|
||||
@ -447,21 +444,24 @@ runHandler handler mrender sroute tomr master sub upload log' =
|
||||
let headers = ghsHeaders state
|
||||
let contents = either id (HCContent H.status200 . chooseRep) contents'
|
||||
let handleError e = do
|
||||
yar <- unYesodApp (eh e) safeEh rr cts finalSession
|
||||
yar <- eh e req
|
||||
{ reqOnError = safeEh
|
||||
, reqSession = finalSession
|
||||
}
|
||||
case yar of
|
||||
YARPlain _ hs ct c sess ->
|
||||
YRPlain _ hs ct c sess ->
|
||||
let hs' = appEndo headers hs
|
||||
in return $ YARPlain (getStatus e) hs' ct c sess
|
||||
YARWai _ -> return yar
|
||||
in return $ YRPlain (getStatus e) hs' ct c sess
|
||||
YRWai _ -> return yar
|
||||
let sendFile' ct fp p =
|
||||
return $ YARPlain H.status200 (appEndo headers []) ct (ContentFile fp p) finalSession
|
||||
return $ YRPlain H.status200 (appEndo headers []) ct (ContentFile fp p) finalSession
|
||||
case contents of
|
||||
HCContent status a -> do
|
||||
(ct, c) <- liftIO $ a cts
|
||||
ec' <- liftIO $ evaluateContent c
|
||||
case ec' of
|
||||
Left e -> handleError e
|
||||
Right c' -> return $ YARPlain status (appEndo headers []) ct c' finalSession
|
||||
Right c' -> return $ YRPlain status (appEndo headers []) ct c' finalSession
|
||||
HCError e -> handleError e
|
||||
HCRedirect status loc -> do
|
||||
let disable_caching x =
|
||||
@ -470,7 +470,7 @@ runHandler handler mrender sroute tomr master sub upload log' =
|
||||
: x
|
||||
hs = (if status /= H.movedPermanently301 then disable_caching else id)
|
||||
$ Header "Location" (encodeUtf8 loc) : appEndo headers []
|
||||
return $ YARPlain
|
||||
return $ YRPlain
|
||||
status hs typePlain emptyContent
|
||||
finalSession
|
||||
HCSendFile ct fp p -> catch
|
||||
@ -478,13 +478,17 @@ runHandler handler mrender sroute tomr master sub upload log' =
|
||||
(handleError . toErrorHandler)
|
||||
HCCreated loc -> do
|
||||
let hs = Header "Location" (encodeUtf8 loc) : appEndo headers []
|
||||
return $ YARPlain
|
||||
return $ YRPlain
|
||||
H.status201
|
||||
hs
|
||||
typePlain
|
||||
emptyContent
|
||||
finalSession
|
||||
HCWai r -> return $ YARWai r
|
||||
HCWai r -> return $ YRWai r
|
||||
where
|
||||
eh = reqOnError req
|
||||
cts = reqAccept req
|
||||
initSession = reqSession req
|
||||
|
||||
evaluateContent :: Content -> IO (Either ErrorResponse Content)
|
||||
evaluateContent (ContentBuilder b mlen) = Control.Exception.handle f $ do
|
||||
@ -496,14 +500,14 @@ evaluateContent (ContentBuilder b mlen) = Control.Exception.handle f $ do
|
||||
evaluateContent c = return (Right c)
|
||||
|
||||
safeEh :: ErrorResponse -> YesodApp
|
||||
safeEh er = YesodApp $ \_ _ _ session -> do
|
||||
safeEh er req = do
|
||||
liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er
|
||||
return $ YARPlain
|
||||
return $ YRPlain
|
||||
H.status500
|
||||
[]
|
||||
typePlain
|
||||
(toContent ("Internal Server Error" :: S.ByteString))
|
||||
session
|
||||
(reqSession req)
|
||||
|
||||
-- | Redirect to the given route.
|
||||
-- HTTP status code 303 for HTTP 1.1 clients and 302 for HTTP 1.0
|
||||
@ -806,6 +810,9 @@ instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, [(key, va
|
||||
r <- getUrlRenderParams
|
||||
return $ r url params
|
||||
|
||||
instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, Map.Map key val) where
|
||||
toTextUrl (url, params) = toTextUrl (url, Map.toList params)
|
||||
|
||||
localNoCurrent :: GHandler s m a -> GHandler s m a
|
||||
localNoCurrent =
|
||||
local (\hd -> hd { handlerRoute = Nothing })
|
||||
@ -832,22 +839,21 @@ handlerToYAR :: (HasReps a, HasReps b)
|
||||
-> (Route sub -> Route master)
|
||||
-> (Route master -> [(Text, Text)] -> Text) -- route renderer
|
||||
-> (ErrorResponse -> GHandler sub master a)
|
||||
-> Request
|
||||
-> YesodRequest
|
||||
-> Maybe (Route sub)
|
||||
-> SessionMap
|
||||
-> GHandler sub master b
|
||||
-> ResourceT IO YesodAppResult
|
||||
-> ResourceT IO YesodResponse
|
||||
handlerToYAR y s upload log' toMasterRoute render errorHandler rr murl sessionMap h =
|
||||
unYesodApp ya eh' rr types sessionMap
|
||||
ya rr { reqOnError = eh', reqSession = sessionMap }
|
||||
where
|
||||
ya = runHandler h render murl toMasterRoute y s upload log'
|
||||
eh' er = runHandler (errorHandler' er) render murl toMasterRoute y s upload log'
|
||||
types = httpAccept $ reqWaiRequest rr
|
||||
errorHandler' = localNoCurrent . errorHandler
|
||||
|
||||
yarToResponse :: YesodAppResult -> [(CI ByteString, ByteString)] -> W.Response
|
||||
yarToResponse (YARWai a) _ = a
|
||||
yarToResponse (YARPlain s hs _ c _) extraHeaders =
|
||||
yarToResponse :: YesodResponse -> [(CI ByteString, ByteString)] -> W.Response
|
||||
yarToResponse (YRWai a) _ = a
|
||||
yarToResponse (YRPlain s hs _ c _) extraHeaders =
|
||||
go c
|
||||
where
|
||||
finalHeaders = extraHeaders ++ map headerToPair hs
|
||||
@ -862,12 +868,6 @@ yarToResponse (YARPlain s hs _ c _) extraHeaders =
|
||||
go (ContentSource body) = W.ResponseSource s finalHeaders body
|
||||
go (ContentDontEvaluate c') = go c'
|
||||
|
||||
httpAccept :: W.Request -> [ContentType]
|
||||
httpAccept = parseHttpAccept
|
||||
. fromMaybe mempty
|
||||
. lookup "Accept"
|
||||
. W.requestHeaders
|
||||
|
||||
-- | Convert Header to a key/value pair.
|
||||
headerToPair :: Header
|
||||
-> (CI ByteString, ByteString)
|
||||
|
||||
@ -44,6 +44,8 @@ module Yesod.Internal.Core
|
||||
import Yesod.Content
|
||||
import Yesod.Handler hiding (lift, getExpires)
|
||||
import Control.Monad.Logger (logErrorS)
|
||||
import Control.Applicative ((<$>))
|
||||
import System.Random (newStdGen)
|
||||
|
||||
import Yesod.Routes.Class
|
||||
|
||||
@ -422,9 +424,10 @@ defaultYesodRunner logger handler' master sub murl toMasterRoute msb req
|
||||
| W.KnownLength len <- W.requestBodyLength req, maxLen < len = return tooLargeResponse
|
||||
| otherwise = do
|
||||
let dontSaveSession _ = return []
|
||||
let onError _ = error "FIXME: Yesod.Internal.Core.defaultYesodRunner.onError"
|
||||
(session, saveSession) <- liftIO $ do
|
||||
maybe (return (Map.empty, dontSaveSession)) (\sb -> sbLoadSession sb master req) msb
|
||||
rr <- liftIO $ parseWaiRequest req session (isJust msb) maxLen
|
||||
rr <- liftIO $ parseWaiRequest req session onError (isJust msb) maxLen <$> newStdGen
|
||||
let h = {-# SCC "h" #-} do
|
||||
case murl of
|
||||
Nothing -> handler
|
||||
@ -448,7 +451,7 @@ defaultYesodRunner logger handler' master sub murl toMasterRoute msb req
|
||||
yar <- handlerToYAR master sub (fileUpload master) log' toMasterRoute
|
||||
(yesodRender master ra) errorHandler rr murl sessionMap h
|
||||
extraHeaders <- case yar of
|
||||
(YARPlain _ _ ct _ newSess) -> do
|
||||
(YRPlain _ _ ct _ newSess) -> do
|
||||
let nsToken = maybe
|
||||
newSess
|
||||
(\n -> Map.insert tokenKey (TE.encodeUtf8 n) newSess)
|
||||
@ -800,7 +803,7 @@ runFakeHandler fakeSessionMap logger master handler = liftIO $ do
|
||||
ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result")
|
||||
let handler' = do liftIO . I.writeIORef ret . Right =<< handler
|
||||
return ()
|
||||
let YesodApp yapp =
|
||||
let yapp =
|
||||
runHandler
|
||||
handler'
|
||||
(yesodRender master $ resolveApproot master fakeWaiRequest)
|
||||
@ -810,15 +813,14 @@ runFakeHandler fakeSessionMap logger master handler = liftIO $ do
|
||||
master
|
||||
(fileUpload master)
|
||||
(messageLoggerSource master $ logger master)
|
||||
errHandler err =
|
||||
YesodApp $ \_ _ _ session -> do
|
||||
errHandler err req = do
|
||||
liftIO $ I.writeIORef ret (Left err)
|
||||
return $ YARPlain
|
||||
return $ YRPlain
|
||||
H.status500
|
||||
[]
|
||||
typePlain
|
||||
(toContent ("runFakeHandler: errHandler" :: S8.ByteString))
|
||||
session
|
||||
(reqSession req)
|
||||
fakeWaiRequest =
|
||||
W.Request
|
||||
{ W.requestMethod = "POST"
|
||||
@ -839,15 +841,17 @@ runFakeHandler fakeSessionMap logger master handler = liftIO $ do
|
||||
#endif
|
||||
}
|
||||
fakeRequest =
|
||||
Request
|
||||
YesodRequest
|
||||
{ reqGetParams = []
|
||||
, reqCookies = []
|
||||
, reqWaiRequest = fakeWaiRequest
|
||||
, reqLangs = []
|
||||
, reqToken = Just "NaN" -- not a nonce =)
|
||||
, reqOnError = errHandler
|
||||
, reqAccept = []
|
||||
, reqSession = fakeSessionMap
|
||||
}
|
||||
fakeContentType = []
|
||||
_ <- runResourceT $ yapp errHandler fakeRequest fakeContentType fakeSessionMap
|
||||
_ <- runResourceT $ yapp fakeRequest
|
||||
I.readIORef ret
|
||||
{-# WARNING runFakeHandler "Usually you should *not* use runFakeHandler unless you really understand how it works and why you need it." #-}
|
||||
|
||||
|
||||
@ -2,7 +2,6 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
module Yesod.Internal.Request
|
||||
( parseWaiRequest
|
||||
, Request (..)
|
||||
, RequestBodyContents
|
||||
, FileInfo
|
||||
, fileName
|
||||
@ -16,21 +15,18 @@ module Yesod.Internal.Request
|
||||
, tooLargeResponse
|
||||
-- The below are exported for testing.
|
||||
, randomString
|
||||
, parseWaiRequest'
|
||||
) where
|
||||
|
||||
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 (RandomGen, newStdGen, randomRs)
|
||||
import System.Random (RandomGen, randomRs)
|
||||
import Web.Cookie (parseCookiesText)
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
import Data.Text (Text, pack)
|
||||
import Network.HTTP.Types (queryToQueryText, Status (Status))
|
||||
import Control.Monad (join)
|
||||
import Data.Maybe (fromMaybe, catMaybes)
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.Set as Set
|
||||
@ -46,14 +42,6 @@ import Control.Exception (throwIO)
|
||||
import Yesod.Core.Types
|
||||
import qualified Data.Map as Map
|
||||
|
||||
parseWaiRequest :: W.Request
|
||||
-> SessionMap
|
||||
-> Bool
|
||||
-> Word64 -- ^ maximum allowed body size
|
||||
-> IO Request
|
||||
parseWaiRequest env session' useToken maxBodySize =
|
||||
parseWaiRequest' env session' useToken maxBodySize <$> newStdGen
|
||||
|
||||
-- | Impose a limit on the size of the request body.
|
||||
limitRequestBody :: Word64 -> W.Request -> W.Request
|
||||
limitRequestBody maxLen req =
|
||||
@ -79,29 +67,40 @@ tooLargeResponse = W.responseLBS
|
||||
[("Content-Type", "text/plain")]
|
||||
"Request body too large to be processed."
|
||||
|
||||
parseWaiRequest' :: RandomGen g
|
||||
=> W.Request
|
||||
-> SessionMap
|
||||
-> Bool
|
||||
-> Word64 -- ^ max body size
|
||||
-> g
|
||||
-> Request
|
||||
parseWaiRequest' env session' useToken maxBodySize gen =
|
||||
Request gets'' cookies' (limitRequestBody maxBodySize env) langs'' token
|
||||
parseWaiRequest :: RandomGen g
|
||||
=> W.Request
|
||||
-> SessionMap
|
||||
-> (ErrorResponse -> YesodApp)
|
||||
-> Bool
|
||||
-> Word64 -- ^ max body size
|
||||
-> g
|
||||
-> YesodRequest
|
||||
parseWaiRequest env session onError useToken maxBodySize gen =
|
||||
YesodRequest
|
||||
{ reqGetParams = gets
|
||||
, reqCookies = cookies
|
||||
, reqWaiRequest = limitRequestBody maxBodySize env
|
||||
, reqLangs = langs''
|
||||
, reqToken = token
|
||||
, reqSession = session
|
||||
, reqAccept = httpAccept env
|
||||
, reqOnError = onError
|
||||
}
|
||||
where
|
||||
gets' = queryToQueryText $ W.queryString env
|
||||
gets'' = map (second $ fromMaybe "") gets'
|
||||
gets = map (second $ fromMaybe "")
|
||||
$ queryToQueryText
|
||||
$ W.queryString env
|
||||
reqCookie = lookup "Cookie" $ W.requestHeaders env
|
||||
cookies' = maybe [] parseCookiesText reqCookie
|
||||
cookies = maybe [] parseCookiesText reqCookie
|
||||
acceptLang = lookup "Accept-Language" $ W.requestHeaders env
|
||||
langs = map (pack . S8.unpack) $ maybe [] NWP.parseHttpAccept acceptLang
|
||||
|
||||
lookupText k = fmap (decodeUtf8With lenientDecode) . Map.lookup k
|
||||
|
||||
-- The language preferences are prioritized as follows:
|
||||
langs' = catMaybes [ join $ lookup langKey gets' -- Query _LANG
|
||||
, lookup langKey cookies' -- Cookie _LANG
|
||||
, lookupText langKey session' -- Session _LANG
|
||||
langs' = catMaybes [ lookup langKey gets -- Query _LANG
|
||||
, lookup langKey cookies -- Cookie _LANG
|
||||
, lookupText langKey session -- Session _LANG
|
||||
] ++ langs -- Accept-Language(s)
|
||||
|
||||
-- Github issue #195. We want to add an extra two-letter version of any
|
||||
@ -117,7 +116,17 @@ parseWaiRequest' env session' useToken maxBodySize gen =
|
||||
else Just $ maybe
|
||||
(pack $ randomString 10 gen)
|
||||
(decodeUtf8With lenientDecode)
|
||||
(Map.lookup tokenKey session')
|
||||
(Map.lookup tokenKey session)
|
||||
|
||||
-- | Get the list of accepted content types from the WAI Request\'s Accept
|
||||
-- header.
|
||||
--
|
||||
-- Since 1.2.0
|
||||
httpAccept :: W.Request -> [ContentType]
|
||||
httpAccept = NWP.parseHttpAccept
|
||||
. fromMaybe S8.empty
|
||||
. lookup "Accept"
|
||||
. W.requestHeaders
|
||||
|
||||
addTwoLetters :: ([Text] -> [Text], Set.Set Text) -> [Text] -> [Text]
|
||||
addTwoLetters (toAdd, exist) [] =
|
||||
|
||||
@ -5,7 +5,7 @@
|
||||
-- imported by library users.
|
||||
--
|
||||
module Yesod.Internal.TestApi
|
||||
( randomString, parseWaiRequest'
|
||||
( randomString, parseWaiRequest
|
||||
) where
|
||||
|
||||
import Yesod.Internal.Request (randomString, parseWaiRequest')
|
||||
import Yesod.Internal.Request (randomString, parseWaiRequest)
|
||||
|
||||
@ -15,7 +15,7 @@ module Yesod.Request
|
||||
(
|
||||
-- * Request datatype
|
||||
RequestBodyContents
|
||||
, Request (..)
|
||||
, YesodRequest (..)
|
||||
, FileInfo
|
||||
, fileName
|
||||
, fileContentType
|
||||
@ -41,6 +41,7 @@ import Control.Monad (liftM)
|
||||
import Control.Monad.Instances () -- I'm missing the instance Monad ((->) r
|
||||
import Data.Maybe (listToMaybe)
|
||||
import Data.Text (Text)
|
||||
import Yesod.Core.Types
|
||||
|
||||
-- | Get the list of supported languages supplied by the user.
|
||||
--
|
||||
|
||||
@ -5,7 +5,7 @@ module YesodCoreTest.CleanPath (cleanPathTest, Widget) where
|
||||
|
||||
import Test.Hspec
|
||||
|
||||
import Yesod.Core hiding (Request)
|
||||
import Yesod.Core
|
||||
|
||||
import Network.Wai
|
||||
import Network.Wai.Test
|
||||
|
||||
@ -5,7 +5,7 @@ module YesodCoreTest.Exceptions (exceptionsTest, Widget) where
|
||||
|
||||
import Test.Hspec
|
||||
|
||||
import Yesod.Core hiding (Request)
|
||||
import Yesod.Core
|
||||
import Network.Wai
|
||||
import Network.Wai.Test
|
||||
import Network.HTTP.Types (status301)
|
||||
|
||||
@ -6,8 +6,8 @@ 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 Yesod.Internal.TestApi (randomString, parseWaiRequest)
|
||||
import Yesod.Request (YesodRequest (..))
|
||||
import Test.Hspec
|
||||
import Data.Monoid (mempty)
|
||||
import Data.Map (singleton)
|
||||
@ -40,19 +40,19 @@ tokenSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqToken)" $ do
|
||||
|
||||
noDisabledToken :: Bool
|
||||
noDisabledToken = reqToken r == Nothing where
|
||||
r = parseWaiRequest' defaultRequest mempty False 1000 g
|
||||
r = parseWaiRequest defaultRequest mempty onError False 1000 g
|
||||
|
||||
ignoreDisabledToken :: Bool
|
||||
ignoreDisabledToken = reqToken r == Nothing where
|
||||
r = parseWaiRequest' defaultRequest (singleton "_TOKEN" "old") False 1000 g
|
||||
r = parseWaiRequest defaultRequest (singleton "_TOKEN" "old") onError False 1000 g
|
||||
|
||||
useOldToken :: Bool
|
||||
useOldToken = reqToken r == Just "old" where
|
||||
r = parseWaiRequest' defaultRequest (singleton "_TOKEN" "old") True 1000 g
|
||||
r = parseWaiRequest defaultRequest (singleton "_TOKEN" "old") onError True 1000 g
|
||||
|
||||
generateToken :: Bool
|
||||
generateToken = reqToken r /= Nothing where
|
||||
r = parseWaiRequest' defaultRequest (singleton "_TOKEN" "old") True 1000 g
|
||||
r = parseWaiRequest defaultRequest (singleton "_TOKEN" "old") onError True 1000 g
|
||||
|
||||
|
||||
langSpecs :: Spec
|
||||
@ -65,32 +65,34 @@ langSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqLangs)" $ do
|
||||
|
||||
respectAcceptLangs :: Bool
|
||||
respectAcceptLangs = reqLangs r == ["en-US", "es", "en"] where
|
||||
r = parseWaiRequest' defaultRequest
|
||||
{ requestHeaders = [("Accept-Language", "en-US, es")] } mempty False 1000 g
|
||||
r = parseWaiRequest defaultRequest
|
||||
{ requestHeaders = [("Accept-Language", "en-US, es")] } mempty onError False 1000 g
|
||||
|
||||
respectSessionLang :: Bool
|
||||
respectSessionLang = reqLangs r == ["en"] where
|
||||
r = parseWaiRequest' defaultRequest (singleton "_LANG" "en") False 1000 g
|
||||
r = parseWaiRequest defaultRequest (singleton "_LANG" "en") onError False 1000 g
|
||||
|
||||
respectCookieLang :: Bool
|
||||
respectCookieLang = reqLangs r == ["en"] where
|
||||
r = parseWaiRequest' defaultRequest
|
||||
r = parseWaiRequest defaultRequest
|
||||
{ requestHeaders = [("Cookie", "_LANG=en")]
|
||||
} mempty False 1000 g
|
||||
} mempty onError False 1000 g
|
||||
|
||||
respectQueryLang :: Bool
|
||||
respectQueryLang = reqLangs r == ["en-US", "en"] where
|
||||
r = parseWaiRequest' defaultRequest { queryString = [("_LANG", Just "en-US")] } mempty False 1000 g
|
||||
r = parseWaiRequest defaultRequest { queryString = [("_LANG", Just "en-US")] } mempty onError False 1000 g
|
||||
|
||||
prioritizeLangs :: Bool
|
||||
prioritizeLangs = reqLangs r == ["en-QUERY", "en-COOKIE", "en-SESSION", "en", "es"] where
|
||||
r = parseWaiRequest' defaultRequest
|
||||
r = parseWaiRequest defaultRequest
|
||||
{ requestHeaders = [ ("Accept-Language", "en, es")
|
||||
, ("Cookie", "_LANG=en-COOKIE")
|
||||
]
|
||||
, queryString = [("_LANG", Just "en-QUERY")]
|
||||
} (singleton "_LANG" "en-SESSION") False 10000 g
|
||||
} (singleton "_LANG" "en-SESSION") onError False 10000 g
|
||||
|
||||
onError :: a
|
||||
onError = error "Yesod.InternalRequest.onError"
|
||||
|
||||
internalRequestTest :: Spec
|
||||
internalRequestTest = describe "Test.InternalRequestTest" $ do
|
||||
|
||||
@ -8,7 +8,7 @@ import YesodCoreTest.JsLoaderSites.Bottom (B(..))
|
||||
|
||||
import Test.Hspec
|
||||
|
||||
import Yesod.Core hiding (Request)
|
||||
import Yesod.Core
|
||||
import Network.Wai.Test
|
||||
|
||||
data H = H
|
||||
|
||||
@ -5,7 +5,7 @@ module YesodCoreTest.Links (linksTest, Widget) where
|
||||
|
||||
import Test.Hspec
|
||||
|
||||
import Yesod.Core hiding (Request)
|
||||
import Yesod.Core
|
||||
import Text.Hamlet
|
||||
import Network.Wai
|
||||
import Network.Wai.Test
|
||||
|
||||
@ -5,7 +5,7 @@
|
||||
module YesodCoreTest.Media (mediaTest, Widget) where
|
||||
|
||||
import Test.Hspec
|
||||
import Yesod.Core hiding (Request)
|
||||
import Yesod.Core
|
||||
import Network.Wai
|
||||
import Network.Wai.Test
|
||||
import Text.Lucius
|
||||
|
||||
@ -4,7 +4,7 @@ module YesodCoreTest.NoOverloadedStrings (noOverloadedTest, Widget) where
|
||||
|
||||
import Test.Hspec
|
||||
|
||||
import Yesod.Core hiding (Request)
|
||||
import Yesod.Core
|
||||
import Network.Wai.Test
|
||||
import Data.Monoid (mempty)
|
||||
|
||||
|
||||
@ -5,7 +5,7 @@ module YesodCoreTest.RequestBodySize (specs, Widget) where
|
||||
|
||||
import Test.Hspec
|
||||
|
||||
import Yesod.Core hiding (Request)
|
||||
import Yesod.Core
|
||||
|
||||
import Network.Wai
|
||||
import Network.Wai.Test
|
||||
|
||||
@ -5,7 +5,7 @@ module YesodCoreTest.Widget (widgetTest) where
|
||||
|
||||
import Test.Hspec
|
||||
|
||||
import Yesod.Core hiding (Request)
|
||||
import Yesod.Core
|
||||
import Text.Julius
|
||||
import Text.Lucius
|
||||
import Text.Hamlet
|
||||
|
||||
@ -9,7 +9,7 @@ module YesodCoreTest.YesodTest
|
||||
, module Test.Hspec
|
||||
) where
|
||||
|
||||
import Yesod.Core hiding (Request)
|
||||
import Yesod.Core
|
||||
import Network.Wai.Test
|
||||
import Network.Wai
|
||||
import Test.Hspec
|
||||
|
||||
Loading…
Reference in New Issue
Block a user