diff --git a/Data/BCD.hs b/Data/BCD.hs new file mode 100644 --- /dev/null +++ b/Data/BCD.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE NoImplicitPrelude, UnicodeSyntax #-} + +module Data.BCD ( BCD4, unmarshalBCD4, decodeBCD ) where + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +-- from base: +import Prelude ( fromInteger, fromIntegral, (-) ) +import Control.Monad ( (>>) ) +import Data.Bits ( Bits, shiftL, shiftR, bitSize ) +import Data.Bool ( otherwise ) +import Data.Function ( ($) ) +import Data.List ( map ) +import Data.Ord ( (<) ) +import Data.Int ( Int ) +import Data.Word ( Word16 ) + + +-------------------------------------------------------------------------------- +-- Binary Coded Decimals +-------------------------------------------------------------------------------- + +-- | A decoded 16 bits Binary Coded Decimal using 4 bits for each digit. +type BCD4 = (Int, Int, Int, Int) + +-- | Decode a @Word16@ as a Binary Coded Decimal using 4 bits per digit. +unmarshalBCD4 ∷ Word16 → BCD4 +unmarshalBCD4 abcd = (a, b, c, d) + where + [a, b, c, d] = map fromIntegral $ decodeBCD 4 abcd + +{-| @decodeBCD bitsInDigit bcd@ decodes the Binary Coded Decimal @bcd@ 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 α ⇒ Int → α → [α] +decodeBCD bitsInDigit abcd = go shftR [] + where + shftR = bitSize abcd - bitsInDigit + + go shftL ds | shftL < 0 = ds + | otherwise = go (shftL - bitsInDigit) + (((abcd `shiftL` shftL) `shiftR` shftR) : ds) + + +-- The End --------------------------------------------------------------------- diff --git a/System/USB.hs b/System/USB.hs --- a/System/USB.hs +++ b/System/USB.hs @@ -5,37 +5,7 @@ -- License : BSD-style (see the file LICENSE) -- Maintainer : Bas van Dijk -- --- 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: --- --- --- --- Also see the @usb-safe@ package which wraps this package and provides some --- strong safety guarantees for working with USB devices. --- --- --- --- 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: --- --- --- * \"USB in a NutShell\" at: --- +-- A convenience module which re-exports all the important modules. -- -------------------------------------------------------------------------------- @@ -45,7 +15,6 @@ , module System.USB.DeviceHandling , module System.USB.Descriptors , module System.USB.IO.Synchronous - , module System.USB.IO.Synchronous.Enumerator , module System.USB.Exceptions ) where @@ -54,5 +23,4 @@ import System.USB.DeviceHandling import System.USB.Descriptors import System.USB.IO.Synchronous -import System.USB.IO.Synchronous.Enumerator import System.USB.Exceptions diff --git a/System/USB/Descriptors.hs b/System/USB/Descriptors.hs --- a/System/USB/Descriptors.hs +++ b/System/USB/Descriptors.hs @@ -69,3 +69,4 @@ ) where import System.USB.Internal +import Data.BCD ( BCD4 ) diff --git a/System/USB/IO/StandardDeviceRequests.hs b/System/USB/IO/StandardDeviceRequests.hs new file mode 100644 --- /dev/null +++ b/System/USB/IO/StandardDeviceRequests.hs @@ -0,0 +1,239 @@ +{-# LANGUAGE NoImplicitPrelude, UnicodeSyntax, DeriveDataTypeable #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : System.USB.IO.StandardDeviceRequests +-- Copyright : (c) 2009–2010 Bas van Dijk +-- License : BSD3 (see the file LICENSE) +-- Maintainer : Bas van Dijk +-- +-- This module provides functionality for performing standard device requests. +-- +-------------------------------------------------------------------------------- + +module System.USB.IO.StandardDeviceRequests + ( setHalt + , clearRemoteWakeup + , setRemoteWakeup + , setStandardTestMode, TestMode(..) + , getInterfaceAltSetting + , getDeviceStatus + , getEndpointStatus + , setDeviceAddress + , synchFrame, FrameNumber + ) where + + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +-- from base: +import Data.Bits ( testBit, shiftL ) +import Data.Bool ( Bool ) +import Data.Data ( Data ) +import Data.Eq ( Eq ) +import Data.Functor ( (<$>) ) +import Data.Typeable ( Typeable ) +import Data.Word ( Word8, Word16 ) +import Prelude ( (+), fromInteger, fromIntegral, Enum ) +import System.IO ( IO ) +import Text.Read ( Read ) +import Text.Show ( Show ) + +-- from base-unicode-symbols: +import Data.Eq.Unicode ( (≡) ) +import Data.Function.Unicode ( (∘) ) +import Prelude.Unicode ( (⋅) ) + +-- from bytestring: +import qualified Data.ByteString as B ( head, unpack ) + +-- from bindings-libusb: +import Bindings.Libusb ( c'LIBUSB_REQUEST_SET_FEATURE + , c'LIBUSB_REQUEST_CLEAR_FEATURE + , c'LIBUSB_REQUEST_GET_INTERFACE + , c'LIBUSB_REQUEST_GET_STATUS + , c'LIBUSB_REQUEST_SET_ADDRESS + , c'LIBUSB_REQUEST_SYNCH_FRAME + ) + +-- from usb: +import System.USB.DeviceHandling ( DeviceHandle + , InterfaceNumber + , InterfaceAltSetting + ) +import System.USB.Descriptors ( EndpointAddress + , DeviceStatus(..) + ) +import System.USB.IO.Synchronous ( Timeout + , RequestType(Standard) + , Recipient( ToDevice + , ToInterface + , ToEndpoint + ) + , Value + , control, readControlExact + ) + +import System.USB.Unsafe ( marshalEndpointAddress ) + +import Utils ( genFromEnum ) + + +-------------------------------------------------------------------------------- +-- Standard Device Requests +------------------------------------------------------------------------------- + +-- See: USB 2.0 Spec. section 9.4 + +-- Standard Feature Selectors: +-- See: USB 2.0 Spec. table 9-6 +haltFeature, remoteWakeupFeature, testModeFeature ∷ Value +haltFeature = 0 +remoteWakeupFeature = 1 +testModeFeature = 2 + +-- | See: USB 2.0 Spec. section 9.4.9 +setHalt ∷ DeviceHandle → EndpointAddress → (Timeout → IO ()) +setHalt devHndl endpointAddr = + control devHndl + Standard + ToEndpoint + c'LIBUSB_REQUEST_SET_FEATURE + haltFeature + (marshalEndpointAddress endpointAddr) + +-- | See: USB 2.0 Spec. section 9.4.1 +clearRemoteWakeup ∷ DeviceHandle → (Timeout → IO ()) +clearRemoteWakeup devHndl = + control devHndl + Standard + ToDevice + c'LIBUSB_REQUEST_CLEAR_FEATURE + remoteWakeupFeature + 0 + +-- | See: USB 2.0 Spec. section 9.4.9 +setRemoteWakeup ∷ DeviceHandle → (Timeout → IO ()) +setRemoteWakeup devHndl = + control devHndl + Standard + ToDevice + c'LIBUSB_REQUEST_SET_FEATURE + remoteWakeupFeature + 0 + +-- | See: USB 2.0 Spec. section 9.4.9 +-- TODO: What about vendor-specific test modes? +setStandardTestMode ∷ DeviceHandle → TestMode → (Timeout → IO ()) +setStandardTestMode devHndl testMode = + control devHndl + Standard + ToDevice + c'LIBUSB_REQUEST_SET_FEATURE + testModeFeature + ((genFromEnum testMode + 1) `shiftL` 8) + +-- | See: USB 2.0 Spec. table 9-7 +data TestMode = Test_J + | Test_K + | Test_SE0_NAK + | Test_Packet + | Test_Force_Enable + deriving (Eq, Show, Read, Enum, Data, Typeable) + +-- | See: USB 2.0 Spec. section 9.4.4 +getInterfaceAltSetting ∷ DeviceHandle → InterfaceNumber → (Timeout → IO InterfaceAltSetting) +getInterfaceAltSetting devHndl ifNum = \timeout → do + B.head <$> readControlExact devHndl + Standard + ToInterface + c'LIBUSB_REQUEST_GET_INTERFACE + 0 + (fromIntegral ifNum) + 1 + timeout + +-- | See: USB 2.0 Spec. section 9.4.5 +getDeviceStatus ∷ DeviceHandle → (Timeout → IO DeviceStatus) +getDeviceStatus devHndl = \timeout → do + (unmarshalDeviceStatus ∘ B.head) <$> readControlExact devHndl + Standard + ToDevice + c'LIBUSB_REQUEST_GET_STATUS + 0 + 0 + 2 + timeout + where + 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 devHndl endpointAddr = \timeout → do + ((1 ≡) ∘ B.head) <$> readControlExact devHndl + Standard + ToEndpoint + c'LIBUSB_REQUEST_GET_STATUS + 0 + (marshalEndpointAddress endpointAddr) + 2 + timeout + +-- | See: USB 2.0 Spec. section 9.4.6 +setDeviceAddress ∷ DeviceHandle → Word16 → (Timeout → IO ()) +setDeviceAddress devHndl deviceAddr = control devHndl + Standard + ToDevice + c'LIBUSB_REQUEST_SET_ADDRESS + deviceAddr + 0 + +-- TODO: setDescriptor See: USB 2.0 Spec. section 9.4.8 + +-- TODO Sync Frame klopt niet helemaal, je kunt met deze request ook het frame number setten! + +{-| +This request is used to set and then report an endpoint's synchronization frame. + +When an endpoint supports isochronous transfers, the endpoint may also require +per-frame transfers to vary in size according to a specific pattern. The host +and the endpoint must agree on which frame the repeating pattern begins. The +number of the frame in which the pattern began is returned to the host. + +If a high-speed device supports the Synch Frame request, it must internally +synchronize itself to the zeroth microframe and have a time notion of classic +frame. Only the frame number is used to synchronize and reported by the device +endpoint (i.e., no microframe number). The endpoint must synchronize to the +zeroth microframe. + +This value is only used for isochronous data transfers using implicit pattern +synchronization. If the specified endpoint does not support this request, then +the device will respond with a Request Error. + +See: USB 2.0 Spec. section 9.4.11 +-} +synchFrame ∷ DeviceHandle → EndpointAddress → (Timeout → IO FrameNumber) +synchFrame devHndl endpointAddr = \timeout → do + unmarshallFrameNumber <$> readControlExact + devHndl + Standard + ToEndpoint + c'LIBUSB_REQUEST_SYNCH_FRAME + 0 + (marshalEndpointAddress endpointAddr) + 2 + timeout + where + unmarshallFrameNumber bs = let [h, l] = B.unpack bs + in fromIntegral h ⋅ 256 + fromIntegral l + +type FrameNumber = Word16 + + +-- The End --------------------------------------------------------------------- diff --git a/System/USB/IO/Synchronous.hs b/System/USB/IO/Synchronous.hs --- a/System/USB/IO/Synchronous.hs +++ b/System/USB/IO/Synchronous.hs @@ -14,7 +14,7 @@ ( ReadAction , WriteAction - , Timeout + , Timeout, TimedOut , Size -- * Control transfers @@ -26,19 +26,8 @@ , Index , control - , readControl + , readControl, readControlExact , writeControl - - -- ** Standard Device Requests - , setHalt - , clearRemoteWakeup - , setRemoteWakeup - , setStandardTestMode, TestMode(..) - , getInterfaceAltSetting - , getDeviceStatus - , getEndpointStatus - , setDeviceAddress - , synchFrame -- * Bulk transfers , readBulk diff --git a/System/USB/IO/Synchronous/Enumerator.hs b/System/USB/IO/Synchronous/Enumerator.hs deleted file mode 100644 --- a/System/USB/IO/Synchronous/Enumerator.hs +++ /dev/null @@ -1,157 +0,0 @@ -{-# LANGUAGE CPP, UnicodeSyntax, NoImplicitPrelude, FlexibleContexts #-} - --------------------------------------------------------------------------------- --- | --- Module : System.USB.IO.Synchronous.Enumerator --- Copyright : (c) 2009–2010 Bas van Dijk --- License : BSD3 (see the file LICENSE) --- Maintainer : Bas van Dijk --- --- /Untested/ /experimental/ enumerators for endpoints. --- --------------------------------------------------------------------------------- - -module System.USB.IO.Synchronous.Enumerator - ( enumReadBulk - , enumReadInterrupt - ) where - - --------------------------------------------------------------------------------- --- Imports --------------------------------------------------------------------------------- - --- from base: -import Prelude ( fromInteger, fromIntegral ) -import Data.Function ( ($) ) -import Data.Word ( Word8 ) -import Data.Maybe ( Maybe(Nothing, Just) ) -import Control.Monad ( return, (>>=), fail ) -import Text.Show ( show ) -import Foreign.Storable ( peek ) -import Foreign.Ptr ( castPtr ) - --- from base-unicode-symbols: -import Data.Eq.Unicode ( (≡), (≢) ) -import Data.Bool.Unicode ( (∧) ) - --- from bindings-libusb: -import Bindings.Libusb ( c'libusb_bulk_transfer, c'libusb_interrupt_transfer - , c'LIBUSB_SUCCESS, c'LIBUSB_ERROR_TIMEOUT - ) - --- from transformers: -import Control.Monad.IO.Class ( liftIO ) - --- from MonadCatchIO-transformers: -import Control.Monad.CatchIO ( MonadCatchIO ) - --- from MonadCatchIO-transformers-foreign: -import Control.Monad.CatchIO.Foreign ( alloca, allocaBytes ) - --- from iteratee: -import Data.Iteratee.Base ( EnumeratorGM - , StreamG(Chunk) - , IterGV(Done, Cont) - , runIter - , enumErr - , throwErr - ) -import Data.Iteratee.Base.StreamChunk ( ReadableChunk(readFromPtr) ) - --- from myself: -import System.USB.DeviceHandling ( DeviceHandle ) -import System.USB.Descriptors ( EndpointAddress ) -import System.USB.IO.Synchronous ( Timeout, Size ) - -import System.USB.Internal ( C'TransferFunc - , getDevHndlPtr - , marshalEndpointAddress - , convertUSBException - ) - -#ifdef __HADDOCK__ -import System.USB.Descriptors ( maxPacketSize, endpointMaxPacketSize ) -#endif - - --------------------------------------------------------------------------------- --- Enumerators --------------------------------------------------------------------------------- - -enumReadBulk ∷ (ReadableChunk s Word8, MonadCatchIO m) - ⇒ 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. - → Size -- ^ Chunk size. A good value for this would be - -- the @'maxPacketSize' . 'endpointMaxPacketSize'@. - → Timeout -- ^ Timeout (in milliseconds) that this function - -- should wait for each chunk before giving up - -- due to no response being received. For no - -- timeout, use value 0. - → EnumeratorGM s Word8 m α -enumReadBulk = enumRead c'libusb_bulk_transfer - -enumReadInterrupt ∷ (ReadableChunk s Word8, MonadCatchIO m) - ⇒ 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. - → Size -- ^ Chunk size. A good value for this would - -- be the @'maxPacketSize' . 'endpointMaxPacketSize'@. - → Timeout -- ^ Timeout (in milliseconds) that this - -- function should wait for each chunk - -- before giving up due to no response - -- being received. For no timeout, use - -- value 0. - → EnumeratorGM s Word8 m α -enumReadInterrupt = enumRead c'libusb_interrupt_transfer - - --------------------------------------------------------------------------------- - -enumRead ∷ (ReadableChunk s Word8, MonadCatchIO m) - ⇒ C'TransferFunc → ( DeviceHandle - → EndpointAddress - → Size - → Timeout - → EnumeratorGM s Word8 m α - ) -enumRead c'transfer = \devHndl - endpoint - chunkSize - timeout → \iter → - alloca $ \transferredPtr → - allocaBytes chunkSize $ \dataPtr → - let loop i1 = do - err ← liftIO $ c'transfer (getDevHndlPtr devHndl) - (marshalEndpointAddress endpoint) - (castPtr dataPtr) - (fromIntegral chunkSize) - transferredPtr - (fromIntegral timeout) - if err ≢ c'LIBUSB_SUCCESS ∧ - err ≢ c'LIBUSB_ERROR_TIMEOUT - then enumErr (show $ convertUSBException err) i1 - else do - t ← liftIO $ peek transferredPtr - if t ≡ 0 - then return i1 - else do - s ← liftIO $ readFromPtr dataPtr $ fromIntegral t - r ← runIter i1 $ Chunk s - case r of - Done x _ → return $ return x - Cont i2 Nothing → loop i2 - Cont _ (Just e) → return $ throwErr e - in loop iter - - --- The End --------------------------------------------------------------------- diff --git a/System/USB/Initialization.hs b/System/USB/Initialization.hs --- a/System/USB/Initialization.hs +++ b/System/USB/Initialization.hs @@ -5,7 +5,7 @@ -- License : BSD3 (see the file LICENSE) -- Maintainer : Bas van Dijk -- --- This module provides functionality for initializing this @usb@ library. +-- This module provides functionality for initializing the @usb@ library. -- -------------------------------------------------------------------------------- diff --git a/System/USB/Internal.hs b/System/USB/Internal.hs --- a/System/USB/Internal.hs +++ b/System/USB/Internal.hs @@ -8,13 +8,13 @@ -------------------------------------------------------------------------------- -- from base: -import Prelude ( Num, (+), (-), fromInteger, (^) +import Prelude ( Num, (+), (-), (*), fromInteger , Integral, fromIntegral, div - , Enum, fromEnum, toEnum - , error + , Enum, error ) import Foreign ( unsafePerformIO ) import Foreign.C.Types ( CUChar, CInt, CUInt ) +import Foreign.C.String ( CStringLen ) import Foreign.Marshal.Alloc ( alloca ) import Foreign.Marshal.Array ( peekArray, allocaArray ) import Foreign.Storable ( Storable, peek, peekElemOff ) @@ -26,51 +26,48 @@ , bracket, bracket_ , block, unblock , onException + , assert ) import Control.Monad ( Monad, return, (>>=), (>>), (=<<), fail - , when, forM, mapM + , when, forM ) import Control.Arrow ( (&&&) ) -import Data.Function ( ($), flip ) -import Data.Functor ( Functor, fmap, (<$), (<$>) ) +import Data.Function ( ($), flip, on ) +import Data.Functor ( Functor, fmap, (<$>) ) import Data.Data ( Data ) import Data.Typeable ( Typeable ) import Data.Maybe ( fromMaybe ) -import Data.List ( lookup, map ) +import Data.List ( lookup, map, (++) ) import Data.Int ( Int ) import Data.Word ( Word8, Word16 ) import Data.Char ( String ) import Data.Eq ( Eq, (==) ) import Data.Ord ( Ord, (<), (>) ) -import Data.Bool ( Bool(False, True), not, otherwise ) +import Data.Bool ( Bool(False, True), not ) import Data.Bits ( Bits - , (.|.), (.&.) + , (.|.) , setBit, testBit - , shiftR, shiftL - , bitSize + , shiftL ) import System.IO ( IO ) -import Text.Show ( Show ) +import Text.Show ( Show, show ) +import Text.Read ( Read ) +import Text.Printf ( printf ) -- from base-unicode-symbols: -import Prelude.Unicode ( (⋅) ) import Data.Function.Unicode ( (∘) ) -import Data.Bool.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.Internal as BI ( createAndTrim , createAndTrim' - , toForeignPtr ) +import qualified Data.ByteString.Unsafe as BU ( unsafeUseAsCStringLen ) -- from text: import qualified Data.Text as T ( unpack ) @@ -79,7 +76,17 @@ -- from bindings-libusb: import Bindings.Libusb +-- from usb: +import Data.BCD ( BCD4, unmarshalBCD4 ) +import Utils ( bits + , between + , void + , genToEnum, genFromEnum + , mapPeekArray + , ifM + ) + -------------------------------------------------------------------------------- -- * Initialization -------------------------------------------------------------------------------- @@ -95,6 +102,7 @@ The only functions that receive a @Ctx@ are 'setDebug' and 'getDevices'. -} newtype Ctx = Ctx { unCtx ∷ ForeignPtr C'libusb_context } + deriving (Eq, Typeable) withCtxPtr ∷ Ctx → (Ptr C'libusb_context → IO α) → IO α withCtxPtr = withForeignPtr ∘ unCtx @@ -129,9 +137,8 @@ nothing: you'll always get messages from all levels. -} setDebug ∷ Ctx → Verbosity → IO () -setDebug ctx verbosity = - withCtxPtr ctx $ \ctxPtr → - c'libusb_set_debug ctxPtr $ genFromEnum verbosity +setDebug ctx verbosity = withCtxPtr ctx $ \ctxPtr → + c'libusb_set_debug ctxPtr $ genFromEnum verbosity -- | Message verbosity data Verbosity = @@ -140,7 +147,7 @@ | 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 + deriving (Enum, Show, Read, Eq, Ord, Data, Typeable) -------------------------------------------------------------------------------- @@ -163,6 +170,9 @@ To get additional information about a device you can retrieve its descriptor using 'deviceDesc'. + +Note that equality on devices is defined by comparing their descriptors: +@(==) = (==) \`on\` `deviceDesc`@ -} data Device = Device { _ctx ∷ Ctx -- ^ This reference to the 'Ctx' is needed so that it won't @@ -172,8 +182,19 @@ , getDevFrgnPtr ∷ ForeignPtr C'libusb_device , deviceDesc ∷ DeviceDesc -- ^ Get the descriptor of the device. - } + } deriving Typeable +instance Eq Device where + (==) = (==) `on` deviceDesc + +instance Show Device where + show d = printf "Bus %03d Device %03d: ID %04x:%04x" (busNumber d) + (deviceAddress d) + (deviceVendorId desc) + (deviceProductId desc) + where + desc = deviceDesc d + withDevicePtr ∷ Device → (Ptr C'libusb_device → IO α) → IO α withDevicePtr = withForeignPtr ∘ getDevFrgnPtr @@ -206,26 +227,20 @@ -} getDevices ∷ Ctx → IO [Device] getDevices ctx = - withCtxPtr ctx $ \ctxPtr → alloca $ \devPtrArrayPtr → block $ do - - numDevs ← c'libusb_get_device_list ctxPtr devPtrArrayPtr + numDevs ← withCtxPtr ctx $ flip c'libusb_get_device_list devPtrArrayPtr + when (numDevs ≡ c'LIBUSB_ERROR_NO_MEM) $ throwIO NoMemException devPtrArray ← peek devPtrArrayPtr - let freeDevPtrArray = c'libusb_free_device_list devPtrArray 0 - - devs ← flip onException freeDevPtrArray $ unblock $ - case numDevs of - n | n ≡ c'LIBUSB_ERROR_NO_MEM → throwIO NoMemException - | n < 0 → unknownLibUsbError - | otherwise → do - devPtrs ← peekArray (fromIntegral numDevs) devPtrArray - forM devPtrs $ \devPtr → - liftA2 (Device ctx) - (newForeignPtr p'libusb_unref_device devPtr) - (getDeviceDesc devPtr) + devs ← unblock (mapPeekArray mkDev (fromIntegral numDevs) devPtrArray) + `onException` freeDevPtrArray freeDevPtrArray return devs + where + mkDev ∷ Ptr C'libusb_device → IO Device + mkDev devPtr = liftA2 (Device ctx) + (newForeignPtr p'libusb_unref_device devPtr) + (getDeviceDesc devPtr) -- | The number of the bus that a device is connected to. busNumber ∷ Device → Word8 @@ -264,8 +279,15 @@ -- and therefor the 'Ctx' alive. -- ^ Retrieve the 'Device' from the 'DeviceHandle'. , getDevHndlPtr ∷ Ptr C'libusb_device_handle - } + -- ^ Retrieve the pointer to the @libusb@ device handle. + } deriving Typeable +instance Eq DeviceHandle where + (==) = (==) `on` getDevHndlPtr + +instance Show DeviceHandle where + show devHndl = "{USB device handle to: " ++ show (getDevice devHndl) ++ "}" + {-| Open a device and obtain a device handle. A handle allows you to perform I/O on the device in question. @@ -420,8 +442,8 @@ -} claimInterface ∷ DeviceHandle → InterfaceNumber → IO () -claimInterface (DeviceHandle _ devHndlPtr) ifNum = - handleUSBException $ c'libusb_claim_interface devHndlPtr +claimInterface devHndl ifNum = + handleUSBException $ c'libusb_claim_interface (getDevHndlPtr devHndl) (fromIntegral ifNum) {-| Release an interface previously claimed with 'claimInterface'. @@ -440,8 +462,8 @@ * Another 'USBException'. -} releaseInterface ∷ DeviceHandle → InterfaceNumber → IO () -releaseInterface (DeviceHandle _ devHndlPtr) ifNum = - handleUSBException $ c'libusb_release_interface devHndlPtr +releaseInterface devHndl ifNum = + handleUSBException $ c'libusb_release_interface (getDevHndlPtr devHndl) (fromIntegral ifNum) {-| @withClaimedInterface@ claims the interface on the given device handle then @@ -681,7 +703,7 @@ -- | List of configurations supported by the device. , deviceConfigs ∷ [ConfigDesc] - } deriving (Show, Eq, Data, Typeable) + } deriving (Show, Read, Eq, Data, Typeable) type VendorId = Word16 type ProductId = Word16 @@ -722,7 +744,7 @@ -- descriptors, it will store them here, should you wish to parse them. , configExtra ∷ B.ByteString - } deriving (Show, Eq, Data, Typeable) + } deriving (Show, Read, Eq, Data, Typeable) -- | An interface is represented as a list of alternate interface settings. type Interface = [InterfaceDesc] @@ -742,7 +764,7 @@ -- support remote wakeup is disabled. , selfPowered ∷ Bool -- ^ The Self Powered field indicates whether the -- device is currently self-powered - } deriving (Show, Eq, Data, Typeable) + } deriving (Show, Read, Eq, Data, Typeable) -------------------------------------------------------------------------------- -- ** Interface descriptor @@ -781,7 +803,7 @@ -- | Extra descriptors. If @libusb@ encounters unknown interface -- descriptors, it will store them here, should you wish to parse them. , interfaceExtra ∷ B.ByteString - } deriving (Show, Eq, Data, Typeable) + } deriving (Show, Read, Eq, Data, Typeable) -------------------------------------------------------------------------------- @@ -819,7 +841,7 @@ -- | Extra descriptors. If @libusb@ encounters unknown endpoint descriptors, -- it will store them here, should you wish to parse them. , endpointExtra ∷ B.ByteString - } deriving (Show, Eq, Data, Typeable) + } deriving (Show, Read, Eq, Data, Typeable) -------------------------------------------------------------------------------- -- *** Endpoint address @@ -829,14 +851,14 @@ data EndpointAddress = EndpointAddress { endpointNumber ∷ Int -- ^ Must be >= 0 and <= 15 , transferDirection ∷ TransferDirection - } deriving (Show, Eq, Data, Typeable) + } deriving (Show, Read, Eq, Data, Typeable) -- | The direction of data transfer relative to the host. data TransferDirection = Out -- ^ Out transfer direction (host -> device) used -- for writing. | In -- ^ In transfer direction (device -> host) used -- for reading. - deriving (Show, Eq, Data, Typeable) + deriving (Show, Read, Eq, Data, Typeable) -------------------------------------------------------------------------------- -- *** Endpoint attributes @@ -861,18 +883,18 @@ -- | Interrupt transfers are typically non-periodic, small device -- \"initiated\" communication requiring bounded latency. | Interrupt - deriving (Show, Eq, Data, Typeable) + deriving (Show, Read, Eq, Data, Typeable) data Synchronization = NoSynchronization | Asynchronous | Adaptive | Synchronous - deriving (Enum, Show, Eq, Data, Typeable) + deriving (Enum, Show, Read, Eq, Data, Typeable) data Usage = Data | Feedback | Implicit - deriving (Enum, Show, Eq, Data, Typeable) + deriving (Enum, Show, Read, Eq, Data, Typeable) -------------------------------------------------------------------------------- -- *** Endpoint max packet size @@ -881,11 +903,11 @@ data MaxPacketSize = MaxPacketSize { maxPacketSize ∷ Size , transactionOpportunities ∷ TransactionOpportunities - } deriving (Show, Eq, Data, Typeable) + } deriving (Show, Read, Eq, Data, Typeable) -- | Number of additional transactions. data TransactionOpportunities = Zero | One | Two - deriving (Enum, Show, Eq, Data, Typeable) + deriving (Enum, Ord, Show, Read, Eq, Data, Typeable) -------------------------------------------------------------------------------- -- Retrieving and converting descriptors @@ -966,7 +988,7 @@ , fromIntegral extraLength ) -convertInterface∷ C'libusb_interface → IO [InterfaceDesc] +convertInterface ∷ C'libusb_interface → IO [InterfaceDesc] convertInterface i = mapPeekArray convertInterfaceDesc (fromIntegral $ c'libusb_interface'num_altsetting i) @@ -1018,14 +1040,14 @@ , transferDirection = if testBit a 7 then In else Out } +-- | Marshal an @EndpointAddress@ so that it can be used by the @libusb@ +-- transfer functions. marshalEndpointAddress ∷ (Bits a, Num a) ⇒ EndpointAddress → a -marshalEndpointAddress (EndpointAddress num transDir) - | between num 0 15 = let n = fromIntegral num - in case transDir of - Out → n - In → setBit n 7 - | otherwise = - error "marshalEndpointAddress: endpointNumber not >= 0 and <= 15" +marshalEndpointAddress (EndpointAddress num transDir) = + assert (between num 0 15) $ let n = fromIntegral num + in case transDir of + Out → n + In → setBit n 7 unmarshalEndpointAttribs ∷ Word8 → EndpointAttribs unmarshalEndpointAttribs a = @@ -1048,6 +1070,7 @@ -- ** String descriptors -------------------------------------------------------------------------------- +-- | The size in number of bytes of the header of string descriptors strDescHeaderSize ∷ Size strDescHeaderSize = 2 @@ -1056,15 +1079,17 @@ 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 - map unmarshalLangId <$> - peekArray ((reportedSize - strDescHeaderSize) `div` 2) - (castPtr $ dataPtr `plusPtr` strDescHeaderSize) +getLanguages devHndl = allocaArray maxSize $ \dataPtr → do + reportedSize ← write dataPtr + let strSize = (reportedSize - strDescHeaderSize) `div` 2 + strPtr = castPtr $ dataPtr `plusPtr` strDescHeaderSize + map unmarshalLangId <$> peekArray strSize strPtr + where + maxSize = 255 -- Some devices choke on size > 255 + write = putStrDesc devHndl 0 0 maxSize + {-| @putStrDesc devHndl strIx langId maxSize dataPtr@ retrieves the string descriptor @strIx@ in the language @langId@ from the @devHndl@ and writes at most @maxSize@ bytes from that string descriptor to the @@ -1086,15 +1111,18 @@ langId dataPtr (fromIntegral maxSize) - -- if there are enough bytes, parse the header - when (actualSize < strDescHeaderSize) $ throwIO IOException + when (actualSize < strDescHeaderSize) $ + throwIO $ IOException "Incomplete header" + reportedSize ← peek dataPtr + + when (reportedSize > fromIntegral actualSize) $ + throwIO $ IOException "Not enough space to hold data" + descType ← peekElemOff dataPtr 1 - -- Check header incorrectness: - when ( descType ≢ c'LIBUSB_DT_STRING - ∨ reportedSize > fromIntegral actualSize - ) $ throwIO IOException + when (descType ≢ c'LIBUSB_DT_STRING) $ + throwIO $ IOException "Invalid header" return $ fromIntegral reportedSize @@ -1132,14 +1160,19 @@ 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 strDescHeaderSize) $ - BI.createAndTrim size $ putStrDesc devHndl - strIx - (marshalLangId langId) - size - ∘ castPtr +getStrDesc ∷ DeviceHandle + → StrIx + → LangId + → Int -- ^ Maximum number of characters in the requested string. An + -- 'IOException' will be thrown when the requested string is + -- larger than this number. + → IO String +getStrDesc devHndl strIx langId nrOfChars = + fmap decode $ BI.createAndTrim size $ write ∘ castPtr + where + write = putStrDesc devHndl strIx (marshalLangId langId) size + size = strDescHeaderSize + 2 * nrOfChars -- characters are 2 bytes + decode = T.unpack ∘ TE.decodeUtf16LE ∘ B.drop strDescHeaderSize {-| Retrieve a string descriptor from a device using the first supported language. @@ -1150,12 +1183,17 @@ This function may throw 'USBException's. -} -getStrDescFirstLang ∷ DeviceHandle → StrIx → Size → IO String -getStrDescFirstLang devHndl strIx size = +getStrDescFirstLang ∷ DeviceHandle + → StrIx + → Int -- ^ Maximum number of characters in the requested + -- string. An 'IOException' will be thrown when the + -- requested string is larger than this number. + → IO String +getStrDescFirstLang devHndl strIx nrOfChars = do langIds ← getLanguages devHndl case langIds of - [] → throwIO IOException - langId : _ → getStrDesc devHndl strIx langId size + [] → throwIO $ IOException "Zero languages" + langId : _ → getStrDesc devHndl strIx langId nrOfChars -------------------------------------------------------------------------------- @@ -1177,7 +1215,7 @@ executed, performs the actual read and returns the 'B.ByteString' that was read paired with a flag which indicates whether a transfer timed out. -} -type ReadAction = Size → Timeout → IO (B.ByteString, Bool) +type ReadAction = Size → Timeout → IO (B.ByteString, TimedOut) {-| Handy type synonym for write transfers. @@ -1186,13 +1224,16 @@ number of bytes that were actually written paired with an flag which indicates whether a transfer timed out. -} -type WriteAction = B.ByteString → Timeout → IO (Size, Bool) +type WriteAction = B.ByteString → Timeout → IO (Size, TimedOut) -- | A timeout in milliseconds. A timeout defines how long a transfer should wait -- before giving up due to no response being received. For no timeout, use value -- 0. type Timeout = Int +-- | 'True' when a transfer timed out and 'False' otherwise. +type TimedOut = Bool + -- | Number of bytes transferred. type Size = Int @@ -1206,13 +1247,13 @@ data RequestType = Standard | Class | Vendor - deriving (Enum, Show, Eq, Data, Typeable) + deriving (Enum, Show, Read, Eq, Data, Typeable) data Recipient = ToDevice | ToInterface | ToEndpoint | ToOther - deriving (Enum, Show, Eq, Data, Typeable) + deriving (Enum, Show, Read, Eq, Data, Typeable) type Request = Word8 @@ -1276,6 +1317,27 @@ then throwIO $ convertUSBException err else return (0, fromIntegral err, timedOut) +-- | A convenience function similar to 'readControl' which checks if the +-- specified number of bytes to read were actually read. Throws an 'IOException' +-- if this is not the case. +readControlExact ∷ DeviceHandle → ControlAction (Size → Timeout → IO B.ByteString) +readControlExact devHndl = \reqType reqRecipient request value index → \size timeout → do + BI.createAndTrim size $ \dataPtr → do + err ← c'libusb_control_transfer + (getDevHndlPtr devHndl) + (marshalRequestType reqType reqRecipient `setBit` 7) + request + value + index + (castPtr dataPtr) + (fromIntegral size) + (fromIntegral timeout) + if err < 0 ∧ err ≢ c'LIBUSB_ERROR_TIMEOUT + then throwIO $ convertUSBException err + else if err ≢ fromIntegral size + then throwIO $ IOException "The read number of bytes doesn't equal the requested number" + else return $ fromIntegral err + {-| Perform a USB /control/ write. Exceptions: @@ -1288,7 +1350,7 @@ -} writeControl ∷ DeviceHandle → ControlAction WriteAction writeControl devHndl = \reqType reqRecipient request value index → \input timeout → - input `writeWith` \size dataPtr → do + BU.unsafeUseAsCStringLen input $ \(dataPtr, size) → do err ← c'libusb_control_transfer (getDevHndlPtr devHndl) (marshalRequestType reqType reqRecipient) @@ -1303,147 +1365,7 @@ then throwIO $ convertUSBException err else return (fromIntegral err, timedOut) --------------------------------------------------------------------------------- --- *** Standard Device Requests -------------------------------------------------------------------------------- --- See: USB 2.0 Spec. section 9.4 - --- Standard Feature Selectors: --- See: USB 2.0 Spec. table 9-6 -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 devHndl endpointAddr = - control devHndl - Standard - ToEndpoint - c'LIBUSB_REQUEST_SET_FEATURE - haltFeature - (marshalEndpointAddress endpointAddr) - --- | See: USB 2.0 Spec. section 9.4.1 -clearRemoteWakeup ∷ DeviceHandle → Timeout → IO () -clearRemoteWakeup devHndl = - control devHndl - Standard - ToDevice - c'LIBUSB_REQUEST_CLEAR_FEATURE - remoteWakeupFeature - 0 - --- | See: USB 2.0 Spec. section 9.4.9 -setRemoteWakeup ∷ DeviceHandle → Timeout → IO () -setRemoteWakeup devHndl = - control devHndl - Standard - ToDevice - c'LIBUSB_REQUEST_SET_FEATURE - remoteWakeupFeature - 0 - --- | See: USB 2.0 Spec. section 9.4.9 --- TODO: What about vendor-specific test modes? -setStandardTestMode ∷ DeviceHandle → TestMode → Timeout → IO () -setStandardTestMode devHndl testMode = - control devHndl - Standard - ToDevice - c'LIBUSB_REQUEST_SET_FEATURE - testModeFeature - (genFromEnum testMode + 1 `shiftL` 8) - --- | See: USB 2.0 Spec. table 9-7 -data TestMode = Test_J - | Test_K - | Test_SE0_NAK - | Test_Packet - | Test_Force_Enable - deriving (Show, Enum, Data, Typeable) - --- | See: USB 2.0 Spec. section 9.4.4 -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 - then throwIO IOException - else return $ B.head bs - --- | See: USB 2.0 Spec. section 9.4.5 -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 - then throwIO IOException - else return $ unmarshalDeviceStatus $ B.head bs - where - 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 devHndl endpointAddr = \timeout → do - (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 - --- | See: USB 2.0 Spec. section 9.4.6 -setDeviceAddress ∷ DeviceHandle → Word16 → Timeout → IO () -setDeviceAddress devHndl deviceAddr = - control devHndl - Standard - ToDevice - c'LIBUSB_REQUEST_SET_ADDRESS - deviceAddr - 0 - --- 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 devHndl endpointAddr = \timeout → do - (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 - -------------------------------------------------------------------------------- -- ** Bulk transfers -------------------------------------------------------------------------------- @@ -1547,6 +1469,7 @@ -------------------------------------------------------------------------------- +-- | Handy type synonym for the @libusb@ transfer functions. type C'TransferFunc = Ptr C'libusb_device_handle -- devHndlPtr → CUChar -- endpoint address → Ptr CUChar -- dataPtr @@ -1562,23 +1485,25 @@ devHndl endpointAddr timeout - size - dataPtr + (castPtr dataPtr, size) return (0, transferred, timedOut) writeTransfer ∷ C'TransferFunc → (DeviceHandle → EndpointAddress → WriteAction) writeTransfer c'transfer = \devHndl endpointAddr → \input timeout → - input `writeWith` transfer c'transfer - devHndl - endpointAddr - timeout + BU.unsafeUseAsCStringLen input $ transfer c'transfer + devHndl + endpointAddr + timeout transfer ∷ C'TransferFunc → DeviceHandle → EndpointAddress - → Timeout → Size → Ptr Word8 → IO (Size, Bool) + → Timeout + → CStringLen + → IO (Size, TimedOut) transfer c'transfer devHndl endpointAddr - timeout size dataPtr = + timeout + (dataPtr, size) = alloca $ \transferredPtr → do err ← c'transfer (getDevHndlPtr devHndl) (marshalEndpointAddress endpointAddr) @@ -1614,7 +1539,7 @@ then throwIO $ convertUSBException r else return $ fromIntegral r --- | Convert a 'C\'libusb_error' to a 'USBException'. If the C'libusb_error is +-- | 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 $ @@ -1626,7 +1551,7 @@ -- | 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_IO, IOException "") , (c'LIBUSB_ERROR_INVALID_PARAM, InvalidParamException) , (c'LIBUSB_ERROR_ACCESS, AccessException) , (c'LIBUSB_ERROR_NO_DEVICE, NoDeviceException) @@ -1643,7 +1568,7 @@ -- | Type of USB exceptions. data USBException = - IOException -- ^ Input/output exception. + IOException String -- ^ Input/output exception. | InvalidParamException -- ^ Invalid parameter. | AccessException -- ^ Access denied (insufficient permissions). | NoDeviceException -- ^ No such device (it may have been disconnected). @@ -1657,87 +1582,9 @@ | NotSupportedException -- ^ Operation not supported or unimplemented on this -- platform. | OtherException -- ^ Other exception. - deriving (Eq, Show, Data, Typeable) + deriving (Eq, Show, Read, Data, Typeable) instance Exception USBException - - --------------------------------------------------------------------------------- --- * Binary Coded Decimals --------------------------------------------------------------------------------- - --- | A decoded 16 bits Binary Coded Decimal using 4 bits for each digit. -type BCD4 = (Int, Int, Int, Int) - --- | Decode a @Word16@ as a Binary Coded Decimal using 4 bits per digit. -unmarshalBCD4 ∷ Word16 → BCD4 -unmarshalBCD4 bcd = let [a, b, c, d] = map 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 α ⇒ Int → α → [α] -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) - - --------------------------------------------------------------------------------- --- * Utils --------------------------------------------------------------------------------- - --- | @bits s e b@ extract bit @s@ to @e@ (including) from @b@. -bits ∷ Bits α ⇒ Int → Int → α → α -bits s e b = (2 ^ (e - s + 1) - 1) .&. (b `shiftR` s) - --- | @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. -void ∷ Functor m ⇒ m α → m () -void = (() <$) - --- | 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 - --- | @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 - --- | @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 --- this array and the array itself. 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 → (Size → Ptr Word8 → IO α) → IO α -input `writeWith` doWrite = - let (dataFrgnPtr, _, size) = BI.toForeignPtr input - in withForeignPtr dataFrgnPtr $ doWrite size - --- | 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 -- The End --------------------------------------------------------------------- diff --git a/System/USB/Unsafe.hs b/System/USB/Unsafe.hs new file mode 100644 --- /dev/null +++ b/System/USB/Unsafe.hs @@ -0,0 +1,21 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : System.USB.Unsafe +-- Copyright : (c) 2009–2010 Bas van Dijk +-- License : BSD3 (see the file LICENSE) +-- Maintainer : Bas van Dijk +-- +-- This module is not intended for end users. It provides internal and unsafe +-- functions used for extending this package. +-- It is primarily used by the @usb-enumerator@ package. +-- +-------------------------------------------------------------------------------- + +module System.USB.Unsafe + ( C'TransferFunc + , getDevHndlPtr + , marshalEndpointAddress + , convertUSBException + ) where + +import System.USB.Internal diff --git a/Utils.hs b/Utils.hs new file mode 100644 --- /dev/null +++ b/Utils.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE NoImplicitPrelude, UnicodeSyntax #-} + +module Utils where + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +-- from base: +import Prelude ( (+), (-), (^) + , Enum, toEnum, fromEnum + , fromInteger + , Integral, fromIntegral + ) +import Control.Monad ( Monad, (>>=), fail, mapM ) +import Foreign.Ptr ( Ptr ) +import Foreign.Storable ( Storable, ) +import Foreign.Marshal.Array ( peekArray ) +import Data.Bool ( Bool ) +import Data.Ord ( Ord ) +import Data.Bits ( Bits, shiftR, (.&.) ) +import Data.Int ( Int ) +import Data.Functor ( Functor, (<$)) +import System.IO ( IO ) + +-- from base-unicode-symbols: +import Data.Function.Unicode ( (∘) ) +import Data.Ord.Unicode ( (≥), (≤) ) +import Data.Bool.Unicode ( (∧) ) + + +-------------------------------------------------------------------------------- +-- Utils +-------------------------------------------------------------------------------- + +-- | @bits s e b@ extract bit @s@ to @e@ (including) from @b@. +bits ∷ Bits α ⇒ Int → Int → α → α +bits s e b = (2 ^ (e - s + 1) - 1) .&. (b `shiftR` s) + +-- | @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. +void ∷ Functor m ⇒ m α → m () +void = (() <$) + +-- | 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 + +-- | @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 + +-- | 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 + + +-- The End --------------------------------------------------------------------- diff --git a/usb.cabal b/usb.cabal --- a/usb.cabal +++ b/usb.cabal @@ -1,5 +1,5 @@ name: usb -version: 0.4 +version: 0.5 cabal-version: >=1.6 build-type: Custom license: BSD3 @@ -10,10 +10,48 @@ stability: experimental category: System synopsis: Communicate with USB devices -description: This library enables you to communicate with USB devices from +description: 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.*. + @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: + . + + . + Also see the @usb-safe@ package which wraps this package and + provides some strong safety guarantees for working with USB + devices: + . + + . + Finally have a look at the @usb-enumerator@ package which + provides iteratee enumerators for enumerating bulk and interrupt + endpoints: + . + + . + 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: + + . + * \"USB in a NutShell\" at: + source-repository head Type: darcs @@ -21,21 +59,20 @@ Library GHC-Options: -Wall - build-depends: base >= 4 && < 4.3 - , base-unicode-symbols >= 0.1.1 && < 0.3 - , bindings-libusb >= 1.3 && < 1.5 - , bytestring >= 0.9 && < 0.10 - , text >= 0.5 && < 0.8 - , iteratee >= 0.3.5 && < 0.4 - , transformers >= 0.2 && < 0.3 - , MonadCatchIO-transformers >= 0.2 && < 0.3 - , MonadCatchIO-transformers-foreign >= 0.1 && < 0.2 + build-depends: base >= 4 && < 4.3 + , base-unicode-symbols >= 0.1.1 && < 0.3 + , bindings-libusb >= 1.3 && < 1.5 + , bytestring >= 0.9 && < 0.10 + , text >= 0.5 && < 0.8 exposed-modules: System.USB System.USB.Initialization System.USB.Enumeration System.USB.DeviceHandling System.USB.Descriptors System.USB.IO.Synchronous - System.USB.IO.Synchronous.Enumerator + System.USB.IO.StandardDeviceRequests System.USB.Exceptions + System.USB.Unsafe other-modules: System.USB.Internal + Data.BCD + Utils