summaryrefslogtreecommitdiff
path: root/src/Propellor/CmdLine.hs
blob: bd01b34ce453cc0281e0621eba3c682d111ce91d (plain)
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
module Propellor.CmdLine (
	defaultMain,
	processCmdLine,
) where

import System.Environment (getArgs)
import Data.List
import System.Exit
import System.PosixCompat
import Network.Socket

import Propellor.Base
import Propellor.Gpg
import Propellor.Git
import Propellor.Git.VerifiedBranch
import Propellor.Bootstrap
import Propellor.Spin
import Propellor.Types.CmdLine
import qualified Propellor.Property.Docker as Docker
import qualified Propellor.Property.Chroot as Chroot
import qualified Propellor.Shim as Shim
import Utility.FileSystemEncoding

usage :: Handle -> IO ()
usage h = hPutStrLn h $ unlines
	[ "Usage:"
	, "  with no arguments, provision the current host"
	, ""
	, "  --init"
	, "      initialize ~/.propellor"
	, "  hostname"
	, "      provision the current host as if it had the specified hostname"
	, "  --spin targethost [--via relayhost]"
	, "      provision the specified host"
	, "  --build"
	, "      recompile using your current config"
	, "  --add-key keyid"
	, "      add an additional signing key to the private data"
	, "  --rm-key keyid"
	, "      remove a signing key from the private data"
	, "  --list-fields"
	, "      list private data fields"
	, "  --set field context"
	, "      set a private data field"
	, "  --unset field context"
	, "      clear a private data field"
	, "  --unset-unused"
	, "      clear unused fields from the private data"
	, "  --dump field context"
	, "      show the content of a private data field"
	, "  --edit field context"
	, "      edit the content of a private data field"
	, "  --merge"
	, "      combine multiple spins into a single git commit"
	, "  --check"
	, "      double-check that propellor can actually run here"]

usageError :: [String] -> IO a
usageError ps = do
	usage stderr
	error ("(Unexpected: " ++ show ps)

processCmdLine :: IO CmdLine
processCmdLine = go =<< getArgs
  where
	go ("--check":_) = return Check
	go ("--spin":ps) = case reverse ps of
		(r:"--via":hs) -> Spin
			<$> mapM hostname (reverse hs)
			<*> pure (Just r)
		_ -> Spin <$> mapM hostname ps <*> pure Nothing
	go ("--build":[]) = return Build
	go ("--add-key":k:[]) = return $ AddKey k
	go ("--rm-key":k:[]) = return $ RmKey k
	go ("--set":f:c:[]) = withprivfield f c Set
	go ("--unset":f:c:[]) = withprivfield f c Unset
	go ("--unset-unused":[]) = return UnsetUnused
	go ("--dump":f:c:[]) = withprivfield f c Dump
	go ("--edit":f:c:[]) = withprivfield f c Edit
	go ("--list-fields":[]) = return ListFields
	go ("--merge":[]) = return Merge
	go ("--help":_) = do
		usage stdout
		exitFailure
	go ("--boot":_:[]) = return $ Update Nothing -- for back-compat
	go ("--serialized":s:[]) = serialized Serialized s
	go ("--continue":s:[]) = serialized Continue s
	go ("--gitpush":fin:fout:_) = return $ GitPush (Prelude.read fin) (Prelude.read fout)
	go ("--run":h:[]) = go [h]
	go (h:[])
		| "--" `isPrefixOf` h = usageError [h]
		| otherwise = Run <$> hostname 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

	serialized mk s = case readish s of
		Just cmdline -> return $ mk cmdline
		Nothing -> errorMessage $ "serialization failure (" ++ s ++ ")"

data CanRebuild = CanRebuild | NoRebuild

-- | Runs propellor on hosts, as controlled by command-line options.
defaultMain :: [Host] -> IO ()
defaultMain hostlist = withConcurrentOutput $ do
	useFileSystemEncoding
	setupGpgEnv
	Shim.cleanEnv
	checkDebugMode
	cmdline <- processCmdLine
	debug ["command line: ", show cmdline]
	go CanRebuild cmdline
  where
	go cr (Serialized cmdline) = go cr cmdline
	go _ Check = return ()
	go cr Build = buildFirst Nothing cr Build $ return ()
	go _ (Set field context) = setPrivData field context
	go _ (Unset field context) = unsetPrivData field context
	go _ (UnsetUnused) = unsetPrivDataUnused hostlist
	go _ (Dump field context) = dumpPrivData field context
	go _ (Edit field context) = editPrivData field context
	go _ ListFields = listPrivDataFields hostlist
	go _ (AddKey keyid) = addKey keyid
	go _ (RmKey keyid) = rmKey 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 cr (Relay h) = forceConsole >>
		updateFirst Nothing cr (Update (Just h)) (update (Just h))
	go _ (Update Nothing) = forceConsole >>
		fetchFirst (onlyprocess (update Nothing))
	go _ (Update (Just h)) = update (Just h)
	go _ Merge = mergeSpin
	go cr cmdline@(Spin hs mrelay) = buildFirst Nothing cr cmdline $ do
		unless (isJust mrelay) commitSpin
		forM_ hs $ \hn -> withhost hn $ spin mrelay hn
	go cr cmdline@(Run hn) = ifM ((==) 0 <$> getRealUserID)
		( updateFirst (findHost hostlist hn) cr cmdline $ runhost hn
		, fetchFirst $ go cr (Spin [hn] Nothing)
		)
	go cr cmdline@(SimpleRun hn) = forceConsole >>
		fetchFirst (buildFirst (findHost hostlist hn) cr cmdline (runhost hn))
	-- When continuing after a rebuild, don't want to rebuild again.
	go _ (Continue cmdline) = go NoRebuild cmdline

	withhost :: HostName -> (Host -> IO ()) -> IO ()
	withhost hn a = maybe (unknownhost hn hostlist) a (findHost hostlist hn)

	runhost hn = onlyprocess $ withhost hn mainProperties

	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)
	]

-- Builds propellor (when allowed) and if it looks like a new binary,
-- re-execs it to continue.
-- Otherwise, runs the IO action to continue.
--
-- The Host should only be provided when dependencies should be installed
-- as needed to build propellor.
buildFirst :: Maybe Host -> CanRebuild -> CmdLine -> IO () -> IO ()
buildFirst h CanRebuild cmdline next = do
	oldtime <- getmtime
	buildPropellor h
	newtime <- getmtime
	if newtime == oldtime
		then next
		else continueAfterBuild cmdline
  where
	getmtime = catchMaybeIO $ getModificationTime "propellor"
buildFirst _ NoRebuild _ next = next

continueAfterBuild :: CmdLine -> IO a
continueAfterBuild cmdline = go =<< boolSystem "./propellor"
	[ Param "--continue"
	, Param (show cmdline)
	]
  where
	go True = exitSuccess
	go False = exitWith (ExitFailure 1)

fetchFirst :: IO () -> IO ()
fetchFirst next = do
	whenM hasOrigin $
		void fetchOrigin
	next

updateFirst :: Maybe Host -> CanRebuild -> CmdLine -> IO () -> IO ()
updateFirst h canrebuild cmdline next = ifM hasOrigin
	( updateFirst' h canrebuild cmdline next
	, next
	)

-- If changes can be fetched from origin, builds propellor (when allowed)
-- and re-execs the updated propellor binary to continue.
-- Otherwise, runs the IO action to continue.
updateFirst' :: Maybe Host -> CanRebuild -> CmdLine -> IO () -> IO ()
updateFirst' h CanRebuild cmdline next = ifM fetchOrigin
	( do
		buildPropellor h
		continueAfterBuild cmdline
	, next
	)
updateFirst' _ NoRebuild _ next = next

-- Gets the fully qualified domain name, given a string that might be
-- a short name to look up in the DNS.
hostname :: String -> IO HostName
hostname s = go =<< catchDefaultIO [] dnslookup
  where
	dnslookup = getAddrInfo (Just canonname) (Just s) Nothing
	canonname = defaultHints { addrFlags = [AI_CANONNAME] }
	go (AddrInfo { addrCanonName = Just v } : _) = pure v
	go _
		| "." `isInfixOf` s = pure s -- assume it's a fqdn
		| otherwise =
			error $ "cannot find host " ++ s ++ " in the DNS"