diff --git a/mohws.cabal b/mohws.cabal --- a/mohws.cabal +++ b/mohws.cabal @@ -1,5 +1,5 @@ Name: mohws -Version: 0.2.1.2 +Version: 0.2.1.3 Author: Simon Marlow, Bjorn Bringert Copyright: Simon Marlow, Bjorn Bringert Maintainer: Henning Thielemann @@ -28,7 +28,7 @@ Source-Repository this Type: darcs Location: http://code.haskell.org/mohws/ - Tag: 0.2.1.2 + Tag: 0.2.1.3 Flag dynamic description: Build server with dynamically loaded plugins @@ -38,20 +38,20 @@ Build-depends: HTTP >=4000.0.4 && <4001, network >=2.1 && <2.4, - unix >=2.3 && <2.6, + unix >=2.3 && <2.7, parsec >=2.1 && <3.2, html >=1.0 && <1.1, process >=1.0 && <1.2, - containers >=0.1 && <0.5, + containers >=0.1 && <0.6, old-time >=1.0 && <1.2, old-locale >=1.0 && <1.1, - bytestring >=0.9 && <0.10, + bytestring >=0.9 && <0.11, filepath >=1.1 && <1.4, utility-ht >=0.0.3 && <0.1, transformers >=0.2 && <0.4, explicit-exception >=0.1 && <0.2, data-accessor >=0.2 && <0.3, - directory >=1.0 && <1.2, + directory >=1.0 && <1.3, -- base-4.3 need for Exception.mask base >=4.3 && <5 diff --git a/src/Network/MoHWS/Part/UserDirectory.hs b/src/Network/MoHWS/Part/UserDirectory.hs --- a/src/Network/MoHWS/Part/UserDirectory.hs +++ b/src/Network/MoHWS/Part/UserDirectory.hs @@ -19,6 +19,7 @@ import Control.Monad (mzero, guard, ) import Control.Monad.Trans.Maybe (MaybeT(MaybeT), ) +import System.IO.Error (catchIOError, ) import System.Posix (homeDirectory, getUserEntryForName, ) @@ -68,7 +69,7 @@ guard $ not $ null $ dir debug st $ "looking for user: " ++ show usr ent <- - MaybeT $ flip catch (const $ return Nothing) $ + MaybeT $ flip catchIOError (const $ return Nothing) $ fmap Just (getUserEntryForName usr) let p = '/': homeDirectory ent ++ '/':dir ++ path debug st $ "userdir path: " ++ p diff --git a/src/Network/MoHWS/Server.hs b/src/Network/MoHWS/Server.hs --- a/src/Network/MoHWS/Server.hs +++ b/src/Network/MoHWS/Server.hs @@ -61,24 +61,26 @@ import Data.List.HT (viewR, ) import qualified Data.Set as Set -import Control.Monad.Trans.State (StateT, runStateT, modify, ) import qualified Control.Monad.Exception.Synchronous as Exc import qualified Control.Exception as Exception -import Control.Monad.Trans.Class (lift, ) - import Control.Monad.Exception.Synchronous (ExceptionalT, runExceptionalT, ) +import Control.Monad.Trans.State (StateT, runStateT, modify, ) +import Control.Monad.Trans.Class (lift, ) +import qualified Network.Socket as Socket +import qualified Network.BSD as BSD import Control.Concurrent (myThreadId, ThreadId, throwTo, killThread, forkIO, ) import Control.Exception (ErrorCall(ErrorCall), finally, mask, ) import Control.Monad (liftM, when, ) -import Network.BSD -import Network.Socket hiding (listen) -import qualified Network.Socket as Socket +import Network.BSD (HostEntry, hostName, ) +import Network.Socket (Socket, HostAddress, Family(AF_INET), ) import Network.URI (uriPath, ) + +import qualified System.Posix as Posix +import qualified System.IO as IO +import System.IO.Error (isAlreadyInUseError, isEOFError, catchIOError, ) import System.Environment (getArgs, ) -import System.IO -import System.IO.Error (isAlreadyInUseError, isEOFError, ) -import System.Posix +import System.Posix (installHandler, sigHUP, sigPIPE, ) import Text.ParserCombinators.Parsec (parse, choice, ) @@ -129,8 +131,8 @@ Init.T body ext -> Options.T -> IO () mainWithOptions initExt opts = do main_thread <- myThreadId - _ <- installHandler sigPIPE Ignore Nothing - _ <- installHandler sigHUP (Catch (hupHandler main_thread)) Nothing + _ <- installHandler sigPIPE Posix.Ignore Nothing + _ <- installHandler sigHUP (Posix.Catch (hupHandler main_thread)) Nothing mask (readConfig initExt opts) type Unblock a = IO a -> IO a @@ -139,8 +141,8 @@ hupHandler main_thread = throwTo main_thread (ErrorCall "**restart**") -sigsToBlock :: SignalSet -sigsToBlock = addSignal sigHUP emptySignalSet +sigsToBlock :: Posix.SignalSet +sigsToBlock = Posix.addSignal sigHUP Posix.emptySignalSet -- Async exceptions should be blocked on entry to readConfig (so that -- multiple SIGHUPs close together can't kill us). Make sure that @@ -148,7 +150,7 @@ readConfig :: (Stream.C body) => Init.T body ext -> Options.T -> (forall a. Unblock a) -> IO () readConfig initExt opts unblock = do - blockSignals sigsToBlock + Posix.blockSignals sigsToBlock r <- ConfigParser.run (choice $ map ModuleDesc.configParser $ Init.moduleList initExt) (Options.configPath opts) @@ -175,7 +177,7 @@ initServerState :: Options.T -> Config.T ext -> IO (ServerContext.T ext) initServerState opts conf = - do host <- do ent <- getHostEntry + do host <- do ent <- BSD.getHostEntry case serverName conf of "" -> return ent n -> return ent { hostName = n } @@ -225,7 +227,7 @@ rereadConfig st initExt unblock _ -> Exception.throw e)) loop = - (do unblockSignals sigsToBlock + (do Posix.unblockSignals sigsToBlock unblock startServers) `Exception.catch` (\(Exception.SomeException e) -> @@ -245,9 +247,9 @@ mkAddr (maddr,port) = do addr <- case maddr of - Nothing -> return iNADDR_ANY - Just ip -> inet_addr ip - return (mkEnv port, SockAddrInet port addr) + Nothing -> return Socket.iNADDR_ANY + Just ip -> Socket.inet_addr ip + return (mkEnv port, Socket.SockAddrInet port addr) in do addrs <- mapM mkAddr (listen (ServerContext.config st)) mapM (\ (env,addr) -> forkIO (server env addr)) addrs @@ -255,33 +257,32 @@ -- open the server socket and start accepting connections server :: (Stream.C body) => - ServerEnv.T body ext -> SockAddr -> IO () + ServerEnv.T body ext -> Socket.SockAddr -> IO () server st addr = do logInfo st $ "Starting server thread on " ++ show addr - proto <- getProtocolNumber "tcp" + proto <- BSD.getProtocolNumber "tcp" Exception.bracket - (socket AF_INET Stream proto) - (\sock -> sClose sock) - (\sock -> do setSocketOption sock ReuseAddr 1 + (Socket.socket AF_INET Socket.Stream proto) + (\sock -> Socket.sClose sock) + (\sock -> do Socket.setSocketOption sock Socket.ReuseAddr 1 ok <- Util.catchSomeIOErrors isAlreadyInUseError - (bindSocket sock addr >> return True) + (Socket.bindSocket sock addr >> return True) (\e -> do logError st ("server: " ++ show e) - hPutStrLn stderr $ show e + IO.hPutStrLn IO.stderr $ show e return False) - when ok $ do Socket.listen sock maxListenQueue - acceptConnections st sock - ) + when ok $ do Socket.listen sock Socket.maxListenQueue + acceptConnections st sock) -- accept connections, and fork off a new thread to handle each one acceptConnections :: (Stream.C body) => ServerEnv.T body ext -> Socket -> IO () acceptConnections st sock = do debug st "Calling accept..." - (h, SockAddrInet port haddr) <- Util.accept sock - inet_ntoa haddr >>= + (h, Socket.SockAddrInet port haddr) <- Util.accept sock + Socket.inet_ntoa haddr >>= \ip -> debug st $ "Got connection from " ++ ip ++ ":" ++ show port _ <- forkIO ( - (talk st h haddr `finally` hClose h) + (talk st h haddr `finally` IO.hClose h) `Exception.catch` (\(Exception.SomeException e) -> debug st ("servlet died: " ++ show e)) @@ -289,15 +290,15 @@ acceptConnections st sock talk :: (Stream.C body) => - ServerEnv.T body ext -> Handle -> HostAddress -> IO () + ServerEnv.T body ext -> IO.Handle -> HostAddress -> IO () talk st h haddr = do debug st "Started" - hSetBuffering h LineBuffering + IO.hSetBuffering h IO.LineBuffering run st True h haddr debug st "Done" run :: (Stream.C body) => - ServerEnv.T body ext -> Bool -> Handle -> HostAddress -> IO () + ServerEnv.T body ext -> Bool -> IO.Handle -> HostAddress -> IO () run st first h haddr = do let conf = ServerEnv.config st -- read a request up to the first empty line. If we @@ -309,8 +310,8 @@ else keepAliveTimeout conf debug st "Waiting for request..." - req <- catch ( - do ok <- hWaitForInput h (time_allowed * 1000) + req <- catchIOError ( + do ok <- IO.hWaitForInput h (time_allowed * 1000) if ok then liftM Just (getUntilEmptyLine h) -- only send a "request timed out" response if this -- was the first request on the socket. Subsequent @@ -359,7 +360,7 @@ getBody :: (Stream.C body) => - Handle -> Request.T body -> IO (Request.T body) + IO.Handle -> Request.T body -> IO (Request.T body) getBody h req = let -- FIXME: handled chunked input readBody = @@ -432,8 +433,8 @@ maybeLookupHostname :: Config.T ext -> HostAddress -> IO (Maybe HostEntry) maybeLookupHostname conf haddr = if hostnameLookups conf - then catch - (liftM Just (getHostByAddr AF_INET haddr)) + then catchIOError + (liftM Just (BSD.getHostByAddr AF_INET haddr)) (\_ -> return Nothing) else return Nothing @@ -511,7 +512,7 @@ response :: (Stream.C body) => ServerEnv.T body ext -> - Handle -> + IO.Handle -> Response.T body -> IO () @@ -556,7 +557,7 @@ Response.sendBodyChunked (Config.chunkSize conf) h body _ -> Response.sendBody h body -hPutHeader :: Handle -> Header.T -> IO () +hPutHeader :: IO.Handle -> Header.T -> IO () hPutHeader h = - hPutStr h . show + IO.hPutStr h . show -- Util.hPutStrCrLf h . show