mighttpd2 2.3.4 → 2.4.0
raw patch · 10 files changed
+123/−51 lines, 10 filesdep +http-enumerator
Dependencies added: http-enumerator
Files
- Config/Internal.hs +6/−3
- FileCGIApp.hs +19/−9
- FileCache.hs +13/−14
- Mighty.hs +20/−9
- Route.hs +34/−6
- Types.hs +15/−3
- mighttpd2.cabal +3/−2
- mkindex.hs +3/−3
- sample.conf +2/−1
- sample.route +8/−1
Config/Internal.hs view
@@ -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")
FileCGIApp.hs view
@@ -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
FileCache.hs view
@@ -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
Mighty.hs view
@@ -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
Route.hs view
@@ -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'])
Types.hs view
@@ -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
mighttpd2.cabal view
@@ -1,5 +1,5 @@ Name: mighttpd2-Version: 2.3.4+Version: 2.4.0 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> 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
mkindex.hs view
@@ -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
sample.conf view
@@ -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
sample.route view
@@ -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