usb 0.8 → 1.0
raw patch · 22 files changed
+2886/−1755 lines, 22 filesdep +containersdep ~basedep ~bindings-libusbsetup-changed
Dependencies added: containers
Dependency ranges changed: base, bindings-libusb
Files
- Event.hs +9/−0
- LICENSE +1/−1
- NEWS +256/−0
- Poll.hsc +29/−0
- README.markdown +49/−0
- Setup.hs +1/−5
- System/USB.hs +3/−3
- System/USB/Base.hs +2226/−0
- System/USB/Descriptors.hs +3/−2
- System/USB/DeviceHandling.hs +2/−2
- System/USB/Enumeration.hs +2/−2
- System/USB/Exceptions.hs +5/−2
- System/USB/IO.hs +69/−0
- System/USB/IO/StandardDeviceRequests.hs +3/−6
- System/USB/IO/Synchronous.hs +0/−41
- System/USB/Initialization.hs +7/−2
- System/USB/Internal.hs +54/−1610
- System/USB/Unsafe.hs +0/−21
- SystemEventManager.hs +33/−0
- Timeval.hs +52/−0
- Utils.hs +5/−4
- usb.cabal +77/−54
+ 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
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2009–2010 Bas van Dijk+Copyright (c) 2009–2011 Bas van Dijk All rights reserved.
+ NEWS view
@@ -0,0 +1,256 @@+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 view
@@ -0,0 +1,29 @@+{-# LANGUAGE UnicodeSyntax, NoImplicitPrelude #-}++#include <poll.h>++module Poll ( toEvent ) where++-- from base:+import Data.Bits ( (.&.) )+import Data.Bool ( otherwise )+import Data.Monoid ( mempty, mappend )+import Foreign.C.Types ( CShort )++-- from base-unicode-symbols:+import Data.Eq.Unicode ( (≢) )++-- from usb:+-- I need to import GHC.Event or System.Event based on the version of base.+-- However it's currently not possible to use cabal macros in .hsc files.+-- See: http://hackage.haskell.org/trac/hackage/ticket/870+-- So I use an intermediate module that makes the choice:+import Event ( Event, evtRead, evtWrite )++toEvent ∷ CShort → Event+toEvent e = remap (#const POLLIN) evtRead `mappend`+ remap (#const POLLOUT) evtWrite+ where+ remap evt to+ | e .&. evt ≢ 0 = to+ | otherwise = mempty
+ README.markdown view
@@ -0,0 +1,49 @@+This library enables you to communicate with USB devices from+userspace. It is implemented as a high-level wrapper around+[bindings-libusb] which is a low-level binding to the C library:+[libusb-1.*].++The USB transfer functions in this library have a simple synchronous+interface (they block) but are implemented using the `libusb`+asynchronous interface. They integrate with the GHC event manager+making them efficient (no busy-loops) and interruptible (throwing an+exception to the thread executing a transfer immediately cancels the+transfer).++If the GHC event manager is not available (because you're either not+using GHC or because you're on Windows) the library degrades+gracefully to the `libusb` synchronous implementation.++The documentation assumes knowledge of how to operate USB devices+from a software standpoint (descriptors, configurations, interfaces,+endpoints, control/bulk/interrupt/isochronous transfers, etc). Full+information can be found in the [USB 2.0 Specification][USB-2.0-spec].++For an example how to use this library see either the [usb-example] or+[ls-usb] package.++Also see the [usb-safe] package which wraps this package and provides+some strong safety guarantees for working with USB devices.++Finally have a look at the [usb-iteratee] package which provides+iteratee enumerators for enumerating bulk, interrupt and isochronous+endpoints.++Besides the API documentation the following sources might be+interesting:++* [The libusb 1.0 documentation](http://libusb.sourceforge.net/api-1.0/)++* [The USB 2.0 specification][USB-2.0-spec]++* [The `bindings-libusb` documentation][bindings-libusb]++* ["USB in a NutShell"](http://www.beyondlogic.org/usbnutshell/usb1.htm)++[bindings-libusb]: http://hackage.haskell.org/package/bindings-libusb+[usb-example]: https://github.com/basvandijk/usb-example+[ls-usb]: http://hackage.haskell.org/package/ls-usb+[usb-safe]: http://hackage.haskell.org/package/usb-safe+[usb-iteratee]: http://hackage.haskell.org/package/usb-iteratee+[libusb-1.*]: http://libusb.org/wiki/libusb-1.0+[USB-2.0-spec]: http://www.usb.org/developers/docs/
Setup.hs view
@@ -27,8 +27,7 @@ ---------------------------------------------------------------------------------- Cabal setup program with support for 'cabal test' and--- which sets the CPP define '__HADDOCK __' when haddock is run.+-- Cabal setup program which sets the CPP define '__HADDOCK __' when haddock is run. ------------------------------------------------------------------------------- main ∷ IO ()@@ -42,6 +41,3 @@ haddockHook simpleUserHooks pkg (lbi { withPrograms = p }) where p = userSpecifyArgs "haddock" ["--optghc=-D__HADDOCK__"] (withPrograms lbi)----- The End ---------------------------------------------------------------------
System/USB.hs view
@@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- -- | -- Module : System.USB--- Copyright : (c) 2009–2010 Bas van Dijk+-- Copyright : (c) 2009–2011 Bas van Dijk -- License : BSD-style (see the file LICENSE) -- Maintainer : Bas van Dijk <v.dijk.bas@gmail.com> --@@ -14,7 +14,7 @@ , module System.USB.Enumeration , module System.USB.DeviceHandling , module System.USB.Descriptors- , module System.USB.IO.Synchronous+ , module System.USB.IO , module System.USB.Exceptions ) where @@ -22,5 +22,5 @@ import System.USB.Enumeration import System.USB.DeviceHandling import System.USB.Descriptors-import System.USB.IO.Synchronous+import System.USB.IO import System.USB.Exceptions
+ System/USB/Base.hs view
@@ -0,0 +1,2226 @@+{-# LANGUAGE CPP, UnicodeSyntax, NoImplicitPrelude, DeriveDataTypeable #-}++#ifdef HAS_EVENT_MANAGER+{-# LANGUAGE ForeignFunctionInterface #-}+#endif++module System.USB.Base where++--------------------------------------------------------------------------------+-- Imports+--------------------------------------------------------------------------------++-- from base:+import Prelude ( Num, (+), (-), (*), Integral, fromIntegral, div+ , Enum, fromEnum, error, String+ )+import Foreign.C.Types ( CUChar, CInt, CUInt )+import Foreign.C.String ( CStringLen )+import Foreign.Marshal.Alloc ( alloca )+import Foreign.Marshal.Array ( peekArray, allocaArray )+import Foreign.Storable ( Storable, peek, peekElemOff )+import Foreign.Ptr ( Ptr, castPtr, plusPtr, nullPtr )+import Foreign.ForeignPtr ( ForeignPtr, newForeignPtr, withForeignPtr)+import Control.Applicative ( liftA2 )+import Control.Exception ( Exception, throwIO, bracket, bracket_, onException, assert )+import Control.Monad ( Monad, (>>=), (=<<), return, when, forM )+import Control.Arrow ( (&&&) )+import Data.Function ( ($), on )+import Data.Data ( Data )+import Data.Typeable ( Typeable )+import Data.Maybe ( Maybe(Nothing, Just), maybe, fromMaybe )+import Data.List ( lookup, map, (++) )+import Data.Int ( Int )+import Data.Word ( Word8, Word16 )+import Data.Eq ( Eq, (==) )+import Data.Ord ( Ord, (<), (>) )+import Data.Bool ( Bool(False, True), not, otherwise )+import Data.Bits ( Bits, (.|.), setBit, testBit, shiftL )+import System.IO ( IO )+import System.IO.Unsafe ( unsafePerformIO )+import Text.Show ( Show, show )+import Text.Read ( Read )+import Text.Printf ( printf )++#if MIN_VERSION_base(4,2,0)+import Data.Functor ( Functor, fmap, (<$>) )+#else+import Control.Monad ( Functor, fmap )+import Control.Applicative ( (<$>) )+#endif++#if __GLASGOW_HASKELL__ < 700+import Prelude ( fromInteger, negate )+import Control.Monad ( (>>), fail )+#endif++-- from base-unicode-symbols:+import Data.Function.Unicode ( (∘) )+import Data.Bool.Unicode ( (∧) )+import Data.Eq.Unicode ( (≢), (≡) )++-- from bytestring:+import qualified Data.ByteString as B ( ByteString, packCStringLen, drop, length )+import qualified Data.ByteString.Internal as BI ( createAndTrim, createAndTrim' )+import qualified Data.ByteString.Unsafe as BU ( unsafeUseAsCStringLen )++-- from text:+import Data.Text ( Text )+import qualified Data.Text.Encoding as TE ( decodeUtf16LE )++-- from bindings-libusb:+import Bindings.Libusb++-- from usb (this package):+import Utils ( bits, between, genToEnum, genFromEnum, mapPeekArray, ifM, decodeBCD )++--------------------------------------------------------------------------------++#ifdef HAS_EVENT_MANAGER+-- from base:+import Prelude ( undefined )+import Foreign.C.Types ( CShort, CChar )+import Foreign.Marshal.Alloc ( allocaBytes, free )+import Foreign.Marshal.Array ( peekArray0, copyArray )+import Foreign.Storable ( sizeOf, poke )+import Foreign.Ptr ( nullFunPtr, freeHaskellFunPtr )+import Control.Monad ( mapM_, foldM_ )+import Data.IORef ( newIORef, atomicModifyIORef, readIORef )+import Data.Function ( id )+import Data.List ( foldl' )+import System.Posix.Types ( Fd(Fd) )+import Control.Exception ( uninterruptibleMask_ )+import Control.Concurrent.MVar ( MVar, newEmptyMVar, takeMVar, putMVar )+import System.IO ( hPutStrLn, stderr )++import qualified Foreign.Concurrent as FC ( newForeignPtr )++#if MIN_VERSION_base(4,4,0)+import GHC.Event+#else+import System.Event+#endif+ ( EventManager+ , FdKey+ , registerFd, unregisterFd+ , registerTimeout, unregisterTimeout+ )++-- from containers:+import Data.IntMap ( IntMap, fromList, insert, updateLookupWithKey, elems )++-- from bytestring:+import qualified Data.ByteString.Internal as BI ( create )++-- from usb (this package):+import Timeval ( withTimeval )+import qualified Poll ( toEvent )+import SystemEventManager ( getSystemEventManager )+#endif++--------------------------------------------------------------------------------++#if MIN_VERSION_base(4,3,0)+import Control.Exception ( mask, mask_ )+#else+import Control.Exception ( blocked, block, unblock )+import Data.Function ( id )++mask ∷ ((IO α → IO α) → IO β) → IO β+mask io = do+ b ← blocked+ if b+ then io id+ else block $ io unblock++mask_ ∷ IO α → IO α+mask_ = block+#endif++#define COMMON_INSTANCES Show, Read, Eq, Data, Typeable++--------------------------------------------------------------------------------+-- * Initialization+--------------------------------------------------------------------------------++{-| Abstract type representing a USB session.++The concept of individual sessions allows your program to use multiple threads+that can independently use this library without interfering with eachother.++Sessions are created and initialized by 'newCtx' and are automatically closed+when they are garbage collected.++The only functions that receive a @Ctx@ are 'setDebug' and 'getDevices'.+-}+data Ctx = Ctx+ {+#ifdef HAS_EVENT_MANAGER+ getEventManager ∷ !(Maybe (EventManager, Maybe (IO ()))),+ -- ^ Retrieve the optional event manager from the context+ -- and the optional 'IO' action for handling events.+#endif+ getCtxFrgnPtr ∷ !(ForeignPtr C'libusb_context)+ } deriving Typeable++instance Eq Ctx where (==) = (==) `on` getCtxFrgnPtr++withCtxPtr ∷ Ctx → (Ptr C'libusb_context → IO α) → IO α+withCtxPtr = withForeignPtr ∘ getCtxFrgnPtr++libusb_init ∷ IO (Ptr C'libusb_context)+libusb_init = alloca $ \ctxPtrPtr → do+ handleUSBException $ c'libusb_init ctxPtrPtr+ peek ctxPtrPtr++newCtxNoEventManager ∷ (ForeignPtr C'libusb_context → Ctx) → IO Ctx+newCtxNoEventManager ctx = mask_ $ do+ ctxPtr ← libusb_init+ ctx <$> newForeignPtr p'libusb_exit ctxPtr++#ifndef HAS_EVENT_MANAGER+-- | Create and initialize a new USB context.+--+-- This function may throw 'USBException's.+newCtx ∷ IO Ctx+newCtx = newCtxNoEventManager Ctx+#else+--------------------------------------------------------------------------------++{-| Create and initialize a new USB context.++This function may throw 'USBException's.++Note that the internal @libusb@ event handling can return errors. These errors+occur in the thread that is executing the event handling loop. 'newCtx' will+print these errors to 'stderr'. If you need to handle the errors yourself (for+example log them in an application specific way) please use 'newCtx''.+-}+newCtx ∷ IO Ctx+newCtx = newCtx' $ \e → hPutStrLn stderr $+ thisModule ++ ": libusb_handle_events_timeout returned error: " ++ show e++-- | Like 'newCtx' but enables you to specify the way errors should be handled+-- that occur while handling @libusb@ events.+newCtx' ∷ (USBException → IO ()) → IO Ctx+newCtx' handleError = do+ mbEvtMgr ← getSystemEventManager+ case mbEvtMgr of+ Nothing → newCtxNoEventManager $ Ctx Nothing+ Just evtMgr → mask_ $ do+ ctxPtr ← libusb_init++ let handleEvents ∷ IO ()+ handleEvents = do+ err ← withTimeval noTimeout $+ c'libusb_handle_events_timeout ctxPtr+ when (err ≢ c'LIBUSB_SUCCESS) $+ if err ≡ c'LIBUSB_ERROR_INTERRUPTED+ then handleEvents+ else handleError $ convertUSBException err++ register ∷ CInt → CShort → IO FdKey+ register fd evt = registerFd evtMgr (\_ _ → handleEvents)+ (Fd fd) (Poll.toEvent evt)++ -- Register initial libusb file descriptors with the event manager:+ pollFdPtrLst ← c'libusb_get_pollfds ctxPtr+ pollFdPtrs ← peekArray0 nullPtr pollFdPtrLst+ fdKeys ← forM pollFdPtrs $ \pollFdPtr → do+ C'libusb_pollfd fd evt ← peek pollFdPtr+ fdKey ← register fd evt+ return (fromIntegral fd, fdKey)+ fdKeyMapRef ← newIORef (fromList fdKeys ∷ IntMap FdKey)+ free pollFdPtrLst++ -- Be notified when libusb file descriptors are added or removed:+ aFP ← mk'libusb_pollfd_added_cb $ \fd evt _ → mask_ $ do+ fdKey ← register fd evt+ atomicModifyIORef fdKeyMapRef $ \fdKeyMap →+ (insert (fromIntegral fd) fdKey fdKeyMap, ())++ rFP ← mk'libusb_pollfd_removed_cb $ \fd _ → mask_ $ do+ fdKey ← atomicModifyIORef fdKeyMapRef $ \fdKeyMap →+ let (Just fdKey, newFdKeyMap) =+ updateLookupWithKey (\_ _ → Nothing)+ (fromIntegral fd)+ fdKeyMap+ in (newFdKeyMap, fdKey)+ unregisterFd evtMgr fdKey++ c'libusb_set_pollfd_notifiers ctxPtr aFP rFP nullPtr++ -- Check if we have to do our own timeout handling:+ r ← c'libusb_pollfds_handle_timeouts ctxPtr+ let mbHandleEvents | r ≡ 0 = Just handleEvents+ | otherwise = Nothing++ fmap (Ctx (Just (evtMgr, mbHandleEvents))) $ FC.newForeignPtr ctxPtr $ do+ -- Remove notifiers after which we can safely free the FunPtrs:+ c'libusb_set_pollfd_notifiers ctxPtr nullFunPtr nullFunPtr nullPtr+ freeHaskellFunPtr aFP+ freeHaskellFunPtr rFP++ -- Unregister all registered file descriptors from the event manager:+ readIORef fdKeyMapRef >>= mapM_ (unregisterFd evtMgr) ∘ elems++ -- Finally deinitialize libusb:+ c'libusb_exit ctxPtr++-- | 'True' if the RTS supports bound threads and 'False' otherwise.+--+-- The asynchronous implementations only work correctly when this is 'True'.+foreign import ccall unsafe "rtsSupportsBoundThreads" threaded ∷ Bool+#endif+--------------------------------------------------------------------------------++{-| Set message verbosity.++The default level is 'PrintNothing'. This means no messages are ever+printed. If you choose to increase the message verbosity level you must ensure+that your application does not close the @stdout@/@stderr@ file descriptors.++You are advised to set the debug level to 'PrintWarnings'. Libusb is+conservative with its message logging. Most of the time it will only log+messages that explain error conditions and other oddities. This will help you+debug your software.++The LIBUSB_DEBUG environment variable overrules the debug level set by this+function. The message verbosity is fixed to the value in the environment+variable if it is defined.++If @libusb@ was compiled without any message logging, this function does nothing:+you'll never get any messages.++If @libusb@ was compiled with verbose debug message logging, this function does+nothing: you'll always get messages from all levels.+-}+setDebug ∷ Ctx → Verbosity → IO ()+setDebug ctx verbosity = withCtxPtr ctx $ \ctxPtr →+ c'libusb_set_debug ctxPtr $ genFromEnum verbosity++-- | Message verbosity+data Verbosity =+ PrintNothing -- ^ No messages are ever printed by the library+ | PrintErrors -- ^ Error messages are printed to stderr+ | PrintWarnings -- ^ Warning and error messages are printed to stderr+ | PrintInfo -- ^ Informational messages are printed to stdout,+ -- warning and error messages are printed to stderr+ deriving (Enum, Ord, COMMON_INSTANCES)++--------------------------------------------------------------------------------+-- * Enumeration+--------------------------------------------------------------------------------++{-| Abstract type representing a USB device detected on the system.++You can only obtain a USB device from the 'getDevices' function.++Certain operations can be performed on a device, but in order to do any I/O you+will have to first obtain a 'DeviceHandle' using 'openDevice'. Alternatively you+can use the @usb-safe@ package which provides type-safe device handling. See:++<http://hackage.haskell.org/package/usb-safe>++Just because you have a reference to a device does not mean it is necessarily+usable. The device may have been unplugged, you may not have permission to+operate such device or another process or driver may be using the device.++To get additional information about a device you can retrieve its descriptor+using 'deviceDesc'.+-}+data Device = Device+ { getCtx ∷ !Ctx -- ^ This reference to the 'Ctx' is needed so that it won't+ -- get garbage collected. The finalizer "p'libusb_exit" is+ -- run only when all references to 'Devices' are gone.++ , getDevFrgnPtr ∷ !(ForeignPtr C'libusb_device)++ , deviceDesc ∷ !DeviceDesc -- ^ Get the descriptor of the device.+ } deriving Typeable++-- | Equality on devices is defined by comparing their descriptors:+-- @(==) = (==) \`on\` `deviceDesc`@+instance Eq Device where (==) = (==) `on` deviceDesc++-- | Devices are shown in the same way as the popular @lsusb@ program:+--+-- @Bus \<busNumber\> Device \<address\>: ID \<vid\>:\<pid\>@+instance Show Device where+ show d = printf "Bus %03d Device %03d: ID %04x:%04x" (busNumber d)+ (deviceAddress d)+ (deviceVendorId desc)+ (deviceProductId desc)+ where+ desc = deviceDesc d++withDevicePtr ∷ Device → (Ptr C'libusb_device → IO α) → IO α+withDevicePtr (Device ctx devFP _) f = withCtxPtr ctx $ \_ →+ withForeignPtr devFP f++{-| Returns a list of USB devices currently attached to the system.++This is your entry point into finding a USB device.++Exceptions:++ * 'NoMemException' on a memory allocation failure.++-}++{-+Visual description of the 'devPtrArrayPtr':++ D+ ^ D+ D │ ^+ ^ │ │+ │ │ │+devPtrArrayPtr: ┏━┷━┳━┷━┳━━━┳━━━┳━┷━┓+ P ───> ┃ P ┃ P ┃ P ┃ P ┃ P ┃+ ┗━━━┻━━━┻━┯━┻━┯━┻━━━┛+ │ │+P = pointer v │+D = device structure D │+ v+ D+-}+getDevices ∷ Ctx → IO [Device]+getDevices ctx =+ withCtxPtr ctx $ \ctxPtr →+ alloca $ \devPtrArrayPtr → mask $ \restore → do+ numDevs ← checkUSBException $ c'libusb_get_device_list ctxPtr+ devPtrArrayPtr+ devPtrArray ← peek devPtrArrayPtr+ let freeDevPtrArray = c'libusb_free_device_list devPtrArray 0+ devs ← restore (mapPeekArray mkDev numDevs devPtrArray)+ `onException` freeDevPtrArray+ freeDevPtrArray+ return devs+ where+ mkDev ∷ Ptr C'libusb_device → IO Device+ mkDev devPtr = liftA2 (Device ctx)+ (newForeignPtr p'libusb_unref_device devPtr)+ (getDeviceDesc devPtr)++-- Both of the following numbers are static variables in the libusb device+-- structure. It's therefore safe to use unsafePerformIO:++-- | The number of the bus that a device is connected to.+busNumber ∷ Device → Word8+busNumber dev = unsafePerformIO $ withDevicePtr dev c'libusb_get_bus_number++-- | The address of the device on the bus it is connected to.+deviceAddress ∷ Device → Word8+deviceAddress dev = unsafePerformIO $ withDevicePtr dev c'libusb_get_device_address++--------------------------------------------------------------------------------+-- * Device handling+--------------------------------------------------------------------------------++--------------------------------------------------------------------------------+-- ** Opening & closing devices+--------------------------------------------------------------------------------++{-| Abstract type representing a handle of a USB device.++You can acquire a handle from 'openDevice'.++A device handle is used to perform I/O and other operations. When finished with+a device handle you should close it by applying 'closeDevice' to it.+-}+data DeviceHandle = DeviceHandle+ { getDevice ∷ !Device -- This reference is needed for keeping the 'Device'+ -- and therefor the 'Ctx' alive.+ -- ^ Retrieve the 'Device' from the 'DeviceHandle'.+ , getDevHndlPtr ∷ !(Ptr C'libusb_device_handle)+ } deriving Typeable++instance Eq DeviceHandle where (==) = (==) `on` getDevHndlPtr++instance Show DeviceHandle where+ show devHndl = "{USB device handle to: " ++ show (getDevice devHndl) ++ "}"++withDevHndlPtr ∷ DeviceHandle → (Ptr C'libusb_device_handle → IO α) → IO α+withDevHndlPtr (DeviceHandle dev devHndlPtr) f = withDevicePtr dev $ \_ →+ f devHndlPtr++{-| Open a device and obtain a device handle.++A handle allows you to perform I/O on the device in question.++This is a non-blocking function; no requests are sent over the bus.++It is advisable to use 'withDeviceHandle' because it automatically closes the+device when the computation terminates.++Exceptions:++ * 'NoMemException' if there is a memory allocation failure.++ * 'AccessException' if the user has insufficient permissions.++ * 'NoDeviceException' if the device has been disconnected.++ * Another 'USBException'.+-}+openDevice ∷ Device → IO DeviceHandle+openDevice dev = withDevicePtr dev $ \devPtr →+ alloca $ \devHndlPtrPtr → do+ handleUSBException $ c'libusb_open devPtr devHndlPtrPtr+ DeviceHandle dev <$> peek devHndlPtrPtr++{-| Close a device handle.++Should be called on all open handles before your application exits.++This is a non-blocking function; no requests are sent over the bus.+-}+closeDevice ∷ DeviceHandle → IO ()+closeDevice devHndl = withDevHndlPtr devHndl c'libusb_close++{-| @withDeviceHandle dev act@ opens the 'Device' @dev@ and passes+the resulting handle to the computation @act@. The handle will be closed on exit+from @withDeviceHandle@ whether by normal termination or by raising an+exception.+-}+withDeviceHandle ∷ Device → (DeviceHandle → IO α) → IO α+withDeviceHandle dev = bracket (openDevice dev) closeDevice++--------------------------------------------------------------------------------+-- ** Getting & setting the configuration+--------------------------------------------------------------------------------++-- | Identifier for configurations.+--+-- Can be retrieved by 'getConfig' or by 'configValue'.+type ConfigValue = Word8++{-| Determine the value of the currently active configuration.++You could formulate your own control request to obtain this information, but+this function has the advantage that it may be able to retrieve the information+from operating system caches (no I/O involved).++If the OS does not cache this information, then this function will block while+a control transfer is submitted to retrieve the information.++This function returns 'Nothing' if the device is in unconfigured state.++Exceptions:++ * 'NoDeviceException' if the device has been disconnected.++ * Another 'USBException'.+-}+getConfig ∷ DeviceHandle → IO (Maybe ConfigValue)+getConfig devHndl =+ alloca $ \configPtr → do+ withDevHndlPtr devHndl $ \devHndlPtr →+ handleUSBException $ c'libusb_get_configuration devHndlPtr configPtr+ unmarshal <$> peek configPtr+ where+ unmarshal 0 = Nothing+ unmarshal n = Just $ fromIntegral n++{-| Set the active configuration for a device.++The operating system may or may not have already set an active configuration on+the device. It is up to your application to ensure the correct configuration is+selected before you attempt to claim interfaces and perform other operations.++If you call this function on a device already configured with the selected+configuration, then this function will act as a lightweight device reset: it+will issue a SET_CONFIGURATION request using the current configuration, causing+most USB-related device state to be reset (altsetting reset to zero, endpoint+halts cleared, toggles reset).++You cannot change/reset configuration if your application has claimed interfaces+- you should free them with 'releaseInterface' first. You cannot change/reset+configuration if other applications or drivers have claimed interfaces.++A configuration value of 'Nothing' will put the device in an unconfigured+state. The USB specification states that a configuration value of 0 does this,+however buggy devices exist which actually have a configuration 0.++You should always use this function rather than formulating your own+SET_CONFIGURATION control request. This is because the underlying operating+system needs to know when such changes happen.++This is a blocking function.++Exceptions:++ * 'NotFoundException' if the requested configuration does not exist.++ * 'BusyException' if interfaces are currently claimed.++ * 'NoDeviceException' if the device has been disconnected++ * Another 'USBException'.+-}+setConfig ∷ DeviceHandle → Maybe ConfigValue → IO ()+setConfig devHndl config =+ withDevHndlPtr devHndl $ \devHndlPtr →+ handleUSBException $ c'libusb_set_configuration devHndlPtr $+ marshal config+ where+ marshal = maybe (-1) fromIntegral++--------------------------------------------------------------------------------+-- ** Claiming & releasing interfaces+--------------------------------------------------------------------------------++{-| Identifier for interfaces.++Can be retrieved by 'interfaceNumber'.+-}+type InterfaceNumber = Word8++{-| Claim an interface on a given device handle.++You must claim the interface you wish to use before you can perform I/O on any+of its endpoints.++It is legal to attempt to claim an already-claimed interface, in which case this+function just returns without doing anything.++Claiming of interfaces is a purely logical operation; it does not cause any+requests to be sent over the bus. Interface claiming is used to instruct the+underlying operating system that your application wishes to take ownership of+the interface.++This is a non-blocking function.++Exceptions:++ * 'NotFoundException' if the requested interface does not exist.++ * 'BusyException' if the interface is already claimed.++ * 'NoDeviceException' if the device has been disconnected.++ * Another 'USBException'.+-}++claimInterface ∷ DeviceHandle → InterfaceNumber → IO ()+claimInterface devHndl ifNum =+ withDevHndlPtr devHndl $ \devHndlPtr →+ handleUSBException $ c'libusb_claim_interface devHndlPtr+ (fromIntegral ifNum)++{-| Release an interface previously claimed with 'claimInterface'.++You should release all claimed interfaces before closing a device handle.++This is a blocking function. A SET_INTERFACE control request will be sent to the+device, resetting interface state to the first alternate setting.++Exceptions:++ * 'NotFoundException' if the interface was not claimed.++ * 'NoDeviceException' if the device has been disconnected++ * Another 'USBException'.+-}+releaseInterface ∷ DeviceHandle → InterfaceNumber → IO ()+releaseInterface devHndl ifNum =+ withDevHndlPtr devHndl $ \devHndlPtr →+ handleUSBException $ c'libusb_release_interface devHndlPtr+ (fromIntegral ifNum)++{-| @withClaimedInterface@ claims the interface on the given device handle then+executes the given computation. On exit from @withClaimedInterface@, the+interface is released whether by normal termination or by raising an exception.+-}+withClaimedInterface ∷ DeviceHandle → InterfaceNumber → IO α → IO α+withClaimedInterface devHndl ifNum = bracket_ (claimInterface devHndl ifNum)+ (releaseInterface devHndl ifNum)++--------------------------------------------------------------------------------+-- ** Setting interface alternate settings+--------------------------------------------------------------------------------++-- | Identifier for interface alternate settings.+--+-- Can be retrieved by 'interfaceAltSetting'.+type InterfaceAltSetting = Word8++{-| Activate an alternate setting for an interface.++The interface must have been previously claimed with 'claimInterface' or+'withInterfaceHandle'.++You should always use this function rather than formulating your own+SET_INTERFACE control request. This is because the underlying operating system+needs to know when such changes happen.++This is a blocking function.++Exceptions:++ * 'NotFoundException' if the interface was not claimed or the requested+ alternate setting does not exist.++ * 'NoDeviceException' if the device has been disconnected.++ * Another 'USBException'.+-}+setInterfaceAltSetting ∷ DeviceHandle+ → InterfaceNumber+ → InterfaceAltSetting+ → IO ()+setInterfaceAltSetting devHndl ifNum alternateSetting =+ withDevHndlPtr devHndl $ \devHndlPtr →+ handleUSBException $+ c'libusb_set_interface_alt_setting devHndlPtr+ (fromIntegral ifNum)+ (fromIntegral alternateSetting)++--------------------------------------------------------------------------------+-- ** Clearing & Resetting devices+--------------------------------------------------------------------------------++{-| Clear the halt/stall condition for an endpoint.++Endpoints with halt status are unable to receive or transmit data until the halt+condition is stalled.++You should cancel all pending transfers before attempting to clear the halt+condition.++This is a blocking function.++Exceptions:++ * 'NotFoundException' if the endpoint does not exist.++ * 'NoDeviceException' if the device has been disconnected.++ * Another 'USBException'.+-}+clearHalt ∷ DeviceHandle → EndpointAddress → IO ()+clearHalt devHndl endpointAddr =+ withDevHndlPtr devHndl $ \devHndlPtr →+ handleUSBException $+ c'libusb_clear_halt devHndlPtr (marshalEndpointAddress endpointAddr)++{-| Perform a USB port reset to reinitialize a device.++The system will attempt to restore the previous configuration and alternate+settings after the reset has completed.++If the reset fails, the descriptors change, or the previous state cannot be+restored, the device will appear to be disconnected and reconnected. This means+that the device handle is no longer valid (you should close it) and rediscover+the device. A 'NotFoundException' is raised to indicate that this is the+case.++This is a blocking function which usually incurs a noticeable delay.++Exceptions:++ * 'NotFoundException' if re-enumeration is required, or if the+ device has been disconnected.++ * Another 'USBException'.+-}+resetDevice ∷ DeviceHandle → IO ()+resetDevice devHndl = withDevHndlPtr devHndl $+ handleUSBException ∘ c'libusb_reset_device++--------------------------------------------------------------------------------+-- ** USB kernel drivers+--------------------------------------------------------------------------------++{-| Determine if a kernel driver is active on an interface.++If a kernel driver is active, you cannot claim the interface, and libusb will be+unable to perform I/O.++Exceptions:++ * 'NoDeviceException' if the device has been disconnected.++ * Another 'USBException'.+-}+kernelDriverActive ∷ DeviceHandle → InterfaceNumber → IO Bool+kernelDriverActive devHndl ifNum =+ withDevHndlPtr devHndl $ \devHndlPtr → do+ r ← c'libusb_kernel_driver_active devHndlPtr (fromIntegral ifNum)+ case r of+ 0 → return False+ 1 → return True+ _ → throwIO $ convertUSBException r++{-| Detach a kernel driver from an interface.++If successful, you will then be able to claim the interface and perform I/O.++Exceptions:++ * 'NotFoundException' if no kernel driver was active.++ * 'InvalidParamException' if the interface does not exist.++ * 'NoDeviceException' if the device has been disconnected.++ * Another 'USBException'.+-}+detachKernelDriver ∷ DeviceHandle → InterfaceNumber → IO ()+detachKernelDriver devHndl ifNum =+ withDevHndlPtr devHndl $ \devHndlPtr →+ handleUSBException $ c'libusb_detach_kernel_driver devHndlPtr+ (fromIntegral ifNum)++{-| Re-attach an interface's kernel driver, which was previously+detached using 'detachKernelDriver'.++Exceptions:++ * 'NotFoundException' if no kernel driver was active.++ * 'InvalidParamException' if the interface does not exist.++ * 'NoDeviceException' if the device has been disconnected.++ * 'BusyException' if the driver cannot be attached because the interface+ is claimed by a program or driver.++ * Another 'USBException'.+-}+attachKernelDriver ∷ DeviceHandle → InterfaceNumber → IO ()+attachKernelDriver devHndl ifNum =+ withDevHndlPtr devHndl $ \devHndlPtr →+ handleUSBException $ c'libusb_attach_kernel_driver devHndlPtr+ (fromIntegral ifNum)++{-| If a kernel driver is active on the specified interface the driver is+detached and the given action is executed. If the action terminates, whether by+normal termination or by raising an exception, the kernel driver is attached+again. If a kernel driver is not active on the specified interface the action is+just executed.++Exceptions:++ * 'NoDeviceException' if the device has been disconnected.++ * Another 'USBException'.+-}+withDetachedKernelDriver ∷ DeviceHandle → InterfaceNumber → IO α → IO α+withDetachedKernelDriver devHndl ifNum action =+ ifM (kernelDriverActive devHndl ifNum)+ (bracket_ (detachKernelDriver devHndl ifNum)+ (attachKernelDriver devHndl ifNum)+ action)+ action++--------------------------------------------------------------------------------+-- * Descriptors+--------------------------------------------------------------------------------++--------------------------------------------------------------------------------+-- ** Device descriptor+--------------------------------------------------------------------------------++{-| A structure representing the standard USB device descriptor.++This descriptor is documented in section 9.6.1 of the USB 2.0 specification.++This structure can be retrieved by 'deviceDesc'.+-}+data DeviceDesc = DeviceDesc+ { -- | USB specification release number.+ deviceUSBSpecReleaseNumber ∷ !ReleaseNumber++ -- | USB-IF class code for the device.+ , deviceClass ∷ !Word8++ -- | USB-IF subclass code for the device, qualified by the 'deviceClass'+ -- value.+ , deviceSubClass ∷ !Word8++ -- | USB-IF protocol code for the device, qualified by the 'deviceClass'+ -- and 'deviceSubClass' values.+ , deviceProtocol ∷ !Word8++ -- | Maximum packet size for endpoint 0.+ , deviceMaxPacketSize0 ∷ !Word8++ -- | USB-IF vendor ID.+ , deviceVendorId ∷ !VendorId++ -- | USB-IF product ID.+ , deviceProductId ∷ !ProductId++ -- | Device release number.+ , deviceReleaseNumber ∷ !ReleaseNumber++ -- | Optional index of string descriptor describing manufacturer.+ , deviceManufacturerStrIx ∷ !(Maybe StrIx)++ -- | Optional index of string descriptor describing product.+ , deviceProductStrIx ∷ !(Maybe StrIx)++ -- | Optional index of string descriptor containing device serial number.+ , deviceSerialNumberStrIx ∷ !(Maybe StrIx)++ -- | Number of possible configurations.+ , deviceNumConfigs ∷ !Word8++ -- | List of configurations supported by the device.+ , deviceConfigs ∷ ![ConfigDesc]+ } deriving (COMMON_INSTANCES)++type ReleaseNumber = (Int, Int, Int, Int)++type VendorId = Word16+type ProductId = Word16++--------------------------------------------------------------------------------+-- ** Configuration descriptor+--------------------------------------------------------------------------------++{-| A structure representing the standard USB configuration descriptor.++This descriptor is documented in section 9.6.3 of the USB 2.0 specification.++This structure can be retrieved by 'deviceConfigs'.+-}+data ConfigDesc = ConfigDesc+ { -- | Identifier value for the configuration.+ configValue ∷ !ConfigValue++ -- | Optional index of string descriptor describing the configuration.+ , configStrIx ∷ !(Maybe StrIx)++ -- | Configuration characteristics.+ , configAttribs ∷ !ConfigAttribs++ -- | Maximum power consumption of the USB device from the bus in the+ -- configuration when the device is fully operational. Expressed in 2 mA+ -- units (i.e., 50 = 100 mA).+ , configMaxPower ∷ !Word8++ -- | Number of interfaces supported by the configuration.+ , configNumInterfaces ∷ !Word8++ -- | List of interfaces supported by the configuration. Note that the+ -- length of this list should equal 'configNumInterfaces'.+ , configInterfaces ∷ ![Interface]++ -- | Extra descriptors. If @libusb@ encounters unknown configuration+ -- descriptors, it will store them here, should you wish to parse them.+ , configExtra ∷ !B.ByteString++ } deriving (COMMON_INSTANCES)++-- | An interface is represented as a list of alternate interface settings.+type Interface = [InterfaceDesc]++--------------------------------------------------------------------------------+-- *** Configuration attributes+--------------------------------------------------------------------------------++-- | The USB 2.0 specification specifies that the configuration attributes only+-- describe the device status.+type ConfigAttribs = DeviceStatus++data DeviceStatus = DeviceStatus+ { remoteWakeup ∷ !Bool -- ^ The Remote Wakeup field indicates whether the+ -- device is currently enabled to request remote+ -- wakeup. The default mode for devices that+ -- support remote wakeup is disabled.+ , selfPowered ∷ !Bool -- ^ The Self Powered field indicates whether the+ -- device is currently self-powered+ } deriving (COMMON_INSTANCES)++--------------------------------------------------------------------------------+-- ** Interface descriptor+--------------------------------------------------------------------------------++{-| A structure representing the standard USB interface descriptor.++This descriptor is documented in section 9.6.5 of the USB 2.0 specification.++This structure can be retrieved using 'configInterfaces'.+-}+data InterfaceDesc = InterfaceDesc+ { -- | Number of the interface.+ interfaceNumber ∷ !InterfaceNumber++ -- | Value used to select the alternate setting for the interface.+ , interfaceAltSetting ∷ !InterfaceAltSetting++ -- | USB-IF class code for the interface.+ , interfaceClass ∷ !Word8++ -- | USB-IF subclass code for the interface, qualified by the+ -- 'interfaceClass' value.+ , interfaceSubClass ∷ !Word8++ -- | USB-IF protocol code for the interface, qualified by the+ -- 'interfaceClass' and 'interfaceSubClass' values.+ , interfaceProtocol ∷ !Word8++ -- | Optional index of string descriptor describing the interface.+ , interfaceStrIx ∷ !(Maybe StrIx)++ -- | List of endpoints supported by the interface.+ , interfaceEndpoints ∷ ![EndpointDesc]++ -- | Extra descriptors. If @libusb@ encounters unknown interface+ -- descriptors, it will store them here, should you wish to parse them.+ , interfaceExtra ∷ !B.ByteString+ } deriving (COMMON_INSTANCES)++--------------------------------------------------------------------------------+-- ** Endpoint descriptor+--------------------------------------------------------------------------------++{-| A structure representing the standard USB endpoint descriptor.++This descriptor is documented in section 9.6.3 of the USB 2.0 specification.++This structure can be retrieved by using 'interfaceEndpoints'.+-}+data EndpointDesc = EndpointDesc+ { -- | The address of the endpoint described by the descriptor.+ endpointAddress ∷ !EndpointAddress++ -- | Attributes which apply to the endpoint when it is configured using the+ -- 'configValue'.+ , endpointAttribs ∷ !EndpointAttribs++ -- | Maximum packet size the endpoint is capable of sending/receiving.+ , endpointMaxPacketSize ∷ !MaxPacketSize++ -- | Interval for polling endpoint for data transfers. Expressed in frames+ -- or microframes depending on the device operating speed (i.e., either 1+ -- millisecond or 125 μs units).+ , endpointInterval ∷ !Word8++ -- | /For audio devices only:/ the rate at which synchronization feedback+ -- is provided.+ , endpointRefresh ∷ !Word8++ -- | /For audio devices only:/ the address of the synch endpoint.+ , endpointSynchAddress ∷ !Word8++ -- | Extra descriptors. If @libusb@ encounters unknown endpoint descriptors,+ -- it will store them here, should you wish to parse them.+ , endpointExtra ∷ !B.ByteString+ } deriving (COMMON_INSTANCES)++--------------------------------------------------------------------------------+-- *** Endpoint address+--------------------------------------------------------------------------------++-- | The address of an endpoint.+data EndpointAddress = EndpointAddress+ { endpointNumber ∷ !Int -- ^ Must be >= 0 and <= 15+ , transferDirection ∷ !TransferDirection+ } deriving (COMMON_INSTANCES)++-- | The direction of data transfer relative to the host.+data TransferDirection = Out -- ^ Out transfer direction (host -> device) used+ -- for writing.+ | In -- ^ In transfer direction (device -> host) used+ -- for reading.+ deriving (COMMON_INSTANCES)++--------------------------------------------------------------------------------+-- *** Endpoint attributes+--------------------------------------------------------------------------------++-- | The USB 2.0 specification specifies that the endpoint attributes only+-- describe the endpoint transfer type.+type EndpointAttribs = TransferType++-- | Describes what types of transfers are allowed on the endpoint.+data TransferType =+ -- | Control transfers are typically used for command and status+ -- operations.+ Control++ -- | Isochronous transfers occur continuously and periodically.+ | Isochronous !Synchronization !Usage++ -- | Bulk transfers can be used for large bursty data.+ | Bulk++ -- | Interrupt transfers are typically non-periodic, small device+ -- \"initiated\" communication requiring bounded latency.+ | Interrupt+ deriving (COMMON_INSTANCES)++-- | See section 5.12.4.1 of the USB 2.0 specification.+data Synchronization =+ NoSynchronization+ | Asynchronous -- ^ Unsynchronized,+ -- although sinks provide data rate feedback.+ | Adaptive -- ^ Synchronized using feedback or feedforward+ -- data rate information+ | Synchronous -- ^ Synchronized to the USB’s SOF (/Start Of Frame/)+ deriving (Enum, COMMON_INSTANCES)++-- | See section 5.12.4.2 of the USB 2.0 specification.+data Usage = Data+ | Feedback+ | Implicit+ deriving (Enum, COMMON_INSTANCES)++--------------------------------------------------------------------------------+-- *** Endpoint max packet size+--------------------------------------------------------------------------------++data MaxPacketSize = MaxPacketSize+ { maxPacketSize ∷ !Size+ , transactionOpportunities ∷ !TransactionOpportunities+ } deriving (COMMON_INSTANCES)++-- | Number of additional transaction oppurtunities per microframe.+--+-- See table 9-13 of the USB 2.0 specification.+data TransactionOpportunities = Zero -- ^ None (1 transaction per microframe)+ | One -- ^ 1 additional (2 per microframe)+ | Two -- ^ 2 additional (3 per microframe)+ deriving (Enum, Ord, COMMON_INSTANCES)++{-| Calculate the maximum packet size which a specific endpoint is capable of+sending or receiving in the duration of 1 microframe.++If acting on an 'Isochronous' or 'Interrupt' endpoint, this function will+multiply the 'maxPacketSize' by the additional 'transactionOpportunities'.+If acting on another type of endpoint only the 'maxPacketSize' is returned.++This function is mainly useful for setting up /isochronous/ transfers.+-}+maxIsoPacketSize ∷ EndpointDesc → Size+maxIsoPacketSize epDesc | isochronousOrInterrupt = mps * (1 + fromEnum to)+ | otherwise = mps+ where+ MaxPacketSize mps to = endpointMaxPacketSize epDesc++ isochronousOrInterrupt = case endpointAttribs epDesc of+ Isochronous _ _ → True+ Interrupt → True+ _ → False++--------------------------------------------------------------------------------+-- ** Retrieving and converting descriptors+--------------------------------------------------------------------------------++getDeviceDesc ∷ Ptr C'libusb_device → IO DeviceDesc+getDeviceDesc devPtr = alloca $ \devDescPtr → do+ handleUSBException $ c'libusb_get_device_descriptor devPtr devDescPtr+ peek devDescPtr >>= convertDeviceDesc devPtr++convertDeviceDesc ∷ Ptr C'libusb_device+ → C'libusb_device_descriptor+ → IO DeviceDesc+convertDeviceDesc devPtr d = do+ let numConfigs = c'libusb_device_descriptor'bNumConfigurations d++ configs ← forM [0..numConfigs-1] $ getConfigDesc devPtr++ return DeviceDesc+ { deviceUSBSpecReleaseNumber = unmarshalReleaseNumber $+ c'libusb_device_descriptor'bcdUSB d+ , deviceClass = c'libusb_device_descriptor'bDeviceClass d+ , deviceSubClass = c'libusb_device_descriptor'bDeviceSubClass d+ , deviceProtocol = c'libusb_device_descriptor'bDeviceProtocol d+ , deviceMaxPacketSize0 = c'libusb_device_descriptor'bMaxPacketSize0 d+ , deviceVendorId = c'libusb_device_descriptor'idVendor d+ , deviceProductId = c'libusb_device_descriptor'idProduct d+ , deviceReleaseNumber = unmarshalReleaseNumber $+ c'libusb_device_descriptor'bcdDevice d+ , deviceManufacturerStrIx = unmarshalStrIx $+ c'libusb_device_descriptor'iManufacturer d+ , deviceProductStrIx = unmarshalStrIx $+ c'libusb_device_descriptor'iProduct d+ , deviceSerialNumberStrIx = unmarshalStrIx $+ c'libusb_device_descriptor'iSerialNumber d+ , deviceNumConfigs = numConfigs+ , deviceConfigs = configs+ }++-- | Unmarshal a a 16bit word as a release number. The 16bit word should be+-- encoded as a Binary Coded Decimal using 4 bits for each of the 4+-- decimals. Also see:+--+-- <http://en.wikipedia.org/wiki/Binary-coded_decimal>+unmarshalReleaseNumber ∷ Word16 → ReleaseNumber+unmarshalReleaseNumber abcd = (a, b, c, d)+ where+ [a, b, c, d] = map fromIntegral $ decodeBCD 4 abcd++-- | Unmarshal an 8bit word to a string descriptor index. 0 denotes that a+-- string descriptor is not available and unmarshals to 'Nothing'.+unmarshalStrIx ∷ Word8 → Maybe StrIx+unmarshalStrIx 0 = Nothing+unmarshalStrIx strIx = Just strIx++getConfigDesc ∷ Ptr C'libusb_device → Word8 → IO ConfigDesc+getConfigDesc devPtr ix = bracket getConfigDescPtr+ c'libusb_free_config_descriptor+ ((convertConfigDesc =<<) ∘ peek)+ where+ getConfigDescPtr = alloca $ \configDescPtrPtr → do+ handleUSBException $ c'libusb_get_config_descriptor+ devPtr+ ix+ configDescPtrPtr+ peek configDescPtrPtr++convertConfigDesc ∷ C'libusb_config_descriptor → IO ConfigDesc+convertConfigDesc c = do+ let numInterfaces = c'libusb_config_descriptor'bNumInterfaces c++ interfaces ← mapPeekArray convertInterface+ (fromIntegral numInterfaces)+ (c'libusb_config_descriptor'interface c)++ extra ← getExtra (c'libusb_config_descriptor'extra c)+ (c'libusb_config_descriptor'extra_length c)++ return ConfigDesc+ { configValue = c'libusb_config_descriptor'bConfigurationValue c+ , configStrIx = unmarshalStrIx $+ c'libusb_config_descriptor'iConfiguration c+ , configAttribs = unmarshalConfigAttribs $+ c'libusb_config_descriptor'bmAttributes c+ , configMaxPower = c'libusb_config_descriptor'MaxPower c+ , configNumInterfaces = numInterfaces+ , configInterfaces = interfaces+ , configExtra = extra+ }++unmarshalConfigAttribs ∷ Word8 → ConfigAttribs+unmarshalConfigAttribs a = DeviceStatus { remoteWakeup = testBit a 5+ , selfPowered = testBit a 6+ }++getExtra ∷ Ptr CUChar → CInt → IO B.ByteString+getExtra extra extraLength = B.packCStringLen ( castPtr extra+ , fromIntegral extraLength+ )++convertInterface ∷ C'libusb_interface → IO [InterfaceDesc]+convertInterface i =+ mapPeekArray convertInterfaceDesc+ (fromIntegral $ c'libusb_interface'num_altsetting i)+ (c'libusb_interface'altsetting i)++convertInterfaceDesc ∷ C'libusb_interface_descriptor → IO InterfaceDesc+convertInterfaceDesc i = do+ let numEndpoints = c'libusb_interface_descriptor'bNumEndpoints i++ endpoints ← mapPeekArray convertEndpointDesc+ (fromIntegral numEndpoints)+ (c'libusb_interface_descriptor'endpoint i)++ extra ← getExtra (c'libusb_interface_descriptor'extra i)+ (c'libusb_interface_descriptor'extra_length i)++ return InterfaceDesc+ { interfaceNumber = c'libusb_interface_descriptor'bInterfaceNumber i+ , interfaceAltSetting = c'libusb_interface_descriptor'bAlternateSetting i+ , interfaceClass = c'libusb_interface_descriptor'bInterfaceClass i+ , interfaceSubClass = c'libusb_interface_descriptor'bInterfaceSubClass i+ , interfaceStrIx = unmarshalStrIx $+ c'libusb_interface_descriptor'iInterface i+ , interfaceProtocol = c'libusb_interface_descriptor'bInterfaceProtocol i+ , interfaceEndpoints = endpoints+ , interfaceExtra = extra+ }++convertEndpointDesc ∷ C'libusb_endpoint_descriptor → IO EndpointDesc+convertEndpointDesc e = do+ extra ← getExtra (c'libusb_endpoint_descriptor'extra e)+ (c'libusb_endpoint_descriptor'extra_length e)++ return EndpointDesc+ { endpointAddress = unmarshalEndpointAddress $+ c'libusb_endpoint_descriptor'bEndpointAddress e+ , endpointAttribs = unmarshalEndpointAttribs $+ c'libusb_endpoint_descriptor'bmAttributes e+ , endpointMaxPacketSize = unmarshalMaxPacketSize $+ c'libusb_endpoint_descriptor'wMaxPacketSize e+ , endpointInterval = c'libusb_endpoint_descriptor'bInterval e+ , endpointRefresh = c'libusb_endpoint_descriptor'bRefresh e+ , endpointSynchAddress = c'libusb_endpoint_descriptor'bSynchAddress e+ , endpointExtra = extra+ }++-- | Unmarshal an 8bit word as an endpoint address. This function is primarily+-- used when unmarshalling USB descriptors.+unmarshalEndpointAddress ∷ Word8 → EndpointAddress+unmarshalEndpointAddress a =+ EndpointAddress { endpointNumber = fromIntegral $ bits 0 3 a+ , transferDirection = if testBit a 7 then In else Out+ }++-- | Marshal an endpoint address so that it can be used by the @libusb@ transfer+-- functions.+marshalEndpointAddress ∷ (Bits α, Num α) ⇒ EndpointAddress → α+marshalEndpointAddress (EndpointAddress num transDir) =+ assert (between num 0 15) $ let n = fromIntegral num+ in case transDir of+ Out → n+ In → setBit n 7++unmarshalEndpointAttribs ∷ Word8 → EndpointAttribs+unmarshalEndpointAttribs a =+ case bits 0 1 a of+ 0 → Control+ 1 → Isochronous (genToEnum $ bits 2 3 a)+ (genToEnum $ bits 4 5 a)+ 2 → Bulk+ 3 → Interrupt+ _ → moduleError "unmarshalEndpointAttribs: this can't happen!"++unmarshalMaxPacketSize ∷ Word16 → MaxPacketSize+unmarshalMaxPacketSize m =+ MaxPacketSize+ { maxPacketSize = fromIntegral $ bits 0 10 m+ , transactionOpportunities = genToEnum $ bits 11 12 m+ }++--------------------------------------------------------------------------------+-- ** String descriptors+--------------------------------------------------------------------------------++-- | The size in number of bytes of the header of string descriptors.+strDescHeaderSize ∷ Size+strDescHeaderSize = 2++-- | Characters are encoded as UTF16LE so each character takes two bytes.+charSize ∷ Size+charSize = 2++{-| Retrieve a list of supported languages.++This function may throw 'USBException's.+-}+getLanguages ∷ DeviceHandle → IO [LangId]+getLanguages devHndl = allocaArray maxSize $ \dataPtr → do+ reportedSize ← write dataPtr++ let strSize = (reportedSize - strDescHeaderSize) `div` charSize+ strPtr = castPtr $ dataPtr `plusPtr` strDescHeaderSize++ map unmarshalLangId <$> peekArray strSize strPtr+ where+ maxSize = 255 -- Some devices choke on size > 255+ write = putStrDesc devHndl 0 0 maxSize++{-| @putStrDesc devHndl strIx langId maxSize dataPtr@ retrieves the+string descriptor @strIx@ in the language @langId@ from the @devHndl@+and writes at most @maxSize@ bytes from that string descriptor to the+location that @dataPtr@ points to. So ensure there is at least space+for @maxSize@ bytes there. Next, the header of the string descriptor+is checked for correctness. If it's incorrect an 'IOException' is+thrown. Finally, the size reported in the header is returned.+-}+putStrDesc ∷ DeviceHandle+ → StrIx+ → Word16+ → Size+ → Ptr CUChar+ → IO Size+putStrDesc devHndl strIx langId maxSize dataPtr = do+ actualSize ← withDevHndlPtr devHndl $ \devHndlPtr →+ checkUSBException $ c'libusb_get_string_descriptor+ devHndlPtr+ strIx+ langId+ dataPtr+ (fromIntegral maxSize)+ when (actualSize < strDescHeaderSize) $+ throwIO $ IOException "Incomplete header"++ reportedSize ← peek dataPtr++ when (reportedSize > fromIntegral actualSize) $+ throwIO $ IOException "Not enough space to hold data"++ descType ← peekElemOff dataPtr 1++ when (descType ≢ c'LIBUSB_DT_STRING) $+ throwIO $ IOException "Invalid header"++ return $ fromIntegral reportedSize++{-| The language ID consists of the primary language identifier and the+sublanguage identififier as described in:++<http://www.usb.org/developers/docs/USB_LANGIDs.pdf>++For a mapping between IDs and languages see the @usb-id-database@ package at:++<http://hackage.haskell.org/package/usb-id-database>++To see which 'LangId's are supported by a device see 'getLanguages'.+-}+type LangId = (PrimaryLangId, SubLangId)+type PrimaryLangId = Word16+type SubLangId = Word16++unmarshalLangId ∷ Word16 → LangId+unmarshalLangId = bits 0 9 &&& bits 10 15++marshalLangId ∷ LangId → Word16+marshalLangId (p, s) = p .|. s `shiftL`10++-- | Type of indici of string descriptors.+--+-- Can be retrieved by all the *StrIx functions.+type StrIx = Word8++{-| Retrieve a string descriptor from a device.++This function may throw 'USBException's.+-}+getStrDesc ∷ DeviceHandle+ → StrIx+ → LangId+ → Int -- ^ Maximum number of characters in the requested string. An+ -- 'IOException' will be thrown when the requested string is+ -- larger than this number.+ → IO Text+getStrDesc devHndl strIx langId nrOfChars = assert (strIx ≢ 0) $+ fmap decode $ BI.createAndTrim size $ write ∘ castPtr+ where+ write = putStrDesc devHndl strIx (marshalLangId langId) size+ size = strDescHeaderSize + nrOfChars * charSize+ decode = TE.decodeUtf16LE ∘ B.drop strDescHeaderSize++{-| Retrieve a string descriptor from a device using the first supported language.++This function may throw 'USBException's.+-}+getStrDescFirstLang ∷ DeviceHandle+ → StrIx+ → Int -- ^ Maximum number of characters in the requested+ -- string. An 'IOException' will be thrown when the+ -- requested string is larger than this number.+ → IO Text+getStrDescFirstLang devHndl strIx nrOfChars = do+ langIds ← getLanguages devHndl+ case langIds of+ [] → throwIO $ IOException "Zero languages"+ langId : _ → getStrDesc devHndl strIx langId nrOfChars++--------------------------------------------------------------------------------+-- * I/O+--------------------------------------------------------------------------------++{-| Handy type synonym for read transfers.++A @ReadAction@ is a function which takes a 'Size' which defines how many bytes+to read and a 'Timeout'. The function returns an 'IO' action which, when+executed, performs the actual read and returns the 'B.ByteString' that was read+paired with a 'Status' flag which indicates whether the transfer+'Completed' or 'TimedOut'.+-}+type ReadAction = Size → Timeout → IO (B.ByteString, Status)++-- | Handy type synonym for read transfers that must exactly read the specified+-- number of bytes. An 'incompleteReadException' is thrown otherwise.+type ReadExactAction = Size → Timeout → IO B.ByteString++{-| Handy type synonym for write transfers.++A @WriteAction@ is a function which takes a 'B.ByteString' to write and a+'Timeout'. The function returns an 'IO' action which, when exectued, returns the+number of bytes that were actually written paired with a 'Status' flag which+indicates whether the transfer 'Completed' or 'TimedOut'.+-}+type WriteAction = B.ByteString → Timeout → IO (Size, Status)++-- | Handy type synonym for write transfers that must exactly write all the+-- given bytes. An 'incompleteWriteException' is thrown otherwise.+type WriteExactAction = B.ByteString → Timeout → IO ()++-- | Number of bytes transferred.+type Size = Int++-- | A timeout in milliseconds. A timeout defines how long a transfer should wait+-- before giving up due to no response being received.+-- Use 'noTimeout' for no timeout.+type Timeout = Int++-- | A timeout of 0 denotes no timeout so: @noTimeout = 0@.+noTimeout ∷ Timeout+noTimeout = 0++-- | Status of a terminated transfer.+data Status = Completed -- ^ All bytes were transferred+ -- within the maximum allowed 'Timeout' period.+ | TimedOut -- ^ Not all bytes were transferred+ -- within the maximum allowed 'Timeout' period.+ deriving (COMMON_INSTANCES)++-------------------------------------------------------------------------------+-- ** Types of control transfers+-------------------------------------------------------------------------------++-- | Handy type synonym that names the parameters of a control transfer.+type ControlAction α = RequestType → Recipient → Request → Value → Index → α++data RequestType = Standard+ | Class+ | Vendor+ deriving (Enum, COMMON_INSTANCES)++data Recipient = ToDevice+ | ToInterface+ | ToEndpoint+ | ToOther+ deriving (Enum, COMMON_INSTANCES)++type Request = Word8++-- | (Host-endian)+type Value = Word16++-- | (Host-endian)+type Index = Word16++marshalRequestType ∷ RequestType → Recipient → Word8+marshalRequestType t r = genFromEnum t `shiftL` 5 .|. genFromEnum r++--------------------------------------------------------------------------------+-- ** Control transfers+--------------------------------------------------------------------------------++{-| Perform a USB /control/ request that does not transfer data.++Exceptions:++ * 'TimeoutException' if the transfer timed out.++ * 'PipeException' if the control request was not supported by the device++ * 'NoDeviceException' if the device has been disconnected.++ * Another 'USBException'.+-}+control ∷ DeviceHandle → ControlAction (Timeout → IO ())+control devHndl reqType reqRecipient request value index timeout = do+ (_, status) ← doControl+ when (status ≡ TimedOut) $ throwIO TimeoutException+ where+ doControl+#ifdef HAS_EVENT_MANAGER+ | threaded = allocaBytes controlSetupSize $ \bufferPtr → do+ poke bufferPtr $ C'libusb_control_setup requestType+ request value index+ 0+ transferAsync c'LIBUSB_TRANSFER_TYPE_CONTROL+ devHndl+ controlEndpoint+ timeout+ (bufferPtr, controlSetupSize)+#endif+ | otherwise = controlTransferSync devHndl+ requestType+ request value index+ timeout+ (nullPtr, 0)+ requestType = marshalRequestType reqType reqRecipient++--------------------------------------------------------------------------------++{-| Perform a USB /control/ read.++Exceptions:++ * 'PipeException' if the control request was not supported by the device++ * 'NoDeviceException' if the device has been disconnected.++ * Another 'USBException'.+-}+readControl ∷ DeviceHandle → ControlAction ReadAction+readControl devHndl reqType reqRecipient request value index size timeout+#ifdef HAS_EVENT_MANAGER+ | threaded = do+ let totalSize = controlSetupSize + size+ allocaBytes totalSize $ \bufferPtr → do+ poke bufferPtr $ C'libusb_control_setup requestType+ request value index+ (fromIntegral size)+ (transferred, status) ← transferAsync c'LIBUSB_TRANSFER_TYPE_CONTROL+ devHndl controlEndpoint+ timeout+ (bufferPtr, totalSize)+ bs ← BI.create transferred $ \dataPtr →+ copyArray dataPtr (bufferPtr `plusPtr` controlSetupSize) transferred+ return (bs, status)+#endif+ | otherwise = createAndTrimNoOffset size $ \dataPtr →+ controlTransferSync devHndl+ requestType+ request value index+ timeout+ (dataPtr, size)+ where+ requestType = marshalRequestType reqType reqRecipient `setBit` 7++-- | A convenience function similar to 'readControl' which checks if the+-- specified number of bytes to read were actually read.+-- Throws an 'incompleteReadException' if this is not the case.+readControlExact ∷ DeviceHandle → ControlAction ReadExactAction+readControlExact devHndl+ reqType reqRecipient request value index+ size timeout = do+ (bs, _) ← readControl devHndl+ reqType reqRecipient request value index+ size timeout+ if B.length bs ≢ size+ then throwIO incompleteReadException+ else return bs++--------------------------------------------------------------------------------+++{-| Perform a USB /control/ write.++Exceptions:++ * 'PipeException' if the control request was not supported by the device++ * 'NoDeviceException' if the device has been disconnected.++ * Another 'USBException'.+-}+writeControl ∷ DeviceHandle → ControlAction WriteAction+writeControl devHndl reqType reqRecipient request value index input timeout+#ifdef HAS_EVENT_MANAGER+ | threaded = BU.unsafeUseAsCStringLen input $ \(dataPtr, size) → do+ let totalSize = controlSetupSize + size+ allocaBytes totalSize $ \bufferPtr → do+ poke bufferPtr $ C'libusb_control_setup requestType+ request value index+ (fromIntegral size)+ copyArray (bufferPtr `plusPtr` controlSetupSize) dataPtr size+ transferAsync c'LIBUSB_TRANSFER_TYPE_CONTROL+ devHndl controlEndpoint+ timeout+ (bufferPtr, totalSize)+#endif+ | otherwise = BU.unsafeUseAsCStringLen input $+ controlTransferSync devHndl+ requestType+ request value index+ timeout+ where+ requestType = marshalRequestType reqType reqRecipient++-- | A convenience function similar to 'writeControl' which checks if the given+-- bytes were actually fully written.+-- Throws an 'incompleteWriteException' if this is not the case.+writeControlExact ∷ DeviceHandle → ControlAction WriteExactAction+writeControlExact devHndl+ reqType reqRecipient request value index+ input timeout = do+ (transferred, _) ← writeControl devHndl+ reqType reqRecipient request value index+ input timeout+ when (transferred ≢ B.length input) $ throwIO incompleteWriteException++--------------------------------------------------------------------------------++#ifdef HAS_EVENT_MANAGER+controlSetupSize ∷ Size+controlSetupSize = sizeOf (undefined ∷ C'libusb_control_setup)++controlEndpoint ∷ CUChar+controlEndpoint = 0+#endif++controlTransferSync ∷ DeviceHandle+ → Word8 → Request → Value → Index+ → Timeout+ → (Ptr byte, Size)+ → IO (Size, Status)+controlTransferSync devHndl+ reqType request value index+ timeout+ (dataPtr, size) = do+ err ← withDevHndlPtr devHndl $ \devHndlPtr →+ c'libusb_control_transfer devHndlPtr+ reqType request value index+ (castPtr dataPtr) (fromIntegral size)+ (fromIntegral timeout)+ let timedOut = err ≡ c'LIBUSB_ERROR_TIMEOUT+ if err < 0 ∧ not timedOut+ then throwIO $ convertUSBException err+ else return ( fromIntegral err+ , if timedOut then TimedOut else Completed+ )++--------------------------------------------------------------------------------+-- ** Bulk transfers+--------------------------------------------------------------------------------++{-| Perform a USB /bulk/ read.++Exceptions:++ * 'PipeException' if the endpoint halted.++ * 'OverflowException' if the device offered more data,+ see /Packets and overflows/ in the @libusb@ documentation:+ <http://libusb.sourceforge.net/api-1.0/packetoverflow.html>.++ * 'NoDeviceException' if the device has been disconnected.++ * Another 'USBException'.+-}+readBulk ∷ DeviceHandle → EndpointAddress → ReadAction+readBulk+#ifdef HAS_EVENT_MANAGER+ | threaded = readTransferAsync c'LIBUSB_TRANSFER_TYPE_BULK+#endif+ | otherwise = readTransferSync c'libusb_bulk_transfer++{-| Perform a USB /bulk/ write.++Exceptions:++ * 'PipeException' if the endpoint halted.++ * 'OverflowException' if the device offered more data,+ see /Packets and overflows/ in the @libusb@ documentation:+ <http://libusb.sourceforge.net/api-1.0/packetoverflow.html>.++ * 'NoDeviceException' if the device has been disconnected.++ * Another 'USBException'.+-}+writeBulk ∷ DeviceHandle → EndpointAddress → WriteAction+writeBulk+#ifdef HAS_EVENT_MANAGER+ | threaded = writeTransferAsync c'LIBUSB_TRANSFER_TYPE_BULK+#endif+ | otherwise = writeTransferSync c'libusb_bulk_transfer++--------------------------------------------------------------------------------+-- ** Interrupt transfers+--------------------------------------------------------------------------------++{-| Perform a USB /interrupt/ read.++Exceptions:++ * 'PipeException' if the endpoint halted.++ * 'OverflowException' if the device offered more data,+ see /Packets and overflows/ in the libusb documentation:+ <http://libusb.sourceforge.net/api-1.0/packetoverflow.html>.++ * 'NoDeviceException' if the device has been disconnected.++ * Another 'USBException'.+-}+readInterrupt ∷ DeviceHandle → EndpointAddress → ReadAction+readInterrupt+#ifdef HAS_EVENT_MANAGER+ | threaded = readTransferAsync c'LIBUSB_TRANSFER_TYPE_INTERRUPT+#endif+ | otherwise = readTransferSync c'libusb_interrupt_transfer+++{-| Perform a USB /interrupt/ write.++Exceptions:++ * 'PipeException' if the endpoint halted.++ * 'OverflowException' if the device offered more data,+ see /Packets and overflows/ in the @libusb@ documentation:+ <http://libusb.sourceforge.net/api-1.0/packetoverflow.html>.++ * 'NoDeviceException' if the device has been disconnected.++ * Another 'USBException'.+-}+writeInterrupt ∷ DeviceHandle → EndpointAddress → WriteAction+writeInterrupt+#ifdef HAS_EVENT_MANAGER+ | threaded = writeTransferAsync c'LIBUSB_TRANSFER_TYPE_INTERRUPT+#endif+ | otherwise = writeTransferSync c'libusb_interrupt_transfer++--------------------------------------------------------------------------------++-- | Handy type synonym for the @libusb@ transfer functions.+type C'TransferFunc = Ptr C'libusb_device_handle -- devHndlPtr+ → CUChar -- endpoint address+ → Ptr CUChar -- dataPtr+ → CInt -- size+ → Ptr CInt -- transferredPtr+ → CUInt -- timeout+ → IO CInt -- error++readTransferSync ∷ C'TransferFunc → (DeviceHandle → EndpointAddress → ReadAction)+readTransferSync c'transfer = \devHndl endpointAddr → \size timeout →+ createAndTrimNoOffset size $ \dataPtr →+ transferSync c'transfer+ devHndl endpointAddr+ timeout+ (castPtr dataPtr, size)++writeTransferSync ∷ C'TransferFunc → (DeviceHandle → EndpointAddress → WriteAction)+writeTransferSync c'transfer = \devHndl endpointAddr → \input timeout →+ BU.unsafeUseAsCStringLen input $+ transferSync c'transfer+ devHndl endpointAddr+ timeout++transferSync ∷ C'TransferFunc → DeviceHandle+ → EndpointAddress+ → Timeout+ → CStringLen+ → IO (Size, Status)+transferSync c'transfer devHndl+ endpointAddr+ timeout+ (dataPtr, size) =+ alloca $ \transferredPtr → do+ err ← withDevHndlPtr devHndl $ \devHndlPtr →+ c'transfer devHndlPtr+ (marshalEndpointAddress endpointAddr)+ (castPtr dataPtr)+ (fromIntegral size)+ transferredPtr+ (fromIntegral timeout)+ let timedOut = err ≡ c'LIBUSB_ERROR_TIMEOUT+ if err ≢ c'LIBUSB_SUCCESS ∧ not timedOut+ then throwIO $ convertUSBException err+ else do transferred ← peek transferredPtr+ return ( fromIntegral transferred+ , if timedOut then TimedOut else Completed+ )++--------------------------------------------------------------------------------++#ifdef HAS_EVENT_MANAGER+readTransferAsync ∷ C'TransferType → DeviceHandle → EndpointAddress → ReadAction+readTransferAsync transType = \devHndl endpointAddr → \size timeout →+ createAndTrimNoOffset size $ \bufferPtr →+ transferAsync transType+ devHndl (marshalEndpointAddress endpointAddr)+ timeout+ (bufferPtr, size)++writeTransferAsync ∷ C'TransferType → DeviceHandle → EndpointAddress → WriteAction+writeTransferAsync transType = \devHndl endpointAddr → \input timeout →+ BU.unsafeUseAsCStringLen input $+ transferAsync transType+ devHndl (marshalEndpointAddress endpointAddr)+ timeout++--------------------------------------------------------------------------------++type C'TransferType = CUChar++transferAsync ∷ C'TransferType+ → DeviceHandle → CUChar -- ^ Encoded endpoint address+ → Timeout+ → (Ptr byte, Size)+ → IO (Size, Status)+transferAsync transType devHndl endpoint timeout bytes =+ withTerminatedTransfer transType+ 0 []+ devHndl endpoint+ timeout+ bytes+ (continue Completed)+ (continue TimedOut)+ where+ continue status transPtr = do+ n ← peek $ p'libusb_transfer'actual_length transPtr+ return (fromIntegral n, status)++--------------------------------------------------------------------------------++withTerminatedTransfer ∷ C'TransferType+ → Int → [C'libusb_iso_packet_descriptor]+ → DeviceHandle → CUChar -- ^ Encoded endpoint address+ → Timeout+ → (Ptr byte, Size)+ → (Ptr C'libusb_transfer → IO α)+ → (Ptr C'libusb_transfer → IO α)+ → IO α+withTerminatedTransfer transType+ nrOfIsoPackets isoPackageDescs+ devHndl endpoint+ timeout+ (bufferPtr, size)+ onCompletion+ onTimeout =+ withDevHndlPtr devHndl $ \devHndlPtr →+ allocaTransfer nrOfIsoPackets $ \transPtr → do++ lock ← newLock+ let Just (evtMgr, mbHandleEvents) = getEventManager $+ getCtx $+ getDevice devHndl+ waitForTermination =+ case mbHandleEvents of+ Just handleEvents | timeout ≢ noTimeout → do+ tk ← registerTimeout evtMgr (timeout * 1000) handleEvents+ acquire lock+ `onException`+ (uninterruptibleMask_ $ do+ unregisterTimeout evtMgr tk+ _err ← c'libusb_cancel_transfer transPtr+ acquire lock)+ _ → acquire lock+ `onException`+ (uninterruptibleMask_ $ do+ _err ← c'libusb_cancel_transfer transPtr+ acquire lock)+ withCallback (\_ → release lock) $ \cbPtr → do++ poke transPtr $ C'libusb_transfer+ { c'libusb_transfer'dev_handle = devHndlPtr+ , c'libusb_transfer'flags = 0 -- unused+ , c'libusb_transfer'endpoint = endpoint+ , c'libusb_transfer'type = transType+ , c'libusb_transfer'timeout = fromIntegral timeout+ , c'libusb_transfer'status = 0 -- output+ , c'libusb_transfer'length = fromIntegral size+ , c'libusb_transfer'actual_length = 0 -- output+ , c'libusb_transfer'callback = cbPtr+ , c'libusb_transfer'user_data = nullPtr -- unused+ , c'libusb_transfer'buffer = castPtr bufferPtr+ , c'libusb_transfer'num_iso_packets = fromIntegral nrOfIsoPackets+ , c'libusb_transfer'iso_packet_desc = isoPackageDescs+ }++ mask_ $ do+ handleUSBException $ c'libusb_submit_transfer transPtr+ waitForTermination++ status ← peek $ p'libusb_transfer'status transPtr+ case status of+ ts | ts ≡ c'LIBUSB_TRANSFER_COMPLETED → onCompletion transPtr+ | ts ≡ c'LIBUSB_TRANSFER_TIMED_OUT → onTimeout transPtr++ | ts ≡ c'LIBUSB_TRANSFER_ERROR → throwIO ioException+ | ts ≡ c'LIBUSB_TRANSFER_NO_DEVICE → throwIO NoDeviceException+ | ts ≡ c'LIBUSB_TRANSFER_OVERFLOW → throwIO OverflowException+ | ts ≡ c'LIBUSB_TRANSFER_STALL → throwIO PipeException++ | ts ≡ c'LIBUSB_TRANSFER_CANCELLED →+ moduleError "transfer status can't be Cancelled!"++ | otherwise → moduleError $ "Unknown transfer status: " ++ show ts ++ "!"++--------------------------------------------------------------------------------++-- | Allocate a transfer with the given number of isochronous packets and apply+-- the function to the resulting pointer. The transfer is automatically freed+-- when the function terminates (whether normally or by raising an exception).+--+-- A 'NoMemException' may be thrown.+allocaTransfer ∷ Int → (Ptr C'libusb_transfer → IO α) → IO α+allocaTransfer nrOfIsoPackets = bracket mallocTransfer c'libusb_free_transfer+ where+ mallocTransfer = do+ transPtr ← c'libusb_alloc_transfer (fromIntegral nrOfIsoPackets)+ when (transPtr ≡ nullPtr) (throwIO NoMemException)+ return transPtr++--------------------------------------------------------------------------------++-- | Create a 'FunPtr' to the given transfer callback function and pass it to+-- the continuation function. The 'FunPtr' is automatically freed when the+-- continuation terminates (whether normally or by raising an exception).+withCallback ∷ (Ptr C'libusb_transfer → IO ())+ → (C'libusb_transfer_cb_fn → IO α)+ → IO α+withCallback cb = bracket (mk'libusb_transfer_cb_fn cb) freeHaskellFunPtr++--------------------------------------------------------------------------------++-- | A lock is in one of two states: \"locked\" or \"unlocked\".+newtype Lock = Lock (MVar ()) deriving Eq++-- | Create a lock in the \"unlocked\" state.+newLock ∷ IO Lock+newLock = Lock <$> newEmptyMVar++{-|+Acquires the 'Lock'. Blocks if another thread has acquired the 'Lock'.++@acquire@ behaves as follows:++* When the state is \"unlocked\" @acquire@ changes the state to \"locked\".++* When the state is \"locked\" @acquire@ /blocks/ until a call to 'release' in+another thread wakes the calling thread. Upon awakening it will change the state+to \"locked\".+-}+acquire ∷ Lock → IO ()+acquire (Lock mv) = takeMVar mv++{-|+@release@ changes the state to \"unlocked\" and returns immediately.++The behaviour is undefined when a lock in the \"unlocked\" state is released!++If there are any threads blocked on 'acquire' the thread that first called+@acquire@ will be woken up.+-}+release ∷ Lock → IO ()+release (Lock mv) = putMVar mv ()++--------------------------------------------------------------------------------+-- ** Isochronous transfers+--------------------------------------------------------------------------------++{-| Perform a USB /isochronous/ read.++/WARNING:/ You need to enable the threaded runtime (@-threaded@) for this+function to work correctly. It throws a runtime error otherwise!++Exceptions:++ * 'PipeException' if the endpoint halted.++ * 'OverflowException' if the device offered more data,+ see /Packets and overflows/ in the @libusb@ documentation:+ <http://libusb.sourceforge.net/api-1.0/packetoverflow.html>.++ * 'NoDeviceException' if the device has been disconnected.++ * Another 'USBException'.+-}+readIsochronous ∷ DeviceHandle+ → EndpointAddress+ → [Size] -- ^ Sizes of isochronous packets+ → Timeout+ → IO [B.ByteString]+readIsochronous devHndl endpointAddr sizes timeout+ | not threaded = needThreadedRTSError "readIsochronous"+ | otherwise = do+ let SumLength totalSize nrOfIsoPackets = sumLength sizes+ allocaBytes totalSize $ \bufferPtr →+ withTerminatedTransfer c'LIBUSB_TRANSFER_TYPE_ISOCHRONOUS+ nrOfIsoPackets (map initIsoPacketDesc sizes)+ devHndl+ (marshalEndpointAddress endpointAddr)+ timeout+ (bufferPtr, totalSize)+ (\transPtr → convertIsos nrOfIsoPackets+ transPtr+ bufferPtr)+ (\_ → throwIO TimeoutException)++--------------------------------------------------------------------------------++{-| Perform a USB /isochronous/ write.++/WARNING:/ You need to enable the threaded runtime (@-threaded@) for this+function to work correctly. It throws a runtime error otherwise!++Exceptions:++ * 'PipeException' if the endpoint halted.++ * 'OverflowException' if the device offered more data,+ see /Packets and overflows/ in the @libusb@ documentation:+ <http://libusb.sourceforge.net/api-1.0/packetoverflow.html>.++ * 'NoDeviceException' if the device has been disconnected.++ * Another 'USBException'.+-}+writeIsochronous ∷ DeviceHandle+ → EndpointAddress+ → [B.ByteString]+ → Timeout+ → IO [Size]+writeIsochronous devHndl endpointAddr isoPackets timeout+ | not threaded = needThreadedRTSError "writeIsochronous"+ | otherwise = do+ let sizes = map B.length isoPackets+ SumLength totalSize nrOfIsoPackets = sumLength sizes+ allocaBytes totalSize $ \bufferPtr → do+ copyIsos (castPtr bufferPtr) isoPackets+ withTerminatedTransfer c'LIBUSB_TRANSFER_TYPE_ISOCHRONOUS+ nrOfIsoPackets (map initIsoPacketDesc sizes)+ devHndl+ (marshalEndpointAddress endpointAddr)+ timeout+ (bufferPtr, totalSize)+ (\transPtr →+ map actualLength <$> peekIsoPacketDescs+ nrOfIsoPackets+ transPtr)+ (\_ → throwIO TimeoutException)++--------------------------------------------------------------------------------++actualLength ∷ C'libusb_iso_packet_descriptor → Size+actualLength = fromIntegral ∘ c'libusb_iso_packet_descriptor'actual_length++-- | Simultaneously calculate the sum and length of the given list.+sumLength ∷ [Int] → SumLength+sumLength = foldl' (\(SumLength s l) x → SumLength (s+x) (l+1)) (SumLength 0 0)++-- | Strict pair of sum and length.+data SumLength = SumLength !Int !Int++-- | An isochronous packet descriptor with all fields zero except for the length.+initIsoPacketDesc ∷ Size → C'libusb_iso_packet_descriptor+initIsoPacketDesc size =+ C'libusb_iso_packet_descriptor+ { c'libusb_iso_packet_descriptor'length = fromIntegral size+ , c'libusb_iso_packet_descriptor'actual_length = 0+ , c'libusb_iso_packet_descriptor'status = 0+ }++convertIsos ∷ Int → Ptr C'libusb_transfer → Ptr Word8 → IO [B.ByteString]+convertIsos nrOfIsoPackets transPtr bufferPtr =+ peekIsoPacketDescs nrOfIsoPackets transPtr >>= go bufferPtr id+ where+ go _ bss [] = return $ bss []+ go ptr bss (C'libusb_iso_packet_descriptor l a _ : ds) = do+ let transferred = fromIntegral a+ bs ← BI.create transferred $ \p → copyArray p ptr transferred+ go (ptr `plusPtr` fromIntegral l) (bss ∘ (bs:)) ds++-- | Retrieve the isochronous packet descriptors from the given transfer.+peekIsoPacketDescs ∷ Int+ → Ptr C'libusb_transfer+ → IO [C'libusb_iso_packet_descriptor]+peekIsoPacketDescs nrOfIsoPackets = peekArray nrOfIsoPackets+ ∘ p'libusb_transfer'iso_packet_desc++copyIsos ∷ Ptr CChar → [B.ByteString] → IO ()+copyIsos = foldM_ $ \bufferPtr bs →+ BU.unsafeUseAsCStringLen bs $ \(ptr, len) → do+ copyArray bufferPtr ptr len+ return $ bufferPtr `plusPtr` len+#endif++--------------------------------------------------------------------------------++createAndTrimNoOffset ∷ Size → (Ptr Word8 → IO (Size, α)) → IO (B.ByteString, α)+createAndTrimNoOffset size f = BI.createAndTrim' size $ \ptr → do+ (l, x) ← f ptr+ return (offset, l, x)+ where+ offset = 0++--------------------------------------------------------------------------------+-- * Exceptions+--------------------------------------------------------------------------------++-- | @handleUSBException action@ executes @action@. If @action@ returned an+-- error code other than 'c\'LIBUSB_SUCCESS', the error is converted to a+-- 'USBException' and thrown.+handleUSBException ∷ IO CInt → IO ()+handleUSBException action = do err ← action+ when (err ≢ c'LIBUSB_SUCCESS)+ (throwIO $ convertUSBException err)++-- | @checkUSBException action@ executes @action@. If @action@ returned a+-- negative integer the integer is converted to a 'USBException' and thrown. If+-- not, the integer is returned.+checkUSBException ∷ Integral α ⇒ IO α → IO Int+checkUSBException action = do r ← action+ if r < 0+ then throwIO $ convertUSBException r+ else return $ fromIntegral r++-- | Convert a @C'libusb_error@ to a 'USBException'. If the @C'libusb_error@ is+-- unknown an 'error' is thrown.+convertUSBException ∷ Num α ⇒ α → USBException+convertUSBException err = fromMaybe unknownLibUsbError $+ lookup err libusb_error_to_USBException+ where+ unknownLibUsbError =+ moduleError $ "Unknown libusb error code: " ++ show err ++ "!"++-- | Association list mapping 'C'libusb_error's to 'USBException's.+libusb_error_to_USBException ∷ Num α ⇒ [(α, USBException)]+libusb_error_to_USBException =+ [ (c'LIBUSB_ERROR_IO, ioException)+ , (c'LIBUSB_ERROR_INVALID_PARAM, InvalidParamException)+ , (c'LIBUSB_ERROR_ACCESS, AccessException)+ , (c'LIBUSB_ERROR_NO_DEVICE, NoDeviceException)+ , (c'LIBUSB_ERROR_NOT_FOUND, NotFoundException)+ , (c'LIBUSB_ERROR_BUSY, BusyException)+ , (c'LIBUSB_ERROR_TIMEOUT, TimeoutException)+ , (c'LIBUSB_ERROR_OVERFLOW, OverflowException)+ , (c'LIBUSB_ERROR_PIPE, PipeException)+ , (c'LIBUSB_ERROR_INTERRUPTED, InterruptedException)+ , (c'LIBUSB_ERROR_NO_MEM, NoMemException)+ , (c'LIBUSB_ERROR_NOT_SUPPORTED, NotSupportedException)+ , (c'LIBUSB_ERROR_OTHER, OtherException)+ ]++-- | Type of USB exceptions.+data USBException =+ IOException String -- ^ Input/output exception.+ | InvalidParamException -- ^ Invalid parameter.+ | AccessException -- ^ Access denied (insufficient permissions). It may+ -- help to run your program with elevated privileges or+ -- change the permissions of your device using+ -- something like @udev@.+ | NoDeviceException -- ^ No such device (it may have been disconnected).+ | NotFoundException -- ^ Entity not found.+ | BusyException -- ^ Resource busy.+ | TimeoutException -- ^ Operation timed out.+ | OverflowException -- ^ If the device offered to much data.+ -- See /Packets and overflows/ in the @libusb@ documentation:+ -- <http://libusb.sourceforge.net/api-1.0/packetoverflow.html>+ | 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 view
@@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- -- | -- Module : System.USB.Descriptors--- Copyright : (c) 2009–2010 Bas van Dijk+-- Copyright : (c) 2009–2011 Bas van Dijk -- License : BSD3 (see the file LICENSE) -- Maintainer : Bas van Dijk <v.dijk.bas@gmail.com> --@@ -58,6 +58,7 @@ -- *** Endpoint max packet size , MaxPacketSize(..) , TransactionOpportunities(..)+ , maxIsoPacketSize -- * String descriptors , getLanguages@@ -67,4 +68,4 @@ , getStrDescFirstLang ) where -import System.USB.Internal+import System.USB.Base
System/USB/DeviceHandling.hs view
@@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- -- | -- Module : System.USB.Devices--- Copyright : (c) 2009–2010 Bas van Dijk+-- Copyright : (c) 2009–2011 Bas van Dijk -- License : BSD3 (see the file LICENSE) -- Maintainer : Bas van Dijk <v.dijk.bas@gmail.com> --@@ -44,4 +44,4 @@ , withDetachedKernelDriver ) where -import System.USB.Internal+import System.USB.Base
System/USB/Enumeration.hs view
@@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- -- | -- Module : System.USB.Devices--- Copyright : (c) 2009–2010 Bas van Dijk+-- Copyright : (c) 2009–2011 Bas van Dijk -- License : BSD3 (see the file LICENSE) -- Maintainer : Bas van Dijk <v.dijk.bas@gmail.com> --@@ -19,4 +19,4 @@ , deviceDesc ) where -import System.USB.Internal+import System.USB.Base
System/USB/Exceptions.hs view
@@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- -- | -- Module : System.USB.Exceptions--- Copyright : (c) 2009–2010 Bas van Dijk+-- Copyright : (c) 2009–2011 Bas van Dijk -- License : BSD3 (see the file LICENSE) -- Maintainer : Bas van Dijk <v.dijk.bas@gmail.com> --@@ -9,6 +9,9 @@ module System.USB.Exceptions ( USBException(..)+ , ioException+ , incompleteReadException+ , incompleteWriteException ) where -import System.USB.Internal+import System.USB.Base
+ System/USB/IO.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE CPP, UnicodeSyntax, NoImplicitPrelude #-}++--------------------------------------------------------------------------------+-- |+-- Module : System.USB.IO+-- Copyright : (c) 2009–2011 Bas van Dijk+-- License : BSD3 (see the file LICENSE)+-- Maintainer : Bas van Dijk <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 view
@@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module : System.USB.IO.StandardDeviceRequests--- Copyright : (c) 2009–2010 Bas van Dijk+-- Copyright : (c) 2009–2011 Bas van Dijk -- License : BSD3 (see the file LICENSE) -- Maintainer : Bas van Dijk <v.dijk.bas@gmail.com> --@@ -85,7 +85,7 @@ import System.USB.Descriptors ( EndpointAddress , DeviceStatus(..) )-import System.USB.IO.Synchronous ( Timeout+import System.USB.IO ( Timeout , RequestType(Standard) , Recipient( ToDevice , ToInterface@@ -95,7 +95,7 @@ , control, readControlExact ) -import System.USB.Unsafe ( marshalEndpointAddress )+import System.USB.Internal ( marshalEndpointAddress ) import Utils ( genFromEnum ) @@ -285,6 +285,3 @@ in fromIntegral h ⋅ 256 + fromIntegral l type FrameNumber = Word16----- The End ---------------------------------------------------------------------
− System/USB/IO/Synchronous.hs
@@ -1,41 +0,0 @@------------------------------------------------------------------------------------ |--- Module : System.USB.IO.Synchronous--- Copyright : (c) 2009–2010 Bas van Dijk--- License : BSD3 (see the file LICENSE)--- Maintainer : Bas van Dijk <v.dijk.bas@gmail.com>------ This module provides functionality for performing control, bulk and interrupt--- transfers.--------------------------------------------------------------------------------------module System.USB.IO.Synchronous- ( ReadAction- , WriteAction-- , Timeout, TimedOut- , Size-- -- * Control transfers- , ControlAction- , RequestType(..)- , Recipient(..)- , Request- , Value- , Index-- , control- , readControl, readControlExact- , writeControl-- -- * Bulk transfers- , readBulk- , writeBulk-- -- * Interrupt transfers- , readInterrupt- , writeInterrupt- ) where--import System.USB.Internal
System/USB/Initialization.hs view
@@ -1,7 +1,9 @@+{-# LANGUAGE CPP #-}+ -------------------------------------------------------------------------------- -- | -- Module : System.USB.Init--- Copyright : (c) 2009–2010 Bas van Dijk+-- Copyright : (c) 2009–2011 Bas van Dijk -- License : BSD3 (see the file LICENSE) -- Maintainer : Bas van Dijk <v.dijk.bas@gmail.com> --@@ -12,8 +14,11 @@ module System.USB.Initialization ( Ctx , newCtx+#ifdef HAS_EVENT_MANAGER+ , newCtx'+#endif , setDebug , Verbosity(..) ) where -import System.USB.Internal+import System.USB.Base
System/USB/Internal.hs view
@@ -1,1610 +1,54 @@-{-# LANGUAGE CPP, UnicodeSyntax, NoImplicitPrelude, DeriveDataTypeable #-}--module System.USB.Internal where-------------------------------------------------------------------------------------- Imports------------------------------------------------------------------------------------- from base:-import Prelude ( Num, (+), (-), (*)- , Integral, fromIntegral, div- , Enum, error- )-import Foreign ( unsafePerformIO )-import Foreign.C.Types ( CUChar, CInt, CUInt )-import Foreign.C.String ( CStringLen )-import Foreign.Marshal.Alloc ( alloca )-import Foreign.Marshal.Array ( peekArray, allocaArray )-import Foreign.Storable ( Storable, peek, peekElemOff )-import Foreign.Ptr ( Ptr, castPtr, plusPtr, nullPtr )-import Foreign.ForeignPtr ( ForeignPtr, newForeignPtr, withForeignPtr)-import Control.Applicative ( liftA2 )-import Control.Exception ( Exception, throwIO, bracket, bracket_- , onException, assert- )-import Control.Monad ( Monad, return, (>>=), (=<<), when, forM )-import Control.Arrow ( (&&&) )-import Data.Function ( ($), flip, on )-import Data.Functor ( Functor, fmap, (<$>) )-import Data.Data ( Data )-import Data.Typeable ( Typeable )-import Data.Maybe ( Maybe(Nothing, Just), maybe, fromMaybe )-import Data.List ( lookup, map, (++) )-import Data.Int ( Int )-import Data.Word ( Word8, Word16 )-import Data.Char ( String )-import Data.Eq ( Eq, (==) )-import Data.Ord ( Ord, (<), (>) )-import Data.Bool ( Bool(False, True), not )-import Data.Bits ( Bits, (.|.), setBit, testBit, shiftL )-import System.IO ( IO )-import Text.Show ( Show, show )-import Text.Read ( Read )-import Text.Printf ( printf )--#if __GLASGOW_HASKELL__ < 700-import Prelude ( fromInteger, negate )-import Control.Monad ( (>>), fail )-#endif---- from base-unicode-symbols:-import Data.Function.Unicode ( (∘) )-import Data.Bool.Unicode ( (∧) )-import Data.Eq.Unicode ( (≢), (≡) )---- from bytestring:-import qualified Data.ByteString as B ( ByteString, packCStringLen, drop )-import qualified Data.ByteString.Internal as BI ( createAndTrim, createAndTrim' )-import qualified Data.ByteString.Unsafe as BU ( unsafeUseAsCStringLen )---- from text:-import Data.Text ( Text )-import qualified Data.Text.Encoding as TE ( decodeUtf16LE )---- from bindings-libusb:-import Bindings.Libusb---- from usb:-import Utils ( bits- , between- , genToEnum, genFromEnum- , mapPeekArray- , ifM- , decodeBCD- )--#if MIN_VERSION_base(4,3,0)-import Control.Exception ( mask )-import Control.Monad ( void )-#else-import Control.Exception ( blocked, block, unblock )-import Data.Function ( id )-import Data.Functor ( (<$) )--mask ∷ ((IO α → IO α) → IO β) → IO β-mask io = do- b ← blocked- if b- then io id- else block $ io unblock---- | Execute the given action but ignore the result.-void ∷ Functor m ⇒ m α → m ()-void = (() <$)-#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'.--}-newtype Ctx = Ctx { unCtx ∷ ForeignPtr C'libusb_context }- deriving (Eq, Typeable)--withCtxPtr ∷ Ctx → (Ptr C'libusb_context → IO α) → IO α-withCtxPtr = withForeignPtr ∘ unCtx---- | Create and initialize a new USB context.------ This function may throw 'USBException's.-newCtx ∷ IO Ctx-newCtx = alloca $ \ctxPtrPtr → do- handleUSBException $ c'libusb_init ctxPtrPtr- peek ctxPtrPtr >>= fmap Ctx ∘ newForeignPtr p'libusb_exit--{-| 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, Show, Read, Eq, Ord, Data, Typeable)-------------------------------------------------------------------------------------- * Enumeration-----------------------------------------------------------------------------------{-| Abstract type representing a USB device detected on the system.--You can only obtain a USB device from the 'getDevices' function.--Certain operations can be performed on a device, but in order to do any I/O you-will have to first obtain a 'DeviceHandle' using 'openDevice'. Alternatively you-can use the /usb-safe/ package which provides type-safe device handling. See:--<http://hackage.haskell.org/package/usb-safe>--Just because you have a reference to a device does not mean it is necessarily-usable. The device may have been unplugged, you may not have permission to-operate such device or another process or driver may be using the device.--To get additional information about a device you can retrieve its descriptor-using 'deviceDesc'.--Note that equality on devices is defined by comparing their descriptors:-@(==) = (==) \`on\` `deviceDesc`@--}-data Device = Device- { _ctx ∷ !Ctx -- ^ This reference to the 'Ctx' is needed so that it won't- -- get garbage collected. The finalizer "p'libusb_exit" is- -- run only when all references to 'Devices' are gone.-- , getDevFrgnPtr ∷ !(ForeignPtr C'libusb_device)-- , deviceDesc ∷ !DeviceDesc -- ^ Get the descriptor of the device.- } deriving Typeable--instance Eq Device where- (==) = (==) `on` deviceDesc--instance Show Device where- show d = printf "Bus %03d Device %03d: ID %04x:%04x" (busNumber d)- (deviceAddress d)- (deviceVendorId desc)- (deviceProductId desc)- where- desc = deviceDesc d--withDevicePtr ∷ Device → (Ptr C'libusb_device → IO α) → IO α-withDevicePtr = withForeignPtr ∘ getDevFrgnPtr--{-| Returns a list of USB devices currently attached to the system.--This is your entry point into finding a USB device.--Exceptions:-- * 'NoMemException' on a memory allocation failure.---}--{--Visual description of the 'devPtrArrayPtr':-- D- ^ D- D │ ^- ^ │ │- │ │ │-devPtrArrayPtr: ┏━┷━┳━┷━┳━━━┳━━━┳━┷━┓- P ───> ┃ P ┃ P ┃ P ┃ P ┃ P ┃- ┗━━━┻━━━┻━┯━┻━┯━┻━━━┛- │ │-P = pointer v │-D = device structure D │- v- D--}-getDevices ∷ Ctx → IO [Device]-getDevices ctx =- alloca $ \devPtrArrayPtr → mask $ \restore → do- numDevs ← checkUSBException $ withCtxPtr ctx $- flip c'libusb_get_device_list devPtrArrayPtr- devPtrArray ← peek devPtrArrayPtr- let freeDevPtrArray = c'libusb_free_device_list devPtrArray 0- devs ← restore (mapPeekArray mkDev numDevs devPtrArray)- `onException` freeDevPtrArray- freeDevPtrArray- return devs- where- mkDev ∷ Ptr C'libusb_device → IO Device- mkDev devPtr = liftA2 (Device ctx)- (newForeignPtr p'libusb_unref_device devPtr)- (getDeviceDesc devPtr)---- | The number of the bus that a device is connected to.-busNumber ∷ Device → Word8-busNumber dev = -- Getting the bus number from libusb is a side-effect free- -- operation. The bus number is a static variable in the device- -- structure. That's why it's safe to use:- 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 = -- Getting the device address from libusb is a side-effect- -- free operation. The device address is a static variable- -- in the device structure. That's why it's safe to use:- 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)- -- ^ Retrieve the pointer to the @libusb@ device handle.- } deriving Typeable--instance Eq DeviceHandle where- (==) = (==) `on` getDevHndlPtr--instance Show DeviceHandle where- show devHndl = "{USB device handle to: " ++ show (getDevice devHndl) ++ "}"--{-| 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 = c'libusb_close ∘ getDevHndlPtr--{-| @withDeviceHandle dev act@ opens the 'Device' @dev@ and passes-the resulting handle to the computation @act@. The handle will be closed on exit-from @withDeviceHandle@ whether by normal termination or by raising an-exception.--}-withDeviceHandle ∷ Device → (DeviceHandle → IO α) → IO α-withDeviceHandle dev = bracket (openDevice dev) closeDevice------------------------------------------------------------------------------------- ** Getting & setting the configuration------------------------------------------------------------------------------------- | Identifier for configurations.------ Can be retrieved by 'getConfig' or by 'configValue'.-type ConfigValue = Word8--{-| Determine the value of the currently active configuration.--You could formulate your own control request to obtain this information, but-this function has the advantage that it may be able to retrieve the information-from operating system caches (no I/O involved).--If the OS does not cache this information, then this function will block while-a control transfer is submitted to retrieve the information.--This function returns 'Nothing' if the device is in unconfigured state.--Exceptions:-- * 'NoDeviceException' if the device has been disconnected.-- * Another 'USBException'.--}-getConfig ∷ DeviceHandle → IO (Maybe ConfigValue)-getConfig devHndl =- alloca $ \configPtr → do- handleUSBException $ c'libusb_get_configuration (getDevHndlPtr devHndl)- 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 = handleUSBException- ∘ c'libusb_set_configuration (getDevHndlPtr devHndl)- ∘ marshal- 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 =- handleUSBException $ c'libusb_claim_interface (getDevHndlPtr devHndl)- (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 =- handleUSBException $ c'libusb_release_interface (getDevHndlPtr devHndl)- (fromIntegral ifNum)--{-| @withClaimedInterface@ claims the interface on the given device handle then-executes the given computation. On exit from @withClaimedInterface@, the-interface is released whether by normal termination or by raising an exception.--}-withClaimedInterface ∷ DeviceHandle → InterfaceNumber → IO α → IO α-withClaimedInterface devHndl ifNum = bracket_ (claimInterface devHndl ifNum)- (releaseInterface devHndl ifNum)------------------------------------------------------------------------------------- ** Setting interface alternate settings------------------------------------------------------------------------------------- | Identifier for interface alternate settings.------ Can be retrieved by 'interfaceAltSetting'.-type InterfaceAltSetting = Word8--{-| Activate an alternate setting for an interface.--The interface must have been previously claimed with 'claimInterface' or-'withInterfaceHandle'.--You should always use this function rather than formulating your own-SET_INTERFACE control request. This is because the underlying operating system-needs to know when such changes happen.--This is a blocking function.--Exceptions:-- * 'NotFoundException' if the interface was not claimed or the requested- alternate setting does not exist.-- * 'NoDeviceException' if the device has been disconnected.-- * Another 'USBException'.--}-setInterfaceAltSetting ∷ DeviceHandle- → InterfaceNumber- → InterfaceAltSetting- → IO ()-setInterfaceAltSetting devHndl ifNum alternateSetting =- handleUSBException $- c'libusb_set_interface_alt_setting (getDevHndlPtr devHndl)- (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 = handleUSBException- ∘ c'libusb_clear_halt (getDevHndlPtr devHndl)- ∘ marshalEndpointAddress--{-| 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 = handleUSBException ∘ c'libusb_reset_device ∘ getDevHndlPtr------------------------------------------------------------------------------------- ** 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 = do- r ← c'libusb_kernel_driver_active (getDevHndlPtr devHndl)- (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 =- handleUSBException $ c'libusb_detach_kernel_driver (getDevHndlPtr devHndl)- (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 =- handleUSBException $ c'libusb_attach_kernel_driver (getDevHndlPtr devHndl)- (fromIntegral ifNum)--{-| If a kernel driver is active on the specified interface the driver is-detached and the given action is executed. If the action terminates, whether by-normal termination or by raising an exception, the kernel driver is attached-again. If a kernel driver is not active on the specified interface the action is-just executed.--Exceptions:-- * 'NoDeviceException' if the device has been disconnected.-- * Another 'USBException'.--}-withDetachedKernelDriver ∷ DeviceHandle → InterfaceNumber → IO α → IO α-withDetachedKernelDriver devHndl ifNum action =- ifM (kernelDriverActive devHndl ifNum)- (bracket_ (detachKernelDriver devHndl ifNum)- (attachKernelDriver devHndl ifNum)- action)- action-------------------------------------------------------------------------------------- * Descriptors---------------------------------------------------------------------------------------------------------------------------------------------------------------------- ** Device descriptor-----------------------------------------------------------------------------------{-| A structure representing the standard USB device descriptor.--This descriptor is documented in section 9.6.1 of the USB 2.0 specification.--This structure can be retrieved by 'deviceDesc'.--}-data DeviceDesc = DeviceDesc- { -- | USB specification release number.- deviceUSBSpecReleaseNumber ∷ !ReleaseNumber-- -- | USB-IF class code for the device.- , deviceClass ∷ !Word8-- -- | USB-IF subclass code for the device, qualified by the 'deviceClass'- -- value.- , deviceSubClass ∷ !Word8-- -- | USB-IF protocol code for the device, qualified by the 'deviceClass'- -- and 'deviceSubClass' values.- , deviceProtocol ∷ !Word8-- -- | Maximum packet size for endpoint 0.- , deviceMaxPacketSize0 ∷ !Word8-- -- | USB-IF vendor ID.- , deviceVendorId ∷ !VendorId-- -- | USB-IF product ID.- , deviceProductId ∷ !ProductId-- -- | Device release number.- , deviceReleaseNumber ∷ !ReleaseNumber-- -- | Optional index of string descriptor describing manufacturer.- , deviceManufacturerStrIx ∷ !(Maybe StrIx)-- -- | Optional index of string descriptor describing product.- , deviceProductStrIx ∷ !(Maybe StrIx)-- -- | Optional index of string descriptor containing device serial number.- , deviceSerialNumberStrIx ∷ !(Maybe StrIx)-- -- | Number of possible configurations.- , deviceNumConfigs ∷ !Word8-- -- | List of configurations supported by the device.- , deviceConfigs ∷ ![ConfigDesc]- } deriving (Show, Read, Eq, Data, Typeable)--type ReleaseNumber = (Int, Int, Int, Int)--type VendorId = Word16-type ProductId = Word16------------------------------------------------------------------------------------- ** Configuration descriptor-----------------------------------------------------------------------------------{-| A structure representing the standard USB configuration descriptor.--This descriptor is documented in section 9.6.3 of the USB 2.0 specification.--This structure can be retrieved by 'deviceConfigs'.--}-data ConfigDesc = ConfigDesc- { -- | Identifier value for the configuration.- configValue ∷ !ConfigValue-- -- | Optional index of string descriptor describing the configuration.- , configStrIx ∷ !(Maybe StrIx)-- -- | Configuration characteristics.- , configAttribs ∷ !ConfigAttribs-- -- | Maximum power consumption of the USB device from the bus in the- -- configuration when the device is fully operational. Expressed in 2 mA- -- units (i.e., 50 = 100 mA).- , configMaxPower ∷ !Word8-- -- | Number of interfaces supported by the configuration.- , configNumInterfaces ∷ !Word8-- -- | List of interfaces supported by the configuration. Note that the- -- length of this list should equal 'configNumInterfaces'.- , configInterfaces ∷ ![Interface]-- -- | Extra descriptors. If @libusb@ encounters unknown configuration- -- descriptors, it will store them here, should you wish to parse them.- , configExtra ∷ !B.ByteString-- } deriving (Show, Read, Eq, Data, Typeable)---- | An interface is represented as a list of alternate interface settings.-type Interface = [InterfaceDesc]------------------------------------------------------------------------------------- *** Configuration attributes------------------------------------------------------------------------------------- | The USB 2.0 specification specifies that the configuration attributes only--- describe the device status.-type ConfigAttribs = DeviceStatus--data DeviceStatus = DeviceStatus- { remoteWakeup ∷ !Bool -- ^ The Remote Wakeup field indicates whether the- -- device is currently enabled to request remote- -- wakeup. The default mode for devices that- -- support remote wakeup is disabled.- , selfPowered ∷ !Bool -- ^ The Self Powered field indicates whether the- -- device is currently self-powered- } deriving (Show, Read, Eq, Data, Typeable)------------------------------------------------------------------------------------- ** Interface descriptor-----------------------------------------------------------------------------------{-| A structure representing the standard USB interface descriptor.--This descriptor is documented in section 9.6.5 of the USB 2.0 specification.--This structure can be retrieved using 'configInterfaces'.--}-data InterfaceDesc = InterfaceDesc- { -- | Number of the interface.- interfaceNumber ∷ !InterfaceNumber-- -- | Value used to select the alternate setting for the interface.- , interfaceAltSetting ∷ !InterfaceAltSetting-- -- | USB-IF class code for the interface.- , interfaceClass ∷ !Word8-- -- | USB-IF subclass code for the interface, qualified by the- -- 'interfaceClass' value.- , interfaceSubClass ∷ !Word8-- -- | USB-IF protocol code for the interface, qualified by the- -- 'interfaceClass' and 'interfaceSubClass' values.- , interfaceProtocol ∷ !Word8-- -- | Optional index of string descriptor describing the interface.- , interfaceStrIx ∷ !(Maybe StrIx)-- -- | List of endpoints supported by the interface.- , interfaceEndpoints ∷ ![EndpointDesc]-- -- | Extra descriptors. If @libusb@ encounters unknown interface- -- descriptors, it will store them here, should you wish to parse them.- , interfaceExtra ∷ !B.ByteString- } deriving (Show, Read, Eq, Data, Typeable)-------------------------------------------------------------------------------------- ** 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 (Show, Read, Eq, Data, Typeable)------------------------------------------------------------------------------------- *** Endpoint address------------------------------------------------------------------------------------- | The address of an endpoint.-data EndpointAddress = EndpointAddress- { endpointNumber ∷ !Int -- ^ Must be >= 0 and <= 15- , transferDirection ∷ !TransferDirection- } deriving (Show, Read, Eq, Data, Typeable)---- | 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 (Show, Read, Eq, Data, Typeable)------------------------------------------------------------------------------------- *** 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 (Show, Read, Eq, Data, Typeable)--data Synchronization = NoSynchronization- | Asynchronous- | Adaptive- | Synchronous- deriving (Enum, Show, Read, Eq, Data, Typeable)--data Usage = Data- | Feedback- | Implicit- deriving (Enum, Show, Read, Eq, Data, Typeable)------------------------------------------------------------------------------------- *** Endpoint max packet size-----------------------------------------------------------------------------------data MaxPacketSize = MaxPacketSize- { maxPacketSize ∷ !Size- , transactionOpportunities ∷ !TransactionOpportunities- } deriving (Show, Read, Eq, Data, Typeable)---- | Number of additional transactions.-data TransactionOpportunities = Zero | One | Two- deriving (Enum, Ord, Show, Read, Eq, Data, Typeable)------------------------------------------------------------------------------------- Retrieving and converting descriptors-----------------------------------------------------------------------------------getDeviceDesc ∷ Ptr C'libusb_device → IO DeviceDesc-getDeviceDesc devPtr = alloca $ \devDescPtr → do- handleUSBException $ c'libusb_get_device_descriptor devPtr devDescPtr- peek devDescPtr >>= convertDeviceDesc devPtr--convertDeviceDesc ∷ Ptr C'libusb_device- → C'libusb_device_descriptor- → IO DeviceDesc-convertDeviceDesc devPtr d = do- let numConfigs = c'libusb_device_descriptor'bNumConfigurations d-- configs ← forM [0..numConfigs-1] $ getConfigDesc devPtr-- return DeviceDesc- { deviceUSBSpecReleaseNumber = unmarshalReleaseNumber $- c'libusb_device_descriptor'bcdUSB d- , deviceClass = c'libusb_device_descriptor'bDeviceClass d- , deviceSubClass = c'libusb_device_descriptor'bDeviceSubClass d- , deviceProtocol = c'libusb_device_descriptor'bDeviceProtocol d- , deviceMaxPacketSize0 = c'libusb_device_descriptor'bMaxPacketSize0 d- , deviceVendorId = c'libusb_device_descriptor'idVendor d- , deviceProductId = c'libusb_device_descriptor'idProduct d- , deviceReleaseNumber = unmarshalReleaseNumber $- c'libusb_device_descriptor'bcdDevice d- , deviceManufacturerStrIx = unmarshalStrIx $- c'libusb_device_descriptor'iManufacturer d- , deviceProductStrIx = unmarshalStrIx $- c'libusb_device_descriptor'iProduct d- , deviceSerialNumberStrIx = unmarshalStrIx $- c'libusb_device_descriptor'iSerialNumber d- , deviceNumConfigs = numConfigs- , deviceConfigs = configs- }--unmarshalReleaseNumber ∷ Word16 → ReleaseNumber-unmarshalReleaseNumber abcd = (a, b, c, d)- where- [a, b, c, d] = map fromIntegral $ decodeBCD 4 abcd--unmarshalStrIx ∷ Word8 → Maybe StrIx-unmarshalStrIx 0 = Nothing-unmarshalStrIx strIx = Just strIx--getConfigDesc ∷ Ptr C'libusb_device → Word8 → IO ConfigDesc-getConfigDesc devPtr ix = bracket getConfigDescPtr- c'libusb_free_config_descriptor- ((convertConfigDesc =<<) ∘ peek)- where- getConfigDescPtr = alloca $ \configDescPtrPtr → do- handleUSBException $ c'libusb_get_config_descriptor- devPtr- ix- configDescPtrPtr- peek configDescPtrPtr--convertConfigDesc ∷ C'libusb_config_descriptor → IO ConfigDesc-convertConfigDesc c = do- let numInterfaces = c'libusb_config_descriptor'bNumInterfaces c-- interfaces ← mapPeekArray convertInterface- (fromIntegral numInterfaces)- (c'libusb_config_descriptor'interface c)-- extra ← getExtra (c'libusb_config_descriptor'extra c)- (c'libusb_config_descriptor'extra_length c)-- return ConfigDesc- { configValue = c'libusb_config_descriptor'bConfigurationValue c- , configStrIx = unmarshalStrIx $- c'libusb_config_descriptor'iConfiguration c- , configAttribs = unmarshalConfigAttribs $- c'libusb_config_descriptor'bmAttributes c- , configMaxPower = c'libusb_config_descriptor'MaxPower c- , configNumInterfaces = numInterfaces- , configInterfaces = interfaces- , configExtra = extra- }--unmarshalConfigAttribs ∷ Word8 → ConfigAttribs-unmarshalConfigAttribs a = DeviceStatus { remoteWakeup = testBit a 5- , selfPowered = testBit a 6- }--getExtra ∷ Ptr CUChar → CInt → IO B.ByteString-getExtra extra extraLength = B.packCStringLen ( castPtr extra- , fromIntegral extraLength- )--convertInterface ∷ C'libusb_interface → IO [InterfaceDesc]-convertInterface i =- mapPeekArray convertInterfaceDesc- (fromIntegral $ c'libusb_interface'num_altsetting i)- (c'libusb_interface'altsetting i)--convertInterfaceDesc ∷ C'libusb_interface_descriptor → IO InterfaceDesc-convertInterfaceDesc i = do- let numEndpoints = c'libusb_interface_descriptor'bNumEndpoints i-- endpoints ← mapPeekArray convertEndpointDesc- (fromIntegral numEndpoints)- (c'libusb_interface_descriptor'endpoint i)-- extra ← getExtra (c'libusb_interface_descriptor'extra i)- (c'libusb_interface_descriptor'extra_length i)-- return InterfaceDesc- { interfaceNumber = c'libusb_interface_descriptor'bInterfaceNumber i- , interfaceAltSetting = c'libusb_interface_descriptor'bAlternateSetting i- , interfaceClass = c'libusb_interface_descriptor'bInterfaceClass i- , interfaceSubClass = c'libusb_interface_descriptor'bInterfaceSubClass i- , interfaceStrIx = unmarshalStrIx $- c'libusb_interface_descriptor'iInterface i- , interfaceProtocol = c'libusb_interface_descriptor'bInterfaceProtocol i- , interfaceEndpoints = endpoints- , interfaceExtra = extra- }--convertEndpointDesc ∷ C'libusb_endpoint_descriptor → IO EndpointDesc-convertEndpointDesc e = do- extra ← getExtra (c'libusb_endpoint_descriptor'extra e)- (c'libusb_endpoint_descriptor'extra_length e)-- return EndpointDesc- { endpointAddress = unmarshalEndpointAddress $- c'libusb_endpoint_descriptor'bEndpointAddress e- , endpointAttribs = unmarshalEndpointAttribs $- c'libusb_endpoint_descriptor'bmAttributes e- , endpointMaxPacketSize = unmarshalMaxPacketSize $- c'libusb_endpoint_descriptor'wMaxPacketSize e- , endpointInterval = c'libusb_endpoint_descriptor'bInterval e- , endpointRefresh = c'libusb_endpoint_descriptor'bRefresh e- , endpointSynchAddress = c'libusb_endpoint_descriptor'bSynchAddress e- , endpointExtra = extra- }--unmarshalEndpointAddress ∷ Word8 → EndpointAddress-unmarshalEndpointAddress a =- EndpointAddress { endpointNumber = fromIntegral $ bits 0 3 a- , transferDirection = if testBit a 7 then In else Out- }---- | Marshal an @EndpointAddress@ 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- _ → error "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--{-| Retrieve a list of supported languages.--This function may throw 'USBException's.--}-getLanguages ∷ DeviceHandle → IO [LangId]-getLanguages devHndl = allocaArray maxSize $ \dataPtr → do- reportedSize ← write dataPtr-- let strSize = (reportedSize - strDescHeaderSize) `div` 2- strPtr = castPtr $ dataPtr `plusPtr` strDescHeaderSize-- map unmarshalLangId <$> peekArray strSize strPtr- where- maxSize = 255 -- Some devices choke on size > 255- write = putStrDesc devHndl 0 0 maxSize--{-| @putStrDesc devHndl strIx langId maxSize dataPtr@ retrieves the-string descriptor @strIx@ in the language @langId@ from the @devHndl@-and writes at most @maxSize@ bytes from that string descriptor to the-location that @dataPtr@ points to. So ensure there is at least space-for @maxSize@ bytes there. Next, the header of the string descriptor-is checked for correctness. If it's incorrect an 'IOException' is-thrown. Finally, the size reported in the header is returned.--}-putStrDesc ∷ DeviceHandle- → StrIx- → Word16- → Size- → Ptr CUChar- → IO Size-putStrDesc devHndl strIx langId maxSize dataPtr = do- actualSize ← checkUSBException $ c'libusb_get_string_descriptor- (getDevHndlPtr devHndl)- 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 @usb-id-database@ package at:--<http://hackage.haskell.org/package/usb-id-database>--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 + 2 * nrOfChars -- characters are 2 bytes- decode = TE.decodeUtf16LE ∘ B.drop strDescHeaderSize--{-| Retrieve a string descriptor from a device using the first supported language.--This function may throw 'USBException's.--}-getStrDescFirstLang ∷ DeviceHandle- → StrIx- → Int -- ^ Maximum number of characters in the requested- -- string. An 'IOException' will be thrown when the- -- requested string is larger than this number.- → IO Text-getStrDescFirstLang devHndl strIx nrOfChars =- do langIds ← getLanguages devHndl- case langIds of- [] → throwIO $ IOException "Zero languages"- langId : _ → getStrDesc devHndl strIx langId nrOfChars-------------------------------------------------------------------------------------- * Asynchronous device I/O------------------------------------------------------------------------------------- TODO: Not implemented yet. I'm not sure if I should implement it because you--- can simulate asynchronous IO using threads.-------------------------------------------------------------------------------------- * Synchronous device 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 flag which indicates whether a transfer timed out.--}-type ReadAction = Size → Timeout → IO (B.ByteString, TimedOut)--{-| 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 an flag which indicates-whether a transfer timed out.--}-type WriteAction = B.ByteString → Timeout → IO (Size, TimedOut)---- | A timeout in milliseconds. A timeout defines how long a transfer should wait--- before giving up due to no response being received. For no timeout, use value--- 0.-type Timeout = Int---- | 'True' when a transfer timed out and 'False' otherwise.-type TimedOut = Bool---- | Number of bytes transferred.-type Size = Int------------------------------------------------------------------------------------ ** Control transfers------------------------------------------------------------------------------------ | Handy type synonym that names the parameters of a control transfer.-type ControlAction α = RequestType → Recipient → Request → Value → Index → α--data RequestType = Standard- | Class- | Vendor- deriving (Enum, Show, Read, Eq, Data, Typeable)--data Recipient = ToDevice- | ToInterface- | ToEndpoint- | ToOther- deriving (Enum, Show, Read, Eq, Data, Typeable)--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--{-| 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 →- void $ checkUSBException $ c'libusb_control_transfer- (getDevHndlPtr devHndl)- (marshalRequestType reqType reqRecipient)- request- value- index- nullPtr- 0- (fromIntegral timeout)--{-| 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 →- BI.createAndTrim' size $ \dataPtr → do- err ← c'libusb_control_transfer- (getDevHndlPtr devHndl)- (marshalRequestType reqType reqRecipient `setBit` 7)- 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 (0, fromIntegral err, timedOut)---- | A convenience function similar to 'readControl' which checks if the--- specified number of bytes to read were actually read. Throws an 'IOException'--- if this is not the case.-readControlExact ∷ DeviceHandle → ControlAction (Size → Timeout → IO B.ByteString)-readControlExact devHndl = \reqType reqRecipient request value index → \size timeout → do- BI.createAndTrim size $ \dataPtr → do- err ← c'libusb_control_transfer- (getDevHndlPtr devHndl)- (marshalRequestType reqType reqRecipient `setBit` 7)- request- value- index- (castPtr dataPtr)- (fromIntegral size)- (fromIntegral timeout)- if err < 0 ∧ err ≢ c'LIBUSB_ERROR_TIMEOUT- then throwIO $ convertUSBException err- else if err ≢ fromIntegral size- then throwIO $ IOException "The read number of bytes doesn't equal the requested number"- else return $ fromIntegral err--{-| 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 →- BU.unsafeUseAsCStringLen input $ \(dataPtr, size) → do- err ← c'libusb_control_transfer- (getDevHndlPtr devHndl)- (marshalRequestType reqType reqRecipient)- 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, timedOut)-------------------------------------------------------------------------------------- ** Bulk transfers-----------------------------------------------------------------------------------{-| Perform a USB /bulk/ read.--Exceptions:-- * 'PipeException' if the endpoint halted.-- * 'OverflowException' if the device offered more data,- see /Packets and overflows/ in the @libusb@ documentation:- <http://libusb.sourceforge.net/api-1.0/packetoverflow.html>.-- * 'NoDeviceException' if the device has been disconnected.-- * Another 'USBException'.--}-readBulk ∷ DeviceHandle -- ^ A handle for the device to communicate with.- → EndpointAddress -- ^ The address of a valid 'In' and 'Bulk' endpoint- -- to communicate with. Make sure the endpoint- -- belongs to the current alternate setting of a- -- claimed interface which belongs to the device.- → ReadAction-readBulk = readTransfer c'libusb_bulk_transfer--{-| Perform a USB /bulk/ write.--Exceptions:-- * 'PipeException' if the endpoint halted.-- * 'OverflowException' if the device offered more data,- see /Packets and overflows/ in the @libusb@ documentation:- <http://libusb.sourceforge.net/api-1.0/packetoverflow.html>.-- * 'NoDeviceException' if the device has been disconnected.-- * Another 'USBException'.--}-writeBulk ∷ DeviceHandle -- ^ A handle for the device to communicate with.- → EndpointAddress -- ^ The address of a valid 'Out' and 'Bulk'- -- endpoint to communicate with. Make sure the- -- endpoint belongs to the current alternate- -- setting of a claimed interface which belongs to- -- the device.- → WriteAction-writeBulk = writeTransfer c'libusb_bulk_transfer------------------------------------------------------------------------------------- ** Interrupt transfers-----------------------------------------------------------------------------------{-| Perform a USB /interrupt/ read.--Exceptions:-- * 'PipeException' if the endpoint halted.-- * 'OverflowException' if the device offered more data,- see /Packets and overflows/ in the libusb documentation:- <http://libusb.sourceforge.net/api-1.0/packetoverflow.html>.-- * 'NoDeviceException' if the device has been disconnected.-- * Another 'USBException'.--}-readInterrupt ∷ DeviceHandle -- ^ A handle for the device to communicate- -- with.- → EndpointAddress -- ^ The address of a valid 'In' and 'Interrupt'- -- endpoint to communicate with. Make sure the- -- endpoint belongs to the current alternate- -- setting of a claimed interface which- -- belongs to the device.- → ReadAction-readInterrupt = readTransfer c'libusb_interrupt_transfer--{-| Perform a USB /interrupt/ write.--Exceptions:-- * 'PipeException' if the endpoint halted.-- * 'OverflowException' if the device offered more data,- see /Packets and overflows/ in the @libusb@ documentation:- <http://libusb.sourceforge.net/api-1.0/packetoverflow.html>.-- * 'NoDeviceException' if the device has been disconnected.-- * Another 'USBException'.--}-writeInterrupt ∷ DeviceHandle -- ^ A handle for the device to communicate- -- with.- → EndpointAddress -- ^ The address of a valid 'Out' and- -- 'Interrupt' endpoint to communicate- -- with. Make sure the endpoint belongs to- -- the current alternate setting of a claimed- -- interface which belongs to the device.- → WriteAction-writeInterrupt = writeTransfer c'libusb_interrupt_transfer-------------------------------------------------------------------------------------- | Handy type synonym for the @libusb@ transfer functions.-type C'TransferFunc = Ptr C'libusb_device_handle -- devHndlPtr- → CUChar -- endpoint address- → Ptr CUChar -- dataPtr- → CInt -- size- → Ptr CInt -- transferredPtr- → CUInt -- timeout- → IO CInt -- error--readTransfer ∷ C'TransferFunc → (DeviceHandle → EndpointAddress → ReadAction)-readTransfer c'transfer = \devHndl endpointAddr → \size timeout →- BI.createAndTrim' size $ \dataPtr → do- (transferred, timedOut) ← transfer c'transfer- devHndl- endpointAddr- timeout- (castPtr dataPtr, size)- return (0, transferred, timedOut)--writeTransfer ∷ C'TransferFunc → (DeviceHandle → EndpointAddress → WriteAction)-writeTransfer c'transfer = \devHndl endpointAddr → \input timeout →- BU.unsafeUseAsCStringLen input $ transfer c'transfer- devHndl- endpointAddr- timeout--transfer ∷ C'TransferFunc → DeviceHandle- → EndpointAddress- → Timeout- → CStringLen- → IO (Size, TimedOut)-transfer c'transfer devHndl- endpointAddr- timeout- (dataPtr, size) =- alloca $ \transferredPtr → do- err ← c'transfer (getDevHndlPtr devHndl)- (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, timedOut)-------------------------------------------------------------------------------------- * Exceptions------------------------------------------------------------------------------------- | @handleUSBException action@ executes @action@. If @action@ returned an--- error code other than 'c\'LIBUSB_SUCCESS', the error is converted to a--- 'USBException' and thrown.-handleUSBException ∷ IO CInt → IO ()-handleUSBException action = do err ← action- when (err ≢ c'LIBUSB_SUCCESS)- (throwIO $ convertUSBException err)---- | @checkUSBException action@ executes @action@. If @action@ returned a--- negative integer the integer is converted to a 'USBException' and thrown. If--- not, the integer is returned.-checkUSBException ∷ Integral α ⇒ IO α → IO Int-checkUSBException action = do r ← action- if r < 0- then throwIO $ convertUSBException r- else return $ fromIntegral r---- | Convert a C'libusb_error to a 'USBException'. If the C'libusb_error is--- unknown an 'error' is thrown.-convertUSBException ∷ Num α ⇒ α → USBException-convertUSBException err = fromMaybe unknownLibUsbError $- lookup err libusb_error_to_USBException- where- unknownLibUsbError = error $ "Unknown Libusb error code: " ++ show err ++ "!"---- | Association list mapping 'C'libusb_error's to 'USBException's.-libusb_error_to_USBException ∷ Num α ⇒ [(α, USBException)]-libusb_error_to_USBException =- [ (c'LIBUSB_ERROR_IO, IOException "")- , (c'LIBUSB_ERROR_INVALID_PARAM, InvalidParamException)- , (c'LIBUSB_ERROR_ACCESS, AccessException)- , (c'LIBUSB_ERROR_NO_DEVICE, NoDeviceException)- , (c'LIBUSB_ERROR_NOT_FOUND, NotFoundException)- , (c'LIBUSB_ERROR_BUSY, BusyException)- , (c'LIBUSB_ERROR_TIMEOUT, TimeoutException)- , (c'LIBUSB_ERROR_OVERFLOW, OverflowException)- , (c'LIBUSB_ERROR_PIPE, PipeException)- , (c'LIBUSB_ERROR_INTERRUPTED, InterruptedException)- , (c'LIBUSB_ERROR_NO_MEM, NoMemException)- , (c'LIBUSB_ERROR_NOT_SUPPORTED, NotSupportedException)- , (c'LIBUSB_ERROR_OTHER, OtherException)- ]---- | Type of USB exceptions.-data USBException =- IOException String -- ^ Input/output exception.- | InvalidParamException -- ^ Invalid parameter.- | AccessException -- ^ Access denied (insufficient permissions).- | NoDeviceException -- ^ No such device (it may have been disconnected).- | NotFoundException -- ^ Entity not found.- | BusyException -- ^ Resource busy.- | TimeoutException -- ^ Operation timed out.- | OverflowException -- ^ Overflow.- | 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 (Eq, Show, Read, Data, Typeable)--instance Exception USBException----- The End ---------------------------------------------------------------------+{-# LANGUAGE CPP #-}++--------------------------------------------------------------------------------+-- |+-- Module : System.USB.Unsafe+-- Copyright : (c) 2009–2011 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++ , threaded++ , allocaTransfer+ , withCallback++ , SumLength(..), sumLength+ , peekIsoPacketDescs+ , initIsoPacketDesc++ , getCtx, getEventManager++ -- ** Locks+ , Lock, newLock, acquire, release+#endif+ ) where++import System.USB.Base
− System/USB/Unsafe.hs
@@ -1,21 +0,0 @@------------------------------------------------------------------------------------ |--- Module : System.USB.Unsafe--- Copyright : (c) 2009–2010 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.--- It is primarily used by the @usb-enumerator@ package.--------------------------------------------------------------------------------------module System.USB.Unsafe- ( C'TransferFunc- , getDevHndlPtr- , marshalEndpointAddress- , convertUSBException- ) where--import System.USB.Internal
+ 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
+ Timeval.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE NoImplicitPrelude, UnicodeSyntax #-}++-- | A short module to work with C's struct timeval.++-- Copied from the package "time" - Data.Time.Clock.CTimeval++module Timeval ( withTimeval ) where++--------------------------------------------------------------------------------+-- Imports+--------------------------------------------------------------------------------++-- from base:+import Control.Monad ( return )+import Foreign.C.Types ( CLong )+import Foreign.Marshal.Utils ( with )+import Foreign.Ptr ( Ptr, castPtr )+import Foreign.Storable ( Storable(..) )+import Prelude ( (*), quotRem, fromIntegral, undefined, Int )+import System.IO ( IO )++-- from base-unicode-symbols:+import Data.Function.Unicode ( (∘) )++-- from bindings-libusb:+import Bindings.Libusb.PollingAndTiming ( C'timeval )++--------------------------------------------------------------------------------+-- Timeval+--------------------------------------------------------------------------------++data CTimeval = MkCTimeval CLong CLong++instance Storable CTimeval where+ sizeOf _ = (sizeOf (undefined ∷ CLong)) * 2+ alignment _ = alignment (undefined ∷ CLong)+ peek p = do+ s ← peekElemOff (castPtr p) 0+ mus ← peekElemOff (castPtr p) 1+ return (MkCTimeval s mus)+ poke p (MkCTimeval s mus) = do+ pokeElemOff (castPtr p) 0 s+ pokeElemOff (castPtr p) 1 mus++-- Every things done so far in libusb was in milliseconds. So this+-- function should accept a time in milliseconds too !+withTimeval ∷ Int → (Ptr C'timeval → IO α) → IO α+withTimeval milliseconds action =+ let (seconds, mseconds) = milliseconds `quotRem` 1000+ timeval = MkCTimeval (fromIntegral seconds)+ (fromIntegral (1000 * mseconds)) -- micro-seconds+ in with timeval (action ∘ castPtr)
Utils.hs view
@@ -1,4 +1,8 @@-{-# LANGUAGE CPP, NoImplicitPrelude, UnicodeSyntax, BangPatterns #-}+{-# LANGUAGE CPP+ , NoImplicitPrelude+ , UnicodeSyntax+ , BangPatterns+ #-} module Utils where @@ -76,6 +80,3 @@ go shftL ds | shftL < 0 = ds | otherwise = let !d = (abcd `shiftL` shftL) `shiftR` shftR in go (shftL - bitsInDigit) (d : ds)----- The End ---------------------------------------------------------------------
usb.cabal view
@@ -1,78 +1,101 @@ name: usb-version: 0.8+version: 1.0 cabal-version: >=1.6 build-type: Custom license: BSD3 license-file: LICENSE-copyright: 2009–2010 Bas van Dijk <v.dijk.bas@gmail.com>+copyright: 2009–2011 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>-stability: experimental+homepage: https://github.com/basvandijk/usb/+bug-reports: https://github.com/basvandijk/usb/issues category: System synopsis: Communicate with USB devices-description: This library allows you to communicate with USB devices from+description: This library enables you to communicate with USB devices from userspace. It is implemented as a high-level wrapper around @bindings-libusb@ which is a low-level binding to the C library: @libusb-1.*@.- .- This documentation assumes knowledge of how to operate USB- devices from a software standpoint (descriptors, configurations,- interfaces, endpoints, control\/bulk\/interrupt\/isochronous- transfers, etc). Full information can be found in the USB 2.0- Specification.- .- For an example how to use this library see the @ls-usb@ package- at:- .- <http://hackage.haskell.org/package/ls-usb>- .- Also see the @usb-safe@ package which wraps this package and- provides some strong safety guarantees for working with USB- devices:- .- <http://hackage.haskell.org/package/usb-safe>- .- Finally have a look at the @usb-enumerator@ package which- provides iteratee enumerators for enumerating bulk and interrupt- endpoints: .- <http://hackage.haskell.org/package/usb-enumerator>+ The USB transfer functions in this library have a simple synchronous+ interface (they block) but are implemented using the @libusb@+ asynchronous interface. They integrate with the GHC event manager+ making them efficient (no busy-loops) and interruptible (throwing an+ exception to the thread executing a transfer immediately cancels the+ transfer). .- Besides this API documentation the following sources might be- interesting:- .- * The libusb 1.0 documentation at:- <http://libusb.sourceforge.net/api-1.0/>- .- * The USB 2.0 specification at:- <http://www.usb.org/developers/docs/>- .- * The @bindings-libusb@ documentation at:- <http://hackage.haskell.org/package/bindings-libusb>- .- * \"USB in a NutShell\" at:- <http://www.beyondlogic.org/usbnutshell/usb1.htm>+ If the GHC event manager is not available (because you're either not+ using GHC or because you're on Windows) the library degrades+ gracefully to the @libusb@ synchronous implementation.+ .+ This documentation assumes knowledge of how to operate USB+ devices from a software standpoint (descriptors, configurations,+ interfaces, endpoints, control\/bulk\/interrupt\/isochronous+ transfers, etc). Full information can be found in the USB 2.0+ Specification.+ .+ For an example how to use this library see the @usb-example@+ package at:+ .+ <https://github.com/basvandijk/usb-example>+ .+ or the @ls-usb@ package at:+ .+ <http://hackage.haskell.org/package/ls-usb>+ .+ Also see the @usb-safe@ package which wraps this package and+ provides some strong safety guarantees for working with USB+ devices:+ .+ <http://hackage.haskell.org/package/usb-safe>+ .+ Finally have a look at the @usb-iteratee@ package which+ provides @iteratee@ enumerators for enumerating bulk, interrupt+ and isochronous endpoints:+ .+ <http://hackage.haskell.org/package/usb-iteratee>+ .+ Besides this API documentation the following sources might be+ interesting:+ .+ * The libusb 1.0 documentation at:+ <http://libusb.sourceforge.net/api-1.0/>+ .+ * The USB 2.0 specification at:+ <http://www.usb.org/developers/docs/>+ .+ * The @bindings-libusb@ documentation at:+ <http://hackage.haskell.org/package/bindings-libusb>+ .+ * \"USB in a NutShell\" at:+ <http://www.beyondlogic.org/usbnutshell/usb1.htm> +extra-source-files: README.markdown, NEWS+ source-repository head- Type: darcs- Location: http://code.haskell.org/~basvandijk/code/usb+ Type: git+ Location: git://github.com/basvandijk/usb.git Library GHC-Options: -Wall - build-depends: base >= 4 && < 4.4+ build-depends: base >= 4 && < 4.5 , base-unicode-symbols >= 0.1.1 && < 0.3- , bindings-libusb >= 1.3 && < 1.5+ , bindings-libusb >= 1.4.4 && < 1.5 , bytestring >= 0.9 && < 0.10 , text >= 0.5 && < 0.12+ exposed-modules: System.USB- System.USB.Initialization- System.USB.Enumeration- System.USB.DeviceHandling- System.USB.Descriptors- System.USB.IO.Synchronous- System.USB.IO.StandardDeviceRequests- System.USB.Exceptions- System.USB.Unsafe- other-modules: System.USB.Internal- Utils+ System.USB.Initialization+ 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)+ cpp-options: -DHAS_EVENT_MANAGER+ other-modules: Poll, Event, SystemEventManager, Timeval+ build-depends: containers >= 0.1 && < 0.5