@@ -5,30 +5,22 @@ module Network.Wai.Handler.DevelServer (run) where
55
66import Language.Haskell.Interpreter
77import Network.Wai
8−import qualified System.IO
98
10−import Data.ByteString (ByteString)
11−import Data.ByteString.Lazy.Internal (defaultChunkSize)
12−import qualified Data.ByteString.Char8 as B
13−import qualified Data.ByteString.Lazy as L
149import qualified Data.ByteString.Lazy.Char8 as L8
1510import Network
1611 ( listenOn, accept, sClose, PortID(PortNumber), Socket
1712 , withSocketsDo)
18−import Control.Exception (bracket, finally, Exception, throwIO,
19− handle, SomeException, toException)
13+import Control.Exception (bracket, finally, Exception,
14+ SomeException, toException)
15+import qualified Control.Exception as E
2016import System.IO (Handle, hClose)
2117import Control.Concurrent (forkIO, threadDelay)
22−import Control.Monad (unless, forM)
23−import Data.Maybe (isJust, fromJust, fromMaybe)
18+import Control.Monad (forM)
2419
25−import Data.Typeable (Typeable)
26−
27−import Network.Socket.SendFile
28−import Control.Arrow (first)
2920import qualified Control.Concurrent.MVar as M
3021import qualified Control.Concurrent.Chan as C
3122import System.Directory (getModificationTime)
23+import Network.Wai.Handler.SimpleServer (parseRequest, sendResponse)
3224
3325type FunctionName = String
3426
@@ -82,7 +74,7 @@ fillApp modu func mqueue =
8274 return (Just $ toException err, [])
8375 Right (app, files) -> do
8476 putStrLn "Interpreting success, new app loaded"
85− handle onInitErr $ do
77+ E.handle onInitErr $ do
8678 swapApp app mqueue
8779 files' <- forM files $ \f -> do
8880 t <- getModificationTime f
@@ -96,6 +88,7 @@ fillApp modu func mqueue =
9688loadingApp' :: Maybe SomeException -> M.MVar Queue -> IO ()
9789loadingApp' err mqueue = swapApp (loadingApp err) mqueue
9890
91+swapApp :: Handler -> M.MVar Queue -> IO ()
9992swapApp app mqueue = do
10093 oldqueue <- M.takeMVar mqueue
10194 C.writeChan oldqueue Nothing
@@ -114,7 +107,6 @@ loadingApp err f =
114107 toMessage (Just err') = "Error loading code: " ++ show err'
115108
116109type Handler = (Application -> IO ()) -> IO ()
117−type MHandler = M.MVar Application
118110
119111theapp :: String -> String -> IO (Either InterpreterError (Handler, [FilePath]))
120112theapp modu func =
@@ -147,142 +139,10 @@ type Queue = C.Chan (Maybe (Request, Response -> IO ()))
147139
148140serveConnection :: Port -> M.MVar Queue -> Handle -> String -> IO ()
149141serveConnection port mqueue conn remoteHost' = do
150− env <- hParseRequest port conn remoteHost'
142+ env <- parseRequest port conn remoteHost'
151143 let onRes res =
152144 finally
153145 (sendResponse (httpVersion env) conn res)
154146 (hClose conn)
155147 queue <- M.readMVar mqueue
156148 C.writeChan queue $ Just (env, onRes)
157−
158−hParseRequest :: Port -> Handle -> String -> IO Request
159−hParseRequest port conn remoteHost' = do
160− headers' <- takeUntilBlank conn id
161− parseRequest port headers' conn remoteHost'
162−
163−takeUntilBlank :: Handle
164− -> ([ByteString] -> [ByteString])
165− -> IO [ByteString]
166−takeUntilBlank h front = do
167− l <- stripCR `fmap` B.hGetLine h
168− if B.null l
169− then return $ front []
170− else takeUntilBlank h $ front . (:) l
171−
172−stripCR :: ByteString -> ByteString
173−stripCR bs
174− | B.null bs = bs
175− | B.last bs == '\r' = B.init bs
176− | otherwise = bs
177−
178−data InvalidRequest =
179− NotEnoughLines [String]
180− | HostNotIncluded
181− | BadFirstLine String
182− | NonHttp
183− deriving (Show, Typeable)
184−instance Exception InvalidRequest
185−
186−-- | Parse a set of header lines and body into a 'Request'.
187−parseRequest :: Port
188− -> [ByteString]
189− -> Handle
190− -> String
191− -> IO Request
192−parseRequest port lines' handle remoteHost' = do
193− case lines' of
194− (_:_:_) -> return ()
195− _ -> throwIO $ NotEnoughLines $ map B.unpack lines'
196− (method, rpath', gets, httpversion) <- parseFirst $ head lines'
197− let rpath = '/' : case B.unpack rpath' of
198− ('/':x) -> x
199− _ -> B.unpack rpath'
200− let heads = map (first mkCIByteString . parseHeaderNoAttr) $ tail lines'
201− let host' = lookup "Host" heads
202− unless (isJust host') $ throwIO HostNotIncluded
203− let host = fromJust host'
204− let len = fromMaybe 0 $ do
205− bs <- lookup "Content-Length" heads
206− let str = B.unpack bs
207− case reads str of
208− (x, _):_ -> Just x
209− _ -> Nothing
210− let (serverName', _) = B.break (== ':') host
211− return $ Request
212− { requestMethod = method
213− , httpVersion = httpversion
214− , pathInfo = B.pack rpath
215− , queryString = gets
216− , serverName = serverName'
217− , serverPort = port
218− , requestHeaders = heads
219− , isSecure = False
220− , requestBody = requestBodyHandle handle len
221− , errorHandler = System.IO.hPutStr System.IO.stderr
222− , remoteHost = B.pack remoteHost'
223− }
224−
225−parseFirst :: ByteString
226− -> IO (ByteString, ByteString, ByteString, HttpVersion)
227−parseFirst s = do
228− let pieces = B.words s
229− (method, query, http') <-
230− case pieces of
231− [x, y, z] -> return (x, y, z)
232− _ -> throwIO $ BadFirstLine $ B.unpack s
233− let (hfirst, hsecond) = B.splitAt 5 http'
234− unless (hfirst == B.pack "HTTP/") $ throwIO NonHttp
235− let (rpath, qstring) = B.break (== '?') query
236− return (method, rpath, qstring, hsecond)
237−
238−sendResponse :: HttpVersion -> Handle -> Response -> IO ()
239−sendResponse httpversion h res = do
240− B.hPut h $ B.pack "HTTP/"
241− B.hPut h $ httpversion
242− B.hPut h $ B.pack " "
243− B.hPut h $ B.pack $ show $ statusCode $ status res
244− B.hPut h $ B.pack " "
245− B.hPut h $ statusMessage $ status res
246− B.hPut h $ B.pack "\r\n"
247− mapM_ putHeader $ responseHeaders res
248− B.hPut h $ B.pack "\r\n"
249− case responseBody res of
250− ResponseFile fp -> unsafeSendFile h fp
251− ResponseEnumerator (Enumerator enum) -> enum myPut h >> return ()
252− ResponseLBS lbs -> L.hPut h lbs
253− where
254− myPut _ bs = do
255− B.hPut h bs
256− return (Right h)
257− putHeader (x, y) = do
258− B.hPut h $ ciOriginal x
259− B.hPut h $ B.pack ": "
260− B.hPut h y
261− B.hPut h $ B.pack "\r\n"
262−
263−parseHeaderNoAttr :: ByteString -> (ByteString, ByteString)
264−parseHeaderNoAttr s =
265− let (k, rest) = B.span (/= ':') s
266− rest' = if not (B.null rest) &&
267− B.head rest == ':' &&
268− not (B.null $ B.tail rest) &&
269− B.head (B.tail rest) == ' '
270− then B.drop 2 rest
271− else rest
272− in (k, rest')
273−
274−requestBodyHandle :: Handle -> Int -> Source
275−requestBodyHandle h =
276− requestBodyFunc go
277− where
278− go i = Just `fmap` B.hGet h (min i defaultChunkSize)
279−
280−requestBodyFunc :: (Int -> IO (Maybe B.ByteString)) -> Int -> Source
281−requestBodyFunc _ 0 = Source $ return Nothing
282−requestBodyFunc h len = Source $ do
283− mbs <- h len
284− case mbs of
285− Nothing -> return Nothing
286− Just bs -> do
287− let newLen = len - B.length bs
288− return $ Just (bs, requestBodyFunc h $ max 0 newLen)