93b6355 · typeable/wai

21import Network.Wai.Handler.Helper

22import qualified System.IO

23

24−import qualified Data.ByteString as BS

24+import Data.ByteString (ByteString)

25−import qualified Data.ByteString.Char8 as B8

25+import qualified Data.ByteString.Char8 as B

26import Network

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

28 , withSocketsDo)

75 return $ shouldConnectionClose env res

76

77reqConnectionHeader :: RequestHeader

78−reqConnectionHeader = RequestHeader $ B8.pack "Connection"

78+reqConnectionHeader = RequestHeader $ B.pack "Connection"

79

80resConnectionHeader :: ResponseHeader

81−resConnectionHeader = ResponseHeader $ B8.pack "Connection"

81+resConnectionHeader = ResponseHeader $ B.pack "Connection"

82

83shouldConnectionClose :: Request -> Response -> Bool

84shouldConnectionClose req res = (isClose req_conn)

86

87 where

88 isClose v = case v of

89− Just x -> (B8.unpack x) == "close"

89+ Just x -> (B.unpack x) == "close"

90 Nothing -> False

91

92 req_conn = lookup reqConnectionHeader $ requestHeaders req

98 parseRequest port headers' conn remoteHost'

99

100takeUntilBlank :: Handle

101− -> ([BS.ByteString] -> [BS.ByteString])

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

102− -> IO [BS.ByteString]

102+ -> IO [ByteString]

103takeUntilBlank h front = do

104− l <- stripCR `fmap` BS.hGetLine h

104+ l <- stripCR `fmap` B.hGetLine h

105− if BS.null l

105+ if B.null l

106 then return $ front []

107 else takeUntilBlank h $ front . (:) l

108

109−stripCR :: BS.ByteString -> BS.ByteString

109+stripCR :: ByteString -> ByteString

110stripCR bs

111− | BS.null bs = bs

111+ | B.null bs = bs

112− | B8.last bs == '\r' = BS.init bs

112+ | B.last bs == '\r' = B.init bs

113 | otherwise = bs

114

115data InvalidRequest =

122

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

124parseRequest :: Port

125− -> [BS.ByteString]

125+ -> [ByteString]

126 -> Handle

127 -> String

128 -> IO Request

129parseRequest port lines' handle remoteHost' = do

130 case lines' of

131 (_:_:_) -> return ()

132− _ -> failure $ NotEnoughLines $ map SL.unpack lines'

132+ _ -> failure $ NotEnoughLines $ map B.unpack lines'

133 (method', rpath', gets, httpversion) <- parseFirst $ head lines'

134 let method = methodFromBS method'

135− let rpath = '/' : case SL.unpack rpath' of

135+ let rpath = '/' : case B.unpack rpath' of

136 ('/':x) -> x

137− _ -> SL.unpack rpath'

137+ _ -> B.unpack rpath'

138 let heads = map (first requestHeaderFromBS . parseHeaderNoAttr)

139 $ tail lines'

140 let host' = lookup Host heads

142 let host = fromJust host'

143 let len = fromMaybe 0 $ do

144 bs <- lookup ReqContentLength heads

145− let str = SL.unpack bs

145+ let str = B.unpack bs

146 Safe.readMay str

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

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

148 return $ Request

149 { requestMethod = method

150 , httpVersion = httpversion

151− , pathInfo = SL.pack rpath

151+ , pathInfo = B.pack rpath

152 , queryString = gets

153 , serverName = serverName'

154 , serverPort = port

156 , urlScheme = HTTP

157 , requestBody = requestBodyHandle handle len

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

159− , remoteHost = B8.pack remoteHost'

159+ , remoteHost = B.pack remoteHost'

160 }

161

162−parseFirst :: BS.ByteString

162+parseFirst :: ByteString

163− -> IO (BS.ByteString, BS.ByteString, BS.ByteString, HttpVersion)

163+ -> IO (ByteString, ByteString, ByteString, HttpVersion)

164parseFirst s = do

165 let pieces = SL.split ' ' s

166 (method, query, http') <-

167 case pieces of

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

169− _ -> failure $ BadFirstLine $ SL.unpack s

169+ _ -> failure $ BadFirstLine $ B.unpack s

170− print ("http", http')

171− let (hfirst, hsecond) = BS.splitAt 5 http'

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

172− print (hfirst, hsecond)

173− unless (hfirst == B8.pack "HTTP/") $ failure NonHttp

171+ unless (hfirst == B.pack "HTTP/") $ failure NonHttp

174− let (rpath, qstring) = SL.breakChar '?' query

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

175− print (httpVersionFromBS hsecond)

176 return (method, rpath, qstring, httpVersionFromBS hsecond)

173 return (method, rpath, qstring, httpVersionFromBS hsecond)

177

174

178sendResponse :: HttpVersion -> Handle -> Response -> IO ()

175sendResponse :: HttpVersion -> Handle -> Response -> IO ()

179sendResponse httpversion h res = do

176sendResponse httpversion h res = do

180− BS.hPut h $ B8.pack "HTTP/"

177+ B.hPut h $ B.pack "HTTP/"

181− print $ httpVersionToBS httpversion

182− BS.hPut h $ httpVersionToBS httpversion

178+ B.hPut h $ httpVersionToBS httpversion

183− BS.hPut h $ B8.pack " "

179+ B.hPut h $ B.pack " "

184− BS.hPut h $ B8.pack $ show $ statusCode $ status res

180+ B.hPut h $ B.pack $ show $ statusCode $ status res

185− BS.hPut h $ statusMessage $ status res

181+ B.hPut h $ statusMessage $ status res

186− BS.hPut h $ B8.pack "\r\n"

182+ B.hPut h $ B.pack "\r\n"

187 mapM_ putHeader $ responseHeaders res

183 mapM_ putHeader $ responseHeaders res

188− BS.hPut h $ B8.pack "\r\n"

184+ B.hPut h $ B.pack "\r\n"

189 case responseBody res of

185 case responseBody res of

190 Left fp -> unsafeSendFile h fp

186 Left fp -> unsafeSendFile h fp

191 Right (Enumerator enum) -> enum myPut h >> return ()

187 Right (Enumerator enum) -> enum myPut h >> return ()

192 where

188 where

193 myPut _ bs = do

189 myPut _ bs = do

194− BS.hPut h bs

190+ B.hPut h bs

195 return (Right h)

191 return (Right h)

196 putHeader (x, y) = do

192 putHeader (x, y) = do

197− BS.hPut h $ responseHeaderToBS x

193+ B.hPut h $ responseHeaderToBS x

198− BS.hPut h $ SL.pack ": "

194+ B.hPut h $ B.pack ": "

199− BS.hPut h y

195+ B.hPut h y

200− BS.hPut h $ SL.pack "\r\n"

196+ B.hPut h $ B.pack "\r\n"

201

197

202−parseHeaderNoAttr :: BS.ByteString -> (BS.ByteString, BS.ByteString)

198+parseHeaderNoAttr :: ByteString -> (ByteString, ByteString)

203parseHeaderNoAttr s =

199parseHeaderNoAttr s =

204− let (k, rest) = B8.span (/= ':') s

200+ let (k, rest) = B.span (/= ':') s

205− in (k, SL.dropPrefix' (B8.pack ": ") rest)

201+ in (k, SL.dropPrefix' (B.pack ": ") rest)