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_index_cgi = "index.cgi" , opt_status_file_dir = "/usr/local/share/mighty/status" , opt_connection_timeout = 30 , opt_server_name = programName ++ "/" ++ programVersion @@ -39,6 +40,7 @@ , opt_log_file_size :: !Int , opt_log_backup_number :: !Int , opt_index_file :: !String + , opt_index_cgi :: !String , opt_status_file_dir :: !String , opt_connection_timeout :: !Int , opt_server_name :: !String @@ -64,6 +66,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_index_cgi = get "Index_Cgi" opt_index_cgi , 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 diff --git a/FileCGIApp.hs b/FileCGIApp.hs --- a/FileCGIApp.hs +++ b/FileCGIApp.hs @@ -2,6 +2,7 @@ module FileCGIApp (fileCgiApp) where +import Control.Monad.IO.Class (liftIO) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS import Network.HTTP.Types @@ -9,21 +10,32 @@ import Network.Wai.Application.Classic import Types -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 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 +data Perhaps a = Found a | Redirect | Fail + +fileCgiApp :: ClassicAppSpec -> FileAppSpec -> CgiAppSpec -> RevProxyAppSpec -> RouteDB -> Application +fileCgiApp cspec filespec cgispec revproxyspec um req = case mmp of + Fail -> do + let st = statusPreconditionFailed + liftIO $ logger cspec req st Nothing + fastResponse st defaultHeader "Precondition Failed\r\n" + Redirect -> do + let st = statusMovedPermanently + hdr = defaultHeader ++ redirectHeader req + liftIO $ logger cspec req st Nothing + fastResponse st hdr "Moved Permanently\r\n" + Found (RouteFile src dst) -> do + fileApp cspec filespec (FileRoute src dst) req + Found (RouteCGI src dst) -> + cgiApp cspec cgispec (CgiRoute src dst) req + Found (RouteRevProxy src dst dom prt) -> + revProxyApp cspec revproxyspec (RevProxyRoute src dst dom prt) req where - mmp = getBlock (serverName req) um >>= getRoute (rawPathInfo req) - toP = fromByteString + mmp = case getBlock (serverName req) um of + Nothing -> Fail + Just blk -> getRoute (rawPathInfo req) blk + fastResponse st hdr body = return $ responseLBS st hdr body + defaultHeader = [("Content-Type", "text/plain") + ,("Server", softwareName cspec)] getBlock :: ByteString -> RouteDB -> Maybe [Route] getBlock _ [] = Nothing @@ -31,14 +43,28 @@ | key `elem` doms = Just maps | otherwise = getBlock key ms -getRoute :: ByteString -> [Route] -> Maybe Route -getRoute _ [] = Nothing +getRoute :: ByteString -> [Route] -> Perhaps Route +getRoute _ [] = Fail getRoute key (m@(RouteFile src _):ms) - | src `BS.isPrefixOf` key = Just m - | otherwise = getRoute key ms + | src `isPrefixOf` key = Found m + | src `isMountPointOf` key = Redirect + | otherwise = getRoute key ms getRoute key (m@(RouteCGI src _):ms) - | src `BS.isPrefixOf` key = Just m - | otherwise = getRoute key ms + | src `isPrefixOf` key = Found m + | src `isMountPointOf` key = Redirect + | otherwise = getRoute key ms getRoute key (m@(RouteRevProxy src _ _ _):ms) - | src `BS.isPrefixOf` key = Just m - | otherwise = getRoute key ms + | src `isPrefixOf` key = Found m + | otherwise = getRoute key ms + +isPrefixOf :: Path -> ByteString -> Bool +isPrefixOf src key = src' `BS.isPrefixOf` key + where + src' = pathByteString src + +isMountPointOf :: Path -> ByteString -> Bool +isMountPointOf src key = hasTrailingPathSeparator src + && BS.length src' - BS.length key == 1 + && key `BS.isPrefixOf` src' + where + src' = pathByteString src diff --git a/Mighty.hs b/Mighty.hs --- a/Mighty.hs +++ b/Mighty.hs @@ -3,6 +3,7 @@ module Main where import Config +import Control.Applicative import Control.Concurrent import Control.Exception (catch, handle, SomeException) import Control.Monad @@ -13,30 +14,48 @@ import qualified Network.HTTP.Conduit as H import Network.Wai.Application.Classic import Network.Wai.Handler.Warp +import Network.Wai.Logger import Network.Wai.Logger.Prefork import Prelude hiding (catch) import Route +import System.Directory import System.Environment import System.Exit +import System.FilePath import System.IO import System.Posix import Types main :: IO () main = do - opt <- fileName 0 >>= parseOption - route <- fileName 1 >>= parseRoute + (opt,route) <- getOptRoute if opt_debug_mode opt then server opt route else daemonize $ server opt route where - fileName n = do - args <- getArgs - when (length args /= 2) $ do - hPutStrLn stderr "Usage: mighty config_file routing_file" - exitFailure - return $ args !! n + getOptRoute = getArgs >>= eachCase + eachCase args + | n == 0 = do + root <- amIrootUser + let opt = if root then + defaultOption { opt_port = 80 } + else + defaultOption + dir <- getCurrentDirectory + let dst = fromString . addTrailingPathSeparator $ dir + route = [Block ["localhost"] [RouteFile "/" dst]] + return (opt, route) + | n == 2 = do + opt <- parseOption $ args !! 0 + route <- parseRoute $ args !! 1 + return (opt,route) + | otherwise = do + hPutStrLn stderr "Usage: mighty" + hPutStrLn stderr " mighty config_file routing_file" + exitFailure + where + n = length args ---------------------------------------------------------------- @@ -89,7 +108,7 @@ H.managerConnCount = 1024 } runSettingsSocket setting s $ \req -> - fileCgiApp (cspec lgr) (filespec getInfo) (revproxyspec mgr) route req + fileCgiApp (cspec lgr) (filespec getInfo) cgispec (revproxyspec mgr) route req where setting = defaultSettings { settingsPort = opt_port opt @@ -108,6 +127,9 @@ , isHTML = \x -> ".html" `isSuffixOf` x || ".htm" `isSuffixOf` x , getFileInfo = getInfo } + cgispec = CgiAppSpec { + indexCgi = "index.cgi" + } revproxyspec mgr = RevProxyAppSpec { revProxyManager = mgr } @@ -135,10 +157,13 @@ ---------------------------------------------------------------- +amIrootUser :: IO Bool +amIrootUser = (== 0) <$> getRealUserID + setGroupUser :: Option -> IO () setGroupUser opt = do - uid <- getRealUserID - when (uid == 0) $ do + root <- amIrootUser + when root $ do getGroupEntryForName (opt_group opt) >>= setGroupID . groupID getUserEntryForName (opt_user opt) >>= setUserID . userID diff --git a/Route.hs b/Route.hs --- a/Route.hs +++ b/Route.hs @@ -4,6 +4,7 @@ import Control.Applicative hiding (many,(<|>)) import qualified Data.ByteString.Char8 as BS +import Network.Wai.Application.Classic import Parser import Text.Parsec import Text.Parsec.ByteString.Lazy @@ -50,10 +51,10 @@ <|> OpRevProxy <$ string ">>" op = op0 <* spcs -path :: Parser Dst +path :: Parser Path path = do c <- char '/' - BS.pack . (c:) <$> many (noneOf "[], \t\n") <* spcs + fromByteString . BS.pack . (c:) <$> many (noneOf "[], \t\n") <* spcs -- [host1][:port2]/path2 diff --git a/Types.hs b/Types.hs --- a/Types.hs +++ b/Types.hs @@ -5,10 +5,11 @@ import Data.ByteString import Data.ByteString.Char8 () import Data.Version +import Network.Wai.Application.Classic import Paths_mighttpd2 -type Src = ByteString -type Dst = ByteString +type Src = Path +type Dst = Path type Domain = ByteString type PathInfo = ByteString type Port = Int diff --git a/mighttpd2.cabal b/mighttpd2.cabal --- a/mighttpd2.cabal +++ b/mighttpd2.cabal @@ -1,5 +1,5 @@ Name: mighttpd2 -Version: 2.5.1 +Version: 2.5.2 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -9,21 +9,35 @@ Static files and CGI can be handled. Homepage: http://www.mew.org/~kazu/proj/mighttpd/ Category: Network, Web -Cabal-Version: >= 1.6 +Cabal-Version: >= 1.8 Build-Type: Simple Data-Files: sample.conf sample.route + Executable mighty Main-Is: Mighty.hs GHC-Options: -Wall -fno-warn-unused-do-bind -threaded - Build-Depends: base >= 4.0 && < 5, parsec >= 3, - network, - unix, bytestring, unix-bytestring, - warp, old-locale, time, - wai-app-file-cgi, wai >= 1.1, transformers, http-types, - directory, filepath, - http-date, hashmap, deepseq, wai-logger-prefork, - http-conduit - Other-Modules: Config + Build-Depends: base >= 4.0 && < 5 + , bytestring + , deepseq + , directory + , filepath + , hashmap >= 1.2 && < 1.3 + , http-conduit + , http-date + , http-types + , network + , old-locale + , parsec >= 3 + , time + , transformers + , unix + , unix-bytestring + , wai >= 1.1 + , wai-app-file-cgi + , wai-logger + , wai-logger-prefork + , warp + Other-Modules: Config Config.Internal FileCGIApp FileCache @@ -32,10 +46,21 @@ Route Types Paths_mighttpd2 + Executable mkindex Main-Is: mkindex.hs GHC-Options: -Wall -fno-warn-unused-do-bind Build-Depends: base >= 4 && < 5 + +Test-Suite test + Main-Is: Test.hs + Hs-Source-Dirs: test, . + Type: exitcode-stdio-1.0 + Build-Depends: base >= 4 && < 5 + , HUnit + , test-framework-hunit + , test-framework-th-prime + Source-Repository head Type: git - Location: git://github.com/kazu-yamamoto/mighttpd2.git + Location: git clone git://github.com/kazu-yamamoto/mighttpd2.git diff --git a/sample.conf b/sample.conf --- a/sample.conf +++ b/sample.conf @@ -9,6 +9,7 @@ Log_File_Size: 16777216 # bytes Log_Backup_Number: 10 Index_File: index.html +Index_Cgi: index.cgi Status_File_Dir: /usr/local/share/mighty/status Connection_Timeout: 30 # seconds # Server_Name: Mighttpd/2.x.y diff --git a/sample.route b/sample.route --- a/sample.route +++ b/sample.route @@ -12,7 +12,6 @@ # 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 @@ -21,3 +20,5 @@ # URLs generated by Yesod are absolute. # We cannot re-write pathinfo. /app/wiki >> :8080/app/wiki + +/ -> /export/www/ diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} + +module Main where + +import Config.Internal +import Route +import Test.Framework.Providers.HUnit +import Test.Framework.TH.Prime +import Test.HUnit +import Types + +---------------------------------------------------------------- + +main :: IO () +main = $(defaultMainGenerator) + +---------------------------------------------------------------- + +case_config :: Assertion +case_config = do + res <- parseConfig "sample.conf" + res @?= ans + where + ans = [("Port",CV_Int 80),("Debug_Mode",CV_Bool True),("User",CV_String "nobody"),("Group",CV_String "nobody"),("Pid_File",CV_String "/var/run/mighty.pid"),("Logging",CV_Bool True),("Log_File",CV_String "/var/log/mighty"),("Log_File_Size",CV_Int 16777216),("Log_Backup_Number",CV_Int 10),("Index_File",CV_String "index.html"),("Index_Cgi",CV_String "index.cgi"),("Status_File_Dir",CV_String "/usr/local/share/mighty/status"),("Connection_Timeout",CV_Int 30),("Worker_Processes",CV_Int 1)] + +case_route :: Assertion +case_route = do + res <- parseRoute "sample.route" + res @?= ans + where + ans = [Block ["localhost","www.example.com"] [RouteCGI "/~alice/cgi-bin/" "/home/alice/public_html/cgi-bin/",RouteFile "/~alice/" "/home/alice/public_html/",RouteCGI "/cgi-bin/" "/export/cgi-bin/",RouteRevProxy "/app/cal" "/calendar" "example.net" 80,RouteRevProxy "/app/wiki" "/app/wiki" "localhost" 8080,RouteFile "/" "/export/www/"]] + +----------------------------------------------------------------