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
|
module Propellor.CmdLine (
defaultMain,
processCmdLine,
) where
import System.Environment (getArgs)
import Data.List
import System.Exit
import System.PosixCompat
import Propellor
import Propellor.Protocol
import Propellor.Gpg
import Propellor.Git
import Propellor.Ssh
import Propellor.Server
import qualified Propellor.Property.Docker as Docker
import qualified Propellor.Property.Chroot as Chroot
import qualified Propellor.Shim as Shim
import Utility.SafeCommand
usage :: Handle -> IO ()
usage h = hPutStrLn h $ unlines
[ "Usage:"
, " propellor"
, " propellor hostname"
, " propellor --spin hostname"
, " propellor --add-key keyid"
, " propellor --set field context"
, " propellor --dump field context"
, " propellor --edit field context"
, " propellor --list-fields"
]
usageError :: [String] -> IO a
usageError ps = do
usage stderr
error ("(Unexpected: " ++ show ps)
processCmdLine :: IO CmdLine
processCmdLine = go =<< getArgs
where
go ("--run":h:[]) = return $ Run h
go ("--spin":h:[]) = return $ Spin h
go ("--add-key":k:[]) = return $ AddKey k
go ("--set":f:c:[]) = withprivfield f c Set
go ("--dump":f:c:[]) = withprivfield f c Dump
go ("--edit":f:c:[]) = withprivfield f c Edit
go ("--list-fields":[]) = return ListFields
go ("--help":_) = do
usage stdout
exitFailure
go ("--update":h:[]) = return $ Update h
go ("--boot":h:[]) = return $ Update h -- for back-compat
go ("--continue":s:[]) = case readish s of
Just cmdline -> return $ Continue cmdline
Nothing -> errorMessage $ "--continue serialization failure (" ++ s ++ ")"
go ("--gitpush":fin:fout:_) = return $ GitPush (Prelude.read fin) (Prelude.read fout)
go (h:[])
| "--" `isPrefixOf` h = usageError [h]
| otherwise = return $ Run h
go [] = do
s <- takeWhile (/= '\n') <$> readProcess "hostname" ["-f"]
if null s
then errorMessage "Cannot determine hostname! Pass it on the command line."
else return $ Run s
go v = usageError v
withprivfield s c f = case readish s of
Just pf -> return $ f pf (Context c)
Nothing -> errorMessage $ "Unknown privdata field " ++ s
-- | Runs propellor on hosts, as controlled by command-line options.
defaultMain :: [Host] -> IO ()
defaultMain hostlist = do
Shim.cleanEnv
checkDebugMode
cmdline <- processCmdLine
debug ["command line: ", show cmdline]
go True cmdline
where
go _ (Continue cmdline) = go False cmdline
go _ (Set field context) = setPrivData field context
go _ (Dump field context) = dumpPrivData field context
go _ (Edit field context) = editPrivData field context
go _ ListFields = listPrivDataFields hostlist
go _ (AddKey keyid) = addKey keyid
go _ c@(ChrootChain _ _ _ _) = Chroot.chain hostlist c
go _ (DockerChain hn cid) = Docker.chain hostlist hn cid
go _ (DockerInit hn) = Docker.init hn
go _ (GitPush fin fout) = gitPushHelper fin fout
go _ (Update _) = forceConsole >> fetchFirst (onlyprocess update)
go True cmdline@(Spin _) = buildFirst cmdline $ go False cmdline
go True cmdline = updateFirst cmdline $ go False cmdline
go False (Spin hn) = withhost hn $ spin hn
go False cmdline@(SimpleRun hn) = buildFirst cmdline $
go False (Run hn)
go False (Run hn) = ifM ((==) 0 <$> getRealUserID)
( onlyprocess $ withhost hn mainProperties
, go True (Spin hn)
)
withhost :: HostName -> (Host -> IO ()) -> IO ()
withhost hn a = maybe (unknownhost hn hostlist) a (findHost hostlist hn)
onlyprocess = onlyProcess (localdir </> ".lock")
unknownhost :: HostName -> [Host] -> IO a
unknownhost h hosts = errorMessage $ unlines
[ "Propellor does not know about host: " ++ h
, "(Perhaps you should specify the real hostname on the command line?)"
, "(Or, edit propellor's config.hs to configure this host)"
, "Known hosts: " ++ unwords (map hostName hosts)
]
buildFirst :: CmdLine -> IO () -> IO ()
buildFirst cmdline next = ifM (doesFileExist "Makefile")
( do
oldtime <- getmtime
ifM (actionMessage "Propellor build" $ boolSystem "make" [Param "build"])
( do
newtime <- getmtime
if newtime == oldtime
then next
else void $ boolSystem "./propellor" [Param "--continue", Param (show cmdline)]
, errorMessage "Propellor build failed!"
)
, next
)
where
getmtime = catchMaybeIO $ getModificationTime "propellor"
fetchFirst :: IO () -> IO ()
fetchFirst next = do
whenM hasOrigin $
void fetchOrigin
next
updateFirst :: CmdLine -> IO () -> IO ()
updateFirst cmdline next = ifM hasOrigin (updateFirst' cmdline next, next)
updateFirst' :: CmdLine -> IO () -> IO ()
updateFirst' cmdline next = ifM fetchOrigin
( ifM (actionMessage "Propellor build" $ boolSystem "make" [Param "build"])
( void $ boolSystem "./propellor" [Param "--continue", Param (show cmdline)]
, errorMessage "Propellor build failed!"
)
, next
)
spin :: HostName -> Host -> IO ()
spin hn hst = do
void $ actionMessage "Git commit" $
gitCommit [Param "--allow-empty", Param "-a", Param "-m", Param "propellor spin"]
-- 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" $
boolSystem "git" [Param "push"]
cacheparams <- toCommand <$> sshCachingParams hn
-- Install, or update the remote propellor.
updateServer hn hst $ withBothHandles createProcessSuccess
(proc "ssh" $ cacheparams ++ [user, updatecmd])
-- And now we can run it.
unlessM (boolSystem "ssh" (map Param $ cacheparams ++ ["-t", user, runcmd])) $
error $ "remote propellor failed"
where
user = "root@"++hn
mkcmd = shellWrap . intercalate " ; "
updatecmd = mkcmd
[ "if [ ! -d " ++ localdir ++ " ]"
, "then (" ++ intercalate " && "
[ "apt-get-fail update"
, "apt-get --no-install-recommends --no-upgrade -y install git make"
, "echo " ++ toMarked statusMarker (show NeedGitClone)
] ++ ") || echo " ++ toMarked statusMarker (show NeedPrecompiled)
, "else " ++ intercalate " && "
[ "cd " ++ localdir
, "if ! test -x ./propellor; then make deps build; fi"
, "./propellor --boot " ++ hn
]
, "fi"
]
runcmd = mkcmd
[ "cd " ++ localdir ++ " && ./propellor --continue " ++ shellEscape (show (SimpleRun hn)) ]
|
