summaryrefslogtreecommitdiff
path: root/Propellor/CmdLine.hs
diff options
context:
space:
mode:
authorJoey Hess2014-04-10 21:09:20 -0400
committerJoey Hess2014-04-10 21:13:56 -0400
commit50cd59cb3e6d20afe48a50fa9dc0c3a9cf9d9960 (patch)
treea40995cebd88f276750a3f998124d4d55aaecdba /Propellor/CmdLine.hs
parent981085fe8148c23985e1735f0a0926d2efd62375 (diff)
new more expressive config.hs WIP
Diffstat (limited to 'Propellor/CmdLine.hs')
-rw-r--r--Propellor/CmdLine.hs65
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"