module Sound.SC3.Server.Process (
module Sound.SC3.Server.Options
, OutputHandler(..)
, defaultOutputHandler
, withTransport
, withSynth
, openTCP
, openUDP
, withNRT
) where
import Control.Concurrent
import Control.Exception
import Control.Monad (unless)
import Prelude hiding (catch)
import Data.List (isPrefixOf)
import Sound.OpenSoundControl (Transport, TCP, UDP)
import qualified Sound.OpenSoundControl as OSC
import Sound.SC3 (quit)
import Sound.SC3.Server.Options
import Sound.SC3.Server.Process.CommandLine
import System.Exit (ExitCode(..))
import System.IO (Handle, hGetLine, hIsEOF, hPutStrLn, stderr, stdout)
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
openTCP :: ServerOptions -> RTOptions -> IO TCP
openTCP _ rtOptions = OSC.openTCP localhost (checkPort "TCP" $ tcpPortNumber rtOptions)
openUDP :: ServerOptions -> RTOptions -> IO UDP
openUDP _ rtOptions = OSC.openUDP localhost (checkPort "UDP" $ udpPortNumber rtOptions)
data OutputHandler = OutputHandler {
onPutString :: String -> IO ()
, onPutError :: String -> IO ()
}
defaultOutputHandler :: OutputHandler
defaultOutputHandler = OutputHandler {
onPutString = hPutStrLn stdout
, onPutError = hPutStrLn stderr
}
pipeOutput :: (String -> IO ()) -> Handle -> IO ()
pipeOutput f h = hIsEOF h >>= flip unless (hGetLine h >>= f >> pipeOutput f h)
withTransport :: (Transport t) =>
(ServerOptions -> RTOptions -> IO t)
-> ServerOptions
-> RTOptions
-> (t -> IO a)
-> IO a
withTransport openTransport serverOptions rtOptions =
bracket (openTransport serverOptions rtOptions)
OSC.close
withSynth :: (Transport t) =>
(ServerOptions -> RTOptions -> IO t)
-> ServerOptions
-> RTOptions
-> OutputHandler
-> (t -> IO a)
-> IO a
withSynth openTransport serverOptions rtOptions handler action = do
(_, hOut, hErr, hProc) <- runInteractiveProcess exe args Nothing Nothing
forkIO $ putStderr hErr
result <- newEmptyMVar
thread <- forkIO (loop hOut result)
exitCode <- waitForProcess hProc
case exitCode of
ExitSuccess -> do
a <- readMVar result
case a of
Left e -> throw e
Right a -> return a
ExitFailure _ -> do
killThread thread
throw (toException exitCode)
where
(exe:args) = rtCommandLine serverOptions rtOptions
loop h result = do
l <- try (hGetLine h)
case l of
Left (ex :: IOException) -> returnExc (toException ex)
Right l ->
if "SuperCollider 3 server ready" `isPrefixOf` l
then do
e <- try (onPutString handler l)
case e of
Left (ex :: IOException) -> returnExc (toException ex)
_ -> do
forkIO $ putStdout h
fd <- openTransport serverOptions rtOptions
a <- try (action fd >>= evaluate)
OSC.send fd quit
case a of
Left (ex :: SomeException) -> returnExc (toException ex)
Right a -> returnRes a
else do
e <- try (onPutString handler l)
case e of
Left (ex :: IOException) -> returnExc (toException ex)
_ -> loop h result
where
returnRes a = putMVar result (Right a)
returnExc e = putMVar result (Left e)
putStdout = pipeOutput (onPutString handler)
putStderr = pipeOutput (onPutError handler)
withNRT ::
ServerOptions
-> NRTOptions
-> OutputHandler
-> (Handle -> IO a)
-> IO a
withNRT serverOptions nrtOptions handler action = do
(hIn, hOut, hErr, hProc) <- runInteractiveProcess exe args Nothing Nothing
forkIO $ putStdout hOut
forkIO $ putStderr hErr
result <- newEmptyMVar
thread <- forkIO $ do
a <- try (action hIn)
case a of
Left (ex :: SomeException) -> putMVar result (Left ex)
_ -> putMVar result a
exitCode <- waitForProcess hProc
case exitCode of
ExitSuccess -> do
a <- readMVar result
case a of
Left e -> throw e
Right a -> return a
ExitFailure _ -> do
killThread thread
throw (toException exitCode)
where
(exe:args) = nrtCommandLine serverOptions nrtOptions { commandFilePath = Nothing }
putStdout = pipeOutput (onPutString handler)
putStderr = pipeOutput (onPutString handler)