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
|
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 :: IO ()
update = do
whenM hasOrigin $
req NeedRepoUrl repoUrlMarker setRepoUrl
makePrivDataDir
req NeedPrivData privDataMarker $
writeFileProtected privDataLocal
whenM hasOrigin $
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 "."
]
-- The connect action should ssh to the remote host and run the provided
-- calback action.
updateServer :: HostName -> Host -> (((Handle, Handle) -> IO ()) -> IO ()) -> IO ()
updateServer hn hst connect = connect go
where
go (toh, fromh) = do
let loop = go (toh, fromh)
v <- (maybe Nothing readish <$> getMarked fromh statusMarker)
case v of
(Just NeedRepoUrl) -> do
sendRepoUrl toh
loop
(Just NeedPrivData) -> do
sendPrivData hn hst toh
loop
(Just NeedGitPush) -> do
sendGitUpdate hn fromh toh
-- no more protocol possible after git push
hClose fromh
hClose toh
(Just NeedGitClone) -> do
hClose toh
hClose fromh
sendGitClone hn
updateServer hn hst connect
(Just NeedPrecompiled) -> do
hClose toh
hClose fromh
sendPrecompiled hn
updateServer hn hst connect
Nothing -> return ()
sendRepoUrl :: Handle -> IO ()
sendRepoUrl toh = sendMarked toh repoUrlMarker =<< (fromMaybe "" <$> getRepoUrl)
sendPrivData :: HostName -> Host -> Handle -> IO ()
sendPrivData hn hst toh = do
privdata <- show . filterPrivData hst <$> decryptPrivData
void $ actionMessage ("Sending privdata (" ++ show (length privdata) ++ " bytes) to " ++ hn) $ do
sendMarked toh privDataMarker privdata
return True
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"]
, 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
cacheparams <- sshCachingParams hn
withTmpDir "propellor" $ \tmpdir ->
bracket getWorkingDirectory changeWorkingDirectory $ \_ -> do
let shimdir = "propellor"
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 "cf", File tarball, File shimdir]
, boolSystem "scp" $ cacheparams ++ [File tarball, Param ("root@"++hn++":"++remotetarball)]
, boolSystem "ssh" $ cacheparams ++ [Param ("root@"++hn), Param unpackcmd]
]
where
remotetarball = "/usr/local/propellor.tar"
unpackcmd = shellWrap $ intercalate " && "
[ "cd " ++ takeDirectory remotetarball
, "tar xf " ++ 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
|
