diff options
Diffstat (limited to 'Utility')
| -rw-r--r-- | Utility/Daemon.hs | 55 | ||||
| -rw-r--r-- | Utility/Directory.hs | 5 | ||||
| -rw-r--r-- | Utility/Misc.hs | 10 | ||||
| -rw-r--r-- | Utility/RsyncFile.hs | 11 |
4 files changed, 51 insertions, 30 deletions
diff --git a/Utility/Daemon.hs b/Utility/Daemon.hs index 192340cef..f36a761d0 100644 --- a/Utility/Daemon.hs +++ b/Utility/Daemon.hs @@ -27,7 +27,7 @@ daemonize logfd pidfile changedirectory a = do _ <- forkProcess child2 out child2 = do - maybe noop (lockPidFile True alreadyrunning) pidfile + maybe noop (lockPidFile alreadyrunning) pidfile when changedirectory $ setCurrentDirectory "/" nullfd <- openFd "/dev/null" ReadOnly Nothing defaultFileFlags @@ -42,31 +42,44 @@ daemonize logfd pidfile changedirectory a = do alreadyrunning = error "Daemon is already running." out = exitImmediately ExitSuccess -lockPidFile :: Bool -> IO () -> FilePath -> IO () -lockPidFile write onfailure file = do - fd <- openFd file ReadWrite (Just stdFileMode) - defaultFileFlags { trunc = write } - locked <- catchMaybeIO $ setLock fd (locktype, AbsoluteSeek, 0, 0) - case locked of - Nothing -> onfailure - _ -> when write $ void $ - fdWrite fd =<< show <$> getProcessID +{- Locks the pid file, with an exclusive, non-blocking lock. + - Runs an action on failure. On success, writes the pid to the file, + - fully atomically. -} +lockPidFile :: IO () -> FilePath -> IO () +lockPidFile onfailure file = do + fd <- openFd file 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, _) -> onfailure + (_, Nothing) -> onfailure + _ -> do + _ <- fdWrite fd' =<< show <$> getProcessID + renameFile newfile file + closeFd fd where - locktype - | write = WriteLock - | otherwise = ReadLock + newfile = file ++ ".new" {- Stops the daemon. - - The pid file is used to get the daemon's pid. - - - To guard against a stale pid, try to take a nonblocking shared lock - - of the pid file. If this *fails*, the daemon must be running, - - and have the exclusive lock, so the pid file is trustworthy. + - To guard against a stale pid, check the lock of the pid file, + - and compare the process that has it locked with the file content. -} stopDaemon :: FilePath -> IO () -stopDaemon pidfile = lockPidFile False go pidfile - where - go = do - pid <- readish <$> readFile pidfile - maybe noop (signalProcess sigTERM) pid +stopDaemon pidfile = do + fd <- openFd pidfile ReadOnly (Just stdFileMode) defaultFileFlags + locked <- getLock fd (ReadLock, AbsoluteSeek, 0, 0) + p <- readish <$> readFile pidfile + case (locked, p) of + (Nothing, _) -> noop + (_, Nothing) -> noop + (Just (pid, _), Just pid') + | pid == pid' -> signalProcess sigTERM pid + | otherwise -> error $ + "stale pid in " ++ pidfile ++ + " (got " ++ show pid' ++ + "; expected" ++ show pid ++ " )" diff --git a/Utility/Directory.hs b/Utility/Directory.hs index 2f2960a9d..057da6087 100644 --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -35,14 +35,15 @@ dirContents :: FilePath -> IO [FilePath] dirContents d = map (d </>) . filter (not . dirCruft) <$> getDirectoryContents d {- Gets files in a directory, and then its subdirectories, recursively, - - and lazily. -} + - and lazily. If the directory does not exist, no exception is thrown, + - instead, [] is returned. -} dirContentsRecursive :: FilePath -> IO [FilePath] dirContentsRecursive topdir = dirContentsRecursive' topdir [""] dirContentsRecursive' :: FilePath -> [FilePath] -> IO [FilePath] dirContentsRecursive' _ [] = return [] dirContentsRecursive' topdir (dir:dirs) = unsafeInterleaveIO $ do - (files, dirs') <- collect [] [] =<< dirContents (topdir </> dir) + (files, dirs') <- collect [] [] =<< catchDefaultIO (dirContents (topdir </> dir)) [] files' <- dirContentsRecursive' topdir (dirs' ++ dirs) return (files ++ files') where diff --git a/Utility/Misc.hs b/Utility/Misc.hs index 3ac5ca5c0..3b359139b 100644 --- a/Utility/Misc.hs +++ b/Utility/Misc.hs @@ -35,3 +35,13 @@ separate c l = unbreak $ break c l {- Breaks out the first line. -} firstLine :: String-> String firstLine = takeWhile (/= '\n') + +{- Splits a list into segments that are delimited by items matching + - a predicate. (The delimiters are not included in the segments.) -} +segment :: (a -> Bool) -> [a] -> [[a]] +segment p l = map reverse $ go [] [] l + where + go c r [] = reverse $ c:r + go c r (i:is) + | p i = go [] (c:r) is + | otherwise = go (i:c) r is diff --git a/Utility/RsyncFile.hs b/Utility/RsyncFile.hs index db9057843..075e91d23 100644 --- a/Utility/RsyncFile.hs +++ b/Utility/RsyncFile.hs @@ -22,9 +22,9 @@ rsyncShell command = [Param "-e", Param $ unwords $ map escape (toCommand comman - string is a single quote. -} escape s = "'" ++ join "''" (split "'" s) ++ "'" -{- Runs rsync in server mode to send a file, and exits. -} -rsyncServerSend :: FilePath -> IO () -rsyncServerSend file = rsyncExec $ +{- Runs rsync in server mode to send a file. -} +rsyncServerSend :: FilePath -> IO Bool +rsyncServerSend file = rsync $ rsyncServerParams ++ [Param "--sender", File file] {- Runs rsync in server mode to receive a file. -} @@ -47,11 +47,8 @@ rsyncServerParams = rsync :: [CommandParam] -> IO Bool rsync = boolSystem "rsync" -rsyncExec :: [CommandParam] -> IO () -rsyncExec params = executeFile "rsync" True (toCommand params) Nothing - {- Checks if an rsync url involves the remote shell (ssh or rsh). - - Use of such urls with rsync or rsyncExec requires additional shell + - Use of such urls with rsync requires additional shell - escaping. -} rsyncUrlIsShell :: String -> Bool rsyncUrlIsShell s |