diff --git a/Changelog b/Changelog --- a/Changelog +++ b/Changelog @@ -1,3 +1,8 @@ +1.3.0.6 (2018-04-01) + + * Support GHC-8.4 + + 1.3.0.5 (2017-07-07) * Fix segfault in registerHotplugCallback caused by a double-free. diff --git a/Event.hs b/Event.hs deleted file mode 100644 --- a/Event.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude, CPP #-} - -module Event ( Event, evtRead, evtWrite ) where - -#if MIN_VERSION_base(4,4,0) -import GHC.Event ( Event, evtRead, evtWrite ) -#else -import System.Event ( Event, evtRead, evtWrite ) -#endif diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2009–2017 Bas van Dijk +Copyright (c) 2009–2018 Bas van Dijk All rights reserved. diff --git a/Poll.hsc b/Poll.hsc deleted file mode 100644 --- a/Poll.hsc +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -#include - -module Poll ( toEvent ) where - --- from base: -import Data.Bits ( (.&.) ) -import Data.Bool ( otherwise ) -import Data.Eq ( (/=) ) -import Data.Monoid ( mempty, mappend ) -import Foreign.C.Types ( CShort ) - --- from usb: --- I need to import GHC.Event or System.Event based on the version of base. --- However it's currently not possible to use cabal macros in .hsc files. --- See: http://hackage.haskell.org/trac/hackage/ticket/870 --- So I use an intermediate module that makes the choice: -import Event ( Event, evtRead, evtWrite ) - -toEvent :: CShort -> Event -toEvent e = remap (#const POLLIN) evtRead `mappend` - remap (#const POLLOUT) evtWrite - where - remap evt to - | e .&. evt /= 0 = to - | otherwise = mempty diff --git a/System/USB.hs b/System/USB.hs deleted file mode 100644 --- a/System/USB.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE Safe #-} -#endif - --------------------------------------------------------------------------------- --- | --- Module : System.USB --- Copyright : (c) 2009–2017 Bas van Dijk --- License : BSD-style (see the file LICENSE) --- Maintainer : Bas van Dijk --- --- A convenience module which re-exports all the important modules. --- --------------------------------------------------------------------------------- - -module System.USB - ( module System.USB.Initialization - , module System.USB.Misc - , module System.USB.Enumeration - , module System.USB.DeviceHandling - , module System.USB.Descriptors - , module System.USB.IO -#ifdef HAS_EVENT_MANAGER - , module System.USB.IO.Transfers -#endif - , module System.USB.Exceptions - ) where - -import System.USB.Initialization -import System.USB.Misc -import System.USB.Enumeration -import System.USB.DeviceHandling -import System.USB.Descriptors -import System.USB.IO -#ifdef HAS_EVENT_MANAGER -import System.USB.IO.Transfers -#endif -import System.USB.Exceptions diff --git a/System/USB/Base.hs b/System/USB/Base.hs deleted file mode 100644 --- a/System/USB/Base.hs +++ /dev/null @@ -1,3787 +0,0 @@ -{-# LANGUAGE CPP - , NoImplicitPrelude - , DeriveDataTypeable - , BangPatterns - , ScopedTypeVariables - #-} - -#if __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE Unsafe #-} -#endif - -#ifdef HAS_EVENT_MANAGER -{-# LANGUAGE PatternGuards #-} -#endif - -#ifdef GENERICS -{-# LANGUAGE DeriveGeneric #-} -#endif - -module System.USB.Base where - --------------------------------------------------------------------------------- --- Imports --------------------------------------------------------------------------------- - --- from base: -import Prelude ( Num, (+), (-), (*), Integral, fromIntegral, div - , Enum, fromEnum, error, String ) -import Foreign.C.Types ( CUChar, CInt, CUInt ) -import Foreign.C.String ( CStringLen, peekCString ) -import Foreign.Marshal.Alloc ( alloca ) -import Foreign.Marshal.Array ( allocaArray ) -import Foreign.Marshal.Utils ( toBool, fromBool ) -import Foreign.Storable ( peek, peekElemOff ) -import Foreign.Ptr ( Ptr, castPtr, plusPtr, nullPtr, freeHaskellFunPtr ) -import Foreign.ForeignPtr ( ForeignPtr, withForeignPtr, touchForeignPtr ) -import Control.Applicative ( (<*>) ) -import Control.Exception ( Exception, throwIO, bracket, bracket_ - , onException, assert ) -import Control.Concurrent.MVar ( MVar, newEmptyMVar, takeMVar, putMVar ) -import Control.Monad ( (>>=), (=<<), return, when ) -import Control.Arrow ( (&&&) ) -import Data.Function ( ($), (.), on ) -import Data.Data ( Data ) -import Data.Typeable ( Typeable ) -import Data.Maybe ( Maybe(Nothing, Just), maybe, fromMaybe ) -import Data.Monoid ( Monoid, mempty, mappend ) -import Data.List -import Data.Int ( Int ) -import Data.Word ( Word8, Word16 ) -import Data.Eq ( Eq, (==), (/=) ) -import Data.Ord ( Ord, (<), (>) ) -import Data.Bool ( Bool(False, True), not, otherwise, (&&) ) -import Data.Bits ( Bits, (.&.), (.|.), setBit, testBit, shiftL, shiftR ) -import Data.Version ( Version(..) -#if MIN_VERSION_base(4,8,0) - , makeVersion -#endif - ) -import System.IO ( IO ) -import System.IO.Unsafe ( unsafePerformIO ) -import Text.Show ( Show, show ) -import Text.Read ( Read ) -import Text.Printf ( printf ) - -#if MIN_VERSION_base(4,2,0) -import Data.Functor ( fmap, (<$>) ) -#else -import Control.Monad ( fmap ) -import Control.Applicative ( (<$>) ) -#endif - -#if __GLASGOW_HASKELL__ < 700 -import Prelude ( fromInteger, negate ) -import Control.Monad ( (>>), fail ) -#endif - -import qualified Data.Foldable as Foldable ( forM_ ) -import qualified Foreign.Concurrent as FC ( newForeignPtr ) - --- from bytestring: -import qualified Data.ByteString as B ( ByteString, packCStringLen, drop, length ) -import qualified Data.ByteString.Internal as BI ( createAndTrim, createAndTrim' ) -import qualified Data.ByteString.Unsafe as BU ( unsafeUseAsCStringLen ) - --- from text: -import Data.Text ( Text ) -import qualified Data.Text.Encoding as TE ( decodeUtf16LE ) - --- from vector: -import Data.Vector ( Vector ) -import qualified Data.Vector.Generic as VG ( convert, map ) - --- from bindings-libusb: -import Bindings.Libusb - --- from usb (this package): -import Utils ( bits, between, genToEnum, genFromEnum, peekVector, mapPeekArray - , allocaPeek, ifM - ) - -import qualified Utils as V ( uncons ) - --------------------------------------------------------------------------------- - -#ifdef HAS_EVENT_MANAGER --- from base: -import Prelude ( undefined, seq ) -import Foreign.C.Types ( CShort, CChar, CLong ) -import Foreign.Marshal.Alloc ( allocaBytes, mallocBytes, reallocBytes, free ) -import Foreign.Marshal.Array ( peekArray0, copyArray, advancePtr ) -import Foreign.Storable ( Storable, sizeOf, poke, pokeElemOff ) -import Foreign.Ptr ( nullFunPtr ) -#if MIN_VERSION_base(4,4,0) -import Foreign.ForeignPtr.Unsafe ( unsafeForeignPtrToPtr ) -#else -import Foreign.ForeignPtr ( unsafeForeignPtrToPtr ) -#endif -import Control.Monad ( mapM_, forM_, unless ) -import Data.IORef ( IORef, newIORef, atomicModifyIORef, readIORef, writeIORef ) -import System.Posix.Types ( Fd(Fd) ) -import Control.Exception ( uninterruptibleMask_ ) -import Control.Concurrent.MVar - ( newMVar - , withMVar -#if MIN_VERSION_base(4,7,0) - , withMVarMasked -#endif - ) -import System.IO ( hPutStrLn, stderr ) - -#if MIN_VERSION_base(4,8,0) && !MIN_VERSION_base(4,8,1) -import Unsafe.Coerce ( unsafeCoerce ) -#endif - -#if MIN_VERSION_base(4,4,0) -import GHC.Event -#else -import System.Event -#endif - ( EventManager - , IOCallback - , FdKey - , registerFd, unregisterFd - , registerTimeout, unregisterTimeout -#if MIN_VERSION_base(4,7,0) - , getSystemTimerManager -#endif -#if MIN_VERSION_base(4,8,1) - , Lifetime(MultiShot) -#endif - ) - --- from containers: -import Data.IntMap ( IntMap ) -import qualified Data.IntMap as IntMap ( empty, insert, updateLookupWithKey, elems ) - --- from bytestring: -import qualified Data.ByteString.Internal as BI ( create, memcpy, toForeignPtr ) - ---from vector: -import qualified Data.Vector.Unboxed as Unboxed ( Vector ) -import qualified Data.Vector.Storable as Storable ( Vector ) -import qualified Data.Vector.Generic as VG ( empty, length, sum, foldM_, unsafeFreeze) -import qualified Data.Vector.Generic.Mutable as VGM ( unsafeNew, unsafeWrite ) - --- from usb (this package): -import qualified Poll ( toEvent ) -import SystemEventManager ( getSystemEventManager ) -import Utils ( pokeVector ) - -#include "EventConfig.h" - -#define HAVE_ONE_SHOT \ - (__GLASGOW_HASKELL__ >= 708 && !MIN_VERSION_base(4,8,1) && \ - !(defined(darwin_HOST_OS) || defined(ios_HOST_OS)) && \ - (defined(HAVE_EPOLL) || defined(HAVE_KQUEUE))) - -#endif - --------------------------------------------------------------------------------- - -#ifdef GENERICS -import GHC.Generics ( Generic ) -#define COMMON_INSTANCES Show, Read, Eq, Data, Typeable, Generic -#else -#define COMMON_INSTANCES Show, Read, Eq, Data, Typeable -#endif - --------------------------------------------------------------------------------- - -#if MIN_VERSION_base(4,3,0) -import Control.Exception ( mask, mask_ ) -#else -import Control.Exception ( blocked, block, unblock ) -import Data.Function ( id ) - -mask :: ((IO a -> IO a) -> IO b) -> IO b -mask io = do - b <- blocked - if b - then io id - else block $ io unblock - -mask_ :: IO a -> IO a -mask_ = block -#endif - -#if defined(HAS_EVENT_MANAGER) && !MIN_VERSION_base(4,7,0) -{-# INLINE withMVarMasked #-} -withMVarMasked :: MVar a -> (a -> IO b) -> IO b -withMVarMasked m io = - mask_ $ do - a <- takeMVar m - b <- io a `onException` putMVar m a - putMVar m a - return b -#endif - --------------------------------------------------------------------------------- --- * Initialization --------------------------------------------------------------------------------- - -{-| Abstract type representing a USB session. - -The concept of individual sessions allows your program to use multiple threads -that can independently use this library without interfering with eachother. - -Sessions are created and initialized by 'newCtx' and are automatically closed -when they are garbage collected. - -The only functions that receive a @Ctx@ are 'hasCapability', 'setDebug' and -'getDevices'. --} -data Ctx = Ctx - { -#ifdef HAS_EVENT_MANAGER - ctxGetWait :: !(Maybe Wait), -#endif - getCtxFrgnPtr :: !(ForeignPtr C'libusb_context) - } deriving Typeable - -instance Eq Ctx where (==) = (==) `on` getCtxFrgnPtr - -withCtxPtr :: Ctx -> (Ptr C'libusb_context -> IO a) -> IO a -withCtxPtr = withForeignPtr . getCtxFrgnPtr - --- | Internal function used to initialize libusb. --- --- This function must be called before calling any other libusb function. -libusb_init :: IO (Ptr C'libusb_context) -libusb_init = alloca $ \ctxPtrPtr -> do - handleUSBException $ c'libusb_init ctxPtrPtr - peek ctxPtrPtr - -newCtxNoEventManager :: (ForeignPtr C'libusb_context -> Ctx) -> IO Ctx -newCtxNoEventManager ctx = mask_ $ do - ctxPtr <- libusb_init - ctx <$> FC.newForeignPtr ctxPtr - (c'libusb_exit ctxPtr) - -#ifndef HAS_EVENT_MANAGER --- | Create and initialize a new USB context. --- --- This function may throw 'USBException's. -newCtx :: IO Ctx -newCtx = newCtxNoEventManager Ctx -#else --------------------------------------------------------------------------------- - --- | A function to wait for the termination of a submitted transfer. -type Wait = Timeout -> Lock -> Ptr C'libusb_transfer -> IO () - -{-| Create and initialize a new USB context. - -This function may throw 'USBException's. - -Note that the internal @libusb@ event handling can return errors. These errors -occur in the thread that is executing the event handling loop. 'newCtx' will -print these errors to 'stderr'. If you need to handle the errors yourself (for -example log them in an application specific way) please use 'newCtx''. --} -newCtx :: IO Ctx -newCtx = newCtx' $ \e -> hPutStrLn stderr $ - thisModule ++ ": libusb_handle_events_timeout returned error: " ++ show e - --- | Like 'newCtx' but enables you to specify the way errors should be handled --- that occur while handling @libusb@ events. -newCtx' :: (USBException -> IO ()) -> IO Ctx -newCtx' handleError = do - mbEvtMgr <- getSystemEventManager - case mbEvtMgr of - Nothing -> newCtxNoEventManager $ Ctx Nothing - Just evtMgr -> mask_ $ do - ctxPtr <- libusb_init - - -- Lateron, we need to apply c'libusb_handle_events_timeout to a zeroed - -- timeval structure. We allocate this structure here and it's freed - -- when the Ctx is garbage collected: - zeroTimevalPtr <- mallocZeroTimeval - - newCtxWithEventManager evtMgr zeroTimevalPtr ctxPtr - where - mallocZeroTimeval :: IO (Ptr C'timeval) - mallocZeroTimeval = do - p <- mallocBytes (2 * (sizeOf (undefined :: CLong))) - pokeElemOff (castPtr p) 0 (0 :: CLong) - pokeElemOff (castPtr p) 1 (0 :: CLong) - return (castPtr p) - - newCtxWithEventManager :: EventManager - -> Ptr C'timeval - -> Ptr C'libusb_context - -> IO Ctx - newCtxWithEventManager evtMgr zeroTimevalPtr ctxPtr = do - finalizeRegisterPollFds <- registerPollFds - - wait <- determineWait - - let finalize :: IO () - finalize = do - finalizeRegisterPollFds - free zeroTimevalPtr - c'libusb_exit ctxPtr - - ctxFrgnPtr <- FC.newForeignPtr ctxPtr finalize - - return Ctx{ ctxGetWait = Just wait - , getCtxFrgnPtr = ctxFrgnPtr - } - where - registerPollFds :: IO (IO ()) - registerPollFds = do - fdKeyMapRef <- newIORef IntMap.empty - registerInitialPollFds fdKeyMapRef - unregisterPollFdCallbacks <- registerPollFdCallbacks fdKeyMapRef - return $ do - unregisterPollFdCallbacks - - -- Unregister all registered file descriptors from the event manager: - unregisterAllPollFds fdKeyMapRef - where - -- Register initial libusb file descriptors with the event manager - -- and store the Fd to FdKey associations: - registerInitialPollFds :: IORef (IntMap FdKey) -> IO () - registerInitialPollFds fdKeyMapRef = do - -- Get the initial file descriptors: - pollFdPtrLst <- c'libusb_get_pollfds ctxPtr - pollFdPtrs <- peekArray0 nullPtr pollFdPtrLst - - -- Register them with the GHC EventManager: - forM_ pollFdPtrs $ \pollFdPtr -> do - C'libusb_pollfd fd evt <- peek pollFdPtr - register fdKeyMapRef fd evt - - free pollFdPtrLst - - -- Be notified when libusb file descriptors are added or removed: - registerPollFdCallbacks :: IORef (IntMap FdKey) -> IO (IO ()) - registerPollFdCallbacks fdKeyMapRef = do - -- Create the callbacks that can be passed to libusb: - pollFdAddedFP <- mk'libusb_pollfd_added_cb pollFdAddedCallback - pollFdRemovedFP <- mk'libusb_pollfd_removed_cb pollFdRemovedCallback - - c'libusb_set_pollfd_notifiers ctxPtr pollFdAddedFP pollFdRemovedFP nullPtr - - -- Return a finalizer that should be called when garbage collecting the Ctx: - return $ do - -- Remove notifiers after which we can safely free the FunPtrs: - c'libusb_set_pollfd_notifiers ctxPtr nullFunPtr nullFunPtr nullPtr - - freeHaskellFunPtr pollFdAddedFP - freeHaskellFunPtr pollFdRemovedFP - where - pollFdAddedCallback :: CInt -> CShort -> Ptr () -> IO () - pollFdAddedCallback fd evt _userData = mask_ $ do - register fdKeyMapRef fd evt - - pollFdRemovedCallback :: CInt -> Ptr () -> IO () - pollFdRemovedCallback fd _userData = mask_ $ do - (newFdKeyMap, fdKey) <- atomicModifyIORef fdKeyMapRef $ \fdKeyMap -> - let (Just fdKey, newFdKeyMap) = - IntMap.updateLookupWithKey (\_ _ -> Nothing) - (fromIntegral fd) - fdKeyMap - in (newFdKeyMap, (newFdKeyMap, fdKey)) - - newFdKeyMap `seq` unregisterFd evtMgr fdKey - - unregisterAllPollFds :: IORef (IntMap FdKey) -> IO () - unregisterAllPollFds fdKeyMapRef = - readIORef fdKeyMapRef >>= - mapM_ (unregisterFd evtMgr) . IntMap.elems - - register :: IORef (IntMap FdKey) -> CInt -> CShort -> IO () - register fdKeyMapRef fd evt = registerAndInsert - where - registerAndInsert :: IO () - registerAndInsert = do - fdKey <- registerFd evtMgr callback (Fd fd) (Poll.toEvent evt) - -- In base-4.8 registerFd gains an additonal argument of type - -- Lifetime. However, because of an oversight, base-4.8 doesn't export - -- the constructors: OneShot | MultiShot. We therefor use the hack of - -- unsafely coercing a Bool to a Lifetime. -#if MIN_VERSION_base(4,8,1) - MultiShot -#elif MIN_VERSION_base(4,8,0) - -- We would like to use MultiShot (unsafeCoerce True) - -- registrations. However, base-4.8 has a bug in the MultiShot - -- implementation which means we have to fall back to OneShot. - (unsafeCoerce False) -#endif - - -- Associate the fd with the fdKey: - newFdKeyMap <- atomicModifyIORef fdKeyMapRef $ \fdKeyMap -> - let newFdKeyMap = IntMap.insert (fromIntegral fd) fdKey fdKeyMap - in (newFdKeyMap, newFdKeyMap) - newFdKeyMap `seq` return () - - callback :: IOCallback - callback _fdKey _ev = do -#if HAVE_ONE_SHOT - -- In GHC >= 7.8 && <= 7.10.1 the system event manager might - -- have one-shot semantics. One-shot semantics means that - -- when an event occurs on a registered fd the fd is - -- unregistered before the callback is called. This usb - -- library only works with multi-shot semantics, - -- i.e. registered fds stay registered until they are - -- explicitly unregistered. To work around the one-shot - -- semantics we register the fd again when the callback - -- fires: - registerAndInsert -#endif - handleEvents - - handleEvents :: IO () - handleEvents = do - err <- c'libusb_handle_events_timeout ctxPtr zeroTimevalPtr - when (err /= c'LIBUSB_SUCCESS) $ - if err == c'LIBUSB_ERROR_INTERRUPTED - then handleEvents -- TODO: could this cause an infinite loop? - else handleError $ convertUSBException err - - -- Construct the appropriate Wait function based on whether we have to do - -- our own timeout handling: - determineWait :: IO Wait - determineWait = do - timeoutsHandled <- toBool <$> c'libusb_pollfds_handle_timeouts ctxPtr - if timeoutsHandled - then return $ \_timeout -> autoTimeout - else do -#if MIN_VERSION_base(4,7,0) - timerMgr <- getSystemTimerManager -#else - let timerMgr = evtMgr -#endif - return $ manualTimeout timerMgr - where - autoTimeout lock transPtr = - acquire lock - `onException` - (uninterruptibleMask_ $ do - handleUSBException $ c'libusb_cancel_transfer transPtr - acquire lock) - - manualTimeout timerMgr timeout lock transPtr - | timeout == noTimeout = autoTimeout lock transPtr - | otherwise = do - timeoutKey <- registerTimeout timerMgr (timeout * 1000) handleEvents - acquire lock - `onException` - (uninterruptibleMask_ $ do - unregisterTimeout timerMgr timeoutKey - handleUSBException $ c'libusb_cancel_transfer transPtr - acquire lock) - --- | Checks if the system supports asynchronous I\/O. --- --- * 'Nothing' means asynchronous I\/O is not supported so synchronous I\/O should --- be used instead. --- --- * @'Just' wait@ means that asynchronous I\/O is supported. The @wait@ --- function can be used to wait for submitted transfers. -getWait :: DeviceHandle -> Maybe Wait -getWait = ctxGetWait . getCtx . getDevice - --- | Like 'getWait' but throws an error if the system doesn't support --- asynchronous I\/O. -requireWait :: DeviceHandle -> String -> IO Wait -requireWait devHndl funName = - case getWait devHndl of - Nothing -> moduleError $ funName ++ - " is only supported when using the threaded runtime. " ++ - "Please build your program with -threaded." - Just wait -> return wait -#endif - --------------------------------------------------------------------------------- - -{-| Set message verbosity. - -The default level is 'PrintNothing'. This means no messages are ever -printed. If you choose to increase the message verbosity level you must ensure -that your application does not close the @stdout@/@stderr@ file descriptors. - -You are advised to set the debug level to 'PrintWarnings'. Libusb is -conservative with its message logging. Most of the time it will only log -messages that explain error conditions and other oddities. This will help you -debug your software. - -The LIBUSB_DEBUG environment variable overrules the debug level set by this -function. The message verbosity is fixed to the value in the environment -variable if it is defined. - -If @libusb@ was compiled without any message logging, this function does nothing: -you'll never get any messages. - -If @libusb@ was compiled with verbose debug message logging, this function does -nothing: you'll always get messages from all levels. --} -setDebug :: Ctx -> Verbosity -> IO () -setDebug ctx verbosity = withCtxPtr ctx $ \ctxPtr -> - c'libusb_set_debug ctxPtr $ - marshallVerbosity verbosity - --- | Message verbosity -data Verbosity = - PrintNothing -- ^ No messages are ever printed by the library. - | PrintErrors -- ^ Error messages are printed to @stderr@. - | PrintWarnings -- ^ Warning and error messages are printed to @stderr@. - | PrintInfo -- ^ Informational messages are printed to @stdout@, - -- warning and error messages are printed to @stderr@. - | PrintDebug -- ^ Debug and informational messages are printed to - -- @stdout@, warnings and errors to @stderr@. - deriving (Enum, Ord, COMMON_INSTANCES) - -marshallVerbosity :: Verbosity -> CInt -marshallVerbosity PrintNothing = c'LIBUSB_LOG_LEVEL_NONE -marshallVerbosity PrintErrors = c'LIBUSB_LOG_LEVEL_ERROR -marshallVerbosity PrintWarnings = c'LIBUSB_LOG_LEVEL_WARNING -marshallVerbosity PrintInfo = c'LIBUSB_LOG_LEVEL_INFO -marshallVerbosity PrintDebug = c'LIBUSB_LOG_LEVEL_DEBUG - - --------------------------------------------------------------------------------- --- * Miscellaneous --------------------------------------------------------------------------------- - --- | Structure providing the version of the @libusb@ runtime. -data LibusbVersion = LibusbVersion - { major :: Word16 -- ^ Library major version. - , minor :: Word16 -- ^ Library minor version. - , micro :: Word16 -- ^ Library micro version. - , nano :: Word16 -- ^ Library nano version. - , rc :: String -- ^ Library release candidate suffix string, e.g. @\"-rc4\"@. - - -- , describe :: String -- ^ For ABI compatibility only. - } deriving (COMMON_INSTANCES) - --- | Returns the version (major, minor, micro, nano and rc) of the loaded --- @libusb@ library. -libusbVersion :: LibusbVersion -libusbVersion = unsafePerformIO $ do - ptr <- c'libusb_get_version - LibusbVersion <$> peek (p'libusb_version'major ptr) - <*> peek (p'libusb_version'minor ptr) - <*> peek (p'libusb_version'micro ptr) - <*> peek (p'libusb_version'nano ptr) - <*> (peek (p'libusb_version'rc ptr) >>= peekCString) - - -- <*> (peek (p'libusb_version'describe ptr) >>= peekCString) - --- | Convert a 'LibusbVersion' to a 'Version' for easy comparison. -toVersion :: LibusbVersion -> Version -toVersion (LibusbVersion maj min mic nan _rcTag) = -#if MIN_VERSION_base(4,8,0) - makeVersion branch -#else - Version { versionBranch = branch - , versionTags = if null _rcTag then [] else [_rcTag] - } -#endif - where - branch :: [Int] - branch = map fromIntegral [maj, min, mic, nan] - - --------------------------------------------------------------------------------- - --- | Capabilities supported by an instance of @libusb@ on the current running --- platform. --- --- Test if the loaded @libusb@ library supports a given capability by calling --- 'hasCapability'. -data Capability = HasCapability - -- ^ The 'hasCapability' API is available. - | HasHotplug - -- ^ Hotplug support is available on this platform. - | HasHidAccess - -- ^ The library can access HID devices without requiring user - -- intervention. - -- - -- Note that before being able to actually access an HID - -- device, you may still have to call additional @libusb@ - -- functions such as 'detachKernelDriver'. - | SupportsDetachKernelDriver - -- ^ The library supports detaching of the default USB driver, - -- using 'detachKernelDriver', if one is set by the OS kernel. - deriving (Enum, Ord, COMMON_INSTANCES) - -marshallCapability :: Capability -> C'libusb_capability -marshallCapability HasCapability = c'LIBUSB_CAP_HAS_CAPABILITY -marshallCapability HasHotplug = c'LIBUSB_CAP_HAS_HOTPLUG -marshallCapability HasHidAccess = c'LIBUSB_CAP_HAS_HID_ACCESS -marshallCapability SupportsDetachKernelDriver = c'LIBUSB_CAP_SUPPORTS_DETACH_KERNEL_DRIVER - --- | Check at runtime if the loaded @libusb@ library has a given capability. --- --- This call should be performed after 'newCtx', to ensure the backend has --- updated its capability set. For this reason you need to apply it to a 'Ctx'. -hasCapability :: Ctx -> Capability -> Bool -hasCapability _ctx = toBool . c'libusb_has_capability . marshallCapability - - --------------------------------------------------------------------------------- --- * Enumeration --------------------------------------------------------------------------------- - -{-| Abstract type representing a USB device detected on the system. - -You can only obtain a USB device from the 'getDevices' function. - -Certain operations can be performed on a device, but in order to do any I/O you -will have to first obtain a 'DeviceHandle' using 'openDevice'. - -Just because you have a reference to a device does not mean it is necessarily -usable. The device may have been unplugged, you may not have permission to -operate such device or another process or driver may be using the device. - -To get additional information about a device you can retrieve its descriptor -using 'getDeviceDesc'. --} -data Device = Device - { getCtx :: !Ctx -- ^ This reference to the 'Ctx' is needed so that it won't - -- gets garbage collected. The finalizer @libusb_exit@ is - -- run only when all references to 'Devices' are gone. - , getDevFrgnPtr :: !(ForeignPtr C'libusb_device) - } deriving Typeable - -instance Eq Device where (==) = (==) `on` getDevFrgnPtr - --- | Devices are shown as: @Bus \<'busNumber'\> Device \<'deviceAddress'\>@ -instance Show Device where - show d = printf "Bus %03d Device %03d" (busNumber d) (deviceAddress d) - -withDevicePtr :: Device -> (Ptr C'libusb_device -> IO a) -> IO a -withDevicePtr (Device ctx devFP ) f = do - x <- withForeignPtr devFP f - touchForeignPtr $ getCtxFrgnPtr ctx - return x - -mkDev :: Ctx -> Ptr C'libusb_device -> IO Device -mkDev ctx devPtr = - Device ctx <$> FC.newForeignPtr devPtr (c'libusb_unref_device devPtr) - --------------------------------------------------------------------------------- - -{-| Returns a vector of USB devices currently attached to the system. - -This is your entry point into finding a USB device. - -Exceptions: - - * 'NoMemException' on a memory allocation failure. - --} - -{- -Visual description of the 'devPtrArrayPtr': - - D - ^ D - D │ ^ - ^ │ │ - │ │ │ -devPtrArrayPtr: ┏━┷━┳━┷━┳━━━┳━━━┳━┷━┓ - P ───> ┃ P ┃ P ┃ P ┃ P ┃ P ┃ - ┗━━━┻━━━┻━┯━┻━┯━┻━━━┛ - │ │ -P = pointer v │ -D = device structure D │ - v - D --} -getDevices :: Ctx -> IO (Vector Device) -getDevices ctx = - withCtxPtr ctx $ \ctxPtr -> - alloca $ \devPtrArrayPtr -> mask $ \restore -> do - numDevs <- checkUSBException $ c'libusb_get_device_list ctxPtr - devPtrArrayPtr - devPtrArray <- peek devPtrArrayPtr - let freeDevPtrArray = c'libusb_free_device_list devPtrArray 0 - devs <- restore (mapPeekArray (mkDev ctx) numDevs devPtrArray) - `onException` freeDevPtrArray - freeDevPtrArray - return devs - - --------------------------------------------------------------------------------- --- * Device hotplug event notification --------------------------------------------------------------------------------- - --- | The set of hotplug events to trigger the callback in --- 'registerHotplugCallback'. -newtype HotplugEvent = HotplugEvent {unHotplugEvent :: C'libusb_hotplug_event} - --- | Use 'mempty' to specify the empty set of events. Use @'mappend' e1 e2@ to --- join the events in @e1@ and @e2@. -instance Monoid HotplugEvent where - mempty = HotplugEvent 0 - ev1 `mappend` ev2 = HotplugEvent $ unHotplugEvent ev1 .|. unHotplugEvent ev2 - --- | A device has been plugged in and is ready to use. -deviceArrived :: HotplugEvent -deviceArrived = HotplugEvent c'LIBUSB_HOTPLUG_EVENT_DEVICE_ARRIVED - --- | A device has left and is no longer available. --- --- It is the user's responsibility to call 'closeDevice' on any handle --- associated with a disconnected device. It is safe to call 'getDeviceDesc' on --- a device that has left. -deviceLeft :: HotplugEvent -deviceLeft = HotplugEvent c'LIBUSB_HOTPLUG_EVENT_DEVICE_LEFT - --- | Determine if the set of events contains a 'deviceArrived' event. -matchDeviceArrived :: HotplugEvent -> Bool -matchDeviceArrived = isEvent c'LIBUSB_HOTPLUG_EVENT_DEVICE_ARRIVED - --- | Determine if the set of events contains a 'deviceLeft' event. -matchDeviceLeft :: HotplugEvent -> Bool -matchDeviceLeft = isEvent c'LIBUSB_HOTPLUG_EVENT_DEVICE_LEFT - -isEvent :: C'libusb_hotplug_event -> (HotplugEvent -> Bool) -isEvent c'ev = \ev -> unHotplugEvent ev .&. c'ev == c'ev - --------------------------------------------------------------------------------- - --- | Set of configuration flags for 'registerHotplugCallback'. -newtype HotplugFlag = HotplugFlag {unHotplugFlag :: C'libusb_hotplug_flag} - --- | Use 'mempty' to specify the empty set of flags. Use @'mappend' e1 e2@ to --- join the flags in @e1@ and @e2@. -instance Monoid HotplugFlag where - mempty = HotplugFlag 0 - ev1 `mappend` ev2 = HotplugFlag $ unHotplugFlag ev1 .|. unHotplugFlag ev2 - --- | Fire events for all matching currently attached devices. -enumerate :: HotplugFlag -enumerate = HotplugFlag c'LIBUSB_HOTPLUG_ENUMERATE - --------------------------------------------------------------------------------- - --- | Hotplug callback function type used in 'registerHotplugCallback'. --- --- @libusb@ will call this function, once registered using --- 'registerHotplugCallback', when a matching event has happened on a matching --- device. --- --- This callback may be called by an internal event thread and as such it is --- recommended the callback do minimal processing before returning. In fact, it --- has been observed that doing any I/O with the device from inside the callback --- results in dead-lock! See the example below on the correct use of this --- callback. --- --- It is safe to call either 'registerHotplugCallback' or --- 'deregisterHotplugCallback' from within a callback function. --- --- Should return a 'CallbackRegistrationStatus' which indicates whether this --- callback is finished processing events. Returning 'DeregisterThisCallback' --- will cause this callback to be deregistered. --- --- If you need to wait on the arrival of a device after which you need to do --- something with it, it's recommended to write the device to a concurrent --- channel like a MVar \/ TChan \/ TMVar \/ TChan \/ etc. then read the channel --- outside the callback. This way the processing of the device takes place in a --- different thread. See the following for one correct use-case: --- --- @ --- waitForMyDevice :: Ctx --- -> Maybe VendorId --- -> Maybe ProductId --- -> Maybe Word8 --- -> IO Device --- waitForMyDevice ctx mbVendorId mbProductId mbDevClass = do --- mv <- newEmptyMVar --- -- We mask asynchronous exceptions to ensure that the callback --- -- gets properly deregistered when an asynchronous exception is --- -- thrown during the interruptible takeMVar operation. --- mask_ $ do --- h <- registerHotplugCallback ctx --- deviceArrived --- enumerate --- mbVendorId --- mbProductId --- mbDevClass --- (\\dev event -> --- tryPutMVar mv (dev, event) $> --- DeregisterThisCallback) --- (dev, _event) <- takeMVar mv --- \`onException\` --- deregisterHotplugCallback h --- return dev --- @ -type HotplugCallback = Device -> HotplugEvent -> IO CallbackRegistrationStatus - --- | Returned from a 'HotplugCallback' to indicate whether the callback is --- finished processing events. -data CallbackRegistrationStatus = KeepCallbackRegistered - -- ^ The callback remains registered. - | DeregisterThisCallback - -- ^ The callback will be deregistered. - deriving (COMMON_INSTANCES) - --- | Callback handle. --- --- Callbacks handles are generated by 'registerHotplugCallback' and can be used --- to deregister callbacks. Callback handles are unique per 'Ctx' and it is safe --- to call 'deregisterHotplugCallback' on an already deregisted callback. -data HotplugCallbackHandle = HotplugCallbackHandle - Ctx - (MVar (Maybe C'libusb_hotplug_callback_fn)) - C'libusb_hotplug_callback_handle - --- | /WARNING:/ see the note on 'HotplugCallback' for the danger of using this --- function! --- --- Register a hotplug callback function with the context. The callback will fire --- when a matching event occurs on a matching device. The callback is armed --- until either it is deregistered with 'deregisterHotplugCallback' or the --- supplied callback returns 'DeregisterThisCallback' to indicate it is finished --- processing events. --- --- If the 'enumerate' flag is passed the callback will be called with a --- 'deviceArrived' for all devices already plugged into the machine. Note that --- @libusb@ modifies its internal device list from a separate thread, while --- calling hotplug callbacks from @libusb_handle_events()@, so it is possible --- for a device to already be present on, or removed from, its internal device --- list, while the hotplug callbacks still need to be dispatched. This means --- that when using the 'enumerate' flag, your callback may be called twice for --- the arrival of the same device, once from 'registerHotplugCallback' and once --- from @libusb_handle_events()@; and\/or your callback may be called for the --- removal of a device for which an arrived call was never made. -registerHotplugCallback - :: Ctx -- ^ Context to register this callback with. - -> HotplugEvent -- ^ Set of events that will trigger this callback. - -> HotplugFlag -- ^ Set of configuration flags. - -> Maybe VendorId -- ^ 'Just' the vendor id to match or 'Nothing' to match anything. - -> Maybe ProductId -- ^ 'Just' the product id to match or 'Nothing' to match anything. - -> Maybe Word8 -- ^ 'Just' the device class to match or 'Nothing' to match anything. - -> HotplugCallback -- ^ The function to be invoked on a matching event/device. - -> IO HotplugCallbackHandle -registerHotplugCallback ctx - hotplugEvent - hotplugFlag - mbVendorId - mbProductId - mbDevClass - hotplugCallback = do - (mbCbFnPtrMv :: MVar (Maybe C'libusb_hotplug_callback_fn)) <- newEmptyMVar - - let cb :: Ptr C'libusb_context - -> Ptr C'libusb_device - -> C'libusb_hotplug_event - -> Ptr () - -> IO CInt - cb _ctxPtr devPtr ev _userData = do - dev <- mask_ $ c'libusb_ref_device devPtr >>= mkDev ctx - status <- hotplugCallback dev (HotplugEvent ev) - - case status of - KeepCallbackRegistered -> return 0 - DeregisterThisCallback -> mask_ $ do - mbCbFnPtr <- takeMVar mbCbFnPtrMv - Foldable.forM_ mbCbFnPtr freeHaskellFunPtr - putMVar mbCbFnPtrMv Nothing - return 1 - - withCtxPtr ctx $ \ctxPtr -> - alloca $ \(hotplugCallbackHandlePtr :: Ptr C'libusb_hotplug_callback_handle) -> - mask_ $ do -- We mask to ensure the freeing of cbFnPtr. - cbFnPtr <- mk'libusb_hotplug_callback_fn cb - putMVar mbCbFnPtrMv $ Just cbFnPtr - handleUSBException (c'libusb_hotplug_register_callback - ctxPtr - (unHotplugEvent hotplugEvent) - (unHotplugFlag hotplugFlag) - (unmarshallMatch mbVendorId) - (unmarshallMatch mbProductId) - (unmarshallMatch mbDevClass) - cbFnPtr - nullPtr - hotplugCallbackHandlePtr) - `onException` freeHaskellFunPtr cbFnPtr - HotplugCallbackHandle ctx mbCbFnPtrMv <$> - peek hotplugCallbackHandlePtr - where - unmarshallMatch :: Integral a => Maybe a -> CInt - unmarshallMatch = maybe c'LIBUSB_HOTPLUG_MATCH_ANY fromIntegral - --- | Deregisters a hotplug callback. --- --- Deregister a callback from a 'Ctx'. This function is safe --- to call from within a hotplug callback. -deregisterHotplugCallback :: HotplugCallbackHandle -> IO () -deregisterHotplugCallback (HotplugCallbackHandle ctx mbCbFnPtrMv handle) = mask_ $ do - mbCbFnPtr <- takeMVar mbCbFnPtrMv - Foldable.forM_ mbCbFnPtr $ \cbFnPtr -> - withCtxPtr ctx $ \ctxPtr -> do - c'libusb_hotplug_deregister_callback ctxPtr handle - `onException` putMVar mbCbFnPtrMv mbCbFnPtr - freeHaskellFunPtr cbFnPtr - putMVar mbCbFnPtrMv Nothing - - --------------------------------------------------------------------------------- --- * Device location --------------------------------------------------------------------------------- - --- The following numbers are static variables in the libusb device --- structure. It's therefore safe to use unsafePerformIO: - --- | The number of the bus that a device is connected to. -busNumber :: Device -> Word8 -busNumber dev = unsafePerformIO $ withDevicePtr dev c'libusb_get_bus_number - --- | Get the number of the port that a is device connected to. Unless the OS --- does something funky, or you are hot-plugging USB extension cards, the port --- number returned by this call is usually guaranteed to be uniquely tied to a --- physical port, meaning that different devices plugged on the same physical --- port should return the same port number. --- --- But outside of this, there is no guarantee that the port number returned by --- this call will remain the same, or even match the order in which ports have --- been numbered by the HUB/HCD manufacturer. -portNumber :: Device -> Word8 -portNumber dev = unsafePerformIO $ withDevicePtr dev c'libusb_get_port_number - --- | Get the list of all port numbers from root for the specified device. -portNumbers :: Device - -> Int -- ^ The maximum number of ports allowed in the resulting - -- vector. If there are more ports than this number 'Nothing' - -- will be returned. As per the USB 3.0 specs, the current - -- maximum limit for the depth is 7. - -> Maybe (Vector Word8) -portNumbers dev m = unsafePerformIO $ - withDevicePtr dev $ \devPtr -> - allocaArray m $ \ptr -> do - n <- c'libusb_get_port_numbers devPtr ptr (fromIntegral m) - if n == c'LIBUSB_ERROR_OVERFLOW - then return Nothing - else Just . VG.convert <$> peekVector (fromIntegral n) ptr - --- | The address of the device on the bus it is connected to. -deviceAddress :: Device -> Word8 -deviceAddress dev = unsafePerformIO $ withDevicePtr dev c'libusb_get_device_address - - --------------------------------------------------------------------------------- --- * Device speed --------------------------------------------------------------------------------- - --- | Get the negotiated connection speed for a device. --- --- 'Nothing' means that the OS doesn't know or doesn't support returning the --- negotiated speed. -deviceSpeed :: Device -> Maybe Speed -deviceSpeed dev = unsafePerformIO $ withDevicePtr dev $ \devPtr -> - unmarshallSpeed <$> c'libusb_get_device_speed devPtr - -unmarshallSpeed :: CInt -> Maybe Speed -unmarshallSpeed speed | speed == c'LIBUSB_SPEED_UNKNOWN = Nothing - | otherwise = Just $ genToEnum (speed - 1) - --- | Speed codes. Indicates the speed at which the device is operating. -data Speed = LowSpeed -- ^ The device is operating at low speed (1.5MBit/s). - | FullSpeed -- ^ The device is operating at full speed (12MBit/s). - | HighSpeed -- ^ The device is operating at high speed (480MBit/s). - | SuperSpeed -- ^ The device is operating at super speed (5000MBit/s). - deriving (Enum, COMMON_INSTANCES) - - --------------------------------------------------------------------------------- --- * Device handling --------------------------------------------------------------------------------- - --------------------------------------------------------------------------------- --- ** Opening & closing devices --------------------------------------------------------------------------------- - -{-| Abstract type representing a handle of a USB device. - -You can acquire a handle from 'openDevice'. - -A device handle is used to perform I/O and other operations. When finished with -a device handle you should close it by applying 'closeDevice' to it. --} -data DeviceHandle = DeviceHandle - { getDevice :: !Device -- This reference is needed for keeping the 'Device' - -- and therefor the 'Ctx' alive. - -- ^ Retrieve the 'Device' from the 'DeviceHandle'. - , getDevHndlPtr :: !(Ptr C'libusb_device_handle) - } deriving Typeable - -instance Eq DeviceHandle where (==) = (==) `on` getDevHndlPtr - -instance Show DeviceHandle where - show devHndl = "{USB device handle to: " ++ show (getDevice devHndl) ++ "}" - --- | Operate the 'C'libusb_device_handle' pointer inside the 'DeviceHandle'. --- --- The 'Device' that the handle references and the 'Ctx' in which it was created --- are kept alive at least during the whole action, even if they are not used --- directly inside. -withDevHndlPtr :: DeviceHandle -> (Ptr C'libusb_device_handle -> IO a) -> IO a -withDevHndlPtr (DeviceHandle (Device ctx devFrgnPtr) devHndlPtr) f = do - x <- f devHndlPtr - touchForeignPtr devFrgnPtr - touchForeignPtr $ getCtxFrgnPtr ctx - return x - -{-| Open a device and obtain a device handle. - -A handle allows you to perform I/O on the device in question. - -This is a non-blocking function; no requests are sent over the bus. - -It is advisable to use 'withDeviceHandle' because it automatically closes the -device when the computation terminates. - -Exceptions: - - * 'NoMemException' if there is a memory allocation failure. - - * 'AccessException' if the user has insufficient permissions. - - * 'NoDeviceException' if the device has been disconnected. - - * Another 'USBException'. --} -openDevice :: Device -> IO DeviceHandle -openDevice dev = withDevicePtr dev $ \devPtr -> - alloca $ \devHndlPtrPtr -> do - handleUSBException $ c'libusb_open devPtr devHndlPtrPtr - DeviceHandle dev <$> peek devHndlPtrPtr - -{-| Close a device handle. - -Should be called on all open handles before your application exits. - -This is a non-blocking function; no requests are sent over the bus. --} -closeDevice :: DeviceHandle -> IO () -closeDevice devHndl = withDevHndlPtr devHndl c'libusb_close - -{-| @withDeviceHandle dev act@ opens the 'Device' @dev@ and passes -the resulting handle to the computation @act@. The handle will be closed on exit -from @withDeviceHandle@ whether by normal termination or by raising an -exception. --} -withDeviceHandle :: Device -> (DeviceHandle -> IO a) -> IO a -withDeviceHandle dev = bracket (openDevice dev) closeDevice - --------------------------------------------------------------------------------- --- ** Getting & setting the configuration --------------------------------------------------------------------------------- - --- | Identifier for configurations. --- --- Can be retrieved by 'getConfig' or by 'configValue'. -type ConfigValue = Word8 - -{-| Determine the value of the currently active configuration. - -You could formulate your own control request to obtain this information, but -this function has the advantage that it may be able to retrieve the information -from operating system caches (no I/O involved). - -If the OS does not cache this information, then this function will block while -a control transfer is submitted to retrieve the information. - -This function returns 'Nothing' if the device is in unconfigured state. - -Exceptions: - - * 'NoDeviceException' if the device has been disconnected. - - * Another 'USBException'. --} -getConfig :: DeviceHandle -> IO (Maybe ConfigValue) -getConfig devHndl = - alloca $ \configPtr -> do - withDevHndlPtr devHndl $ \devHndlPtr -> - handleUSBException $ c'libusb_get_configuration devHndlPtr configPtr - unmarshal <$> peek configPtr - where - unmarshal 0 = Nothing - unmarshal n = Just $ fromIntegral n - -{-| Set the active configuration for a device. - -The operating system may or may not have already set an active configuration on -the device. It is up to your application to ensure the correct configuration is -selected before you attempt to claim interfaces and perform other operations. - -If you call this function on a device already configured with the selected -configuration, then this function will act as a lightweight device reset: it -will issue a SET_CONFIGURATION request using the current configuration, causing -most USB-related device state to be reset (altsetting reset to zero, endpoint -halts cleared, toggles reset). - -You cannot change/reset configuration if your application has claimed interfaces -- you should free them with 'releaseInterface' first. You cannot change/reset -configuration if other applications or drivers have claimed interfaces. - -A configuration value of 'Nothing' will put the device in an unconfigured -state. The USB specification states that a configuration value of 0 does this, -however buggy devices exist which actually have a configuration 0. - -You should always use this function rather than formulating your own -SET_CONFIGURATION control request. This is because the underlying operating -system needs to know when such changes happen. - -This is a blocking function. - -Exceptions: - - * 'NotFoundException' if the requested configuration does not exist. - - * 'BusyException' if interfaces are currently claimed. - - * 'NoDeviceException' if the device has been disconnected - - * Another 'USBException'. --} -setConfig :: DeviceHandle -> Maybe ConfigValue -> IO () -setConfig devHndl config = - withDevHndlPtr devHndl $ \devHndlPtr -> - handleUSBException $ c'libusb_set_configuration devHndlPtr $ - marshal config - where - marshal = maybe (-1) fromIntegral - --------------------------------------------------------------------------------- --- ** Claiming & releasing interfaces --------------------------------------------------------------------------------- - -{-| Identifier for interfaces. - -Can be retrieved by 'interfaceNumber'. --} -type InterfaceNumber = Word8 - -{-| Claim an interface on a given device handle. - -You must claim the interface you wish to use before you can perform I/O on any -of its endpoints. - -It is legal to attempt to claim an already-claimed interface, in which case this -function just returns without doing anything. - -Claiming of interfaces is a purely logical operation; it does not cause any -requests to be sent over the bus. Interface claiming is used to instruct the -underlying operating system that your application wishes to take ownership of -the interface. - -This is a non-blocking function. - -Exceptions: - - * 'NotFoundException' if the requested interface does not exist. - - * 'BusyException' if the interface is already claimed. - - * 'NoDeviceException' if the device has been disconnected. - - * Another 'USBException'. --} - -claimInterface :: DeviceHandle -> InterfaceNumber -> IO () -claimInterface devHndl ifNum = - withDevHndlPtr devHndl $ \devHndlPtr -> - handleUSBException $ c'libusb_claim_interface devHndlPtr - (fromIntegral ifNum) - -{-| Release an interface previously claimed with 'claimInterface'. - -You should release all claimed interfaces before closing a device handle. - -This is a blocking function. A SET_INTERFACE control request will be sent to the -device, resetting interface state to the first alternate setting. - -Exceptions: - - * 'NotFoundException' if the interface was not claimed. - - * 'NoDeviceException' if the device has been disconnected - - * Another 'USBException'. --} -releaseInterface :: DeviceHandle -> InterfaceNumber -> IO () -releaseInterface devHndl ifNum = - withDevHndlPtr devHndl $ \devHndlPtr -> - handleUSBException $ c'libusb_release_interface devHndlPtr - (fromIntegral ifNum) - -{-| @withClaimedInterface@ claims the interface on the given device handle then -executes the given computation. On exit from @withClaimedInterface@, the -interface is released whether by normal termination or by raising an exception. --} -withClaimedInterface :: DeviceHandle -> InterfaceNumber -> IO a -> IO a -withClaimedInterface devHndl ifNum = bracket_ (claimInterface devHndl ifNum) - (releaseInterface devHndl ifNum) - --------------------------------------------------------------------------------- --- ** Setting interface alternate settings --------------------------------------------------------------------------------- - --- | Identifier for interface alternate settings. --- --- Can be retrieved by 'interfaceAltSetting'. -type InterfaceAltSetting = Word8 - -{-| Activate an alternate setting for an interface. - -The interface must have been previously claimed with 'claimInterface'. - -You should always use this function rather than formulating your own -SET_INTERFACE control request. This is because the underlying operating system -needs to know when such changes happen. - -This is a blocking function. - -Exceptions: - - * 'NotFoundException' if the interface was not claimed or the requested - alternate setting does not exist. - - * 'NoDeviceException' if the device has been disconnected. - - * Another 'USBException'. --} -setInterfaceAltSetting :: DeviceHandle - -> InterfaceNumber - -> InterfaceAltSetting - -> IO () -setInterfaceAltSetting devHndl ifNum alternateSetting = - withDevHndlPtr devHndl $ \devHndlPtr -> - handleUSBException $ - c'libusb_set_interface_alt_setting devHndlPtr - (fromIntegral ifNum) - (fromIntegral alternateSetting) - --------------------------------------------------------------------------------- --- ** Clearing & Resetting devices --------------------------------------------------------------------------------- - -{-| Clear the halt/stall condition for an endpoint. - -Endpoints with halt status are unable to receive or transmit data until the halt -condition is stalled. - -You should cancel all pending transfers before attempting to clear the halt -condition. - -This is a blocking function. - -Exceptions: - - * 'NotFoundException' if the endpoint does not exist. - - * 'NoDeviceException' if the device has been disconnected. - - * Another 'USBException'. --} -clearHalt :: DeviceHandle -> EndpointAddress -> IO () -clearHalt devHndl endpointAddr = - withDevHndlPtr devHndl $ \devHndlPtr -> - handleUSBException $ - c'libusb_clear_halt devHndlPtr (marshalEndpointAddress endpointAddr) - -{-| Perform a USB port reset to reinitialize a device. - -The system will attempt to restore the previous configuration and alternate -settings after the reset has completed. - -If the reset fails, the descriptors change, or the previous state cannot be -restored, the device will appear to be disconnected and reconnected. This means -that the device handle is no longer valid (you should close it) and rediscover -the device. A 'NotFoundException' is raised to indicate that this is the -case. - -This is a blocking function which usually incurs a noticeable delay. - -Exceptions: - - * 'NotFoundException' if re-enumeration is required, or if the - device has been disconnected. - - * Another 'USBException'. --} -resetDevice :: DeviceHandle -> IO () -resetDevice devHndl = withDevHndlPtr devHndl $ - handleUSBException . c'libusb_reset_device - --------------------------------------------------------------------------------- --- ** USB kernel drivers --------------------------------------------------------------------------------- - --- | Enable/disable @libusb's@ automatic kernel driver detachment. When this is --- enabled @libusb@ will automatically detach the kernel driver on an interface --- when claiming the interface, and attach it when releasing the interface. --- --- Automatic kernel driver detachment is disabled on newly opened device handles --- by default. --- --- On platforms which do not have the 'SupportsDetachKernelDriver' capability --- this function will throw a 'NotSupportedException', and @libusb@ will --- continue as if this function was never called. -setAutoDetachKernelDriver :: DeviceHandle -> Bool -> IO () -setAutoDetachKernelDriver devHndl enable = - withDevHndlPtr devHndl $ \devHndlPtr -> - handleUSBException $ c'libusb_set_auto_detach_kernel_driver - devHndlPtr (fromBool enable) - -{-| Determine if a kernel driver is active on an interface. - -If a kernel driver is active, you cannot claim the interface, and libusb will be -unable to perform I/O. - -Exceptions: - - * 'NoDeviceException' if the device has been disconnected. - - * Another 'USBException'. --} -kernelDriverActive :: DeviceHandle -> InterfaceNumber -> IO Bool -kernelDriverActive devHndl ifNum = - withDevHndlPtr devHndl $ \devHndlPtr -> do - r <- c'libusb_kernel_driver_active devHndlPtr (fromIntegral ifNum) - case r of - 0 -> return False - 1 -> return True - _ -> throwIO $ convertUSBException r - -{-| Detach a kernel driver from an interface. - -If successful, you will then be able to claim the interface and perform I/O. - -Exceptions: - - * 'NotFoundException' if no kernel driver was active. - - * 'InvalidParamException' if the interface does not exist. - - * 'NoDeviceException' if the device has been disconnected. - - * Another 'USBException'. --} -detachKernelDriver :: DeviceHandle -> InterfaceNumber -> IO () -detachKernelDriver devHndl ifNum = - withDevHndlPtr devHndl $ \devHndlPtr -> - handleUSBException $ c'libusb_detach_kernel_driver devHndlPtr - (fromIntegral ifNum) - -{-| Re-attach an interface's kernel driver, which was previously -detached using 'detachKernelDriver'. - -Exceptions: - - * 'NotFoundException' if no kernel driver was active. - - * 'InvalidParamException' if the interface does not exist. - - * 'NoDeviceException' if the device has been disconnected. - - * 'BusyException' if the driver cannot be attached because the interface - is claimed by a program or driver. - - * Another 'USBException'. --} -attachKernelDriver :: DeviceHandle -> InterfaceNumber -> IO () -attachKernelDriver devHndl ifNum = - withDevHndlPtr devHndl $ \devHndlPtr -> - handleUSBException $ c'libusb_attach_kernel_driver devHndlPtr - (fromIntegral ifNum) - -{-| If a kernel driver is active on the specified interface the driver is -detached and the given action is executed. If the action terminates, whether by -normal termination or by raising an exception, the kernel driver is attached -again. If a kernel driver is not active on the specified interface the action is -just executed. - -Exceptions: - - * 'NoDeviceException' if the device has been disconnected. - - * Another 'USBException'. --} -withDetachedKernelDriver :: DeviceHandle -> InterfaceNumber -> IO a -> IO a -withDetachedKernelDriver devHndl ifNum action = - ifM (kernelDriverActive devHndl ifNum) - (bracket_ (detachKernelDriver devHndl ifNum) - (attachKernelDriver devHndl ifNum) - action) - action - --------------------------------------------------------------------------------- --- * Descriptors --------------------------------------------------------------------------------- - --------------------------------------------------------------------------------- --- ** Device descriptor --------------------------------------------------------------------------------- - -{-| A structure representing the standard USB device descriptor. - -This descriptor is documented in section 9.6.1 of the USB 2.0 specification. - -This structure can be retrieved by 'getDeviceDesc'. --} -data DeviceDesc = DeviceDesc - { -- | USB specification release number. - deviceUSBSpecReleaseNumber :: !ReleaseNumber - - -- | USB-IF class code for the device. - , deviceClass :: !Word8 - - -- | USB-IF subclass code for the device, qualified by the 'deviceClass' - -- value. - , deviceSubClass :: !Word8 - - -- | USB-IF protocol code for the device, qualified by the 'deviceClass' - -- and 'deviceSubClass' values. - , deviceProtocol :: !Word8 - - -- | Maximum packet size for endpoint 0. - , deviceMaxPacketSize0 :: !Word8 - - -- | USB-IF vendor ID. - , deviceVendorId :: !VendorId - - -- | USB-IF product ID. - , deviceProductId :: !ProductId - - -- | Device release number. - , deviceReleaseNumber :: !ReleaseNumber - - -- | Optional index of string descriptor describing manufacturer. - , deviceManufacturerStrIx :: !(Maybe StrIx) - - -- | Optional index of string descriptor describing product. - , deviceProductStrIx :: !(Maybe StrIx) - - -- | Optional index of string descriptor containing device serial number. - , deviceSerialNumberStrIx :: !(Maybe StrIx) - - -- | Number of possible configurations. - , deviceNumConfigs :: !Word8 - } deriving (COMMON_INSTANCES) - --- | Release \/ version number of the USB specification \/ device. -type ReleaseNumber = (Int, Int, Int, Int) - --- | A 16-bit number used to identify a USB device. Each vendor ID is assigned --- by the USB Implementers Forum to a specific company. -type VendorId = Word16 - --- | A 16-bit number used to identify a USB device. Each company which is --- assigned a 'VendorId' can assign a product ID to its USB-based products. -type ProductId = Word16 - --------------------------------------------------------------------------------- --- ** Configuration descriptor --------------------------------------------------------------------------------- - -{-| A structure representing the standard USB configuration descriptor. - -This descriptor is documented in section 9.6.3 of the USB 2.0 specification. - -This structure can be retrieved by 'getConfigDesc'. --} -data ConfigDesc = ConfigDesc - { -- | Identifier value for the configuration. - configValue :: !ConfigValue - - -- | Optional index of string descriptor describing the configuration. - , configStrIx :: !(Maybe StrIx) - - -- | Configuration characteristics. - , configAttribs :: !ConfigAttribs - - -- | Maximum power consumption of the USB device from the bus in the - -- configuration when the device is fully operational. Expressed in 2 mA - -- units (i.e., 50 = 100 mA). - , configMaxPower :: !Word8 - - -- | Vector of interfaces supported by the configuration. - , configInterfaces :: !(Vector Interface) - - -- | Extra descriptors. If @libusb@ encounters unknown configuration - -- descriptors, it will store them here, should you wish to parse them. - , configExtra :: !B.ByteString - - } deriving (COMMON_INSTANCES) - --------------------------------------------------------------------------------- --- *** Configuration attributes --------------------------------------------------------------------------------- - --- | The USB 2.0 specification specifies that the configuration attributes only --- describe the device status. -type ConfigAttribs = DeviceStatus - --- | The status of a USB device. -data DeviceStatus = DeviceStatus - { remoteWakeup :: !Bool -- ^ The Remote Wakeup field indicates whether the - -- device is currently enabled to request remote - -- wakeup. The default mode for devices that - -- support remote wakeup is disabled. - , selfPowered :: !Bool -- ^ The Self Powered field indicates whether the - -- device is currently self-powered - } deriving (COMMON_INSTANCES) - --------------------------------------------------------------------------------- --- ** Interface descriptor --------------------------------------------------------------------------------- - --- | An interface is represented as a vector of alternate interface settings. -type Interface = Vector InterfaceDesc - -{-| A structure representing the standard USB interface descriptor. - -This descriptor is documented in section 9.6.5 of the USB 2.0 specification. - -This structure can be retrieved using 'configInterfaces'. --} -data InterfaceDesc = InterfaceDesc - { -- | Number of the interface. - interfaceNumber :: !InterfaceNumber - - -- | Value used to select the alternate setting for the interface. - , interfaceAltSetting :: !InterfaceAltSetting - - -- | USB-IF class code for the interface. - , interfaceClass :: !Word8 - - -- | USB-IF subclass code for the interface, qualified by the - -- 'interfaceClass' value. - , interfaceSubClass :: !Word8 - - -- | USB-IF protocol code for the interface, qualified by the - -- 'interfaceClass' and 'interfaceSubClass' values. - , interfaceProtocol :: !Word8 - - -- | Optional index of string descriptor describing the interface. - , interfaceStrIx :: !(Maybe StrIx) - - -- | Vector of endpoints supported by the interface. - , interfaceEndpoints :: !(Vector EndpointDesc) - - -- | Extra descriptors. If @libusb@ encounters unknown interface - -- descriptors, it will store them here, should you wish to parse them. - , interfaceExtra :: !B.ByteString - } deriving (COMMON_INSTANCES) - --------------------------------------------------------------------------------- --- ** Endpoint descriptor --------------------------------------------------------------------------------- - -{-| A structure representing the standard USB endpoint descriptor. - -This descriptor is documented in section 9.6.3 of the USB 2.0 specification. - -This structure can be retrieved by using 'interfaceEndpoints'. --} -data EndpointDesc = EndpointDesc - { -- | The address of the endpoint described by the descriptor. - endpointAddress :: !EndpointAddress - - -- | Attributes which apply to the endpoint when it is configured using the - -- 'configValue'. - , endpointAttribs :: !EndpointAttribs - - -- | Maximum packet size the endpoint is capable of sending/receiving. - , endpointMaxPacketSize :: !MaxPacketSize - - -- | Interval for polling endpoint for data transfers. Expressed in frames - -- or microframes depending on the device operating speed (i.e., either 1 - -- millisecond or 125 μs units). - , endpointInterval :: !Word8 - - -- | /For audio devices only:/ the rate at which synchronization feedback - -- is provided. - , endpointRefresh :: !Word8 - - -- | /For audio devices only:/ the address of the synch endpoint. - , endpointSynchAddress :: !Word8 - - -- | Extra descriptors. If @libusb@ encounters unknown endpoint descriptors, - -- it will store them here, should you wish to parse them. - , endpointExtra :: !B.ByteString - } deriving (COMMON_INSTANCES) - --------------------------------------------------------------------------------- --- *** Endpoint address --------------------------------------------------------------------------------- - --- | The address of an endpoint. -data EndpointAddress = EndpointAddress - { endpointNumber :: !Int - -- ^ Must be >= 0 and <= 15 - , transferDirection :: !TransferDirection - -- ^ The direction of data transfer relative to the host of this endpoint. - } deriving (COMMON_INSTANCES) - --- | The direction of data transfer relative to the host. -data TransferDirection = Out -- ^ Out transfer direction (host -> device) used - -- for writing. - | In -- ^ In transfer direction (device -> host) used - -- for reading. - deriving (Enum, COMMON_INSTANCES) - --------------------------------------------------------------------------------- --- *** Endpoint attributes --------------------------------------------------------------------------------- - --- | The USB 2.0 specification specifies that the endpoint attributes only --- describe the endpoint transfer type. -type EndpointAttribs = TransferType - --- | Describes what types of transfers are allowed on the endpoint. -data TransferType = - -- | Control transfers are typically used for command and status - -- operations. - Control - - -- | Isochronous transfers occur continuously and periodically. - | Isochronous !Synchronization !Usage - - -- | Bulk transfers can be used for large bursty data. - | Bulk - - -- | Interrupt transfers are typically non-periodic, small device - -- \"initiated\" communication requiring bounded latency. - | Interrupt - deriving (COMMON_INSTANCES) - --- | See section 5.12.4.1 of the USB 2.0 specification. -data Synchronization = - NoSynchronization -- ^ No Synchonisation. - | Asynchronous -- ^ Unsynchronized, - -- although sinks provide data rate feedback. - | Adaptive -- ^ Synchronized using feedback or feedforward - -- data rate information - | Synchronous -- ^ Synchronized to the USB’s SOF (/Start Of Frame/) - deriving (Enum, COMMON_INSTANCES) - --- | See section 5.12.4.2 of the USB 2.0 specification. -data Usage = Data - | Feedback - | Implicit - deriving (Enum, COMMON_INSTANCES) - --------------------------------------------------------------------------------- --- *** Endpoint max packet size --------------------------------------------------------------------------------- - --- | Maximum packet size. -data MaxPacketSize = MaxPacketSize - { maxPacketSize :: !Size - , transactionOpportunities :: !TransactionOpportunities - } deriving (COMMON_INSTANCES) - --- | Number of additional transaction oppurtunities per microframe. --- --- See table 9-13 of the USB 2.0 specification. -data TransactionOpportunities = Zero -- ^ None (1 transaction per microframe) - | One -- ^ 1 additional (2 per microframe) - | Two -- ^ 2 additional (3 per microframe) - deriving (Enum, Ord, COMMON_INSTANCES) - -{-| Calculate the maximum packet size which a specific endpoint is capable of -sending or receiving in the duration of 1 microframe. - -If acting on an 'Isochronous' or 'Interrupt' endpoint, this function will -multiply the 'maxPacketSize' by the additional 'transactionOpportunities'. -If acting on another type of endpoint only the 'maxPacketSize' is returned. - -This function is mainly useful for setting up /isochronous/ transfers. --} -maxIsoPacketSize :: EndpointDesc -> Size -maxIsoPacketSize epDesc | isochronousOrInterrupt = mps * (1 + fromEnum to) - | otherwise = mps - where - MaxPacketSize mps to = endpointMaxPacketSize epDesc - - isochronousOrInterrupt = case endpointAttribs epDesc of - Isochronous _ _ -> True - Interrupt -> True - _ -> False - --------------------------------------------------------------------------------- --- ** Retrieving and converting descriptors --------------------------------------------------------------------------------- - --- | Get the USB device descriptor for a given device. --- --- This is a non-blocking function; the device descriptor is cached in memory. --- --- This function may throw 'USBException's. -getDeviceDesc :: Device -> IO DeviceDesc -getDeviceDesc dev = - withDevicePtr dev $ \devPtr -> - convertDeviceDesc <$> - allocaPeek (handleUSBException . c'libusb_get_device_descriptor devPtr) - -convertDeviceDesc :: C'libusb_device_descriptor -> DeviceDesc -convertDeviceDesc d = DeviceDesc - { deviceUSBSpecReleaseNumber = unmarshalReleaseNumber $ - c'libusb_device_descriptor'bcdUSB d - , deviceClass = c'libusb_device_descriptor'bDeviceClass d - , deviceSubClass = c'libusb_device_descriptor'bDeviceSubClass d - , deviceProtocol = c'libusb_device_descriptor'bDeviceProtocol d - , deviceMaxPacketSize0 = c'libusb_device_descriptor'bMaxPacketSize0 d - , deviceVendorId = c'libusb_device_descriptor'idVendor d - , deviceProductId = c'libusb_device_descriptor'idProduct d - , deviceReleaseNumber = unmarshalReleaseNumber $ - c'libusb_device_descriptor'bcdDevice d - , deviceManufacturerStrIx = unmarshalStrIx $ - c'libusb_device_descriptor'iManufacturer d - , deviceProductStrIx = unmarshalStrIx $ - c'libusb_device_descriptor'iProduct d - , deviceSerialNumberStrIx = unmarshalStrIx $ - c'libusb_device_descriptor'iSerialNumber d - , deviceNumConfigs = c'libusb_device_descriptor'bNumConfigurations d - } - --- | Unmarshal a a 16bit word as a release number. The 16bit word should be --- encoded as a --- --- using 4 bits for each of the 4 decimals. -unmarshalReleaseNumber :: Word16 -> ReleaseNumber -unmarshalReleaseNumber abcd = (a, b, c, d) - where - a = fromIntegral $ abcd `shiftR` 12 - b = fromIntegral $ (abcd `shiftL` 4) `shiftR` 12 - c = fromIntegral $ (abcd `shiftL` 8) `shiftR` 12 - d = fromIntegral $ (abcd `shiftL` 12) `shiftR` 12 - --- | Unmarshal an 8bit word to a string descriptor index. 0 denotes that a --- string descriptor is not available and unmarshals to 'Nothing'. -unmarshalStrIx :: Word8 -> Maybe StrIx -unmarshalStrIx 0 = Nothing -unmarshalStrIx strIx = Just strIx - --- | Get a USB configuration descriptor based on its index. --- --- This is a non-blocking function which does not involve any requests --- being sent to the device. --- --- Exceptions: --- --- * 'NotFoundException' if the configuration does not exist. --- --- * Another 'USBException'. -getConfigDesc :: Device -> Word8 -> IO ConfigDesc -getConfigDesc dev ix = withDevicePtr dev $ \devPtr -> - bracket (allocaPeek $ handleUSBException - . c'libusb_get_config_descriptor devPtr ix) - c'libusb_free_config_descriptor - ((convertConfigDesc =<<) . peek) - -convertConfigDesc :: C'libusb_config_descriptor -> IO ConfigDesc -convertConfigDesc c = do - interfaces <- mapPeekArray convertInterface - (fromIntegral $ c'libusb_config_descriptor'bNumInterfaces c) - (c'libusb_config_descriptor'interface c) - - extra <- getExtra (c'libusb_config_descriptor'extra c) - (c'libusb_config_descriptor'extra_length c) - - return ConfigDesc - { configValue = c'libusb_config_descriptor'bConfigurationValue c - , configStrIx = unmarshalStrIx $ - c'libusb_config_descriptor'iConfiguration c - , configAttribs = unmarshalConfigAttribs $ - c'libusb_config_descriptor'bmAttributes c - , configMaxPower = c'libusb_config_descriptor'MaxPower c - , configInterfaces = interfaces - , configExtra = extra - } - -unmarshalConfigAttribs :: Word8 -> ConfigAttribs -unmarshalConfigAttribs a = DeviceStatus { remoteWakeup = testBit a 5 - , selfPowered = testBit a 6 - } - -getExtra :: Ptr CUChar -> CInt -> IO B.ByteString -getExtra extra extraLength = B.packCStringLen ( castPtr extra - , fromIntegral extraLength - ) - -convertInterface :: C'libusb_interface -> IO Interface -convertInterface i = - mapPeekArray convertInterfaceDesc - (fromIntegral $ c'libusb_interface'num_altsetting i) - (c'libusb_interface'altsetting i) - -convertInterfaceDesc :: C'libusb_interface_descriptor -> IO InterfaceDesc -convertInterfaceDesc i = do - endpoints <- mapPeekArray convertEndpointDesc - (fromIntegral $ c'libusb_interface_descriptor'bNumEndpoints i) - (c'libusb_interface_descriptor'endpoint i) - - extra <- getExtra (c'libusb_interface_descriptor'extra i) - (c'libusb_interface_descriptor'extra_length i) - - return InterfaceDesc - { interfaceNumber = c'libusb_interface_descriptor'bInterfaceNumber i - , interfaceAltSetting = c'libusb_interface_descriptor'bAlternateSetting i - , interfaceClass = c'libusb_interface_descriptor'bInterfaceClass i - , interfaceSubClass = c'libusb_interface_descriptor'bInterfaceSubClass i - , interfaceStrIx = unmarshalStrIx $ - c'libusb_interface_descriptor'iInterface i - , interfaceProtocol = c'libusb_interface_descriptor'bInterfaceProtocol i - , interfaceEndpoints = endpoints - , interfaceExtra = extra - } - -convertEndpointDesc :: C'libusb_endpoint_descriptor -> IO EndpointDesc -convertEndpointDesc e = do - extra <- getExtra (c'libusb_endpoint_descriptor'extra e) - (c'libusb_endpoint_descriptor'extra_length e) - - return EndpointDesc - { endpointAddress = unmarshalEndpointAddress $ - c'libusb_endpoint_descriptor'bEndpointAddress e - , endpointAttribs = unmarshalEndpointAttribs $ - c'libusb_endpoint_descriptor'bmAttributes e - , endpointMaxPacketSize = unmarshalMaxPacketSize $ - c'libusb_endpoint_descriptor'wMaxPacketSize e - , endpointInterval = c'libusb_endpoint_descriptor'bInterval e - , endpointRefresh = c'libusb_endpoint_descriptor'bRefresh e - , endpointSynchAddress = c'libusb_endpoint_descriptor'bSynchAddress e - , endpointExtra = extra - } - --- | Unmarshal an 8bit word as an endpoint address. This function is primarily --- used when unmarshalling USB descriptors. -unmarshalEndpointAddress :: Word8 -> EndpointAddress -unmarshalEndpointAddress a = - EndpointAddress { endpointNumber = fromIntegral $ bits 0 3 a - , transferDirection = if testBit a 7 then In else Out - } - --- | Marshal an endpoint address so that it can be used by the @libusb@ transfer --- functions. -marshalEndpointAddress :: (Bits a, Num a) => EndpointAddress -> a -marshalEndpointAddress (EndpointAddress num transDir) = - assert (between num 0 15) $ let n = fromIntegral num - in case transDir of - Out -> n - In -> setBit n 7 - -unmarshalEndpointAttribs :: Word8 -> EndpointAttribs -unmarshalEndpointAttribs a = - case bits 0 1 a of - 0 -> Control - 1 -> Isochronous (genToEnum $ bits 2 3 a) - (genToEnum $ bits 4 5 a) - 2 -> Bulk - 3 -> Interrupt - _ -> moduleError "unmarshalEndpointAttribs: this can't happen!" - -unmarshalMaxPacketSize :: Word16 -> MaxPacketSize -unmarshalMaxPacketSize m = - MaxPacketSize - { maxPacketSize = fromIntegral $ bits 0 10 m - , transactionOpportunities = genToEnum $ bits 11 12 m - } - --------------------------------------------------------------------------------- --- ** String descriptors --------------------------------------------------------------------------------- - --- | The size in number of bytes of the header of string descriptors. -strDescHeaderSize :: Size -strDescHeaderSize = 2 - --- | Characters are encoded as UTF16LE so each character takes two bytes. -charSize :: Size -charSize = 2 - -{-| Retrieve a vector of supported languages. - -This function may throw 'USBException's. --} -getLanguages :: DeviceHandle -> IO (Vector LangId) -getLanguages devHndl = allocaArray maxSize $ \dataPtr -> do - let strIx = 0 - langId = 0 - reportedSize <- retrieveStrDesc devHndl strIx langId maxSize dataPtr - - let strSize = (reportedSize - strDescHeaderSize) `div` charSize - strPtr = castPtr $ dataPtr `plusPtr` strDescHeaderSize - - (VG.map unmarshalLangId . VG.convert) <$> peekVector strSize strPtr - where - maxSize = 255 -- Some devices choke on size > 255 - -{-| @retrieveStrDesc devHndl strIx langId maxSize dataPtr@ retrieves the string -descriptor @strIx@ in the language @langId@ from the @devHndl@ and writes at -most @maxSize@ bytes from that string descriptor to the location that @dataPtr@ -points to. So ensure there is at least space for @maxSize@ bytes there. Next, -the header of the string descriptor is checked for correctness. If it's -incorrect an 'IOException' is thrown. Finally, the size reported in the header -is returned. --} -retrieveStrDesc :: DeviceHandle - -> StrIx - -> Word16 - -> Size - -> Ptr CUChar - -> IO Size -retrieveStrDesc devHndl strIx langId maxSize dataPtr = do - actualSize <- withDevHndlPtr devHndl $ \devHndlPtr -> - checkUSBException $ c'libusb_get_string_descriptor - devHndlPtr - strIx - langId - dataPtr - (fromIntegral maxSize) - when (actualSize < strDescHeaderSize) $ - throwIO $ IOException "Incomplete header" - - reportedSize <- peek dataPtr - - when (reportedSize > fromIntegral actualSize) $ - throwIO $ IOException "Not enough space to hold data" - - descType <- peekElemOff dataPtr 1 - - when (descType /= c'LIBUSB_DT_STRING) $ - throwIO $ IOException "Invalid header" - - return $ fromIntegral reportedSize - -{-| The language ID consists of the primary language identifier and the -sublanguage identififier as described in: - - - -For a mapping between IDs and languages see the - package. - -To see which 'LangId's are supported by a device see 'getLanguages'. --} -type LangId = (PrimaryLangId, SubLangId) - --- | The primary language identifier. -type PrimaryLangId = Word16 - --- | The sublanguage identifier. -type SubLangId = Word16 - -unmarshalLangId :: Word16 -> LangId -unmarshalLangId = bits 0 9 &&& bits 10 15 - -marshalLangId :: LangId -> Word16 -marshalLangId (p, s) = p .|. s `shiftL`10 - --- | Type of indici of string descriptors. --- --- Can be retrieved by all the *StrIx functions. -type StrIx = Word8 - -{-| Retrieve a string descriptor from a device. - -This function may throw 'USBException's. --} -getStrDesc :: DeviceHandle - -> StrIx - -> LangId - -> Int -- ^ Maximum number of characters in the requested string. An - -- 'IOException' will be thrown when the requested string is - -- larger than this number. - -> IO Text -getStrDesc devHndl strIx langId nrOfChars = assert (strIx /= 0) $ - fmap decode $ BI.createAndTrim size $ write . castPtr - where - write = retrieveStrDesc devHndl strIx (marshalLangId langId) size - size = strDescHeaderSize + nrOfChars * charSize - decode = TE.decodeUtf16LE . B.drop strDescHeaderSize - -{-| Retrieve a string descriptor from a device using the first supported language. - -This function may throw 'USBException's. --} -getStrDescFirstLang :: DeviceHandle - -> StrIx - -> Int -- ^ Maximum number of characters in the requested - -- string. An 'IOException' will be thrown when the - -- requested string is larger than this number. - -> IO Text -getStrDescFirstLang devHndl strIx nrOfChars = do - langIds <- getLanguages devHndl - case V.uncons langIds of - Nothing -> throwIO $ IOException "Zero languages" - Just (langId, _) -> getStrDesc devHndl strIx langId nrOfChars - --------------------------------------------------------------------------------- --- * I/O --------------------------------------------------------------------------------- - -{-| Handy type synonym for read transfers. - -A @ReadAction@ is a function which takes a 'Size' which defines how many bytes -to read and a 'Timeout'. The function returns an 'IO' action which, when -executed, performs the actual read and returns the 'B.ByteString' that was read -paired with a 'Status' flag which indicates whether the transfer -'Completed' or 'TimedOut'. --} -type ReadAction = Size -> Timeout -> IO (B.ByteString, Status) - --- | Handy type synonym for read transfers that must exactly read the specified --- number of bytes. An 'incompleteReadException' is thrown otherwise. -type ReadExactAction = Size -> Timeout -> IO B.ByteString - -{-| Handy type synonym for write transfers. - -A @WriteAction@ is a function which takes a 'B.ByteString' to write and a -'Timeout'. The function returns an 'IO' action which, when exectued, returns the -number of bytes that were actually written paired with a 'Status' flag which -indicates whether the transfer 'Completed' or 'TimedOut'. --} -type WriteAction = B.ByteString -> Timeout -> IO (Size, Status) - --- | Handy type synonym for write transfers that must exactly write all the --- given bytes. An 'incompleteWriteException' is thrown otherwise. -type WriteExactAction = B.ByteString -> Timeout -> IO () - --- | Number of bytes transferred. -type Size = Int - --- | A timeout in milliseconds. A timeout defines how long a transfer should wait --- before giving up due to no response being received. --- Use 'noTimeout' for no timeout. -type Timeout = Int - --- | A timeout of 0 denotes no timeout so: @noTimeout = 0@. -noTimeout :: Timeout -noTimeout = 0 - --- | Status of a terminated transfer. -data Status = Completed -- ^ All bytes were transferred - -- within the maximum allowed 'Timeout' period. - | TimedOut -- ^ Not all bytes were transferred - -- within the maximum allowed 'Timeout' period. - deriving (COMMON_INSTANCES) - -------------------------------------------------------------------------------- --- ** Types of control transfers -------------------------------------------------------------------------------- - --- | Setup for control transfers. -data ControlSetup = ControlSetup - { controlSetupRequestType :: !RequestType -- ^ The type of request. - , controlSetupRecipient :: !Recipient -- ^ The recipient of the request. - , controlSetupRequest :: !Request -- ^ The numeric request. - , controlSetupValue :: !Value -- ^ The value. - , controlSetupIndex :: !Index -- ^ The index. - } deriving (COMMON_INSTANCES) - - -marshallControlSetup :: ControlSetup -> - TransferDirection -> - Size -> C'libusb_control_setup -marshallControlSetup (ControlSetup reqType reqRecipient request value index) - reqDir size = - C'libusb_control_setup requestType - request value index - (fromIntegral size) - where - requestType = marshalRequestType reqType reqRecipient reqDir - --- | The type of control requests. -data RequestType = - Standard - -- ^ Standard requests are common to all USB device's. - | Class - -- ^ Class requests are common to classes of drivers. For example, all - -- device's conforming to the HID class will have a common set of class - -- specific requests. These will differ to a device conforming to the - -- communications class and differ again to that of a device conforming - -- to the mass storage class. - | Vendor - -- ^ These are requests which the USB device designer (you?) can - -- assign. These are normally different from device to device, but this - -- is all up to your implementation and imagination. - deriving (Enum, COMMON_INSTANCES) - --- | A common request can be directed to different recipients and based on the --- recipient perform different functions. A @GetStatus@ 'Standard' request for --- example, can be directed at the device, interface or endpoint. When directed --- to a device it returns flags indicating the status of remote wakeup and if --- the device is self powered. However if the same request is directed at the --- interface it always returns zero, or should it be directed at an endpoint --- will return the halt flag for the endpoint. -data Recipient = ToDevice -- ^ Directed to the device. - | ToInterface -- ^ Directed to the interface. - | ToEndpoint -- ^ Directed to the endpoint. - | ToOther -- ^ Directed to something other than the device, - -- interface or endpoint. - deriving (Enum, COMMON_INSTANCES) - --- | The actual request code. -type Request = Word8 - --- | A potential additional parameter for the request. --- --- (Host-endian) -type Value = Word16 - --- | A potential additional parameter for the request. Usually used as an index --- or offset. --- --- (Host-endian) -type Index = Word16 - -marshalRequestType :: RequestType -> Recipient -> TransferDirection -> Word8 -marshalRequestType t r d = genFromEnum d `shiftL` 7 .|. - genFromEnum t `shiftL` 5 .|. - genFromEnum r - --------------------------------------------------------------------------------- --- ** Control transfers --------------------------------------------------------------------------------- - -{-| Perform a USB /control/ request that does not transfer data. - -Exceptions: - - * 'TimeoutException' if the transfer timed out. - - * 'PipeException' if the control request was not supported by the device - - * 'NoDeviceException' if the device has been disconnected. - - * Another 'USBException'. --} -control :: DeviceHandle -> ControlSetup -> Timeout -> IO () -control devHndl ctrlSetup timeout = do - (_, status) <- doControl - when (status == TimedOut) $ throwIO TimeoutException - where - doControl -#ifdef HAS_EVENT_MANAGER - | Just wait <- getWait devHndl = - allocaBytes controlSetupSize $ \bufferPtr -> do - poke bufferPtr $ marshallControlSetup ctrlSetup Out 0 - transferAsync wait - c'LIBUSB_TRANSFER_TYPE_CONTROL - devHndl - controlEndpoint - timeout - (bufferPtr, controlSetupSize) -#endif - | otherwise = controlTransferSync devHndl ctrlSetup Out timeout (nullPtr, 0) - --------------------------------------------------------------------------------- - -{-| Perform a USB /control/ read. - -Exceptions: - - * 'PipeException' if the control request was not supported by the device - - * 'NoDeviceException' if the device has been disconnected. - - * Another 'USBException'. --} -readControl :: DeviceHandle -> ControlSetup -> ReadAction -readControl devHndl ctrlSetup size timeout -#ifdef HAS_EVENT_MANAGER - | Just wait <- getWait devHndl = do - let totalSize = controlSetupSize + size - allocaBytes totalSize $ \bufferPtr -> do - poke bufferPtr $ marshallControlSetup ctrlSetup In size - (transferred, status) <- transferAsync wait - c'LIBUSB_TRANSFER_TYPE_CONTROL - devHndl controlEndpoint - timeout - (bufferPtr, totalSize) - bs <- BI.create transferred $ \dataPtr -> - copyArray dataPtr (bufferPtr `plusPtr` controlSetupSize) transferred - return (bs, status) -#endif - | otherwise = createAndTrimNoOffset size $ \dataPtr -> - controlTransferSync devHndl ctrlSetup In timeout (dataPtr, size) - --- | A convenience function similar to 'readControl' which checks if the --- specified number of bytes to read were actually read. --- Throws an 'incompleteReadException' if this is not the case. -readControlExact :: DeviceHandle -> ControlSetup -> ReadExactAction -readControlExact devHndl ctrlSetup size timeout = do - (bs, _) <- readControl devHndl ctrlSetup size timeout - if B.length bs /= size - then throwIO incompleteReadException - else return bs - --------------------------------------------------------------------------------- - - -{-| Perform a USB /control/ write. - -Exceptions: - - * 'PipeException' if the control request was not supported by the device - - * 'NoDeviceException' if the device has been disconnected. - - * Another 'USBException'. --} -writeControl :: DeviceHandle -> ControlSetup -> WriteAction -writeControl devHndl ctrlSetup input timeout -#ifdef HAS_EVENT_MANAGER - | Just wait <- getWait devHndl = - BU.unsafeUseAsCStringLen input $ \(dataPtr, size) -> do - let totalSize = controlSetupSize + size - allocaBytes totalSize $ \bufferPtr -> do - poke bufferPtr $ marshallControlSetup ctrlSetup Out size - copyArray (bufferPtr `plusPtr` controlSetupSize) dataPtr size - transferAsync wait - c'LIBUSB_TRANSFER_TYPE_CONTROL - devHndl controlEndpoint - timeout - (bufferPtr, totalSize) -#endif - | otherwise = BU.unsafeUseAsCStringLen input $ - controlTransferSync devHndl ctrlSetup Out timeout - --- | A convenience function similar to 'writeControl' which checks if the given --- bytes were actually fully written. --- Throws an 'incompleteWriteException' if this is not the case. -writeControlExact :: DeviceHandle -> ControlSetup -> WriteExactAction -writeControlExact devHndl ctrlSetup input timeout = do - (transferred, _) <- writeControl devHndl ctrlSetup input timeout - when (transferred /= B.length input) $ throwIO incompleteWriteException - --------------------------------------------------------------------------------- - -#ifdef HAS_EVENT_MANAGER -controlSetupSize :: Size -controlSetupSize = sizeOf (undefined :: C'libusb_control_setup) - -controlEndpoint :: CUChar -controlEndpoint = 0 -#endif - -controlTransferSync :: DeviceHandle - -> ControlSetup - -> TransferDirection - -> Timeout - -> (Ptr byte, Size) - -> IO (Size, Status) -controlTransferSync devHndl - (ControlSetup reqType reqRecipient request value index) - reqDir - timeout - (dataPtr, size) = do - err <- withDevHndlPtr devHndl $ \devHndlPtr -> - c'libusb_control_transfer devHndlPtr - requestType request value index - (castPtr dataPtr) (fromIntegral size) - (fromIntegral timeout) - let timedOut = err == c'LIBUSB_ERROR_TIMEOUT - if err < 0 && not timedOut - then throwIO $ convertUSBException err - else return ( fromIntegral err - , if timedOut then TimedOut else Completed - ) - where - requestType = marshalRequestType reqType reqRecipient reqDir - - --------------------------------------------------------------------------------- --- ** Bulk transfers --------------------------------------------------------------------------------- - -{-| Perform a USB /bulk/ read. - -Exceptions: - - * 'PipeException' if the endpoint halted. - - * 'OverflowException' if the device offered more data, see - - in the @libusb@ documentation. - - * 'NoDeviceException' if the device has been disconnected. - - * Another 'USBException'. --} -readBulk :: DeviceHandle - -> EndpointAddress -- ^ Make sure 'transferDirection' is set to 'In'. - -> ReadAction -readBulk devHndl -#ifdef HAS_EVENT_MANAGER - | Just wait <- getWait devHndl = - readTransferAsync wait c'LIBUSB_TRANSFER_TYPE_BULK devHndl -#endif - | otherwise = readTransferSync c'libusb_bulk_transfer devHndl - -{-| Perform a USB /bulk/ write. - -Exceptions: - - * 'PipeException' if the endpoint halted. - - * 'OverflowException' if the device offered more data, see - - in the @libusb@ documentation. - - * 'NoDeviceException' if the device has been disconnected. - - * Another 'USBException'. --} -writeBulk :: DeviceHandle - -> EndpointAddress -- ^ Make sure 'transferDirection' is set to 'Out'. - -> WriteAction -writeBulk devHndl -#ifdef HAS_EVENT_MANAGER - | Just wait <- getWait devHndl = - writeTransferAsync wait c'LIBUSB_TRANSFER_TYPE_BULK devHndl -#endif - | otherwise = writeTransferSync c'libusb_bulk_transfer devHndl - --------------------------------------------------------------------------------- --- ** Interrupt transfers --------------------------------------------------------------------------------- - -{-| Perform a USB /interrupt/ read. - -Exceptions: - - * 'PipeException' if the endpoint halted. - - * 'OverflowException' if the device offered more data, see - - in the @libusb@ documentation. - - * 'NoDeviceException' if the device has been disconnected. - - * Another 'USBException'. --} -readInterrupt :: DeviceHandle - -> EndpointAddress -- ^ Make sure 'transferDirection' is set to 'In'. - -> ReadAction -readInterrupt devHndl -#ifdef HAS_EVENT_MANAGER - | Just wait <- getWait devHndl = - readTransferAsync wait c'LIBUSB_TRANSFER_TYPE_INTERRUPT devHndl -#endif - | otherwise = readTransferSync c'libusb_interrupt_transfer devHndl - - -{-| Perform a USB /interrupt/ write. - -Exceptions: - - * 'PipeException' if the endpoint halted. - - * 'OverflowException' if the device offered more data, see - - in the @libusb@ documentation. - - * 'NoDeviceException' if the device has been disconnected. - - * Another 'USBException'. --} -writeInterrupt :: DeviceHandle - -> EndpointAddress -- ^ Make sure 'transferDirection' is set to 'Out'. - -> WriteAction -writeInterrupt devHndl -#ifdef HAS_EVENT_MANAGER - | Just wait <- getWait devHndl = - writeTransferAsync wait c'LIBUSB_TRANSFER_TYPE_INTERRUPT devHndl -#endif - | otherwise = writeTransferSync c'libusb_interrupt_transfer devHndl - --------------------------------------------------------------------------------- - --- | Handy type synonym for the @libusb@ transfer functions. -type C'TransferFunc = Ptr C'libusb_device_handle -- devHndlPtr - -> CUChar -- endpoint address - -> Ptr CUChar -- dataPtr - -> CInt -- size - -> Ptr CInt -- transferredPtr - -> CUInt -- timeout - -> IO CInt -- error - -readTransferSync :: C'TransferFunc -> (DeviceHandle -> EndpointAddress -> ReadAction) -readTransferSync c'transfer = \devHndl endpointAddr -> \size timeout -> - createAndTrimNoOffset size $ \dataPtr -> - transferSync c'transfer - devHndl endpointAddr - timeout - (castPtr dataPtr, size) - -writeTransferSync :: C'TransferFunc -> (DeviceHandle -> EndpointAddress -> WriteAction) -writeTransferSync c'transfer = \devHndl endpointAddr -> \input timeout -> - BU.unsafeUseAsCStringLen input $ - transferSync c'transfer - devHndl endpointAddr - timeout - -transferSync :: C'TransferFunc -> DeviceHandle - -> EndpointAddress - -> Timeout - -> CStringLen - -> IO (Size, Status) -transferSync c'transfer devHndl - endpointAddr - timeout - (dataPtr, size) = - alloca $ \transferredPtr -> do - err <- withDevHndlPtr devHndl $ \devHndlPtr -> - c'transfer devHndlPtr - (marshalEndpointAddress endpointAddr) - (castPtr dataPtr) - (fromIntegral size) - transferredPtr - (fromIntegral timeout) - let timedOut = err == c'LIBUSB_ERROR_TIMEOUT - if err /= c'LIBUSB_SUCCESS && not timedOut - then throwIO $ convertUSBException err - else do transferred <- peek transferredPtr - return ( fromIntegral transferred - , if timedOut then TimedOut else Completed - ) - --------------------------------------------------------------------------------- - -#ifdef HAS_EVENT_MANAGER -readTransferAsync :: Wait - -> C'TransferType - -> DeviceHandle -> EndpointAddress -> ReadAction -readTransferAsync wait transType = \devHndl endpointAddr -> \size timeout -> - createAndTrimNoOffset size $ \bufferPtr -> - transferAsync wait - transType - devHndl (marshalEndpointAddress endpointAddr) - timeout - (bufferPtr, size) - -writeTransferAsync :: Wait - -> C'TransferType - -> DeviceHandle -> EndpointAddress -> WriteAction -writeTransferAsync wait transType = \devHndl endpointAddr -> \input timeout -> - BU.unsafeUseAsCStringLen input $ - transferAsync wait - transType - devHndl (marshalEndpointAddress endpointAddr) - timeout - --------------------------------------------------------------------------------- - --- | Endpoint transfer type. Can be any of: --- --- * 'c'LIBUSB_TRANSFER_TYPE_CONTROL' --- * 'c'LIBUSB_TRANSFER_TYPE_ISOCHRONOUS' --- * 'c'LIBUSB_TRANSFER_TYPE_BULK' --- * 'c'LIBUSB_TRANSFER_TYPE_INTERRUPT' -type C'TransferType = CUChar - -transferAsync :: Wait - -> C'TransferType - -> DeviceHandle -> CUChar -- ^ Encoded endpoint address - -> Timeout - -> (Ptr byte, Size) - -> IO (Size, Status) -transferAsync wait transType devHndl endpoint timeout bytes = - withTerminatedTransfer wait - transType - isos - devHndl endpoint - timeout - bytes - (continue Completed) - (continue TimedOut) - where - isos :: Storable.Vector C'libusb_iso_packet_descriptor - isos = VG.empty - - continue :: Status -> (Ptr C'libusb_transfer -> IO (Size, Status)) - continue status = \transPtr -> do - n <- peek $ p'libusb_transfer'actual_length transPtr - return (fromIntegral n, status) - --------------------------------------------------------------------------------- - -withTerminatedTransfer :: Wait - -> C'TransferType - -> Storable.Vector C'libusb_iso_packet_descriptor - -> DeviceHandle -> CUChar -- ^ Encoded endpoint address - -> Timeout - -> (Ptr byte, Size) - -> (Ptr C'libusb_transfer -> IO a) - -> (Ptr C'libusb_transfer -> IO a) - -> IO a -withTerminatedTransfer wait - transType - isos - devHndl endpoint - timeout - (bufferPtr, size) - onCompletion - onTimeout = - withDevHndlPtr devHndl $ \devHndlPtr -> - allocaTransfer nrOfIsos $ \transPtr -> do - lock <- newLock - withCallback (\_transPtr -> release lock) $ \cbPtr -> do - poke (p'libusb_transfer'dev_handle transPtr) devHndlPtr - poke (p'libusb_transfer'endpoint transPtr) endpoint - poke (p'libusb_transfer'type transPtr) transType - poke (p'libusb_transfer'timeout transPtr) (fromIntegral timeout) - poke (p'libusb_transfer'length transPtr) (fromIntegral size) - poke (p'libusb_transfer'callback transPtr) cbPtr - poke (p'libusb_transfer'buffer transPtr) (castPtr bufferPtr) - poke (p'libusb_transfer'num_iso_packets transPtr) (fromIntegral nrOfIsos) - - pokeVector (p'libusb_transfer'iso_packet_desc transPtr) isos - - mask_ $ do - handleUSBException $ c'libusb_submit_transfer transPtr - wait timeout lock transPtr - - status <- peek $ p'libusb_transfer'status transPtr - case status of - ts | ts == c'LIBUSB_TRANSFER_COMPLETED -> onCompletion transPtr - | ts == c'LIBUSB_TRANSFER_TIMED_OUT -> onTimeout transPtr - - | ts == c'LIBUSB_TRANSFER_ERROR -> throwIO ioException - | ts == c'LIBUSB_TRANSFER_NO_DEVICE -> throwIO NoDeviceException - | ts == c'LIBUSB_TRANSFER_OVERFLOW -> throwIO OverflowException - | ts == c'LIBUSB_TRANSFER_STALL -> throwIO PipeException - - | ts == c'LIBUSB_TRANSFER_CANCELLED -> - moduleError "transfer status can't be Cancelled!" - - | otherwise -> moduleError $ "Unknown transfer status: " ++ - show ts ++ "!" - where - nrOfIsos = VG.length isos - --------------------------------------------------------------------------------- - --- | Allocate a transfer with the given number of isochronous packets and apply --- the function to the resulting pointer. The transfer is automatically freed --- when the function terminates (whether normally or by raising an exception). --- --- A 'NoMemException' may be thrown. -allocaTransfer :: Int -> (Ptr C'libusb_transfer -> IO a) -> IO a -allocaTransfer nrOfIsos = bracket (mallocTransfer nrOfIsos) - c'libusb_free_transfer - -mallocTransfer :: Int -> IO (Ptr C'libusb_transfer) -mallocTransfer nrOfIsos = do - transPtr <- c'libusb_alloc_transfer (fromIntegral nrOfIsos) - when (transPtr == nullPtr) (throwIO NoMemException) - return transPtr - --------------------------------------------------------------------------------- - --- | Create a 'FunPtr' to the given transfer callback function and pass it to --- the continuation function. The 'FunPtr' is automatically freed when the --- continuation terminates (whether normally or by raising an exception). -withCallback :: (Ptr C'libusb_transfer -> IO ()) - -> (C'libusb_transfer_cb_fn -> IO a) - -> IO a -withCallback cb = bracket (mk'libusb_transfer_cb_fn cb) freeHaskellFunPtr - --------------------------------------------------------------------------------- - --- | A lock is in one of two states: \"locked\" or \"unlocked\". -newtype Lock = Lock (MVar ()) deriving Eq - --- | Create a lock in the \"unlocked\" state. -newLock :: IO Lock -newLock = Lock <$> newEmptyMVar - -{-| -Acquires the 'Lock'. Blocks if another thread has acquired the 'Lock'. - -@acquire@ behaves as follows: - -* When the state is \"unlocked\" @acquire@ changes the state to \"locked\". - -* When the state is \"locked\" @acquire@ /blocks/ until a call to 'release' in -another thread wakes the calling thread. Upon awakening it will change the state -to \"locked\". --} -acquire :: Lock -> IO () -acquire (Lock mv) = takeMVar mv - -{-| -@release@ changes the state to \"unlocked\" and returns immediately. - -The behaviour is undefined when a lock in the \"unlocked\" state is released! - -If there are any threads blocked on 'acquire' the thread that first called -@acquire@ will be woken up. --} -release :: Lock -> IO () -release (Lock mv) = putMVar mv () - --------------------------------------------------------------------------------- --- ** Isochronous transfers --------------------------------------------------------------------------------- - -{-| Perform a USB /isochronous/ read. - -/WARNING:/ You need to enable the threaded runtime (@-threaded@) for this -function to work correctly. It throws a runtime error otherwise! - -Exceptions: - - * 'PipeException' if the endpoint halted. - - * 'OverflowException' if the device offered more data, see - - in the @libusb@ documentation. - - * 'NoDeviceException' if the device has been disconnected. - - * Another 'USBException'. --} -readIsochronous :: DeviceHandle - -> EndpointAddress -- ^ Make sure 'transferDirection' is set to 'In'. - -> Unboxed.Vector Size -- ^ Sizes of isochronous packets to read. - -> Timeout - -> IO (Vector B.ByteString) -readIsochronous devHndl endpointAddr sizes timeout = do - wait <- requireWait devHndl "readIsochronous" - allocaBytes totalSize $ \bufferPtr -> - withTerminatedTransfer - wait - c'LIBUSB_TRANSFER_TYPE_ISOCHRONOUS - isos - devHndl - (marshalEndpointAddress endpointAddr) - timeout - (bufferPtr, totalSize) - (getPackets nrOfIsos bufferPtr) - (\_ -> throwIO TimeoutException) - where - totalSize = VG.sum sizes - nrOfIsos = VG.length sizes - isos = VG.map initIsoPacketDesc $ VG.convert sizes - -getPackets :: Int -> Ptr Word8 -> Ptr C'libusb_transfer -> IO (Vector B.ByteString) -getPackets nrOfIsos bufferPtr transPtr = do - mv <- VGM.unsafeNew nrOfIsos - let go !ix ptr - | ix < nrOfIsos = do - let isoPtr = advancePtr isoArrayPtr ix - l <- peek (p'libusb_iso_packet_descriptor'length isoPtr) - a <- peek (p'libusb_iso_packet_descriptor'actual_length isoPtr) - let transferred = fromIntegral a - bs <- BI.create transferred $ \p -> copyArray p ptr transferred - VGM.unsafeWrite mv ix bs - go (ix+1) (ptr `plusPtr` fromIntegral l) - | otherwise = VG.unsafeFreeze mv - go 0 bufferPtr - where - isoArrayPtr = p'libusb_transfer'iso_packet_desc transPtr - --------------------------------------------------------------------------------- - -{-| Perform a USB /isochronous/ write. - -/WARNING:/ You need to enable the threaded runtime (@-threaded@) for this -function to work correctly. It throws a runtime error otherwise! - -Exceptions: - - * 'PipeException' if the endpoint halted. - - * 'OverflowException' if the device offered more data, see - - in the @libusb@ documentation. - - * 'NoDeviceException' if the device has been disconnected. - - * Another 'USBException'. --} -writeIsochronous :: DeviceHandle - -> EndpointAddress -- ^ Make sure 'transferDirection' is set to 'Out'. - -> Vector B.ByteString -- ^ Isochronous packets to write. - -> Timeout - -> IO (Unboxed.Vector Size) -writeIsochronous devHndl endpointAddr isoPackets timeout = do - wait <- requireWait devHndl "writeIsochronous" - allocaBytes totalSize $ \bufferPtr -> do - copyIsos (castPtr bufferPtr) isoPackets - withTerminatedTransfer - wait - c'LIBUSB_TRANSFER_TYPE_ISOCHRONOUS - isos - devHndl - (marshalEndpointAddress endpointAddr) - timeout - (bufferPtr, totalSize) - (getSizes nrOfIsos) - (\_ -> throwIO TimeoutException) - where - sizes = VG.map B.length isoPackets - nrOfIsos = VG.length sizes - totalSize = VG.sum sizes - isos = VG.convert $ VG.map initIsoPacketDesc sizes - -getSizes :: Int -> Ptr C'libusb_transfer -> IO (Unboxed.Vector Size) -getSizes nrOfIsos transPtr = do - mv <- VGM.unsafeNew nrOfIsos - let go !ix - | ix < nrOfIsos = do - let isoPtr = advancePtr isoArrayPtr ix - a <- peek (p'libusb_iso_packet_descriptor'actual_length isoPtr) - let transferred = fromIntegral a - VGM.unsafeWrite mv ix transferred - go (ix+1) - | otherwise = VG.unsafeFreeze mv - go 0 - where - isoArrayPtr = p'libusb_transfer'iso_packet_desc transPtr - -copyIsos :: Ptr CChar -> Vector B.ByteString -> IO () -copyIsos = VG.foldM_ $ \bufferPtr bs -> - BU.unsafeUseAsCStringLen bs $ \(ptr, len) -> do - copyArray bufferPtr ptr len - return $ bufferPtr `plusPtr` len - --- | An isochronous packet descriptor with all fields zero except for the length. -initIsoPacketDesc :: Size -> C'libusb_iso_packet_descriptor -initIsoPacketDesc size = - C'libusb_iso_packet_descriptor - { c'libusb_iso_packet_descriptor'length = fromIntegral size - , c'libusb_iso_packet_descriptor'actual_length = 0 - , c'libusb_iso_packet_descriptor'status = 0 - } - - --------------------------------------------------------------------------------- --- * Repeatable transfers --------------------------------------------------------------------------------- - --- | A 'Transfer' should not be performed concurrently which is why we --- sequentialize it using an 'MVar'. -type ThreadSafeTransfer = MVar Transfer - -data Transfer = Transfer - { transForeignPtr :: ForeignPtr C'libusb_transfer - , transWait :: Timeout -> Ptr C'libusb_transfer -> IO () - -- ^ Function to wait on the termination of a transfer. - -- Note that this is just 'Wait' partially applied to a 'Lock'. - , transDevHndl :: DeviceHandle - -- ^ The 'DeviceHandle' is stored so that its associated 'Device' and - -- 'Ctx' can be kept alive during the lifetime of a 'Transfer'. - , transBufferFinalizerIORef :: IORef (IO ()) - } - --- | Safely operate on the internal @libusb@ @transfer@ structure. -withTransPtr :: Transfer -> (Ptr C'libusb_transfer -> IO a) -> IO a -withTransPtr = withForeignPtr . transForeignPtr - -newThreadSafeTransfer :: (Ptr byte, Size) -- ^ Pointer to an input or output buffer - -- with its associated size. - -> IO () -- ^ Buffer finalizer. - -> C'TransferType - -> Storable.Vector C'libusb_iso_packet_descriptor - -> DeviceHandle - -> CUChar - -> Timeout - -> IO ThreadSafeTransfer -newThreadSafeTransfer (bufferPtr, size) - finalizeBuffer transType isos devHndl endpoint timeout = do - wait <- requireWait devHndl "newThreadSafeTransfer" - withDevHndlPtr devHndl $ \devHndlPtr -> mask_ $ do - - -- Allocate: - transPtr <- mallocTransfer nrOfIsos - - waitLock <- newLock - cbPtr <- mk'libusb_transfer_cb_fn (\_transPtr -> release waitLock) - - -- Fill the transfer: - poke (p'libusb_transfer'dev_handle transPtr) devHndlPtr - poke (p'libusb_transfer'endpoint transPtr) endpoint - poke (p'libusb_transfer'type transPtr) transType - poke (p'libusb_transfer'timeout transPtr) (fromIntegral timeout) - poke (p'libusb_transfer'length transPtr) (fromIntegral size) - poke (p'libusb_transfer'callback transPtr) cbPtr - poke (p'libusb_transfer'buffer transPtr) (castPtr bufferPtr) - poke (p'libusb_transfer'num_iso_packets transPtr) (fromIntegral nrOfIsos) - - pokeVector (p'libusb_transfer'iso_packet_desc transPtr) isos - - bufferFinalizerIORef <- newIORef finalizeBuffer - - transFP <- FC.newForeignPtr transPtr $ do - c'libusb_free_transfer transPtr - freeHaskellFunPtr cbPtr - - bufferFinalizer <- readIORef bufferFinalizerIORef - bufferFinalizer - - newMVar Transfer - { transForeignPtr = transFP - , transWait = \t -> wait t waitLock - , transDevHndl = devHndl - , transBufferFinalizerIORef = bufferFinalizerIORef - } - where - nrOfIsos = VG.length isos - -performThreadSafeTransfer :: ThreadSafeTransfer - -> (Ptr C'libusb_transfer -> IO a) - -> (Ptr C'libusb_transfer -> IO a) - -> IO a -performThreadSafeTransfer threadSafeTransfer onCompletion onTimeout = - - -- Ensure transfers are not performed concurrently: - withMVar threadSafeTransfer $ \transfer -> - - withTransPtr transfer $ \transPtr -> - - -- Ensure that the Device and Ctx, associated with the DeviceHandle, are - -- kept alive at least for the duration of the transfer: - withDevHndlPtr (transDevHndl transfer) $ \_devHndlPtr -> do - - mask_ $ do - handleUSBException $ c'libusb_submit_transfer transPtr - timeout <- peek $ p'libusb_transfer'timeout transPtr - transWait transfer (fromIntegral timeout) transPtr - - status <- peek $ p'libusb_transfer'status transPtr - case status of - ts | ts == c'LIBUSB_TRANSFER_COMPLETED -> onCompletion transPtr - | ts == c'LIBUSB_TRANSFER_TIMED_OUT -> onTimeout transPtr - - | ts == c'LIBUSB_TRANSFER_ERROR -> throwIO ioException - | ts == c'LIBUSB_TRANSFER_NO_DEVICE -> throwIO NoDeviceException - | ts == c'LIBUSB_TRANSFER_OVERFLOW -> throwIO OverflowException - | ts == c'LIBUSB_TRANSFER_STALL -> throwIO PipeException - - | ts == c'LIBUSB_TRANSFER_CANCELLED -> - moduleError "transfer status can't be Cancelled!" - - | otherwise -> moduleError $ "Unknown transfer status: " ++ - show ts ++ "!" - --------------------------------------------------------------------------------- --- ** Setting transfers properties --------------------------------------------------------------------------------- - -setTransferProperty :: (Storable a) - => (Ptr C'libusb_transfer -> Ptr a) - -> ThreadSafeTransfer - -> a - -> IO () -setTransferProperty prop threadSafeTransfer val = - withMVar threadSafeTransfer $ \transfer -> - withTransPtr transfer $ \transPtr -> - poke (prop transPtr) val - --------------------------------------------------------------------------------- - -setTransferType :: ThreadSafeTransfer -> C'TransferType -> IO () -setTransferType = setTransferProperty p'libusb_transfer'type - -setTransferDeviceHandle :: ThreadSafeTransfer -> DeviceHandle -> IO () -setTransferDeviceHandle threadSafeTransfer devHndl = - withDevHndlPtr devHndl $ \devHndlPtr -> mask_ $ do - transfer <- takeMVar threadSafeTransfer - withTransPtr transfer $ \transPtr -> do - poke (p'libusb_transfer'dev_handle transPtr) devHndlPtr - putMVar threadSafeTransfer transfer{transDevHndl = devHndl} - -setTransferEndpointAddress :: ThreadSafeTransfer -> EndpointAddress -> IO () -setTransferEndpointAddress threadSafeTransfer endpointAddr = - setTransferProperty p'libusb_transfer'endpoint - threadSafeTransfer - (marshalEndpointAddress endpointAddr) - -setTransferTimeout :: ThreadSafeTransfer -> Timeout -> IO () -setTransferTimeout threadSafeTransfer timeout = - setTransferProperty p'libusb_transfer'timeout - threadSafeTransfer - (fromIntegral timeout) - --------------------------------------------------------------------------------- --- ** Getting transfers properties --------------------------------------------------------------------------------- - -getTransferProperty :: (Storable a) - => (Ptr C'libusb_transfer -> Ptr a) - -> ThreadSafeTransfer - -> IO a -getTransferProperty prop threadSafeTransfer = - withMVar threadSafeTransfer $ \transfer -> - withTransPtr transfer $ \transPtr -> - peek $ prop transPtr - --------------------------------------------------------------------------------- - -getTransferType :: ThreadSafeTransfer -> IO C'TransferType -getTransferType = getTransferProperty p'libusb_transfer'type - -getTransferDeviceHandle :: ThreadSafeTransfer -> IO DeviceHandle -getTransferDeviceHandle threadSafeTransfer = - withMVar threadSafeTransfer $ return . transDevHndl - -getTransferEndpointAddress :: ThreadSafeTransfer -> IO EndpointAddress -getTransferEndpointAddress = fmap (unmarshalEndpointAddress . fromIntegral) - . getTransferProperty p'libusb_transfer'endpoint - -getTransferTimeout :: ThreadSafeTransfer -> IO Timeout -getTransferTimeout = fmap fromIntegral - . getTransferProperty p'libusb_transfer'timeout - --------------------------------------------------------------------------------- --- ** Control transfers --------------------------------------------------------------------------------- - --------------------------------------------------------------------------------- --- *** No data transfer --------------------------------------------------------------------------------- - --- | A control transfer which doesn't transfer data. -newtype ControlTransfer = ControlTransfer - {unControlTransfer :: ThreadSafeTransfer} - --- | Create a new control transfer which doesn't transfer data. -newControlTransfer :: DeviceHandle -> ControlSetup -> Timeout -> IO ControlTransfer -newControlTransfer devHndl ctrlSetup timeout = mask_ $ do - bufferPtr <- mallocBytes size - when (bufferPtr == nullPtr) $ throwIO NoMemException - - poke bufferPtr $ marshallControlSetup ctrlSetup Out 0 - - ControlTransfer <$> newThreadSafeTransfer - (bufferPtr, size) (free bufferPtr) - c'LIBUSB_TRANSFER_TYPE_CONTROL - isos devHndl controlEndpoint timeout - where - size = controlSetupSize - - isos :: Storable.Vector C'libusb_iso_packet_descriptor - isos = VG.empty - --- | Execute a control transfer which doesn't transfer data. -performControlTransfer :: ControlTransfer -> IO () -performControlTransfer ctrlTransfer = - performThreadSafeTransfer (unControlTransfer ctrlTransfer) - (\_transPtr -> return ()) - (\_transPtr -> throwIO TimeoutException) - --------------------------------------------------------------------------------- --- **** Setting control /read/ transfer properties --------------------------------------------------------------------------------- - --- | Update the device handle of a control transfer. -setControlTransferDeviceHandle :: ControlTransfer -> DeviceHandle -> IO () -setControlTransferDeviceHandle = setTransferDeviceHandle . unControlTransfer - --- | Update the timeout of a control transfer. -setControlTransferTimeout :: ControlTransfer -> Timeout -> IO () -setControlTransferTimeout = setTransferTimeout . unControlTransfer - --- | Update the setup parameters of a control transfer. -setControlSetup :: ControlTransfer -> ControlSetup -> IO () -setControlSetup ctrlTransfer ctrlSetup = - withMVarMasked (unControlTransfer ctrlTransfer) $ \transfer -> - withTransPtr transfer $ \transPtr -> do - bufferPtr <- peek (p'libusb_transfer'buffer transPtr) - poke (castPtr bufferPtr) $ marshallControlSetup ctrlSetup Out 0 - --------------------------------------------------------------------------------- --- **** Getting control /read/ transfer properties --------------------------------------------------------------------------------- - --- | Retrieve the device handle of a control transfer. -getControlTransferDeviceHandle :: ControlTransfer -> IO DeviceHandle -getControlTransferDeviceHandle = getTransferDeviceHandle . unControlTransfer - --- | Retrieve the timeout of a control transfer. -getControlTransferTimeout :: ControlTransfer -> IO Timeout -getControlTransferTimeout = getTransferTimeout . unControlTransfer - - --------------------------------------------------------------------------------- --- *** Control /read/ transfers --------------------------------------------------------------------------------- - --- | A control transfer which reads data from a device. -newtype ControlReadTransfer = ControlReadTransfer - {unControlReadTransfer :: ThreadSafeTransfer} - --- | Create a new control transfer which can read data from a device. -newControlReadTransfer - :: DeviceHandle -> ControlSetup -> Size -> Timeout -> IO ControlReadTransfer -newControlReadTransfer devHndl ctrlSetup readSize timeout = mask_ $ do - bufferPtr <- mallocBytes size - when (bufferPtr == nullPtr) $ throwIO NoMemException - - poke bufferPtr $ marshallControlSetup ctrlSetup In readSize - - ControlReadTransfer <$> newThreadSafeTransfer - (bufferPtr, size) (free bufferPtr) - c'LIBUSB_TRANSFER_TYPE_CONTROL - isos devHndl controlEndpoint timeout - where - size = controlSetupSize + readSize - - isos :: Storable.Vector C'libusb_iso_packet_descriptor - isos = VG.empty - --- | Execute a control transfer to read data from the device. -performControlReadTransfer :: ControlReadTransfer -> IO (B.ByteString, Status) -performControlReadTransfer ctrlReadTransfer = - performThreadSafeTransfer (unControlReadTransfer ctrlReadTransfer) - (continue Completed) (continue TimedOut) - where - continue :: Status -> (Ptr C'libusb_transfer -> IO (B.ByteString, Status)) - continue status = \transPtr -> do - len <- fromIntegral <$> peek (p'libusb_transfer'actual_length transPtr) - bufferPtr <- castPtr <$> peek (p'libusb_transfer'buffer transPtr) - - bs <- BI.create len $ \ptr -> - BI.memcpy ptr (bufferPtr `plusPtr` controlSetupSize) (fromIntegral len) - - return (bs, status) - --------------------------------------------------------------------------------- --- **** Setting control /read/ transfer properties --------------------------------------------------------------------------------- - --- | Update the device handle of a control transfer that reads data from a device. -setControlReadTransferDeviceHandle :: ControlReadTransfer -> DeviceHandle -> IO () -setControlReadTransferDeviceHandle = setTransferDeviceHandle . unControlReadTransfer - --- | Update the timeout of a control transfer that reads data from a device. -setControlReadTransferTimeout :: ControlReadTransfer -> Timeout -> IO () -setControlReadTransferTimeout = setTransferTimeout . unControlReadTransfer - --- | Update the setup parameters of a control transfer that reads data from a device.. -setControlReadSetup :: ControlReadTransfer -> ControlSetup -> Size -> IO () -setControlReadSetup ctrlReadTransfer ctrlSetup readSize = - withMVarMasked (unControlReadTransfer ctrlReadTransfer) $ \transfer -> - withTransPtr transfer $ \transPtr -> do - oldBufferPtr <- peek (p'libusb_transfer'buffer transPtr) - oldReadSize <- peek (p'libusb_control_setup'wLength (castPtr oldBufferPtr)) - - bufferPtr <- - if fromIntegral oldReadSize == readSize - then return oldBufferPtr - else do - bufferPtr <- reallocBytes oldBufferPtr size - when (bufferPtr == nullPtr) $ throwIO NoMemException - - writeIORef (transBufferFinalizerIORef transfer) $ free bufferPtr - - poke (p'libusb_transfer'buffer transPtr) bufferPtr - poke (p'libusb_transfer'length transPtr) (fromIntegral size) - - return bufferPtr - - poke (castPtr bufferPtr) $ marshallControlSetup ctrlSetup In readSize - where - size = controlSetupSize + readSize - --------------------------------------------------------------------------------- --- **** Getting control /read/ transfer properties --------------------------------------------------------------------------------- - --- | Retrieve the device handle of a control transfer that reads data from a device. -getControlReadTransferDeviceHandle :: ControlReadTransfer -> IO DeviceHandle -getControlReadTransferDeviceHandle = getTransferDeviceHandle . unControlReadTransfer - --- | Retrieve the timeout of a control transfer that reads data from a device. -getControlReadTransferTimeout :: ControlReadTransfer -> IO Timeout -getControlReadTransferTimeout = getTransferTimeout . unControlReadTransfer - - --------------------------------------------------------------------------------- --- *** Control /write/ transfers --------------------------------------------------------------------------------- - --- | A control transfer which writes data to a device. -newtype ControlWriteTransfer = ControlWriteTransfer - {unControlWriteTransfer :: ThreadSafeTransfer} - --- | Create a new control transfer which can write data to a device. -newControlWriteTransfer - :: DeviceHandle - -> ControlSetup - -> B.ByteString - -> Timeout - -> IO ControlWriteTransfer -newControlWriteTransfer devHndl ctrlSetup input timeout = - BU.unsafeUseAsCStringLen input $ \(dataPtr, writeSize) -> mask_ $ do - let size = controlSetupSize + writeSize - - bufferPtr <- mallocBytes size - when (bufferPtr == nullPtr) $ throwIO NoMemException - - poke bufferPtr $ marshallControlSetup ctrlSetup Out writeSize - - copyArray (bufferPtr `plusPtr` controlSetupSize) dataPtr writeSize - - ControlWriteTransfer <$> newThreadSafeTransfer - (bufferPtr, size) (free bufferPtr) - c'LIBUSB_TRANSFER_TYPE_CONTROL - isos devHndl controlEndpoint timeout - where - isos :: Storable.Vector C'libusb_iso_packet_descriptor - isos = VG.empty - --- | Execute a control transfer to write the data to the device. -performControlWriteTransfer :: ControlWriteTransfer -> IO (Size, Status) -performControlWriteTransfer ctrlWriteTransfer = - performThreadSafeTransfer (unControlWriteTransfer ctrlWriteTransfer) - (continue Completed) (continue TimedOut) - where - continue :: Status -> (Ptr C'libusb_transfer -> IO (Size, Status)) - continue status = \transPtr -> do - len <- fromIntegral <$> peek (p'libusb_transfer'actual_length transPtr) - return (len, status) - --------------------------------------------------------------------------------- --- **** Setting control /write/ transfer properties --------------------------------------------------------------------------------- - --- | Update the device handle of a control transfer that writes data to a device. -setControlWriteTransferDeviceHandle :: ControlWriteTransfer -> DeviceHandle -> IO () -setControlWriteTransferDeviceHandle = setTransferDeviceHandle . unControlWriteTransfer - --- | Update the timeout of a control transfer that writes data to a device. -setControlWriteTransferTimeout :: ControlWriteTransfer -> Timeout -> IO () -setControlWriteTransferTimeout = setTransferTimeout . unControlWriteTransfer - --- | Update the setup parameters of a control transfer that writes data to a device. -setControlWriteSetup :: ControlWriteTransfer -> ControlSetup -> B.ByteString -> IO () -setControlWriteSetup ctrlWriteTransfer ctrlSetup input = - withMVarMasked (unControlWriteTransfer ctrlWriteTransfer) $ \transfer -> - withTransPtr transfer $ \transPtr -> do - BU.unsafeUseAsCStringLen input $ \(dataPtr, writeSize) -> do - let size = controlSetupSize + writeSize - - oldBufferPtr <- peek (p'libusb_transfer'buffer transPtr) - oldWriteSize <- peek (p'libusb_control_setup'wLength (castPtr oldBufferPtr)) - - bufferPtr <- - if fromIntegral oldWriteSize == writeSize - then return oldBufferPtr - else do - bufferPtr <- reallocBytes oldBufferPtr size - when (bufferPtr == nullPtr) $ throwIO NoMemException - - writeIORef (transBufferFinalizerIORef transfer) $ free bufferPtr - - poke (p'libusb_transfer'buffer transPtr) bufferPtr - poke (p'libusb_transfer'length transPtr) (fromIntegral size) - - return bufferPtr - - poke (castPtr bufferPtr) $ marshallControlSetup ctrlSetup Out writeSize - - copyArray (bufferPtr `plusPtr` controlSetupSize) dataPtr writeSize - - --------------------------------------------------------------------------------- --- **** Getting control /write/ transfer properties --------------------------------------------------------------------------------- - --- | Retrieve the device handle of a control transfer that writes data to a device. -getControlWriteTransferDeviceHandle :: ControlWriteTransfer -> IO DeviceHandle -getControlWriteTransferDeviceHandle = getTransferDeviceHandle . unControlWriteTransfer - --- | Retrieve the timeout of a control transfer that writes data to a device. -getControlWriteTransferTimeout :: ControlWriteTransfer -> IO Timeout -getControlWriteTransferTimeout = getTransferTimeout . unControlWriteTransfer - --------------------------------------------------------------------------------- --- ** Bulk / Interrupt transfers --------------------------------------------------------------------------------- - --- | Type of 'ReadTransfer' or 'WriteTransfer' which can either be --- /bulk/ or /interrupt/. --- --- Note that isochronous transfers are handled differently using the --- 'IsochronousReadTransfer' or 'IsochronousWriteTransfer' types. -data RepeatableTransferType = BulkTransfer - | InterruptTransfer - -marshallRepeatableTransferType :: RepeatableTransferType -> C'TransferType -marshallRepeatableTransferType BulkTransfer = c'LIBUSB_TRANSFER_TYPE_BULK -marshallRepeatableTransferType InterruptTransfer = c'LIBUSB_TRANSFER_TYPE_INTERRUPT - -unmarshalRepeatableTransferType :: C'TransferType -> RepeatableTransferType -unmarshalRepeatableTransferType transType - | transType == c'LIBUSB_TRANSFER_TYPE_BULK = BulkTransfer - | transType == c'LIBUSB_TRANSFER_TYPE_INTERRUPT = InterruptTransfer - | otherwise = - moduleError $ "unmarshalRepeatableTransferType: Invalid transfer type: " ++ - show transType - --------------------------------------------------------------------------------- --- *** Bulk / Interrupt /read/ transfers --------------------------------------------------------------------------------- - --- | A bulk or interrupt read transfer. -newtype ReadTransfer = ReadTransfer {unReadTransfer :: ThreadSafeTransfer} - --- | Create a new bulk or interrupt transfer that can read data from a device. -newReadTransfer :: RepeatableTransferType - -> DeviceHandle - -> EndpointAddress - -> Size -- ^ Number of bytes to read. - -> Timeout - -> IO ReadTransfer -newReadTransfer transType devHndl endpointAddr size timeout = mask_ $ do - bufferPtr <- mallocBytes size - - when (bufferPtr == nullPtr && size /= 0) $ - throwIO NoMemException - - ReadTransfer <$> newThreadSafeTransfer - (bufferPtr, size) (free bufferPtr) - (marshallRepeatableTransferType transType) - isos devHndl (marshalEndpointAddress endpointAddr) timeout - where - isos :: Storable.Vector C'libusb_iso_packet_descriptor - isos = VG.empty - --- | Execute a bulk or interrupt transfer to read data from a device. -performReadTransfer :: ReadTransfer -> IO (B.ByteString, Status) -performReadTransfer readTransfer = - performThreadSafeTransfer (unReadTransfer readTransfer) - (continue Completed) (continue TimedOut) - where - continue :: Status -> (Ptr C'libusb_transfer -> IO (B.ByteString, Status)) - continue status = \transPtr -> do - len <- fromIntegral <$> peek (p'libusb_transfer'actual_length transPtr) - bufferPtr <- castPtr <$> peek (p'libusb_transfer'buffer transPtr) - - bs <- BI.create len $ \ptr -> BI.memcpy ptr bufferPtr (fromIntegral len) - - return (bs, status) - --------------------------------------------------------------------------------- --- **** Setting bulk / interrupt /read/ transfer properties --------------------------------------------------------------------------------- - --- | Specify whether the transfer should perform bulk or interrupt reads. -setReadTransferType :: ReadTransfer -> RepeatableTransferType -> IO () -setReadTransferType readTransfer transType = - setTransferType (unReadTransfer readTransfer) - (marshallRepeatableTransferType transType) - --- | Update the device handle of a bulk or interrupt read transfer. -setReadTransferDeviceHandle :: ReadTransfer -> DeviceHandle -> IO () -setReadTransferDeviceHandle = setTransferDeviceHandle . unReadTransfer - --- | Update the endpoint address of a bulk or interrupt read transfer. -setReadTransferEndpointAddress :: ReadTransfer -> EndpointAddress -> IO () -setReadTransferEndpointAddress = setTransferEndpointAddress . unReadTransfer - --- | Update the timeout of a bulk or interrupt read transfer. -setReadTransferTimeout :: ReadTransfer -> Timeout -> IO () -setReadTransferTimeout = setTransferTimeout . unReadTransfer - --- | Update the number of bytes to read for a bulk or interrupt transfer. -setReadTransferSize :: ReadTransfer -> Size -> IO () -setReadTransferSize readTransfer size = - withMVarMasked (unReadTransfer readTransfer) $ \transfer -> - withTransPtr transfer $ \transPtr -> do - let ref = transBufferFinalizerIORef transfer - if size == 0 - then do - finalizeBuffer <- readIORef ref - finalizeBuffer - writeIORef ref (return ()) - else do - bufferPtr <- peek (p'libusb_transfer'buffer transPtr) - bufferPtr' <- reallocBytes bufferPtr size - when (bufferPtr' == nullPtr) $ throwIO NoMemException - writeIORef ref $ free bufferPtr' - poke (p'libusb_transfer'buffer transPtr) bufferPtr' - - poke (p'libusb_transfer'length transPtr) (fromIntegral size) - --------------------------------------------------------------------------------- --- **** Getting bulk / interrupt /read/ transfer properties --------------------------------------------------------------------------------- - --- | Check if this transfer does bulk or interrupt reads. -getReadTransferType :: ReadTransfer -> IO RepeatableTransferType -getReadTransferType = fmap unmarshalRepeatableTransferType - . getTransferType . unReadTransfer - --- | Retrieve the device handle of a bulk or interrupt read transfer. -getReadTransferDeviceHandle :: ReadTransfer -> IO DeviceHandle -getReadTransferDeviceHandle = getTransferDeviceHandle . unReadTransfer - --- | Retrieve the endpoint address of a bulk or interrupt read transfer. -getReadTransferEndpointAddress :: ReadTransfer -> IO EndpointAddress -getReadTransferEndpointAddress = getTransferEndpointAddress . unReadTransfer - --- | Retreive the number of bytes to read for a bulk or interrupt transfer. -getReadTransferSize :: ReadTransfer -> IO Size -getReadTransferSize = fmap fromIntegral - . getTransferProperty p'libusb_transfer'length - . unReadTransfer - --- | Retrieve the timeout of a bulk or interrupt read transfer. -getReadTransferTimeout :: ReadTransfer -> IO Timeout -getReadTransferTimeout = getTransferTimeout . unReadTransfer - --------------------------------------------------------------------------------- --- *** Bulk / Interrupt /write/ transfers --------------------------------------------------------------------------------- - --- | A bulk or interrupt write transfer. -newtype WriteTransfer = WriteTransfer {unWriteTransfer :: ThreadSafeTransfer} - --- | Create a new bulk or interrupt transfer that can write data to a device. -newWriteTransfer :: RepeatableTransferType - -> DeviceHandle - -> EndpointAddress - -> B.ByteString -- ^ Bytes to write. - -> Timeout - -> IO WriteTransfer -newWriteTransfer transType devHndl endpointAddr input timeout = - WriteTransfer <$> newThreadSafeTransfer - (bufferPtr, size) finalizeBuffer - (marshallRepeatableTransferType transType) - isos devHndl (marshalEndpointAddress endpointAddr) timeout - where - (fp, offset, size) = BI.toForeignPtr input - bufferPtr = unsafeForeignPtrToPtr fp `plusPtr` offset - finalizeBuffer = touchForeignPtr fp - - isos :: Storable.Vector C'libusb_iso_packet_descriptor - isos = VG.empty - --- | Execute a bulk or interrupt transfer to write data to a device. -performWriteTransfer :: WriteTransfer -> IO (Size, Status) -performWriteTransfer writeTransfer = - performThreadSafeTransfer (unWriteTransfer writeTransfer) - (continue Completed) (continue TimedOut) - where - continue :: Status -> (Ptr C'libusb_transfer -> IO (Size, Status)) - continue status = \transPtr -> do - len <- fromIntegral <$> peek (p'libusb_transfer'actual_length transPtr) - return (len, status) - --------------------------------------------------------------------------------- --- **** Setting bulk / interrupt /write/ transfer properties --------------------------------------------------------------------------------- - --- | Specify whether the transfer should perform bulk or interrupt writes. -setWriteTransferType :: WriteTransfer -> RepeatableTransferType -> IO () -setWriteTransferType writeTransfer transType = - setTransferType (unWriteTransfer writeTransfer) - (marshallRepeatableTransferType transType) - --- | Update the device handle of a bulk or interrupt write transfer. -setWriteTransferDeviceHandle :: WriteTransfer -> DeviceHandle -> IO () -setWriteTransferDeviceHandle = setTransferDeviceHandle . unWriteTransfer - --- | Update the endpoint address of a bulk or interrupt write transfer. -setWriteTransferEndpointAddress :: WriteTransfer -> EndpointAddress -> IO () -setWriteTransferEndpointAddress = setTransferEndpointAddress . unWriteTransfer - --- | Update the timeout of a bulk or interrupt write transfer. -setWriteTransferTimeout :: WriteTransfer -> Timeout -> IO () -setWriteTransferTimeout = setTransferTimeout . unWriteTransfer - --- | Update the bytes to write for a bulk or interrupt transfer. -setWriteTransferInput :: WriteTransfer -> B.ByteString -> IO () -setWriteTransferInput writeTransfer input = - withMVarMasked (unWriteTransfer writeTransfer) $ \transfer -> - withTransPtr transfer $ \transPtr -> do - writeIORef (transBufferFinalizerIORef transfer) finalizeBuffer - poke (p'libusb_transfer'buffer transPtr) bufferPtr - poke (p'libusb_transfer'length transPtr) (fromIntegral size) - where - (fp, offset, size) = BI.toForeignPtr input - bufferPtr = unsafeForeignPtrToPtr fp `plusPtr` offset - finalizeBuffer = touchForeignPtr fp - --------------------------------------------------------------------------------- --- **** Getting bulk / interrupt /write/ transfer properties --------------------------------------------------------------------------------- - --- | Check if this transfer does bulk or interrupt writes. -getWriteTransferType :: WriteTransfer -> IO RepeatableTransferType -getWriteTransferType = fmap unmarshalRepeatableTransferType - . getTransferType . unWriteTransfer - --- | Retrieve the device handle of a bulk or interrupt write transfer. -getWriteTransferDeviceHandle :: WriteTransfer -> IO DeviceHandle -getWriteTransferDeviceHandle = getTransferDeviceHandle . unWriteTransfer - --- | Retrieve the endpoint address of a bulk or interrupt write transfer. -getWriteTransferEndpointAddress :: WriteTransfer -> IO EndpointAddress -getWriteTransferEndpointAddress = getTransferEndpointAddress . unWriteTransfer - --- | Retreive the bytes to write from a bulk or interrupt transfer. -getWriteTransferInput :: WriteTransfer -> IO B.ByteString -getWriteTransferInput writeTransfer = - withMVar (unWriteTransfer writeTransfer) $ \transfer -> - withTransPtr transfer $ \transPtr -> do - len <- fromIntegral <$> peek (p'libusb_transfer'length transPtr) - bufferPtr <- castPtr <$> peek (p'libusb_transfer'buffer transPtr) - BI.create len $ \ptr -> BI.memcpy ptr bufferPtr (fromIntegral len) - --- | Retrieve the timeout of a bulk or interrupt write transfer. -getWriteTransferTimeout :: WriteTransfer -> IO Timeout -getWriteTransferTimeout = getTransferTimeout . unWriteTransfer - --------------------------------------------------------------------------------- --- ** Isochronous transfers --------------------------------------------------------------------------------- - --------------------------------------------------------------------------------- --- *** Isochronous /read/ transfers --------------------------------------------------------------------------------- - --- | An isochronous read transfer. -newtype IsochronousReadTransfer = IsochronousReadTransfer - {unIsochronousReadTransfer :: ThreadSafeTransfer} - --- | Create a new isochronous transfer that can read isochronous packets from a --- device. -newIsochronousReadTransfer :: DeviceHandle - -> EndpointAddress - -> Unboxed.Vector Size -- ^ Sizes of isochronous packets to read. - -> Timeout - -> IO IsochronousReadTransfer -newIsochronousReadTransfer devHndl endpointAddr sizes timeout = mask_ $ do - bufferPtr <- mallocBytes size - - when (bufferPtr == nullPtr && size /= 0) $ - throwIO NoMemException - - IsochronousReadTransfer <$> newThreadSafeTransfer - (bufferPtr, size) (free bufferPtr) - c'LIBUSB_TRANSFER_TYPE_ISOCHRONOUS - isos devHndl (marshalEndpointAddress endpointAddr) timeout - where - size = VG.sum sizes - isos = VG.map initIsoPacketDesc $ VG.convert sizes - --- | Execute a transfer to read isochronous packets from a device. -performIsochronousReadTransfer :: IsochronousReadTransfer -> IO (Vector B.ByteString) -performIsochronousReadTransfer isoReadTransfer = - performThreadSafeTransfer (unIsochronousReadTransfer isoReadTransfer) - onCompletion onTimeout - where - onCompletion, onTimeout :: Ptr C'libusb_transfer -> IO (Vector B.ByteString) - onCompletion transPtr = do - nrOfIsos <- fromIntegral <$> peek (p'libusb_transfer'num_iso_packets transPtr) - bufferPtr <- castPtr <$> peek (p'libusb_transfer'buffer transPtr) - - getPackets nrOfIsos bufferPtr transPtr - onTimeout _transPtr = throwIO TimeoutException - --------------------------------------------------------------------------------- --- **** Setting isochronous /read/ transfer properties --------------------------------------------------------------------------------- - --- | Update the device handle of an isochronous read transfer. -setIsochronousReadTransferDeviceHandle - :: IsochronousReadTransfer -> DeviceHandle -> IO () -setIsochronousReadTransferDeviceHandle - = setTransferDeviceHandle . unIsochronousReadTransfer - --- | Update the endpoint address of an isochronous read transfer. -setIsochronousReadTransferEndpointAddress - :: IsochronousReadTransfer -> EndpointAddress -> IO () -setIsochronousReadTransferEndpointAddress - = setTransferEndpointAddress . unIsochronousReadTransfer - --- | Update the size of packets to read for an isochronous transfer. -setIsochronousReadTransferSizes - :: IsochronousReadTransfer -> Unboxed.Vector Size -> IO () -setIsochronousReadTransferSizes isoReadTransfer sizes = - withMVarMasked (unIsochronousReadTransfer isoReadTransfer) $ \transfer -> - withTransPtr transfer $ \transPtr -> do - bufferPtr <- peek (p'libusb_transfer'buffer transPtr) - bufferPtr' <- reallocBytes bufferPtr size - - if bufferPtr' == nullPtr - then unless (size == 0) $ throwIO NoMemException - else writeIORef (transBufferFinalizerIORef transfer) $ free bufferPtr' - - poke (p'libusb_transfer'buffer transPtr) bufferPtr' - poke (p'libusb_transfer'length transPtr) (fromIntegral size) - - pokeVector (p'libusb_transfer'iso_packet_desc transPtr) isos - where - size = VG.sum sizes - isos = VG.map initIsoPacketDesc $ VG.convert sizes - --------------------------------------------------------------------------------- --- **** Getting isochronous /read/ transfer properties --------------------------------------------------------------------------------- - --- | Retrieve the device handle of an isochronous read transfer. -getIsochronousReadTransferDeviceHandle - :: IsochronousReadTransfer -> IO DeviceHandle -getIsochronousReadTransferDeviceHandle - = getTransferDeviceHandle . unIsochronousReadTransfer - --- | Retrieve the endpoint address of an isochronous read transfer. -getIsochronousReadTransferEndpointAddress - :: IsochronousReadTransfer -> IO EndpointAddress -getIsochronousReadTransferEndpointAddress - = getTransferEndpointAddress . unIsochronousReadTransfer - --- | Retrieve the packets sizes to read for an isochronous transfer. -getIsochronousReadTransferSizes - :: IsochronousReadTransfer -> IO (Unboxed.Vector Size) -getIsochronousReadTransferSizes isoReadTransfer = - withMVar (unIsochronousReadTransfer isoReadTransfer) $ \transfer -> - withTransPtr transfer $ \transPtr -> do - nrOfIsos <- fromIntegral <$> - peek (p'libusb_transfer'num_iso_packets transPtr) - (VG.convert . VG.map (fromIntegral . c'libusb_iso_packet_descriptor'length)) <$> - peekVector nrOfIsos (p'libusb_transfer'iso_packet_desc transPtr) - - --------------------------------------------------------------------------------- --- *** Isochronous /write/ transfers --------------------------------------------------------------------------------- - --- | An isochronous write transfer. -newtype IsochronousWriteTransfer = IsochronousWriteTransfer - {unIsochronousWriteTransfer :: ThreadSafeTransfer} - --- | Create a new isochronous transfer that can write isochronous packets to a --- device. -newIsochronousWriteTransfer :: DeviceHandle - -> EndpointAddress - -> Vector B.ByteString -- ^ Isochronous packets to write. - -> Timeout - -> IO IsochronousWriteTransfer -newIsochronousWriteTransfer devHndl endpointAddr isoPackets timeout = mask_ $ do - bufferPtr <- mallocBytes size - - when (bufferPtr == nullPtr && size /= 0) $ - throwIO NoMemException - - copyIsos (castPtr bufferPtr) isoPackets - - IsochronousWriteTransfer <$> newThreadSafeTransfer - (bufferPtr, size) (free bufferPtr) - c'LIBUSB_TRANSFER_TYPE_ISOCHRONOUS - isos devHndl (marshalEndpointAddress endpointAddr) timeout - where - size = VG.sum sizes - sizes = VG.map B.length isoPackets - isos = VG.convert $ VG.map initIsoPacketDesc sizes - --- | Execute a transfer to write isochronous packets to a device. -performIsochronousWriteTransfer :: IsochronousWriteTransfer -> IO (Unboxed.Vector Size) -performIsochronousWriteTransfer isoWriteTransfer = - performThreadSafeTransfer (unIsochronousWriteTransfer isoWriteTransfer) - onCompletion onTimeout - where - onCompletion, onTimeout :: Ptr C'libusb_transfer -> IO (Unboxed.Vector Size) - onCompletion transPtr = do - nrOfIsos <- fromIntegral <$> peek (p'libusb_transfer'num_iso_packets transPtr) - getSizes nrOfIsos transPtr - onTimeout _transPtr = throwIO TimeoutException - --------------------------------------------------------------------------------- --- **** Setting isochronous /write/ transfer properties --------------------------------------------------------------------------------- - --- | Update the device handle of an isochronous write transfer. -setIsochronousWriteTransferDeviceHandle - :: IsochronousWriteTransfer -> DeviceHandle -> IO () -setIsochronousWriteTransferDeviceHandle - = setTransferDeviceHandle . unIsochronousWriteTransfer - --- | Update the endpoint address of an isochronous write transfer. -setIsochronousWriteTransferEndpointAddress - :: IsochronousWriteTransfer -> EndpointAddress -> IO () -setIsochronousWriteTransferEndpointAddress - = setTransferEndpointAddress . unIsochronousWriteTransfer - --- | Update the packets to write for an isochronous transfer. -setIsochronousWriteTransferPackets - :: IsochronousWriteTransfer -> Vector B.ByteString -> IO () -setIsochronousWriteTransferPackets isoWriteTransfer isoPackets = - withMVarMasked (unIsochronousWriteTransfer isoWriteTransfer) $ \transfer -> - withTransPtr transfer $ \transPtr -> do - - bufferPtr <- peek (p'libusb_transfer'buffer transPtr) - bufferPtr' <- reallocBytes bufferPtr size - - if bufferPtr' == nullPtr - then unless (size == 0) $ throwIO NoMemException - else writeIORef (transBufferFinalizerIORef transfer) $ free bufferPtr' - - poke (p'libusb_transfer'buffer transPtr) bufferPtr' - poke (p'libusb_transfer'length transPtr) (fromIntegral size) - - pokeVector (p'libusb_transfer'iso_packet_desc transPtr) isos - copyIsos (castPtr bufferPtr') isoPackets - where - size = VG.sum sizes - sizes = VG.map B.length isoPackets - isos = VG.convert $ VG.map initIsoPacketDesc sizes - --------------------------------------------------------------------------------- --- **** Getting isochronous /write/ transfer properties --------------------------------------------------------------------------------- - --- | Retrieve the device handle of an isochronous write transfer. -getIsochronousWriteTransferDeviceHandle - :: IsochronousWriteTransfer -> IO DeviceHandle -getIsochronousWriteTransferDeviceHandle - = getTransferDeviceHandle . unIsochronousWriteTransfer - --- | Retrieve the endpoint address of an isochronous write transfer. -getIsochronousWriteTransferEndpointAddress - :: IsochronousWriteTransfer -> IO EndpointAddress -getIsochronousWriteTransferEndpointAddress - = getTransferEndpointAddress . unIsochronousWriteTransfer - --- | Retrieve the packets to write for an isochronous transfer. -getIsochronousWriteTransferPackets - :: IsochronousWriteTransfer -> IO (Vector B.ByteString) -getIsochronousWriteTransferPackets isoWriteTransfer = - withMVar (unIsochronousWriteTransfer isoWriteTransfer) $ \transfer -> - withTransPtr transfer $ \transPtr -> do - bufferPtr <- castPtr <$> peek (p'libusb_transfer'buffer transPtr) - - nrOfIsos <- fromIntegral <$> - peek (p'libusb_transfer'num_iso_packets transPtr) - - mv <- VGM.unsafeNew nrOfIsos - let isoArrayPtr = p'libusb_transfer'iso_packet_desc transPtr - go !ix ptr - | ix < nrOfIsos = do - let isoPtr = advancePtr isoArrayPtr ix - l <- fromIntegral <$> peek (p'libusb_iso_packet_descriptor'length isoPtr) - bs <- BI.create l $ \p -> copyArray p ptr l - VGM.unsafeWrite mv ix bs - go (ix+1) (ptr `plusPtr` l) - | otherwise = VG.unsafeFreeze mv - go 0 bufferPtr -#endif - --------------------------------------------------------------------------------- - -createAndTrimNoOffset :: Size -> (Ptr Word8 -> IO (Size, a)) -> IO (B.ByteString, a) -createAndTrimNoOffset size f = BI.createAndTrim' size $ \ptr -> do - (l, x) <- f ptr - return (offset, l, x) - where - offset = 0 - --------------------------------------------------------------------------------- --- * Exceptions --------------------------------------------------------------------------------- - --- | @handleUSBException action@ executes @action@. If @action@ returned an --- error code other than 'c\'LIBUSB_SUCCESS', the error is converted to a --- 'USBException' and thrown. -handleUSBException :: IO CInt -> IO () -handleUSBException action = do err <- action - when (err /= c'LIBUSB_SUCCESS) - (throwIO $ convertUSBException err) - --- | @checkUSBException action@ executes @action@. If @action@ returned a --- negative integer the integer is converted to a 'USBException' and thrown. If --- not, the integer is returned. -checkUSBException :: (Integral a, Show a) => IO a -> IO Int -checkUSBException action = do r <- action - if r < 0 - then throwIO $ convertUSBException r - else return $ fromIntegral r - --- | Convert a @C'libusb_error@ to a 'USBException'. If the @C'libusb_error@ is --- unknown an 'error' is thrown. -convertUSBException :: (Num a, Eq a, Show a) => a -> USBException -convertUSBException err = fromMaybe unknownLibUsbError $ - lookup err libusb_error_to_USBException - where - unknownLibUsbError = - moduleError $ "Unknown libusb error code: " ++ show err ++ "!" - --- | Association list mapping 'C'libusb_error's to 'USBException's. -libusb_error_to_USBException :: Num a => [(a, USBException)] -libusb_error_to_USBException = - [ (c'LIBUSB_ERROR_IO, ioException) - , (c'LIBUSB_ERROR_INVALID_PARAM, InvalidParamException) - , (c'LIBUSB_ERROR_ACCESS, AccessException) - , (c'LIBUSB_ERROR_NO_DEVICE, NoDeviceException) - , (c'LIBUSB_ERROR_NOT_FOUND, NotFoundException) - , (c'LIBUSB_ERROR_BUSY, BusyException) - , (c'LIBUSB_ERROR_TIMEOUT, TimeoutException) - , (c'LIBUSB_ERROR_OVERFLOW, OverflowException) - , (c'LIBUSB_ERROR_PIPE, PipeException) - , (c'LIBUSB_ERROR_INTERRUPTED, InterruptedException) - , (c'LIBUSB_ERROR_NO_MEM, NoMemException) - , (c'LIBUSB_ERROR_NOT_SUPPORTED, NotSupportedException) - , (c'LIBUSB_ERROR_OTHER, OtherException) - ] - --- | Type of USB exceptions. -data USBException = - IOException String -- ^ Input/output exception. - | InvalidParamException -- ^ Invalid parameter. - | AccessException -- ^ Access denied (insufficient permissions). It may - -- help to run your program with elevated privileges or - -- change the permissions of your device using - -- something like @udev@. - | NoDeviceException -- ^ No such device (it may have been disconnected). - | NotFoundException -- ^ Entity not found. - | BusyException -- ^ Resource busy. - | TimeoutException -- ^ Operation timed out. - | OverflowException -- ^ If the device offered to much data. See - -- in the @libusb@ documentation. - -- - | PipeException -- ^ Pipe exception. - | InterruptedException -- ^ System call interrupted (perhaps due to signal). - | NoMemException -- ^ Insufficient memory. - | NotSupportedException -- ^ Operation not supported or unimplemented on this - -- platform. If possible, it's recommended the check - -- if a certain operation is supported by using the - -- 'hasCapability' API. - | OtherException -- ^ Other exception. - deriving (COMMON_INSTANCES) - -instance Exception USBException - --- | A general 'IOException'. -ioException :: USBException -ioException = IOException "" - --- | 'IOException' that is thrown when the number of bytes /read/ --- doesn't equal the requested number. -incompleteReadException :: USBException -incompleteReadException = incompleteException "read" - --- | 'IOException' that is thrown when the number of bytes /written/ --- doesn't equal the requested number. -incompleteWriteException :: USBException -incompleteWriteException = incompleteException "written" - -incompleteException :: String -> USBException -incompleteException rw = IOException $ - "The number of bytes " ++ rw ++ " doesn't equal the requested number!" - --------------------------------------------------------------------------------- - -moduleError :: String -> error -moduleError msg = error $ thisModule ++ ": " ++ msg - -thisModule :: String -thisModule = "System.USB.Base" diff --git a/System/USB/Descriptors.hs b/System/USB/Descriptors.hs deleted file mode 100644 --- a/System/USB/Descriptors.hs +++ /dev/null @@ -1,77 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE Trustworthy #-} -#endif - --------------------------------------------------------------------------------- --- | --- Module : System.USB.Descriptors --- Copyright : (c) 2009–2017 Bas van Dijk --- License : BSD3 (see the file LICENSE) --- Maintainer : Bas van Dijk --- --- USB devices report their attributes using descriptors. A descriptor is a data --- structure with a defined format. Using descriptors allows concise storage of --- the attributes of individual configurations because each configuration may --- reuse descriptors or portions of descriptors from other configurations that --- have the same characteristics. In this manner, the descriptors resemble --- individual data records in a relational database. --- --- Where appropriate, descriptors contain references to string descriptors --- ('StrIx') that provide textual information describing a descriptor in --- human-readable form. Note that the inclusion of string descriptors is --- optional. --- --------------------------------------------------------------------------------- - -module System.USB.Descriptors - ( -- * Device descriptor - getDeviceDesc - , DeviceDesc(..) - - , ReleaseNumber - - -- | For a database of USB vendors and products see the @usb-id-database@ - -- package at: - , VendorId, ProductId - - -- * Configuration descriptor - , getConfigDesc - , ConfigDesc(..) - - -- *** Configuration attributes - , ConfigAttribs - , DeviceStatus(..) - - -- * Interface descriptor - , Interface - , InterfaceDesc(..) - - -- * Endpoint descriptor - , EndpointDesc(..) - - -- *** Endpoint address - , EndpointAddress(..) - , TransferDirection(..) - - -- *** Endpoint attributes - , EndpointAttribs - , TransferType(..) - -- **** Isochronous transfer attributes - , Synchronization(..) - , Usage(..) - - -- *** Endpoint max packet size - , MaxPacketSize(..) - , TransactionOpportunities(..) - , maxIsoPacketSize - - -- * String descriptors - , getLanguages - , LangId, PrimaryLangId, SubLangId - , StrIx - , getStrDesc - , getStrDescFirstLang - ) where - -import System.USB.Base diff --git a/System/USB/DeviceHandling.hs b/System/USB/DeviceHandling.hs deleted file mode 100644 --- a/System/USB/DeviceHandling.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE Trustworthy #-} -#endif - --------------------------------------------------------------------------------- --- | --- Module : System.USB.Devices --- Copyright : (c) 2009–2017 Bas van Dijk --- License : BSD3 (see the file LICENSE) --- Maintainer : Bas van Dijk --- --- The module provides functionality for opening, closing and configuring USB --- devices. --- --------------------------------------------------------------------------------- - -module System.USB.DeviceHandling - ( -- * Opening & closing devices - DeviceHandle - , openDevice - , closeDevice - , withDeviceHandle - , getDevice - - -- * Getting & setting the configuration - , ConfigValue - , getConfig - , setConfig - - -- * Claiming & releasing interfaces - , InterfaceNumber - , claimInterface - , releaseInterface - , withClaimedInterface - - -- * Setting interface alternate settings - , InterfaceAltSetting - , setInterfaceAltSetting - - -- * Clearing & Resetting devices - , clearHalt - , resetDevice - - -- * USB kernel drivers - , setAutoDetachKernelDriver - , kernelDriverActive - , detachKernelDriver - , attachKernelDriver - , withDetachedKernelDriver - ) where - -import System.USB.Base diff --git a/System/USB/Enumeration.hs b/System/USB/Enumeration.hs deleted file mode 100644 --- a/System/USB/Enumeration.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE Trustworthy #-} -#endif - --------------------------------------------------------------------------------- --- | --- Module : System.USB.Devices --- Copyright : (c) 2009–2017 Bas van Dijk --- License : BSD3 (see the file LICENSE) --- Maintainer : Bas van Dijk --- --- This module provides functionality for enumerating the USB devices currently --- attached to the system. --- --------------------------------------------------------------------------------- - -module System.USB.Enumeration - ( Device - - -- * Device enumeration - , getDevices - - -- * Device hotplug event notification - - -- | Instead of enumerating all devices attached to the system using - -- 'getDevices' you can also be notified on device attachment and removal - -- using the hotplug event notification API. - - -- ** Hotplug events - , HotplugEvent - , deviceArrived - , deviceLeft - - , matchDeviceArrived - , matchDeviceLeft - - -- ** Hotplug flags - , HotplugFlag, enumerate - - -- ** Asynchronous event notification - , HotplugCallback - , CallbackRegistrationStatus(..) - , HotplugCallbackHandle - , registerHotplugCallback - , deregisterHotplugCallback - - -- * Device location - , busNumber - , portNumber - , portNumbers - , deviceAddress - - -- * Device speed - , deviceSpeed - , Speed(..) - ) where - -import System.USB.Base diff --git a/System/USB/Exceptions.hs b/System/USB/Exceptions.hs deleted file mode 100644 --- a/System/USB/Exceptions.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE Trustworthy #-} -#endif - --------------------------------------------------------------------------------- --- | --- Module : System.USB.Exceptions --- Copyright : (c) 2009–2017 Bas van Dijk --- License : BSD3 (see the file LICENSE) --- Maintainer : Bas van Dijk --- --------------------------------------------------------------------------------- - -module System.USB.Exceptions - ( USBException(..) - , ioException - , incompleteReadException - , incompleteWriteException - ) where - -import System.USB.Base diff --git a/System/USB/IO.hs b/System/USB/IO.hs deleted file mode 100644 --- a/System/USB/IO.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# LANGUAGE CPP, NoImplicitPrelude #-} - -#if __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE Trustworthy #-} -#endif - --------------------------------------------------------------------------------- --- | --- Module : System.USB.IO --- Copyright : (c) 2009–2017 Bas van Dijk --- License : BSD3 (see the file LICENSE) --- Maintainer : Bas van Dijk --- --- This module provides functions for performing /control/, /bulk/ and --- /interrupt/ transfers. --- --- When your system supports the GHC 'EventManager' this module additionally --- exports functions for performing /isochronous/ transfers. These are currently --- not available on Windows. --- --- /WARNING:/ You need to enable the threaded runtime (@-threaded@) when using --- the isochronous functions. They throw a runtime error otherwise! --- --------------------------------------------------------------------------------- - -module System.USB.IO - ( - -- * One-off transfers - ReadAction, ReadExactAction - , WriteAction, WriteExactAction - , Size - , Timeout, noTimeout - , Status(..) - - -- ** Control transfers - , ControlSetup(..) - , RequestType(..) - , Recipient(..) - , Request - , Value - , Index - - , control - , readControl, readControlExact - , writeControl, writeControlExact - - -- ** Bulk transfers - , readBulk - , writeBulk - - -- ** Interrupt transfers - , readInterrupt - , writeInterrupt - -#ifdef HAS_EVENT_MANAGER - -- ** Isochronous transfers - -- | /WARNING:/ You need to enable the threaded runtime (@-threaded@) when using - -- the isochronous functions. They throw a runtime error otherwise! - , readIsochronous - , writeIsochronous -#endif - ) where - -#ifdef __HADDOCK_VERSION__ -#ifdef HAS_EVENT_MANAGER -#if MIN_VERSION_base(4,4,0) -import GHC.Event -#else -import System.Event -#endif - ( EventManager ) -#endif -#endif - -import System.USB.Base diff --git a/System/USB/IO/StandardDeviceRequests.hs b/System/USB/IO/StandardDeviceRequests.hs deleted file mode 100644 --- a/System/USB/IO/StandardDeviceRequests.hs +++ /dev/null @@ -1,310 +0,0 @@ -{-# LANGUAGE CPP, NoImplicitPrelude, DeriveDataTypeable #-} - -#if __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE Trustworthy #-} -#endif - -{-# OPTIONS_HADDOCK hide #-} - --------------------------------------------------------------------------------- --- | --- Module : System.USB.IO.StandardDeviceRequests --- Copyright : (c) 2009–2017 Bas van Dijk --- License : BSD3 (see the file LICENSE) --- Maintainer : Bas van Dijk --- --- /This module is for testing purposes only!/ --- --- This module provides functions for performing standard device requests. --- The functions are primarily used for testing USB devices. --- --- To avoid name clashes with functions from @System.USB@ it is advised to use --- an explicit import list or a qualified import. --- --------------------------------------------------------------------------------- - -module System.USB.IO.StandardDeviceRequests - ( setHalt - , setConfig, getConfig - , clearRemoteWakeup - , setRemoteWakeup - , setStandardTestMode, TestMode(..) - , getInterfaceAltSetting - , getDeviceStatus - , getEndpointStatus - , setDeviceAddress - , synchFrame, FrameNumber - ) where - - --------------------------------------------------------------------------------- --- Imports --------------------------------------------------------------------------------- - --- from base: -import Data.Bits ( testBit, shiftL ) -import Data.Bool ( Bool ) -import Data.Data ( Data ) -import Data.Eq ( Eq, (==) ) -import Data.Function ( ($), (.) ) -import Data.Functor ( fmap ) -import Data.Maybe ( Maybe(Nothing, Just), maybe ) -import Data.Typeable ( Typeable ) -import Data.Word ( Word8, Word16 ) -import Prelude ( (+), (*), fromIntegral, Enum ) -import System.IO ( IO ) -import Text.Read ( Read ) -import Text.Show ( Show ) - -#if __GLASGOW_HASKELL__ < 700 -import Prelude ( fromInteger ) -#endif - --- from bytestring: -import qualified Data.ByteString as B ( ByteString, head, unpack ) - --- from bindings-libusb: -import Bindings.Libusb ( c'LIBUSB_REQUEST_SET_FEATURE - , c'LIBUSB_REQUEST_SET_CONFIGURATION - , c'LIBUSB_REQUEST_GET_CONFIGURATION - , c'LIBUSB_REQUEST_CLEAR_FEATURE - , c'LIBUSB_REQUEST_GET_INTERFACE - , c'LIBUSB_REQUEST_GET_STATUS - , c'LIBUSB_REQUEST_SET_ADDRESS - , c'LIBUSB_REQUEST_SYNCH_FRAME - ) - --- from usb: -import System.USB.DeviceHandling ( DeviceHandle - , ConfigValue - , InterfaceNumber - , InterfaceAltSetting - ) -#ifdef __HADDOCK_VERSION__ -import qualified System.USB.DeviceHandling as USB ( setConfig, getConfig ) -#endif - -import System.USB.Descriptors ( EndpointAddress - , DeviceStatus(..) - ) -import System.USB.IO ( Timeout - , ControlSetup(..) - , RequestType(Standard) - , Recipient( ToDevice - , ToInterface - , ToEndpoint - ) - , Value - , control, readControlExact - ) - -import System.USB.Base ( marshalEndpointAddress ) - -import Utils ( genFromEnum ) - - --------------------------------------------------------------------------------- --- Standard Device Requests -------------------------------------------------------------------------------- - --- See: USB 2.0 Spec. section 9.4 - --- Standard Feature Selectors: --- See: USB 2.0 Spec. table 9-6 -haltFeature, remoteWakeupFeature, testModeFeature :: Value -haltFeature = 0 -remoteWakeupFeature = 1 -testModeFeature = 2 - --- | See: USB 2.0 Spec. section 9.4.9 -setHalt :: DeviceHandle -> EndpointAddress -> (Timeout -> IO ()) -setHalt devHndl endpointAddr = control devHndl - ControlSetup - { controlSetupRequestType = Standard - , controlSetupRecipient = ToEndpoint - , controlSetupRequest = c'LIBUSB_REQUEST_SET_FEATURE - , controlSetupValue = haltFeature - , controlSetupIndex = marshalEndpointAddress endpointAddr - } - --- | See: USB 2.0 Spec. section 9.4.7 --- --- /This function is for testing purposes only!/ --- --- You should normally use @System.USB.DeviceHandling.'USB.setConfig'@ because --- that function notifies the underlying operating system about the changed --- configuration. -setConfig :: DeviceHandle -> Maybe ConfigValue -> (Timeout -> IO ()) -setConfig devHndl mbConfigValue = control devHndl - ControlSetup - { controlSetupRequestType = Standard - , controlSetupRecipient = ToDevice - , controlSetupRequest = c'LIBUSB_REQUEST_SET_CONFIGURATION - , controlSetupValue = marshal mbConfigValue - , controlSetupIndex = 0 - } - where - marshal :: Maybe ConfigValue -> Value - marshal = maybe 0 fromIntegral - --- | See: USB 2.0 Spec. section 9.4.2 --- --- /This function is for testing purposes only!/ --- --- You should normally use @System.USB.DeviceHandling.'USB.getConfig'@ because --- that functon may exploit operating system caches (no I/O involved). -getConfig :: DeviceHandle -> (Timeout -> IO (Maybe ConfigValue)) -getConfig devHndl = fmap (unmarshal . B.head) - . readControlExact devHndl ctrlSetup 1 - where - ctrlSetup = ControlSetup - { controlSetupRequestType = Standard - , controlSetupRecipient = ToDevice - , controlSetupRequest = c'LIBUSB_REQUEST_GET_CONFIGURATION - , controlSetupValue = 0 - , controlSetupIndex = 0 - } - - unmarshal :: Word8 -> Maybe ConfigValue - unmarshal 0 = Nothing - unmarshal n = Just $ fromIntegral n - --- | See: USB 2.0 Spec. section 9.4.1 -clearRemoteWakeup :: DeviceHandle -> (Timeout -> IO ()) -clearRemoteWakeup devHndl = control devHndl - ControlSetup - { controlSetupRequestType = Standard - , controlSetupRecipient = ToDevice - , controlSetupRequest = c'LIBUSB_REQUEST_CLEAR_FEATURE - , controlSetupValue = remoteWakeupFeature - , controlSetupIndex = 0 - } - --- | See: USB 2.0 Spec. section 9.4.9 -setRemoteWakeup :: DeviceHandle -> (Timeout -> IO ()) -setRemoteWakeup devHndl = control devHndl - ControlSetup - { controlSetupRequestType = Standard - , controlSetupRecipient = ToDevice - , controlSetupRequest = c'LIBUSB_REQUEST_SET_FEATURE - , controlSetupValue = remoteWakeupFeature - , controlSetupIndex = 0 - } - --- | See: USB 2.0 Spec. section 9.4.9 --- TODO: What about vendor-specific test modes? -setStandardTestMode :: DeviceHandle -> TestMode -> (Timeout -> IO ()) -setStandardTestMode devHndl testMode = control devHndl - ControlSetup - { controlSetupRequestType = Standard - , controlSetupRecipient = ToDevice - , controlSetupRequest = c'LIBUSB_REQUEST_SET_FEATURE - , controlSetupValue = testModeFeature - , controlSetupIndex = (genFromEnum testMode + 1) `shiftL` 8 - } - --- | See: USB 2.0 Spec. table 9-7 -data TestMode = Test_J - | Test_K - | Test_SE0_NAK - | Test_Packet - | Test_Force_Enable - deriving (Eq, Show, Read, Enum, Data, Typeable) - --- | See: USB 2.0 Spec. section 9.4.4 -getInterfaceAltSetting :: DeviceHandle -> InterfaceNumber -> (Timeout -> IO InterfaceAltSetting) -getInterfaceAltSetting devHndl ifNum = - fmap B.head . readControlExact devHndl ctrlSetup 1 - where - ctrlSetup = ControlSetup - { controlSetupRequestType = Standard - , controlSetupRecipient = ToInterface - , controlSetupRequest = c'LIBUSB_REQUEST_GET_INTERFACE - , controlSetupValue = 0 - , controlSetupIndex = fromIntegral ifNum - } - --- | See: USB 2.0 Spec. section 9.4.5 -getDeviceStatus :: DeviceHandle -> (Timeout -> IO DeviceStatus) -getDeviceStatus devHndl = - fmap (unmarshal . B.head) . readControlExact devHndl ctrlSetup 2 - where - ctrlSetup = ControlSetup - { controlSetupRequestType = Standard - , controlSetupRecipient = ToDevice - , controlSetupRequest = c'LIBUSB_REQUEST_GET_STATUS - , controlSetupValue = 0 - , controlSetupIndex = 0 - } - - unmarshal :: Word8 -> DeviceStatus - unmarshal a = DeviceStatus { remoteWakeup = testBit a 1 - , selfPowered = testBit a 0 - } - --- | See: USB 2.0 Spec. section 9.4.5 -getEndpointStatus :: DeviceHandle -> EndpointAddress -> (Timeout -> IO Bool) -getEndpointStatus devHndl endpointAddr = - fmap ((1 ==) . B.head) . readControlExact devHndl ctrlSetup 2 - where - ctrlSetup = ControlSetup - { controlSetupRequestType = Standard - , controlSetupRecipient = ToEndpoint - , controlSetupRequest = c'LIBUSB_REQUEST_GET_STATUS - , controlSetupValue = 0 - , controlSetupIndex = marshalEndpointAddress endpointAddr - } - --- | See: USB 2.0 Spec. section 9.4.6 -setDeviceAddress :: DeviceHandle -> Word16 -> (Timeout -> IO ()) -setDeviceAddress devHndl deviceAddr = control devHndl - ControlSetup - { controlSetupRequestType = Standard - , controlSetupRecipient = ToDevice - , controlSetupRequest = c'LIBUSB_REQUEST_SET_ADDRESS - , controlSetupValue = deviceAddr - , controlSetupIndex = 0 - } - --- TODO: setDescriptor See: USB 2.0 Spec. section 9.4.8 - --- TODO Sync Frame klopt niet helemaal, je kunt met deze request ook het frame number setten! - -{-| -This request is used to set and then report an endpoint's synchronization frame. - -When an endpoint supports isochronous transfers, the endpoint may also require -per-frame transfers to vary in size according to a specific pattern. The host -and the endpoint must agree on which frame the repeating pattern begins. The -number of the frame in which the pattern began is returned to the host. - -If a high-speed device supports the Synch Frame request, it must internally -synchronize itself to the zeroth microframe and have a time notion of classic -frame. Only the frame number is used to synchronize and reported by the device -endpoint (i.e., no microframe number). The endpoint must synchronize to the -zeroth microframe. - -This value is only used for isochronous data transfers using implicit pattern -synchronization. If the specified endpoint does not support this request, then -the device will respond with a Request Error. - -See: USB 2.0 Spec. section 9.4.11 --} -synchFrame :: DeviceHandle -> EndpointAddress -> (Timeout -> IO FrameNumber) -synchFrame devHndl endpointAddr = - fmap unmarshal . readControlExact devHndl ctrlSetup 2 - where - ctrlSetup = ControlSetup - { controlSetupRequestType = Standard - , controlSetupRecipient = ToEndpoint - , controlSetupRequest = c'LIBUSB_REQUEST_SYNCH_FRAME - , controlSetupValue = 0 - , controlSetupIndex = marshalEndpointAddress endpointAddr - } - - unmarshal :: B.ByteString -> FrameNumber - unmarshal bs = let [h, l] = B.unpack bs - in fromIntegral h * 256 + fromIntegral l - --- | Endpoint's synchronization frame. -type FrameNumber = Word16 diff --git a/System/USB/IO/Transfers.hs b/System/USB/IO/Transfers.hs deleted file mode 100644 --- a/System/USB/IO/Transfers.hs +++ /dev/null @@ -1,173 +0,0 @@ -{-# LANGUAGE CPP, NoImplicitPrelude #-} - -#if __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE Trustworthy #-} -#endif - --------------------------------------------------------------------------------- --- | --- Module : System.USB.IO.Transfers --- Copyright : (c) 2009–2017 Bas van Dijk --- License : BSD3 (see the file LICENSE) --- Maintainer : Bas van Dijk --- Stability : Experimental --- --- /WARNING:/ This module is experimental and untested. The API will likely --- change in future releases. --- --- /WARNING:/ This module is only available on systems which support the GHC --- 'EventManager'. --- --- /WARNING:/ You need to enable the threaded runtime (@-threaded@) when using --- this module. The functions throw a runtime error otherwise! --- --- This modules provides alternative I\/O operations than the ones in --- "System.USB.IO". The difference is that this module separates the --- construction from the execution of a USB transfer. This has the --- advantage that a transfer can be constructed once and executed --- multiple times thereby saving repeated allocation costs. --- --------------------------------------------------------------------------------- - -module System.USB.IO.Transfers - ( - -- * Control transfers - - -- ** No data transfer - ControlTransfer - , newControlTransfer - , performControlTransfer - - -- *** Setting - , setControlTransferDeviceHandle - , setControlTransferTimeout - , setControlSetup - - -- *** Getting - , getControlTransferDeviceHandle - , getControlTransferTimeout - - -- ** Reading - , ControlReadTransfer - - , newControlReadTransfer - - , performControlReadTransfer - - -- *** Setting - , setControlReadTransferDeviceHandle - , setControlReadTransferTimeout - , setControlReadSetup - - -- *** Getting - , getControlReadTransferDeviceHandle - , getControlReadTransferTimeout - - -- ** Writing - , ControlWriteTransfer - - , newControlWriteTransfer - - , performControlWriteTransfer - - -- *** Setting - , setControlWriteTransferDeviceHandle - , setControlWriteTransferTimeout - , setControlWriteSetup - - -- *** Getting - , getControlWriteTransferDeviceHandle - , getControlWriteTransferTimeout - - -- * Bulk / Interrupt transfers - , RepeatableTransferType(..) - - -- ** Reading - , ReadTransfer - - , newReadTransfer - - , performReadTransfer - - -- *** Setting - , setReadTransferType - , setReadTransferDeviceHandle - , setReadTransferEndpointAddress - , setReadTransferTimeout - , setReadTransferSize - - -- *** Getting - , getReadTransferType - , getReadTransferDeviceHandle - , getReadTransferEndpointAddress - , getReadTransferTimeout - , getReadTransferSize - - -- ** Writing - , WriteTransfer - - , newWriteTransfer - - , performWriteTransfer - - -- *** Setting - , setWriteTransferType - , setWriteTransferDeviceHandle - , setWriteTransferEndpointAddress - , setWriteTransferTimeout - , setWriteTransferInput - - -- *** Getting - , getWriteTransferType - , getWriteTransferDeviceHandle - , getWriteTransferEndpointAddress - , getWriteTransferTimeout - , getWriteTransferInput - - -- * Isochronous transfers - - -- ** Reading - , IsochronousReadTransfer - - , newIsochronousReadTransfer - - , performIsochronousReadTransfer - - -- *** Setting - , setIsochronousReadTransferDeviceHandle - , setIsochronousReadTransferEndpointAddress - , setIsochronousReadTransferSizes - - -- *** Getting - , getIsochronousReadTransferDeviceHandle - , getIsochronousReadTransferEndpointAddress - , getIsochronousReadTransferSizes - - -- ** Writing - , IsochronousWriteTransfer - - , newIsochronousWriteTransfer - - , performIsochronousWriteTransfer - - -- *** Setting - , setIsochronousWriteTransferDeviceHandle - , setIsochronousWriteTransferEndpointAddress - , setIsochronousWriteTransferPackets - - -- *** Getting - , getIsochronousWriteTransferDeviceHandle - , getIsochronousWriteTransferEndpointAddress - , getIsochronousWriteTransferPackets - ) where - -#ifdef __HADDOCK_VERSION__ -#if MIN_VERSION_base(4,4,0) -import GHC.Event -#else -import System.Event -#endif - ( EventManager ) -#endif - -import System.USB.Base diff --git a/System/USB/Initialization.hs b/System/USB/Initialization.hs deleted file mode 100644 --- a/System/USB/Initialization.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE CPP #-} - -#if __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE Trustworthy #-} -#endif - --------------------------------------------------------------------------------- --- | --- Module : System.USB.Init --- Copyright : (c) 2009–2017 Bas van Dijk --- License : BSD3 (see the file LICENSE) --- Maintainer : Bas van Dijk --- --- This module provides functionality for initializing the @usb@ library. --- --------------------------------------------------------------------------------- - -module System.USB.Initialization - ( Ctx - , newCtx -#ifdef HAS_EVENT_MANAGER - , newCtx' -#endif - - -- * Logging - , setDebug - , Verbosity(..) - ) where - -import System.USB.Base diff --git a/System/USB/Misc.hs b/System/USB/Misc.hs deleted file mode 100644 --- a/System/USB/Misc.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE CPP #-} - -#if __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE Trustworthy #-} -#endif - --------------------------------------------------------------------------------- --- | --- Module : System.USB.Misc --- Copyright : (c) 2009–2017 Bas van Dijk --- License : BSD3 (see the file LICENSE) --- Maintainer : Bas van Dijk --- --- This module provides miscellaneous functionality. --- --------------------------------------------------------------------------------- - -module System.USB.Misc - ( - -- * Capabilties of @libusb@ - Capability(..) - , hasCapability - - -- * Version of @libusb@ - , LibusbVersion(..) - , libusbVersion - , toVersion - ) where - -import System.USB.Base diff --git a/SystemEventManager.hs b/SystemEventManager.hs deleted file mode 100644 --- a/SystemEventManager.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE CPP, NoImplicitPrelude #-} - -#if MIN_VERSION_base(4,4,0) -module SystemEventManager ( getSystemEventManager ) where -import GHC.Event ( getSystemEventManager ) -#else - -{-# LANGUAGE UnicodeSyntax, ForeignFunctionInterface #-} - -module SystemEventManager ( getSystemEventManager ) where - --- from base: -import Data.Function ( ($) ) -import Data.IORef ( IORef, newIORef, readIORef ) -import Data.Maybe ( Maybe(Nothing) ) -import Foreign.Ptr ( Ptr ) -import GHC.Conc.Sync ( sharedCAF ) -import System.Event ( EventManager ) -import System.IO ( IO ) -import System.IO.Unsafe ( unsafePerformIO ) - -getSystemEventManager ∷ IO (Maybe EventManager) -getSystemEventManager = readIORef eventManager - -eventManager ∷ IORef (Maybe EventManager) -eventManager = unsafePerformIO $ do - em ← newIORef Nothing - sharedCAF em getOrSetSystemEventThreadEventManagerStore -{-# NOINLINE eventManager #-} - -foreign import ccall unsafe "getOrSetSystemEventThreadEventManagerStore" - getOrSetSystemEventThreadEventManagerStore ∷ Ptr α → IO (Ptr α) -#endif diff --git a/Utils.hs b/Utils.hs deleted file mode 100644 --- a/Utils.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# LANGUAGE CPP - , NoImplicitPrelude - , BangPatterns - , ScopedTypeVariables - #-} - -module Utils where - --------------------------------------------------------------------------------- --- Imports --------------------------------------------------------------------------------- - --- from base: -import Prelude ( ($) - , Num, (+), (*), (-) - , Enum, toEnum, fromEnum - , Integral, fromIntegral, undefined - ) - -#if __GLASGOW_HASKELL__ < 700 -import Prelude ( fromInteger, fail ) -#endif - -import Control.Monad ( Monad, return, (>>=), (>>) ) -import Foreign.Ptr ( Ptr ) -import Foreign.ForeignPtr ( withForeignPtr ) -import Foreign.Storable ( Storable, peek, sizeOf ) -import Foreign.Marshal.Alloc ( alloca ) -import Foreign.Marshal.Utils ( copyBytes ) -import Data.Bool ( Bool, otherwise, (&&) ) -import Data.Ord ( Ord, (<=), (>=) ) -import Data.Bits ( Bits, shiftL, shiftR, (.&.) ) -import Data.Function ( (.) ) -import Data.Int ( Int ) -import Data.Maybe ( Maybe(Nothing, Just) ) -import System.IO ( IO ) -import GHC.ForeignPtr ( mallocPlainForeignPtrBytes ) - --- from vector: -import Data.Vector ( Vector ) -import qualified Data.Vector as V ( null, unsafeHead, unsafeTail ) -import qualified Data.Vector.Storable as VS ( Vector, empty, null - , unsafeFromForeignPtr0 - , unsafeToForeignPtr0 - ) -import qualified Data.Vector.Generic as VG ( Vector, mapM, convert ) - - --------------------------------------------------------------------------------- --- Utils --------------------------------------------------------------------------------- - --- | @bits s e b@ extract bit @s@ to @e@ (including) from @b@. -bits :: (Bits a, Num a) => Int -> Int -> a -> a -bits s e b = ((1 `shiftL` (e - s + 1)) - 1) .&. (b `shiftR` s) - --- | @between n b e@ tests if @n@ is between the given bounds @b@ and @e@ --- (including). -between :: Ord a => a -> a -> a -> Bool -between n b e = n >= b && n <= e - --- | A generalized 'toEnum' that works on any 'Integral' type. -genToEnum :: (Integral i, Enum e) => i -> e -genToEnum = toEnum . fromIntegral - --- | A generalized 'fromEnum' that returns any 'Integral' type. -genFromEnum :: (Integral i, Enum e) => e -> i -genFromEnum = fromIntegral . fromEnum - --- | @mapPeekArray f n a@ applies the monadic function @f@ to each of the @n@ --- elements of the array @a@ and returns the results in a list. -mapPeekArray :: (Storable a, VG.Vector v a, VG.Vector v b) - => (a -> IO b) -> Int -> Ptr a -> IO (v b) -mapPeekArray f n a = peekVector n a >>= VG.mapM f . VG.convert - -peekVector :: forall a. (Storable a) => Int -> Ptr a -> IO (VS.Vector a) -peekVector size ptr - | size <= 0 = return VS.empty - | otherwise = do - let n = (size * sizeOf (undefined :: a)) - fp <- mallocPlainForeignPtrBytes n - withForeignPtr fp $ \p -> copyBytes p ptr n - return $ VS.unsafeFromForeignPtr0 fp size - --- | Write the elements of a storable vector to the given array. -pokeVector :: forall a. Storable a => Ptr a -> VS.Vector a -> IO () -pokeVector ptr v | VS.null v = return () - | otherwise = withForeignPtr fp $ \p -> - copyBytes ptr p (size * sizeOf (undefined :: a)) - where - (fp, size) = VS.unsafeToForeignPtr0 v - -allocaPeek :: Storable a => (Ptr a -> IO ()) -> IO a -allocaPeek f = alloca $ \ptr -> f ptr >> peek ptr - --- | Monadic if...then...else... -ifM :: Monad m => m Bool -> m a -> m a -> m a -ifM cM tM eM = cM >>= \c -> if c then tM else eM - -uncons :: Vector a -> Maybe (a, Vector a) -uncons v | V.null v = Nothing - | otherwise = Just (V.unsafeHead v, V.unsafeTail v) diff --git a/default.nix b/default.nix deleted file mode 100644 --- a/default.nix +++ /dev/null @@ -1,2 +0,0 @@ -let pkgs = import {}; -in pkgs.haskellPackages.callPackage ./usb.nix {} diff --git a/shell.nix b/shell.nix deleted file mode 100644 --- a/shell.nix +++ /dev/null @@ -1,15 +0,0 @@ -{ nixpkgs ? import {}, compiler ? "default" }: - -let - - inherit (nixpkgs) pkgs; - - haskellPackages = if compiler == "default" - then pkgs.haskellPackages - else pkgs.haskell.packages.${compiler}; - - drv = haskellPackages.callPackage (import ./usb.nix) {}; - -in - - if pkgs.lib.inNixShell then drv.env else drv diff --git a/src/Event.hs b/src/Event.hs new file mode 100644 --- /dev/null +++ b/src/Event.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE NoImplicitPrelude, CPP #-} + +module Event ( Event, evtRead, evtWrite ) where + +#if MIN_VERSION_base(4,4,0) +import GHC.Event ( Event, evtRead, evtWrite ) +#else +import System.Event ( Event, evtRead, evtWrite ) +#endif diff --git a/src/Poll.hsc b/src/Poll.hsc new file mode 100644 --- /dev/null +++ b/src/Poll.hsc @@ -0,0 +1,27 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +#include + +module Poll ( toEvent ) where + +-- from base: +import Data.Bits ( (.&.) ) +import Data.Bool ( otherwise ) +import Data.Eq ( (/=) ) +import Data.Monoid ( mempty, mappend ) +import Foreign.C.Types ( CShort ) + +-- from usb: +-- I need to import GHC.Event or System.Event based on the version of base. +-- However it's currently not possible to use cabal macros in .hsc files. +-- See: http://hackage.haskell.org/trac/hackage/ticket/870 +-- So I use an intermediate module that makes the choice: +import Event ( Event, evtRead, evtWrite ) + +toEvent :: CShort -> Event +toEvent e = remap (#const POLLIN) evtRead `mappend` + remap (#const POLLOUT) evtWrite + where + remap evt to + | e .&. evt /= 0 = to + | otherwise = mempty diff --git a/src/System/USB.hs b/src/System/USB.hs new file mode 100644 --- /dev/null +++ b/src/System/USB.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 704 +{-# LANGUAGE Safe #-} +#endif + +-------------------------------------------------------------------------------- +-- | +-- Module : System.USB +-- Copyright : (c) 2009–2017 Bas van Dijk +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Bas van Dijk +-- +-- A convenience module which re-exports all the important modules. +-- +-------------------------------------------------------------------------------- + +module System.USB + ( module System.USB.Initialization + , module System.USB.Misc + , module System.USB.Enumeration + , module System.USB.DeviceHandling + , module System.USB.Descriptors + , module System.USB.IO +#ifdef HAS_EVENT_MANAGER + , module System.USB.IO.Transfers +#endif + , module System.USB.Exceptions + ) where + +import System.USB.Initialization +import System.USB.Misc +import System.USB.Enumeration +import System.USB.DeviceHandling +import System.USB.Descriptors +import System.USB.IO +#ifdef HAS_EVENT_MANAGER +import System.USB.IO.Transfers +#endif +import System.USB.Exceptions diff --git a/src/System/USB/Base.hs b/src/System/USB/Base.hs new file mode 100644 --- /dev/null +++ b/src/System/USB/Base.hs @@ -0,0 +1,3808 @@ +{-# LANGUAGE CPP + , NoImplicitPrelude + , DeriveDataTypeable + , BangPatterns + , ScopedTypeVariables + #-} + +#if __GLASGOW_HASKELL__ >= 704 +{-# LANGUAGE Unsafe #-} +#endif + +#ifdef HAS_EVENT_MANAGER +{-# LANGUAGE PatternGuards #-} +#endif + +#ifdef GENERICS +{-# LANGUAGE DeriveGeneric #-} +#endif + +module System.USB.Base where + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +-- from base: +import Prelude ( Num, (+), (-), (*), Integral, fromIntegral, div + , Enum, fromEnum, error, String ) +import Foreign.C.Types ( CUChar, CInt, CUInt ) +import Foreign.C.String ( CStringLen, peekCString ) +import Foreign.Marshal.Alloc ( alloca ) +import Foreign.Marshal.Array ( allocaArray ) +import Foreign.Marshal.Utils ( toBool, fromBool ) +import Foreign.Storable ( peek, peekElemOff ) +import Foreign.Ptr ( Ptr, castPtr, plusPtr, nullPtr, freeHaskellFunPtr ) +import Foreign.ForeignPtr ( ForeignPtr, withForeignPtr, touchForeignPtr ) +import Control.Applicative ( (<*>) ) +import Control.Exception ( Exception, throwIO, bracket, bracket_ + , onException, assert ) +import Control.Concurrent.MVar ( MVar, newEmptyMVar, takeMVar, putMVar ) +import Control.Monad ( (>>=), (=<<), return, when ) +import Control.Arrow ( (&&&) ) +import Data.Function ( ($), (.), on ) +import Data.Data ( Data ) +import Data.Typeable ( Typeable ) +import Data.Maybe ( Maybe(Nothing, Just), maybe, fromMaybe ) +import Data.Monoid ( Monoid, mempty +#if !MIN_VERSION_base(4,11,0) + , mappend +#endif + ) +#if MIN_VERSION_base(4,9,0) +import Data.Semigroup ( Semigroup, (<>) ) +#endif +import Data.List +import Data.Int ( Int ) +import Data.Word ( Word8, Word16 ) +import Data.Eq ( Eq, (==), (/=) ) +import Data.Ord ( Ord, (<), (>) ) +import Data.Bool ( Bool(False, True), not, otherwise, (&&) ) +import Data.Bits ( Bits, (.&.), (.|.), setBit, testBit, shiftL, shiftR ) +import Data.Version ( Version(..) +#if MIN_VERSION_base(4,8,0) + , makeVersion +#endif + ) +import System.IO ( IO ) +import System.IO.Unsafe ( unsafePerformIO ) +import Text.Show ( Show, show ) +import Text.Read ( Read ) +import Text.Printf ( printf ) + +#if MIN_VERSION_base(4,2,0) +import Data.Functor ( fmap, (<$>) ) +#else +import Control.Monad ( fmap ) +import Control.Applicative ( (<$>) ) +#endif + +#if __GLASGOW_HASKELL__ < 700 +import Prelude ( fromInteger, negate ) +import Control.Monad ( (>>), fail ) +#endif + +import qualified Data.Foldable as Foldable ( forM_ ) +import qualified Foreign.Concurrent as FC ( newForeignPtr ) + +-- from bytestring: +import qualified Data.ByteString as B ( ByteString, packCStringLen, drop, length ) +import qualified Data.ByteString.Internal as BI ( createAndTrim, createAndTrim' ) +import qualified Data.ByteString.Unsafe as BU ( unsafeUseAsCStringLen ) + +-- from text: +import Data.Text ( Text ) +import qualified Data.Text.Encoding as TE ( decodeUtf16LE ) + +-- from vector: +import Data.Vector ( Vector ) +import qualified Data.Vector.Generic as VG ( convert, map ) + +-- from bindings-libusb: +import Bindings.Libusb + +-- from usb (this package): +import Utils ( bits, between, genToEnum, genFromEnum, peekVector, mapPeekArray + , allocaPeek, ifM + ) + +import qualified Utils as V ( uncons ) + +-------------------------------------------------------------------------------- + +#ifdef HAS_EVENT_MANAGER +-- from base: +import Prelude ( undefined, seq ) +import Foreign.C.Types ( CShort, CChar, CLong ) +import Foreign.Marshal.Alloc ( allocaBytes, mallocBytes, reallocBytes, free ) +import Foreign.Marshal.Array ( peekArray0, copyArray, advancePtr ) +import Foreign.Storable ( Storable, sizeOf, poke, pokeElemOff ) +import Foreign.Ptr ( nullFunPtr ) +#if MIN_VERSION_base(4,4,0) +import Foreign.ForeignPtr.Unsafe ( unsafeForeignPtrToPtr ) +#else +import Foreign.ForeignPtr ( unsafeForeignPtrToPtr ) +#endif +import Control.Monad ( mapM_, forM_, unless ) +import Data.IORef ( IORef, newIORef, atomicModifyIORef, readIORef, writeIORef ) +import System.Posix.Types ( Fd(Fd) ) +import Control.Exception ( uninterruptibleMask_ ) +import Control.Concurrent.MVar + ( newMVar + , withMVar +#if MIN_VERSION_base(4,7,0) + , withMVarMasked +#endif + ) +import System.IO ( hPutStrLn, stderr ) + +#if MIN_VERSION_base(4,8,0) && !MIN_VERSION_base(4,8,1) +import Unsafe.Coerce ( unsafeCoerce ) +#endif + +#if MIN_VERSION_base(4,4,0) +import GHC.Event +#else +import System.Event +#endif + ( EventManager + , IOCallback + , FdKey + , registerFd, unregisterFd + , registerTimeout, unregisterTimeout +#if MIN_VERSION_base(4,7,0) + , getSystemTimerManager +#endif +#if MIN_VERSION_base(4,8,1) + , Lifetime(MultiShot) +#endif + ) + +-- from containers: +import Data.IntMap ( IntMap ) +import qualified Data.IntMap as IntMap ( empty, insert, updateLookupWithKey, elems ) + +-- from bytestring: +import qualified Data.ByteString.Internal as BI ( create, memcpy, toForeignPtr ) + +--from vector: +import qualified Data.Vector.Unboxed as Unboxed ( Vector ) +import qualified Data.Vector.Storable as Storable ( Vector ) +import qualified Data.Vector.Generic as VG ( empty, length, sum, foldM_, unsafeFreeze) +import qualified Data.Vector.Generic.Mutable as VGM ( unsafeNew, unsafeWrite ) + +-- from usb (this package): +import qualified Poll ( toEvent ) +import SystemEventManager ( getSystemEventManager ) +import Utils ( pokeVector ) + +#include "EventConfig.h" + +#define HAVE_ONE_SHOT \ + (__GLASGOW_HASKELL__ >= 708 && !MIN_VERSION_base(4,8,1) && \ + !(defined(darwin_HOST_OS) || defined(ios_HOST_OS)) && \ + (defined(HAVE_EPOLL) || defined(HAVE_KQUEUE))) + +#endif + +-------------------------------------------------------------------------------- + +#ifdef GENERICS +import GHC.Generics ( Generic ) +#define COMMON_INSTANCES Show, Read, Eq, Data, Typeable, Generic +#else +#define COMMON_INSTANCES Show, Read, Eq, Data, Typeable +#endif + +-------------------------------------------------------------------------------- + +#if MIN_VERSION_base(4,3,0) +import Control.Exception ( mask, mask_ ) +#else +import Control.Exception ( blocked, block, unblock ) +import Data.Function ( id ) + +mask :: ((IO a -> IO a) -> IO b) -> IO b +mask io = do + b <- blocked + if b + then io id + else block $ io unblock + +mask_ :: IO a -> IO a +mask_ = block +#endif + +#if defined(HAS_EVENT_MANAGER) && !MIN_VERSION_base(4,7,0) +{-# INLINE withMVarMasked #-} +withMVarMasked :: MVar a -> (a -> IO b) -> IO b +withMVarMasked m io = + mask_ $ do + a <- takeMVar m + b <- io a `onException` putMVar m a + putMVar m a + return b +#endif + +-------------------------------------------------------------------------------- +-- * Initialization +-------------------------------------------------------------------------------- + +{-| Abstract type representing a USB session. + +The concept of individual sessions allows your program to use multiple threads +that can independently use this library without interfering with eachother. + +Sessions are created and initialized by 'newCtx' and are automatically closed +when they are garbage collected. + +The only functions that receive a @Ctx@ are 'hasCapability', 'setDebug' and +'getDevices'. +-} +data Ctx = Ctx + { +#ifdef HAS_EVENT_MANAGER + ctxGetWait :: !(Maybe Wait), +#endif + getCtxFrgnPtr :: !(ForeignPtr C'libusb_context) + } deriving Typeable + +instance Eq Ctx where (==) = (==) `on` getCtxFrgnPtr + +withCtxPtr :: Ctx -> (Ptr C'libusb_context -> IO a) -> IO a +withCtxPtr = withForeignPtr . getCtxFrgnPtr + +-- | Internal function used to initialize libusb. +-- +-- This function must be called before calling any other libusb function. +libusb_init :: IO (Ptr C'libusb_context) +libusb_init = alloca $ \ctxPtrPtr -> do + handleUSBException $ c'libusb_init ctxPtrPtr + peek ctxPtrPtr + +newCtxNoEventManager :: (ForeignPtr C'libusb_context -> Ctx) -> IO Ctx +newCtxNoEventManager ctx = mask_ $ do + ctxPtr <- libusb_init + ctx <$> FC.newForeignPtr ctxPtr + (c'libusb_exit ctxPtr) + +#ifndef HAS_EVENT_MANAGER +-- | Create and initialize a new USB context. +-- +-- This function may throw 'USBException's. +newCtx :: IO Ctx +newCtx = newCtxNoEventManager Ctx +#else +-------------------------------------------------------------------------------- + +-- | A function to wait for the termination of a submitted transfer. +type Wait = Timeout -> Lock -> Ptr C'libusb_transfer -> IO () + +{-| Create and initialize a new USB context. + +This function may throw 'USBException's. + +Note that the internal @libusb@ event handling can return errors. These errors +occur in the thread that is executing the event handling loop. 'newCtx' will +print these errors to 'stderr'. If you need to handle the errors yourself (for +example log them in an application specific way) please use 'newCtx''. +-} +newCtx :: IO Ctx +newCtx = newCtx' $ \e -> hPutStrLn stderr $ + thisModule ++ ": libusb_handle_events_timeout returned error: " ++ show e + +-- | Like 'newCtx' but enables you to specify the way errors should be handled +-- that occur while handling @libusb@ events. +newCtx' :: (USBException -> IO ()) -> IO Ctx +newCtx' handleError = do + mbEvtMgr <- getSystemEventManager + case mbEvtMgr of + Nothing -> newCtxNoEventManager $ Ctx Nothing + Just evtMgr -> mask_ $ do + ctxPtr <- libusb_init + + -- Lateron, we need to apply c'libusb_handle_events_timeout to a zeroed + -- timeval structure. We allocate this structure here and it's freed + -- when the Ctx is garbage collected: + zeroTimevalPtr <- mallocZeroTimeval + + newCtxWithEventManager evtMgr zeroTimevalPtr ctxPtr + where + mallocZeroTimeval :: IO (Ptr C'timeval) + mallocZeroTimeval = do + p <- mallocBytes (2 * (sizeOf (undefined :: CLong))) + pokeElemOff (castPtr p) 0 (0 :: CLong) + pokeElemOff (castPtr p) 1 (0 :: CLong) + return (castPtr p) + + newCtxWithEventManager :: EventManager + -> Ptr C'timeval + -> Ptr C'libusb_context + -> IO Ctx + newCtxWithEventManager evtMgr zeroTimevalPtr ctxPtr = do + finalizeRegisterPollFds <- registerPollFds + + wait <- determineWait + + let finalize :: IO () + finalize = do + finalizeRegisterPollFds + free zeroTimevalPtr + c'libusb_exit ctxPtr + + ctxFrgnPtr <- FC.newForeignPtr ctxPtr finalize + + return Ctx{ ctxGetWait = Just wait + , getCtxFrgnPtr = ctxFrgnPtr + } + where + registerPollFds :: IO (IO ()) + registerPollFds = do + fdKeyMapRef <- newIORef IntMap.empty + registerInitialPollFds fdKeyMapRef + unregisterPollFdCallbacks <- registerPollFdCallbacks fdKeyMapRef + return $ do + unregisterPollFdCallbacks + + -- Unregister all registered file descriptors from the event manager: + unregisterAllPollFds fdKeyMapRef + where + -- Register initial libusb file descriptors with the event manager + -- and store the Fd to FdKey associations: + registerInitialPollFds :: IORef (IntMap FdKey) -> IO () + registerInitialPollFds fdKeyMapRef = do + -- Get the initial file descriptors: + pollFdPtrLst <- c'libusb_get_pollfds ctxPtr + pollFdPtrs <- peekArray0 nullPtr pollFdPtrLst + + -- Register them with the GHC EventManager: + forM_ pollFdPtrs $ \pollFdPtr -> do + C'libusb_pollfd fd evt <- peek pollFdPtr + register fdKeyMapRef fd evt + + free pollFdPtrLst + + -- Be notified when libusb file descriptors are added or removed: + registerPollFdCallbacks :: IORef (IntMap FdKey) -> IO (IO ()) + registerPollFdCallbacks fdKeyMapRef = do + -- Create the callbacks that can be passed to libusb: + pollFdAddedFP <- mk'libusb_pollfd_added_cb pollFdAddedCallback + pollFdRemovedFP <- mk'libusb_pollfd_removed_cb pollFdRemovedCallback + + c'libusb_set_pollfd_notifiers ctxPtr pollFdAddedFP pollFdRemovedFP nullPtr + + -- Return a finalizer that should be called when garbage collecting the Ctx: + return $ do + -- Remove notifiers after which we can safely free the FunPtrs: + c'libusb_set_pollfd_notifiers ctxPtr nullFunPtr nullFunPtr nullPtr + + freeHaskellFunPtr pollFdAddedFP + freeHaskellFunPtr pollFdRemovedFP + where + pollFdAddedCallback :: CInt -> CShort -> Ptr () -> IO () + pollFdAddedCallback fd evt _userData = mask_ $ do + register fdKeyMapRef fd evt + + pollFdRemovedCallback :: CInt -> Ptr () -> IO () + pollFdRemovedCallback fd _userData = mask_ $ do + (newFdKeyMap, fdKey) <- atomicModifyIORef fdKeyMapRef $ \fdKeyMap -> + let (Just fdKey, newFdKeyMap) = + IntMap.updateLookupWithKey (\_ _ -> Nothing) + (fromIntegral fd) + fdKeyMap + in (newFdKeyMap, (newFdKeyMap, fdKey)) + + newFdKeyMap `seq` unregisterFd evtMgr fdKey + + unregisterAllPollFds :: IORef (IntMap FdKey) -> IO () + unregisterAllPollFds fdKeyMapRef = + readIORef fdKeyMapRef >>= + mapM_ (unregisterFd evtMgr) . IntMap.elems + + register :: IORef (IntMap FdKey) -> CInt -> CShort -> IO () + register fdKeyMapRef fd evt = registerAndInsert + where + registerAndInsert :: IO () + registerAndInsert = do + fdKey <- registerFd evtMgr callback (Fd fd) (Poll.toEvent evt) + -- In base-4.8 registerFd gains an additonal argument of type + -- Lifetime. However, because of an oversight, base-4.8 doesn't export + -- the constructors: OneShot | MultiShot. We therefor use the hack of + -- unsafely coercing a Bool to a Lifetime. +#if MIN_VERSION_base(4,8,1) + MultiShot +#elif MIN_VERSION_base(4,8,0) + -- We would like to use MultiShot (unsafeCoerce True) + -- registrations. However, base-4.8 has a bug in the MultiShot + -- implementation which means we have to fall back to OneShot. + (unsafeCoerce False) +#endif + + -- Associate the fd with the fdKey: + newFdKeyMap <- atomicModifyIORef fdKeyMapRef $ \fdKeyMap -> + let newFdKeyMap = IntMap.insert (fromIntegral fd) fdKey fdKeyMap + in (newFdKeyMap, newFdKeyMap) + newFdKeyMap `seq` return () + + callback :: IOCallback + callback _fdKey _ev = do +#if HAVE_ONE_SHOT + -- In GHC >= 7.8 && <= 7.10.1 the system event manager might + -- have one-shot semantics. One-shot semantics means that + -- when an event occurs on a registered fd the fd is + -- unregistered before the callback is called. This usb + -- library only works with multi-shot semantics, + -- i.e. registered fds stay registered until they are + -- explicitly unregistered. To work around the one-shot + -- semantics we register the fd again when the callback + -- fires: + registerAndInsert +#endif + handleEvents + + handleEvents :: IO () + handleEvents = do + err <- c'libusb_handle_events_timeout ctxPtr zeroTimevalPtr + when (err /= c'LIBUSB_SUCCESS) $ + if err == c'LIBUSB_ERROR_INTERRUPTED + then handleEvents -- TODO: could this cause an infinite loop? + else handleError $ convertUSBException err + + -- Construct the appropriate Wait function based on whether we have to do + -- our own timeout handling: + determineWait :: IO Wait + determineWait = do + timeoutsHandled <- toBool <$> c'libusb_pollfds_handle_timeouts ctxPtr + if timeoutsHandled + then return $ \_timeout -> autoTimeout + else do +#if MIN_VERSION_base(4,7,0) + timerMgr <- getSystemTimerManager +#else + let timerMgr = evtMgr +#endif + return $ manualTimeout timerMgr + where + autoTimeout lock transPtr = + acquire lock + `onException` + (uninterruptibleMask_ $ do + handleUSBException $ c'libusb_cancel_transfer transPtr + acquire lock) + + manualTimeout timerMgr timeout lock transPtr + | timeout == noTimeout = autoTimeout lock transPtr + | otherwise = do + timeoutKey <- registerTimeout timerMgr (timeout * 1000) handleEvents + acquire lock + `onException` + (uninterruptibleMask_ $ do + unregisterTimeout timerMgr timeoutKey + handleUSBException $ c'libusb_cancel_transfer transPtr + acquire lock) + +-- | Checks if the system supports asynchronous I\/O. +-- +-- * 'Nothing' means asynchronous I\/O is not supported so synchronous I\/O should +-- be used instead. +-- +-- * @'Just' wait@ means that asynchronous I\/O is supported. The @wait@ +-- function can be used to wait for submitted transfers. +getWait :: DeviceHandle -> Maybe Wait +getWait = ctxGetWait . getCtx . getDevice + +-- | Like 'getWait' but throws an error if the system doesn't support +-- asynchronous I\/O. +requireWait :: DeviceHandle -> String -> IO Wait +requireWait devHndl funName = + case getWait devHndl of + Nothing -> moduleError $ funName ++ + " is only supported when using the threaded runtime. " ++ + "Please build your program with -threaded." + Just wait -> return wait +#endif + +-------------------------------------------------------------------------------- + +{-| Set message verbosity. + +The default level is 'PrintNothing'. This means no messages are ever +printed. If you choose to increase the message verbosity level you must ensure +that your application does not close the @stdout@/@stderr@ file descriptors. + +You are advised to set the debug level to 'PrintWarnings'. Libusb is +conservative with its message logging. Most of the time it will only log +messages that explain error conditions and other oddities. This will help you +debug your software. + +The LIBUSB_DEBUG environment variable overrules the debug level set by this +function. The message verbosity is fixed to the value in the environment +variable if it is defined. + +If @libusb@ was compiled without any message logging, this function does nothing: +you'll never get any messages. + +If @libusb@ was compiled with verbose debug message logging, this function does +nothing: you'll always get messages from all levels. +-} +setDebug :: Ctx -> Verbosity -> IO () +setDebug ctx verbosity = withCtxPtr ctx $ \ctxPtr -> + c'libusb_set_debug ctxPtr $ + marshallVerbosity verbosity + +-- | Message verbosity +data Verbosity = + PrintNothing -- ^ No messages are ever printed by the library. + | PrintErrors -- ^ Error messages are printed to @stderr@. + | PrintWarnings -- ^ Warning and error messages are printed to @stderr@. + | PrintInfo -- ^ Informational messages are printed to @stdout@, + -- warning and error messages are printed to @stderr@. + | PrintDebug -- ^ Debug and informational messages are printed to + -- @stdout@, warnings and errors to @stderr@. + deriving (Enum, Ord, COMMON_INSTANCES) + +marshallVerbosity :: Verbosity -> CInt +marshallVerbosity PrintNothing = c'LIBUSB_LOG_LEVEL_NONE +marshallVerbosity PrintErrors = c'LIBUSB_LOG_LEVEL_ERROR +marshallVerbosity PrintWarnings = c'LIBUSB_LOG_LEVEL_WARNING +marshallVerbosity PrintInfo = c'LIBUSB_LOG_LEVEL_INFO +marshallVerbosity PrintDebug = c'LIBUSB_LOG_LEVEL_DEBUG + + +-------------------------------------------------------------------------------- +-- * Miscellaneous +-------------------------------------------------------------------------------- + +-- | Structure providing the version of the @libusb@ runtime. +data LibusbVersion = LibusbVersion + { major :: Word16 -- ^ Library major version. + , minor :: Word16 -- ^ Library minor version. + , micro :: Word16 -- ^ Library micro version. + , nano :: Word16 -- ^ Library nano version. + , rc :: String -- ^ Library release candidate suffix string, e.g. @\"-rc4\"@. + + -- , describe :: String -- ^ For ABI compatibility only. + } deriving (COMMON_INSTANCES) + +-- | Returns the version (major, minor, micro, nano and rc) of the loaded +-- @libusb@ library. +libusbVersion :: LibusbVersion +libusbVersion = unsafePerformIO $ do + ptr <- c'libusb_get_version + LibusbVersion <$> peek (p'libusb_version'major ptr) + <*> peek (p'libusb_version'minor ptr) + <*> peek (p'libusb_version'micro ptr) + <*> peek (p'libusb_version'nano ptr) + <*> (peek (p'libusb_version'rc ptr) >>= peekCString) + + -- <*> (peek (p'libusb_version'describe ptr) >>= peekCString) + +-- | Convert a 'LibusbVersion' to a 'Version' for easy comparison. +toVersion :: LibusbVersion -> Version +toVersion (LibusbVersion maj min mic nan _rcTag) = +#if MIN_VERSION_base(4,8,0) + makeVersion branch +#else + Version { versionBranch = branch + , versionTags = if null _rcTag then [] else [_rcTag] + } +#endif + where + branch :: [Int] + branch = map fromIntegral [maj, min, mic, nan] + + +-------------------------------------------------------------------------------- + +-- | Capabilities supported by an instance of @libusb@ on the current running +-- platform. +-- +-- Test if the loaded @libusb@ library supports a given capability by calling +-- 'hasCapability'. +data Capability = HasCapability + -- ^ The 'hasCapability' API is available. + | HasHotplug + -- ^ Hotplug support is available on this platform. + | HasHidAccess + -- ^ The library can access HID devices without requiring user + -- intervention. + -- + -- Note that before being able to actually access an HID + -- device, you may still have to call additional @libusb@ + -- functions such as 'detachKernelDriver'. + | SupportsDetachKernelDriver + -- ^ The library supports detaching of the default USB driver, + -- using 'detachKernelDriver', if one is set by the OS kernel. + deriving (Enum, Ord, COMMON_INSTANCES) + +marshallCapability :: Capability -> C'libusb_capability +marshallCapability HasCapability = c'LIBUSB_CAP_HAS_CAPABILITY +marshallCapability HasHotplug = c'LIBUSB_CAP_HAS_HOTPLUG +marshallCapability HasHidAccess = c'LIBUSB_CAP_HAS_HID_ACCESS +marshallCapability SupportsDetachKernelDriver = c'LIBUSB_CAP_SUPPORTS_DETACH_KERNEL_DRIVER + +-- | Check at runtime if the loaded @libusb@ library has a given capability. +-- +-- This call should be performed after 'newCtx', to ensure the backend has +-- updated its capability set. For this reason you need to apply it to a 'Ctx'. +hasCapability :: Ctx -> Capability -> Bool +hasCapability _ctx = toBool . c'libusb_has_capability . marshallCapability + + +-------------------------------------------------------------------------------- +-- * Enumeration +-------------------------------------------------------------------------------- + +{-| Abstract type representing a USB device detected on the system. + +You can only obtain a USB device from the 'getDevices' function. + +Certain operations can be performed on a device, but in order to do any I/O you +will have to first obtain a 'DeviceHandle' using 'openDevice'. + +Just because you have a reference to a device does not mean it is necessarily +usable. The device may have been unplugged, you may not have permission to +operate such device or another process or driver may be using the device. + +To get additional information about a device you can retrieve its descriptor +using 'getDeviceDesc'. +-} +data Device = Device + { getCtx :: !Ctx -- ^ This reference to the 'Ctx' is needed so that it won't + -- gets garbage collected. The finalizer @libusb_exit@ is + -- run only when all references to 'Devices' are gone. + , getDevFrgnPtr :: !(ForeignPtr C'libusb_device) + } deriving Typeable + +instance Eq Device where (==) = (==) `on` getDevFrgnPtr + +-- | Devices are shown as: @Bus \<'busNumber'\> Device \<'deviceAddress'\>@ +instance Show Device where + show d = printf "Bus %03d Device %03d" (busNumber d) (deviceAddress d) + +withDevicePtr :: Device -> (Ptr C'libusb_device -> IO a) -> IO a +withDevicePtr (Device ctx devFP ) f = do + x <- withForeignPtr devFP f + touchForeignPtr $ getCtxFrgnPtr ctx + return x + +mkDev :: Ctx -> Ptr C'libusb_device -> IO Device +mkDev ctx devPtr = + Device ctx <$> FC.newForeignPtr devPtr (c'libusb_unref_device devPtr) + +-------------------------------------------------------------------------------- + +{-| Returns a vector of USB devices currently attached to the system. + +This is your entry point into finding a USB device. + +Exceptions: + + * 'NoMemException' on a memory allocation failure. + +-} + +{- +Visual description of the 'devPtrArrayPtr': + + D + ^ D + D │ ^ + ^ │ │ + │ │ │ +devPtrArrayPtr: ┏━┷━┳━┷━┳━━━┳━━━┳━┷━┓ + P ───> ┃ P ┃ P ┃ P ┃ P ┃ P ┃ + ┗━━━┻━━━┻━┯━┻━┯━┻━━━┛ + │ │ +P = pointer v │ +D = device structure D │ + v + D +-} +getDevices :: Ctx -> IO (Vector Device) +getDevices ctx = + withCtxPtr ctx $ \ctxPtr -> + alloca $ \devPtrArrayPtr -> mask $ \restore -> do + numDevs <- checkUSBException $ c'libusb_get_device_list ctxPtr + devPtrArrayPtr + devPtrArray <- peek devPtrArrayPtr + let freeDevPtrArray = c'libusb_free_device_list devPtrArray 0 + devs <- restore (mapPeekArray (mkDev ctx) numDevs devPtrArray) + `onException` freeDevPtrArray + freeDevPtrArray + return devs + + +-------------------------------------------------------------------------------- +-- * Device hotplug event notification +-------------------------------------------------------------------------------- + +-- | The set of hotplug events to trigger the callback in +-- 'registerHotplugCallback'. +newtype HotplugEvent = HotplugEvent {unHotplugEvent :: C'libusb_hotplug_event} + +#if MIN_VERSION_base(4,9,0) +instance Semigroup HotplugEvent where + ev1 <> ev2 = HotplugEvent $ unHotplugEvent ev1 .|. unHotplugEvent ev2 +#endif + +-- | Use 'mempty' to specify the empty set of events. Use @'mappend' e1 e2@ to +-- join the events in @e1@ and @e2@. +instance Monoid HotplugEvent where + mempty = HotplugEvent 0 +#if !MIN_VERSION_base(4,11,0) + ev1 `mappend` ev2 = HotplugEvent $ unHotplugEvent ev1 .|. unHotplugEvent ev2 +#endif + +-- | A device has been plugged in and is ready to use. +deviceArrived :: HotplugEvent +deviceArrived = HotplugEvent c'LIBUSB_HOTPLUG_EVENT_DEVICE_ARRIVED + +-- | A device has left and is no longer available. +-- +-- It is the user's responsibility to call 'closeDevice' on any handle +-- associated with a disconnected device. It is safe to call 'getDeviceDesc' on +-- a device that has left. +deviceLeft :: HotplugEvent +deviceLeft = HotplugEvent c'LIBUSB_HOTPLUG_EVENT_DEVICE_LEFT + +-- | Determine if the set of events contains a 'deviceArrived' event. +matchDeviceArrived :: HotplugEvent -> Bool +matchDeviceArrived = isEvent c'LIBUSB_HOTPLUG_EVENT_DEVICE_ARRIVED + +-- | Determine if the set of events contains a 'deviceLeft' event. +matchDeviceLeft :: HotplugEvent -> Bool +matchDeviceLeft = isEvent c'LIBUSB_HOTPLUG_EVENT_DEVICE_LEFT + +isEvent :: C'libusb_hotplug_event -> (HotplugEvent -> Bool) +isEvent c'ev = \ev -> unHotplugEvent ev .&. c'ev == c'ev + +-------------------------------------------------------------------------------- + +-- | Set of configuration flags for 'registerHotplugCallback'. +newtype HotplugFlag = HotplugFlag {unHotplugFlag :: C'libusb_hotplug_flag} + +#if MIN_VERSION_base(4,9,0) +instance Semigroup HotplugFlag where + flg1 <> flg2 = HotplugFlag $ unHotplugFlag flg1 .|. unHotplugFlag flg2 +#endif + +-- | Use 'mempty' to specify the empty set of flags. Use @'mappend' e1 e2@ to +-- join the flags in @e1@ and @e2@. +instance Monoid HotplugFlag where + mempty = HotplugFlag 0 +#if !MIN_VERSION_base(4,11,0) + flg1 `mappend` flg2 = HotplugFlag $ unHotplugFlag flg1 .|. unHotplugFlag flg2 +#endif + +-- | Fire events for all matching currently attached devices. +enumerate :: HotplugFlag +enumerate = HotplugFlag c'LIBUSB_HOTPLUG_ENUMERATE + +-------------------------------------------------------------------------------- + +-- | Hotplug callback function type used in 'registerHotplugCallback'. +-- +-- @libusb@ will call this function, once registered using +-- 'registerHotplugCallback', when a matching event has happened on a matching +-- device. +-- +-- This callback may be called by an internal event thread and as such it is +-- recommended the callback do minimal processing before returning. In fact, it +-- has been observed that doing any I/O with the device from inside the callback +-- results in dead-lock! See the example below on the correct use of this +-- callback. +-- +-- It is safe to call either 'registerHotplugCallback' or +-- 'deregisterHotplugCallback' from within a callback function. +-- +-- Should return a 'CallbackRegistrationStatus' which indicates whether this +-- callback is finished processing events. Returning 'DeregisterThisCallback' +-- will cause this callback to be deregistered. +-- +-- If you need to wait on the arrival of a device after which you need to do +-- something with it, it's recommended to write the device to a concurrent +-- channel like a MVar \/ TChan \/ TMVar \/ TChan \/ etc. then read the channel +-- outside the callback. This way the processing of the device takes place in a +-- different thread. See the following for one correct use-case: +-- +-- @ +-- waitForMyDevice :: Ctx +-- -> Maybe VendorId +-- -> Maybe ProductId +-- -> Maybe Word8 +-- -> IO Device +-- waitForMyDevice ctx mbVendorId mbProductId mbDevClass = do +-- mv <- newEmptyMVar +-- -- We mask asynchronous exceptions to ensure that the callback +-- -- gets properly deregistered when an asynchronous exception is +-- -- thrown during the interruptible takeMVar operation. +-- mask_ $ do +-- h <- registerHotplugCallback ctx +-- deviceArrived +-- enumerate +-- mbVendorId +-- mbProductId +-- mbDevClass +-- (\\dev event -> +-- tryPutMVar mv (dev, event) $> +-- DeregisterThisCallback) +-- (dev, _event) <- takeMVar mv +-- \`onException\` +-- deregisterHotplugCallback h +-- return dev +-- @ +type HotplugCallback = Device -> HotplugEvent -> IO CallbackRegistrationStatus + +-- | Returned from a 'HotplugCallback' to indicate whether the callback is +-- finished processing events. +data CallbackRegistrationStatus = KeepCallbackRegistered + -- ^ The callback remains registered. + | DeregisterThisCallback + -- ^ The callback will be deregistered. + deriving (COMMON_INSTANCES) + +-- | Callback handle. +-- +-- Callbacks handles are generated by 'registerHotplugCallback' and can be used +-- to deregister callbacks. Callback handles are unique per 'Ctx' and it is safe +-- to call 'deregisterHotplugCallback' on an already deregisted callback. +data HotplugCallbackHandle = HotplugCallbackHandle + Ctx + (MVar (Maybe C'libusb_hotplug_callback_fn)) + C'libusb_hotplug_callback_handle + +-- | /WARNING:/ see the note on 'HotplugCallback' for the danger of using this +-- function! +-- +-- Register a hotplug callback function with the context. The callback will fire +-- when a matching event occurs on a matching device. The callback is armed +-- until either it is deregistered with 'deregisterHotplugCallback' or the +-- supplied callback returns 'DeregisterThisCallback' to indicate it is finished +-- processing events. +-- +-- If the 'enumerate' flag is passed the callback will be called with a +-- 'deviceArrived' for all devices already plugged into the machine. Note that +-- @libusb@ modifies its internal device list from a separate thread, while +-- calling hotplug callbacks from @libusb_handle_events()@, so it is possible +-- for a device to already be present on, or removed from, its internal device +-- list, while the hotplug callbacks still need to be dispatched. This means +-- that when using the 'enumerate' flag, your callback may be called twice for +-- the arrival of the same device, once from 'registerHotplugCallback' and once +-- from @libusb_handle_events()@; and\/or your callback may be called for the +-- removal of a device for which an arrived call was never made. +registerHotplugCallback + :: Ctx -- ^ Context to register this callback with. + -> HotplugEvent -- ^ Set of events that will trigger this callback. + -> HotplugFlag -- ^ Set of configuration flags. + -> Maybe VendorId -- ^ 'Just' the vendor id to match or 'Nothing' to match anything. + -> Maybe ProductId -- ^ 'Just' the product id to match or 'Nothing' to match anything. + -> Maybe Word8 -- ^ 'Just' the device class to match or 'Nothing' to match anything. + -> HotplugCallback -- ^ The function to be invoked on a matching event/device. + -> IO HotplugCallbackHandle +registerHotplugCallback ctx + hotplugEvent + hotplugFlag + mbVendorId + mbProductId + mbDevClass + hotplugCallback = do + (mbCbFnPtrMv :: MVar (Maybe C'libusb_hotplug_callback_fn)) <- newEmptyMVar + + let cb :: Ptr C'libusb_context + -> Ptr C'libusb_device + -> C'libusb_hotplug_event + -> Ptr () + -> IO CInt + cb _ctxPtr devPtr ev _userData = do + dev <- mask_ $ c'libusb_ref_device devPtr >>= mkDev ctx + status <- hotplugCallback dev (HotplugEvent ev) + + case status of + KeepCallbackRegistered -> return 0 + DeregisterThisCallback -> mask_ $ do + mbCbFnPtr <- takeMVar mbCbFnPtrMv + Foldable.forM_ mbCbFnPtr freeHaskellFunPtr + putMVar mbCbFnPtrMv Nothing + return 1 + + withCtxPtr ctx $ \ctxPtr -> + alloca $ \(hotplugCallbackHandlePtr :: Ptr C'libusb_hotplug_callback_handle) -> + mask_ $ do -- We mask to ensure the freeing of cbFnPtr. + cbFnPtr <- mk'libusb_hotplug_callback_fn cb + putMVar mbCbFnPtrMv $ Just cbFnPtr + handleUSBException (c'libusb_hotplug_register_callback + ctxPtr + (unHotplugEvent hotplugEvent) + (unHotplugFlag hotplugFlag) + (unmarshallMatch mbVendorId) + (unmarshallMatch mbProductId) + (unmarshallMatch mbDevClass) + cbFnPtr + nullPtr + hotplugCallbackHandlePtr) + `onException` freeHaskellFunPtr cbFnPtr + HotplugCallbackHandle ctx mbCbFnPtrMv <$> + peek hotplugCallbackHandlePtr + where + unmarshallMatch :: Integral a => Maybe a -> CInt + unmarshallMatch = maybe c'LIBUSB_HOTPLUG_MATCH_ANY fromIntegral + +-- | Deregisters a hotplug callback. +-- +-- Deregister a callback from a 'Ctx'. This function is safe +-- to call from within a hotplug callback. +deregisterHotplugCallback :: HotplugCallbackHandle -> IO () +deregisterHotplugCallback (HotplugCallbackHandle ctx mbCbFnPtrMv handle) = mask_ $ do + mbCbFnPtr <- takeMVar mbCbFnPtrMv + Foldable.forM_ mbCbFnPtr $ \cbFnPtr -> + withCtxPtr ctx $ \ctxPtr -> do + c'libusb_hotplug_deregister_callback ctxPtr handle + `onException` putMVar mbCbFnPtrMv mbCbFnPtr + freeHaskellFunPtr cbFnPtr + putMVar mbCbFnPtrMv Nothing + + +-------------------------------------------------------------------------------- +-- * Device location +-------------------------------------------------------------------------------- + +-- The following numbers are static variables in the libusb device +-- structure. It's therefore safe to use unsafePerformIO: + +-- | The number of the bus that a device is connected to. +busNumber :: Device -> Word8 +busNumber dev = unsafePerformIO $ withDevicePtr dev c'libusb_get_bus_number + +-- | Get the number of the port that a is device connected to. Unless the OS +-- does something funky, or you are hot-plugging USB extension cards, the port +-- number returned by this call is usually guaranteed to be uniquely tied to a +-- physical port, meaning that different devices plugged on the same physical +-- port should return the same port number. +-- +-- But outside of this, there is no guarantee that the port number returned by +-- this call will remain the same, or even match the order in which ports have +-- been numbered by the HUB/HCD manufacturer. +portNumber :: Device -> Word8 +portNumber dev = unsafePerformIO $ withDevicePtr dev c'libusb_get_port_number + +-- | Get the list of all port numbers from root for the specified device. +portNumbers :: Device + -> Int -- ^ The maximum number of ports allowed in the resulting + -- vector. If there are more ports than this number 'Nothing' + -- will be returned. As per the USB 3.0 specs, the current + -- maximum limit for the depth is 7. + -> Maybe (Vector Word8) +portNumbers dev m = unsafePerformIO $ + withDevicePtr dev $ \devPtr -> + allocaArray m $ \ptr -> do + n <- c'libusb_get_port_numbers devPtr ptr (fromIntegral m) + if n == c'LIBUSB_ERROR_OVERFLOW + then return Nothing + else Just . VG.convert <$> peekVector (fromIntegral n) ptr + +-- | The address of the device on the bus it is connected to. +deviceAddress :: Device -> Word8 +deviceAddress dev = unsafePerformIO $ withDevicePtr dev c'libusb_get_device_address + + +-------------------------------------------------------------------------------- +-- * Device speed +-------------------------------------------------------------------------------- + +-- | Get the negotiated connection speed for a device. +-- +-- 'Nothing' means that the OS doesn't know or doesn't support returning the +-- negotiated speed. +deviceSpeed :: Device -> Maybe Speed +deviceSpeed dev = unsafePerformIO $ withDevicePtr dev $ \devPtr -> + unmarshallSpeed <$> c'libusb_get_device_speed devPtr + +unmarshallSpeed :: CInt -> Maybe Speed +unmarshallSpeed speed | speed == c'LIBUSB_SPEED_UNKNOWN = Nothing + | otherwise = Just $ genToEnum (speed - 1) + +-- | Speed codes. Indicates the speed at which the device is operating. +data Speed = LowSpeed -- ^ The device is operating at low speed (1.5MBit/s). + | FullSpeed -- ^ The device is operating at full speed (12MBit/s). + | HighSpeed -- ^ The device is operating at high speed (480MBit/s). + | SuperSpeed -- ^ The device is operating at super speed (5000MBit/s). + deriving (Enum, COMMON_INSTANCES) + + +-------------------------------------------------------------------------------- +-- * Device handling +-------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- +-- ** Opening & closing devices +-------------------------------------------------------------------------------- + +{-| Abstract type representing a handle of a USB device. + +You can acquire a handle from 'openDevice'. + +A device handle is used to perform I/O and other operations. When finished with +a device handle you should close it by applying 'closeDevice' to it. +-} +data DeviceHandle = DeviceHandle + { getDevice :: !Device -- This reference is needed for keeping the 'Device' + -- and therefor the 'Ctx' alive. + -- ^ Retrieve the 'Device' from the 'DeviceHandle'. + , getDevHndlPtr :: !(Ptr C'libusb_device_handle) + } deriving Typeable + +instance Eq DeviceHandle where (==) = (==) `on` getDevHndlPtr + +instance Show DeviceHandle where + show devHndl = "{USB device handle to: " ++ show (getDevice devHndl) ++ "}" + +-- | Operate the 'C'libusb_device_handle' pointer inside the 'DeviceHandle'. +-- +-- The 'Device' that the handle references and the 'Ctx' in which it was created +-- are kept alive at least during the whole action, even if they are not used +-- directly inside. +withDevHndlPtr :: DeviceHandle -> (Ptr C'libusb_device_handle -> IO a) -> IO a +withDevHndlPtr (DeviceHandle (Device ctx devFrgnPtr) devHndlPtr) f = do + x <- f devHndlPtr + touchForeignPtr devFrgnPtr + touchForeignPtr $ getCtxFrgnPtr ctx + return x + +{-| Open a device and obtain a device handle. + +A handle allows you to perform I/O on the device in question. + +This is a non-blocking function; no requests are sent over the bus. + +It is advisable to use 'withDeviceHandle' because it automatically closes the +device when the computation terminates. + +Exceptions: + + * 'NoMemException' if there is a memory allocation failure. + + * 'AccessException' if the user has insufficient permissions. + + * 'NoDeviceException' if the device has been disconnected. + + * Another 'USBException'. +-} +openDevice :: Device -> IO DeviceHandle +openDevice dev = withDevicePtr dev $ \devPtr -> + alloca $ \devHndlPtrPtr -> do + handleUSBException $ c'libusb_open devPtr devHndlPtrPtr + DeviceHandle dev <$> peek devHndlPtrPtr + +{-| Close a device handle. + +Should be called on all open handles before your application exits. + +This is a non-blocking function; no requests are sent over the bus. +-} +closeDevice :: DeviceHandle -> IO () +closeDevice devHndl = withDevHndlPtr devHndl c'libusb_close + +{-| @withDeviceHandle dev act@ opens the 'Device' @dev@ and passes +the resulting handle to the computation @act@. The handle will be closed on exit +from @withDeviceHandle@ whether by normal termination or by raising an +exception. +-} +withDeviceHandle :: Device -> (DeviceHandle -> IO a) -> IO a +withDeviceHandle dev = bracket (openDevice dev) closeDevice + +-------------------------------------------------------------------------------- +-- ** Getting & setting the configuration +-------------------------------------------------------------------------------- + +-- | Identifier for configurations. +-- +-- Can be retrieved by 'getConfig' or by 'configValue'. +type ConfigValue = Word8 + +{-| Determine the value of the currently active configuration. + +You could formulate your own control request to obtain this information, but +this function has the advantage that it may be able to retrieve the information +from operating system caches (no I/O involved). + +If the OS does not cache this information, then this function will block while +a control transfer is submitted to retrieve the information. + +This function returns 'Nothing' if the device is in unconfigured state. + +Exceptions: + + * 'NoDeviceException' if the device has been disconnected. + + * Another 'USBException'. +-} +getConfig :: DeviceHandle -> IO (Maybe ConfigValue) +getConfig devHndl = + alloca $ \configPtr -> do + withDevHndlPtr devHndl $ \devHndlPtr -> + handleUSBException $ c'libusb_get_configuration devHndlPtr configPtr + unmarshal <$> peek configPtr + where + unmarshal 0 = Nothing + unmarshal n = Just $ fromIntegral n + +{-| Set the active configuration for a device. + +The operating system may or may not have already set an active configuration on +the device. It is up to your application to ensure the correct configuration is +selected before you attempt to claim interfaces and perform other operations. + +If you call this function on a device already configured with the selected +configuration, then this function will act as a lightweight device reset: it +will issue a SET_CONFIGURATION request using the current configuration, causing +most USB-related device state to be reset (altsetting reset to zero, endpoint +halts cleared, toggles reset). + +You cannot change/reset configuration if your application has claimed interfaces +- you should free them with 'releaseInterface' first. You cannot change/reset +configuration if other applications or drivers have claimed interfaces. + +A configuration value of 'Nothing' will put the device in an unconfigured +state. The USB specification states that a configuration value of 0 does this, +however buggy devices exist which actually have a configuration 0. + +You should always use this function rather than formulating your own +SET_CONFIGURATION control request. This is because the underlying operating +system needs to know when such changes happen. + +This is a blocking function. + +Exceptions: + + * 'NotFoundException' if the requested configuration does not exist. + + * 'BusyException' if interfaces are currently claimed. + + * 'NoDeviceException' if the device has been disconnected + + * Another 'USBException'. +-} +setConfig :: DeviceHandle -> Maybe ConfigValue -> IO () +setConfig devHndl config = + withDevHndlPtr devHndl $ \devHndlPtr -> + handleUSBException $ c'libusb_set_configuration devHndlPtr $ + marshal config + where + marshal = maybe (-1) fromIntegral + +-------------------------------------------------------------------------------- +-- ** Claiming & releasing interfaces +-------------------------------------------------------------------------------- + +{-| Identifier for interfaces. + +Can be retrieved by 'interfaceNumber'. +-} +type InterfaceNumber = Word8 + +{-| Claim an interface on a given device handle. + +You must claim the interface you wish to use before you can perform I/O on any +of its endpoints. + +It is legal to attempt to claim an already-claimed interface, in which case this +function just returns without doing anything. + +Claiming of interfaces is a purely logical operation; it does not cause any +requests to be sent over the bus. Interface claiming is used to instruct the +underlying operating system that your application wishes to take ownership of +the interface. + +This is a non-blocking function. + +Exceptions: + + * 'NotFoundException' if the requested interface does not exist. + + * 'BusyException' if the interface is already claimed. + + * 'NoDeviceException' if the device has been disconnected. + + * Another 'USBException'. +-} + +claimInterface :: DeviceHandle -> InterfaceNumber -> IO () +claimInterface devHndl ifNum = + withDevHndlPtr devHndl $ \devHndlPtr -> + handleUSBException $ c'libusb_claim_interface devHndlPtr + (fromIntegral ifNum) + +{-| Release an interface previously claimed with 'claimInterface'. + +You should release all claimed interfaces before closing a device handle. + +This is a blocking function. A SET_INTERFACE control request will be sent to the +device, resetting interface state to the first alternate setting. + +Exceptions: + + * 'NotFoundException' if the interface was not claimed. + + * 'NoDeviceException' if the device has been disconnected + + * Another 'USBException'. +-} +releaseInterface :: DeviceHandle -> InterfaceNumber -> IO () +releaseInterface devHndl ifNum = + withDevHndlPtr devHndl $ \devHndlPtr -> + handleUSBException $ c'libusb_release_interface devHndlPtr + (fromIntegral ifNum) + +{-| @withClaimedInterface@ claims the interface on the given device handle then +executes the given computation. On exit from @withClaimedInterface@, the +interface is released whether by normal termination or by raising an exception. +-} +withClaimedInterface :: DeviceHandle -> InterfaceNumber -> IO a -> IO a +withClaimedInterface devHndl ifNum = bracket_ (claimInterface devHndl ifNum) + (releaseInterface devHndl ifNum) + +-------------------------------------------------------------------------------- +-- ** Setting interface alternate settings +-------------------------------------------------------------------------------- + +-- | Identifier for interface alternate settings. +-- +-- Can be retrieved by 'interfaceAltSetting'. +type InterfaceAltSetting = Word8 + +{-| Activate an alternate setting for an interface. + +The interface must have been previously claimed with 'claimInterface'. + +You should always use this function rather than formulating your own +SET_INTERFACE control request. This is because the underlying operating system +needs to know when such changes happen. + +This is a blocking function. + +Exceptions: + + * 'NotFoundException' if the interface was not claimed or the requested + alternate setting does not exist. + + * 'NoDeviceException' if the device has been disconnected. + + * Another 'USBException'. +-} +setInterfaceAltSetting :: DeviceHandle + -> InterfaceNumber + -> InterfaceAltSetting + -> IO () +setInterfaceAltSetting devHndl ifNum alternateSetting = + withDevHndlPtr devHndl $ \devHndlPtr -> + handleUSBException $ + c'libusb_set_interface_alt_setting devHndlPtr + (fromIntegral ifNum) + (fromIntegral alternateSetting) + +-------------------------------------------------------------------------------- +-- ** Clearing & Resetting devices +-------------------------------------------------------------------------------- + +{-| Clear the halt/stall condition for an endpoint. + +Endpoints with halt status are unable to receive or transmit data until the halt +condition is stalled. + +You should cancel all pending transfers before attempting to clear the halt +condition. + +This is a blocking function. + +Exceptions: + + * 'NotFoundException' if the endpoint does not exist. + + * 'NoDeviceException' if the device has been disconnected. + + * Another 'USBException'. +-} +clearHalt :: DeviceHandle -> EndpointAddress -> IO () +clearHalt devHndl endpointAddr = + withDevHndlPtr devHndl $ \devHndlPtr -> + handleUSBException $ + c'libusb_clear_halt devHndlPtr (marshalEndpointAddress endpointAddr) + +{-| Perform a USB port reset to reinitialize a device. + +The system will attempt to restore the previous configuration and alternate +settings after the reset has completed. + +If the reset fails, the descriptors change, or the previous state cannot be +restored, the device will appear to be disconnected and reconnected. This means +that the device handle is no longer valid (you should close it) and rediscover +the device. A 'NotFoundException' is raised to indicate that this is the +case. + +This is a blocking function which usually incurs a noticeable delay. + +Exceptions: + + * 'NotFoundException' if re-enumeration is required, or if the + device has been disconnected. + + * Another 'USBException'. +-} +resetDevice :: DeviceHandle -> IO () +resetDevice devHndl = withDevHndlPtr devHndl $ + handleUSBException . c'libusb_reset_device + +-------------------------------------------------------------------------------- +-- ** USB kernel drivers +-------------------------------------------------------------------------------- + +-- | Enable/disable @libusb's@ automatic kernel driver detachment. When this is +-- enabled @libusb@ will automatically detach the kernel driver on an interface +-- when claiming the interface, and attach it when releasing the interface. +-- +-- Automatic kernel driver detachment is disabled on newly opened device handles +-- by default. +-- +-- On platforms which do not have the 'SupportsDetachKernelDriver' capability +-- this function will throw a 'NotSupportedException', and @libusb@ will +-- continue as if this function was never called. +setAutoDetachKernelDriver :: DeviceHandle -> Bool -> IO () +setAutoDetachKernelDriver devHndl enable = + withDevHndlPtr devHndl $ \devHndlPtr -> + handleUSBException $ c'libusb_set_auto_detach_kernel_driver + devHndlPtr (fromBool enable) + +{-| Determine if a kernel driver is active on an interface. + +If a kernel driver is active, you cannot claim the interface, and libusb will be +unable to perform I/O. + +Exceptions: + + * 'NoDeviceException' if the device has been disconnected. + + * Another 'USBException'. +-} +kernelDriverActive :: DeviceHandle -> InterfaceNumber -> IO Bool +kernelDriverActive devHndl ifNum = + withDevHndlPtr devHndl $ \devHndlPtr -> do + r <- c'libusb_kernel_driver_active devHndlPtr (fromIntegral ifNum) + case r of + 0 -> return False + 1 -> return True + _ -> throwIO $ convertUSBException r + +{-| Detach a kernel driver from an interface. + +If successful, you will then be able to claim the interface and perform I/O. + +Exceptions: + + * 'NotFoundException' if no kernel driver was active. + + * 'InvalidParamException' if the interface does not exist. + + * 'NoDeviceException' if the device has been disconnected. + + * Another 'USBException'. +-} +detachKernelDriver :: DeviceHandle -> InterfaceNumber -> IO () +detachKernelDriver devHndl ifNum = + withDevHndlPtr devHndl $ \devHndlPtr -> + handleUSBException $ c'libusb_detach_kernel_driver devHndlPtr + (fromIntegral ifNum) + +{-| Re-attach an interface's kernel driver, which was previously +detached using 'detachKernelDriver'. + +Exceptions: + + * 'NotFoundException' if no kernel driver was active. + + * 'InvalidParamException' if the interface does not exist. + + * 'NoDeviceException' if the device has been disconnected. + + * 'BusyException' if the driver cannot be attached because the interface + is claimed by a program or driver. + + * Another 'USBException'. +-} +attachKernelDriver :: DeviceHandle -> InterfaceNumber -> IO () +attachKernelDriver devHndl ifNum = + withDevHndlPtr devHndl $ \devHndlPtr -> + handleUSBException $ c'libusb_attach_kernel_driver devHndlPtr + (fromIntegral ifNum) + +{-| If a kernel driver is active on the specified interface the driver is +detached and the given action is executed. If the action terminates, whether by +normal termination or by raising an exception, the kernel driver is attached +again. If a kernel driver is not active on the specified interface the action is +just executed. + +Exceptions: + + * 'NoDeviceException' if the device has been disconnected. + + * Another 'USBException'. +-} +withDetachedKernelDriver :: DeviceHandle -> InterfaceNumber -> IO a -> IO a +withDetachedKernelDriver devHndl ifNum action = + ifM (kernelDriverActive devHndl ifNum) + (bracket_ (detachKernelDriver devHndl ifNum) + (attachKernelDriver devHndl ifNum) + action) + action + +-------------------------------------------------------------------------------- +-- * Descriptors +-------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- +-- ** Device descriptor +-------------------------------------------------------------------------------- + +{-| A structure representing the standard USB device descriptor. + +This descriptor is documented in section 9.6.1 of the USB 2.0 specification. + +This structure can be retrieved by 'getDeviceDesc'. +-} +data DeviceDesc = DeviceDesc + { -- | USB specification release number. + deviceUSBSpecReleaseNumber :: !ReleaseNumber + + -- | USB-IF class code for the device. + , deviceClass :: !Word8 + + -- | USB-IF subclass code for the device, qualified by the 'deviceClass' + -- value. + , deviceSubClass :: !Word8 + + -- | USB-IF protocol code for the device, qualified by the 'deviceClass' + -- and 'deviceSubClass' values. + , deviceProtocol :: !Word8 + + -- | Maximum packet size for endpoint 0. + , deviceMaxPacketSize0 :: !Word8 + + -- | USB-IF vendor ID. + , deviceVendorId :: !VendorId + + -- | USB-IF product ID. + , deviceProductId :: !ProductId + + -- | Device release number. + , deviceReleaseNumber :: !ReleaseNumber + + -- | Optional index of string descriptor describing manufacturer. + , deviceManufacturerStrIx :: !(Maybe StrIx) + + -- | Optional index of string descriptor describing product. + , deviceProductStrIx :: !(Maybe StrIx) + + -- | Optional index of string descriptor containing device serial number. + , deviceSerialNumberStrIx :: !(Maybe StrIx) + + -- | Number of possible configurations. + , deviceNumConfigs :: !Word8 + } deriving (COMMON_INSTANCES) + +-- | Release \/ version number of the USB specification \/ device. +type ReleaseNumber = (Int, Int, Int, Int) + +-- | A 16-bit number used to identify a USB device. Each vendor ID is assigned +-- by the USB Implementers Forum to a specific company. +type VendorId = Word16 + +-- | A 16-bit number used to identify a USB device. Each company which is +-- assigned a 'VendorId' can assign a product ID to its USB-based products. +type ProductId = Word16 + +-------------------------------------------------------------------------------- +-- ** Configuration descriptor +-------------------------------------------------------------------------------- + +{-| A structure representing the standard USB configuration descriptor. + +This descriptor is documented in section 9.6.3 of the USB 2.0 specification. + +This structure can be retrieved by 'getConfigDesc'. +-} +data ConfigDesc = ConfigDesc + { -- | Identifier value for the configuration. + configValue :: !ConfigValue + + -- | Optional index of string descriptor describing the configuration. + , configStrIx :: !(Maybe StrIx) + + -- | Configuration characteristics. + , configAttribs :: !ConfigAttribs + + -- | Maximum power consumption of the USB device from the bus in the + -- configuration when the device is fully operational. Expressed in 2 mA + -- units (i.e., 50 = 100 mA). + , configMaxPower :: !Word8 + + -- | Vector of interfaces supported by the configuration. + , configInterfaces :: !(Vector Interface) + + -- | Extra descriptors. If @libusb@ encounters unknown configuration + -- descriptors, it will store them here, should you wish to parse them. + , configExtra :: !B.ByteString + + } deriving (COMMON_INSTANCES) + +-------------------------------------------------------------------------------- +-- *** Configuration attributes +-------------------------------------------------------------------------------- + +-- | The USB 2.0 specification specifies that the configuration attributes only +-- describe the device status. +type ConfigAttribs = DeviceStatus + +-- | The status of a USB device. +data DeviceStatus = DeviceStatus + { remoteWakeup :: !Bool -- ^ The Remote Wakeup field indicates whether the + -- device is currently enabled to request remote + -- wakeup. The default mode for devices that + -- support remote wakeup is disabled. + , selfPowered :: !Bool -- ^ The Self Powered field indicates whether the + -- device is currently self-powered + } deriving (COMMON_INSTANCES) + +-------------------------------------------------------------------------------- +-- ** Interface descriptor +-------------------------------------------------------------------------------- + +-- | An interface is represented as a vector of alternate interface settings. +type Interface = Vector InterfaceDesc + +{-| A structure representing the standard USB interface descriptor. + +This descriptor is documented in section 9.6.5 of the USB 2.0 specification. + +This structure can be retrieved using 'configInterfaces'. +-} +data InterfaceDesc = InterfaceDesc + { -- | Number of the interface. + interfaceNumber :: !InterfaceNumber + + -- | Value used to select the alternate setting for the interface. + , interfaceAltSetting :: !InterfaceAltSetting + + -- | USB-IF class code for the interface. + , interfaceClass :: !Word8 + + -- | USB-IF subclass code for the interface, qualified by the + -- 'interfaceClass' value. + , interfaceSubClass :: !Word8 + + -- | USB-IF protocol code for the interface, qualified by the + -- 'interfaceClass' and 'interfaceSubClass' values. + , interfaceProtocol :: !Word8 + + -- | Optional index of string descriptor describing the interface. + , interfaceStrIx :: !(Maybe StrIx) + + -- | Vector of endpoints supported by the interface. + , interfaceEndpoints :: !(Vector EndpointDesc) + + -- | Extra descriptors. If @libusb@ encounters unknown interface + -- descriptors, it will store them here, should you wish to parse them. + , interfaceExtra :: !B.ByteString + } deriving (COMMON_INSTANCES) + +-------------------------------------------------------------------------------- +-- ** Endpoint descriptor +-------------------------------------------------------------------------------- + +{-| A structure representing the standard USB endpoint descriptor. + +This descriptor is documented in section 9.6.3 of the USB 2.0 specification. + +This structure can be retrieved by using 'interfaceEndpoints'. +-} +data EndpointDesc = EndpointDesc + { -- | The address of the endpoint described by the descriptor. + endpointAddress :: !EndpointAddress + + -- | Attributes which apply to the endpoint when it is configured using the + -- 'configValue'. + , endpointAttribs :: !EndpointAttribs + + -- | Maximum packet size the endpoint is capable of sending/receiving. + , endpointMaxPacketSize :: !MaxPacketSize + + -- | Interval for polling endpoint for data transfers. Expressed in frames + -- or microframes depending on the device operating speed (i.e., either 1 + -- millisecond or 125 μs units). + , endpointInterval :: !Word8 + + -- | /For audio devices only:/ the rate at which synchronization feedback + -- is provided. + , endpointRefresh :: !Word8 + + -- | /For audio devices only:/ the address of the synch endpoint. + , endpointSynchAddress :: !Word8 + + -- | Extra descriptors. If @libusb@ encounters unknown endpoint descriptors, + -- it will store them here, should you wish to parse them. + , endpointExtra :: !B.ByteString + } deriving (COMMON_INSTANCES) + +-------------------------------------------------------------------------------- +-- *** Endpoint address +-------------------------------------------------------------------------------- + +-- | The address of an endpoint. +data EndpointAddress = EndpointAddress + { endpointNumber :: !Int + -- ^ Must be >= 0 and <= 15 + , transferDirection :: !TransferDirection + -- ^ The direction of data transfer relative to the host of this endpoint. + } deriving (COMMON_INSTANCES) + +-- | The direction of data transfer relative to the host. +data TransferDirection = Out -- ^ Out transfer direction (host -> device) used + -- for writing. + | In -- ^ In transfer direction (device -> host) used + -- for reading. + deriving (Enum, COMMON_INSTANCES) + +-------------------------------------------------------------------------------- +-- *** Endpoint attributes +-------------------------------------------------------------------------------- + +-- | The USB 2.0 specification specifies that the endpoint attributes only +-- describe the endpoint transfer type. +type EndpointAttribs = TransferType + +-- | Describes what types of transfers are allowed on the endpoint. +data TransferType = + -- | Control transfers are typically used for command and status + -- operations. + Control + + -- | Isochronous transfers occur continuously and periodically. + | Isochronous !Synchronization !Usage + + -- | Bulk transfers can be used for large bursty data. + | Bulk + + -- | Interrupt transfers are typically non-periodic, small device + -- \"initiated\" communication requiring bounded latency. + | Interrupt + deriving (COMMON_INSTANCES) + +-- | See section 5.12.4.1 of the USB 2.0 specification. +data Synchronization = + NoSynchronization -- ^ No Synchonisation. + | Asynchronous -- ^ Unsynchronized, + -- although sinks provide data rate feedback. + | Adaptive -- ^ Synchronized using feedback or feedforward + -- data rate information + | Synchronous -- ^ Synchronized to the USB’s SOF (/Start Of Frame/) + deriving (Enum, COMMON_INSTANCES) + +-- | See section 5.12.4.2 of the USB 2.0 specification. +data Usage = Data + | Feedback + | Implicit + deriving (Enum, COMMON_INSTANCES) + +-------------------------------------------------------------------------------- +-- *** Endpoint max packet size +-------------------------------------------------------------------------------- + +-- | Maximum packet size. +data MaxPacketSize = MaxPacketSize + { maxPacketSize :: !Size + , transactionOpportunities :: !TransactionOpportunities + } deriving (COMMON_INSTANCES) + +-- | Number of additional transaction oppurtunities per microframe. +-- +-- See table 9-13 of the USB 2.0 specification. +data TransactionOpportunities = Zero -- ^ None (1 transaction per microframe) + | One -- ^ 1 additional (2 per microframe) + | Two -- ^ 2 additional (3 per microframe) + deriving (Enum, Ord, COMMON_INSTANCES) + +{-| Calculate the maximum packet size which a specific endpoint is capable of +sending or receiving in the duration of 1 microframe. + +If acting on an 'Isochronous' or 'Interrupt' endpoint, this function will +multiply the 'maxPacketSize' by the additional 'transactionOpportunities'. +If acting on another type of endpoint only the 'maxPacketSize' is returned. + +This function is mainly useful for setting up /isochronous/ transfers. +-} +maxIsoPacketSize :: EndpointDesc -> Size +maxIsoPacketSize epDesc | isochronousOrInterrupt = mps * (1 + fromEnum to) + | otherwise = mps + where + MaxPacketSize mps to = endpointMaxPacketSize epDesc + + isochronousOrInterrupt = case endpointAttribs epDesc of + Isochronous _ _ -> True + Interrupt -> True + _ -> False + +-------------------------------------------------------------------------------- +-- ** Retrieving and converting descriptors +-------------------------------------------------------------------------------- + +-- | Get the USB device descriptor for a given device. +-- +-- This is a non-blocking function; the device descriptor is cached in memory. +-- +-- This function may throw 'USBException's. +getDeviceDesc :: Device -> IO DeviceDesc +getDeviceDesc dev = + withDevicePtr dev $ \devPtr -> + convertDeviceDesc <$> + allocaPeek (handleUSBException . c'libusb_get_device_descriptor devPtr) + +convertDeviceDesc :: C'libusb_device_descriptor -> DeviceDesc +convertDeviceDesc d = DeviceDesc + { deviceUSBSpecReleaseNumber = unmarshalReleaseNumber $ + c'libusb_device_descriptor'bcdUSB d + , deviceClass = c'libusb_device_descriptor'bDeviceClass d + , deviceSubClass = c'libusb_device_descriptor'bDeviceSubClass d + , deviceProtocol = c'libusb_device_descriptor'bDeviceProtocol d + , deviceMaxPacketSize0 = c'libusb_device_descriptor'bMaxPacketSize0 d + , deviceVendorId = c'libusb_device_descriptor'idVendor d + , deviceProductId = c'libusb_device_descriptor'idProduct d + , deviceReleaseNumber = unmarshalReleaseNumber $ + c'libusb_device_descriptor'bcdDevice d + , deviceManufacturerStrIx = unmarshalStrIx $ + c'libusb_device_descriptor'iManufacturer d + , deviceProductStrIx = unmarshalStrIx $ + c'libusb_device_descriptor'iProduct d + , deviceSerialNumberStrIx = unmarshalStrIx $ + c'libusb_device_descriptor'iSerialNumber d + , deviceNumConfigs = c'libusb_device_descriptor'bNumConfigurations d + } + +-- | Unmarshal a a 16bit word as a release number. The 16bit word should be +-- encoded as a +-- +-- using 4 bits for each of the 4 decimals. +unmarshalReleaseNumber :: Word16 -> ReleaseNumber +unmarshalReleaseNumber abcd = (a, b, c, d) + where + a = fromIntegral $ abcd `shiftR` 12 + b = fromIntegral $ (abcd `shiftL` 4) `shiftR` 12 + c = fromIntegral $ (abcd `shiftL` 8) `shiftR` 12 + d = fromIntegral $ (abcd `shiftL` 12) `shiftR` 12 + +-- | Unmarshal an 8bit word to a string descriptor index. 0 denotes that a +-- string descriptor is not available and unmarshals to 'Nothing'. +unmarshalStrIx :: Word8 -> Maybe StrIx +unmarshalStrIx 0 = Nothing +unmarshalStrIx strIx = Just strIx + +-- | Get a USB configuration descriptor based on its index. +-- +-- This is a non-blocking function which does not involve any requests +-- being sent to the device. +-- +-- Exceptions: +-- +-- * 'NotFoundException' if the configuration does not exist. +-- +-- * Another 'USBException'. +getConfigDesc :: Device -> Word8 -> IO ConfigDesc +getConfigDesc dev ix = withDevicePtr dev $ \devPtr -> + bracket (allocaPeek $ handleUSBException + . c'libusb_get_config_descriptor devPtr ix) + c'libusb_free_config_descriptor + ((convertConfigDesc =<<) . peek) + +convertConfigDesc :: C'libusb_config_descriptor -> IO ConfigDesc +convertConfigDesc c = do + interfaces <- mapPeekArray convertInterface + (fromIntegral $ c'libusb_config_descriptor'bNumInterfaces c) + (c'libusb_config_descriptor'interface c) + + extra <- getExtra (c'libusb_config_descriptor'extra c) + (c'libusb_config_descriptor'extra_length c) + + return ConfigDesc + { configValue = c'libusb_config_descriptor'bConfigurationValue c + , configStrIx = unmarshalStrIx $ + c'libusb_config_descriptor'iConfiguration c + , configAttribs = unmarshalConfigAttribs $ + c'libusb_config_descriptor'bmAttributes c + , configMaxPower = c'libusb_config_descriptor'MaxPower c + , configInterfaces = interfaces + , configExtra = extra + } + +unmarshalConfigAttribs :: Word8 -> ConfigAttribs +unmarshalConfigAttribs a = DeviceStatus { remoteWakeup = testBit a 5 + , selfPowered = testBit a 6 + } + +getExtra :: Ptr CUChar -> CInt -> IO B.ByteString +getExtra extra extraLength = B.packCStringLen ( castPtr extra + , fromIntegral extraLength + ) + +convertInterface :: C'libusb_interface -> IO Interface +convertInterface i = + mapPeekArray convertInterfaceDesc + (fromIntegral $ c'libusb_interface'num_altsetting i) + (c'libusb_interface'altsetting i) + +convertInterfaceDesc :: C'libusb_interface_descriptor -> IO InterfaceDesc +convertInterfaceDesc i = do + endpoints <- mapPeekArray convertEndpointDesc + (fromIntegral $ c'libusb_interface_descriptor'bNumEndpoints i) + (c'libusb_interface_descriptor'endpoint i) + + extra <- getExtra (c'libusb_interface_descriptor'extra i) + (c'libusb_interface_descriptor'extra_length i) + + return InterfaceDesc + { interfaceNumber = c'libusb_interface_descriptor'bInterfaceNumber i + , interfaceAltSetting = c'libusb_interface_descriptor'bAlternateSetting i + , interfaceClass = c'libusb_interface_descriptor'bInterfaceClass i + , interfaceSubClass = c'libusb_interface_descriptor'bInterfaceSubClass i + , interfaceStrIx = unmarshalStrIx $ + c'libusb_interface_descriptor'iInterface i + , interfaceProtocol = c'libusb_interface_descriptor'bInterfaceProtocol i + , interfaceEndpoints = endpoints + , interfaceExtra = extra + } + +convertEndpointDesc :: C'libusb_endpoint_descriptor -> IO EndpointDesc +convertEndpointDesc e = do + extra <- getExtra (c'libusb_endpoint_descriptor'extra e) + (c'libusb_endpoint_descriptor'extra_length e) + + return EndpointDesc + { endpointAddress = unmarshalEndpointAddress $ + c'libusb_endpoint_descriptor'bEndpointAddress e + , endpointAttribs = unmarshalEndpointAttribs $ + c'libusb_endpoint_descriptor'bmAttributes e + , endpointMaxPacketSize = unmarshalMaxPacketSize $ + c'libusb_endpoint_descriptor'wMaxPacketSize e + , endpointInterval = c'libusb_endpoint_descriptor'bInterval e + , endpointRefresh = c'libusb_endpoint_descriptor'bRefresh e + , endpointSynchAddress = c'libusb_endpoint_descriptor'bSynchAddress e + , endpointExtra = extra + } + +-- | Unmarshal an 8bit word as an endpoint address. This function is primarily +-- used when unmarshalling USB descriptors. +unmarshalEndpointAddress :: Word8 -> EndpointAddress +unmarshalEndpointAddress a = + EndpointAddress { endpointNumber = fromIntegral $ bits 0 3 a + , transferDirection = if testBit a 7 then In else Out + } + +-- | Marshal an endpoint address so that it can be used by the @libusb@ transfer +-- functions. +marshalEndpointAddress :: (Bits a, Num a) => EndpointAddress -> a +marshalEndpointAddress (EndpointAddress num transDir) = + assert (between num 0 15) $ let n = fromIntegral num + in case transDir of + Out -> n + In -> setBit n 7 + +unmarshalEndpointAttribs :: Word8 -> EndpointAttribs +unmarshalEndpointAttribs a = + case bits 0 1 a of + 0 -> Control + 1 -> Isochronous (genToEnum $ bits 2 3 a) + (genToEnum $ bits 4 5 a) + 2 -> Bulk + 3 -> Interrupt + _ -> moduleError "unmarshalEndpointAttribs: this can't happen!" + +unmarshalMaxPacketSize :: Word16 -> MaxPacketSize +unmarshalMaxPacketSize m = + MaxPacketSize + { maxPacketSize = fromIntegral $ bits 0 10 m + , transactionOpportunities = genToEnum $ bits 11 12 m + } + +-------------------------------------------------------------------------------- +-- ** String descriptors +-------------------------------------------------------------------------------- + +-- | The size in number of bytes of the header of string descriptors. +strDescHeaderSize :: Size +strDescHeaderSize = 2 + +-- | Characters are encoded as UTF16LE so each character takes two bytes. +charSize :: Size +charSize = 2 + +{-| Retrieve a vector of supported languages. + +This function may throw 'USBException's. +-} +getLanguages :: DeviceHandle -> IO (Vector LangId) +getLanguages devHndl = allocaArray maxSize $ \dataPtr -> do + let strIx = 0 + langId = 0 + reportedSize <- retrieveStrDesc devHndl strIx langId maxSize dataPtr + + let strSize = (reportedSize - strDescHeaderSize) `div` charSize + strPtr = castPtr $ dataPtr `plusPtr` strDescHeaderSize + + (VG.map unmarshalLangId . VG.convert) <$> peekVector strSize strPtr + where + maxSize = 255 -- Some devices choke on size > 255 + +{-| @retrieveStrDesc devHndl strIx langId maxSize dataPtr@ retrieves the string +descriptor @strIx@ in the language @langId@ from the @devHndl@ and writes at +most @maxSize@ bytes from that string descriptor to the location that @dataPtr@ +points to. So ensure there is at least space for @maxSize@ bytes there. Next, +the header of the string descriptor is checked for correctness. If it's +incorrect an 'IOException' is thrown. Finally, the size reported in the header +is returned. +-} +retrieveStrDesc :: DeviceHandle + -> StrIx + -> Word16 + -> Size + -> Ptr CUChar + -> IO Size +retrieveStrDesc devHndl strIx langId maxSize dataPtr = do + actualSize <- withDevHndlPtr devHndl $ \devHndlPtr -> + checkUSBException $ c'libusb_get_string_descriptor + devHndlPtr + strIx + langId + dataPtr + (fromIntegral maxSize) + when (actualSize < strDescHeaderSize) $ + throwIO $ IOException "Incomplete header" + + reportedSize <- peek dataPtr + + when (reportedSize > fromIntegral actualSize) $ + throwIO $ IOException "Not enough space to hold data" + + descType <- peekElemOff dataPtr 1 + + when (descType /= c'LIBUSB_DT_STRING) $ + throwIO $ IOException "Invalid header" + + return $ fromIntegral reportedSize + +{-| The language ID consists of the primary language identifier and the +sublanguage identififier as described in: + + + +For a mapping between IDs and languages see the + package. + +To see which 'LangId's are supported by a device see 'getLanguages'. +-} +type LangId = (PrimaryLangId, SubLangId) + +-- | The primary language identifier. +type PrimaryLangId = Word16 + +-- | The sublanguage identifier. +type SubLangId = Word16 + +unmarshalLangId :: Word16 -> LangId +unmarshalLangId = bits 0 9 &&& bits 10 15 + +marshalLangId :: LangId -> Word16 +marshalLangId (p, s) = p .|. s `shiftL`10 + +-- | Type of indici of string descriptors. +-- +-- Can be retrieved by all the *StrIx functions. +type StrIx = Word8 + +{-| Retrieve a string descriptor from a device. + +This function may throw 'USBException's. +-} +getStrDesc :: DeviceHandle + -> StrIx + -> LangId + -> Int -- ^ Maximum number of characters in the requested string. An + -- 'IOException' will be thrown when the requested string is + -- larger than this number. + -> IO Text +getStrDesc devHndl strIx langId nrOfChars = assert (strIx /= 0) $ + fmap decode $ BI.createAndTrim size $ write . castPtr + where + write = retrieveStrDesc devHndl strIx (marshalLangId langId) size + size = strDescHeaderSize + nrOfChars * charSize + decode = TE.decodeUtf16LE . B.drop strDescHeaderSize + +{-| Retrieve a string descriptor from a device using the first supported language. + +This function may throw 'USBException's. +-} +getStrDescFirstLang :: DeviceHandle + -> StrIx + -> Int -- ^ Maximum number of characters in the requested + -- string. An 'IOException' will be thrown when the + -- requested string is larger than this number. + -> IO Text +getStrDescFirstLang devHndl strIx nrOfChars = do + langIds <- getLanguages devHndl + case V.uncons langIds of + Nothing -> throwIO $ IOException "Zero languages" + Just (langId, _) -> getStrDesc devHndl strIx langId nrOfChars + +-------------------------------------------------------------------------------- +-- * I/O +-------------------------------------------------------------------------------- + +{-| Handy type synonym for read transfers. + +A @ReadAction@ is a function which takes a 'Size' which defines how many bytes +to read and a 'Timeout'. The function returns an 'IO' action which, when +executed, performs the actual read and returns the 'B.ByteString' that was read +paired with a 'Status' flag which indicates whether the transfer +'Completed' or 'TimedOut'. +-} +type ReadAction = Size -> Timeout -> IO (B.ByteString, Status) + +-- | Handy type synonym for read transfers that must exactly read the specified +-- number of bytes. An 'incompleteReadException' is thrown otherwise. +type ReadExactAction = Size -> Timeout -> IO B.ByteString + +{-| Handy type synonym for write transfers. + +A @WriteAction@ is a function which takes a 'B.ByteString' to write and a +'Timeout'. The function returns an 'IO' action which, when exectued, returns the +number of bytes that were actually written paired with a 'Status' flag which +indicates whether the transfer 'Completed' or 'TimedOut'. +-} +type WriteAction = B.ByteString -> Timeout -> IO (Size, Status) + +-- | Handy type synonym for write transfers that must exactly write all the +-- given bytes. An 'incompleteWriteException' is thrown otherwise. +type WriteExactAction = B.ByteString -> Timeout -> IO () + +-- | Number of bytes transferred. +type Size = Int + +-- | A timeout in milliseconds. A timeout defines how long a transfer should wait +-- before giving up due to no response being received. +-- Use 'noTimeout' for no timeout. +type Timeout = Int + +-- | A timeout of 0 denotes no timeout so: @noTimeout = 0@. +noTimeout :: Timeout +noTimeout = 0 + +-- | Status of a terminated transfer. +data Status = Completed -- ^ All bytes were transferred + -- within the maximum allowed 'Timeout' period. + | TimedOut -- ^ Not all bytes were transferred + -- within the maximum allowed 'Timeout' period. + deriving (COMMON_INSTANCES) + +------------------------------------------------------------------------------- +-- ** Types of control transfers +------------------------------------------------------------------------------- + +-- | Setup for control transfers. +data ControlSetup = ControlSetup + { controlSetupRequestType :: !RequestType -- ^ The type of request. + , controlSetupRecipient :: !Recipient -- ^ The recipient of the request. + , controlSetupRequest :: !Request -- ^ The numeric request. + , controlSetupValue :: !Value -- ^ The value. + , controlSetupIndex :: !Index -- ^ The index. + } deriving (COMMON_INSTANCES) + + +marshallControlSetup :: ControlSetup -> + TransferDirection -> + Size -> C'libusb_control_setup +marshallControlSetup (ControlSetup reqType reqRecipient request value index) + reqDir size = + C'libusb_control_setup requestType + request value index + (fromIntegral size) + where + requestType = marshalRequestType reqType reqRecipient reqDir + +-- | The type of control requests. +data RequestType = + Standard + -- ^ Standard requests are common to all USB device's. + | Class + -- ^ Class requests are common to classes of drivers. For example, all + -- device's conforming to the HID class will have a common set of class + -- specific requests. These will differ to a device conforming to the + -- communications class and differ again to that of a device conforming + -- to the mass storage class. + | Vendor + -- ^ These are requests which the USB device designer (you?) can + -- assign. These are normally different from device to device, but this + -- is all up to your implementation and imagination. + deriving (Enum, COMMON_INSTANCES) + +-- | A common request can be directed to different recipients and based on the +-- recipient perform different functions. A @GetStatus@ 'Standard' request for +-- example, can be directed at the device, interface or endpoint. When directed +-- to a device it returns flags indicating the status of remote wakeup and if +-- the device is self powered. However if the same request is directed at the +-- interface it always returns zero, or should it be directed at an endpoint +-- will return the halt flag for the endpoint. +data Recipient = ToDevice -- ^ Directed to the device. + | ToInterface -- ^ Directed to the interface. + | ToEndpoint -- ^ Directed to the endpoint. + | ToOther -- ^ Directed to something other than the device, + -- interface or endpoint. + deriving (Enum, COMMON_INSTANCES) + +-- | The actual request code. +type Request = Word8 + +-- | A potential additional parameter for the request. +-- +-- (Host-endian) +type Value = Word16 + +-- | A potential additional parameter for the request. Usually used as an index +-- or offset. +-- +-- (Host-endian) +type Index = Word16 + +marshalRequestType :: RequestType -> Recipient -> TransferDirection -> Word8 +marshalRequestType t r d = genFromEnum d `shiftL` 7 .|. + genFromEnum t `shiftL` 5 .|. + genFromEnum r + +-------------------------------------------------------------------------------- +-- ** Control transfers +-------------------------------------------------------------------------------- + +{-| Perform a USB /control/ request that does not transfer data. + +Exceptions: + + * 'TimeoutException' if the transfer timed out. + + * 'PipeException' if the control request was not supported by the device + + * 'NoDeviceException' if the device has been disconnected. + + * Another 'USBException'. +-} +control :: DeviceHandle -> ControlSetup -> Timeout -> IO () +control devHndl ctrlSetup timeout = do + (_, status) <- doControl + when (status == TimedOut) $ throwIO TimeoutException + where + doControl +#ifdef HAS_EVENT_MANAGER + | Just wait <- getWait devHndl = + allocaBytes controlSetupSize $ \bufferPtr -> do + poke bufferPtr $ marshallControlSetup ctrlSetup Out 0 + transferAsync wait + c'LIBUSB_TRANSFER_TYPE_CONTROL + devHndl + controlEndpoint + timeout + (bufferPtr, controlSetupSize) +#endif + | otherwise = controlTransferSync devHndl ctrlSetup Out timeout (nullPtr, 0) + +-------------------------------------------------------------------------------- + +{-| Perform a USB /control/ read. + +Exceptions: + + * 'PipeException' if the control request was not supported by the device + + * 'NoDeviceException' if the device has been disconnected. + + * Another 'USBException'. +-} +readControl :: DeviceHandle -> ControlSetup -> ReadAction +readControl devHndl ctrlSetup size timeout +#ifdef HAS_EVENT_MANAGER + | Just wait <- getWait devHndl = do + let totalSize = controlSetupSize + size + allocaBytes totalSize $ \bufferPtr -> do + poke bufferPtr $ marshallControlSetup ctrlSetup In size + (transferred, status) <- transferAsync wait + c'LIBUSB_TRANSFER_TYPE_CONTROL + devHndl controlEndpoint + timeout + (bufferPtr, totalSize) + bs <- BI.create transferred $ \dataPtr -> + copyArray dataPtr (bufferPtr `plusPtr` controlSetupSize) transferred + return (bs, status) +#endif + | otherwise = createAndTrimNoOffset size $ \dataPtr -> + controlTransferSync devHndl ctrlSetup In timeout (dataPtr, size) + +-- | A convenience function similar to 'readControl' which checks if the +-- specified number of bytes to read were actually read. +-- Throws an 'incompleteReadException' if this is not the case. +readControlExact :: DeviceHandle -> ControlSetup -> ReadExactAction +readControlExact devHndl ctrlSetup size timeout = do + (bs, _) <- readControl devHndl ctrlSetup size timeout + if B.length bs /= size + then throwIO incompleteReadException + else return bs + +-------------------------------------------------------------------------------- + + +{-| Perform a USB /control/ write. + +Exceptions: + + * 'PipeException' if the control request was not supported by the device + + * 'NoDeviceException' if the device has been disconnected. + + * Another 'USBException'. +-} +writeControl :: DeviceHandle -> ControlSetup -> WriteAction +writeControl devHndl ctrlSetup input timeout +#ifdef HAS_EVENT_MANAGER + | Just wait <- getWait devHndl = + BU.unsafeUseAsCStringLen input $ \(dataPtr, size) -> do + let totalSize = controlSetupSize + size + allocaBytes totalSize $ \bufferPtr -> do + poke bufferPtr $ marshallControlSetup ctrlSetup Out size + copyArray (bufferPtr `plusPtr` controlSetupSize) dataPtr size + transferAsync wait + c'LIBUSB_TRANSFER_TYPE_CONTROL + devHndl controlEndpoint + timeout + (bufferPtr, totalSize) +#endif + | otherwise = BU.unsafeUseAsCStringLen input $ + controlTransferSync devHndl ctrlSetup Out timeout + +-- | A convenience function similar to 'writeControl' which checks if the given +-- bytes were actually fully written. +-- Throws an 'incompleteWriteException' if this is not the case. +writeControlExact :: DeviceHandle -> ControlSetup -> WriteExactAction +writeControlExact devHndl ctrlSetup input timeout = do + (transferred, _) <- writeControl devHndl ctrlSetup input timeout + when (transferred /= B.length input) $ throwIO incompleteWriteException + +-------------------------------------------------------------------------------- + +#ifdef HAS_EVENT_MANAGER +controlSetupSize :: Size +controlSetupSize = sizeOf (undefined :: C'libusb_control_setup) + +controlEndpoint :: CUChar +controlEndpoint = 0 +#endif + +controlTransferSync :: DeviceHandle + -> ControlSetup + -> TransferDirection + -> Timeout + -> (Ptr byte, Size) + -> IO (Size, Status) +controlTransferSync devHndl + (ControlSetup reqType reqRecipient request value index) + reqDir + timeout + (dataPtr, size) = do + err <- withDevHndlPtr devHndl $ \devHndlPtr -> + c'libusb_control_transfer devHndlPtr + requestType request value index + (castPtr dataPtr) (fromIntegral size) + (fromIntegral timeout) + let timedOut = err == c'LIBUSB_ERROR_TIMEOUT + if err < 0 && not timedOut + then throwIO $ convertUSBException err + else return ( fromIntegral err + , if timedOut then TimedOut else Completed + ) + where + requestType = marshalRequestType reqType reqRecipient reqDir + + +-------------------------------------------------------------------------------- +-- ** Bulk transfers +-------------------------------------------------------------------------------- + +{-| Perform a USB /bulk/ read. + +Exceptions: + + * 'PipeException' if the endpoint halted. + + * 'OverflowException' if the device offered more data, see + + in the @libusb@ documentation. + + * 'NoDeviceException' if the device has been disconnected. + + * Another 'USBException'. +-} +readBulk :: DeviceHandle + -> EndpointAddress -- ^ Make sure 'transferDirection' is set to 'In'. + -> ReadAction +readBulk devHndl +#ifdef HAS_EVENT_MANAGER + | Just wait <- getWait devHndl = + readTransferAsync wait c'LIBUSB_TRANSFER_TYPE_BULK devHndl +#endif + | otherwise = readTransferSync c'libusb_bulk_transfer devHndl + +{-| Perform a USB /bulk/ write. + +Exceptions: + + * 'PipeException' if the endpoint halted. + + * 'OverflowException' if the device offered more data, see + + in the @libusb@ documentation. + + * 'NoDeviceException' if the device has been disconnected. + + * Another 'USBException'. +-} +writeBulk :: DeviceHandle + -> EndpointAddress -- ^ Make sure 'transferDirection' is set to 'Out'. + -> WriteAction +writeBulk devHndl +#ifdef HAS_EVENT_MANAGER + | Just wait <- getWait devHndl = + writeTransferAsync wait c'LIBUSB_TRANSFER_TYPE_BULK devHndl +#endif + | otherwise = writeTransferSync c'libusb_bulk_transfer devHndl + +-------------------------------------------------------------------------------- +-- ** Interrupt transfers +-------------------------------------------------------------------------------- + +{-| Perform a USB /interrupt/ read. + +Exceptions: + + * 'PipeException' if the endpoint halted. + + * 'OverflowException' if the device offered more data, see + + in the @libusb@ documentation. + + * 'NoDeviceException' if the device has been disconnected. + + * Another 'USBException'. +-} +readInterrupt :: DeviceHandle + -> EndpointAddress -- ^ Make sure 'transferDirection' is set to 'In'. + -> ReadAction +readInterrupt devHndl +#ifdef HAS_EVENT_MANAGER + | Just wait <- getWait devHndl = + readTransferAsync wait c'LIBUSB_TRANSFER_TYPE_INTERRUPT devHndl +#endif + | otherwise = readTransferSync c'libusb_interrupt_transfer devHndl + + +{-| Perform a USB /interrupt/ write. + +Exceptions: + + * 'PipeException' if the endpoint halted. + + * 'OverflowException' if the device offered more data, see + + in the @libusb@ documentation. + + * 'NoDeviceException' if the device has been disconnected. + + * Another 'USBException'. +-} +writeInterrupt :: DeviceHandle + -> EndpointAddress -- ^ Make sure 'transferDirection' is set to 'Out'. + -> WriteAction +writeInterrupt devHndl +#ifdef HAS_EVENT_MANAGER + | Just wait <- getWait devHndl = + writeTransferAsync wait c'LIBUSB_TRANSFER_TYPE_INTERRUPT devHndl +#endif + | otherwise = writeTransferSync c'libusb_interrupt_transfer devHndl + +-------------------------------------------------------------------------------- + +-- | Handy type synonym for the @libusb@ transfer functions. +type C'TransferFunc = Ptr C'libusb_device_handle -- devHndlPtr + -> CUChar -- endpoint address + -> Ptr CUChar -- dataPtr + -> CInt -- size + -> Ptr CInt -- transferredPtr + -> CUInt -- timeout + -> IO CInt -- error + +readTransferSync :: C'TransferFunc -> (DeviceHandle -> EndpointAddress -> ReadAction) +readTransferSync c'transfer = \devHndl endpointAddr -> \size timeout -> + createAndTrimNoOffset size $ \dataPtr -> + transferSync c'transfer + devHndl endpointAddr + timeout + (castPtr dataPtr, size) + +writeTransferSync :: C'TransferFunc -> (DeviceHandle -> EndpointAddress -> WriteAction) +writeTransferSync c'transfer = \devHndl endpointAddr -> \input timeout -> + BU.unsafeUseAsCStringLen input $ + transferSync c'transfer + devHndl endpointAddr + timeout + +transferSync :: C'TransferFunc -> DeviceHandle + -> EndpointAddress + -> Timeout + -> CStringLen + -> IO (Size, Status) +transferSync c'transfer devHndl + endpointAddr + timeout + (dataPtr, size) = + alloca $ \transferredPtr -> do + err <- withDevHndlPtr devHndl $ \devHndlPtr -> + c'transfer devHndlPtr + (marshalEndpointAddress endpointAddr) + (castPtr dataPtr) + (fromIntegral size) + transferredPtr + (fromIntegral timeout) + let timedOut = err == c'LIBUSB_ERROR_TIMEOUT + if err /= c'LIBUSB_SUCCESS && not timedOut + then throwIO $ convertUSBException err + else do transferred <- peek transferredPtr + return ( fromIntegral transferred + , if timedOut then TimedOut else Completed + ) + +-------------------------------------------------------------------------------- + +#ifdef HAS_EVENT_MANAGER +readTransferAsync :: Wait + -> C'TransferType + -> DeviceHandle -> EndpointAddress -> ReadAction +readTransferAsync wait transType = \devHndl endpointAddr -> \size timeout -> + createAndTrimNoOffset size $ \bufferPtr -> + transferAsync wait + transType + devHndl (marshalEndpointAddress endpointAddr) + timeout + (bufferPtr, size) + +writeTransferAsync :: Wait + -> C'TransferType + -> DeviceHandle -> EndpointAddress -> WriteAction +writeTransferAsync wait transType = \devHndl endpointAddr -> \input timeout -> + BU.unsafeUseAsCStringLen input $ + transferAsync wait + transType + devHndl (marshalEndpointAddress endpointAddr) + timeout + +-------------------------------------------------------------------------------- + +-- | Endpoint transfer type. Can be any of: +-- +-- * 'c'LIBUSB_TRANSFER_TYPE_CONTROL' +-- * 'c'LIBUSB_TRANSFER_TYPE_ISOCHRONOUS' +-- * 'c'LIBUSB_TRANSFER_TYPE_BULK' +-- * 'c'LIBUSB_TRANSFER_TYPE_INTERRUPT' +type C'TransferType = CUChar + +transferAsync :: Wait + -> C'TransferType + -> DeviceHandle -> CUChar -- ^ Encoded endpoint address + -> Timeout + -> (Ptr byte, Size) + -> IO (Size, Status) +transferAsync wait transType devHndl endpoint timeout bytes = + withTerminatedTransfer wait + transType + isos + devHndl endpoint + timeout + bytes + (continue Completed) + (continue TimedOut) + where + isos :: Storable.Vector C'libusb_iso_packet_descriptor + isos = VG.empty + + continue :: Status -> (Ptr C'libusb_transfer -> IO (Size, Status)) + continue status = \transPtr -> do + n <- peek $ p'libusb_transfer'actual_length transPtr + return (fromIntegral n, status) + +-------------------------------------------------------------------------------- + +withTerminatedTransfer :: Wait + -> C'TransferType + -> Storable.Vector C'libusb_iso_packet_descriptor + -> DeviceHandle -> CUChar -- ^ Encoded endpoint address + -> Timeout + -> (Ptr byte, Size) + -> (Ptr C'libusb_transfer -> IO a) + -> (Ptr C'libusb_transfer -> IO a) + -> IO a +withTerminatedTransfer wait + transType + isos + devHndl endpoint + timeout + (bufferPtr, size) + onCompletion + onTimeout = + withDevHndlPtr devHndl $ \devHndlPtr -> + allocaTransfer nrOfIsos $ \transPtr -> do + lock <- newLock + withCallback (\_transPtr -> release lock) $ \cbPtr -> do + poke (p'libusb_transfer'dev_handle transPtr) devHndlPtr + poke (p'libusb_transfer'endpoint transPtr) endpoint + poke (p'libusb_transfer'type transPtr) transType + poke (p'libusb_transfer'timeout transPtr) (fromIntegral timeout) + poke (p'libusb_transfer'length transPtr) (fromIntegral size) + poke (p'libusb_transfer'callback transPtr) cbPtr + poke (p'libusb_transfer'buffer transPtr) (castPtr bufferPtr) + poke (p'libusb_transfer'num_iso_packets transPtr) (fromIntegral nrOfIsos) + + pokeVector (p'libusb_transfer'iso_packet_desc transPtr) isos + + mask_ $ do + handleUSBException $ c'libusb_submit_transfer transPtr + wait timeout lock transPtr + + status <- peek $ p'libusb_transfer'status transPtr + case status of + ts | ts == c'LIBUSB_TRANSFER_COMPLETED -> onCompletion transPtr + | ts == c'LIBUSB_TRANSFER_TIMED_OUT -> onTimeout transPtr + + | ts == c'LIBUSB_TRANSFER_ERROR -> throwIO ioException + | ts == c'LIBUSB_TRANSFER_NO_DEVICE -> throwIO NoDeviceException + | ts == c'LIBUSB_TRANSFER_OVERFLOW -> throwIO OverflowException + | ts == c'LIBUSB_TRANSFER_STALL -> throwIO PipeException + + | ts == c'LIBUSB_TRANSFER_CANCELLED -> + moduleError "transfer status can't be Cancelled!" + + | otherwise -> moduleError $ "Unknown transfer status: " ++ + show ts ++ "!" + where + nrOfIsos = VG.length isos + +-------------------------------------------------------------------------------- + +-- | Allocate a transfer with the given number of isochronous packets and apply +-- the function to the resulting pointer. The transfer is automatically freed +-- when the function terminates (whether normally or by raising an exception). +-- +-- A 'NoMemException' may be thrown. +allocaTransfer :: Int -> (Ptr C'libusb_transfer -> IO a) -> IO a +allocaTransfer nrOfIsos = bracket (mallocTransfer nrOfIsos) + c'libusb_free_transfer + +mallocTransfer :: Int -> IO (Ptr C'libusb_transfer) +mallocTransfer nrOfIsos = do + transPtr <- c'libusb_alloc_transfer (fromIntegral nrOfIsos) + when (transPtr == nullPtr) (throwIO NoMemException) + return transPtr + +-------------------------------------------------------------------------------- + +-- | Create a 'FunPtr' to the given transfer callback function and pass it to +-- the continuation function. The 'FunPtr' is automatically freed when the +-- continuation terminates (whether normally or by raising an exception). +withCallback :: (Ptr C'libusb_transfer -> IO ()) + -> (C'libusb_transfer_cb_fn -> IO a) + -> IO a +withCallback cb = bracket (mk'libusb_transfer_cb_fn cb) freeHaskellFunPtr + +-------------------------------------------------------------------------------- + +-- | A lock is in one of two states: \"locked\" or \"unlocked\". +newtype Lock = Lock (MVar ()) deriving Eq + +-- | Create a lock in the \"unlocked\" state. +newLock :: IO Lock +newLock = Lock <$> newEmptyMVar + +{-| +Acquires the 'Lock'. Blocks if another thread has acquired the 'Lock'. + +@acquire@ behaves as follows: + +* When the state is \"unlocked\" @acquire@ changes the state to \"locked\". + +* When the state is \"locked\" @acquire@ /blocks/ until a call to 'release' in +another thread wakes the calling thread. Upon awakening it will change the state +to \"locked\". +-} +acquire :: Lock -> IO () +acquire (Lock mv) = takeMVar mv + +{-| +@release@ changes the state to \"unlocked\" and returns immediately. + +The behaviour is undefined when a lock in the \"unlocked\" state is released! + +If there are any threads blocked on 'acquire' the thread that first called +@acquire@ will be woken up. +-} +release :: Lock -> IO () +release (Lock mv) = putMVar mv () + +-------------------------------------------------------------------------------- +-- ** Isochronous transfers +-------------------------------------------------------------------------------- + +{-| Perform a USB /isochronous/ read. + +/WARNING:/ You need to enable the threaded runtime (@-threaded@) for this +function to work correctly. It throws a runtime error otherwise! + +Exceptions: + + * 'PipeException' if the endpoint halted. + + * 'OverflowException' if the device offered more data, see + + in the @libusb@ documentation. + + * 'NoDeviceException' if the device has been disconnected. + + * Another 'USBException'. +-} +readIsochronous :: DeviceHandle + -> EndpointAddress -- ^ Make sure 'transferDirection' is set to 'In'. + -> Unboxed.Vector Size -- ^ Sizes of isochronous packets to read. + -> Timeout + -> IO (Vector B.ByteString) +readIsochronous devHndl endpointAddr sizes timeout = do + wait <- requireWait devHndl "readIsochronous" + allocaBytes totalSize $ \bufferPtr -> + withTerminatedTransfer + wait + c'LIBUSB_TRANSFER_TYPE_ISOCHRONOUS + isos + devHndl + (marshalEndpointAddress endpointAddr) + timeout + (bufferPtr, totalSize) + (getPackets nrOfIsos bufferPtr) + (\_ -> throwIO TimeoutException) + where + totalSize = VG.sum sizes + nrOfIsos = VG.length sizes + isos = VG.map initIsoPacketDesc $ VG.convert sizes + +getPackets :: Int -> Ptr Word8 -> Ptr C'libusb_transfer -> IO (Vector B.ByteString) +getPackets nrOfIsos bufferPtr transPtr = do + mv <- VGM.unsafeNew nrOfIsos + let go !ix ptr + | ix < nrOfIsos = do + let isoPtr = advancePtr isoArrayPtr ix + l <- peek (p'libusb_iso_packet_descriptor'length isoPtr) + a <- peek (p'libusb_iso_packet_descriptor'actual_length isoPtr) + let transferred = fromIntegral a + bs <- BI.create transferred $ \p -> copyArray p ptr transferred + VGM.unsafeWrite mv ix bs + go (ix+1) (ptr `plusPtr` fromIntegral l) + | otherwise = VG.unsafeFreeze mv + go 0 bufferPtr + where + isoArrayPtr = p'libusb_transfer'iso_packet_desc transPtr + +-------------------------------------------------------------------------------- + +{-| Perform a USB /isochronous/ write. + +/WARNING:/ You need to enable the threaded runtime (@-threaded@) for this +function to work correctly. It throws a runtime error otherwise! + +Exceptions: + + * 'PipeException' if the endpoint halted. + + * 'OverflowException' if the device offered more data, see + + in the @libusb@ documentation. + + * 'NoDeviceException' if the device has been disconnected. + + * Another 'USBException'. +-} +writeIsochronous :: DeviceHandle + -> EndpointAddress -- ^ Make sure 'transferDirection' is set to 'Out'. + -> Vector B.ByteString -- ^ Isochronous packets to write. + -> Timeout + -> IO (Unboxed.Vector Size) +writeIsochronous devHndl endpointAddr isoPackets timeout = do + wait <- requireWait devHndl "writeIsochronous" + allocaBytes totalSize $ \bufferPtr -> do + copyIsos (castPtr bufferPtr) isoPackets + withTerminatedTransfer + wait + c'LIBUSB_TRANSFER_TYPE_ISOCHRONOUS + isos + devHndl + (marshalEndpointAddress endpointAddr) + timeout + (bufferPtr, totalSize) + (getSizes nrOfIsos) + (\_ -> throwIO TimeoutException) + where + sizes = VG.map B.length isoPackets + nrOfIsos = VG.length sizes + totalSize = VG.sum sizes + isos = VG.convert $ VG.map initIsoPacketDesc sizes + +getSizes :: Int -> Ptr C'libusb_transfer -> IO (Unboxed.Vector Size) +getSizes nrOfIsos transPtr = do + mv <- VGM.unsafeNew nrOfIsos + let go !ix + | ix < nrOfIsos = do + let isoPtr = advancePtr isoArrayPtr ix + a <- peek (p'libusb_iso_packet_descriptor'actual_length isoPtr) + let transferred = fromIntegral a + VGM.unsafeWrite mv ix transferred + go (ix+1) + | otherwise = VG.unsafeFreeze mv + go 0 + where + isoArrayPtr = p'libusb_transfer'iso_packet_desc transPtr + +copyIsos :: Ptr CChar -> Vector B.ByteString -> IO () +copyIsos = VG.foldM_ $ \bufferPtr bs -> + BU.unsafeUseAsCStringLen bs $ \(ptr, len) -> do + copyArray bufferPtr ptr len + return $ bufferPtr `plusPtr` len + +-- | An isochronous packet descriptor with all fields zero except for the length. +initIsoPacketDesc :: Size -> C'libusb_iso_packet_descriptor +initIsoPacketDesc size = + C'libusb_iso_packet_descriptor + { c'libusb_iso_packet_descriptor'length = fromIntegral size + , c'libusb_iso_packet_descriptor'actual_length = 0 + , c'libusb_iso_packet_descriptor'status = 0 + } + + +-------------------------------------------------------------------------------- +-- * Repeatable transfers +-------------------------------------------------------------------------------- + +-- | A 'Transfer' should not be performed concurrently which is why we +-- sequentialize it using an 'MVar'. +type ThreadSafeTransfer = MVar Transfer + +data Transfer = Transfer + { transForeignPtr :: ForeignPtr C'libusb_transfer + , transWait :: Timeout -> Ptr C'libusb_transfer -> IO () + -- ^ Function to wait on the termination of a transfer. + -- Note that this is just 'Wait' partially applied to a 'Lock'. + , transDevHndl :: DeviceHandle + -- ^ The 'DeviceHandle' is stored so that its associated 'Device' and + -- 'Ctx' can be kept alive during the lifetime of a 'Transfer'. + , transBufferFinalizerIORef :: IORef (IO ()) + } + +-- | Safely operate on the internal @libusb@ @transfer@ structure. +withTransPtr :: Transfer -> (Ptr C'libusb_transfer -> IO a) -> IO a +withTransPtr = withForeignPtr . transForeignPtr + +newThreadSafeTransfer :: (Ptr byte, Size) -- ^ Pointer to an input or output buffer + -- with its associated size. + -> IO () -- ^ Buffer finalizer. + -> C'TransferType + -> Storable.Vector C'libusb_iso_packet_descriptor + -> DeviceHandle + -> CUChar + -> Timeout + -> IO ThreadSafeTransfer +newThreadSafeTransfer (bufferPtr, size) + finalizeBuffer transType isos devHndl endpoint timeout = do + wait <- requireWait devHndl "newThreadSafeTransfer" + withDevHndlPtr devHndl $ \devHndlPtr -> mask_ $ do + + -- Allocate: + transPtr <- mallocTransfer nrOfIsos + + waitLock <- newLock + cbPtr <- mk'libusb_transfer_cb_fn (\_transPtr -> release waitLock) + + -- Fill the transfer: + poke (p'libusb_transfer'dev_handle transPtr) devHndlPtr + poke (p'libusb_transfer'endpoint transPtr) endpoint + poke (p'libusb_transfer'type transPtr) transType + poke (p'libusb_transfer'timeout transPtr) (fromIntegral timeout) + poke (p'libusb_transfer'length transPtr) (fromIntegral size) + poke (p'libusb_transfer'callback transPtr) cbPtr + poke (p'libusb_transfer'buffer transPtr) (castPtr bufferPtr) + poke (p'libusb_transfer'num_iso_packets transPtr) (fromIntegral nrOfIsos) + + pokeVector (p'libusb_transfer'iso_packet_desc transPtr) isos + + bufferFinalizerIORef <- newIORef finalizeBuffer + + transFP <- FC.newForeignPtr transPtr $ do + c'libusb_free_transfer transPtr + freeHaskellFunPtr cbPtr + + bufferFinalizer <- readIORef bufferFinalizerIORef + bufferFinalizer + + newMVar Transfer + { transForeignPtr = transFP + , transWait = \t -> wait t waitLock + , transDevHndl = devHndl + , transBufferFinalizerIORef = bufferFinalizerIORef + } + where + nrOfIsos = VG.length isos + +performThreadSafeTransfer :: ThreadSafeTransfer + -> (Ptr C'libusb_transfer -> IO a) + -> (Ptr C'libusb_transfer -> IO a) + -> IO a +performThreadSafeTransfer threadSafeTransfer onCompletion onTimeout = + + -- Ensure transfers are not performed concurrently: + withMVar threadSafeTransfer $ \transfer -> + + withTransPtr transfer $ \transPtr -> + + -- Ensure that the Device and Ctx, associated with the DeviceHandle, are + -- kept alive at least for the duration of the transfer: + withDevHndlPtr (transDevHndl transfer) $ \_devHndlPtr -> do + + mask_ $ do + handleUSBException $ c'libusb_submit_transfer transPtr + timeout <- peek $ p'libusb_transfer'timeout transPtr + transWait transfer (fromIntegral timeout) transPtr + + status <- peek $ p'libusb_transfer'status transPtr + case status of + ts | ts == c'LIBUSB_TRANSFER_COMPLETED -> onCompletion transPtr + | ts == c'LIBUSB_TRANSFER_TIMED_OUT -> onTimeout transPtr + + | ts == c'LIBUSB_TRANSFER_ERROR -> throwIO ioException + | ts == c'LIBUSB_TRANSFER_NO_DEVICE -> throwIO NoDeviceException + | ts == c'LIBUSB_TRANSFER_OVERFLOW -> throwIO OverflowException + | ts == c'LIBUSB_TRANSFER_STALL -> throwIO PipeException + + | ts == c'LIBUSB_TRANSFER_CANCELLED -> + moduleError "transfer status can't be Cancelled!" + + | otherwise -> moduleError $ "Unknown transfer status: " ++ + show ts ++ "!" + +-------------------------------------------------------------------------------- +-- ** Setting transfers properties +-------------------------------------------------------------------------------- + +setTransferProperty :: (Storable a) + => (Ptr C'libusb_transfer -> Ptr a) + -> ThreadSafeTransfer + -> a + -> IO () +setTransferProperty prop threadSafeTransfer val = + withMVar threadSafeTransfer $ \transfer -> + withTransPtr transfer $ \transPtr -> + poke (prop transPtr) val + +-------------------------------------------------------------------------------- + +setTransferType :: ThreadSafeTransfer -> C'TransferType -> IO () +setTransferType = setTransferProperty p'libusb_transfer'type + +setTransferDeviceHandle :: ThreadSafeTransfer -> DeviceHandle -> IO () +setTransferDeviceHandle threadSafeTransfer devHndl = + withDevHndlPtr devHndl $ \devHndlPtr -> mask_ $ do + transfer <- takeMVar threadSafeTransfer + withTransPtr transfer $ \transPtr -> do + poke (p'libusb_transfer'dev_handle transPtr) devHndlPtr + putMVar threadSafeTransfer transfer{transDevHndl = devHndl} + +setTransferEndpointAddress :: ThreadSafeTransfer -> EndpointAddress -> IO () +setTransferEndpointAddress threadSafeTransfer endpointAddr = + setTransferProperty p'libusb_transfer'endpoint + threadSafeTransfer + (marshalEndpointAddress endpointAddr) + +setTransferTimeout :: ThreadSafeTransfer -> Timeout -> IO () +setTransferTimeout threadSafeTransfer timeout = + setTransferProperty p'libusb_transfer'timeout + threadSafeTransfer + (fromIntegral timeout) + +-------------------------------------------------------------------------------- +-- ** Getting transfers properties +-------------------------------------------------------------------------------- + +getTransferProperty :: (Storable a) + => (Ptr C'libusb_transfer -> Ptr a) + -> ThreadSafeTransfer + -> IO a +getTransferProperty prop threadSafeTransfer = + withMVar threadSafeTransfer $ \transfer -> + withTransPtr transfer $ \transPtr -> + peek $ prop transPtr + +-------------------------------------------------------------------------------- + +getTransferType :: ThreadSafeTransfer -> IO C'TransferType +getTransferType = getTransferProperty p'libusb_transfer'type + +getTransferDeviceHandle :: ThreadSafeTransfer -> IO DeviceHandle +getTransferDeviceHandle threadSafeTransfer = + withMVar threadSafeTransfer $ return . transDevHndl + +getTransferEndpointAddress :: ThreadSafeTransfer -> IO EndpointAddress +getTransferEndpointAddress = fmap (unmarshalEndpointAddress . fromIntegral) + . getTransferProperty p'libusb_transfer'endpoint + +getTransferTimeout :: ThreadSafeTransfer -> IO Timeout +getTransferTimeout = fmap fromIntegral + . getTransferProperty p'libusb_transfer'timeout + +-------------------------------------------------------------------------------- +-- ** Control transfers +-------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- +-- *** No data transfer +-------------------------------------------------------------------------------- + +-- | A control transfer which doesn't transfer data. +newtype ControlTransfer = ControlTransfer + {unControlTransfer :: ThreadSafeTransfer} + +-- | Create a new control transfer which doesn't transfer data. +newControlTransfer :: DeviceHandle -> ControlSetup -> Timeout -> IO ControlTransfer +newControlTransfer devHndl ctrlSetup timeout = mask_ $ do + bufferPtr <- mallocBytes size + when (bufferPtr == nullPtr) $ throwIO NoMemException + + poke bufferPtr $ marshallControlSetup ctrlSetup Out 0 + + ControlTransfer <$> newThreadSafeTransfer + (bufferPtr, size) (free bufferPtr) + c'LIBUSB_TRANSFER_TYPE_CONTROL + isos devHndl controlEndpoint timeout + where + size = controlSetupSize + + isos :: Storable.Vector C'libusb_iso_packet_descriptor + isos = VG.empty + +-- | Execute a control transfer which doesn't transfer data. +performControlTransfer :: ControlTransfer -> IO () +performControlTransfer ctrlTransfer = + performThreadSafeTransfer (unControlTransfer ctrlTransfer) + (\_transPtr -> return ()) + (\_transPtr -> throwIO TimeoutException) + +-------------------------------------------------------------------------------- +-- **** Setting control /read/ transfer properties +-------------------------------------------------------------------------------- + +-- | Update the device handle of a control transfer. +setControlTransferDeviceHandle :: ControlTransfer -> DeviceHandle -> IO () +setControlTransferDeviceHandle = setTransferDeviceHandle . unControlTransfer + +-- | Update the timeout of a control transfer. +setControlTransferTimeout :: ControlTransfer -> Timeout -> IO () +setControlTransferTimeout = setTransferTimeout . unControlTransfer + +-- | Update the setup parameters of a control transfer. +setControlSetup :: ControlTransfer -> ControlSetup -> IO () +setControlSetup ctrlTransfer ctrlSetup = + withMVarMasked (unControlTransfer ctrlTransfer) $ \transfer -> + withTransPtr transfer $ \transPtr -> do + bufferPtr <- peek (p'libusb_transfer'buffer transPtr) + poke (castPtr bufferPtr) $ marshallControlSetup ctrlSetup Out 0 + +-------------------------------------------------------------------------------- +-- **** Getting control /read/ transfer properties +-------------------------------------------------------------------------------- + +-- | Retrieve the device handle of a control transfer. +getControlTransferDeviceHandle :: ControlTransfer -> IO DeviceHandle +getControlTransferDeviceHandle = getTransferDeviceHandle . unControlTransfer + +-- | Retrieve the timeout of a control transfer. +getControlTransferTimeout :: ControlTransfer -> IO Timeout +getControlTransferTimeout = getTransferTimeout . unControlTransfer + + +-------------------------------------------------------------------------------- +-- *** Control /read/ transfers +-------------------------------------------------------------------------------- + +-- | A control transfer which reads data from a device. +newtype ControlReadTransfer = ControlReadTransfer + {unControlReadTransfer :: ThreadSafeTransfer} + +-- | Create a new control transfer which can read data from a device. +newControlReadTransfer + :: DeviceHandle -> ControlSetup -> Size -> Timeout -> IO ControlReadTransfer +newControlReadTransfer devHndl ctrlSetup readSize timeout = mask_ $ do + bufferPtr <- mallocBytes size + when (bufferPtr == nullPtr) $ throwIO NoMemException + + poke bufferPtr $ marshallControlSetup ctrlSetup In readSize + + ControlReadTransfer <$> newThreadSafeTransfer + (bufferPtr, size) (free bufferPtr) + c'LIBUSB_TRANSFER_TYPE_CONTROL + isos devHndl controlEndpoint timeout + where + size = controlSetupSize + readSize + + isos :: Storable.Vector C'libusb_iso_packet_descriptor + isos = VG.empty + +-- | Execute a control transfer to read data from the device. +performControlReadTransfer :: ControlReadTransfer -> IO (B.ByteString, Status) +performControlReadTransfer ctrlReadTransfer = + performThreadSafeTransfer (unControlReadTransfer ctrlReadTransfer) + (continue Completed) (continue TimedOut) + where + continue :: Status -> (Ptr C'libusb_transfer -> IO (B.ByteString, Status)) + continue status = \transPtr -> do + len <- fromIntegral <$> peek (p'libusb_transfer'actual_length transPtr) + bufferPtr <- castPtr <$> peek (p'libusb_transfer'buffer transPtr) + + bs <- BI.create len $ \ptr -> + BI.memcpy ptr (bufferPtr `plusPtr` controlSetupSize) (fromIntegral len) + + return (bs, status) + +-------------------------------------------------------------------------------- +-- **** Setting control /read/ transfer properties +-------------------------------------------------------------------------------- + +-- | Update the device handle of a control transfer that reads data from a device. +setControlReadTransferDeviceHandle :: ControlReadTransfer -> DeviceHandle -> IO () +setControlReadTransferDeviceHandle = setTransferDeviceHandle . unControlReadTransfer + +-- | Update the timeout of a control transfer that reads data from a device. +setControlReadTransferTimeout :: ControlReadTransfer -> Timeout -> IO () +setControlReadTransferTimeout = setTransferTimeout . unControlReadTransfer + +-- | Update the setup parameters of a control transfer that reads data from a device.. +setControlReadSetup :: ControlReadTransfer -> ControlSetup -> Size -> IO () +setControlReadSetup ctrlReadTransfer ctrlSetup readSize = + withMVarMasked (unControlReadTransfer ctrlReadTransfer) $ \transfer -> + withTransPtr transfer $ \transPtr -> do + oldBufferPtr <- peek (p'libusb_transfer'buffer transPtr) + oldReadSize <- peek (p'libusb_control_setup'wLength (castPtr oldBufferPtr)) + + bufferPtr <- + if fromIntegral oldReadSize == readSize + then return oldBufferPtr + else do + bufferPtr <- reallocBytes oldBufferPtr size + when (bufferPtr == nullPtr) $ throwIO NoMemException + + writeIORef (transBufferFinalizerIORef transfer) $ free bufferPtr + + poke (p'libusb_transfer'buffer transPtr) bufferPtr + poke (p'libusb_transfer'length transPtr) (fromIntegral size) + + return bufferPtr + + poke (castPtr bufferPtr) $ marshallControlSetup ctrlSetup In readSize + where + size = controlSetupSize + readSize + +-------------------------------------------------------------------------------- +-- **** Getting control /read/ transfer properties +-------------------------------------------------------------------------------- + +-- | Retrieve the device handle of a control transfer that reads data from a device. +getControlReadTransferDeviceHandle :: ControlReadTransfer -> IO DeviceHandle +getControlReadTransferDeviceHandle = getTransferDeviceHandle . unControlReadTransfer + +-- | Retrieve the timeout of a control transfer that reads data from a device. +getControlReadTransferTimeout :: ControlReadTransfer -> IO Timeout +getControlReadTransferTimeout = getTransferTimeout . unControlReadTransfer + + +-------------------------------------------------------------------------------- +-- *** Control /write/ transfers +-------------------------------------------------------------------------------- + +-- | A control transfer which writes data to a device. +newtype ControlWriteTransfer = ControlWriteTransfer + {unControlWriteTransfer :: ThreadSafeTransfer} + +-- | Create a new control transfer which can write data to a device. +newControlWriteTransfer + :: DeviceHandle + -> ControlSetup + -> B.ByteString + -> Timeout + -> IO ControlWriteTransfer +newControlWriteTransfer devHndl ctrlSetup input timeout = + BU.unsafeUseAsCStringLen input $ \(dataPtr, writeSize) -> mask_ $ do + let size = controlSetupSize + writeSize + + bufferPtr <- mallocBytes size + when (bufferPtr == nullPtr) $ throwIO NoMemException + + poke bufferPtr $ marshallControlSetup ctrlSetup Out writeSize + + copyArray (bufferPtr `plusPtr` controlSetupSize) dataPtr writeSize + + ControlWriteTransfer <$> newThreadSafeTransfer + (bufferPtr, size) (free bufferPtr) + c'LIBUSB_TRANSFER_TYPE_CONTROL + isos devHndl controlEndpoint timeout + where + isos :: Storable.Vector C'libusb_iso_packet_descriptor + isos = VG.empty + +-- | Execute a control transfer to write the data to the device. +performControlWriteTransfer :: ControlWriteTransfer -> IO (Size, Status) +performControlWriteTransfer ctrlWriteTransfer = + performThreadSafeTransfer (unControlWriteTransfer ctrlWriteTransfer) + (continue Completed) (continue TimedOut) + where + continue :: Status -> (Ptr C'libusb_transfer -> IO (Size, Status)) + continue status = \transPtr -> do + len <- fromIntegral <$> peek (p'libusb_transfer'actual_length transPtr) + return (len, status) + +-------------------------------------------------------------------------------- +-- **** Setting control /write/ transfer properties +-------------------------------------------------------------------------------- + +-- | Update the device handle of a control transfer that writes data to a device. +setControlWriteTransferDeviceHandle :: ControlWriteTransfer -> DeviceHandle -> IO () +setControlWriteTransferDeviceHandle = setTransferDeviceHandle . unControlWriteTransfer + +-- | Update the timeout of a control transfer that writes data to a device. +setControlWriteTransferTimeout :: ControlWriteTransfer -> Timeout -> IO () +setControlWriteTransferTimeout = setTransferTimeout . unControlWriteTransfer + +-- | Update the setup parameters of a control transfer that writes data to a device. +setControlWriteSetup :: ControlWriteTransfer -> ControlSetup -> B.ByteString -> IO () +setControlWriteSetup ctrlWriteTransfer ctrlSetup input = + withMVarMasked (unControlWriteTransfer ctrlWriteTransfer) $ \transfer -> + withTransPtr transfer $ \transPtr -> do + BU.unsafeUseAsCStringLen input $ \(dataPtr, writeSize) -> do + let size = controlSetupSize + writeSize + + oldBufferPtr <- peek (p'libusb_transfer'buffer transPtr) + oldWriteSize <- peek (p'libusb_control_setup'wLength (castPtr oldBufferPtr)) + + bufferPtr <- + if fromIntegral oldWriteSize == writeSize + then return oldBufferPtr + else do + bufferPtr <- reallocBytes oldBufferPtr size + when (bufferPtr == nullPtr) $ throwIO NoMemException + + writeIORef (transBufferFinalizerIORef transfer) $ free bufferPtr + + poke (p'libusb_transfer'buffer transPtr) bufferPtr + poke (p'libusb_transfer'length transPtr) (fromIntegral size) + + return bufferPtr + + poke (castPtr bufferPtr) $ marshallControlSetup ctrlSetup Out writeSize + + copyArray (bufferPtr `plusPtr` controlSetupSize) dataPtr writeSize + + +-------------------------------------------------------------------------------- +-- **** Getting control /write/ transfer properties +-------------------------------------------------------------------------------- + +-- | Retrieve the device handle of a control transfer that writes data to a device. +getControlWriteTransferDeviceHandle :: ControlWriteTransfer -> IO DeviceHandle +getControlWriteTransferDeviceHandle = getTransferDeviceHandle . unControlWriteTransfer + +-- | Retrieve the timeout of a control transfer that writes data to a device. +getControlWriteTransferTimeout :: ControlWriteTransfer -> IO Timeout +getControlWriteTransferTimeout = getTransferTimeout . unControlWriteTransfer + +-------------------------------------------------------------------------------- +-- ** Bulk / Interrupt transfers +-------------------------------------------------------------------------------- + +-- | Type of 'ReadTransfer' or 'WriteTransfer' which can either be +-- /bulk/ or /interrupt/. +-- +-- Note that isochronous transfers are handled differently using the +-- 'IsochronousReadTransfer' or 'IsochronousWriteTransfer' types. +data RepeatableTransferType = BulkTransfer + | InterruptTransfer + +marshallRepeatableTransferType :: RepeatableTransferType -> C'TransferType +marshallRepeatableTransferType BulkTransfer = c'LIBUSB_TRANSFER_TYPE_BULK +marshallRepeatableTransferType InterruptTransfer = c'LIBUSB_TRANSFER_TYPE_INTERRUPT + +unmarshalRepeatableTransferType :: C'TransferType -> RepeatableTransferType +unmarshalRepeatableTransferType transType + | transType == c'LIBUSB_TRANSFER_TYPE_BULK = BulkTransfer + | transType == c'LIBUSB_TRANSFER_TYPE_INTERRUPT = InterruptTransfer + | otherwise = + moduleError $ "unmarshalRepeatableTransferType: Invalid transfer type: " ++ + show transType + +-------------------------------------------------------------------------------- +-- *** Bulk / Interrupt /read/ transfers +-------------------------------------------------------------------------------- + +-- | A bulk or interrupt read transfer. +newtype ReadTransfer = ReadTransfer {unReadTransfer :: ThreadSafeTransfer} + +-- | Create a new bulk or interrupt transfer that can read data from a device. +newReadTransfer :: RepeatableTransferType + -> DeviceHandle + -> EndpointAddress + -> Size -- ^ Number of bytes to read. + -> Timeout + -> IO ReadTransfer +newReadTransfer transType devHndl endpointAddr size timeout = mask_ $ do + bufferPtr <- mallocBytes size + + when (bufferPtr == nullPtr && size /= 0) $ + throwIO NoMemException + + ReadTransfer <$> newThreadSafeTransfer + (bufferPtr, size) (free bufferPtr) + (marshallRepeatableTransferType transType) + isos devHndl (marshalEndpointAddress endpointAddr) timeout + where + isos :: Storable.Vector C'libusb_iso_packet_descriptor + isos = VG.empty + +-- | Execute a bulk or interrupt transfer to read data from a device. +performReadTransfer :: ReadTransfer -> IO (B.ByteString, Status) +performReadTransfer readTransfer = + performThreadSafeTransfer (unReadTransfer readTransfer) + (continue Completed) (continue TimedOut) + where + continue :: Status -> (Ptr C'libusb_transfer -> IO (B.ByteString, Status)) + continue status = \transPtr -> do + len <- fromIntegral <$> peek (p'libusb_transfer'actual_length transPtr) + bufferPtr <- castPtr <$> peek (p'libusb_transfer'buffer transPtr) + + bs <- BI.create len $ \ptr -> BI.memcpy ptr bufferPtr (fromIntegral len) + + return (bs, status) + +-------------------------------------------------------------------------------- +-- **** Setting bulk / interrupt /read/ transfer properties +-------------------------------------------------------------------------------- + +-- | Specify whether the transfer should perform bulk or interrupt reads. +setReadTransferType :: ReadTransfer -> RepeatableTransferType -> IO () +setReadTransferType readTransfer transType = + setTransferType (unReadTransfer readTransfer) + (marshallRepeatableTransferType transType) + +-- | Update the device handle of a bulk or interrupt read transfer. +setReadTransferDeviceHandle :: ReadTransfer -> DeviceHandle -> IO () +setReadTransferDeviceHandle = setTransferDeviceHandle . unReadTransfer + +-- | Update the endpoint address of a bulk or interrupt read transfer. +setReadTransferEndpointAddress :: ReadTransfer -> EndpointAddress -> IO () +setReadTransferEndpointAddress = setTransferEndpointAddress . unReadTransfer + +-- | Update the timeout of a bulk or interrupt read transfer. +setReadTransferTimeout :: ReadTransfer -> Timeout -> IO () +setReadTransferTimeout = setTransferTimeout . unReadTransfer + +-- | Update the number of bytes to read for a bulk or interrupt transfer. +setReadTransferSize :: ReadTransfer -> Size -> IO () +setReadTransferSize readTransfer size = + withMVarMasked (unReadTransfer readTransfer) $ \transfer -> + withTransPtr transfer $ \transPtr -> do + let ref = transBufferFinalizerIORef transfer + if size == 0 + then do + finalizeBuffer <- readIORef ref + finalizeBuffer + writeIORef ref (return ()) + else do + bufferPtr <- peek (p'libusb_transfer'buffer transPtr) + bufferPtr' <- reallocBytes bufferPtr size + when (bufferPtr' == nullPtr) $ throwIO NoMemException + writeIORef ref $ free bufferPtr' + poke (p'libusb_transfer'buffer transPtr) bufferPtr' + + poke (p'libusb_transfer'length transPtr) (fromIntegral size) + +-------------------------------------------------------------------------------- +-- **** Getting bulk / interrupt /read/ transfer properties +-------------------------------------------------------------------------------- + +-- | Check if this transfer does bulk or interrupt reads. +getReadTransferType :: ReadTransfer -> IO RepeatableTransferType +getReadTransferType = fmap unmarshalRepeatableTransferType + . getTransferType . unReadTransfer + +-- | Retrieve the device handle of a bulk or interrupt read transfer. +getReadTransferDeviceHandle :: ReadTransfer -> IO DeviceHandle +getReadTransferDeviceHandle = getTransferDeviceHandle . unReadTransfer + +-- | Retrieve the endpoint address of a bulk or interrupt read transfer. +getReadTransferEndpointAddress :: ReadTransfer -> IO EndpointAddress +getReadTransferEndpointAddress = getTransferEndpointAddress . unReadTransfer + +-- | Retreive the number of bytes to read for a bulk or interrupt transfer. +getReadTransferSize :: ReadTransfer -> IO Size +getReadTransferSize = fmap fromIntegral + . getTransferProperty p'libusb_transfer'length + . unReadTransfer + +-- | Retrieve the timeout of a bulk or interrupt read transfer. +getReadTransferTimeout :: ReadTransfer -> IO Timeout +getReadTransferTimeout = getTransferTimeout . unReadTransfer + +-------------------------------------------------------------------------------- +-- *** Bulk / Interrupt /write/ transfers +-------------------------------------------------------------------------------- + +-- | A bulk or interrupt write transfer. +newtype WriteTransfer = WriteTransfer {unWriteTransfer :: ThreadSafeTransfer} + +-- | Create a new bulk or interrupt transfer that can write data to a device. +newWriteTransfer :: RepeatableTransferType + -> DeviceHandle + -> EndpointAddress + -> B.ByteString -- ^ Bytes to write. + -> Timeout + -> IO WriteTransfer +newWriteTransfer transType devHndl endpointAddr input timeout = + WriteTransfer <$> newThreadSafeTransfer + (bufferPtr, size) finalizeBuffer + (marshallRepeatableTransferType transType) + isos devHndl (marshalEndpointAddress endpointAddr) timeout + where + (fp, offset, size) = BI.toForeignPtr input + bufferPtr = unsafeForeignPtrToPtr fp `plusPtr` offset + finalizeBuffer = touchForeignPtr fp + + isos :: Storable.Vector C'libusb_iso_packet_descriptor + isos = VG.empty + +-- | Execute a bulk or interrupt transfer to write data to a device. +performWriteTransfer :: WriteTransfer -> IO (Size, Status) +performWriteTransfer writeTransfer = + performThreadSafeTransfer (unWriteTransfer writeTransfer) + (continue Completed) (continue TimedOut) + where + continue :: Status -> (Ptr C'libusb_transfer -> IO (Size, Status)) + continue status = \transPtr -> do + len <- fromIntegral <$> peek (p'libusb_transfer'actual_length transPtr) + return (len, status) + +-------------------------------------------------------------------------------- +-- **** Setting bulk / interrupt /write/ transfer properties +-------------------------------------------------------------------------------- + +-- | Specify whether the transfer should perform bulk or interrupt writes. +setWriteTransferType :: WriteTransfer -> RepeatableTransferType -> IO () +setWriteTransferType writeTransfer transType = + setTransferType (unWriteTransfer writeTransfer) + (marshallRepeatableTransferType transType) + +-- | Update the device handle of a bulk or interrupt write transfer. +setWriteTransferDeviceHandle :: WriteTransfer -> DeviceHandle -> IO () +setWriteTransferDeviceHandle = setTransferDeviceHandle . unWriteTransfer + +-- | Update the endpoint address of a bulk or interrupt write transfer. +setWriteTransferEndpointAddress :: WriteTransfer -> EndpointAddress -> IO () +setWriteTransferEndpointAddress = setTransferEndpointAddress . unWriteTransfer + +-- | Update the timeout of a bulk or interrupt write transfer. +setWriteTransferTimeout :: WriteTransfer -> Timeout -> IO () +setWriteTransferTimeout = setTransferTimeout . unWriteTransfer + +-- | Update the bytes to write for a bulk or interrupt transfer. +setWriteTransferInput :: WriteTransfer -> B.ByteString -> IO () +setWriteTransferInput writeTransfer input = + withMVarMasked (unWriteTransfer writeTransfer) $ \transfer -> + withTransPtr transfer $ \transPtr -> do + writeIORef (transBufferFinalizerIORef transfer) finalizeBuffer + poke (p'libusb_transfer'buffer transPtr) bufferPtr + poke (p'libusb_transfer'length transPtr) (fromIntegral size) + where + (fp, offset, size) = BI.toForeignPtr input + bufferPtr = unsafeForeignPtrToPtr fp `plusPtr` offset + finalizeBuffer = touchForeignPtr fp + +-------------------------------------------------------------------------------- +-- **** Getting bulk / interrupt /write/ transfer properties +-------------------------------------------------------------------------------- + +-- | Check if this transfer does bulk or interrupt writes. +getWriteTransferType :: WriteTransfer -> IO RepeatableTransferType +getWriteTransferType = fmap unmarshalRepeatableTransferType + . getTransferType . unWriteTransfer + +-- | Retrieve the device handle of a bulk or interrupt write transfer. +getWriteTransferDeviceHandle :: WriteTransfer -> IO DeviceHandle +getWriteTransferDeviceHandle = getTransferDeviceHandle . unWriteTransfer + +-- | Retrieve the endpoint address of a bulk or interrupt write transfer. +getWriteTransferEndpointAddress :: WriteTransfer -> IO EndpointAddress +getWriteTransferEndpointAddress = getTransferEndpointAddress . unWriteTransfer + +-- | Retreive the bytes to write from a bulk or interrupt transfer. +getWriteTransferInput :: WriteTransfer -> IO B.ByteString +getWriteTransferInput writeTransfer = + withMVar (unWriteTransfer writeTransfer) $ \transfer -> + withTransPtr transfer $ \transPtr -> do + len <- fromIntegral <$> peek (p'libusb_transfer'length transPtr) + bufferPtr <- castPtr <$> peek (p'libusb_transfer'buffer transPtr) + BI.create len $ \ptr -> BI.memcpy ptr bufferPtr (fromIntegral len) + +-- | Retrieve the timeout of a bulk or interrupt write transfer. +getWriteTransferTimeout :: WriteTransfer -> IO Timeout +getWriteTransferTimeout = getTransferTimeout . unWriteTransfer + +-------------------------------------------------------------------------------- +-- ** Isochronous transfers +-------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- +-- *** Isochronous /read/ transfers +-------------------------------------------------------------------------------- + +-- | An isochronous read transfer. +newtype IsochronousReadTransfer = IsochronousReadTransfer + {unIsochronousReadTransfer :: ThreadSafeTransfer} + +-- | Create a new isochronous transfer that can read isochronous packets from a +-- device. +newIsochronousReadTransfer :: DeviceHandle + -> EndpointAddress + -> Unboxed.Vector Size -- ^ Sizes of isochronous packets to read. + -> Timeout + -> IO IsochronousReadTransfer +newIsochronousReadTransfer devHndl endpointAddr sizes timeout = mask_ $ do + bufferPtr <- mallocBytes size + + when (bufferPtr == nullPtr && size /= 0) $ + throwIO NoMemException + + IsochronousReadTransfer <$> newThreadSafeTransfer + (bufferPtr, size) (free bufferPtr) + c'LIBUSB_TRANSFER_TYPE_ISOCHRONOUS + isos devHndl (marshalEndpointAddress endpointAddr) timeout + where + size = VG.sum sizes + isos = VG.map initIsoPacketDesc $ VG.convert sizes + +-- | Execute a transfer to read isochronous packets from a device. +performIsochronousReadTransfer :: IsochronousReadTransfer -> IO (Vector B.ByteString) +performIsochronousReadTransfer isoReadTransfer = + performThreadSafeTransfer (unIsochronousReadTransfer isoReadTransfer) + onCompletion onTimeout + where + onCompletion, onTimeout :: Ptr C'libusb_transfer -> IO (Vector B.ByteString) + onCompletion transPtr = do + nrOfIsos <- fromIntegral <$> peek (p'libusb_transfer'num_iso_packets transPtr) + bufferPtr <- castPtr <$> peek (p'libusb_transfer'buffer transPtr) + + getPackets nrOfIsos bufferPtr transPtr + onTimeout _transPtr = throwIO TimeoutException + +-------------------------------------------------------------------------------- +-- **** Setting isochronous /read/ transfer properties +-------------------------------------------------------------------------------- + +-- | Update the device handle of an isochronous read transfer. +setIsochronousReadTransferDeviceHandle + :: IsochronousReadTransfer -> DeviceHandle -> IO () +setIsochronousReadTransferDeviceHandle + = setTransferDeviceHandle . unIsochronousReadTransfer + +-- | Update the endpoint address of an isochronous read transfer. +setIsochronousReadTransferEndpointAddress + :: IsochronousReadTransfer -> EndpointAddress -> IO () +setIsochronousReadTransferEndpointAddress + = setTransferEndpointAddress . unIsochronousReadTransfer + +-- | Update the size of packets to read for an isochronous transfer. +setIsochronousReadTransferSizes + :: IsochronousReadTransfer -> Unboxed.Vector Size -> IO () +setIsochronousReadTransferSizes isoReadTransfer sizes = + withMVarMasked (unIsochronousReadTransfer isoReadTransfer) $ \transfer -> + withTransPtr transfer $ \transPtr -> do + bufferPtr <- peek (p'libusb_transfer'buffer transPtr) + bufferPtr' <- reallocBytes bufferPtr size + + if bufferPtr' == nullPtr + then unless (size == 0) $ throwIO NoMemException + else writeIORef (transBufferFinalizerIORef transfer) $ free bufferPtr' + + poke (p'libusb_transfer'buffer transPtr) bufferPtr' + poke (p'libusb_transfer'length transPtr) (fromIntegral size) + + pokeVector (p'libusb_transfer'iso_packet_desc transPtr) isos + where + size = VG.sum sizes + isos = VG.map initIsoPacketDesc $ VG.convert sizes + +-------------------------------------------------------------------------------- +-- **** Getting isochronous /read/ transfer properties +-------------------------------------------------------------------------------- + +-- | Retrieve the device handle of an isochronous read transfer. +getIsochronousReadTransferDeviceHandle + :: IsochronousReadTransfer -> IO DeviceHandle +getIsochronousReadTransferDeviceHandle + = getTransferDeviceHandle . unIsochronousReadTransfer + +-- | Retrieve the endpoint address of an isochronous read transfer. +getIsochronousReadTransferEndpointAddress + :: IsochronousReadTransfer -> IO EndpointAddress +getIsochronousReadTransferEndpointAddress + = getTransferEndpointAddress . unIsochronousReadTransfer + +-- | Retrieve the packets sizes to read for an isochronous transfer. +getIsochronousReadTransferSizes + :: IsochronousReadTransfer -> IO (Unboxed.Vector Size) +getIsochronousReadTransferSizes isoReadTransfer = + withMVar (unIsochronousReadTransfer isoReadTransfer) $ \transfer -> + withTransPtr transfer $ \transPtr -> do + nrOfIsos <- fromIntegral <$> + peek (p'libusb_transfer'num_iso_packets transPtr) + (VG.convert . VG.map (fromIntegral . c'libusb_iso_packet_descriptor'length)) <$> + peekVector nrOfIsos (p'libusb_transfer'iso_packet_desc transPtr) + + +-------------------------------------------------------------------------------- +-- *** Isochronous /write/ transfers +-------------------------------------------------------------------------------- + +-- | An isochronous write transfer. +newtype IsochronousWriteTransfer = IsochronousWriteTransfer + {unIsochronousWriteTransfer :: ThreadSafeTransfer} + +-- | Create a new isochronous transfer that can write isochronous packets to a +-- device. +newIsochronousWriteTransfer :: DeviceHandle + -> EndpointAddress + -> Vector B.ByteString -- ^ Isochronous packets to write. + -> Timeout + -> IO IsochronousWriteTransfer +newIsochronousWriteTransfer devHndl endpointAddr isoPackets timeout = mask_ $ do + bufferPtr <- mallocBytes size + + when (bufferPtr == nullPtr && size /= 0) $ + throwIO NoMemException + + copyIsos (castPtr bufferPtr) isoPackets + + IsochronousWriteTransfer <$> newThreadSafeTransfer + (bufferPtr, size) (free bufferPtr) + c'LIBUSB_TRANSFER_TYPE_ISOCHRONOUS + isos devHndl (marshalEndpointAddress endpointAddr) timeout + where + size = VG.sum sizes + sizes = VG.map B.length isoPackets + isos = VG.convert $ VG.map initIsoPacketDesc sizes + +-- | Execute a transfer to write isochronous packets to a device. +performIsochronousWriteTransfer :: IsochronousWriteTransfer -> IO (Unboxed.Vector Size) +performIsochronousWriteTransfer isoWriteTransfer = + performThreadSafeTransfer (unIsochronousWriteTransfer isoWriteTransfer) + onCompletion onTimeout + where + onCompletion, onTimeout :: Ptr C'libusb_transfer -> IO (Unboxed.Vector Size) + onCompletion transPtr = do + nrOfIsos <- fromIntegral <$> peek (p'libusb_transfer'num_iso_packets transPtr) + getSizes nrOfIsos transPtr + onTimeout _transPtr = throwIO TimeoutException + +-------------------------------------------------------------------------------- +-- **** Setting isochronous /write/ transfer properties +-------------------------------------------------------------------------------- + +-- | Update the device handle of an isochronous write transfer. +setIsochronousWriteTransferDeviceHandle + :: IsochronousWriteTransfer -> DeviceHandle -> IO () +setIsochronousWriteTransferDeviceHandle + = setTransferDeviceHandle . unIsochronousWriteTransfer + +-- | Update the endpoint address of an isochronous write transfer. +setIsochronousWriteTransferEndpointAddress + :: IsochronousWriteTransfer -> EndpointAddress -> IO () +setIsochronousWriteTransferEndpointAddress + = setTransferEndpointAddress . unIsochronousWriteTransfer + +-- | Update the packets to write for an isochronous transfer. +setIsochronousWriteTransferPackets + :: IsochronousWriteTransfer -> Vector B.ByteString -> IO () +setIsochronousWriteTransferPackets isoWriteTransfer isoPackets = + withMVarMasked (unIsochronousWriteTransfer isoWriteTransfer) $ \transfer -> + withTransPtr transfer $ \transPtr -> do + + bufferPtr <- peek (p'libusb_transfer'buffer transPtr) + bufferPtr' <- reallocBytes bufferPtr size + + if bufferPtr' == nullPtr + then unless (size == 0) $ throwIO NoMemException + else writeIORef (transBufferFinalizerIORef transfer) $ free bufferPtr' + + poke (p'libusb_transfer'buffer transPtr) bufferPtr' + poke (p'libusb_transfer'length transPtr) (fromIntegral size) + + pokeVector (p'libusb_transfer'iso_packet_desc transPtr) isos + copyIsos (castPtr bufferPtr') isoPackets + where + size = VG.sum sizes + sizes = VG.map B.length isoPackets + isos = VG.convert $ VG.map initIsoPacketDesc sizes + +-------------------------------------------------------------------------------- +-- **** Getting isochronous /write/ transfer properties +-------------------------------------------------------------------------------- + +-- | Retrieve the device handle of an isochronous write transfer. +getIsochronousWriteTransferDeviceHandle + :: IsochronousWriteTransfer -> IO DeviceHandle +getIsochronousWriteTransferDeviceHandle + = getTransferDeviceHandle . unIsochronousWriteTransfer + +-- | Retrieve the endpoint address of an isochronous write transfer. +getIsochronousWriteTransferEndpointAddress + :: IsochronousWriteTransfer -> IO EndpointAddress +getIsochronousWriteTransferEndpointAddress + = getTransferEndpointAddress . unIsochronousWriteTransfer + +-- | Retrieve the packets to write for an isochronous transfer. +getIsochronousWriteTransferPackets + :: IsochronousWriteTransfer -> IO (Vector B.ByteString) +getIsochronousWriteTransferPackets isoWriteTransfer = + withMVar (unIsochronousWriteTransfer isoWriteTransfer) $ \transfer -> + withTransPtr transfer $ \transPtr -> do + bufferPtr <- castPtr <$> peek (p'libusb_transfer'buffer transPtr) + + nrOfIsos <- fromIntegral <$> + peek (p'libusb_transfer'num_iso_packets transPtr) + + mv <- VGM.unsafeNew nrOfIsos + let isoArrayPtr = p'libusb_transfer'iso_packet_desc transPtr + go !ix ptr + | ix < nrOfIsos = do + let isoPtr = advancePtr isoArrayPtr ix + l <- fromIntegral <$> peek (p'libusb_iso_packet_descriptor'length isoPtr) + bs <- BI.create l $ \p -> copyArray p ptr l + VGM.unsafeWrite mv ix bs + go (ix+1) (ptr `plusPtr` l) + | otherwise = VG.unsafeFreeze mv + go 0 bufferPtr +#endif + +-------------------------------------------------------------------------------- + +createAndTrimNoOffset :: Size -> (Ptr Word8 -> IO (Size, a)) -> IO (B.ByteString, a) +createAndTrimNoOffset size f = BI.createAndTrim' size $ \ptr -> do + (l, x) <- f ptr + return (offset, l, x) + where + offset = 0 + +-------------------------------------------------------------------------------- +-- * Exceptions +-------------------------------------------------------------------------------- + +-- | @handleUSBException action@ executes @action@. If @action@ returned an +-- error code other than 'c\'LIBUSB_SUCCESS', the error is converted to a +-- 'USBException' and thrown. +handleUSBException :: IO CInt -> IO () +handleUSBException action = do err <- action + when (err /= c'LIBUSB_SUCCESS) + (throwIO $ convertUSBException err) + +-- | @checkUSBException action@ executes @action@. If @action@ returned a +-- negative integer the integer is converted to a 'USBException' and thrown. If +-- not, the integer is returned. +checkUSBException :: (Integral a, Show a) => IO a -> IO Int +checkUSBException action = do r <- action + if r < 0 + then throwIO $ convertUSBException r + else return $ fromIntegral r + +-- | Convert a @C'libusb_error@ to a 'USBException'. If the @C'libusb_error@ is +-- unknown an 'error' is thrown. +convertUSBException :: (Num a, Eq a, Show a) => a -> USBException +convertUSBException err = fromMaybe unknownLibUsbError $ + lookup err libusb_error_to_USBException + where + unknownLibUsbError = + moduleError $ "Unknown libusb error code: " ++ show err ++ "!" + +-- | Association list mapping 'C'libusb_error's to 'USBException's. +libusb_error_to_USBException :: Num a => [(a, USBException)] +libusb_error_to_USBException = + [ (c'LIBUSB_ERROR_IO, ioException) + , (c'LIBUSB_ERROR_INVALID_PARAM, InvalidParamException) + , (c'LIBUSB_ERROR_ACCESS, AccessException) + , (c'LIBUSB_ERROR_NO_DEVICE, NoDeviceException) + , (c'LIBUSB_ERROR_NOT_FOUND, NotFoundException) + , (c'LIBUSB_ERROR_BUSY, BusyException) + , (c'LIBUSB_ERROR_TIMEOUT, TimeoutException) + , (c'LIBUSB_ERROR_OVERFLOW, OverflowException) + , (c'LIBUSB_ERROR_PIPE, PipeException) + , (c'LIBUSB_ERROR_INTERRUPTED, InterruptedException) + , (c'LIBUSB_ERROR_NO_MEM, NoMemException) + , (c'LIBUSB_ERROR_NOT_SUPPORTED, NotSupportedException) + , (c'LIBUSB_ERROR_OTHER, OtherException) + ] + +-- | Type of USB exceptions. +data USBException = + IOException String -- ^ Input/output exception. + | InvalidParamException -- ^ Invalid parameter. + | AccessException -- ^ Access denied (insufficient permissions). It may + -- help to run your program with elevated privileges or + -- change the permissions of your device using + -- something like @udev@. + | NoDeviceException -- ^ No such device (it may have been disconnected). + | NotFoundException -- ^ Entity not found. + | BusyException -- ^ Resource busy. + | TimeoutException -- ^ Operation timed out. + | OverflowException -- ^ If the device offered to much data. See + -- in the @libusb@ documentation. + -- + | PipeException -- ^ Pipe exception. + | InterruptedException -- ^ System call interrupted (perhaps due to signal). + | NoMemException -- ^ Insufficient memory. + | NotSupportedException -- ^ Operation not supported or unimplemented on this + -- platform. If possible, it's recommended the check + -- if a certain operation is supported by using the + -- 'hasCapability' API. + | OtherException -- ^ Other exception. + deriving (COMMON_INSTANCES) + +instance Exception USBException + +-- | A general 'IOException'. +ioException :: USBException +ioException = IOException "" + +-- | 'IOException' that is thrown when the number of bytes /read/ +-- doesn't equal the requested number. +incompleteReadException :: USBException +incompleteReadException = incompleteException "read" + +-- | 'IOException' that is thrown when the number of bytes /written/ +-- doesn't equal the requested number. +incompleteWriteException :: USBException +incompleteWriteException = incompleteException "written" + +incompleteException :: String -> USBException +incompleteException rw = IOException $ + "The number of bytes " ++ rw ++ " doesn't equal the requested number!" + +-------------------------------------------------------------------------------- + +moduleError :: String -> error +moduleError msg = error $ thisModule ++ ": " ++ msg + +thisModule :: String +thisModule = "System.USB.Base" diff --git a/src/System/USB/Descriptors.hs b/src/System/USB/Descriptors.hs new file mode 100644 --- /dev/null +++ b/src/System/USB/Descriptors.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 704 +{-# LANGUAGE Trustworthy #-} +#endif + +-------------------------------------------------------------------------------- +-- | +-- Module : System.USB.Descriptors +-- Copyright : (c) 2009–2017 Bas van Dijk +-- License : BSD3 (see the file LICENSE) +-- Maintainer : Bas van Dijk +-- +-- USB devices report their attributes using descriptors. A descriptor is a data +-- structure with a defined format. Using descriptors allows concise storage of +-- the attributes of individual configurations because each configuration may +-- reuse descriptors or portions of descriptors from other configurations that +-- have the same characteristics. In this manner, the descriptors resemble +-- individual data records in a relational database. +-- +-- Where appropriate, descriptors contain references to string descriptors +-- ('StrIx') that provide textual information describing a descriptor in +-- human-readable form. Note that the inclusion of string descriptors is +-- optional. +-- +-------------------------------------------------------------------------------- + +module System.USB.Descriptors + ( -- * Device descriptor + getDeviceDesc + , DeviceDesc(..) + + , ReleaseNumber + + -- | For a database of USB vendors and products see the @usb-id-database@ + -- package at: + , VendorId, ProductId + + -- * Configuration descriptor + , getConfigDesc + , ConfigDesc(..) + + -- *** Configuration attributes + , ConfigAttribs + , DeviceStatus(..) + + -- * Interface descriptor + , Interface + , InterfaceDesc(..) + + -- * Endpoint descriptor + , EndpointDesc(..) + + -- *** Endpoint address + , EndpointAddress(..) + , TransferDirection(..) + + -- *** Endpoint attributes + , EndpointAttribs + , TransferType(..) + -- **** Isochronous transfer attributes + , Synchronization(..) + , Usage(..) + + -- *** Endpoint max packet size + , MaxPacketSize(..) + , TransactionOpportunities(..) + , maxIsoPacketSize + + -- * String descriptors + , getLanguages + , LangId, PrimaryLangId, SubLangId + , StrIx + , getStrDesc + , getStrDescFirstLang + ) where + +import System.USB.Base diff --git a/src/System/USB/DeviceHandling.hs b/src/System/USB/DeviceHandling.hs new file mode 100644 --- /dev/null +++ b/src/System/USB/DeviceHandling.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 704 +{-# LANGUAGE Trustworthy #-} +#endif + +-------------------------------------------------------------------------------- +-- | +-- Module : System.USB.Devices +-- Copyright : (c) 2009–2017 Bas van Dijk +-- License : BSD3 (see the file LICENSE) +-- Maintainer : Bas van Dijk +-- +-- The module provides functionality for opening, closing and configuring USB +-- devices. +-- +-------------------------------------------------------------------------------- + +module System.USB.DeviceHandling + ( -- * Opening & closing devices + DeviceHandle + , openDevice + , closeDevice + , withDeviceHandle + , getDevice + + -- * Getting & setting the configuration + , ConfigValue + , getConfig + , setConfig + + -- * Claiming & releasing interfaces + , InterfaceNumber + , claimInterface + , releaseInterface + , withClaimedInterface + + -- * Setting interface alternate settings + , InterfaceAltSetting + , setInterfaceAltSetting + + -- * Clearing & Resetting devices + , clearHalt + , resetDevice + + -- * USB kernel drivers + , setAutoDetachKernelDriver + , kernelDriverActive + , detachKernelDriver + , attachKernelDriver + , withDetachedKernelDriver + ) where + +import System.USB.Base diff --git a/src/System/USB/Enumeration.hs b/src/System/USB/Enumeration.hs new file mode 100644 --- /dev/null +++ b/src/System/USB/Enumeration.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 704 +{-# LANGUAGE Trustworthy #-} +#endif + +-------------------------------------------------------------------------------- +-- | +-- Module : System.USB.Devices +-- Copyright : (c) 2009–2017 Bas van Dijk +-- License : BSD3 (see the file LICENSE) +-- Maintainer : Bas van Dijk +-- +-- This module provides functionality for enumerating the USB devices currently +-- attached to the system. +-- +-------------------------------------------------------------------------------- + +module System.USB.Enumeration + ( Device + + -- * Device enumeration + , getDevices + + -- * Device hotplug event notification + + -- | Instead of enumerating all devices attached to the system using + -- 'getDevices' you can also be notified on device attachment and removal + -- using the hotplug event notification API. + + -- ** Hotplug events + , HotplugEvent + , deviceArrived + , deviceLeft + + , matchDeviceArrived + , matchDeviceLeft + + -- ** Hotplug flags + , HotplugFlag, enumerate + + -- ** Asynchronous event notification + , HotplugCallback + , CallbackRegistrationStatus(..) + , HotplugCallbackHandle + , registerHotplugCallback + , deregisterHotplugCallback + + -- * Device location + , busNumber + , portNumber + , portNumbers + , deviceAddress + + -- * Device speed + , deviceSpeed + , Speed(..) + ) where + +import System.USB.Base diff --git a/src/System/USB/Exceptions.hs b/src/System/USB/Exceptions.hs new file mode 100644 --- /dev/null +++ b/src/System/USB/Exceptions.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 704 +{-# LANGUAGE Trustworthy #-} +#endif + +-------------------------------------------------------------------------------- +-- | +-- Module : System.USB.Exceptions +-- Copyright : (c) 2009–2017 Bas van Dijk +-- License : BSD3 (see the file LICENSE) +-- Maintainer : Bas van Dijk +-- +-------------------------------------------------------------------------------- + +module System.USB.Exceptions + ( USBException(..) + , ioException + , incompleteReadException + , incompleteWriteException + ) where + +import System.USB.Base diff --git a/src/System/USB/IO.hs b/src/System/USB/IO.hs new file mode 100644 --- /dev/null +++ b/src/System/USB/IO.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE CPP, NoImplicitPrelude #-} + +#if __GLASGOW_HASKELL__ >= 704 +{-# LANGUAGE Trustworthy #-} +#endif + +-------------------------------------------------------------------------------- +-- | +-- Module : System.USB.IO +-- Copyright : (c) 2009–2017 Bas van Dijk +-- License : BSD3 (see the file LICENSE) +-- Maintainer : Bas van Dijk +-- +-- This module provides functions for performing /control/, /bulk/ and +-- /interrupt/ transfers. +-- +-- When your system supports the GHC 'EventManager' this module additionally +-- exports functions for performing /isochronous/ transfers. These are currently +-- not available on Windows. +-- +-- /WARNING:/ You need to enable the threaded runtime (@-threaded@) when using +-- the isochronous functions. They throw a runtime error otherwise! +-- +-------------------------------------------------------------------------------- + +module System.USB.IO + ( + -- * One-off transfers + ReadAction, ReadExactAction + , WriteAction, WriteExactAction + , Size + , Timeout, noTimeout + , Status(..) + + -- ** Control transfers + , ControlSetup(..) + , RequestType(..) + , Recipient(..) + , Request + , Value + , Index + + , control + , readControl, readControlExact + , writeControl, writeControlExact + + -- ** Bulk transfers + , readBulk + , writeBulk + + -- ** Interrupt transfers + , readInterrupt + , writeInterrupt + +#ifdef HAS_EVENT_MANAGER + -- ** Isochronous transfers + -- | /WARNING:/ You need to enable the threaded runtime (@-threaded@) when using + -- the isochronous functions. They throw a runtime error otherwise! + , readIsochronous + , writeIsochronous +#endif + ) where + +#ifdef __HADDOCK_VERSION__ +#ifdef HAS_EVENT_MANAGER +#if MIN_VERSION_base(4,4,0) +import GHC.Event +#else +import System.Event +#endif + ( EventManager ) +#endif +#endif + +import System.USB.Base diff --git a/src/System/USB/IO/StandardDeviceRequests.hs b/src/System/USB/IO/StandardDeviceRequests.hs new file mode 100644 --- /dev/null +++ b/src/System/USB/IO/StandardDeviceRequests.hs @@ -0,0 +1,310 @@ +{-# LANGUAGE CPP, NoImplicitPrelude, DeriveDataTypeable #-} + +#if __GLASGOW_HASKELL__ >= 704 +{-# LANGUAGE Trustworthy #-} +#endif + +{-# OPTIONS_HADDOCK hide #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : System.USB.IO.StandardDeviceRequests +-- Copyright : (c) 2009–2017 Bas van Dijk +-- License : BSD3 (see the file LICENSE) +-- Maintainer : Bas van Dijk +-- +-- /This module is for testing purposes only!/ +-- +-- This module provides functions for performing standard device requests. +-- The functions are primarily used for testing USB devices. +-- +-- To avoid name clashes with functions from @System.USB@ it is advised to use +-- an explicit import list or a qualified import. +-- +-------------------------------------------------------------------------------- + +module System.USB.IO.StandardDeviceRequests + ( setHalt + , setConfig, getConfig + , clearRemoteWakeup + , setRemoteWakeup + , setStandardTestMode, TestMode(..) + , getInterfaceAltSetting + , getDeviceStatus + , getEndpointStatus + , setDeviceAddress + , synchFrame, FrameNumber + ) where + + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +-- from base: +import Data.Bits ( testBit, shiftL ) +import Data.Bool ( Bool ) +import Data.Data ( Data ) +import Data.Eq ( Eq, (==) ) +import Data.Function ( ($), (.) ) +import Data.Functor ( fmap ) +import Data.Maybe ( Maybe(Nothing, Just), maybe ) +import Data.Typeable ( Typeable ) +import Data.Word ( Word8, Word16 ) +import Prelude ( (+), (*), fromIntegral, Enum ) +import System.IO ( IO ) +import Text.Read ( Read ) +import Text.Show ( Show ) + +#if __GLASGOW_HASKELL__ < 700 +import Prelude ( fromInteger ) +#endif + +-- from bytestring: +import qualified Data.ByteString as B ( ByteString, head, unpack ) + +-- from bindings-libusb: +import Bindings.Libusb ( c'LIBUSB_REQUEST_SET_FEATURE + , c'LIBUSB_REQUEST_SET_CONFIGURATION + , c'LIBUSB_REQUEST_GET_CONFIGURATION + , c'LIBUSB_REQUEST_CLEAR_FEATURE + , c'LIBUSB_REQUEST_GET_INTERFACE + , c'LIBUSB_REQUEST_GET_STATUS + , c'LIBUSB_REQUEST_SET_ADDRESS + , c'LIBUSB_REQUEST_SYNCH_FRAME + ) + +-- from usb: +import System.USB.DeviceHandling ( DeviceHandle + , ConfigValue + , InterfaceNumber + , InterfaceAltSetting + ) +#ifdef __HADDOCK_VERSION__ +import qualified System.USB.DeviceHandling as USB ( setConfig, getConfig ) +#endif + +import System.USB.Descriptors ( EndpointAddress + , DeviceStatus(..) + ) +import System.USB.IO ( Timeout + , ControlSetup(..) + , RequestType(Standard) + , Recipient( ToDevice + , ToInterface + , ToEndpoint + ) + , Value + , control, readControlExact + ) + +import System.USB.Base ( marshalEndpointAddress ) + +import Utils ( genFromEnum ) + + +-------------------------------------------------------------------------------- +-- Standard Device Requests +------------------------------------------------------------------------------- + +-- See: USB 2.0 Spec. section 9.4 + +-- Standard Feature Selectors: +-- See: USB 2.0 Spec. table 9-6 +haltFeature, remoteWakeupFeature, testModeFeature :: Value +haltFeature = 0 +remoteWakeupFeature = 1 +testModeFeature = 2 + +-- | See: USB 2.0 Spec. section 9.4.9 +setHalt :: DeviceHandle -> EndpointAddress -> (Timeout -> IO ()) +setHalt devHndl endpointAddr = control devHndl + ControlSetup + { controlSetupRequestType = Standard + , controlSetupRecipient = ToEndpoint + , controlSetupRequest = c'LIBUSB_REQUEST_SET_FEATURE + , controlSetupValue = haltFeature + , controlSetupIndex = marshalEndpointAddress endpointAddr + } + +-- | See: USB 2.0 Spec. section 9.4.7 +-- +-- /This function is for testing purposes only!/ +-- +-- You should normally use @System.USB.DeviceHandling.'USB.setConfig'@ because +-- that function notifies the underlying operating system about the changed +-- configuration. +setConfig :: DeviceHandle -> Maybe ConfigValue -> (Timeout -> IO ()) +setConfig devHndl mbConfigValue = control devHndl + ControlSetup + { controlSetupRequestType = Standard + , controlSetupRecipient = ToDevice + , controlSetupRequest = c'LIBUSB_REQUEST_SET_CONFIGURATION + , controlSetupValue = marshal mbConfigValue + , controlSetupIndex = 0 + } + where + marshal :: Maybe ConfigValue -> Value + marshal = maybe 0 fromIntegral + +-- | See: USB 2.0 Spec. section 9.4.2 +-- +-- /This function is for testing purposes only!/ +-- +-- You should normally use @System.USB.DeviceHandling.'USB.getConfig'@ because +-- that functon may exploit operating system caches (no I/O involved). +getConfig :: DeviceHandle -> (Timeout -> IO (Maybe ConfigValue)) +getConfig devHndl = fmap (unmarshal . B.head) + . readControlExact devHndl ctrlSetup 1 + where + ctrlSetup = ControlSetup + { controlSetupRequestType = Standard + , controlSetupRecipient = ToDevice + , controlSetupRequest = c'LIBUSB_REQUEST_GET_CONFIGURATION + , controlSetupValue = 0 + , controlSetupIndex = 0 + } + + unmarshal :: Word8 -> Maybe ConfigValue + unmarshal 0 = Nothing + unmarshal n = Just $ fromIntegral n + +-- | See: USB 2.0 Spec. section 9.4.1 +clearRemoteWakeup :: DeviceHandle -> (Timeout -> IO ()) +clearRemoteWakeup devHndl = control devHndl + ControlSetup + { controlSetupRequestType = Standard + , controlSetupRecipient = ToDevice + , controlSetupRequest = c'LIBUSB_REQUEST_CLEAR_FEATURE + , controlSetupValue = remoteWakeupFeature + , controlSetupIndex = 0 + } + +-- | See: USB 2.0 Spec. section 9.4.9 +setRemoteWakeup :: DeviceHandle -> (Timeout -> IO ()) +setRemoteWakeup devHndl = control devHndl + ControlSetup + { controlSetupRequestType = Standard + , controlSetupRecipient = ToDevice + , controlSetupRequest = c'LIBUSB_REQUEST_SET_FEATURE + , controlSetupValue = remoteWakeupFeature + , controlSetupIndex = 0 + } + +-- | See: USB 2.0 Spec. section 9.4.9 +-- TODO: What about vendor-specific test modes? +setStandardTestMode :: DeviceHandle -> TestMode -> (Timeout -> IO ()) +setStandardTestMode devHndl testMode = control devHndl + ControlSetup + { controlSetupRequestType = Standard + , controlSetupRecipient = ToDevice + , controlSetupRequest = c'LIBUSB_REQUEST_SET_FEATURE + , controlSetupValue = testModeFeature + , controlSetupIndex = (genFromEnum testMode + 1) `shiftL` 8 + } + +-- | See: USB 2.0 Spec. table 9-7 +data TestMode = Test_J + | Test_K + | Test_SE0_NAK + | Test_Packet + | Test_Force_Enable + deriving (Eq, Show, Read, Enum, Data, Typeable) + +-- | See: USB 2.0 Spec. section 9.4.4 +getInterfaceAltSetting :: DeviceHandle -> InterfaceNumber -> (Timeout -> IO InterfaceAltSetting) +getInterfaceAltSetting devHndl ifNum = + fmap B.head . readControlExact devHndl ctrlSetup 1 + where + ctrlSetup = ControlSetup + { controlSetupRequestType = Standard + , controlSetupRecipient = ToInterface + , controlSetupRequest = c'LIBUSB_REQUEST_GET_INTERFACE + , controlSetupValue = 0 + , controlSetupIndex = fromIntegral ifNum + } + +-- | See: USB 2.0 Spec. section 9.4.5 +getDeviceStatus :: DeviceHandle -> (Timeout -> IO DeviceStatus) +getDeviceStatus devHndl = + fmap (unmarshal . B.head) . readControlExact devHndl ctrlSetup 2 + where + ctrlSetup = ControlSetup + { controlSetupRequestType = Standard + , controlSetupRecipient = ToDevice + , controlSetupRequest = c'LIBUSB_REQUEST_GET_STATUS + , controlSetupValue = 0 + , controlSetupIndex = 0 + } + + unmarshal :: Word8 -> DeviceStatus + unmarshal a = DeviceStatus { remoteWakeup = testBit a 1 + , selfPowered = testBit a 0 + } + +-- | See: USB 2.0 Spec. section 9.4.5 +getEndpointStatus :: DeviceHandle -> EndpointAddress -> (Timeout -> IO Bool) +getEndpointStatus devHndl endpointAddr = + fmap ((1 ==) . B.head) . readControlExact devHndl ctrlSetup 2 + where + ctrlSetup = ControlSetup + { controlSetupRequestType = Standard + , controlSetupRecipient = ToEndpoint + , controlSetupRequest = c'LIBUSB_REQUEST_GET_STATUS + , controlSetupValue = 0 + , controlSetupIndex = marshalEndpointAddress endpointAddr + } + +-- | See: USB 2.0 Spec. section 9.4.6 +setDeviceAddress :: DeviceHandle -> Word16 -> (Timeout -> IO ()) +setDeviceAddress devHndl deviceAddr = control devHndl + ControlSetup + { controlSetupRequestType = Standard + , controlSetupRecipient = ToDevice + , controlSetupRequest = c'LIBUSB_REQUEST_SET_ADDRESS + , controlSetupValue = deviceAddr + , controlSetupIndex = 0 + } + +-- TODO: setDescriptor See: USB 2.0 Spec. section 9.4.8 + +-- TODO Sync Frame klopt niet helemaal, je kunt met deze request ook het frame number setten! + +{-| +This request is used to set and then report an endpoint's synchronization frame. + +When an endpoint supports isochronous transfers, the endpoint may also require +per-frame transfers to vary in size according to a specific pattern. The host +and the endpoint must agree on which frame the repeating pattern begins. The +number of the frame in which the pattern began is returned to the host. + +If a high-speed device supports the Synch Frame request, it must internally +synchronize itself to the zeroth microframe and have a time notion of classic +frame. Only the frame number is used to synchronize and reported by the device +endpoint (i.e., no microframe number). The endpoint must synchronize to the +zeroth microframe. + +This value is only used for isochronous data transfers using implicit pattern +synchronization. If the specified endpoint does not support this request, then +the device will respond with a Request Error. + +See: USB 2.0 Spec. section 9.4.11 +-} +synchFrame :: DeviceHandle -> EndpointAddress -> (Timeout -> IO FrameNumber) +synchFrame devHndl endpointAddr = + fmap unmarshal . readControlExact devHndl ctrlSetup 2 + where + ctrlSetup = ControlSetup + { controlSetupRequestType = Standard + , controlSetupRecipient = ToEndpoint + , controlSetupRequest = c'LIBUSB_REQUEST_SYNCH_FRAME + , controlSetupValue = 0 + , controlSetupIndex = marshalEndpointAddress endpointAddr + } + + unmarshal :: B.ByteString -> FrameNumber + unmarshal bs = let [h, l] = B.unpack bs + in fromIntegral h * 256 + fromIntegral l + +-- | Endpoint's synchronization frame. +type FrameNumber = Word16 diff --git a/src/System/USB/IO/Transfers.hs b/src/System/USB/IO/Transfers.hs new file mode 100644 --- /dev/null +++ b/src/System/USB/IO/Transfers.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE CPP, NoImplicitPrelude #-} + +#if __GLASGOW_HASKELL__ >= 704 +{-# LANGUAGE Trustworthy #-} +#endif + +-------------------------------------------------------------------------------- +-- | +-- Module : System.USB.IO.Transfers +-- Copyright : (c) 2009–2017 Bas van Dijk +-- License : BSD3 (see the file LICENSE) +-- Maintainer : Bas van Dijk +-- Stability : Experimental +-- +-- /WARNING:/ This module is experimental and untested. The API will likely +-- change in future releases. +-- +-- /WARNING:/ This module is only available on systems which support the GHC +-- 'EventManager'. +-- +-- /WARNING:/ You need to enable the threaded runtime (@-threaded@) when using +-- this module. The functions throw a runtime error otherwise! +-- +-- This modules provides alternative I\/O operations than the ones in +-- "System.USB.IO". The difference is that this module separates the +-- construction from the execution of a USB transfer. This has the +-- advantage that a transfer can be constructed once and executed +-- multiple times thereby saving repeated allocation costs. +-- +-------------------------------------------------------------------------------- + +module System.USB.IO.Transfers + ( + -- * Control transfers + + -- ** No data transfer + ControlTransfer + , newControlTransfer + , performControlTransfer + + -- *** Setting + , setControlTransferDeviceHandle + , setControlTransferTimeout + , setControlSetup + + -- *** Getting + , getControlTransferDeviceHandle + , getControlTransferTimeout + + -- ** Reading + , ControlReadTransfer + + , newControlReadTransfer + + , performControlReadTransfer + + -- *** Setting + , setControlReadTransferDeviceHandle + , setControlReadTransferTimeout + , setControlReadSetup + + -- *** Getting + , getControlReadTransferDeviceHandle + , getControlReadTransferTimeout + + -- ** Writing + , ControlWriteTransfer + + , newControlWriteTransfer + + , performControlWriteTransfer + + -- *** Setting + , setControlWriteTransferDeviceHandle + , setControlWriteTransferTimeout + , setControlWriteSetup + + -- *** Getting + , getControlWriteTransferDeviceHandle + , getControlWriteTransferTimeout + + -- * Bulk / Interrupt transfers + , RepeatableTransferType(..) + + -- ** Reading + , ReadTransfer + + , newReadTransfer + + , performReadTransfer + + -- *** Setting + , setReadTransferType + , setReadTransferDeviceHandle + , setReadTransferEndpointAddress + , setReadTransferTimeout + , setReadTransferSize + + -- *** Getting + , getReadTransferType + , getReadTransferDeviceHandle + , getReadTransferEndpointAddress + , getReadTransferTimeout + , getReadTransferSize + + -- ** Writing + , WriteTransfer + + , newWriteTransfer + + , performWriteTransfer + + -- *** Setting + , setWriteTransferType + , setWriteTransferDeviceHandle + , setWriteTransferEndpointAddress + , setWriteTransferTimeout + , setWriteTransferInput + + -- *** Getting + , getWriteTransferType + , getWriteTransferDeviceHandle + , getWriteTransferEndpointAddress + , getWriteTransferTimeout + , getWriteTransferInput + + -- * Isochronous transfers + + -- ** Reading + , IsochronousReadTransfer + + , newIsochronousReadTransfer + + , performIsochronousReadTransfer + + -- *** Setting + , setIsochronousReadTransferDeviceHandle + , setIsochronousReadTransferEndpointAddress + , setIsochronousReadTransferSizes + + -- *** Getting + , getIsochronousReadTransferDeviceHandle + , getIsochronousReadTransferEndpointAddress + , getIsochronousReadTransferSizes + + -- ** Writing + , IsochronousWriteTransfer + + , newIsochronousWriteTransfer + + , performIsochronousWriteTransfer + + -- *** Setting + , setIsochronousWriteTransferDeviceHandle + , setIsochronousWriteTransferEndpointAddress + , setIsochronousWriteTransferPackets + + -- *** Getting + , getIsochronousWriteTransferDeviceHandle + , getIsochronousWriteTransferEndpointAddress + , getIsochronousWriteTransferPackets + ) where + +#ifdef __HADDOCK_VERSION__ +#if MIN_VERSION_base(4,4,0) +import GHC.Event +#else +import System.Event +#endif + ( EventManager ) +#endif + +import System.USB.Base diff --git a/src/System/USB/Initialization.hs b/src/System/USB/Initialization.hs new file mode 100644 --- /dev/null +++ b/src/System/USB/Initialization.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE CPP #-} + +#if __GLASGOW_HASKELL__ >= 704 +{-# LANGUAGE Trustworthy #-} +#endif + +-------------------------------------------------------------------------------- +-- | +-- Module : System.USB.Init +-- Copyright : (c) 2009–2017 Bas van Dijk +-- License : BSD3 (see the file LICENSE) +-- Maintainer : Bas van Dijk +-- +-- This module provides functionality for initializing the @usb@ library. +-- +-------------------------------------------------------------------------------- + +module System.USB.Initialization + ( Ctx + , newCtx +#ifdef HAS_EVENT_MANAGER + , newCtx' +#endif + + -- * Logging + , setDebug + , Verbosity(..) + ) where + +import System.USB.Base diff --git a/src/System/USB/Misc.hs b/src/System/USB/Misc.hs new file mode 100644 --- /dev/null +++ b/src/System/USB/Misc.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE CPP #-} + +#if __GLASGOW_HASKELL__ >= 704 +{-# LANGUAGE Trustworthy #-} +#endif + +-------------------------------------------------------------------------------- +-- | +-- Module : System.USB.Misc +-- Copyright : (c) 2009–2017 Bas van Dijk +-- License : BSD3 (see the file LICENSE) +-- Maintainer : Bas van Dijk +-- +-- This module provides miscellaneous functionality. +-- +-------------------------------------------------------------------------------- + +module System.USB.Misc + ( + -- * Capabilties of @libusb@ + Capability(..) + , hasCapability + + -- * Version of @libusb@ + , LibusbVersion(..) + , libusbVersion + , toVersion + ) where + +import System.USB.Base diff --git a/src/SystemEventManager.hs b/src/SystemEventManager.hs new file mode 100644 --- /dev/null +++ b/src/SystemEventManager.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE CPP, NoImplicitPrelude #-} + +#if MIN_VERSION_base(4,4,0) +module SystemEventManager ( getSystemEventManager ) where +import GHC.Event ( getSystemEventManager ) +#else + +{-# LANGUAGE UnicodeSyntax, ForeignFunctionInterface #-} + +module SystemEventManager ( getSystemEventManager ) where + +-- from base: +import Data.Function ( ($) ) +import Data.IORef ( IORef, newIORef, readIORef ) +import Data.Maybe ( Maybe(Nothing) ) +import Foreign.Ptr ( Ptr ) +import GHC.Conc.Sync ( sharedCAF ) +import System.Event ( EventManager ) +import System.IO ( IO ) +import System.IO.Unsafe ( unsafePerformIO ) + +getSystemEventManager ∷ IO (Maybe EventManager) +getSystemEventManager = readIORef eventManager + +eventManager ∷ IORef (Maybe EventManager) +eventManager = unsafePerformIO $ do + em ← newIORef Nothing + sharedCAF em getOrSetSystemEventThreadEventManagerStore +{-# NOINLINE eventManager #-} + +foreign import ccall unsafe "getOrSetSystemEventThreadEventManagerStore" + getOrSetSystemEventThreadEventManagerStore ∷ Ptr α → IO (Ptr α) +#endif diff --git a/src/Utils.hs b/src/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Utils.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE CPP + , NoImplicitPrelude + , BangPatterns + , ScopedTypeVariables + #-} + +module Utils where + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +-- from base: +import Prelude ( ($) + , Num, (+), (*), (-) + , Enum, toEnum, fromEnum + , Integral, fromIntegral, undefined + ) + +#if __GLASGOW_HASKELL__ < 700 +import Prelude ( fromInteger, fail ) +#endif + +import Control.Monad ( Monad, return, (>>=), (>>) ) +import Foreign.Ptr ( Ptr ) +import Foreign.ForeignPtr ( withForeignPtr ) +import Foreign.Storable ( Storable, peek, sizeOf ) +import Foreign.Marshal.Alloc ( alloca ) +import Foreign.Marshal.Utils ( copyBytes ) +import Data.Bool ( Bool, otherwise, (&&) ) +import Data.Ord ( Ord, (<=), (>=) ) +import Data.Bits ( Bits, shiftL, shiftR, (.&.) ) +import Data.Function ( (.) ) +import Data.Int ( Int ) +import Data.Maybe ( Maybe(Nothing, Just) ) +import System.IO ( IO ) +import GHC.ForeignPtr ( mallocPlainForeignPtrBytes ) + +-- from vector: +import Data.Vector ( Vector ) +import qualified Data.Vector as V ( null, unsafeHead, unsafeTail ) +import qualified Data.Vector.Storable as VS ( Vector, empty, null + , unsafeFromForeignPtr0 + , unsafeToForeignPtr0 + ) +import qualified Data.Vector.Generic as VG ( Vector, mapM, convert ) + + +-------------------------------------------------------------------------------- +-- Utils +-------------------------------------------------------------------------------- + +-- | @bits s e b@ extract bit @s@ to @e@ (including) from @b@. +bits :: (Bits a, Num a) => Int -> Int -> a -> a +bits s e b = ((1 `shiftL` (e - s + 1)) - 1) .&. (b `shiftR` s) + +-- | @between n b e@ tests if @n@ is between the given bounds @b@ and @e@ +-- (including). +between :: Ord a => a -> a -> a -> Bool +between n b e = n >= b && n <= e + +-- | A generalized 'toEnum' that works on any 'Integral' type. +genToEnum :: (Integral i, Enum e) => i -> e +genToEnum = toEnum . fromIntegral + +-- | A generalized 'fromEnum' that returns any 'Integral' type. +genFromEnum :: (Integral i, Enum e) => e -> i +genFromEnum = fromIntegral . fromEnum + +-- | @mapPeekArray f n a@ applies the monadic function @f@ to each of the @n@ +-- elements of the array @a@ and returns the results in a list. +mapPeekArray :: (Storable a, VG.Vector v a, VG.Vector v b) + => (a -> IO b) -> Int -> Ptr a -> IO (v b) +mapPeekArray f n a = peekVector n a >>= VG.mapM f . VG.convert + +peekVector :: forall a. (Storable a) => Int -> Ptr a -> IO (VS.Vector a) +peekVector size ptr + | size <= 0 = return VS.empty + | otherwise = do + let n = (size * sizeOf (undefined :: a)) + fp <- mallocPlainForeignPtrBytes n + withForeignPtr fp $ \p -> copyBytes p ptr n + return $ VS.unsafeFromForeignPtr0 fp size + +-- | Write the elements of a storable vector to the given array. +pokeVector :: forall a. Storable a => Ptr a -> VS.Vector a -> IO () +pokeVector ptr v | VS.null v = return () + | otherwise = withForeignPtr fp $ \p -> + copyBytes ptr p (size * sizeOf (undefined :: a)) + where + (fp, size) = VS.unsafeToForeignPtr0 v + +allocaPeek :: Storable a => (Ptr a -> IO ()) -> IO a +allocaPeek f = alloca $ \ptr -> f ptr >> peek ptr + +-- | Monadic if...then...else... +ifM :: Monad m => m Bool -> m a -> m a -> m a +ifM cM tM eM = cM >>= \c -> if c then tM else eM + +uncons :: Vector a -> Maybe (a, Vector a) +uncons v | V.null v = Nothing + | otherwise = Just (V.unsafeHead v, V.unsafeTail v) diff --git a/usb.cabal b/usb.cabal --- a/usb.cabal +++ b/usb.cabal @@ -1,5 +1,5 @@ name: usb -version: 1.3.0.5 +version: 1.3.0.6 cabal-version: >=1.6 build-type: Simple license: BSD3 @@ -55,9 +55,10 @@ GHC == 7.8.1, GHC == 7.8.2, GHC == 7.8.3, GHC == 7.8.4 GHC == 7.10.1, GHC == 7.10.2, GHC == 7.10.3 GHC == 8.0.1, GHC == 8.0.2 - GHC == 8.3 + GHC == 8.2.1, GHC == 8.2.2 + GHC == 8.4.1 -extra-source-files: README.markdown, Changelog, default.nix, shell.nix +extra-source-files: README.markdown, Changelog source-repository head Type: git @@ -66,12 +67,14 @@ Library GHC-Options: -Wall - build-depends: base >= 4 && < 4.11 - , bindings-libusb >= 1.4.5 && < 1.5 - , bytestring >= 0.9 && < 0.11 - , text >= 0.5 && < 1.3 - , vector >= 0.5 && < 0.13 + build-depends: base >= 4 && < 5 + , bindings-libusb >= 1.4.5 + , bytestring >= 0.9 + , text >= 0.5 + , vector >= 0.5 + hs-source-dirs: src + exposed-modules: System.USB System.USB.Initialization System.USB.Misc @@ -87,8 +90,8 @@ cpp-options: -DHAS_EVENT_MANAGER exposed-modules: System.USB.IO.Transfers other-modules: Poll, Event, SystemEventManager - build-depends: containers >= 0.1 && < 0.6 + build-depends: containers >= 0.1 if impl(ghc >= 7.2.1) cpp-options: -DGENERICS - build-depends: ghc-prim >= 0.2 && < 0.6 + build-depends: ghc-prim >= 0.2