{-# 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, disconnect, makeProcess, setProcess, withProcess, getBufferSize, getSampleRate, lastFrameTime, makeClientRegistration, setClientRegistration, withClientRegistration, JackFFI.PortId, makePortRegistration, setPortRegistration, withPortRegistration, makePortConnect, setPortConnect, withPortConnect, portById, portByName, portName, portShortName, portAliases, getPorts, portGetAllConnections, narrowPort, narrowPortType, narrowPortDirection, switchUnknownTypePort, switchUnknownDirectionPort, JackFFI.NFrames(JackFFI.NFrames), nframesIndices, nframesBounds, quit, waitForBreakAndClose, waitForBreak, -- * Exceptions handleExceptions, ) where import Sound.JACK.Private (Port(Port), PortType, PortTypeString, portTypeString, Client(Client), bracket, bracket_, liftErrno, withCString, alloca, ) 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, 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 Control.Monad (join) import Control.Applicative (Const(Const), (<$>), (<$), ) import qualified Foreign.Marshal.Array as Array import qualified Foreign.C.String as CString import qualified Foreign.C.Types as C import Foreign.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 Data.Monoid (Monoid, mempty, mappend, ) class Direction dir where switchDir :: f Input -> f Output -> f dir instance Direction Input where switchDir f _ = f instance Direction Output where switchDir _ f = f type DirFlagSet = Const JackFFI.PortFlagSet dirFlags :: Direction dir => Const JackFFI.PortFlagSet dir dirFlags = switchDir (Const JackFFI.portIsInput) (Const 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) => PortTypeString typ -> DirFlagSet dir -> Client -> String -> Sync.ExceptionalT e IO (Port typ dir) newPortByType (Const portTyp) (Const dir) (Client client) name = withPortName name $ \cPortName -> withCString portTyp $ \pType -> do -- putStrLn ("register..." ++ show (client, cstring, pType, inout, 0)) port <- Trans.lift $ JackFFI.port_register client cPortName (JackFFI.PortType pType) dir 0 Sync.assertT JackExc.portRegister (port/=nullPtr) return $ Port port {- | 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 = newPortByType portTypeString dirFlags 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 disconnect :: (JackExc.ThrowsErrno e) => Client -> String -> String -> Sync.ExceptionalT e IO () disconnect client outport inport = withPortName outport $ \ outCString -> withPortName inport $ \ inCString -> liftErrno $ JackFFI.disconnect (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) {-# DEPRECATED quit "Write your own function instead." #-} 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 () {-# DEPRECATED waitForBreakAndClose "Write your own function instead." #-} waitForBreakAndClose :: Client -> PortSet -> IO () waitForBreakAndClose client ports = do mvar <- newEmptyMVar Exc.finally waitForBreak (quit mvar client ports) takeMVar mvar waitForBreak :: IO () waitForBreak = let go = getLine >> go in go 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 {- | The callback function must respond in real-time, i.e. in a bounded amout of time. That is, strictly spoken it must not wait for anything, e.g. it must not wait for locks and it must not allocate memory. In Haskell this is practically impossible because even simplest operations allocate memory. If the callback needs to much time, JACK will shut down your client. The best you can do is to hope that nothing evil happens. -} 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 getBufferSize :: Client -> IO Int getBufferSize (Client ptr) = fmap fromIntegral $ JackFFI.get_buffer_size ptr 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) = peekCString . JackFFI.deconsPortName =<< JackFFI.port_name port -- | 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 portType :: Port JackFFI.UnknownType dir -> IO String portType (Port port) = peekCString . JackFFI.deconsPortType =<< JackFFI.port_type port castPort :: Port typ0 dir0 -> Port typ1 dir1 castPort (Port port) = Port $ castPtr port {- | Return the port aliases, including the @client_name:@ prefixes. This is especially useful for external midi devices, as the alias names are usually more descriptive than @system:midi_capture_1@. -} portAliases :: Port typ dir -> IO [String] portAliases (Port port) = do sz <- fmap fromIntegral JackFFI.port_name_size Array.allocaArray sz $ \s1 -> Array.allocaArray sz $ \s2 -> do let ss = [s1, s2] Array.withArray ss $ \ptr -> do cnt <- JackFFI.port_get_aliases port ptr if cnt <= 2 then mapM peekCString $ take (fromIntegral cnt) ss else error $ "port_get_aliases returned " ++ show cnt ++ " aliases" -- | 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 port = do typ <- Trans.lift $ portType port liftExc $ narrowPortTypeMaybe portTypeString typ port narrowPortDirection :: (Direction dir, JackExc.ThrowsPortMismatch e) => Port typ UnknownDirection -> Sync.ExceptionalT e IO (Port typ dir) narrowPortDirection (Port port) = do flags <- Trans.lift $ JackFFI.port_flags port liftExc $ narrowPortDirectionMaybe dirFlags flags (Port port) 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 audio midi = do typ <- Trans.lift $ portType port join $ liftExc $ altExc (audio <$> narrowPortTypeMaybe portTypeString typ port) (midi <$> narrowPortTypeMaybe portTypeString typ port) 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 join $ liftExc $ altExc (input <$> narrowPortDirectionMaybe dirFlags flags (Port port)) (output <$> narrowPortDirectionMaybe dirFlags flags (Port port)) narrowPortTypeMaybe :: (PortType typ, JackExc.ThrowsPortMismatch e) => PortTypeString typ -> String -> Port JackFFI.UnknownType dir -> Sync.Exceptional e (Port typ dir) narrowPortTypeMaybe (Const portTyp) typ port = castPort port <$ Sync.assert (JackExc.portMismatch JackExc.TypeMismatch) (portTyp == typ) narrowPortDirectionMaybe :: (Direction dir, JackExc.ThrowsPortMismatch e) => DirFlagSet dir -> JackFFI.PortFlagSet -> Port typ UnknownDirection -> Sync.Exceptional e (Port typ dir) narrowPortDirectionMaybe (Const dir) flags (Port port) = Port port <$ Sync.assert (JackExc.portMismatch JackExc.DirectionMismatch) (not $ ES.disjoint flags dir) liftExc :: (Monad m) => Sync.Exceptional e a -> Sync.ExceptionalT e m a liftExc = Sync.ExceptionalT . return altExc :: Sync.Exceptional e a -> Sync.Exceptional e a -> Sync.Exceptional e a altExc x y = Sync.switch (const y) Sync.Success x