git.iko.soy/typeable/wai
on master help sign in
Removed the RequestBody typeclass
commit3c8ffbda062fa3bb3fc53b814203db9c4646d097 authorMichael Snoyman <michael@snoyman.com> dateSat 23 Jan 2010, 20:47 (17 years ago) parent5c9f4a0
4 files changed+56−34
compare with master
unifiedsplit
Network/Wai.hs+1−9 Network/Wai/Handler/SimpleServer.hs+22−19 index.html+6 test.hs+27−6
Network/Wai.hs+1−9
@@ -6,8 +6,6 @@ module Network.Wai
66 , Response (..)
77 , Application
88 , Middleware
9− , RequestBody (..)
10− , RequestBodyClass (..)
119 , ResponseBody (..)
1210 , ResponseBodyClass (..)
1311 ) where
@@ -36,7 +34,7 @@ data Request = Request
3634 , serverPort :: Int
3735 , httpHeaders :: [(B.ByteString, B.ByteString)]
3836 , urlScheme :: UrlScheme
39− , requestBody :: RequestBody
37+ , requestBody :: IO (Maybe B.ByteString)
4038 , errorHandler :: String -> IO ()
4139 , remoteHost :: String
4240 }
@@ -52,12 +50,6 @@ type Application = Request -> IO Response
5250
5351type Middleware = Application -> Application
5452
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−
6153data ResponseBody = forall a. ResponseBodyClass a => ResponseBody a
6254class ResponseBodyClass a where
6355 sendByteString :: a -> B.ByteString -> IO ()
Network/Wai/Handler/SimpleServer.hs+22−19
@@ -29,7 +29,7 @@ import Control.Exception (bracket, finally, Exception)
2929import System.IO (Handle, hClose)
3030import Control.Concurrent
3131import Control.Monad (unless)
32−import Data.Maybe (isJust, fromJust)
32+import Data.Maybe (isJust, fromJust, fromMaybe)
3333
3434import Control.Failure
3535import Data.Typeable (Typeable)
@@ -37,6 +37,8 @@ import Data.Typeable (Typeable)
3737import Web.Encodings.StringLike (StringLike)
3838import qualified Web.Encodings.StringLike as SL
3939
40+import qualified Safe
41+
4042run :: Port -> Application -> IO ()
4143run port = withSocketsDo .
4244 bracket
@@ -97,12 +99,11 @@ data InvalidRequest =
9799instance Exception InvalidRequest
98100
99101-- | Parse a set of header lines and body into a 'Request'.
100−parseRequest :: (MonadFailure InvalidRequest m)
101− => Port
102− -> [BS.ByteString]
103− -> Handle
104− -> String
105− -> m Request
102+parseRequest :: Port
103+ -> [BS.ByteString]
104+ -> Handle
105+ -> String
106+ -> IO Request
106107parseRequest port lines' handle remoteHost' = do
107108 case lines' of
108109 (_:_:_) -> return ()
@@ -116,10 +117,11 @@ parseRequest port lines' handle remoteHost' = do
116117 let host' = lookup (SL.pack "Host") heads
117118 unless (isJust host') $ failure HostNotIncluded
118119 let host = fromJust host'
119− {- FIXME use length somewhere?
120− let len = maybe "0" SL.unpack
121− $ lookup (SL.pack "Content-Length") heads
122− -}
120+ let len = fromMaybe 0 $ do
121+ bs <- lookup (SL.pack "Content-Length") heads
122+ let str = SL.unpack bs
123+ Safe.readMay str
124+ mlen <- newMVar len
123125 let (serverName', _) = SL.breakChar ':' host
124126 return $ Request
125127 { requestMethod = method
@@ -129,18 +131,19 @@ parseRequest port lines' handle remoteHost' = do
129131 , serverPort = port
130132 , httpHeaders = heads
131133 , urlScheme = HTTP
132− , requestBody = RequestBody $ SSRequestBody handle
134+ , requestBody = requestBodyHandle handle mlen
133135 , errorHandler = System.IO.hPutStr System.IO.stderr
134136 , remoteHost = remoteHost'
135137 }
136138
137−newtype SSRequestBody = SSRequestBody Handle
138−instance RequestBodyClass SSRequestBody where
139− receiveByteString (SSRequestBody h) = do
140− bs <- BS.hGet h 1024 -- FIXME find a good chunk size
141− if BS.null bs
142− then return Nothing
143− else return $ Just bs
139+requestBodyHandle :: Handle -> MVar Int -> IO (Maybe BS.ByteString)
140+requestBodyHandle h mlen = modifyMVar mlen helper where
141+ helper :: Int -> IO (Int, Maybe BS.ByteString)
142+ helper 0 = return (0, Nothing)
143+ helper len = do
144+ bs <- BS.hGet h len
145+ let newLen = len - BS.length bs
146+ return (newLen, Just bs)
144147
145148parseFirst :: (StringLike s, MonadFailure InvalidRequest m) =>
146149 s
index.html+6
@@ -7,5 +7,11 @@
77 <body>
88 <p>It works</p>
99 <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>
1016 </body>
1117</html>
test.hs+27−6
@@ -1,17 +1,38 @@
11import Network.Wai
22import Network.Wai.Handler.SimpleServer
33import qualified Data.ByteString.Char8 as B8
4+import qualified Data.ByteString as B
45
56main :: IO ()
67main = putStrLn "http://localhost:3000/" >> run 3000 app
78
89app :: Application
9−app _ = return $ Response
10− { status = 200
11− , statusMessage = B8.pack "OK"
12− , headers = [(B8.pack "Content-Type", B8.pack "text/html")]
13− , body = index
14− }
10+app req = case B8.unpack $ pathInfo req of
11+ "/post/" -> postResponse $ requestBody req
12+ _ -> indexResponse
13+
14+indexResponse :: IO Response
15+indexResponse = return Response
16+ { status = 200
17+ , statusMessage = B8.pack "OK"
18+ , headers = [(B8.pack "Content-Type", B8.pack "text/html")]
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
28+ }
1529
1630index :: ResponseBody -> IO ()
1731index 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