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
|
{- various rsync stuff
-
- Copyright 2010-2013 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
{-# LANGUAGE CPP #-}
module Utility.Rsync (
rsyncShell,
rsyncServerSend,
rsyncServerReceive,
rsyncUseDestinationPermissions,
rsync,
rsyncUrlIsShell,
rsyncUrlIsPath,
rsyncProgress,
filterRsyncSafeOptions,
) where
import Common
import Utility.Metered
import Utility.Tuple
#ifdef mingw32_HOST_OS
import qualified System.FilePath.Posix as Posix
#endif
import Data.Char
import System.Console.GetOpt
{- Generates parameters to make rsync use a specified command as its remote
- shell. -}
rsyncShell :: [CommandParam] -> [CommandParam]
rsyncShell command = [Param "-e", Param $ unwords $ map escape (toCommand command)]
where
{- rsync requires some weird, non-shell like quoting in
- here. A doubled single quote inside the single quoted
- string is a single quote. -}
escape s = "'" ++ intercalate "''" (splitc '\'' s) ++ "'"
{- Runs rsync in server mode to send a file. -}
rsyncServerSend :: [CommandParam] -> FilePath -> IO Bool
rsyncServerSend options file = rsync $
rsyncServerParams ++ Param "--sender" : options ++ [File file]
{- Runs rsync in server mode to receive a file. -}
rsyncServerReceive :: [CommandParam] -> FilePath -> IO Bool
rsyncServerReceive options file = rsync $
rsyncServerParams ++ options ++ [File file]
rsyncServerParams :: [CommandParam]
rsyncServerParams =
[ Param "--server"
-- preserve timestamps
, Param "-t"
-- allow resuming of transfers of big files
, Param "--inplace"
-- other options rsync normally uses in server mode
, Param "-e.Lsf"
, Param "."
]
rsyncUseDestinationPermissions :: CommandParam
rsyncUseDestinationPermissions = Param "--chmod=ugo=rwX"
rsync :: [CommandParam] -> IO Bool
rsync = boolSystem "rsync" . rsyncParamsFixup
{- On Windows, rsync is from msys2, and expects to get msys2 formatted
- paths to files. (It thinks that C:foo refers to a host named "C").
- Fix up the Params appropriately. -}
rsyncParamsFixup :: [CommandParam] -> [CommandParam]
#ifdef mingw32_HOST_OS
rsyncParamsFixup = map fixup
where
fixup (File f) = File (toMSYS2Path f)
fixup (Param s)
| rsyncUrlIsPath s = Param (toMSYS2Path s)
fixup p = p
#else
rsyncParamsFixup = id
#endif
{- Checks if an rsync url involves the remote shell (ssh or rsh).
- Use of such urls with rsync requires additional shell
- escaping. -}
rsyncUrlIsShell :: String -> Bool
rsyncUrlIsShell s
| "rsync://" `isPrefixOf` s = False
| otherwise = go s
where
-- host::dir is rsync protocol, while host:dir is ssh/rsh
go [] = False
go (c:cs)
| c == '/' = False -- got to directory with no colon
| c == ':' = not $ ":" `isPrefixOf` cs
| otherwise = go cs
{- Checks if a rsync url is really just a local path. -}
rsyncUrlIsPath :: String -> Bool
rsyncUrlIsPath s
#ifdef mingw32_HOST_OS
| not (null (takeDrive s)) = True
#endif
| rsyncUrlIsShell s = False
| otherwise = ':' `notElem` s
{- Runs rsync, but intercepts its progress output and updates a progress
- meter.
-
- The params must enable rsync's --progress mode for this to work.
-}
rsyncProgress :: OutputHandler -> MeterUpdate -> [CommandParam] -> IO Bool
rsyncProgress oh meter ps =
commandMeterExitCode parseRsyncProgress oh Nothing meter "rsync" (rsyncParamsFixup ps) >>= \case
Just ExitSuccess -> return True
Just (ExitFailure exitcode) -> do
when (exitcode /= 1) $
hPutStrLn stderr $ "rsync exited " ++ show exitcode
return False
Nothing -> do
hPutStrLn stderr $ "unable to run rsync"
return False
{- Strategy: Look for chunks prefixed with \r (rsync writes a \r before
- the first progress output, and each thereafter). The first number
- after the \r is the number of bytes processed. After the number,
- there must appear some whitespace, or we didn't get the whole number,
- and return the \r and part we did get, for later processing.
-
- In some locales, the number will have one or more commas in the middle
- of it.
-}
parseRsyncProgress :: ProgressParser
parseRsyncProgress = go [] . reverse . progresschunks
where
go remainder [] = (Nothing, Nothing, remainder)
go remainder (x:xs) = case parsebytes (findbytesstart x) of
Nothing -> go (delim:x++remainder) xs
Just b -> (Just (toBytesProcessed b), Nothing, remainder)
delim = '\r'
{- Find chunks that each start with delim.
- The first chunk doesn't start with it
- (it's empty when delim is at the start of the string). -}
progresschunks = drop 1 . splitc delim
findbytesstart s = dropWhile isSpace s
parsebytes :: String -> Maybe Integer
parsebytes s = case break isSpace s of
([], _) -> Nothing
(_, []) -> Nothing
(b, _) -> readish $ filter (/= ',') b
{- Filters options to those that are safe to pass to rsync in server mode,
- without causing it to eg, expose files. -}
filterRsyncSafeOptions :: [String] -> [String]
filterRsyncSafeOptions = fst3 . getOpt Permute
[ Option [] ["bwlimit"] (reqArgLong "bwlimit") "" ]
where
reqArgLong x = ReqArg (\v -> "--" ++ x ++ "=" ++ v) ""
{- Converts a DOS style path to a msys2 style path. Only on Windows.
- Any trailing '\' is preserved as a trailing '/'
-
- Taken from: http://sourceforge.net/p/msys2/wiki/MSYS2%20introduction/i
-
- The virtual filesystem contains:
- /c, /d, ... mount points for Windows drives
-}
#ifdef mingw32_HOST_OS
toMSYS2Path :: FilePath -> FilePath
toMSYS2Path p
| null drive = recombine parts
| otherwise = recombine $ "/" : driveletter drive : parts
where
(drive, p') = splitDrive p
parts = splitDirectories p'
driveletter = map toLower . takeWhile (/= ':')
recombine = fixtrailing . Posix.joinPath
fixtrailing s
| hasTrailingPathSeparator p = Posix.addTrailingPathSeparator s
| otherwise = s
#endif
|
