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

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

Browse Source
This commit is contained in:
Michael Snoyman 2014-06-15 15:49:51 +03:00
commit 21d1965774
12 changed files with 112 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
yesod-bin/GhcBuild.hs
View File

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

15
yesod-bin/Scaffolding/Scaffolder.hs
View File

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

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

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

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

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

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

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

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

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

3
yesod-core/Yesod/Core/Types.hs
View File

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

67
yesod-core/test/YesodCoreTest/RawResponse.hs
View File

@ -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"

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

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

6
yesod-platform/yesod-platform.cabal
View File

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

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

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

6
yesod-websockets/yesod-websockets.cabal
View File

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