diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/System/USB.hs b/System/USB.hs new file mode 100644 --- /dev/null +++ b/System/USB.hs @@ -0,0 +1,48 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : System.USB +-- Copyright : (c) 2009 Bas van Dijk +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Bas van Dijk +-- 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: +-- +-- +-- +-- Besides this API documentation the following sources might be interesting: +-- +-- * The libusb 1.0 documentation at: +-- +-- +-- * The USB 2.0 specification at: +-- +-- +-- * The 'Bindings.Libusb' documentation at: +-- +-- +-------------------------------------------------------------------------------- + +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 diff --git a/System/USB/Descriptors.hs b/System/USB/Descriptors.hs new file mode 100644 --- /dev/null +++ b/System/USB/Descriptors.hs @@ -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 + ) diff --git a/System/USB/DeviceHandlingAndEnumeration.hs b/System/USB/DeviceHandlingAndEnumeration.hs new file mode 100644 --- /dev/null +++ b/System/USB/DeviceHandlingAndEnumeration.hs @@ -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 + ) + diff --git a/System/USB/Exceptions.hs b/System/USB/Exceptions.hs new file mode 100644 --- /dev/null +++ b/System/USB/Exceptions.hs @@ -0,0 +1,8 @@ +module System.USB.Exceptions + ( USBException(..) + ) where + +import System.USB.Internal + ( USBException(..) + ) + diff --git a/System/USB/IO/Synchronous.hs b/System/USB/IO/Synchronous.hs new file mode 100644 --- /dev/null +++ b/System/USB/IO/Synchronous.hs @@ -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 + ) diff --git a/System/USB/Initialization.hs b/System/USB/Initialization.hs new file mode 100644 --- /dev/null +++ b/System/USB/Initialization.hs @@ -0,0 +1,12 @@ +module System.USB.Initialization + ( Ctx + , newCtx + , setDebug + , Verbosity(..) + ) where + +import System.USB.Internal ( Ctx + , newCtx + , setDebug + , Verbosity(..) + ) diff --git a/System/USB/Internal.hs b/System/USB/Internal.hs new file mode 100644 --- /dev/null +++ b/System/USB/Internal.hs @@ -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: +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: + + + +For a mapping between IDs and languages see the /usb-id-database/ package at: + + + +To see which 'LangId's are supported by a device see 'getLanguages'. +-} +type LangId = (PrimaryLangId, SubLangId) +type PrimaryLangId = Word16 +type SubLangId = Word16 + +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: + . + + * '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: + . + + * '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: + . + + * '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: + . + + * '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: + +-} +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 --------------------------------------------------------------------- diff --git a/usb.cabal b/usb.cabal new file mode 100644 --- /dev/null +++ b/usb.cabal @@ -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 +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