mohws 0.2.0.1 → 0.2.1
raw patch · 16 files changed
+105/−89 lines, 16 filesdep ~basedep ~containersdep ~directory
Dependency ranges changed: base, containers, directory, filepath, network, parsec, transformers, unix
Files
- mohws.cabal +12/−12
- src/Network/MoHWS/Configuration/Parser.hs +5/−9
- src/Network/MoHWS/HTTP/Header.hs +5/−4
- src/Network/MoHWS/HTTP/MimeType.hs +1/−0
- src/Network/MoHWS/HTTP/Request.hs +5/−5
- src/Network/MoHWS/Logger.hs +17/−11
- src/Network/MoHWS/Logger/Error.hs +3/−2
- src/Network/MoHWS/ParserUtility.hs +3/−1
- src/Network/MoHWS/Part/CGI.hs +8/−7
- src/Network/MoHWS/Part/File.hs +2/−2
- src/Network/MoHWS/Part/Index.hs +2/−2
- src/Network/MoHWS/Part/Listing.hs +1/−1
- src/Network/MoHWS/Part/UserDirectory.hs +2/−3
- src/Network/MoHWS/Part/VirtualHost.hs +3/−1
- src/Network/MoHWS/Server.hs +30/−23
- src/Network/MoHWS/Utility.hs +6/−6
mohws.cabal view
@@ -1,5 +1,5 @@ Name: mohws-Version: 0.2.0.1+Version: 0.2.1 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.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
src/Network/MoHWS/Configuration/Parser.hs view
@@ -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)
src/Network/MoHWS/HTTP/Header.hs view
@@ -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) {-
src/Network/MoHWS/HTTP/MimeType.hs view
@@ -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, )
src/Network/MoHWS/HTTP/Request.hs view
@@ -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
src/Network/MoHWS/Logger.hs view
@@ -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 =
src/Network/MoHWS/Logger/Error.hs view
@@ -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, )
src/Network/MoHWS/ParserUtility.hs view
@@ -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
src/Network/MoHWS/Part/CGI.hs view
@@ -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
src/Network/MoHWS/Part/File.hs view
@@ -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) >>=
src/Network/MoHWS/Part/Index.hs view
@@ -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
src/Network/MoHWS/Part/Listing.hs view
@@ -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, )
src/Network/MoHWS/Part/UserDirectory.hs view
@@ -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
src/Network/MoHWS/Part/VirtualHost.hs view
@@ -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
src/Network/MoHWS/Server.hs view
@@ -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
src/Network/MoHWS/Utility.hs view
@@ -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)