summaryrefslogtreecommitdiff
path: root/src/Propellor
diff options
context:
space:
mode:
authorJoey Hess2014-11-19 01:04:11 -0400
committerJoey Hess2014-11-19 01:04:11 -0400
commitc3962dcf7db5f4692a45fe0ff9802f819a97e2d7 (patch)
tree89f80b8f9f5166ced16b8a526e1eed0229e72b86 /src/Propellor
parentf0675727c2833a8ebe8b954384ca484559b3b378 (diff)
propellor spin
Diffstat (limited to 'src/Propellor')
-rw-r--r--src/Propellor/SimpleSh.hs101
1 files changed, 0 insertions, 101 deletions
diff --git a/src/Propellor/SimpleSh.hs b/src/Propellor/SimpleSh.hs
deleted file mode 100644
index cc5c62cd..00000000
--- a/src/Propellor/SimpleSh.hs
+++ /dev/null
@@ -1,101 +0,0 @@
--- | 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
-import Control.Concurrent.Async
-import System.Process (std_in, std_out, std_err)
-
-import Propellor
-import Utility.FileMode
-import Utility.ThreadScheduler
-
-data Cmd = Cmd String [String]
- deriving (Read, Show)
-
-data Resp = StdoutLine String | StderrLine String | Done
- deriving (Read, Show)
-
-simpleSh :: FilePath -> IO ()
-simpleSh namedpipe = do
- nukeFile namedpipe
- let dir = takeDirectory namedpipe
- createDirectoryIfMissing True dir
- modifyFileMode dir (removeModes otherGroupModes)
- s <- socket AF_UNIX Stream defaultProtocol
- bindSocket s (SockAddrUnix namedpipe)
- listen s 2
- forever $ do
- (client, _addr) <- accept s
- forkIO $ do
- h <- socketToHandle client ReadWriteMode
- maybe noop (run h) . readish =<< hGetLine h
- where
- run h (Cmd cmd params) = do
- chan <- newChan
- let runwriter = do
- v <- readChan chan
- hPutStrLn h (show v)
- hFlush h
- case v of
- Done -> noop
- _ -> runwriter
- writer <- async runwriter
-
- flip catchIO (\_e -> writeChan chan Done) $ do
- let p = (proc cmd params)
- { std_in = Inherit
- , std_out = CreatePipe
- , std_err = CreatePipe
- }
- (Nothing, Just outh, Just errh, pid) <- createProcess p
-
- let mkreader t from = maybe noop (const $ mkreader t from)
- =<< catchMaybeIO (writeChan chan . t =<< hGetLine from)
- void $ concurrently
- (mkreader StdoutLine outh)
- (mkreader StderrLine errh)
-
- void $ tryIO $ waitForProcess pid
-
- writeChan chan Done
-
- hClose outh
- hClose errh
-
- wait writer
- 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
- hPutStrLn h $ show $ Cmd cmd params
- hFlush h
- resps <- catMaybes . map readish . lines <$> hGetContents h
- v <- hClose h `after` handler resps
- return v
-
-simpleShClientRetry :: Int -> FilePath -> String -> [String] -> ([Resp] -> IO a) -> IO a
-simpleShClientRetry retries namedpipe cmd params handler = go retries
- where
- run = simpleShClient namedpipe cmd params handler
- go n
- | n < 1 = run
- | otherwise = do
- v <- tryIO run
- case v of
- Right r -> return r
- Left e -> do
- debug ["simplesh connection retry", show e]
- threadDelaySeconds (Seconds 1)
- go (n - 1)
-
-getStdout :: Resp -> Maybe String
-getStdout (StdoutLine s) = Just s
-getStdout _ = Nothing