#if __GLASGOW_HASKELL__ >= 704
#endif
#ifdef HAS_EVENT_MANAGER
#endif
#ifdef GENERICS
#endif
module System.USB.Base where
import Prelude ( Num, (+), (), (*), Integral, fromIntegral, div
, Enum, fromEnum, error, String, ($!), seq
)
import Foreign.C.Types ( CUChar, CInt, CUInt )
import Foreign.C.String ( CStringLen )
import Foreign.Marshal.Alloc ( alloca )
import Foreign.Marshal.Array ( allocaArray )
import Foreign.Storable ( Storable, peek, peekElemOff )
import Foreign.Ptr ( Ptr, castPtr, plusPtr, nullPtr )
import Foreign.ForeignPtr ( ForeignPtr, withForeignPtr, touchForeignPtr )
import Control.Exception ( Exception, throwIO, bracket, bracket_, onException, assert )
import Control.Monad ( Monad, (=<<), return, when )
import Control.Arrow ( (&&&) )
import Data.Function ( ($), on )
import Data.Data ( Data )
import Data.Typeable ( Typeable )
import Data.Maybe ( Maybe(Nothing, Just), maybe, fromMaybe )
import Data.List ( lookup, map, (++) )
import Data.Int ( Int )
import Data.Word ( Word8, Word16 )
import Data.Eq ( Eq, (==) )
import Data.Ord ( Ord, (<), (>) )
import Data.Bool ( Bool(False, True), not, otherwise )
import Data.Bits ( Bits, (.|.), setBit, testBit, shiftL )
import System.IO ( IO )
import System.IO.Unsafe ( unsafePerformIO )
import Text.Show ( Show, show )
import Text.Read ( Read )
import Text.Printf ( printf )
#if MIN_VERSION_base(4,2,0)
import Data.Functor ( Functor, fmap, (<$>) )
#else
import Control.Monad ( Functor, fmap )
import Control.Applicative ( (<$>) )
#endif
#if __GLASGOW_HASKELL__ < 700
import Prelude ( fromInteger, negate )
import Control.Monad ( (>>), fail )
#endif
import Data.Function.Unicode ( (∘) )
import Data.Bool.Unicode ( (∧) )
import Data.Eq.Unicode ( (≢), (≡) )
import qualified Data.ByteString as B ( ByteString, packCStringLen, drop, length )
import qualified Data.ByteString.Internal as BI ( createAndTrim, createAndTrim' )
import qualified Data.ByteString.Unsafe as BU ( unsafeUseAsCStringLen )
import Data.Text ( Text )
import qualified Data.Text.Encoding as TE ( decodeUtf16LE )
import Data.Vector ( Vector )
import qualified Data.Vector.Generic as VG ( convert, map )
import Bindings.Libusb
import Utils ( bits, between, genToEnum, genFromEnum, peekVector, mapPeekArray
, allocaPeek, ifM, decodeBCD, uncons
)
#ifdef HAS_EVENT_MANAGER
import Prelude ( undefined )
import Foreign.C.Types ( CShort, CChar )
import Foreign.Marshal.Alloc ( allocaBytes, free )
import Foreign.Marshal.Array ( peekArray0, copyArray, advancePtr )
import Foreign.Storable ( sizeOf, poke )
import Foreign.Ptr ( nullFunPtr, freeHaskellFunPtr )
import Control.Monad ( (>>=), mapM_, forM )
import Data.IORef ( newIORef, atomicModifyIORef, readIORef )
import System.Posix.Types ( Fd(Fd) )
import Control.Exception ( uninterruptibleMask_ )
import Control.Concurrent.MVar ( MVar, newEmptyMVar, takeMVar, putMVar )
import System.IO ( hPutStrLn, stderr )
#if MIN_VERSION_base(4,4,0)
import GHC.Event
#else
import System.Event
#endif
( FdKey
, registerFd, unregisterFd
, registerTimeout, unregisterTimeout
)
import Data.IntMap ( IntMap, fromList, insert, updateLookupWithKey, elems )
import qualified Data.ByteString.Internal as BI ( create )
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 )
import Timeval ( withTimeval )
import qualified Poll ( toEvent )
import SystemEventManager ( getSystemEventManager )
import Utils ( pokeVector )
#endif
#if defined(HAS_EVENT_MANAGER) || defined(mingw32_HOST_OS)
import qualified Foreign.Concurrent as FC ( newForeignPtr )
#endif
#if !defined(mingw32_HOST_OS)
import Foreign.ForeignPtr ( newForeignPtr )
#endif
#ifdef GENERICS
import GHC.Generics ( Generic )
#define COMMON_INSTANCES Show, Read, Eq, Data, Typeable, Generic
#else
#define COMMON_INSTANCES Show, Read, Eq, Data, Typeable
#endif
#if MIN_VERSION_base(4,3,0)
import Control.Exception ( mask, mask_ )
#else
import Control.Exception ( blocked, block, unblock )
import Data.Function ( id )
mask ∷ ((IO α → IO α) → IO β) → IO β
mask io = do
b ← blocked
if b
then io id
else block $ io unblock
mask_ ∷ IO α → IO α
mask_ = block
#endif
data Ctx = Ctx
{
#ifdef HAS_EVENT_MANAGER
ctxGetWait ∷ !(Maybe Wait),
#endif
getCtxFrgnPtr ∷ !(ForeignPtr C'libusb_context)
} deriving Typeable
instance Eq Ctx where (==) = (==) `on` getCtxFrgnPtr
withCtxPtr ∷ Ctx → (Ptr C'libusb_context → IO α) → IO α
withCtxPtr = withForeignPtr ∘ getCtxFrgnPtr
libusb_init ∷ IO (Ptr C'libusb_context)
libusb_init = alloca $ \ctxPtrPtr → do
handleUSBException $ c'libusb_init ctxPtrPtr
peek ctxPtrPtr
newCtxNoEventManager ∷ (ForeignPtr C'libusb_context → Ctx) → IO Ctx
newCtxNoEventManager ctx = mask_ $ do
ctxPtr ← libusb_init
#ifdef mingw32_HOST_OS
ctx <$> FC.newForeignPtr ctxPtr
(c'libusb_exit ctxPtr)
#else
ctx <$> newForeignPtr p'libusb_exit ctxPtr
#endif
#ifndef HAS_EVENT_MANAGER
newCtx ∷ IO Ctx
newCtx = newCtxNoEventManager Ctx
#else
type Wait = Timeout → Lock → Ptr C'libusb_transfer → IO ()
newCtx ∷ IO Ctx
newCtx = newCtx' $ \e → hPutStrLn stderr $
thisModule ++ ": libusb_handle_events_timeout returned error: " ++ show e
newCtx' ∷ (USBException → IO ()) → IO Ctx
newCtx' handleError = do
mbEvtMgr ← getSystemEventManager
case mbEvtMgr of
Nothing → newCtxNoEventManager $ Ctx Nothing
Just evtMgr → mask_ $ do
ctxPtr ← libusb_init
let handleEvents = do
err ← withTimeval noTimeout $
c'libusb_handle_events_timeout ctxPtr
when (err ≢ c'LIBUSB_SUCCESS) $
if err ≡ c'LIBUSB_ERROR_INTERRUPTED
then handleEvents
else handleError $ convertUSBException err
register ∷ CInt → CShort → IO FdKey
register fd evt = registerFd evtMgr (\_ _ → handleEvents)
(Fd fd) (Poll.toEvent evt)
pollFdPtrLst ← c'libusb_get_pollfds ctxPtr
pollFdPtrs ← peekArray0 nullPtr pollFdPtrLst
fdKeys ← forM pollFdPtrs $ \pollFdPtr → do
C'libusb_pollfd fd evt ← peek pollFdPtr
fdKey ← register fd evt
return (fromIntegral fd, fdKey)
fdKeyMapRef ← newIORef $! (fromList fdKeys ∷ IntMap FdKey)
free pollFdPtrLst
aFP ← mk'libusb_pollfd_added_cb $ \fd evt _ → mask_ $ do
fdKey ← register fd evt
newFdKeyMap ← atomicModifyIORef fdKeyMapRef $ \fdKeyMap →
let newFdKeyMap = insert (fromIntegral fd) fdKey fdKeyMap
in (newFdKeyMap, newFdKeyMap)
newFdKeyMap `seq` return ()
rFP ← mk'libusb_pollfd_removed_cb $ \fd _ → mask_ $ do
(newFdKeyMap, fdKey) ← atomicModifyIORef fdKeyMapRef $ \fdKeyMap →
let (Just fdKey, newFdKeyMap) =
updateLookupWithKey (\_ _ → Nothing)
(fromIntegral fd)
fdKeyMap
in (newFdKeyMap, (newFdKeyMap, fdKey))
newFdKeyMap `seq` unregisterFd evtMgr fdKey
c'libusb_set_pollfd_notifiers ctxPtr aFP rFP nullPtr
r ← c'libusb_pollfds_handle_timeouts ctxPtr
let wait ∷ Wait
!wait | r ≡ 0 = manualTimeout
| otherwise = \_ → autoTimeout
manualTimeout timeout lock transPtr
| timeout ≡ noTimeout = autoTimeout lock transPtr
| otherwise = do
tk ← registerTimeout evtMgr (timeout * 1000) handleEvents
acquire lock
`onException`
(uninterruptibleMask_ $ do
unregisterTimeout evtMgr tk
_err ← c'libusb_cancel_transfer transPtr
acquire lock)
autoTimeout lock transPtr =
acquire lock
`onException`
(uninterruptibleMask_ $ do
_err ← c'libusb_cancel_transfer transPtr
acquire lock)
fmap (Ctx (Just wait)) $ FC.newForeignPtr ctxPtr $ do
c'libusb_set_pollfd_notifiers ctxPtr nullFunPtr nullFunPtr nullPtr
freeHaskellFunPtr aFP
freeHaskellFunPtr rFP
readIORef fdKeyMapRef >>= mapM_ (unregisterFd evtMgr) ∘ elems
c'libusb_exit ctxPtr
getWait ∷ DeviceHandle → Maybe Wait
getWait = ctxGetWait ∘ getCtx ∘ getDevice
#endif
setDebug ∷ Ctx → Verbosity → IO ()
setDebug ctx verbosity = withCtxPtr ctx $ \ctxPtr →
c'libusb_set_debug ctxPtr $ genFromEnum verbosity
data Verbosity =
PrintNothing
| PrintErrors
| PrintWarnings
| PrintInfo
deriving (Enum, Ord, COMMON_INSTANCES)
data Device = Device
{ getCtx ∷ !Ctx
, getDevFrgnPtr ∷ !(ForeignPtr C'libusb_device)
} deriving Typeable
instance Eq Device where (==) = (==) `on` getDevFrgnPtr
instance Show Device where
show d = printf "Bus %03d Device %03d" (busNumber d) (deviceAddress d)
withDevicePtr ∷ Device → (Ptr C'libusb_device → IO α) → IO α
withDevicePtr (Device ctx devFP ) f = do
x ← withForeignPtr devFP f
touchForeignPtr $ getCtxFrgnPtr ctx
return x
getDevices ∷ Ctx → IO (Vector Device)
getDevices ctx =
withCtxPtr ctx $ \ctxPtr →
alloca $ \devPtrArrayPtr → mask $ \restore → do
numDevs ← checkUSBException $ c'libusb_get_device_list ctxPtr
devPtrArrayPtr
devPtrArray ← peek devPtrArrayPtr
let freeDevPtrArray = c'libusb_free_device_list devPtrArray 0
devs ← restore (mapPeekArray mkDev numDevs devPtrArray)
`onException` freeDevPtrArray
freeDevPtrArray
return devs
where
mkDev ∷ Ptr C'libusb_device → IO Device
mkDev devPtr = Device ctx <$>
#ifdef mingw32_HOST_OS
FC.newForeignPtr devPtr
(c'libusb_unref_device devPtr)
#else
newForeignPtr p'libusb_unref_device devPtr
#endif
busNumber ∷ Device → Word8
busNumber dev = unsafePerformIO $ withDevicePtr dev c'libusb_get_bus_number
deviceAddress ∷ Device → Word8
deviceAddress dev = unsafePerformIO $ withDevicePtr dev c'libusb_get_device_address
data DeviceHandle = DeviceHandle
{ getDevice ∷ !Device
, getDevHndlPtr ∷ !(Ptr C'libusb_device_handle)
} deriving Typeable
instance Eq DeviceHandle where (==) = (==) `on` getDevHndlPtr
instance Show DeviceHandle where
show devHndl = "{USB device handle to: " ++ show (getDevice devHndl) ++ "}"
withDevHndlPtr ∷ DeviceHandle → (Ptr C'libusb_device_handle → IO α) → IO α
withDevHndlPtr (DeviceHandle (Device ctx devFrgnPtr) devHndlPtr) f = do
x ← f devHndlPtr
touchForeignPtr devFrgnPtr
touchForeignPtr $ getCtxFrgnPtr ctx
return x
openDevice ∷ Device → IO DeviceHandle
openDevice dev = withDevicePtr dev $ \devPtr →
alloca $ \devHndlPtrPtr → do
handleUSBException $ c'libusb_open devPtr devHndlPtrPtr
DeviceHandle dev <$> peek devHndlPtrPtr
closeDevice ∷ DeviceHandle → IO ()
closeDevice devHndl = withDevHndlPtr devHndl c'libusb_close
withDeviceHandle ∷ Device → (DeviceHandle → IO α) → IO α
withDeviceHandle dev = bracket (openDevice dev) closeDevice
type ConfigValue = Word8
getConfig ∷ DeviceHandle → IO (Maybe ConfigValue)
getConfig devHndl =
alloca $ \configPtr → do
withDevHndlPtr devHndl $ \devHndlPtr →
handleUSBException $ c'libusb_get_configuration devHndlPtr configPtr
unmarshal <$> peek configPtr
where
unmarshal 0 = Nothing
unmarshal n = Just $ fromIntegral n
setConfig ∷ DeviceHandle → Maybe ConfigValue → IO ()
setConfig devHndl config =
withDevHndlPtr devHndl $ \devHndlPtr →
handleUSBException $ c'libusb_set_configuration devHndlPtr $
marshal config
where
marshal = maybe (1) fromIntegral
type InterfaceNumber = Word8
claimInterface ∷ DeviceHandle → InterfaceNumber → IO ()
claimInterface devHndl ifNum =
withDevHndlPtr devHndl $ \devHndlPtr →
handleUSBException $ c'libusb_claim_interface devHndlPtr
(fromIntegral ifNum)
releaseInterface ∷ DeviceHandle → InterfaceNumber → IO ()
releaseInterface devHndl ifNum =
withDevHndlPtr devHndl $ \devHndlPtr →
handleUSBException $ c'libusb_release_interface devHndlPtr
(fromIntegral ifNum)
withClaimedInterface ∷ DeviceHandle → InterfaceNumber → IO α → IO α
withClaimedInterface devHndl ifNum = bracket_ (claimInterface devHndl ifNum)
(releaseInterface devHndl ifNum)
type InterfaceAltSetting = Word8
setInterfaceAltSetting ∷ DeviceHandle
→ InterfaceNumber
→ InterfaceAltSetting
→ IO ()
setInterfaceAltSetting devHndl ifNum alternateSetting =
withDevHndlPtr devHndl $ \devHndlPtr →
handleUSBException $
c'libusb_set_interface_alt_setting devHndlPtr
(fromIntegral ifNum)
(fromIntegral alternateSetting)
clearHalt ∷ DeviceHandle → EndpointAddress → IO ()
clearHalt devHndl endpointAddr =
withDevHndlPtr devHndl $ \devHndlPtr →
handleUSBException $
c'libusb_clear_halt devHndlPtr (marshalEndpointAddress endpointAddr)
resetDevice ∷ DeviceHandle → IO ()
resetDevice devHndl = withDevHndlPtr devHndl $
handleUSBException ∘ c'libusb_reset_device
kernelDriverActive ∷ DeviceHandle → InterfaceNumber → IO Bool
kernelDriverActive devHndl ifNum =
withDevHndlPtr devHndl $ \devHndlPtr → do
r ← c'libusb_kernel_driver_active devHndlPtr (fromIntegral ifNum)
case r of
0 → return False
1 → return True
_ → throwIO $ convertUSBException r
detachKernelDriver ∷ DeviceHandle → InterfaceNumber → IO ()
detachKernelDriver devHndl ifNum =
withDevHndlPtr devHndl $ \devHndlPtr →
handleUSBException $ c'libusb_detach_kernel_driver devHndlPtr
(fromIntegral ifNum)
attachKernelDriver ∷ DeviceHandle → InterfaceNumber → IO ()
attachKernelDriver devHndl ifNum =
withDevHndlPtr devHndl $ \devHndlPtr →
handleUSBException $ c'libusb_attach_kernel_driver devHndlPtr
(fromIntegral ifNum)
withDetachedKernelDriver ∷ DeviceHandle → InterfaceNumber → IO α → IO α
withDetachedKernelDriver devHndl ifNum action =
ifM (kernelDriverActive devHndl ifNum)
(bracket_ (detachKernelDriver devHndl ifNum)
(attachKernelDriver devHndl ifNum)
action)
action
data DeviceDesc = DeviceDesc
{
deviceUSBSpecReleaseNumber ∷ !ReleaseNumber
, deviceClass ∷ !Word8
, deviceSubClass ∷ !Word8
, deviceProtocol ∷ !Word8
, deviceMaxPacketSize0 ∷ !Word8
, deviceVendorId ∷ !VendorId
, deviceProductId ∷ !ProductId
, deviceReleaseNumber ∷ !ReleaseNumber
, deviceManufacturerStrIx ∷ !(Maybe StrIx)
, deviceProductStrIx ∷ !(Maybe StrIx)
, deviceSerialNumberStrIx ∷ !(Maybe StrIx)
, deviceNumConfigs ∷ !Word8
} deriving (COMMON_INSTANCES)
type ReleaseNumber = (Int, Int, Int, Int)
type VendorId = Word16
type ProductId = Word16
data ConfigDesc = ConfigDesc
{
configValue ∷ !ConfigValue
, configStrIx ∷ !(Maybe StrIx)
, configAttribs ∷ !ConfigAttribs
, configMaxPower ∷ !Word8
, configInterfaces ∷ !(Vector Interface)
, configExtra ∷ !B.ByteString
} deriving (COMMON_INSTANCES)
type ConfigAttribs = DeviceStatus
data DeviceStatus = DeviceStatus
{ remoteWakeup ∷ !Bool
, selfPowered ∷ !Bool
} deriving (COMMON_INSTANCES)
type Interface = Vector InterfaceDesc
data InterfaceDesc = InterfaceDesc
{
interfaceNumber ∷ !InterfaceNumber
, interfaceAltSetting ∷ !InterfaceAltSetting
, interfaceClass ∷ !Word8
, interfaceSubClass ∷ !Word8
, interfaceProtocol ∷ !Word8
, interfaceStrIx ∷ !(Maybe StrIx)
, interfaceEndpoints ∷ !(Vector EndpointDesc)
, interfaceExtra ∷ !B.ByteString
} deriving (COMMON_INSTANCES)
data EndpointDesc = EndpointDesc
{
endpointAddress ∷ !EndpointAddress
, endpointAttribs ∷ !EndpointAttribs
, endpointMaxPacketSize ∷ !MaxPacketSize
, endpointInterval ∷ !Word8
, endpointRefresh ∷ !Word8
, endpointSynchAddress ∷ !Word8
, endpointExtra ∷ !B.ByteString
} deriving (COMMON_INSTANCES)
data EndpointAddress = EndpointAddress
{ endpointNumber ∷ !Int
, transferDirection ∷ !TransferDirection
} deriving (COMMON_INSTANCES)
data TransferDirection = Out
| In
deriving (COMMON_INSTANCES)
type EndpointAttribs = TransferType
data TransferType =
Control
| Isochronous !Synchronization !Usage
| Bulk
| Interrupt
deriving (COMMON_INSTANCES)
data Synchronization =
NoSynchronization
| Asynchronous
| Adaptive
| Synchronous
deriving (Enum, COMMON_INSTANCES)
data Usage = Data
| Feedback
| Implicit
deriving (Enum, COMMON_INSTANCES)
data MaxPacketSize = MaxPacketSize
{ maxPacketSize ∷ !Size
, transactionOpportunities ∷ !TransactionOpportunities
} deriving (COMMON_INSTANCES)
data TransactionOpportunities = Zero
| One
| Two
deriving (Enum, Ord, COMMON_INSTANCES)
maxIsoPacketSize ∷ EndpointDesc → Size
maxIsoPacketSize epDesc | isochronousOrInterrupt = mps * (1 + fromEnum to)
| otherwise = mps
where
MaxPacketSize mps to = endpointMaxPacketSize epDesc
isochronousOrInterrupt = case endpointAttribs epDesc of
Isochronous _ _ → True
Interrupt → True
_ → False
getDeviceDesc ∷ Device → IO DeviceDesc
getDeviceDesc dev =
withDevicePtr dev $ \devPtr →
convertDeviceDesc <$>
allocaPeek (handleUSBException ∘ c'libusb_get_device_descriptor devPtr)
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
}
unmarshalReleaseNumber ∷ Word16 → ReleaseNumber
unmarshalReleaseNumber abcd = (a, b, c, d)
where
[a, b, c, d] = map fromIntegral $ decodeBCD 4 abcd
unmarshalStrIx ∷ Word8 → Maybe StrIx
unmarshalStrIx 0 = Nothing
unmarshalStrIx strIx = Just strIx
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
interfaces ← mapPeekArray convertInterface
(fromIntegral $ c'libusb_config_descriptor'bNumInterfaces c)
(c'libusb_config_descriptor'interface c)
extra ← getExtra (c'libusb_config_descriptor'extra c)
(c'libusb_config_descriptor'extra_length c)
return ConfigDesc
{ configValue = c'libusb_config_descriptor'bConfigurationValue c
, configStrIx = unmarshalStrIx $
c'libusb_config_descriptor'iConfiguration c
, configAttribs = unmarshalConfigAttribs $
c'libusb_config_descriptor'bmAttributes c
, configMaxPower = c'libusb_config_descriptor'MaxPower c
, configInterfaces = interfaces
, configExtra = extra
}
unmarshalConfigAttribs ∷ Word8 → ConfigAttribs
unmarshalConfigAttribs a = DeviceStatus { remoteWakeup = testBit a 5
, selfPowered = testBit a 6
}
getExtra ∷ Ptr CUChar → CInt → IO B.ByteString
getExtra extra extraLength = B.packCStringLen ( castPtr extra
, fromIntegral extraLength
)
convertInterface ∷ C'libusb_interface → IO Interface
convertInterface i =
mapPeekArray convertInterfaceDesc
(fromIntegral $ c'libusb_interface'num_altsetting i)
(c'libusb_interface'altsetting i)
convertInterfaceDesc ∷ C'libusb_interface_descriptor → IO InterfaceDesc
convertInterfaceDesc i = do
endpoints ← mapPeekArray convertEndpointDesc
(fromIntegral $ c'libusb_interface_descriptor'bNumEndpoints i)
(c'libusb_interface_descriptor'endpoint i)
extra ← getExtra (c'libusb_interface_descriptor'extra i)
(c'libusb_interface_descriptor'extra_length i)
return InterfaceDesc
{ interfaceNumber = c'libusb_interface_descriptor'bInterfaceNumber i
, interfaceAltSetting = c'libusb_interface_descriptor'bAlternateSetting i
, interfaceClass = c'libusb_interface_descriptor'bInterfaceClass i
, interfaceSubClass = c'libusb_interface_descriptor'bInterfaceSubClass i
, interfaceStrIx = unmarshalStrIx $
c'libusb_interface_descriptor'iInterface i
, interfaceProtocol = c'libusb_interface_descriptor'bInterfaceProtocol i
, interfaceEndpoints = endpoints
, interfaceExtra = extra
}
convertEndpointDesc ∷ C'libusb_endpoint_descriptor → IO EndpointDesc
convertEndpointDesc e = do
extra ← getExtra (c'libusb_endpoint_descriptor'extra e)
(c'libusb_endpoint_descriptor'extra_length e)
return EndpointDesc
{ endpointAddress = unmarshalEndpointAddress $
c'libusb_endpoint_descriptor'bEndpointAddress e
, endpointAttribs = unmarshalEndpointAttribs $
c'libusb_endpoint_descriptor'bmAttributes e
, endpointMaxPacketSize = unmarshalMaxPacketSize $
c'libusb_endpoint_descriptor'wMaxPacketSize e
, endpointInterval = c'libusb_endpoint_descriptor'bInterval e
, endpointRefresh = c'libusb_endpoint_descriptor'bRefresh e
, endpointSynchAddress = c'libusb_endpoint_descriptor'bSynchAddress e
, endpointExtra = extra
}
unmarshalEndpointAddress ∷ Word8 → EndpointAddress
unmarshalEndpointAddress a =
EndpointAddress { endpointNumber = fromIntegral $ bits 0 3 a
, transferDirection = if testBit a 7 then In else Out
}
marshalEndpointAddress ∷ (Bits α, Num α) ⇒ EndpointAddress → α
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 =
case bits 0 1 a of
0 → Control
1 → Isochronous (genToEnum $ bits 2 3 a)
(genToEnum $ bits 4 5 a)
2 → Bulk
3 → Interrupt
_ → moduleError "unmarshalEndpointAttribs: this can't happen!"
unmarshalMaxPacketSize ∷ Word16 → MaxPacketSize
unmarshalMaxPacketSize m =
MaxPacketSize
{ maxPacketSize = fromIntegral $ bits 0 10 m
, transactionOpportunities = genToEnum $ bits 11 12 m
}
strDescHeaderSize ∷ Size
strDescHeaderSize = 2
charSize ∷ Size
charSize = 2
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
(VG.map unmarshalLangId ∘ VG.convert) <$> peekVector strSize strPtr
where
maxSize = 255
write = putStrDesc devHndl 0 0 maxSize
putStrDesc ∷ DeviceHandle
→ StrIx
→ Word16
→ Size
→ Ptr CUChar
→ IO Size
putStrDesc devHndl strIx langId maxSize dataPtr = do
actualSize ← withDevHndlPtr devHndl $ \devHndlPtr →
checkUSBException $ c'libusb_get_string_descriptor
devHndlPtr
strIx
langId
dataPtr
(fromIntegral maxSize)
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
when (descType ≢ c'LIBUSB_DT_STRING) $
throwIO $ IOException "Invalid header"
return $ fromIntegral reportedSize
type LangId = (PrimaryLangId, SubLangId)
type PrimaryLangId = Word16
type SubLangId = Word16
unmarshalLangId ∷ Word16 → LangId
unmarshalLangId = bits 0 9 &&& bits 10 15
marshalLangId ∷ LangId → Word16
marshalLangId (p, s) = p .|. s `shiftL`10
type StrIx = Word8
getStrDesc ∷ DeviceHandle
→ StrIx
→ LangId
→ Int
→ IO Text
getStrDesc devHndl strIx langId nrOfChars = assert (strIx ≢ 0) $
fmap decode $ BI.createAndTrim size $ write ∘ castPtr
where
write = putStrDesc devHndl strIx (marshalLangId langId) size
size = strDescHeaderSize + nrOfChars * charSize
decode = TE.decodeUtf16LE ∘ B.drop strDescHeaderSize
getStrDescFirstLang ∷ DeviceHandle
→ StrIx
→ Int
→ IO Text
getStrDescFirstLang devHndl strIx nrOfChars = do
langIds ← getLanguages devHndl
case uncons langIds of
Nothing → throwIO $ IOException "Zero languages"
Just (langId, _) → getStrDesc devHndl strIx langId nrOfChars
type ReadAction = Size → Timeout → IO (B.ByteString, Status)
type ReadExactAction = Size → Timeout → IO B.ByteString
type WriteAction = B.ByteString → Timeout → IO (Size, Status)
type WriteExactAction = B.ByteString → Timeout → IO ()
type Size = Int
type Timeout = Int
noTimeout ∷ Timeout
noTimeout = 0
data Status = Completed
| TimedOut
deriving (COMMON_INSTANCES)
type ControlAction α = RequestType → Recipient → Request → Value → Index → α
data RequestType = Standard
| Class
| Vendor
deriving (Enum, COMMON_INSTANCES)
data Recipient = ToDevice
| ToInterface
| ToEndpoint
| ToOther
deriving (Enum, COMMON_INSTANCES)
type Request = Word8
type Value = Word16
type Index = Word16
marshalRequestType ∷ RequestType → Recipient → Word8
marshalRequestType t r = genFromEnum t `shiftL` 5 .|. genFromEnum r
control ∷ DeviceHandle → ControlAction (Timeout → IO ())
control devHndl reqType reqRecipient request value index timeout = do
(_, status) ← doControl
when (status ≡ TimedOut) $ throwIO TimeoutException
where
doControl
#ifdef HAS_EVENT_MANAGER
| Just wait ← getWait devHndl =
allocaBytes controlSetupSize $ \bufferPtr → do
poke bufferPtr $ C'libusb_control_setup requestType
request value index
0
transferAsync wait
c'LIBUSB_TRANSFER_TYPE_CONTROL
devHndl
controlEndpoint
timeout
(bufferPtr, controlSetupSize)
#endif
| otherwise = controlTransferSync devHndl
requestType
request value index
timeout
(nullPtr, 0)
requestType = marshalRequestType reqType reqRecipient
readControl ∷ DeviceHandle → ControlAction ReadAction
readControl devHndl reqType reqRecipient request value index size timeout
#ifdef HAS_EVENT_MANAGER
| Just wait ← getWait devHndl = do
let totalSize = controlSetupSize + size
allocaBytes totalSize $ \bufferPtr → do
poke bufferPtr $ C'libusb_control_setup requestType
request value index
(fromIntegral size)
(transferred, status) ← transferAsync wait
c'LIBUSB_TRANSFER_TYPE_CONTROL
devHndl controlEndpoint
timeout
(bufferPtr, totalSize)
bs ← BI.create transferred $ \dataPtr →
copyArray dataPtr (bufferPtr `plusPtr` controlSetupSize) transferred
return (bs, status)
#endif
| otherwise = createAndTrimNoOffset size $ \dataPtr →
controlTransferSync devHndl
requestType
request value index
timeout
(dataPtr, size)
where
requestType = marshalRequestType reqType reqRecipient `setBit` 7
readControlExact ∷ DeviceHandle → ControlAction ReadExactAction
readControlExact devHndl
reqType reqRecipient request value index
size timeout = do
(bs, _) ← readControl devHndl
reqType reqRecipient request value index
size timeout
if B.length bs ≢ size
then throwIO incompleteReadException
else return bs
writeControl ∷ DeviceHandle → ControlAction WriteAction
writeControl devHndl reqType reqRecipient request value index input timeout
#ifdef HAS_EVENT_MANAGER
| Just wait ← getWait devHndl =
BU.unsafeUseAsCStringLen input $ \(dataPtr, size) → do
let totalSize = controlSetupSize + size
allocaBytes totalSize $ \bufferPtr → do
poke bufferPtr $ C'libusb_control_setup requestType
request value index
(fromIntegral size)
copyArray (bufferPtr `plusPtr` controlSetupSize) dataPtr size
transferAsync wait
c'LIBUSB_TRANSFER_TYPE_CONTROL
devHndl controlEndpoint
timeout
(bufferPtr, totalSize)
#endif
| otherwise = BU.unsafeUseAsCStringLen input $
controlTransferSync devHndl
requestType
request value index
timeout
where
requestType = marshalRequestType reqType reqRecipient
writeControlExact ∷ DeviceHandle → ControlAction WriteExactAction
writeControlExact devHndl
reqType reqRecipient request value index
input timeout = do
(transferred, _) ← writeControl devHndl
reqType reqRecipient request value index
input timeout
when (transferred ≢ B.length input) $ throwIO incompleteWriteException
#ifdef HAS_EVENT_MANAGER
controlSetupSize ∷ Size
controlSetupSize = sizeOf (undefined ∷ C'libusb_control_setup)
controlEndpoint ∷ CUChar
controlEndpoint = 0
#endif
controlTransferSync ∷ DeviceHandle
→ Word8 → Request → Value → Index
→ Timeout
→ (Ptr byte, Size)
→ IO (Size, Status)
controlTransferSync devHndl
reqType request value index
timeout
(dataPtr, size) = do
err ← withDevHndlPtr devHndl $ \devHndlPtr →
c'libusb_control_transfer devHndlPtr
reqType 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
, if timedOut then TimedOut else Completed
)
readBulk ∷ DeviceHandle → EndpointAddress → ReadAction
readBulk devHndl
#ifdef HAS_EVENT_MANAGER
| Just wait ← getWait devHndl =
readTransferAsync wait c'LIBUSB_TRANSFER_TYPE_BULK devHndl
#endif
| otherwise = readTransferSync c'libusb_bulk_transfer devHndl
writeBulk ∷ DeviceHandle → EndpointAddress → WriteAction
writeBulk devHndl
#ifdef HAS_EVENT_MANAGER
| Just wait ← getWait devHndl =
writeTransferAsync wait c'LIBUSB_TRANSFER_TYPE_BULK devHndl
#endif
| otherwise = writeTransferSync c'libusb_bulk_transfer devHndl
readInterrupt ∷ DeviceHandle → EndpointAddress → ReadAction
readInterrupt devHndl
#ifdef HAS_EVENT_MANAGER
| Just wait ← getWait devHndl =
readTransferAsync wait c'LIBUSB_TRANSFER_TYPE_INTERRUPT devHndl
#endif
| otherwise = readTransferSync c'libusb_interrupt_transfer devHndl
writeInterrupt ∷ DeviceHandle → EndpointAddress → WriteAction
writeInterrupt devHndl
#ifdef HAS_EVENT_MANAGER
| Just wait ← getWait devHndl =
writeTransferAsync wait c'LIBUSB_TRANSFER_TYPE_INTERRUPT devHndl
#endif
| otherwise = writeTransferSync c'libusb_interrupt_transfer devHndl
type C'TransferFunc = Ptr C'libusb_device_handle
→ CUChar
→ Ptr CUChar
→ CInt
→ Ptr CInt
→ CUInt
→ IO CInt
readTransferSync ∷ C'TransferFunc → (DeviceHandle → EndpointAddress → ReadAction)
readTransferSync c'transfer = \devHndl endpointAddr → \size timeout →
createAndTrimNoOffset size $ \dataPtr →
transferSync c'transfer
devHndl endpointAddr
timeout
(castPtr dataPtr, size)
writeTransferSync ∷ C'TransferFunc → (DeviceHandle → EndpointAddress → WriteAction)
writeTransferSync c'transfer = \devHndl endpointAddr → \input timeout →
BU.unsafeUseAsCStringLen input $
transferSync c'transfer
devHndl endpointAddr
timeout
transferSync ∷ C'TransferFunc → DeviceHandle
→ EndpointAddress
→ Timeout
→ CStringLen
→ IO (Size, Status)
transferSync c'transfer devHndl
endpointAddr
timeout
(dataPtr, size) =
alloca $ \transferredPtr → do
err ← withDevHndlPtr devHndl $ \devHndlPtr →
c'transfer devHndlPtr
(marshalEndpointAddress endpointAddr)
(castPtr dataPtr)
(fromIntegral size)
transferredPtr
(fromIntegral 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
, if timedOut then TimedOut else Completed
)
#ifdef HAS_EVENT_MANAGER
readTransferAsync ∷ Wait
→ C'TransferType
→ DeviceHandle → EndpointAddress → ReadAction
readTransferAsync wait transType = \devHndl endpointAddr → \size timeout →
createAndTrimNoOffset size $ \bufferPtr →
transferAsync wait
transType
devHndl (marshalEndpointAddress endpointAddr)
timeout
(bufferPtr, size)
writeTransferAsync ∷ Wait
→ C'TransferType
→ DeviceHandle → EndpointAddress → WriteAction
writeTransferAsync wait transType = \devHndl endpointAddr → \input timeout →
BU.unsafeUseAsCStringLen input $
transferAsync wait
transType
devHndl (marshalEndpointAddress endpointAddr)
timeout
type C'TransferType = CUChar
transferAsync ∷ Wait
→ C'TransferType
→ DeviceHandle → CUChar
→ Timeout
→ (Ptr byte, Size)
→ IO (Size, Status)
transferAsync wait transType devHndl endpoint timeout bytes =
withTerminatedTransfer wait
transType
VG.empty
devHndl endpoint
timeout
bytes
(continue Completed)
(continue TimedOut)
where
continue status transPtr = do
n ← peek $ p'libusb_transfer'actual_length transPtr
return (fromIntegral n, status)
withTerminatedTransfer ∷ Wait
→ C'TransferType
→ Storable.Vector C'libusb_iso_packet_descriptor
→ DeviceHandle → CUChar
→ Timeout
→ (Ptr byte, Size)
→ (Ptr C'libusb_transfer → IO α)
→ (Ptr C'libusb_transfer → IO α)
→ IO α
withTerminatedTransfer wait
transType
isos
devHndl endpoint
timeout
(bufferPtr, size)
onCompletion
onTimeout =
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)
pokeVector (p'libusb_transfer'iso_packet_desc transPtr) isos
mask_ $ do
handleUSBException $ c'libusb_submit_transfer transPtr
wait timeout lock transPtr
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_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
| ts ≡ c'LIBUSB_TRANSFER_CANCELLED →
moduleError "transfer status can't be Cancelled!"
| otherwise → moduleError $ "Unknown transfer status: " ++
show ts ++ "!"
allocaTransfer ∷ Int → (Ptr C'libusb_transfer → IO α) → IO α
allocaTransfer nrOfIsos = bracket mallocTransfer c'libusb_free_transfer
where
mallocTransfer = do
transPtr ← c'libusb_alloc_transfer (fromIntegral nrOfIsos)
when (transPtr ≡ nullPtr) (throwIO NoMemException)
return transPtr
withCallback ∷ (Ptr C'libusb_transfer → IO ())
→ (C'libusb_transfer_cb_fn → IO α)
→ IO α
withCallback cb = bracket (mk'libusb_transfer_cb_fn cb) freeHaskellFunPtr
newtype Lock = Lock (MVar ()) deriving Eq
newLock ∷ IO Lock
newLock = Lock <$> newEmptyMVar
acquire ∷ Lock → IO ()
acquire (Lock mv) = takeMVar mv
release ∷ Lock → IO ()
release (Lock mv) = putMVar mv ()
readIsochronous ∷ DeviceHandle
→ EndpointAddress
→ Unboxed.Vector Size
→ Timeout
→ IO (Vector B.ByteString)
readIsochronous devHndl endpointAddr sizes timeout
| Just wait ← getWait devHndl = do
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
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
writeIsochronous ∷ DeviceHandle
→ EndpointAddress
→ Vector B.ByteString
→ Timeout
→ IO (Unboxed.Vector Size)
writeIsochronous devHndl endpointAddr isoPackets timeout
| Just wait ← getWait devHndl = do
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
isos
devHndl
(marshalEndpointAddress endpointAddr)
timeout
(bufferPtr, totalSize)
(getSizes nrOfIsos)
(\_ → throwIO TimeoutException)
| otherwise = needThreadedRTSError "writeIsochronous"
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
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
initIsoPacketDesc ∷ Size → C'libusb_iso_packet_descriptor
initIsoPacketDesc size =
C'libusb_iso_packet_descriptor
{ c'libusb_iso_packet_descriptor'length = fromIntegral size
, c'libusb_iso_packet_descriptor'actual_length = 0
, c'libusb_iso_packet_descriptor'status = 0
}
#endif
createAndTrimNoOffset ∷ Size → (Ptr Word8 → IO (Size, α)) → IO (B.ByteString, α)
createAndTrimNoOffset size f = BI.createAndTrim' size $ \ptr → do
(l, x) ← f ptr
return (offset, l, x)
where
offset = 0
handleUSBException ∷ IO CInt → IO ()
handleUSBException action = do err ← action
when (err ≢ c'LIBUSB_SUCCESS)
(throwIO $ convertUSBException err)
checkUSBException ∷ (Integral α, Show α) ⇒ IO α → IO Int
checkUSBException action = do r ← action
if r < 0
then throwIO $ convertUSBException r
else return $ fromIntegral r
convertUSBException ∷ (Num α, Eq α, Show α) ⇒ α → USBException
convertUSBException err = fromMaybe unknownLibUsbError $
lookup err libusb_error_to_USBException
where
unknownLibUsbError =
moduleError $ "Unknown libusb error code: " ++ show err ++ "!"
libusb_error_to_USBException ∷ Num α ⇒ [(α, USBException)]
libusb_error_to_USBException =
[ (c'LIBUSB_ERROR_IO, ioException)
, (c'LIBUSB_ERROR_INVALID_PARAM, InvalidParamException)
, (c'LIBUSB_ERROR_ACCESS, AccessException)
, (c'LIBUSB_ERROR_NO_DEVICE, NoDeviceException)
, (c'LIBUSB_ERROR_NOT_FOUND, NotFoundException)
, (c'LIBUSB_ERROR_BUSY, BusyException)
, (c'LIBUSB_ERROR_TIMEOUT, TimeoutException)
, (c'LIBUSB_ERROR_OVERFLOW, OverflowException)
, (c'LIBUSB_ERROR_PIPE, PipeException)
, (c'LIBUSB_ERROR_INTERRUPTED, InterruptedException)
, (c'LIBUSB_ERROR_NO_MEM, NoMemException)
, (c'LIBUSB_ERROR_NOT_SUPPORTED, NotSupportedException)
, (c'LIBUSB_ERROR_OTHER, OtherException)
]
data USBException =
IOException String
| InvalidParamException
| AccessException
| NoDeviceException
| NotFoundException
| BusyException
| TimeoutException
| OverflowException
| PipeException
| InterruptedException
| NoMemException
| NotSupportedException
| OtherException
deriving (COMMON_INSTANCES)
instance Exception USBException
ioException ∷ USBException
ioException = IOException ""
incompleteReadException ∷ USBException
incompleteReadException = incompleteException "read"
incompleteWriteException ∷ USBException
incompleteWriteException = incompleteException "written"
incompleteException ∷ String → USBException
incompleteException rw = IOException $
"The number of bytes " ++ rw ++ " doesn't equal the requested number!"
moduleError ∷ String → error
moduleError msg = error $ thisModule ++ ": " ++ msg
thisModule ∷ String
thisModule = "System.USB.Base"
needThreadedRTSError ∷ String → error
needThreadedRTSError msg = moduleError $ msg ++
" is only supported when using the threaded runtime. " ++
"Please build your program with -threaded."