diff --git a/Sound/SC3/Server/Process.hs b/Sound/SC3/Server/Process.hs --- a/Sound/SC3/Server/Process.hs +++ b/Sound/SC3/Server/Process.hs @@ -3,32 +3,31 @@ module Sound.SC3.Server.Process ( module Sound.SC3.Server.Process.Options, OpenTransport(..), - commandLine, - EventHandler(..), - _onBoot, - _onPutString, - _onPutError, - defaultEventHandler, + OutputHandler(..), + defaultOutputHandler, withSynth, withNRT ) where -import Sound.OpenSoundControl (Transport, TCP, UDP, openTCP, openUDP) -import Control.Concurrent (forkIO) +import Sound.OpenSoundControl (Transport, TCP, UDP, openTCP, openUDP, send) +import Control.Concurrent (ThreadId, forkIO, myThreadId, throwTo) +import Control.Exception (finally) 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.Exit (ExitCode(..)) import System.IO (Handle, hGetLine, hIsEOF, hPutStrLn, stderr, stdout) -import System.Process (runInteractiveProcess, waitForProcess) +import System.Process (ProcessHandle, runInteractiveProcess, waitForProcess) -- | Helper class for polymorphic opening of network connections. class OpenTransport t where + -- | Open a transport to scsynth based on the given RTOptions and a hostname. openTransport :: RTOptions -> String -> IO t -- | Check wether a network port is within the valid range (0, 65535] @@ -43,25 +42,19 @@ openTransport options server = openTCP server (checkPort "TCP" $ tcpPortNumber options) -- ==================================================================== --- * Event handler +-- * Output handler --- | Event handler for handling I/O with external @scsynth@ processes, --- parameterized by the I/O handle used for sending OSC commands to the --- server. -data EventHandler t = EventHandler { - onPutString :: String -> IO (), -- ^ Handle one line of normal output - onPutError :: String -> IO (), -- ^ Handle one line of error output - onBoot :: t -> IO () -- ^ Executed with the OSC handle after the server has booted +-- | Handle output of external @scsynth@ processes. +data OutputHandler = OutputHandler { + onPutString :: String -> IO () -- ^ Handle one line of normal output + , onPutError :: String -> IO () -- ^ Handle one line of error output } -$(deriveAccessors ''EventHandler) - --- | Default event handler, writing to stdout and stderr, respectively. -defaultEventHandler :: EventHandler t -defaultEventHandler = EventHandler { - onPutString = hPutStrLn stdout, - onPutError = hPutStrLn stderr, - onBoot = const (return ()) +-- | Default IO handler, writing to stdout and stderr, respectively. +defaultOutputHandler :: OutputHandler +defaultOutputHandler = OutputHandler { + onPutString = hPutStrLn stdout + , onPutError = hPutStrLn stderr } -- ==================================================================== @@ -70,45 +63,51 @@ pipeOutput :: (String -> IO ()) -> Handle -> IO () pipeOutput f h = hIsEOF h >>= flip unless (hGetLine h >>= f >> pipeOutput f h) +watchProcess :: ProcessHandle -> ThreadId -> IO () +watchProcess pid tid = do + e <- waitForProcess pid + case e of + ExitSuccess -> return () + ex -> throwTo tid ex + -- ==================================================================== -- * Realtime scsynth execution --- | Execute a realtime instance of @scsynth@ with 'Transport' t and return --- 'ExitCode' when the process exists. +-- | Execute a realtime instance of @scsynth@ with 'Transport' t. -- --- /NOTE/: When compiling executables with GHC, the @-threaded@ option should be --- passed, otherwise the I\/O handlers will not work correctly. +-- The spawned @scsynth@ is sent a @\/quit@ message after the supplied action +-- returns. +-- +-- /NOTE/: When compiling executables with GHC, the @-threaded@ option should +-- be passed, otherwise the I\/O handlers will not work correctly. withSynth :: (Transport t, OpenTransport t) => ServerOptions -> RTOptions - -> EventHandler t - -> IO ExitCode -withSynth serverOptions rtOptions handler = do - print (exe, args) + -> OutputHandler + -> (t -> IO a) + -> IO a +withSynth serverOptions rtOptions handler action = do (_, hOut, hErr, hProc) <- runInteractiveProcess exe args Nothing Nothing - forkIO $ putStdout0 hOut - forkIO $ putStderr hErr - waitForProcess hProc + forkIO $ putStderr hErr + myThreadId >>= forkIO . watchProcess hProc + loop hOut where - (exe:args) = commandLine serverOptions rtOptions - putStdout0 h = do - eof <- hIsEOF h - unless eof $ do - l <- hGetLine h - if isPrefixOf "SuperCollider 3 server ready.." l - then do - onPutString handler l - fd <- openTransport rtOptions "127.0.0.1" - forkIO $ onBoot handler fd - -- Spawn more efficient output handler - forkIO $ putStdout h - return () - else do - onPutString handler l - putStdout0 h -- recurse + (exe:args) = rtCommandLine serverOptions rtOptions + loop h = do + l <- hGetLine h + if "SuperCollider 3 server ready.." `isPrefixOf` l + then do + onPutString handler l + -- Spawn output handler + forkIO $ putStdout h + fd <- openTransport rtOptions "127.0.0.1" + action fd `finally` send fd quit + else do + onPutString handler l + loop h -- recurse putStdout = pipeOutput (onPutString handler) putStderr = pipeOutput (onPutError handler) - + -- ==================================================================== -- * Non-Realtime scsynth execution @@ -117,16 +116,17 @@ withNRT :: ServerOptions -> NRTOptions - -> EventHandler Handle - -> IO ExitCode -withNRT serverOptions nrtOptions handler = do + -> 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 - forkIO $ onBoot handler hIn - waitForProcess hProc + myThreadId >>= forkIO . watchProcess hProc + action hIn where - (exe:args) = commandLine serverOptions nrtOptions { commandFilePath = Nothing } + (exe:args) = nrtCommandLine serverOptions nrtOptions { commandFilePath = Nothing } putStdout = pipeOutput (onPutString handler) putStderr = pipeOutput (onPutString handler) diff --git a/Sound/SC3/Server/Process/CommandLine.hs b/Sound/SC3/Server/Process/CommandLine.hs --- a/Sound/SC3/Server/Process/CommandLine.hs +++ b/Sound/SC3/Server/Process/CommandLine.hs @@ -1,10 +1,12 @@ module Sound.SC3.Server.Process.CommandLine ( - CommandLine(..), - commandLine + rtCommandLine + , nrtCommandLine + , mkOption ) where import Data.Accessor -import Data.Maybe (fromMaybe) +import Data.List (intercalate) +import Data.Maybe (fromMaybe) import Sound.SC3.Server.Process.Options -- ==================================================================== @@ -31,10 +33,18 @@ showOption (Just a) = showOption a instance Option (Verbosity) where - showOption = showOption . fromEnum + showOption = showOption . ((-)2) . fromEnum -mkOption :: (Eq b, Option b, Show b) => a -> a -> String -> Accessor a b -> [String] -mkOption defaultOptions options optName accessor = +instance Option [FilePath] where + showOption = intercalate ":" . map show + +data ToOption a = forall b . Option b => ToOption (a -> b) + +toOption :: a -> ToOption a -> String +toOption a (ToOption f) = showOption (f a) + +mkOption_ :: (Eq b, Option b, Show b) => a -> a -> String -> Accessor a b -> [String] +mkOption_ defaultOptions options optName accessor = if value == defaultValue then [] else [optName, showOption value] @@ -42,50 +52,67 @@ defaultValue = defaultOptions ^. accessor value = options ^. accessor -instance CommandLine (ServerOptions) where - argumentList options = concat [ - o "-c" _numberOfControlBusChannels - , o "-a" _numberOfAudioBusChannels - , o "-i" _numberOfInputBusChannels - , o "-o" _numberOfOutputBusChannels - , o "-z" _blockSize - , o "-b" _numberOfSampleBuffers - , o "-n" _maxNumberOfNodes - , o "-d" _maxNumberOfSynthDefs - , o "-w" _numberOfWireBuffers - , o "-r" _numberOfRandomSeeds - , o "-D" _loadSynthDefs - , o "-v" _verbosity ] - where - o :: (Eq b, Option b, Show b) => String -> Accessor ServerOptions b -> [String] - o = mkOption defaultServerOptions options +mkOption :: a -> a -> String -> ToOption a -> Maybe (String, String) +mkOption defaultOptions options optName accessor = + if value == defaultValue + then Nothing + else Just (optName, value) + where + defaultValue = defaultOptions `toOption` accessor + value = options `toOption` accessor -instance CommandLine (RTOptions) where - argumentList options = concat [ - o "-u" _udpPortNumber - , o "-t" _tcpPortNumber - , o "-R" _useZeroconf - , o "-H" _hardwareDeviceName - , o "-Z" _hardwareBufferSize - , o "-S" _hardwareSampleRate - , o "-l" _maxNumberOfLogins - , o "-p" _sessionPassword - , o "-I" _inputStreamsEnabled - , o "-O" _outputStreamsEnabled ] - where - o :: (Eq b, Option b, Show b) => String -> Accessor RTOptions b -> [String] - o = mkOption defaultRTOptions options +mkOptions :: a -> a -> [(String, ToOption a)] -> [(String, String)] +mkOptions defaultOptions options assocs = [x | Just x <- map (uncurry $ mkOption defaultOptions options) assocs] -instance CommandLine (NRTOptions) where - argumentList options = - "-N" : map ($ options) [ - fromMaybe "_" . commandFilePath - , fromMaybe "_" . inputFilePath - , outputFilePath - , showOption . outputSampleRate - , outputHeaderFormat - , outputSampleFormat ] +flattenOptions :: [(a, a)] -> [a] +flattenOptions [] = [] +flattenOptions ((a, b):xs) = a : b : flattenOptions xs --- | Construct the scsynth command line from 'ServerOptions' and either 'RTOptions' or 'NRTOptions'. -commandLine :: (CommandLine a) => ServerOptions -> a -> [String] -commandLine serverOptions options = (serverProgram serverOptions : argumentList serverOptions) ++ argumentList options +mkServerOptions :: ServerOptions -> [String] +mkServerOptions options = (flattenOptions.mkOptions defaultServerOptions options) [ + ("-c" , ToOption numberOfControlBusChannels) + , ("-a" , ToOption numberOfAudioBusChannels ) + , ("-i" , ToOption numberOfInputBusChannels ) + , ("-o" , ToOption numberOfOutputBusChannels ) + , ("-z" , ToOption blockSize ) + , ("-b" , ToOption numberOfSampleBuffers ) + , ("-n" , ToOption maxNumberOfNodes ) + , ("-d" , ToOption maxNumberOfSynthDefs ) + , ("-m" , ToOption realtimeMemorySize ) + , ("-w" , ToOption numberOfWireBuffers ) + , ("-r" , ToOption numberOfRandomSeeds ) + , ("-D" , ToOption loadSynthDefs ) + , ("-v" , ToOption verbosity ) + , ("-U" , ToOption ugenPluginPath ) + , ("-P" , ToOption restrictedPath ) ] + +mkRTOptions :: RTOptions -> [String] +mkRTOptions options = (flattenOptions.mkOptions defaultRTOptions options) [ + ("-u" , ToOption udpPortNumber ) + , ("-t" , ToOption tcpPortNumber ) + , ("-R" , ToOption useZeroconf ) + , ("-H" , ToOption hardwareDeviceName ) + , ("-Z" , ToOption hardwareBufferSize ) + , ("-S" , ToOption hardwareSampleRate ) + , ("-l" , ToOption maxNumberOfLogins ) + , ("-p" , ToOption sessionPassword ) + , ("-I" , ToOption inputStreamsEnabled ) + , ("-O" , ToOption outputStreamsEnabled ) ] + +mkNRTOptions :: NRTOptions -> [String] +mkNRTOptions options = + "-N" : map ($ options) [ + fromMaybe "_" . commandFilePath + , fromMaybe "_" . inputFilePath + , outputFilePath + , showOption . outputSampleRate + , outputHeaderFormat + , outputSampleFormat ] + +-- | Construct the scsynth command line from 'ServerOptions' and 'RTOptions'. +rtCommandLine :: ServerOptions -> RTOptions -> [String] +rtCommandLine serverOptions rtOptions = (serverProgram serverOptions : mkServerOptions serverOptions) ++ mkRTOptions rtOptions + +-- | Construct the scsynth command line from 'ServerOptions' and 'NRTOptions'. +nrtCommandLine :: ServerOptions -> NRTOptions -> [String] +nrtCommandLine serverOptions nrtOptions = (serverProgram serverOptions : mkServerOptions serverOptions) ++ mkNRTOptions nrtOptions diff --git a/Sound/SC3/Server/Process/Options.hs b/Sound/SC3/Server/Process/Options.hs --- a/Sound/SC3/Server/Process/Options.hs +++ b/Sound/SC3/Server/Process/Options.hs @@ -11,23 +11,7 @@ | Verbose | VeryVerbose | ExtremelyVerbose - deriving (Eq, Read, Show) - --- 'Enum' instance for 'Verbosity' for conversion to a commandline option. -instance Enum (Verbosity) where - fromEnum Silent = -2 - fromEnum Quiet = -1 - fromEnum Normal = 0 - fromEnum Verbose = 1 - fromEnum VeryVerbose = 2 - fromEnum ExtremelyVerbose = 4 - - toEnum (-1) = Quiet - toEnum 0 = Normal - toEnum 1 = Verbose - toEnum 2 = VeryVerbose - toEnum x | x >= 4 = ExtremelyVerbose - toEnum _ = Silent + deriving (Enum, Eq, Read, Show) -- ==================================================================== -- * Server options @@ -35,39 +19,43 @@ -- | Specify general server options used both in realtime and non-realtime -- mode. data ServerOptions = ServerOptions { - serverProgram :: FilePath, -- ^ Path to the @scsynth@ program - numberOfControlBusChannels :: Int, -- ^ Number of allocated control bus channels - numberOfAudioBusChannels :: Int, -- ^ Number of allocated audio bus channels - numberOfInputBusChannels :: Int, -- ^ Number of physical input channels - numberOfOutputBusChannels :: Int, -- ^ Number of physical output channels - blockSize :: Int, -- ^ Synthesis block size - numberOfSampleBuffers :: Int, -- ^ Number of allocated sample buffers - maxNumberOfNodes :: Int, -- ^ Maximum number of synthesis nodes - maxNumberOfSynthDefs :: Int, -- ^ Maximum number of synth definitions - realtimeMemorySize :: Int, -- ^ Realtime memory size in bytes - numberOfWireBuffers :: Int, -- ^ Number of unit generator connection buffers - numberOfRandomSeeds :: Int, -- ^ Number of random number generator seeds - loadSynthDefs :: Bool, -- ^ If 'True', load synth definitions from /synthdefs/ directory on startup - verbosity :: Verbosity -- ^ 'Verbosity' level + serverProgram :: FilePath -- ^ Path to the @scsynth@ program + , numberOfControlBusChannels :: Int -- ^ Number of allocated control bus channels + , numberOfAudioBusChannels :: Int -- ^ Number of allocated audio bus channels + , numberOfInputBusChannels :: Int -- ^ Number of physical input channels + , numberOfOutputBusChannels :: Int -- ^ Number of physical output channels + , blockSize :: Int -- ^ Synthesis block size + , numberOfSampleBuffers :: Int -- ^ Number of allocated sample buffers + , maxNumberOfNodes :: Int -- ^ Maximum number of synthesis nodes + , maxNumberOfSynthDefs :: Int -- ^ Maximum number of synth definitions + , realtimeMemorySize :: Int -- ^ Realtime memory size in bytes + , numberOfWireBuffers :: Int -- ^ Number of unit generator connection buffers + , numberOfRandomSeeds :: Int -- ^ Number of random number generator seeds + , loadSynthDefs :: Bool -- ^ If 'True', load synth definitions from /synthdefs/ directory on startup + , verbosity :: Verbosity -- ^ 'Verbosity' level + , ugenPluginPath :: Maybe [FilePath] -- ^ List of UGen plugin search paths + , restrictedPath :: Maybe FilePath -- ^ Sandbox path to restrict OSC command filesystem access } deriving (Eq, Show) -- | Default server options. defaultServerOptions :: ServerOptions defaultServerOptions = ServerOptions { - serverProgram = "scsynth", - numberOfControlBusChannels = 4096, - numberOfAudioBusChannels = 128, - numberOfInputBusChannels = 8, - numberOfOutputBusChannels = 8, - blockSize = 64, - numberOfSampleBuffers = 1024, - maxNumberOfNodes = 1024, - maxNumberOfSynthDefs = 1024, - realtimeMemorySize = 8192, - numberOfWireBuffers = 64, - numberOfRandomSeeds = 64, - loadSynthDefs = True, - verbosity = Normal + serverProgram = "scsynth" + , numberOfControlBusChannels = 4096 + , numberOfAudioBusChannels = 128 + , numberOfInputBusChannels = 8 + , numberOfOutputBusChannels = 8 + , blockSize = 64 + , numberOfSampleBuffers = 1024 + , maxNumberOfNodes = 1024 + , maxNumberOfSynthDefs = 1024 + , realtimeMemorySize = 8192 + , numberOfWireBuffers = 64 + , numberOfRandomSeeds = 64 + , loadSynthDefs = True + , verbosity = Normal + , ugenPluginPath = Nothing + , restrictedPath = Nothing } $(deriveAccessors ''ServerOptions) diff --git a/examples/sine.hs b/examples/sine.hs --- a/examples/sine.hs +++ b/examples/sine.hs @@ -1,13 +1,19 @@ -import Sound.OpenSoundControl (UDP) +import Control.Concurrent +import Sound.OpenSoundControl (OSC(..), Time(..), UDP, pauseThread) import Sound.SC3 import Sound.SC3.Server.Process -import Data.Accessor +import System.Exit +sine :: UGen +sine = out 0 (mce2 (s 390) (s 400)) + where s f = sinOsc AR f 0.1 * 0.3 + scmain :: UDP -> IO () -scmain _ = return () +scmain fd = do + reset fd + play fd sine + pauseThread 10 + send fd quit main :: IO () -main = do - putStrLn "fuck" - withSynth defaultServerOptions defaultRTOptionsUDP ((onBoot^=scmain) defaultEventHandler) - return () +main = withSynth defaultServerOptions defaultRTOptionsUDP defaultOutputHandler scmain diff --git a/hsc3-process.cabal b/hsc3-process.cabal --- a/hsc3-process.cabal +++ b/hsc3-process.cabal @@ -1,5 +1,5 @@ name: hsc3-process -version: 0.2.0 +version: 0.2.1 synopsis: Create and control scsynth processes description: Create and control scsynth processes. license: GPL @@ -25,19 +25,26 @@ other-modules: Sound.SC3.Server.Process.Accessor, Sound.SC3.Server.Process.CommandLine - extensions: FlexibleContexts, TemplateHaskell, TypeSynonymInstances + extensions: ExistentialQuantification + , FlexibleContexts + , FlexibleInstances + , TemplateHaskell + , TypeSynonymInstances - build-depends: base >= 3 && < 5, - ConfigFile == 1.0.*, - containers == 0.2.*, - data-accessor == 0.2.*, - data-accessor-template == 0.2.*, - hosc == 0.8.*, - mtl == 1.1.*, - process == 1.0.*, - template-haskell == 2.3.*, - transformers == 0.1.* + build-depends: base >= 3 && < 5 + , ConfigFile >= 1 + , containers >= 0.2 + , data-accessor >= 0.2 + , data-accessor-template >= 0.2 + , hosc >= 0.7 + , hsc3 >= 0.7 + , mtl >= 1.1 + , process >= 1.0 + , template-haskell >= 2 + , transformers + ghc-options: -Wall + source-repository head type: darcs location: http://code.haskell.org/~StefanKersten/code/hsc3-process/