propellor/Propellor/CmdLine.hs

243 lines
6.5 KiB
Haskell
Raw Normal View History

2014-03-31 03:37:54 +00:00
module Propellor.CmdLine where
2014-03-30 23:10:32 +00:00
import System.Environment
import Data.List
import System.Exit
2014-03-31 18:41:40 +00:00
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Base64.Lazy as B64
import Data.Bits.Utils
2014-03-30 23:10:32 +00:00
2014-03-31 03:55:59 +00:00
import Propellor
2014-03-30 23:10:32 +00:00
import Utility.FileMode
2014-03-31 03:55:59 +00:00
import Utility.SafeCommand
2014-03-31 18:41:40 +00:00
import Utility.Data
2014-03-30 23:10:32 +00:00
data CmdLine
= Run HostName
| Spin HostName
| Boot HostName
2014-03-31 01:01:18 +00:00
| Set HostName PrivDataField
2014-03-31 16:06:04 +00:00
| AddKey String
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 16:06:04 +00:00
go ("--add-key":k:[]) = return $ AddKey k
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-31 16:06:04 +00:00
, " propellor --add-key keyid"
2014-03-30 23:10:32 +00:00
]
exitFailure
2014-03-31 03:02:10 +00:00
defaultMain :: (HostName -> Maybe [Property]) -> IO ()
2014-03-30 23:10:32 +00:00
defaultMain getprops = go =<< processCmdLine
where
2014-03-31 18:59:06 +00:00
go (Run host) = withprops host ensureProperties
go (Spin host) = withprops host (const $ spin host)
go (Boot host) = withprops host boot
2014-03-31 01:01:18 +00:00
go (Set host field) = setPrivData host field
2014-03-31 16:06:04 +00:00
go (AddKey keyid) = addKey keyid
2014-03-31 18:59:06 +00:00
withprops host a = maybe (unknownhost host) a (getprops host)
2014-03-30 23:10:32 +00:00
2014-03-31 03:02:10 +00:00
unknownhost :: HostName -> IO a
unknownhost h = error $ unwords
[ "Unknown host:", h
, "(perhaps you should specify the real hostname on the command line?)"
]
2014-03-30 23:10:32 +00:00
spin :: HostName -> IO ()
spin host = do
url <- getUrl
2014-03-31 16:06:04 +00:00
void $ gitCommit [Param "--allow-empty", Param "-a", Param "-m", Param "propellor spin"]
2014-03-30 23:19:29 +00:00
void $ boolSystem "git" [Param "push"]
2014-03-31 19:40:16 +00:00
go url =<< gpgDecrypt (privDataFile host)
where
go url privdata = withBothHandles createProcessSuccess (proc "ssh" [user, bootstrapcmd]) $ \(toh, fromh) -> do
let finish = do
senddata toh (privDataFile host) privDataMarker privdata
hClose toh
-- Display remaining output.
void $ tryIO $ forever $
showremote =<< hGetLine fromh
hClose fromh
2014-03-31 16:28:40 +00:00
status <- getstatus fromh `catchIO` error "protocol error"
2014-03-31 16:06:04 +00:00
case status of
2014-03-31 19:40:16 +00:00
HaveKeyRing -> finish
2014-03-31 16:28:40 +00:00
NeedKeyRing -> do
2014-03-31 19:05:13 +00:00
d <- w82s . BL.unpack . B64.encode
<$> BL.readFile keyring
senddata toh keyring keyringMarker d
2014-03-31 19:40:16 +00:00
finish
NeedGitClone -> do
hClose toh
hClose fromh
sendGitClone host url
go url privdata
2014-03-31 16:06:04 +00:00
user = "root@"++host
2014-03-31 19:40:16 +00:00
bootstrapcmd = shellWrap $ intercalate " && "
2014-03-30 23:10:32 +00:00
[ 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"
2014-03-31 19:40:16 +00:00
, "echo " ++ toMarked statusMarker (show NeedGitClone)
2014-03-30 23:10:32 +00:00
]
, "fi"
]
, "cd " ++ localdir
2014-03-31 19:40:16 +00:00
, "make build"
2014-03-30 23:10:32 +00:00
, "./propellor --boot " ++ host
]
2014-03-31 19:40:16 +00:00
2014-03-31 16:28:40 +00:00
getstatus :: Handle -> IO BootStrapStatus
2014-03-31 18:22:48 +00:00
getstatus h = do
l <- hGetLine h
case readish =<< fromMarked statusMarker l of
Nothing -> do
2014-03-31 18:24:15 +00:00
showremote l
2014-03-31 18:22:48 +00:00
getstatus h
Just status -> return status
2014-03-31 19:40:16 +00:00
2014-03-31 18:44:38 +00:00
showremote s = putStrLn s
2014-03-31 19:05:13 +00:00
senddata toh f marker s = do
putStr $ "Sending " ++ f ++ " (" ++ show (length s) ++ " bytes) to " ++ host ++ "..."
hFlush stdout
hPutStrLn toh $ toMarked marker s
hFlush toh
putStrLn "done"
2014-03-30 23:10:32 +00:00
2014-03-31 19:40:16 +00:00
sendGitClone :: HostName -> String -> IO ()
sendGitClone host url = do
putStrLn $ "Pushing git repository to " ++ host
withTmpFile "gitbundle" $ \tmp _ -> do
-- TODO: ssh connection caching, or better push method
-- with less connections.
void $ boolSystem "git" [Param "bundle", Param "create", File tmp, Param "HEAD"]
void $ boolSystem "scp" [File tmp, Param ("root@"++host++":"++remotebundle)]
void $ boolSystem "ssh" [Param ("root@"++host), Param unpackcmd]
where
remotebundle = "/usr/local/propellor.git"
unpackcmd = shellWrap $ intercalate " && "
[ "git clone " ++ remotebundle ++ " " ++ localdir
, "cd " ++ localdir
, "git checkout -b master"
, "git remote rm origin"
, "git remote add origin " ++ url
, "rm -f " ++ remotebundle
]
data BootStrapStatus = HaveKeyRing | NeedKeyRing | NeedGitClone
2014-03-31 16:06:04 +00:00
deriving (Read, Show, Eq)
type Marker = String
type Marked = String
statusMarker :: Marker
statusMarker = "STATUS"
keyringMarker :: Marker
keyringMarker = "KEYRING"
privDataMarker :: String
privDataMarker = "PRIVDATA "
toMarked :: Marker -> String -> String
2014-03-31 19:43:24 +00:00
toMarked marker = intercalate "\n" . map (marker ++) . lines
2014-03-31 16:06:04 +00:00
2014-03-31 18:21:14 +00:00
fromMarked :: Marker -> Marked -> Maybe String
fromMarked marker s
| null matches = Nothing
2014-03-31 19:43:24 +00:00
| otherwise = Just $ intercalate "\n" $
map (drop len) matches
2014-03-31 16:06:04 +00:00
where
len = length marker
2014-03-31 18:21:14 +00:00
matches = filter (marker `isPrefixOf`) $ lines s
2014-03-31 16:06:04 +00:00
2014-03-30 23:10:32 +00:00
boot :: [Property] -> IO ()
boot props = do
2014-03-31 16:06:04 +00:00
havering <- doesFileExist keyring
putStrLn $ toMarked statusMarker $ show $ if havering then HaveKeyRing else NeedKeyRing
2014-03-31 16:28:40 +00:00
hFlush stdout
2014-03-31 18:26:56 +00:00
reply <- hGetContentsStrict stdin
2014-03-31 18:15:12 +00:00
2014-03-30 23:19:29 +00:00
makePrivDataDir
2014-03-31 18:21:14 +00:00
maybe noop (writeFileProtected privDataLocal) $
fromMarked privDataMarker reply
2014-03-31 19:43:24 +00:00
case eitherToMaybe . B64.decode . BL.pack . s2w8 =<< fromMarked keyringMarker reply of
2014-03-31 18:41:40 +00:00
Nothing -> noop
Just d -> do
writeFileProtected keyring ""
BL.writeFile keyring d
2014-03-30 23:10:32 +00:00
ensureProperties props
2014-03-31 16:06:04 +00:00
addKey :: String -> IO ()
addKey keyid = exitBool =<< allM id [ gpg, gitadd, gitcommit ]
where
gpg = boolSystem "sh"
[ Param "-c"
, Param $ "gpg --export " ++ keyid ++ " | gpg " ++
unwords (gpgopts ++ ["--import"])
]
gitadd = boolSystem "git"
[ Param "add"
, File keyring
]
gitcommit = gitCommit
[ File keyring
, Param "-m"
, Param "propellor addkey"
]
{- Automatically sign the commit if there'a a keyring. -}
gitCommit :: [CommandParam] -> IO Bool
gitCommit ps = do
k <- doesFileExist keyring
boolSystem "git" $ catMaybes $
[ Just (Param "commit")
, if k then Just (Param "--gpg-sign") else Nothing
] ++ map Just ps
keyring :: FilePath
keyring = privDataDir </> "keyring.gpg"
gpgopts :: [String]
gpgopts = ["--options", "/dev/null", "--no-default-keyring", "--keyring", keyring]
2014-03-30 23:10:32 +00:00
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