usb 1.1.0.4 → 1.2

raw patch · 6 files changed

+259/−226 lines, 6 filesdep +vectorPVP ok

version bump matches the API change (PVP)

Dependencies added: vector

API changes (from Hackage documentation)

Files

• System/USB/Base.hs +204/−212
• System/USB/Descriptors.hs +4/−3
• System/USB/Enumeration.hs +0/−1
• System/USB/Internal.hs +2/−2
• Utils.hs +47/−7
• usb.cabal +2/−1

@@ -30,13 +30,12 @@ import Foreign.C.Types       ( CUChar, CInt, CUInt ) import Foreign.C.String      ( CStringLen ) import Foreign.Marshal.Alloc ( alloca )-import Foreign.Marshal.Array ( peekArray, allocaArray )+import Foreign.Marshal.Array ( allocaArray ) import Foreign.Storable      ( Storable, peek, peekElemOff ) import Foreign.Ptr           ( Ptr, castPtr, plusPtr, nullPtr )-import Foreign.ForeignPtr    ( ForeignPtr, withForeignPtr )-import Control.Applicative   ( liftA2 )+import Foreign.ForeignPtr    ( ForeignPtr, withForeignPtr, touchForeignPtr ) import Control.Exception     ( Exception, throwIO, bracket, bracket_, onException, assert )-import Control.Monad         ( Monad, (>>=), (=<<), return, when, forM )+import Control.Monad         ( Monad, (=<<), return, when ) import Control.Arrow         ( (&&&) ) import Data.Function         ( ($), on ) import Data.Data             ( Data )@@ -81,11 +80,17 @@ import           Data.Text                ( Text ) import qualified Data.Text.Encoding as TE ( decodeUtf16LE ) +-- from vector:+import           Data.Vector                ( Vector )+import qualified Data.Vector.Generic  as VG ( convert, map )+ -- from bindings-libusb: import Bindings.Libusb  -- from usb (this package):-import Utils ( bits, between, genToEnum, genFromEnum, mapPeekArray, ifM, decodeBCD )+import Utils ( bits, between, genToEnum, genFromEnum, peekVector, mapPeekArray+             , allocaPeek, ifM, decodeBCD, uncons+             )  -------------------------------------------------------------------------------- @@ -94,13 +99,11 @@ import Prelude                 ( undefined ) import Foreign.C.Types         ( CShort, CChar ) import Foreign.Marshal.Alloc   ( allocaBytes, free )-import Foreign.Marshal.Array   ( peekArray0, copyArray )+import Foreign.Marshal.Array   ( peekArray0, copyArray, advancePtr ) import Foreign.Storable        ( sizeOf, poke ) import Foreign.Ptr             ( nullFunPtr, freeHaskellFunPtr )-import Control.Monad           ( mapM_, foldM_ )+import Control.Monad           ( (>>=), mapM_, forM ) import Data.IORef              ( newIORef, atomicModifyIORef, readIORef )-import Data.Function           ( id )-import Data.List               ( foldl' ) import System.Posix.Types      ( Fd(Fd) ) import Control.Exception       ( uninterruptibleMask_ ) import Control.Concurrent.MVar ( MVar, newEmptyMVar, takeMVar, putMVar )@@ -122,10 +125,17 @@ -- from bytestring: import qualified Data.ByteString.Internal as BI ( create ) +--from vector:+import qualified Data.Vector.Unboxed         as Unboxed  ( Vector )+import qualified Data.Vector.Storable        as Storable ( Vector )+import qualified Data.Vector.Generic         as VG  ( empty, length, sum, foldM_, unsafeFreeze)+import qualified Data.Vector.Generic.Mutable as VGM ( unsafeNew, unsafeWrite )+ -- from usb (this package): import Timeval            ( withTimeval ) import qualified Poll     ( toEvent ) import SystemEventManager ( getSystemEventManager )+import Utils              ( pokeVector ) #endif  #if defined(HAS_EVENT_MANAGER) || defined(mingw32_HOST_OS)@@ -266,7 +276,7 @@       -- Be notified when libusb file descriptors are added or removed:       aFP ← mk'libusb_pollfd_added_cb $ \fd evt _ → mask_ $ do               fdKey ← register fd evt-              newFdKeyMap <- atomicModifyIORef fdKeyMapRef $ \fdKeyMap →+              newFdKeyMap ← atomicModifyIORef fdKeyMapRef $ \fdKeyMap →                   let newFdKeyMap = insert (fromIntegral fd) fdKey fdKeyMap                   in (newFdKeyMap, newFdKeyMap)               newFdKeyMap `seq` return ()@@ -382,38 +392,29 @@ operate such device or another process or driver may be using the device.  To get additional information about a device you can retrieve its descriptor-using 'deviceDesc'.+using 'getDeviceDesc'. -} data Device = Device     { getCtx ∷ !Ctx -- ^ This reference to the 'Ctx' is needed so that it won't-                    --   get garbage collected. The finalizer "p'libusb_exit" is+                    --   gets garbage collected. The finalizer @libusb_exit@ is                     --   run only when all references to 'Devices' are gone.      , getDevFrgnPtr ∷ !(ForeignPtr C'libusb_device)--    , deviceDesc ∷ !DeviceDesc -- ^ Get the descriptor of the device.     } deriving Typeable --- | Equality on devices is defined by comparing their descriptors:--- @(==) = (==) \`on\` `deviceDesc`@-instance Eq Device where (==) = (==) `on` deviceDesc+instance Eq Device where (==) = (==) `on` getDevFrgnPtr --- | Devices are shown in the same way as the popular @lsusb@ program:------ @Bus \<busNumber\> Device \<address\>: ID \<vid\>:\<pid\>@+-- | Devices are shown as: @Bus \<'busNumber'\> Device \<'deviceAddress'\>@ instance Show Device where-    show d = printf "Bus %03d Device %03d: ID %04x:%04x" (busNumber d)-                                                         (deviceAddress d)-                                                         (deviceVendorId desc)-                                                         (deviceProductId desc)-        where-          desc = deviceDesc d+    show d = printf "Bus %03d Device %03d" (busNumber d) (deviceAddress d)  withDevicePtr ∷ Device → (Ptr C'libusb_device → IO α) → IO α-withDevicePtr (Device ctx devFP _) f = withCtxPtr ctx $ \_ →-                                         withForeignPtr devFP f+withDevicePtr (Device ctx devFP ) f = do+  x ← withForeignPtr devFP f+  touchForeignPtr $ getCtxFrgnPtr ctx+  return x -{-| Returns a list of USB devices currently attached to the system.+{-| Returns a vector of USB devices currently attached to the system.  This is your entry point into finding a USB device. @@ -440,7 +441,7 @@                                       v                                       D -}-getDevices ∷ Ctx → IO [Device]+getDevices ∷ Ctx → IO (Vector Device) getDevices ctx =     withCtxPtr ctx $ \ctxPtr →       alloca $ \devPtrArrayPtr → mask $ \restore → do@@ -454,14 +455,13 @@         return devs       where         mkDev ∷ Ptr C'libusb_device → IO Device-        mkDev devPtr = liftA2 (Device ctx)+        mkDev devPtr = Device ctx <$> #ifdef mingw32_HOST_OS-                              (FC.newForeignPtr devPtr-                                 (c'libusb_unref_device devPtr))+                              FC.newForeignPtr devPtr+                                 (c'libusb_unref_device devPtr) #else-                              (newForeignPtr p'libusb_unref_device devPtr)+                              newForeignPtr p'libusb_unref_device devPtr #endif-                              (getDeviceDesc devPtr)  -- Both of the following numbers are static variables in the libusb device -- structure. It's therefore safe to use unsafePerformIO:@@ -502,8 +502,11 @@     show devHndl = "{USB device handle to: " ++ show (getDevice devHndl) ++ "}"  withDevHndlPtr ∷ DeviceHandle → (Ptr C'libusb_device_handle → IO α) → IO α-withDevHndlPtr (DeviceHandle dev devHndlPtr) f = withDevicePtr dev $ \_ →-                                                   f devHndlPtr+withDevHndlPtr (DeviceHandle (Device ctx devFrgnPtr) devHndlPtr) f = do+  x ← f devHndlPtr+  touchForeignPtr devFrgnPtr+  touchForeignPtr $ getCtxFrgnPtr ctx+  return x  {-| Open a device and obtain a device handle. @@ -709,8 +712,7 @@  {-| Activate an alternate setting for an interface. -The interface must have been previously claimed with 'claimInterface' or-'withInterfaceHandle'.+The interface must have been previously claimed with 'claimInterface'.  You should always use this function rather than formulating your own SET_INTERFACE control request. This is because the underlying operating system@@ -928,9 +930,6 @@        -- | Number of possible configurations.     , deviceNumConfigs ∷ !Word8--      -- | List of configurations supported by the device.-    , deviceConfigs ∷ ![ConfigDesc]     } deriving (COMMON_INSTANCES)  type ReleaseNumber = (Int, Int, Int, Int)@@ -946,7 +945,7 @@  This descriptor is documented in section 9.6.3 of the USB 2.0 specification. -This structure can be retrieved by 'deviceConfigs'.+This structure can be retrieved by 'getConfigDesc'. -} data ConfigDesc = ConfigDesc     { -- | Identifier value for the configuration.@@ -963,12 +962,8 @@       -- units (i.e., 50 = 100 mA).     , configMaxPower ∷ !Word8 -      -- | Number of interfaces supported by the configuration.-    , configNumInterfaces ∷ !Word8--      -- | List of interfaces supported by the configuration.  Note that the-      -- length of this list should equal 'configNumInterfaces'.-    , configInterfaces ∷ ![Interface]+      -- | Vector of interfaces supported by the configuration.+    , configInterfaces ∷ !(Vector Interface)        -- | Extra descriptors. If @libusb@ encounters unknown configuration       -- descriptors, it will store them here, should you wish to parse them.@@ -976,9 +971,6 @@      } deriving (COMMON_INSTANCES) --- | An interface is represented as a list of alternate interface settings.-type Interface = [InterfaceDesc]- -------------------------------------------------------------------------------- -- *** Configuration attributes --------------------------------------------------------------------------------@@ -1000,6 +992,9 @@ -- ** Interface descriptor -------------------------------------------------------------------------------- +-- | An interface is represented as a vector of alternate interface settings.+type Interface = Vector InterfaceDesc+ {-| A structure representing the standard USB interface descriptor.  This descriptor is documented in section 9.6.5 of the USB 2.0 specification.@@ -1027,8 +1022,8 @@       -- | Optional index of string descriptor describing the interface.     , interfaceStrIx ∷ !(Maybe StrIx) -      -- | List of endpoints supported by the interface.-    , interfaceEndpoints ∷ ![EndpointDesc]+      -- | Vector of endpoints supported by the interface.+    , interfaceEndpoints ∷ !(Vector EndpointDesc)        -- | Extra descriptors. If @libusb@ encounters unknown interface       -- descriptors, it will store them here, should you wish to parse them.@@ -1172,39 +1167,37 @@ -- ** Retrieving and converting descriptors -------------------------------------------------------------------------------- -getDeviceDesc ∷ Ptr C'libusb_device → IO DeviceDesc-getDeviceDesc devPtr = alloca $ \devDescPtr → do-  handleUSBException $ c'libusb_get_device_descriptor devPtr devDescPtr-  peek devDescPtr >>= convertDeviceDesc devPtr--convertDeviceDesc ∷ Ptr C'libusb_device-                  → C'libusb_device_descriptor-                  → IO DeviceDesc-convertDeviceDesc devPtr d = do-  let numConfigs = c'libusb_device_descriptor'bNumConfigurations d--  configs ← forM [0..numConfigs-1] $ getConfigDesc devPtr+-- | Get the USB device descriptor for a given device.+--+-- This is a non-blocking function; the device descriptor is cached in memory.+--+-- This function may throw 'USBException's.+getDeviceDesc ∷ Device → IO DeviceDesc+getDeviceDesc dev =+  withDevicePtr dev $ \devPtr →+    convertDeviceDesc <$>+      allocaPeek (handleUSBException ∘ c'libusb_get_device_descriptor devPtr) -  return DeviceDesc-    { deviceUSBSpecReleaseNumber = unmarshalReleaseNumber $-                                   c'libusb_device_descriptor'bcdUSB          d-    , deviceClass                = c'libusb_device_descriptor'bDeviceClass    d-    , deviceSubClass             = c'libusb_device_descriptor'bDeviceSubClass d-    , deviceProtocol             = c'libusb_device_descriptor'bDeviceProtocol d-    , deviceMaxPacketSize0       = c'libusb_device_descriptor'bMaxPacketSize0 d-    , deviceVendorId             = c'libusb_device_descriptor'idVendor        d-    , deviceProductId            = c'libusb_device_descriptor'idProduct       d-    , deviceReleaseNumber        = unmarshalReleaseNumber $-                                   c'libusb_device_descriptor'bcdDevice       d-    , deviceManufacturerStrIx    = unmarshalStrIx $-                                   c'libusb_device_descriptor'iManufacturer   d-    , deviceProductStrIx         = unmarshalStrIx $-                                   c'libusb_device_descriptor'iProduct        d-    , deviceSerialNumberStrIx    = unmarshalStrIx $-                                   c'libusb_device_descriptor'iSerialNumber   d-    , deviceNumConfigs           = numConfigs-    , deviceConfigs              = configs-    }+convertDeviceDesc ∷ C'libusb_device_descriptor → DeviceDesc+convertDeviceDesc d = DeviceDesc+  { deviceUSBSpecReleaseNumber = unmarshalReleaseNumber $+                                 c'libusb_device_descriptor'bcdUSB             d+  , deviceClass                = c'libusb_device_descriptor'bDeviceClass       d+  , deviceSubClass             = c'libusb_device_descriptor'bDeviceSubClass    d+  , deviceProtocol             = c'libusb_device_descriptor'bDeviceProtocol    d+  , deviceMaxPacketSize0       = c'libusb_device_descriptor'bMaxPacketSize0    d+  , deviceVendorId             = c'libusb_device_descriptor'idVendor           d+  , deviceProductId            = c'libusb_device_descriptor'idProduct          d+  , deviceReleaseNumber        = unmarshalReleaseNumber $+                                 c'libusb_device_descriptor'bcdDevice          d+  , deviceManufacturerStrIx    = unmarshalStrIx $+                                 c'libusb_device_descriptor'iManufacturer      d+  , deviceProductStrIx         = unmarshalStrIx $+                                 c'libusb_device_descriptor'iProduct           d+  , deviceSerialNumberStrIx    = unmarshalStrIx $+                                 c'libusb_device_descriptor'iSerialNumber      d+  , deviceNumConfigs           = c'libusb_device_descriptor'bNumConfigurations d+  }  -- | Unmarshal a a 16bit word as a release number. The 16bit word should be -- encoded as a@@ -1221,24 +1214,27 @@ unmarshalStrIx 0     = Nothing unmarshalStrIx strIx = Just strIx -getConfigDesc ∷ Ptr C'libusb_device → Word8 → IO ConfigDesc-getConfigDesc devPtr ix = bracket getConfigDescPtr-                                  c'libusb_free_config_descriptor-                                  ((convertConfigDesc =<<) ∘ peek)-    where-      getConfigDescPtr = alloca $ \configDescPtrPtr → do-                           handleUSBException $ c'libusb_get_config_descriptor-                                                  devPtr-                                                  ix-                                                  configDescPtrPtr-                           peek configDescPtrPtr+-- | Get a USB configuration descriptor based on its index.+--+-- This is a non-blocking function which does not involve any requests+-- being sent to the device.+--+-- Exceptions:+--+-- * 'NotFoundException' if the configuration does not exist.+--+-- * Another 'USBException'.+getConfigDesc ∷ Device → Word8 → IO ConfigDesc+getConfigDesc dev ix = withDevicePtr dev $ \devPtr →+  bracket (allocaPeek $ handleUSBException+                      ∘ c'libusb_get_config_descriptor devPtr ix)+          c'libusb_free_config_descriptor+          ((convertConfigDesc =<<) ∘ peek)  convertConfigDesc ∷ C'libusb_config_descriptor → IO ConfigDesc convertConfigDesc c = do-  let numInterfaces = c'libusb_config_descriptor'bNumInterfaces c-   interfaces ← mapPeekArray convertInterface-                            (fromIntegral numInterfaces)+                            (fromIntegral $ c'libusb_config_descriptor'bNumInterfaces c)                             (c'libusb_config_descriptor'interface c)    extra ← getExtra (c'libusb_config_descriptor'extra c)@@ -1251,7 +1247,6 @@     , configAttribs       = unmarshalConfigAttribs $                             c'libusb_config_descriptor'bmAttributes        c     , configMaxPower      = c'libusb_config_descriptor'MaxPower            c-    , configNumInterfaces = numInterfaces     , configInterfaces    = interfaces     , configExtra         = extra     }@@ -1266,7 +1261,7 @@                                               , fromIntegral extraLength                                               ) -convertInterface ∷ C'libusb_interface → IO [InterfaceDesc]+convertInterface ∷ C'libusb_interface → IO Interface convertInterface i =     mapPeekArray convertInterfaceDesc                  (fromIntegral $ c'libusb_interface'num_altsetting i)@@ -1274,10 +1269,8 @@  convertInterfaceDesc ∷ C'libusb_interface_descriptor → IO InterfaceDesc convertInterfaceDesc i = do-  let numEndpoints = c'libusb_interface_descriptor'bNumEndpoints i-   endpoints ← mapPeekArray convertEndpointDesc-                           (fromIntegral numEndpoints)+                           (fromIntegral $ c'libusb_interface_descriptor'bNumEndpoints i)                            (c'libusb_interface_descriptor'endpoint i)    extra ← getExtra (c'libusb_interface_descriptor'extra i)@@ -1359,18 +1352,18 @@ charSize ∷ Size charSize = 2 -{-| Retrieve a list of supported languages.+{-| Retrieve a vector of supported languages.  This function may throw 'USBException's. -}-getLanguages ∷ DeviceHandle → IO [LangId]+getLanguages ∷ DeviceHandle → IO (Vector LangId) getLanguages devHndl = allocaArray maxSize $ \dataPtr → do   reportedSize ← write dataPtr    let strSize = (reportedSize - strDescHeaderSize) `div` charSize       strPtr = castPtr $ dataPtr `plusPtr` strDescHeaderSize -  map unmarshalLangId <$> peekArray strSize strPtr+  (VG.map unmarshalLangId ∘ VG.convert) <$> peekVector strSize strPtr       where         maxSize = 255 -- Some devices choke on size > 255         write = putStrDesc devHndl 0 0 maxSize@@ -1467,9 +1460,9 @@                     → IO Text getStrDescFirstLang devHndl strIx nrOfChars = do   langIds ← getLanguages devHndl-  case langIds of-    []         → throwIO $ IOException "Zero languages"-    langId : _ → getStrDesc devHndl strIx langId nrOfChars+  case uncons langIds of+    Nothing          → throwIO $ IOException "Zero languages"+    Just (langId, _) → getStrDesc devHndl strIx langId nrOfChars  -------------------------------------------------------------------------------- -- * I/O@@ -1911,7 +1904,7 @@ transferAsync wait transType devHndl endpoint timeout bytes =     withTerminatedTransfer wait                            transType-                           0 []+                           VG.empty                            devHndl endpoint                            timeout                            bytes@@ -1926,7 +1919,7 @@  withTerminatedTransfer ∷ Wait                        → C'TransferType-                       → Int → [C'libusb_iso_packet_descriptor]+                       → Storable.Vector C'libusb_iso_packet_descriptor                        → DeviceHandle → CUChar -- ^ Encoded endpoint address                        → Timeout                        → (Ptr byte, Size)@@ -1935,51 +1928,48 @@                        → IO α withTerminatedTransfer wait                        transType-                       nrOfIsoPackets isoPackageDescs+                       isos                        devHndl endpoint                        timeout                        (bufferPtr, size)                        onCompletion                        onTimeout =-    withDevHndlPtr devHndl $ \devHndlPtr →-      allocaTransfer nrOfIsoPackets $ \transPtr → do-        lock ← newLock-        withCallback (\_ → release lock) $ \cbPtr → do-          poke transPtr $ C'libusb_transfer-            { c'libusb_transfer'dev_handle      = devHndlPtr-            , c'libusb_transfer'flags           = 0 -- unused-            , c'libusb_transfer'endpoint        = endpoint-            , c'libusb_transfer'type            = transType-            , c'libusb_transfer'timeout         = fromIntegral timeout-            , c'libusb_transfer'status          = 0  -- output-            , c'libusb_transfer'length          = fromIntegral size-            , c'libusb_transfer'actual_length   = 0 -- output-            , c'libusb_transfer'callback        = cbPtr-            , c'libusb_transfer'user_data       = nullPtr -- unused-            , c'libusb_transfer'buffer          = castPtr bufferPtr-            , c'libusb_transfer'num_iso_packets = fromIntegral nrOfIsoPackets-            , c'libusb_transfer'iso_packet_desc = isoPackageDescs-            }+  withDevHndlPtr devHndl $ \devHndlPtr → do+    let nrOfIsos = VG.length isos+    allocaTransfer nrOfIsos $ \transPtr → do+      lock ← newLock+      withCallback (\_ → release lock) $ \cbPtr → do+        poke (p'libusb_transfer'dev_handle      transPtr) devHndlPtr+        poke (p'libusb_transfer'endpoint        transPtr) endpoint+        poke (p'libusb_transfer'type            transPtr) transType+        poke (p'libusb_transfer'timeout         transPtr) (fromIntegral timeout)+        poke (p'libusb_transfer'length          transPtr) (fromIntegral size)+        poke (p'libusb_transfer'callback        transPtr) cbPtr+        poke (p'libusb_transfer'buffer          transPtr) (castPtr bufferPtr)+        poke (p'libusb_transfer'num_iso_packets transPtr) (fromIntegral nrOfIsos) -          mask_ $ do-            handleUSBException $ c'libusb_submit_transfer transPtr-            wait timeout lock transPtr+        pokeVector (p'libusb_transfer'iso_packet_desc transPtr) isos -          status ← peek $ p'libusb_transfer'status transPtr-          case status of-            ts | ts ≡ c'LIBUSB_TRANSFER_COMPLETED → onCompletion transPtr-               | ts ≡ c'LIBUSB_TRANSFER_TIMED_OUT → onTimeout    transPtr+        mask_ $ do+          handleUSBException $ c'libusb_submit_transfer transPtr+          wait timeout lock transPtr -               | ts ≡ c'LIBUSB_TRANSFER_ERROR     → throwIO ioException-               | ts ≡ c'LIBUSB_TRANSFER_NO_DEVICE → throwIO NoDeviceException-               | ts ≡ c'LIBUSB_TRANSFER_OVERFLOW  → throwIO OverflowException-               | ts ≡ c'LIBUSB_TRANSFER_STALL     → throwIO PipeException+        status ← peek $ p'libusb_transfer'status transPtr+        case status of+          ts | ts ≡ c'LIBUSB_TRANSFER_COMPLETED → onCompletion transPtr+             | ts ≡ c'LIBUSB_TRANSFER_TIMED_OUT → onTimeout    transPtr -               | ts ≡ c'LIBUSB_TRANSFER_CANCELLED →-                   moduleError "transfer status can't be Cancelled!"+             | ts ≡ c'LIBUSB_TRANSFER_ERROR     → throwIO ioException+             | ts ≡ c'LIBUSB_TRANSFER_NO_DEVICE → throwIO NoDeviceException+             | ts ≡ c'LIBUSB_TRANSFER_OVERFLOW  → throwIO OverflowException+             | ts ≡ c'LIBUSB_TRANSFER_STALL     → throwIO PipeException -               | otherwise → moduleError $ "Unknown transfer status: " ++ show ts ++ "!"+             | ts ≡ c'LIBUSB_TRANSFER_CANCELLED →+                 moduleError "transfer status can't be Cancelled!" +             | otherwise → moduleError $ "Unknown transfer status: " +++                                         show ts ++ "!"+ --------------------------------------------------------------------------------  -- | Allocate a transfer with the given number of isochronous packets and apply@@ -1988,10 +1978,10 @@ -- -- A 'NoMemException' may be thrown. allocaTransfer ∷ Int → (Ptr C'libusb_transfer → IO α) → IO α-allocaTransfer nrOfIsoPackets = bracket mallocTransfer c'libusb_free_transfer+allocaTransfer nrOfIsos = bracket mallocTransfer c'libusb_free_transfer     where       mallocTransfer = do-        transPtr ← c'libusb_alloc_transfer (fromIntegral nrOfIsoPackets)+        transPtr ← c'libusb_alloc_transfer (fromIntegral nrOfIsos)         when (transPtr ≡ nullPtr) (throwIO NoMemException)         return transPtr @@ -2062,26 +2052,43 @@ -} readIsochronous ∷ DeviceHandle                 → EndpointAddress-                → [Size] -- ^ Sizes of isochronous packets+                → Unboxed.Vector Size -- ^ Sizes of isochronous packets                 → Timeout-                → IO [B.ByteString]+                → IO (Vector B.ByteString) readIsochronous devHndl endpointAddr sizes timeout     | Just wait ← getWait devHndl = do-        let SumLength totalSize nrOfIsoPackets = sumLength sizes+        let totalSize = VG.sum    sizes+            nrOfIsos  = VG.length sizes+            isos      = VG.map initIsoPacketDesc $ VG.convert sizes         allocaBytes totalSize $ \bufferPtr →-          withTerminatedTransfer wait-                                 c'LIBUSB_TRANSFER_TYPE_ISOCHRONOUS-                                 nrOfIsoPackets (map initIsoPacketDesc sizes)-                                 devHndl-                                 (marshalEndpointAddress endpointAddr)-                                 timeout-                                 (bufferPtr, totalSize)-                                 (\transPtr → convertIsos nrOfIsoPackets-                                                          transPtr-                                                          bufferPtr)-                                 (\_ → throwIO TimeoutException)+          withTerminatedTransfer+            wait+            c'LIBUSB_TRANSFER_TYPE_ISOCHRONOUS+            isos+            devHndl+            (marshalEndpointAddress endpointAddr)+            timeout+            (bufferPtr, totalSize)+            (getPackets nrOfIsos bufferPtr)+            (\_ → throwIO TimeoutException)     | otherwise = needThreadedRTSError "readIsochronous" +getPackets ∷ Int → Ptr Word8 → Ptr C'libusb_transfer → IO (Vector B.ByteString)+getPackets nrOfIsos bufferPtr transPtr = do+    mv ← VGM.unsafeNew nrOfIsos+    let isoArrayPtr = p'libusb_transfer'iso_packet_desc transPtr+        go ix ptr+            | ix < nrOfIsos = do+                let isoPtr = advancePtr isoArrayPtr ix+                l ← peek (p'libusb_iso_packet_descriptor'length        isoPtr)+                a ← peek (p'libusb_iso_packet_descriptor'actual_length isoPtr)+                let transferred = fromIntegral a+                bs ← BI.create transferred $ \p → copyArray p ptr transferred+                VGM.unsafeWrite mv ix bs+                go (ix+1) (ptr `plusPtr` fromIntegral l)+            | otherwise = VG.unsafeFreeze mv+    go 0 bufferPtr+ --------------------------------------------------------------------------------  {-| Perform a USB /isochronous/ write.@@ -2103,40 +2110,48 @@ -} writeIsochronous ∷ DeviceHandle                  → EndpointAddress-                 → [B.ByteString]+                 → Vector B.ByteString                  → Timeout-                 → IO [Size]+                 → IO (Unboxed.Vector Size) writeIsochronous devHndl endpointAddr isoPackets timeout     | Just wait ← getWait devHndl = do-        let sizes = map B.length isoPackets-            SumLength totalSize nrOfIsoPackets = sumLength sizes+        let sizes     = VG.map B.length isoPackets+            nrOfIsos  = VG.length sizes+            totalSize = VG.sum sizes+            isos      = VG.convert $ VG.map initIsoPacketDesc sizes         allocaBytes totalSize $ \bufferPtr → do           copyIsos (castPtr bufferPtr) isoPackets-          withTerminatedTransfer wait-                                 c'LIBUSB_TRANSFER_TYPE_ISOCHRONOUS-                                 nrOfIsoPackets (map initIsoPacketDesc sizes)-                                 devHndl-                                 (marshalEndpointAddress endpointAddr)-                                 timeout-                                 (bufferPtr, totalSize)-                                 (\transPtr →-                                    map actualLength <$> peekIsoPacketDescs-                                                           nrOfIsoPackets-                                                           transPtr)-                                 (\_ → throwIO TimeoutException)+          withTerminatedTransfer+            wait+            c'LIBUSB_TRANSFER_TYPE_ISOCHRONOUS+            isos+            devHndl+            (marshalEndpointAddress endpointAddr)+            timeout+            (bufferPtr, totalSize)+            (getSizes nrOfIsos)+            (\_ → throwIO TimeoutException)     | otherwise = needThreadedRTSError "writeIsochronous" -----------------------------------------------------------------------------------actualLength ∷ C'libusb_iso_packet_descriptor → Size-actualLength = fromIntegral ∘ c'libusb_iso_packet_descriptor'actual_length---- | Simultaneously calculate the sum and length of the given list.-sumLength ∷ [Int] → SumLength-sumLength = foldl' (\(SumLength s l) x → SumLength (s+x) (l+1)) (SumLength 0 0)+getSizes ∷ Int → Ptr C'libusb_transfer → IO (Unboxed.Vector Size)+getSizes nrOfIsos transPtr = do+  mv ← VGM.unsafeNew nrOfIsos+  let isoArrayPtr = p'libusb_transfer'iso_packet_desc transPtr+      go ix+          | ix < nrOfIsos = do+              let isoPtr = advancePtr isoArrayPtr ix+              a ← peek (p'libusb_iso_packet_descriptor'actual_length isoPtr)+              let transferred = fromIntegral a+              VGM.unsafeWrite mv ix transferred+              go (ix+1)+          | otherwise = VG.unsafeFreeze mv+  go 0 --- | Strict pair of sum and length.-data SumLength = SumLength !Int !Int+copyIsos ∷ Ptr CChar → Vector B.ByteString → IO ()+copyIsos = VG.foldM_ $ \bufferPtr bs →+             BU.unsafeUseAsCStringLen bs $ \(ptr, len) → do+               copyArray bufferPtr ptr len+               return $ bufferPtr `plusPtr` len  -- | An isochronous packet descriptor with all fields zero except for the length. initIsoPacketDesc ∷ Size → C'libusb_iso_packet_descriptor@@ -2146,29 +2161,6 @@     , c'libusb_iso_packet_descriptor'actual_length = 0     , c'libusb_iso_packet_descriptor'status        = 0     }--convertIsos ∷ Int → Ptr C'libusb_transfer → Ptr Word8 → IO [B.ByteString]-convertIsos nrOfIsoPackets transPtr bufferPtr =-    peekIsoPacketDescs nrOfIsoPackets transPtr >>= go bufferPtr id-      where-        go _   bss [] = return $ bss []-        go ptr bss (C'libusb_iso_packet_descriptor l a _ : ds) = do-          let transferred = fromIntegral a-          bs ← BI.create transferred $ \p → copyArray p ptr transferred-          go (ptr `plusPtr` fromIntegral l) (bss ∘ (bs:)) ds---- | Retrieve the isochronous packet descriptors from the given transfer.-peekIsoPacketDescs ∷ Int-                   → Ptr C'libusb_transfer-                   → IO [C'libusb_iso_packet_descriptor]-peekIsoPacketDescs nrOfIsoPackets = peekArray nrOfIsoPackets-                                  ∘ p'libusb_transfer'iso_packet_desc--copyIsos ∷ Ptr CChar → [B.ByteString] → IO ()-copyIsos = foldM_ $ \bufferPtr bs →-             BU.unsafeUseAsCStringLen bs $ \(ptr, len) → do-               copyArray bufferPtr ptr len-               return $ bufferPtr `plusPtr` len #endif  --------------------------------------------------------------------------------

@@ -26,7 +26,8 @@  module System.USB.Descriptors     ( -- * Device descriptor-      DeviceDesc(..)+      getDeviceDesc+    , DeviceDesc(..)      , ReleaseNumber @@ -35,15 +36,15 @@     , VendorId, ProductId        -- * Configuration descriptor+    , getConfigDesc     , ConfigDesc(..) -    , Interface-       -- *** Configuration attributes     , ConfigAttribs     , DeviceStatus(..)        -- * Interface descriptor+    , Interface     , InterfaceDesc(..)        -- * Endpoint descriptor

@@ -21,7 +21,6 @@      , busNumber     , deviceAddress-    , deviceDesc     ) where  import System.USB.Base

@@ -44,8 +44,7 @@     , allocaTransfer     , withCallback -    , SumLength(..), sumLength-    , peekIsoPacketDescs+    , pokeVector     , initIsoPacketDesc      -- ** Locks@@ -54,3 +53,4 @@     ) where  import System.USB.Base+import Utils

@@ -2,6 +2,7 @@            , NoImplicitPrelude            , UnicodeSyntax            , BangPatterns+           , ScopedTypeVariables   #-}  module Utils where@@ -11,23 +12,39 @@ --------------------------------------------------------------------------------  -- from base:-import Prelude ( Num, (+), (-), Enum, toEnum, fromEnum, Integral, fromIntegral )+import Prelude ( ($)+               , Num, (+), (*), (-)+               , Enum, toEnum, fromEnum+               , Integral, fromIntegral, undefined+               )  #if __GLASGOW_HASKELL__ < 700 import Prelude               ( fromInteger )-import Control.Monad         ( (>>) ) #endif -import Control.Monad         ( Monad, (>>=), mapM )+import Control.Monad         ( Monad, return, (>>=), (>>) ) import Foreign.Ptr           ( Ptr )-import Foreign.Storable      ( Storable,  )-import Foreign.Marshal.Array ( peekArray )+import Foreign.ForeignPtr    ( withForeignPtr )+import Foreign.Storable      ( Storable, peek, sizeOf )+import Foreign.Marshal.Alloc ( alloca )+import Foreign.Marshal.Utils ( copyBytes ) import Data.Bool             ( Bool, otherwise ) import Data.Ord              ( Ord, (>) ) import Data.Bits             ( Bits, shiftL, shiftR, bitSize, (.&.) ) import Data.Int              ( Int )+import Data.Maybe            ( Maybe(Nothing, Just) ) import System.IO             ( IO )+import GHC.ForeignPtr        ( mallocPlainForeignPtrBytes ) +-- from vector:+import           Data.Vector                ( Vector )+import qualified Data.Vector          as V  ( null, unsafeHead, unsafeTail )+import qualified Data.Vector.Storable as VS ( Vector, empty, null+                                            , unsafeFromForeignPtr0+                                            , unsafeToForeignPtr0+                                            )+import qualified Data.Vector.Generic  as VG ( Vector, mapM, convert )+ -- from base-unicode-symbols: import Data.Function.Unicode ( (∘) ) import Data.Ord.Unicode      ( (≥), (≤) )@@ -57,9 +74,28 @@  -- | @mapPeekArray f n a@ applies the monadic function @f@ to each of the @n@ -- elements of the array @a@ and returns the results in a list.-mapPeekArray ∷ Storable α ⇒ (α → IO β) → Int → Ptr α → IO [β]-mapPeekArray f n a = peekArray n a >>= mapM f+mapPeekArray ∷ (Storable a, VG.Vector v a, VG.Vector v b) ⇒ (a → IO b) → Int → Ptr a → IO (v b)+mapPeekArray f n a = peekVector n a >>= VG.mapM f ∘ VG.convert +peekVector ∷ forall a. (Storable a) ⇒ Int → Ptr a → IO (VS.Vector a)+peekVector size ptr+    | size ≤ 0  = return VS.empty+    | otherwise = do+        let n = (size * sizeOf (undefined ∷ a))+        fp ← mallocPlainForeignPtrBytes n+        withForeignPtr fp $ \p → copyBytes p ptr n+        return $ VS.unsafeFromForeignPtr0 fp size++pokeVector ∷ forall a. Storable a ⇒ Ptr a → VS.Vector a → IO ()+pokeVector ptr v | VS.null v = return ()+                 | otherwise = withForeignPtr fp $ \p →+                     copyBytes ptr p (size * sizeOf (undefined ∷ a))+    where+      (fp, size) = VS.unsafeToForeignPtr0 v++allocaPeek ∷ Storable α ⇒ (Ptr α → IO ()) → IO α+allocaPeek f = alloca $ \ptr → f ptr >> peek ptr+ -- | Monadic if...then...else... ifM ∷ Monad m ⇒ m Bool → m α → m α → m α ifM cM tM eM = cM >>= \c → if c then tM else eM@@ -77,3 +113,7 @@       go !shftL | shftL > shftR = []                 | otherwise     = let !d = (abcd `shiftL` shftL) `shiftR` shftR                                   in d : go (shftL + bitsInDigit)++uncons ∷ Vector α → Maybe (α, Vector α)+uncons v | V.null v  = Nothing+         | otherwise = Just (V.unsafeHead v, V.unsafeTail v)

@@ -1,5 +1,5 @@ name:          usb-version:       1.1.0.4+version:       1.2 cabal-version: >=1.6 build-type:    Custom license:       BSD3@@ -68,6 +68,7 @@                , bindings-libusb      >= 1.4.4 && < 1.5                , bytestring           >= 0.9   && < 0.11                , text                 >= 0.5   && < 0.12+               , vector               >= 0.5   && < 0.11    exposed-modules: System.USB                    System.USB.Initialization