de699b0 · typeable/wai

18 ( run

19 , sendResponse

20 , parseRequest

21− , drainRequestBody

22 ) where

21 ) where

23

22

24import Network.Wai

23import Network.Wai

25import qualified System.IO

24import qualified System.IO

26

25

27import Data.ByteString (ByteString)

26import Data.ByteString (ByteString)

28−import qualified Data.ByteString.Char8 as B

29import qualified Data.ByteString as S

27import qualified Data.ByteString as S

28+import qualified Data.ByteString.Char8 as B

30import qualified Data.ByteString.Lazy as L

29import qualified Data.ByteString.Lazy as L

31import Network

30import Network

32 ( listenOn, accept, sClose, PortID(PortNumber), Socket

31 ( listenOn, accept, sClose, PortID(PortNumber), Socket

33 , withSocketsDo)

32 , withSocketsDo)

34−import Control.Exception (bracket, finally, Exception, throwIO)

33+import Control.Exception (bracket, finally, Exception)

35import System.IO (Handle, hClose, hFlush)

34import System.IO (Handle, hClose, hFlush)

36import System.IO.Error (isEOFError, ioeGetHandle)

35import System.IO.Error (isEOFError, ioeGetHandle)

37import Control.Concurrent (forkIO)

36import Control.Concurrent (forkIO)

44

43

45import Data.Enumerator (($$), (>>==))

44import Data.Enumerator (($$), (>>==))

46import qualified Data.Enumerator as E

45import qualified Data.Enumerator as E

47−import Data.Enumerator.IO (iterHandle)

46+import Data.Enumerator.IO (iterHandle, enumHandle)

48import Blaze.ByteString.Builder.Enumerator (builderToByteString)

47import Blaze.ByteString.Builder.Enumerator (builderToByteString)

49import Blaze.ByteString.Builder.HTTP

48import Blaze.ByteString.Builder.HTTP

50 (chunkedTransferEncoding, chunkedTransferTerminator)

49 (chunkedTransferEncoding, chunkedTransferTerminator)

54import Network.Socket.SendFile (unsafeSendFile)

53import Network.Socket.SendFile (unsafeSendFile)

55

54

56import Control.Monad.IO.Class (liftIO)

55import Control.Monad.IO.Class (liftIO)

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

58−

59−import Data.IORef (IORef, writeIORef, readIORef, newIORef)

60

56

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

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

62run port = withSocketsDo .

58run port = withSocketsDo .

69serveConnections :: Port -> Application -> Socket -> IO ()

65serveConnections :: Port -> Application -> Socket -> IO ()

70serveConnections port app socket = do

66serveConnections port app socket = do

71 (conn, remoteHost', _) <- accept socket -- FIXME use sockets directly instead of Handlers?

67 (conn, remoteHost', _) <- accept socket -- FIXME use sockets directly instead of Handlers?

68+ -- FIXME disable buffering

72 _ <- forkIO $ serveConnection port app conn remoteHost'

69 _ <- forkIO $ serveConnection port app conn remoteHost'

73 serveConnections port app socket

70 serveConnections port app socket

74

71

75serveConnection :: Port -> Application -> Handle -> String -> IO ()

72serveConnection :: Port -> Application -> Handle -> String -> IO ()

76serveConnection port app conn remoteHost' = do

73serveConnection port app conn remoteHost' = do

77− catch

74+ catch

78− (finally

75+ (finally

79− serveConnection'

76+ (E.run_ $ fromClient $$ serveConnection')

80− (hClose conn))

77+ (hClose conn))

81− catchEOFError

78+ catchEOFError

79+ where

80+ fromClient = enumHandle 4096 conn

82− where serveConnection' = do

81+ serveConnection' = do

83− (ilen, env) <- parseRequest port conn remoteHost'

82+ (enumeratee, env) <- parseRequest port remoteHost'

84− res <- app env

83+ res <- E.joinI $ enumeratee $$ app env

85− drainRequestBody conn ilen

86− keepAlive <- sendResponse env (httpVersion env) conn res

84+ keepAlive <- liftIO $ sendResponse env (httpVersion env) conn res

87− hFlush conn

85+ liftIO $ hFlush conn

88− when keepAlive serveConnection'

86+ when keepAlive serveConnection'

89

87

90− catchEOFError :: IOError -> IO ()

88+ catchEOFError :: IOError -> IO ()

89+ catchEOFError e

90+ | isEOFError e =

91− catchEOFError e | isEOFError e = case ioeGetHandle e of

91+ case ioeGetHandle e of

92− Just h -> unless (h == conn) (ioError e)

92+ Just h -> unless (h == conn) (ioError e)

93− Nothing -> ioError e

93+ Nothing -> ioError e

94− | otherwise = ioError e

94+ | otherwise = ioError e

95

96−drainRequestBody :: Handle -> IORef Int -> IO ()

96+parseRequest :: Port -> String -> E.Iteratee S.ByteString IO (E.Enumeratee ByteString ByteString IO a, Request)

97−drainRequestBody conn ilen = do

97+parseRequest port remoteHost' = do

98− remaining <- readIORef ilen

98+ headers' <- takeUntilBlank 0 id

99− _ <- B.hGet conn remaining -- FIXME just skip, don't read

99+ parseRequest' port headers' remoteHost'

100− return ()

101

100

102−parseRequest :: Port -> Handle -> String -> IO (IORef Int, Request)

101+-- FIXME come up with good values here

103−parseRequest port conn remoteHost' = do

102+maxHeaders, maxHeaderLength :: Int

104− headers' <- takeUntilBlank conn id

103+maxHeaders = 30

105− parseRequest' port headers' conn remoteHost'

104+maxHeaderLength = 1024

106

105

107−takeUntilBlank :: Handle

106+takeUntilBlank :: Int

108 -> ([ByteString] -> [ByteString])

107 -> ([ByteString] -> [ByteString])

109− -> IO [ByteString]

108+ -> E.Iteratee S.ByteString IO [ByteString]

110−takeUntilBlank h front = do

109+takeUntilBlank count _

111− l <- stripCR `fmap` B.hGetLine h

110+ | count > maxHeaders = E.throwError TooManyHeaders

111+takeUntilBlank count front = do

112+ l <- takeLine 0 id

112 if B.null l

113 if B.null l

113 then return $ front []

114 then return $ front []

114− else takeUntilBlank h $ front . (:) l

115+ else takeUntilBlank (count + 1) $ front . (:) l

115

116

117+takeLine :: Int

116−stripCR :: ByteString -> ByteString

118+ -> ([ByteString] -> [ByteString])

117−stripCR bs

119+ -> E.Iteratee ByteString IO ByteString

118− | B.null bs = bs

120+takeLine len front = do

119− | B.last bs == '\r' = B.init bs

121+ mbs <- E.head

122+ case mbs of

123+ Nothing -> E.throwError IncompleteHeaders

124+ Just bs -> do

125+ let (x, y) = S.breakByte 10 bs

126+ x' = if S.length x > 0 && S.last x == 13

127+ then S.init x

128+ else x

129+ let len' = len + B.length x

130+ case () of

131+ ()

132+ | len' > maxHeaderLength -> E.throwError OverLargeHeader

133+ | B.null y -> takeLine len' $ front . (:) x

120− | otherwise = bs

134+ | otherwise -> do

135+ E.yield () $ E.Chunks [B.drop 1 y]

136+ return $ B.concat $ front [x']

121

137

122data InvalidRequest =

138data InvalidRequest =

123 NotEnoughLines [String]

139 NotEnoughLines [String]

124 | BadFirstLine String

140 | BadFirstLine String

125 | NonHttp

141 | NonHttp

142+ | TooManyHeaders

143+ | IncompleteHeaders

144+ | OverLargeHeader

126 deriving (Show, Typeable)

145 deriving (Show, Typeable)

127instance Exception InvalidRequest

146instance Exception InvalidRequest

128

147

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

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

130parseRequest' :: Port

149parseRequest' :: Port

131 -> [ByteString]

150 -> [ByteString]

132− -> Handle

133 -> String

151 -> String

134− -> IO (IORef Int, Request)

152+ -> E.Iteratee S.ByteString IO (E.Enumeratee S.ByteString S.ByteString IO a, Request)

135−parseRequest' port lines' handle remoteHost' = do

153+parseRequest' port lines' remoteHost' = do

136 (firstLine, otherLines) <-

154 (firstLine, otherLines) <-

137 case lines' of

155 case lines' of

138 x:xs -> return (x, xs)

156 x:xs -> return (x, xs)

139− [] -> throwIO $ NotEnoughLines $ map B.unpack lines'

157+ [] -> E.throwError $ NotEnoughLines $ map B.unpack lines'

140 (method, rpath', gets, httpversion) <- parseFirst firstLine

158 (method, rpath', gets, httpversion) <- parseFirst firstLine

141 let rpath = '/' : case B.unpack rpath' of

159 let rpath = '/' : case B.unpack rpath' of

142 ('/':x) -> x

160 ('/':x) -> x

150 (x, _):_ -> Just x

168 (x, _):_ -> Just x

151 _ -> Nothing

169 _ -> Nothing

152 let (serverName', _) = B.break (== ':') host

170 let (serverName', _) = B.break (== ':') host

153− ilen <- newIORef len

154− return (ilen, Request

171+ return (requestBodyHandle len, Request

155 { requestMethod = method

172 { requestMethod = method

156 , httpVersion = httpversion

173 , httpVersion = httpversion

157 , pathInfo = B.pack rpath

174 , pathInfo = B.pack rpath

160 , serverPort = port

177 , serverPort = port

161 , requestHeaders = heads

178 , requestHeaders = heads

162 , isSecure = False

179 , isSecure = False

163− , requestBody = requestBodyHandle handle ilen len

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

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

165 , remoteHost = B.pack remoteHost'

181 , remoteHost = B.pack remoteHost'

166 })

182 })

167

183

168parseFirst :: ByteString

184parseFirst :: ByteString

169− -> IO (ByteString, ByteString, ByteString, HttpVersion)

185+ -> E.Iteratee S.ByteString IO (ByteString, ByteString, ByteString, HttpVersion)

170parseFirst s = do

186parseFirst s = do

171 let pieces = B.words s

187 let pieces = B.words s

172 (method, query, http') <-

188 (method, query, http') <-

173 case pieces of

189 case pieces of

174 [x, y, z] -> return (x, y, z)

190 [x, y, z] -> return (x, y, z)

175− _ -> throwIO $ BadFirstLine $ B.unpack s

191+ _ -> E.throwError $ BadFirstLine $ B.unpack s

176 let (hfirst, hsecond) = B.splitAt 5 http'

192 let (hfirst, hsecond) = B.splitAt 5 http'

177− unless (hfirst == B.pack "HTTP/") $ throwIO NonHttp

193+ unless (hfirst == "HTTP/") $ E.throwError NonHttp

178 let (rpath, qstring) = B.break (== '?') query

194 let (rpath, qstring) = B.break (== '?') query

179 return (method, rpath, qstring, hsecond)

195 return (method, rpath, qstring, hsecond)

180

196

256 else rest

272 else rest

257 in (k, rest')

273 in (k, rest')

258

274

259−requestBodyHandle :: Handle

275+requestBodyHandle :: Int

260− -> IORef Int

261− -> Int

262− -> E.Enumerator B.ByteString IO a

276+ -> E.Enumeratee ByteString ByteString IO a

263−requestBodyHandle handle ilen initLen =

277+requestBodyHandle initLen =

264 go initLen

278 go initLen

265 where

279 where

266− go 0 step = E.returnI step

280+ go 0 step = return step

267 go len (E.Continue k) = do

281 go len (E.Continue k) = do

268− bs <- liftIO $ B.hGet handle (min len defaultChunkSize) -- FIXME play with defaultChunkSize

282+ x <- E.head

283+ case x of

284+ Nothing -> return $ E.Continue k

285+ Just bs -> do

269− let newLen = len - B.length bs

286+ let newlen = max 0 $ len - B.length bs

270− liftIO $ writeIORef ilen newLen

271− k (E.Chunks [bs]) >>== go newLen

287+ k (E.Chunks [bs]) >>== go newlen

272− go _ step = E.returnI step

288+ go len step = do

289+ drain len

290+ return step

291+ drain 0 = return ()

292+ drain len = do

293+ mbs <- E.head

294+ case mbs of

295+ Nothing -> return ()

296+ Just bs -> do

297+ let newlen = len - B.length bs

298+ if newlen <= 0

299+ then return ()

300+ else drain newlen