1{- daemon support 2 - 3 - Copyright 2012-2021 Joey Hess <id@joeyh.name> 4 - 5 - License: BSD-2-clause 6 -} 7 8{-# LANGUAGE CPP #-} 9 10module Utility.Daemon ( 11#ifndef mingw32_HOST_OS 12 daemonize, 13#endif 14 foreground, 15 checkDaemon, 16 stopDaemon, 17) where 18 19import Common 20import Utility.PID 21#ifndef mingw32_HOST_OS 22import Utility.LogFile 23import Utility.Env 24#else 25import System.Win32.Process (terminateProcessById) 26import Utility.LockFile 27#endif 28 29#ifndef mingw32_HOST_OS 30import System.Posix hiding (getEnv, getEnvironment) 31#endif 32 33#ifndef mingw32_HOST_OS 34{- Run an action as a daemon, with all output sent to a file descriptor, 35 - and in a new session. 36 - 37 - Can write its pid to a file. 38 - 39 - This does not double-fork to background, because forkProcess is 40 - rather fragile and highly unused in haskell programs, so likely to break. 41 - Instead, it runs the cmd with provided params, in the background, 42 - which the caller should arrange to run this again. 43 -} 44daemonize :: String -> [CommandParam] -> IO Fd -> Maybe FilePath -> Bool -> IO () -> IO () 45daemonize cmd params openlogfd pidfile changedirectory a = do 46 maybe noop checkalreadyrunning pidfile 47 getEnv envvar >>= \case 48 Just s | s == cmd -> do 49 maybe noop lockPidFile pidfile 50 a 51 _ -> do 52 nullfd <- openFd "/dev/null" ReadOnly Nothing defaultFileFlags 53 redir nullfd stdInput 54 redirLog =<< openlogfd 55 environ <- getEnvironment 56 _ <- createProcess $ 57 (proc cmd (toCommand params)) 58 { env = Just (addEntry envvar cmd environ) 59 , create_group = True 60 , new_session = True 61 , cwd = if changedirectory then Just "/" else Nothing 62 } 63 return () 64 where 65 checkalreadyrunning f = maybe noop (const alreadyRunning) 66 =<< checkDaemon f 67 envvar = "DAEMONIZED" 68#endif 69 70{- To run an action that is normally daemonized in the forground. -} 71#ifndef mingw32_HOST_OS 72foreground :: IO Fd -> Maybe FilePath -> IO () -> IO () 73foreground openlogfd pidfile a = do 74#else 75foreground :: Maybe FilePath -> IO () -> IO () 76foreground pidfile a = do 77#endif 78 maybe noop lockPidFile pidfile 79#ifndef mingw32_HOST_OS 80 _ <- tryIO createSession 81 redirLog =<< openlogfd 82#endif 83 a 84#ifndef mingw32_HOST_OS 85 exitImmediately ExitSuccess 86#else 87 exitWith ExitSuccess 88#endif 89 90{- Locks the pid file, with an exclusive, non-blocking lock, 91 - and leaves it locked on return. 92 - 93 - Writes the pid to the file, fully atomically. 94 - Fails if the pid file is already locked by another process. -} 95lockPidFile :: FilePath -> IO () 96lockPidFile pidfile = do 97#ifndef mingw32_HOST_OS 98 fd <- openFd pidfile ReadWrite (Just stdFileMode) defaultFileFlags 99 locked <- catchMaybeIO $ setLock fd (WriteLock, AbsoluteSeek, 0, 0) 100 fd' <- openFd newfile ReadWrite (Just stdFileMode) defaultFileFlags 101 { trunc = True } 102 locked' <- catchMaybeIO $ setLock fd' (WriteLock, AbsoluteSeek, 0, 0) 103 case (locked, locked') of 104 (Nothing, _) -> alreadyRunning 105 (_, Nothing) -> alreadyRunning 106 _ -> do 107 _ <- fdWrite fd' =<< show <$> getPID 108 closeFd fd 109 rename newfile pidfile 110 where 111 newfile = pidfile ++ ".new" 112#else 113 {- Not atomic on Windows, oh well. -} 114 unlessM (isNothing <$> checkDaemon pidfile) 115 alreadyRunning 116 pid <- getPID 117 writeFile pidfile (show pid) 118 lckfile <- winLockFile pid pidfile 119 writeFile (fromRawFilePath lckfile) "" 120 void $ lockExclusive lckfile 121#endif 122 123alreadyRunning :: IO () 124alreadyRunning = giveup "Daemon is already running." 125 126{- Checks if the daemon is running, by checking that the pid file 127 - is locked by the same process that is listed in the pid file. 128 - 129 - If it's running, returns its pid. -} 130checkDaemon :: FilePath -> IO (Maybe PID) 131#ifndef mingw32_HOST_OS 132checkDaemon pidfile = bracket setup cleanup go 133 where 134 setup = catchMaybeIO $ 135 openFd pidfile ReadOnly (Just stdFileMode) defaultFileFlags 136 cleanup (Just fd) = closeFd fd 137 cleanup Nothing = return () 138 go (Just fd) = catchDefaultIO Nothing $ do 139 locked <- getLock fd (ReadLock, AbsoluteSeek, 0, 0) 140 p <- readish <$> readFile pidfile 141 return (check locked p) 142 go Nothing = return Nothing 143 144 check Nothing _ = Nothing 145 check _ Nothing = Nothing 146 check (Just (pid, _)) (Just pid') 147 | pid == pid' = Just pid 148 | otherwise = giveup $ 149 "stale pid in " ++ pidfile ++ 150 " (got " ++ show pid' ++ 151 "; expected " ++ show pid ++ " )" 152#else 153checkDaemon pidfile = maybe (return Nothing) (check . readish) 154 =<< catchMaybeIO (readFile pidfile) 155 where 156 check Nothing = return Nothing 157 check (Just pid) = do 158 v <- lockShared =<< winLockFile pid pidfile 159 case v of 160 Just h -> do 161 dropLock h 162 return Nothing 163 Nothing -> return (Just pid) 164#endif 165 166{- Stops the daemon, safely. -} 167stopDaemon :: FilePath -> IO () 168stopDaemon pidfile = go =<< checkDaemon pidfile 169 where 170 go Nothing = noop 171 go (Just pid) = 172#ifndef mingw32_HOST_OS 173 signalProcess sigTERM pid 174#else 175 terminateProcessById pid 176#endif 177 178{- Windows locks a lock file that corresponds with the pid of the process. 179 - This allows changing the process in the pid file and taking a new lock 180 - when eg, restarting the daemon. 181 -} 182#ifdef mingw32_HOST_OS 183winLockFile :: PID -> FilePath -> IO RawFilePath 184winLockFile pid pidfile = do 185 cleanstale 186 return $ toRawFilePath $ prefix ++ show pid ++ suffix 187 where 188 prefix = pidfile ++ "." 189 suffix = ".lck" 190 cleanstale = mapM_ (void . tryIO . removeFile) =<< 191 (filter iswinlockfile <$> dirContents (fromRawFilePath (parentDir (toRawFilePath pidfile)))) 192 iswinlockfile f = suffix `isSuffixOf` f && prefix `isPrefixOf` f 193#endif 194