de3b989 · typeable/wai

git.iko.soy/typeable/wai

Switch to newtype and Source

commitde3b98944f725c9410cc0397908c78b7c9768dbc authorSnoyman <snoyman@snoytop-karmic.(none)> dateFri 26 Feb 2010, 10:17 (17 years ago) parent31c0729

7 files changed+33−48

compare with master

unifiedsplit

Network/Wai/Handler/CGI.hs+3−16 Network/Wai/Handler/Helper.hs+14 Network/Wai/Handler/SimpleServer.hs+7−19 Network/Wai/Middleware/CleanPath.hs+2−2 Network/Wai/Middleware/Gzip.hs+4−9 Network/Wai/Middleware/Jsonp.hs+2−2 wai-extra.cabal+1

Network/Wai/Handler/CGI.hs+3−16

@@ -5,14 +5,13 @@ module Network.Wai.Handler.CGI

66import Network.Wai

77import Network.Wai.Enumerator (fromEitherFile)

8+import Network.Wai.Handler.Helper

89import System.Environment (getEnvironment)

910import Data.Maybe (fromMaybe)

1011import qualified Data.ByteString.Char8 as B

1112import Control.Arrow ((***))

1213import Data.Char (toLower)

1314import qualified System.IO

14−import Control.Concurrent

15−import Data.ByteString.Lazy.Internal (defaultChunkSize)

1615

1716safeRead :: Read a => a -> String -> a

1817safeRead d s =

@@ -51,7 +50,6 @@ run' vars inputH outputH app = do

5150 case map toLower $ lookup' "SERVER_PROTOCOL" vars of

5251 "https" -> HTTPS

5352 _ -> HTTP

54− mContentLength <- newMVar contentLength

5553 let env = Request

5654 { requestMethod = rmethod

5755 , pathInfo = B.pack pinfo

@@ -60,7 +58,7 @@ run' vars inputH outputH app = do

6058 , serverPort = serverport

6159 , requestHeaders = map (cleanupVarName *** B.pack) vars

6260 , urlScheme = urlScheme'

63− , requestBody = requestBodyHandle inputH mContentLength

61+ , requestBody = Source contentLength $ requestBodyHandle inputH

6462 , errorHandler = System.IO.hPutStr System.IO.stderr

6563 , remoteHost = B.pack remoteHost'

6664 , httpVersion = HttpVersion B.empty

@@ -77,23 +75,12 @@ run' vars inputH outputH app = do

7775 hPut $ B.singleton '\n'

7876 mapM_ (printHeader hPut) h'

7977 hPut $ B.singleton '\n'

80− _ <- fromEitherFile (responseBody res) (myPut outputH) ()

78+ _ <- runEnumerator (fromEitherFile (responseBody res)) (myPut outputH) ()

8179 return ()

8280

8381myPut :: System.IO.Handle -> () -> B.ByteString -> IO (Either () ())

8482myPut outputH _ bs = B.hPut outputH bs >> return (Right ())

8583

86−requestBodyHandle :: System.IO.Handle -> MVar Int -> Enumerator a

87−requestBodyHandle h mlen iter accum = modifyMVar mlen (helper accum) where

88− helper a 0 = return (0, Right a)

89− helper a len = do

90− bs <- B.hGet h $ min len defaultChunkSize

91− let newLen = len - B.length bs

92− ea' <- iter a bs

93− case ea' of

94− Left a' -> return (newLen, Left a')

95− Right a' -> helper a' newLen

96−

9784printHeader :: (B.ByteString -> IO ())

9885 -> (ResponseHeader, B.ByteString)

9986 -> IO ()

Network/Wai/Handler/Helper.hsnew file+14

@@ -0,0 +1,14 @@

1+module Network.Wai.Handler.Helper

2+ ( requestBodyHandle

3+ ) where

5+import System.IO (Handle)

6+import qualified Data.ByteString as B

8+requestBodyHandle :: Handle -> Int -> IO (Maybe (B.ByteString, Int))

9+requestBodyHandle _ 0 = return Nothing

10+requestBodyHandle h len = do

11+ let maxChunkSize = 1024

12+ bs <- B.hGet h $ min len maxChunkSize

13+ let newLen = len - B.length bs

14+ return $ Just (bs, newLen)

Network/Wai/Handler/SimpleServer.hs+7−19

@@ -18,6 +18,7 @@ module Network.Wai.Handler.SimpleServer

1818 ) where

1919

2020import Network.Wai

21+import Network.Wai.Handler.Helper

2122import qualified System.IO

2223

2324import qualified Data.ByteString as BS

@@ -27,7 +28,7 @@ import Network

2728 , withSocketsDo)

2829import Control.Exception (bracket, finally, Exception)

2930import System.IO (Handle, hClose)

30−import Control.Concurrent

31+import Control.Concurrent (forkIO)

3132import Control.Monad (unless)

3233import Data.Maybe (isJust, fromJust, fromMaybe)

3334

@@ -40,7 +41,6 @@ import qualified Web.Encodings.StringLike as SL

4041import qualified Safe

4142import Network.Socket.SendFile

4243import Control.Arrow (first)

43−import Data.ByteString.Lazy.Internal (defaultChunkSize)

4444

4545run :: Port -> Application -> IO ()

4646run port = withSocketsDo .

@@ -69,8 +69,8 @@ serveConnection port app conn remoteHost' =

6969

7070hParseRequest :: Port -> Handle -> String -> IO Request

7171hParseRequest port conn remoteHost' = do

72− responseHeaders' <- takeUntilBlank conn id

73− parseRequest port responseHeaders' conn remoteHost'

72+ headers' <- takeUntilBlank conn id

73+ parseRequest port headers' conn remoteHost'

7474

7575takeUntilBlank :: Handle

7676 -> ([BS.ByteString] -> [BS.ByteString])

@@ -95,7 +95,7 @@ data InvalidRequest =

9595 deriving (Show, Typeable)

9696instance Exception InvalidRequest

9797

98−-- | Parse a set of header lines and responseBody into a 'Request'.

98+-- | Parse a set of header lines and body into a 'Request'.

9999parseRequest :: Port

100100 -> [BS.ByteString]

101101 -> Handle

@@ -119,7 +119,6 @@ parseRequest port lines' handle remoteHost' = do

119119 bs <- lookup ReqContentLength heads

120120 let str = SL.unpack bs

121121 Safe.readMay str

122− mlen <- newMVar len

123122 let (serverName', _) = SL.breakChar ':' host

124123 return $ Request

125124 { requestMethod = method

@@ -130,22 +129,11 @@ parseRequest port lines' handle remoteHost' = do

130129 , serverPort = port

131130 , requestHeaders = heads

132131 , urlScheme = HTTP

133− , requestBody = requestBodyHandle handle mlen

132+ , requestBody = Source len $ requestBodyHandle handle

134133 , errorHandler = System.IO.hPutStr System.IO.stderr

135134 , remoteHost = B8.pack remoteHost'

136135 }

137136

138−requestBodyHandle :: Handle -> MVar Int -> Enumerator a

139−requestBodyHandle h mlen iter accum = modifyMVar mlen (helper accum) where

140− helper a 0 = return (0, Right a)

141− helper a len = do

142− bs <- BS.hGet h $ min len defaultChunkSize

143− let newLen = len - BS.length bs

144− ea' <- iter a bs

145− case ea' of

146− Left a' -> return (newLen, Left a')

147− Right a' -> helper a' newLen

148−

149137parseFirst :: (StringLike s, MonadFailure InvalidRequest m) =>

150138 s

151139 -> m (s, s, s)

@@ -169,7 +157,7 @@ sendResponse h res = do

169157 BS.hPut h $ SL.pack "\r\n"

170158 case responseBody res of

171159 Left fp -> unsafeSendFile h fp

172− Right enum -> enum myPut h >> return ()

160+ Right (Enumerator enum) -> enum myPut h >> return ()

173161 where

174162 myPut _ bs = do

175163 BS.hPut h bs

Network/Wai/Middleware/CleanPath.hs+2−2

@@ -20,8 +20,8 @@ cleanPath app env =

2020 $ Right emptyEnum

2121 Right pieces -> app pieces env

2222

23−emptyEnum :: Enumerator a

24−emptyEnum _ = return . Right

23+emptyEnum :: Enumerator

24+emptyEnum = Enumerator $ \_ -> return . Right

2525

2626-- | Given a certain requested path, return either a corrected path

2727-- to redirect to or the tokenized path.

Network/Wai/Middleware/Gzip.hs+4−9

@@ -16,12 +16,11 @@

1616module Network.Wai.Middleware.Gzip (gzip) where

1717

1818import Network.Wai

19−import Network.Wai.Enumerator (mapE)

19+import Network.Wai.Enumerator (fromLBS', toLBS)

2020import Codec.Compression.GZip (compress)

2121import Data.Maybe (fromMaybe)

2222import Data.List.Split (splitOneOf)

2323import qualified Data.ByteString.Char8 as B

24−import qualified Data.ByteString.Lazy as L

2524

2625-- | Use gzip to compress the body of the response.

2726--

@@ -54,10 +53,6 @@ gzip app env = do

5453 }

5554 else return res

5655

57−compressE :: Either FilePath (Enumerator a) -> Either FilePath (Enumerator a)

58−compressE = either (Left . id) (Right . mapE compress')

59−

60−-- | Note: this might lose a lot of the compression power by dealing with

61−-- smaller chunks, I'm not certain.

62−compress' :: B.ByteString -> B.ByteString

63−compress' bs = B.concat $ L.toChunks $ compress $ L.fromChunks [bs]

56+compressE :: Either FilePath Enumerator -> Either FilePath Enumerator

57+compressE (Left fp) = Left fp

58+compressE (Right e) = Right $ fromLBS' $ fmap compress $ toLBS e

Network/Wai/Middleware/Jsonp.hs+2−2

@@ -51,8 +51,8 @@ jsonp app env = do

5151 }

5252 _ -> return res

5353

54−addCallback :: B8.ByteString -> Enumerator a -> Enumerator a

55−addCallback cb e iter a = do

54+addCallback :: B8.ByteString -> Enumerator -> Enumerator

55+addCallback cb (Enumerator e) = Enumerator $ \iter a -> do

5656 ea' <- iter a $ B8.snoc cb '('

5757 case ea' of

5858 Left a' -> return $ Left a'

wai-extra.cabal+1

@@ -34,4 +34,5 @@ Library

3434 Network.Wai.Middleware.Gzip

3535 Network.Wai.Middleware.Jsonp

3636 Network.Wai.Middleware.MethodOverride

37+ Other-modules: Network.Wai.Handler.Helper

3738 ghc-options: -Wall -Werror