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

Various additional WAI 3.0 fixes

Browse Source
This commit is contained in:
Michael Snoyman 2014-05-22 21:04:28 +03:00
parent 71263ae047
commit 82de52e3d2
11 changed files with 69 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
yesod-bin/Devel.hs
View File

@ -161,7 +161,11 @@ reverseProxy opts iappPort = do
#endif
$ ProxyDest "127.0.0.1" appPort)
def
#if MIN_VERSION_wai(3, 0, 0)
{ wpsOnExc = \e req f -> onExc e req >>= f
#else
{ wpsOnExc = onExc
#endif
, wpsTimeout =
if proxyTimeout opts == 0
then Nothing

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

@ -93,6 +93,9 @@ module Yesod.Core.Handler
, sendWaiResponse
#if MIN_VERSION_wai(2, 1, 0)
, sendRawResponse
#endif
#if MIN_VERSION_wai(3, 0, 0)
, sendRawResponseNoConduit
#endif
-- * Different representations
-- $representations
@ -582,6 +585,24 @@ sendResponseCreated url = do
sendWaiResponse :: MonadHandler m => W.Response -> m b
sendWaiResponse = handlerError . HCWai
#if MIN_VERSION_wai(3, 0, 0)
-- | Send a raw response without conduit. This is used for cases such as
-- WebSockets. Requires WAI 3.0 or later, and a web server which supports raw
-- responses (e.g., Warp).
--
-- Since 1.2.16
sendRawResponseNoConduit
:: (MonadHandler m, MonadBaseControl IO m)
=> (IO S8.ByteString -> (S8.ByteString -> IO ()) -> m ())
-> m a
sendRawResponseNoConduit raw = control $ \runInIO ->
runInIO $ sendWaiResponse $ flip W.responseRaw fallback
$ \src sink -> runInIO (raw src sink) >> return ()
where
fallback = W.responseLBS H.status500 [("Content-Type", "text/plain")]
"sendRawResponse: backend does not support raw responses"
#endif
#if MIN_VERSION_wai(2, 1, 0)
-- | Send a raw response. This is used for cases such as WebSockets. Requires
-- WAI 2.1 or later, and a web server which supports raw responses (e.g.,

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

@ -1,5 +1,5 @@
name: yesod-core
version: 1.2.15.1
version: 1.2.16
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>

13
yesod-eventsource/Yesod/EventSource.hs
View File

@ -46,7 +46,18 @@ repEventSource :: (EventSourcePolyfill -> C.Source (HandlerT site IO) ES.ServerE
-> HandlerT site IO TypedContent
repEventSource src =
prepareForEventSource >>=
respondEventStream . ES.sourceToSource . src
respondEventStream . sourceToSource . src
-- | Convert a ServerEvent source into a Builder source of serialized
-- events.
sourceToSource :: Monad m => C.Source m ES.ServerEvent -> C.Source m (C.Flush Builder)
sourceToSource src =
src C.$= C.awaitForever eventToFlushBuilder
where
eventToFlushBuilder event =
case ES.eventToBuilder event of
Nothing -> return ()
Just x -> C.yield (C.Chunk x) >> C.yield C.Flush
-- | Return a Server-Sent Event stream given a 'HandlerT' action

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

@ -32,6 +32,7 @@ library
, conduit >= 0.5 && < 1.2
, wai >= 1.3
, wai-eventsource >= 1.3
, wai-extra
, blaze-builder
, transformers
exposed-modules: Yesod.EventSource

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

@ -34,6 +34,7 @@ test-suite test
build-depends: base
, hspec
, wai-test
, wai-extra
, yesod-core
, persistent-sqlite
, yesod-persistent

5
yesod-static/Yesod/EmbeddedStatic.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
@ -89,7 +90,11 @@ instance Yesod master => YesodSubDispatch EmbeddedStatic (HandlerT master IO) wh
resp = case pathInfo req of
("res":_) -> stApp site req
("widget":_) -> staticApp (widgetSettings site) req
#if MIN_VERSION_wai(3,0,0)
_ -> ($ responseLBS status404 [] "Not Found")
#else
_ -> return $ responseLBS status404 [] "Not Found"
#endif
-- | Create the haskell variable for the link to the entry
mkRoute :: ComputedEntry -> Q [Dec]

24
yesod-static/Yesod/EmbeddedStatic/Internal.hs
View File

@ -106,12 +106,22 @@ prodEmbed e = do
}
return $ ComputedEntry (ebHaskellName e) st link
toApp :: (Request -> IO Response) -> Application
#if MIN_VERSION_wai(3, 0, 0)
toApp f req g = f req >>= g
#else
toApp = id
#endif
tryExtraDevelFiles :: [[T.Text] -> IO (Maybe (MimeType, BL.ByteString))] -> Application
tryExtraDevelFiles [] _ = return $ responseLBS status404 [] ""
tryExtraDevelFiles (f:fs) r = do
tryExtraDevelFiles = toApp . tryExtraDevelFiles'
tryExtraDevelFiles' :: [[T.Text] -> IO (Maybe (MimeType, BL.ByteString))] -> Request -> IO Response
tryExtraDevelFiles' [] _ = return $ responseLBS status404 [] ""
tryExtraDevelFiles' (f:fs) r = do
mct <- liftIO $ f $ drop 1 $ pathInfo r -- drop the initial "res"
case mct of
Nothing -> tryExtraDevelFiles fs r
Nothing -> tryExtraDevelFiles' fs r
Just (mime, ct) -> do
let hash = T.encodeUtf8 $ T.pack $ base64md5 ct
let headers = [ ("Content-Type", mime)
@ -123,11 +133,19 @@ tryExtraDevelFiles (f:fs) r = do
-- | Helper to create the development application at runtime
develApp :: StaticSettings -> [[T.Text] -> IO (Maybe (MimeType, BL.ByteString))] -> Application
#if MIN_VERSION_wai(3, 0, 0)
develApp settings extra req sendResponse = do
staticApp settings {ssMaxAge = NoMaxAge} req $ \resp ->
if statusCode (responseStatus resp) == 404
then tryExtraDevelFiles extra req sendResponse
else sendResponse resp
#else
develApp settings extra req = do
resp <- staticApp settings {ssMaxAge = NoMaxAge} req
if statusCode (responseStatus resp) == 404
then tryExtraDevelFiles extra req
else return resp
#endif
-- | The type of 'addStaticContent'
type AddStaticContent site = T.Text -> T.Text -> BL.ByteString

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

@ -82,6 +82,7 @@ test-suite tests
, hspec >= 1.3
, yesod-test >= 1.2
, wai-test
, wai-extra
, HUnit
-- copy from above

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

@ -20,6 +20,7 @@ library
, transformers >= 0.2.2
, wai >= 1.3
, wai-test >= 1.3
, wai-extra
, network >= 2.2
, http-types >= 0.7
, HUnit >= 1.2

2
yesod-websockets/Yesod/WebSockets.hs
View File

@ -46,7 +46,7 @@ webSockets :: (Y.MonadBaseControl IO m, Y.MonadHandler m) => WebSocketsT m () ->
webSockets inner = do
req <- Y.waiRequest
when (WaiWS.isWebSocketsReq req) $
Y.sendRawResponse $ \src sink -> control $ \runInIO -> WaiWS.runWebSockets
Y.sendRawResponseNoConduit $ \src sink -> control $ \runInIO -> WaiWS.runWebSockets
WS.defaultConnectionOptions
(WaiWS.getRequestHead req)
(\pconn -> do