simple socket server, will hopefully work with docker

This commit is contained in:
Joey Hess 2014-04-01 02:37:48 -04:00
parent 90f86b8b2b
commit 25c4d18503
4 changed files with 82 additions and 4 deletions

View File

@ -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

View File

@ -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

73
Propellor/SimpleSh.hs Normal file
View File

@ -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

View File

@ -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