diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright: (c) Vo Minh Thu, 2012. + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/Sentry.hs b/Sentry.hs new file mode 100644 --- /dev/null +++ b/Sentry.hs @@ -0,0 +1,34 @@ +-- | +-- Module : Sentry +-- Copyright : (c) 2012 Vo Minh Thu, +-- +-- License : BSD-style +-- Maintainer : thu@hypered.be +-- Stability : experimental +-- Portability : GHC +-- +-- This module re-exports everything one needs to write a Sentry +-- configuration file. A configuration file is actually a (simple) Haskell +-- program. As an example, consider the following code: +-- +-- > import Sentry +-- > +-- > main :: IO () +-- > main = sentry +-- > [ entry "dummy" "sleep" ["4"] 1000 2 +-- > ] +-- +-- When compiled (some features don't work correctly under @ghci@) and run, the +-- above program will maintain two processes, both running @sleep@. Whenever a +-- process exits, Sentry will restart it. Detailed usage information can be +-- found at and by running the program with +-- the @--help@ option. +-- +-- See `sentry` and `entry` below for more details on those functions. +module Sentry + ( sentry + , entry + ) where + +import Sentry.Command (sentry) +import Sentry.Types (entry) diff --git a/Sentry/Command.hs b/Sentry/Command.hs new file mode 100644 --- /dev/null +++ b/Sentry/Command.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +-- | +-- Module : Sentry.Command +-- Copyright : (c) 2012 Vo Minh Thu, +-- +-- License : BSD-style +-- Maintainer : thu@hypered.be +-- Stability : experimental +-- Portability : GHC +-- +-- This module provides the command-line interface for a Sentry program. It +-- defines data types to represent different subcommands and the corresponding +-- functions. +module Sentry.Command where + +import System.Console.CmdArgs.Implicit + +import Sentry.Core +import Sentry.Types (Entry(..)) + +-- | 'sentry' provides the main function of a Sentry configuration file. In +-- particular it provides the command-line interface. It takes a list of +-- configuration entries as its sole argument. +sentry :: [Entry] -> IO () +sentry entries = (runCmd =<<) $ cmdArgs $ + modes + [ cmdStart entries + , cmdContinue entries + , cmdCompile + , cmdReload + ] + &= summary versionString + &= program "sentry" + +-- | String with the program name, version and copyright. +versionString :: String +versionString = + "Sentry - Process monitoring. Copyright (c) 2012 Vo Minh Thu." + -- TODO add the version. + +-- | Data type representing the different command-line subcommands. +data Cmd = + Start { cmdEntries :: [Entry] } + -- ^ Start Sentry with the provided process specifications. + | Continue { cmdEntries :: [Entry] } + -- ^ Resume Sentry with the provided process specifications. + | Compile + -- ^ Compile Sentry. + | Reload + -- ^ Reload Sentry. + deriving (Data, Typeable) + +-- | Create a 'Start' command. +cmdStart :: [Entry] -> Cmd +cmdStart entries = Start + { cmdEntries = entries + &= ignore + } &= help "Start Sentry." + &= explicit + &= name "start" + +-- | Create a 'Continue' command. +cmdContinue :: [Entry] -> Cmd +cmdContinue entries = Continue + { cmdEntries = entries + &= ignore + } &= help ("Resume Sentry after a graceful exit or SIGHUP." ++ + " This is normally not called explicitely from the command-line.") + &= explicit + &= name "continue" + +-- | Create a 'Compile' command. +cmdCompile :: Cmd +cmdCompile = Compile + &= help "Compile the configuration file, replacing this executable." + &= explicit + &= name "compile" + +-- | Create a 'Reload' command. +cmdReload :: Cmd +cmdReload = Reload + &= help "Instruct a running Sentry to reload itself by sending it a SIGHUP." + &= explicit + &= name "reload" + +-- | Run a Sentry sub-command. +runCmd :: Cmd -> IO () +runCmd Start{..} = startMonitor cmdEntries + +runCmd Continue{..} = continueMonitor cmdEntries + +runCmd Compile{..} = do + state <- initializeState [] + _ <- compile state + return () + +runCmd Reload{..} = do + state <- initializeState [] + sendSIGHUP state diff --git a/Sentry/Core.hs b/Sentry/Core.hs new file mode 100644 --- /dev/null +++ b/Sentry/Core.hs @@ -0,0 +1,472 @@ +{-# LANGUAGE RecordWildCards #-} +-- | +-- Module : Sentry.Core +-- Copyright : (c) 2012 Vo Minh Thu, +-- +-- License : BSD-style +-- Maintainer : thu@hypered.be +-- Stability : experimental +-- Portability : GHC +-- +-- This module is Sentry's core implementation: state initialization, process +-- spawning and monitoring. +module Sentry.Core + ( + -- * Processes + spawn + , follow + , terminate + , updateProcess + , removeProcess + -- * Application state + , initializeState + , saveState + , readState + -- * Main entry points + , startMonitor + , continueMonitor + , sendSIGHUP + , compile + , reexecute + ) where + +import Control.Concurrent (forkIO, threadDelay) +import Control.Concurrent.Chan +import Control.Concurrent.MVar +import Control.Applicative ((<$>)) +import Control.Monad (forM_, replicateM, when) +import qualified Data.ByteString as B +import Data.Either (partitionEithers) +import Data.List (foldl') +import Data.Maybe (isJust) +import Data.Serialize (runGet, runPut) +import Data.SafeCopy (safeGet, safePut) +import Data.Time.Clock.POSIX(getPOSIXTime) +import System.Console.ANSI (setSGRCode, ColorIntensity(..), Color(..) + , ConsoleLayer(..), SGR(..)) +import System.Directory (createDirectoryIfMissing, doesFileExist, getHomeDirectory) +import System.Exit (ExitCode(..)) +import System.FilePath ((<.>), (), takeDirectory) +import System.IO (hGetLine, hIsEOF, hPutStrLn, hReady, hSetBuffering + , stderr, stdout, withFile + , BufferMode(..), IOMode(..), Handle) +import System.Locale (defaultTimeLocale) +import System.Posix.Files (readSymbolicLink) +import System.Posix.Process (executeFile, getProcessID) +import System.Posix.Signals (installHandler, sigHUP, sigINT, signalProcess + , Handler(..)) +import System.Process (createProcess, getProcessExitCode, proc + , runProcess, std_out, terminateProcess, waitForProcess) +import System.Process.Internals +import System.Time (formatCalendarTime, getClockTime, toCalendarTime) + +import Sentry.Types + +-- | Create a new process, monitored by a new thread. The provided channel +-- is used by the monitoring thread when the process exits to notify the +-- main thread. +spawn :: Chan Command -> Entry -> IO Int -- TODO newtype ProcessID +spawn chan e@Entry{..} = do + (_, Just hout, Just herr, h) <- createProcess $ + (proc eCommand eArguments) + { std_out = CreatePipe, std_err = CreatePipe } + i <- processHandleToInt h + t1 <- getTime + logP e i $ "Started at " ++ show t1 ++ "." + follow chan e i + _ <- forkIO $ pipeToStdout e i hout herr + return i + +-- | Wait for a process to complete. When it happens, it will notify the main +-- thread using the provided channel. Return without blocking. +follow :: Chan Command -> Entry -> Int -> IO () +follow chan p@Entry{..} i = do + _ <- forkIO $ do + -- After a re-exec, waitForProcess will make an error if the + -- child has already exited, so use getProcessExitCode at first. + -- If it returns Nothing, then we have to continue waiting for t + -- (the handle is valid) otherwise the process has completed. + h <- intToProcessHandle i + mCode <- getProcessExitCode h + case mCode of + Just _ -> writeChan chan $ ProcessExited eType i + Nothing -> do + exitCode <- waitForProcess h + t <- getTime + logP p i $ "Exited at " ++ show t ++ " with " ++ show exitCode ++ "." + threadDelay $ eDelay * 1000 + writeChan chan $ ProcessExited eType i + return () + +terminate :: MonitoredEntry -> IO () +terminate MonitoredEntry{..} = do + putStrLn $ "Process type `" ++ eType mEntry ++ "` removed. Killing " + ++ "workers." + mapM_ (\i -> intToProcessHandle i >>= terminateProcess) mHandles + +-- | Given a monitored process, adjust the number of worker processes to match +-- the possibly updated spec. +updateProcess :: Chan Command -> MonitoredEntry -> IO MonitoredEntry +updateProcess chan p@MonitoredEntry{..} = + case length mHandles `compare` eCount mEntry of + EQ -> return p + GT -> do + let n = length mHandles - eCount mEntry + toTerminate = take n mHandles + toKeep = drop n mHandles + -- logP mEntry $ show n ++ " less workers required." + hs <- mapM intToProcessHandle toTerminate -- TODO make sure eCount always >= 0 + mapM_ terminateProcess hs -- TODO is SIGTERM really what we want? + return p { mHandles = toKeep } + LT -> do + let n = eCount mEntry - length mHandles + is <- replicateM n $ spawn chan mEntry + return p { mHandles = is ++ mHandles } + +-- | Remove the process handle from the monitored process (if they match, +-- otherwise do nothing). +removeProcess :: ProcessType -> Int -> MonitoredEntry -> MonitoredEntry +removeProcess typ i p@MonitoredEntry{..} = + if eType mEntry == typ + then p { mHandles = filter (/= i) mHandles } + else p + +-- | Given a list of process specifications, start to monitor them. +startMonitor :: [Entry] -> IO () +startMonitor entries = do + state <- initializeState entries + + home <- getHomeDirectory + let sentry = home ".sentry" + conf = sentry "conf" + binPath = sExecutablePath state + pidPath = binPath <.> "pid" + + pid <- fromIntegral <$> getProcessID :: IO Int + if takeDirectory binPath /= conf + then putStrLn $ "Sentry started (PID: " ++ show pid ++ ")." + else do + putStrLn $ "Sentry started (PID: " ++ show pid ++ " saved in " + ++ pidPath ++ ")." + writeFile pidPath $ show pid + + monitor state + +-- | Given new process specifications, continue the monitoring. +continueMonitor :: [Entry] -> IO () +continueMonitor entries = do + mstate <- readState + case mstate of + Nothing -> return () + Just state@Sentry{..} -> do + putStrLn $ "Sentry reexec'd. Initially started at " ++ + show sStartTime ++ maybe "." (\r -> " (Previously reexec'd at " ++ + show r ++ ").") sReexecTime + t <- getTime + let (walkingDeads, kept) = partitionEithers $ + map (continueProcess entries) sProcesses + state' = state + { sProcesses = addEntries kept entries + , sReexecTime = Just t } + mapM_ terminate walkingDeads + monitor state' + +-- | Monitor the processes from the given application state. +monitor :: Sentry -> IO () +monitor state = do + let state' = state { sProcesses = colorize $ sProcesses state } + hSetBuffering stdout LineBuffering + hSetBuffering stderr LineBuffering + chan <- newChan + setupHUP chan + setupINT chan + -- follow existing handles, if any (after a re-exec there can be some). + forM_ (sProcesses state') $ + \p -> mapM_ (follow chan $ mEntry p) $ mHandles p + writeChan chan UpdateProcesses + processChan state' chan + +-- | Process the command received on the main channel. This acts as a main +-- event loop. +processChan :: Sentry -> Chan Command -> IO () +processChan state@Sentry{..} chan = do + command <- readChan chan + case command of + UpdateProcesses -> do + ps <- mapM (updateProcess chan) sProcesses + let state' = state { sProcesses = ps } + processChan state' chan + ProcessExited typ i -> do + let ps = map (removeProcess typ i) sProcesses + ps' <- mapM (updateProcess chan) ps + let state' = state { sProcesses = ps' } + processChan state' chan + Reexec -> do + -- TODO Compile/Reexec can be splitted: + -- First start a thread waiting while compiling. + -- Second push Reexec on the chan. + -- Or simply let the `sentry reload` command do it + -- before issuing the SIGHUP signal. + -- TODO compile only if the file has been modified. + b <- compile state + if b + then reexecute state + else processChan state chan + Quit -> do + putStrLn "Bye." + -- TODO SIGTERM should be replaced by SIGINT and a small + -- waiting period? + mapM_ (mapM_ (\i -> intToProcessHandle i >>= + terminateProcess) . mHandles) sProcesses + +-- | Compile itself. +compile :: Sentry -> IO Bool +compile state = do + home <- getHomeDirectory + let sentry = home ".sentry" + conf = sentry "conf" + binPath = sExecutablePath state + sourcePath = binPath <.> "hs" + errorPath = binPath <.> "error" + + if takeDirectory binPath /= conf + then do + hPutStrLn stderr $ binPath ++ " is not under " ++ conf ++ "." + return False + else do + status <- withFile errorPath WriteMode $ \h -> do + p <- runProcess "ghc" + [ "--make", sourcePath, "-fforce-recomp", "-v0", "-threaded", + "-o", binPath] + (Just conf) + Nothing Nothing Nothing (Just h) + waitForProcess p + + if status == ExitSuccess + then do + putStrLn $ sourcePath ++ " successfully compiled." + return True + else do + content <- readFile errorPath + hPutStrLn stderr $ "Problem encountered while compiling " ++ sourcePath ++ ":" + hPutStrLn stderr content + return False + +-- | Save the application state then re-exec itself (calling `sentry continue`). +reexecute :: Sentry -> IO a +reexecute state = do + saveState state + executeFile (sExecutablePath state) False ["continue"] Nothing + +-- | Send a @SIGHUP@ signal to a running Sentry. +sendSIGHUP :: Sentry -> IO () +sendSIGHUP state = do + let binPath = sExecutablePath state + pidPath = binPath <.> "pid" + -- TODO all these xxxPath could be function on Sentry. + -- TODO better error messages. + content <- readFile pidPath + signalProcess sigHUP $ fromIntegral (read content :: Int) + +------------------------------------------------------------------------------ +-- State +------------------------------------------------------------------------------ + +-- | Return the path where to save the application state. +getStatePath :: IO FilePath +getStatePath = do + home <- getHomeDirectory + return $ home ".sentry" "sentry.state" + +-- Inspired by the `executale-path` package, which implements +-- a similar function for different OS. +getExecutablePath :: IO FilePath +getExecutablePath = do + pid <- fromIntegral <$> getProcessID :: IO Int + readSymbolicLink $ "/proc/" ++ show pid ++ "/exe" + +-- | Make sure the directory where the application state is saved exists. +ensureStateDirectory :: IO () +ensureStateDirectory = do + home <- getHomeDirectory + let dir = home ".sentry" + conf = dir "conf" + createDirectoryIfMissing False dir + createDirectoryIfMissing False conf + +-- | Create a initial application state from a list of process specifications. +initializeState :: [Entry] -> IO Sentry +initializeState specs = do + path <- getExecutablePath + t <- getTime + return Sentry + { sExecutablePath = path + , sStartTime = t + , sReexecTime = Nothing + , sProcesses = map (flip MonitoredEntry []) specs + } + +-- | Save the application state to disk (normally done just before re-exec'ing +-- itself). +saveState :: Sentry -> IO () +saveState state = do + ensureStateDirectory + statePath <- getStatePath + B.writeFile statePath . runPut $ safePut state + +-- | Try to restore the application state (normally saved previously before +-- re-exec'ing itself). +readState :: IO (Maybe Sentry) +readState = do + statePath <- getStatePath + b <- doesFileExist statePath + if b + then do + content <- B.readFile statePath + case runGet safeGet content of + Left err -> do + hPutStrLn stderr $ "Can't parse existing state." ++ + " Sentry continues with its current state." ++ + " The error was: " ++ err + return Nothing + Right a -> return $ Just a + else do + hPutStrLn stderr $ "The file `" ++ statePath ++ + "` doesn't exist. Sentry continues with its current state." + return Nothing + +-- | Given a list of "new" entries, either modify the monitored entry if it +-- must be updated (and return @Right@) or return @Left@ if it must be +-- deleted. @Left@ is used instead of @Nothing@ so the process handles can +-- be terminated if necessary. +continueProcess :: [Entry] -> MonitoredEntry -> + Either MonitoredEntry MonitoredEntry +continueProcess entries m@MonitoredEntry{..} = + case lookupProcess mEntry entries of + Just p -> Right $ MonitoredEntry p mHandles + Nothing -> Left m + +-- | Add entries to a list of monitored entries if they are not already in +-- there. +addEntries :: [MonitoredEntry] -> [Entry] -> [MonitoredEntry] +addEntries = foldl' addEntry + +-- | Add an entry to a list of monitored entries if it is not already in +-- there. +addEntry :: [MonitoredEntry] -> Entry -> [MonitoredEntry] +-- Order doesn't matter as it will be a Map anyway. +addEntry es e = if present then es else MonitoredEntry e [] : es + where present = isJust $ lookupProcess e $ map mEntry es + +-- | Try to find a matching process in the given list. +lookupProcess :: Entry -> [Entry] -> Maybe Entry +lookupProcess p entries = + case filter (sameEntries p) entries of + [p'] -> Just p' + [] -> Nothing + _ -> error "More than one process" + -- TODO `entries` must be a Map instead of a list. + +-- | Compare if two entries are equal, i.e. if they have +-- same type, command and arguments. +sameEntries :: Entry -> Entry -> Bool +sameEntries p1 p2 = eType p1 == eType p2 + && eCommand p1 == eCommand p2 + && eArguments p1 == eArguments p2 + +------------------------------------------------------------------------------ +-- Logging +------------------------------------------------------------------------------ + +colorize :: [MonitoredEntry] -> [MonitoredEntry] +colorize entries = zipWith f entries $ cycle $ map Just + [Red, Blue, Green, Yellow, Magenta, Cyan, White] + where f e c = e { mEntry = (mEntry e) { eColor = c } } + +colorized :: Entry -> String -> String +colorized Entry{..} str = + case eColor of + Nothing -> pad str + Just c -> + setSGRCode [SetColor Foreground Dull c] ++ pad str ++ setSGRCode [] + +-- TODO non-hardcoded constant +pad :: String -> String +pad s = s ++ replicate (25 - length s) ' ' + +logP :: Entry -> Int -> String -> IO () +logP p@Entry{..} i s = do + ts <- getTimeString + putStrLn $ colorized p (ts ++ " " ++ eType ++ "." ++ show i) ++ s + +------------------------------------------------------------------------------ +-- Signals +------------------------------------------------------------------------------ + +-- | Install the handleHUP function as a SIGHUP handler. +setupHUP :: Chan Command -> IO () +setupHUP chan = do + _ <- installHandler sigHUP (Catch $ handleHUP chan) Nothing + return () + +-- | SIGHUP handler. When the handler is run, it simply instructs the main +-- thread to re-exec the program. +handleHUP :: Chan Command -> IO () +handleHUP = flip writeChan Reexec + +-- | Install the handleINT function as a SIGINT handler. +setupINT :: Chan Command -> IO () +setupINT chan = do + _ <- installHandler sigINT (Catch $ handleINT chan) Nothing + return () + +-- | SIGINT handler. When the handler is run, it simply instructs the main +-- thread to quit the program. +handleINT :: Chan Command -> IO () +handleINT = flip writeChan Quit + +------------------------------------------------------------------------------ +-- Utilities +------------------------------------------------------------------------------ + +-- | Convenience function to turn a ProcessHandle into an Int (used later when +-- saving/restoring the state with SafeCopy). +processHandleToInt :: ProcessHandle -> IO Int +processHandleToInt (ProcessHandle mvar) = do + OpenHandle i <- readMVar mvar + return $ fromIntegral i + +-- | Convenience function to turn an Int into a ProcessHandle (used later when +-- saving/restoring the state with SafeCopy). +intToProcessHandle :: Int -> IO ProcessHandle +intToProcessHandle i = do + mvar <- newMVar $ OpenHandle $ fromIntegral i + return $ ProcessHandle mvar + +-- | Convenience function to get a Posix time as an Int. +getTime :: IO Int +getTime = floor <$> getPOSIXTime + +getTimeString :: IO String +getTimeString = do + tm <- getClockTime + ct <- toCalendarTime tm + return $ formatCalendarTime defaultTimeLocale "%H:%M:%S" ct + +-- | Copy two handles to stout. It is better if the handles are line-buffered. +pipeToStdout :: Entry -> Int -> Handle -> Handle -> IO () +pipeToStdout p i h1 h2 = do + eof1 <- hIsEOF h1 + eof2 <- hIsEOF h2 + ready1 <- if eof1 then return False else hReady h1 + ready2 <- if eof2 then return False else hReady h2 + when ready1 $ do + l <- hGetLine h1 + logP p i l + when ready2 $ do + l <- hGetLine h2 + logP p i l + when (not eof1 || not eof2) $ + pipeToStdout p i h1 h2 + + diff --git a/Sentry/Types.hs b/Sentry/Types.hs new file mode 100644 --- /dev/null +++ b/Sentry/Types.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +-- | +-- Module : Sentry.Types +-- Copyright : (c) 2012 Vo Minh Thu, +-- +-- License : BSD-style +-- Maintainer : thu@hypered.be +-- Stability : experimental +-- Portability : GHC +-- +-- This module contains the different data types and type synonyms used in +-- Sentry. +module Sentry.Types where + +import Data.Data (Data) +import Data.SafeCopy +import Data.Typeable +import System.Console.ANSI (Color(..)) + +-- | A process type is just a name for a specific command. +type ProcessType = String + +-- | An entry in the configuration, i.e. a process specification. +data Entry = Entry + { eType :: ProcessType -- ^ Process type. + , eCommand :: String -- ^ Command. + , eArguments :: [String] -- ^ Command arguments. + , eDelay :: Int -- ^ Dealy before re-starting a process, in milliseconds. + , eCount :: Int -- ^ Number of requested processes of this type. + , eColor :: Maybe Color + } + deriving (Data, Typeable) + -- Data is only needed so we can have [Entry] + -- inside the Sentry.Command.Start command. + +deriving instance Data Color +deriving instance Typeable Color +deriveSafeCopy 0 'base ''Color + +-- | 'entry' is used to define configuration entries to be passed to 'sentry'. +-- A sample entry looks like +-- +-- > entry "dummy" "sleep" ["3"] 1000 1 +-- +-- It creates an entry with type \"dummy\". The type is an arbitrary string that +-- will appear in the logs. It is also used to dynamically change the +-- configuration by refering to its type. It then specifies that the command +-- `sleep 3` will be kept running, restarting it after 1000 milliseconds if +-- necessary. The last value is the number of instances to run, in the example +-- just one. +entry :: ProcessType -> String -> [String] -> Int -> Int -> Entry +entry typ cmd args delay count = + Entry typ cmd args delay count Nothing + +data MonitoredEntry = MonitoredEntry + { mEntry :: Entry -- ^ Process specification. + , mHandles :: [Int] -- ^ List of process handles running the process + -- specification (Int is used instead of ProcessHandle so we can + -- save/restore them with SafeCopy). + } + deriving Typeable + +-- | The application state can be serialized and saved to disk then restored +-- when the process is reexec'd. +data Sentry = Sentry + { sExecutablePath :: FilePath -- ^ Original executable path. + , sStartTime :: Int -- ^ When the process was started. + , sReexecTime :: Maybe Int -- ^ When the process was reexec'd for the last time. + , sProcesses :: [MonitoredEntry] -- ^ List of monitored processes. + } + deriving Typeable + +deriveSafeCopy 0 'base ''Entry +deriveSafeCopy 0 'base ''MonitoredEntry +deriveSafeCopy 0 'base ''Sentry + +-- | The possible commands the main Sentry thread can execute. +data Command = + UpdateProcesses -- ^ Request to update the monitored processes list (e.g. + -- because a process has exited or a process specification + -- has been changed, added, or removed. + | ProcessExited ProcessType Int -- ^ A process has exited. Its type and its + -- ProcessHandle (as an Int) are given. + | Reexec -- ^ Re-exec the application, usually after a SIGHUP. + | Quit -- ^ Request the application to terminate, usually after SIGINT. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMain diff --git a/bin/sentry-sleep.hs b/bin/sentry-sleep.hs new file mode 100644 --- /dev/null +++ b/bin/sentry-sleep.hs @@ -0,0 +1,15 @@ +-- | Sample program that sleep some amount of time and prints to stdout and +-- stderr. +module Main where + +import Control.Concurrent (threadDelay) +import System.IO (hPutStrLn, hSetBuffering, stderr, stdout, BufferMode(..)) + +main :: IO () +main = do + hSetBuffering stdout LineBuffering + hSetBuffering stderr LineBuffering + threadDelay $ 5 * 1000 * 1000 + hPutStrLn stdout "Printed on stdout." + hPutStrLn stderr "Printed on stderr." + threadDelay $ 5 * 1000 * 1000 diff --git a/bin/sentry.hs b/bin/sentry.hs new file mode 100644 --- /dev/null +++ b/bin/sentry.hs @@ -0,0 +1,10 @@ +module Main where + +import Sentry + +main :: IO () +main = sentry + [ entry "short" "sleep" ["2"] 1000 1 + , entry "long" "sleep" ["10"] 1000 2 + , entry "verylong" "sleep" ["30"] 1000 1 + ] diff --git a/sentry.cabal b/sentry.cabal new file mode 100644 --- /dev/null +++ b/sentry.cabal @@ -0,0 +1,62 @@ +name: sentry +version: 0.1.0 +Cabal-Version: >= 1.8 +synopsis: Process monitoring tool written and configured in Haskell +description: + Sentry is a process monitoring tool written and configured in Haskell. Its + aim is to keep running programs. For each configured program, multiple + processes can be started. Currently Sentry runs on Linux only. + . + Under normal circumstance, the "Sentry" module is enough to write + configuration files. +category: Network +license: BSD3 +license-file: LICENSE +author: Vo Minh Thu +maintainer: noteed@gmail.com +homepage: https://github.com/noteed/sentry +bug-reports: https://github.com/noteed/sentry/issues +build-type: Simple + +source-repository head + type: git + location: https://github.com/noteed/sentry + +library + build-depends: base == 4.*, + ansi-terminal == 0.5.*, + bytestring == 0.9.*, + cereal == 0.3.*, + cmdargs == 0.9.*, + directory == 1.1.*, + filepath == 1.2.*, + old-locale == 1.0.*, + old-time == 1.0.*, + process == 1.1.*, + safecopy == 0.6.*, + time == 1.1.*, + unix == 2.4.* + exposed-modules: Sentry, + Sentry.Command, + Sentry.Core, + Sentry.Types + ghc-options: -Wall + +executable sentry + hs-source-dirs: bin + main-is: sentry.hs + build-depends: base == 4.*, + directory == 1.1.*, + filepath == 1.2.*, + sentry, + unix == 2.4.* + ghc-options: -Wall + -threaded + +executable sentry-sleep + hs-source-dirs: bin + main-is: sentry-sleep.hs + build-depends: base == 4.* + ghc-options: -Wall + -threaded + buildable: True