mighttpd2 2.5.10 → 2.5.11
raw patch · 6 files changed
+66/−54 lines, 6 filesdep +io-choice
Dependencies added: io-choice
Files
- Config/Internal.hs +2/−2
- FileCache.hs +41/−31
- Mighty.hs +13/−14
- Route.hs +1/−1
- example.conf +4/−2
- mighttpd2.cabal +5/−4
Config/Internal.hs view
@@ -14,8 +14,8 @@ defaultOption = Option { opt_port = 8080 , opt_debug_mode = True- , opt_user = "nobody"- , opt_group = "nobody"+ , opt_user = "root"+ , opt_group = "root" , opt_pid_file = "/var/run/mighty.pid" , opt_logging = True , opt_log_file = "/var/log/mighty"
FileCache.hs view
@@ -4,6 +4,7 @@ import Control.Concurrent import Control.Exception+import Control.Exception.IOChoice import Control.Monad import Data.ByteString (ByteString) import Data.HashMap.Strict (HashMap)@@ -11,7 +12,6 @@ import Data.IORef import Network.HTTP.Date import Network.Wai.Application.Classic-import System.IO.Unsafe import System.Posix.Files data Entry = Negative | Positive FileInfo@@ -20,45 +20,55 @@ fileInfo :: IORef Cache -> GetInfo fileInfo ref path = do- !mx <- atomicModifyIORef ref (lok path)- case mx of- Nothing -> throwIO (userError "fileInfo")- Just x -> return x+ cache <- readIORef ref+ case M.lookup bpath cache of+ Just Negative -> throwIO (userError "fileInfo")+ Just (Positive x) -> return x+ Nothing -> register ||> negative ref path+ where+ bpath = pathByteString path+ sfile = pathString path+ register = do+ fs <- getFileStatus sfile+ if not (isDirectory fs) then+ positive ref fs path+ else+ goNext -lok :: Path -> Cache -> (Cache, Maybe FileInfo)-lok path cache = unsafePerformIO $ do- let ment = M.lookup bpath cache- case ment of- Nothing -> handle handler $ do- let sfile = pathString path- fs <- getFileStatus sfile- if doesExist fs then pos fs else neg- Just Negative -> return (cache, Nothing)- Just (Positive x) -> return (cache, Just x)+positive :: IORef Cache -> FileStatus -> GetInfo+positive ref fs path = do+ !_ <- atomicModifyIORef ref modify+ return info where+ info = FileInfo {+ fileInfoName = path+ , fileInfoSize = size fs+ , fileInfoTime = mtime fs+ } size = fromIntegral . fileSize mtime = epochTimeToHTTPDate . modificationTime- doesExist = not . isDirectory+ entry = Positive info bpath = pathByteString path- pos fs = do- let info = FileInfo {- fileInfoName = path- , fileInfoSize = size fs- , fileInfoTime = mtime fs- }- entry = Positive info- cache' = M.insert bpath entry cache- return (cache', Just info)- neg = do- let cache' = M.insert bpath Negative cache- return (cache', Nothing)- handler :: SomeException -> IO (Cache, Maybe FileInfo)- handler _ = neg+ modify cache = (cache', ())+ where+ cache' = M.insert bpath entry cache +negative :: IORef Cache -> GetInfo+negative ref path = do+ !_ <- atomicModifyIORef ref modify+ throwIO (userError "fileInfo")+ where+ bpath = pathByteString path+ modify cache = (cache', ())+ where+ cache' = M.insert bpath Negative cache++----------------------------------------------------------------+ fileCacheInit :: IO GetInfo fileCacheInit = do ref <- newIORef M.empty- forkIO (remover ref)+ _ <- forkIO (remover ref) return $ fileInfo ref -- atomicModifyIORef is not necessary here.
Mighty.hs view
@@ -45,10 +45,8 @@ eachCase args | n == 0 = do root <- amIrootUser- let opt = if root then- defaultOption { opt_port = 80 }- else- defaultOption+ let opt | root = defaultOption { opt_port = 80 }+ | otherwise = defaultOption dir <- getCurrentDirectory let dst = fromString . addTrailingPathSeparator $ dir route = [Block ["*"] [RouteFile "/" dst]]@@ -77,7 +75,7 @@ setGroupUser opt logCheck logtype if workers == 1 then do- forkIO $ single opt route s logtype+ _ <- forkIO $ single opt route s logtype myid <- getProcessID logController logtype [myid] else do@@ -111,7 +109,7 @@ single :: Option -> RouteDB -> Socket -> LogType -> IO () single opt route s logtype = do- ignoreSigChild+ _ <- ignoreSigChild lgr <- logInit FromSocket logtype getInfo <- fileCacheInit mgr <- H.newManager H.def {@@ -121,9 +119,10 @@ runSettingsSocket setting s $ \req -> fileCgiApp (cspec lgr) (filespec getInfo) cgispec (revproxyspec mgr) route req where+ debug = opt_debug_mode opt setting = defaultSettings { settingsPort = opt_port opt- , settingsOnException = printStdout+ , settingsOnException = if debug then printStdout else ignore , settingsTimeout = opt_connection_timeout opt , settingsHost = HostAny }@@ -147,11 +146,11 @@ multi :: Option -> RouteDB -> Socket -> LogType -> IO [ProcessID] multi opt route s logtype = do- ignoreSigChild+ _ <- ignoreSigChild cids <- replicateM workers $ forkProcess (single opt route s logtype) sClose s- initHandler sigTERM $ terminateHandler cids- initHandler sigINT $ terminateHandler cids+ _ <- initHandler sigTERM $ terminateHandler cids+ _ <- initHandler sigINT $ terminateHandler cids return cids where workers = opt_worker_processes opt@@ -182,18 +181,18 @@ daemonize :: IO () -> IO () daemonize program = ensureDetachTerminalCanWork $ do- detachTerminal+ _ <- detachTerminal ensureNeverAttachTerminal $ do changeWorkingDirectory "/"- setFileCreationMask 0+ _ <- setFileCreationMask 0 mapM_ closeFd [stdInput, stdOutput, stdError] program where ensureDetachTerminalCanWork p = do- forkProcess p+ _ <- forkProcess p exitImmediately ExitSuccess ensureNeverAttachTerminal p = do- forkProcess p+ _ <- forkProcess p exitImmediately ExitSuccess detachTerminal = createSession
Route.hs view
@@ -65,5 +65,5 @@ where domain = BS.pack <$> many1 (noneOf ":/[], \t\n") port = do- char ':'+ _ <- char ':' read <$> many1 (oneOf ['0'..'9'])
example.conf view
@@ -1,8 +1,10 @@ # Example configuration for Mighttpd 2 Port: 80 Debug_Mode: Yes # Yes or No-User: nobody-Group: nobody+# If available, "nobody" is much more secure for User:.+User: root+# If available, "nobody" is much more secure for Group:.+Group: root Pid_File: /var/run/mighty.pid Logging: Yes # Yes or No Log_File: /var/log/mighty # The directory must be writable by User:
mighttpd2.cabal view
@@ -1,5 +1,5 @@ Name: mighttpd2-Version: 2.5.10+Version: 2.5.11 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> License: BSD3@@ -17,8 +17,10 @@ Executable mighty Main-Is: Mighty.hs- GHC-Options: -Wall -fno-warn-unused-do-bind -threaded+ GHC-Options: -Wall -threaded Build-Depends: base >= 4.0 && < 5+ -- should be removed someday+ , blaze-html >= 0.5 , bytestring , deepseq , directory@@ -26,6 +28,7 @@ , http-conduit , http-date , http-types+ , io-choice , network , network-conduit , old-locale@@ -36,8 +39,6 @@ , unix-bytestring , unordered-containers , wai >= 1.1- -- should be removed someday- , blaze-html >= 0.5 , wai-app-file-cgi , wai-logger , wai-logger-prefork