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