propellor/Propellor/CmdLine.hs

384 lines
12 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
2014-04-01 15:59:48 +00:00
import System.Environment (getArgs)
2014-03-30 23:10:32 +00:00
import Data.List
import System.Exit
2014-04-01 15:59:48 +00:00
import System.Log.Logger
import System.Log.Formatter
import System.Log.Handler (setFormatter, LogHandler)
import System.Log.Handler.Simple
2014-04-03 17:49:26 +00:00
import System.PosixCompat
2014-04-04 20:20:20 +00:00
import Control.Exception (bracket)
import System.Posix.IO
import Data.Time.Clock.POSIX
2014-03-30 23:10:32 +00:00
2014-03-31 03:55:59 +00:00
import Propellor
import qualified Propellor.Property.Docker as Docker
import qualified Propellor.Property.Docker.Shim as DockerShim
2014-03-30 23:10:32 +00:00
import Utility.FileMode
2014-03-31 03:55:59 +00:00
import Utility.SafeCommand
import Utility.UserInfo
2014-03-30 23:10:32 +00:00
2014-03-31 20:37:19 +00:00
usage :: IO a
usage = do
putStrLn $ unlines
[ "Usage:"
, " propellor"
, " propellor hostname"
, " propellor --spin hostname"
, " propellor --set hostname field"
, " propellor --add-key keyid"
]
exitFailure
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-31 22:31:08 +00:00
Nothing -> errorMessage $ "Unknown privdata field " ++ f
go ("--continue":s:[]) = case readish s of
2014-03-31 20:37:19 +00:00
Just cmdline -> return $ Continue cmdline
2014-03-31 22:31:08 +00:00
Nothing -> errorMessage "--continue serialization failure"
go ("--chain":h:[]) = return $ Chain h
go ("--docker":h:[]) = return $ Docker h
2014-04-01 15:59:48 +00:00
go (h:[])
| "--" `isPrefixOf` h = usage
| otherwise = return $ Run h
2014-03-30 23:10:32 +00:00
go [] = do
s <- takeWhile (/= '\n') <$> readProcess "hostname" ["-f"]
if null s
2014-03-31 22:31:08 +00:00
then errorMessage "Cannot determine hostname! Pass it on the command line."
2014-03-30 23:10:32 +00:00
else return $ Run s
go _ = usage
2014-04-11 01:09:20 +00:00
defaultMain :: [Host] -> IO ()
defaultMain hostlist = do
DockerShim.cleanEnv
2014-04-01 15:59:48 +00:00
checkDebugMode
cmdline <- processCmdLine
debug ["command line: ", show cmdline]
go True cmdline
2014-03-30 23:10:32 +00:00
where
2014-03-31 20:37:19 +00:00
go _ (Continue cmdline) = go False cmdline
2014-04-11 01:09:20 +00:00
go _ (Set hn field) = setPrivData hn field
2014-03-31 20:37:19 +00:00
go _ (AddKey keyid) = addKey keyid
2014-04-11 01:09:20 +00:00
go _ (Chain hn) = withprops hn $ \attr ps -> do
r <- runPropellor attr $ ensureProperties ps
putStrLn $ "\n" ++ show r
2014-04-11 01:09:20 +00:00
go _ (Docker hn) = Docker.chain hn
2014-03-31 22:53:27 +00:00
go True cmdline@(Spin _) = buildFirst cmdline $ go False cmdline
2014-03-31 21:57:12 +00:00
go True cmdline = updateFirst cmdline $ go False cmdline
2014-04-11 01:09:20 +00:00
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)
2014-04-03 17:58:21 +00:00
)
2014-04-11 01:09:20 +00:00
go False (Boot hn) = onlyProcess $ withprops hn boot
2014-03-31 20:37:19 +00:00
2014-04-11 01:09:20 +00:00
withprops :: HostName -> (Attr -> [Property] -> IO ()) -> IO ()
withprops hn a = maybe
(unknownhost hn)
(\h -> a (hostAttr h) (hostProperties h))
(findHost hostlist hn)
2014-03-30 23:10:32 +00:00
2014-04-04 20:20:20 +00:00
onlyProcess :: IO a -> IO a
onlyProcess a = bracket lock unlock (const a)
where
lock = do
2014-04-04 22:34:03 +00:00
l <- createFile lockfile stdFileMode
2014-04-04 20:20:20 +00:00
setLock l (WriteLock, AbsoluteSeek, 0, 0)
2014-04-04 22:34:03 +00:00
`catchIO` const alreadyrunning
2014-04-04 20:20:20 +00:00
return l
unlock = closeFd
alreadyrunning = error "Propellor is already running on this host!"
lockfile = localdir </> ".lock"
2014-03-31 03:02:10 +00:00
unknownhost :: HostName -> IO a
unknownhost h = errorMessage $ unlines
2014-04-08 22:42:54 +00:00
[ "Propellor does not know about host: " ++ h
, "(Perhaps you should specify the real hostname on the command line?)"
, "(Or, edit propellor's config.hs to configure this host)"
2014-03-31 03:02:10 +00:00
]
2014-03-31 22:53:27 +00:00
buildFirst :: CmdLine -> IO () -> IO ()
buildFirst cmdline next = do
oldtime <- getmtime
2014-03-31 23:31:35 +00:00
ifM (actionMessage "Propellor build" $ boolSystem "make" [Param "build"])
2014-03-31 22:53:27 +00:00
( do
newtime <- getmtime
if newtime == oldtime
then next
else void $ boolSystem "./propellor" [Param "--continue", Param (show cmdline)]
, errorMessage "Propellor build failed!"
)
where
getmtime = catchMaybeIO $ getModificationTime "propellor"
getCurrentBranch :: IO String
getCurrentBranch = takeWhile (/= '\n')
<$> readProcess "git" ["symbolic-ref", "--short", "HEAD"]
2014-03-31 21:57:12 +00:00
updateFirst :: CmdLine -> IO () -> IO ()
updateFirst cmdline next = do
branchref <- getCurrentBranch
let originbranch = "origin" </> branchref
2014-03-31 22:39:39 +00:00
2014-03-31 23:31:35 +00:00
void $ actionMessage "Git fetch" $ boolSystem "git" [Param "fetch"]
2014-03-31 20:20:38 +00:00
2014-04-10 20:12:06 +00:00
whenM (doesFileExist keyring) $ do
2014-04-03 17:49:26 +00:00
{- To verify origin branch commit's signature, have to
2014-03-31 20:20:38 +00:00
- convince gpg to use our keyring. While running git log.
- Which has no way to pass options to gpg.
- Argh! -}
let gpgconf = privDataDir </> "gpg.conf"
writeFile gpgconf $ unlines
[ " keyring " ++ keyring
, "no-auto-check-trustdb"
]
-- gpg is picky about perms
modifyFileMode privDataDir (removeModes otherGroupModes)
s <- readProcessEnv "git" ["log", "-n", "1", "--format=%G?", originbranch]
(Just [("GNUPGHOME", privDataDir)])
2014-04-03 16:20:42 +00:00
nukeFile $ privDataDir </> "trustdb.gpg"
nukeFile $ privDataDir </> "pubring.gpg"
2014-03-31 20:20:38 +00:00
nukeFile $ privDataDir </> "gpg.conf"
2014-03-31 20:37:19 +00:00
if s == "U\n" || s == "G\n"
2014-03-31 20:42:25 +00:00
then do
putStrLn $ "git branch " ++ originbranch ++ " gpg signature verified; merging"
hFlush stdout
2014-03-31 22:31:08 +00:00
else errorMessage $ "git branch " ++ originbranch ++ " is not signed with a trusted gpg key; refusing to deploy it!"
2014-03-31 20:20:38 +00:00
2014-03-31 20:40:03 +00:00
oldsha <- getCurrentGitSha1 branchref
2014-03-31 20:20:38 +00:00
void $ boolSystem "git" [Param "merge", Param originbranch]
2014-03-31 20:40:03 +00:00
newsha <- getCurrentGitSha1 branchref
2014-03-31 20:37:19 +00:00
if oldsha == newsha
2014-03-31 20:50:30 +00:00
then next
2014-03-31 23:31:35 +00:00
else ifM (actionMessage "Propellor build" $ boolSystem "make" [Param "build"])
2014-03-31 22:31:08 +00:00
( void $ boolSystem "./propellor" [Param "--continue", Param (show cmdline)]
, errorMessage "Propellor build failed!"
)
2014-03-31 20:20:38 +00:00
2014-03-31 20:40:03 +00:00
getCurrentGitSha1 :: String -> IO String
getCurrentGitSha1 branchref = readProcess "git" ["show-ref", "--hash", branchref]
2014-03-31 20:20:38 +00:00
2014-03-30 23:10:32 +00:00
spin :: HostName -> IO ()
2014-04-11 01:09:20 +00:00
spin hn = do
2014-03-30 23:10:32 +00:00
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-04-11 01:09:20 +00:00
cacheparams <- toCommand <$> sshCachingParams hn
go cacheparams url =<< gpgDecrypt (privDataFile hn)
2014-03-31 19:40:16 +00:00
where
go cacheparams url privdata = withBothHandles createProcessSuccess (proc "ssh" $ cacheparams ++ [user, bootstrapcmd]) $ \(toh, fromh) -> do
2014-03-31 19:40:16 +00:00
let finish = do
2014-04-11 01:09:20 +00:00
senddata toh (privDataFile hn) privDataMarker privdata
2014-03-31 19:40:16 +00:00
hClose toh
-- Display remaining output.
void $ tryIO $ forever $
showremote =<< hGetLine fromh
hClose fromh
2014-03-31 22:39:39 +00:00
status <- getstatus fromh `catchIO` (const $ errorMessage "protocol error (perhaps the remote propellor failed to run?)")
2014-03-31 16:06:04 +00:00
case status of
Ready -> finish
2014-03-31 19:40:16 +00:00
NeedGitClone -> do
hClose toh
hClose fromh
2014-04-11 01:09:20 +00:00
sendGitClone hn url
go cacheparams url privdata
2014-03-31 19:40:16 +00:00
2014-04-11 01:09:20 +00:00
user = "root@"++hn
2014-03-31 19:40:16 +00:00
2014-04-03 17:49:26 +00:00
bootstrapcmd = shellWrap $ intercalate " ; "
2014-03-31 20:45:32 +00:00
[ "if [ ! -d " ++ localdir ++ " ]"
, "then " ++ intercalate " && "
2014-04-10 20:08:38 +00:00
[ "apt-get --no-install-recommends --no-upgrade -y install git make"
2014-03-31 20:45:32 +00:00
, "echo " ++ toMarked statusMarker (show NeedGitClone)
]
, "else " ++ intercalate " && "
[ "cd " ++ localdir
2014-04-10 04:40:38 +00:00
, "if ! test -x ./propellor; then make deps build; fi"
2014-04-11 01:09:20 +00:00
, "./propellor --boot " ++ hn
2014-03-30 23:10:32 +00:00
]
2014-03-31 20:52:58 +00:00
, "fi"
2014-03-30 23:10:32 +00:00
]
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 22:31:08 +00:00
senddata toh f marker s = void $
2014-04-11 01:09:20 +00:00
actionMessage ("Sending " ++ f ++ " (" ++ show (length s) ++ " bytes) to " ++ hn) $ do
2014-03-31 22:44:10 +00:00
sendMarked toh marker s
2014-03-31 22:31:08 +00:00
return True
2014-03-30 23:10:32 +00:00
2014-03-31 19:40:16 +00:00
sendGitClone :: HostName -> String -> IO ()
2014-04-11 01:09:20 +00:00
sendGitClone hn url = void $ actionMessage ("Pushing git repository to " ++ hn) $ do
2014-04-03 17:49:26 +00:00
branch <- getCurrentBranch
2014-04-11 01:09:20 +00:00
cacheparams <- sshCachingParams hn
2014-04-03 16:26:27 +00:00
withTmpFile "propellor.git" $ \tmp _ -> allM id
2014-03-31 23:01:56 +00:00
[ boolSystem "git" [Param "bundle", Param "create", File tmp, Param "HEAD"]
2014-04-11 01:09:20 +00:00
, boolSystem "scp" $ cacheparams ++ [File tmp, Param ("root@"++hn++":"++remotebundle)]
, boolSystem "ssh" $ cacheparams ++ [Param ("root@"++hn), Param $ unpackcmd branch]
2014-03-31 22:31:08 +00:00
]
2014-03-31 19:40:16 +00:00
where
remotebundle = "/usr/local/propellor.git"
2014-04-03 17:49:26 +00:00
unpackcmd branch = shellWrap $ intercalate " && "
2014-03-31 19:40:16 +00:00
[ "git clone " ++ remotebundle ++ " " ++ localdir
, "cd " ++ localdir
2014-04-03 17:49:26 +00:00
, "git checkout -b " ++ branch
2014-03-31 19:40:16 +00:00
, "git remote rm origin"
, "rm -f " ++ remotebundle
2014-04-03 17:49:26 +00:00
, "git remote add origin " ++ url
-- same as --set-upstream-to, except origin branch
-- has not been pulled yet
, "git config branch."++branch++".remote origin"
, "git config branch."++branch++".merge refs/heads/"++branch
2014-03-31 19:40:16 +00:00
]
data BootStrapStatus = Ready | NeedGitClone
2014-03-31 16:06:04 +00:00
deriving (Read, Show, Eq)
type Marker = String
type Marked = String
statusMarker :: Marker
statusMarker = "STATUS"
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 22:44:10 +00:00
sendMarked :: Handle -> Marker -> String -> IO ()
sendMarked h marker s = do
-- Prefix string with newline because sometimes a
-- incomplete line is output.
hPutStrLn h ("\n" ++ toMarked marker s)
hFlush h
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-04-11 01:09:20 +00:00
boot :: Attr -> [Property] -> IO ()
boot attr ps = do
2014-03-31 22:44:10 +00:00
sendMarked stdout statusMarker $ show Ready
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-04-11 01:09:20 +00:00
mainProperties attr ps
2014-03-30 23:10:32 +00:00
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
getUrl :: IO String
2014-03-31 22:31:08 +00:00
getUrl = maybe nourl return =<< getM get urls
2014-03-30 23:10:32 +00:00
where
urls = ["remote.deploy.url", "remote.origin.url"]
2014-03-31 22:31:08 +00:00
nourl = errorMessage $ "Cannot find deploy url in " ++ show urls
2014-03-30 23:10:32 +00:00
get u = do
v <- catchMaybeIO $
takeWhile (/= '\n')
<$> readProcess "git" ["config", u]
return $ case v of
Just url | not (null url) -> Just url
_ -> Nothing
2014-04-01 15:59:48 +00:00
checkDebugMode :: IO ()
checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG"
where
go (Just s)
| s == "1" = do
f <- setFormatter
<$> streamHandler stderr DEBUG
<*> pure (simpleLogFormatter "[$time] $msg")
updateGlobalLogger rootLoggerName $
setLevel DEBUG . setHandlers [f]
go _ = noop
-- Parameters can be passed to both ssh and scp, to enable a ssh connection
-- caching socket.
--
-- If the socket already exists, check if its mtime is older than 10
-- minutes, and if so stop that ssh process, in order to not try to
-- use an old stale connection. (atime would be nicer, but there's
-- a good chance a laptop uses noatime)
sshCachingParams :: HostName -> IO [CommandParam]
2014-04-11 01:09:20 +00:00
sshCachingParams hn = do
home <- myHomeDir
let cachedir = home </> ".ssh" </> "propellor"
createDirectoryIfMissing False cachedir
2014-04-11 01:09:20 +00:00
let socketfile = cachedir </> hn ++ ".sock"
let ps =
[ Param "-o", Param ("ControlPath=" ++ socketfile)
, Params "-o ControlMaster=auto -o ControlPersist=yes"
]
maybe noop (expireold ps socketfile)
=<< catchMaybeIO (getFileStatus socketfile)
return ps
where
expireold ps f s = do
now <- truncate <$> getPOSIXTime :: IO Integer
if modificationTime s > fromIntegral now - tenminutes
then touchFile f
else do
void $ boolSystem "ssh" $
[ Params "-O stop" ] ++ ps ++
[ Param "localhost" ]
nukeFile f
tenminutes = 600