diff --git a/Sound/SC3/Server/Internal.hs b/Sound/SC3/Server/Internal.hs --- a/Sound/SC3/Server/Internal.hs +++ b/Sound/SC3/Server/Internal.hs @@ -8,7 +8,8 @@ import Control.Concurrent.MVar import Control.Exception (bracket) import Control.Monad -import Control.Monad.State +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.State (execStateT, get, put) import qualified Data.ByteString as BS import qualified Data.ByteString.Internal as BS import qualified Data.ByteString.Lazy as BL @@ -21,7 +22,6 @@ import Foreign.StablePtr import Sound.OpenSoundControl (OSC) import qualified Sound.OpenSoundControl as OSC --- import qualified Sound.OpenSoundControl.Binary as BOSC import qualified Sound.SC3 as SC import Sound.SC3.Server.Options import Sound.SC3.Server.Process (OutputHandler(..)) @@ -82,14 +82,7 @@ sendIT :: InternalTransport -> OSC -> IO () sendIT t osc = withMVar (world t) $ \w -> do let buf = OSC.encodeOSC osc - -- buf1 = OSC.encodeOSC osc n = BL.length buf - -- putStrLn $ "sendIT: " ++ show n ++ " (" ++ show osc ++ ")" - -- when (buf /= buf1) $ do - -- putStrLn $ "================\n" - -- ++ show (BS.pack.BL.unpack$buf1) - -- ++ "\n--------------\n" - -- ++ show (BS.pack.BL.unpack$buf) when (w /= nullPtr) $ do -- TODO: Check return value and throw exception _ <- allocaArray (fromIntegral n) $ \cbuf -> do diff --git a/Sound/SC3/Server/Options.hs b/Sound/SC3/Server/Options.hs --- a/Sound/SC3/Server/Options.hs +++ b/Sound/SC3/Server/Options.hs @@ -1,51 +1,21 @@ {-# LANGUAGE TemplateHaskell #-} -module Sound.SC3.Server.Options ( - Verbosity(..) +module Sound.SC3.Server.Options + ( Verbosity(..) , ServerOptions(..) , defaultServerOptions - -- , _serverProgram - -- , _numberOfControlBusChannels - -- , _numberOfAudioBusChannels - -- , _numberOfInputBusChannels - -- , _numberOfOutputBusChannels - -- , _blockSize - -- , _numberOfSampleBuffers - -- , _maxNumberOfNodes - -- , _maxNumberOfSynthDefs - -- , _realtimeMemorySize - -- , _numberOfWireBuffers - -- , _numberOfRandomSeeds - -- , _loadSynthDefs - -- , _verbosity - -- , _ugenPluginPath - -- , _restrictedPath + , NetworkPort(..) + , defaultUDPPort + , defaultTCPPort , RTOptions(..) , defaultRTOptions , defaultRTOptionsUDP , defaultRTOptionsTCP - -- , _udpPortNumber - -- , _tcpPortNumber - -- , _useZeroconf - -- , _maxNumberOfLogins - -- , _sessionPassword - -- , _hardwareDeviceName - -- , _hardwareBufferSize - -- , _hardwareSampleRate - -- , _inputStreamsEnabled - -- , _outputStreamsEnabled , NRTOptions(..) , defaultNRTOptions - -- , _commandFilePath - -- , _inputFilePath - -- , _outputFilePath - -- , _outputSampleRate - -- , _outputHeaderFormat - -- , _outputSampleFormat -) where + ) where -import Control.Monad.Error +-- import Control.Monad.Error -- import qualified Data.ConfigFile as CF --- import Sound.SC3.Server.Process.Accessor (deriveAccessors) -- | Used with the 'verbosity' field in 'ServerOptions'. data Verbosity = @@ -106,7 +76,7 @@ , 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) + } deriving (Eq, Show) -- | Default server options. defaultServerOptions :: ServerOptions @@ -127,19 +97,33 @@ , verbosity = Normal , ugenPluginPath = Nothing , restrictedPath = Nothing -} - --- $(deriveAccessors ''ServerOptions) + } -- ==================================================================== -- * Realtime options +data NetworkPort = + UDPPort Int + | TCPPort Int + deriving (Eq, Show) + +-- | Default network port number. +defaultPortNumber :: Int +defaultPortNumber = 57110 + +-- | Default UDP port. +defaultUDPPort :: NetworkPort +defaultUDPPort = UDPPort defaultPortNumber + +-- | Default TCP port. +defaultTCPPort :: NetworkPort +defaultTCPPort = TCPPort defaultPortNumber + -- | Realtime server options, parameterized by the OpenSoundControl -- 'Transport' to be used. data RTOptions = RTOptions { -- Network control - udpPortNumber :: Int -- ^ UDP port number (one of 'udpPortNumber' and 'tcpPortNumber' must be non-zero) - , tcpPortNumber :: Int -- ^ TCP port number (one of 'udpPortNumber' and 'tcpPortNumber' must be non-zero) + networkPort :: NetworkPort -- ^ Network port , useZeroconf :: Bool -- ^ If 'True', publish scsynth service through Zeroconf , maxNumberOfLogins :: Int -- ^ Max number of supported logins if 'sessionPassword' is set , sessionPassword :: Maybe String -- ^ Session password @@ -149,57 +133,52 @@ , hardwareSampleRate :: Int -- ^ Hardware buffer size (no effect with JACK) , inputStreamsEnabled :: Maybe Int -- ^ Enabled input streams (CoreAudio only) , outputStreamsEnabled :: Maybe Int -- ^ Enabled output streams (CoreAudio only) -} deriving (Eq, Show) + } deriving (Eq, Show) -- | Default realtime server options. defaultRTOptions :: RTOptions defaultRTOptions = RTOptions { -- Network control - udpPortNumber = 0, - tcpPortNumber = 0, - useZeroconf = False, - maxNumberOfLogins = 16, - sessionPassword = Nothing, + networkPort = defaultUDPPort + , useZeroconf = False + , maxNumberOfLogins = 16 + , sessionPassword = Nothing -- Audio device control - hardwareDeviceName = Nothing, - hardwareBufferSize = 0, - hardwareSampleRate = 0, - inputStreamsEnabled = Nothing, - outputStreamsEnabled = Nothing -} - --- $(deriveAccessors ''RTOptions) + , hardwareDeviceName = Nothing + , hardwareBufferSize = 0 + , hardwareSampleRate = 0 + , inputStreamsEnabled = Nothing + , outputStreamsEnabled = Nothing + } -- | Default realtime server options (UDP transport). defaultRTOptionsUDP :: RTOptions -defaultRTOptionsUDP = defaultRTOptions { udpPortNumber = 57110 } +defaultRTOptionsUDP = defaultRTOptions { networkPort = defaultUDPPort } -- | Default realtime server options (TCP transport). defaultRTOptionsTCP :: RTOptions -defaultRTOptionsTCP = defaultRTOptions { tcpPortNumber = 57110 } +defaultRTOptionsTCP = defaultRTOptions { networkPort = defaultTCPPort } -- ==================================================================== -- * Non-Realtime options -- | Non-realtime server options. data NRTOptions = NRTOptions { - commandFilePath :: Maybe FilePath, -- ^ Path to OSC command file ('Nothing' for stdin) - inputFilePath :: Maybe FilePath, -- ^ Path to input sound file ('Nothing' for no audio input) - outputFilePath :: FilePath, -- ^ Path to output sound file - outputSampleRate :: Int, -- ^ Output sound file sample rate - outputHeaderFormat :: String, -- ^ Output sound file header format - outputSampleFormat :: String -- ^ Output sound file sample format + commandFilePath :: Maybe FilePath -- ^ Path to OSC command file ('Nothing' for stdin) + , inputFilePath :: Maybe FilePath -- ^ Path to input sound file ('Nothing' for no audio input) + , outputFilePath :: FilePath -- ^ Path to output sound file + , outputSampleRate :: Int -- ^ Output sound file sample rate + , outputHeaderFormat :: String -- ^ Output sound file header format + , outputSampleFormat :: String -- ^ Output sound file sample format } deriving (Eq, Show) -- | Default non-realtime server options. defaultNRTOptions :: NRTOptions defaultNRTOptions = NRTOptions { - commandFilePath = Nothing, - inputFilePath = Nothing, - outputFilePath = "output.wav", - outputSampleRate = 44100, - outputHeaderFormat = "wav", - outputSampleFormat = "int16" -} - --- $(deriveAccessors ''NRTOptions) + commandFilePath = Nothing + , inputFilePath = Nothing + , outputFilePath = "output.wav" + , outputSampleRate = 44100 + , outputHeaderFormat = "wav" + , outputSampleFormat = "int16" + } 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 @@ -1,29 +1,29 @@ -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ExistentialQuantification + , ScopedTypeVariables #-} -- | This module includes utilities for spawning an external scsynth process, -- either for realtime or non-realtime execution. -module Sound.SC3.Server.Process ( - module Sound.SC3.Server.Options +module Sound.SC3.Server.Process + ( module Sound.SC3.Server.Options , OutputHandler(..) , defaultOutputHandler + , NetworkTransport , withTransport , withSynth - , openTCP - , openUDP - , withNRT -) where + , withNRT ) where +import Control.Applicative 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 Sound.OpenSoundControl (Transport(..)) 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.IO (Handle, hFlush, hGetLine, hIsEOF, hPutStrLn, stderr, stdout) import System.Process (runInteractiveProcess, waitForProcess) localhost :: String @@ -34,12 +34,19 @@ 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) +-- | Network transport wrapper. +data NetworkTransport = forall t . Transport t => NetworkTransport t -openUDP :: ServerOptions -> RTOptions -> IO UDP -openUDP _ rtOptions = OSC.openUDP localhost (checkPort "UDP" $ udpPortNumber rtOptions) +instance Transport NetworkTransport where + recv (NetworkTransport t) = recv t + send (NetworkTransport t) = send t + close (NetworkTransport t) = close t +-- | Open a network transport connected to a network port. +openTransport :: NetworkPort -> IO NetworkTransport +openTransport (UDPPort p) = NetworkTransport <$> OSC.openUDP localhost (checkPort "UDP" p) +openTransport (TCPPort p) = NetworkTransport <$> OSC.openTCP localhost (checkPort "TCP" p) + -- ==================================================================== -- * Output handler @@ -47,14 +54,14 @@ data OutputHandler = OutputHandler { onPutString :: String -> IO () -- ^ Handle one line of normal output , onPutError :: String -> IO () -- ^ Handle one line of error output -} + } -- | Default IO handler, writing to stdout and stderr, respectively. defaultOutputHandler :: OutputHandler defaultOutputHandler = OutputHandler { - onPutString = hPutStrLn stdout - , onPutError = hPutStrLn stderr -} + onPutString = \s -> hPutStrLn stdout s >> hFlush stdout + , onPutError = \s -> hPutStrLn stderr s >> hFlush stderr + } -- ==================================================================== -- Process helpers @@ -65,15 +72,12 @@ -- ==================================================================== -- * Realtime scsynth execution -withTransport :: (Transport t) => - (ServerOptions -> RTOptions -> IO t) - -> ServerOptions +withTransport :: + ServerOptions -> RTOptions - -> (t -> IO a) + -> (NetworkTransport -> IO a) -> IO a -withTransport openTransport serverOptions rtOptions = - bracket (openTransport serverOptions rtOptions) - OSC.close +withTransport _ rtOptions = bracket (openTransport (networkPort rtOptions)) OSC.close -- | Execute a realtime instance of @scsynth@ with 'Transport' t. -- @@ -82,28 +86,27 @@ -- -- /NOTE/: When compiling executables with GHC, the @-threaded@ option should -- be passed, otherwise the I\/O handlers will not work correctly. -withSynth :: (Transport t) => - (ServerOptions -> RTOptions -> IO t) - -> ServerOptions +withSynth :: + ServerOptions -> RTOptions -> OutputHandler - -> (t -> IO a) + -> (NetworkTransport -> 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) +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 @@ -118,7 +121,7 @@ Left (ex :: IOException) -> returnExc (toException ex) _ -> do forkIO $ putStdout h - fd <- openTransport serverOptions rtOptions + fd <- openTransport (networkPort rtOptions) a <- try (action fd >>= evaluate) OSC.send fd quit case a of @@ -147,25 +150,25 @@ -> (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) + (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 (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) + 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) 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 @@ -2,10 +2,8 @@ module Sound.SC3.Server.Process.CommandLine ( rtCommandLine , nrtCommandLine - , mkOption ) where -import Data.Accessor import Data.List (intercalate) import Data.Maybe (fromMaybe) import Sound.SC3.Server.Options @@ -13,9 +11,6 @@ -- ==================================================================== -- scsynth commandline options -class CommandLine a where - argumentList :: a -> [String] - -- | Convert a value to an option string. class Show a => Option a where showOption :: a -> String @@ -44,15 +39,6 @@ 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] - where - defaultValue = defaultOptions ^. accessor - value = options ^. accessor - mkOption :: a -> a -> String -> ToOption a -> Maybe (String, String) mkOption defaultOptions options optName accessor = if value == defaultValue @@ -88,17 +74,20 @@ , ("-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 ) ] +mkRTOptions options = + (case networkPort options of + UDPPort p -> ["-u", showOption p] + TCPPort p -> ["-t", showOption p]) + ++ + (flattenOptions $ mkOptions defaultRTOptions options $ + [ ("-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 = diff --git a/examples/sine.hs b/examples/sine.hs --- a/examples/sine.hs +++ b/examples/sine.hs @@ -1,5 +1,5 @@ import Control.Concurrent -import Sound.OpenSoundControl (OSC(..), Time(..), UDP, pauseThread) +import Sound.OpenSoundControl (OSC(..), Time(..), Transport, pauseThread) import Sound.SC3 import Sound.SC3.Server.Process import System.Exit @@ -8,7 +8,7 @@ sine = out 0 (mce2 (s 390) (s 400)) where s f = sinOsc AR f 0.1 * 0.3 -scmain :: UDP -> IO () +scmain :: Transport t => t -> IO () scmain fd = do reset fd play fd sine @@ -21,6 +21,6 @@ { serverProgram = "scsynth" , loadSynthDefs = False }) (defaultRTOptionsUDP - { udpPortNumber = 2278 }) + { networkPort = UDPPort 2278 }) defaultOutputHandler scmain diff --git a/hsc3-process.cabal b/hsc3-process.cabal --- a/hsc3-process.cabal +++ b/hsc3-process.cabal @@ -1,11 +1,11 @@ Name: hsc3-process -Version: 0.5.1 +Version: 0.6.0 Synopsis: Create and control scsynth processes Description: Create and control scsynth processes. License: GPL License-File: LICENSE Category: Sound -Copyright: Copyright (c) Stefan Kersten 2008-2010 +Copyright: Copyright (c) Stefan Kersten 2008-2012 Author: Stefan Kersten Maintainer: Stefan Kersten Stability: experimental @@ -27,19 +27,19 @@ -- Other-Modules: Sound.SC3.Server.Process.Accessor Build-Depends: base >= 3 && < 5 - , bindings-sc3 - , bytestring >= 0.8 && < 0.10 + , bindings-sc3 >= 0.3.0 + , bytestring >= 0.8 -- , ConfigFile >= 1 , containers >= 0.2 , data-accessor >= 0.2 -- , data-accessor-template >= 0.2 -- , data-accessor-transformers >= 0.2 - , hosc >= 0.7 && < 0.10 - , hsc3 >= 0.7 && < 0.10 - , mtl + , hosc >= 0.7 + , hsc3 >= 0.7 + , mtl >= 2.0 && < 2.1 , process >= 1.0 , regex-compat >= 0.9 - -- , template-haskell >= 2 + , transformers >= 0.2.0 && < 0.3.0 Ghc-Options: -W