@@ -35,7 +35,6 @@ import Data.Maybe (isJust, fromJust, fromMaybe)
3535import Control.Failure
3636import Data.Typeable (Typeable)
3737
38−import Web.Encodings.StringLike (StringLike)
3938import qualified Web.Encodings.StringLike as SL
4039
4140import qualified Safe
@@ -72,7 +71,7 @@ serveConnection port app conn remoteHost' =
7271 serveOneRequest' = do
7372 env <- hParseRequest port conn remoteHost'
7473 res <- app env
75− sendResponse conn res
74+ sendResponse (httpVersion env) conn res
7675 return $ shouldConnectionClose env res
7776
7877reqConnectionHeader :: RequestHeader
@@ -117,7 +116,7 @@ data InvalidRequest =
117116 NotEnoughLines [String]
118117 | HostNotIncluded
119118 | BadFirstLine String
120− | NonHttp11
119+ | NonHttp
121120 deriving (Show, Typeable)
122121instance Exception InvalidRequest
123122
@@ -131,7 +130,7 @@ parseRequest port lines' handle remoteHost' = do
131130 case lines' of
132131 (_:_:_) -> return ()
133132 _ -> failure $ NotEnoughLines $ map SL.unpack lines'
134− (method', rpath', gets) <- parseFirst $ head lines'
133+ (method', rpath', gets, httpversion) <- parseFirst $ head lines'
135134 let method = methodFromBS method'
136135 let rpath = '/' : case SL.unpack rpath' of
137136 ('/':x) -> x
@@ -148,7 +147,7 @@ parseRequest port lines' handle remoteHost' = do
148147 let (serverName', _) = SL.breakChar ':' host
149148 return $ Request
150149 { requestMethod = method
151− , httpVersion = Http11
150+ , httpVersion = httpversion
152151 , pathInfo = SL.pack rpath
153152 , queryString = gets
154153 , serverName = serverName'
@@ -160,27 +159,33 @@ parseRequest port lines' handle remoteHost' = do
160159 , remoteHost = B8.pack remoteHost'
161160 }
162161
163−parseFirst :: (StringLike s, MonadFailure InvalidRequest m) =>
164− s
165− -> m (s, s, s)
162+parseFirst :: BS.ByteString
163+ -> IO (BS.ByteString, BS.ByteString, BS.ByteString, HttpVersion)
166164parseFirst s = do
167165 let pieces = SL.split ' ' s
168166 (method, query, http') <-
169167 case pieces of
170168 [x, y, z] -> return (x, y, z)
171169 _ -> failure $ BadFirstLine $ SL.unpack s
172− unless (http' == SL.pack "HTTP/1.1") $ failure NonHttp11
170+ print ("http", http')
171+ let (hfirst, hsecond) = BS.splitAt 5 http'
172+ print (hfirst, hsecond)
173+ unless (hfirst == B8.pack "HTTP/") $ failure NonHttp
173174 let (rpath, qstring) = SL.breakChar '?' query
174− return (method, rpath, qstring)
175−
176−sendResponse :: Handle -> Response -> IO ()
177−sendResponse h res = do
178− BS.hPut h $ SL.pack "HTTP/1.1 "
179− BS.hPut h $ SL.pack $ show $ statusCode $ status res
175+ print (httpVersionFromBS hsecond)
176+ return (method, rpath, qstring, httpVersionFromBS hsecond)
177+
178+sendResponse :: HttpVersion -> Handle -> Response -> IO ()
179+sendResponse httpversion h res = do
180+ BS.hPut h $ B8.pack "HTTP/"
181+ print $ httpVersionToBS httpversion
182+ BS.hPut h $ httpVersionToBS httpversion
183+ BS.hPut h $ B8.pack " "
184+ BS.hPut h $ B8.pack $ show $ statusCode $ status res
180185 BS.hPut h $ statusMessage $ status res
181− BS.hPut h $ SL.pack "\r\n"
186+ BS.hPut h $ B8.pack "\r\n"
182187 mapM_ putHeader $ responseHeaders res
183− BS.hPut h $ SL.pack "\r\n"
188+ BS.hPut h $ B8.pack "\r\n"
184189 case responseBody res of
185190 Left fp -> unsafeSendFile h fp
186191 Right (Enumerator enum) -> enum myPut h >> return ()
@@ -194,7 +199,7 @@ sendResponse h res = do
194199 BS.hPut h y
195200 BS.hPut h $ SL.pack "\r\n"
196201
197−parseHeaderNoAttr :: StringLike a => a -> (a, a)
202+parseHeaderNoAttr :: BS.ByteString -> (BS.ByteString, BS.ByteString)
198203parseHeaderNoAttr s =
199− let (k, rest) = SL.span (/= ':') s
200− in (k, SL.dropPrefix' (SL.pack ": ") rest)
204+ let (k, rest) = B8.span (/= ':') s
205+ in (k, SL.dropPrefix' (B8.pack ": ") rest)