usb 1.2.0.1 → 1.3.0.6
raw patch · 36 files changed
Files
- Changelog +367/−0
- Event.hs +0/−9
- LICENSE +1/−1
- NEWS +0/−304
- Poll.hsc +0/−27
- README.markdown +3/−0
- Setup.hs +2/−43
- System/USB.hs +0/−31
- System/USB/Base.hs +0/−2283
- System/USB/Descriptors.hs +0/−77
- System/USB/DeviceHandling.hs +0/−52
- System/USB/Enumeration.hs +0/−26
- System/USB/Exceptions.hs +0/−22
- System/USB/IO.hs +0/−73
- System/USB/IO/StandardDeviceRequests.hs +0/−286
- System/USB/Initialization.hs +0/−28
- System/USB/Internal.hs +0/−56
- SystemEventManager.hs +0/−33
- Timeval.hs +0/−50
- Utils.hs +0/−101
- src/Event.hs +9/−0
- src/Poll.hsc +27/−0
- src/System/USB.hs +39/−0
- src/System/USB/Base.hs +3808/−0
- src/System/USB/Descriptors.hs +77/−0
- src/System/USB/DeviceHandling.hs +53/−0
- src/System/USB/Enumeration.hs +59/−0
- src/System/USB/Exceptions.hs +22/−0
- src/System/USB/IO.hs +75/−0
- src/System/USB/IO/StandardDeviceRequests.hs +310/−0
- src/System/USB/IO/Transfers.hs +173/−0
- src/System/USB/Initialization.hs +30/−0
- src/System/USB/Misc.hs +30/−0
- src/SystemEventManager.hs +33/−0
- src/Utils.hs +102/−0
- usb.cabal +26/−19
+ Changelog view
@@ -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
− Event.hs
@@ -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
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2009–2012 Bas van Dijk+Copyright (c) 2009–2018 Bas van Dijk All rights reserved.
− NEWS
@@ -1,304 +0,0 @@-1.1--(Released on: 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--(Released on: 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--(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
− Poll.hsc
@@ -1,27 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--#include <poll.h>--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
README.markdown view
@@ -1,3 +1,6 @@+[](https://hackage.haskell.org/package/usb)+[](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:
Setup.hs view
@@ -1,43 +1,2 @@-#! /usr/bin/env runhaskell--{-# LANGUAGE NoImplicitPrelude #-}--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
− System/USB.hs
@@ -1,31 +0,0 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 704-{-# LANGUAGE Trustworthy #-}-#endif------------------------------------------------------------------------------------- |--- Module : System.USB--- Copyright : (c) 2009–2012 Bas van Dijk--- License : BSD-style (see the file LICENSE)--- Maintainer : Bas van Dijk <v.dijk.bas@gmail.com>------ 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
− System/USB/Base.hs
@@ -1,2283 +0,0 @@-{-# LANGUAGE CPP- , NoImplicitPrelude- , DeriveDataTypeable- , BangPatterns- #-}--#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, ($!), seq- )-import Foreign.C.Types ( CUChar, CInt, CUInt )-import Foreign.C.String ( CStringLen )-import Foreign.Marshal.Alloc ( alloca )-import Foreign.Marshal.Array ( allocaArray )-import Foreign.Storable ( peek, peekElemOff )-import Foreign.Ptr ( Ptr, castPtr, plusPtr, nullPtr )-import Foreign.ForeignPtr ( ForeignPtr, withForeignPtr, touchForeignPtr )-import Control.Exception ( Exception, throwIO, bracket, bracket_, onException, assert )-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.List ( lookup, (++) )-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 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---- 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, uncons- )------------------------------------------------------------------------------------#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, advancePtr )-import Foreign.Storable ( sizeOf, poke )-import Foreign.Ptr ( nullFunPtr, freeHaskellFunPtr )-import Control.Monad ( (>>=), mapM_, forM )-import Data.IORef ( newIORef, atomicModifyIORef, readIORef )-import System.Posix.Types ( Fd(Fd) )-import Control.Exception ( uninterruptibleMask_ )-import Control.Concurrent.MVar ( MVar, newEmptyMVar, takeMVar, putMVar )-import System.IO ( hPutStrLn, stderr )--#if MIN_VERSION_base(4,4,0)-import GHC.Event-#else-import System.Event-#endif- ( FdKey- , registerFd, unregisterFd- , registerTimeout, unregisterTimeout-#if MIN_VERSION_base(4,7,0)- , getSystemTimerManager-#endif- )---- from containers:-import Data.IntMap ( IntMap, fromList, insert, updateLookupWithKey, elems )---- from bytestring:-import qualified Data.ByteString.Internal as BI ( create )----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 Timeval ( withTimeval )-import qualified Poll ( toEvent )-import SystemEventManager ( getSystemEventManager )-import Utils ( pokeVector )-#endif--#if defined(HAS_EVENT_MANAGER) || defined(mingw32_HOST_OS)-import qualified Foreign.Concurrent as FC ( newForeignPtr )-#endif--#if !defined(mingw32_HOST_OS)-import Foreign.ForeignPtr ( newForeignPtr )-#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------------------------------------------------------------------------------------- * 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- 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--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-#ifdef mingw32_HOST_OS- ctx <$> FC.newForeignPtr ctxPtr- (c'libusb_exit ctxPtr)-#else- ctx <$> newForeignPtr p'libusb_exit ctxPtr-#endif--#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-- let 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- newFdKeyMap <- atomicModifyIORef fdKeyMapRef $ \fdKeyMap ->- let newFdKeyMap = insert (fromIntegral fd) fdKey fdKeyMap- in (newFdKeyMap, newFdKeyMap)- newFdKeyMap `seq` return ()-- rFP <- mk'libusb_pollfd_removed_cb $ \fd _ -> mask_ $ do- (newFdKeyMap, fdKey) <- atomicModifyIORef fdKeyMapRef $ \fdKeyMap ->- let (Just fdKey, newFdKeyMap) =- updateLookupWithKey (\_ _ -> Nothing)- (fromIntegral fd)- fdKeyMap- in (newFdKeyMap, (newFdKeyMap, fdKey))- newFdKeyMap `seq` unregisterFd evtMgr fdKey-- c'libusb_set_pollfd_notifiers ctxPtr aFP rFP nullPtr-- -- Check if we have to do our own timeout handling and construct the- -- appropriate Wait function:- r <- c'libusb_pollfds_handle_timeouts ctxPtr--#if MIN_VERSION_base(4,7,0)- timerMgr <- getSystemTimerManager-#else- let timerMgr = evtMgr-#endif-- let wait :: Wait- !wait | r == 0 = manualTimeout- | otherwise = \_ -> autoTimeout-- manualTimeout timeout lock transPtr- | timeout == noTimeout = autoTimeout lock transPtr- | otherwise = do- tk <- registerTimeout timerMgr (timeout * 1000) handleEvents- acquire lock- `onException`- (uninterruptibleMask_ $ do- unregisterTimeout timerMgr tk- _err <- c'libusb_cancel_transfer transPtr- acquire lock)-- autoTimeout lock transPtr =- acquire lock- `onException`- (uninterruptibleMask_ $ do- _err <- c'libusb_cancel_transfer transPtr- acquire lock)-- fmap (Ctx (Just wait)) $ 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---- | 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-#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'.--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--{-| 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 numDevs devPtrArray)- `onException` freeDevPtrArray- freeDevPtrArray- return devs- where- mkDev :: Ptr C'libusb_device -> IO Device- mkDev devPtr = Device ctx <$>-#ifdef mingw32_HOST_OS- FC.newForeignPtr devPtr- (c'libusb_unref_device devPtr)-#else- newForeignPtr p'libusb_unref_device devPtr-#endif---- 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 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-----------------------------------------------------------------------------------{-| 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 '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- } 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 '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--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- } 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------------------------------------------------------------------------------------- | 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--- <http://en.wikipedia.org/wiki/Binary-coded_decimal Binary Coded Decimal>--- 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- reportedSize <- write 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- 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:--<http://www.usb.org/developers/docs/USB_LANGIDs.pdf>--For a mapping between IDs and languages see the-<http://hackage.haskell.org/package/usb-id-database usb-id-database> package.--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 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------------------------------------------------------------------------------------ | Handy type synonym that names the parameters of a control transfer.-type ControlAction a = RequestType -> Recipient -> Request -> Value -> Index -> a--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- | Just wait <- getWait devHndl =- allocaBytes controlSetupSize $ \bufferPtr -> do- poke bufferPtr $ C'libusb_control_setup requestType- request value index- 0- transferAsync wait- 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- | Just wait <- getWait devHndl = do- let totalSize = controlSetupSize + size- allocaBytes totalSize $ \bufferPtr -> do- poke bufferPtr $ C'libusb_control_setup requestType- request value index- (fromIntegral 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- 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- | Just wait <- getWait devHndl =- 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 wait- 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- <http://libusb.sourceforge.net/api-1.0/packetoverflow.html Packets and overflows>- in the @libusb@ documentation.-- * 'NoDeviceException' if the device has been disconnected.-- * Another 'USBException'.--}-readBulk :: DeviceHandle -> EndpointAddress -> 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- <http://libusb.sourceforge.net/api-1.0/packetoverflow.html Packets and overflows>- in the @libusb@ documentation.-- * 'NoDeviceException' if the device has been disconnected.-- * Another 'USBException'.--}-writeBulk :: DeviceHandle -> EndpointAddress -> 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- <http://libusb.sourceforge.net/api-1.0/packetoverflow.html Packets and overflows>- in the @libusb@ documentation.-- * 'NoDeviceException' if the device has been disconnected.-- * Another 'USBException'.--}-readInterrupt :: DeviceHandle -> EndpointAddress -> 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- <http://libusb.sourceforge.net/api-1.0/packetoverflow.html Packets and overflows>- in the @libusb@ documentation.-- * 'NoDeviceException' if the device has been disconnected.-- * Another 'USBException'.--}-writeInterrupt :: DeviceHandle -> EndpointAddress -> 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------------------------------------------------------------------------------------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- VG.empty- 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 :: 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 -> do- let nrOfIsos = VG.length isos- allocaTransfer nrOfIsos $ \transPtr -> do- lock <- newLock- withCallback (\_ -> 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 ++ "!"-------------------------------------------------------------------------------------- | 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 c'libusb_free_transfer- where- mallocTransfer = 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- <http://libusb.sourceforge.net/api-1.0/packetoverflow.html Packets and overflows>- in the @libusb@ documentation.-- * 'NoDeviceException' if the device has been disconnected.-- * Another 'USBException'.--}-readIsochronous :: DeviceHandle- -> EndpointAddress- -> Unboxed.Vector Size -- ^ Sizes of isochronous packets- -> Timeout- -> IO (Vector B.ByteString)-readIsochronous devHndl endpointAddr sizes timeout- | Just wait <- getWait devHndl = do- let totalSize = VG.sum sizes- nrOfIsos = VG.length sizes- isos = VG.map initIsoPacketDesc $ VG.convert sizes- allocaBytes totalSize $ \bufferPtr ->- withTerminatedTransfer- wait- c'LIBUSB_TRANSFER_TYPE_ISOCHRONOUS- isos- devHndl- (marshalEndpointAddress endpointAddr)- timeout- (bufferPtr, totalSize)- (getPackets nrOfIsos bufferPtr)- (\_ -> throwIO TimeoutException)- | otherwise = needThreadedRTSError "readIsochronous"--getPackets :: Int -> Ptr Word8 -> Ptr C'libusb_transfer -> IO (Vector B.ByteString)-getPackets nrOfIsos bufferPtr transPtr = do- 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 <- 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------------------------------------------------------------------------------------{-| 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- <http://libusb.sourceforge.net/api-1.0/packetoverflow.html Packets and overflows>- in the @libusb@ documentation.-- * 'NoDeviceException' if the device has been disconnected.-- * Another 'USBException'.--}-writeIsochronous :: DeviceHandle- -> EndpointAddress- -> Vector B.ByteString- -> Timeout- -> IO (Unboxed.Vector Size)-writeIsochronous devHndl endpointAddr isoPackets timeout- | Just wait <- getWait devHndl = do- let sizes = VG.map B.length isoPackets- nrOfIsos = VG.length sizes- totalSize = VG.sum sizes- isos = VG.convert $ VG.map initIsoPacketDesc sizes- 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)- | otherwise = needThreadedRTSError "writeIsochronous"--getSizes :: Int -> Ptr C'libusb_transfer -> IO (Unboxed.Vector Size)-getSizes nrOfIsos transPtr = do- mv <- VGM.unsafeNew nrOfIsos- let isoArrayPtr = p'libusb_transfer'iso_packet_desc transPtr- 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--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- }-#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- -- <http://libusb.sourceforge.net/api-1.0/packetoverflow.html 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."
− System/USB/Descriptors.hs
@@ -1,77 +0,0 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 704-{-# LANGUAGE Trustworthy #-}-#endif------------------------------------------------------------------------------------- |--- Module : System.USB.Descriptors--- Copyright : (c) 2009–2012 Bas van Dijk--- License : BSD3 (see the file LICENSE)--- Maintainer : Bas van Dijk <v.dijk.bas@gmail.com>------ 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: <http://hackage.haskell.org/package/usb-id-database>- , 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
− System/USB/DeviceHandling.hs
@@ -1,52 +0,0 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 704-{-# LANGUAGE Trustworthy #-}-#endif------------------------------------------------------------------------------------- |--- Module : System.USB.Devices--- Copyright : (c) 2009–2012 Bas van Dijk--- License : BSD3 (see the file LICENSE)--- Maintainer : Bas van Dijk <v.dijk.bas@gmail.com>------ 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
− System/USB/Enumeration.hs
@@ -1,26 +0,0 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 704-{-# LANGUAGE Trustworthy #-}-#endif------------------------------------------------------------------------------------- |--- Module : System.USB.Devices--- Copyright : (c) 2009–2012 Bas van Dijk--- License : BSD3 (see the file LICENSE)--- Maintainer : Bas van Dijk <v.dijk.bas@gmail.com>------ This module provides functionality for enumerating the USB devices currently--- attached to the system.--------------------------------------------------------------------------------------module System.USB.Enumeration- ( Device- , getDevices-- , busNumber- , deviceAddress- ) where--import System.USB.Base
− System/USB/Exceptions.hs
@@ -1,22 +0,0 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 704-{-# LANGUAGE Trustworthy #-}-#endif------------------------------------------------------------------------------------- |--- Module : System.USB.Exceptions--- Copyright : (c) 2009–2012 Bas van Dijk--- License : BSD3 (see the file LICENSE)--- Maintainer : Bas van Dijk <v.dijk.bas@gmail.com>--------------------------------------------------------------------------------------module System.USB.Exceptions- ( USBException(..)- , ioException- , incompleteReadException- , incompleteWriteException- ) where--import System.USB.Base
− System/USB/IO.hs
@@ -1,73 +0,0 @@-{-# LANGUAGE CPP, UnicodeSyntax, NoImplicitPrelude #-}--#if __GLASGOW_HASKELL__ >= 704-{-# LANGUAGE Trustworthy #-}-#endif------------------------------------------------------------------------------------- |--- Module : System.USB.IO--- Copyright : (c) 2009–2012 Bas van Dijk--- License : BSD3 (see the file LICENSE)--- Maintainer : Bas van Dijk <v.dijk.bas@gmail.com>------ 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
− System/USB/IO/StandardDeviceRequests.hs
@@ -1,286 +0,0 @@-{-# LANGUAGE CPP, NoImplicitPrelude, DeriveDataTypeable #-}--#if __GLASGOW_HASKELL__ >= 704-{-# LANGUAGE Trustworthy #-}-#endif------------------------------------------------------------------------------------- |--- Module : System.USB.IO.StandardDeviceRequests--- Copyright : (c) 2009–2012 Bas van Dijk--- License : BSD3 (see the file LICENSE)--- Maintainer : Bas van Dijk <v.dijk.bas@gmail.com>------ 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 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
− System/USB/Initialization.hs
@@ -1,28 +0,0 @@-{-# LANGUAGE CPP #-}--#if __GLASGOW_HASKELL__ >= 704-{-# LANGUAGE Trustworthy #-}-#endif------------------------------------------------------------------------------------- |--- Module : System.USB.Init--- Copyright : (c) 2009–2012 Bas van Dijk--- License : BSD3 (see the file LICENSE)--- Maintainer : Bas van Dijk <v.dijk.bas@gmail.com>------ 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
− System/USB/Internal.hs
@@ -1,56 +0,0 @@-{-# LANGUAGE CPP #-}--#if __GLASGOW_HASKELL__ >= 704-{-# LANGUAGE Unsafe #-}-#endif------------------------------------------------------------------------------------- |--- Module : System.USB.Unsafe--- Copyright : (c) 2009–2012 Bas van Dijk--- License : BSD3 (see the file LICENSE)--- Maintainer : Bas van Dijk <v.dijk.bas@gmail.com>------ 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-- , getWait, Wait-- , allocaTransfer- , withCallback-- , pokeVector- , initIsoPacketDesc-- -- ** Locks- , Lock, newLock, acquire, release-#endif- ) where--import System.USB.Base-import Utils
− SystemEventManager.hs
@@ -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
− Timeval.hs
@@ -1,50 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}---- | 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 Data.Function ( (.) )-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 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)
− Utils.hs
@@ -1,101 +0,0 @@-{-# LANGUAGE CPP- , NoImplicitPrelude- , BangPatterns- , ScopedTypeVariables- #-}--module Utils where------------------------------------------------------------------------------------- Imports------------------------------------------------------------------------------------- from base:-import Prelude ( ($)- , Num, (+), (*), (-)- , Enum, toEnum, fromEnum- , Integral, fromIntegral, undefined- )--#if __GLASGOW_HASKELL__ < 700-import Prelude ( fromInteger )-#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--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)
+ src/Event.hs view
@@ -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
+ src/Poll.hsc view
@@ -0,0 +1,27 @@+{-# LANGUAGE NoImplicitPrelude #-}++#include <poll.h>++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
+ src/System/USB.hs view
@@ -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 <v.dijk.bas@gmail.com>+--+-- 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
+ src/System/USB/Base.hs view
@@ -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+-- <http://en.wikipedia.org/wiki/Binary-coded_decimal Binary Coded Decimal>+-- 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:++<http://www.usb.org/developers/docs/USB_LANGIDs.pdf>++For a mapping between IDs and languages see the+<http://hackage.haskell.org/package/usb-id-database usb-id-database> 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+ <http://libusb.sourceforge.net/api-1.0/packetoverflow.html Packets and overflows>+ 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+ <http://libusb.sourceforge.net/api-1.0/packetoverflow.html Packets and overflows>+ 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+ <http://libusb.sourceforge.net/api-1.0/packetoverflow.html Packets and overflows>+ 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+ <http://libusb.sourceforge.net/api-1.0/packetoverflow.html Packets and overflows>+ 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+ <http://libusb.sourceforge.net/api-1.0/packetoverflow.html Packets and overflows>+ 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+ <http://libusb.sourceforge.net/api-1.0/packetoverflow.html Packets and overflows>+ 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+ -- <http://libusb.sourceforge.net/api-1.0/packetoverflow.html 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. 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"
+ src/System/USB/Descriptors.hs view
@@ -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 <v.dijk.bas@gmail.com>+--+-- 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: <http://hackage.haskell.org/package/usb-id-database>+ , 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
+ src/System/USB/DeviceHandling.hs view
@@ -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 <v.dijk.bas@gmail.com>+--+-- 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
+ src/System/USB/Enumeration.hs view
@@ -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 <v.dijk.bas@gmail.com>+--+-- 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
+ src/System/USB/Exceptions.hs view
@@ -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 <v.dijk.bas@gmail.com>+--+--------------------------------------------------------------------------------++module System.USB.Exceptions+ ( USBException(..)+ , ioException+ , incompleteReadException+ , incompleteWriteException+ ) where++import System.USB.Base
+ src/System/USB/IO.hs view
@@ -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 <v.dijk.bas@gmail.com>+--+-- 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
+ src/System/USB/IO/StandardDeviceRequests.hs view
@@ -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 <v.dijk.bas@gmail.com>+--+-- /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
+ src/System/USB/IO/Transfers.hs view
@@ -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 <v.dijk.bas@gmail.com>+-- 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
+ src/System/USB/Initialization.hs view
@@ -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 <v.dijk.bas@gmail.com>+--+-- 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
+ src/System/USB/Misc.hs view
@@ -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 <v.dijk.bas@gmail.com>+--+-- 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
+ src/SystemEventManager.hs view
@@ -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
+ src/Utils.hs view
@@ -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)
usb.cabal view
@@ -1,10 +1,10 @@ name: usb-version: 1.2.0.1+version: 1.3.0.6 cabal-version: >=1.6-build-type: Custom+build-type: Simple license: BSD3 license-file: LICENSE-copyright: 2009–2012 Bas van Dijk <v.dijk.bas@gmail.com>+copyright: 2009–2017 Bas van Dijk <v.dijk.bas@gmail.com> author: Bas van Dijk <v.dijk.bas@gmail.com> maintainer: Bas van Dijk <v.dijk.bas@gmail.com> homepage: http://basvandijk.github.com/usb@@ -16,8 +16,7 @@ @bindings-libusb@ (<http://hackage.haskell.org/package/bindings-libusb>) which is a low-level binding to the C library:- @libusb-1.*@ (<http://libusb.org/>) or its fork:- @libusbx-1.*@ (<http://libusbx.org/>).+ @libusb-1.*@ (<http://libusb.org/>). . The USB transfer functions in this library have a simple synchronous interface (they block) but are implemented using the @libusb@@@ -37,7 +36,7 @@ USB 2.0 specification (<http://www.usb.org/developers/docs/>). . For an example how to use this library see the- @usb-example@ package (<https://github.com/basvandijk/usb-example>)+ @usb-example@ package (<https://github.com/basvandijk/usb-example>) or the @ls-usb@ package (<http://hackage.haskell.org/package/ls-usb>). . Besides this API documentation the following sources might be@@ -45,16 +44,21 @@ . * The @libusb 1.0@ documentation (<http://libusb.sourceforge.net/api-1.0/>). .- * The @libusbx 1.0@ documentation (<http://libusbx.sourceforge.net/api-1.0/>).- . * The USB 2.0 specification (<http://www.usb.org/developers/docs/>). . * The @bindings-libusb@ documentation (<http://hackage.haskell.org/package/bindings-libusb>). . * \"USB in a NutShell\" (<http://www.beyondlogic.org/usbnutshell/usb1.htm>). +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, NEWS+extra-source-files: README.markdown, Changelog source-repository head Type: git@@ -63,28 +67,31 @@ Library GHC-Options: -Wall - build-depends: base >= 4 && < 4.8- , bindings-libusb >= 1.4.4 && < 1.5- , bytestring >= 0.9 && < 0.11- , text >= 0.5 && < 1.2- , vector >= 0.5 && < 0.11+ 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.6+ 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 && < 0.4+ build-depends: ghc-prim >= 0.2