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
|
-- When propellor --spin is running, the local host acts as a server,
-- which connects to the remote host's propellor and responds to its
-- requests.
module Propellor.Server (
update,
updateServer,
gitPushHelper
) where
import Data.List
import System.Exit
import System.PosixCompat
import System.Posix.IO
import System.Posix.Directory
import Control.Concurrent.Async
import Control.Exception (bracket)
import qualified Data.ByteString as B
import Propellor
import Propellor.Protocol
import Propellor.PrivData.Paths
import Propellor.Git
import Propellor.Ssh
import qualified Propellor.Shim as Shim
import Utility.FileMode
import Utility.SafeCommand
-- 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
unlessM (boolSystem "git" (pullparams hin hout)) $
errorMessage "git pull from client failed"
where
pullparams hin hout =
[ Param "pull"
, 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
-- The connect action should ssh to the remote host and run the provided
-- calback action.
updateServer :: HostName -> Maybe HostName -> Host -> (((Handle, Handle) -> IO ()) -> IO ()) -> IO ()
updateServer target relay hst connect = connect go
where
hn = fromMaybe target relay
relaying = relay == Just target
go (toh, fromh) = do
let loop = go (toh, fromh)
let restart = updateServer hn relay hst connect
let done = return ()
v <- (maybe Nothing readish <$> getMarked fromh statusMarker)
case v of
(Just NeedRepoUrl) -> do
sendRepoUrl toh
loop
(Just NeedPrivData) -> do
sendPrivData hn hst toh relaying
loop
(Just NeedGitClone) -> do
hClose toh
hClose fromh
sendGitClone hn
restart
(Just NeedPrecompiled) -> do
hClose toh
hClose fromh
sendPrecompiled hn
restart
(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 -> Host -> Handle -> Bool -> IO ()
sendPrivData hn hst toh relaying = do
privdata <- getdata
void $ actionMessage ("Sending privdata (" ++ show (length privdata) ++ " bytes) to " ++ hn) $ do
sendMarked toh privDataMarker privdata
return True
where
getdata
| relaying = do
let f = privDataRelay hn
d <- readFileStrictAnyEncoding f
nukeFile f
return d
| otherwise = show . filterPrivData hst <$> decryptPrivData
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 False
withTmpFile "propellor.git" $ \tmp _ -> allM id
[ boolSystem "git" [Param "bundle", Param "create", File tmp, Param "HEAD"]
, boolSystem "scp" $ cacheparams ++ [File tmp, Param ("root@"++hn++":"++remotebundle)]
, boolSystem "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") $ do
bracket getWorkingDirectory changeWorkingDirectory $ \_ ->
withTmpDir "propellor" go
where
go tmpdir = do
cacheparams <- sshCachingParams hn False
let shimdir = takeFileName localdir
createDirectoryIfMissing True (tmpdir </> shimdir)
changeWorkingDirectory (tmpdir </> shimdir)
me <- readSymbolicLink "/proc/self/exe"
shim <- Shim.setup me "."
when (shim /= "propellor") $
renameFile shim "propellor"
changeWorkingDirectory tmpdir
withTmpFile "propellor.tar." $ \tarball _ -> allM id
[ boolSystem "strip" [File me]
, boolSystem "tar" [Param "czf", File tarball, File shimdir]
, boolSystem "scp" $ cacheparams ++ [File tarball, Param ("root@"++hn++":"++remotetarball)]
, boolSystem "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
|
