summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Makefile2
-rw-r--r--Propellor/CmdLine.hs6
-rw-r--r--Propellor/SimpleSh.hs73
-rw-r--r--propellor.cabal5
4 files changed, 82 insertions, 4 deletions
diff --git a/Makefile b/Makefile
index 2ba41b2b..0cf58fa5 100644
--- a/Makefile
+++ b/Makefile
@@ -8,7 +8,7 @@ build: deps dist/setup-config
ln -sf dist/build/propellor/propellor
deps:
- @if [ $$(whoami) = root ]; then apt-get -y install gnupg ghc cabal-install libghc-missingh-dev libghc-ansi-terminal-dev libghc-ifelse-dev libghc-unix-compat-dev libghc-hslogger-dev; fi || true
+ @if [ $$(whoami) = root ]; then apt-get -y install gnupg ghc cabal-install libghc-missingh-dev libghc-ansi-terminal-dev libghc-ifelse-dev libghc-unix-compat-dev libghc-hslogger-dev libghc-network-dev; fi || true
dist/setup-config: propellor.cabal
cabal configure
diff --git a/Propellor/CmdLine.hs b/Propellor/CmdLine.hs
index e43cf0aa..05df86bf 100644
--- a/Propellor/CmdLine.hs
+++ b/Propellor/CmdLine.hs
@@ -5,6 +5,7 @@ import Data.List
import System.Exit
import Propellor
+import Propellor.SimpleSh
import Utility.FileMode
import Utility.SafeCommand
@@ -15,6 +16,7 @@ data CmdLine
| Set HostName PrivDataField
| AddKey String
| Continue CmdLine
+ | SimpleSh FilePath
deriving (Read, Show, Eq)
usage :: IO a
@@ -39,9 +41,10 @@ processCmdLine = go =<< getArgs
go ("--set":h:f:[]) = case readish f of
Just pf -> return $ Set h pf
Nothing -> errorMessage $ "Unknown privdata field " ++ f
- go ("--continue":s:[]) =case readish s of
+ go ("--continue":s:[]) = case readish s of
Just cmdline -> return $ Continue cmdline
Nothing -> errorMessage "--continue serialization failure"
+ go ("--simplesh":f:[]) = return $ SimpleSh f
go (h:[]) = return $ Run h
go [] = do
s <- takeWhile (/= '\n') <$> readProcess "hostname" ["-f"]
@@ -56,6 +59,7 @@ defaultMain getprops = go True =<< processCmdLine
go _ (Continue cmdline) = go False cmdline
go _ (Set host field) = setPrivData host field
go _ (AddKey keyid) = addKey keyid
+ go _ (SimpleSh f) = simpleSh f
go True cmdline@(Spin _) = buildFirst cmdline $ go False cmdline
go True cmdline = updateFirst cmdline $ go False cmdline
go False (Spin host) = withprops host $ const $ spin host
diff --git a/Propellor/SimpleSh.hs b/Propellor/SimpleSh.hs
new file mode 100644
index 00000000..971fe502
--- /dev/null
+++ b/Propellor/SimpleSh.hs
@@ -0,0 +1,73 @@
+-- | Simple server, using a named pipe. Client connects, sends a command,
+-- and gets back all the output from the command, in a stream.
+--
+-- This is useful for eg, docker.
+
+module Propellor.SimpleSh where
+
+import Network.Socket
+import Control.Concurrent.Chan
+import Control.Concurrent.Async
+import System.Process (std_in, std_out, std_err)
+import System.Exit
+
+import Propellor
+
+data Cmd = Cmd String [String]
+ deriving (Read, Show)
+
+data Resp = StdoutLine String | StderrLine String | Done ExitCode
+ deriving (Read, Show)
+
+simpleSh :: FilePath -> IO ()
+simpleSh namedpipe = do
+ nukeFile namedpipe
+ s <- socket AF_UNIX Stream defaultProtocol
+ bind s (SockAddrUnix namedpipe)
+ listen s 2
+ forever $ do
+ (client, _addr) <- accept s
+ h <- socketToHandle client ReadWriteMode
+ hSetBuffering h LineBuffering
+ maybe noop (run h) . readish =<< hGetLine h
+ where
+ run h (Cmd cmd params) = do
+ let p = (proc cmd params)
+ { std_in = Inherit
+ , std_out = CreatePipe
+ , std_err = CreatePipe
+ }
+ (Nothing, Just outh, Just errh, pid) <- createProcess p
+ chan <- newChan
+
+ let runwriter = do
+ v <- readChan chan
+ hPutStrLn h (show v)
+ case v of
+ Done _ -> noop
+ _ -> runwriter
+ writer <- async runwriter
+
+ let mkreader t from = maybe noop (const $ mkreader t from)
+ =<< catchMaybeIO (writeChan chan . t =<< hGetLine from)
+ void $ concurrently
+ (mkreader StdoutLine outh)
+ (mkreader StderrLine outh)
+
+ writeChan chan . Done =<< waitForProcess pid
+
+ wait writer
+
+ hClose outh
+ hClose errh
+ hClose h
+
+simpleShClient :: FilePath -> String -> [String] -> ([Resp] -> IO a) -> IO a
+simpleShClient namedpipe cmd params handler = do
+ s <- socket AF_UNIX Stream defaultProtocol
+ connect s (SockAddrUnix namedpipe)
+ h <- socketToHandle s ReadWriteMode
+ hSetBuffering h LineBuffering
+ hPutStrLn h $ show $ Cmd cmd params
+ resps <- catMaybes . map readish . lines <$> hGetContents h
+ hClose h `after` handler resps
diff --git a/propellor.cabal b/propellor.cabal
index 4af11b27..d6070fa1 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -28,7 +28,7 @@ Executable propellor
GHC-Options: -Wall
Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,
IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
- containers
+ containers, network, async
if (! os(windows))
Build-Depends: unix
@@ -37,7 +37,7 @@ Library
GHC-Options: -Wall
Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,
IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
- containers, dataenc
+ containers, network, async
if (! os(windows))
Build-Depends: unix
@@ -63,6 +63,7 @@ Library
Propellor.Message
Propellor.PrivData
Propellor.Engine
+ Propellor.SimpleSh
Propellor.Types
Other-Modules:
Utility.Applicative