propellor/CmdLine.hs

102 lines
2.6 KiB
Haskell
Raw Normal View History

2014-03-30 23:10:32 +00:00
module CmdLine where
import System.Environment
import Data.List
import System.Exit
import Common
import Utility.FileMode
data CmdLine
= Run HostName
| Spin HostName
| Boot HostName
2014-03-31 01:01:18 +00:00
| Set HostName PrivDataField
2014-03-30 23:10:32 +00:00
processCmdLine :: IO CmdLine
processCmdLine = go =<< getArgs
where
go ("--help":_) = usage
go ("--spin":h:[]) = return $ Spin h
go ("--boot":h:[]) = return $ Boot h
2014-03-31 01:01:18 +00:00
go ("--set":h:f:[]) = case readish f of
Just pf -> return $ Set h pf
2014-03-30 23:10:32 +00:00
Nothing -> error $ "Unknown privdata field " ++ f
go (h:[]) = return $ Run h
go [] = do
s <- takeWhile (/= '\n') <$> readProcess "hostname" ["-f"]
if null s
then error "Cannot determine hostname! Pass it on the command line."
else return $ Run s
go _ = usage
usage :: IO a
usage = do
putStrLn $ unlines
[ "Usage:"
, " propellor"
, " propellor hostname"
, " propellor --spin hostname"
2014-03-31 01:01:18 +00:00
, " propellor --set hostname field"
2014-03-30 23:10:32 +00:00
]
exitFailure
defaultMain :: (HostName -> [Property]) -> IO ()
defaultMain getprops = go =<< processCmdLine
where
go (Run host) = ensureProperties (getprops host)
go (Spin host) = spin host
go (Boot host) = boot (getprops host)
2014-03-31 01:01:18 +00:00
go (Set host field) = setPrivData host field
2014-03-30 23:10:32 +00:00
spin :: HostName -> IO ()
spin host = do
url <- getUrl
void $ boolSystem "git" [Param "commit", Param "-a", Param "-m", Param "propellor spin"]
2014-03-30 23:19:29 +00:00
void $ boolSystem "git" [Param "push"]
privdata <- gpgDecrypt (privDataFile host)
2014-03-30 23:10:32 +00:00
withHandle StdinHandle createProcessSuccess
(proc "ssh" ["root@"++host, bootstrap url]) $ \h -> do
hPutStr h $ unlines $ map (privDataMarker ++) $ lines privdata
hClose h
where
bootstrap url = shellWrap $ intercalate " && "
[ intercalate " ; "
[ "if [ ! -d " ++ localdir ++ " ]"
2014-03-30 23:13:26 +00:00
, "then " ++ intercalate " && "
2014-03-30 23:10:32 +00:00
[ "apt-get -y install git"
, "git clone " ++ url ++ " " ++ localdir
]
, "fi"
]
, "cd " ++ localdir
, "make pull build"
, "./propellor --boot " ++ host
]
boot :: [Property] -> IO ()
boot props = do
privdata <- map (drop $ length privDataMarker )
. filter (privDataMarker `isPrefixOf`)
. lines
<$> getContents
2014-03-30 23:19:29 +00:00
makePrivDataDir
2014-03-30 23:10:32 +00:00
writeFileProtected privDataLocal (unlines privdata)
ensureProperties props
localdir :: FilePath
localdir = "/usr/local/propellor"
getUrl :: IO String
getUrl = fromMaybe nourl <$> getM get urls
where
urls = ["remote.deploy.url", "remote.origin.url"]
nourl = error $ "Cannot find deploy url in " ++ show urls
get u = do
v <- catchMaybeIO $
takeWhile (/= '\n')
<$> readProcess "git" ["config", u]
return $ case v of
Just url | not (null url) -> Just url
_ -> Nothing