From 82de52e3d2820090159d02018670ca977105d89d Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 22 May 2014 21:04:28 +0300 Subject: [PATCH] Various additional WAI 3.0 fixes --- yesod-bin/Devel.hs | 4 ++++ yesod-core/Yesod/Core/Handler.hs | 21 ++++++++++++++++ yesod-core/yesod-core.cabal | 2 +- yesod-eventsource/Yesod/EventSource.hs | 13 +++++++++- yesod-eventsource/yesod-eventsource.cabal | 1 + yesod-persistent/yesod-persistent.cabal | 1 + yesod-static/Yesod/EmbeddedStatic.hs | 5 ++++ yesod-static/Yesod/EmbeddedStatic/Internal.hs | 24 ++++++++++++++++--- yesod-static/yesod-static.cabal | 1 + yesod-test/yesod-test.cabal | 1 + yesod-websockets/Yesod/WebSockets.hs | 2 +- 11 files changed, 69 insertions(+), 6 deletions(-) diff --git a/yesod-bin/Devel.hs b/yesod-bin/Devel.hs index d10e3cf4..616e0139 100644 --- a/yesod-bin/Devel.hs +++ b/yesod-bin/Devel.hs @@ -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 diff --git a/yesod-core/Yesod/Core/Handler.hs b/yesod-core/Yesod/Core/Handler.hs index adc79430..2e5d7cb4 100644 --- a/yesod-core/Yesod/Core/Handler.hs +++ b/yesod-core/Yesod/Core/Handler.hs @@ -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., diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 698bea88..e04141ec 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.2.15.1 +version: 1.2.16 license: MIT license-file: LICENSE author: Michael Snoyman diff --git a/yesod-eventsource/Yesod/EventSource.hs b/yesod-eventsource/Yesod/EventSource.hs index df698cfd..4a265124 100644 --- a/yesod-eventsource/Yesod/EventSource.hs +++ b/yesod-eventsource/Yesod/EventSource.hs @@ -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 diff --git a/yesod-eventsource/yesod-eventsource.cabal b/yesod-eventsource/yesod-eventsource.cabal index 0d3e20fc..1bdf3ffd 100644 --- a/yesod-eventsource/yesod-eventsource.cabal +++ b/yesod-eventsource/yesod-eventsource.cabal @@ -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 diff --git a/yesod-persistent/yesod-persistent.cabal b/yesod-persistent/yesod-persistent.cabal index 3560dd93..e7bde025 100644 --- a/yesod-persistent/yesod-persistent.cabal +++ b/yesod-persistent/yesod-persistent.cabal @@ -34,6 +34,7 @@ test-suite test build-depends: base , hspec , wai-test + , wai-extra , yesod-core , persistent-sqlite , yesod-persistent diff --git a/yesod-static/Yesod/EmbeddedStatic.hs b/yesod-static/Yesod/EmbeddedStatic.hs index e8196302..e5d2a14c 100644 --- a/yesod-static/Yesod/EmbeddedStatic.hs +++ b/yesod-static/Yesod/EmbeddedStatic.hs @@ -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] diff --git a/yesod-static/Yesod/EmbeddedStatic/Internal.hs b/yesod-static/Yesod/EmbeddedStatic/Internal.hs index 0882c16d..640c4e32 100644 --- a/yesod-static/Yesod/EmbeddedStatic/Internal.hs +++ b/yesod-static/Yesod/EmbeddedStatic/Internal.hs @@ -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 diff --git a/yesod-static/yesod-static.cabal b/yesod-static/yesod-static.cabal index 2582a958..6a9d9354 100644 --- a/yesod-static/yesod-static.cabal +++ b/yesod-static/yesod-static.cabal @@ -82,6 +82,7 @@ test-suite tests , hspec >= 1.3 , yesod-test >= 1.2 , wai-test + , wai-extra , HUnit -- copy from above diff --git a/yesod-test/yesod-test.cabal b/yesod-test/yesod-test.cabal index 6de95874..55a872eb 100644 --- a/yesod-test/yesod-test.cabal +++ b/yesod-test/yesod-test.cabal @@ -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 diff --git a/yesod-websockets/Yesod/WebSockets.hs b/yesod-websockets/Yesod/WebSockets.hs index eebe9202..ad2f5ad4 100644 --- a/yesod-websockets/Yesod/WebSockets.hs +++ b/yesod-websockets/Yesod/WebSockets.hs @@ -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