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

WAI 2.0 updates

Browse Source
This commit is contained in:
Michael Snoyman 2013-11-10 16:49:26 +02:00
parent 6f495fc758
commit d34c3f26dc
7 changed files with 77 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
yesod-bin/Devel.hs
View File

@ -67,7 +67,12 @@ import qualified Config as GHC
import Data.Conduit.Network (HostPreference (HostIPv4),
bindPort)
import Network (withSocketsDo)
#if MIN_VERSION_http_conduit(2, 0, 0)
import Network.HTTP.Conduit (conduitManagerSettings, newManager)
import Data.Default (def)
#else
import Network.HTTP.Conduit (def, newManager)
#endif
import Network.HTTP.ReverseProxy (ProxyDest (ProxyDest),
waiProxyToSettings, wpsTimeout, wpsOnExc)
#if MIN_VERSION_http_reverse_proxy(0, 2, 0)
@ -121,7 +126,11 @@ cabalProgram opts | isCabalDev opts = "cabal-dev"
-- 3001, give an appropriate message to the user.
reverseProxy :: DevelOpts -> I.IORef Int -> IO ()
reverseProxy opts iappPort = do
#if MIN_VERSION_http_conduit(2, 0, 0)
manager <- newManager conduitManagerSettings
#else
manager <- newManager def
#endif
let loop = forever $ do
run (develPort opts) $ waiProxyToSettings
(const $ do

1
yesod-bin/yesod-bin.cabal
View File

@ -87,6 +87,7 @@ executable yesod
, transformers
, warp >= 1.3.7.5
, wai >= 1.4
, data-default
ghc-options: -Wall -threaded
main-is: main.hs

2
yesod-core/Yesod/Core/Dispatch.hs
View File

@ -146,6 +146,7 @@ warp :: YesodDispatch site => Int -> site -> IO ()
warp port site = toWaiApp site >>= Network.Wai.Handler.Warp.runSettings
Network.Wai.Handler.Warp.defaultSettings
{ Network.Wai.Handler.Warp.settingsPort = port
{- FIXME
, Network.Wai.Handler.Warp.settingsServerName = S8.pack $ concat
[ "Warp/"
, Network.Wai.Handler.Warp.warpVersion
@ -153,6 +154,7 @@ warp port site = toWaiApp site >>= Network.Wai.Handler.Warp.runSettings
, showVersion Paths_yesod_core.version
, " (core)"
]
-}
}
-- | A default set of middlewares.

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

@ -195,6 +195,9 @@ import Control.Failure (failure)
import Blaze.ByteString.Builder (Builder)
import Safe (headMay)
import Data.CaseInsensitive (CI)
#if MIN_VERSION_wai(2, 0, 0)
import qualified System.PosixCompat.Files as PC
#endif
get :: MonadHandler m => m GHState
get = liftHandlerT $ HandlerT $ I.readIORef . handlerState
@ -499,8 +502,17 @@ sendFilePart :: MonadHandler m
-> Integer -- ^ offset
-> Integer -- ^ count
-> m a
sendFilePart ct fp off count =
sendFilePart ct fp off count = do
#if MIN_VERSION_wai(2, 0, 0)
fs <- liftIO $ PC.getFileStatus fp
handlerError $ HCSendFile ct fp $ Just W.FilePart
{ W.filePartOffset = off
, W.filePartByteCount = count
, W.filePartFileSize = fromIntegral $ PC.fileSize fs
}
#else
handlerError $ HCSendFile ct fp $ Just $ W.FilePart off count
#endif
-- | Bypass remaining handler code and output the given content with a 200
-- status code.

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

@ -15,8 +15,10 @@ 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 Control.Monad.Trans.Resource (runInternalState, getInternalState, runResourceT, InternalState, closeInternalState)
import Control.Monad.Trans.Class (lift)
import Network.Wai.Internal
import Control.Exception (finally)
#endif
import Prelude hiding (catch)
import Web.Cookie (renderSetCookie)
@ -32,14 +34,30 @@ import qualified Data.Map as Map
import Yesod.Core.Internal.Request (tokenKey)
import Data.Text.Encoding (encodeUtf8)
yarToResponse :: Monad m
=> YesodResponse
-> (SessionMap -> m [Header]) -- ^ save session
yarToResponse :: YesodResponse
-> (SessionMap -> IO [Header]) -- ^ save session
-> YesodRequest
-> Request
-> m Response
#if MIN_VERSION_wai(2, 0, 0)
-> InternalState
#endif
-> IO Response
#if MIN_VERSION_wai(2, 0, 0)
yarToResponse (YRWai a) _ _ _ is =
case a of
ResponseSource s hs w -> return $ ResponseSource s hs $ \f ->
w f `finally` closeInternalState is
_ -> do
closeInternalState is
return a
#else
yarToResponse (YRWai a) _ _ _ = return a
yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq req = do
#endif
yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq req
#if MIN_VERSION_wai(2, 0, 0)
is
#endif
= do
extraHeaders <- do
let nsToken = maybe
newSess
@ -50,17 +68,29 @@ yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq req = do
let finalHeaders = extraHeaders ++ map headerToPair hs
finalHeaders' len = ("Content-Length", S8.pack $ show len)
: finalHeaders
#if MIN_VERSION_wai(2, 0, 0)
let go (ContentBuilder b mlen) = do
let hs' = maybe finalHeaders finalHeaders' mlen
closeInternalState is
return $ ResponseBuilder s hs' b
go (ContentFile fp p) = do
closeInternalState is
return $ ResponseFile s finalHeaders fp p
go (ContentSource body) = return $ ResponseSource s finalHeaders $ \f ->
f (transPipe (flip runInternalState is) body) `finally`
closeInternalState is
go (ContentDontEvaluate c') = go c'
go c
#else
let go (ContentBuilder b mlen) =
let hs' = maybe finalHeaders finalHeaders' mlen
in ResponseBuilder s hs' b
go (ContentFile fp p) = ResponseFile s finalHeaders fp p
#if MIN_VERSION_wai(2, 0, 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
#endif
where
s
| s' == defaultStatus = H.status200

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

@ -10,13 +10,13 @@ module Yesod.Core.Internal.Run where
import Yesod.Core.Internal.Response
import Blaze.ByteString.Builder (toByteString)
import Control.Applicative ((<$>))
import Control.Exception (fromException)
import Control.Exception (fromException, bracketOnError)
import Control.Exception.Lifted (catch)
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, getInternalState)
import Control.Monad.Trans.Resource (runResourceT, withInternalState, runInternalState, createInternalState, closeInternalState)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.IORef as I
@ -165,16 +165,9 @@ 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(2, 0, 0)
let yapp internalState = runHandler
#else
let yapp = runHandler
#endif
RunHandlerEnv
{ rheRender = yesodRender site $ resolveApproot site $ fakeWaiRequest
#if MIN_VERSION_wai(2, 0, 0)
internalState
#endif
{ rheRender = yesodRender site $ resolveApproot site fakeWaiRequest
, rheRoute = Nothing
, rheSite = site
, rheUpload = fileUpload site
@ -190,18 +183,13 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do
typePlain
(toContent ("runFakeHandler: errHandler" :: S8.ByteString))
(reqSession req)
fakeWaiRequest
#if MIN_VERSION_wai(2, 0, 0)
internalState
#endif
=
Request
fakeWaiRequest = Request
{ requestMethod = "POST"
, httpVersion = H.http11
, rawPathInfo = "/runFakeHandler/pathInfo"
, rawQueryString = ""
#if MIN_VERSION_wai(2, 0, 0)
, resourceInternalState = internalState
, requestHeaderHost = Nothing
#else
, serverName = "runFakeHandler-serverName"
, serverPort = 80
@ -215,30 +203,17 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do
, vault = mempty
, requestBodyLength = KnownLength 0
}
#if MIN_VERSION_wai(2, 0, 0)
fakeRequest internalState =
#else
fakeRequest =
#endif
YesodRequest
{ reqGetParams = []
, reqCookies = []
, reqWaiRequest = fakeWaiRequest
#if MIN_VERSION_wai(2, 0, 0)
internalState
#endif
, reqLangs = []
, reqToken = Just "NaN" -- not a nonce =)
, reqAccept = []
, reqSession = fakeSessionMap
}
#if MIN_VERSION_wai(2, 0, 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." #-}
@ -275,12 +250,14 @@ yesodRunner handler' YesodRunnerEnv {..} route req
rhe = rheSafe
{ rheOnError = runHandler rheSafe . errorHandler
}
yar <-
#if MIN_VERSION_wai(2, 0, 0)
flip runInternalState (resourceInternalState req) $
#endif
runHandler rhe handler yreq
bracketOnError createInternalState closeInternalState $ \is -> do
yar <- runInternalState (runHandler rhe handler yreq) is
liftIO $ yarToResponse yar saveSession yreq req is
#else
yar <- runHandler rhe handler yreq
liftIO $ yarToResponse yar saveSession yreq req
#endif
where
mmaxLen = maximumContentLength yreSite route
handler = yesodMiddleware handler'

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

@ -65,6 +65,7 @@ library
, data-default
, safe
, warp >= 1.3.8
, unix-compat
exposed-modules: Yesod.Core
Yesod.Core.Content