public
Created

Coroutine interface to Bash from Haskell.

  • Download Gist
CoBash.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69
{-# LANGUAGE OverloadedStrings
, ScopedTypeVariables
, ParallelListComp
, TupleSections #-}
 
module CoBash where
 
import Control.Applicative
import Control.Concurrent
import Control.Concurrent.MVar
import Control.Exception
import Control.Monad
import Data.Bits
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as Bytes
import Data.Maybe
import Data.Monoid
import qualified GHC.IO.Handle.FD
import System.IO
import System.IO.Error
import System.Process
import System.Posix.ByteString
 
import System.IO.Temp
 
import qualified Text.ShellEscape as Esc
 
 
start :: IO (Handle, Handle, Handle, ProcessHandle)
start = runInteractiveProcess "bash" [] Nothing (Just [])
 
query :: (Handle, Handle, Handle, ProcessHandle) -> ByteString
-> IO (ByteString, ByteString)
query (i, _, _, _) query = withFIFOs query'
where query' ofo efo = do
Bytes.hPut i cmd
hFlush i
[ob, eb] <- backgroundReadFIFOs [ofo, efo]
return (ob, eb)
where cmd = Bytes.unlines ["{", query, "} 1>" <> ofo <> " 2>" <> efo]
 
shutdown :: (Handle, Handle, Handle, ProcessHandle) -> IO ()
shutdown (i, _, _, p) = () <$ hClose i <* waitForProcess p
 
 
openFIFO path = GHC.IO.Handle.FD.openFileBlocking (Bytes.unpack path) ReadMode
 
-- | Run an IO action with two FIFOs in scope, which will removed after it
-- completes.
withFIFOs :: (RawFilePath -> RawFilePath -> IO a) -> IO a
withFIFOs m = withSystemTempDirectory "cobash." m'
where m' = (uncurry m =<<) . mk . Bytes.pack
mk d = (o, e) <$ (createNamedPipe o mode >> createNamedPipe e mode)
where (o, e) = (d <> "/o", d <> "/e")
mode = ownerReadMode .|. ownerWriteMode .|. namedPipeMode
 
drainFIFO :: ByteString -> IO ByteString
drainFIFO path = do
(i, o, e, p) <- bash ["-c", "exec cat <"<>(Bytes.unpack path)]
hClose i
hClose e
Bytes.hGetContents o <* waitForProcess p
 
backgroundReadFIFOs theFIFOs = do
cells <- sequence (newEmptyMVar <$ theFIFOs)
sequence_ [ forkIO (drainFIFO p >>= putMVar c) | p <- theFIFOs | c <- cells ]
sequence (takeMVar <$> cells)
 
bash args = runInteractiveProcess "bash" args Nothing (Just [])

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.