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
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
|
{-# Language ScopedTypeVariables #-}
module Propellor.Spin (
commitSpin,
spin,
spin',
update,
gitPushHelper,
mergeSpin,
) where
import Data.List
import System.Exit
import System.PosixCompat
import System.Posix.IO
import System.Posix.Directory
import Control.Concurrent.Async
import qualified Data.ByteString as B
import qualified Data.Set as S
import Network.Socket (getAddrInfo, defaultHints, AddrInfo(..), AddrInfoFlag(..), SockAddr)
import Propellor.Base
import Propellor.Protocol
import Propellor.PrivData.Paths
import Propellor.Git
import Propellor.Git.Config
import Propellor.Ssh
import Propellor.Gpg
import Propellor.Bootstrap
import Propellor.Types.CmdLine
import Propellor.Types.Info
import qualified Propellor.Shim as Shim
import Utility.FileMode
import Utility.SafeCommand
import Utility.Process.NonConcurrent
commitSpin :: IO ()
commitSpin = do
-- safety check #1: check we're on the configured spin branch
spinBranch <- getGitConfigValue "propellor.spin-branch"
case spinBranch of
Nothing -> return () -- just a noop
Just b -> do
currentBranch <- getCurrentBranch
when (b /= currentBranch) $
error ("spin aborted: check out "
++ b ++ " branch first")
-- safety check #2: check we can commit with a dirty tree
noDirtySpin <- getGitConfigBool "propellor.forbid-dirty-spin"
when noDirtySpin $ do
status <- takeWhile (/= '\n')
<$> readProcess "git" ["status", "--porcelain"]
when (not . null $ status) $
error "spin aborted: commit changes first"
void $ actionMessage "Git commit" $
gitCommit (Just spinCommitMessage)
[Param "--allow-empty", Param "-a"]
-- Push to central origin repo first, if possible.
-- The remote propellor will pull from there, which avoids
-- us needing to send stuff directly to the remote host.
whenM hasOrigin $
void $ actionMessage "Push to central git repository" $
boolSystemNonConcurrent "git" [Param "push"]
spin :: Maybe HostName -> HostName -> Host -> IO ()
spin = spin' Nothing
spin' :: Maybe PrivMap -> Maybe HostName -> HostName -> Host -> IO ()
spin' mprivdata relay target hst = do
cacheparams <- if viarelay
then pure ["-A"]
else toCommand <$> sshCachingParams hn
when viarelay $
void $ boolSystem "ssh-add" []
sshtarget <- ("root@" ++) <$> case relay of
Just r -> pure r
Nothing -> getSshTarget target hst
-- Install, or update the remote propellor.
updateServer target relay hst
(proc "ssh" $ cacheparams ++ [sshtarget, shellWrap probecmd])
(proc "ssh" $ cacheparams ++ [sshtarget, shellWrap updatecmd])
=<< getprivdata
-- And now we can run it.
unlessM (boolSystemNonConcurrent "ssh" (map Param $ cacheparams ++ ["-t", sshtarget, shellWrap runcmd])) $
error "remote propellor failed"
where
hn = fromMaybe target relay
sys = case fromInfo (hostInfo hst) of
InfoVal o -> Just o
NoInfoVal -> Nothing
relaying = relay == Just target
viarelay = isJust relay && not relaying
probecmd = intercalate " ; "
[ "if [ ! -d " ++ localdir ++ "/.git ]"
, "then (" ++ intercalate " && "
[ installGitCommand sys
, "echo " ++ toMarked statusMarker (show NeedGitClone)
] ++ ") || echo " ++ toMarked statusMarker (show NeedPrecompiled)
, "else " ++ updatecmd
, "fi"
]
updatecmd = intercalate " && "
[ "cd " ++ localdir
, bootstrapPropellorCommand sys
, if viarelay
then "./propellor --continue " ++
shellEscape (show (Relay target))
-- Still using --boot for back-compat...
else "./propellor --boot " ++ target
]
runcmd = "cd " ++ localdir ++ " && ./propellor " ++ cmd
cmd = "--serialized " ++ shellEscape (show cmdline)
cmdline
| viarelay = Spin [target] (Just target)
| otherwise = SimpleRun target
getprivdata = case mprivdata of
Nothing
| relaying -> do
let f = privDataRelay hn
d <- readPrivDataFile f
nukeFile f
return d
| otherwise ->
filterPrivData hst <$> decryptPrivData
Just pd -> pure pd
-- Check if the Host contains an IP address that matches one of the IPs
-- in the DNS for the HostName. If so, the HostName is used as-is,
-- but if the DNS is out of sync with the Host config, or doesn't have
-- the host in it at all, use one of the Host's IPs instead.
getSshTarget :: HostName -> Host -> IO String
getSshTarget target hst
| null configips = return target
| otherwise = go =<< tryIO (dnslookup target)
where
go (Left e) = useip (show e)
go (Right addrinfos) = do
configaddrinfos <- catMaybes <$> mapM iptoaddr configips
if any (`elem` configaddrinfos) (map addrAddress addrinfos)
then return target
else useip ("DNS lookup did not return any of the expected addresses " ++ show configips)
dnslookup h = getAddrInfo (Just $ defaultHints { addrFlags = [AI_CANONNAME] }) (Just h) Nothing
-- Convert a string containing an IP address into a SockAddr.
iptoaddr :: String -> IO (Maybe SockAddr)
iptoaddr ip = catchDefaultIO Nothing $ headMaybe . map addrAddress
<$> getAddrInfo (Just $ defaultHints { addrFlags = [AI_NUMERICHOST] }) (Just ip) Nothing
useip why = case headMaybe configips of
Nothing -> return target
Just ip -> do
-- If we're being asked to run on the local host,
-- ignore DNS.
s <- takeWhile (/= '\n') <$> readProcess "hostname" ["-f"]
if s == target
then return target
else do
warningMessage $ "DNS seems out of date for " ++ target ++ " (" ++ why ++ "); using IP address from configuration instead."
return ip
configips = map fromIPAddr $ mapMaybe getIPAddr $
S.toList $ fromDnsInfo $ fromInfo $ hostInfo hst
-- Update the privdata, repo url, and git repo over the ssh
-- connection, talking to the user's local propellor instance which is
-- running the updateServer
update :: Maybe HostName -> IO ()
update forhost = do
whenM hasGitRepo $
req NeedRepoUrl repoUrlMarker setRepoUrl
makePrivDataDir
createDirectoryIfMissing True (takeDirectory privfile)
req NeedPrivData privDataMarker $
writeFileProtected privfile
whenM hasGitRepo $
req NeedGitPush gitPushMarker $ \_ -> do
hin <- dup stdInput
hout <- dup stdOutput
hClose stdin
hClose stdout
-- Not using git pull because git 2.5.0 badly
-- broke its option parser.
unlessM (boolSystemNonConcurrent "git" (pullparams hin hout)) $
errorMessage "git fetch from client failed"
unlessM (boolSystemNonConcurrent "git" [Param "merge", Param "FETCH_HEAD"]) $
errorMessage "git merge from client failed"
where
pullparams hin hout =
[ Param "fetch"
, Param "--progress"
, Param "--upload-pack"
, Param $ "./propellor --gitpush " ++ show hin ++ " " ++ show hout
, Param "."
]
-- When --spin --relay is run, get a privdata file
-- to be relayed to the target host.
privfile = maybe privDataLocal privDataRelay forhost
updateServer
:: HostName
-> Maybe HostName
-> Host
-> CreateProcess
-> CreateProcess
-> PrivMap
-> IO ()
updateServer target relay hst connect haveprecompiled privdata = do
(Just toh, Just fromh, _, pid) <- createProcessNonConcurrent $ connect
{ std_in = CreatePipe
, std_out = CreatePipe
}
go (toh, fromh)
forceSuccessProcess' connect =<< waitForProcessNonConcurrent pid
where
hn = fromMaybe target relay
go (toh, fromh) = do
let loop = go (toh, fromh)
let restart = updateServer hn relay hst connect haveprecompiled privdata
let done = return ()
v <- maybe Nothing readish <$> getMarked fromh statusMarker
case v of
(Just NeedRepoUrl) -> do
sendRepoUrl toh
loop
(Just NeedPrivData) -> do
sendPrivData hn toh privdata
loop
(Just NeedGitClone) -> do
hClose toh
hClose fromh
sendGitClone hn
restart
(Just NeedPrecompiled) -> do
hClose toh
hClose fromh
sendPrecompiled hn
updateServer hn relay hst haveprecompiled (error "loop") privdata
(Just NeedGitPush) -> do
sendGitUpdate hn fromh toh
hClose fromh
hClose toh
done
Nothing -> done
sendRepoUrl :: Handle -> IO ()
sendRepoUrl toh = sendMarked toh repoUrlMarker =<< (fromMaybe "" <$> getRepoUrl)
sendPrivData :: HostName -> Handle -> PrivMap -> IO ()
sendPrivData hn toh privdata = void $ actionMessage msg $ do
sendMarked toh privDataMarker d
return True
where
msg = "Sending privdata (" ++ show (length d) ++ " bytes) to " ++ hn
d = show privdata
sendGitUpdate :: HostName -> Handle -> Handle -> IO ()
sendGitUpdate hn fromh toh =
void $ actionMessage ("Sending git update to " ++ hn) $ do
sendMarked toh gitPushMarker ""
(Nothing, Nothing, Nothing, h) <- createProcess p
(==) ExitSuccess <$> waitForProcess h
where
p = (proc "git" ["upload-pack", "."])
{ std_in = UseHandle fromh
, std_out = UseHandle toh
}
-- Initial git clone, used for bootstrapping.
sendGitClone :: HostName -> IO ()
sendGitClone hn = void $ actionMessage ("Clone git repository to " ++ hn) $ do
branch <- getCurrentBranch
cacheparams <- sshCachingParams hn
withTmpFile "propellor.git" $ \tmp _ -> allM id
[ boolSystem "git" [Param "bundle", Param "create", File tmp, Param "HEAD"]
, boolSystemNonConcurrent "scp" $ cacheparams ++ [File tmp, Param ("root@"++hn++":"++remotebundle)]
, boolSystemNonConcurrent "ssh" $ cacheparams ++ [Param ("root@"++hn), Param $ unpackcmd branch]
]
where
remotebundle = "/usr/local/propellor.git"
unpackcmd branch = shellWrap $ intercalate " && "
[ "git clone " ++ remotebundle ++ " " ++ localdir
, "cd " ++ localdir
, "git checkout -b " ++ branch
, "git remote rm origin"
, "rm -f " ++ remotebundle
]
-- Send a tarball containing the precompiled propellor, and libraries.
-- This should be reasonably portable, as long as the remote host has the
-- same architecture as the build host.
sendPrecompiled :: HostName -> IO ()
sendPrecompiled hn = void $ actionMessage "Uploading locally compiled propellor as a last resort" $
bracket getWorkingDirectory changeWorkingDirectory $ \_ ->
withTmpDir "propellor" go
where
go tmpdir = do
cacheparams <- sshCachingParams hn
let shimdir = takeFileName localdir
createDirectoryIfMissing True (tmpdir </> shimdir)
changeWorkingDirectory (tmpdir </> shimdir)
me <- readSymbolicLink "/proc/self/exe"
createDirectoryIfMissing True "bin"
unlessM (boolSystem "cp" [File me, File "bin/propellor"]) $
errorMessage "failed copying in propellor"
let bin = "bin/propellor"
let binpath = Just $ localdir </> bin
void $ Shim.setup bin binpath "."
changeWorkingDirectory tmpdir
withTmpFile "propellor.tar." $ \tarball _ -> allM id
[ boolSystem "strip" [File me]
, boolSystem "tar" [Param "czf", File tarball, File shimdir]
, boolSystemNonConcurrent "scp" $ cacheparams ++ [File tarball, Param ("root@"++hn++":"++remotetarball)]
, boolSystemNonConcurrent "ssh" $ cacheparams ++ [Param ("root@"++hn), Param unpackcmd]
]
remotetarball = "/usr/local/propellor.tar"
unpackcmd = shellWrap $ intercalate " && "
[ "cd " ++ takeDirectory remotetarball
, "tar xzf " ++ remotetarball
, "rm -f " ++ remotetarball
]
-- Shim for git push over the propellor ssh channel.
-- Reads from stdin and sends it to hout;
-- reads from hin and sends it to stdout.
gitPushHelper :: Fd -> Fd -> IO ()
gitPushHelper hin hout = void $ fromstdin `concurrently` tostdout
where
fromstdin = do
h <- fdToHandle hout
connect stdin h
tostdout = do
h <- fdToHandle hin
connect h stdout
connect fromh toh = do
hSetBinaryMode fromh True
hSetBinaryMode toh True
b <- B.hGetSome fromh 40960
if B.null b
then do
hClose fromh
hClose toh
else do
B.hPut toh b
hFlush toh
connect fromh toh
mergeSpin :: IO ()
mergeSpin = do
branch <- getCurrentBranch
branchref <- getCurrentBranchRef
old_head <- getCurrentGitSha1 branch
old_commit <- findLastNonSpinCommit
rungit "reset" [Param old_commit]
unlessM (gitCommit Nothing [Param "-a", Param "--allow-empty"]) $
error "git commit failed"
rungit "merge" =<< gpgSignParams [Param "-s", Param "ours", Param old_head, Param "--no-edit"]
current_commit <- getCurrentGitSha1 branch
rungit "update-ref" [Param branchref, Param current_commit]
rungit "checkout" [Param branch]
where
rungit cmd ps = unlessM (boolSystem "git" (Param cmd:ps)) $
error ("git " ++ cmd ++ " failed")
findLastNonSpinCommit :: IO String
findLastNonSpinCommit = do
commits <- map (separate (== ' ')) . lines
<$> readProcess "git" ["log", "--oneline", "--no-abbrev-commit"]
case dropWhile (\(_, msg) -> msg == spinCommitMessage) commits of
((sha, _):_) -> return sha
_ -> error $ "Did not find any previous commit that was not a " ++ show spinCommitMessage
spinCommitMessage :: String
spinCommitMessage = "propellor spin"
|