ca0a26f · typeable/wai

git.iko.soy/typeable/wai

on master help sign in

Non just HTTP 1.1

ca0a26fSnoyman17 years ago

Network/Wai/Handler/SimpleServer.hs+25−20

compare with master

unifiedsplit

@@ -35,7 +35,6 @@ import Data.Maybe (isJust, fromJust, fromMaybe)

35import Control.Failure

36import Data.Typeable (Typeable)

38−import Web.Encodings.StringLike (StringLike)

39import qualified Web.Encodings.StringLike as SL

38import qualified Web.Encodings.StringLike as SL

41import qualified Safe

40import qualified Safe

@@ -72,7 +71,7 @@ serveConnection port app conn remoteHost' =

72 serveOneRequest' = do

71 serveOneRequest' = do

73 env <- hParseRequest port conn remoteHost'

72 env <- hParseRequest port conn remoteHost'

74 res <- app env

73 res <- app env

75− sendResponse conn res

74+ sendResponse (httpVersion env) conn res

76 return $ shouldConnectionClose env res

75 return $ shouldConnectionClose env res

78reqConnectionHeader :: RequestHeader

77reqConnectionHeader :: RequestHeader

@@ -117,7 +116,7 @@ data InvalidRequest =

117 NotEnoughLines [String]

116 NotEnoughLines [String]

118 | HostNotIncluded

117 | HostNotIncluded

119 | BadFirstLine String

118 | BadFirstLine String

120− | NonHttp11

119+ | NonHttp

121 deriving (Show, Typeable)

120 deriving (Show, Typeable)

122instance Exception InvalidRequest

121instance Exception InvalidRequest

123

122

@@ -131,7 +130,7 @@ parseRequest port lines' handle remoteHost' = do

131 case lines' of

130 case lines' of

132 (_:_:_) -> return ()

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

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

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

134− (method', rpath', gets) <- parseFirst $ head lines'

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

135 let method = methodFromBS method'

134 let method = methodFromBS method'

136 let rpath = '/' : case SL.unpack rpath' of

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

137 ('/':x) -> x

136 ('/':x) -> x

@@ -148,7 +147,7 @@ parseRequest port lines' handle remoteHost' = do

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

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

149 return $ Request

148 return $ Request

150 { requestMethod = method

149 { requestMethod = method

151− , httpVersion = Http11

150+ , httpVersion = httpversion

152 , pathInfo = SL.pack rpath

151 , pathInfo = SL.pack rpath

153 , queryString = gets

152 , queryString = gets

154 , serverName = serverName'

153 , serverName = serverName'

@@ -160,27 +159,33 @@ parseRequest port lines' handle remoteHost' = do

160 , remoteHost = B8.pack remoteHost'

159 , remoteHost = B8.pack remoteHost'

161 }

160 }

162

161

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

162+parseFirst :: BS.ByteString

164− s

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

165− -> m (s, s, s)

166parseFirst s = do

164parseFirst s = do

167 let pieces = SL.split ' ' s

165 let pieces = SL.split ' ' s

168 (method, query, http') <-

166 (method, query, http') <-

169 case pieces of

167 case pieces of

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

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

171 _ -> failure $ BadFirstLine $ SL.unpack s

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

170+ print ("http", http')

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

172+ print (hfirst, hsecond)

172− unless (http' == SL.pack "HTTP/1.1") $ failure NonHttp11

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

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

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

175+ print (httpVersionFromBS hsecond)

174− return (method, rpath, qstring)

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

175−

177+

176−sendResponse :: Handle -> Response -> IO ()

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

177−sendResponse h res = do

179+sendResponse httpversion h res = do

178− BS.hPut h $ SL.pack "HTTP/1.1 "

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

181+ print $ httpVersionToBS httpversion

182+ BS.hPut h $ httpVersionToBS httpversion

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

179− BS.hPut h $ SL.pack $ show $ statusCode $ status res

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

180 BS.hPut h $ statusMessage $ status res

185 BS.hPut h $ statusMessage $ status res

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

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

182 mapM_ putHeader $ responseHeaders res

187 mapM_ putHeader $ responseHeaders res

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

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

184 case responseBody res of

189 case responseBody res of

185 Left fp -> unsafeSendFile h fp

190 Left fp -> unsafeSendFile h fp

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

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

@@ -194,7 +199,7 @@ sendResponse h res = do

194 BS.hPut h y

199 BS.hPut h y

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

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

196

201

197−parseHeaderNoAttr :: StringLike a => a -> (a, a)

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

198parseHeaderNoAttr s =

203parseHeaderNoAttr s =

199− let (k, rest) = SL.span (/= ':') s

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

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

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