de3b989 · typeable/wai

git.iko.soy/typeable/wai

on master help sign in

Switch to newtype and Source

de3b989Snoyman17 years ago

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

compare with master

unifiedsplit

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

6import Network.Wai

7import Network.Wai.Enumerator (fromEitherFile)

8+import Network.Wai.Handler.Helper

8import System.Environment (getEnvironment)

9import System.Environment (getEnvironment)

9import Data.Maybe (fromMaybe)

10import Data.Maybe (fromMaybe)

10import qualified Data.ByteString.Char8 as B

11import qualified Data.ByteString.Char8 as B

11import Control.Arrow ((***))

12import Control.Arrow ((***))

12import Data.Char (toLower)

13import Data.Char (toLower)

13import qualified System.IO

14import qualified System.IO

14−import Control.Concurrent

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

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

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

18safeRead d s =

17safeRead d s =

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

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

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

52 "https" -> HTTPS

51 "https" -> HTTPS

53 _ -> HTTP

52 _ -> HTTP

54− mContentLength <- newMVar contentLength

55 let env = Request

53 let env = Request

56 { requestMethod = rmethod

54 { requestMethod = rmethod

57 , pathInfo = B.pack pinfo

55 , pathInfo = B.pack pinfo

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

60 , serverPort = serverport

58 , serverPort = serverport

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

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

62 , urlScheme = urlScheme'

60 , urlScheme = urlScheme'

63− , requestBody = requestBodyHandle inputH mContentLength

61+ , requestBody = Source contentLength $ requestBodyHandle inputH

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

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

65 , remoteHost = B.pack remoteHost'

63 , remoteHost = B.pack remoteHost'

66 , httpVersion = HttpVersion B.empty

64 , httpVersion = HttpVersion B.empty

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

77 hPut $ B.singleton '\n'

75 hPut $ B.singleton '\n'

78 mapM_ (printHeader hPut) h'

76 mapM_ (printHeader hPut) h'

79 hPut $ B.singleton '\n'

77 hPut $ B.singleton '\n'

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

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

81 return ()

79 return ()

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

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

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

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

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−

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

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

98 -> (ResponseHeader, B.ByteString)

85 -> (ResponseHeader, B.ByteString)

99 -> IO ()

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

18 ) where

20import Network.Wai

21+import Network.Wai.Handler.Helper

21import qualified System.IO

22import qualified System.IO

23import qualified Data.ByteString as BS

24import qualified Data.ByteString as BS

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

27 , withSocketsDo)

28 , withSocketsDo)

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

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

29import System.IO (Handle, hClose)

30import System.IO (Handle, hClose)

30−import Control.Concurrent

31+import Control.Concurrent (forkIO)

31import Control.Monad (unless)

32import Control.Monad (unless)

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

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

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

40import qualified Safe

41import qualified Safe

41import Network.Socket.SendFile

42import Network.Socket.SendFile

42import Control.Arrow (first)

43import Control.Arrow (first)

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

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

46run port = withSocketsDo .

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

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

71hParseRequest port conn remoteHost' = do

72− responseHeaders' <- takeUntilBlank conn id

72+ headers' <- takeUntilBlank conn id

73− parseRequest port responseHeaders' conn remoteHost'

73+ parseRequest port headers' conn remoteHost'

75takeUntilBlank :: Handle

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

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

95 deriving (Show, Typeable)

96instance Exception InvalidRequest

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

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

99parseRequest :: Port

100 -> [BS.ByteString]

101 -> Handle

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

119 bs <- lookup ReqContentLength heads

120 let str = SL.unpack bs

121 Safe.readMay str

122− mlen <- newMVar len

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

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

124 return $ Request

123 return $ Request

125 { requestMethod = method

124 { requestMethod = method

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

130 , serverPort = port

129 , serverPort = port

131 , requestHeaders = heads

130 , requestHeaders = heads

132 , urlScheme = HTTP

131 , urlScheme = HTTP

133− , requestBody = requestBodyHandle handle mlen

132+ , requestBody = Source len $ requestBodyHandle handle

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

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

135 , remoteHost = B8.pack remoteHost'

134 , remoteHost = B8.pack remoteHost'

136 }

135 }

137

136

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−

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

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

150 s

138 s

151 -> m (s, s, s)

139 -> m (s, s, s)

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

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

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

170 case responseBody res of

158 case responseBody res of

171 Left fp -> unsafeSendFile h fp

159 Left fp -> unsafeSendFile h fp

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

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

173 where

161 where

174 myPut _ bs = do

162 myPut _ bs = do

175 BS.hPut h bs

163 BS.hPut h bs

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

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

20 $ Right emptyEnum

21 Right pieces -> app pieces env

23−emptyEnum :: Enumerator a

23+emptyEnum :: Enumerator

24−emptyEnum _ = return . Right

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

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

27-- to redirect to or the tokenized path.

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

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

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

18import Network.Wai

19−import Network.Wai.Enumerator (mapE)

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

20import Codec.Compression.GZip (compress)

21import Data.Maybe (fromMaybe)

22import Data.List.Split (splitOneOf)

23import qualified Data.ByteString.Char8 as B

24−import qualified Data.ByteString.Lazy as L

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

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

27--

26--

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

54 }

53 }

55 else return res

54 else return res

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

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

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

57+compressE (Left fp) = Left fp

59−

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

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]

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

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

51 }

52 _ -> return res

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

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

55−addCallback cb e iter a = do

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

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

57 case ea' of

58 Left a' -> return $ Left a'

wai-extra.cabal+1

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

34 Network.Wai.Middleware.Gzip

35 Network.Wai.Middleware.Jsonp

36 Network.Wai.Middleware.MethodOverride

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

37 ghc-options: -Wall -Werror

38 ghc-options: -Wall -Werror