Merge remote-tracking branch 'origin/master' into yesod-1.4

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))

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?
+validPackageName :: String -> Bool
-validPN :: Char -> Bool
+validPackageName s = isJust (simpleParse s :: Maybe PackageName)
-validPN c
-    | 'A' <= c && c <= 'Z' = True
-    | 'a' <= c && c <= 'z' = True
-    | '0' <= c && c <= '9' = True
-validPN '-' = True
-validPN _ = False
 
 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

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 <michael@snoyman.com>

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

yesod-core/Yesod/Core/Internal/Response.hs

@@ -42,9 +42,11 @@ yarToResponse :: YesodResponse
               -> YesodRequest
               -> Request
               -> InternalState
-              -> IO Response
+              -> (Response -> IO ResponseReceived)
-yarToResponse (YRWai a) _ _ _ _ = return a
+              -> IO ResponseReceived
-yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq req is = do
+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
+            sendResponse $ ResponseFile s finalHeaders fp p
-        go (ContentSource body) = return $ responseStream s finalHeaders
+        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 ->

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
+        yarToResponse yar saveSession yreq' req is sendResponse
-        sendResponse res
 
 #else
 
 #if MIN_VERSION_wai(2, 0, 0)
     bracketOnError createInternalState closeInternalState $ \is -> do
-        yar <- runInternalState (runHandler rhe handler yreq) is
+        yreq' <- yreq
-        liftIO $ yarToResponse yar saveSession yreq req is
+        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

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

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
+specs = do
-    it "works" $ do
+    describe "RawResponse" $ do
-        port <- getFreePort
+        it "works" $ do
-        withAsync (warp port App) $ \_ -> do
+            port <- getFreePort
-            threadDelay 100000
+            withAsync (warp port App) $ \_ -> do
-            runTCPClient (clientSettings port "127.0.0.1") $ \ad -> do
+                threadDelay 100000
-                yield "GET / HTTP/1.1\r\n\r\nhello" $$ appSink ad
+                runTCPClient (clientSettings port "127.0.0.1") $ \ad -> do
-                (appSource ad $$ CB.take 6) >>= (`shouldBe` "0HELLO")
+                    yield "GET / HTTP/1.1\r\n\r\nhello" $$ appSink ad
-                yield "WORLd" $$ appSink ad
+                    (appSource ad $$ CB.take 6) >>= (`shouldBe` "0HELLO")
-                (appSource ad $$ await) >>= (`shouldBe` Just "WORLD")
+                    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"

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 <michael@snoyman.com>
@@ -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

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 <michael@snoyman.com>
@@ -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

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

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