mighttpd2 2.5.11 → 2.6.0
raw patch · 13 files changed
+496/−82 lines, 13 filesdep +conduitdep +process-conduitdep +unix-timedep ~warpnew-component:exe:mightyctl
Dependencies added: conduit, process-conduit, unix-time
Dependency ranges changed: warp
Files
- Config/Internal.hs +3/−0
- FileCGIApp.hs +12/−10
- FileCache.hs +4/−11
- Mighty.hs +146/−54
- Process.hs +90/−0
- Report.hs +22/−0
- Route.hs +11/−4
- Signal.hs +32/−0
- State.hs +49/−0
- Types.hs +1/−0
- Utils.hs +40/−0
- mighttpd2.cabal +20/−3
- mightyctl.hs +66/−0
Config/Internal.hs view
@@ -27,6 +27,7 @@ , opt_connection_timeout = 30 , opt_server_name = programName ++ "/" ++ programVersion , opt_worker_processes = 1+ , opt_routing_file = Nothing } data Option = Option {@@ -45,6 +46,7 @@ , opt_connection_timeout :: !Int , opt_server_name :: !String , opt_worker_processes :: !Int+ , opt_routing_file :: !(Maybe FilePath) } deriving (Eq,Show) ----------------------------------------------------------------@@ -71,6 +73,7 @@ , 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+ , opt_routing_file = Nothing } where get k func = maybe (func def) fromConf $ lookup k conf
FileCGIApp.hs view
@@ -23,8 +23,10 @@ hdr = defaultHeader ++ redirectHeader req liftIO $ logger cspec req st Nothing fastResponse st hdr "Moved Permanently\r\n"- Found (RouteFile src dst) -> do+ Found (RouteFile src dst) -> fileApp cspec filespec (FileRoute src dst) req+ Found (RouteRedirect src dst) ->+ redirectApp cspec (RedirectRoute src dst) req Found (RouteCGI src dst) -> cgiApp cspec cgispec (CgiRoute src dst) req Found (RouteRevProxy src dst dom prt) ->@@ -46,18 +48,18 @@ getRoute :: ByteString -> [Route] -> Perhaps Route getRoute _ [] = Fail-getRoute key (m@(RouteFile src _):ms)- | src `isPrefixOf` key = Found m- | src `isMountPointOf` key = Redirect- | otherwise = getRoute key ms-getRoute key (m@(RouteCGI src _):ms)- | src `isPrefixOf` key = Found m- | src `isMountPointOf` key = Redirect- | otherwise = getRoute key ms-getRoute key (m@(RouteRevProxy src _ _ _):ms)+getRoute key (m:ms) | src `isPrefixOf` key = Found m | src `isMountPointOf` key = Redirect | otherwise = getRoute key ms+ where+ src = routeSource m++routeSource :: Route -> Src+routeSource (RouteFile src _) = src+routeSource (RouteRedirect src _) = src+routeSource (RouteCGI src _) = src+routeSource (RouteRevProxy src _ _ _) = src isPrefixOf :: Path -> ByteString -> Bool isPrefixOf src key = src' `BS.isPrefixOf` key
FileCache.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE BangPatterns #-}- module FileCache (fileCacheInit) where import Control.Concurrent@@ -13,6 +11,7 @@ import Network.HTTP.Date import Network.Wai.Application.Classic import System.Posix.Files+import Utils data Entry = Negative | Positive FileInfo type Cache = HashMap ByteString Entry@@ -37,7 +36,7 @@ positive :: IORef Cache -> FileStatus -> GetInfo positive ref fs path = do- !_ <- atomicModifyIORef ref modify+ strictAtomicModifyIORef ref $ M.insert bpath entry return info where info = FileInfo {@@ -49,26 +48,20 @@ mtime = epochTimeToHTTPDate . modificationTime entry = Positive info bpath = pathByteString path- modify cache = (cache', ())- where- cache' = M.insert bpath entry cache negative :: IORef Cache -> GetInfo negative ref path = do- !_ <- atomicModifyIORef ref modify+ strictAtomicModifyIORef ref $ M.insert bpath Negative 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)+ void . forkIO $ remover ref return $ fileInfo ref -- atomicModifyIORef is not necessary here.
Mighty.hs view
@@ -5,7 +5,7 @@ import Config import Control.Applicative import Control.Concurrent-import Control.Exception (catch, handle, SomeException)+import Control.Exception import Control.Monad import qualified Data.ByteString.Char8 as BS import Data.Conduit.Network@@ -13,22 +13,26 @@ import FileCache import Network import qualified Network.HTTP.Conduit as H-import Network.Wai.Application.Classic+import Network.Wai.Application.Classic hiding ((</>), (+++)) import Network.Wai.Handler.Warp import Network.Wai.Logger import Network.Wai.Logger.Prefork-import Prelude hiding (catch)+import Process+import Report import Route+import Signal+import State import System.Directory import System.Environment import System.Exit import System.FilePath import System.IO+import System.IO.Error (ioeGetErrorString) import System.Posix import Types+import Utils -errorFile :: FilePath-errorFile = "/tmp/mighty_error"+---------------------------------------------------------------- main :: IO () main = do@@ -36,8 +40,9 @@ if opt_debug_mode opt then server opt route else do- putStrLn "Detaching this terminal..."- putStrLn $ "If any, errors can be found in \"" ++ errorFile ++ "\""+ let port = opt_port opt+ putStrLn $ "Serving on port " ++ show port ++ " and detaching this terminal..."+ putStrLn $ "(If errors occur, they will be written in \"" ++ reportFile ++ "\".)" hFlush stdout daemonize $ server opt route where@@ -52,35 +57,45 @@ route = [Block ["*"] [RouteFile "/" dst]] return (opt, route) | n == 2 = do- opt <- parseOption $ args !! 0- route <- parseRoute $ args !! 1- return (opt,route)+ let config_file = args !! 0+ routing_file <- getAbsoluteFile (args !! 1)+ opt <- parseOption config_file+ route <- parseRoute routing_file+ let opt' = opt {opt_routing_file = Just routing_file}+ return (opt',route) | otherwise = do hPutStrLn stderr "Usage: mighty" hPutStrLn stderr " mighty config_file routing_file" exitFailure where n = length args+ getAbsoluteFile file+ | isAbsolute file = return file+ | otherwise = do+ dir <- getCurrentDirectory+ return $ dir </> normalise file ---------------------------------------------------------------- server :: Option -> RouteDB -> IO ()-server opt route = handle handler $ do+server opt route = safeDo $ do s <- sOpen if debug then do putStrLn $ "Serving on port " ++ show port ++ "." hFlush stdout else writePidFile- setGroupUser opt logCheck logtype+ sref <- initState+ myid <- getProcessID if workers == 1 then do- _ <- forkIO $ single opt route s logtype- myid <- getProcessID- logController logtype [myid]+ void . forkIO $ single opt route s logtype sref -- killed by signal+ void . forkIO $ logController logtype [myid]+ slaveMainLoop sref else do- cids <- multi opt route s logtype- logController logtype cids+ cids <- multi opt route s logtype sref+ void . forkIO $ logController logtype cids+ masterMainLoop myid where debug = opt_debug_mode opt port = opt_port opt@@ -91,10 +106,6 @@ pid <- getProcessID writeFile pidfile $ show pid ++ "\n" setFileMode pidfile 0o644- handler :: SomeException -> IO ()- handler e- | debug = hPrint stderr e- | otherwise = writeFile errorFile (show e) logspec = FileLogSpec { log_file = opt_log_file opt , log_file_size = fromIntegral $ opt_log_file_size opt@@ -107,32 +118,102 @@ ---------------------------------------------------------------- -single :: Option -> RouteDB -> Socket -> LogType -> IO ()-single opt route s logtype = do- _ <- ignoreSigChild+masterMainLoop :: ProcessID -> IO ()+masterMainLoop myid = do+ threadDelay 10000000+ cs <- findChildren myid+ if null cs then -- FIXME serverStatus st == Retiring+ report "Master Mighty retired"+ else+ masterMainLoop myid++slaveMainLoop :: StateRef -> IO ()+slaveMainLoop sref = do+ threadDelay 1000000+ st <- getState sref+ if serverStatus st == Retiring && connectionCounter st == 0 then+ report "Worker Mighty retired"+ else+ slaveMainLoop sref++----------------------------------------------------------------++safeDo :: IO () -> IO ()+safeDo act = act `catches` [Handler asynHandler, Handler someHandler]++asynHandler :: AsyncException -> IO ()+asynHandler e+ | e == ThreadKilled = return ()+ | otherwise = report $ bshow e++someHandler :: SomeException -> IO ()+someHandler e = report $ bshow e++----------------------------------------------------------------++single :: Option -> RouteDB -> Socket -> LogType -> StateRef -> IO ()+single opt route s logtype sref = safeDo $ do+ setGroupUser opt -- don't change the user of the master process+ ignoreSigChild lgr <- logInit FromSocket logtype getInfo <- fileCacheInit mgr <- H.newManager H.def { -- FIXME H.managerConnCount = 1024 }+ setHandler sigStop stopHandler+ setHandler sigRetire retireHandler+ setHandler sigReload (reloadHandler lgr getInfo mgr)+ setHandler sigInfo infoHandler+ report "Worker Mighty started"+ single' opt route s sref lgr getInfo mgr+ where+ stopHandler = Catch $ do+ report "Worker Mighty finished"+ sClose s+ exitImmediately ExitSuccess+ retireHandler = Catch $+ warpThreadId <$> getState sref >>>= \tid -> do+ report "Worker Mighty retiring"+ killThread tid+ sClose s+ retireStatus sref+ reloadHandler lgr getInfo mgr = Catch $+ warpThreadId <$> getState sref >>>= \tid ->+ ifRouteFileIsValid opt $ \newroute -> do+ report "Worker Mighty reloaded"+ killThread tid+ void . forkIO $ single' opt newroute s sref lgr getInfo mgr+ infoHandler = Catch $ do+ st <- getState sref+ let i = bshow $ connectionCounter st+ status = bshow $ serverStatus st+ report $ status +++ ": # of connections = " +++ i++single' :: Option -> RouteDB -> Socket+ -> StateRef -> ApacheLogger -> (Path -> IO FileInfo) -> H.Manager+ -> IO ()+single' opt route s sref lgr getInfo mgr = safeDo $ do+ myThreadId >>= setWarpThreadId sref runSettingsSocket setting s $ \req ->- fileCgiApp (cspec lgr) (filespec getInfo) cgispec (revproxyspec mgr) route req+ fileCgiApp cspec filespec cgispec revproxyspec route req where debug = opt_debug_mode opt setting = defaultSettings { settingsPort = opt_port opt , settingsOnException = if debug then printStdout else ignore+ , settingsOnOpen = increment sref+ , settingsOnClose = decrement sref , settingsTimeout = opt_connection_timeout opt , settingsHost = HostAny } serverName = BS.pack $ opt_server_name opt- cspec lgr = ClassicAppSpec {+ cspec = ClassicAppSpec { softwareName = serverName , logger = lgr , statusFileDir = fromString $ opt_status_file_dir opt }- filespec getInfo = FileAppSpec {+ filespec = FileAppSpec { indexFile = fromString $ opt_index_file opt , isHTML = \x -> ".html" `isSuffixOf` x || ".htm" `isSuffixOf` x , getFileInfo = getInfo@@ -140,30 +221,49 @@ cgispec = CgiAppSpec { indexCgi = "index.cgi" }- revproxyspec mgr = RevProxyAppSpec {+ revproxyspec = RevProxyAppSpec { revProxyManager = mgr } -multi :: Option -> RouteDB -> Socket -> LogType -> IO [ProcessID]-multi opt route s logtype = do- _ <- ignoreSigChild- cids <- replicateM workers $ forkProcess (single opt route s logtype)+----------------------------------------------------------------++multi :: Option -> RouteDB -> Socket -> LogType -> StateRef -> IO [ProcessID]+multi opt route s logtype sref = do+ report "Master Mighty started"+ ignoreSigChild+ cids <- replicateM workers $ forkProcess $ do+ void . forkIO $ single opt route s logtype sref -- killed by signal+ slaveMainLoop sref sClose s- _ <- initHandler sigTERM $ terminateHandler cids- _ <- initHandler sigINT $ terminateHandler cids+ setHandler sigStop $ stopHandler cids+ setHandler sigINT $ stopHandler cids -- C-c from keyboard when debugging+ setHandler sigRetire $ retireHandler cids+ setHandler sigReload $ reloadHandler cids+ setHandler sigInfo $ infoHandler cids return cids where workers = opt_worker_processes opt- terminateHandler cids = Catch $ do- mapM_ terminateChild cids+ stopHandler cids = Catch $ do+ report "Master Mighty finished"+ mapM_ (sendSignal sigStop) cids exitImmediately ExitSuccess- terminateChild cid = signalProcess sigTERM cid `catch` ignore+ retireHandler cids = Catch $ do+ report "Master Mighty retiring"+ retireStatus sref+ mapM_ (sendSignal sigRetire) cids+ reloadHandler cids = Catch $ ifRouteFileIsValid opt $ \_ -> do+ report "Master Mighty reloaded"+ mapM_ (sendSignal sigReload) cids+ infoHandler cids = Catch $ mapM_ (sendSignal sigInfo) cids -initHandler :: Signal -> Handler -> IO Handler-initHandler sig func = installHandler sig func Nothing+---------------------------------------------------------------- -ignoreSigChild :: IO Handler-ignoreSigChild = initHandler sigCHLD Ignore+ifRouteFileIsValid :: Option -> (RouteDB -> IO ()) -> IO ()+ifRouteFileIsValid opt act =+ return (opt_routing_file opt) >>>= \rfile ->+ try (parseRoute rfile) >>= either reportError act+ where+ reportError = report . BS.pack . ioeGetErrorString ---------------------------------------------------------------- @@ -181,25 +281,17 @@ daemonize :: IO () -> IO () daemonize program = ensureDetachTerminalCanWork $ do- _ <- detachTerminal+ detachTerminal ensureNeverAttachTerminal $ do changeWorkingDirectory "/"- _ <- setFileCreationMask 0+ void $ setFileCreationMask 0 mapM_ closeFd [stdInput, stdOutput, stdError] program where ensureDetachTerminalCanWork p = do- _ <- forkProcess p+ void $ forkProcess p exitImmediately ExitSuccess ensureNeverAttachTerminal p = do- _ <- forkProcess p+ void $ forkProcess p exitImmediately ExitSuccess- detachTerminal = createSession--------------------------------------------------------------------ignore :: SomeException -> IO ()-ignore _ = return ()--printStdout :: SomeException -> IO ()-printStdout = print+ detachTerminal = void createSession
+ Process.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE OverloadedStrings #-}++module Process (getMightyPid, findChildren) where++import Control.Applicative+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as BS+import Data.Conduit+import qualified Data.Conduit.Binary as CB+import qualified Data.Conduit.List as CL+import Data.Conduit.Process+import Data.Function+import Data.List+import Data.Ord+import System.Posix.Types++----------------------------------------------------------------++data PsResult = PsResult {+ uid :: ByteString+ , pid :: ProcessID+ , ppid :: ProcessID+ , command :: ByteString+ } deriving (Eq, Show)++toPsResult :: [ByteString] -> PsResult+toPsResult (a:b:c:_:_:_:_:h:_) = PsResult {+ uid = a+ , pid = maybe 0 (fromIntegral . fst) $ BS.readInt b+ , ppid = maybe 0 (fromIntegral . fst) $ BS.readInt c+ , command = h+ }+toPsResult _ = PsResult "unknown" 0 0 "unknown"++----------------------------------------------------------------++runPS :: IO [PsResult]+runPS = runResourceT $+ sourceCmd "ps -ef"+ $= CB.lines+ $= CL.map BS.words+ $= CL.map toPsResult+ $= CL.filter mighty+ $$ CL.consume+ where+ commandName = last . split '/' . command+ mighty ps = "mighty" `BS.isInfixOf` name+ && not ("mightyctl" `BS.isInfixOf` name)+ where+ name = commandName ps++----------------------------------------------------------------++findParent :: [PsResult] -> [PsResult]+findParent ps = deleteAloneChild $ masters ++ candidates+ where+ iAmMaster p = ppid p == 1+ masters = filter iAmMaster ps+ rest = filter (not.iAmMaster) ps+ candidates = map head+ $ filter (\xs -> length xs == 1) -- master is alone+ $ groupBy ((==) `on` ppid)+ $ sortBy (comparing ppid) rest+++deleteAloneChild :: [PsResult] -> [PsResult]+deleteAloneChild [] = []+deleteAloneChild (p:ps) = p : deleteAloneChild (filter noParent ps)+ where+ parent = pid p+ noParent x = ppid x /= parent++----------------------------------------------------------------++getMightyPid :: IO [ProcessID]+getMightyPid = (map pid . findParent) <$> runPS++----------------------------------------------------------------++findChildren :: ProcessID -> IO [PsResult]+findChildren parent = filter (\p -> ppid p == parent) <$> runPS++----------------------------------------------------------------++split :: Char -> ByteString -> [ByteString]+split _ "" = []+split c s = case BS.break (c==) s of+ ("",r) -> split c (BS.tail r)+ (s',"") -> [s']+ (s',r) -> s' : split c (BS.tail r)
+ Report.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE OverloadedStrings #-}++module Report where++import Control.Applicative+import Control.Exception+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS+import Data.UnixTime+import System.Posix+import Utils++reportFile :: FilePath+reportFile = "/tmp/mighty_report"++report :: ByteString -> IO ()+report msg = handle ignore $ do+ pid <- BS.pack . show <$> getProcessID+ tm <- formatUnixTime "%d %b %Y %H:%M:%S" <$> getUnixTime+ BS.appendFile reportFile $ BS.concat [tm, ": pid = ", pid, ": ", msg, "\n"]++
Route.hs view
@@ -3,6 +3,7 @@ module Route (parseRoute) where import Control.Applicative hiding (many,(<|>))+import Control.Monad import qualified Data.ByteString.Char8 as BS import Network.Wai.Application.Classic import Parser@@ -31,22 +32,25 @@ domain = BS.pack <$> many1 (noneOf "[], \t\n") sep = () <$ spcs1 -data Op = OpFile | OpCGI | OpRevProxy+data Op = OpFile | OpCGI | OpRevProxy | OpRedirect route :: Parser Route route = do s <- src o <- op case o of- OpFile -> RouteFile s <$> dst <* trailing- OpCGI -> RouteCGI s <$> dst <* trailing+ OpFile -> RouteFile s <$> dst <* trailing+ OpRedirect -> RouteRedirect s <$> dst' <* trailing+ OpCGI -> RouteCGI s <$> dst <* trailing OpRevProxy -> do (dom,prt,d) <- domPortDst return $ RouteRevProxy s d dom prt where src = path dst = path+ dst' = path' op0 = OpFile <$ string "->"+ <|> OpRedirect <$ string "<<" <|> OpCGI <$ string "=>" <|> OpRevProxy <$ string ">>" op = op0 <* spcs@@ -56,6 +60,9 @@ c <- char '/' fromByteString . BS.pack . (c:) <$> many (noneOf "[], \t\n") <* spcs +path' :: Parser Path+path' = fromByteString . BS.pack <$> many (noneOf "[], \t\n") <* spcs+ -- [host1][:port2]/path2 domPortDst :: Parser (Domain, Port, Dst)@@ -65,5 +72,5 @@ where domain = BS.pack <$> many1 (noneOf ":/[], \t\n") port = do- _ <- char ':'+ void $ char ':' read <$> many1 (oneOf ['0'..'9'])
+ Signal.hs view
@@ -0,0 +1,32 @@+module Signal where++import Control.Exception (catch)+import Control.Monad+import Prelude hiding (catch)+import System.Posix+import Utils++----------------------------------------------------------------++sigStop :: Signal+sigStop = sigTERM++sigReload :: Signal+sigReload = sigHUP++sigRetire :: Signal+sigRetire = sigQUIT++sigInfo :: Signal+sigInfo = sigUSR2 -- sigUSR1 does not work on Linux++----------------------------------------------------------------++sendSignal :: Signal -> ProcessID -> IO ()+sendSignal sig cid = signalProcess sig cid `catch` ignore++setHandler :: Signal -> Handler -> IO ()+setHandler sig func = void $ installHandler sig func Nothing++ignoreSigChild :: IO ()+ignoreSigChild = setHandler sigCHLD Ignore
+ State.hs view
@@ -0,0 +1,49 @@+module State where++import Control.Concurrent+import Data.IORef+import Utils++data Status = Serving | Retiring deriving (Eq, Show)++data State = State {+ connectionCounter :: !Int+ , serverStatus :: !Status+ , warpThreadId :: !(Maybe ThreadId)+ }++initialState :: State+initialState = State 0 Serving Nothing++type StateRef = IORef State++initState :: IO (IORef State)+initState = newIORef initialState++getState :: IORef State -> IO State+getState = readIORef++retireStatus :: StateRef -> IO ()+retireStatus sref =+ strictAtomicModifyIORef sref $ \st -> st {+ serverStatus = Retiring+ , warpThreadId = Nothing+ }++increment :: IORef State -> IO ()+increment sref =+ strictAtomicModifyIORef sref $ \st -> st {+ connectionCounter = connectionCounter st + 1+ }++decrement :: IORef State -> IO ()+decrement sref =+ strictAtomicModifyIORef sref $ \st -> st {+ connectionCounter = connectionCounter st - 1+ }++setWarpThreadId :: IORef State -> ThreadId -> IO ()+setWarpThreadId sref tid =+ strictAtomicModifyIORef sref $ \st -> st {+ warpThreadId = Just tid+ }
Types.hs view
@@ -15,6 +15,7 @@ type Port = Int data Block = Block [Domain] [Route] deriving (Eq,Show) data Route = RouteFile Src Dst+ | RouteRedirect Src Dst | RouteCGI Src Dst | RouteRevProxy Src Dst Domain Port deriving (Eq,Show)
+ Utils.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE BangPatterns #-}++module Utils where++import Control.Exception+import Data.IORef+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS++----------------------------------------------------------------++ignore :: SomeException -> IO ()+ignore _ = return ()++printStdout :: SomeException -> IO ()+printStdout = print++----------------------------------------------------------------++strictAtomicModifyIORef :: IORef a -> (a -> a) -> IO ()+strictAtomicModifyIORef ref f = do+ !_ <- atomicModifyIORef ref (\x -> let !r = f x in (r, ()))+ return ()++----------------------------------------------------------------++bshow :: Show a => a -> ByteString+bshow = BS.pack . show++infixr 5 +++++(+++) :: ByteString -> ByteString -> ByteString+(+++) = BS.append+ +----------------------------------------------------------------++infixr 0 >>>=++(>>>=) :: IO (Maybe a) -> (a -> IO ()) -> IO ()+x >>>= f = x >>= maybe (return ()) f
mighttpd2.cabal view
@@ -1,5 +1,5 @@ Name: mighttpd2-Version: 2.5.11+Version: 2.6.0 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> License: BSD3@@ -22,6 +22,7 @@ -- should be removed someday , blaze-html >= 0.5 , bytestring+ , conduit , deepseq , directory , filepath@@ -33,34 +34,50 @@ , network-conduit , old-locale , parsec >= 3+ , process-conduit , time , transformers , unix , unix-bytestring+ , unix-time , unordered-containers , wai >= 1.1 , wai-app-file-cgi , wai-logger , wai-logger-prefork- , warp+ , warp >= 1.2.1.1 Other-Modules: Config Config.Internal FileCGIApp FileCache Mighty Parser+ Process+ Report Route+ Signal+ State Types+ Utils Paths_mighttpd2 Executable mkindex Main-Is: mkindex.hs- GHC-Options: -Wall -fno-warn-unused-do-bind+ GHC-Options: -Wall Build-Depends: base >= 4 && < 5 , unix , old-locale , directory , time++Executable mightyctl+ Main-Is: mightyctl.hs+ GHC-Options: -Wall+ Build-Depends: base >= 4 && < 5+ , bytestring+ , conduit+ , process-conduit+ , unix Test-Suite test Main-Is: Test.hs
+ mightyctl.hs view
@@ -0,0 +1,66 @@+module Main where++import Data.List+import Process+import Signal+import System.Environment+import System.Exit+import System.Posix.Signals+import System.Posix.Types++commandDB :: [(String, Signal)]+commandDB = [+ ("stop", sigStop)+ , ("reload", sigReload)+ , ("retire", sigRetire)+ , ("info", sigInfo)+ ]++usage :: IO a+usage = do+ putStrLn "Usage:"+ putStrLn $ " mightyctl " ++ cmds ++ " [pid]"+ exitFailure+ where+ cmds = intercalate "|" $ map fst commandDB++main :: IO ()+main = do+ (sig,mpid) <- getArgs >>= checkArgs+ pid <- maybe getProcessIdWithPS return mpid+ signalProcess sig pid++checkArgs :: [String] -> IO (Signal, Maybe ProcessID)+checkArgs [cmd] = do+ sig <- getSignal cmd+ return (sig, Nothing)+checkArgs [cmd,num] = do+ sig <- getSignal cmd+ pid <- getProcessId num+ return (sig, Just pid)+checkArgs _ = usage++getSignal :: String -> IO Signal+getSignal cmd = check $ lookup cmd commandDB+ where+ check (Just sig) = return sig+ check Nothing = do+ putStrLn $ "No such command: " ++ cmd+ usage++getProcessId :: String -> IO ProcessID+getProcessId num = check $ reads num+ where+ check [(pid,"")] = return . fromIntegral $ (pid :: Int)+ check _ = do+ putStrLn $ "No such process id: " ++ num+ usage++getProcessIdWithPS :: IO ProcessID+getProcessIdWithPS = getMightyPid >>= check+ where+ check [] = putStrLn "No Mighty found" >> usage+ check [pid] = return pid+ check pids = do+ putStrLn $ "Multiple Mighty found: " ++ intercalate ", " (map show pids)+ usage