diff --git a/Config/Internal.hs b/Config/Internal.hs --- a/Config/Internal.hs +++ b/Config/Internal.hs @@ -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 diff --git a/FileCGIApp.hs b/FileCGIApp.hs --- a/FileCGIApp.hs +++ b/FileCGIApp.hs @@ -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 diff --git a/FileCache.hs b/FileCache.hs --- a/FileCache.hs +++ b/FileCache.hs @@ -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. diff --git a/Mighty.hs b/Mighty.hs --- a/Mighty.hs +++ b/Mighty.hs @@ -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 diff --git a/Process.hs b/Process.hs new file mode 100644 --- /dev/null +++ b/Process.hs @@ -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) diff --git a/Report.hs b/Report.hs new file mode 100644 --- /dev/null +++ b/Report.hs @@ -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"] + + diff --git a/Route.hs b/Route.hs --- a/Route.hs +++ b/Route.hs @@ -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']) diff --git a/Signal.hs b/Signal.hs new file mode 100644 --- /dev/null +++ b/Signal.hs @@ -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 diff --git a/State.hs b/State.hs new file mode 100644 --- /dev/null +++ b/State.hs @@ -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 + } diff --git a/Types.hs b/Types.hs --- a/Types.hs +++ b/Types.hs @@ -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) diff --git a/Utils.hs b/Utils.hs new file mode 100644 --- /dev/null +++ b/Utils.hs @@ -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 diff --git a/mighttpd2.cabal b/mighttpd2.cabal --- a/mighttpd2.cabal +++ b/mighttpd2.cabal @@ -1,5 +1,5 @@ Name: mighttpd2 -Version: 2.5.11 +Version: 2.6.0 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto 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 diff --git a/mightyctl.hs b/mightyctl.hs new file mode 100644 --- /dev/null +++ b/mightyctl.hs @@ -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