module Sound.SC3.Server.Process (
module Sound.SC3.Server.Process.Options,
OpenTransport(..),
OutputHandler(..),
defaultOutputHandler,
withSynth,
withNRT
) where
import Sound.OpenSoundControl (Transport, TCP, UDP, openTCP, openUDP, send)
import Control.Concurrent
import Control.Concurrent.MVar
import Control.Exception
import Control.Monad (unless)
import Prelude hiding (catch)
import Data.List (isPrefixOf)
import Sound.SC3 (quit)
import Sound.SC3.Server.Process.Accessor (deriveAccessors)
import Sound.SC3.Server.Process.Options
import Sound.SC3.Server.Process.CommandLine
import System.Exit (ExitCode(..))
import System.IO (Handle, hGetLine, hIsEOF, hPutStrLn, stderr, stdout)
import System.Process (ProcessHandle, runInteractiveProcess, waitForProcess)
class OpenTransport t where
openTransport :: RTOptions -> String -> IO t
checkPort :: String -> Int -> Int
checkPort tag p | p <= 0 || p > 65535 = error ("Invalid " ++ tag ++ " port " ++ show p)
checkPort _ p = p
instance OpenTransport (UDP) where
openTransport options server = openUDP server (checkPort "UDP" $ udpPortNumber options)
instance OpenTransport (TCP) where
openTransport options server = openTCP server (checkPort "TCP" $ tcpPortNumber options)
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)
withSynth :: (Transport t, OpenTransport t) =>
ServerOptions
-> RTOptions
-> OutputHandler
-> (t -> IO a)
-> IO a
withSynth 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 rtOptions "127.0.0.1"
a <- try (action fd)
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)