haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

wai 2.0

Browse Source
This commit is contained in:
Michael Snoyman 2013-08-19 12:51:47 +03:00
parent 01738f354f
commit 2d0f560bea
7 changed files with 84 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
yesod-core/Yesod/Core/Handler.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleInstances #-}
@ -229,11 +230,19 @@ runRequestBody = do
Just rbc -> return rbc
Nothing -> do
rr <- waiRequest
#if MIN_VERSION_wai(0, 2, 0)
rbc <- liftIO $ rbHelper upload rr
#else
rbc <- liftResourceT $ rbHelper upload rr
#endif
put x { ghsRBC = Just rbc }
return rbc
#if MIN_VERSION_wai(2, 0, 0)
rbHelper :: FileUpload -> W.Request -> IO RequestBodyContents
#else
rbHelper :: FileUpload -> W.Request -> ResourceT IO RequestBodyContents
#endif
rbHelper upload =
case upload of
FileUploadMemory s -> rbHelper' s mkFileInfoLBS
@ -243,7 +252,11 @@ rbHelper upload =
rbHelper' :: NWP.BackEnd x
-> (Text -> Text -> x -> FileInfo)
-> W.Request
#if MIN_VERSION_wai(2, 0, 0)
-> IO ([(Text, Text)], [(Text, FileInfo)])
#else
-> ResourceT IO ([(Text, Text)], [(Text, FileInfo)])
#endif
rbHelper' backend mkFI req =
(map fix1 *** mapMaybe fix2) <$> (NWP.parseRequestBody backend req)
where
@ -916,7 +929,7 @@ selectRep w = do
]) reps
-- match on the type for sub-type wildcards.
-- If the accept is text/* it should match a provided text/html
-- If the accept is text/ * it should match a provided text/html
mainTypeMap = Map.fromList $ reverse $ map
(\v@(ProvidedRep ct _) -> (fst $ contentTypeTypes ct, v)) reps
@ -972,7 +985,13 @@ provideRepType ct handler =
rawRequestBody :: MonadHandler m => Source m S.ByteString
rawRequestBody = do
req <- lift waiRequest
transPipe liftResourceT $ W.requestBody req
transPipe
#if MIN_VERSION_wai(0, 2, 0)
liftIO
#else
liftResourceT
#endif
(W.requestBody req)
-- | Stream the data from the file. Since Yesod 1.2, this has been generalized
-- to work in any @MonadResource@.

15
yesod-core/Yesod/Core/Internal/Response.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RankNTypes #-}
@ -12,6 +13,11 @@ import qualified Data.ByteString.Char8 as S8
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import Network.Wai
#if MIN_VERSION_wai(2, 0, 0)
import Data.Conduit (transPipe)
import Control.Monad.Trans.Resource (runInternalState)
import Network.Wai.Internal
#endif
import Prelude hiding (catch)
import Web.Cookie (renderSetCookie)
import Yesod.Core.Content
@ -30,9 +36,10 @@ yarToResponse :: Monad m
=> YesodResponse
-> (SessionMap -> m [Header]) -- ^ save session
-> YesodRequest
-> Request
-> m Response
yarToResponse (YRWai a) _ _ = return a
yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq = do
yarToResponse (YRWai a) _ _ _ = return a
yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq req = do
extraHeaders <- do
let nsToken = maybe
newSess
@ -47,7 +54,11 @@ yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq = do
let hs' = maybe finalHeaders finalHeaders' mlen
in ResponseBuilder s hs' b
go (ContentFile fp p) = ResponseFile s finalHeaders fp p
#if MIN_VERSION_wai(0, 2, 0)
go (ContentSource body) = ResponseSource s finalHeaders $ transPipe (flip runInternalState $ resourceInternalState req) body
#else
go (ContentSource body) = ResponseSource s finalHeaders body
#endif
go (ContentDontEvaluate c') = go c'
return $ go c
where

46
yesod-core/Yesod/Core/Internal/Run.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RankNTypes #-}
@ -15,7 +16,7 @@ import Control.Monad.IO.Class (MonadIO)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Logger (LogLevel (LevelError), LogSource,
liftLoc)
import Control.Monad.Trans.Resource (runResourceT, withInternalState, runInternalState)
import Control.Monad.Trans.Resource (runResourceT, withInternalState, runInternalState, getInternalState)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.IORef as I
@ -31,6 +32,9 @@ import Data.Text.Encoding.Error (lenientDecode)
import Language.Haskell.TH.Syntax (Loc, qLocation)
import qualified Network.HTTP.Types as H
import Network.Wai
#if MIN_VERSION_wai(0, 2, 0)
import Network.Wai.Internal
#endif
import Prelude hiding (catch)
import System.Log.FastLogger (Logger)
import System.Log.FastLogger (LogStr, toLogStr)
@ -161,9 +165,16 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do
ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result")
let handler' = do liftIO . I.writeIORef ret . Right =<< handler
return ()
#if MIN_VERSION_wai(0, 2, 0)
let yapp internalState = runHandler
#else
let yapp = runHandler
#endif
RunHandlerEnv
{ rheRender = yesodRender site $ resolveApproot site fakeWaiRequest
{ rheRender = yesodRender site $ resolveApproot site $ fakeWaiRequest
#if MIN_VERSION_wai(0, 2, 0)
internalState
#endif
, rheRoute = Nothing
, rheSite = site
, rheUpload = fileUpload site
@ -179,14 +190,22 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do
typePlain
(toContent ("runFakeHandler: errHandler" :: S8.ByteString))
(reqSession req)
fakeWaiRequest =
fakeWaiRequest
#if MIN_VERSION_wai(0, 2, 0)
internalState
#endif
=
Request
{ requestMethod = "POST"
, httpVersion = H.http11
, rawPathInfo = "/runFakeHandler/pathInfo"
, rawQueryString = ""
#if MIN_VERSION_wai(0, 2, 0)
, resourceInternalState = internalState
#else
, serverName = "runFakeHandler-serverName"
, serverPort = 80
#endif
, requestHeaders = []
, isSecure = False
, remoteHost = error "runFakeHandler-remoteHost"
@ -196,17 +215,30 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do
, vault = mempty
, requestBodyLength = KnownLength 0
}
#if MIN_VERSION_wai(0, 2, 0)
fakeRequest internalState =
#else
fakeRequest =
#endif
YesodRequest
{ reqGetParams = []
, reqCookies = []
, reqWaiRequest = fakeWaiRequest
#if MIN_VERSION_wai(0, 2, 0)
internalState
#endif
, reqLangs = []
, reqToken = Just "NaN" -- not a nonce =)
, reqAccept = []
, reqSession = fakeSessionMap
}
#if MIN_VERSION_wai(0, 2, 0)
_ <- runResourceT $ do
is <- getInternalState
yapp is $ fakeRequest is
#else
_ <- runResourceT $ yapp fakeRequest
#endif
I.readIORef ret
{-# WARNING runFakeHandler "Usually you should *not* use runFakeHandler unless you really understand how it works and why you need it." #-}
@ -243,8 +275,12 @@ yesodRunner handler' YesodRunnerEnv {..} route req
rhe = rheSafe
{ rheOnError = runHandler rheSafe . errorHandler
}
yar <- runHandler rhe handler yreq
liftIO $ yarToResponse yar saveSession yreq
yar <-
#if MIN_VERSION_wai(0, 2, 0)
flip runInternalState (resourceInternalState req) $
#endif
runHandler rhe handler yreq
liftIO $ yarToResponse yar saveSession yreq req
where
mmaxLen = maximumContentLength yreSite route
handler = yesodMiddleware handler'

4
yesod-core/yesod-core.cabal
View File

@ -26,8 +26,8 @@ library
build-depends: base >= 4.3 && < 5
, time >= 1.1.4
, yesod-routes >= 1.2 && < 1.3
, wai >= 1.4 && < 1.5
, wai-extra >= 1.3 && < 1.4
, wai >= 1.4
, wai-extra >= 1.3
, bytestring >= 0.9.1.4
, text >= 0.7 && < 0.12
, template-haskell

4
yesod-eventsource/yesod-eventsource.cabal
View File

@ -30,8 +30,8 @@ library
build-depends: base >= 4 && < 5
, yesod-core == 1.2.*
, conduit >= 0.5 && < 1.1
, wai >= 1.3 && < 1.5
, wai-eventsource >= 1.3 && < 1.4
, wai >= 1.3
, wai-eventsource >= 1.3
, blaze-builder
, transformers
exposed-modules: Yesod.EventSource

4
yesod-static/yesod-static.cabal
View File

@ -30,8 +30,8 @@ library
, template-haskell
, directory >= 1.0
, transformers >= 0.2.2
, wai-app-static >= 1.3 && < 1.4
, wai >= 1.3 && < 1.5
, wai-app-static >= 1.3
, wai >= 1.3
, text >= 0.9
, file-embed >= 0.0.4.1 && < 0.5
, http-types >= 0.7

6
yesod/yesod.cabal
View File

@ -28,12 +28,12 @@ library
, yesod-form >= 1.3 && < 1.4
, monad-control >= 0.3 && < 0.4
, transformers >= 0.2.2 && < 0.4
, wai >= 1.3 && < 1.5
, wai-extra >= 1.3 && < 1.4
, wai >= 1.3
, wai-extra >= 1.3
, hamlet >= 1.1 && < 1.2
, shakespeare-js >= 1.0.2 && < 1.2
, shakespeare-css >= 1.0 && < 1.1
, warp >= 1.3 && < 1.4
, warp >= 1.3
, blaze-html >= 0.5
, blaze-markup >= 0.5.1
, aeson