diff --git a/Sound/SC3/Server/Internal.hs b/Sound/SC3/Server/Internal.hs new file mode 100644 --- /dev/null +++ b/Sound/SC3/Server/Internal.hs @@ -0,0 +1,173 @@ +module Sound.SC3.Server.Internal ( + InternalTransport + , withInternal +) where + +import Bindings.Sound.SC3 +import Control.Concurrent.Chan +import Control.Exception (bracket) +import Control.Monad +import Control.Monad.State +import qualified Data.ByteString as BS +import qualified Data.ByteString.Internal as BS +import qualified Data.ByteString.Lazy as BL +import qualified Data.List as L +import Foreign.C +import Foreign.ForeignPtr +import Foreign.Marshal +import Foreign.Ptr +import Foreign.Storable +import Foreign.StablePtr +import Sound.OpenSoundControl as OSC +import qualified Sound.SC3 as SC +import Sound.SC3.Server.Options +import Sound.SC3.Server.Process (OutputHandler(..)) + +data InternalTransport = InternalTransport { + world :: Ptr C'World + , recvChan :: Chan OSC + , replyFunc :: C'ReplyFunc + , replyFuncData :: StablePtr (Chan OSC) + , printFunc :: C'HaskellPrintFunc + } + +withInternal :: + ServerOptions + -> RTOptions + -> OutputHandler + -> (InternalTransport -> IO a) + -> IO a +withInternal serverOptions rtOptions handler = + bracket (withWorldOptions (newIT handler) serverOptions rtOptions) + close + +newIT :: OutputHandler -> Ptr C'WorldOptions -> IO InternalTransport +newIT handler options = do + pf <- mk'HaskellPrintFunc (\cs -> mapM_ (onPutString handler) . lines =<< peekCString cs) + c'SetHaskellPrintFunc pf + w <- c'World_New options + c <- newChan + f <- mk'ReplyFunc it_replyFunc + p <- newStablePtr c + return $ InternalTransport w c f p pf + +it_replyFunc :: Ptr C'ReplyAddress -> Ptr CChar -> CInt -> IO () +it_replyFunc replyAddress cbuf csize = do + -- putStrLn $ "it_replyFunc: " ++ show (replyAddress, cbuf, csize) + buf <- BS.packCStringLen (cbuf, fromIntegral csize) + ptr <- liftM castPtrToStablePtr (c'ReplyAddress_ReplyData replyAddress) + chan <- deRefStablePtr ptr + let osc = decodeOSC (BL.fromChunks [buf]) + -- putStrLn $ "it_replyFunc: " ++ show osc + writeChan chan osc + +copyChunks :: Ptr CChar -> [BS.ByteString] -> IO () +copyChunks dst = foldM_ f 0 + where + f i b = do + let (fp, o, n) = BS.toForeignPtr b + -- putStrLn $ "copyChunks " ++ show (i, o, n) + withForeignPtr fp $ \src -> + copyBytes (dst `plusPtr` i) + (src `plusPtr` o) + n + return (i + n) + +copyByteString :: Ptr CChar -> BL.ByteString -> IO () +copyByteString dst = copyChunks dst . BL.toChunks + +sendIT :: InternalTransport -> OSC -> IO () +sendIT t osc = do + let buf = encodeOSC osc + n = BL.length buf + -- putStrLn $ "sendIT: " ++ show n ++ " (" ++ show osc ++ ")" + _ <- allocaArray (fromIntegral n) $ \cbuf -> do + copyByteString cbuf buf + c'World_SendPacketWithContext + (world t) + (fromIntegral n) + cbuf + (replyFunc t) + (castStablePtrToPtr (replyFuncData t)) + -- putStrLn $ "sendIT: " ++ show b + return () + +recvIT :: InternalTransport -> IO OSC +recvIT = readChan . recvChan + +closeIT :: InternalTransport -> IO () +closeIT t = do + sendIT t SC.quit + c'World_WaitForQuit (world t) + freeHaskellFunPtr (replyFunc t) + freeStablePtr (replyFuncData t) + freeHaskellFunPtr (printFunc t) + +withWorldOptions :: (Ptr C'WorldOptions -> IO a) -> ServerOptions -> RTOptions -> IO a +withWorldOptions f so ro = do + (fs, cs) <- flip execStateT ([], []) $ do + -- c'WorldOptions'mPassword :: CString + setOpt (\x -> x { c'WorldOptions'mNumBuffers = int (numberOfSampleBuffers so) }) + setOpt (\x -> x { c'WorldOptions'mMaxLogins = int (maxNumberOfLogins ro) }) + setOpt (\x -> x { c'WorldOptions'mMaxNodes = int (maxNumberOfNodes so) }) + setOpt (\x -> x { c'WorldOptions'mMaxGraphDefs = int (maxNumberOfSynthDefs so) }) + setOpt (\x -> x { c'WorldOptions'mMaxWireBufs = int (numberOfWireBuffers so) }) + setOpt (\x -> x { c'WorldOptions'mNumAudioBusChannels = int (numberOfAudioBusChannels so) }) + setOpt (\x -> x { c'WorldOptions'mNumInputBusChannels = int (numberOfInputBusChannels so) }) + setOpt (\x -> x { c'WorldOptions'mNumOutputBusChannels = int (numberOfOutputBusChannels so) }) + setOpt (\x -> x { c'WorldOptions'mNumControlBusChannels = int (numberOfControlBusChannels so) }) + setOpt (\x -> x { c'WorldOptions'mBufLength = int (blockSize so) }) + setOpt (\x -> x { c'WorldOptions'mRealTimeMemorySize = int (realtimeMemorySize so) }) + -- TODO: Make shared controls accessible + setOpt (\x -> x { c'WorldOptions'mNumSharedControls = 0 }) + setOpt (\x -> x { c'WorldOptions'mSharedControls = nullPtr }) + -- TODO + -- tell (\x -> x { c'WorldOptions'mRealTime }) + -- TODO + -- tell (\x -> x { c'WorldOptions'mMemoryLocking :: CInt + -- tell (\x -> x { c'WorldOptions'mNonRealTimeCmdFilename :: CString + -- tell (\x -> x { c'WorldOptions'mNonRealTimeInputFilename :: CString + -- tell (\x -> x { c'WorldOptions'mNonRealTimeOutputFilename :: CString + -- tell (\x -> x { c'WorldOptions'mNonRealTimeOutputHeaderFormat :: CString + -- tell (\x -> x { c'WorldOptions'mNonRealTimeOutputSampleFormat :: CString + setOpt (\x -> x { c'WorldOptions'mPreferredSampleRate = int (hardwareSampleRate ro) }) + setOpt (\x -> x { c'WorldOptions'mNumRGens = int (numberOfRandomSeeds so) }) + setOpt (\x -> x { c'WorldOptions'mPreferredHardwareBufferFrameSize = int (hardwareBufferSize ro) }) + setOpt (\x -> x { c'WorldOptions'mLoadGraphDefs = bool (loadSynthDefs so) }) + -- tell (\x -> x { c'WorldOptions'mInputStreamsEnabled :: CString + -- tell (\x -> x { c'WorldOptions'mOutputStreamsEnabled :: CString + -- TODO: Make input and output device configurable separately + case hardwareDeviceName ro of + Nothing -> return () + Just name -> do + setOptS (\x s -> x { c'WorldOptions'mInDeviceName = s }) name + setOptS (\x s -> x { c'WorldOptions'mOutDeviceName = s }) name + setOpt (\x -> x { c'WorldOptions'mVerbosity = int (fromEnum (verbosity so)) }) + setOpt (\x -> x { c'WorldOptions'mRendezvous = bool (useZeroconf ro) }) + maybe (return ()) (setOptS (\x s -> x { c'WorldOptions'mUGensPluginPath = s }) . path) (ugenPluginPath so) + maybe (return ()) (setOptS (\x s -> x { c'WorldOptions'mRestrictedPath = s })) (restrictedPath so) + opts <- liftM (flip (foldl (flip ($))) fs) (c'kDefaultWorldOptions >>= peek) + a <- alloca $ \ptr -> do + ptr `poke` opts + f ptr + mapM_ free cs + return a + where + int :: (Integral a, Num b) => a -> b + int = fromIntegral + bool :: Num a => Bool -> a + bool b = int (if b then 1 else 0) + path :: [String] -> String + path = L.intercalate ":" + setOpt f = do + (fs, cs) <- get + put (f:fs, cs) + setOptS f s = do + ptr <- liftIO (newCString s) + (fs, cs) <- get + put (flip f ptr:fs, ptr:cs) + +instance OSC.Transport InternalTransport where + send = sendIT + recv = recvIT + close = closeIT diff --git a/Sound/SC3/Server/Options.hs b/Sound/SC3/Server/Options.hs new file mode 100644 --- /dev/null +++ b/Sound/SC3/Server/Options.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE TemplateHaskell #-} +module Sound.SC3.Server.Options ( + Verbosity(..) + , ServerOptions(..) + , defaultServerOptions + , _serverProgram + , _numberOfControlBusChannels + , _numberOfAudioBusChannels + , _numberOfInputBusChannels + , _numberOfOutputBusChannels + , _blockSize + , _numberOfSampleBuffers + , _maxNumberOfNodes + , _maxNumberOfSynthDefs + , _realtimeMemorySize + , _numberOfWireBuffers + , _numberOfRandomSeeds + , _loadSynthDefs + , _verbosity + , _ugenPluginPath + , _restrictedPath + , RTOptions(..) + , defaultRTOptions + , defaultRTOptionsUDP + , defaultRTOptionsTCP + , _udpPortNumber + , _tcpPortNumber + , _useZeroconf + , _maxNumberOfLogins + , _sessionPassword + , _hardwareDeviceName + , _hardwareBufferSize + , _hardwareSampleRate + , _inputStreamsEnabled + , _outputStreamsEnabled + , NRTOptions(..) + , defaultNRTOptions + , _commandFilePath + , _inputFilePath + , _outputFilePath + , _outputSampleRate + , _outputHeaderFormat + , _outputSampleFormat +) where + +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 = + Silent + | Quiet + | Normal + | Verbose + | VeryVerbose + | ExtremelyVerbose + deriving (Eq, Read, Show) + +instance Enum Verbosity where + fromEnum Silent = -2 + fromEnum Quiet = -1 + fromEnum Normal = 0 + fromEnum Verbose = 1 + fromEnum VeryVerbose = 2 + fromEnum ExtremelyVerbose = 3 + toEnum (-2) = Silent + toEnum (-1) = Quiet + toEnum 0 = Normal + toEnum 1 = Verbose + toEnum 2 = VeryVerbose + toEnum 3 = ExtremelyVerbose + toEnum _ = error "Verbosity (toEnum): bad argument" + +instance CF.Get_C Verbosity where + get parser section option = do + s <- CF.get parser section option + case s of + "Silent" -> return Silent + "Quiet" -> return Quiet + "Normal" -> return Normal + "Verbose" -> return Verbose + "VeryVerbose" -> return VeryVerbose + "ExtremelyVerbose" -> return ExtremelyVerbose + _ -> throwError $ (CF.ParseError $ "Invalid Verbosity value: " ++ s, "") + +-- ==================================================================== +-- * Server options + +-- | 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 + , 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 + , ugenPluginPath = Nothing + , restrictedPath = Nothing +} + +$(deriveAccessors ''ServerOptions) + +-- ==================================================================== +-- * Realtime options + +-- | 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) + , 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 + -- Audio device control + , hardwareDeviceName :: Maybe String -- ^ Hardware device name (JACK client:server name on Linux) + , hardwareBufferSize :: Int -- ^ Hardware buffer size (no effect with JACK) + , 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) + +-- | Default realtime server options. +defaultRTOptions :: RTOptions +defaultRTOptions = RTOptions { + -- Network control + udpPortNumber = 0, + tcpPortNumber = 0, + useZeroconf = False, + maxNumberOfLogins = 16, + sessionPassword = Nothing, + -- Audio device control + hardwareDeviceName = Nothing, + hardwareBufferSize = 0, + hardwareSampleRate = 0, + inputStreamsEnabled = Nothing, + outputStreamsEnabled = Nothing +} + +$(deriveAccessors ''RTOptions) + +-- | Default realtime server options (UDP transport). +defaultRTOptionsUDP :: RTOptions +defaultRTOptionsUDP = defaultRTOptions { udpPortNumber = 57110 } + +-- | Default realtime server options (TCP transport). +defaultRTOptionsTCP :: RTOptions +defaultRTOptionsTCP = defaultRTOptions { tcpPortNumber = 57110 } + +-- ==================================================================== +-- * 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 +} 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) 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 @@ -2,46 +2,43 @@ -- | 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.Process.Options, - OpenTransport(..), - OutputHandler(..), - defaultOutputHandler, - withSynth, - withNRT + module Sound.SC3.Server.Options + , OutputHandler(..) + , defaultOutputHandler + , withTransport + , withSynth + , openTCP + , openUDP + , 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) +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) --- | 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 +localhost :: String +localhost = "127.0.0.1" -- | Check wether a network port is within the valid range (0, 65535] 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) +openTCP :: ServerOptions -> RTOptions -> IO TCP +openTCP _ rtOptions = OSC.openTCP localhost (checkPort "TCP" $ tcpPortNumber rtOptions) -instance OpenTransport (TCP) where - openTransport options server = openTCP server (checkPort "TCP" $ tcpPortNumber options) +openUDP :: ServerOptions -> RTOptions -> IO UDP +openUDP _ rtOptions = OSC.openUDP localhost (checkPort "UDP" $ udpPortNumber rtOptions) -- ==================================================================== -- * Output handler @@ -68,6 +65,16 @@ -- ==================================================================== -- * Realtime scsynth execution +withTransport :: (Transport t) => + (ServerOptions -> RTOptions -> IO t) + -> ServerOptions + -> RTOptions + -> (t -> IO a) + -> IO a +withTransport openTransport serverOptions rtOptions = + bracket (openTransport serverOptions rtOptions) + OSC.close + -- | Execute a realtime instance of @scsynth@ with 'Transport' t. -- -- The spawned @scsynth@ is sent a @\/quit@ message after the supplied action @@ -75,13 +82,14 @@ -- -- /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 +withSynth :: (Transport t) => + (ServerOptions -> RTOptions -> IO t) + -> ServerOptions -> RTOptions -> OutputHandler -> (t -> IO a) -> IO a -withSynth serverOptions rtOptions handler action = do +withSynth openTransport serverOptions rtOptions handler action = do (_, hOut, hErr, hProc) <- runInteractiveProcess exe args Nothing Nothing forkIO $ putStderr hErr result <- newEmptyMVar @@ -103,16 +111,16 @@ case l of Left (ex :: IOException) -> returnExc (toException ex) Right l -> - if "SuperCollider 3 server ready." `isPrefixOf` 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 + 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 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 @@ -8,7 +8,7 @@ import Data.Accessor import Data.List (intercalate) import Data.Maybe (fromMaybe) -import Sound.SC3.Server.Process.Options +import Sound.SC3.Server.Options -- ==================================================================== -- scsynth commandline options @@ -34,7 +34,7 @@ showOption (Just a) = showOption a instance Option (Verbosity) where - showOption = showOption . ((-)2) . fromEnum + showOption = showOption . fromEnum instance Option [FilePath] where showOption = intercalate ":" diff --git a/Sound/SC3/Server/Process/ConfigFile.hs b/Sound/SC3/Server/Process/ConfigFile.hs --- a/Sound/SC3/Server/Process/ConfigFile.hs +++ b/Sound/SC3/Server/Process/ConfigFile.hs @@ -1,145 +1,169 @@ {-# LANGUAGE FlexibleContexts #-} -- | Read server options from configuraton file. module Sound.SC3.Server.Process.ConfigFile ( - fromAssocs, - toAssocs + getOptions + , setOptions ) where - -import Control.Monad.Error (MonadError) -import Control.Monad.Trans.State (StateT, evalStateT, execStateT) -import Data.Accessor -import Sound.OpenSoundControl (TCP, UDP) -import Sound.SC3.Server.Process.Options -import Data.ConfigFile (CPError, OptionSpec) -import Data.Map (Map) -import qualified Data.Map as Map -readMaybe :: (Read a) => String -> Maybe a -readMaybe s = case reads s of - [(a, "")] -> return a - _ -> fail ("Could not read " ++ (show s)) +import Control.Monad +import Control.Monad.Error +import Control.Monad.State (StateT) +import qualified Control.Monad.State as State +import Data.Accessor +import qualified Data.Accessor.Monad.MTL.State as A +import qualified Data.List as L +import Sound.SC3.Server.Options +import Data.ConfigFile +import Text.Regex --- TODO: Add parse error handling -set :: (Read b, Monad m) => Map OptionSpec String -> OptionSpec -> Accessor a b -> StateT a m () -set opts name accessor = do - case Map.lookup name opts of - Nothing -> return () - Just str -> case readMaybe str of - Nothing -> return () - Just value -> putA accessor value +newtype MaybeConfig a = MaybeConfig { maybeConfig :: Maybe a } -get :: (Show b, Monad m) => OptionSpec -> Accessor a b -> StateT a m (OptionSpec, String) -get name accessor = do - value <- getA accessor - return (name, show value) +instance Show a => Show (MaybeConfig a) where + show = maybe "" show . maybeConfig +instance Get_C a => Get_C (MaybeConfig a) where + get parser section option = liftM (MaybeConfig . Just) (get parser section option) + +data FilePathList = FilePathList { filePathList :: [FilePath] } + +instance Show FilePathList where + show = L.intercalate ":" . filePathList + +instance Get_C FilePathList where + get parser section option = liftM (FilePathList . splitRegex r) (get parser section option) + where r = mkRegex ":" + +getField :: (MonadError CPError m, Get_C b) => ConfigParser -> SectionSpec -> OptionSpec -> Accessor a b -> StateT a m () +getField parser section option accessor = do + case get parser section option of + Left _ -> return () + Right x -> A.set accessor x + +getField_ :: (MonadError CPError m, Get_C c) => ConfigParser -> SectionSpec -> (c -> b) -> OptionSpec -> Accessor a b -> StateT a m () +getField_ parser section wrapper option accessor = do + case get parser section option of + Left _ -> return () + Right x -> A.set accessor (wrapper x) + -- | Get 'ServerOptions' from an option 'Map'. -- Uninitialized fields are taken from 'defaultServerOptions'. -getServerOptions :: (Monad m) => Map OptionSpec String -> m ServerOptions -getServerOptions m = flip execStateT defaultServerOptions $ do - set m "serverProgram" _serverProgram - set m "numberOfControlBusChannels" _numberOfControlBusChannels - set m "numberOfAudioBusChannels" _numberOfAudioBusChannels - set m "numberOfInputBusChannels" _numberOfInputBusChannels - set m "numberOfOutputBusChannels" _numberOfOutputBusChannels - set m "blockSize" _blockSize - set m "numberOfSampleBuffers" _numberOfSampleBuffers - set m "maxNumberOfNodes" _maxNumberOfNodes - set m "maxNumberOfSynthDefs" _maxNumberOfSynthDefs - set m "realtimeMemorySize" _realtimeMemorySize - set m "numberOfWireBuffers" _numberOfWireBuffers - set m "numberOfRandomSeeds" _numberOfRandomSeeds - set m "loadSynthDefs" _loadSynthDefs - set m "verbosity" _verbosity +getServerOptions :: (MonadError CPError m) => ConfigParser -> SectionSpec -> m ServerOptions +getServerOptions parser section = flip State.execStateT defaultServerOptions $ do + getField parser section "serverProgram" _serverProgram + getField parser section "numberOfControlBusChannels" _numberOfControlBusChannels + getField parser section "numberOfAudioBusChannels" _numberOfAudioBusChannels + getField parser section "numberOfInputBusChannels" _numberOfInputBusChannels + getField parser section "numberOfOutputBusChannels" _numberOfOutputBusChannels + getField parser section "blockSize" _blockSize + getField parser section "numberOfSampleBuffers" _numberOfSampleBuffers + getField parser section "maxNumberOfNodes" _maxNumberOfNodes + getField parser section "maxNumberOfSynthDefs" _maxNumberOfSynthDefs + getField parser section "realtimeMemorySize" _realtimeMemorySize + getField parser section "numberOfWireBuffers" _numberOfWireBuffers + getField parser section "numberOfRandomSeeds" _numberOfRandomSeeds + getField parser section "loadSynthDefs" _loadSynthDefs + getField parser section "verbosity" _verbosity + getField_ parser section (Just . filePathList) "ugenPluginPath" _ugenPluginPath + getField_ parser section maybeConfig "restrictedPath" _restrictedPath -- | Get 'RTOptions' from an option 'Map'. -- Uninitialized fields are taken from 'defaultRTOptions'. -getRTOptions :: (Monad m) => Map OptionSpec String -> m RTOptions -getRTOptions m = flip execStateT defaultRTOptions $ do - set m "udpPortNumber" _udpPortNumber - set m "tcpPortNumber" _tcpPortNumber - set m "useZeroconf" _useZeroconf - set m "maxNumberOfLogins" _maxNumberOfLogins - set m "sessionPassword" _sessionPassword - set m "hardwareDeviceName" _hardwareDeviceName - set m "hardwareBufferSize" _hardwareBufferSize - set m "hardwareSampleRate" _hardwareSampleRate - set m "inputStreamsEnabled" _inputStreamsEnabled - set m "outputStreamsEnabled" _outputStreamsEnabled +getRTOptions :: (MonadError CPError m) => ConfigParser -> SectionSpec -> m RTOptions +getRTOptions parser section = flip State.execStateT defaultRTOptions $ do + getField parser section "udpPortNumber" _udpPortNumber + getField parser section "tcpPortNumber" _tcpPortNumber + getField parser section "useZeroconf" _useZeroconf + getField parser section "maxNumberOfLogins" _maxNumberOfLogins + getField_ parser section maybeConfig "sessionPassword" _sessionPassword + getField_ parser section maybeConfig "hardwareDeviceName" _hardwareDeviceName + getField parser section "hardwareBufferSize" _hardwareBufferSize + getField parser section "hardwareSampleRate" _hardwareSampleRate + getField_ parser section maybeConfig "inputStreamsEnabled" _inputStreamsEnabled + getField_ parser section maybeConfig "outputStreamsEnabled" _outputStreamsEnabled -- | Get 'NRTOptions' from an option 'Map'. -- Uninitialized fields are taken from 'defaultNRTOptions'. -getNRTOptions :: Monad m => Map OptionSpec String -> m NRTOptions -getNRTOptions m = flip execStateT defaultNRTOptions $ do - set m "commandFilePath" _commandFilePath - set m "inputFilePath" _inputFilePath - set m "outputFilePath" _outputFilePath - set m "outputSampleRate" _outputSampleRate - set m "outputHeaderFormat" _outputHeaderFormat - set m "outputSampleFormat" _outputSampleFormat +getNRTOptions :: MonadError CPError m => ConfigParser -> SectionSpec -> m NRTOptions +getNRTOptions parser section = flip State.execStateT defaultNRTOptions $ do + getField_ parser section maybeConfig "commandFilePath" _commandFilePath + getField_ parser section maybeConfig "inputFilePath" _inputFilePath + getField parser section "outputFilePath" _outputFilePath + getField parser section "outputSampleRate" _outputSampleRate + getField parser section "outputHeaderFormat" _outputHeaderFormat + getField parser section "outputSampleFormat" _outputSampleFormat --- | Read server options, realtime options and non-relatime options from an --- association list. --- --- TODO: Add error handling. -fromAssocs :: MonadError CPError m => [(OptionSpec, String)] -> m (ServerOptions, RTOptions, NRTOptions) -fromAssocs opts = do - srvo <- getServerOptions m - rto <- getRTOptions m - nrto <- getNRTOptions m - return (srvo, rto, nrto) - where m = Map.fromList opts +-- | Read server options, realtime options and non-relatime options from a 'ConfigParser'. +getOptions :: MonadError CPError m => ConfigParser -> SectionSpec -> m (ServerOptions, RTOptions, NRTOptions) +getOptions parser section = do + so <- getServerOptions parser section + ro <- getRTOptions parser section + no <- getNRTOptions parser section + return (so, ro, no) --- | Convert 'ServerOptions' to association list. -assocsServerOptions :: Monad m => ServerOptions -> m [(OptionSpec, String)] -assocsServerOptions options = flip evalStateT options $ sequence [ - get "serverProgram" _serverProgram - , get "numberOfControlBusChannels" _numberOfControlBusChannels - , get "numberOfAudioBusChannels" _numberOfAudioBusChannels - , get "numberOfInputBusChannels" _numberOfInputBusChannels - , get "numberOfOutputBusChannels" _numberOfOutputBusChannels - , get "blockSize" _blockSize - , get "numberOfSampleBuffers" _numberOfSampleBuffers - , get "maxNumberOfNodes" _maxNumberOfNodes - , get "maxNumberOfSynthDefs" _maxNumberOfSynthDefs - , get "realtimeMemorySize" _realtimeMemorySize - , get "numberOfWireBuffers" _numberOfWireBuffers - , get "numberOfRandomSeeds" _numberOfRandomSeeds - , get "loadSynthDefs" _loadSynthDefs - , get "verbosity" _verbosity - ] +setField :: (Show b, MonadError CPError m) => SectionSpec -> OptionSpec -> Accessor a b -> StateT (a, ConfigParser) m () +setField section option accessor = do + (options, parser) <- State.get + let value = getVal accessor options + parser' <- lift (setshow parser section option value) + State.put (options, parser') --- | Convert 'RTOptions' to association list. -assocsRTOptions :: Monad m => RTOptions -> m [(OptionSpec, String)] -assocsRTOptions options = flip evalStateT options $ sequence [ - get "udpPortNumber" _udpPortNumber - , get "tcpPortNumber" _tcpPortNumber - , get "useZeroconf" _useZeroconf - , get "maxNumberOfLogins" _maxNumberOfLogins - , get "sessionPassword" _sessionPassword - , get "hardwareDeviceName" _hardwareDeviceName - , get "hardwareBufferSize" _hardwareBufferSize - , get "hardwareSampleRate" _hardwareSampleRate - , get "inputStreamsEnabled" _inputStreamsEnabled - , get "outputStreamsEnabled" _outputStreamsEnabled - ] +setField_ :: (Show c, MonadError CPError m) => (b -> c) -> SectionSpec -> OptionSpec -> Accessor a b -> StateT (a, ConfigParser) m () +setField_ wrapper section option accessor = do + (options, parser) <- State.get + let value = getVal accessor options + parser' <- lift (setshow parser section option (wrapper value)) + State.put (options, parser') --- | Convert 'NRTOptions' to association list. -assocsNRTOptions :: Monad m => NRTOptions -> m [(OptionSpec, String)] -assocsNRTOptions options = flip evalStateT options $ sequence [ - get "commandFilePath" _commandFilePath - , get "inputFilePath" _inputFilePath - , get "outputFilePath" _outputFilePath - , get "outputSampleRate" _outputSampleRate - , get "outputHeaderFormat" _outputHeaderFormat - , get "outputSampleFormat" _outputSampleFormat - ] +-- -- | Convert 'ServerOptions' to association list. +setServerOptions :: MonadError CPError m => ServerOptions -> ConfigParser -> SectionSpec -> m ConfigParser +setServerOptions options parser section = liftM snd $ flip State.execStateT (options, parser) $ do + setField section "serverProgram" _serverProgram + setField section "numberOfControlBusChannels" _numberOfControlBusChannels + setField section "numberOfAudioBusChannels" _numberOfAudioBusChannels + setField section "numberOfInputBusChannels" _numberOfInputBusChannels + setField section "numberOfOutputBusChannels" _numberOfOutputBusChannels + setField section "blockSize" _blockSize + setField section "numberOfSampleBuffers" _numberOfSampleBuffers + setField section "maxNumberOfNodes" _maxNumberOfNodes + setField section "maxNumberOfSynthDefs" _maxNumberOfSynthDefs + setField section "realtimeMemorySize" _realtimeMemorySize + setField section "numberOfWireBuffers" _numberOfWireBuffers + setField section "numberOfRandomSeeds" _numberOfRandomSeeds + setField section "loadSynthDefs" _loadSynthDefs + setField section "verbosity" _verbosity + setField_ (MaybeConfig . fmap FilePathList) section "ugenPluginPath" _ugenPluginPath + setField_ MaybeConfig section "restrictedPath" _restrictedPath +-- -- | Convert 'RTOptions' to association list. +setRTOptions :: MonadError CPError m => RTOptions -> ConfigParser -> SectionSpec -> m ConfigParser +setRTOptions options parser section = liftM snd $ flip State.execStateT (options, parser) $ do + setField section "udpPortNumber" _udpPortNumber + setField section "tcpPortNumber" _tcpPortNumber + setField section "useZeroconf" _useZeroconf + setField section "maxNumberOfLogins" _maxNumberOfLogins + setField_ MaybeConfig section "sessionPassword" _sessionPassword + setField_ MaybeConfig section "hardwareDeviceName" _hardwareDeviceName + setField section "hardwareBufferSize" _hardwareBufferSize + setField section "hardwareSampleRate" _hardwareSampleRate + setField_ MaybeConfig section "inputStreamsEnabled" _inputStreamsEnabled + setField_ MaybeConfig section "outputStreamsEnabled" _outputStreamsEnabled + +-- -- | Convert 'NRTOptions' to association list. +setNRTOptions :: MonadError CPError m => NRTOptions -> ConfigParser -> SectionSpec -> m ConfigParser +setNRTOptions options parser section = liftM snd $ flip State.execStateT (options, parser) $ do + setField_ MaybeConfig section "commandFilePath" _commandFilePath + setField_ MaybeConfig section "inputFilePath" _inputFilePath + setField section "outputFilePath" _outputFilePath + setField section "outputSampleRate" _outputSampleRate + setField section "outputHeaderFormat" _outputHeaderFormat + setField section "outputSampleFormat" _outputSampleFormat + + -- | Convert server options and optionally realtime options and non-realtime -- options to an association list. -toAssocs :: Monad m => ServerOptions -> Maybe RTOptions -> Maybe NRTOptions -> m [(OptionSpec, String)] -toAssocs serverOptions rtOptions nrtOptions = do - srvo <- assocsServerOptions serverOptions - rto <- maybe (return []) assocsRTOptions rtOptions - nrto <- maybe (return []) assocsNRTOptions nrtOptions - return $ srvo++rto++nrto +setOptions :: MonadError CPError m => ConfigParser -> SectionSpec -> (ServerOptions, RTOptions, NRTOptions) -> m ConfigParser +setOptions p0 section (so, ro, no) = do + p1 <- setServerOptions so p0 section + p2 <- setRTOptions ro p1 section + p3 <- setNRTOptions no p2 section + return p3 diff --git a/Sound/SC3/Server/Process/Options.hs b/Sound/SC3/Server/Process/Options.hs deleted file mode 100644 --- a/Sound/SC3/Server/Process/Options.hs +++ /dev/null @@ -1,144 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Sound.SC3.Server.Process.Options where - -import Data.Accessor (Accessor) -import Sound.SC3.Server.Process.Accessor (deriveAccessors) - --- | Used with the 'verbosity' field in 'ServerOptions'. -data Verbosity = - Silent - | Quiet - | Normal - | Verbose - | VeryVerbose - | ExtremelyVerbose - deriving (Enum, Eq, Read, Show) - --- ==================================================================== --- * Server options - --- | 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 - , 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 - , ugenPluginPath = Nothing - , restrictedPath = Nothing -} - -$(deriveAccessors ''ServerOptions) - -{-# DEPRECATED realTimeMemorySize "Use `realtimeMemorySize' instead" #-} -realTimeMemorySize :: ServerOptions -> Int -realTimeMemorySize = realtimeMemorySize - -{-# DEPRECATED _realTimeMemorySize "Use `_realtimeMemorySize' instead" #-} -_realTimeMemorySize :: Accessor ServerOptions Int -_realTimeMemorySize = _realtimeMemorySize - --- ==================================================================== --- * Realtime options - --- | 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) - 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 - -- Audio device control - hardwareDeviceName :: Maybe String, -- ^ Hardware device name (JACK client:server name on Linux) - hardwareBufferSize :: Int, -- ^ Hardware buffer size (no effect with JACK) - 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) - --- | Default realtime server options. -defaultRTOptions :: RTOptions -defaultRTOptions = RTOptions { - -- Network control - udpPortNumber = 0, - tcpPortNumber = 0, - useZeroconf = False, - maxNumberOfLogins = 16, - sessionPassword = Nothing, - -- Audio device control - hardwareDeviceName = Nothing, - hardwareBufferSize = 0, - hardwareSampleRate = 0, - inputStreamsEnabled = Nothing, - outputStreamsEnabled = Nothing -} - -$(deriveAccessors ''RTOptions) - --- | Default realtime server options (UDP transport). -defaultRTOptionsUDP :: RTOptions -defaultRTOptionsUDP = defaultRTOptions { udpPortNumber = 57110 } - --- | Default realtime server options (TCP transport). -defaultRTOptionsTCP :: RTOptions -defaultRTOptionsTCP = defaultRTOptions { tcpPortNumber = 57110 } - --- ==================================================================== --- * 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 -} 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) - diff --git a/hsc3-process.cabal b/hsc3-process.cabal --- a/hsc3-process.cabal +++ b/hsc3-process.cabal @@ -1,44 +1,48 @@ -name: hsc3-process -version: 0.3.1 -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-2009 -author: Stefan Kersten -maintainer: Stefan Kersten -stability: provisional -homepage: http://code.haskell.org/~StefanKersten/code/hsc3-process -tested-with: GHC == 6.10.1 -build-type: Simple -cabal-version: >= 1.6 +Name: hsc3-process +Version: 0.4.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 +Author: Stefan Kersten +Maintainer: Stefan Kersten +Stability: experimental +Homepage: http://space.k-hornz.de/software/hsc3-process +Tested-With: GHC == 6.10.1, GHC == 6.12.3 +Build-Type: Simple +Cabal-Version: >= 1.6 -extra-source-files: examples/config.hs +Extra-Source-Files: examples/config.hs examples/scsynth.cfg examples/sine.hs -library - exposed-modules: Sound.SC3.Server.Process +Library + Exposed-Modules: Sound.SC3.Server.Internal + Sound.SC3.Server.Options + Sound.SC3.Server.Process Sound.SC3.Server.Process.CommandLine Sound.SC3.Server.Process.ConfigFile - Sound.SC3.Server.Process.Options - other-modules: Sound.SC3.Server.Process.Accessor + Other-Modules: Sound.SC3.Server.Process.Accessor - build-depends: base >= 3 && < 5 + Build-Depends: base >= 3 && < 5 + , bindings-sc3 + , bytestring >= 0.8 && < 0.10 , ConfigFile >= 1 , containers >= 0.2 , data-accessor >= 0.2 , data-accessor-template >= 0.2 - , hosc >= 0.7 - , hsc3 >= 0.7 + , data-accessor-mtl >= 0.2 + , hosc >= 0.7 && < 0.9 + , hsc3 >= 0.7 && < 0.9 , mtl >= 1.1 , process >= 1.0 + , regex-compat >= 0.9 , template-haskell >= 2 - , transformers - ghc-options: -Wall + Ghc-Options: -W -source-repository head - type: darcs - location: http://code.haskell.org/~StefanKersten/code/hsc3-process/ +Source-Repository head + Type: git + Location: git://github.com/kaoskorobase/hsc3-process.git