diff --git a/mohws.cabal b/mohws.cabal --- a/mohws.cabal +++ b/mohws.cabal @@ -1,5 +1,5 @@ Name: mohws -Version: 0.2.0.1 +Version: 0.2.1 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.0.1 + Tag: 0.2.1 Flag dynamic description: Build server with dynamically loaded plugins @@ -36,26 +36,26 @@ Library Build-depends: - base >3, - directory >=1.0 && <1.1, HTTP >=4000.0.4 && <4001, - network >=2.1 && <2.3, - unix >=2.3 && <2.4, - parsec >=2.1 && <2.2, + network >=2.1 && <2.4, + unix >=2.3 && <2.5, + parsec >=2.1 && <3.2, html >=1.0 && <1.1, process >=1.0 && <1.1, - containers >=0.1 && <0.3, + containers >=0.1 && <0.5, old-time >=1.0 && <1.1, old-locale >=1.0 && <1.1, bytestring >=0.9 && <0.10, - filepath >=1.1 && <1.2, + filepath >=1.1 && <1.3, utility-ht >=0.0.3 && <0.1, - transformers >=0.1.3 && <0.2, + transformers >=0.2 && <0.3, explicit-exception >=0.1 && <0.2, - data-accessor >=0.2 && <0.3 + data-accessor >=0.2 && <0.3, + directory >=1.0 && <1.2, + base >4 && <5 Hs-Source-dirs: src - Ghc-Options: -threaded -Wall + GHC-Options: -Wall Exposed-Modules: -- server Network.MoHWS.Server diff --git a/src/Network/MoHWS/Configuration/Parser.hs b/src/Network/MoHWS/Configuration/Parser.hs --- a/src/Network/MoHWS/Configuration/Parser.hs +++ b/src/Network/MoHWS/Configuration/Parser.hs @@ -208,17 +208,13 @@ let p_addr = option Nothing $ try $ do addr <- p_ip_addr - char ':' + _ <- char ':' return $ Just addr - p_ip_addr = do b1 <- p_dec_byte - char '.' - b2 <- p_dec_byte - char '.' - b3 <- p_dec_byte - char '.' - b4 <- p_dec_byte - return (b1++"."++b2++"."++b3++"."++b4) + p_ip_addr = + fmap concat $ sequence $ + p_dec_byte : replicate 3 p_dot_dec_byte p_dec_byte = countBetween 1 3 digit + p_dot_dec_byte = liftM2 (:) (char '.') p_dec_byte in addToList ConfigA.listen $ liftM2 (,) p_addr (fmap fromInteger $ Token.integer p) diff --git a/src/Network/MoHWS/HTTP/Header.hs b/src/Network/MoHWS/HTTP/Header.hs --- a/src/Network/MoHWS/HTTP/Header.hs +++ b/src/Network/MoHWS/HTTP/Header.hs @@ -47,6 +47,7 @@ import qualified Data.Map as Map hiding (Map) import System.Time (ClockTime, toUTCTime, ) import Text.ParserCombinators.Parsec + (Parser, char, skipMany, many, ) import qualified Data.Accessor.Basic as Accessor @@ -264,10 +265,10 @@ pHeader :: Parser T pHeader = do n <- pToken - char ':' - many pWS1 + _ <- char ':' + skipMany pWS1 line <- lineString - pCRLF + _ <- pCRLF extraLines <- many extraFieldLine return $ Hdrs.Header (makeName n) (concat (line:extraLines)) @@ -275,7 +276,7 @@ extraFieldLine = do sp <- pWS1 line <- lineString - pCRLF + _ <- pCRLF return (sp:line) {- diff --git a/src/Network/MoHWS/HTTP/MimeType.hs b/src/Network/MoHWS/HTTP/MimeType.hs --- a/src/Network/MoHWS/HTTP/MimeType.hs +++ b/src/Network/MoHWS/HTTP/MimeType.hs @@ -44,6 +44,7 @@ import Data.Map (Map) import qualified Data.Map as Map import Text.ParserCombinators.Parsec + (Parser, parse, char, spaces, sepBy, ) import qualified System.FilePath as FilePath import Control.Monad (liftM2, guard, ) import Data.Maybe (mapMaybe, ) diff --git a/src/Network/MoHWS/HTTP/Request.hs b/src/Network/MoHWS/HTTP/Request.hs --- a/src/Network/MoHWS/HTTP/Request.hs +++ b/src/Network/MoHWS/HTTP/Request.hs @@ -43,7 +43,7 @@ getConnection, ) where -import Text.ParserCombinators.Parsec (Parser, many1, many, noneOf, ) +import Text.ParserCombinators.Parsec (Parser, skipMany1, many, noneOf, ) import Network.MoHWS.ParserUtility (pCRLF, pSP, pToken, parseList, ) import qualified Network.MoHWS.HTTP.Header as Header @@ -127,17 +127,17 @@ pHeaders = do (cmd,loc,ver) <- pCommandLine hdrs <- Header.pGroup - pCRLF + _ <- pCRLF return $ Cons cmd loc ver hdrs mempty pCommandLine :: Parser (Command, URI, HTTPVersion.T) pCommandLine = do cmd <- pCommand - many1 pSP + skipMany1 pSP loc <- pURI - many1 pSP + skipMany1 pSP ver <- HTTPVersion.pInRequest - pCRLF + _ <- pCRLF return (cmd,loc,ver) commandDictionary :: Map.Map String Command diff --git a/src/Network/MoHWS/Logger.hs b/src/Network/MoHWS/Logger.hs --- a/src/Network/MoHWS/Logger.hs +++ b/src/Network/MoHWS/Logger.hs @@ -42,6 +42,7 @@ import Network.MoHWS.Utility (dirname, ) import qualified Control.Exception as Exception +import Control.Exception (SomeException(SomeException), ) import Control.Concurrent (Chan, ThreadId, newChan, forkIO, writeChan, readChan, ) import System.Directory (createDirectoryIfMissing, ) import System.IO (IOMode(AppendMode), hPutStrLn, stderr, hClose, hFlush, ) @@ -77,10 +78,12 @@ format = format0, file = file0 } - t <- forkIO (run l - `Exception.catch` - (\e -> hPutStrLn stderr - ("Error starting logger: " ++ show e))) + t <- forkIO $ + run l + `Exception.catch` + \(SomeException e) -> + hPutStrLn stderr + ("Error starting logger: " ++ show e) return $ Handle { handleChan = chan0, @@ -96,10 +99,12 @@ -- Internals run :: T a -> IO () -run l = run1 l - `Exception.catch` - (\e -> do hPutStrLn stderr ("Logger died: " ++ show e) - run l) +run l = + run1 l + `Exception.catch` + \(SomeException e) -> + do hPutStrLn stderr ("Logger died: " ++ show e) + run l run1 :: T a -> IO () run1 l = @@ -111,9 +116,10 @@ openFile :: FilePath -> IO IO.Handle openFile f = IO.openFile f AppendMode - `Exception.catch` - (\e -> do hPutStrLn stderr ("Failed to open log file: " ++ show e) - Exception.throw e) + `Exception.catch` + \(SomeException e) -> + do hPutStrLn stderr ("Failed to open log file: " ++ show e) + Exception.throw e handleCommands :: T a -> IO.Handle -> IO () handleCommands l hdl = diff --git a/src/Network/MoHWS/Logger/Error.hs b/src/Network/MoHWS/Logger/Error.hs --- a/src/Network/MoHWS/Logger/Error.hs +++ b/src/Network/MoHWS/Logger/Error.hs @@ -54,9 +54,10 @@ import System.Time (ClockTime, toUTCTime, getClockTime, ) import Control.Concurrent (myThreadId, ) -import Control.Monad.Trans (lift, MonadIO, liftIO, ) -import Control.Monad (mzero, ) +import Control.Monad.IO.Class (MonadIO, liftIO, ) +import Control.Monad.Trans.Class (lift, ) import Control.Monad.Trans.Maybe (MaybeT(MaybeT), runMaybeT, ) +import Control.Monad (mzero, ) import Prelude hiding (log, ) diff --git a/src/Network/MoHWS/ParserUtility.hs b/src/Network/MoHWS/ParserUtility.hs --- a/src/Network/MoHWS/ParserUtility.hs +++ b/src/Network/MoHWS/ParserUtility.hs @@ -11,6 +11,8 @@ import Data.List.HT (dropWhileRev, ) import System.IO (Handle, hGetLine, ) import Text.ParserCombinators.Parsec + (GenParser, Parser, char, string, + (<|>), try, oneOf, noneOf, option, skipMany, many, many1, ) pSP :: Parser Char @@ -28,7 +30,7 @@ pCRLF = try (string "\r\n" <|> string "\n\r") <|> string "\n" <|> string "\r" lexeme :: Parser a -> Parser a -lexeme p = do x <- p; many pWS1; return x +lexeme p = do x <- p; skipMany pWS1; return x -- | One line lineString :: Parser String diff --git a/src/Network/MoHWS/Part/CGI.hs b/src/Network/MoHWS/Part/CGI.hs --- a/src/Network/MoHWS/Part/CGI.hs +++ b/src/Network/MoHWS/Part/CGI.hs @@ -26,12 +26,13 @@ import qualified Text.ParserCombinators.Parsec as Parsec import Network.MoHWS.ParserUtility (trimLWS, ) +import Data.Maybe.HT (toMaybe, ) import Data.Tuple.HT (mapFst, ) import Data.Bool.HT (if', ) import Control.Monad.Trans.Maybe (MaybeT, ) import Control.Concurrent (forkIO, ) import qualified Control.Exception as Exception -import Control.Monad.Trans (lift, ) +import Control.Monad.Trans.Class (lift, ) import Control.Monad (when, mzero, ) import Data.Char (toUpper, ) import Data.List (isSuffixOf, ) @@ -123,7 +124,7 @@ else IO.hClose inp -- log process stderr to the error log - forkIO (logErrorsFromHandle st err) + _ <- forkIO (logErrorsFromHandle st err) -- FIXME: exception handling -- FIXME: close handle? @@ -131,7 +132,7 @@ -- wait in a separate thread, so that this thread can continue. -- this is needed since output is lazy. - forkIO (waitForProcess pid >> return ()) + _ <- forkIO (waitForProcess pid >> return ()) case parseCGIOutput output of Left errp -> @@ -248,10 +249,10 @@ -- | Reads lines form the given 'Handle' and log them with 'logError'. logErrorsFromHandle :: ServerContext.T ext -> IO.Handle -> IO () logErrorsFromHandle st h = - (loop `Exception.catch` \e -> - case e of - Exception.IOException f | isEOFError f -> return () - _ -> logError st $ "CGI:" ++ show e) + (Exception.catchJust (\ e -> toMaybe (isEOFError e) e) + loop (const $ return ()) + `Exception.catch` + \(Exception.SomeException e) -> logError st $ "CGI:" ++ show e) `Exception.finally` IO.hClose h where loop = do l <- IO.hGetLine h logError st l diff --git a/src/Network/MoHWS/Part/File.hs b/src/Network/MoHWS/Part/File.hs --- a/src/Network/MoHWS/Part/File.hs +++ b/src/Network/MoHWS/Part/File.hs @@ -20,7 +20,7 @@ import Data.Bool.HT (if', ) import Control.Monad.Trans.Maybe (MaybeT, ) -import Control.Monad.Trans (lift, ) +import Control.Monad.Trans.Class (lift, ) import System.Posix (isRegularFile, isSymbolicLink, FileStatus, fileAccess, modificationTime, fileSize, ) @@ -74,7 +74,7 @@ if' (isSymbolicLink stat) (if Config.followSymbolicLinks conf then processFile - else abort st $ "findProg: Not following symlink: " ++ show filename) $ + else abort st $ "findFile: Not following symlink: " ++ show filename) $ (abort st $ "Strange file: " ++ show filename) in debugOnAbort st ("File not found: " ++ show filename) (statSymLink filename) >>= diff --git a/src/Network/MoHWS/Part/Index.hs b/src/Network/MoHWS/Part/Index.hs --- a/src/Network/MoHWS/Part/Index.hs +++ b/src/Network/MoHWS/Part/Index.hs @@ -28,7 +28,7 @@ import Network.MoHWS.Utility (statFile, hasTrailingSlash, ) import Data.Maybe (fromMaybe, ) import Control.Monad.Trans.Maybe (MaybeT, runMaybeT, ) -import Control.Monad.Trans (lift, ) +import Control.Monad.Trans.Class (lift, ) import Control.Monad (guard, ) import qualified System.FilePath as FilePath @@ -87,5 +87,5 @@ guard (isDirectory stat) let indexFilename = FilePath.combine filename $ index_ $ Config.extension conf lift $ debug st $ "indexFilename = " ++ show indexFilename - statFile indexFilename -- check whether file exists + _ <- statFile indexFilename -- check whether file exists return indexFilename diff --git a/src/Network/MoHWS/Part/Listing.hs b/src/Network/MoHWS/Part/Listing.hs --- a/src/Network/MoHWS/Part/Listing.hs +++ b/src/Network/MoHWS/Part/Listing.hs @@ -23,7 +23,7 @@ import qualified Text.Html as Html import Text.Html((<<), (+++)) import qualified Network.URI as URI -import Control.Monad.Trans (liftIO, ) +import Control.Monad.IO.Class (liftIO, ) import Control.Monad (guard, ) import Data.List (sort, ) import Control.Monad.Trans.Maybe (MaybeT, ) 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,7 +19,6 @@ import Control.Monad (mzero, guard, ) import Control.Monad.Trans.Maybe (MaybeT(MaybeT), ) -import Control.Exception (tryJust, ioErrors, ) import System.Posix (homeDirectory, getUserEntryForName, ) @@ -69,8 +68,8 @@ guard $ not $ null $ dir debug st $ "looking for user: " ++ show usr ent <- - MaybeT $ fmap (either (const Nothing) Just) $ - tryJust ioErrors (getUserEntryForName usr) + MaybeT $ flip catch (const $ return Nothing) $ + fmap Just (getUserEntryForName usr) let p = '/': homeDirectory ent ++ '/':dir ++ path debug st $ "userdir path: " ++ p return p diff --git a/src/Network/MoHWS/Part/VirtualHost.hs b/src/Network/MoHWS/Part/VirtualHost.hs --- a/src/Network/MoHWS/Part/VirtualHost.hs +++ b/src/Network/MoHWS/Part/VirtualHost.hs @@ -1,5 +1,7 @@ -- Copyright 2009, Henning Thielemann -module Network.MoHWS.Part.VirtualHost (Configuration, desc, ) where +module Network.MoHWS.Part.VirtualHost + (Configuration, desc, + virtualDocumentRoot, virtualFile, ) where import qualified Network.MoHWS.Module as Module import qualified Network.MoHWS.Module.Description as ModuleDesc 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 @@ -31,7 +31,7 @@ -- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- ----------------------------------------------------------------------------- - +{-# LANGUAGE Rank2Types #-} module Network.MoHWS.Server (main, mainWithOptions, ) where import qualified Network.MoHWS.Server.Request as ServerRequest @@ -64,12 +64,12 @@ 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 (lift, ) +import Control.Monad.Trans.Class (lift, ) import Control.Monad.Exception.Synchronous (ExceptionalT, runExceptionalT, ) import Control.Concurrent (myThreadId, ThreadId, throwTo, killThread, forkIO, ) -import Control.Exception (Exception(ErrorCall), finally, catchJust, ioErrors, block, unblock, ) +import Control.Exception (ErrorCall(ErrorCall), finally, mask, ) import Control.Monad (liftM, when, ) import Network.BSD import Network.Socket hiding (listen) @@ -129,10 +129,12 @@ 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 - block $ readConfig initExt opts + _ <- installHandler sigPIPE Ignore Nothing + _ <- installHandler sigHUP (Catch (hupHandler main_thread)) Nothing + mask (readConfig initExt opts) +type Unblock a = IO a -> IO a + hupHandler :: ThreadId -> IO () hupHandler main_thread = throwTo main_thread (ErrorCall "**restart**") @@ -144,8 +146,8 @@ -- multiple SIGHUPs close together can't kill us). Make sure that -- there aren't any interruptible operations until we've blocked signals. readConfig :: (Stream.C body) => - Init.T body ext -> Options.T -> IO () -readConfig initExt opts = do + Init.T body ext -> Options.T -> (forall a. Unblock a) -> IO () +readConfig initExt opts unblock = do blockSignals sigsToBlock r <- ConfigParser.run (choice $ map ModuleDesc.configParser $ Init.moduleList initExt) @@ -161,14 +163,14 @@ conf = b (Config.deflt confExtDeflt) st <- initServerState opts conf mods <- fmap catMaybes $ mapM (loadModule st) $ Init.moduleList initExt - topServer st mods initExt + topServer st mods initExt unblock rereadConfig :: (Stream.C body) => - ServerContext.T ext -> Init.T body ext -> IO () -rereadConfig st initExt = + ServerContext.T ext -> Init.T body ext -> (forall a. Unblock a) -> IO () +rereadConfig st initExt unblock = do mapM_ AccessLogger.stop (ServerContext.accessLoggers st) ErrorLogger.stop (ServerContext.errorLogger st) - readConfig initExt (ServerContext.options st) + readConfig initExt (ServerContext.options st) unblock initServerState :: Options.T -> Config.T ext -> IO (ServerContext.T ext) @@ -203,7 +205,8 @@ (do logInfo st $ "Loading module " ++ ModuleDesc.name md ++ "..." fmap Just $ ModuleDesc.load md st) `Exception.catch` - \e -> do logError st $ unlines ["Error loading module " ++ ModuleDesc.name md, + \(Exception.SomeException e) -> + do logError st $ unlines ["Error loading module " ++ ModuleDesc.name md, show e] return Nothing @@ -211,21 +214,22 @@ -- server. If we receive a restart signal (from a SIGHUP), then we -- re-read the configuration file. topServer :: (Stream.C body) => - ServerContext.T ext -> [Module.T body] -> Init.T body ext -> IO () -topServer st mods initExt = + ServerContext.T ext -> [Module.T body] -> Init.T body ext -> (forall a. Unblock a) -> IO () +topServer st mods initExt unblock = let startServers = do ts <- servers st mods (Util.wait `Exception.catch` (\e -> case e of ErrorCall "**restart**" -> do mapM_ killThread ts - rereadConfig st initExt + rereadConfig st initExt unblock _ -> Exception.throw e)) loop = (do unblockSignals sigsToBlock unblock startServers) `Exception.catch` - (\e -> do logError st ("server: " ++ show e) + (\(Exception.SomeException e) -> + do logError st ("server: " ++ show e) loop) in loop @@ -276,9 +280,11 @@ (h, SockAddrInet port haddr) <- Util.accept sock inet_ntoa haddr >>= \ip -> debug st $ "Got connection from " ++ ip ++ ":" ++ show port - forkIO ( (talk st h haddr `finally` hClose h) + _ <- forkIO ( + (talk st h haddr `finally` hClose h) `Exception.catch` - (\e -> debug st ("servlet died: " ++ show e)) + (\(Exception.SomeException e) -> + debug st ("servlet died: " ++ show e)) ) acceptConnections st sock @@ -303,7 +309,7 @@ else keepAliveTimeout conf debug st "Waiting for request..." - req <- catchJust ioErrors ( + req <- catch ( do ok <- hWaitForInput h (time_allowed * 1000) if ok then liftM Just (getUntilEmptyLine h) -- only send a "request timed out" response if this @@ -401,7 +407,7 @@ in fmap swap (runStateT (fmap maybeExc $ runExceptionalT $ serverRequestExc st req haddr) sreq) `Exception.catch` - ( \exception -> do + ( \(Exception.SomeException exception) -> do logError st ("request: " ++ show exception) return (sreq, Just (Response.makeInternalServerError conf)) ) @@ -426,8 +432,9 @@ maybeLookupHostname :: Config.T ext -> HostAddress -> IO (Maybe HostEntry) maybeLookupHostname conf haddr = if hostnameLookups conf - then catchJust ioErrors (liftM Just (getHostByAddr AF_INET haddr)) - (\_ -> return Nothing) + then catch + (liftM Just (getHostByAddr AF_INET haddr)) + (\_ -> return Nothing) else return Nothing type EIO body = ExceptionalT (Response.T body) IO diff --git a/src/Network/MoHWS/Utility.hs b/src/Network/MoHWS/Utility.hs --- a/src/Network/MoHWS/Utility.hs +++ b/src/Network/MoHWS/Utility.hs @@ -33,11 +33,12 @@ module Network.MoHWS.Utility where -import qualified Control.Exception as Exception -import Control.Exception (tryJust, ioErrors, catchJust, Exception(IOException), ) +import Control.Exception (try, catchJust, ) + import Control.Concurrent (newEmptyMVar, takeMVar, ) import Control.Monad (liftM, ) import Control.Monad.Trans.Maybe (MaybeT(MaybeT), runMaybeT, ) +import Data.Maybe.HT (toMaybe, ) import Data.Maybe (fromMaybe, ) import Data.Tuple.HT (mapSnd, ) import Data.List (intersperse, ) @@ -172,7 +173,7 @@ stat_ :: (FilePath -> IO FileStatus) -> String -> MaybeT IO FileStatus stat_ f filename = MaybeT $ do - maybe_stat <- tryJust ioErrors (f filename) + maybe_stat <- try (f filename) case maybe_stat of Left e -> do errno <- getErrno @@ -190,6 +191,5 @@ -- | Catch IO Errors for which a given predicate is true. catchSomeIOErrors :: (IOError -> Bool) -> IO a -> (IOError -> IO a) -> IO a -catchSomeIOErrors p = catchJust p' - where p' (IOException e) | p e = Just e - p' _ = Nothing +catchSomeIOErrors p = + catchJust (\e -> toMaybe (p e) e)