Source

udon / src / Common.hs

Full commit
module Common where

import Control.Arrow ((***))
import Control.Monad (forM_)
import Control.Monad.State (liftIO, MonadIO)
import Data.List (intercalate)
import Data.Time (UTCTime)
import Data.Version (Version)
import System.Directory (getHomeDirectory, createDirectoryIfMissing)
import System.Environment (getProgName)
import System.Exit (ExitCode)
import System.FilePath ((</>))
import System.Posix.Files (setFileCreationMask)
import System.Posix.Signals (Signal)
import System.Posix.Types (ProcessID, Fd)
import System.Posix.User (getEffectiveUserName)
import Text.Printf (printf)

import Paths_udon (getBinDir)

data Daemon = Daemon
    { dName      :: String             -- ^ unique name for daemons
    , dCommand   :: String             -- ^ command
    , dArgs      :: [String]           -- ^ args
    , dCwd       :: String             -- ^ current working directory
    , dEnv       :: [(String, String)] -- ^ environmental variables
    , dAutoStart :: Bool               -- ^ whether auto (re)start process or not
    } deriving (Eq, Ord, Read, Show)

type Logger = Daemon

data DaemonState = DaemonState
    { dsDaemon    :: Daemon
    , dsStatus    :: DaemonStatus
    , dsFdInput   :: Maybe Fd
    , dsFdOutput  :: Maybe Fd
    } deriving (Eq, Ord, Show, Read)

type LoggerState = DaemonState

data DaemonStatus = Running ProcessID UTCTime
                  | Exited ExitCode
                  | Terminated Signal
                  | FastSpawn DaemonStatus
                  | Initializing
                  | NotStarted
                  | Deleting
                  | Updating
                  | Resuming DaemonStatus
    deriving (Eq, Ord, Show, Read)

data Config = Config
    { rcPath            :: FilePath
    , masterLock        :: FilePath
    , masterSock        :: FilePath
    , masterLog         :: FilePath
    , daemonsDir        :: FilePath
    , loggersDir        :: FilePath
    , logDir            :: FilePath
    , fastspawnCount    :: Int
    , fastspawnInterval :: Double
    , loggerCmd         :: (FilePath, [String])
    , contacts          :: [String]
    , notificationCmd   :: (FilePath, [String])
    }

data Request = Ping
             | RegisterDaemon Daemon
             | UnregisterDaemon String
             | UpdateDaemon String Daemon
             | StartDaemon String
             | KillDaemon String Signal
             | SetAutoStart String Bool
             | GetListDaemons
             | GetDaemonStatus String
             | ShutdownMaster
             | RestartMaster FilePath [String]
             | GetMasterVersion
    deriving  (Eq, Ord, Show, Read)

data Response = Pong
              | OK
              | NG String
              | ListDaemons [(DaemonState, LoggerState)]
              | DaemonStatus DaemonState LoggerState
              | MasterVersion String Version
    deriving  (Eq, Ord, Show, Read)

pprintDaemon :: Daemon -> String
pprintDaemon (Daemon name cmd args cwd env auto) =
    unlines
        [ "Daemon {"
        , "  dName = " ++ show name ++ ","
        , "  dCommand = " ++ show cmd ++ ","
        , "  dArgs = [" ++ intercalate ", " (map show args) ++ "],"
        , "  dCwd = " ++ show cwd ++ ","
        , "  dEnv = ["
        , intercalate ",\n" (map (uncurry (printf "    (%s, %s)") . (show *** show)) env)
        , "  ],"
        , "  dAutoStart = " ++ show auto
        , "}"
        ]

simplePprintDaemon :: Daemon -> String
simplePprintDaemon (Daemon name cmd args cwd env auto) =
    unlines
        [ "Daemon {"
        , "  dName = " ++ show name ++ ","
        , "  dCommand = " ++ show cmd ++ ","
        , "  dArgs = [" ++ intercalate ", " (map show args) ++ "],"
        , "  dAutoStart = " ++ show auto
        , "}"
        ]

pprintDaemonState :: DaemonState -> String
pprintDaemonState (DaemonState d dst minp mout) =
    unlines
        [ "DaemonState {"
        , "  dsDaemon   = " ++ init (indent 2 (pprintDaemon d)) ++ ","
        , "  dsStatus   = " ++ show dst ++ ","
        , "  dsFdInput  = " ++ show minp ++ ","
        , "  dsFdOutput = " ++ show mout
        , "}"
        ]

simplePprintDaemonState :: DaemonState -> String
simplePprintDaemonState (DaemonState d dst minp mout) =
    unlines
        [ "DaemonState {"
        , "  dsDaemon   = " ++ init (indent 2 (simplePprintDaemon d)) ++ ","
        , "  dsStatus   = " ++ show dst ++ ","
        , "}"
        ]

indent :: Int -> String -> String
indent n = unlines . map ((replicate n ' ') ++) . lines

defaultRcPath :: FilePath
defaultRcPath = ".udon"

mkDefaultConfig :: IO Config
mkDefaultConfig = do
    h <- getHomeDirectory
    let defaultRcPath' = h </> defaultRcPath
    lcmd <- getLoggerPath
    mcmd <- getSendMailPath
    self <- getProgName
    user <- getEffectiveUserName
    return Config
        { rcPath     = defaultRcPath'
        , masterLock = defaultRcPath' </> "master.lock"
        , masterSock = defaultRcPath' </> "master.sock"
        , masterLog  = defaultRcPath' </> "master.log"
        , daemonsDir = defaultRcPath' </> "run"
        , loggersDir = defaultRcPath' </> "run" </> "logger"
        , logDir     = defaultRcPath' </> "log"

        , fastspawnCount = 3
        , fastspawnInterval = 3

        , loggerCmd = (lcmd, [])

        , contacts        = [user]
        , notificationCmd = (mcmd, [user ++ " (" ++ self ++ ")"])
        }

createRcDirs :: Config -> IO ()
createRcDirs Config { rcPath = rp, daemonsDir = dp, loggersDir = lgp, logDir = lp } = do
    omask <- setFileCreationMask 0o0077
    forM_ [rp, dp, lgp, lp] $ createDirectoryIfMissing True
    setFileCreationMask omask
    return ()

io :: (MonadIO m) => IO a -> m a
io = liftIO

getMasterPath :: IO FilePath
getMasterPath = getBinPath "udon-master"

getClientPath :: IO FilePath
getClientPath = getBinPath "udon"

getLoggerPath :: IO FilePath
getLoggerPath = getBinPath "udon-log"

getSendMailPath :: IO FilePath
getSendMailPath = getBinPath "udon-sendmail"

getBinPath :: FilePath -> IO FilePath
getBinPath f = getBinDir >>= return . (</> f)

escapedDName :: Daemon -> String
escapedDName = escapeFName . dName

escapeFName :: String -> String
escapeFName = escapeSlash . init . tail . show

escapeSlash :: String -> String
escapeSlash      []  = []
escapeSlash ('/':cs) = '\\':'0':'4':'7' : escapeSlash cs
escapeSlash   (c:cs) = c : escapeSlash cs