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
buf <- BS.packCStringLen (cbuf, fromIntegral csize)
ptr <- liftM castPtrToStablePtr (c'ReplyAddress_ReplyData replyAddress)
chan <- deRefStablePtr ptr
let osc = decodeOSC (BL.fromChunks [buf])
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
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
_ <- allocaArray (fromIntegral n) $ \cbuf -> do
copyByteString cbuf buf
c'World_SendPacketWithContext
(world t)
(fromIntegral n)
cbuf
(replyFunc t)
(castStablePtrToPtr (replyFuncData t))
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
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) })
setOpt (\x -> x { c'WorldOptions'mNumSharedControls = 0 })
setOpt (\x -> x { c'WorldOptions'mSharedControls = nullPtr })
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) })
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