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 @@ -5,6 +5,7 @@ import Bindings.Sound.SC3 import Control.Concurrent.Chan +import Control.Concurrent.MVar import Control.Exception (bracket) import Control.Monad import Control.Monad.State @@ -18,17 +19,19 @@ import Foreign.Ptr import Foreign.Storable import Foreign.StablePtr -import Sound.OpenSoundControl as OSC +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(..)) data InternalTransport = InternalTransport { - world :: Ptr C'World - , recvChan :: Chan OSC - , replyFunc :: C'ReplyFunc - , replyFuncData :: StablePtr (Chan OSC) - , printFunc :: C'HaskellPrintFunc + world :: MVar (Ptr C'World) -- ^The World pointer, wrapped in an MVar. + , recvChan :: Chan OSC -- ^The channel messages received from the library are written to. + , replyFunc :: C'ReplyFunc -- ^Reply callback function pointer. + , replyFuncData :: StablePtr (Chan OSC) -- ^Data for the reply callback (a pointer to the receive channel). + , printFunc :: C'HaskellPrintFunc -- ^Print callback function pointer. } withInternal :: @@ -39,13 +42,13 @@ -> IO a withInternal serverOptions rtOptions handler = bracket (withWorldOptions (newIT handler) serverOptions rtOptions) - close + OSC.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 + w <- newMVar =<< c'World_New options c <- newChan f <- mk'ReplyFunc it_replyFunc p <- newStablePtr c @@ -57,7 +60,7 @@ buf <- BS.packCStringLen (cbuf, fromIntegral csize) ptr <- liftM castPtrToStablePtr (c'ReplyAddress_ReplyData replyAddress) chan <- deRefStablePtr ptr - let osc = decodeOSC (BL.fromChunks [buf]) + let osc = OSC.decodeOSC (BL.fromChunks [buf]) -- putStrLn $ "it_replyFunc: " ++ show osc writeChan chan osc @@ -77,20 +80,27 @@ copyByteString dst = copyChunks dst . BL.toChunks sendIT :: InternalTransport -> OSC -> IO () -sendIT t osc = do - let buf = encodeOSC osc +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 ++ ")" - _ <- 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 () + -- 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 + copyByteString cbuf buf + c'World_SendPacketWithContext + w + (fromIntegral n) + cbuf + (replyFunc t) + (castStablePtrToPtr (replyFuncData t)) + return () recvIT :: InternalTransport -> IO OSC recvIT = readChan . recvChan @@ -98,10 +108,13 @@ closeIT :: InternalTransport -> IO () closeIT t = do sendIT t SC.quit - c'World_WaitForQuit (world t) - freeHaskellFunPtr (replyFunc t) - freeStablePtr (replyFuncData t) - freeHaskellFunPtr (printFunc t) + modifyMVar_ (world t) $ \w -> do + when (w /= nullPtr) $ do + c'World_WaitForQuit w + freeHaskellFunPtr (replyFunc t) + freeStablePtr (replyFuncData t) + freeHaskellFunPtr (printFunc t) + return nullPtr withWorldOptions :: (Ptr C'WorldOptions -> IO a) -> ServerOptions -> RTOptions -> IO a withWorldOptions f so ro = 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 @@ -3,49 +3,49 @@ Verbosity(..) , ServerOptions(..) , defaultServerOptions - , _serverProgram - , _numberOfControlBusChannels - , _numberOfAudioBusChannels - , _numberOfInputBusChannels - , _numberOfOutputBusChannels - , _blockSize - , _numberOfSampleBuffers - , _maxNumberOfNodes - , _maxNumberOfSynthDefs - , _realtimeMemorySize - , _numberOfWireBuffers - , _numberOfRandomSeeds - , _loadSynthDefs - , _verbosity - , _ugenPluginPath - , _restrictedPath + -- , _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 + -- , _udpPortNumber + -- , _tcpPortNumber + -- , _useZeroconf + -- , _maxNumberOfLogins + -- , _sessionPassword + -- , _hardwareDeviceName + -- , _hardwareBufferSize + -- , _hardwareSampleRate + -- , _inputStreamsEnabled + -- , _outputStreamsEnabled , NRTOptions(..) , defaultNRTOptions - , _commandFilePath - , _inputFilePath - , _outputFilePath - , _outputSampleRate - , _outputHeaderFormat - , _outputSampleFormat + -- , _commandFilePath + -- , _inputFilePath + -- , _outputFilePath + -- , _outputSampleRate + -- , _outputHeaderFormat + -- , _outputSampleFormat ) where import Control.Monad.Error import qualified Data.ConfigFile as CF -import Sound.SC3.Server.Process.Accessor (deriveAccessors) +-- import Sound.SC3.Server.Process.Accessor (deriveAccessors) -- | Used with the 'verbosity' field in 'ServerOptions'. data Verbosity = @@ -129,7 +129,7 @@ , restrictedPath = Nothing } -$(deriveAccessors ''ServerOptions) +-- $(deriveAccessors ''ServerOptions) -- ==================================================================== -- * Realtime options @@ -168,7 +168,7 @@ outputStreamsEnabled = Nothing } -$(deriveAccessors ''RTOptions) +-- $(deriveAccessors ''RTOptions) -- | Default realtime server options (UDP transport). defaultRTOptionsUDP :: RTOptions @@ -202,4 +202,4 @@ outputSampleFormat = "int16" } -$(deriveAccessors ''NRTOptions) +-- $(deriveAccessors ''NRTOptions) diff --git a/Sound/SC3/Server/Process/Accessor.hs b/Sound/SC3/Server/Process/Accessor.hs deleted file mode 100644 --- a/Sound/SC3/Server/Process/Accessor.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Sound.SC3.Server.Process.Accessor ( - deriveAccessors -) where - -import qualified Data.Accessor.Template as Accessor -import Language.Haskell.TH (Dec, Name, Q) - --- | Derive accessors with a leading @_@. -deriveAccessors :: Name -> Q [Dec] -deriveAccessors = flip Accessor.nameDeriveAccessors (Just . ("_"++)) diff --git a/Sound/SC3/Server/Process/ConfigFile.hs b/Sound/SC3/Server/Process/ConfigFile.hs deleted file mode 100644 --- a/Sound/SC3/Server/Process/ConfigFile.hs +++ /dev/null @@ -1,169 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} --- | Read server options from configuraton file. -module Sound.SC3.Server.Process.ConfigFile ( - getOptions - , setOptions -) where - -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 - -newtype MaybeConfig a = MaybeConfig { maybeConfig :: Maybe a } - -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 :: (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 :: (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 :: 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 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) - -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') - -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 '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. -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/hsc3-process.cabal b/hsc3-process.cabal --- a/hsc3-process.cabal +++ b/hsc3-process.cabal @@ -1,5 +1,5 @@ Name: hsc3-process -Version: 0.4.0 +Version: 0.5.0 Synopsis: Create and control scsynth processes Description: Create and control scsynth processes. License: GPL @@ -10,7 +10,7 @@ Maintainer: Stefan Kersten Stability: experimental Homepage: http://space.k-hornz.de/software/hsc3-process -Tested-With: GHC == 6.10.1, GHC == 6.12.3 +Tested-With: GHC == 6.10.1, GHC == 6.12.3, GHC == 7.0.1 Build-Type: Simple Cabal-Version: >= 1.6 @@ -23,8 +23,8 @@ Sound.SC3.Server.Options Sound.SC3.Server.Process Sound.SC3.Server.Process.CommandLine - Sound.SC3.Server.Process.ConfigFile - Other-Modules: Sound.SC3.Server.Process.Accessor + -- Sound.SC3.Server.Process.ConfigFile + -- Other-Modules: Sound.SC3.Server.Process.Accessor Build-Depends: base >= 3 && < 5 , bindings-sc3 @@ -32,11 +32,11 @@ , ConfigFile >= 1 , containers >= 0.2 , data-accessor >= 0.2 - , data-accessor-template >= 0.2 - , data-accessor-mtl >= 0.2 - , hosc >= 0.7 && < 0.9 - , hsc3 >= 0.7 && < 0.9 - , mtl >= 1.1 + -- , data-accessor-template >= 0.2 + , data-accessor-transformers >= 0.2 + , hosc >= 0.7 && < 0.10 + , hsc3 >= 0.7 && < 0.10 + , mtl >= 2 , process >= 1.0 , regex-compat >= 0.9 , template-haskell >= 2