summaryrefslogtreecommitdiff
path: root/src/Propellor/Server.hs
diff options
context:
space:
mode:
authorJoey Hess2014-11-22 20:17:46 -0400
committerJoey Hess2014-11-22 20:17:46 -0400
commit239581c75901c3305eaa9298cf41de28a57bd099 (patch)
treeb4553b934197105461a58c126922e7c540bcc820 /src/Propellor/Server.hs
parentd603741d1108913eba207b64d2366ca1c7d8e838 (diff)
reorg
Diffstat (limited to 'src/Propellor/Server.hs')
-rw-r--r--src/Propellor/Server.hs207
1 files changed, 0 insertions, 207 deletions
diff --git a/src/Propellor/Server.hs b/src/Propellor/Server.hs
deleted file mode 100644
index 77f72085..00000000
--- a/src/Propellor/Server.hs
+++ /dev/null
@@ -1,207 +0,0 @@
--- When propellor --spin is running, the local host acts as a server,
--- which connects to the remote host's propellor and responds to its
--- requests.
-
-module Propellor.Server (
- update,
- updateServer,
- gitPushHelper
-) where
-
-import Data.List
-import System.Exit
-import System.PosixCompat
-import System.Posix.IO
-import System.Posix.Directory
-import Control.Concurrent.Async
-import Control.Exception (bracket)
-import qualified Data.ByteString as B
-
-import Propellor
-import Propellor.Protocol
-import Propellor.PrivData.Paths
-import Propellor.Git
-import Propellor.Ssh
-import qualified Propellor.Shim as Shim
-import Utility.FileMode
-import Utility.SafeCommand
-
--- Update the privdata, repo url, and git repo over the ssh
--- connection, talking to the user's local propellor instance which is
--- running the updateServer
-update :: Maybe HostName -> IO ()
-update forhost = do
- whenM hasGitRepo $
- req NeedRepoUrl repoUrlMarker setRepoUrl
-
- makePrivDataDir
- createDirectoryIfMissing True (takeDirectory privfile)
- req NeedPrivData privDataMarker $
- writeFileProtected privfile
-
- whenM hasGitRepo $
- req NeedGitPush gitPushMarker $ \_ -> do
- hin <- dup stdInput
- hout <- dup stdOutput
- hClose stdin
- hClose stdout
- unlessM (boolSystem "git" (pullparams hin hout)) $
- errorMessage "git pull from client failed"
- where
- pullparams hin hout =
- [ Param "pull"
- , Param "--progress"
- , Param "--upload-pack"
- , Param $ "./propellor --gitpush " ++ show hin ++ " " ++ show hout
- , Param "."
- ]
-
- -- When --spin --relay is run, get a privdata file
- -- to be relayed to the target host.
- privfile = maybe privDataLocal privDataRelay forhost
-
--- The connect action should ssh to the remote host and run the provided
--- calback action.
-updateServer :: HostName -> Maybe HostName -> Host -> (((Handle, Handle) -> IO ()) -> IO ()) -> IO ()
-updateServer target relay hst connect = connect go
- where
- hn = fromMaybe target relay
- relaying = relay == Just target
-
- go (toh, fromh) = do
- let loop = go (toh, fromh)
- let restart = updateServer hn relay hst connect
- let done = return ()
- v <- (maybe Nothing readish <$> getMarked fromh statusMarker)
- case v of
- (Just NeedRepoUrl) -> do
- sendRepoUrl toh
- loop
- (Just NeedPrivData) -> do
- sendPrivData hn hst toh relaying
- loop
- (Just NeedGitClone) -> do
- hClose toh
- hClose fromh
- sendGitClone hn
- restart
- (Just NeedPrecompiled) -> do
- hClose toh
- hClose fromh
- sendPrecompiled hn
- restart
- (Just NeedGitPush) -> do
- sendGitUpdate hn fromh toh
- hClose fromh
- hClose toh
- done
- Nothing -> done
-
-sendRepoUrl :: Handle -> IO ()
-sendRepoUrl toh = sendMarked toh repoUrlMarker =<< (fromMaybe "" <$> getRepoUrl)
-
-sendPrivData :: HostName -> Host -> Handle -> Bool -> IO ()
-sendPrivData hn hst toh relaying = do
- privdata <- getdata
- void $ actionMessage ("Sending privdata (" ++ show (length privdata) ++ " bytes) to " ++ hn) $ do
- sendMarked toh privDataMarker privdata
- return True
- where
- getdata
- | relaying = do
- let f = privDataRelay hn
- d <- readFileStrictAnyEncoding f
- nukeFile f
- return d
- | otherwise = show . filterPrivData hst <$> decryptPrivData
-
-sendGitUpdate :: HostName -> Handle -> Handle -> IO ()
-sendGitUpdate hn fromh toh =
- void $ actionMessage ("Sending git update to " ++ hn) $ do
- sendMarked toh gitPushMarker ""
- (Nothing, Nothing, Nothing, h) <- createProcess p
- (==) ExitSuccess <$> waitForProcess h
- where
- p = (proc "git" ["upload-pack", "."])
- { std_in = UseHandle fromh
- , std_out = UseHandle toh
- }
-
--- Initial git clone, used for bootstrapping.
-sendGitClone :: HostName -> IO ()
-sendGitClone hn = void $ actionMessage ("Clone git repository to " ++ hn) $ do
- branch <- getCurrentBranch
- cacheparams <- sshCachingParams hn
- withTmpFile "propellor.git" $ \tmp _ -> allM id
- [ boolSystem "git" [Param "bundle", Param "create", File tmp, Param "HEAD"]
- , boolSystem "scp" $ cacheparams ++ [File tmp, Param ("root@"++hn++":"++remotebundle)]
- , boolSystem "ssh" $ cacheparams ++ [Param ("root@"++hn), Param $ unpackcmd branch]
- ]
- where
- remotebundle = "/usr/local/propellor.git"
- unpackcmd branch = shellWrap $ intercalate " && "
- [ "git clone " ++ remotebundle ++ " " ++ localdir
- , "cd " ++ localdir
- , "git checkout -b " ++ branch
- , "git remote rm origin"
- , "rm -f " ++ remotebundle
- ]
-
--- Send a tarball containing the precompiled propellor, and libraries.
--- This should be reasonably portable, as long as the remote host has the
--- same architecture as the build host.
-sendPrecompiled :: HostName -> IO ()
-sendPrecompiled hn = void $ actionMessage ("Uploading locally compiled propellor as a last resort") $ do
- bracket getWorkingDirectory changeWorkingDirectory $ \_ ->
- withTmpDir "propellor" go
- where
- go tmpdir = do
- cacheparams <- sshCachingParams hn
- let shimdir = takeFileName localdir
- createDirectoryIfMissing True (tmpdir </> shimdir)
- changeWorkingDirectory (tmpdir </> shimdir)
- me <- readSymbolicLink "/proc/self/exe"
- createDirectoryIfMissing True "bin"
- unlessM (boolSystem "cp" [File me, File "bin/propellor"]) $
- errorMessage "failed copying in propellor"
- void $ Shim.setup "bin/propellor" "."
- changeWorkingDirectory tmpdir
- withTmpFile "propellor.tar." $ \tarball _ -> allM id
- [ boolSystem "strip" [File me]
- , boolSystem "tar" [Param "czf", File tarball, File shimdir]
- , boolSystem "scp" $ cacheparams ++ [File tarball, Param ("root@"++hn++":"++remotetarball)]
- , boolSystem "ssh" $ cacheparams ++ [Param ("root@"++hn), Param unpackcmd]
- ]
-
- remotetarball = "/usr/local/propellor.tar"
-
- unpackcmd = shellWrap $ intercalate " && "
- [ "cd " ++ takeDirectory remotetarball
- , "tar xzf " ++ remotetarball
- , "rm -f " ++ remotetarball
- ]
-
--- Shim for git push over the propellor ssh channel.
--- Reads from stdin and sends it to hout;
--- reads from hin and sends it to stdout.
-gitPushHelper :: Fd -> Fd -> IO ()
-gitPushHelper hin hout = void $ fromstdin `concurrently` tostdout
- where
- fromstdin = do
- h <- fdToHandle hout
- connect stdin h
- tostdout = do
- h <- fdToHandle hin
- connect h stdout
- connect fromh toh = do
- hSetBinaryMode fromh True
- hSetBinaryMode toh True
- b <- B.hGetSome fromh 40960
- if B.null b
- then do
- hClose fromh
- hClose toh
- else do
- B.hPut toh b
- hFlush toh
- connect fromh toh