simple socket server, will hopefully work with docker

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

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
@@ -42,6 +44,7 @@ processCmdLine = go =<< getArgs
 	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

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

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