wai-handler-devel 0.0.1 → 0.0.2

raw patch · 2 files changed

+10/−150 lines, 2 filesdep +wai-extradep −sendfilePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: wai-extra

Dependencies removed: sendfile

API changes (from Hackage documentation)

Files

• Network/Wai/Handler/DevelServer.hs +8/−148
• wai-handler-devel.cabal +2/−2

@@ -5,30 +5,22 @@  import Language.Haskell.Interpreter import Network.Wai-import qualified System.IO -import Data.ByteString (ByteString)-import Data.ByteString.Lazy.Internal (defaultChunkSize)-import qualified Data.ByteString.Char8 as B-import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as L8 import Network     ( listenOn, accept, sClose, PortID(PortNumber), Socket     , withSocketsDo)-import Control.Exception (bracket, finally, Exception, throwIO,-                          handle, SomeException, toException)+import Control.Exception (bracket, finally, Exception,+                          SomeException, toException)+import qualified Control.Exception as E import System.IO (Handle, hClose) import Control.Concurrent (forkIO, threadDelay)-import Control.Monad (unless, forM)-import Data.Maybe (isJust, fromJust, fromMaybe)--import Data.Typeable (Typeable)+import Control.Monad (forM) -import Network.Socket.SendFile-import Control.Arrow (first) import qualified Control.Concurrent.MVar as M import qualified Control.Concurrent.Chan as C import System.Directory (getModificationTime)+import Network.Wai.Handler.SimpleServer (parseRequest, sendResponse)  type FunctionName = String @@ -82,7 +74,7 @@                 return (Just $ toException err, [])             Right (app, files) -> do                 putStrLn "Interpreting success, new app loaded"-                handle onInitErr $ do+                E.handle onInitErr $ do                     swapApp app mqueue                     files' <- forM files $ \f -> do                         t <- getModificationTime f@@ -96,6 +88,7 @@ loadingApp' :: Maybe SomeException -> M.MVar Queue -> IO () loadingApp' err mqueue = swapApp (loadingApp err) mqueue +swapApp :: Handler -> M.MVar Queue -> IO () swapApp app mqueue = do     oldqueue <- M.takeMVar mqueue     C.writeChan oldqueue Nothing@@ -114,7 +107,6 @@     toMessage (Just err') = "Error loading code: " ++ show err'  type Handler = (Application -> IO ()) -> IO ()-type MHandler = M.MVar Application  theapp :: String -> String -> IO (Either InterpreterError (Handler, [FilePath])) theapp modu func =@@ -147,142 +139,10 @@  serveConnection :: Port -> M.MVar Queue -> Handle -> String -> IO () serveConnection port mqueue conn remoteHost' = do-    env <- hParseRequest port conn remoteHost'+    env <- parseRequest port conn remoteHost'     let onRes res =             finally                 (sendResponse (httpVersion env) conn res)                 (hClose conn)     queue <- M.readMVar mqueue     C.writeChan queue $ Just (env, onRes)--hParseRequest :: Port -> Handle -> String -> IO Request-hParseRequest port conn remoteHost' = do-    headers' <- takeUntilBlank conn id-    parseRequest port headers' conn remoteHost'--takeUntilBlank :: Handle-               -> ([ByteString] -> [ByteString])-               -> IO [ByteString]-takeUntilBlank h front = do-    l <- stripCR `fmap` B.hGetLine h-    if B.null l-        then return $ front []-        else takeUntilBlank h $ front . (:) l--stripCR :: ByteString -> ByteString-stripCR bs-    | B.null bs = bs-    | B.last bs == '\r' = B.init bs-    | otherwise = bs--data InvalidRequest =-    NotEnoughLines [String]-    | HostNotIncluded-    | BadFirstLine String-    | NonHttp-    deriving (Show, Typeable)-instance Exception InvalidRequest---- | Parse a set of header lines and body into a 'Request'.-parseRequest :: Port-             -> [ByteString]-             -> Handle-             -> String-             -> IO Request-parseRequest port lines' handle remoteHost' = do-    case lines' of-        (_:_:_) -> return ()-        _ -> throwIO $ NotEnoughLines $ map B.unpack lines'-    (method, rpath', gets, httpversion) <- parseFirst $ head lines'-    let rpath = '/' : case B.unpack rpath' of-                        ('/':x) -> x-                        _ -> B.unpack rpath'-    let heads = map (first mkCIByteString . parseHeaderNoAttr) $ tail lines'-    let host' = lookup "Host" heads-    unless (isJust host') $ throwIO HostNotIncluded-    let host = fromJust host'-    let len = fromMaybe 0 $ do-                bs <- lookup "Content-Length" heads-                let str = B.unpack bs-                case reads str of-                    (x, _):_ -> Just x-                    _ -> Nothing-    let (serverName', _) = B.break (== ':') host-    return $ Request-                { requestMethod = method-                , httpVersion = httpversion-                , pathInfo = B.pack rpath-                , queryString = gets-                , serverName = serverName'-                , serverPort = port-                , requestHeaders = heads-                , isSecure = False-                , requestBody = requestBodyHandle handle len-                , errorHandler = System.IO.hPutStr System.IO.stderr-                , remoteHost = B.pack remoteHost'-                }--parseFirst :: ByteString-           -> IO (ByteString, ByteString, ByteString, HttpVersion)-parseFirst s = do-    let pieces = B.words s-    (method, query, http') <--        case pieces of-            [x, y, z] -> return (x, y, z)-            _ -> throwIO $ BadFirstLine $ B.unpack s-    let (hfirst, hsecond) = B.splitAt 5 http'-    unless (hfirst == B.pack "HTTP/") $ throwIO NonHttp-    let (rpath, qstring) = B.break (== '?') query-    return (method, rpath, qstring, hsecond)--sendResponse :: HttpVersion -> Handle -> Response -> IO ()-sendResponse httpversion h res = do-    B.hPut h $ B.pack "HTTP/"-    B.hPut h $ httpversion-    B.hPut h $ B.pack " "-    B.hPut h $ B.pack $ show $ statusCode $ status res-    B.hPut h $ B.pack " "-    B.hPut h $ statusMessage $ status res-    B.hPut h $ B.pack "\r\n"-    mapM_ putHeader $ responseHeaders res-    B.hPut h $ B.pack "\r\n"-    case responseBody res of-        ResponseFile fp -> unsafeSendFile h fp-        ResponseEnumerator (Enumerator enum) -> enum myPut h >> return ()-        ResponseLBS lbs -> L.hPut h lbs-    where-        myPut _ bs = do-            B.hPut h bs-            return (Right h)-        putHeader (x, y) = do-            B.hPut h $ ciOriginal x-            B.hPut h $ B.pack ": "-            B.hPut h y-            B.hPut h $ B.pack "\r\n"--parseHeaderNoAttr :: ByteString -> (ByteString, ByteString)-parseHeaderNoAttr s =-    let (k, rest) = B.span (/= ':') s-        rest' = if not (B.null rest) &&-                   B.head rest == ':' &&-                   not (B.null $ B.tail rest) &&-                   B.head (B.tail rest) == ' '-                    then B.drop 2 rest-                    else rest-     in (k, rest')--requestBodyHandle :: Handle -> Int -> Source-requestBodyHandle h =-    requestBodyFunc go-  where-    go i = Just `fmap` B.hGet h (min i defaultChunkSize)--requestBodyFunc :: (Int -> IO (Maybe B.ByteString)) -> Int -> Source-requestBodyFunc _ 0 = Source $ return Nothing-requestBodyFunc h len = Source $ do-    mbs <- h len-    case mbs of-        Nothing -> return Nothing-        Just bs -> do-            let newLen = len - B.length bs-            return $ Just (bs, requestBodyFunc h $ max 0 newLen)

@@ -1,5 +1,5 @@ Name:                wai-handler-devel-Version:             0.0.1+Version:             0.0.2 Synopsis:            WAI server that automatically reloads code after modification. Description:         This handler automatically reloads your source code upon any changes. It works by using the hint package, essentially embedding GHC inside the handler. The handler (both the executable and library) takes three arguments: the port to listen on, the module name containing the application function, and the name of the function.                      .@@ -23,8 +23,8 @@ Library   Build-Depends:     base >= 3 && < 5,                      wai >= 0.2.1 && < 0.3,+                     wai-extra >= 0.2.3 && < 0.3,                      directory >= 1.0 && < 1.1,-                     sendfile >= 0.6 && < 0.8,                      network >= 2.2 && < 2.3,                      bytestring >= 0.9 && < 0.10,                      hint >= 0.3.2.3 && < 0.4