new more expressive config.hs WIP

1 files changed, 33 insertions, 32 deletions

diff --git a/Propellor/CmdLine.hs b/Propellor/CmdLine.hs
index 2026c47a..5be91c4f 100644
--- a/Propellor/CmdLine.hs
+++ b/Propellor/CmdLine.hs
@@ -55,8 +55,8 @@ processCmdLine = go =<< getArgs
 			else return $ Run s
 	go _ = usage
 
-defaultMain :: [HostName -> Maybe [Property]] -> IO ()
-defaultMain getprops = do
+defaultMain :: [Host] -> IO ()
+defaultMain hostlist = do
 	DockerShim.cleanEnv
 	checkDebugMode
 	cmdline <- processCmdLine
@@ -64,25 +64,26 @@ defaultMain getprops = do
 	go True cmdline
   where
 	go _ (Continue cmdline) = go False cmdline
-	go _ (Set host field) = setPrivData host field
+	go _ (Set hn field) = setPrivData hn field
 	go _ (AddKey keyid) = addKey keyid
-	go _ (Chain host) = withprops host $ \hostattr ps -> do
-		r <- runPropellor hostattr $ ensureProperties ps
+	go _ (Chain hn) = withprops hn $ \attr ps -> do
+		r <- runPropellor attr $ ensureProperties ps
 		putStrLn $ "\n" ++ show r
-	go _ (Docker host) = Docker.chain host
+	go _ (Docker hn) = Docker.chain hn
 	go True cmdline@(Spin _) = buildFirst cmdline $ go False cmdline
 	go True cmdline = updateFirst cmdline $ go False cmdline
-	go False (Spin host) = withprops host $ const . const $ spin host
-	go False (Run host) = ifM ((==) 0 <$> getRealUserID)
-		( onlyProcess $ withprops host mainProperties
-		, go True (Spin host)
+	go False (Spin hn) = withprops hn $ const . const $ spin hn
+	go False (Run hn) = ifM ((==) 0 <$> getRealUserID)
+		( onlyProcess $ withprops hn mainProperties
+		, go True (Spin hn)
 		)
-	go False (Boot host) = onlyProcess $ withprops host $ boot
+	go False (Boot hn) = onlyProcess $ withprops hn boot
 
-	withprops host a = maybe (unknownhost host) (a hostattr) $
-		headMaybe $ catMaybes $ map (\get -> get host) getprops
-	  where
-		hostattr = mkHostAttr host
+	withprops :: HostName -> (Attr -> [Property] -> IO ()) -> IO ()
+	withprops hn a = maybe
+		(unknownhost hn)
+		(\h -> a (hostAttr h) (hostProperties h))
+		(findHost hostlist hn)
 
 onlyProcess :: IO a -> IO a
 onlyProcess a = bracket lock unlock (const a)
@@ -166,16 +167,16 @@ getCurrentGitSha1 :: String -> IO String
 getCurrentGitSha1 branchref = readProcess "git" ["show-ref", "--hash", branchref]
 
 spin :: HostName -> IO ()
-spin host = do
+spin hn = do
 	url <- getUrl
 	void $ gitCommit [Param "--allow-empty", Param "-a", Param "-m", Param "propellor spin"]
 	void $ boolSystem "git" [Param "push"]
-	cacheparams <- toCommand <$> sshCachingParams host
-	go cacheparams url =<< gpgDecrypt (privDataFile host)
+	cacheparams <- toCommand <$> sshCachingParams hn
+	go cacheparams url =<< gpgDecrypt (privDataFile hn)
   where
 	go cacheparams url privdata = withBothHandles createProcessSuccess (proc "ssh" $ cacheparams ++ [user, bootstrapcmd]) $ \(toh, fromh) -> do
 		let finish = do
-			senddata toh (privDataFile host) privDataMarker privdata
+			senddata toh (privDataFile hn) privDataMarker privdata
 			hClose toh
 			
 			-- Display remaining output.
@@ -188,10 +189,10 @@ spin host = do
 			NeedGitClone -> do
 				hClose toh
 				hClose fromh
-				sendGitClone host url
+				sendGitClone hn url
 				go cacheparams url privdata
 	
-	user = "root@"++host
+	user = "root@"++hn
 
 	bootstrapcmd = shellWrap $ intercalate " ; "
 		[ "if [ ! -d " ++ localdir ++ " ]"
@@ -202,7 +203,7 @@ spin host = do
 		, "else " ++ intercalate " && "
 			[ "cd " ++ localdir
 			, "if ! test -x ./propellor; then make deps build; fi"
-			, "./propellor --boot " ++ host
+			, "./propellor --boot " ++ hn
 			]
 		, "fi"
 		]
@@ -218,18 +219,18 @@ spin host = do
 	
 	showremote s = putStrLn s
 	senddata toh f marker s = void $
-		actionMessage ("Sending " ++ f ++ " (" ++ show (length s) ++ " bytes) to " ++ host) $ do
+		actionMessage ("Sending " ++ f ++ " (" ++ show (length s) ++ " bytes) to " ++ hn) $ do
 			sendMarked toh marker s
 			return True
 
 sendGitClone :: HostName -> String -> IO ()
-sendGitClone host url = void $ actionMessage ("Pushing git repository to " ++ host) $ do
+sendGitClone hn url = void $ actionMessage ("Pushing git repository to " ++ hn) $ do
 	branch <- getCurrentBranch
-	cacheparams <- sshCachingParams host
+	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@"++host++":"++remotebundle)]
-		, boolSystem "ssh" $ cacheparams ++ [Param ("root@"++host), Param $ unpackcmd branch]
+		, boolSystem "scp" $ cacheparams ++ [File tmp, Param ("root@"++hn++":"++remotebundle)]
+		, boolSystem "ssh" $ cacheparams ++ [Param ("root@"++hn), Param $ unpackcmd branch]
 		]
   where
 	remotebundle = "/usr/local/propellor.git"
@@ -277,15 +278,15 @@ fromMarked marker s
 	len = length marker
 	matches = filter (marker `isPrefixOf`) $ lines s
 
-boot :: HostAttr -> [Property] -> IO ()
-boot hostattr ps = do
+boot :: Attr -> [Property] -> IO ()
+boot attr ps = do
 	sendMarked stdout statusMarker $ show Ready
 	reply <- hGetContentsStrict stdin
 
 	makePrivDataDir
 	maybe noop (writeFileProtected privDataLocal) $
 		fromMarked privDataMarker reply
-	mainProperties hostattr ps
+	mainProperties attr ps
 
 addKey :: String -> IO ()
 addKey keyid = exitBool =<< allM id [ gpg, gitadd, gitcommit ]
@@ -347,11 +348,11 @@ checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG"
 
 -- Parameters can be passed to both ssh and scp.
 sshCachingParams :: HostName -> IO [CommandParam]
-sshCachingParams hostname = do
+sshCachingParams hn = do
 	home <- myHomeDir
 	let cachedir = home </> ".ssh" </> "propellor"
 	createDirectoryIfMissing False cachedir
-	let socketfile = cachedir </> hostname ++ ".sock"
+	let socketfile = cachedir </> hn ++ ".sock"
 	return
 		[ Param "-o", Param ("ControlPath=" ++ socketfile)
 		, Params "-o ControlMaster=auto -o ControlPersist=yes"