usb 0.3 → 0.3.0.1
raw patch · 5 files changed
+510/−464 lines, 5 filesdep +base-unicode-symbolsdep ~basedep ~text
Dependencies added: base-unicode-symbols
Dependency ranges changed: base, text
Files
- System/USB/DeviceHandling.hs +1/−1
- System/USB/IO/Synchronous.hs +3/−0
- System/USB/IO/Synchronous/Enumerator.hs +13/−3
- System/USB/Internal.hs +487/−455
- usb.cabal +6/−5
System/USB/DeviceHandling.hs view
@@ -5,7 +5,7 @@ -- License : BSD3 (see the file LICENSE) -- Maintainer : Bas van Dijk <v.dijk.bas@gmail.com> ----- The module provides functionality for opening, closing and configuring a USB+-- The module provides functionality for opening, closing and configuring USB -- devices. -- --------------------------------------------------------------------------------
System/USB/IO/Synchronous.hs view
@@ -5,6 +5,9 @@ -- License : BSD3 (see the file LICENSE) -- Maintainer : Bas van Dijk <v.dijk.bas@gmail.com> --+-- This module provides functionality for performing control, bulk and interrupt+-- transfers.+-- -------------------------------------------------------------------------------- module System.USB.IO.Synchronous
System/USB/IO/Synchronous/Enumerator.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} --------------------------------------------------------------------------------@@ -23,9 +24,18 @@ import System.USB.Internal -- from base:-import Foreign.Marshal.Alloc ( malloc, mallocBytes, free )-import Foreign.Storable ( Storable, peek, sizeOf )-import Foreign.Ptr ( Ptr, castPtr )+import Prelude ( (*), fromIntegral, undefined )+import Data.Function ( ($), (.) )+import Data.Eq ( (/=) )+import Data.Bool ( (&&) )+import Data.Int ( Int )+import Data.Maybe ( Maybe(Nothing, Just) )+import Control.Monad ( Monad, return, (>>=), fail )+import System.IO ( IO )+import Text.Show ( show )+import Foreign.Marshal.Alloc ( malloc, mallocBytes, free )+import Foreign.Storable ( Storable, peek, sizeOf )+import Foreign.Ptr ( Ptr, castPtr ) -- from bindings-libusb: import Bindings.Libusb
System/USB/Internal.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DeriveDataTypeable #-} module System.USB.Internal where@@ -8,6 +10,11 @@ -------------------------------------------------------------------------------- -- from base:+import Prelude ( Num, (+), (-), fromInteger, (^)+ , Integral, fromIntegral, div+ , Enum, fromEnum, toEnum+ , error+ ) import Foreign ( unsafePerformIO ) import Foreign.C.Types ( CUChar, CInt, CUInt ) import Foreign.Marshal.Alloc ( alloca )@@ -17,41 +24,60 @@ import Foreign.ForeignPtr ( ForeignPtr, newForeignPtr, withForeignPtr) import Control.Exception ( Exception , throwIO- , bracket- , bracket_- , block- , unblock+ , bracket, bracket_+ , block, unblock , onException )-import Control.Monad ( fmap, when, forM, liftM )+import Control.Monad ( Monad, return, (>>=), fail+ , (>>), (=<<), when, forM, liftM, mapM+ , fmap+ ) import Control.Arrow ( (&&&) )+import Data.Function ( ($), flip ) import Data.Data ( Data ) import Data.Typeable ( Typeable ) import Data.Maybe ( fromMaybe )+import Data.List ( lookup )+import Data.Int ( Int ) import Data.Word ( Word8, Word16 )+import Data.Char ( String )+import Data.Eq ( Eq, (==) )+import Data.Ord ( Ord, (<), (>) )+import Data.Bool ( Bool(False, True)+ , not, otherwise+ ) import Data.Bits ( Bits , (.|.), (.&.) , setBit, testBit , shiftR, shiftL , bitSize )+import System.IO ( IO )+import Text.Show ( Show ) +-- from base-unicode-symbols:+import Prelude.Unicode ( (⋅) )+import Data.Function.Unicode ( (∘) )+import Data.Bool.Unicode ( (∧), (∨) )+import Data.Eq.Unicode ( (≢), (≡) )+import Data.Ord.Unicode ( (≥), (≤) )+ -- from bytestring:-import qualified Data.ByteString as B ( ByteString- , packCStringLen- , drop- , head- , length- , unpack- )+import qualified Data.ByteString as B ( ByteString+ , packCStringLen+ , drop+ , head+ , length+ , unpack+ ) import qualified Data.ByteString.Internal as BI ( createAndTrim , createAndTrim' , toForeignPtr ) -- from text:-import qualified Data.Text as T ( unpack )-import qualified Data.Text.Encoding as TE ( decodeUtf16LE )+import qualified Data.Text as T ( unpack )+import qualified Data.Text.Encoding as TE ( decodeUtf16LE ) -- from bindings-libusb: import Bindings.Libusb@@ -71,18 +97,18 @@ The only functions that receive a @Ctx@ are 'setDebug' and 'getDevices'. -}-newtype Ctx = Ctx { unCtx :: ForeignPtr C'libusb_context }+newtype Ctx = Ctx { unCtx ∷ ForeignPtr C'libusb_context } -withCtxPtr :: Ctx -> (Ptr C'libusb_context -> IO a) -> IO a-withCtxPtr = withForeignPtr . unCtx+withCtxPtr ∷ Ctx → (Ptr C'libusb_context → IO α) → IO α+withCtxPtr = withForeignPtr ∘ unCtx -- | Create and initialize a new USB context. -- -- This function may throw 'USBException's.-newCtx :: IO Ctx-newCtx = alloca $ \ctxPtrPtr -> do+newCtx ∷ IO Ctx+newCtx = alloca $ \ctxPtrPtr → do handleUSBException $ c'libusb_init ctxPtrPtr- peek ctxPtrPtr >>= fmap Ctx . newForeignPtr p'libusb_exit+ peek ctxPtrPtr >>= fmap Ctx ∘ newForeignPtr p'libusb_exit {-| Set message verbosity. @@ -104,9 +130,9 @@ 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 → IO () setDebug ctx verbosity =- withCtxPtr ctx $ \ctxPtr ->+ withCtxPtr ctx $ \ctxPtr → c'libusb_set_debug ctxPtr $ genFromEnum verbosity -- | Message verbosity@@ -140,18 +166,18 @@ using 'deviceDesc'. -} data Device = Device- { _ctx :: 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.+ { _ctx ∷ 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. - , getDevFrgnPtr :: ForeignPtr C'libusb_device+ , getDevFrgnPtr ∷ ForeignPtr C'libusb_device - , deviceDesc :: DeviceDesc -- ^ Get the USB device descriptor for a given- -- device.+ , deviceDesc ∷ DeviceDesc -- ^ Get the USB device descriptor for a given+ -- device. } -withDevicePtr :: Device -> (Ptr C'libusb_device -> IO a) -> IO a-withDevicePtr = withForeignPtr . getDevFrgnPtr+withDevicePtr ∷ Device → (Ptr C'libusb_device → IO α) → IO α+withDevicePtr = withForeignPtr ∘ getDevFrgnPtr {-| Returns a list of USB devices currently attached to the system. @@ -163,45 +189,46 @@ -} -{- Visual description of the 'devPtrArrayPtr':- D- /\ D- D | /\- /\ | |- | | |-devPtrArrayPtr: _|_ _|_ ___ ___ _|_- P----> | P | P | P | P | P |- |___|___|___|___|___|- | |-P = pointer | |-D = device structure \/ |- D |- \/- D+{- +Visual description of the 'devPtrArrayPtr':++ D+ ^ D+ D │ ^ + ^ │ │+ │ │ │+devPtrArrayPtr: ┏━┷━┳━┷━┳━━━┳━━━┳━┷━┓+ P ───> ┃ P ┃ P ┃ P ┃ P ┃ P ┃+ ┗━━━┻━━━┻━┯━┻━┯━┻━━━┛+ │ │+P = pointer v │+D = device structure D │+ v+ D -}-getDevices :: Ctx -> IO [Device]+getDevices ∷ Ctx → IO [Device] getDevices ctx =- withCtxPtr ctx $ \ctxPtr ->- alloca $ \devPtrArrayPtr -> block $ do+ withCtxPtr ctx $ \ctxPtr →+ alloca $ \devPtrArrayPtr → block $ do - numDevs <- c'libusb_get_device_list ctxPtr devPtrArrayPtr- devPtrArray <- peek devPtrArrayPtr+ numDevs ← c'libusb_get_device_list ctxPtr devPtrArrayPtr+ devPtrArray ← peek devPtrArrayPtr let freeDevPtrArray = c'libusb_free_device_list devPtrArray 0 - devs <- flip onException freeDevPtrArray $ unblock $+ devs ← flip onException freeDevPtrArray $ unblock $ case numDevs of- n | n == c'LIBUSB_ERROR_NO_MEM -> throwIO NoMemException- | n < 0 -> unknownLibUsbError- | otherwise -> alloca $ \devDescPtr -> do- devPtrs <- peekArray (fromIntegral numDevs) devPtrArray- forM devPtrs $ \devPtr -> do- devFrgnPtr <- newForeignPtr p'libusb_unref_device devPtr+ n | n ≡ c'LIBUSB_ERROR_NO_MEM → throwIO NoMemException+ | n < 0 → unknownLibUsbError+ | otherwise → alloca $ \devDescPtr → do+ devPtrs ← peekArray (fromIntegral numDevs) devPtrArray+ forM devPtrs $ \devPtr → do+ devFrgnPtr ← newForeignPtr p'libusb_unref_device devPtr handleUSBException $ c'libusb_get_device_descriptor devPtr devDescPtr- devDesc <- convertDeviceDesc devPtr =<< peek devDescPtr+ devDesc ← convertDeviceDesc devPtr =<< peek devDescPtr return $ Device ctx devFrgnPtr devDesc @@ -209,14 +236,20 @@ return devs -- | Get the number of the bus that a device is connected to.-busNumber :: Device -> Word8-busNumber dev = unsafePerformIO+busNumber ∷ Device → Word8+busNumber dev = -- Getting the bus number from libusb is a side-effect free+ -- operation. The bus number is a static variable in the device+ -- structure. That's why it's safe to use:+ unsafePerformIO $ withDevicePtr dev $ c'libusb_get_bus_number -- | Get the address of the device on the bus it is connected to.-deviceAddress :: Device -> Word8-deviceAddress dev = unsafePerformIO+deviceAddress ∷ Device → Word8+deviceAddress dev = -- Getting the device address from libusb is a side-effect+ -- free operation. The device address is a static variable+ -- in the device structure. That's why it's safe to use:+ unsafePerformIO $ withDevicePtr dev $ c'libusb_get_device_address @@ -236,10 +269,10 @@ a device handle, you should close it by applying 'closeDevice' to it. -} data DeviceHandle = DeviceHandle- { getDevice :: Device -- This reference is needed for keeping the 'Device'- -- and therefor the 'Ctx' alive.- -- ^ Retrieve the 'Device' from the 'DeviceHandle'.- , getDevHndlPtr :: Ptr C'libusb_device_handle+ { getDevice ∷ Device -- This reference is needed for keeping the 'Device'+ -- and therefor the 'Ctx' alive.+ -- ^ Retrieve the 'Device' from the 'DeviceHandle'.+ , getDevHndlPtr ∷ Ptr C'libusb_device_handle } {-| Open a device and obtain a device handle.@@ -261,9 +294,9 @@ * Another 'USBException'. -}-openDevice :: Device -> IO DeviceHandle-openDevice dev = withDevicePtr dev $ \devPtr ->- alloca $ \devHndlPtrPtr -> do+openDevice ∷ Device → IO DeviceHandle+openDevice dev = withDevicePtr dev $ \devPtr →+ alloca $ \devHndlPtrPtr → do handleUSBException $ c'libusb_open devPtr devHndlPtrPtr liftM (DeviceHandle dev) $ peek devHndlPtrPtr @@ -274,15 +307,15 @@ This is a non-blocking function; no requests are sent over the bus. -}-closeDevice :: DeviceHandle -> IO ()-closeDevice = c'libusb_close . getDevHndlPtr+closeDevice ∷ DeviceHandle → IO ()+closeDevice = c'libusb_close ∘ getDevHndlPtr {-| @withDeviceHandle dev act@ opens the 'Device' @dev@ and passes the resulting handle to the computation @act@. The handle will be closed on exit from @withDeviceHandle@ whether by normal termination or by raising an exception. -}-withDeviceHandle :: Device -> (DeviceHandle -> IO a) -> IO a+withDeviceHandle ∷ Device → (DeviceHandle → IO α) → IO α withDeviceHandle dev = bracket (openDevice dev) closeDevice --------------------------------------------------------------------------------@@ -312,9 +345,9 @@ * Aanother 'USBException'. -}-getConfig :: DeviceHandle -> IO ConfigValue+getConfig ∷ DeviceHandle → IO ConfigValue getConfig devHndl =- alloca $ \configPtr -> do+ alloca $ \configPtr → do handleUSBException $ c'libusb_get_configuration (getDevHndlPtr devHndl) configPtr fmap fromIntegral $ peek configPtr@@ -355,11 +388,11 @@ * Another 'USBException'. -}-setConfig :: DeviceHandle -> ConfigValue -> IO ()+setConfig ∷ DeviceHandle → ConfigValue → IO () setConfig devHndl = handleUSBException- . c'libusb_set_configuration (getDevHndlPtr devHndl)- . fromIntegral+ ∘ c'libusb_set_configuration (getDevHndlPtr devHndl)+ ∘ fromIntegral -------------------------------------------------------------------------------- -- ** Claiming & releasing interfaces@@ -397,7 +430,7 @@ * Another 'USBException'. -} -claimInterface :: DeviceHandle -> InterfaceNumber -> IO ()+claimInterface ∷ DeviceHandle → InterfaceNumber → IO () claimInterface (DeviceHandle _ devHndlPtr) ifNum = handleUSBException $ c'libusb_claim_interface devHndlPtr (fromIntegral ifNum)@@ -417,7 +450,7 @@ * Another 'USBException'. -}-releaseInterface :: DeviceHandle -> InterfaceNumber -> IO ()+releaseInterface ∷ DeviceHandle → InterfaceNumber → IO () releaseInterface (DeviceHandle _ devHndlPtr) ifNum = handleUSBException $ c'libusb_release_interface devHndlPtr (fromIntegral ifNum)@@ -426,7 +459,7 @@ executes the given computation. On exit from @withClaimedInterface@, the interface is released whether by normal termination or by raising an exception. -}-withClaimedInterface :: DeviceHandle -> InterfaceNumber -> IO a -> IO a+withClaimedInterface ∷ DeviceHandle → InterfaceNumber → IO α → IO α withClaimedInterface devHndl ifNum = bracket_ (claimInterface devHndl ifNum) (releaseInterface devHndl ifNum) @@ -459,10 +492,10 @@ * Another 'USBException'. -}-setInterfaceAltSetting :: DeviceHandle- -> InterfaceNumber- -> InterfaceAltSetting- -> IO ()+setInterfaceAltSetting ∷ DeviceHandle+ → InterfaceNumber+ → InterfaceAltSetting+ → IO () setInterfaceAltSetting devHndl ifNum alternateSetting = handleUSBException $ c'libusb_set_interface_alt_setting (getDevHndlPtr devHndl)@@ -491,11 +524,11 @@ * Another 'USBException'. -}-clearHalt :: DeviceHandle -> EndpointAddress -> IO ()+clearHalt ∷ DeviceHandle → EndpointAddress → IO () clearHalt devHndl = handleUSBException- . c'libusb_clear_halt (getDevHndlPtr devHndl)- . marshalEndpointAddress+ ∘ c'libusb_clear_halt (getDevHndlPtr devHndl)+ ∘ marshalEndpointAddress {-| Perform a USB port reset to reinitialize a device. @@ -517,8 +550,8 @@ * Another 'USBException'. -}-resetDevice :: DeviceHandle -> IO ()-resetDevice = handleUSBException . c'libusb_reset_device . getDevHndlPtr+resetDevice ∷ DeviceHandle → IO ()+resetDevice = handleUSBException ∘ c'libusb_reset_device ∘ getDevHndlPtr -------------------------------------------------------------------------------- -- ** USB kernel drivers@@ -535,14 +568,14 @@ * Another 'USBException'. -}-kernelDriverActive :: DeviceHandle -> InterfaceNumber -> IO Bool+kernelDriverActive ∷ DeviceHandle → InterfaceNumber → IO Bool kernelDriverActive devHndl ifNum = do- r <- c'libusb_kernel_driver_active (getDevHndlPtr devHndl)+ r ← c'libusb_kernel_driver_active (getDevHndlPtr devHndl) (fromIntegral ifNum) case r of- 0 -> return False- 1 -> return True- _ -> throwIO $ convertUSBException r+ 0 → return False+ 1 → return True+ _ → throwIO $ convertUSBException r {-| Detach a kernel driver from an interface. @@ -558,7 +591,7 @@ * Another 'USBException'. -}-detachKernelDriver :: DeviceHandle -> InterfaceNumber -> IO ()+detachKernelDriver ∷ DeviceHandle → InterfaceNumber → IO () detachKernelDriver devHndl ifNum = handleUSBException $ c'libusb_detach_kernel_driver (getDevHndlPtr devHndl) (fromIntegral ifNum)@@ -579,7 +612,7 @@ * Another 'USBException'. -}-attachKernelDriver :: DeviceHandle -> InterfaceNumber -> IO ()+attachKernelDriver ∷ DeviceHandle → InterfaceNumber → IO () attachKernelDriver devHndl ifNum = handleUSBException $ c'libusb_attach_kernel_driver (getDevHndlPtr devHndl) (fromIntegral ifNum)@@ -596,7 +629,7 @@ * Another 'USBException'. -}-withDetachedKernelDriver :: DeviceHandle -> InterfaceNumber -> IO a -> IO a+withDetachedKernelDriver ∷ DeviceHandle → InterfaceNumber → IO α → IO α withDetachedKernelDriver devHndl ifNum action = ifM (kernelDriverActive devHndl ifNum) (bracket_ (detachKernelDriver devHndl ifNum)@@ -620,55 +653,55 @@ This structure can be retrieved by 'deviceDesc'. -} data DeviceDesc = DeviceDesc- { deviceUSBSpecReleaseNumber :: BCD4 -- ^ USB specification release- -- number in binary-coded- -- decimal.+ { 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.+ , 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.+ , deviceProtocol ∷ Word8 -- ^ USB-IF protocol code for the+ -- device, qualified by the+ -- 'deviceClass' and+ -- 'deviceSubClass' values. - , deviceMaxPacketSize0 :: Word8 -- ^ Maximum packet size for- -- endpoint 0.+ , deviceMaxPacketSize0 ∷ Word8 -- ^ Maximum packet size for+ -- endpoint 0. - , deviceVendorId :: VendorId -- ^ USB-IF vendor ID.- , deviceProductId :: ProductId -- ^ USB-IF product ID.+ , deviceVendorId ∷ VendorId -- ^ USB-IF vendor ID.+ , deviceProductId ∷ ProductId -- ^ USB-IF product ID. - , deviceReleaseNumber :: BCD4 -- ^ Device release number in- -- binary-coded decimal.+ , 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.+ , 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.+ , deviceNumConfigs ∷ Word8 -- ^ Number of possible+ -- configurations. - , deviceConfigs :: [ConfigDesc] -- ^ List of configurations- -- supported by the device.+ , deviceConfigs ∷ [ConfigDesc] -- ^ List of configurations+ -- supported by the device. } deriving (Show, Eq, Data, Typeable) type VendorId = Word16 type ProductId = Word16 -convertDeviceDesc :: Ptr C'libusb_device- -> C'libusb_device_descriptor- -> IO DeviceDesc+convertDeviceDesc ∷ Ptr C'libusb_device+ → C'libusb_device_descriptor+ → IO DeviceDesc convertDeviceDesc devPtr d = do let numConfigs = c'libusb_device_descriptor'bNumConfigurations d - configs <- mapM (getConfigDesc devPtr) [0..numConfigs-1]+ configs ← mapM (getConfigDesc devPtr) [0..numConfigs-1] return DeviceDesc { deviceUSBSpecReleaseNumber = unmarshalBCD4 $@@ -699,33 +732,33 @@ This structure can be retrieved by 'deviceConfigs'. -} data ConfigDesc = ConfigDesc- { configValue :: ConfigValue -- ^ Identifier value for the- -- configuration.+ { configValue ∷ ConfigValue -- ^ Identifier value for the+ -- configuration. - , configStrIx :: StrIx -- ^ Index of string descriptor- -- describing the configuration.- , configAttribs :: ConfigAttribs- -- ^ Configuration characteristics.- , configMaxPower :: Word8 -- ^ Maximum power consumption of the- -- USB device from the bus in the- -- configuration when the device is- -- fully operational. Expressed in- -- 2 mA units (i.e., 50 = 100 mA).+ , configStrIx ∷ StrIx -- ^ Index of string descriptor+ -- describing the configuration.+ , configAttribs ∷ ConfigAttribs+ -- ^ Configuration characteristics.+ , configMaxPower ∷ Word8 -- ^ Maximum power consumption of the+ -- USB device from the bus in the+ -- configuration when the device is+ -- fully operational. Expressed in+ -- 2 mA units (i.e., 50 = 100 mA). - , configNumInterfaces :: Word8 -- ^ Number of interfaces supported by- -- the configuration.- , configInterfaces :: [Interface] -- ^ List of interfaces supported by- -- the configuration.- -- Note that the length of this list- -- should equal- -- 'configNumInterfaces'.+ , configNumInterfaces ∷ Word8 -- ^ Number of interfaces supported by+ -- the configuration.+ , configInterfaces ∷ [Interface] -- ^ List of interfaces supported by+ -- the configuration.+ -- 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.+ , 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) -- | An interface is represented as a list of alternate interface settings.@@ -738,15 +771,15 @@ 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+ { 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) -unmarshalConfigAttribs :: Word8 -> ConfigAttribs+unmarshalConfigAttribs ∷ Word8 → ConfigAttribs unmarshalConfigAttribs a = DeviceStatus { remoteWakeup = testBit a 5 , selfPowered = testBit a 6@@ -754,9 +787,9 @@ -------------------------------------------------------------------------------- -getConfigDesc :: Ptr C'libusb_device -> Word8 -> IO ConfigDesc+getConfigDesc ∷ Ptr C'libusb_device → Word8 → IO ConfigDesc getConfigDesc devPtr ix =- alloca $ \configDescPtrPtr ->+ alloca $ \configDescPtrPtr → bracket ( do handleUSBException $ c'libusb_get_config_descriptor devPtr ix@@ -764,19 +797,19 @@ peek configDescPtrPtr ) c'libusb_free_config_descriptor- ((convertConfigDesc =<<) . peek)+ ((convertConfigDesc =<<) ∘ peek) -------------------------------------------------------------------------------- -convertConfigDesc :: C'libusb_config_descriptor -> IO ConfigDesc+convertConfigDesc ∷ C'libusb_config_descriptor → IO ConfigDesc convertConfigDesc c = do let numInterfaces = c'libusb_config_descriptor'bNumInterfaces c - interfaces <- peekArray (fromIntegral numInterfaces)+ interfaces ← peekArray (fromIntegral numInterfaces) (c'libusb_config_descriptor'interface c) >>= mapM convertInterface - extra <- B.packCStringLen+ extra ← B.packCStringLen ( castPtr $ c'libusb_config_descriptor'extra c , fromIntegral $ c'libusb_config_descriptor'extra_length c )@@ -792,7 +825,7 @@ , configExtra = extra } -convertInterface:: C'libusb_interface -> IO [InterfaceDesc]+convertInterface∷ C'libusb_interface → IO [InterfaceDesc] convertInterface i = peekArray (fromIntegral $ c'libusb_interface'num_altsetting i) (c'libusb_interface'altsetting i) >>=@@ -809,48 +842,48 @@ This structure can be retrieved using 'configInterfaces'. -} data InterfaceDesc = InterfaceDesc- { interfaceNumber :: InterfaceNumber -- ^ Number of the- -- interface.- , interfaceAltSetting :: InterfaceAltSetting -- ^ Value used to select- -- the alternate setting- -- for the interface.- , interfaceClass :: Word8 -- ^ USB-IF class code for- -- the interface.- , interfaceSubClass :: Word8 -- ^ USB-IF subclass code for- -- the interface,- -- qualified by the- -- 'interfaceClass' value.- , interfaceProtocol :: Word8 -- ^ USB-IF protocol code for- -- the interface,- -- qualified by the- -- 'interfaceClass' and- -- 'interfaceSubClass'- -- values.- , interfaceStrIx :: StrIx -- ^ Index of string- -- descriptor describing- -- the interface.- , interfaceEndpoints :: [EndpointDesc] -- ^ List of endpoints- -- supported by the- -- interface.- , interfaceExtra :: B.ByteString -- ^ Extra descriptors. If- -- libusb encounters- -- unknown interface- -- descriptors, it will- -- store them here, should- -- you wish to parse them.+ { interfaceNumber ∷ InterfaceNumber -- ^ Number of the+ -- interface.+ , interfaceAltSetting ∷ InterfaceAltSetting -- ^ Value used to select+ -- the alternate setting+ -- for the interface.+ , interfaceClass ∷ Word8 -- ^ USB-IF class code for+ -- the interface.+ , interfaceSubClass ∷ Word8 -- ^ USB-IF subclass code for+ -- the interface,+ -- qualified by the+ -- 'interfaceClass' value.+ , interfaceProtocol ∷ Word8 -- ^ USB-IF protocol code for+ -- the interface,+ -- qualified by the+ -- 'interfaceClass' and+ -- 'interfaceSubClass'+ -- values.+ , interfaceStrIx ∷ StrIx -- ^ Index of string+ -- descriptor describing+ -- the interface.+ , interfaceEndpoints ∷ [EndpointDesc] -- ^ List of endpoints+ -- supported by the+ -- interface.+ , 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 ∷ C'libusb_interface_descriptor → IO InterfaceDesc convertInterfaceDesc i = do let n = c'libusb_interface_descriptor'bNumEndpoints i - endpoints <- peekArray (fromIntegral n)+ endpoints ← peekArray (fromIntegral n) (c'libusb_interface_descriptor'endpoint i) >>= mapM convertEndpointDesc - extra <- B.packCStringLen+ extra ← B.packCStringLen ( castPtr $ c'libusb_interface_descriptor'extra i , fromIntegral $ c'libusb_interface_descriptor'extra_length i )@@ -876,27 +909,27 @@ multiple-byte fields are represented in host-endian format. -} data EndpointDesc = EndpointDesc- { endpointAddress :: EndpointAddress+ { endpointAddress ∷ EndpointAddress -- ^ The address of the endpoint described -- by the descriptor.- , endpointAttribs :: EndpointAttribs+ , endpointAttribs ∷ EndpointAttribs -- ^ Attributes which apply to the -- endpoint when it is configured using -- the 'configValue'.- , endpointMaxPacketSize :: MaxPacketSize+ , endpointMaxPacketSize ∷ MaxPacketSize -- ^ Maximum packet size the endpoint is -- capable of sending/receiving.- , endpointInterval :: Word8 -- ^ Interval for polling endpoint for+ , 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+ , endpointRefresh ∷ Word8 -- ^ /For audio devices only:/ the rate at -- which synchronization feedback is -- provided.- , endpointSynchAddress :: Word8 -- ^ /For audio devices only:/ the address+ , endpointSynchAddress ∷ Word8 -- ^ /For audio devices only:/ the address -- if the synch endpoint.- , endpointExtra :: B.ByteString+ , endpointExtra ∷ B.ByteString -- ^ Extra descriptors. If libusb -- encounters unknown endpoint -- descriptors, it will store@@ -906,10 +939,10 @@ -------------------------------------------------------------------------------- -convertEndpointDesc :: C'libusb_endpoint_descriptor- -> IO EndpointDesc+convertEndpointDesc ∷ C'libusb_endpoint_descriptor+ → IO EndpointDesc convertEndpointDesc e = do- extra <- B.packCStringLen+ extra ← B.packCStringLen ( castPtr $ c'libusb_endpoint_descriptor'extra e , fromIntegral $ c'libusb_endpoint_descriptor'extra_length e )@@ -933,18 +966,18 @@ -- | The address of an endpoint. data EndpointAddress = EndpointAddress- { endpointNumber :: Int -- ^ Must be >= 0 and <= 15- , transferDirection :: TransferDirection+ { endpointNumber ∷ Int -- ^ Must be >= 0 and <= 15+ , transferDirection ∷ TransferDirection } deriving (Show, Eq, Data, Typeable) -- | The direction of data transfer relative to the host.-data TransferDirection = Out -- ^ Out transfer direction (host -> device) used+data TransferDirection = Out -- ^ Out transfer direction (host → device) used -- for writing.- | In -- ^ In transfer direction (device -> host) used+ | In -- ^ In transfer direction (device → host) used -- for reading. deriving (Show, Eq, Data, Typeable) -unmarshalEndpointAddress :: Word8 -> EndpointAddress+unmarshalEndpointAddress ∷ Word8 → EndpointAddress unmarshalEndpointAddress a = EndpointAddress { endpointNumber = fromIntegral $ bits 0 3 a , transferDirection = if testBit a 7@@ -952,13 +985,13 @@ else Out } -marshalEndpointAddress :: (Bits a, Num a)- => EndpointAddress -> a+marshalEndpointAddress ∷ (Bits a, Num a)+ ⇒ EndpointAddress → a marshalEndpointAddress (EndpointAddress num transDir) | between num 0 15 = let n = fromIntegral num in case transDir of- Out -> n- In -> setBit n 7+ Out → n+ In → setBit n 7 | otherwise = error "marshalEndpointAddress: endpointNumber not >= 0 and <= 15" @@ -985,30 +1018,30 @@ | Implicit deriving (Enum, Show, Eq, Data, Typeable) -unmarshalEndpointAttribs :: Word8 -> EndpointAttribs+unmarshalEndpointAttribs ∷ Word8 → EndpointAttribs unmarshalEndpointAttribs a = case bits 0 1 a of- 0 -> Control- 1 -> Isochronous (genToEnum $ bits 2 3 a)+ 0 → Control+ 1 → Isochronous (genToEnum $ bits 2 3 a) (genToEnum $ bits 4 5 a)- 2 -> Bulk- 3 -> Interrupt- _ -> error "unmarshalEndpointAttribs: this can't happen!"+ 2 → Bulk+ 3 → Interrupt+ _ → error "unmarshalEndpointAttribs: this can't happen!" -------------------------------------------------------------------------------- -- *** Endpoint max packet size -------------------------------------------------------------------------------- data MaxPacketSize = MaxPacketSize- { maxPacketSize :: Size- , transactionOpportunities :: TransactionOpportunities+ { maxPacketSize ∷ Size+ , transactionOpportunities ∷ TransactionOpportunities } deriving (Show, Eq, Data, Typeable) -- | Number of additional transactions. data TransactionOpportunities = Zero | One | Two deriving (Enum, Show, Eq, Data, Typeable) -unmarshalMaxPacketSize :: Word16 -> MaxPacketSize+unmarshalMaxPacketSize ∷ Word16 → MaxPacketSize unmarshalMaxPacketSize m = MaxPacketSize { maxPacketSize = fromIntegral $ bits 0 10 m@@ -1019,18 +1052,18 @@ -- ** String descriptors -------------------------------------------------------------------------------- -strDescHeaderSize :: Size+strDescHeaderSize ∷ Size strDescHeaderSize = 2 {-| Retrieve a list of supported languages. This function may throw 'USBException's. -}-getLanguages :: DeviceHandle -> IO [LangId]+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+ in allocaArray maxSize $ \dataPtr → do+ reportedSize ← putStrDesc devHndl 0 0 maxSize dataPtr fmap (fmap unmarshalLangId) $ peekArray ((reportedSize - strDescHeaderSize) `div` 2) (castPtr $ dataPtr `plusPtr` strDescHeaderSize)@@ -1044,14 +1077,14 @@ is checked for correctness. If it's incorrect an 'IOException' is thrown. Finally, the size reported in the header is returned. -}-putStrDesc :: DeviceHandle- -> StrIx- -> Word16- -> Size- -> Ptr CUChar- -> IO Size+putStrDesc ∷ DeviceHandle+ → StrIx+ → Word16+ → Size+ → Ptr CUChar+ → IO Size putStrDesc devHndl strIx langId maxSize dataPtr = do- actualSize <- checkUSBException $ c'libusb_get_string_descriptor+ actualSize ← checkUSBException $ c'libusb_get_string_descriptor (getDevHndlPtr devHndl) strIx langId@@ -1059,12 +1092,12 @@ (fromIntegral maxSize) -- if there're enough bytes, parse the header when (actualSize < strDescHeaderSize) $ throwIO IOException- reportedSize <- peek dataPtr- descType <- peekElemOff dataPtr 1+ reportedSize ← peek dataPtr+ descType ← peekElemOff dataPtr 1 -- Check header correctness:- when ( descType /= c'LIBUSB_DT_STRING- || reportedSize > fromIntegral actualSize+ when ( descType ≢ c'LIBUSB_DT_STRING+ ∨ reportedSize > fromIntegral actualSize ) $ throwIO IOException return $ fromIntegral reportedSize@@ -1084,10 +1117,10 @@ type PrimaryLangId = Word16 type SubLangId = Word16 -unmarshalLangId :: Word16 -> LangId+unmarshalLangId ∷ Word16 → LangId unmarshalLangId = bits 0 9 &&& bits 10 15 -marshalLangId :: LangId -> Word16+marshalLangId ∷ LangId → Word16 marshalLangId (p, s) = p .|. s `shiftL`10 -- | Type of indici of string descriptors.@@ -1103,15 +1136,15 @@ This function may throw 'USBException's. -}-getStrDesc :: DeviceHandle -> StrIx -> LangId -> Size -> IO String+getStrDesc ∷ DeviceHandle → StrIx → LangId → Size → IO String getStrDesc devHndl strIx langId size =- fmap (T.unpack . TE.decodeUtf16LE . B.drop strDescHeaderSize) $+ fmap (T.unpack ∘ TE.decodeUtf16LE ∘ B.drop strDescHeaderSize) $ BI.createAndTrim size $ putStrDesc devHndl strIx (marshalLangId langId) size- . castPtr+ ∘ castPtr {-| Retrieve a string descriptor from a device using the first supported language.@@ -1122,12 +1155,12 @@ This function may throw 'USBException's. -}-getStrDescFirstLang :: DeviceHandle -> StrIx -> Size -> IO String+getStrDescFirstLang ∷ DeviceHandle → StrIx → Size → IO String getStrDescFirstLang devHndl strIx size =- do langIds <- getLanguages devHndl+ do langIds ← getLanguages devHndl case langIds of- [] -> throwIO IOException- langId : _ -> getStrDesc devHndl strIx langId size+ [] → throwIO IOException+ langId : _ → getStrDesc devHndl strIx langId size --------------------------------------------------------------------------------@@ -1149,7 +1182,7 @@ executed, performs the actual read and returns the 'B.ByteString' that was read paired with an indication if the transfer timed out. -}-type ReadAction = Timeout -> Size -> IO (B.ByteString, Bool)+type ReadAction = Timeout → Size → IO (B.ByteString, Bool) {-| Handy type synonym for write transfers. @@ -1158,7 +1191,7 @@ number of bytes that were actually written paired with an indication if the transfer timed out. -}-type WriteAction = Timeout -> B.ByteString -> IO (Size, Bool)+type WriteAction = Timeout → B.ByteString → IO (Size, Bool) -- | A timeout in millseconds. A timeout defines how long a transfer should wait -- before giving up due to no response being received. For no timeout, use value@@ -1183,7 +1216,7 @@ | ToOther deriving (Enum, Show, Eq, Data, Typeable) -marshalRequestType :: RequestType -> Recipient -> Word8+marshalRequestType ∷ RequestType → Recipient → Word8 marshalRequestType t r = genFromEnum t `shiftL` 5 .|. genFromEnum r {-| Perform a USB /control/ request that does not transfer data.@@ -1200,18 +1233,18 @@ * 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+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 ()+ → IO () control devHndl reqType reqRecipient request value index timeout =- ignore . checkUSBException $ c'libusb_control_transfer+ ignore ∘ checkUSBException $ c'libusb_control_transfer (getDevHndlPtr devHndl) (marshalRequestType reqType reqRecipient) request@@ -1233,32 +1266,30 @@ * 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.- -> ReadAction-readControl devHndl reqType reqRecipient request value index = \timeout size ->- BI.createAndTrim' size $ \dataPtr -> do- err <- c'libusb_control_transfer- (getDevHndlPtr devHndl)- (setBit (marshalRequestType reqType reqRecipient)- 7- )- request- value- index- (castPtr dataPtr)- (fromIntegral size)- (fromIntegral timeout)- if err < 0 && err /= c'LIBUSB_ERROR_TIMEOUT+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.+ → ReadAction+readControl devHndl reqType reqRecipient request value index = \timeout size →+ BI.createAndTrim' size $ \dataPtr → do+ err ← c'libusb_control_transfer+ (getDevHndlPtr devHndl)+ (setBit (marshalRequestType reqType reqRecipient)+ 7+ )+ request+ value+ index+ (castPtr dataPtr)+ (fromIntegral size)+ (fromIntegral timeout)+ let timedOut = err ≡ c'LIBUSB_ERROR_TIMEOUT+ if err < 0 ∧ not timedOut then throwIO $ convertUSBException err- else return ( 0- , fromIntegral err- , err == c'LIBUSB_ERROR_TIMEOUT- )+ else return (0, fromIntegral err, timedOut) {-| Perform a USB /control/ write. @@ -1272,29 +1303,28 @@ * 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.- -> WriteAction-writeControl devHndl reqType reqRecipient request value index = \timeout input ->- input `writeWith` \size dataPtr -> do- err <- c'libusb_control_transfer- (getDevHndlPtr devHndl)- (marshalRequestType reqType reqRecipient)- request- value- index- (castPtr dataPtr)- (fromIntegral size)- (fromIntegral timeout)- if err < 0 && err /= c'LIBUSB_ERROR_TIMEOUT+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.+ → WriteAction+writeControl devHndl reqType reqRecipient request value index = \timeout input →+ input `writeWith` \size dataPtr → do+ err ← c'libusb_control_transfer+ (getDevHndlPtr devHndl)+ (marshalRequestType reqType reqRecipient)+ request+ value+ index+ (castPtr dataPtr)+ (fromIntegral size)+ (fromIntegral timeout)+ let timedOut = err ≡ c'LIBUSB_ERROR_TIMEOUT+ if err < 0 ∧ not timedOut then throwIO $ convertUSBException err- else return ( fromIntegral err- , err == c'LIBUSB_ERROR_TIMEOUT- )+ else return (fromIntegral err, timedOut) -------------------------------------------------------------------------------- -- *** Standard Device Requests@@ -1304,13 +1334,13 @@ -- Standard Feature Selectors: -- See: USB 2.0 Spec. table 9-6-haltFeature, remoteWakeupFeature, testModeFeature :: Word16+haltFeature, remoteWakeupFeature, testModeFeature ∷ Word16 remoteWakeupFeature = 1 haltFeature = 0 testModeFeature = 2 -- | See: USB 2.0 Spec. section 9.4.9-setHalt :: DeviceHandle -> EndpointAddress -> Timeout -> IO ()+setHalt ∷ DeviceHandle → EndpointAddress → Timeout → IO () setHalt devHndl endpointAddr = control devHndl Standard@@ -1320,7 +1350,7 @@ (marshalEndpointAddress endpointAddr) -- | See: USB 2.0 Spec. section 9.4.1-clearRemoteWakeup :: DeviceHandle -> Timeout -> IO ()+clearRemoteWakeup ∷ DeviceHandle → Timeout → IO () clearRemoteWakeup devHndl = control devHndl Standard@@ -1330,7 +1360,7 @@ 0 -- | See: USB 2.0 Spec. section 9.4.9-setRemoteWakeup :: DeviceHandle -> Timeout -> IO ()+setRemoteWakeup ∷ DeviceHandle → Timeout → IO () setRemoteWakeup devHndl = control devHndl Standard@@ -1341,7 +1371,7 @@ -- | See: USB 2.0 Spec. section 9.4.9 -- TODO: What about vendor-specific test modes?-setStandardTestMode :: DeviceHandle -> TestMode -> Timeout -> IO ()+setStandardTestMode ∷ DeviceHandle → TestMode → Timeout → IO () setStandardTestMode devHndl testMode = control devHndl Standard@@ -1359,64 +1389,64 @@ deriving (Show, Enum, Data, Typeable) -- | See: USB 2.0 Spec. section 9.4.4-getInterfaceAltSetting :: DeviceHandle- -> InterfaceNumber- -> Timeout- -> IO InterfaceAltSetting+getInterfaceAltSetting ∷ DeviceHandle+ → InterfaceNumber+ → Timeout+ → IO InterfaceAltSetting getInterfaceAltSetting devHndl ifNum timeout = do- (bs, _) <- readControl devHndl- Standard- ToInterface- c'LIBUSB_REQUEST_GET_INTERFACE- 0- (fromIntegral ifNum)- 1- timeout- if B.length bs /= 1+ (bs, _) ← readControl devHndl+ Standard+ ToInterface+ c'LIBUSB_REQUEST_GET_INTERFACE+ 0+ (fromIntegral ifNum)+ 1+ timeout+ if B.length bs ≢ 1 then throwIO IOException else return $ B.head bs -- | See: USB 2.0 Spec. section 9.4.5-getDeviceStatus :: DeviceHandle -> Timeout -> IO DeviceStatus+getDeviceStatus ∷ DeviceHandle → Timeout → IO DeviceStatus getDeviceStatus devHndl timeout = do- (bs, _) <- readControl devHndl- Standard- ToDevice- c'LIBUSB_REQUEST_GET_STATUS- 0- 0- 2- timeout- if B.length bs /= 2+ (bs, _) ← readControl devHndl+ Standard+ ToDevice+ c'LIBUSB_REQUEST_GET_STATUS+ 0+ 0+ 2+ timeout+ if B.length bs ≢ 2 then throwIO IOException else return $ unmarshalDeviceStatus $ B.head bs where- unmarshalDeviceStatus :: Word8 -> DeviceStatus+ unmarshalDeviceStatus ∷ Word8 → DeviceStatus unmarshalDeviceStatus a = DeviceStatus { remoteWakeup = testBit a 1 , selfPowered = testBit a 0 } -- | See: USB 2.0 Spec. section 9.4.5-getEndpointStatus :: DeviceHandle- -> EndpointAddress- -> Timeout- -> IO Bool+getEndpointStatus ∷ DeviceHandle+ → EndpointAddress+ → Timeout+ → IO Bool getEndpointStatus devHndl endpointAddr timeout = do- (bs, _) <- readControl devHndl- Standard- ToEndpoint- c'LIBUSB_REQUEST_GET_STATUS- 0- (marshalEndpointAddress endpointAddr)- 2- timeout- if B.length bs /= 2+ (bs, _) ← readControl devHndl+ Standard+ ToEndpoint+ c'LIBUSB_REQUEST_GET_STATUS+ 0+ (marshalEndpointAddress endpointAddr)+ 2+ timeout+ if B.length bs ≢ 2 then throwIO IOException- else return $ B.head bs == 1+ else return $ B.head bs ≡ 1 -- | See: USB 2.0 Spec. section 9.4.6-setDeviceAddress :: DeviceHandle -> Word16 -> Timeout -> IO ()+setDeviceAddress ∷ DeviceHandle → Word16 → Timeout → IO () setDeviceAddress devHndl deviceAddr = control devHndl Standard@@ -1428,20 +1458,20 @@ -- TODO: setDescriptor See: USB 2.0 Spec. section 9.4.8 -- | See: USB 2.0 Spec. section 9.4.11-synchFrame :: DeviceHandle -> EndpointAddress -> Timeout -> IO Int+synchFrame ∷ DeviceHandle → EndpointAddress → Timeout → IO Int synchFrame devHndl endpointAddr timeout = do- (bs, _) <- readControl devHndl- Standard- ToEndpoint- c'LIBUSB_REQUEST_SYNCH_FRAME- 0- (marshalEndpointAddress endpointAddr)- 2- timeout- if B.length bs /= 2+ (bs, _) ← readControl devHndl+ Standard+ ToEndpoint+ c'LIBUSB_REQUEST_SYNCH_FRAME+ 0+ (marshalEndpointAddress endpointAddr)+ 2+ timeout+ if B.length bs ≢ 2 then throwIO IOException else return $ let [h, l] = B.unpack bs- in fromIntegral h * 256 + fromIntegral l+ in fromIntegral h ⋅ 256 + fromIntegral l -------------------------------------------------------------------------------- -- ** Bulk transfers@@ -1461,14 +1491,12 @@ * Another 'USBException'. -}-readBulk :: DeviceHandle -- ^ A handle for the device to communicate- -- with.- -> EndpointAddress -- ^ The address of a valid 'In' and 'Bulk'- -- endpoint to communicate with. Make sure the- -- endpoint belongs to the current alternate- -- setting of a claimed interface which belongs- -- to the device.- -> ReadAction+readBulk ∷ DeviceHandle -- ^ A handle for the device to communicate with.+ → EndpointAddress -- ^ The address of a valid 'In' and 'Bulk' endpoint+ -- to communicate with. Make sure the endpoint+ -- belongs to the current alternate setting of a+ -- claimed interface which belongs to the device.+ → ReadAction readBulk = readTransfer c'libusb_bulk_transfer {-| Perform a USB /bulk/ write.@@ -1485,14 +1513,13 @@ * Another 'USBException'. -}-writeBulk :: DeviceHandle -- ^ A handle for the device to communicate- -- with.- -> EndpointAddress -- ^ The address of a valid 'Out' and 'Bulk'- -- endpoint to communicate with. Make sure- -- the endpoint belongs to the current- -- alternate setting of a claimed interface- -- which belongs to the device.- -> WriteAction+writeBulk ∷ DeviceHandle -- ^ A handle for the device to communicate with.+ → EndpointAddress -- ^ The address of a valid 'Out' and 'Bulk'+ -- endpoint to communicate with. Make sure the+ -- endpoint belongs to the current alternate+ -- setting of a claimed interface which belongs to+ -- the device.+ → WriteAction writeBulk = writeTransfer c'libusb_bulk_transfer --------------------------------------------------------------------------------@@ -1513,15 +1540,14 @@ * Another 'USBException'. -}-readInterrupt :: DeviceHandle -- ^ A handle for the device to communicate- -- with.- -> EndpointAddress -- ^ The address of a valid 'In' and- -- 'Interrupt' endpoint to communicate- -- with. Make sure the endpoint belongs to- -- the current alternate setting of a- -- claimed interface which belongs to the- -- device.- -> ReadAction+readInterrupt ∷ DeviceHandle -- ^ A handle for the device to communicate+ -- with.+ → EndpointAddress -- ^ The address of a valid 'In' and 'Interrupt'+ -- endpoint to communicate with. Make sure the+ -- endpoint belongs to the current alternate+ -- setting of a claimed interface which+ -- belongs to the device.+ → ReadAction readInterrupt = readTransfer c'libusb_interrupt_transfer {-| Perform a USB /interrupt/ write.@@ -1538,69 +1564,66 @@ * Another 'USBException'. -}-writeInterrupt :: DeviceHandle -- ^ A handle for the device to- -- communicate with.- -> EndpointAddress -- ^ The address of a valid 'Out' and- -- 'Interrupt' endpoint to communicate- -- with. Make sure the endpoint belongs- -- to the current alternate setting of a- -- claimed interface which belongs to- -- the device.- -> WriteAction+writeInterrupt ∷ DeviceHandle -- ^ A handle for the device to communicate+ -- with.+ → EndpointAddress -- ^ The address of a valid 'Out' and+ -- 'Interrupt' endpoint to communicate+ -- with. Make sure the endpoint belongs to+ -- the current alternate setting of a claimed+ -- interface which belongs to the device.+ → WriteAction writeInterrupt = writeTransfer c'libusb_interrupt_transfer -------------------------------------------------------------------------------- -type C'TransferFunc = Ptr C'libusb_device_handle -- devHndlPtr- -> CUChar -- endpoint address- -> Ptr CUChar -- dataPtr- -> CInt -- size- -> Ptr CInt -- transferredPtr- -> CUInt -- timeout- -> IO CInt -- error+type C'TransferFunc = Ptr C'libusb_device_handle -- devHndlPtr+ → CUChar -- endpoint address+ → Ptr CUChar -- dataPtr+ → CInt -- size+ → Ptr CInt -- transferredPtr+ → CUInt -- timeout+ → IO CInt -- error -readTransfer :: C'TransferFunc -> DeviceHandle- -> EndpointAddress- -> ReadAction-readTransfer c'transfer devHndl endpointAddr = \timeout size ->- BI.createAndTrim' size $ \dataPtr -> do- (transferred, timedOut) <- transfer c'transfer- devHndl- endpointAddr- timeout- size- dataPtr+readTransfer ∷ C'TransferFunc → DeviceHandle+ → EndpointAddress+ → ReadAction+readTransfer c'transfer devHndl endpointAddr = \timeout size →+ BI.createAndTrim' size $ \dataPtr → do+ (transferred, timedOut) ← transfer c'transfer+ devHndl+ endpointAddr+ timeout+ size+ dataPtr return (0, transferred, timedOut) -writeTransfer :: C'TransferFunc -> DeviceHandle- -> EndpointAddress- -> WriteAction-writeTransfer c'transfer devHndl endpointAddr = \timeout input ->+writeTransfer ∷ C'TransferFunc → DeviceHandle+ → EndpointAddress+ → WriteAction+writeTransfer c'transfer devHndl endpointAddr = \timeout input → input `writeWith` transfer c'transfer devHndl endpointAddr timeout -transfer :: C'TransferFunc -> DeviceHandle- -> EndpointAddress- -> Timeout -> Size -> Ptr Word8 -> IO (Size, Bool)+transfer ∷ C'TransferFunc → DeviceHandle+ → EndpointAddress+ → Timeout → Size → Ptr Word8 → IO (Size, Bool) transfer c'transfer devHndl endpointAddr timeout size dataPtr =- alloca $ \transferredPtr -> do- err <- c'transfer (getDevHndlPtr devHndl)+ alloca $ \transferredPtr → do+ err ← c'transfer (getDevHndlPtr devHndl) (marshalEndpointAddress endpointAddr) (castPtr dataPtr) (fromIntegral size) transferredPtr (fromIntegral timeout)- if err /= c'LIBUSB_SUCCESS &&- err /= c'LIBUSB_ERROR_TIMEOUT+ let timedOut = err ≡ c'LIBUSB_ERROR_TIMEOUT+ if err ≢ c'LIBUSB_SUCCESS ∧ not timedOut then throwIO $ convertUSBException err- else do transferred <- peek transferredPtr- return ( fromIntegral transferred- , err == c'LIBUSB_ERROR_TIMEOUT- )+ else do transferred ← peek transferredPtr+ return (fromIntegral transferred, timedOut) --------------------------------------------------------------------------------@@ -1610,31 +1633,31 @@ -- | @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)+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+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 ∷ CInt → USBException convertUSBException err = fromMaybe unknownLibUsbError $ lookup err libusb_error_to_USBException -unknownLibUsbError :: error+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 ∷ [(CInt, USBException)] libusb_error_to_USBException = [ (c'LIBUSB_ERROR_IO, IOException) , (c'LIBUSB_ERROR_INVALID_PARAM, InvalidParamException)@@ -1673,13 +1696,14 @@ ----------------------------------------------------------------------------------- * Utils+-- * Binary Coded Decimals -------------------------------------------------------------------------------- -- | A decoded 16 bits Binary Coded Decimal using 4 bits for each digit. type BCD4 = (Int, Int, Int, Int) -unmarshalBCD4 :: Word16 -> BCD4+-- | Decode a @Word16@ as a Binary Coded Decimal using 4 bits per digit.+unmarshalBCD4 ∷ Word16 → BCD4 unmarshalBCD4 bcd = let [a, b, c, d] = fmap fromIntegral $ decodeBCD 4 bcd in (a, b, c, d) @@ -1688,7 +1712,7 @@ used to encode a single digit. See: <http://en.wikipedia.org/wiki/Binary-coded_decimal> -}-decodeBCD :: Bits a => Int -> a -> [a]+decodeBCD ∷ Bits α ⇒ Int → α → [α] decodeBCD bitsInDigit n = go shftR [] where shftR = bitSize n - bitsInDigit@@ -1697,24 +1721,31 @@ | otherwise = go (shftL - bitsInDigit) (((n `shiftL` shftL) `shiftR` shftR) : ds) ++--------------------------------------------------------------------------------+-- * Utils+--------------------------------------------------------------------------------+ -- | @bits s e b@ extract bit @s@ to @e@ (including) from @b@.-bits :: Bits a => Int -> Int -> a -> a+bits ∷ Bits α ⇒ Int → Int → α → α 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+-- | @between n b e@ tests if @n@ is between the given bounds @b@ and @e@+-- (including).+between ∷ Ord α ⇒ α → α → α → Bool+between n b e = n ≥ b ∧ n ≤ e -- | Execute the given action but ignore the result.-ignore :: Monad m => m a -> m ()+ignore ∷ Monad m ⇒ m α → m () ignore = (>> return ()) -- | A generalized 'toEnum' that works on any 'Integral' type.-genToEnum :: (Integral i, Enum e) => i -> e-genToEnum = toEnum . fromIntegral+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+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 the size of@@ -1724,13 +1755,14 @@ -- /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 -> (Size -> Ptr Word8 -> IO a) -> IO a+writeWith ∷ B.ByteString → (Size → Ptr Word8 → IO α) → IO α input `writeWith` doWrite = let (dataFrgnPtr, _, size) = BI.toForeignPtr input in withForeignPtr dataFrgnPtr $ doWrite size -ifM :: Monad m => m Bool -> m a -> m a -> m a-ifM cM tM eM = do c <- cM+-- | Monadic if...then...else...+ifM ∷ Monad m ⇒ m Bool → m α → m α → m α+ifM cM tM eM = do c ← cM if c then tM else eM
usb.cabal view
@@ -1,5 +1,5 @@ name: usb-version: 0.3+version: 0.3.0.1 cabal-version: >=1.6 build-type: Simple license: BSD3@@ -25,10 +25,11 @@ Library GHC-Options: -O2 -Wall- build-depends: base >= 4 && < 4.2- , bindings-libusb >= 1.3 && < 1.5- , bytestring == 0.9.*- , text == 0.5.*+ build-depends: base >= 4 && < 4.3+ , base-unicode-symbols >= 0.1.1 && < 0.2+ , bindings-libusb >= 1.3 && < 1.5+ , bytestring == 0.9.*+ , text >= 0.5 && < 0.8 exposed-modules: System.USB System.USB.Initialization System.USB.Enumeration