c82e85d · typeable/wai

git.iko.soy/typeable/wai

on master help sign in

Merge remote-tracking branch 'origin/master'

c82e85dMichael Snoyman15 years ago

wai-app-static/test/WaiAppStaticTest.hs+1−20

compare with master

unifiedsplit

@@ -27,26 +27,7 @@ import Control.Monad.IO.Class (liftIO)

27import Data.Monoid (mempty)

29defRequest :: Request

30−defRequest = Request {

30+defRequest = defaultRequest

31− rawQueryString = ""

32−, queryString = []

33−, requestMethod = "GET"

34−, rawPathInfo = ""

35−, pathInfo = []

36−, requestHeaders = []

37−, serverName = "wai-test"

38−, httpVersion = H.http11

39−, serverPort = 80

40−, isSecure = False

41−, remoteHost = Sock.SockAddrInet 1 2

42−, vault = mempty

43−, requestBody = error "requestBody"

44−}

45−

46−setRawPathInfo :: Request -> S8.ByteString -> Request

47−setRawPathInfo r rawPinfo =

48− let pInfo = T.split (== '/') $ TE.decodeUtf8 rawPinfo

49− in r { rawPathInfo = rawPinfo, pathInfo = pInfo }

51specs :: Specs

32specs :: Specs

52specs = do

33specs = do

wai-test/Network/Wai/Test.hs+8

@@ -9,6 +9,7 @@ module Network.Wai.Test

9 , SRequest (..)

10 , SResponse (..)

11 , defaultRequest

12+ , setRawPathInfo

12 -- * Assertions

13 -- * Assertions

13 , assertStatus

14 , assertStatus

14 , assertContentType

15 , assertContentType

@@ -33,6 +34,8 @@ import qualified Data.ByteString.Lazy.Char8 as L8

33import qualified Network.HTTP.Types as H

34import qualified Network.HTTP.Types as H

34import Data.CaseInsensitive (CI)

35import Data.CaseInsensitive (CI)

35import qualified Data.ByteString as S

36import qualified Data.ByteString as S

37+import qualified Data.Text as T

38+import qualified Data.Text.Encoding as TE

36import qualified Data.Conduit as C

39import qualified Data.Conduit as C

37import qualified Data.Conduit.List as CL

40import qualified Data.Conduit.List as CL

38import Data.Monoid (mempty)

41import Data.Monoid (mempty)

@@ -79,6 +82,11 @@ defaultRequest = Request

79 , vault = mempty

82 , vault = mempty

80 }

83 }

85+setRawPathInfo :: Request -> S8.ByteString -> Request

86+setRawPathInfo r rawPinfo =

87+ let pInfo = T.split (== '/') $ TE.decodeUtf8 rawPinfo

88+ in r { rawPathInfo = rawPinfo, pathInfo = pInfo }

89+

82srequest :: SRequest -> Session SResponse

90srequest :: SRequest -> Session SResponse

83srequest (SRequest req bod) = do

91srequest (SRequest req bod) = do

84 app <- ask

92 app <- ask

wai-test/wai-test.cabal+1

@@ -16,6 +16,7 @@ library

16 build-depends: base >= 4 && < 5

17 , wai >= 1.1 && < 1.2

18 , bytestring >= 0.9.1.4 && < 0.10

19+ , text >= 0.7 && < 0.12

19 , blaze-builder >= 0.2.1.4 && < 0.4

20 , blaze-builder >= 0.2.1.4 && < 0.4

20 , transformers >= 0.2.2 && < 0.3

21 , transformers >= 0.2.2 && < 0.3

21 , containers >= 0.2 && < 0.5

22 , containers >= 0.2 && < 0.5

warp/Network/Wai/Handler/Warp.hs+20−28

@@ -115,7 +115,7 @@ import Data.List (foldl')

115import Control.Monad (forever, when)

116import qualified Network.HTTP.Types as H

117import qualified Data.CaseInsensitive as CI

118−import System.IO (hPutStrLn, stderr)

118+import System.IO (hPrint, stderr)

119import ReadInt (readInt64)

120import qualified Data.IORef as I

121import Data.String (IsString (..))

@@ -198,7 +198,7 @@ bindPort p s = do

198 theBody addr =

199 bracketOnError

200 (Network.Socket.socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))

201− (sClose)

201+ sClose

202 (\sock -> do

203 setSocketOption sock ReuseAddr 1

204 bindSocket sock (addrAddress addr)

@@ -511,6 +511,7 @@ sendResponse th req conn r = sendResponse' r

511 needsChunked hs = isChunked' && not (hasLength hs)

512 isKeepAlive hs = isPersist && (isChunked' || hasLength hs)

513 hasLength hs = isJust $ lookup "content-length" hs

514+ sendHeader = connSendMany conn . L.toChunks . toLazyByteString

514

515

515 sendResponse' :: Response -> ResourceT IO Bool

516 sendResponse' :: Response -> ResourceT IO Bool

516 sendResponse' (ResponseFile s hs fp mpart) = liftIO $ do

517 sendResponse' (ResponseFile s hs fp mpart) = liftIO $ do

@@ -523,17 +524,17 @@ sendResponse th req conn r = sendResponse' r

523 (Nothing, Just part) -> do

524 (Nothing, Just part) -> do

524 let cl = filePartByteCount part

525 let cl = filePartByteCount part

525 return $ addClToHeaders cl

526 return $ addClToHeaders cl

526− connSendMany conn $ L.toChunks $ toLazyByteString $

527− headers version s lengthyHeaders False

527+ let headers' = headers version s lengthyHeaders

528−

528+ sendHeader $ headers' False

529 T.tickle th

530−

531− if not (hasBody s req) then return isPersist else do

530+ if hasBody s req then do

532 case mpart of

531 case mpart of

533 Nothing -> connSendFile conn fp 0 cl (T.tickle th)

532 Nothing -> connSendFile conn fp 0 cl (T.tickle th)

534 Just part -> connSendFile conn fp (filePartOffset part) (filePartByteCount part) (T.tickle th)

533 Just part -> connSendFile conn fp (filePartOffset part) (filePartByteCount part) (T.tickle th)

535 T.tickle th

534 T.tickle th

536 return isPersist

535 return isPersist

536+ else

537+ return isPersist

537 where

538 where

538 addClToHeaders cl = (("Content-Length", B.pack $ show cl):hs, fromIntegral cl)

539 addClToHeaders cl = (("Content-Length", B.pack $ show cl):hs, fromIntegral cl)

539

540

@@ -544,10 +545,7 @@ sendResponse th req conn r = sendResponse' r

544 T.tickle th) body

545 T.tickle th) body

545 return (isKeepAlive hs)

546 return (isKeepAlive hs)

546 | otherwise = liftIO $ do

547 | otherwise = liftIO $ do

547− connSendMany conn

548− $ L.toChunks

549− $ toLazyByteString

550− $ headers' False

548+ sendHeader $ headers' False

551 T.tickle th

549 T.tickle th

552 return isPersist

550 return isPersist

553 where

551 where

@@ -559,8 +557,16 @@ sendResponse th req conn r = sendResponse' r

559 `mappend` chunkedTransferTerminator

557 `mappend` chunkedTransferTerminator

560 else headers' False `mappend` b

558 else headers' False `mappend` b

561

559

562− sendResponse' (ResponseSource s hs bodyFlush) =

560+ sendResponse' (ResponseSource s hs bodyFlush)

563− response

561+ | hasBody s req = do

562+ let src = CL.sourceList [headers' needsChunked'] `mappend`

563+ (if needsChunked' then body C.$= chunk else body)

564+ src C.$$ builderToByteString C.=$ connSink conn th

565+ return $ isKeepAlive hs

566+ | otherwise = liftIO $ do

567+ sendHeader $ headers' False

568+ T.tickle th

569+ return isPersist

564 where

570 where

565 body = fmap (\x -> case x of

571 body = fmap (\x -> case x of

566 C.Flush -> flush

572 C.Flush -> flush

@@ -568,26 +574,12 @@ sendResponse th req conn r = sendResponse' r

568 headers' = headers version s hs

574 headers' = headers version s hs

569 -- FIXME perhaps alloca a buffer per thread and reuse that in all

575 -- FIXME perhaps alloca a buffer per thread and reuse that in all

570 -- functions below. Should lessen greatly the GC burden (I hope)

576 -- functions below. Should lessen greatly the GC burden (I hope)

571− response

572− | not (hasBody s req) = liftIO $ do

573− connSendMany conn

574− $ L.toChunks $ toLazyByteString

575− $ headers' False

576− T.tickle th

577− return (checkPersist req)

578− | otherwise = do

579− let src =

580− CL.sourceList [headers' needsChunked'] `mappend`

581− (if needsChunked' then body C.$= chunk else body)

582− src C.$$ builderToByteString C.=$ connSink conn th

583− return $ isKeepAlive hs

584 needsChunked' = needsChunked hs

577 needsChunked' = needsChunked hs

585 chunk :: C.Conduit Builder IO Builder

578 chunk :: C.Conduit Builder IO Builder

586 chunk = C.Conduit

579 chunk = C.Conduit

587 { C.conduitPush = push

580 { C.conduitPush = push

588 , C.conduitClose = close

581 , C.conduitClose = close

589 }

582 }

590−

591 conduit = C.Conduit push close

583 conduit = C.Conduit push close

592 push x = return $ C.Producing conduit [chunkedTransferEncoding x]

584 push x = return $ C.Producing conduit [chunkedTransferEncoding x]

593 close = return [chunkedTransferTerminator]

585 close = return [chunkedTransferTerminator]

@@ -695,7 +687,7 @@ defaultSettings = Settings

695 Just x -> go x

687 Just x -> go x

696 Nothing ->

688 Nothing ->

697 when (go' $ fromException e) $

689 when (go' $ fromException e) $

698− hPutStrLn stderr $ show e

690+ hPrint stderr e

699 , settingsTimeout = 30

691 , settingsTimeout = 30

700 , settingsIntercept = const Nothing

692 , settingsIntercept = const Nothing

701 , settingsManager = Nothing

693 , settingsManager = Nothing