summaryrefslogtreecommitdiff
path: root/Utility/Daemon.hs
blob: 5c0ea41696d4daf3cec2586957c67489eb587fa1 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
{- daemon support
 -
 - Copyright 2012-2014 Joey Hess <id@joeyh.name>
 -
 - License: BSD-2-clause
 -}

{-# LANGUAGE CPP #-}

module Utility.Daemon where

import Common
import Utility.PID
#ifndef mingw32_HOST_OS
import Utility.LogFile
#else
import Utility.WinProcess
import Utility.LockFile
#endif

#ifndef mingw32_HOST_OS
import System.Posix
import Control.Concurrent.Async
#endif

#ifndef mingw32_HOST_OS
{- Run an action as a daemon, with all output sent to a file descriptor.
 -
 - Can write its pid to a file, to guard against multiple instances
 - running and allow easy termination.
 -
 - When successful, does not return. -}
daemonize :: Fd -> Maybe FilePath -> Bool -> IO () -> IO ()
daemonize logfd pidfile changedirectory a = do
	maybe noop checkalreadyrunning pidfile
	_ <- forkProcess child1
	out
  where
	checkalreadyrunning f = maybe noop (const alreadyRunning) 
		=<< checkDaemon f
	child1 = do
		_ <- tryIO createSession
		_ <- forkProcess child2
		out
	child2 = do
		maybe noop lockPidFile pidfile 
		when changedirectory $
			setCurrentDirectory "/"
		nullfd <- openFd "/dev/null" ReadOnly Nothing defaultFileFlags
		redir nullfd stdInput
		redirLog logfd
		{- In old versions of ghc, forkProcess masks async exceptions;
		 - unmask them inside the action. -}
		wait =<< asyncWithUnmask (\unmask -> unmask a)
		out
	out = exitImmediately ExitSuccess
#endif

{- To run an action that is normally daemonized in the forground. -}
#ifndef mingw32_HOST_OS
foreground :: Fd -> Maybe FilePath -> IO () -> IO ()
foreground logfd pidfile a = do
#else
foreground :: Maybe FilePath -> IO () -> IO ()
foreground pidfile a = do
#endif
	maybe noop lockPidFile pidfile
#ifndef mingw32_HOST_OS
	_ <- tryIO createSession
	redirLog logfd
#endif
	a
#ifndef mingw32_HOST_OS
	exitImmediately ExitSuccess
#else
	exitWith ExitSuccess
#endif

{- Locks the pid file, with an exclusive, non-blocking lock,
 - and leaves it locked on return.
 -
 - Writes the pid to the file, fully atomically.
 - Fails if the pid file is already locked by another process. -}
lockPidFile :: FilePath -> IO ()
lockPidFile pidfile = do
	createDirectoryIfMissing True (parentDir pidfile)
#ifndef mingw32_HOST_OS
	fd <- openFd pidfile ReadWrite (Just stdFileMode) defaultFileFlags
	locked <- catchMaybeIO $ setLock fd (WriteLock, AbsoluteSeek, 0, 0)
	fd' <- openFd newfile ReadWrite (Just stdFileMode) defaultFileFlags
		{ trunc = True }
	locked' <- catchMaybeIO $ setLock fd' (WriteLock, AbsoluteSeek, 0, 0)
	case (locked, locked') of
		(Nothing, _) -> alreadyRunning
		(_, Nothing) -> alreadyRunning
		_ -> do
			_ <- fdWrite fd' =<< show <$> getPID
			closeFd fd
	rename newfile pidfile
  where
	newfile = pidfile ++ ".new"
#else
	{- Not atomic on Windows, oh well. -}
	unlessM (isNothing <$> checkDaemon pidfile)
		alreadyRunning
	pid <- getPID
	writeFile pidfile (show pid)
	lckfile <- winLockFile pid pidfile
	writeFile lckfile ""
	void $ lockExclusive lckfile
#endif

alreadyRunning :: IO ()
alreadyRunning = giveup "Daemon is already running."

{- Checks if the daemon is running, by checking that the pid file
 - is locked by the same process that is listed in the pid file.
 -
 - If it's running, returns its pid. -}
checkDaemon :: FilePath -> IO (Maybe PID)
#ifndef mingw32_HOST_OS
checkDaemon pidfile = bracket setup cleanup go
  where
	setup = catchMaybeIO $
		openFd pidfile ReadOnly (Just stdFileMode) defaultFileFlags
	cleanup (Just fd) = closeFd fd
	cleanup Nothing = return ()
	go (Just fd) = catchDefaultIO Nothing $ do
		locked <- getLock fd (ReadLock, AbsoluteSeek, 0, 0)
		p <- readish <$> readFile pidfile
		return (check locked p)
	go Nothing = return Nothing

	check Nothing _ = Nothing
	check _ Nothing = Nothing
	check (Just (pid, _)) (Just pid')
		| pid == pid' = Just pid
		| otherwise = giveup $
			"stale pid in " ++ pidfile ++ 
			" (got " ++ show pid' ++ 
			"; expected " ++ show pid ++ " )"
#else
checkDaemon pidfile = maybe (return Nothing) (check . readish)
	=<< catchMaybeIO (readFile pidfile)
  where
	check Nothing = return Nothing
	check (Just pid) = do
		v <- lockShared =<< winLockFile pid pidfile
		case v of
			Just h -> do
				dropLock h
				return Nothing
			Nothing -> return (Just pid)
#endif

{- Stops the daemon, safely. -}
stopDaemon :: FilePath -> IO ()
stopDaemon pidfile = go =<< checkDaemon pidfile
  where
	go Nothing = noop
	go (Just pid) =
#ifndef mingw32_HOST_OS
		signalProcess sigTERM pid
#else
		terminatePID pid
#endif

{- Windows locks a lock file that corresponds with the pid of the process.
 - This allows changing the process in the pid file and taking a new lock
 - when eg, restarting the daemon.
 -}
#ifdef mingw32_HOST_OS
winLockFile :: PID -> FilePath -> IO FilePath
winLockFile pid pidfile = do
	cleanstale
	return $ prefix ++ show pid ++ suffix
  where
	prefix = pidfile ++ "."
	suffix = ".lck"
	cleanstale = mapM_ (void . tryIO . removeFile) =<<
		(filter iswinlockfile <$> dirContents (parentDir pidfile))
	iswinlockfile f = suffix `isSuffixOf` f && prefix `isPrefixOf` f
#endif