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
|
{- git-annex utility functions
-
- Copyright 2010 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Utility (
withFileLocked,
hGetContentsStrict,
parentDir,
relPathCwdToDir,
relPathDirToDir,
boolSystem,
shellEscape
) where
import System.IO
import System.Cmd.Utils
import System.Exit
import System.Posix.Process
import System.Posix.Process.Internals
import System.Posix.Signals
import System.Posix.IO
import Data.String.Utils
import System.Path
import System.IO.HVFS
import System.FilePath
import System.Directory
{- Let's just say that Haskell makes reading/writing a file with
- file locking excessively difficult. -}
withFileLocked file mode action = do
-- TODO: find a way to use bracket here
handle <- openFile file mode
lockfd <- handleToFd handle -- closes handle
waitToSetLock lockfd (lockType mode, AbsoluteSeek, 0, 0)
handle' <- fdToHandle lockfd
ret <- action handle'
hClose handle'
return ret
where
lockType ReadMode = ReadLock
lockType _ = WriteLock
{- A version of hgetContents that is not lazy. Ensures file is
- all read before it gets closed. -}
hGetContentsStrict h = hGetContents h >>= \s -> length s `seq` return s
{- Returns the parent directory of a path. Parent of / is "" -}
parentDir :: String -> String
parentDir dir =
if (not $ null dirs)
then slash ++ (join s $ take ((length dirs) - 1) dirs)
else ""
where
dirs = filter (\x -> length x > 0) $
split s dir
slash = if (not $ isAbsolute dir) then "" else s
s = [pathSeparator]
{- Constructs a relative path from the CWD to a directory.
-
- For example, assuming CWD is /tmp/foo/bar:
- relPathCwdToDir "/tmp/foo" == "../"
- relPathCwdToDir "/tmp/foo/bar" == ""
- relPathCwdToDir "/tmp/foo/bar" == ""
-}
relPathCwdToDir :: FilePath -> IO FilePath
relPathCwdToDir dir = do
cwd <- getCurrentDirectory
let absdir = abs cwd dir
return $ relPathDirToDir cwd absdir
where
-- absolute, normalized form of the directory
abs cwd dir =
case (absNormPath cwd dir) of
Just d -> d
Nothing -> error $ "unable to normalize " ++ dir
{- Constructs a relative path from one directory to another.
-
- Both directories must be absolute, and normalized (eg with absNormpath).
-
- The path will end with "/", unless it is empty.
-}
relPathDirToDir :: FilePath -> FilePath -> FilePath
relPathDirToDir from to =
if (not $ null path)
then addTrailingPathSeparator path
else ""
where
s = [pathSeparator]
pfrom = split s from
pto = split s to
common = map fst $ filter same $ zip pfrom pto
same (c,d) = c == d
uncommon = drop numcommon pto
dotdots = take ((length pfrom) - numcommon) $ repeat ".."
numcommon = length $ common
path = join s $ dotdots ++ uncommon
{- Run a system command, and returns True or False
- if it succeeded or failed.
-
- SIGINT(ctrl-c) is allowed to propigate and will terminate the program.
-}
boolSystem :: FilePath -> [String] -> IO Bool
boolSystem command params = do
-- Going low-level because all the high-level system functions
-- block SIGINT etc. We need to block SIGCHLD, but allow
-- SIGINT to do its default program termination.
let sigset = addSignal sigCHLD emptySignalSet
oldint <- installHandler sigINT Default Nothing
oldset <- getSignalMask
blockSignals sigset
childpid <- forkProcess $ childaction oldint oldset
mps <- getProcessStatus True False childpid
restoresignals oldint oldset
case mps of
Just (Exited ExitSuccess) -> return True
_ -> return False
where
restoresignals oldint oldset = do
installHandler sigINT oldint Nothing
setSignalMask oldset
childaction oldint oldset = do
restoresignals oldint oldset
executeFile command True params Nothing
{- Escapes a filename to be safely able to be exposed to the shell. -}
shellEscape f = "'" ++ quote ++ "'"
where
-- replace ' with '"'"'
quote = join "'\"'\"'" $ split "'" f
|