3c8ffbd · typeable/wai

git.iko.soy/typeable/wai

on master help sign in

Removed the RequestBody typeclass

3c8ffbdMichael Snoyman17 years ago

Network/Wai.hs+1−9

compare with master

unifiedsplit

@@ -6,8 +6,6 @@ module Network.Wai

6 , Response (..)

7 , Application

8 , Middleware

9− , RequestBody (..)

10− , RequestBodyClass (..)

11 , ResponseBody (..)

9 , ResponseBody (..)

12 , ResponseBodyClass (..)

10 , ResponseBodyClass (..)

13 ) where

11 ) where

@@ -36,7 +34,7 @@ data Request = Request

36 , serverPort :: Int

34 , serverPort :: Int

37 , httpHeaders :: [(B.ByteString, B.ByteString)]

35 , httpHeaders :: [(B.ByteString, B.ByteString)]

38 , urlScheme :: UrlScheme

36 , urlScheme :: UrlScheme

39− , requestBody :: RequestBody

37+ , requestBody :: IO (Maybe B.ByteString)

40 , errorHandler :: String -> IO ()

38 , errorHandler :: String -> IO ()

41 , remoteHost :: String

39 , remoteHost :: String

42 }

40 }

@@ -52,12 +50,6 @@ type Application = Request -> IO Response

53type Middleware = Application -> Application

51type Middleware = Application -> Application

55−data RequestBody = forall a. RequestBodyClass a => RequestBody a

56−class RequestBodyClass a where

57− receiveByteString :: a -> IO (Maybe B.ByteString)

58−instance RequestBodyClass RequestBody where

59− receiveByteString (RequestBody a) = receiveByteString a

60−

61data ResponseBody = forall a. ResponseBodyClass a => ResponseBody a

53data ResponseBody = forall a. ResponseBodyClass a => ResponseBody a

62class ResponseBodyClass a where

54class ResponseBodyClass a where

63 sendByteString :: a -> B.ByteString -> IO ()

55 sendByteString :: a -> B.ByteString -> IO ()

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

@@ -29,7 +29,7 @@ import Control.Exception (bracket, finally, Exception)

29import System.IO (Handle, hClose)

30import Control.Concurrent

31import Control.Monad (unless)

32−import Data.Maybe (isJust, fromJust)

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

34import Control.Failure

35import Data.Typeable (Typeable)

@@ -37,6 +37,8 @@ import Data.Typeable (Typeable)

37import Web.Encodings.StringLike (StringLike)

38import qualified Web.Encodings.StringLike as SL

40+import qualified Safe

41+

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

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

41run port = withSocketsDo .

43run port = withSocketsDo .

42 bracket

44 bracket

@@ -97,12 +99,11 @@ data InvalidRequest =

97instance Exception InvalidRequest

99instance Exception InvalidRequest

100

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

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

100−parseRequest :: (MonadFailure InvalidRequest m)

102+parseRequest :: Port

101− => Port

102− -> [BS.ByteString]

103+ -> [BS.ByteString]

103− -> Handle

104+ -> Handle

104− -> String

105+ -> String

105− -> m Request

106+ -> IO Request

106parseRequest port lines' handle remoteHost' = do

107parseRequest port lines' handle remoteHost' = do

107 case lines' of

108 case lines' of

108 (_:_:_) -> return ()

109 (_:_:_) -> return ()

@@ -116,10 +117,11 @@ parseRequest port lines' handle remoteHost' = do

116 let host' = lookup (SL.pack "Host") heads

117 let host' = lookup (SL.pack "Host") heads

117 unless (isJust host') $ failure HostNotIncluded

118 unless (isJust host') $ failure HostNotIncluded

118 let host = fromJust host'

119 let host = fromJust host'

119− {- FIXME use length somewhere?

120+ let len = fromMaybe 0 $ do

120− let len = maybe "0" SL.unpack

121− $ lookup (SL.pack "Content-Length") heads

121+ bs <- lookup (SL.pack "Content-Length") heads

122− -}

122+ let str = SL.unpack bs

123+ Safe.readMay str

124+ mlen <- newMVar len

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

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

124 return $ Request

126 return $ Request

125 { requestMethod = method

127 { requestMethod = method

@@ -129,18 +131,19 @@ parseRequest port lines' handle remoteHost' = do

129 , serverPort = port

131 , serverPort = port

130 , httpHeaders = heads

132 , httpHeaders = heads

131 , urlScheme = HTTP

133 , urlScheme = HTTP

132− , requestBody = RequestBody $ SSRequestBody handle

134+ , requestBody = requestBodyHandle handle mlen

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

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

134 , remoteHost = remoteHost'

136 , remoteHost = remoteHost'

135 }

137 }

136

138

137−newtype SSRequestBody = SSRequestBody Handle

139+requestBodyHandle :: Handle -> MVar Int -> IO (Maybe BS.ByteString)

138−instance RequestBodyClass SSRequestBody where

140+requestBodyHandle h mlen = modifyMVar mlen helper where

139− receiveByteString (SSRequestBody h) = do

141+ helper :: Int -> IO (Int, Maybe BS.ByteString)

140− bs <- BS.hGet h 1024 -- FIXME find a good chunk size

142+ helper 0 = return (0, Nothing)

141− if BS.null bs

143+ helper len = do

142− then return Nothing

144+ bs <- BS.hGet h len

145+ let newLen = len - BS.length bs

143− else return $ Just bs

146+ return (newLen, Just bs)

144

147

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

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

146 s

149 s

index.html+6

@@ -7,5 +7,11 @@

7 <body>

8 <p>It works</p>

9 <p>Here's some Unicode stuff: שלום</p>

10+ <form method="POST" action="/post/" enctype="multipart/form-data">

11+ <p>Name: <input type="text" name="name"></p>

12+ <textarea name="textarea"></textarea>

13+ <p>Some file: <input type="file" name="file"></p>

14+ <p><input type="submit"></p>

15+ </form>

10 </body>

16 </body>

11</html>

17</html>

test.hs+27−6

@@ -1,17 +1,38 @@

1import Network.Wai

2import Network.Wai.Handler.SimpleServer

3import qualified Data.ByteString.Char8 as B8

4+import qualified Data.ByteString as B

5main :: IO ()

6main :: IO ()

6main = putStrLn "http://localhost:3000/" >> run 3000 app

7main = putStrLn "http://localhost:3000/" >> run 3000 app

8app :: Application

9app :: Application

10+app req = case B8.unpack $ pathInfo req of

11+ "/post/" -> postResponse $ requestBody req

12+ _ -> indexResponse

13+

14+indexResponse :: IO Response

9−app _ = return $ Response

15+indexResponse = return Response

10− { status = 200

16+ { status = 200

11− , statusMessage = B8.pack "OK"

17+ , statusMessage = B8.pack "OK"

12− , headers = [(B8.pack "Content-Type", B8.pack "text/html")]

18+ , headers = [(B8.pack "Content-Type", B8.pack "text/html")]

13− , body = index

19+ , body = index

20+ }

21+

22+postResponse :: IO (Maybe B.ByteString) -> IO Response

23+postResponse rb = return Response

24+ { status = 200

25+ , statusMessage = B8.pack "OK"

26+ , headers = [(B8.pack "Content-Type", B8.pack "text/plain")]

27+ , body = postBody rb

14− }

28+ }

16index :: ResponseBody -> IO ()

30index :: ResponseBody -> IO ()

17index rb = sendFile rb "index.html"

31index rb = sendFile rb "index.html"

32+

33+postBody :: IO (Maybe B.ByteString) -> ResponseBody -> IO ()

34+postBody req res = do

35+ mbs <- req

36+ case mbs of

37+ Nothing -> return ()

38+ Just bs -> sendByteString res bs >> postBody req res