propellor spin
This commit is contained in:
parent
78b05d22ff
commit
4a7e60cc53
|
@ -14,24 +14,8 @@ data CmdLine
|
||||||
| Boot HostName
|
| Boot HostName
|
||||||
| Set HostName PrivDataField
|
| Set HostName PrivDataField
|
||||||
| AddKey String
|
| AddKey String
|
||||||
|
| Continue CmdLine
|
||||||
processCmdLine :: IO CmdLine
|
deriving (Read, Show, Eq)
|
||||||
processCmdLine = go =<< getArgs
|
|
||||||
where
|
|
||||||
go ("--help":_) = usage
|
|
||||||
go ("--spin":h:[]) = return $ Spin h
|
|
||||||
go ("--boot":h:[]) = return $ Boot h
|
|
||||||
go ("--add-key":k:[]) = return $ AddKey k
|
|
||||||
go ("--set":h:f:[]) = case readish f of
|
|
||||||
Just pf -> return $ Set h pf
|
|
||||||
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 :: IO a
|
||||||
usage = do
|
usage = do
|
||||||
|
@ -45,14 +29,38 @@ usage = do
|
||||||
]
|
]
|
||||||
exitFailure
|
exitFailure
|
||||||
|
|
||||||
defaultMain :: (HostName -> Maybe [Property]) -> IO ()
|
processCmdLine :: IO CmdLine
|
||||||
defaultMain getprops = go =<< processCmdLine
|
processCmdLine = go =<< getArgs
|
||||||
where
|
where
|
||||||
go (Run host) = withprops host $ pullFirst . ensureProperties
|
go ("--help":_) = usage
|
||||||
go (Spin host) = withprops host $ const $ spin host
|
go ("--spin":h:[]) = return $ Spin h
|
||||||
go (Boot host) = withprops host $ pullFirst . boot
|
go ("--boot":h:[]) = return $ Boot h
|
||||||
go (Set host field) = setPrivData host field
|
go ("--add-key":k:[]) = return $ AddKey k
|
||||||
go (AddKey keyid) = addKey keyid
|
go ("--set":h:f:[]) = case readish f of
|
||||||
|
Just pf -> return $ Set h pf
|
||||||
|
Nothing -> error $ "Unknown privdata field " ++ f
|
||||||
|
go ("--continue":s:[]) =case readish s of
|
||||||
|
Just cmdline -> return $ Continue cmdline
|
||||||
|
Nothing -> error "--continue serialization failure"
|
||||||
|
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
|
||||||
|
|
||||||
|
defaultMain :: (HostName -> Maybe [Property]) -> IO ()
|
||||||
|
defaultMain getprops = go True =<< processCmdLine
|
||||||
|
where
|
||||||
|
go _ (Continue cmdline) = go False cmdline
|
||||||
|
go _ (Set host field) = setPrivData host field
|
||||||
|
go _ (AddKey keyid) = addKey keyid
|
||||||
|
go _ (Spin host) = withprops host $ const $ spin host
|
||||||
|
go True cmdline = pullFirst cmdline $ go False cmdline
|
||||||
|
go _ (Run host) = withprops host $ ensureProperties
|
||||||
|
go _ (Boot host) = withprops host $ boot
|
||||||
|
|
||||||
withprops host a = maybe (unknownhost host) a (getprops host)
|
withprops host a = maybe (unknownhost host) a (getprops host)
|
||||||
|
|
||||||
unknownhost :: HostName -> IO a
|
unknownhost :: HostName -> IO a
|
||||||
|
@ -61,8 +69,8 @@ unknownhost h = error $ unwords
|
||||||
, "(perhaps you should specify the real hostname on the command line?)"
|
, "(perhaps you should specify the real hostname on the command line?)"
|
||||||
]
|
]
|
||||||
|
|
||||||
pullFirst :: IO () -> IO ()
|
pullFirst :: CmdLine -> IO () -> IO ()
|
||||||
pullFirst next = do
|
pullFirst cmdline next = do
|
||||||
branchref <- takeWhile (/= '\n')
|
branchref <- takeWhile (/= '\n')
|
||||||
<$> readProcess "git" ["symbolic-ref", "HEAD"]
|
<$> readProcess "git" ["symbolic-ref", "HEAD"]
|
||||||
let originbranch = "origin" </> takeFileName branchref
|
let originbranch = "origin" </> takeFileName branchref
|
||||||
|
@ -84,13 +92,22 @@ pullFirst next = do
|
||||||
(Just [("GNUPGHOME", privDataDir)])
|
(Just [("GNUPGHOME", privDataDir)])
|
||||||
nukeFile $ privDataDir </> "trustring.gpg"
|
nukeFile $ privDataDir </> "trustring.gpg"
|
||||||
nukeFile $ privDataDir </> "gpg.conf"
|
nukeFile $ privDataDir </> "gpg.conf"
|
||||||
if s /= "U\n" && s/= "G\n"
|
if s == "U\n" || s == "G\n"
|
||||||
then error $ "git branch " ++ originbranch ++ " is not signed with a trusted gpg key; refusing to deploy it!"
|
then putStrLn $ "git branch " ++ originbranch ++ " gpg signature verified; merging"
|
||||||
else putStrLn "git branch " ++ originbranch ++ " gpg signature verified; merging"
|
else error $ "git branch " ++ originbranch ++ " is not signed with a trusted gpg key; refusing to deploy it!"
|
||||||
|
|
||||||
|
oldsha <- getCurrentGitSha1
|
||||||
void $ boolSystem "git" [Param "merge", Param originbranch]
|
void $ boolSystem "git" [Param "merge", Param originbranch]
|
||||||
|
newsha <- getCurrentGitSha1
|
||||||
|
|
||||||
next
|
if oldsha == newsha
|
||||||
|
then next
|
||||||
|
else do
|
||||||
|
void $ boolSystem "make" [Param "build"]
|
||||||
|
void $ boolSystem "./propellor" [Param "--continue", Param (show cmdline)]
|
||||||
|
|
||||||
|
getCurrentGitSha1 :: IO String
|
||||||
|
getCurrentGitSha1 = readProcess "git" ["show-ref", "--hash", "HEAD"]
|
||||||
|
|
||||||
spin :: HostName -> IO ()
|
spin :: HostName -> IO ()
|
||||||
spin host = do
|
spin host = do
|
||||||
|
|
Loading…
Reference in New Issue