diff --git a/yesod-bin/GhcBuild.hs b/yesod-bin/GhcBuild.hs index d50c77ed..04410002 100644 --- a/yesod-bin/GhcBuild.hs +++ b/yesod-bin/GhcBuild.hs @@ -151,7 +151,9 @@ buildPackage' argv2 ld ar = do haskellish (f,Nothing) = looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f haskellish (_,Just phase) = -#if MIN_VERSION_ghc(7,4,0) +#if MIN_VERSION_ghc(7,8,3) + phase `notElem` [As True, As False, Cc, Cobjc, Cobjcpp, CmmCpp, Cmm, StopLn] +#elif MIN_VERSION_ghc(7,4,0) phase `notElem` [As, Cc, Cobjc, Cobjcpp, CmmCpp, Cmm, StopLn] #else phase `notElem` [As, Cc, CmmCpp, Cmm, StopLn] @@ -301,7 +303,11 @@ mode_flags = , Flag "E" (PassFlag (setMode (stopBeforeMode anyHsc))) , Flag "C" (PassFlag (\f -> do setMode (stopBeforeMode HCc) f addFlag "-fvia-C" f)) +#if MIN_VERSION_ghc(7,8,3) + , Flag "S" (PassFlag (setMode (stopBeforeMode (As True)))) +#else , Flag "S" (PassFlag (setMode (stopBeforeMode As))) +#endif , Flag "-make" (PassFlag (setMode doMakeMode)) , Flag "-interactive" (PassFlag (setMode doInteractiveMode)) , Flag "-abi-hash" (PassFlag (setMode doAbiHashMode)) diff --git a/yesod-bin/Scaffolding/Scaffolder.hs b/yesod-bin/Scaffolding/Scaffolder.hs index daa76c8c..e3a69faa 100644 --- a/yesod-bin/Scaffolding/Scaffolder.hs +++ b/yesod-bin/Scaffolding/Scaffolder.hs @@ -15,6 +15,9 @@ import Text.ProjectTemplate (unpackTemplate, receiveFS) import System.IO import Text.Shakespeare.Text (renderTextUrl, textFile) import Network.HTTP.Conduit (withManager, http, parseUrl, responseBody) +import Data.Maybe (isJust) +import Distribution.Text (simpleParse) +import Distribution.Package (PackageName) prompt :: (String -> Maybe a) -> IO a prompt f = do @@ -59,21 +62,15 @@ backendBS Mysql = $(embedFile "hsfiles/mysql.hsfiles") backendBS MongoDB = $(embedFile "hsfiles/mongo.hsfiles") backendBS Simple = $(embedFile "hsfiles/simple.hsfiles") --- | Is the character valid for a project name? -validPN :: Char -> Bool -validPN c - | 'A' <= c && c <= 'Z' = True - | 'a' <= c && c <= 'z' = True - | '0' <= c && c <= '9' = True -validPN '-' = True -validPN _ = False +validPackageName :: String -> Bool +validPackageName s = isJust (simpleParse s :: Maybe PackageName) scaffold :: Bool -- ^ bare directory instead of a new subdirectory? -> IO () scaffold isBare = do puts $ renderTextUrl undefined $(textFile "input/welcome.cg") project <- prompt $ \s -> - if all validPN s && not (null s) && s /= "test" + if validPackageName s && s /= "test" then Just s else Nothing let dir = project diff --git a/yesod-bin/yesod-bin.cabal b/yesod-bin/yesod-bin.cabal index 24356f60..7b9408a9 100644 --- a/yesod-bin/yesod-bin.cabal +++ b/yesod-bin/yesod-bin.cabal @@ -1,5 +1,5 @@ name: yesod-bin -version: 1.2.10.1 +version: 1.2.10.2 license: MIT license-file: LICENSE author: Michael Snoyman diff --git a/yesod-core/Yesod/Core/Handler.hs b/yesod-core/Yesod/Core/Handler.hs index 2e5d7cb4..aa2f6195 100644 --- a/yesod-core/Yesod/Core/Handler.hs +++ b/yesod-core/Yesod/Core/Handler.hs @@ -91,6 +91,7 @@ module Yesod.Core.Handler , sendResponseStatus , sendResponseCreated , sendWaiResponse + , sendWaiApplication #if MIN_VERSION_wai(2, 1, 0) , sendRawResponse #endif @@ -585,6 +586,12 @@ sendResponseCreated url = do sendWaiResponse :: MonadHandler m => W.Response -> m b sendWaiResponse = handlerError . HCWai +-- | Switch over to handling the current request with a WAI @Application@. +-- +-- Since 1.2.17 +sendWaiApplication :: MonadHandler m => W.Application -> m b +sendWaiApplication = handlerError . HCWaiApp + #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 diff --git a/yesod-core/Yesod/Core/Internal/Response.hs b/yesod-core/Yesod/Core/Internal/Response.hs index 7336ef1d..affa1a7b 100644 --- a/yesod-core/Yesod/Core/Internal/Response.hs +++ b/yesod-core/Yesod/Core/Internal/Response.hs @@ -42,9 +42,11 @@ yarToResponse :: YesodResponse -> YesodRequest -> Request -> InternalState - -> IO Response -yarToResponse (YRWai a) _ _ _ _ = return a -yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq req is = do + -> (Response -> IO ResponseReceived) + -> IO ResponseReceived +yarToResponse (YRWai a) _ _ _ _ sendResponse = sendResponse a +yarToResponse (YRWaiApp app) _ _ req _ sendResponse = app req sendResponse +yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq req is sendResponse = do extraHeaders <- do let nsToken = maybe newSess @@ -58,10 +60,10 @@ yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq req is = do let go (ContentBuilder b mlen) = do let hs' = maybe finalHeaders finalHeaders' mlen - return $ ResponseBuilder s hs' b + sendResponse $ ResponseBuilder s hs' b go (ContentFile fp p) = do - return $ ResponseFile s finalHeaders fp p - go (ContentSource body) = return $ responseStream s finalHeaders + sendResponse $ ResponseFile s finalHeaders fp p + go (ContentSource body) = sendResponse $ responseStream s finalHeaders $ \sendChunk flush -> do transPipe (flip runInternalState is) body $$ CL.mapM_ (\mchunk -> @@ -85,6 +87,7 @@ yarToResponse :: YesodResponse #endif -> IO Response #if MIN_VERSION_wai(2, 0, 0) +yarToResponse (YRWaiApp app) _ _ req _ = app req yarToResponse (YRWai a) _ _ _ is = case a of ResponseSource s hs w -> return $ ResponseSource s hs $ \f -> diff --git a/yesod-core/Yesod/Core/Internal/Run.hs b/yesod-core/Yesod/Core/Internal/Run.hs index 9a87f932..311f2088 100644 --- a/yesod-core/Yesod/Core/Internal/Run.hs +++ b/yesod-core/Yesod/Core/Internal/Run.hs @@ -152,6 +152,7 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState - emptyContent finalSession HCWai r -> return $ YRWai r + HCWaiApp a -> return $ YRWaiApp a safeEh :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> ErrorResponse @@ -295,15 +296,15 @@ yesodRunner handler' YesodRunnerEnv {..} route req E.bracket createInternalState closeInternalState $ \is -> do yreq' <- yreq yar <- runInternalState (runHandler rhe handler yreq') is - res <- yarToResponse yar saveSession yreq' req is - sendResponse res + yarToResponse yar saveSession yreq' req is sendResponse #else #if MIN_VERSION_wai(2, 0, 0) bracketOnError createInternalState closeInternalState $ \is -> do - yar <- runInternalState (runHandler rhe handler yreq) is - liftIO $ yarToResponse yar saveSession yreq req is + yreq' <- yreq + 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 diff --git a/yesod-core/Yesod/Core/Types.hs b/yesod-core/Yesod/Core/Types.hs index 7e3fd0dd..09d274f8 100644 --- a/yesod-core/Yesod/Core/Types.hs +++ b/yesod-core/Yesod/Core/Types.hs @@ -126,6 +126,7 @@ data YesodRequest = YesodRequest -- or a higher-level data structure which Yesod will turn into a @Response@. data YesodResponse = YRWai !W.Response + | YRWaiApp !W.Application | YRPlain !H.Status ![Header] !ContentType !Content !SessionMap -- | A tuple containing both the POST parameters and submitted files. @@ -372,6 +373,7 @@ data HandlerContents = | HCRedirect H.Status Text | HCCreated Text | HCWai W.Response + | HCWaiApp W.Application deriving Typeable instance Show HandlerContents where @@ -381,6 +383,7 @@ instance Show HandlerContents where show (HCRedirect s t) = "HCRedirect " ++ show (s, t) show (HCCreated t) = "HCCreated " ++ show t show (HCWai _) = "HCWai" + show (HCWaiApp _) = "HCWaiApp" instance Exception HandlerContents -- Instances for WidgetT diff --git a/yesod-core/test/YesodCoreTest/RawResponse.hs b/yesod-core/test/YesodCoreTest/RawResponse.hs index 83bd686a..e4977afb 100644 --- a/yesod-core/test/YesodCoreTest/RawResponse.hs +++ b/yesod-core/test/YesodCoreTest/RawResponse.hs @@ -5,6 +5,7 @@ import Yesod.Core import Test.Hspec import qualified Data.Map as Map import Network.Wai.Test +import Network.Wai (responseStream) import Data.Text (Text) import Data.ByteString.Lazy (ByteString) import qualified Data.Conduit.List as CL @@ -20,11 +21,15 @@ import Control.Concurrent.Async (withAsync) import Control.Monad.Trans.Resource (register) import Data.IORef import Data.Streaming.Network (bindPortTCP) +import Network.HTTP.Types (status200) +import Blaze.ByteString.Builder (fromByteString) data App = App mkYesod "App" [parseRoutes| / HomeR GET +/wai-stream WaiStreamR GET +/wai-app-stream WaiAppStreamR GET |] instance Yesod App @@ -38,6 +43,20 @@ getHomeR = do yield (S8.pack $ show val) $$ sink src $$ CL.map (S8.map toUpper) =$ sink +getWaiStreamR :: Handler () +getWaiStreamR = sendWaiResponse $ responseStream status200 [] $ \send flush -> do + flush + send $ fromByteString "hello" + flush + send $ fromByteString " world" + +getWaiAppStreamR :: Handler () +getWaiAppStreamR = sendWaiApplication $ \_ f -> f $ responseStream status200 [] $ \send flush -> do + flush + send $ fromByteString "hello" + flush + send $ fromByteString " world" + getFreePort :: IO Int getFreePort = do loop 43124 @@ -51,13 +70,41 @@ getFreePort = do return port specs :: Spec -specs = describe "RawResponse" $ do - it "works" $ do - port <- getFreePort - withAsync (warp port App) $ \_ -> do - threadDelay 100000 - runTCPClient (clientSettings port "127.0.0.1") $ \ad -> do - yield "GET / HTTP/1.1\r\n\r\nhello" $$ appSink ad - (appSource ad $$ CB.take 6) >>= (`shouldBe` "0HELLO") - yield "WORLd" $$ appSink ad - (appSource ad $$ await) >>= (`shouldBe` Just "WORLD") +specs = do + describe "RawResponse" $ do + it "works" $ do + port <- getFreePort + withAsync (warp port App) $ \_ -> do + threadDelay 100000 + runTCPClient (clientSettings port "127.0.0.1") $ \ad -> do + yield "GET / HTTP/1.1\r\n\r\nhello" $$ appSink ad + (appSource ad $$ CB.take 6) >>= (`shouldBe` "0HELLO") + yield "WORLd" $$ appSink ad + (appSource ad $$ await) >>= (`shouldBe` Just "WORLD") + + let body req = do + port <- getFreePort + withAsync (warp port App) $ \_ -> do + threadDelay 100000 + runTCPClient (clientSettings port "127.0.0.1") $ \ad -> do + yield req $$ appSink ad + appSource ad $$ CB.lines =$ do + let loop = do + x <- await + case x of + Nothing -> return () + Just "\r" -> return () + _ -> loop + loop + + Just "0005\r" <- await + Just "hello\r" <- await + + Just "0006\r" <- await + Just " world\r" <- await + + return () + it "sendWaiResponse + responseStream" $ do + body "GET /wai-stream HTTP/1.1\r\n\r\n" + it "sendWaiApplication + responseStream" $ do + body "GET /wai-app-stream HTTP/1.1\r\n\r\n" diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 55e20529..79c4e6c4 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.2.16 +version: 1.2.17 license: MIT license-file: LICENSE author: Michael Snoyman @@ -108,7 +108,7 @@ test-suite tests build-depends: base ,hspec >= 1.3 ,wai-test >= 1.3.0.5 - ,wai + ,wai >= 3.0 ,yesod-core ,bytestring ,hamlet diff --git a/yesod-platform/yesod-platform.cabal b/yesod-platform/yesod-platform.cabal index aa55459b..c56597fd 100644 --- a/yesod-platform/yesod-platform.cabal +++ b/yesod-platform/yesod-platform.cabal @@ -1,5 +1,5 @@ name: yesod-platform -version: 1.2.12 +version: 1.2.12.2 license: MIT license-file: LICENSE author: Michael Snoyman @@ -61,7 +61,7 @@ library , data-default-instances-old-locale == 0.0.1 , dlist == 0.7.0.1 , email-validate == 2.0.1 - , entropy == 0.3 + , entropy == 0.3.2 , esqueleto == 1.4.1.2 , exceptions == 0.6.1 , fast-logger == 2.1.5 @@ -134,7 +134,7 @@ library , wai-extra == 3.0.0 , wai-logger == 2.1.1 , wai-test == 3.0.0 - , warp == 3.0.0 + , warp == 3.0.0.2 , warp-tls == 3.0.0 , word8 == 0.0.4 , x509 == 1.4.11 diff --git a/yesod-websockets/Yesod/WebSockets.hs b/yesod-websockets/Yesod/WebSockets.hs index ad2f5ad4..82757413 100644 --- a/yesod-websockets/Yesod/WebSockets.hs +++ b/yesod-websockets/Yesod/WebSockets.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} module Yesod.WebSockets @@ -46,7 +47,12 @@ webSockets :: (Y.MonadBaseControl IO m, Y.MonadHandler m) => WebSocketsT m () -> webSockets inner = do req <- Y.waiRequest when (WaiWS.isWebSocketsReq req) $ - Y.sendRawResponseNoConduit $ \src sink -> control $ \runInIO -> WaiWS.runWebSockets +#if MIN_VERSION_wai(3, 0, 0) + Y.sendRawResponseNoConduit +#else + Y.sendRawResponse +#endif + $ \src sink -> control $ \runInIO -> WaiWS.runWebSockets WS.defaultConnectionOptions (WaiWS.getRequestHead req) (\pconn -> do diff --git a/yesod-websockets/yesod-websockets.cabal b/yesod-websockets/yesod-websockets.cabal index 5185e45b..8708bba2 100644 --- a/yesod-websockets/yesod-websockets.cabal +++ b/yesod-websockets/yesod-websockets.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: yesod-websockets -version: 0.1.1 +version: 0.1.1.1 synopsis: WebSockets support for Yesod description: WebSockets support for Yesod homepage: https://github.com/yesodweb/yesod @@ -17,6 +17,10 @@ cabal-version: >=1.8 library exposed-modules: Yesod.WebSockets build-depends: base >= 4.5 && < 5 + + -- Just for CPP macro + , wai + , wai-websockets >= 2.1 , websockets >= 0.8 , transformers >= 0.2