summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--propellor.cabal1
-rw-r--r--src/Propellor/CmdLine.hs90
-rw-r--r--src/Propellor/Protocol.hs47
3 files changed, 74 insertions, 64 deletions
diff --git a/propellor.cabal b/propellor.cabal
index 8e552f2d..0a01ada8 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -116,6 +116,7 @@ Library
Propellor.Gpg
Propellor.SimpleSh
Propellor.PrivData.Paths
+ Propellor.Protocol
Propellor.Property.Docker.Shim
Utility.Applicative
Utility.Data
diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs
index a4e45981..c133b7d8 100644
--- a/src/Propellor/CmdLine.hs
+++ b/src/Propellor/CmdLine.hs
@@ -13,6 +13,7 @@ import System.Posix.IO
import Data.Time.Clock.POSIX
import Propellor
+import Propellor.Protocol
import Propellor.PrivData.Paths
import Propellor.Gpg
import qualified Propellor.Property.Docker as Docker
@@ -180,35 +181,37 @@ updateFirst cmdline next = do
getCurrentGitSha1 :: String -> IO String
getCurrentGitSha1 branchref = readProcess "git" ["show-ref", "--hash", branchref]
+-- spin handles deploying propellor to a remote host, if it's not already
+-- installed there, or updating it if it is. Once the remote propellor is
+-- updated, it's run.
spin :: HostName -> Host -> IO ()
spin hn hst = do
- url <- getUrl
void $ gitCommit [Param "--allow-empty", Param "-a", Param "-m", Param "propellor spin"]
void $ boolSystem "git" [Param "push"]
cacheparams <- toCommand <$> sshCachingParams hn
- go cacheparams url =<< hostprivdata
+ go cacheparams =<< hostprivdata
unlessM (boolSystem "ssh" (map Param (cacheparams ++ ["-t", user, runcmd]))) $
error $ "remote propellor failed (running: " ++ runcmd ++")"
where
hostprivdata = show . filterPrivData hst <$> decryptPrivData
- go cacheparams url privdata = withBothHandles createProcessSuccess (proc "ssh" $ cacheparams ++ [user, bootstrapcmd]) $ \(toh, fromh) -> do
- let finish = do
- senddata toh "privdata" privDataMarker privdata
- hClose toh
-
- -- Display remaining output.
- void $ tryIO $ forever $
- showremote =<< hGetLine fromh
- hClose fromh
- status <- getstatus fromh `catchIO` (const $ errorMessage "protocol error (perhaps the remote propellor failed to run?)")
- case status of
- Ready -> finish
- NeedGitClone -> do
+ go cacheparams privdata = withBothHandles createProcessSuccess (proc "ssh" $ cacheparams ++ [user, bootstrapcmd]) $ \(toh, fromh) -> do
+ status <- getMarked fromh statusMarker
+ case readish =<< status of
+ Just Ready -> do
+ sendprivdata toh "privdata" privDataMarker privdata
hClose toh
+
+ -- Display remaining output.
+ void $ tryIO $ forever $
+ showremote =<< hGetLine fromh
hClose fromh
- sendGitClone hn url
- go cacheparams url privdata
+ Just NeedGitClone -> do
+ hClose toh
+ hClose fromh
+ sendGitClone hn =<< getUrl
+ go cacheparams privdata
+ Nothing -> error $ "protocol error; received: " ++ show status
user = "root@"++hn
@@ -232,17 +235,9 @@ spin hn hst = do
runcmd = mkcmd
[ "cd " ++ localdir ++ " && ./propellor --run " ++ hn ]
- getstatus :: Handle -> IO BootStrapStatus
- getstatus h = do
- l <- hGetLine h
- case readish =<< fromMarked statusMarker l of
- Nothing -> do
- showremote l
- getstatus h
- Just status -> return status
-
showremote s = putStrLn s
- senddata toh desc marker s = void $
+
+ sendprivdata toh desc marker s = void $
actionMessage ("Sending " ++ desc ++ " (" ++ show (length s) ++ " bytes) to " ++ hn) $ do
sendMarked toh marker s
return True
@@ -267,50 +262,17 @@ sendGitClone hn url = void $ actionMessage ("Pushing git repository to " ++ hn)
, "rm -f " ++ remotebundle
, "git remote add origin " ++ url
-- same as --set-upstream-to, except origin branch
- -- has not been pulled yet
+ -- may not have been pulled yet
, "git config branch."++branch++".remote origin"
, "git config branch."++branch++".merge refs/heads/"++branch
]
-data BootStrapStatus = Ready | NeedGitClone
- deriving (Read, Show, Eq)
-
-type Marker = String
-type Marked = String
-
-statusMarker :: Marker
-statusMarker = "STATUS"
-
-privDataMarker :: String
-privDataMarker = "PRIVDATA "
-
-toMarked :: Marker -> String -> String
-toMarked marker = intercalate "\n" . map (marker ++) . lines
-
-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
-
-fromMarked :: Marker -> Marked -> Maybe String
-fromMarked marker s
- | null matches = Nothing
- | otherwise = Just $ intercalate "\n" $
- map (drop len) matches
- where
- len = length marker
- matches = filter (marker `isPrefixOf`) $ lines s
-
boot :: IO ()
boot = do
- sendMarked stdout statusMarker $ show Ready
- reply <- hGetContentsStrict stdin
-
+ sendMarked stdout statusMarker (show Ready)
makePrivDataDir
- maybe noop (writeFileProtected privDataLocal) $
- fromMarked privDataMarker reply
+ maybe noop (writeFileProtected privDataLocal)
+ =<< getMarked stdin privDataMarker
getUrl :: IO String
getUrl = maybe nourl return =<< getM get urls
diff --git a/src/Propellor/Protocol.hs b/src/Propellor/Protocol.hs
new file mode 100644
index 00000000..a1643187
--- /dev/null
+++ b/src/Propellor/Protocol.hs
@@ -0,0 +1,47 @@
+-- | This is a simple line-based protocol used for communication between
+-- a local and remote propellor. It's sent over a ssh channel, and lines of
+-- the protocol can be interspersed with other, non-protocol lines
+-- that should just be passed through to be displayed.
+
+module Propellor.Protocol where
+
+import Data.List
+
+import Propellor
+
+data BootStrapStatus = Ready | NeedGitClone
+ deriving (Read, Show, Eq)
+
+type Marker = String
+type Marked = String
+
+statusMarker :: Marker
+statusMarker = "STATUS"
+
+privDataMarker :: String
+privDataMarker = "PRIVDATA "
+
+toMarked :: Marker -> String -> String
+toMarked marker = intercalate "\n" . map (marker ++) . lines
+
+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
+
+fromMarked :: Marker -> Marked -> Maybe String
+fromMarked marker s
+ | marker `isPrefixOf` s = Just $ drop (length marker) s
+ | otherwise = Nothing
+
+getMarked :: Handle -> Marker -> IO (Maybe String)
+getMarked h marker = go =<< catchMaybeIO (hGetLine h)
+ where
+ go Nothing = return Nothing
+ go (Just l) = case fromMarked marker l of
+ Nothing -> do
+ putStrLn l
+ getMarked h marker
+ Just v -> return (Just v)