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
184
185
186
187
188
189
190
191
192
193
194
195
196
|
{- daemon support
-
- Copyright 2012-2021 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Utility.Daemon (
#ifndef mingw32_HOST_OS
daemonize,
#endif
foreground,
checkDaemon,
stopDaemon,
) where
import Common
import Utility.PID
#ifndef mingw32_HOST_OS
import Utility.LogFile
import Utility.Env
import Utility.OpenFd
#else
import System.Win32.Process (terminateProcessById)
import Utility.LockFile
import qualified Utility.OsString as OS
#endif
#ifndef mingw32_HOST_OS
import System.Posix hiding (getEnv, getEnvironment)
#endif
#ifndef mingw32_HOST_OS
{- Run an action as a daemon, with all output sent to a file descriptor,
- and in a new session.
-
- Can write its pid to a file.
-
- This does not double-fork to background, because forkProcess is
- rather fragile and highly unused in haskell programs, so likely to break.
- Instead, it runs the cmd with provided params, in the background,
- which the caller should arrange to run this again.
-}
daemonize :: String -> [CommandParam] -> IO Fd -> Maybe OsPath -> Bool -> IO () -> IO ()
daemonize cmd params openlogfd pidfile changedirectory a = do
maybe noop checkalreadyrunning pidfile
getEnv envvar >>= \case
Just s | s == cmd -> do
maybe noop lockPidFile pidfile
a
_ -> do
nullfd <- openFdWithMode (toRawFilePath "/dev/null") ReadOnly Nothing defaultFileFlags
redir nullfd stdInput
redirLog =<< openlogfd
environ <- getEnvironment
_ <- createProcess $
(proc cmd (toCommand params))
{ env = Just (addEntry envvar cmd environ)
, create_group = True
, new_session = True
, cwd = if changedirectory then Just "/" else Nothing
}
return ()
where
checkalreadyrunning f = maybe noop (const alreadyRunning)
=<< checkDaemon f
envvar = "DAEMONIZED"
#endif
{- To run an action that is normally daemonized in the foreground. -}
#ifndef mingw32_HOST_OS
foreground :: IO Fd -> Maybe OsPath -> IO () -> IO ()
foreground openlogfd pidfile a = do
#else
foreground :: Maybe OsPath -> IO () -> IO ()
foreground pidfile a = do
#endif
maybe noop lockPidFile pidfile
#ifndef mingw32_HOST_OS
_ <- tryIO createSession
redirLog =<< openlogfd
#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 :: OsPath -> IO ()
lockPidFile pidfile = do
#ifndef mingw32_HOST_OS
fd <- openFdWithMode (fromOsPath pidfile) ReadWrite (Just stdFileMode) defaultFileFlags
locked <- catchMaybeIO $ setLock fd (WriteLock, AbsoluteSeek, 0, 0)
fd' <- openFdWithMode (fromOsPath 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
renameFile newfile pidfile
where
newfile = pidfile <> literalOsPath ".new"
#else
{- Not atomic on Windows, oh well. -}
unlessM (isNothing <$> checkDaemon pidfile)
alreadyRunning
pid <- getPID
writeFile (fromOsPath pidfile) (show pid)
lckfile <- winLockFile pid pidfile
writeFile (fromOsPath 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 :: OsPath -> IO (Maybe PID)
#ifndef mingw32_HOST_OS
checkDaemon pidfile = bracket setup cleanup go
where
setup = catchMaybeIO $
openFdWithMode (fromOsPath 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 (fromOsPath 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 " ++ fromOsPath pidfile ++
" (got " ++ show pid' ++
"; expected " ++ show pid ++ " )"
#else
checkDaemon pidfile = maybe (return Nothing) (check . readish)
=<< catchMaybeIO (readFile (fromOsPath 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 :: OsPath -> IO ()
stopDaemon pidfile = go =<< checkDaemon pidfile
where
go Nothing = noop
go (Just pid) =
#ifndef mingw32_HOST_OS
signalProcess sigTERM pid
#else
terminateProcessById 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 -> OsPath -> IO OsPath
winLockFile pid pidfile = do
cleanstale
return $ prefix <> toOsPath (show pid) <> suffix
where
prefix = pidfile <> literalOsPath "."
suffix = literalOsPath ".lck"
cleanstale = mapM_ (void . tryIO . removeFile) =<<
(filter iswinlockfile <$> dirContents (parentDir pidfile))
iswinlockfile f = suffix `OS.isSuffixOf` f && prefix `OS.isPrefixOf` f
#endif
|
