diff --git a/Config/Internal.hs b/Config/Internal.hs --- a/Config/Internal.hs +++ b/Config/Internal.hs @@ -22,6 +22,7 @@ , opt_log_file_size = 16777216 , opt_log_backup_number = 10 , opt_index_file = "index.html" + , opt_status_file_dir = "/usr/local/share/mighty/status" , opt_connection_timeout = 30 , opt_server_name = programName ++ "/" ++ programVersion , opt_worker_processes = 1 @@ -38,6 +39,7 @@ , opt_log_file_size :: !Int , opt_log_backup_number :: !Int , opt_index_file :: !String + , opt_status_file_dir :: !String , opt_connection_timeout :: !Int , opt_server_name :: !String , opt_worker_processes :: !Int @@ -62,6 +64,7 @@ , opt_log_file_size = get "Log_File_Size" opt_log_file_size , opt_log_backup_number = get "Log_Backup_Number" opt_log_backup_number , opt_index_file = get "Index_File" opt_index_file + , opt_status_file_dir = get "Status_File_Dir" opt_status_file_dir , opt_connection_timeout = get "Connection_Timeout" opt_connection_timeout , opt_server_name = get "Server_Name" opt_server_name , opt_worker_processes = get "Worker_Processes" opt_worker_processes @@ -115,11 +118,11 @@ value = choice [try cv_int, try cv_bool, cv_string] <* spcs cv_int :: Parser ConfValue -cv_int = CV_Int . read <$> (many1 digit) +cv_int = CV_Int . read <$> many1 digit cv_bool :: Parser ConfValue -cv_bool = CV_Bool True <$ (string "Yes") <|> - CV_Bool False <$ (string "No") +cv_bool = CV_Bool True <$ string "Yes" <|> + CV_Bool False <$ string "No" cv_string :: Parser ConfValue cv_string = CV_String <$> many1 (noneOf " \t\n") diff --git a/FileCGIApp.hs b/FileCGIApp.hs --- a/FileCGIApp.hs +++ b/FileCGIApp.hs @@ -9,17 +9,21 @@ import Network.Wai.Application.Classic import Types -fileCgiApp :: AppSpec -> RouteDB -> Application -fileCgiApp spec um req = case mmp of - Nothing -> return $ responseLBS statusNotFound +fileCgiApp :: ClassicAppSpec -> FileAppSpec -> RevProxyAppSpec -> RouteDB -> Application +fileCgiApp cspec filespec revproxyspec um req = case mmp of + Nothing -> return $ responseLBS statusPreconditionFailed [("Content-Type", "text/plain") - ,("Server", softwareName spec)] - "Not Found\r\n" - Just (Route src op dst) -> case op of - OpFile -> fileApp spec (FileRoute src dst) req - OpCGI -> cgiApp spec (CgiRoute src dst) req + ,("Server", softwareName cspec)] + "Precondition Failed\r\n" + Just (RouteFile src dst) -> + fileApp cspec filespec (FileRoute (toP src) (toP dst)) req + Just (RouteCGI src dst) -> + cgiApp cspec (CgiRoute (toP src) (toP dst)) req + Just (RouteRevProxy src dst dom prt) -> + revProxyApp cspec revproxyspec (RevProxyRoute (toP src) (toP dst) dom prt) req where mmp = getBlock (serverName req) um >>= getRoute (rawPathInfo req) + toP = fromByteString getBlock :: ByteString -> RouteDB -> Maybe [Route] getBlock _ [] = Nothing @@ -29,6 +33,12 @@ getRoute :: ByteString -> [Route] -> Maybe Route getRoute _ [] = Nothing -getRoute key (m@(Route src _ _):ms) +getRoute key (m@(RouteFile src _):ms) + | src `BS.isPrefixOf` key = Just m + | otherwise = getRoute key ms +getRoute key (m@(RouteCGI src _):ms) + | src `BS.isPrefixOf` key = Just m + | otherwise = getRoute key ms +getRoute key (m@(RouteRevProxy src _ _ _):ms) | src `BS.isPrefixOf` key = Just m | otherwise = getRoute key ms diff --git a/FileCache.hs b/FileCache.hs --- a/FileCache.hs +++ b/FileCache.hs @@ -2,8 +2,8 @@ import Control.Concurrent import Control.Exception +import Control.Monad import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as BS import Data.HashMap (Map) import qualified Data.HashMap as M import Data.IORef @@ -14,36 +14,37 @@ data Entry = Negative | Positive FileInfo type Cache = Map ByteString Entry -type GetInfo = ByteString -> IO (Maybe FileInfo) +type GetInfo = Path -> IO (Maybe FileInfo) fileInfo :: IORef Cache -> GetInfo fileInfo ref path = atomicModifyIORef ref (lok path) -lok :: ByteString -> Cache -> (Cache, Maybe FileInfo) +lok :: Path -> Cache -> (Cache, Maybe FileInfo) lok path cache = unsafePerformIO $ do - let ment = M.lookup path cache + let ment = M.lookup bpath cache case ment of Nothing -> handle handler $ do - let sfile = BS.unpack path + let sfile = pathString path fs <- getFileStatus sfile - if doesExist fs then pos fs sfile else neg + if doesExist fs then pos fs else neg Just Negative -> return (cache, Nothing) Just (Positive x) -> return (cache, Just x) where size = fromIntegral . fileSize mtime = epochTimeToHTTPDate . modificationTime doesExist = not . isDirectory - pos fs sfile = do + bpath = pathByteString path + pos fs = do let info = FileInfo { - fileInfoName = sfile + fileInfoName = path , fileInfoSize = size fs , fileInfoTime = mtime fs } entry = Positive info - cache' = M.insert path entry cache + cache' = M.insert bpath entry cache return (cache', Just info) neg = do - let cache' = M.insert path Negative cache + let cache' = M.insert bpath Negative cache return (cache', Nothing) handler :: SomeException -> IO (Cache, Maybe FileInfo) handler _ = neg @@ -54,8 +55,6 @@ forkIO (remover ref) return $ fileInfo ref +-- atomicModifyIORef is not necessary here. remover :: IORef Cache -> IO () -remover ref = do - threadDelay 10000000 - _ <- atomicModifyIORef ref (\_ -> (M.empty, ())) - remover ref +remover ref = forever $ threadDelay 10000000 >> writeIORef ref M.empty diff --git a/Mighty.hs b/Mighty.hs --- a/Mighty.hs +++ b/Mighty.hs @@ -4,15 +4,17 @@ import Config import Control.Concurrent -import Control.Exception (onException, handle, SomeException) +import Control.Exception (catch, handle, SomeException) import Control.Monad import qualified Data.ByteString.Char8 as BS import FileCGIApp import FileCache import Network +import qualified Network.HTTP.Enumerator as H import Network.Wai.Application.Classic import Network.Wai.Handler.Warp import Network.Wai.Logger.Prefork +import Prelude hiding (catch) import Route import System.Environment import System.Exit @@ -82,20 +84,29 @@ ignoreSigChild lgr <- logInit FromSocket logtype getInfo <- fileCacheInit - runSettingsSocket setting s $ fileCgiApp (spec lgr getInfo) route + mgr <- H.newManager + runSettingsSocket setting s $ + fileCgiApp (cspec lgr) (filespec getInfo) (revproxyspec mgr) route where setting = defaultSettings { settingsPort = opt_port opt , settingsOnException = printStdout , settingsTimeout = opt_connection_timeout opt } - spec lgr getInfo = AppSpec { - softwareName = BS.pack $ opt_server_name opt - , indexFile = BS.pack $ opt_index_file opt - , isHTML = \x -> ".html" `BS.isSuffixOf` x || ".htm" `BS.isSuffixOf` x + serverName = BS.pack $ opt_server_name opt + cspec lgr = ClassicAppSpec { + softwareName = serverName , logger = lgr + , statusFileDir = fromString $ opt_status_file_dir opt + } + filespec getInfo = FileAppSpec { + indexFile = fromString $ opt_index_file opt + , isHTML = \x -> ".html" `isSuffixOf` x || ".htm" `isSuffixOf` x , getFileInfo = getInfo } + revproxyspec mgr = RevProxyAppSpec { + revProxyManager = mgr + } multi :: Option -> RouteDB -> Socket -> LogType -> IO [ProcessID] multi opt route s logtype = do @@ -110,7 +121,7 @@ terminateHandler cids = Catch $ do mapM_ terminateChild cids exitImmediately ExitSuccess - terminateChild cid = signalProcess sigTERM cid `onException` ignore + terminateChild cid = signalProcess sigTERM cid `catch` ignore initHandler :: Signal -> Handler -> IO Handler initHandler sig func = installHandler sig func Nothing @@ -148,8 +159,8 @@ ---------------------------------------------------------------- -ignore :: IO () -ignore = return () +ignore :: SomeException -> IO () +ignore _ = return () printStdout :: SomeException -> IO () printStdout e = print e diff --git a/Route.hs b/Route.hs --- a/Route.hs +++ b/Route.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, DoAndIfThenElse, TupleSections #-} module Route (parseRoute) where @@ -30,11 +30,39 @@ domain = BS.pack <$> many1 (noneOf "[], \t\n") sep = () <$ spcs1 +data Op = OpFile | OpCGI | OpRevProxy + route :: Parser Route -route = Route <$> src <*> op <*> dst <* trailing +route = do + s <- src + o <- op + case o of + OpFile -> RouteFile s <$> dst <* trailing + OpCGI -> RouteCGI s <$> dst <* trailing + OpRevProxy -> do + (dom,prt,d) <- domPortDst + return $ RouteRevProxy s d dom prt where - path = many1 (noneOf "[], \t\n") - src = BS.pack <$> path <* spcs - dst = BS.pack <$> path <* spcs - op0 = OpFile <$ string "->" <|> OpCGI <$ string "=>" + src = path + dst = path + op0 = OpFile <$ string "->" + <|> OpCGI <$ string "=>" + <|> OpRevProxy <$ string ">>" op = op0 <* spcs + +path :: Parser Dst +path = do + c <- char '/' + BS.pack . (c:) <$> many (noneOf "[], \t\n") <* spcs + +-- [host1][:port2]/path2 + +domPortDst :: Parser (Domain, Port, Dst) +domPortDst = (defaultDomain,,) <$> port <*> path + <|> try((,,) <$> domain <*> port <*> path) + <|> (,defaultPort,) <$> domain <*> path + where + domain = BS.pack <$> many1 (noneOf ":/[], \t\n") + port = do + char ':' + read <$> many1 (oneOf ['0'..'9']) diff --git a/Types.hs b/Types.hs --- a/Types.hs +++ b/Types.hs @@ -1,18 +1,30 @@ +{-# LANGUAGE OverloadedStrings #-} + module Types where import Data.ByteString +import Data.ByteString.Char8 () type Src = ByteString type Dst = ByteString type Domain = ByteString type PathInfo = ByteString +type Port = Int data Block = Block [Domain] [Route] deriving (Eq,Show) -data Route = Route Src Op Dst deriving (Eq,Show) -data Op = OpFile | OpCGI deriving (Eq,Show) +data Route = RouteFile Src Dst + | RouteCGI Src Dst + | RouteRevProxy Src Dst Domain Port + deriving (Eq,Show) type RouteDB = [Block] programName :: String programName = "Mighttpd" programVersion :: String -programVersion = "2.3.4" +programVersion = "2.4.0" + +defaultDomain :: Domain +defaultDomain = "localhost" + +defaultPort :: Int +defaultPort = 80 diff --git a/mighttpd2.cabal b/mighttpd2.cabal --- a/mighttpd2.cabal +++ b/mighttpd2.cabal @@ -1,5 +1,5 @@ Name: mighttpd2 -Version: 2.3.4 +Version: 2.4.0 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -21,7 +21,8 @@ warp, old-locale, time, wai-app-file-cgi, wai, transformers, http-types, directory, filepath, - http-date, hashmap, deepseq, wai-logger + http-date, hashmap, deepseq, wai-logger, + http-enumerator Other-Modules: Config Config.Internal FileCGIApp diff --git a/mkindex.hs b/mkindex.hs --- a/mkindex.hs +++ b/mkindex.hs @@ -25,15 +25,15 @@ mkContents = do fileNames <- filter dotAndIndex <$> getDirectoryContents "." stats <- mapM getFileStatus fileNames - let fmsls = map pp $ zip fileNames stats + let fmsls = zipWith pp fileNames stats maxLen = maximum $ map (\(_,_,_,x) -> x) fmsls contents = concatMap (content maxLen) fmsls return contents where dotAndIndex x = head x /= '.' && x /= indexFile -pp :: (String,FileStatus) -> (String,String,String,Int) -pp (f,st) = (file,mtime,size,flen) +pp :: String -> FileStatus -> (String,String,String,Int) +pp f st = (file,mtime,size,flen) where file = ppFile f st flen = length file diff --git a/sample.conf b/sample.conf --- a/sample.conf +++ b/sample.conf @@ -5,10 +5,11 @@ Group: nobody Pid_File: /var/run/mighty.pid Logging: Yes # Yes or No -Log_File: /var/log/mighty # The directory must be writable by Users: +Log_File: /var/log/mighty # The directory must be writable by User: Log_File_Size: 16777216 # bytes Log_Backup_Number: 10 Index_File: index.html +Status_File_Dir: /usr/local/share/mighty/status Connection_Timeout: 30 # seconds # Server_Name: Mighttpd/2.x.y Worker_Processes: 1 diff --git a/sample.route b/sample.route --- a/sample.route +++ b/sample.route @@ -11,6 +11,13 @@ # A path to static files should be specified with "->" /~alice/ -> /home/alice/public_html/ - /cgi-bin/ => /export/cgi-bin/ / -> /export/www/ + +# Reverse proxy rules should be specified with ">>" +# /path >> host:port/path2 +# Either "host" or ":port" can be committed, but not both. +/app/cal >> example.net/calendar +# URLs generated by Yesod are absolute. +# We cannot re-write pathinfo. +/app/wiki >> :8080/app/wiki