diff --git a/Changelog b/Changelog new file mode 100644 --- /dev/null +++ b/Changelog @@ -0,0 +1,367 @@ +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. + The fix was to increment the reference count of the USB device that + was passed to the HotplugCallback. + + Thanks to Ryan Mulligan and Ian Kane for reporting and investigating this bug. + + +1.3.0.4 (2016-07-02) + + * Support GHC-8.0.1. + * Support vector-0.11. + * Add Travis-CI integration. + + +1.3.0.3 (2015-05-06) + + * Fix incorrect direction in controlRead. + + +1.3.0.2 (2015-05-02) + + * Support GHC-7.10.2. + + +1.3.0.1 (Fri Apr 17 19:39:51 UTC 2015) + + * Support GHC-7.10. + + +1.3.0.0 (Sun Dec 14 23:11:35 UTC 2014) + + * Add hotplug support. + + * Add the System.USB.IO.Transfers module which 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. + + * Added the deviceSpeed, portNumber, portNumbers and parent functions to + System.USB.Enumeration. + + * Added the setAutoDetachKernelDriver to System.USB.DeviceHandling. + + * Added the System.USB.Misc module which exports + the hasCapability & libusbVersion functions. + + * Extended the Verbosity type with the PrintDebug constructor. + + +1.2.0.1 (Fri May 23 21:50:20 UTC 2014) + + * Drop UnicodeSyntax and the dependency on base-unicode-symbols. + + * Fix build on GHC-7.8.2. + + +1.2 (Mon Nov 26 22:55:48 UTC 2012) + + * Make retrieving the DeviceDesc and ConfigDescs IO operations. + + * Use Vectors instead of lists in the public API. + + * Export pokeVector from System.USB.Internal. + + * Fix build & warnings on Windows. + + * Performance improvements. + + * Documentation improvements. + + +1.1.0.4 (Wed Nov 21 23:29:54 UTC 2012) + + * Use Foreign.Concurrent.newForeignPtr on Windows + This will hopefully resolve #1 + This solution was also suggested by Maurício C. Antunes: + https://bitbucket.org/mauricio/bindings-dsl/issue/11/fix-the-calling-convention-for-funptrs-to + + * Update documentation. + + +1.1.0.3 (Sat Sep 8 00:48:55 UTC 2012) + + * Derive Generic instances for all data types. + + * Support base-4.6 and bytestring-0.10. + + * Fix build on Windows. + + * Use the new labeled URLs in Haddock. + + * Updated copyright dates. + + +1.1.0.2 (Sat May 5 23:47:44 UTC 2012) + + * Lazily compute the list of digits from decodeBCD. + + * Support containers-0.5. + + +1.1.0.1 (Thu Apr 12 21:21:14 UTC 2012) + + * Prevent a potential space-leak. + + +1.1 (Sat Jan 7 20:54:10 UTC 2012) + + * Support base-4.5 + + * Mark the safe modules as Trustworthy and the unsafe ones as Unsafe. + + * Replaced getEvtMgr with getWait + + +1.0 (Mon Sep 12 19:50:37 UTC 2011) + + * Support for isochronous reads and writes. + + * All I/O functions now use the libusb asynchronous interface when + support for the GHC event manager is available. + This should be more efficient and allows cancelling of an in flight + transfer by throwing an exception to the thread performing the transfer. + + * Added writeControlExact :: DeviceHandle -> ControlAction WriteExactAction. + + * All I/O functions which previously returned the boolean TimedOut + now return a: data Status = Completed | TimedOut. + + * Added the timeout constant: noTimeout :: Timeout. + + * Added function: maxIsoPacketSize :: EndpointDesc -> Size + Which calculates the maximum packet size which a specific endpoint + is capable of sending or receiving in the duration of 1 microframe. + This function is mainly useful for setting up isochronous transfers. + + * Added some specific IOExceptions: + ioException :: USBException + incompleteReadException :: USBException + incompleteWriteException :: USBException + + * Renamed System.USB.IO.Synchronous to just System.USB.IO. + + * Renamed System.USB.Unsafe to System.USB.Internal and exported more + functions from it which are primarily needed in the usb-iteratee + package. + + * Fixed some bugs. + + +0.8 (Wed Mar 9 12:21:51 UTC 2011) + + * getStrDesc and getStrDescFirstLang now return a Text instead of a + String I believe this is a more efficient and cleaner interface. + + +0.7 (Mon Jan 17 22:04:29 UTC 2011) + + * Change type of setConfig to allow setting a device in unconfigured state + -setConfig :: DeviceHandle -> ConfigValue -> IO () + +setConfig :: DeviceHandle -> Maybe ConfigValue -> IO () + + * Changed type of getConfig to match setConfig + -getConfig :: DeviceHandle -> IO ConfigValue + +getConfig :: DeviceHandle -> IO (Maybe ConfigValue) + + * Added setConfig and getConfig functions to System.USB.IO.StandardDeviceRequests. + These functions are for testing purposes only! + + +0.6.0.8 (Thu Jan 13 12:29:15 UTC 2011) + + * Fix bug in getDevices: + c'libusb_free_device_list returns a 64bit number on 64bit platforms + getDevices assumed c'libusb_free_device_list returned a CInt. + This is correct on 32bit platforms but on 64bit platforms it returns an Int64. + To fix it, I generalized checkUSBException to work over any Integral type. + + +0.6.0.7 (Tue Jan 4 12:30:43 UTC 2011) + + * Fixed bug in getDevices: + c'libusb_free_device_list returned undocumented error code + + * Show unknown libusb error code in unknownLibUsbError + + +0.6.0.6 (Sun Dec 26 12:00:30 UTC 2010) + + * Import missing (>>) in Utils (only when ghc < 7) + Reported by Joris Putcuyps. + + +0.6.0.5 (Thu Dec 16 16:20:12 UTC 2010) + + * Support text-0.11. + + * Resolved some warning when compiling with ghc-7 + + +0.6.0.4 (Sat Oct 23 00:15:14 UTC 2010) + + * Support text-0.10. + + +0.6.0.3 (Thu Oct 21 21:37:50 UTC 2010) + + * Tested with GHC-7 and modified to work with base-4.3. + + +0.6.0.2 (Wed Oct 6 22:06:43 UTC 2010) + + * Support text-0.9. + + +0.6.0.1 (Mon Sep 13 05:48:41 UTC 2010) + + * Fixed bug in Utf16LE encoding in getStrDesc. + + +0.6 (Sat Sep 11 14:19:36 UTC 2010) + + * Renamed BCD4 to ReleaseNumber. + + * Made StrIxs in descriptors optional. + + * Refactored handling of string descriptors (internal change). + + * Added strictness flags to all arguments of data constructors. + + +0.5.0.1 (Wed Sep 1 20:12:03 UTC 2010) + + * Support text-0.8 + + * Prevent a potential space leak in the decoding of BCD values + (Binary Coded Decimals) + + +0.5 (Mon Jul 26 05:48:59 UTC 2010) + + * Fixed bug in all writing related functions: writeControl, writeBulk + and writeInterrupt. I erroneously ignored the offset in the given + ByteString. + + * Fixed bug in getDevices Don't free the array when + c'libusb_get_device_list returns c'LIBUSB_ERROR_NO_MEM. + + * Fixed bug in 'setStandardTestMode' Wrong conversion from TestMode to + Word16. + + * Specify the length of the requested string in getStrDesc in characters + instead of bytes. + + * Moved the standard device requests to their own module + System.USB.IO.StandardDeviceRequests + + * Added System.USB.Unsafe This module is needed by the usb-enumerator + package. + + * Added convenience function 'readControlExact' which is similar to + 'readControl' but checks if the specified number of bytes to read were + actually read. Throws an 'IOException' if this is not the case. + + * Defined more instances for various types. Most types have now + instances for: Show, Read, Eq, Data and Typeable + + * Added type TimedOut = Bool + + * Some refactoring and documentation + + +0.4 (Wed Jun 16 09:12:22 UTC 2010) + + * Some reordering and naming of arguments: + < type ReadAction = Timeout → Size → IO (B.ByteString, Bool) + > type ReadAction = Size → Timeout → IO (B.ByteString, Bool) + + < type WriteAction = Timeout → B.ByteString → IO (Size, Bool) + > type WriteAction = B.ByteString → Timeout → IO (Size, Bool) + + * Return the iterator when the enumerator reads 0 bytes + + * Restricted the enumerators to work on Word8 instead of a polymorphic + elements This is to prevent readFromPtr to read outside allocated memory + + * Use the package MonadCatchIO-transformers-foreign in + System.USB.IO.Synchronous.Enumerator + + +0.3.1 (Sun May 2 20:23:24 UTC 2010) + + * Made the descriptor types non-abstract + + * Updated dependencies + iteratee >= 0.3.5 && < 0.4 + transformers >= 0.2 && < 0.3 + MonadCatchIO-transformers >= 0.2 && < 0.3 + + * Always include the Enumerator and remove its flag + + +0.3.0.1 (Wed Dec 23 13:41:49 UTC 2009) + + * Tested with base-4.2 + + * Tested with text-0.7 + + +0.3 (Tue Dec 8 21:06:22 UTC 2009) + + * Moved the enumeration of usb devices in its own module: + System.USB.Enumeration + + * Moved the device descriptor inside the device type so that you can + retrieve it without doing IO, e.g: deviceDesc :: Device -> DeviceDesc + + * Moved the configuration descriptors inside the device descriptor so + you can retrieve them without doing IO, e.g: deviceConfigs :: DeviceDesc + -> [ConfigDesc] + + * Implemented standard device requests that are missing from libusb. + + * Made the timeout of I/O operations explicit. Now all I/O operations + return an additional Bool that indicates if the operation has timed + out. If an operation timed out does not mean there is no result, it just + means that the result may be incomplete. + + * Added experimental (and still untested) support for iteratees for + doing predictable, high-performance, safe, and elegant input processing + using the iteratee package. See module: + System.USB.IO.Synchronous.Enumerator + + * Fixed some asynchronous exception related bugs (put a needed bracket, + block and unblock here and there). + + * Finally some functions, constructors and types got renamed, + documentation got updated and extended and some refactoring has taken + place. + + +0.2.0.1 (Sat Oct 10 18:09:07 UTC 2009) + + * Tested with text == 0.5.* + + +0.2 (Wed Oct 7 12:19:37 UTC 2009) + + * Depend on bindings-libusb == 1.3.* + * Moved System.USB.DeviceHandlingAndEnumeration to System.USB.Devices + + +0.1.0.1 (Thu Oct 1 19:14:30 UTC 2009) + + * Depend on bindings-libusb == 1.2. + + +0.1 (Wed Sep 30 21:11:15 UTC 2009) + + * Initial release 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–2011 Bas van Dijk +Copyright (c) 2009–2018 Bas van Dijk All rights reserved. diff --git a/NEWS b/NEWS deleted file mode 100644 --- a/NEWS +++ /dev/null @@ -1,256 +0,0 @@ -0.8 - -(Released on: Wed Mar 9 12:21:51 UTC 2011) - -* getStrDesc and getStrDescFirstLang now return a Text instead of a String - I believe this is a more efficient and cleaner interface. - - -0.7 - -(Released on: Mon Jan 17 22:04:29 UTC 2011) - -* Change type of setConfig to allow setting a device in unconfigured state - -setConfig :: DeviceHandle -> ConfigValue -> IO () - +setConfig :: DeviceHandle -> Maybe ConfigValue -> IO () - -* Changed type of getConfig to match setConfig - -getConfig :: DeviceHandle -> IO ConfigValue - +getConfig :: DeviceHandle -> IO (Maybe ConfigValue) - -* Added setConfig and getConfig functions to System.USB.IO.StandardDeviceRequests. - These functions are for testing purposes only! - - -0.6.0.8 - -(Released on: Thu Jan 13 12:29:15 UTC 2011) - -* Fix bug in getDevices: - c'libusb_free_device_list returns a 64bit number on 64bit platforms - getDevices assumed c'libusb_free_device_list returned a CInt. - This is correct on 32bit platforms but on 64bit platforms it returns an Int64. - To fix it, I generalized checkUSBException to work over any Integral type. - - -0.6.0.7 - -(Released on: Tue Jan 4 12:30:43 UTC 2011) - -* Fixed bug in getDevices: - c'libusb_free_device_list returned undocumented error code - -* Show unknown libusb error code in unknownLibUsbError - - -0.6.0.6 - -(Released on: Sun Dec 26 12:00:30 UTC 2010) - -* Import missing (>>) in Utils (only when ghc < 7) - Reported by Joris Putcuyps. - - -0.6.0.5 - -(Released on: Thu Dec 16 16:20:12 UTC 2010) - -* Support text-0.11. - -* Resolved some warning when compiling with ghc-7 - - -0.6.0.4 - -(Released on: Sat Oct 23 00:15:14 UTC 2010) - -* Support text-0.10. - - -0.6.0.3 - -(Released on: Thu Oct 21 21:37:50 UTC 2010) - -* Tested with GHC-7 and modified to work with base-4.3. - - -0.6.0.2 - -(Released on: Wed Oct 6 22:06:43 UTC 2010) - -* Support text-0.9. - - -0.6.0.1 - -(Released on: Mon Sep 13 05:48:41 UTC 2010) - -* Fixed bug in Utf16LE encoding in getStrDesc. - - -0.6 - -(Released on: Sat Sep 11 14:19:36 UTC 2010) - -* Renamed BCD4 to ReleaseNumber. - -* Made StrIxs in descriptors optional. - -* Refactored handling of string descriptors (internal change). - -* Added strictness flags to all arguments of data constructors. - - -0.5.0.1 - -(Released on: Wed Sep 1 20:12:03 UTC 2010) - -* Support text-0.8 - -* Prevent a potential space leak in the decoding of BCD values - (Binary Coded Decimals) - - -0.5 - -(Released on: Mon Jul 26 05:48:59 UTC 2010) - -* Fixed bug in all writing related functions: - writeControl, writeBulk and writeInterrupt. - I erroneously ignored the offset in the given ByteString. - -* Fixed bug in getDevices - Don't free the array when c'libusb_get_device_list returns - c'LIBUSB_ERROR_NO_MEM. - -* Fixed bug in 'setStandardTestMode' - Wrong conversion from TestMode to Word16. - -* Specify the length of the requested string in getStrDesc in - characters instead of bytes. - -* Moved the standard device requests to their own module - System.USB.IO.StandardDeviceRequests - -* Added System.USB.Unsafe - This module is needed by the usb-enumerator package. - -* Added convenience function 'readControlExact' which is similar to - 'readControl' but checks if the specified number of bytes to read - were actually read. Throws an 'IOException' if this is not the case. - -* Defined more instances for various types. - Most types have now instances for: - Show, Read, Eq, Data and Typeable - -* Added type TimedOut = Bool - -* Some refactoring and documentation - - -0.4 - -(Released on: Wed Jun 16 09:12:22 UTC 2010) - -* Some reordering and naming of arguments: - < type ReadAction = Timeout → Size → IO (B.ByteString, Bool) - > type ReadAction = Size → Timeout → IO (B.ByteString, Bool) - - < type WriteAction = Timeout → B.ByteString → IO (Size, Bool) - > type WriteAction = B.ByteString → Timeout → IO (Size, Bool) - -* Return the iterator when the enumerator reads 0 bytes - -* Restricted the enumerators to work on Word8 instead of a polymorphic - elements This is to prevent readFromPtr to read outside allocated - memory - -* Use the package MonadCatchIO-transformers-foreign in - System.USB.IO.Synchronous.Enumerator - - -0.3.1 - -(Released on: Sun May 2 20:23:24 UTC 2010) - -* Made the descriptor types non-abstract - -* Updated dependencies - iteratee >= 0.3.5 && < 0.4 - transformers >= 0.2 && < 0.3 - MonadCatchIO-transformers >= 0.2 && < 0.3 - -* Always include the Enumerator and remove its flag - - -0.3.0.1 - -(Released on: Wed Dec 23 13:41:49 UTC 2009) - -* Tested with base-4.2 - -* Tested with text-0.7 - - -0.3 - -(Released on:Tue Dec 8 21:06:22 UTC 2009) - -* Moved the enumeration of usb devices in its own module: - System.USB.Enumeration - -* Moved the device descriptor inside the device type so that you can - retrieve it without doing IO, e.g: deviceDesc :: Device -> - DeviceDesc - -* Moved the configuration descriptors inside the device descriptor so - you can retrieve them without doing IO, e.g: deviceConfigs :: - DeviceDesc -> [ConfigDesc] - -* Implemented standard device requests that are missing from libusb. - -* Made the timeout of I/O operations explicit. Now all I/O operations - return an additional Bool that indicates if the operation has timed - out. If an operation timed out does not mean there is no result, it - just means that the result may be incomplete. - -* Added experimental (and still untested) support for iteratees for - doing predictable, high-performance, safe, and elegant input - processing using the iteratee package. See module: - System.USB.IO.Synchronous.Enumerator - -* Fixed some asynchronous exception related bugs (put a needed - bracket, block and unblock here and there). - -* Finally some functions, constructors and types got renamed, - documentation got updated and extended and some refactoring has - taken place. - - -0.2.0.1 - -(Released on: Sat Oct 10 18:09:07 UTC 2009) - -* Tested with text == 0.5.* - - -0.2 - -(Released on: Wed Oct 7 12:19:37 UTC 2009) - -* Depend on bindings-libusb == 1.3.* -* Moved System.USB.DeviceHandlingAndEnumeration to System.USB.Devices - - -0.1.0.1 - -(Released on: Thu Oct 1 19:14:30 UTC 2009) - -* Depend on bindings-libusb == 1.2. - - -0.1 - -(Released on: Wed Sep 30 21:11:15 UTC 2009) - -* Initial release diff --git a/Poll.hsc b/Poll.hsc deleted file mode 100644 --- a/Poll.hsc +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE UnicodeSyntax, NoImplicitPrelude #-} - -#include - -module Poll ( toEvent ) where - --- from base: -import Data.Bits ( (.&.) ) -import Data.Bool ( otherwise ) -import Data.Monoid ( mempty, mappend ) -import Foreign.C.Types ( CShort ) - --- from base-unicode-symbols: -import Data.Eq.Unicode ( (≢) ) - --- 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/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -1,3 +1,6 @@ +[![Hackage](https://img.shields.io/hackage/v/usb.svg)](https://hackage.haskell.org/package/usb) +[![Build Status](https://travis-ci.org/basvandijk/usb.svg)](https://travis-ci.org/basvandijk/usb) + This library enables you to communicate with USB devices from userspace. It is implemented as a high-level wrapper around [bindings-libusb] which is a low-level binding to the C library: diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,43 +1,2 @@ -#! /usr/bin/env runhaskell - -{-# LANGUAGE NoImplicitPrelude, UnicodeSyntax #-} - -module Main (main) where - - -------------------------------------------------------------------------------- --- Imports -------------------------------------------------------------------------------- - --- from base -import Control.Monad ( (>>), return ) -import System.IO ( IO ) - --- from cabal -import Distribution.Simple ( defaultMainWithHooks - , simpleUserHooks - , UserHooks(haddockHook) - , Args - ) - -import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) ) -import Distribution.Simple.Program ( userSpecifyArgs ) -import Distribution.Simple.Setup ( HaddockFlags ) -import Distribution.PackageDescription ( PackageDescription(..) ) - - -------------------------------------------------------------------------------- --- Cabal setup program which sets the CPP define '__HADDOCK __' when haddock is run. -------------------------------------------------------------------------------- - -main ∷ IO () -main = defaultMainWithHooks hooks - where - hooks = simpleUserHooks { haddockHook = haddockHook' } - --- Define __HADDOCK__ for CPP when running haddock. -haddockHook' ∷ PackageDescription → LocalBuildInfo → UserHooks → HaddockFlags → IO () -haddockHook' pkg lbi = - haddockHook simpleUserHooks pkg (lbi { withPrograms = p }) - where - p = userSpecifyArgs "haddock" ["--optghc=-D__HADDOCK__"] (withPrograms lbi) +import Distribution.Simple +main = defaultMain diff --git a/System/USB.hs b/System/USB.hs deleted file mode 100644 --- a/System/USB.hs +++ /dev/null @@ -1,26 +0,0 @@ --------------------------------------------------------------------------------- --- | --- Module : System.USB --- Copyright : (c) 2009–2011 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.Enumeration - , module System.USB.DeviceHandling - , module System.USB.Descriptors - , module System.USB.IO - , module System.USB.Exceptions - ) where - -import System.USB.Initialization -import System.USB.Enumeration -import System.USB.DeviceHandling -import System.USB.Descriptors -import System.USB.IO -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,2226 +0,0 @@ -{-# LANGUAGE CPP, UnicodeSyntax, NoImplicitPrelude, DeriveDataTypeable #-} - -#ifdef HAS_EVENT_MANAGER -{-# LANGUAGE ForeignFunctionInterface #-} -#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 ) -import Foreign.Marshal.Alloc ( alloca ) -import Foreign.Marshal.Array ( peekArray, allocaArray ) -import Foreign.Storable ( Storable, peek, peekElemOff ) -import Foreign.Ptr ( Ptr, castPtr, plusPtr, nullPtr ) -import Foreign.ForeignPtr ( ForeignPtr, newForeignPtr, withForeignPtr) -import Control.Applicative ( liftA2 ) -import Control.Exception ( Exception, throwIO, bracket, bracket_, onException, assert ) -import Control.Monad ( Monad, (>>=), (=<<), return, when, forM ) -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.List ( lookup, map, (++) ) -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 ) -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 ( Functor, fmap, (<$>) ) -#else -import Control.Monad ( Functor, fmap ) -import Control.Applicative ( (<$>) ) -#endif - -#if __GLASGOW_HASKELL__ < 700 -import Prelude ( fromInteger, negate ) -import Control.Monad ( (>>), fail ) -#endif - --- from base-unicode-symbols: -import Data.Function.Unicode ( (∘) ) -import Data.Bool.Unicode ( (∧) ) -import Data.Eq.Unicode ( (≢), (≡) ) - --- 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 bindings-libusb: -import Bindings.Libusb - --- from usb (this package): -import Utils ( bits, between, genToEnum, genFromEnum, mapPeekArray, ifM, decodeBCD ) - --------------------------------------------------------------------------------- - -#ifdef HAS_EVENT_MANAGER --- from base: -import Prelude ( undefined ) -import Foreign.C.Types ( CShort, CChar ) -import Foreign.Marshal.Alloc ( allocaBytes, free ) -import Foreign.Marshal.Array ( peekArray0, copyArray ) -import Foreign.Storable ( sizeOf, poke ) -import Foreign.Ptr ( nullFunPtr, freeHaskellFunPtr ) -import Control.Monad ( mapM_, foldM_ ) -import Data.IORef ( newIORef, atomicModifyIORef, readIORef ) -import Data.Function ( id ) -import Data.List ( foldl' ) -import System.Posix.Types ( Fd(Fd) ) -import Control.Exception ( uninterruptibleMask_ ) -import Control.Concurrent.MVar ( MVar, newEmptyMVar, takeMVar, putMVar ) -import System.IO ( hPutStrLn, stderr ) - -import qualified Foreign.Concurrent as FC ( newForeignPtr ) - -#if MIN_VERSION_base(4,4,0) -import GHC.Event -#else -import System.Event -#endif - ( EventManager - , FdKey - , registerFd, unregisterFd - , registerTimeout, unregisterTimeout - ) - --- from containers: -import Data.IntMap ( IntMap, fromList, insert, updateLookupWithKey, elems ) - --- from bytestring: -import qualified Data.ByteString.Internal as BI ( create ) - --- from usb (this package): -import Timeval ( withTimeval ) -import qualified Poll ( toEvent ) -import SystemEventManager ( getSystemEventManager ) -#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 α → IO α) → IO β) → IO β -mask io = do - b ← blocked - if b - then io id - else block $ io unblock - -mask_ ∷ IO α → IO α -mask_ = block -#endif - -#define COMMON_INSTANCES Show, Read, Eq, Data, Typeable - --------------------------------------------------------------------------------- --- * 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 'setDebug' and 'getDevices'. --} -data Ctx = Ctx - { -#ifdef HAS_EVENT_MANAGER - getEventManager ∷ !(Maybe (EventManager, Maybe (IO ()))), - -- ^ Retrieve the optional event manager from the context - -- and the optional 'IO' action for handling events. -#endif - getCtxFrgnPtr ∷ !(ForeignPtr C'libusb_context) - } deriving Typeable - -instance Eq Ctx where (==) = (==) `on` getCtxFrgnPtr - -withCtxPtr ∷ Ctx → (Ptr C'libusb_context → IO α) → IO α -withCtxPtr = withForeignPtr ∘ getCtxFrgnPtr - -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 <$> newForeignPtr p'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 --------------------------------------------------------------------------------- - -{-| 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 - - let handleEvents ∷ IO () - handleEvents = do - err ← withTimeval noTimeout $ - c'libusb_handle_events_timeout ctxPtr - when (err ≢ c'LIBUSB_SUCCESS) $ - if err ≡ c'LIBUSB_ERROR_INTERRUPTED - then handleEvents - else handleError $ convertUSBException err - - register ∷ CInt → CShort → IO FdKey - register fd evt = registerFd evtMgr (\_ _ → handleEvents) - (Fd fd) (Poll.toEvent evt) - - -- Register initial libusb file descriptors with the event manager: - pollFdPtrLst ← c'libusb_get_pollfds ctxPtr - pollFdPtrs ← peekArray0 nullPtr pollFdPtrLst - fdKeys ← forM pollFdPtrs $ \pollFdPtr → do - C'libusb_pollfd fd evt ← peek pollFdPtr - fdKey ← register fd evt - return (fromIntegral fd, fdKey) - fdKeyMapRef ← newIORef (fromList fdKeys ∷ IntMap FdKey) - free pollFdPtrLst - - -- Be notified when libusb file descriptors are added or removed: - aFP ← mk'libusb_pollfd_added_cb $ \fd evt _ → mask_ $ do - fdKey ← register fd evt - atomicModifyIORef fdKeyMapRef $ \fdKeyMap → - (insert (fromIntegral fd) fdKey fdKeyMap, ()) - - rFP ← mk'libusb_pollfd_removed_cb $ \fd _ → mask_ $ do - fdKey ← atomicModifyIORef fdKeyMapRef $ \fdKeyMap → - let (Just fdKey, newFdKeyMap) = - updateLookupWithKey (\_ _ → Nothing) - (fromIntegral fd) - fdKeyMap - in (newFdKeyMap, fdKey) - unregisterFd evtMgr fdKey - - c'libusb_set_pollfd_notifiers ctxPtr aFP rFP nullPtr - - -- Check if we have to do our own timeout handling: - r ← c'libusb_pollfds_handle_timeouts ctxPtr - let mbHandleEvents | r ≡ 0 = Just handleEvents - | otherwise = Nothing - - fmap (Ctx (Just (evtMgr, mbHandleEvents))) $ FC.newForeignPtr ctxPtr $ do - -- Remove notifiers after which we can safely free the FunPtrs: - c'libusb_set_pollfd_notifiers ctxPtr nullFunPtr nullFunPtr nullPtr - freeHaskellFunPtr aFP - freeHaskellFunPtr rFP - - -- Unregister all registered file descriptors from the event manager: - readIORef fdKeyMapRef >>= mapM_ (unregisterFd evtMgr) ∘ elems - - -- Finally deinitialize libusb: - c'libusb_exit ctxPtr - --- | 'True' if the RTS supports bound threads and 'False' otherwise. --- --- The asynchronous implementations only work correctly when this is 'True'. -foreign import ccall unsafe "rtsSupportsBoundThreads" threaded ∷ Bool -#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 $ genFromEnum 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 - deriving (Enum, Ord, COMMON_INSTANCES) - --------------------------------------------------------------------------------- --- * 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'. Alternatively you -can use the @usb-safe@ package which provides type-safe device handling. See: - - - -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 'deviceDesc'. --} -data Device = Device - { getCtx ∷ !Ctx -- ^ This reference to the 'Ctx' is needed so that it won't - -- get garbage collected. The finalizer "p'libusb_exit" is - -- run only when all references to 'Devices' are gone. - - , getDevFrgnPtr ∷ !(ForeignPtr C'libusb_device) - - , deviceDesc ∷ !DeviceDesc -- ^ Get the descriptor of the device. - } deriving Typeable - --- | Equality on devices is defined by comparing their descriptors: --- @(==) = (==) \`on\` `deviceDesc`@ -instance Eq Device where (==) = (==) `on` deviceDesc - --- | Devices are shown in the same way as the popular @lsusb@ program: --- --- @Bus \ Device \: ID \:\@ -instance Show Device where - show d = printf "Bus %03d Device %03d: ID %04x:%04x" (busNumber d) - (deviceAddress d) - (deviceVendorId desc) - (deviceProductId desc) - where - desc = deviceDesc d - -withDevicePtr ∷ Device → (Ptr C'libusb_device → IO α) → IO α -withDevicePtr (Device ctx devFP _) f = withCtxPtr ctx $ \_ → - withForeignPtr devFP f - -{-| Returns a list 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 [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 numDevs devPtrArray) - `onException` freeDevPtrArray - freeDevPtrArray - return devs - where - mkDev ∷ Ptr C'libusb_device → IO Device - mkDev devPtr = liftA2 (Device ctx) - (newForeignPtr p'libusb_unref_device devPtr) - (getDeviceDesc devPtr) - --- Both of 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 - --- | 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 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) ++ "}" - -withDevHndlPtr ∷ DeviceHandle → (Ptr C'libusb_device_handle → IO α) → IO α -withDevHndlPtr (DeviceHandle dev devHndlPtr) f = withDevicePtr dev $ \_ → - f devHndlPtr - -{-| 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 α) → IO α -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 α → IO α -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' or -'withInterfaceHandle'. - -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 --------------------------------------------------------------------------------- - -{-| 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 α → IO α -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 'deviceDesc'. --} -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 - - -- | List of configurations supported by the device. - , deviceConfigs ∷ ![ConfigDesc] - } deriving (COMMON_INSTANCES) - -type ReleaseNumber = (Int, Int, Int, Int) - -type VendorId = Word16 -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 'deviceConfigs'. --} -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 - - -- | Number of interfaces supported by the configuration. - , configNumInterfaces ∷ !Word8 - - -- | List of interfaces supported by the configuration. Note that the - -- length of this list should equal 'configNumInterfaces'. - , configInterfaces ∷ ![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) - --- | An interface is represented as a list of alternate interface settings. -type Interface = [InterfaceDesc] - --------------------------------------------------------------------------------- --- *** Configuration attributes --------------------------------------------------------------------------------- - --- | The USB 2.0 specification specifies that the configuration attributes only --- describe the device status. -type ConfigAttribs = DeviceStatus - -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 --------------------------------------------------------------------------------- - -{-| 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) - - -- | List of endpoints supported by the interface. - , interfaceEndpoints ∷ ![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 - } 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 (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 - | 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 --------------------------------------------------------------------------------- - -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 --------------------------------------------------------------------------------- - -getDeviceDesc ∷ Ptr C'libusb_device → IO DeviceDesc -getDeviceDesc devPtr = alloca $ \devDescPtr → do - handleUSBException $ c'libusb_get_device_descriptor devPtr devDescPtr - peek devDescPtr >>= convertDeviceDesc devPtr - -convertDeviceDesc ∷ Ptr C'libusb_device - → C'libusb_device_descriptor - → IO DeviceDesc -convertDeviceDesc devPtr d = do - let numConfigs = c'libusb_device_descriptor'bNumConfigurations d - - configs ← forM [0..numConfigs-1] $ getConfigDesc devPtr - - return 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 = numConfigs - , deviceConfigs = configs - } - --- | Unmarshal a a 16bit word as a release number. The 16bit word should be --- encoded as a Binary Coded Decimal using 4 bits for each of the 4 --- decimals. Also see: --- --- -unmarshalReleaseNumber ∷ Word16 → ReleaseNumber -unmarshalReleaseNumber abcd = (a, b, c, d) - where - [a, b, c, d] = map fromIntegral $ decodeBCD 4 abcd - --- | 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 - -getConfigDesc ∷ Ptr C'libusb_device → Word8 → IO ConfigDesc -getConfigDesc devPtr ix = bracket getConfigDescPtr - c'libusb_free_config_descriptor - ((convertConfigDesc =<<) ∘ peek) - where - getConfigDescPtr = alloca $ \configDescPtrPtr → do - handleUSBException $ c'libusb_get_config_descriptor - devPtr - ix - configDescPtrPtr - peek configDescPtrPtr - -convertConfigDesc ∷ C'libusb_config_descriptor → IO ConfigDesc -convertConfigDesc c = do - let numInterfaces = c'libusb_config_descriptor'bNumInterfaces c - - interfaces ← mapPeekArray convertInterface - (fromIntegral numInterfaces) - (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 - , configNumInterfaces = numInterfaces - , 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 [InterfaceDesc] -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 - let numEndpoints = c'libusb_interface_descriptor'bNumEndpoints i - - endpoints ← mapPeekArray convertEndpointDesc - (fromIntegral numEndpoints) - (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 α, Num α) ⇒ EndpointAddress → α -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 list of supported languages. - -This function may throw 'USBException's. --} -getLanguages ∷ DeviceHandle → IO [LangId] -getLanguages devHndl = allocaArray maxSize $ \dataPtr → do - reportedSize ← write dataPtr - - let strSize = (reportedSize - strDescHeaderSize) `div` charSize - strPtr = castPtr $ dataPtr `plusPtr` strDescHeaderSize - - map unmarshalLangId <$> peekArray strSize strPtr - where - maxSize = 255 -- Some devices choke on size > 255 - write = putStrDesc devHndl 0 0 maxSize - -{-| @putStrDesc 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. --} -putStrDesc ∷ DeviceHandle - → StrIx - → Word16 - → Size - → Ptr CUChar - → IO Size -putStrDesc 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 @usb-id-database@ package at: - - - -To see which 'LangId's are supported by a device see 'getLanguages'. --} -type LangId = (PrimaryLangId, SubLangId) -type PrimaryLangId = Word16 -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 = putStrDesc 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 langIds of - [] → throwIO $ IOException "Zero languages" - 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 -------------------------------------------------------------------------------- - --- | Handy type synonym that names the parameters of a control transfer. -type ControlAction α = RequestType → Recipient → Request → Value → Index → α - -data RequestType = Standard - | Class - | Vendor - deriving (Enum, COMMON_INSTANCES) - -data Recipient = ToDevice - | ToInterface - | ToEndpoint - | ToOther - deriving (Enum, COMMON_INSTANCES) - -type Request = Word8 - --- | (Host-endian) -type Value = Word16 - --- | (Host-endian) -type Index = Word16 - -marshalRequestType ∷ RequestType → Recipient → Word8 -marshalRequestType t r = 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 → ControlAction (Timeout → IO ()) -control devHndl reqType reqRecipient request value index timeout = do - (_, status) ← doControl - when (status ≡ TimedOut) $ throwIO TimeoutException - where - doControl -#ifdef HAS_EVENT_MANAGER - | threaded = allocaBytes controlSetupSize $ \bufferPtr → do - poke bufferPtr $ C'libusb_control_setup requestType - request value index - 0 - transferAsync c'LIBUSB_TRANSFER_TYPE_CONTROL - devHndl - controlEndpoint - timeout - (bufferPtr, controlSetupSize) -#endif - | otherwise = controlTransferSync devHndl - requestType - request value index - timeout - (nullPtr, 0) - requestType = marshalRequestType reqType reqRecipient - --------------------------------------------------------------------------------- - -{-| 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 → ControlAction ReadAction -readControl devHndl reqType reqRecipient request value index size timeout -#ifdef HAS_EVENT_MANAGER - | threaded = do - let totalSize = controlSetupSize + size - allocaBytes totalSize $ \bufferPtr → do - poke bufferPtr $ C'libusb_control_setup requestType - request value index - (fromIntegral size) - (transferred, status) ← transferAsync 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 - requestType - request value index - timeout - (dataPtr, size) - where - requestType = marshalRequestType reqType reqRecipient `setBit` 7 - --- | 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 → ControlAction ReadExactAction -readControlExact devHndl - reqType reqRecipient request value index - size timeout = do - (bs, _) ← readControl devHndl - reqType reqRecipient request value index - 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 → ControlAction WriteAction -writeControl devHndl reqType reqRecipient request value index input timeout -#ifdef HAS_EVENT_MANAGER - | threaded = BU.unsafeUseAsCStringLen input $ \(dataPtr, size) → do - let totalSize = controlSetupSize + size - allocaBytes totalSize $ \bufferPtr → do - poke bufferPtr $ C'libusb_control_setup requestType - request value index - (fromIntegral size) - copyArray (bufferPtr `plusPtr` controlSetupSize) dataPtr size - transferAsync c'LIBUSB_TRANSFER_TYPE_CONTROL - devHndl controlEndpoint - timeout - (bufferPtr, totalSize) -#endif - | otherwise = BU.unsafeUseAsCStringLen input $ - controlTransferSync devHndl - requestType - request value index - timeout - where - requestType = marshalRequestType reqType reqRecipient - --- | 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 → ControlAction WriteExactAction -writeControlExact devHndl - reqType reqRecipient request value index - input timeout = do - (transferred, _) ← writeControl devHndl - reqType reqRecipient request value index - 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 - → Word8 → Request → Value → Index - → Timeout - → (Ptr byte, Size) - → IO (Size, Status) -controlTransferSync devHndl - reqType request value index - timeout - (dataPtr, size) = do - err ← withDevHndlPtr devHndl $ \devHndlPtr → - c'libusb_control_transfer devHndlPtr - reqType 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 - ) - --------------------------------------------------------------------------------- --- ** Bulk transfers --------------------------------------------------------------------------------- - -{-| Perform a USB /bulk/ read. - -Exceptions: - - * 'PipeException' if the endpoint halted. - - * 'OverflowException' if the device offered more data, - see /Packets and overflows/ in the @libusb@ documentation: - . - - * 'NoDeviceException' if the device has been disconnected. - - * Another 'USBException'. --} -readBulk ∷ DeviceHandle → EndpointAddress → ReadAction -readBulk -#ifdef HAS_EVENT_MANAGER - | threaded = readTransferAsync c'LIBUSB_TRANSFER_TYPE_BULK -#endif - | otherwise = readTransferSync c'libusb_bulk_transfer - -{-| Perform a USB /bulk/ write. - -Exceptions: - - * 'PipeException' if the endpoint halted. - - * 'OverflowException' if the device offered more data, - see /Packets and overflows/ in the @libusb@ documentation: - . - - * 'NoDeviceException' if the device has been disconnected. - - * Another 'USBException'. --} -writeBulk ∷ DeviceHandle → EndpointAddress → WriteAction -writeBulk -#ifdef HAS_EVENT_MANAGER - | threaded = writeTransferAsync c'LIBUSB_TRANSFER_TYPE_BULK -#endif - | otherwise = writeTransferSync c'libusb_bulk_transfer - --------------------------------------------------------------------------------- --- ** Interrupt transfers --------------------------------------------------------------------------------- - -{-| Perform a USB /interrupt/ read. - -Exceptions: - - * 'PipeException' if the endpoint halted. - - * 'OverflowException' if the device offered more data, - see /Packets and overflows/ in the libusb documentation: - . - - * 'NoDeviceException' if the device has been disconnected. - - * Another 'USBException'. --} -readInterrupt ∷ DeviceHandle → EndpointAddress → ReadAction -readInterrupt -#ifdef HAS_EVENT_MANAGER - | threaded = readTransferAsync c'LIBUSB_TRANSFER_TYPE_INTERRUPT -#endif - | otherwise = readTransferSync c'libusb_interrupt_transfer - - -{-| Perform a USB /interrupt/ write. - -Exceptions: - - * 'PipeException' if the endpoint halted. - - * 'OverflowException' if the device offered more data, - see /Packets and overflows/ in the @libusb@ documentation: - . - - * 'NoDeviceException' if the device has been disconnected. - - * Another 'USBException'. --} -writeInterrupt ∷ DeviceHandle → EndpointAddress → WriteAction -writeInterrupt -#ifdef HAS_EVENT_MANAGER - | threaded = writeTransferAsync c'LIBUSB_TRANSFER_TYPE_INTERRUPT -#endif - | otherwise = writeTransferSync c'libusb_interrupt_transfer - --------------------------------------------------------------------------------- - --- | 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 ∷ C'TransferType → DeviceHandle → EndpointAddress → ReadAction -readTransferAsync transType = \devHndl endpointAddr → \size timeout → - createAndTrimNoOffset size $ \bufferPtr → - transferAsync transType - devHndl (marshalEndpointAddress endpointAddr) - timeout - (bufferPtr, size) - -writeTransferAsync ∷ C'TransferType → DeviceHandle → EndpointAddress → WriteAction -writeTransferAsync transType = \devHndl endpointAddr → \input timeout → - BU.unsafeUseAsCStringLen input $ - transferAsync transType - devHndl (marshalEndpointAddress endpointAddr) - timeout - --------------------------------------------------------------------------------- - -type C'TransferType = CUChar - -transferAsync ∷ C'TransferType - → DeviceHandle → CUChar -- ^ Encoded endpoint address - → Timeout - → (Ptr byte, Size) - → IO (Size, Status) -transferAsync transType devHndl endpoint timeout bytes = - withTerminatedTransfer transType - 0 [] - devHndl endpoint - timeout - bytes - (continue Completed) - (continue TimedOut) - where - continue status transPtr = do - n ← peek $ p'libusb_transfer'actual_length transPtr - return (fromIntegral n, status) - --------------------------------------------------------------------------------- - -withTerminatedTransfer ∷ C'TransferType - → Int → [C'libusb_iso_packet_descriptor] - → DeviceHandle → CUChar -- ^ Encoded endpoint address - → Timeout - → (Ptr byte, Size) - → (Ptr C'libusb_transfer → IO α) - → (Ptr C'libusb_transfer → IO α) - → IO α -withTerminatedTransfer transType - nrOfIsoPackets isoPackageDescs - devHndl endpoint - timeout - (bufferPtr, size) - onCompletion - onTimeout = - withDevHndlPtr devHndl $ \devHndlPtr → - allocaTransfer nrOfIsoPackets $ \transPtr → do - - lock ← newLock - let Just (evtMgr, mbHandleEvents) = getEventManager $ - getCtx $ - getDevice devHndl - waitForTermination = - case mbHandleEvents of - Just handleEvents | timeout ≢ noTimeout → do - tk ← registerTimeout evtMgr (timeout * 1000) handleEvents - acquire lock - `onException` - (uninterruptibleMask_ $ do - unregisterTimeout evtMgr tk - _err ← c'libusb_cancel_transfer transPtr - acquire lock) - _ → acquire lock - `onException` - (uninterruptibleMask_ $ do - _err ← c'libusb_cancel_transfer transPtr - acquire lock) - withCallback (\_ → release lock) $ \cbPtr → do - - poke transPtr $ C'libusb_transfer - { c'libusb_transfer'dev_handle = devHndlPtr - , c'libusb_transfer'flags = 0 -- unused - , c'libusb_transfer'endpoint = endpoint - , c'libusb_transfer'type = transType - , c'libusb_transfer'timeout = fromIntegral timeout - , c'libusb_transfer'status = 0 -- output - , c'libusb_transfer'length = fromIntegral size - , c'libusb_transfer'actual_length = 0 -- output - , c'libusb_transfer'callback = cbPtr - , c'libusb_transfer'user_data = nullPtr -- unused - , c'libusb_transfer'buffer = castPtr bufferPtr - , c'libusb_transfer'num_iso_packets = fromIntegral nrOfIsoPackets - , c'libusb_transfer'iso_packet_desc = isoPackageDescs - } - - mask_ $ do - handleUSBException $ c'libusb_submit_transfer transPtr - waitForTermination - - 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 ++ "!" - --------------------------------------------------------------------------------- - --- | 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 α) → IO α -allocaTransfer nrOfIsoPackets = bracket mallocTransfer c'libusb_free_transfer - where - mallocTransfer = do - transPtr ← c'libusb_alloc_transfer (fromIntegral nrOfIsoPackets) - 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 α) - → IO α -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 /Packets and overflows/ in the @libusb@ documentation: - . - - * 'NoDeviceException' if the device has been disconnected. - - * Another 'USBException'. --} -readIsochronous ∷ DeviceHandle - → EndpointAddress - → [Size] -- ^ Sizes of isochronous packets - → Timeout - → IO [B.ByteString] -readIsochronous devHndl endpointAddr sizes timeout - | not threaded = needThreadedRTSError "readIsochronous" - | otherwise = do - let SumLength totalSize nrOfIsoPackets = sumLength sizes - allocaBytes totalSize $ \bufferPtr → - withTerminatedTransfer c'LIBUSB_TRANSFER_TYPE_ISOCHRONOUS - nrOfIsoPackets (map initIsoPacketDesc sizes) - devHndl - (marshalEndpointAddress endpointAddr) - timeout - (bufferPtr, totalSize) - (\transPtr → convertIsos nrOfIsoPackets - transPtr - bufferPtr) - (\_ → throwIO TimeoutException) - --------------------------------------------------------------------------------- - -{-| 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 /Packets and overflows/ in the @libusb@ documentation: - . - - * 'NoDeviceException' if the device has been disconnected. - - * Another 'USBException'. --} -writeIsochronous ∷ DeviceHandle - → EndpointAddress - → [B.ByteString] - → Timeout - → IO [Size] -writeIsochronous devHndl endpointAddr isoPackets timeout - | not threaded = needThreadedRTSError "writeIsochronous" - | otherwise = do - let sizes = map B.length isoPackets - SumLength totalSize nrOfIsoPackets = sumLength sizes - allocaBytes totalSize $ \bufferPtr → do - copyIsos (castPtr bufferPtr) isoPackets - withTerminatedTransfer c'LIBUSB_TRANSFER_TYPE_ISOCHRONOUS - nrOfIsoPackets (map initIsoPacketDesc sizes) - devHndl - (marshalEndpointAddress endpointAddr) - timeout - (bufferPtr, totalSize) - (\transPtr → - map actualLength <$> peekIsoPacketDescs - nrOfIsoPackets - transPtr) - (\_ → throwIO TimeoutException) - --------------------------------------------------------------------------------- - -actualLength ∷ C'libusb_iso_packet_descriptor → Size -actualLength = fromIntegral ∘ c'libusb_iso_packet_descriptor'actual_length - --- | Simultaneously calculate the sum and length of the given list. -sumLength ∷ [Int] → SumLength -sumLength = foldl' (\(SumLength s l) x → SumLength (s+x) (l+1)) (SumLength 0 0) - --- | Strict pair of sum and length. -data SumLength = SumLength !Int !Int - --- | 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 - } - -convertIsos ∷ Int → Ptr C'libusb_transfer → Ptr Word8 → IO [B.ByteString] -convertIsos nrOfIsoPackets transPtr bufferPtr = - peekIsoPacketDescs nrOfIsoPackets transPtr >>= go bufferPtr id - where - go _ bss [] = return $ bss [] - go ptr bss (C'libusb_iso_packet_descriptor l a _ : ds) = do - let transferred = fromIntegral a - bs ← BI.create transferred $ \p → copyArray p ptr transferred - go (ptr `plusPtr` fromIntegral l) (bss ∘ (bs:)) ds - --- | Retrieve the isochronous packet descriptors from the given transfer. -peekIsoPacketDescs ∷ Int - → Ptr C'libusb_transfer - → IO [C'libusb_iso_packet_descriptor] -peekIsoPacketDescs nrOfIsoPackets = peekArray nrOfIsoPackets - ∘ p'libusb_transfer'iso_packet_desc - -copyIsos ∷ Ptr CChar → [B.ByteString] → IO () -copyIsos = foldM_ $ \bufferPtr bs → - BU.unsafeUseAsCStringLen bs $ \(ptr, len) → do - copyArray bufferPtr ptr len - return $ bufferPtr `plusPtr` len -#endif - --------------------------------------------------------------------------------- - -createAndTrimNoOffset ∷ Size → (Ptr Word8 → IO (Size, α)) → IO (B.ByteString, α) -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 α ⇒ IO α → 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 α ⇒ α → 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 α ⇒ [(α, 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 /Packets and overflows/ 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. - | 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" - -needThreadedRTSError ∷ String → error -needThreadedRTSError msg = moduleError $ msg ++ - " is only supported when using the threaded runtime. " ++ - "Please build your program with -threaded." diff --git a/System/USB/Descriptors.hs b/System/USB/Descriptors.hs deleted file mode 100644 --- a/System/USB/Descriptors.hs +++ /dev/null @@ -1,71 +0,0 @@ --------------------------------------------------------------------------------- --- | --- Module : System.USB.Descriptors --- Copyright : (c) 2009–2011 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 - DeviceDesc(..) - - , ReleaseNumber - - -- | For a database of USB vendors and products see the @usb-id-database@ - -- package at: - , VendorId, ProductId - - -- * Configuration descriptor - , ConfigDesc(..) - - , Interface - - -- *** Configuration attributes - , ConfigAttribs - , DeviceStatus(..) - - -- * Interface descriptor - , 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,47 +0,0 @@ --------------------------------------------------------------------------------- --- | --- Module : System.USB.Devices --- Copyright : (c) 2009–2011 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 - , 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,22 +0,0 @@ --------------------------------------------------------------------------------- --- | --- Module : System.USB.Devices --- Copyright : (c) 2009–2011 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 - , getDevices - - , busNumber - , deviceAddress - , deviceDesc - ) 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,17 +0,0 @@ --------------------------------------------------------------------------------- --- | --- Module : System.USB.Exceptions --- Copyright : (c) 2009–2011 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,69 +0,0 @@ -{-# LANGUAGE CPP, UnicodeSyntax, NoImplicitPrelude #-} - --------------------------------------------------------------------------------- --- | --- Module : System.USB.IO --- Copyright : (c) 2009–2011 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 - ( ReadAction, ReadExactAction - , WriteAction, WriteExactAction - , Size - , Timeout, noTimeout - , Status(..) - - -- * Control transfers - , ControlAction - , 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__ -#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,287 +0,0 @@ -{-# LANGUAGE CPP, NoImplicitPrelude, UnicodeSyntax, DeriveDataTypeable #-} - --------------------------------------------------------------------------------- --- | --- Module : System.USB.IO.StandardDeviceRequests --- Copyright : (c) 2009–2011 Bas van Dijk --- License : BSD3 (see the file LICENSE) --- Maintainer : Bas van Dijk --- --- 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 ) -import Data.Eq ( (==) ) -#endif - --- from base-unicode-symbols: -import Data.Eq.Unicode ( (≡) ) -import Data.Function.Unicode ( (∘) ) -import Prelude.Unicode ( (⋅) ) - --- 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 - ) -#if __HADDOCK__ -import qualified System.USB.DeviceHandling as USB ( setConfig, getConfig ) -#endif - -import System.USB.Descriptors ( EndpointAddress - , DeviceStatus(..) - ) -import System.USB.IO ( Timeout - , RequestType(Standard) - , Recipient( ToDevice - , ToInterface - , ToEndpoint - ) - , Value - , control, readControlExact - ) - -import System.USB.Internal ( 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 - Standard - ToEndpoint - c'LIBUSB_REQUEST_SET_FEATURE - haltFeature - (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 - Standard - ToDevice - c'LIBUSB_REQUEST_SET_CONFIGURATION - (marshal mbConfigValue) - 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 - Standard - ToDevice - c'LIBUSB_REQUEST_GET_CONFIGURATION - 0 - 0 - 1 - where - 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 - Standard - ToDevice - c'LIBUSB_REQUEST_CLEAR_FEATURE - remoteWakeupFeature - 0 - --- | See: USB 2.0 Spec. section 9.4.9 -setRemoteWakeup ∷ DeviceHandle → (Timeout → IO ()) -setRemoteWakeup devHndl = - control devHndl - Standard - ToDevice - c'LIBUSB_REQUEST_SET_FEATURE - remoteWakeupFeature - 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 - Standard - ToDevice - c'LIBUSB_REQUEST_SET_FEATURE - testModeFeature - ((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 - Standard - ToInterface - c'LIBUSB_REQUEST_GET_INTERFACE - 0 - (fromIntegral ifNum) - 1 - --- | See: USB 2.0 Spec. section 9.4.5 -getDeviceStatus ∷ DeviceHandle → (Timeout → IO DeviceStatus) -getDeviceStatus devHndl = - fmap (unmarshal ∘ B.head) ∘ readControlExact devHndl - Standard - ToDevice - c'LIBUSB_REQUEST_GET_STATUS - 0 - 0 - 2 - where - 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 - Standard - ToEndpoint - c'LIBUSB_REQUEST_GET_STATUS - 0 - (marshalEndpointAddress endpointAddr) - 2 - --- | See: USB 2.0 Spec. section 9.4.6 -setDeviceAddress ∷ DeviceHandle → Word16 → (Timeout → IO ()) -setDeviceAddress devHndl deviceAddr = control devHndl - Standard - ToDevice - c'LIBUSB_REQUEST_SET_ADDRESS - deviceAddr - 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 - Standard - ToEndpoint - c'LIBUSB_REQUEST_SYNCH_FRAME - 0 - (marshalEndpointAddress endpointAddr) - 2 - where - unmarshal ∷ B.ByteString → FrameNumber - unmarshal bs = let [h, l] = B.unpack bs - in fromIntegral h ⋅ 256 + fromIntegral l - -type FrameNumber = Word16 diff --git a/System/USB/Initialization.hs b/System/USB/Initialization.hs deleted file mode 100644 --- a/System/USB/Initialization.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE CPP #-} - --------------------------------------------------------------------------------- --- | --- Module : System.USB.Init --- Copyright : (c) 2009–2011 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 - , setDebug - , Verbosity(..) - ) where - -import System.USB.Base diff --git a/System/USB/Internal.hs b/System/USB/Internal.hs deleted file mode 100644 --- a/System/USB/Internal.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE CPP #-} - --------------------------------------------------------------------------------- --- | --- Module : System.USB.Unsafe --- Copyright : (c) 2009–2011 Bas van Dijk --- License : BSD3 (see the file LICENSE) --- Maintainer : Bas van Dijk --- --- This module is not intended for end users. It provides internal and unsafe --- functions used for extending this package. --- --------------------------------------------------------------------------------- - -module System.USB.Internal - ( C'TransferFunc - , withDevHndlPtr - , convertUSBException - , unmarshalReleaseNumber - , unmarshalStrIx - - -- * Marshal and unmarshal endpoint addresses - - -- | The address should be encoded according to section 9.6.6 of the USB 2.0 - -- specification. - -- - -- * Bits 0-3 denote the 'endpointNumber'. - -- - -- * Bit 7 denotes the 'transferDirection'. - -- 0 denotes 'Out' and 1 denotes 'In'. - , marshalEndpointAddress - , unmarshalEndpointAddress - -#ifdef HAS_EVENT_MANAGER - -- * Useful types and functions for asynchronous implementations - , C'TransferType - - , threaded - - , allocaTransfer - , withCallback - - , SumLength(..), sumLength - , peekIsoPacketDescs - , initIsoPacketDesc - - , getCtx, getEventManager - - -- ** Locks - , Lock, newLock, acquire, release -#endif - ) 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/Timeval.hs b/Timeval.hs deleted file mode 100644 --- a/Timeval.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude, UnicodeSyntax #-} - --- | A short module to work with C's struct timeval. - --- Copied from the package "time" - Data.Time.Clock.CTimeval - -module Timeval ( withTimeval ) where - --------------------------------------------------------------------------------- --- Imports --------------------------------------------------------------------------------- - --- from base: -import Control.Monad ( return ) -import Foreign.C.Types ( CLong ) -import Foreign.Marshal.Utils ( with ) -import Foreign.Ptr ( Ptr, castPtr ) -import Foreign.Storable ( Storable(..) ) -import Prelude ( (*), quotRem, fromIntegral, undefined, Int ) -import System.IO ( IO ) - --- from base-unicode-symbols: -import Data.Function.Unicode ( (∘) ) - --- from bindings-libusb: -import Bindings.Libusb.PollingAndTiming ( C'timeval ) - --------------------------------------------------------------------------------- --- Timeval --------------------------------------------------------------------------------- - -data CTimeval = MkCTimeval CLong CLong - -instance Storable CTimeval where - sizeOf _ = (sizeOf (undefined ∷ CLong)) * 2 - alignment _ = alignment (undefined ∷ CLong) - peek p = do - s ← peekElemOff (castPtr p) 0 - mus ← peekElemOff (castPtr p) 1 - return (MkCTimeval s mus) - poke p (MkCTimeval s mus) = do - pokeElemOff (castPtr p) 0 s - pokeElemOff (castPtr p) 1 mus - --- Every things done so far in libusb was in milliseconds. So this --- function should accept a time in milliseconds too ! -withTimeval ∷ Int → (Ptr C'timeval → IO α) → IO α -withTimeval milliseconds action = - let (seconds, mseconds) = milliseconds `quotRem` 1000 - timeval = MkCTimeval (fromIntegral seconds) - (fromIntegral (1000 * mseconds)) -- micro-seconds - in with timeval (action ∘ castPtr) diff --git a/Utils.hs b/Utils.hs deleted file mode 100644 --- a/Utils.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# LANGUAGE CPP - , NoImplicitPrelude - , UnicodeSyntax - , BangPatterns - #-} - -module Utils where - --------------------------------------------------------------------------------- --- Imports --------------------------------------------------------------------------------- - --- from base: -import Prelude ( (+), (-), (^) - , Enum, toEnum, fromEnum - , Integral, fromIntegral - ) - -#if __GLASGOW_HASKELL__ < 700 -import Prelude ( fromInteger ) -import Control.Monad ( (>>) ) -#endif - -import Control.Monad ( Monad, (>>=), mapM ) -import Foreign.Ptr ( Ptr ) -import Foreign.Storable ( Storable, ) -import Foreign.Marshal.Array ( peekArray ) -import Data.Bool ( Bool, otherwise ) -import Data.Ord ( Ord, (<) ) -import Data.Bits ( Bits, shiftL, shiftR, bitSize, (.&.) ) -import Data.Int ( Int ) -import System.IO ( IO ) - --- from base-unicode-symbols: -import Data.Function.Unicode ( (∘) ) -import Data.Ord.Unicode ( (≥), (≤) ) -import Data.Bool.Unicode ( (∧) ) - - --------------------------------------------------------------------------------- --- Utils --------------------------------------------------------------------------------- - --- | @bits s e b@ extract bit @s@ to @e@ (including) from @b@. -bits ∷ Bits α ⇒ Int → Int → α → α -bits s e b = (2 ^ (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 α ⇒ α → α → α → 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 α ⇒ (α → IO β) → Int → Ptr α → IO [β] -mapPeekArray f n a = peekArray n a >>= mapM f - --- | Monadic if...then...else... -ifM ∷ Monad m ⇒ m Bool → m α → m α → m α -ifM cM tM eM = cM >>= \c → if c then tM else eM - -{-| @decodeBCD bitsInDigit bcd@ decodes the Binary Coded Decimal @bcd@ to a list -of its encoded digits. @bitsInDigit@, which is usually 4, is the number of bits -used to encode a single digit. See: - --} -decodeBCD ∷ Bits α ⇒ Int → α → [α] -decodeBCD bitsInDigit abcd = go shftR [] - where - shftR = bitSize abcd - bitsInDigit - - go shftL ds | shftL < 0 = ds - | otherwise = let !d = (abcd `shiftL` shftL) `shiftR` shftR - in go (shftL - bitsInDigit) (d : ds) 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,20 +1,22 @@ name: usb -version: 1.0 +version: 1.3.0.6 cabal-version: >=1.6 -build-type: Custom +build-type: Simple license: BSD3 license-file: LICENSE -copyright: 2009–2011 Bas van Dijk +copyright: 2009–2017 Bas van Dijk author: Bas van Dijk maintainer: Bas van Dijk -homepage: https://github.com/basvandijk/usb/ +homepage: http://basvandijk.github.com/usb bug-reports: https://github.com/basvandijk/usb/issues -category: System +category: System, Hardware synopsis: Communicate with USB devices description: This library enables you to communicate with USB devices from userspace. It is implemented as a high-level wrapper around - @bindings-libusb@ which is a low-level binding to the C library: - @libusb-1.*@. + @bindings-libusb@ + () + which is a low-level binding to the C library: + @libusb-1.*@ (). . The USB transfer functions in this library have a simple synchronous interface (they block) but are implemented using the @libusb@ @@ -30,47 +32,34 @@ This documentation assumes knowledge of how to operate USB devices from a software standpoint (descriptors, configurations, interfaces, endpoints, control\/bulk\/interrupt\/isochronous - transfers, etc). Full information can be found in the USB 2.0 - Specification. - . - For an example how to use this library see the @usb-example@ - package at: - . - - . - or the @ls-usb@ package at: - . - - . - Also see the @usb-safe@ package which wraps this package and - provides some strong safety guarantees for working with USB - devices: - . - - . - Finally have a look at the @usb-iteratee@ package which - provides @iteratee@ enumerators for enumerating bulk, interrupt - and isochronous endpoints: + transfers, etc). Full information can be found in the + USB 2.0 specification (). . - + For an example how to use this library see the + @usb-example@ package () + or the @ls-usb@ package (). . Besides this API documentation the following sources might be interesting: . - * The libusb 1.0 documentation at: - + * The @libusb 1.0@ documentation (). . - * The USB 2.0 specification at: - + * The USB 2.0 specification (). . - * The @bindings-libusb@ documentation at: - + * The @bindings-libusb@ documentation (). . - * \"USB in a NutShell\" at: - + * \"USB in a NutShell\" (). -extra-source-files: README.markdown, NEWS +tested-with: GHC == 7.4.1, GHC == 7.4.2, + GHC == 7.6.1, GHC == 7.6.2, GHC == 7.6.3, + 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.2.1, GHC == 8.2.2 + GHC == 8.4.1 +extra-source-files: README.markdown, Changelog + source-repository head Type: git Location: git://github.com/basvandijk/usb.git @@ -78,24 +67,31 @@ Library GHC-Options: -Wall - build-depends: base >= 4 && < 4.5 - , base-unicode-symbols >= 0.1.1 && < 0.3 - , bindings-libusb >= 1.4.4 && < 1.5 - , bytestring >= 0.9 && < 0.10 - , text >= 0.5 && < 0.12 + 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 System.USB.Enumeration System.USB.DeviceHandling System.USB.Descriptors System.USB.IO System.USB.IO.StandardDeviceRequests System.USB.Exceptions - System.USB.Internal other-modules: System.USB.Base, Utils - if impl(ghc>7) && !os(windows) + if !os(windows) && impl(ghc>7) cpp-options: -DHAS_EVENT_MANAGER - other-modules: Poll, Event, SystemEventManager, Timeval - build-depends: containers >= 0.1 && < 0.5 + exposed-modules: System.USB.IO.Transfers + other-modules: Poll, Event, SystemEventManager + build-depends: containers >= 0.1 + + if impl(ghc >= 7.2.1) + cpp-options: -DGENERICS + build-depends: ghc-prim >= 0.2