module Sound.SC3.Server.Process (
module Sound.SC3.Server.Process.Options
, OutputHandler(..)
, defaultOutputHandler
, NetworkTransport
, withTransport
, withSynth
, runNRT
, withNRT
) where
import Control.Applicative ((<$>))
import Control.Concurrent (forkIO, rtsSupportsBoundThreads)
import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
import Control.Exception (Exception(toException), SomeException, bracket, catchJust, throwIO)
import Control.Monad (liftM, unless, void)
import qualified Data.ByteString.Lazy as B
import Data.Default (Default(..))
import Data.List (isPrefixOf)
import Sound.OSC.FD (Transport(..))
import qualified Sound.OSC.FD as OSC
import Sound.SC3 (quit)
import Sound.SC3.Server.Process.CommandLine
import Sound.SC3.Server.Process.Options
import System.Exit (ExitCode(..))
import System.IO (Handle, hFlush, hGetLine, hPutStrLn, stderr, stdout)
import System.IO.Error (isEOFError)
import System.Process (runInteractiveProcess, waitForProcess)
localhost :: String
localhost = "127.0.0.1"
checkPort :: String -> Int -> Int
checkPort tag p | p <= 0 || p > 65535 = error ("Invalid " ++ tag ++ " port " ++ show p)
checkPort _ p = p
data NetworkTransport = forall t . Transport t => NetworkTransport t
instance Transport NetworkTransport where
recvPacket (NetworkTransport t) = recvPacket t
sendOSC (NetworkTransport t) = sendOSC t
close (NetworkTransport t) = close t
openTransport :: String -> NetworkPort -> IO NetworkTransport
openTransport host (UDPPort p) = NetworkTransport <$> OSC.openUDP host (checkPort "UDP" p)
openTransport host (TCPPort p) = NetworkTransport <$> OSC.openTCP host (checkPort "TCP" p)
data OutputHandler = OutputHandler {
onPutString :: String -> IO ()
, onPutError :: String -> IO ()
}
instance Default OutputHandler where
def = defaultOutputHandler
defaultOutputHandler :: OutputHandler
defaultOutputHandler = OutputHandler {
onPutString = \s -> hPutStrLn stdout s >> hFlush stdout
, onPutError = \s -> hPutStrLn stderr s >> hFlush stderr }
catchEOF :: IO a -> (SomeException -> IO a) -> IO a
catchEOF = catchJust (\e -> if isEOFError e then Just (toException e) else Nothing)
pipeOutput :: (String -> IO ()) -> Handle -> IO ()
pipeOutput f h =
catchEOF (hGetLine h >>= f >> pipeOutput f h)
(\_ -> return ())
ensureThreadedRuntime :: String -> IO ()
ensureThreadedRuntime fun = unless rtsSupportsBoundThreads $
error $ "In order to call '"
++ fun
++ "' without blocking all the other threads in the system,"
++ " you must compile the program with -threaded."
withTransport ::
ServerOptions
-> RTOptions
-> Maybe String
-> (NetworkTransport -> IO a)
-> IO a
withTransport _ rtOptions host =
bracket
(openTransport (maybe localhost id host) (networkPort rtOptions))
OSC.close
withSynth ::
ServerOptions
-> RTOptions
-> OutputHandler
-> (NetworkTransport -> IO a)
-> IO a
withSynth serverOptions rtOptions handler action = do
ensureThreadedRuntime "withSynth"
(_, hOut, hErr, hProc) <- runInteractiveProcess exe args Nothing Nothing
forkPipe onPutError hErr
processResult <- newEmptyMVar
void $ forkIO $ waitForProcess hProc >>= putMVar processResult
result <- catchEOF (liftM Right (loop hOut)) (return . Left)
exitCode <- takeMVar processResult
case exitCode of
ExitSuccess ->
case result of
Left ex -> throwIO ex
Right a -> return a
ExitFailure _ -> throwIO exitCode
where
(exe:args) = rtCommandLine serverOptions rtOptions
loop h = do
l <- hGetLine h
onPutString handler l
if "SuperCollider 3 server ready" `isPrefixOf` l
then cont h
else loop h
cont h = do
forkPipe onPutString h
bracket (openTransport localhost (networkPort rtOptions))
(\t -> OSC.sendOSC t quit >> OSC.close t)
action
forkPipe f = void . forkIO . pipeOutput (f handler)
runNRT ::
ServerOptions
-> NRTOptions
-> OutputHandler
-> FilePath
-> IO ()
runNRT serverOptions nrtOptions handler commandFilePath =
withNRT serverOptions nrtOptions handler $
\h -> B.readFile commandFilePath >>= B.hPut h
withNRT ::
ServerOptions
-> NRTOptions
-> OutputHandler
-> (Handle -> IO a)
-> IO a
withNRT serverOptions nrtOptions handler action = do
ensureThreadedRuntime "withNRT"
(hIn, hOut, hErr, pid) <- runInteractiveProcess exe args Nothing Nothing
forkPipe onPutString hOut
forkPipe onPutError hErr
processResult <- newEmptyMVar
void $ forkIO $ waitForProcess pid >>= putMVar processResult
result <- catchEOF (liftM Right (action hIn)) (return . Left)
exitCode <- takeMVar processResult
case exitCode of
ExitSuccess ->
case result of
Left ex -> throwIO ex
Right a -> return a
ExitFailure _ -> throwIO exitCode
where
(exe:args) = nrtCommandLine serverOptions nrtOptions Nothing
forkPipe f = void . forkIO . pipeOutput (f handler)