{-# LANGUAGE ForeignFunctionInterface #-} {- JACK bindings for Haskell Copyright (C) 2011-2013 Henning Thielemann Copyright (C) 2007 Soenke Hahn This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. -} {-| The Jack module defines types and functions that allows you to use the JACK Audio Connection Kit. -} module Sound.JACK ( -- * general stuff Client, newClient, newClientDefault, disposeClient, withClient, withClientDefault, clientClose, activate, deactivate, withActivation, PortType, Direction, Input, Output, JackFFI.UnknownType, UnknownDirection, Port, newPort, disposePort, withPort, PortSet, setOfPort, setOfPorts, Process, connect, makeProcess, setProcess, withProcess, getSampleRate, lastFrameTime, makeClientRegistration, setClientRegistration, withClientRegistration, JackFFI.PortId, makePortRegistration, setPortRegistration, withPortRegistration, makePortConnect, setPortConnect, withPortConnect, portById, portByName, portName, portShortName, getPorts, portGetAllConnections, narrowPort, narrowPortType, narrowPortDirection, switchUnknownTypePort, switchUnknownDirectionPort, JackFFI.NFrames(JackFFI.NFrames), nframesIndices, nframesBounds, quit, waitForBreakAndClose, waitForBreak, -- * Exceptions handleExceptions, ) where import Sound.JACK.Private import qualified Sound.JACK.Exception as JackExc import qualified Sound.JACK.FFI as JackFFI import qualified Sound.JACK.FFIFree as JackFFIFree import Sound.JACK.FFI.MIDI (EventBuffer, ) import Sound.JACK.FFI (Process, Input(Input), Output(Output), nframesIndices, nframesBounds, ) import qualified Control.Monad.Exception.Synchronous as Sync import qualified Control.Monad.Trans.Class as Trans import qualified Control.Exception as Exc import qualified Foreign.Marshal.Array as Array import qualified Foreign.C.String as CString import qualified Foreign.C.Types as C import Foreign.Storable (Storable, peek, ) import Foreign.Ptr (Ptr, FunPtr, nullPtr, castPtr, freeHaskellFunPtr, nullFunPtr, ) import Foreign.C.String (CString, peekCString, ) import Foreign.C.Error (Errno(Errno), eOK) import qualified Data.EnumSet as ES import Control.Concurrent (MVar, putMVar, newEmptyMVar, takeMVar, threadDelay) import qualified System.IO as IO import System.Posix.Signals (installHandler, keyboardSignal, Handler(Catch)) import Data.Monoid (Monoid, mempty, mappend, ) class Direction dir where dirToFlags :: dir -> JackFFI.PortFlagSet instance Direction Input where dirToFlags ~Input = JackFFI.portIsInput instance Direction Output where dirToFlags ~Output = JackFFI.portIsOutput {- | Type argument for Jack ports where we do not know whether it is an input or an output port. -} data UnknownDirection = UnknownDirection _dummyUnknownDirection :: UnknownDirection _dummyUnknownDirection = UnknownDirection -- | Constructs a new Jack client. newClient :: (JackExc.ThrowsStatus e) => String -- ^ name of the JACK server -> String -- ^ name of the client -> Sync.ExceptionalT e IO Client newClient server name = withCString server $ \cserverS -> withCString name $ \cclientS -> alloca $ \status -> do let opt = ES.fromEnums [JackFFI.ServerName, JackFFI.NoStartServer] client <- Trans.lift $ JackFFI.client_open cclientS opt status cserverS _ <- checkStatus client status return (Client client) -- | Creates a new JACK client with the @default@ server newClientDefault :: (JackExc.ThrowsStatus e) => String -- ^ name of the client -> Sync.ExceptionalT e IO Client newClientDefault name = newClient defaultServer name defaultServer :: String defaultServer = "default" disposeClient :: (JackExc.ThrowsErrno e) => Client -> Sync.ExceptionalT e IO () disposeClient client = liftErrno $ JackFFI.client_close (getClient client) {- | Run a block of code with a newly allocated client. Do not use the client outside the block. -} withClient :: (JackExc.ThrowsStatus e) => String -- ^ name of the JACK server -> String -- ^ name of the client -> (Client -> Sync.ExceptionalT e IO a) -> Sync.ExceptionalT e IO a withClient server name = bracket (newClient server name) (Trans.lift . fmap (const ()) . JackFFI.client_close . getClient) withClientDefault :: (JackExc.ThrowsStatus e) => String -- ^ name of the client -> (Client -> Sync.ExceptionalT e IO a) -> Sync.ExceptionalT e IO a withClientDefault = withClient defaultServer checkStatus :: (JackExc.ThrowsStatus e) => Ptr a -> Ptr JackFFI.StatusSet -> Sync.ExceptionalT e IO JackFFI.StatusSet checkStatus c s = do errCode <- Trans.lift $ peek s Sync.assertT (JackExc.status errCode) (c /= nullPtr) return errCode newPortByType :: (PortType typ, Direction dir, JackExc.ThrowsPortRegister e) => JackFFI.PortFlagSet -> Client -> String -> Sync.ExceptionalT e IO (Port typ dir) newPortByType flags (Client client) name = let aux :: (PortType typ, Direction dir, JackExc.ThrowsPortRegister e) => typ -> dir -> Sync.ExceptionalT e IO (Port typ dir) aux portType dir = withPortName name $ \cPortName -> withCString (portTypeToCString portType) $ \pType -> do -- putStrLn ("register..." ++ show (client, cstring, pType, inout, 0)) port <- Trans.lift $ JackFFI.port_register client cPortName pType (dirToFlags dir ES..|. flags) 0 Sync.assertT JackExc.portRegister (port/=nullPtr) return $ Port port in aux undefined undefined {- | Better use 'withPort' that also handles freeing the port. -} newPort :: (PortType typ, Direction dir, JackExc.ThrowsPortRegister e) => Client -- ^ Jack client -> String -- ^ name of the input port -> Sync.ExceptionalT e IO (Port typ dir) newPort client name = newPortByType ES.empty client name disposePort :: (PortType typ, Direction dir, JackExc.ThrowsErrno e) => Client -> Port typ dir -> Sync.ExceptionalT e IO () disposePort client = liftErrno . JackFFI.port_unregister (getClient client) . getPort {- | Creates a new port for the given client and delete it after usage. The port manages audio or MIDI data in input or output direction depending on the Port type. Usually the required port type can be inferred from following actions that use that port. Do not use the port outside the enclosed block. -} withPort :: (PortType typ, Direction dir, JackExc.ThrowsPortRegister e, JackExc.ThrowsErrno e) => Client -- ^ Jack client -> String -- ^ name of the input port -> (Port typ dir -> Sync.ExceptionalT e IO a) -> Sync.ExceptionalT e IO a withPort client name = bracket (newPort client name) (disposePort client) -- | activates the given Jack client activate :: (JackExc.ThrowsErrno e) => Client -> Sync.ExceptionalT e IO () activate client = liftErrno $ JackFFI.activate $ getClient client deactivate :: (JackExc.ThrowsErrno e) => Client -> Sync.ExceptionalT e IO () deactivate client = liftErrno $ JackFFI.deactivate $ getClient client withActivation :: (JackExc.ThrowsErrno e) => Client -> Sync.ExceptionalT e IO () -> Sync.ExceptionalT e IO () withActivation client = bracket_ (activate client) (deactivate client) -- | closes the given Jack client without causing any trouble (hopefully) clientClose :: (JackExc.ThrowsErrno e) => Client -> PortSet -> Sync.ExceptionalT e IO () clientClose client (PortSet ports) = do mapM_ (liftErrno . JackFFI.port_unregister (getClient client)) ports deactivate client disposeClient client {- dummy use of C that we imported in order to expose CInt constructor -} _dummy :: C.CInt _dummy = undefined foreign import ccall "wrapper" makeProcess :: Process arg -> IO (FunPtr (Process arg)) getClient :: Client -> Ptr JackFFI.Client getClient (Client x) = x getPort :: Port typ dir -> Ptr (JackFFI.Port typ) getPort (Port x) = x withPortName :: String -> (JackFFI.PortName -> Sync.ExceptionalT e IO a) -> Sync.ExceptionalT e IO a withPortName name f = withCString name $ f . JackFFI.PortName peekPortNameArray :: Ptr CString -> IO [String] peekPortNameArray a = if a == nullPtr then return [] else Exc.finally (mapM peekCString =<< Array.peekArray0 nullPtr a) (JackFFIFree.freePortNameArray a) -- | Returns the names of all existing ports. getPorts :: Client -- ^ the Jack client -> IO [String] -- ^ the names as a list of strings getPorts client = CString.withCString "" $ \empty -> do JackFFI.get_ports (getClient client) empty empty 0 >>= peekPortNameArray connect :: (JackExc.ThrowsErrno e) => Client -> String -> String -> Sync.ExceptionalT e IO () connect client outport inport = withPortName outport $ \ outCString -> withPortName inport $ \ inCString -> liftErrno $ JackFFI.connect (getClient client) outCString inCString {- | A collection of mixed types of ports. It is mainly needed for freeing all allocated ports. -} newtype PortSet = PortSet [Ptr (JackFFI.Port ())] instance Monoid PortSet where mempty = PortSet mempty mappend (PortSet a) (PortSet b) = PortSet (mappend a b) setOfPort :: (PortType typ, Direction dir) => Port typ dir -> PortSet setOfPort = PortSet . (:[]) . castPtr . getPort setOfPorts :: (PortType typ, Direction dir) => [Port typ dir] -> PortSet setOfPorts = PortSet . map (castPtr . getPort) quit :: MVar () -> Client -> PortSet -> IO () quit mvar client ports = do putStrLn "quitting..." Sync.resolveT (\(Errno e) -> IO.hPutStrLn IO.stderr $ "exception when closing with errno: " ++ show e) (clientClose client ports) threadDelay 1000000 putMVar mvar () waitForBreakAndClose :: Client -> PortSet -> IO () waitForBreakAndClose client ports = do mvar <- newEmptyMVar _ <- installHandler keyboardSignal (Catch $ quit mvar client ports) Nothing takeMVar mvar waitForBreak :: IO () waitForBreak = do mvar <- newEmptyMVar _ <- installHandler keyboardSignal (Catch $ do putStrLn "quitting..." threadDelay 1000000 putMVar mvar ()) Nothing takeMVar mvar handleExceptions :: Sync.ExceptionalT JackExc.All IO () -> IO () handleExceptions = Sync.resolveT $ IO.hPutStrLn IO.stderr . JackExc.toStringWithHead {-# INLINE withCallback #-} withCallback :: (JackExc.ThrowsErrno e) => (callback -> IO (FunPtr callbackExt)) -> (Client -> FunPtr callbackExt -> Ptr () -> Sync.ExceptionalT e IO ()) -> Client -> callback -> Sync.ExceptionalT e IO a -> Sync.ExceptionalT e IO a withCallback makeCallback setCallback client proc act = bracket (do procPtr <- Trans.lift $ makeCallback proc setCallback client procPtr nullPtr return procPtr) (\procPtr -> do setCallback client nullFunPtr nullPtr Trans.lift $ freeHaskellFunPtr procPtr) (const act) setProcess :: (JackExc.ThrowsErrno e) => Client -> FunPtr (Process arg) -> Ptr arg -> Sync.ExceptionalT e IO () setProcess client procPtr arg = liftErrno $ JackFFI.set_process_callback (getClient client) procPtr arg withProcess :: (JackExc.ThrowsErrno e) => Client -> (JackFFI.NFrames -> Sync.ExceptionalT Errno IO ()) -> Sync.ExceptionalT e IO a -> Sync.ExceptionalT e IO a withProcess = withCallback (\proc -> makeProcess $ \ nframes _arg -> Sync.switchT return (\() -> return eOK) $ proc nframes) setProcess getSampleRate :: Client -> IO Int getSampleRate (Client ptr) = fmap fromIntegral $ JackFFI.get_sample_rate ptr {- Call this function from within a callback in order to obtain the start time of the current block. -} lastFrameTime :: Client -> IO JackFFI.NFrames lastFrameTime (Client client) = JackFFI.last_frame_time client -- | Create a client registration callback 'FunPtr'. foreign import ccall "wrapper" makeClientRegistration :: JackFFI.ClientRegistration arg -> IO (FunPtr (JackFFI.ClientRegistration arg)) -- | Set the client registration callback. setClientRegistration :: (JackExc.ThrowsErrno e) => Client -> FunPtr (JackFFI.ClientRegistration arg) -> Ptr arg -> Sync.ExceptionalT e IO () setClientRegistration client procPtr arg = liftErrno $ JackFFI.set_client_registration_callback (getClient client) procPtr arg withClientRegistration :: (JackExc.ThrowsErrno e) => Client -> (String -> Bool -> IO ()) -> Sync.ExceptionalT e IO a -> Sync.ExceptionalT e IO a withClientRegistration = withCallback (\proc -> makeClientRegistration $ \ namePtr registered _arg -> do name <- peekCString namePtr proc name (registered/=0)) setClientRegistration -- | Create a port registration callback 'FunPtr'. foreign import ccall "wrapper" makePortRegistration :: JackFFI.PortRegistration arg -> IO (FunPtr (JackFFI.PortRegistration arg)) -- | Set the port registration callback. setPortRegistration :: (JackExc.ThrowsErrno e) => Client -> FunPtr (JackFFI.PortRegistration arg) -> Ptr arg -> Sync.ExceptionalT e IO () setPortRegistration client procPtr arg = liftErrno $ JackFFI.set_port_registration_callback (getClient client) procPtr arg withPortRegistration :: (JackExc.ThrowsErrno e) => Client -> (JackFFI.PortId -> Bool -> IO ()) -> Sync.ExceptionalT e IO a -> Sync.ExceptionalT e IO a withPortRegistration = withCallback (\proc -> makePortRegistration $ \ portA registered _arg -> proc portA (registered/=0)) setPortRegistration -- | Create a port connect callback 'FunPtr'. foreign import ccall "wrapper" makePortConnect :: JackFFI.PortConnect arg -> IO (FunPtr (JackFFI.PortConnect arg)) -- | Set the port connect callback. setPortConnect :: (JackExc.ThrowsErrno e) => Client -> FunPtr (JackFFI.PortConnect arg) -> Ptr arg -> Sync.ExceptionalT e IO () setPortConnect client procPtr arg = liftErrno $ JackFFI.set_port_connect_callback (getClient client) procPtr arg withPortConnect :: (JackExc.ThrowsErrno e) => Client -> (JackFFI.PortId -> JackFFI.PortId -> Bool -> IO ()) -> Sync.ExceptionalT e IO a -> Sync.ExceptionalT e IO a withPortConnect = withCallback (\proc -> makePortConnect $ \ portA portB connected _arg -> proc portA portB (connected/=0)) setPortConnect portById :: Client -> JackFFI.PortId -> IO (Port JackFFI.UnknownType UnknownDirection) portById client portId = fmap Port $ JackFFI.port_by_id (getClient client) portId portByName :: Client -> String -> IO (Port JackFFI.UnknownType UnknownDirection) portByName client name = fmap Port $ CString.withCString name $ JackFFI.port_by_name (getClient client) . JackFFI.PortName -- | Return the full port name, including the @client_name:@ prefix. portName :: Port typ dir -> IO String portName (Port port) = JackFFI.port_name port >>= peekCString -- | Return the short port name, not including the @client_name:@ prefix. portShortName :: Port typ dir -> IO String portShortName (Port port) = JackFFI.port_short_name port >>= peekCString -- | Return all the port names a given port is connected to. -- -- This function must not be called from a JACK event callback. portGetAllConnections :: Client -> Port typ dir -> IO [String] portGetAllConnections client (Port port) = JackFFI.port_get_all_connections (getClient client) port >>= peekPortNameArray narrowPort :: (PortType typ, Direction dir, JackExc.ThrowsPortMismatch e) => Port JackFFI.UnknownType UnknownDirection -> Sync.ExceptionalT e IO (Port typ dir) narrowPort port = narrowPortType =<< narrowPortDirection port narrowPortType :: (PortType typ, JackExc.ThrowsPortMismatch e) => Port JackFFI.UnknownType dir -> Sync.ExceptionalT e IO (Port typ dir) narrowPortType = let aux :: (PortType typ, JackExc.ThrowsPortMismatch e) => typ -> Port JackFFI.UnknownType dir -> Sync.ExceptionalT e IO (Port typ dir) aux portType (Port port) = do typ <- Trans.lift $ peekCString . JackFFI.deconsPortName =<< JackFFI.port_type port Sync.assertT (JackExc.portMismatch JackExc.TypeMismatch) $ portTypeToCString portType == typ return $ Port $ castPtr port in aux undefined narrowPortDirection :: (Direction dir, JackExc.ThrowsPortMismatch e) => Port typ UnknownDirection -> Sync.ExceptionalT e IO (Port typ dir) narrowPortDirection = let aux :: (Direction dir, JackExc.ThrowsPortMismatch e) => dir -> Port typ UnknownDirection -> Sync.ExceptionalT e IO (Port typ dir) aux dir (Port port) = do flags <- Trans.lift $ JackFFI.port_flags port Sync.assertT (JackExc.portMismatch JackExc.DirectionMismatch) $ not $ ES.disjoint flags $ dirToFlags dir return $ Port port in aux undefined switchUnknownTypePort :: (JackExc.ThrowsPortMismatch e) => Port JackFFI.UnknownType dir -> (Port C.CFloat dir -> Sync.ExceptionalT e IO a) -> (Port EventBuffer dir -> Sync.ExceptionalT e IO a) -> Sync.ExceptionalT e IO a switchUnknownTypePort (Port port) audio midi = do typ <- Trans.lift $ peekCString . JackFFI.deconsPortName =<< JackFFI.port_type port let ifMatch :: (PortType typ, Monad m) => typ -> (Port typ dir -> m a) -> Port typ dir -> m a -> m a ifMatch portType trueAct p falseAct = if portTypeToCString portType == typ then trueAct p else falseAct case Port $ castPtr port of audioPort -> ifMatch undefined audio audioPort $ case Port $ castPtr port of midiPort -> ifMatch undefined midi midiPort $ Sync.throwT $ JackExc.portMismatch JackExc.TypeMismatch switchUnknownDirectionPort :: (JackExc.ThrowsPortMismatch e) => Port typ UnknownDirection -> (Port typ Input -> Sync.ExceptionalT e IO a) -> (Port typ Output -> Sync.ExceptionalT e IO a) -> Sync.ExceptionalT e IO a switchUnknownDirectionPort (Port port) input output = do flags <- Trans.lift $ JackFFI.port_flags port let ifMatch :: (Direction dir, Monad m) => dir -> (Port typ dir -> m a) -> Port typ dir -> m a -> m a ifMatch dir trueAct p falseAct = if not $ ES.disjoint flags $ dirToFlags dir then trueAct p else falseAct case Port port of inPort -> ifMatch undefined input inPort $ case Port port of outPort -> ifMatch undefined output outPort $ Sync.throwT $ JackExc.portMismatch JackExc.DirectionMismatch