usb (empty) → 0.1
raw patch · 10 files changed
+2198/−0 lines, 10 filesdep +basedep +bindings-libusbdep +bytestringsetup-changed
Dependencies added: base, bindings-libusb, bytestring, text
Files
- LICENSE +31/−0
- Setup.hs +3/−0
- System/USB.hs +48/−0
- System/USB/Descriptors.hs +160/−0
- System/USB/DeviceHandlingAndEnumeration.hs +74/−0
- System/USB/Exceptions.hs +8/−0
- System/USB/IO/Synchronous.hs +38/−0
- System/USB/Initialization.hs +12/−0
- System/USB/Internal.hs +1790/−0
- usb.cabal +34/−0
+ LICENSE view
@@ -0,0 +1,31 @@+Copyright (c) 2009 Bas van Dijk++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * The name of Bas van Dijk and the names of contributors may NOT+ be used to endorse or promote products derived from this+ software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ System/USB.hs view
@@ -0,0 +1,48 @@+--------------------------------------------------------------------------------+-- |+-- Module : System.USB+-- Copyright : (c) 2009 Bas van Dijk+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Bas van Dijk <v.dijk.bas@gmail.com>+-- Stability : Experimental+--+-- This library allows 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>+--+-- 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>+--+--------------------------------------------------------------------------------++module System.USB+ ( module System.USB.Initialization+ , module System.USB.DeviceHandlingAndEnumeration+ , module System.USB.Descriptors+ , module System.USB.IO.Synchronous+ , module System.USB.Exceptions+ ) where++import System.USB.Initialization+import System.USB.DeviceHandlingAndEnumeration+import System.USB.Descriptors+import System.USB.IO.Synchronous+import System.USB.Exceptions
+ System/USB/Descriptors.hs view
@@ -0,0 +1,160 @@+module System.USB.Descriptors+ ( -- * Device descriptor+ DeviceDesc+ , getDeviceDesc++ -- ** Querying device descriptors+ , deviceUSBSpecReleaseNumber+ , BCD4+ , deviceClass+ , deviceSubClass+ , deviceProtocol+ , deviceMaxPacketSize0+ , deviceVendorId, VendorId+ , deviceProductId, ProductId+ , deviceReleaseNumber+ , deviceManufacturerStrIx+ , deviceProductStrIx+ , deviceSerialNumberStrIx+ , deviceNumConfigs++ -- * Configuration descriptor+ , ConfigDesc++ , getActiveConfigDesc+ , getConfigDesc+ , getConfigDescByValue++ -- ** Querying configuration descriptors+ , configValue+ , configStrIx++ , configAttribs+ , ConfigAttribs+ , DeviceStatus(..)++ , configMaxPower+ , configNumInterfaces+ , configInterfaces+ , configExtra++ -- * Interface descriptor+ , InterfaceDesc++ -- ** Querying interface descriptors+ , interfaceNumber+ , interfaceAltSetting+ , interfaceClass+ , interfaceSubClass+ , interfaceProtocol+ , interfaceStrIx+ , interfaceNumEndpoints+ , interfaceEndpoints+ , interfaceExtra++ -- * Endpoint descriptor+ , EndpointDesc++ -- ** Querying endpoint descriptors+ , endpointAddress+ , EndpointAddress(..)+ , TransferDirection(..)++ , endpointAttribs+ , EndpointAttribs+ , TransferType(..)+ , Synchronization(..)+ , Usage(..)++ , endpointMaxPacketSize+ , MaxPacketSize(..)+ , TransactionOpportunities(..)++ , endpointInterval+ , endpointRefresh+ , endpointSynchAddress+ , endpointExtra++ -- * String descriptors+ , getLanguages+ , LangId, PrimaryLangId, SubLangId+ , StrIx+ , getStrDesc+ , getStrDescFirstLang+ ) where++import System.USB.Internal+ ( DeviceDesc+ , getDeviceDesc++ , deviceUSBSpecReleaseNumber+ , BCD4+ , deviceClass+ , deviceSubClass+ , deviceProtocol+ , deviceMaxPacketSize0+ , deviceVendorId, VendorId+ , deviceProductId, ProductId+ , deviceReleaseNumber+ , deviceManufacturerStrIx+ , deviceProductStrIx+ , deviceSerialNumberStrIx+ , deviceNumConfigs++ , ConfigDesc++ , getActiveConfigDesc+ , getConfigDesc+ , getConfigDescByValue++ , configValue+ , configStrIx++ , configAttribs+ , ConfigAttribs+ , DeviceStatus(..)++ , configMaxPower+ , configNumInterfaces+ , configInterfaces+ , configExtra++ , InterfaceDesc++ , interfaceNumber+ , interfaceAltSetting+ , interfaceClass+ , interfaceSubClass+ , interfaceProtocol+ , interfaceStrIx+ , interfaceNumEndpoints+ , interfaceEndpoints+ , interfaceExtra++ , EndpointDesc++ , endpointAddress+ , EndpointAddress(..)+ , TransferDirection(..)++ , endpointAttribs+ , EndpointAttribs+ , TransferType(..)+ , Synchronization(..)+ , Usage(..)++ , endpointMaxPacketSize+ , MaxPacketSize(..)+ , TransactionOpportunities(..)++ , endpointInterval+ , endpointRefresh+ , endpointSynchAddress+ , endpointExtra++ , getLanguages+ , LangId, PrimaryLangId, SubLangId+ , StrIx+ , getStrDesc+ , getStrDescFirstLang+ )
+ System/USB/DeviceHandlingAndEnumeration.hs view
@@ -0,0 +1,74 @@+module System.USB.DeviceHandlingAndEnumeration+ ( -- * Enumeration+ Device+ , getDevices++ , getBusNumber+ , getDeviceAddress+ , getMaxPacketSize++ -- * Opening & closing of devices+ , DeviceHandle+ , openDevice+ , closeDevice+ , withDeviceHandle+ , getDevice++ -- * Getting & setting the configuration+ , ConfigValue+ , getConfig+ , setConfig++ -- * Claiming & releasing interfaces+ , InterfaceNumber+ , claimInterface+ , releaseInterface+ , withInterface+ , InterfaceAltSetting+ , setInterfaceAltSetting++ -- * Clearing & Resetting devices+ , clearHalt+ , resetDevice++ -- * USB kernel drivers+ , kernelDriverActive+ , detachKernelDriver+ , attachKernelDriver+ , withDetachedKernelDriver+ ) where++import System.USB.Internal+ ( Device+ , getDevices++ , getBusNumber+ , getDeviceAddress+ , getMaxPacketSize++ , DeviceHandle+ , openDevice+ , closeDevice+ , withDeviceHandle+ , getDevice++ , ConfigValue+ , getConfig+ , setConfig++ , InterfaceNumber+ , claimInterface+ , releaseInterface+ , withInterface+ , InterfaceAltSetting+ , setInterfaceAltSetting++ , clearHalt+ , resetDevice++ , kernelDriverActive+ , detachKernelDriver+ , attachKernelDriver+ , withDetachedKernelDriver+ )+
+ System/USB/Exceptions.hs view
@@ -0,0 +1,8 @@+module System.USB.Exceptions+ ( USBException(..)+ ) where++import System.USB.Internal+ ( USBException(..)+ )+
+ System/USB/IO/Synchronous.hs view
@@ -0,0 +1,38 @@+module System.USB.IO.Synchronous+ ( Timeout+ , Size++ , RequestType(..)+ , Recipient(..)++ -- * Control transfers+ , control+ , readControl+ , writeControl++ -- * Bulk transfers+ , readBulk+ , writeBulk++ -- * Interrupt transfers+ , readInterrupt+ , writeInterrupt+ ) where++import System.USB.Internal+ ( Timeout+ , Size++ , RequestType(..)+ , Recipient(..)++ , control+ , readControl+ , writeControl++ , readBulk+ , writeBulk++ , readInterrupt+ , writeInterrupt+ )
+ System/USB/Initialization.hs view
@@ -0,0 +1,12 @@+module System.USB.Initialization+ ( Ctx+ , newCtx+ , setDebug+ , Verbosity(..)+ ) where++import System.USB.Internal ( Ctx+ , newCtx+ , setDebug+ , Verbosity(..)+ )
+ System/USB/Internal.hs view
@@ -0,0 +1,1790 @@+{-# LANGUAGE DeriveDataTypeable #-}++module System.USB.Internal+ ( -- * Initialisation+ Ctx+ , newCtx+ , setDebug+ , Verbosity(..)+++ -- * Device handling and enumeration+ -- $deviceHandling+ -- ** Enumeration+ , Device+ , getDevices++ , getBusNumber+ , getDeviceAddress+ , getMaxPacketSize++ -- ** Opening & closing of devices+ , DeviceHandle+ , openDevice+ , closeDevice+ , withDeviceHandle+ , getDevice++ -- ** Getting & setting the configuration+ , ConfigValue+ , getConfig+ , setConfig++ -- ** Claiming & releasing interfaces+ , InterfaceNumber+ , claimInterface+ , releaseInterface+ , withInterface+ , InterfaceAltSetting+ , setInterfaceAltSetting++ -- ** Clearing & Resetting devices+ , clearHalt+ , resetDevice++ -- ** USB kernel drivers+ , kernelDriverActive+ , detachKernelDriver+ , attachKernelDriver+ , withDetachedKernelDriver+++ -- * USB descriptors++ -- $descriptors++ -- ** Device descriptor+ , DeviceDesc+ , getDeviceDesc++ -- *** Querying device descriptors+ , deviceUSBSpecReleaseNumber+ , BCD4+ , deviceClass+ , deviceSubClass+ , deviceProtocol+ , deviceMaxPacketSize0+ , deviceVendorId, VendorId+ , deviceProductId, ProductId+ , deviceReleaseNumber+ , deviceManufacturerStrIx+ , deviceProductStrIx+ , deviceSerialNumberStrIx+ , deviceNumConfigs++ -- ** Configuration descriptor+ , ConfigDesc++ , getActiveConfigDesc+ , getConfigDesc+ , getConfigDescByValue++ -- *** Querying configuration descriptors+ , configValue+ , configStrIx++ , configAttribs+ , ConfigAttribs+ , DeviceStatus(..)++ , configMaxPower+ , configNumInterfaces+ , configInterfaces+ , configExtra++ -- ** Interface descriptor+ , InterfaceDesc++ -- *** Querying interface descriptors+ , interfaceNumber+ , interfaceAltSetting+ , interfaceClass+ , interfaceSubClass+ , interfaceProtocol+ , interfaceStrIx+ , interfaceNumEndpoints+ , interfaceEndpoints+ , interfaceExtra++ -- ** Endpoint descriptor+ , EndpointDesc++ -- *** Querying endpoint descriptors+ , endpointAddress+ , EndpointAddress(..)+ , TransferDirection(..)++ , endpointAttribs+ , EndpointAttribs+ , TransferType(..)+ , Synchronization(..)+ , Usage(..)++ , endpointMaxPacketSize+ , MaxPacketSize(..)+ , TransactionOpportunities(..)++ , endpointInterval+ , endpointRefresh+ , endpointSynchAddress+ , endpointExtra++ -- ** String descriptors+ , getLanguages+ , LangId, PrimaryLangId, SubLangId+ , StrIx+ , getStrDesc+ , getStrDescFirstLang+++ -- * Asynchronous device I/O+ -- | /Not implemented yet. I'm not sure if I should implement it because/+ -- /you can simulate asynchronous IO using threads./+++ -- * Synchronous device I/O+ , Timeout+ , Size++ , RequestType(..)+ , Recipient(..)++ -- ** Control transfers+ , control+ , readControl+ , writeControl++ -- ** Bulk transfers+ , readBulk+ , writeBulk++ -- ** Interrupt transfers+ , readInterrupt+ , writeInterrupt+++ -- * Exceptions+ , USBException(..)+ )+ where+++--------------------------------------------------------------------------------+-- Imports+--------------------------------------------------------------------------------++import Foreign.C.Types ( CUChar, CInt, CUInt )+import Foreign.Marshal.Alloc ( alloca )+import Foreign.Marshal.Array ( peekArray, allocaArray )+import Foreign.Storable ( peek, peekElemOff )+import Foreign.Ptr ( Ptr, castPtr, plusPtr, nullPtr )+import Foreign.ForeignPtr ( ForeignPtr, newForeignPtr, withForeignPtr)+import Control.Exception ( Exception, throwIO, finally, bracket )+import Control.Monad ( fmap, when )+import Control.Arrow ( (&&&) )+import Data.Data ( Data )+import Data.Typeable ( Typeable )+import Data.Maybe ( fromMaybe )+import Data.Word ( Word8, Word16 )+import Data.Bits ( Bits+ , (.|.), (.&.)+ , setBit, testBit+ , shiftR, shiftL+ , bitSize+ )++import qualified Data.ByteString as B ( ByteString+ , packCStringLen+ , drop+ )+import qualified Data.ByteString.Internal as BI ( createAndTrim, toForeignPtr )++import qualified Data.Text as T ( unpack )+import qualified Data.Text.Encoding as TE ( decodeUtf16LE )++import Bindings.Libusb+++--------------------------------------------------------------------------------+-- Initialisation+--------------------------------------------------------------------------------++{-| 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 garbage collected.+-}+newtype Ctx = Ctx { unCtx :: ForeignPtr C'libusb_context}++withCtx :: Ctx -> (Ptr C'libusb_context -> IO a) -> IO a+withCtx = 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', which means no messages are ever+printed. If you choose to increase the message verbosity level, ensure that your+application does not close the stdout/stderr file descriptors.++You are advised to set level 'PrintWarnings'. libusb is conservative with its+message logging and most of the time, will only log messages that explain error+conditions and other oddities. This will help you debug your software.++If the LIBUSB_DEBUG environment variable was set when libusb was initialized,+this function does nothing: the message verbosity is fixed to the value in the+environment variable.++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 =+ withCtx 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+++--------------------------------------------------------------------------------+-- * Device handling and enumeration+--------------------------------------------------------------------------------++{- $deviceHandling++The functionality documented in this section is designed to help with the+following operations:++ * Enumerating the USB devices currently attached to the system.++ * Choosing a device to operate from your software.++ * Opening and closing the chosen device.+-}++{-| Abstract type representing a USB device detected on the system, usually+originating from 'getDevices'.++Certain operations can be performed on a device, but in order to do any I/O you+will have to first obtain a 'DeviceHandle' using 'openDevice'.++Just because you have a reference to a device does not mean it is necessarily+usable. The device may have been unplugged, you may not have permission to+operate such device, or another program or driver may be using the device.+-}+data Device = Device+ { _devGetCtx :: Ctx -- ^ This reference to the 'Ctx' is needed so that it+ -- won't get garbage collected so the finalizer+ -- 'p'libusb_exit' only gets run when all references+ -- to 'Devices' are gone.+ , devFrgnPtr :: (ForeignPtr C'libusb_device)+ }++withDevice :: Device -> (Ptr C'libusb_device -> IO a) -> IO a+withDevice = withForeignPtr . devFrgnPtr++{-| Returns a list of USB devices currently attached to the system.++This is your entry point into finding a USB device to operate.++Exceptions:++ * 'NoMemException' on a memory allocation failure.++-}++{- Visual description of the 'devPtrArrayPtr':+ D+ /\ D+ D | /\+ /\ | |+ | | |+devPtrArrayPtr: _|_ _|_ ___ ___ _|_+ P----> | P | P | P | P | P |+ |___|___|___|___|___|+ | |+P = pointer | |+D = device structure \/ |+ D |+ \/+ D+-}+getDevices :: Ctx -> IO [Device]+getDevices ctx =+ withCtx ctx $ \ctxPtr ->+ alloca $ \devPtrArrayPtr -> do+ numDevs <- c'libusb_get_device_list ctxPtr devPtrArrayPtr+ devPtrArray <- peek devPtrArrayPtr+ finally (case numDevs of+ n | n == c'LIBUSB_ERROR_NO_MEM -> throwIO NoMemException+ | n < 0 -> unknownLibUsbError+ | otherwise -> peekArray (fromIntegral numDevs)+ devPtrArray >>=+ mapM ( fmap (Device ctx)+ . newForeignPtr p'libusb_unref_device+ )+ )+ (c'libusb_free_device_list devPtrArray 0)++-- | Get the number of the bus that a device is connected to.+getBusNumber :: Device -> IO Word8+getBusNumber dev = withDevice dev c'libusb_get_bus_number++-- | Get the address of the device on the bus it is connected to.+getDeviceAddress :: Device -> IO Word8+getDeviceAddress dev = withDevice dev c'libusb_get_device_address++{-| Convenience function to retrieve the max packet size for a+particular endpoint in the active device configuration.++This is useful for setting up isochronous transfers.++Exceptions:++ * 'NotFoundException' if the endpoint does not exist.++ * 'OtherException' on another exception.+-}+getMaxPacketSize :: Device -> EndpointAddress -> IO MaxPacketSize+getMaxPacketSize dev endpoint =+ withDevice dev $ \devPtr -> do+ m <- c'libusb_get_max_packet_size devPtr $+ marshallEndpointAddress endpoint+ case m of+ n | n == c'LIBUSB_ERROR_NOT_FOUND -> throwIO NotFoundException+ | n == c'LIBUSB_ERROR_OTHER -> throwIO OtherException+ | otherwise -> return . convertMaxPacketSize $ fromIntegral n+++-- ** Opening & closing of devices ---------------------------------------------++{-| Abstract type representing a handle on a USB device, usually originating+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 apply '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'.+ , devHndlPtr :: Ptr C'libusb_device_handle+ }++{-| 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 advised 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 = withDevice dev $ \devPtr ->+ alloca $ \devHndlPtrPtr -> do+ handleUSBException $ c'libusb_open devPtr devHndlPtrPtr+ fmap (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 . devHndlPtr++{-| @withDeviceHandle dev act@ opens the 'Device' @dev@ and passes+the resulting handle to the computation @act@. The handle will be closed on exit+from @withDeviceHandle@ whether by normal termination or by raising an+exception.+-}+withDeviceHandle :: Device -> (DeviceHandle -> IO a) -> IO a+withDeviceHandle dev = bracket (openDevice dev) closeDevice+++-- ** Getting & setting the configuration --------------------------------------++-- | Identifier for configurations.+--+-- Can be retrieved by 'getConfig' or by 'configValue'.+type ConfigValue = Word8++{-| Determine the bConfigurationValue 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 will return a value of 0 if the device is in unconfigured state.++Exceptions:++ * 'NoDeviceException' if the device has been disconnected.++ * Aanother 'USBException'.+-}+getConfig :: DeviceHandle -> IO ConfigValue+getConfig devHndl =+ alloca $ \configPtr -> do+ handleUSBException $ c'libusb_get_configuration (devHndlPtr devHndl)+ configPtr+ fmap fromIntegral $ peek configPtr++{-| 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 -1 will put the device in unconfigured state. The USB+specifications state 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 -> ConfigValue -> IO ()+setConfig devHndl+ = handleUSBException+ . c'libusb_set_configuration (devHndlPtr devHndl)+ . 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+libusb 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.++It is advised to use 'withInterface' because it automatically releases an+interface when the computation terminates.++Exceptions:++ * 'NotFoundException' if the requested interface does not exist.++ * 'BusyException' if another program or driver has claimed the interface.++ * 'NoDeviceException' if the device has been disconnected.++ * Another 'USBException'.+-}+claimInterface :: DeviceHandle -> InterfaceNumber -> IO ()+claimInterface devHndl+ = handleUSBException+ . c'libusb_claim_interface (devHndlPtr devHndl)+ . fromIntegral++{-| 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+ = handleUSBException+ . c'libusb_release_interface (devHndlPtr devHndl)+ . fromIntegral++{-| @withInterface@ claims the interface on the given device handle then+executes the given computation. On exit from 'withInterface', the interface is+released whether by normal termination or by raising an exception.+-}+withInterface :: DeviceHandle -> InterfaceNumber -> IO a -> IO a+withInterface devHndl interface action = do+ claimInterface devHndl interface+ action `finally` releaseInterface devHndl interface++-- | 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+'withInterface'.++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 interface alternateSetting =+ handleUSBException $+ c'libusb_set_interface_alt_setting (devHndlPtr devHndl)+ (fromIntegral interface)+ (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 (devHndlPtr devHndl)+ . marshallEndpointAddress++{-| 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 . devHndlPtr+++-- ** 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 interface = do+ r <- c'libusb_kernel_driver_active (devHndlPtr devHndl)+ (fromIntegral interface)+ 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+ = handleUSBException+ . c'libusb_detach_kernel_driver (devHndlPtr devHndl)+ . fromIntegral++{-| 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+ = handleUSBException+ . c'libusb_attach_kernel_driver (devHndlPtr devHndl)+ . fromIntegral++{-| If a kernel driver is active on the specified interface the driver is+detached and the given action is executed. If the action terminates, whether by+normal termination or by raising an exception, the kernel driver is attached+again. If a kernel driver is not active on the specified interface the action is+just executed.++Exceptions:++ * 'NoDeviceException' if the device has been disconnected.++ * Another 'USBException'.+-}+withDetachedKernelDriver :: DeviceHandle -> InterfaceNumber -> IO a -> IO a+withDetachedKernelDriver devHndl interface action = do+ active <- kernelDriverActive devHndl interface+ if active+ then do detachKernelDriver devHndl interface+ action `finally` attachKernelDriver devHndl interface+ else action+++--------------------------------------------------------------------------------+-- USB descriptors+--------------------------------------------------------------------------------++{- $descriptors+USB devices report their attributes using descriptors. A descriptor is a data+structure with a defined format. Using descriptors allows concise storage of the+attributes of individual configurations because each configuration may reuse+descriptors or portions of descriptors from other configurations that have the+same characteristics. In this manner, the descriptors resemble individual data+records in a relational database.++Where appropriate, descriptors contain references to string+descriptors ('StrIx') that provide displayable information describing+a descriptor in human-readable form. The inclusion of string+descriptors is optional. If a device does not support string+descriptors, string reference fields must be reset to zero to indicate+no string descriptor is available.+-}++-- ** Device descriptor --------------------------------------------------------++-- TODO: Add more structure to these descriptor types:++{-| A structure representing the standard USB device descriptor.++This descriptor is documented in section 9.6.1 of the USB 2.0 specification.++This structure can be retrieved by 'getDeviceDesc'.+-}+data DeviceDesc = DeviceDesc+ { deviceUSBSpecReleaseNumber :: BCD4 -- ^ USB specification release+ -- number in binary-coded+ -- decimal.++ , deviceClass :: Word8 -- ^ USB-IF class code for the+ -- device.+ , deviceSubClass :: Word8 -- ^ USB-IF subclass code for the+ -- device, qualified by the+ -- 'deviceClass' value.++ , deviceProtocol :: Word8 -- ^ USB-IF protocol code for the+ -- device, qualified by the+ -- 'deviceClass' and+ -- 'deviceSubClass' values.++ , deviceMaxPacketSize0 :: Word8 -- ^ Maximum packet size for+ -- endpoint 0.++ , deviceVendorId :: VendorId -- ^ USB-IF vendor ID.+ , deviceProductId :: ProductId -- ^ USB-IF product ID.++ , deviceReleaseNumber :: BCD4 -- ^ Device release number in+ -- binary-coded decimal.++ , deviceManufacturerStrIx :: StrIx -- ^ Index of string descriptor+ -- describing manufacturer.+ , deviceProductStrIx :: StrIx -- ^ Index of string descriptor+ -- describing product.+ , deviceSerialNumberStrIx :: StrIx -- ^ Index of string descriptor+ -- containing device serial+ -- number.++ , deviceNumConfigs :: Word8 -- ^ Number of possible+ -- configurations.+ } deriving (Show, Eq, Data, Typeable)++-- | For a database of USB vendors and products see the /usb-id-database/+-- package at: <http://hackage.haskell.org/package/usb-id-database>+type VendorId = Word16+type ProductId = Word16++convertDeviceDesc :: C'libusb_device_descriptor -> DeviceDesc+convertDeviceDesc d =+ DeviceDesc+ { deviceUSBSpecReleaseNumber = convertBCD4 $+ libusb_device_descriptor'bcdUSB d+ , deviceClass = libusb_device_descriptor'bDeviceClass d+ , deviceSubClass = libusb_device_descriptor'bDeviceSubClass d+ , deviceProtocol = libusb_device_descriptor'bDeviceProtocol d+ , deviceMaxPacketSize0 = libusb_device_descriptor'bMaxPacketSize0 d+ , deviceVendorId = libusb_device_descriptor'idVendor d+ , deviceProductId = libusb_device_descriptor'idProduct d+ , deviceReleaseNumber = convertBCD4 $+ libusb_device_descriptor'bcdDevice d+ , deviceManufacturerStrIx = libusb_device_descriptor'iManufacturer d+ , deviceProductStrIx = libusb_device_descriptor'iProduct d+ , deviceSerialNumberStrIx = libusb_device_descriptor'iSerialNumber d+ , deviceNumConfigs = libusb_device_descriptor'bNumConfigurations d+ }++{-| Get the USB device descriptor for a given device.++This is a non-blocking function; the device descriptor is cached in memory.++This function may throw 'USBException's.+-}+getDeviceDesc :: Device -> IO DeviceDesc+getDeviceDesc dev =+ withDevice dev $ \devPtr ->+ alloca $ \devDescPtr -> do+ handleUSBException $ c'libusb_get_device_descriptor devPtr devDescPtr+ fmap convertDeviceDesc $ peek devDescPtr+++-- ** 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 'getActiveConfigDesc',+'getConfigDesc' or 'getConfigDescByValue'.+-}+data ConfigDesc = ConfigDesc+ { configValue :: ConfigValue -- ^ Identifier value for this+ -- configuration.++ , configStrIx :: StrIx -- ^ Index of string descriptor+ -- describing this configuration.+ , configAttribs :: ConfigAttribs+ -- ^ Configuration characteristics.+ , configMaxPower :: Word8 -- ^ Maximum power consumption of the+ -- USB device from this bus in this+ -- configuration when the device is+ -- fully operational. Expressed in+ -- 2 mA units (i.e., 50 = 100 mA).++ , configNumInterfaces :: Word8 -- ^ Number of interfaces supported by+ -- this configuration.+ , configInterfaces :: [[InterfaceDesc]]+ -- ^ List of interfaces supported by+ -- this configuration. An interface+ -- is represented as a list of+ -- alternate interface settings.+ -- Note that the length of this list+ -- should equal+ -- 'configNumInterfaces'.++ , configExtra :: B.ByteString+ -- ^ Extra descriptors. If libusb+ -- encounters unknown configuration+ -- descriptors, it will store them+ -- here, should you wish to parse+ -- them.+ } deriving (Show, Eq, Data, Typeable)++--------------------------------------------------------------------------------++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, Eq, Data, Typeable)++convertConfigAttribs :: Word8 -> ConfigAttribs+convertConfigAttribs a = DeviceStatus { remoteWakeup = testBit a 5+ , selfPowered = testBit a 6+ }++--------------------------------------------------------------------------------++{-| Get the USB configuration descriptor for the currently active+configuration.++This is a non-blocking function which does not involve any requests being sent+to the device.++Exceptions:++ * 'NotFoundException' if the device is in unconfigured state.++ * Another 'USBException'.+-}+getActiveConfigDesc :: Device -> IO ConfigDesc+getActiveConfigDesc dev =+ getConfigDescBy dev c'libusb_get_active_config_descriptor++{-| Get a USB configuration descriptor based on its index.++This is a non-blocking function which does not involve any requests being sent+to the device.++Exceptions:++ * 'NotFoundException' if the configuration does not exist.++ * Another 'USBException'.+-}+getConfigDesc :: Device -> Word8 -> IO ConfigDesc+getConfigDesc dev ix =+ getConfigDescBy dev $ \devPtr ->+ c'libusb_get_config_descriptor devPtr ix++{-| Get a USB configuration descriptor with a specific 'configValue'.++This is a non-blocking function which does not involve any requests being sent+to the device.++Exceptions:++ * 'NotFoundException' if the configuration does not exist.++ * Another 'USBException'.+-}+getConfigDescByValue :: Device -> ConfigValue -> IO ConfigDesc+getConfigDescByValue dev value =+ getConfigDescBy dev $ \devPtr ->+ c'libusb_get_config_descriptor_by_value devPtr value++--------------------------------------------------------------------------------++getConfigDescBy :: Device+ -> ( Ptr C'libusb_device+ -> Ptr (Ptr C'libusb_config_descriptor)+ -> IO CInt+ )+ -> IO ConfigDesc+getConfigDescBy dev f =+ withDevice dev $ \devPtr ->+ alloca $ \configDescPtrPtr -> do+ handleUSBException $ f devPtr configDescPtrPtr+ configDescPtr <- peek configDescPtrPtr+ configDesc <- peek configDescPtr >>= convertConfigDesc+ c'libusb_free_config_descriptor configDescPtr+ return configDesc++--------------------------------------------------------------------------------++convertConfigDesc :: C'libusb_config_descriptor -> IO ConfigDesc+convertConfigDesc c = do+ let numInterfaces = libusb_config_descriptor'bNumInterfaces c++ interfaces <- peekArray (fromIntegral numInterfaces)+ (libusb_config_descriptor'interface c) >>=+ mapM convertInterface++ extra <- B.packCStringLen+ ( castPtr $ libusb_config_descriptor'extra c+ , fromIntegral $ libusb_config_descriptor'extra_length c+ )++ return ConfigDesc+ { configValue = libusb_config_descriptor'bConfigurationValue c+ , configStrIx = libusb_config_descriptor'iConfiguration c+ , configAttribs = convertConfigAttribs $+ libusb_config_descriptor'bmAttributes c+ , configMaxPower = libusb_config_descriptor'MaxPower c+ , configNumInterfaces = numInterfaces+ , configInterfaces = interfaces+ , configExtra = extra+ }++convertInterface:: C'libusb_interface -> IO [InterfaceDesc]+convertInterface i =+ peekArray (fromIntegral $ libusb_interface'num_altsetting i)+ (libusb_interface'altsetting i) >>=+ mapM convertInterfaceDesc+++-- ** 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+ { interfaceNumber :: InterfaceNumber -- ^ Number of this+ -- interface.+ , interfaceAltSetting :: InterfaceAltSetting -- ^ Value used to select+ -- this alternate setting+ -- for this interface.+ , interfaceClass :: Word8 -- ^ USB-IF class code for+ -- this interface.+ , interfaceSubClass :: Word8 -- ^ USB-IF subclass code for+ -- this interface,+ -- qualified by the+ -- 'interfaceClass' value.+ , interfaceProtocol :: Word8 -- ^ USB-IF protocol code for+ -- this interface,+ -- qualified by the+ -- 'interfaceClass' and+ -- 'interfaceSubClass'+ -- values.+ , interfaceStrIx :: StrIx -- ^ Index of string+ -- descriptor describing+ -- this interface.+ , interfaceNumEndpoints :: Word8 -- ^ Number of endpoints used+ -- by this interface+ -- (excluding the control+ -- endpoint).+ , interfaceEndpoints :: [EndpointDesc]+ -- ^ List of endpoint+ -- descriptors. Note that+ -- the length of this list+ -- should equal+ -- 'interfaceNumEndpoints'.+ , interfaceExtra :: B.ByteString -- ^ Extra descriptors. If+ -- libusb encounters+ -- unknown interface+ -- descriptors, it will+ -- store them here, should+ -- you wish to parse them.+ } deriving (Show, Eq, Data, Typeable)++--------------------------------------------------------------------------------++convertInterfaceDesc :: C'libusb_interface_descriptor+ -> IO InterfaceDesc+convertInterfaceDesc i = do+ let n = libusb_interface_descriptor'bNumEndpoints i++ endpoints <- peekArray (fromIntegral n)+ (libusb_interface_descriptor'endpoint i) >>=+ mapM convertEndpointDesc++ extra <- B.packCStringLen+ ( castPtr $ libusb_interface_descriptor'extra i+ , fromIntegral $ libusb_interface_descriptor'extra_length i+ )++ return InterfaceDesc+ { interfaceNumber = libusb_interface_descriptor'bInterfaceNumber i+ , interfaceAltSetting = libusb_interface_descriptor'bAlternateSetting i+ , interfaceClass = libusb_interface_descriptor'bInterfaceClass i+ , interfaceSubClass = libusb_interface_descriptor'bInterfaceSubClass i+ , interfaceStrIx = libusb_interface_descriptor'iInterface i+ , interfaceProtocol = libusb_interface_descriptor'bInterfaceProtocol i+ , interfaceNumEndpoints = n+ , interfaceEndpoints = endpoints+ , interfaceExtra = extra+ }+++-- ** 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. All+multiple-byte fields are represented in host-endian format.++This structure can be retrieved using 'interfaceEndpoints'.+-}+data EndpointDesc = EndpointDesc+ { endpointAddress :: EndpointAddress+ -- ^ The address of the endpoint described+ -- by this descriptor.+ , endpointAttribs :: EndpointAttribs+ -- ^ Attributes which apply to the+ -- endpoint when it is configured using+ -- the 'configValue'.+ , endpointMaxPacketSize :: MaxPacketSize+ -- ^ Maximum packet size this endpoint is+ -- capable of sending/receiving.+ , endpointInterval :: Word8 -- ^ 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).+ , endpointRefresh :: Word8 -- ^ /For audio devices only:/ the rate at+ -- which synchronization feedback is+ -- provided.+ , endpointSynchAddress :: Word8 -- ^ /For audio devices only:/ the address+ -- if the synch endpoint.+ , endpointExtra :: B.ByteString+ -- ^ Extra descriptors. If libusb+ -- encounters unknown endpoint+ -- descriptors, it will store+ -- them here, should you wish to+ -- parse them.+ } deriving (Show, Eq, Data, Typeable)++--------------------------------------------------------------------------------++convertEndpointDesc :: C'libusb_endpoint_descriptor -> IO EndpointDesc+convertEndpointDesc e = do+ extra <- B.packCStringLen+ ( castPtr $ libusb_endpoint_descriptor'extra e+ , fromIntegral $ libusb_endpoint_descriptor'extra_length e+ )++ return EndpointDesc+ { endpointAddress = convertEndpointAddress $+ libusb_endpoint_descriptor'bEndpointAddress e+ , endpointAttribs = convertEndpointAttribs $+ libusb_endpoint_descriptor'bmAttributes e+ , endpointMaxPacketSize = convertMaxPacketSize $+ libusb_endpoint_descriptor'wMaxPacketSize e+ , endpointInterval = libusb_endpoint_descriptor'bInterval e+ , endpointRefresh = libusb_endpoint_descriptor'bRefresh e+ , endpointSynchAddress = libusb_endpoint_descriptor'bSynchAddress e+ , endpointExtra = extra+ }++--------------------------------------------------------------------------------++data EndpointAddress = EndpointAddress+ { endpointNumber :: Int -- ^ Must be >= 0 and <= 15+ , endpointDirection :: TransferDirection+ } deriving (Show, Eq, Data, Typeable)++convertEndpointAddress :: Word8 -> EndpointAddress+convertEndpointAddress a = EndpointAddress (fromIntegral $ bits 0 3 a)+ (if testBit a 7 then In else Out)++marshallEndpointAddress :: EndpointAddress -> CUChar+marshallEndpointAddress (EndpointAddress number direction)+ | between number 0 15 = let n = fromIntegral number+ in case direction of+ Out -> n+ In -> setBit n 7+ | otherwise =+ error "marshallEndpointAddress: endpointNumber not >= 0 and <= 15"++-- | Direction of data transfer relative to the host.+data TransferDirection = Out -- ^ Host to device.+ | In -- ^ Device to host.+ deriving (Enum, Show, Eq, Data, Typeable)++--------------------------------------------------------------------------------++type EndpointAttribs = TransferType++data TransferType = Control+ | Isochronous Synchronization Usage+ | Bulk+ | Interrupt+ deriving (Show, Eq, Data, Typeable)++data Synchronization = NoSynchronization+ | Asynchronous+ | Adaptive+ | Synchronous+ deriving (Enum, Show, Eq, Data, Typeable)++data Usage = Data+ | Feedback+ | Implicit+ deriving (Enum, Show, Eq, Data, Typeable)++convertEndpointAttribs :: Word8 -> EndpointAttribs+convertEndpointAttribs 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 "convertEndpointAttribs: this can't happen!"++--------------------------------------------------------------------------------++data MaxPacketSize = MaxPacketSize+ { maxPacketSize :: Int+ , transactionOpportunities :: TransactionOpportunities+ } deriving (Show, Eq, Data, Typeable)++data TransactionOpportunities = NoAdditionalTransactions+ | OneAdditionlTransaction+ | TwoAdditionalTransactions+ deriving (Enum, Show, Eq, Data, Typeable)++convertMaxPacketSize :: Word16 -> MaxPacketSize+convertMaxPacketSize m =+ MaxPacketSize+ { maxPacketSize = fromIntegral $ bits 0 10 m+ , transactionOpportunities = genToEnum $ bits 11 12 m+ }+++-- ** String descriptors -------------------------------------------------------++{-| Retrieve a list of supported languages.++This function may throw 'USBException's.+-}+getLanguages :: DeviceHandle -> IO [LangId]+getLanguages devHndl =+ let maxSize = 255 -- Some devices choke on size > 255+ in allocaArray maxSize $ \dataPtr -> do+ reportedSize <- putStrDesc devHndl 0 0 maxSize dataPtr+ fmap (fmap convertLangId) $+ peekArray ((reportedSize - 2) `div` 2)+ (castPtr $ dataPtr `plusPtr` 2)+++{-| @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 Int+putStrDesc devHndl strIx langId maxSize dataPtr = do+ actualSize <- checkUSBException $ c'libusb_get_string_descriptor+ (devHndlPtr devHndl)+ strIx+ langId+ dataPtr+ (fromIntegral maxSize)++ -- if there're enough bytes, parse the header+ when (actualSize < 2) $ throwIO IOException+ reportedSize <- peek dataPtr+ descType <- peekElemOff dataPtr 1++ -- Check header correctness:+ when ( descType /= c'LIBUSB_DT_STRING+ || reportedSize > fromIntegral actualSize+ ) $ throwIO IOException++ 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++convertLangId :: Word16 -> LangId+convertLangId = bits 0 9 &&& bits 10 15++marshallLangId :: LangId -> Word16+marshallLangId (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 is a convenience function which formulates the appropriate control message+to retrieve the descriptor. The string returned is Unicode, as detailed in the+USB specifications.++This function may throw 'USBException's.+-}+getStrDesc :: DeviceHandle -> StrIx -> LangId -> Size -> IO String+getStrDesc devHndl strIx langId size =+ fmap (T.unpack . TE.decodeUtf16LE . B.drop 2) $+ BI.createAndTrim size $ putStrDesc+ devHndl+ strIx+ (marshallLangId langId)+ size+ . castPtr++{-| Retrieve a string descriptor from a device using the first supported+language.++This is a convenience function which formulates the appropriate control message+to retrieve the descriptor. The string returned is Unicode, as detailed in the+USB specifications.++This function may throw 'USBException's.+-}+getStrDescFirstLang :: DeviceHandle -> StrIx -> Size -> IO String+getStrDescFirstLang devHndl descStrIx size =+ do langIds <- getLanguages devHndl+ case langIds of+ [] -> throwIO IOException+ (langId : _) -> getStrDesc devHndl descStrIx langId size+++--------------------------------------------------------------------------------+-- 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+--------------------------------------------------------------------------------++-- | A timeout in milliseconds. Use 0 to indicate no timeout.+type Timeout = Int++-- | Number of bytes transferred.+type Size = Int++--------------------------------------------------------------------------------++data RequestType = Standard+ | Class+ | Vendor+ deriving (Enum, Show, Eq, Data, Typeable)++data Recipient = ToDevice+ | ToInterface+ | ToEndpoint+ | ToOther+ deriving (Enum, Show, Eq, Data, Typeable)++marshallRequestType :: RequestType -> Recipient -> Word8+marshallRequestType t r = genFromEnum t `shiftL` 5 .|. genFromEnum r+++-- ** Control transfers --------------------------------------------------------++{-| Perform a USB /control/ request that does not transfer data.++The /value/ and /index/ values should be given in host-endian byte order.++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 -- ^ A handle for the device to communicate with.+ -> RequestType -- ^ The type of request.+ -> Recipient -- ^ The recipient of the request.+ -> Word8 -- ^ Request.+ -> Word16 -- ^ Value.+ -> Word16 -- ^ Index.+ -> Timeout -- ^ Timeout (in milliseconds) that this function should+ -- wait before giving up due to no response being+ -- received. For no timeout, use value 0.+ -> IO ()+control devHndl reqType reqRecipient request value index timeout =+ ignore . checkUSBException $ c'libusb_control_transfer+ (devHndlPtr devHndl)+ (marshallRequestType reqType reqRecipient)+ request+ value+ index+ nullPtr+ 0+ (fromIntegral timeout)++{-| Perform a USB /control/ read.++The /value/ and /index/ values should be given in host-endian byte order.++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'.+-}+readControl :: DeviceHandle -- ^ A handle for the device to communicate with.+ -> RequestType -- ^ The type of request.+ -> Recipient -- ^ The recipient of the request.+ -> Word8 -- ^ Request.+ -> Word16 -- ^ Value.+ -> Word16 -- ^ Index.+ -> Size -- ^ The maximum number of bytes to read.+ -> Timeout -- ^ Timeout (in milliseconds) that this function+ -- should wait before giving up due to no response+ -- being received. For no timeout, use value 0.+ -> IO B.ByteString+readControl devHndl reqType reqRecipient request value index size timeout =+ BI.createAndTrim size $ \dataPtr ->+ checkUSBException $ c'libusb_control_transfer+ (devHndlPtr devHndl)+ (setBit (marshallRequestType reqType reqRecipient) 7)+ request+ value+ index+ (castPtr dataPtr)+ (fromIntegral size)+ (fromIntegral timeout)++{-| Perform a USB /control/ write.++The /value/ and /index/ values should be given in host-endian byte order.++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'.+-}+writeControl :: DeviceHandle -- ^ A handle for the device to communicate with.+ -> RequestType -- ^ The type of request.+ -> Recipient -- ^ The recipient of the request.+ -> Word8 -- ^ Request.+ -> Word16 -- ^ Value.+ -> Word16 -- ^ Index.+ -> B.ByteString -- ^ The ByteString to write,+ -> Timeout -- ^ Timeout (in milliseconds) that this function+ -- should wait before giving up due to no+ -- response being received. For no timeout, use+ -- value 0.+ -> IO Size+writeControl devHndl reqType reqRecipient request value index input timeout =+ input `writeWith` \dataPtr size ->+ checkUSBException $ c'libusb_control_transfer+ (devHndlPtr devHndl)+ (marshallRequestType reqType reqRecipient)+ request+ value+ index+ (castPtr dataPtr)+ (fromIntegral size)+ (fromIntegral timeout)+++-- ** Bulk transfers -----------------------------------------------------------++{-| Perform a USB /bulk/ read.++Exceptions:++ * 'TimeoutException' if the transfer timed out.++ * '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 endpoint to communicate+ -- with. Because we are reading, make sure this is+ -- an 'In' endpoint!!! If it isn't the behaviour+ -- is undefined.+ -> Size -- ^ The maximum number of bytes to read.+ -> Timeout -- ^ Timeout (in milliseconds) that this function+ -- should wait before giving up due to no response+ -- being received. For no timeout, use value 0.+ -> IO B.ByteString -- ^ The function returns the ByteString that was+ -- read. Note that the length of this ByteString+ -- <= the requested size to read.+readBulk = readTransfer c'libusb_bulk_transfer++{-| Perform a USB /bulk/ write.++Exceptions:++ * 'TimeoutException' if the transfer timed out.++ * '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 endpoint to communicate+ -- with. Because we are writing, make sure this+ -- is an 'Out' endpoint!!! If it isn't the+ -- behaviour is undefined.+ -> B.ByteString -- ^ The ByteString to write.+ -> Timeout -- ^ Timeout (in milliseconds) that this function+ -- should wait before giving up due to no+ -- response being received. For no timeout, use+ -- value 0.+ -> IO Size -- ^ The function returns the number of bytes+ -- actually written.+writeBulk = writeTransfer c'libusb_bulk_transfer+++-- ** Interrupt transfers ------------------------------------------------------++{-| Perform a USB /interrupt/ read.++Exceptions:++ * 'TimeoutException' if the transfer timed out.++ * '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 endpoint to+ -- communicate with. Because we are reading,+ -- make sure this is an 'In' endpoint!!! If+ -- it isn't the behaviour is undefined.+ -> Size -- ^ The maximum number of bytes to read.+ -> Timeout -- ^ Timeout (in milliseconds) that this+ -- function should wait before giving up due+ -- to no response being received. For no+ -- timeout, use value 0.+ -> IO B.ByteString -- ^ The function returns the ByteString that+ -- was read. Note that the length of this+ -- ByteString <= the requested size to read.+readInterrupt = readTransfer c'libusb_interrupt_transfer++{-| Perform a USB /interrupt/ write.++Exceptions:++ * 'TimeoutException' if the transfer timed out.++ * '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 endpoint to+ -- communicate with. Because we are writing,+ -- make sure this is an 'Out' endpoint!!! If+ -- it isn't the behaviour is undefined.+ -> B.ByteString -- ^ The ByteString to write.+ -> Timeout -- ^ Timeout (in milliseconds) that this+ -- function should wait before giving up due+ -- to no response being received. For no+ -- timeout, use value 0.+ -> IO Size -- ^ The function returns the number of bytes+ -- actually written.+writeInterrupt = writeTransfer c'libusb_interrupt_transfer++----------------------------------------++type TransferFunc = Ptr C'libusb_device_handle -- devHndlPtr+ -> CUChar -- endpoint address+ -> Ptr CUChar -- dataPtr+ -> CInt -- size+ -> Ptr CInt -- transferredPtr+ -> CUInt -- timeout+ -> IO CInt -- error++readTransfer :: TransferFunc+ -> DeviceHandle+ -> EndpointAddress+ -> Size+ -> Timeout+ -> IO B.ByteString+(readTransfer doReadTransfer) devHndl endpoint size timeout =+ BI.createAndTrim size $ \dataPtr ->+ alloca $ \transferredPtr -> do+ handleUSBException $ doReadTransfer+ (devHndlPtr devHndl)+ (marshallEndpointAddress endpoint)+ (castPtr dataPtr)+ (fromIntegral size)+ transferredPtr+ (fromIntegral timeout)+ fmap fromIntegral $ peek transferredPtr++writeTransfer :: TransferFunc+ -> DeviceHandle+ -> EndpointAddress+ -> B.ByteString+ -> Timeout+ -> IO Size+(writeTransfer doWriteTransfer) devHndl endpoint input timeout =+ input `writeWith` \dataPtr size ->+ alloca $ \transferredPtr -> do+ handleUSBException $ doWriteTransfer+ (devHndlPtr devHndl)+ (marshallEndpointAddress endpoint)+ (castPtr dataPtr)+ (fromIntegral size)+ transferredPtr+ (fromIntegral timeout)+ fmap fromIntegral $ peek transferredPtr+++--------------------------------------------------------------------------------+-- 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 :: IO CInt -> 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 :: CInt -> USBException+convertUSBException err = fromMaybe unknownLibUsbError $+ lookup err libusb_error_to_USBException++unknownLibUsbError :: error+unknownLibUsbError = error "Unknown Libusb error"++-- | Association list mapping 'C'libusb_error's to 'USBException's.+libusb_error_to_USBException :: [(CInt, 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 -- ^ 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, Data, Typeable)++instance Exception USBException+++--------------------------------------------------------------------------------+-- Utils+--------------------------------------------------------------------------------++-- | A decoded 16 bits Binary Coded Decimal using 4 bits for each digit.+type BCD4 = (Int, Int, Int, Int)++convertBCD4 :: Word16 -> BCD4+convertBCD4 bcd = let [a, b, c, d] = fmap fromIntegral $ decodeBCD 4 bcd+ in (a, b, c, d)++{-| @decodeBCD bitsInDigit n@ decodes the Binary Coded Decimal @n@ to a list of+its encoded digits. @bitsInDigit@, which is usually 4, is the number of bits+used to encode a single digit. See:+<http://en.wikipedia.org/wiki/Binary-coded_decimal>+-}+decodeBCD :: Bits a => Int -> a -> [a]+decodeBCD bitsInDigit n = go shftR []+ where+ shftR = bitSize n - bitsInDigit++ go shftL ds | shftL < 0 = ds+ | otherwise = go (shftL - bitsInDigit)+ (((n `shiftL` shftL) `shiftR` shftR) : ds)++-- | @bits s e b@ extract bit @s@ to @e@ (including) from @b@.+bits :: Bits a => Int -> Int -> a -> a+bits s e b = (2 ^ (e - s + 1) - 1) .&. (b `shiftR` s)++between :: Ord a => a -> a -> a -> Bool+between n b e = n >= b && n <= e++-- | Execute the given action but ignore the result.+ignore :: Monad m => m a -> m ()+ignore = (>> return ())++-- | A generalized 'toEnum' that works on any 'Integral' type.+genToEnum :: (Integral i, Enum e) => i -> e+genToEnum = toEnum . fromIntegral++-- | A generalized 'fromEnum' that returns any 'Integral' type.+genFromEnum :: (Integral i, Enum e) => e -> i+genFromEnum = fromIntegral . fromEnum++-- | @input `writeWith` doWrite@ first converts the @input@ @ByteString@ to an+-- array of @Word8@s, then @doWrite@ is executed by pointing it to this array+-- and the size of this array. Finally, the result of @doWrite@ is returned.+--+-- /Make sure not to return the pointer to the array from @doWrite@!/+--+-- /Note that the converion from the @ByteString@ to the @Word8@ array is O(1)./+writeWith :: B.ByteString -> (Ptr Word8 -> Size -> IO a) -> IO a+input `writeWith` doWrite =+ let (dataFrgnPtr, _, size) = BI.toForeignPtr input+ in withForeignPtr dataFrgnPtr $ \dataPtr -> doWrite dataPtr size+++-- The End ---------------------------------------------------------------------
+ usb.cabal view
@@ -0,0 +1,34 @@+name: usb+version: 0.1+cabal-version: >=1.6+build-type: Simple+license: BSD3+license-file: LICENSE+copyright: 2009 Bas van Dijk+author: Bas van Dijk+maintainer: Bas van Dijk <v.dijk.bas@gmail.com>+stability: experimental+category: System+synopsis: Communicate with USB devices+description: This library enables you to communicate with USB devices from+ userspace. It is implemented as a high-level wrapper around+ bindings-libusb which is a low-level binding to the C library:+ libusb-1.*.++source-repository head+ Type: darcs+ Location: http://code.haskell.org/~basvandijk/code/usb++Library+ GHC-Options: -O2 -Wall+ build-depends: base >= 4 && < 4.2+ , bytestring == 0.9.*+ , text == 0.4.*+ , bindings-libusb == 1.1.*+ exposed-modules: System.USB+ System.USB.Initialization+ System.USB.DeviceHandlingAndEnumeration+ System.USB.Descriptors+ System.USB.IO.Synchronous+ System.USB.Exceptions+ other-modules: System.USB.Internal