summaryrefslogtreecommitdiff
path: root/src/Propellor/CmdLine.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Propellor/CmdLine.hs')
-rw-r--r--src/Propellor/CmdLine.hs85
1 files changed, 27 insertions, 58 deletions
diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs
index ec2ca7ed..f5cfc783 100644
--- a/src/Propellor/CmdLine.hs
+++ b/src/Propellor/CmdLine.hs
@@ -7,13 +7,12 @@ import System.Environment (getArgs)
import Data.List
import System.Exit
import System.PosixCompat
+import qualified Network.BSD
import Propellor
-import Propellor.Protocol
import Propellor.Gpg
import Propellor.Git
-import Propellor.Ssh
-import Propellor.Server
+import Propellor.Spin
import qualified Propellor.Property.Docker as Docker
import qualified Propellor.Property.Chroot as Chroot
import qualified Propellor.Shim as Shim
@@ -24,7 +23,7 @@ usage h = hPutStrLn h $ unlines
[ "Usage:"
, " propellor"
, " propellor hostname"
- , " propellor --spin hostname"
+ , " propellor --spin targethost [--via relayhost]"
, " propellor --add-key keyid"
, " propellor --set field context"
, " propellor --dump field context"
@@ -40,8 +39,8 @@ usageError ps = do
processCmdLine :: IO CmdLine
processCmdLine = go =<< getArgs
where
- go ("--run":h:[]) = return $ Run h
- go ("--spin":h:[]) = return $ Spin h
+ go ("--spin":h:[]) = Spin <$> hostname h <*> pure Nothing
+ go ("--spin":h:"--via":r:[]) = Spin <$> hostname h <*> pure (Just r)
go ("--add-key":k:[]) = return $ AddKey k
go ("--set":f:c:[]) = withprivfield f c Set
go ("--dump":f:c:[]) = withprivfield f c Dump
@@ -50,15 +49,15 @@ processCmdLine = go =<< getArgs
go ("--help":_) = do
usage stdout
exitFailure
- go ("--update":h:[]) = return $ Update h
- go ("--boot":h:[]) = return $ Update h -- for back-compat
- go ("--continue":s:[]) = case readish s of
- Just cmdline -> return $ Continue cmdline
- Nothing -> errorMessage $ "--continue serialization failure (" ++ s ++ ")"
+ go ("--update":_:[]) = return $ Update Nothing
+ go ("--boot":_:[]) = return $ Update Nothing -- for back-compat
+ go ("--serialized":s:[]) = serialized Serialized s
+ go ("--continue":s:[]) = serialized Continue s
go ("--gitpush":fin:fout:_) = return $ GitPush (Prelude.read fin) (Prelude.read fout)
+ go ("--run":h:[]) = go [h]
go (h:[])
| "--" `isPrefixOf` h = usageError [h]
- | otherwise = return $ Run h
+ | otherwise = Run <$> hostname h
go [] = do
s <- takeWhile (/= '\n') <$> readProcess "hostname" ["-f"]
if null s
@@ -70,6 +69,10 @@ processCmdLine = go =<< getArgs
Just pf -> return $ f pf (Context c)
Nothing -> errorMessage $ "Unknown privdata field " ++ s
+ serialized mk s = case readish s of
+ Just cmdline -> return $ mk cmdline
+ Nothing -> errorMessage $ "serialization failure (" ++ s ++ ")"
+
-- | Runs propellor on hosts, as controlled by command-line options.
defaultMain :: [Host] -> IO ()
defaultMain hostlist = do
@@ -79,6 +82,7 @@ defaultMain hostlist = do
debug ["command line: ", show cmdline]
go True cmdline
where
+ go _ (Serialized cmdline) = go True cmdline
go _ (Continue cmdline) = go False cmdline
go _ (Set field context) = setPrivData field context
go _ (Dump field context) = dumpPrivData field context
@@ -89,15 +93,16 @@ defaultMain hostlist = do
go _ (DockerChain hn cid) = Docker.chain hostlist hn cid
go _ (DockerInit hn) = Docker.init hn
go _ (GitPush fin fout) = gitPushHelper fin fout
- go _ (Update _) = forceConsole >> fetchFirst (onlyprocess update)
- go True cmdline@(Spin _) = buildFirst cmdline $ go False cmdline
+ go _ (Update Nothing) = forceConsole >> fetchFirst (onlyprocess (update Nothing))
+ go _ (Update (Just h)) = forceConsole >> fetchFirst (update (Just h))
+ go True cmdline@(Spin _ _) = buildFirst cmdline $ go False cmdline
go True cmdline = updateFirst cmdline $ go False cmdline
- go False (Spin hn) = withhost hn $ spin hn
+ go False (Spin hn r) = withhost hn $ spin hn r
go False cmdline@(SimpleRun hn) = buildFirst cmdline $
go False (Run hn)
go False (Run hn) = ifM ((==) 0 <$> getRealUserID)
( onlyprocess $ withhost hn mainProperties
- , go True (Spin hn)
+ , go True (Spin hn Nothing)
)
withhost :: HostName -> (Host -> IO ()) -> IO ()
@@ -148,45 +153,9 @@ updateFirst' cmdline next = ifM fetchOrigin
, next
)
-spin :: HostName -> Host -> IO ()
-spin hn hst = do
- void $ actionMessage "Git commit" $
- gitCommit [Param "--allow-empty", Param "-a", Param "-m", Param "propellor spin"]
- -- Push to central origin repo first, if possible.
- -- The remote propellor will pull from there, which avoids
- -- us needing to send stuff directly to the remote host.
- whenM hasOrigin $
- void $ actionMessage "Push to central git repository" $
- boolSystem "git" [Param "push"]
-
- cacheparams <- toCommand <$> sshCachingParams hn
-
- -- Install, or update the remote propellor.
- updateServer hn hst $ withBothHandles createProcessSuccess
- (proc "ssh" $ cacheparams ++ [user, updatecmd])
-
- -- And now we can run it.
- unlessM (boolSystem "ssh" (map Param $ cacheparams ++ ["-t", user, runcmd])) $
- error $ "remote propellor failed"
- where
- user = "root@"++hn
-
- mkcmd = shellWrap . intercalate " ; "
-
- updatecmd = mkcmd
- [ "if [ ! -d " ++ localdir ++ " ]"
- , "then (" ++ intercalate " && "
- [ "apt-get update"
- , "apt-get --no-install-recommends --no-upgrade -y install git make"
- , "echo " ++ toMarked statusMarker (show NeedGitClone)
- ] ++ ") || echo " ++ toMarked statusMarker (show NeedPrecompiled)
- , "else " ++ intercalate " && "
- [ "cd " ++ localdir
- , "if ! test -x ./propellor; then make deps build; fi"
- , "./propellor --boot " ++ hn
- ]
- , "fi"
- ]
-
- runcmd = mkcmd
- [ "cd " ++ localdir ++ " && ./propellor --continue " ++ shellEscape (show (SimpleRun hn)) ]
+hostname :: String -> IO HostName
+hostname s
+ | "." `isInfixOf` s = pure s
+ | otherwise = do
+ h <- Network.BSD.getHostByName s
+ return (Network.BSD.hostName h)