mohws 0.2.1.2 → 0.2.1.3
raw patch · 3 files changed
+52/−50 lines, 3 filesdep ~bytestringdep ~containersdep ~directory
Dependency ranges changed: bytestring, containers, directory, unix
Files
- mohws.cabal +6/−6
- src/Network/MoHWS/Part/UserDirectory.hs +2/−1
- src/Network/MoHWS/Server.hs +44/−43
mohws.cabal view
@@ -1,5 +1,5 @@ Name: mohws-Version: 0.2.1.2+Version: 0.2.1.3 Author: Simon Marlow, Bjorn Bringert <bjorn@bringert.net> Copyright: Simon Marlow, Bjorn Bringert Maintainer: Henning Thielemann <webserver@henning-thielemann.de>@@ -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
src/Network/MoHWS/Part/UserDirectory.hs view
@@ -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
src/Network/MoHWS/Server.hs view
@@ -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