diff --git a/Event.hs b/Event.hs new file mode 100644 --- /dev/null +++ b/Event.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE NoImplicitPrelude, CPP #-} + +module Event ( Event, evtRead, evtWrite ) where + +#if MIN_VERSION_base(4,4,0) +import GHC.Event ( Event, evtRead, evtWrite ) +#else +import System.Event ( Event, evtRead, evtWrite ) +#endif diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2009–2010 Bas van Dijk +Copyright (c) 2009–2011 Bas van Dijk All rights reserved. diff --git a/NEWS b/NEWS new file mode 100644 --- /dev/null +++ b/NEWS @@ -0,0 +1,256 @@ +0.8 + +(Released on: Wed Mar 9 12:21:51 UTC 2011) + +* getStrDesc and getStrDescFirstLang now return a Text instead of a String + I believe this is a more efficient and cleaner interface. + + +0.7 + +(Released on: Mon Jan 17 22:04:29 UTC 2011) + +* Change type of setConfig to allow setting a device in unconfigured state + -setConfig :: DeviceHandle -> ConfigValue -> IO () + +setConfig :: DeviceHandle -> Maybe ConfigValue -> IO () + +* Changed type of getConfig to match setConfig + -getConfig :: DeviceHandle -> IO ConfigValue + +getConfig :: DeviceHandle -> IO (Maybe ConfigValue) + +* Added setConfig and getConfig functions to System.USB.IO.StandardDeviceRequests. + These functions are for testing purposes only! + + +0.6.0.8 + +(Released on: Thu Jan 13 12:29:15 UTC 2011) + +* Fix bug in getDevices: + c'libusb_free_device_list returns a 64bit number on 64bit platforms + getDevices assumed c'libusb_free_device_list returned a CInt. + This is correct on 32bit platforms but on 64bit platforms it returns an Int64. + To fix it, I generalized checkUSBException to work over any Integral type. + + +0.6.0.7 + +(Released on: Tue Jan 4 12:30:43 UTC 2011) + +* Fixed bug in getDevices: + c'libusb_free_device_list returned undocumented error code + +* Show unknown libusb error code in unknownLibUsbError + + +0.6.0.6 + +(Released on: Sun Dec 26 12:00:30 UTC 2010) + +* Import missing (>>) in Utils (only when ghc < 7) + Reported by Joris Putcuyps. + + +0.6.0.5 + +(Released on: Thu Dec 16 16:20:12 UTC 2010) + +* Support text-0.11. + +* Resolved some warning when compiling with ghc-7 + + +0.6.0.4 + +(Released on: Sat Oct 23 00:15:14 UTC 2010) + +* Support text-0.10. + + +0.6.0.3 + +(Released on: Thu Oct 21 21:37:50 UTC 2010) + +* Tested with GHC-7 and modified to work with base-4.3. + + +0.6.0.2 + +(Released on: Wed Oct 6 22:06:43 UTC 2010) + +* Support text-0.9. + + +0.6.0.1 + +(Released on: Mon Sep 13 05:48:41 UTC 2010) + +* Fixed bug in Utf16LE encoding in getStrDesc. + + +0.6 + +(Released on: Sat Sep 11 14:19:36 UTC 2010) + +* Renamed BCD4 to ReleaseNumber. + +* Made StrIxs in descriptors optional. + +* Refactored handling of string descriptors (internal change). + +* Added strictness flags to all arguments of data constructors. + + +0.5.0.1 + +(Released on: Wed Sep 1 20:12:03 UTC 2010) + +* Support text-0.8 + +* Prevent a potential space leak in the decoding of BCD values + (Binary Coded Decimals) + + +0.5 + +(Released on: Mon Jul 26 05:48:59 UTC 2010) + +* Fixed bug in all writing related functions: + writeControl, writeBulk and writeInterrupt. + I erroneously ignored the offset in the given ByteString. + +* Fixed bug in getDevices + Don't free the array when c'libusb_get_device_list returns + c'LIBUSB_ERROR_NO_MEM. + +* Fixed bug in 'setStandardTestMode' + Wrong conversion from TestMode to Word16. + +* Specify the length of the requested string in getStrDesc in + characters instead of bytes. + +* Moved the standard device requests to their own module + System.USB.IO.StandardDeviceRequests + +* Added System.USB.Unsafe + This module is needed by the usb-enumerator package. + +* Added convenience function 'readControlExact' which is similar to + 'readControl' but checks if the specified number of bytes to read + were actually read. Throws an 'IOException' if this is not the case. + +* Defined more instances for various types. + Most types have now instances for: + Show, Read, Eq, Data and Typeable + +* Added type TimedOut = Bool + +* Some refactoring and documentation + + +0.4 + +(Released on: Wed Jun 16 09:12:22 UTC 2010) + +* Some reordering and naming of arguments: + < type ReadAction = Timeout → Size → IO (B.ByteString, Bool) + > type ReadAction = Size → Timeout → IO (B.ByteString, Bool) + + < type WriteAction = Timeout → B.ByteString → IO (Size, Bool) + > type WriteAction = B.ByteString → Timeout → IO (Size, Bool) + +* Return the iterator when the enumerator reads 0 bytes + +* Restricted the enumerators to work on Word8 instead of a polymorphic + elements This is to prevent readFromPtr to read outside allocated + memory + +* Use the package MonadCatchIO-transformers-foreign in + System.USB.IO.Synchronous.Enumerator + + +0.3.1 + +(Released on: Sun May 2 20:23:24 UTC 2010) + +* Made the descriptor types non-abstract + +* Updated dependencies + iteratee >= 0.3.5 && < 0.4 + transformers >= 0.2 && < 0.3 + MonadCatchIO-transformers >= 0.2 && < 0.3 + +* Always include the Enumerator and remove its flag + + +0.3.0.1 + +(Released on: Wed Dec 23 13:41:49 UTC 2009) + +* Tested with base-4.2 + +* Tested with text-0.7 + + +0.3 + +(Released on:Tue Dec 8 21:06:22 UTC 2009) + +* Moved the enumeration of usb devices in its own module: + System.USB.Enumeration + +* Moved the device descriptor inside the device type so that you can + retrieve it without doing IO, e.g: deviceDesc :: Device -> + DeviceDesc + +* Moved the configuration descriptors inside the device descriptor so + you can retrieve them without doing IO, e.g: deviceConfigs :: + DeviceDesc -> [ConfigDesc] + +* Implemented standard device requests that are missing from libusb. + +* Made the timeout of I/O operations explicit. Now all I/O operations + return an additional Bool that indicates if the operation has timed + out. If an operation timed out does not mean there is no result, it + just means that the result may be incomplete. + +* Added experimental (and still untested) support for iteratees for + doing predictable, high-performance, safe, and elegant input + processing using the iteratee package. See module: + System.USB.IO.Synchronous.Enumerator + +* Fixed some asynchronous exception related bugs (put a needed + bracket, block and unblock here and there). + +* Finally some functions, constructors and types got renamed, + documentation got updated and extended and some refactoring has + taken place. + + +0.2.0.1 + +(Released on: Sat Oct 10 18:09:07 UTC 2009) + +* Tested with text == 0.5.* + + +0.2 + +(Released on: Wed Oct 7 12:19:37 UTC 2009) + +* Depend on bindings-libusb == 1.3.* +* Moved System.USB.DeviceHandlingAndEnumeration to System.USB.Devices + + +0.1.0.1 + +(Released on: Thu Oct 1 19:14:30 UTC 2009) + +* Depend on bindings-libusb == 1.2. + + +0.1 + +(Released on: Wed Sep 30 21:11:15 UTC 2009) + +* Initial release diff --git a/Poll.hsc b/Poll.hsc new file mode 100644 --- /dev/null +++ b/Poll.hsc @@ -0,0 +1,29 @@ +{-# LANGUAGE UnicodeSyntax, NoImplicitPrelude #-} + +#include + +module Poll ( toEvent ) where + +-- from base: +import Data.Bits ( (.&.) ) +import Data.Bool ( otherwise ) +import Data.Monoid ( mempty, mappend ) +import Foreign.C.Types ( CShort ) + +-- from base-unicode-symbols: +import Data.Eq.Unicode ( (≢) ) + +-- from usb: +-- I need to import GHC.Event or System.Event based on the version of base. +-- However it's currently not possible to use cabal macros in .hsc files. +-- See: http://hackage.haskell.org/trac/hackage/ticket/870 +-- So I use an intermediate module that makes the choice: +import Event ( Event, evtRead, evtWrite ) + +toEvent ∷ CShort → Event +toEvent e = remap (#const POLLIN) evtRead `mappend` + remap (#const POLLOUT) evtWrite + where + remap evt to + | e .&. evt ≢ 0 = to + | otherwise = mempty diff --git a/README.markdown b/README.markdown new file mode 100644 --- /dev/null +++ b/README.markdown @@ -0,0 +1,49 @@ +This library enables you to communicate with USB devices from +userspace. It is implemented as a high-level wrapper around +[bindings-libusb] which is a low-level binding to the C library: +[libusb-1.*]. + +The USB transfer functions in this library have a simple synchronous +interface (they block) but are implemented using the `libusb` +asynchronous interface. They integrate with the GHC event manager +making them efficient (no busy-loops) and interruptible (throwing an +exception to the thread executing a transfer immediately cancels the +transfer). + +If the GHC event manager is not available (because you're either not +using GHC or because you're on Windows) the library degrades +gracefully to the `libusb` synchronous implementation. + +The 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][USB-2.0-spec]. + +For an example how to use this library see either the [usb-example] or +[ls-usb] package. + +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-iteratee] package which provides +iteratee enumerators for enumerating bulk, interrupt and isochronous +endpoints. + +Besides the API documentation the following sources might be +interesting: + +* [The libusb 1.0 documentation](http://libusb.sourceforge.net/api-1.0/) + +* [The USB 2.0 specification][USB-2.0-spec] + +* [The `bindings-libusb` documentation][bindings-libusb] + +* ["USB in a NutShell"](http://www.beyondlogic.org/usbnutshell/usb1.htm) + +[bindings-libusb]: http://hackage.haskell.org/package/bindings-libusb +[usb-example]: https://github.com/basvandijk/usb-example +[ls-usb]: http://hackage.haskell.org/package/ls-usb +[usb-safe]: http://hackage.haskell.org/package/usb-safe +[usb-iteratee]: http://hackage.haskell.org/package/usb-iteratee +[libusb-1.*]: http://libusb.org/wiki/libusb-1.0 +[USB-2.0-spec]: http://www.usb.org/developers/docs/ diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -27,8 +27,7 @@ ------------------------------------------------------------------------------- --- Cabal setup program with support for 'cabal test' and --- which sets the CPP define '__HADDOCK __' when haddock is run. +-- Cabal setup program which sets the CPP define '__HADDOCK __' when haddock is run. ------------------------------------------------------------------------------- main ∷ IO () @@ -42,6 +41,3 @@ haddockHook simpleUserHooks pkg (lbi { withPrograms = p }) where p = userSpecifyArgs "haddock" ["--optghc=-D__HADDOCK__"] (withPrograms lbi) - - --- The End --------------------------------------------------------------------- diff --git a/System/USB.hs b/System/USB.hs --- a/System/USB.hs +++ b/System/USB.hs @@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- -- | -- Module : System.USB --- Copyright : (c) 2009–2010 Bas van Dijk +-- Copyright : (c) 2009–2011 Bas van Dijk -- License : BSD-style (see the file LICENSE) -- Maintainer : Bas van Dijk -- @@ -14,7 +14,7 @@ , module System.USB.Enumeration , module System.USB.DeviceHandling , module System.USB.Descriptors - , module System.USB.IO.Synchronous + , module System.USB.IO , module System.USB.Exceptions ) where @@ -22,5 +22,5 @@ import System.USB.Enumeration import System.USB.DeviceHandling import System.USB.Descriptors -import System.USB.IO.Synchronous +import System.USB.IO import System.USB.Exceptions diff --git a/System/USB/Base.hs b/System/USB/Base.hs new file mode 100644 --- /dev/null +++ b/System/USB/Base.hs @@ -0,0 +1,2226 @@ +{-# LANGUAGE CPP, UnicodeSyntax, NoImplicitPrelude, DeriveDataTypeable #-} + +#ifdef HAS_EVENT_MANAGER +{-# LANGUAGE ForeignFunctionInterface #-} +#endif + +module System.USB.Base where + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +-- from base: +import Prelude ( Num, (+), (-), (*), Integral, fromIntegral, div + , Enum, fromEnum, error, String + ) +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 ) +import Foreign.Ptr ( Ptr, castPtr, plusPtr, nullPtr ) +import Foreign.ForeignPtr ( ForeignPtr, newForeignPtr, withForeignPtr) +import Control.Applicative ( liftA2 ) +import Control.Exception ( Exception, throwIO, bracket, bracket_, onException, assert ) +import Control.Monad ( Monad, (>>=), (=<<), return, when, forM ) +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 + +-- from base-unicode-symbols: +import Data.Function.Unicode ( (∘) ) +import Data.Bool.Unicode ( (∧) ) +import Data.Eq.Unicode ( (≢), (≡) ) + +-- from bytestring: +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 ) + +-- from text: +import Data.Text ( Text ) +import qualified Data.Text.Encoding as TE ( decodeUtf16LE ) + +-- from bindings-libusb: +import Bindings.Libusb + +-- from usb (this package): +import Utils ( bits, between, genToEnum, genFromEnum, mapPeekArray, ifM, decodeBCD ) + +-------------------------------------------------------------------------------- + +#ifdef HAS_EVENT_MANAGER +-- from base: +import Prelude ( undefined ) +import Foreign.C.Types ( CShort, CChar ) +import Foreign.Marshal.Alloc ( allocaBytes, free ) +import Foreign.Marshal.Array ( peekArray0, copyArray ) +import Foreign.Storable ( sizeOf, poke ) +import Foreign.Ptr ( nullFunPtr, freeHaskellFunPtr ) +import Control.Monad ( mapM_, foldM_ ) +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 ) +import System.IO ( hPutStrLn, stderr ) + +import qualified Foreign.Concurrent as FC ( newForeignPtr ) + +#if MIN_VERSION_base(4,4,0) +import GHC.Event +#else +import System.Event +#endif + ( EventManager + , FdKey + , registerFd, unregisterFd + , registerTimeout, unregisterTimeout + ) + +-- from containers: +import Data.IntMap ( IntMap, fromList, insert, updateLookupWithKey, elems ) + +-- from bytestring: +import qualified Data.ByteString.Internal as BI ( create ) + +-- from usb (this package): +import Timeval ( withTimeval ) +import qualified Poll ( toEvent ) +import SystemEventManager ( getSystemEventManager ) +#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 + +#define COMMON_INSTANCES Show, Read, Eq, Data, Typeable + +-------------------------------------------------------------------------------- +-- * Initialization +-------------------------------------------------------------------------------- + +{-| Abstract type representing a USB session. + +The concept of individual sessions allows your program to use multiple threads +that can independently use this library without interfering with eachother. + +Sessions are created and initialized by 'newCtx' and are automatically closed +when they are garbage collected. + +The only functions that receive a @Ctx@ are 'setDebug' and 'getDevices'. +-} +data Ctx = Ctx + { +#ifdef HAS_EVENT_MANAGER + getEventManager ∷ !(Maybe (EventManager, Maybe (IO ()))), + -- ^ Retrieve the optional event manager from the context + -- and the optional 'IO' action for handling events. +#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 + ctx <$> newForeignPtr p'libusb_exit ctxPtr + +#ifndef HAS_EVENT_MANAGER +-- | Create and initialize a new USB context. +-- +-- This function may throw 'USBException's. +newCtx ∷ IO Ctx +newCtx = newCtxNoEventManager Ctx +#else +-------------------------------------------------------------------------------- + +{-| Create and initialize a new USB context. + +This function may throw 'USBException's. + +Note that the internal @libusb@ event handling can return errors. These errors +occur in the thread that is executing the event handling loop. 'newCtx' will +print these errors to 'stderr'. If you need to handle the errors yourself (for +example log them in an application specific way) please use 'newCtx''. +-} +newCtx ∷ IO Ctx +newCtx = newCtx' $ \e → hPutStrLn stderr $ + thisModule ++ ": libusb_handle_events_timeout returned error: " ++ show e + +-- | Like 'newCtx' but enables you to specify the way errors should be handled +-- that occur while handling @libusb@ events. +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 ∷ IO () + 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) + + -- Register initial libusb file descriptors with the event manager: + 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 + + -- Be notified when libusb file descriptors are added or removed: + aFP ← mk'libusb_pollfd_added_cb $ \fd evt _ → mask_ $ do + fdKey ← register fd evt + atomicModifyIORef fdKeyMapRef $ \fdKeyMap → + (insert (fromIntegral fd) fdKey fdKeyMap, ()) + + rFP ← mk'libusb_pollfd_removed_cb $ \fd _ → mask_ $ do + fdKey ← atomicModifyIORef fdKeyMapRef $ \fdKeyMap → + let (Just fdKey, newFdKeyMap) = + updateLookupWithKey (\_ _ → Nothing) + (fromIntegral fd) + fdKeyMap + in (newFdKeyMap, fdKey) + unregisterFd evtMgr fdKey + + c'libusb_set_pollfd_notifiers ctxPtr aFP rFP nullPtr + + -- Check if we have to do our own timeout handling: + r ← c'libusb_pollfds_handle_timeouts ctxPtr + let mbHandleEvents | r ≡ 0 = Just handleEvents + | otherwise = Nothing + + fmap (Ctx (Just (evtMgr, mbHandleEvents))) $ FC.newForeignPtr ctxPtr $ do + -- Remove notifiers after which we can safely free the FunPtrs: + c'libusb_set_pollfd_notifiers ctxPtr nullFunPtr nullFunPtr nullPtr + freeHaskellFunPtr aFP + freeHaskellFunPtr rFP + + -- Unregister all registered file descriptors from the event manager: + readIORef fdKeyMapRef >>= mapM_ (unregisterFd evtMgr) ∘ elems + + -- Finally deinitialize libusb: + c'libusb_exit ctxPtr + +-- | 'True' if the RTS supports bound threads and 'False' otherwise. +-- +-- The asynchronous implementations only work correctly when this is 'True'. +foreign import ccall unsafe "rtsSupportsBoundThreads" threaded ∷ Bool +#endif +-------------------------------------------------------------------------------- + +{-| Set message verbosity. + +The default level is 'PrintNothing'. This means no messages are ever +printed. If you choose to increase the message verbosity level you must ensure +that your application does not close the @stdout@/@stderr@ file descriptors. + +You are advised to set the debug level to 'PrintWarnings'. Libusb is +conservative with its message logging. Most of the time it will only log +messages that explain error conditions and other oddities. This will help you +debug your software. + +The LIBUSB_DEBUG environment variable overrules the debug level set by this +function. The message verbosity is fixed to the value in the environment +variable if it is defined. + +If @libusb@ was compiled without any message logging, this function does nothing: +you'll never get any messages. + +If @libusb@ was compiled with verbose debug message logging, this function does +nothing: you'll always get messages from all levels. +-} +setDebug ∷ Ctx → Verbosity → IO () +setDebug ctx verbosity = withCtxPtr ctx $ \ctxPtr → + c'libusb_set_debug ctxPtr $ genFromEnum verbosity + +-- | Message verbosity +data Verbosity = + PrintNothing -- ^ No messages are ever printed by the library + | PrintErrors -- ^ Error messages are printed to stderr + | PrintWarnings -- ^ Warning and error messages are printed to stderr + | PrintInfo -- ^ Informational messages are printed to stdout, + -- warning and error messages are printed to stderr + deriving (Enum, Ord, COMMON_INSTANCES) + +-------------------------------------------------------------------------------- +-- * Enumeration +-------------------------------------------------------------------------------- + +{-| Abstract type representing a USB device detected on the system. + +You can only obtain a USB device from the 'getDevices' function. + +Certain operations can be performed on a device, but in order to do any I/O you +will have to first obtain a 'DeviceHandle' using 'openDevice'. Alternatively you +can use the @usb-safe@ package which provides type-safe device handling. See: + + + +Just because you have a reference to a device does not mean it is necessarily +usable. The device may have been unplugged, you may not have permission to +operate such device or another process or driver may be using the device. + +To get additional information about a device you can retrieve its descriptor +using 'deviceDesc'. +-} +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 + -- 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 + +-- | Devices are shown in the same way as the popular @lsusb@ program: +-- +-- @Bus \ Device \: ID \:\@ +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 (Device ctx devFP _) f = withCtxPtr ctx $ \_ → + withForeignPtr devFP f + +{-| Returns a list of USB devices currently attached to the system. + +This is your entry point into finding a USB device. + +Exceptions: + + * 'NoMemException' on a memory allocation failure. + +-} + +{- +Visual description of the 'devPtrArrayPtr': + + D + ^ D + D │ ^ + ^ │ │ + │ │ │ +devPtrArrayPtr: ┏━┷━┳━┷━┳━━━┳━━━┳━┷━┓ + P ───> ┃ P ┃ P ┃ P ┃ P ┃ P ┃ + ┗━━━┻━━━┻━┯━┻━┯━┻━━━┛ + │ │ +P = pointer v │ +D = device structure D │ + v + D +-} +getDevices ∷ Ctx → IO [Device] +getDevices ctx = + 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 = liftA2 (Device ctx) + (newForeignPtr p'libusb_unref_device devPtr) + (getDeviceDesc devPtr) + +-- Both of the following numbers are static variables in the libusb device +-- structure. It's therefore safe to use unsafePerformIO: + +-- | The number of the bus that a device is connected to. +busNumber ∷ Device → Word8 +busNumber dev = unsafePerformIO $ withDevicePtr dev c'libusb_get_bus_number + +-- | The address of the device on the bus it is connected to. +deviceAddress ∷ Device → Word8 +deviceAddress dev = unsafePerformIO $ withDevicePtr dev c'libusb_get_device_address + +-------------------------------------------------------------------------------- +-- * Device handling +-------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- +-- ** Opening & closing devices +-------------------------------------------------------------------------------- + +{-| Abstract type representing a handle of a USB device. + +You can acquire a handle from 'openDevice'. + +A device handle is used to perform I/O and other operations. When finished with +a device handle you should close it by applying 'closeDevice' to it. +-} +data DeviceHandle = DeviceHandle + { getDevice ∷ !Device -- This reference is needed for keeping the 'Device' + -- and therefor the 'Ctx' alive. + -- ^ Retrieve the 'Device' from the 'DeviceHandle'. + , getDevHndlPtr ∷ !(Ptr C'libusb_device_handle) + } 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 dev devHndlPtr) f = withDevicePtr dev $ \_ → + f devHndlPtr + +{-| Open a device and obtain a device handle. + +A handle allows you to perform I/O on the device in question. + +This is a non-blocking function; no requests are sent over the bus. + +It is advisable to use 'withDeviceHandle' because it automatically closes the +device when the computation terminates. + +Exceptions: + + * 'NoMemException' if there is a memory allocation failure. + + * 'AccessException' if the user has insufficient permissions. + + * 'NoDeviceException' if the device has been disconnected. + + * Another 'USBException'. +-} +openDevice ∷ Device → IO DeviceHandle +openDevice dev = withDevicePtr dev $ \devPtr → + alloca $ \devHndlPtrPtr → do + handleUSBException $ c'libusb_open devPtr devHndlPtrPtr + DeviceHandle dev <$> peek devHndlPtrPtr + +{-| Close a device handle. + +Should be called on all open handles before your application exits. + +This is a non-blocking function; no requests are sent over the bus. +-} +closeDevice ∷ DeviceHandle → IO () +closeDevice devHndl = withDevHndlPtr devHndl c'libusb_close + +{-| @withDeviceHandle dev act@ opens the 'Device' @dev@ and passes +the resulting handle to the computation @act@. The handle will be closed on exit +from @withDeviceHandle@ whether by normal termination or by raising an +exception. +-} +withDeviceHandle ∷ Device → (DeviceHandle → IO α) → IO α +withDeviceHandle dev = bracket (openDevice dev) closeDevice + +-------------------------------------------------------------------------------- +-- ** Getting & setting the configuration +-------------------------------------------------------------------------------- + +-- | Identifier for configurations. +-- +-- Can be retrieved by 'getConfig' or by 'configValue'. +type ConfigValue = Word8 + +{-| Determine the value of the currently active configuration. + +You could formulate your own control request to obtain this information, but +this function has the advantage that it may be able to retrieve the information +from operating system caches (no I/O involved). + +If the OS does not cache this information, then this function will block while +a control transfer is submitted to retrieve the information. + +This function returns 'Nothing' if the device is in unconfigured state. + +Exceptions: + + * 'NoDeviceException' if the device has been disconnected. + + * Another 'USBException'. +-} +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 + +{-| Set the active configuration for a device. + +The operating system may or may not have already set an active configuration on +the device. It is up to your application to ensure the correct configuration is +selected before you attempt to claim interfaces and perform other operations. + +If you call this function on a device already configured with the selected +configuration, then this function will act as a lightweight device reset: it +will issue a SET_CONFIGURATION request using the current configuration, causing +most USB-related device state to be reset (altsetting reset to zero, endpoint +halts cleared, toggles reset). + +You cannot change/reset configuration if your application has claimed interfaces +- you should free them with 'releaseInterface' first. You cannot change/reset +configuration if other applications or drivers have claimed interfaces. + +A configuration value of 'Nothing' will put the device in an unconfigured +state. The USB specification states that a configuration value of 0 does this, +however buggy devices exist which actually have a configuration 0. + +You should always use this function rather than formulating your own +SET_CONFIGURATION control request. This is because the underlying operating +system needs to know when such changes happen. + +This is a blocking function. + +Exceptions: + + * 'NotFoundException' if the requested configuration does not exist. + + * 'BusyException' if interfaces are currently claimed. + + * 'NoDeviceException' if the device has been disconnected + + * Another 'USBException'. +-} +setConfig ∷ DeviceHandle → Maybe ConfigValue → IO () +setConfig devHndl config = + withDevHndlPtr devHndl $ \devHndlPtr → + handleUSBException $ c'libusb_set_configuration devHndlPtr $ + marshal config + where + marshal = maybe (-1) fromIntegral + +-------------------------------------------------------------------------------- +-- ** Claiming & releasing interfaces +-------------------------------------------------------------------------------- + +{-| Identifier for interfaces. + +Can be retrieved by 'interfaceNumber'. +-} +type InterfaceNumber = Word8 + +{-| Claim an interface on a given device handle. + +You must claim the interface you wish to use before you can perform I/O on any +of its endpoints. + +It is legal to attempt to claim an already-claimed interface, in which case this +function just returns without doing anything. + +Claiming of interfaces is a purely logical operation; it does not cause any +requests to be sent over the bus. Interface claiming is used to instruct the +underlying operating system that your application wishes to take ownership of +the interface. + +This is a non-blocking function. + +Exceptions: + + * 'NotFoundException' if the requested interface does not exist. + + * 'BusyException' if the interface is already claimed. + + * 'NoDeviceException' if the device has been disconnected. + + * Another 'USBException'. +-} + +claimInterface ∷ DeviceHandle → InterfaceNumber → IO () +claimInterface devHndl ifNum = + withDevHndlPtr devHndl $ \devHndlPtr → + handleUSBException $ c'libusb_claim_interface devHndlPtr + (fromIntegral ifNum) + +{-| Release an interface previously claimed with 'claimInterface'. + +You should release all claimed interfaces before closing a device handle. + +This is a blocking function. A SET_INTERFACE control request will be sent to the +device, resetting interface state to the first alternate setting. + +Exceptions: + + * 'NotFoundException' if the interface was not claimed. + + * 'NoDeviceException' if the device has been disconnected + + * Another 'USBException'. +-} +releaseInterface ∷ DeviceHandle → InterfaceNumber → IO () +releaseInterface devHndl ifNum = + withDevHndlPtr devHndl $ \devHndlPtr → + handleUSBException $ c'libusb_release_interface devHndlPtr + (fromIntegral ifNum) + +{-| @withClaimedInterface@ claims the interface on the given device handle then +executes the given computation. On exit from @withClaimedInterface@, the +interface is released whether by normal termination or by raising an exception. +-} +withClaimedInterface ∷ DeviceHandle → InterfaceNumber → IO α → IO α +withClaimedInterface devHndl ifNum = bracket_ (claimInterface devHndl ifNum) + (releaseInterface devHndl ifNum) + +-------------------------------------------------------------------------------- +-- ** Setting interface alternate settings +-------------------------------------------------------------------------------- + +-- | Identifier for interface alternate settings. +-- +-- Can be retrieved by 'interfaceAltSetting'. +type InterfaceAltSetting = Word8 + +{-| Activate an alternate setting for an interface. + +The interface must have been previously claimed with 'claimInterface' or +'withInterfaceHandle'. + +You should always use this function rather than formulating your own +SET_INTERFACE control request. This is because the underlying operating system +needs to know when such changes happen. + +This is a blocking function. + +Exceptions: + + * 'NotFoundException' if the interface was not claimed or the requested + alternate setting does not exist. + + * 'NoDeviceException' if the device has been disconnected. + + * Another 'USBException'. +-} +setInterfaceAltSetting ∷ DeviceHandle + → InterfaceNumber + → InterfaceAltSetting + → IO () +setInterfaceAltSetting devHndl ifNum alternateSetting = + withDevHndlPtr devHndl $ \devHndlPtr → + handleUSBException $ + c'libusb_set_interface_alt_setting devHndlPtr + (fromIntegral ifNum) + (fromIntegral alternateSetting) + +-------------------------------------------------------------------------------- +-- ** Clearing & Resetting devices +-------------------------------------------------------------------------------- + +{-| Clear the halt/stall condition for an endpoint. + +Endpoints with halt status are unable to receive or transmit data until the halt +condition is stalled. + +You should cancel all pending transfers before attempting to clear the halt +condition. + +This is a blocking function. + +Exceptions: + + * 'NotFoundException' if the endpoint does not exist. + + * 'NoDeviceException' if the device has been disconnected. + + * Another 'USBException'. +-} +clearHalt ∷ DeviceHandle → EndpointAddress → IO () +clearHalt devHndl endpointAddr = + withDevHndlPtr devHndl $ \devHndlPtr → + handleUSBException $ + c'libusb_clear_halt devHndlPtr (marshalEndpointAddress endpointAddr) + +{-| Perform a USB port reset to reinitialize a device. + +The system will attempt to restore the previous configuration and alternate +settings after the reset has completed. + +If the reset fails, the descriptors change, or the previous state cannot be +restored, the device will appear to be disconnected and reconnected. This means +that the device handle is no longer valid (you should close it) and rediscover +the device. A 'NotFoundException' is raised to indicate that this is the +case. + +This is a blocking function which usually incurs a noticeable delay. + +Exceptions: + + * 'NotFoundException' if re-enumeration is required, or if the + device has been disconnected. + + * Another 'USBException'. +-} +resetDevice ∷ DeviceHandle → IO () +resetDevice devHndl = withDevHndlPtr devHndl $ + handleUSBException ∘ c'libusb_reset_device + +-------------------------------------------------------------------------------- +-- ** USB kernel drivers +-------------------------------------------------------------------------------- + +{-| Determine if a kernel driver is active on an interface. + +If a kernel driver is active, you cannot claim the interface, and libusb will be +unable to perform I/O. + +Exceptions: + + * 'NoDeviceException' if the device has been disconnected. + + * Another 'USBException'. +-} +kernelDriverActive ∷ DeviceHandle → InterfaceNumber → IO Bool +kernelDriverActive devHndl 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 + +{-| Detach a kernel driver from an interface. + +If successful, you will then be able to claim the interface and perform I/O. + +Exceptions: + + * 'NotFoundException' if no kernel driver was active. + + * 'InvalidParamException' if the interface does not exist. + + * 'NoDeviceException' if the device has been disconnected. + + * Another 'USBException'. +-} +detachKernelDriver ∷ DeviceHandle → InterfaceNumber → IO () +detachKernelDriver devHndl ifNum = + withDevHndlPtr devHndl $ \devHndlPtr → + handleUSBException $ c'libusb_detach_kernel_driver devHndlPtr + (fromIntegral ifNum) + +{-| Re-attach an interface's kernel driver, which was previously +detached using 'detachKernelDriver'. + +Exceptions: + + * 'NotFoundException' if no kernel driver was active. + + * 'InvalidParamException' if the interface does not exist. + + * 'NoDeviceException' if the device has been disconnected. + + * 'BusyException' if the driver cannot be attached because the interface + is claimed by a program or driver. + + * Another 'USBException'. +-} +attachKernelDriver ∷ DeviceHandle → InterfaceNumber → IO () +attachKernelDriver devHndl ifNum = + withDevHndlPtr devHndl $ \devHndlPtr → + handleUSBException $ c'libusb_attach_kernel_driver devHndlPtr + (fromIntegral ifNum) + +{-| If a kernel driver is active on the specified interface the driver is +detached and the given action is executed. If the action terminates, whether by +normal termination or by raising an exception, the kernel driver is attached +again. If a kernel driver is not active on the specified interface the action is +just executed. + +Exceptions: + + * 'NoDeviceException' if the device has been disconnected. + + * Another 'USBException'. +-} +withDetachedKernelDriver ∷ DeviceHandle → InterfaceNumber → IO α → IO α +withDetachedKernelDriver devHndl ifNum action = + ifM (kernelDriverActive devHndl ifNum) + (bracket_ (detachKernelDriver devHndl ifNum) + (attachKernelDriver devHndl ifNum) + action) + action + +-------------------------------------------------------------------------------- +-- * Descriptors +-------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- +-- ** Device descriptor +-------------------------------------------------------------------------------- + +{-| A structure representing the standard USB device descriptor. + +This descriptor is documented in section 9.6.1 of the USB 2.0 specification. + +This structure can be retrieved by 'deviceDesc'. +-} +data DeviceDesc = DeviceDesc + { -- | USB specification release number. + deviceUSBSpecReleaseNumber ∷ !ReleaseNumber + + -- | USB-IF class code for the device. + , deviceClass ∷ !Word8 + + -- | USB-IF subclass code for the device, qualified by the 'deviceClass' + -- value. + , deviceSubClass ∷ !Word8 + + -- | USB-IF protocol code for the device, qualified by the 'deviceClass' + -- and 'deviceSubClass' values. + , deviceProtocol ∷ !Word8 + + -- | Maximum packet size for endpoint 0. + , deviceMaxPacketSize0 ∷ !Word8 + + -- | USB-IF vendor ID. + , deviceVendorId ∷ !VendorId + + -- | USB-IF product ID. + , deviceProductId ∷ !ProductId + + -- | Device release number. + , deviceReleaseNumber ∷ !ReleaseNumber + + -- | Optional index of string descriptor describing manufacturer. + , deviceManufacturerStrIx ∷ !(Maybe StrIx) + + -- | Optional index of string descriptor describing product. + , deviceProductStrIx ∷ !(Maybe StrIx) + + -- | Optional index of string descriptor containing device serial number. + , deviceSerialNumberStrIx ∷ !(Maybe StrIx) + + -- | Number of possible configurations. + , deviceNumConfigs ∷ !Word8 + + -- | List of configurations supported by the device. + , deviceConfigs ∷ ![ConfigDesc] + } deriving (COMMON_INSTANCES) + +type ReleaseNumber = (Int, Int, Int, Int) + +type VendorId = Word16 +type ProductId = Word16 + +-------------------------------------------------------------------------------- +-- ** Configuration descriptor +-------------------------------------------------------------------------------- + +{-| A structure representing the standard USB configuration descriptor. + +This descriptor is documented in section 9.6.3 of the USB 2.0 specification. + +This structure can be retrieved by 'deviceConfigs'. +-} +data ConfigDesc = ConfigDesc + { -- | Identifier value for the configuration. + configValue ∷ !ConfigValue + + -- | Optional index of string descriptor describing the configuration. + , configStrIx ∷ !(Maybe StrIx) + + -- | Configuration characteristics. + , configAttribs ∷ !ConfigAttribs + + -- | Maximum power consumption of the USB device from the bus in the + -- configuration when the device is fully operational. Expressed in 2 mA + -- units (i.e., 50 = 100 mA). + , 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] + + -- | Extra descriptors. If @libusb@ encounters unknown configuration + -- descriptors, it will store them here, should you wish to parse them. + , configExtra ∷ !B.ByteString + + } deriving (COMMON_INSTANCES) + +-- | An interface is represented as a list of alternate interface settings. +type Interface = [InterfaceDesc] + +-------------------------------------------------------------------------------- +-- *** Configuration attributes +-------------------------------------------------------------------------------- + +-- | The USB 2.0 specification specifies that the configuration attributes only +-- describe the device status. +type ConfigAttribs = DeviceStatus + +data DeviceStatus = DeviceStatus + { remoteWakeup ∷ !Bool -- ^ The Remote Wakeup field indicates whether the + -- device is currently enabled to request remote + -- wakeup. The default mode for devices that + -- support remote wakeup is disabled. + , selfPowered ∷ !Bool -- ^ The Self Powered field indicates whether the + -- device is currently self-powered + } deriving (COMMON_INSTANCES) + +-------------------------------------------------------------------------------- +-- ** Interface descriptor +-------------------------------------------------------------------------------- + +{-| A structure representing the standard USB interface descriptor. + +This descriptor is documented in section 9.6.5 of the USB 2.0 specification. + +This structure can be retrieved using 'configInterfaces'. +-} +data InterfaceDesc = InterfaceDesc + { -- | Number of the interface. + interfaceNumber ∷ !InterfaceNumber + + -- | Value used to select the alternate setting for the interface. + , interfaceAltSetting ∷ !InterfaceAltSetting + + -- | USB-IF class code for the interface. + , interfaceClass ∷ !Word8 + + -- | USB-IF subclass code for the interface, qualified by the + -- 'interfaceClass' value. + , interfaceSubClass ∷ !Word8 + + -- | USB-IF protocol code for the interface, qualified by the + -- 'interfaceClass' and 'interfaceSubClass' values. + , interfaceProtocol ∷ !Word8 + + -- | Optional index of string descriptor describing the interface. + , interfaceStrIx ∷ !(Maybe StrIx) + + -- | List of endpoints supported by the interface. + , interfaceEndpoints ∷ ![EndpointDesc] + + -- | Extra descriptors. If @libusb@ encounters unknown interface + -- descriptors, it will store them here, should you wish to parse them. + , interfaceExtra ∷ !B.ByteString + } deriving (COMMON_INSTANCES) + +-------------------------------------------------------------------------------- +-- ** Endpoint descriptor +-------------------------------------------------------------------------------- + +{-| A structure representing the standard USB endpoint descriptor. + +This descriptor is documented in section 9.6.3 of the USB 2.0 specification. + +This structure can be retrieved by using 'interfaceEndpoints'. +-} +data EndpointDesc = EndpointDesc + { -- | The address of the endpoint described by the descriptor. + endpointAddress ∷ !EndpointAddress + + -- | Attributes which apply to the endpoint when it is configured using the + -- 'configValue'. + , endpointAttribs ∷ !EndpointAttribs + + -- | Maximum packet size the endpoint is capable of sending/receiving. + , endpointMaxPacketSize ∷ !MaxPacketSize + + -- | Interval for polling endpoint for data transfers. Expressed in frames + -- or microframes depending on the device operating speed (i.e., either 1 + -- millisecond or 125 μs units). + , endpointInterval ∷ !Word8 + + -- | /For audio devices only:/ the rate at which synchronization feedback + -- is provided. + , endpointRefresh ∷ !Word8 + + -- | /For audio devices only:/ the address of the synch endpoint. + , endpointSynchAddress ∷ !Word8 + + -- | Extra descriptors. If @libusb@ encounters unknown endpoint descriptors, + -- it will store them here, should you wish to parse them. + , endpointExtra ∷ !B.ByteString + } deriving (COMMON_INSTANCES) + +-------------------------------------------------------------------------------- +-- *** Endpoint address +-------------------------------------------------------------------------------- + +-- | The address of an endpoint. +data EndpointAddress = EndpointAddress + { endpointNumber ∷ !Int -- ^ Must be >= 0 and <= 15 + , transferDirection ∷ !TransferDirection + } deriving (COMMON_INSTANCES) + +-- | 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 (COMMON_INSTANCES) + +-------------------------------------------------------------------------------- +-- *** Endpoint attributes +-------------------------------------------------------------------------------- + +-- | The USB 2.0 specification specifies that the endpoint attributes only +-- describe the endpoint transfer type. +type EndpointAttribs = TransferType + +-- | Describes what types of transfers are allowed on the endpoint. +data TransferType = + -- | Control transfers are typically used for command and status + -- operations. + Control + + -- | Isochronous transfers occur continuously and periodically. + | Isochronous !Synchronization !Usage + + -- | Bulk transfers can be used for large bursty data. + | Bulk + + -- | Interrupt transfers are typically non-periodic, small device + -- \"initiated\" communication requiring bounded latency. + | Interrupt + deriving (COMMON_INSTANCES) + +-- | See section 5.12.4.1 of the USB 2.0 specification. +data Synchronization = + NoSynchronization + | Asynchronous -- ^ Unsynchronized, + -- although sinks provide data rate feedback. + | Adaptive -- ^ Synchronized using feedback or feedforward + -- data rate information + | Synchronous -- ^ Synchronized to the USB’s SOF (/Start Of Frame/) + deriving (Enum, COMMON_INSTANCES) + +-- | See section 5.12.4.2 of the USB 2.0 specification. +data Usage = Data + | Feedback + | Implicit + deriving (Enum, COMMON_INSTANCES) + +-------------------------------------------------------------------------------- +-- *** Endpoint max packet size +-------------------------------------------------------------------------------- + +data MaxPacketSize = MaxPacketSize + { maxPacketSize ∷ !Size + , transactionOpportunities ∷ !TransactionOpportunities + } deriving (COMMON_INSTANCES) + +-- | Number of additional transaction oppurtunities per microframe. +-- +-- See table 9-13 of the USB 2.0 specification. +data TransactionOpportunities = Zero -- ^ None (1 transaction per microframe) + | One -- ^ 1 additional (2 per microframe) + | Two -- ^ 2 additional (3 per microframe) + deriving (Enum, Ord, COMMON_INSTANCES) + +{-| Calculate the maximum packet size which a specific endpoint is capable of +sending or receiving in the duration of 1 microframe. + +If acting on an 'Isochronous' or 'Interrupt' endpoint, this function will +multiply the 'maxPacketSize' by the additional 'transactionOpportunities'. +If acting on another type of endpoint only the 'maxPacketSize' is returned. + +This function is mainly useful for setting up /isochronous/ transfers. +-} +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 + +-------------------------------------------------------------------------------- +-- ** 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 + + 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 + } + +-- | Unmarshal a a 16bit word as a release number. The 16bit word should be +-- encoded as a Binary Coded Decimal using 4 bits for each of the 4 +-- decimals. Also see: +-- +-- +unmarshalReleaseNumber ∷ Word16 → ReleaseNumber +unmarshalReleaseNumber abcd = (a, b, c, d) + where + [a, b, c, d] = map fromIntegral $ decodeBCD 4 abcd + +-- | Unmarshal an 8bit word to a string descriptor index. 0 denotes that a +-- string descriptor is not available and unmarshals to 'Nothing'. +unmarshalStrIx ∷ Word8 → Maybe StrIx +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 + +convertConfigDesc ∷ C'libusb_config_descriptor → IO ConfigDesc +convertConfigDesc c = do + let numInterfaces = c'libusb_config_descriptor'bNumInterfaces c + + interfaces ← mapPeekArray convertInterface + (fromIntegral numInterfaces) + (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 + , configNumInterfaces = numInterfaces + , 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 [InterfaceDesc] +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 + let numEndpoints = c'libusb_interface_descriptor'bNumEndpoints i + + endpoints ← mapPeekArray convertEndpointDesc + (fromIntegral numEndpoints) + (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 + } + +-- | Unmarshal an 8bit word as an endpoint address. This function is primarily +-- used when unmarshalling USB descriptors. +unmarshalEndpointAddress ∷ Word8 → EndpointAddress +unmarshalEndpointAddress a = + EndpointAddress { endpointNumber = fromIntegral $ bits 0 3 a + , transferDirection = if testBit a 7 then In else Out + } + +-- | Marshal an endpoint address so that it can be used by the @libusb@ transfer +-- functions. +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 + } + +-------------------------------------------------------------------------------- +-- ** String descriptors +-------------------------------------------------------------------------------- + +-- | The size in number of bytes of the header of string descriptors. +strDescHeaderSize ∷ Size +strDescHeaderSize = 2 + +-- | Characters are encoded as UTF16LE so each character takes two bytes. +charSize ∷ Size +charSize = 2 + +{-| Retrieve a list of supported languages. + +This function may throw 'USBException's. +-} +getLanguages ∷ DeviceHandle → IO [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 + 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 +location that @dataPtr@ points to. So ensure there is at least space +for @maxSize@ bytes there. Next, the header of the string descriptor +is checked for correctness. If it's incorrect an 'IOException' is +thrown. Finally, the size reported in the header is returned. +-} +putStrDesc ∷ DeviceHandle + → StrIx + → Word16 + → Size + → Ptr CUChar + → IO 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 + +{-| The language ID consists of the primary language identifier and the +sublanguage identififier as described in: + + + +For a mapping between IDs and languages see the @usb-id-database@ package at: + + + +To see which 'LangId's are supported by a device see 'getLanguages'. +-} +type LangId = (PrimaryLangId, SubLangId) +type PrimaryLangId = Word16 +type SubLangId = Word16 + +unmarshalLangId ∷ Word16 → LangId +unmarshalLangId = bits 0 9 &&& bits 10 15 + +marshalLangId ∷ LangId → Word16 +marshalLangId (p, s) = p .|. s `shiftL`10 + +-- | Type of indici of string descriptors. +-- +-- Can be retrieved by all the *StrIx functions. +type StrIx = Word8 + +{-| Retrieve a string descriptor from a device. + +This function may throw 'USBException's. +-} +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 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 + +{-| Retrieve a string descriptor from a device using the first supported language. + +This function may throw 'USBException's. +-} +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 Text +getStrDescFirstLang devHndl strIx nrOfChars = do + langIds ← getLanguages devHndl + case langIds of + [] → throwIO $ IOException "Zero languages" + langId : _ → getStrDesc devHndl strIx langId nrOfChars + +-------------------------------------------------------------------------------- +-- * I/O +-------------------------------------------------------------------------------- + +{-| Handy type synonym for read transfers. + +A @ReadAction@ is a function which takes a 'Size' which defines how many bytes +to read and a 'Timeout'. The function returns an 'IO' action which, when +executed, performs the actual read and returns the 'B.ByteString' that was read +paired with a 'Status' flag which indicates whether the transfer +'Completed' or 'TimedOut'. +-} +type ReadAction = Size → Timeout → IO (B.ByteString, Status) + +-- | Handy type synonym for read transfers that must exactly read the specified +-- number of bytes. An 'incompleteReadException' is thrown otherwise. +type ReadExactAction = Size → Timeout → IO B.ByteString + +{-| Handy type synonym for write transfers. + +A @WriteAction@ is a function which takes a 'B.ByteString' to write and a +'Timeout'. The function returns an 'IO' action which, when exectued, returns the +number of bytes that were actually written paired with a 'Status' flag which +indicates whether the transfer 'Completed' or 'TimedOut'. +-} +type WriteAction = B.ByteString → Timeout → IO (Size, Status) + +-- | Handy type synonym for write transfers that must exactly write all the +-- given bytes. An 'incompleteWriteException' is thrown otherwise. +type WriteExactAction = B.ByteString → Timeout → IO () + +-- | Number of bytes transferred. +type Size = Int + +-- | A timeout in milliseconds. A timeout defines how long a transfer should wait +-- before giving up due to no response being received. +-- Use 'noTimeout' for no timeout. +type Timeout = Int + +-- | A timeout of 0 denotes no timeout so: @noTimeout = 0@. +noTimeout ∷ Timeout +noTimeout = 0 + +-- | Status of a terminated transfer. +data Status = Completed -- ^ All bytes were transferred + -- within the maximum allowed 'Timeout' period. + | TimedOut -- ^ Not all bytes were transferred + -- within the maximum allowed 'Timeout' period. + deriving (COMMON_INSTANCES) + +------------------------------------------------------------------------------- +-- ** Types of control transfers +------------------------------------------------------------------------------- + +-- | Handy type synonym that names the parameters of a control transfer. +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 + +-- | (Host-endian) +type Value = Word16 + +-- | (Host-endian) +type Index = Word16 + +marshalRequestType ∷ RequestType → Recipient → Word8 +marshalRequestType t r = genFromEnum t `shiftL` 5 .|. genFromEnum r + +-------------------------------------------------------------------------------- +-- ** Control transfers +-------------------------------------------------------------------------------- + +{-| Perform a USB /control/ request that does not transfer data. + +Exceptions: + + * 'TimeoutException' if the transfer timed out. + + * 'PipeException' if the control request was not supported by the device + + * 'NoDeviceException' if the device has been disconnected. + + * Another 'USBException'. +-} +control ∷ DeviceHandle → 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 + | threaded = allocaBytes controlSetupSize $ \bufferPtr → do + poke bufferPtr $ C'libusb_control_setup requestType + request value index + 0 + transferAsync 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 + +-------------------------------------------------------------------------------- + +{-| Perform a USB /control/ read. + +Exceptions: + + * 'PipeException' if the control request was not supported by the device + + * 'NoDeviceException' if the device has been disconnected. + + * Another 'USBException'. +-} +readControl ∷ DeviceHandle → ControlAction ReadAction +readControl devHndl reqType reqRecipient request value index size timeout +#ifdef HAS_EVENT_MANAGER + | threaded = do + let totalSize = controlSetupSize + size + allocaBytes totalSize $ \bufferPtr → do + poke bufferPtr $ C'libusb_control_setup requestType + request value index + (fromIntegral size) + (transferred, status) ← transferAsync 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 + +-- | A convenience function similar to 'readControl' which checks if the +-- specified number of bytes to read were actually read. +-- Throws an 'incompleteReadException' if this is not the case. +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 + +-------------------------------------------------------------------------------- + + +{-| Perform a USB /control/ write. + +Exceptions: + + * 'PipeException' if the control request was not supported by the device + + * 'NoDeviceException' if the device has been disconnected. + + * Another 'USBException'. +-} +writeControl ∷ DeviceHandle → ControlAction WriteAction +writeControl devHndl reqType reqRecipient request value index input timeout +#ifdef HAS_EVENT_MANAGER + | threaded = 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 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 + +-- | A convenience function similar to 'writeControl' which checks if the given +-- bytes were actually fully written. +-- Throws an 'incompleteWriteException' if this is not the case. +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 + ) + +-------------------------------------------------------------------------------- +-- ** Bulk transfers +-------------------------------------------------------------------------------- + +{-| Perform a USB /bulk/ read. + +Exceptions: + + * 'PipeException' if the endpoint halted. + + * 'OverflowException' if the device offered more data, + see /Packets and overflows/ in the @libusb@ documentation: + . + + * 'NoDeviceException' if the device has been disconnected. + + * Another 'USBException'. +-} +readBulk ∷ DeviceHandle → EndpointAddress → ReadAction +readBulk +#ifdef HAS_EVENT_MANAGER + | threaded = readTransferAsync c'LIBUSB_TRANSFER_TYPE_BULK +#endif + | otherwise = readTransferSync c'libusb_bulk_transfer + +{-| Perform a USB /bulk/ write. + +Exceptions: + + * 'PipeException' if the endpoint halted. + + * 'OverflowException' if the device offered more data, + see /Packets and overflows/ in the @libusb@ documentation: + . + + * 'NoDeviceException' if the device has been disconnected. + + * Another 'USBException'. +-} +writeBulk ∷ DeviceHandle → EndpointAddress → WriteAction +writeBulk +#ifdef HAS_EVENT_MANAGER + | threaded = writeTransferAsync c'LIBUSB_TRANSFER_TYPE_BULK +#endif + | otherwise = writeTransferSync c'libusb_bulk_transfer + +-------------------------------------------------------------------------------- +-- ** Interrupt transfers +-------------------------------------------------------------------------------- + +{-| Perform a USB /interrupt/ read. + +Exceptions: + + * 'PipeException' if the endpoint halted. + + * 'OverflowException' if the device offered more data, + see /Packets and overflows/ in the libusb documentation: + . + + * 'NoDeviceException' if the device has been disconnected. + + * Another 'USBException'. +-} +readInterrupt ∷ DeviceHandle → EndpointAddress → ReadAction +readInterrupt +#ifdef HAS_EVENT_MANAGER + | threaded = readTransferAsync c'LIBUSB_TRANSFER_TYPE_INTERRUPT +#endif + | otherwise = readTransferSync c'libusb_interrupt_transfer + + +{-| Perform a USB /interrupt/ write. + +Exceptions: + + * 'PipeException' if the endpoint halted. + + * 'OverflowException' if the device offered more data, + see /Packets and overflows/ in the @libusb@ documentation: + . + + * 'NoDeviceException' if the device has been disconnected. + + * Another 'USBException'. +-} +writeInterrupt ∷ DeviceHandle → EndpointAddress → WriteAction +writeInterrupt +#ifdef HAS_EVENT_MANAGER + | threaded = writeTransferAsync c'LIBUSB_TRANSFER_TYPE_INTERRUPT +#endif + | otherwise = writeTransferSync c'libusb_interrupt_transfer + +-------------------------------------------------------------------------------- + +-- | Handy type synonym for the @libusb@ transfer functions. +type C'TransferFunc = Ptr C'libusb_device_handle -- devHndlPtr + → CUChar -- endpoint address + → Ptr CUChar -- dataPtr + → CInt -- size + → Ptr CInt -- transferredPtr + → CUInt -- timeout + → IO CInt -- error + +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 ∷ C'TransferType → DeviceHandle → EndpointAddress → ReadAction +readTransferAsync transType = \devHndl endpointAddr → \size timeout → + createAndTrimNoOffset size $ \bufferPtr → + transferAsync transType + devHndl (marshalEndpointAddress endpointAddr) + timeout + (bufferPtr, size) + +writeTransferAsync ∷ C'TransferType → DeviceHandle → EndpointAddress → WriteAction +writeTransferAsync transType = \devHndl endpointAddr → \input timeout → + BU.unsafeUseAsCStringLen input $ + transferAsync transType + devHndl (marshalEndpointAddress endpointAddr) + timeout + +-------------------------------------------------------------------------------- + +type C'TransferType = CUChar + +transferAsync ∷ C'TransferType + → DeviceHandle → CUChar -- ^ Encoded endpoint address + → Timeout + → (Ptr byte, Size) + → IO (Size, Status) +transferAsync transType devHndl endpoint timeout bytes = + withTerminatedTransfer transType + 0 [] + 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 ∷ C'TransferType + → Int → [C'libusb_iso_packet_descriptor] + → DeviceHandle → CUChar -- ^ Encoded endpoint address + → Timeout + → (Ptr byte, Size) + → (Ptr C'libusb_transfer → IO α) + → (Ptr C'libusb_transfer → IO α) + → IO α +withTerminatedTransfer transType + nrOfIsoPackets isoPackageDescs + devHndl endpoint + timeout + (bufferPtr, size) + onCompletion + onTimeout = + withDevHndlPtr devHndl $ \devHndlPtr → + allocaTransfer nrOfIsoPackets $ \transPtr → do + + lock ← newLock + let Just (evtMgr, mbHandleEvents) = getEventManager $ + getCtx $ + getDevice devHndl + waitForTermination = + case mbHandleEvents of + Just handleEvents | timeout ≢ noTimeout → do + tk ← registerTimeout evtMgr (timeout * 1000) handleEvents + acquire lock + `onException` + (uninterruptibleMask_ $ do + unregisterTimeout evtMgr tk + _err ← c'libusb_cancel_transfer transPtr + acquire lock) + _ → acquire lock + `onException` + (uninterruptibleMask_ $ do + _err ← c'libusb_cancel_transfer transPtr + acquire lock) + 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 + } + + mask_ $ do + handleUSBException $ c'libusb_submit_transfer transPtr + waitForTermination + + 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 ++ "!" + +-------------------------------------------------------------------------------- + +-- | Allocate a transfer with the given number of isochronous packets and apply +-- the function to the resulting pointer. The transfer is automatically freed +-- when the function terminates (whether normally or by raising an exception). +-- +-- A 'NoMemException' may be thrown. +allocaTransfer ∷ Int → (Ptr C'libusb_transfer → IO α) → IO α +allocaTransfer nrOfIsoPackets = bracket mallocTransfer c'libusb_free_transfer + where + mallocTransfer = do + transPtr ← c'libusb_alloc_transfer (fromIntegral nrOfIsoPackets) + when (transPtr ≡ nullPtr) (throwIO NoMemException) + return transPtr + +-------------------------------------------------------------------------------- + +-- | Create a 'FunPtr' to the given transfer callback function and pass it to +-- the continuation function. The 'FunPtr' is automatically freed when the +-- continuation terminates (whether normally or by raising an exception). +withCallback ∷ (Ptr C'libusb_transfer → IO ()) + → (C'libusb_transfer_cb_fn → IO α) + → IO α +withCallback cb = bracket (mk'libusb_transfer_cb_fn cb) freeHaskellFunPtr + +-------------------------------------------------------------------------------- + +-- | A lock is in one of two states: \"locked\" or \"unlocked\". +newtype Lock = Lock (MVar ()) deriving Eq + +-- | Create a lock in the \"unlocked\" state. +newLock ∷ IO Lock +newLock = Lock <$> newEmptyMVar + +{-| +Acquires the 'Lock'. Blocks if another thread has acquired the 'Lock'. + +@acquire@ behaves as follows: + +* When the state is \"unlocked\" @acquire@ changes the state to \"locked\". + +* When the state is \"locked\" @acquire@ /blocks/ until a call to 'release' in +another thread wakes the calling thread. Upon awakening it will change the state +to \"locked\". +-} +acquire ∷ Lock → IO () +acquire (Lock mv) = takeMVar mv + +{-| +@release@ changes the state to \"unlocked\" and returns immediately. + +The behaviour is undefined when a lock in the \"unlocked\" state is released! + +If there are any threads blocked on 'acquire' the thread that first called +@acquire@ will be woken up. +-} +release ∷ Lock → IO () +release (Lock mv) = putMVar mv () + +-------------------------------------------------------------------------------- +-- ** Isochronous transfers +-------------------------------------------------------------------------------- + +{-| Perform a USB /isochronous/ read. + +/WARNING:/ You need to enable the threaded runtime (@-threaded@) for this +function to work correctly. It throws a runtime error otherwise! + +Exceptions: + + * 'PipeException' if the endpoint halted. + + * 'OverflowException' if the device offered more data, + see /Packets and overflows/ in the @libusb@ documentation: + . + + * 'NoDeviceException' if the device has been disconnected. + + * Another 'USBException'. +-} +readIsochronous ∷ DeviceHandle + → EndpointAddress + → [Size] -- ^ Sizes of isochronous packets + → Timeout + → IO [B.ByteString] +readIsochronous devHndl endpointAddr sizes timeout + | not threaded = needThreadedRTSError "readIsochronous" + | otherwise = do + let SumLength totalSize nrOfIsoPackets = sumLength sizes + allocaBytes totalSize $ \bufferPtr → + withTerminatedTransfer c'LIBUSB_TRANSFER_TYPE_ISOCHRONOUS + nrOfIsoPackets (map initIsoPacketDesc sizes) + devHndl + (marshalEndpointAddress endpointAddr) + timeout + (bufferPtr, totalSize) + (\transPtr → convertIsos nrOfIsoPackets + transPtr + bufferPtr) + (\_ → throwIO TimeoutException) + +-------------------------------------------------------------------------------- + +{-| Perform a USB /isochronous/ write. + +/WARNING:/ You need to enable the threaded runtime (@-threaded@) for this +function to work correctly. It throws a runtime error otherwise! + +Exceptions: + + * 'PipeException' if the endpoint halted. + + * 'OverflowException' if the device offered more data, + see /Packets and overflows/ in the @libusb@ documentation: + . + + * 'NoDeviceException' if the device has been disconnected. + + * Another 'USBException'. +-} +writeIsochronous ∷ DeviceHandle + → EndpointAddress + → [B.ByteString] + → Timeout + → IO [Size] +writeIsochronous devHndl endpointAddr isoPackets timeout + | not threaded = needThreadedRTSError "writeIsochronous" + | otherwise = do + let sizes = map B.length isoPackets + SumLength totalSize nrOfIsoPackets = sumLength sizes + allocaBytes totalSize $ \bufferPtr → do + copyIsos (castPtr bufferPtr) isoPackets + withTerminatedTransfer c'LIBUSB_TRANSFER_TYPE_ISOCHRONOUS + nrOfIsoPackets (map initIsoPacketDesc sizes) + devHndl + (marshalEndpointAddress endpointAddr) + timeout + (bufferPtr, totalSize) + (\transPtr → + map actualLength <$> peekIsoPacketDescs + nrOfIsoPackets + transPtr) + (\_ → throwIO TimeoutException) + +-------------------------------------------------------------------------------- + +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) + +-- | Strict pair of sum and length. +data SumLength = SumLength !Int !Int + +-- | An isochronous packet descriptor with all fields zero except for the length. +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 + } + +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 + +-------------------------------------------------------------------------------- + +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 + +-------------------------------------------------------------------------------- +-- * Exceptions +-------------------------------------------------------------------------------- + +-- | @handleUSBException action@ executes @action@. If @action@ returned an +-- error code other than 'c\'LIBUSB_SUCCESS', the error is converted to a +-- 'USBException' and thrown. +handleUSBException ∷ IO CInt → IO () +handleUSBException action = do err ← action + when (err ≢ c'LIBUSB_SUCCESS) + (throwIO $ convertUSBException err) + +-- | @checkUSBException action@ executes @action@. If @action@ returned a +-- negative integer the integer is converted to a 'USBException' and thrown. If +-- not, the integer is returned. +checkUSBException ∷ Integral α ⇒ IO α → IO Int +checkUSBException action = do r ← action + if r < 0 + then throwIO $ convertUSBException r + else return $ fromIntegral r + +-- | Convert a @C'libusb_error@ to a 'USBException'. If the @C'libusb_error@ is +-- unknown an 'error' is thrown. +convertUSBException ∷ Num α ⇒ α → USBException +convertUSBException err = fromMaybe unknownLibUsbError $ + lookup err libusb_error_to_USBException + where + unknownLibUsbError = + moduleError $ "Unknown libusb error code: " ++ show err ++ "!" + +-- | Association list mapping 'C'libusb_error's to 'USBException's. +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) + ] + +-- | Type of USB exceptions. +data USBException = + IOException String -- ^ Input/output exception. + | InvalidParamException -- ^ Invalid parameter. + | AccessException -- ^ Access denied (insufficient permissions). It may + -- help to run your program with elevated privileges or + -- change the permissions of your device using + -- something like @udev@. + | NoDeviceException -- ^ No such device (it may have been disconnected). + | NotFoundException -- ^ Entity not found. + | BusyException -- ^ Resource busy. + | TimeoutException -- ^ Operation timed out. + | OverflowException -- ^ If the device offered to much data. + -- See /Packets and overflows/ in the @libusb@ documentation: + -- + | PipeException -- ^ Pipe exception. + | InterruptedException -- ^ System call interrupted (perhaps due to signal). + | NoMemException -- ^ Insufficient memory. + | NotSupportedException -- ^ Operation not supported or unimplemented on this + -- platform. + | OtherException -- ^ Other exception. + deriving (COMMON_INSTANCES) + +instance Exception USBException + +-- | A general 'IOException'. +ioException ∷ USBException +ioException = IOException "" + +-- | 'IOException' that is thrown when the number of bytes /read/ +-- doesn't equal the requested number. +incompleteReadException ∷ USBException +incompleteReadException = incompleteException "read" + +-- | 'IOException' that is thrown when the number of bytes /written/ +-- doesn't equal the requested number. +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." diff --git a/System/USB/Descriptors.hs b/System/USB/Descriptors.hs --- a/System/USB/Descriptors.hs +++ b/System/USB/Descriptors.hs @@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- -- | -- Module : System.USB.Descriptors --- Copyright : (c) 2009–2010 Bas van Dijk +-- Copyright : (c) 2009–2011 Bas van Dijk -- License : BSD3 (see the file LICENSE) -- Maintainer : Bas van Dijk -- @@ -58,6 +58,7 @@ -- *** Endpoint max packet size , MaxPacketSize(..) , TransactionOpportunities(..) + , maxIsoPacketSize -- * String descriptors , getLanguages @@ -67,4 +68,4 @@ , getStrDescFirstLang ) where -import System.USB.Internal +import System.USB.Base diff --git a/System/USB/DeviceHandling.hs b/System/USB/DeviceHandling.hs --- a/System/USB/DeviceHandling.hs +++ b/System/USB/DeviceHandling.hs @@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- -- | -- Module : System.USB.Devices --- Copyright : (c) 2009–2010 Bas van Dijk +-- Copyright : (c) 2009–2011 Bas van Dijk -- License : BSD3 (see the file LICENSE) -- Maintainer : Bas van Dijk -- @@ -44,4 +44,4 @@ , withDetachedKernelDriver ) where -import System.USB.Internal +import System.USB.Base diff --git a/System/USB/Enumeration.hs b/System/USB/Enumeration.hs --- a/System/USB/Enumeration.hs +++ b/System/USB/Enumeration.hs @@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- -- | -- Module : System.USB.Devices --- Copyright : (c) 2009–2010 Bas van Dijk +-- Copyright : (c) 2009–2011 Bas van Dijk -- License : BSD3 (see the file LICENSE) -- Maintainer : Bas van Dijk -- @@ -19,4 +19,4 @@ , deviceDesc ) where -import System.USB.Internal +import System.USB.Base diff --git a/System/USB/Exceptions.hs b/System/USB/Exceptions.hs --- a/System/USB/Exceptions.hs +++ b/System/USB/Exceptions.hs @@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- -- | -- Module : System.USB.Exceptions --- Copyright : (c) 2009–2010 Bas van Dijk +-- Copyright : (c) 2009–2011 Bas van Dijk -- License : BSD3 (see the file LICENSE) -- Maintainer : Bas van Dijk -- @@ -9,6 +9,9 @@ module System.USB.Exceptions ( USBException(..) + , ioException + , incompleteReadException + , incompleteWriteException ) where -import System.USB.Internal +import System.USB.Base diff --git a/System/USB/IO.hs b/System/USB/IO.hs new file mode 100644 --- /dev/null +++ b/System/USB/IO.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE CPP, UnicodeSyntax, NoImplicitPrelude #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : System.USB.IO +-- Copyright : (c) 2009–2011 Bas van Dijk +-- License : BSD3 (see the file LICENSE) +-- Maintainer : Bas van Dijk +-- +-- This module provides functions for performing /control/, /bulk/ and +-- /interrupt/ transfers. +-- +-- When your system supports the GHC 'EventManager' this module additionally +-- exports functions for performing /isochronous/ transfers. These are currently +-- not available on Windows. +-- +-- /WARNING:/ You need to enable the threaded runtime (@-threaded@) when using +-- the isochronous functions. They throw a runtime error otherwise! +-- +-------------------------------------------------------------------------------- + +module System.USB.IO + ( ReadAction, ReadExactAction + , WriteAction, WriteExactAction + , Size + , Timeout, noTimeout + , Status(..) + + -- * Control transfers + , ControlAction + , RequestType(..) + , Recipient(..) + , Request + , Value + , Index + + , control + , readControl, readControlExact + , writeControl, writeControlExact + + -- * Bulk transfers + , readBulk + , writeBulk + + -- * Interrupt transfers + , readInterrupt + , writeInterrupt + +#ifdef HAS_EVENT_MANAGER + -- * Isochronous transfers + -- | /WARNING:/ You need to enable the threaded runtime (@-threaded@) when using + -- the isochronous functions. They throw a runtime error otherwise! + , readIsochronous + , writeIsochronous +#endif + ) where + +#ifdef __HADDOCK__ +#ifdef HAS_EVENT_MANAGER +#if MIN_VERSION_base(4,4,0) +import GHC.Event +#else +import System.Event +#endif + ( EventManager ) +#endif +#endif + +import System.USB.Base diff --git a/System/USB/IO/StandardDeviceRequests.hs b/System/USB/IO/StandardDeviceRequests.hs --- a/System/USB/IO/StandardDeviceRequests.hs +++ b/System/USB/IO/StandardDeviceRequests.hs @@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module : System.USB.IO.StandardDeviceRequests --- Copyright : (c) 2009–2010 Bas van Dijk +-- Copyright : (c) 2009–2011 Bas van Dijk -- License : BSD3 (see the file LICENSE) -- Maintainer : Bas van Dijk -- @@ -85,7 +85,7 @@ import System.USB.Descriptors ( EndpointAddress , DeviceStatus(..) ) -import System.USB.IO.Synchronous ( Timeout +import System.USB.IO ( Timeout , RequestType(Standard) , Recipient( ToDevice , ToInterface @@ -95,7 +95,7 @@ , control, readControlExact ) -import System.USB.Unsafe ( marshalEndpointAddress ) +import System.USB.Internal ( marshalEndpointAddress ) import Utils ( genFromEnum ) @@ -285,6 +285,3 @@ 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 deleted file mode 100644 --- a/System/USB/IO/Synchronous.hs +++ /dev/null @@ -1,41 +0,0 @@ --------------------------------------------------------------------------------- --- | --- Module : System.USB.IO.Synchronous --- Copyright : (c) 2009–2010 Bas van Dijk --- License : BSD3 (see the file LICENSE) --- Maintainer : Bas van Dijk --- --- This module provides functionality for performing control, bulk and interrupt --- transfers. --- --------------------------------------------------------------------------------- - -module System.USB.IO.Synchronous - ( ReadAction - , WriteAction - - , Timeout, TimedOut - , Size - - -- * Control transfers - , ControlAction - , RequestType(..) - , Recipient(..) - , Request - , Value - , Index - - , control - , readControl, readControlExact - , writeControl - - -- * Bulk transfers - , readBulk - , writeBulk - - -- * Interrupt transfers - , readInterrupt - , writeInterrupt - ) where - -import System.USB.Internal diff --git a/System/USB/Initialization.hs b/System/USB/Initialization.hs --- a/System/USB/Initialization.hs +++ b/System/USB/Initialization.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE CPP #-} + -------------------------------------------------------------------------------- -- | -- Module : System.USB.Init --- Copyright : (c) 2009–2010 Bas van Dijk +-- Copyright : (c) 2009–2011 Bas van Dijk -- License : BSD3 (see the file LICENSE) -- Maintainer : Bas van Dijk -- @@ -12,8 +14,11 @@ module System.USB.Initialization ( Ctx , newCtx +#ifdef HAS_EVENT_MANAGER + , newCtx' +#endif , setDebug , Verbosity(..) ) where -import System.USB.Internal +import System.USB.Base diff --git a/System/USB/Internal.hs b/System/USB/Internal.hs --- a/System/USB/Internal.hs +++ b/System/USB/Internal.hs @@ -1,1610 +1,54 @@ -{-# LANGUAGE CPP, UnicodeSyntax, NoImplicitPrelude, DeriveDataTypeable #-} - -module System.USB.Internal where - - --------------------------------------------------------------------------------- --- Imports --------------------------------------------------------------------------------- - --- from base: -import Prelude ( Num, (+), (-), (*) - , Integral, fromIntegral, div - , 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 ) -import Foreign.Ptr ( Ptr, castPtr, plusPtr, nullPtr ) -import Foreign.ForeignPtr ( ForeignPtr, newForeignPtr, withForeignPtr) -import Control.Applicative ( liftA2 ) -import Control.Exception ( Exception, throwIO, bracket, bracket_ - , onException, assert - ) -import Control.Monad ( Monad, return, (>>=), (=<<), when, forM ) -import Control.Arrow ( (&&&) ) -import Data.Function ( ($), flip, on ) -import Data.Functor ( Functor, fmap, (<$>) ) -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.Char ( String ) -import Data.Eq ( Eq, (==) ) -import Data.Ord ( Ord, (<), (>) ) -import Data.Bool ( Bool(False, True), not ) -import Data.Bits ( Bits, (.|.), setBit, testBit, shiftL ) -import System.IO ( IO ) -import Text.Show ( Show, show ) -import Text.Read ( Read ) -import Text.Printf ( printf ) - -#if __GLASGOW_HASKELL__ < 700 -import Prelude ( fromInteger, negate ) -import Control.Monad ( (>>), fail ) -#endif - --- from base-unicode-symbols: -import Data.Function.Unicode ( (∘) ) -import Data.Bool.Unicode ( (∧) ) -import Data.Eq.Unicode ( (≢), (≡) ) - --- from bytestring: -import qualified Data.ByteString as B ( ByteString, packCStringLen, drop ) -import qualified Data.ByteString.Internal as BI ( createAndTrim, createAndTrim' ) -import qualified Data.ByteString.Unsafe as BU ( unsafeUseAsCStringLen ) - --- from text: -import Data.Text ( Text ) -import qualified Data.Text.Encoding as TE ( decodeUtf16LE ) - --- from bindings-libusb: -import Bindings.Libusb - --- from usb: -import Utils ( bits - , between - , genToEnum, genFromEnum - , mapPeekArray - , ifM - , decodeBCD - ) - -#if MIN_VERSION_base(4,3,0) -import Control.Exception ( mask ) -import Control.Monad ( void ) -#else -import Control.Exception ( blocked, block, unblock ) -import Data.Function ( id ) -import Data.Functor ( (<$) ) - -mask ∷ ((IO α → IO α) → IO β) → IO β -mask io = do - b ← blocked - if b - then io id - else block $ io unblock - --- | Execute the given action but ignore the result. -void ∷ Functor m ⇒ m α → m () -void = (() <$) -#endif - - --------------------------------------------------------------------------------- --- * Initialization --------------------------------------------------------------------------------- - -{-| Abstract type representing a USB session. - -The concept of individual sessions allows your program to use multiple threads -that can independently use this library without interfering with eachother. - -Sessions are created and initialized by 'newCtx' and are automatically closed -when they are garbage collected. - -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 - --- | Create and initialize a new USB context. --- --- This function may throw 'USBException's. -newCtx ∷ IO Ctx -newCtx = alloca $ \ctxPtrPtr → do - handleUSBException $ c'libusb_init ctxPtrPtr - peek ctxPtrPtr >>= fmap Ctx ∘ newForeignPtr p'libusb_exit - -{-| Set message verbosity. - -The default level is 'PrintNothing'. This means no messages are ever -printed. If you choose to increase the message verbosity level you must ensure -that your application does not close the @stdout@/@stderr@ file descriptors. - -You are advised to set the debug level to 'PrintWarnings'. Libusb is -conservative with its message logging. Most of the time it will only log -messages that explain error conditions and other oddities. This will help you -debug your software. - -The LIBUSB_DEBUG environment variable overrules the debug level set by this -function. The message verbosity is fixed to the value in the environment -variable if it is defined. - -If @libusb@ was compiled without any message logging, this function does nothing: -you'll never get any messages. - -If @libusb@ was compiled with verbose debug message logging, this function does -nothing: you'll always get messages from all levels. --} -setDebug ∷ Ctx → Verbosity → IO () -setDebug ctx verbosity = withCtxPtr ctx $ \ctxPtr → - c'libusb_set_debug ctxPtr $ genFromEnum verbosity - --- | Message verbosity -data Verbosity = - PrintNothing -- ^ No messages are ever printed by the library - | PrintErrors -- ^ Error messages are printed to stderr - | PrintWarnings -- ^ Warning and error messages are printed to stderr - | PrintInfo -- ^ Informational messages are printed to stdout, - -- warning and error messages are printed to stderr - deriving (Enum, Show, Read, Eq, Ord, Data, Typeable) - - --------------------------------------------------------------------------------- --- * Enumeration --------------------------------------------------------------------------------- - -{-| Abstract type representing a USB device detected on the system. - -You can only obtain a USB device from the 'getDevices' function. - -Certain operations can be performed on a device, but in order to do any I/O you -will have to first obtain a 'DeviceHandle' using 'openDevice'. Alternatively you -can use the /usb-safe/ package which provides type-safe device handling. See: - - - -Just because you have a reference to a device does not mean it is necessarily -usable. The device may have been unplugged, you may not have permission to -operate such device or another process or driver may be using the device. - -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 - -- get garbage collected. The finalizer "p'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 - -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 - -{-| Returns a list of USB devices currently attached to the system. - -This is your entry point into finding a USB device. - -Exceptions: - - * 'NoMemException' on a memory allocation failure. - --} - -{- -Visual description of the 'devPtrArrayPtr': - - D - ^ D - D │ ^ - ^ │ │ - │ │ │ -devPtrArrayPtr: ┏━┷━┳━┷━┳━━━┳━━━┳━┷━┓ - P ───> ┃ P ┃ P ┃ P ┃ P ┃ P ┃ - ┗━━━┻━━━┻━┯━┻━┯━┻━━━┛ - │ │ -P = pointer v │ -D = device structure D │ - v - D --} -getDevices ∷ Ctx → IO [Device] -getDevices ctx = - alloca $ \devPtrArrayPtr → mask $ \restore → do - numDevs ← checkUSBException $ withCtxPtr ctx $ - flip c'libusb_get_device_list 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 = 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 -busNumber dev = -- Getting the bus number from libusb is a side-effect free - -- operation. The bus number is a static variable in the device - -- structure. That's why it's safe to use: - unsafePerformIO - $ withDevicePtr dev c'libusb_get_bus_number - --- | The address of the device on the bus it is connected to. -deviceAddress ∷ Device → Word8 -deviceAddress dev = -- Getting the device address from libusb is a side-effect - -- free operation. The device address is a static variable - -- in the device structure. That's why it's safe to use: - unsafePerformIO - $ withDevicePtr dev c'libusb_get_device_address - - --------------------------------------------------------------------------------- --- * Device handling --------------------------------------------------------------------------------- - --------------------------------------------------------------------------------- --- ** Opening & closing devices --------------------------------------------------------------------------------- - -{-| Abstract type representing a handle of a USB device. - -You can acquire a handle from 'openDevice'. - -A device handle is used to perform I/O and other operations. When finished with -a device handle you should close it by applying 'closeDevice' to it. --} -data DeviceHandle = DeviceHandle - { getDevice ∷ !Device -- This reference is needed for keeping the 'Device' - -- and therefor the 'Ctx' alive. - -- ^ Retrieve the 'Device' from the 'DeviceHandle'. - , getDevHndlPtr ∷ !(Ptr C'libusb_device_handle) - -- ^ 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. - -This is a non-blocking function; no requests are sent over the bus. - -It is advisable to use 'withDeviceHandle' because it automatically closes the -device when the computation terminates. - -Exceptions: - - * 'NoMemException' if there is a memory allocation failure. - - * 'AccessException' if the user has insufficient permissions. - - * 'NoDeviceException' if the device has been disconnected. - - * Another 'USBException'. --} -openDevice ∷ Device → IO DeviceHandle -openDevice dev = withDevicePtr dev $ \devPtr → - alloca $ \devHndlPtrPtr → do - handleUSBException $ c'libusb_open devPtr devHndlPtrPtr - DeviceHandle dev <$> peek devHndlPtrPtr - -{-| Close a device handle. - -Should be called on all open handles before your application exits. - -This is a non-blocking function; no requests are sent over the bus. --} -closeDevice ∷ DeviceHandle → IO () -closeDevice = c'libusb_close ∘ getDevHndlPtr - -{-| @withDeviceHandle dev act@ opens the 'Device' @dev@ and passes -the resulting handle to the computation @act@. The handle will be closed on exit -from @withDeviceHandle@ whether by normal termination or by raising an -exception. --} -withDeviceHandle ∷ Device → (DeviceHandle → IO α) → IO α -withDeviceHandle dev = bracket (openDevice dev) closeDevice - --------------------------------------------------------------------------------- --- ** Getting & setting the configuration --------------------------------------------------------------------------------- - --- | Identifier for configurations. --- --- Can be retrieved by 'getConfig' or by 'configValue'. -type ConfigValue = Word8 - -{-| Determine the value of the currently active configuration. - -You could formulate your own control request to obtain this information, but -this function has the advantage that it may be able to retrieve the information -from operating system caches (no I/O involved). - -If the OS does not cache this information, then this function will block while -a control transfer is submitted to retrieve the information. - -This function returns 'Nothing' if the device is in unconfigured state. - -Exceptions: - - * 'NoDeviceException' if the device has been disconnected. - - * Another 'USBException'. --} -getConfig ∷ DeviceHandle → IO (Maybe ConfigValue) -getConfig devHndl = - alloca $ \configPtr → do - handleUSBException $ c'libusb_get_configuration (getDevHndlPtr devHndl) - configPtr - unmarshal <$> peek configPtr - where - unmarshal 0 = Nothing - unmarshal n = Just $ fromIntegral n - - -{-| Set the active configuration for a device. - -The operating system may or may not have already set an active configuration on -the device. It is up to your application to ensure the correct configuration is -selected before you attempt to claim interfaces and perform other operations. - -If you call this function on a device already configured with the selected -configuration, then this function will act as a lightweight device reset: it -will issue a SET_CONFIGURATION request using the current configuration, causing -most USB-related device state to be reset (altsetting reset to zero, endpoint -halts cleared, toggles reset). - -You cannot change/reset configuration if your application has claimed interfaces -- you should free them with 'releaseInterface' first. You cannot change/reset -configuration if other applications or drivers have claimed interfaces. - -A configuration value of 'Nothing' will put the device in an unconfigured -state. The USB specification states that a configuration value of 0 does this, -however buggy devices exist which actually have a configuration 0. - -You should always use this function rather than formulating your own -SET_CONFIGURATION control request. This is because the underlying operating -system needs to know when such changes happen. - -This is a blocking function. - -Exceptions: - - * 'NotFoundException' if the requested configuration does not exist. - - * 'BusyException' if interfaces are currently claimed. - - * 'NoDeviceException' if the device has been disconnected - - * Another 'USBException'. --} -setConfig ∷ DeviceHandle → Maybe ConfigValue → IO () -setConfig devHndl = handleUSBException - ∘ c'libusb_set_configuration (getDevHndlPtr devHndl) - ∘ marshal - where marshal = maybe (-1) fromIntegral - --------------------------------------------------------------------------------- --- ** Claiming & releasing interfaces --------------------------------------------------------------------------------- - -{-| Identifier for interfaces. - -Can be retrieved by 'interfaceNumber'. --} -type InterfaceNumber = Word8 - -{-| Claim an interface on a given device handle. - -You must claim the interface you wish to use before you can perform I/O on any -of its endpoints. - -It is legal to attempt to claim an already-claimed interface, in which case this -function just returns without doing anything. - -Claiming of interfaces is a purely logical operation; it does not cause any -requests to be sent over the bus. Interface claiming is used to instruct the -underlying operating system that your application wishes to take ownership of -the interface. - -This is a non-blocking function. - -Exceptions: - - * 'NotFoundException' if the requested interface does not exist. - - * 'BusyException' if the interface is already claimed. - - * 'NoDeviceException' if the device has been disconnected. - - * Another 'USBException'. --} - -claimInterface ∷ DeviceHandle → InterfaceNumber → IO () -claimInterface devHndl ifNum = - handleUSBException $ c'libusb_claim_interface (getDevHndlPtr devHndl) - (fromIntegral ifNum) - -{-| Release an interface previously claimed with 'claimInterface'. - -You should release all claimed interfaces before closing a device handle. - -This is a blocking function. A SET_INTERFACE control request will be sent to the -device, resetting interface state to the first alternate setting. - -Exceptions: - - * 'NotFoundException' if the interface was not claimed. - - * 'NoDeviceException' if the device has been disconnected - - * Another 'USBException'. --} -releaseInterface ∷ DeviceHandle → InterfaceNumber → IO () -releaseInterface devHndl ifNum = - handleUSBException $ c'libusb_release_interface (getDevHndlPtr devHndl) - (fromIntegral ifNum) - -{-| @withClaimedInterface@ claims the interface on the given device handle then -executes the given computation. On exit from @withClaimedInterface@, the -interface is released whether by normal termination or by raising an exception. --} -withClaimedInterface ∷ DeviceHandle → InterfaceNumber → IO α → IO α -withClaimedInterface devHndl ifNum = bracket_ (claimInterface devHndl ifNum) - (releaseInterface devHndl ifNum) - --------------------------------------------------------------------------------- --- ** Setting interface alternate settings --------------------------------------------------------------------------------- - --- | Identifier for interface alternate settings. --- --- Can be retrieved by 'interfaceAltSetting'. -type InterfaceAltSetting = Word8 - -{-| Activate an alternate setting for an interface. - -The interface must have been previously claimed with 'claimInterface' or -'withInterfaceHandle'. - -You should always use this function rather than formulating your own -SET_INTERFACE control request. This is because the underlying operating system -needs to know when such changes happen. - -This is a blocking function. - -Exceptions: - - * 'NotFoundException' if the interface was not claimed or the requested - alternate setting does not exist. - - * 'NoDeviceException' if the device has been disconnected. - - * Another 'USBException'. --} -setInterfaceAltSetting ∷ DeviceHandle - → InterfaceNumber - → InterfaceAltSetting - → IO () -setInterfaceAltSetting devHndl ifNum alternateSetting = - handleUSBException $ - c'libusb_set_interface_alt_setting (getDevHndlPtr devHndl) - (fromIntegral ifNum) - (fromIntegral alternateSetting) - --------------------------------------------------------------------------------- --- ** Clearing & Resetting devices --------------------------------------------------------------------------------- - -{-| Clear the halt/stall condition for an endpoint. - -Endpoints with halt status are unable to receive or transmit data until the halt -condition is stalled. - -You should cancel all pending transfers before attempting to clear the halt -condition. - -This is a blocking function. - -Exceptions: - - * 'NotFoundException' if the endpoint does not exist. - - * 'NoDeviceException' if the device has been disconnected. - - * Another 'USBException'. --} -clearHalt ∷ DeviceHandle → EndpointAddress → IO () -clearHalt devHndl = handleUSBException - ∘ c'libusb_clear_halt (getDevHndlPtr devHndl) - ∘ marshalEndpointAddress - -{-| Perform a USB port reset to reinitialize a device. - -The system will attempt to restore the previous configuration and alternate -settings after the reset has completed. - -If the reset fails, the descriptors change, or the previous state cannot be -restored, the device will appear to be disconnected and reconnected. This means -that the device handle is no longer valid (you should close it) and rediscover -the device. A 'NotFoundException' is raised to indicate that this is the -case. - -This is a blocking function which usually incurs a noticeable delay. - -Exceptions: - - * 'NotFoundException' if re-enumeration is required, or if the - device has been disconnected. - - * Another 'USBException'. --} -resetDevice ∷ DeviceHandle → IO () -resetDevice = handleUSBException ∘ c'libusb_reset_device ∘ getDevHndlPtr - --------------------------------------------------------------------------------- --- ** USB kernel drivers --------------------------------------------------------------------------------- - -{-| Determine if a kernel driver is active on an interface. - -If a kernel driver is active, you cannot claim the interface, and libusb will be -unable to perform I/O. - -Exceptions: - - * 'NoDeviceException' if the device has been disconnected. - - * Another 'USBException'. --} -kernelDriverActive ∷ DeviceHandle → InterfaceNumber → IO Bool -kernelDriverActive devHndl ifNum = do - r ← c'libusb_kernel_driver_active (getDevHndlPtr devHndl) - (fromIntegral ifNum) - case r of - 0 → return False - 1 → return True - _ → throwIO $ convertUSBException r - -{-| Detach a kernel driver from an interface. - -If successful, you will then be able to claim the interface and perform I/O. - -Exceptions: - - * 'NotFoundException' if no kernel driver was active. - - * 'InvalidParamException' if the interface does not exist. - - * 'NoDeviceException' if the device has been disconnected. - - * Another 'USBException'. --} -detachKernelDriver ∷ DeviceHandle → InterfaceNumber → IO () -detachKernelDriver devHndl ifNum = - handleUSBException $ c'libusb_detach_kernel_driver (getDevHndlPtr devHndl) - (fromIntegral ifNum) - -{-| Re-attach an interface's kernel driver, which was previously -detached using 'detachKernelDriver'. - -Exceptions: - - * 'NotFoundException' if no kernel driver was active. - - * 'InvalidParamException' if the interface does not exist. - - * 'NoDeviceException' if the device has been disconnected. - - * 'BusyException' if the driver cannot be attached because the interface - is claimed by a program or driver. - - * Another 'USBException'. --} -attachKernelDriver ∷ DeviceHandle → InterfaceNumber → IO () -attachKernelDriver devHndl ifNum = - handleUSBException $ c'libusb_attach_kernel_driver (getDevHndlPtr devHndl) - (fromIntegral ifNum) - -{-| If a kernel driver is active on the specified interface the driver is -detached and the given action is executed. If the action terminates, whether by -normal termination or by raising an exception, the kernel driver is attached -again. If a kernel driver is not active on the specified interface the action is -just executed. - -Exceptions: - - * 'NoDeviceException' if the device has been disconnected. - - * Another 'USBException'. --} -withDetachedKernelDriver ∷ DeviceHandle → InterfaceNumber → IO α → IO α -withDetachedKernelDriver devHndl ifNum action = - ifM (kernelDriverActive devHndl ifNum) - (bracket_ (detachKernelDriver devHndl ifNum) - (attachKernelDriver devHndl ifNum) - action) - action - - --------------------------------------------------------------------------------- --- * Descriptors --------------------------------------------------------------------------------- - --------------------------------------------------------------------------------- --- ** Device descriptor --------------------------------------------------------------------------------- - -{-| A structure representing the standard USB device descriptor. - -This descriptor is documented in section 9.6.1 of the USB 2.0 specification. - -This structure can be retrieved by 'deviceDesc'. --} -data DeviceDesc = DeviceDesc - { -- | USB specification release number. - deviceUSBSpecReleaseNumber ∷ !ReleaseNumber - - -- | USB-IF class code for the device. - , deviceClass ∷ !Word8 - - -- | USB-IF subclass code for the device, qualified by the 'deviceClass' - -- value. - , deviceSubClass ∷ !Word8 - - -- | USB-IF protocol code for the device, qualified by the 'deviceClass' - -- and 'deviceSubClass' values. - , deviceProtocol ∷ !Word8 - - -- | Maximum packet size for endpoint 0. - , deviceMaxPacketSize0 ∷ !Word8 - - -- | USB-IF vendor ID. - , deviceVendorId ∷ !VendorId - - -- | USB-IF product ID. - , deviceProductId ∷ !ProductId - - -- | Device release number. - , deviceReleaseNumber ∷ !ReleaseNumber - - -- | Optional index of string descriptor describing manufacturer. - , deviceManufacturerStrIx ∷ !(Maybe StrIx) - - -- | Optional index of string descriptor describing product. - , deviceProductStrIx ∷ !(Maybe StrIx) - - -- | Optional index of string descriptor containing device serial number. - , deviceSerialNumberStrIx ∷ !(Maybe StrIx) - - -- | Number of possible configurations. - , deviceNumConfigs ∷ !Word8 - - -- | List of configurations supported by the device. - , deviceConfigs ∷ ![ConfigDesc] - } deriving (Show, Read, Eq, Data, Typeable) - -type ReleaseNumber = (Int, Int, Int, Int) - -type VendorId = Word16 -type ProductId = Word16 - --------------------------------------------------------------------------------- --- ** Configuration descriptor --------------------------------------------------------------------------------- - -{-| A structure representing the standard USB configuration descriptor. - -This descriptor is documented in section 9.6.3 of the USB 2.0 specification. - -This structure can be retrieved by 'deviceConfigs'. --} -data ConfigDesc = ConfigDesc - { -- | Identifier value for the configuration. - configValue ∷ !ConfigValue - - -- | Optional index of string descriptor describing the configuration. - , configStrIx ∷ !(Maybe StrIx) - - -- | Configuration characteristics. - , configAttribs ∷ !ConfigAttribs - - -- | Maximum power consumption of the USB device from the bus in the - -- configuration when the device is fully operational. Expressed in 2 mA - -- units (i.e., 50 = 100 mA). - , 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] - - -- | Extra descriptors. If @libusb@ encounters unknown configuration - -- descriptors, it will store them here, should you wish to parse them. - , configExtra ∷ !B.ByteString - - } deriving (Show, Read, Eq, Data, Typeable) - --- | An interface is represented as a list of alternate interface settings. -type Interface = [InterfaceDesc] - --------------------------------------------------------------------------------- --- *** Configuration attributes --------------------------------------------------------------------------------- - --- | The USB 2.0 specification specifies that the configuration attributes only --- describe the device status. -type ConfigAttribs = DeviceStatus - -data DeviceStatus = DeviceStatus - { remoteWakeup ∷ !Bool -- ^ The Remote Wakeup field indicates whether the - -- device is currently enabled to request remote - -- wakeup. The default mode for devices that - -- support remote wakeup is disabled. - , selfPowered ∷ !Bool -- ^ The Self Powered field indicates whether the - -- device is currently self-powered - } deriving (Show, Read, Eq, Data, Typeable) - --------------------------------------------------------------------------------- --- ** Interface descriptor --------------------------------------------------------------------------------- - -{-| A structure representing the standard USB interface descriptor. - -This descriptor is documented in section 9.6.5 of the USB 2.0 specification. - -This structure can be retrieved using 'configInterfaces'. --} -data InterfaceDesc = InterfaceDesc - { -- | Number of the interface. - interfaceNumber ∷ !InterfaceNumber - - -- | Value used to select the alternate setting for the interface. - , interfaceAltSetting ∷ !InterfaceAltSetting - - -- | USB-IF class code for the interface. - , interfaceClass ∷ !Word8 - - -- | USB-IF subclass code for the interface, qualified by the - -- 'interfaceClass' value. - , interfaceSubClass ∷ !Word8 - - -- | USB-IF protocol code for the interface, qualified by the - -- 'interfaceClass' and 'interfaceSubClass' values. - , interfaceProtocol ∷ !Word8 - - -- | Optional index of string descriptor describing the interface. - , interfaceStrIx ∷ !(Maybe StrIx) - - -- | List of endpoints supported by the interface. - , interfaceEndpoints ∷ ![EndpointDesc] - - -- | Extra descriptors. If @libusb@ encounters unknown interface - -- descriptors, it will store them here, should you wish to parse them. - , interfaceExtra ∷ !B.ByteString - } deriving (Show, Read, Eq, Data, Typeable) - - --------------------------------------------------------------------------------- --- ** Endpoint descriptor --------------------------------------------------------------------------------- - -{-| A structure representing the standard USB endpoint descriptor. - -This descriptor is documented in section 9.6.3 of the USB 2.0 specification. - -This structure can be retrieved by using 'interfaceEndpoints'. --} -data EndpointDesc = EndpointDesc - { -- | The address of the endpoint described by the descriptor. - endpointAddress ∷ !EndpointAddress - - -- | Attributes which apply to the endpoint when it is configured using the - -- 'configValue'. - , endpointAttribs ∷ !EndpointAttribs - - -- | Maximum packet size the endpoint is capable of sending/receiving. - , endpointMaxPacketSize ∷ !MaxPacketSize - - -- | Interval for polling endpoint for data transfers. Expressed in frames - -- or microframes depending on the device operating speed (i.e., either 1 - -- millisecond or 125 μs units). - , endpointInterval ∷ !Word8 - - -- | /For audio devices only:/ the rate at which synchronization feedback - -- is provided. - , endpointRefresh ∷ !Word8 - - -- | /For audio devices only:/ the address of the synch endpoint. - , endpointSynchAddress ∷ !Word8 - - -- | Extra descriptors. If @libusb@ encounters unknown endpoint descriptors, - -- it will store them here, should you wish to parse them. - , endpointExtra ∷ !B.ByteString - } deriving (Show, Read, Eq, Data, Typeable) - --------------------------------------------------------------------------------- --- *** Endpoint address --------------------------------------------------------------------------------- - --- | The address of an endpoint. -data EndpointAddress = EndpointAddress - { endpointNumber ∷ !Int -- ^ Must be >= 0 and <= 15 - , transferDirection ∷ !TransferDirection - } 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, Read, Eq, Data, Typeable) - --------------------------------------------------------------------------------- --- *** Endpoint attributes --------------------------------------------------------------------------------- - --- | The USB 2.0 specification specifies that the endpoint attributes only --- describe the endpoint transfer type. -type EndpointAttribs = TransferType - --- | Describes what types of transfers are allowed on the endpoint. -data TransferType = - -- | Control transfers are typically used for command and status - -- operations. - Control - - -- | Isochronous transfers occur continuously and periodically. - | Isochronous !Synchronization !Usage - - -- | Bulk transfers can be used for large bursty data. - | Bulk - - -- | Interrupt transfers are typically non-periodic, small device - -- \"initiated\" communication requiring bounded latency. - | Interrupt - deriving (Show, Read, Eq, Data, Typeable) - -data Synchronization = NoSynchronization - | Asynchronous - | Adaptive - | Synchronous - deriving (Enum, Show, Read, Eq, Data, Typeable) - -data Usage = Data - | Feedback - | Implicit - deriving (Enum, Show, Read, Eq, Data, Typeable) - --------------------------------------------------------------------------------- --- *** Endpoint max packet size --------------------------------------------------------------------------------- - -data MaxPacketSize = MaxPacketSize - { maxPacketSize ∷ !Size - , transactionOpportunities ∷ !TransactionOpportunities - } deriving (Show, Read, Eq, Data, Typeable) - --- | Number of additional transactions. -data TransactionOpportunities = Zero | One | Two - deriving (Enum, Ord, Show, Read, Eq, Data, Typeable) - --------------------------------------------------------------------------------- --- 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 - - 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 - } - -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 ∷ 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 - -convertConfigDesc ∷ C'libusb_config_descriptor → IO ConfigDesc -convertConfigDesc c = do - let numInterfaces = c'libusb_config_descriptor'bNumInterfaces c - - interfaces ← mapPeekArray convertInterface - (fromIntegral numInterfaces) - (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 - , configNumInterfaces = numInterfaces - , 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 [InterfaceDesc] -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 - let numEndpoints = c'libusb_interface_descriptor'bNumEndpoints i - - endpoints ← mapPeekArray convertEndpointDesc - (fromIntegral numEndpoints) - (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 - } - --- | 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) = - 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 - _ → error "unmarshalEndpointAttribs: this can't happen!" - -unmarshalMaxPacketSize ∷ Word16 → MaxPacketSize -unmarshalMaxPacketSize m = - MaxPacketSize - { maxPacketSize = fromIntegral $ bits 0 10 m - , transactionOpportunities = genToEnum $ bits 11 12 m - } - --------------------------------------------------------------------------------- --- ** String descriptors --------------------------------------------------------------------------------- - --- | The size in number of bytes of the header of string descriptors -strDescHeaderSize ∷ Size -strDescHeaderSize = 2 - -{-| Retrieve a list of supported languages. - -This function may throw 'USBException's. --} -getLanguages ∷ DeviceHandle → IO [LangId] -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 -location that @dataPtr@ points to. So ensure there is at least space -for @maxSize@ bytes there. Next, the header of the string descriptor -is checked for correctness. If it's incorrect an 'IOException' is -thrown. Finally, the size reported in the header is returned. --} -putStrDesc ∷ DeviceHandle - → StrIx - → Word16 - → Size - → Ptr CUChar - → IO Size -putStrDesc devHndl strIx langId maxSize dataPtr = do - actualSize ← checkUSBException $ c'libusb_get_string_descriptor - (getDevHndlPtr devHndl) - 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 - -{-| The language ID consists of the primary language identifier and the -sublanguage identififier as described in: - - - -For a mapping between IDs and languages see the @usb-id-database@ package at: - - - -To see which 'LangId's are supported by a device see 'getLanguages'. --} -type LangId = (PrimaryLangId, SubLangId) -type PrimaryLangId = Word16 -type SubLangId = Word16 - -unmarshalLangId ∷ Word16 → LangId -unmarshalLangId = bits 0 9 &&& bits 10 15 - -marshalLangId ∷ LangId → Word16 -marshalLangId (p, s) = p .|. s `shiftL`10 - --- | Type of indici of string descriptors. --- --- Can be retrieved by all the *StrIx functions. -type StrIx = Word8 - -{-| Retrieve a string descriptor from a device. - -This function may throw 'USBException's. --} -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 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 + 2 * nrOfChars -- characters are 2 bytes - decode = TE.decodeUtf16LE ∘ B.drop strDescHeaderSize - -{-| Retrieve a string descriptor from a device using the first supported language. - -This function may throw 'USBException's. --} -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 Text -getStrDescFirstLang devHndl strIx nrOfChars = - do langIds ← getLanguages devHndl - case langIds of - [] → throwIO $ IOException "Zero languages" - langId : _ → getStrDesc devHndl strIx langId nrOfChars - - --------------------------------------------------------------------------------- --- * Asynchronous device I/O --------------------------------------------------------------------------------- - --- TODO: Not implemented yet. I'm not sure if I should implement it because you --- can simulate asynchronous IO using threads. - - --------------------------------------------------------------------------------- --- * Synchronous device I/O --------------------------------------------------------------------------------- - -{-| Handy type synonym for read transfers. - -A @ReadAction@ is a function which takes a 'Size' which defines how many bytes -to read and a 'Timeout'. The function returns an 'IO' action which, when -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, TimedOut) - -{-| Handy type synonym for write transfers. - -A @WriteAction@ is a function which takes a 'B.ByteString' to write and a -'Timeout'. The function returns an 'IO' action which, when exectued, returns the -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, 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 - -------------------------------------------------------------------------------- --- ** Control transfers -------------------------------------------------------------------------------- - --- | Handy type synonym that names the parameters of a control transfer. -type ControlAction α = RequestType → Recipient → Request → Value → Index → α - -data RequestType = Standard - | Class - | Vendor - deriving (Enum, Show, Read, Eq, Data, Typeable) - -data Recipient = ToDevice - | ToInterface - | ToEndpoint - | ToOther - deriving (Enum, Show, Read, Eq, Data, Typeable) - -type Request = Word8 - --- | (Host-endian) -type Value = Word16 - --- | (Host-endian) -type Index = Word16 - -marshalRequestType ∷ RequestType → Recipient → Word8 -marshalRequestType t r = genFromEnum t `shiftL` 5 .|. genFromEnum r - -{-| Perform a USB /control/ request that does not transfer data. - -Exceptions: - - * 'TimeoutException' if the transfer timed out. - - * 'PipeException' if the control request was not supported by the device - - * 'NoDeviceException' if the device has been disconnected. - - * Another 'USBException'. --} -control ∷ DeviceHandle → ControlAction (Timeout → IO ()) -control devHndl = \reqType reqRecipient request value index → \timeout → - void $ checkUSBException $ c'libusb_control_transfer - (getDevHndlPtr devHndl) - (marshalRequestType reqType reqRecipient) - request - value - index - nullPtr - 0 - (fromIntegral timeout) - -{-| Perform a USB /control/ read. - -Exceptions: - - * 'PipeException' if the control request was not supported by the device - - * 'NoDeviceException' if the device has been disconnected. - - * Another 'USBException'. --} -readControl ∷ DeviceHandle → ControlAction ReadAction -readControl devHndl = \reqType reqRecipient request value index → \size timeout → - 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) - let timedOut = err ≡ c'LIBUSB_ERROR_TIMEOUT - if err < 0 ∧ not timedOut - 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: - - * 'PipeException' if the control request was not supported by the device - - * 'NoDeviceException' if the device has been disconnected. - - * Another 'USBException'. --} -writeControl ∷ DeviceHandle → ControlAction WriteAction -writeControl devHndl = \reqType reqRecipient request value index → \input timeout → - BU.unsafeUseAsCStringLen input $ \(dataPtr, size) → do - err ← c'libusb_control_transfer - (getDevHndlPtr devHndl) - (marshalRequestType reqType reqRecipient) - request - value - index - (castPtr dataPtr) - (fromIntegral size) - (fromIntegral timeout) - let timedOut = err ≡ c'LIBUSB_ERROR_TIMEOUT - if err < 0 ∧ not timedOut - then throwIO $ convertUSBException err - else return (fromIntegral err, timedOut) - - --------------------------------------------------------------------------------- --- ** Bulk transfers --------------------------------------------------------------------------------- - -{-| Perform a USB /bulk/ read. - -Exceptions: - - * 'PipeException' if the endpoint halted. - - * 'OverflowException' if the device offered more data, - see /Packets and overflows/ in the @libusb@ documentation: - . - - * 'NoDeviceException' if the device has been disconnected. - - * Another 'USBException'. --} -readBulk ∷ DeviceHandle -- ^ A handle for the device to communicate with. - → EndpointAddress -- ^ The address of a valid 'In' and 'Bulk' endpoint - -- to communicate with. Make sure the endpoint - -- belongs to the current alternate setting of a - -- claimed interface which belongs to the device. - → ReadAction -readBulk = readTransfer c'libusb_bulk_transfer - -{-| Perform a USB /bulk/ write. - -Exceptions: - - * 'PipeException' if the endpoint halted. - - * 'OverflowException' if the device offered more data, - see /Packets and overflows/ in the @libusb@ documentation: - . - - * 'NoDeviceException' if the device has been disconnected. - - * Another 'USBException'. --} -writeBulk ∷ DeviceHandle -- ^ A handle for the device to communicate with. - → EndpointAddress -- ^ The address of a valid 'Out' and 'Bulk' - -- endpoint to communicate with. Make sure the - -- endpoint belongs to the current alternate - -- setting of a claimed interface which belongs to - -- the device. - → WriteAction -writeBulk = writeTransfer c'libusb_bulk_transfer - --------------------------------------------------------------------------------- --- ** Interrupt transfers --------------------------------------------------------------------------------- - -{-| Perform a USB /interrupt/ read. - -Exceptions: - - * 'PipeException' if the endpoint halted. - - * 'OverflowException' if the device offered more data, - see /Packets and overflows/ in the libusb documentation: - . - - * 'NoDeviceException' if the device has been disconnected. - - * Another 'USBException'. --} -readInterrupt ∷ DeviceHandle -- ^ A handle for the device to communicate - -- with. - → EndpointAddress -- ^ The address of a valid 'In' and 'Interrupt' - -- endpoint to communicate with. Make sure the - -- endpoint belongs to the current alternate - -- setting of a claimed interface which - -- belongs to the device. - → ReadAction -readInterrupt = readTransfer c'libusb_interrupt_transfer - -{-| Perform a USB /interrupt/ write. - -Exceptions: - - * 'PipeException' if the endpoint halted. - - * 'OverflowException' if the device offered more data, - see /Packets and overflows/ in the @libusb@ documentation: - . - - * 'NoDeviceException' if the device has been disconnected. - - * Another 'USBException'. --} -writeInterrupt ∷ DeviceHandle -- ^ A handle for the device to communicate - -- with. - → EndpointAddress -- ^ The address of a valid 'Out' and - -- 'Interrupt' endpoint to communicate - -- with. Make sure the endpoint belongs to - -- the current alternate setting of a claimed - -- interface which belongs to the device. - → WriteAction -writeInterrupt = writeTransfer c'libusb_interrupt_transfer - --------------------------------------------------------------------------------- - --- | Handy type synonym for the @libusb@ transfer functions. -type C'TransferFunc = Ptr C'libusb_device_handle -- devHndlPtr - → CUChar -- endpoint address - → Ptr CUChar -- dataPtr - → CInt -- size - → Ptr CInt -- transferredPtr - → CUInt -- timeout - → IO CInt -- error - -readTransfer ∷ C'TransferFunc → (DeviceHandle → EndpointAddress → ReadAction) -readTransfer c'transfer = \devHndl endpointAddr → \size timeout → - BI.createAndTrim' size $ \dataPtr → do - (transferred, timedOut) ← transfer c'transfer - devHndl - endpointAddr - timeout - (castPtr dataPtr, size) - return (0, transferred, timedOut) - -writeTransfer ∷ C'TransferFunc → (DeviceHandle → EndpointAddress → WriteAction) -writeTransfer c'transfer = \devHndl endpointAddr → \input timeout → - BU.unsafeUseAsCStringLen input $ transfer c'transfer - devHndl - endpointAddr - timeout - -transfer ∷ C'TransferFunc → DeviceHandle - → EndpointAddress - → Timeout - → CStringLen - → IO (Size, TimedOut) -transfer c'transfer devHndl - endpointAddr - timeout - (dataPtr, size) = - alloca $ \transferredPtr → do - err ← c'transfer (getDevHndlPtr devHndl) - (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, timedOut) - - --------------------------------------------------------------------------------- --- * Exceptions --------------------------------------------------------------------------------- - --- | @handleUSBException action@ executes @action@. If @action@ returned an --- error code other than 'c\'LIBUSB_SUCCESS', the error is converted to a --- 'USBException' and thrown. -handleUSBException ∷ IO CInt → IO () -handleUSBException action = do err ← action - when (err ≢ c'LIBUSB_SUCCESS) - (throwIO $ convertUSBException err) - --- | @checkUSBException action@ executes @action@. If @action@ returned a --- negative integer the integer is converted to a 'USBException' and thrown. If --- not, the integer is returned. -checkUSBException ∷ Integral α ⇒ IO α → IO Int -checkUSBException action = do r ← action - if r < 0 - then throwIO $ convertUSBException r - else return $ fromIntegral r - --- | Convert a C'libusb_error to a 'USBException'. If the C'libusb_error is --- unknown an 'error' is thrown. -convertUSBException ∷ Num α ⇒ α → USBException -convertUSBException err = fromMaybe unknownLibUsbError $ - lookup err libusb_error_to_USBException - where - unknownLibUsbError = error $ "Unknown Libusb error code: " ++ show err ++ "!" - --- | Association list mapping 'C'libusb_error's to 'USBException's. -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) - ] - --- | Type of USB exceptions. -data USBException = - IOException String -- ^ Input/output exception. - | InvalidParamException -- ^ Invalid parameter. - | AccessException -- ^ Access denied (insufficient permissions). - | NoDeviceException -- ^ No such device (it may have been disconnected). - | NotFoundException -- ^ Entity not found. - | BusyException -- ^ Resource busy. - | TimeoutException -- ^ Operation timed out. - | OverflowException -- ^ Overflow. - | PipeException -- ^ Pipe exception. - | InterruptedException -- ^ System call interrupted (perhaps due to signal). - | NoMemException -- ^ Insufficient memory. - | NotSupportedException -- ^ Operation not supported or unimplemented on this - -- platform. - | OtherException -- ^ Other exception. - deriving (Eq, Show, Read, Data, Typeable) - -instance Exception USBException - - --- The End --------------------------------------------------------------------- +{-# LANGUAGE CPP #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : System.USB.Unsafe +-- Copyright : (c) 2009–2011 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. +-- +-------------------------------------------------------------------------------- + +module System.USB.Internal + ( C'TransferFunc + , withDevHndlPtr + , convertUSBException + , unmarshalReleaseNumber + , unmarshalStrIx + + -- * Marshal and unmarshal endpoint addresses + + -- | The address should be encoded according to section 9.6.6 of the USB 2.0 + -- specification. + -- + -- * Bits 0-3 denote the 'endpointNumber'. + -- + -- * Bit 7 denotes the 'transferDirection'. + -- 0 denotes 'Out' and 1 denotes 'In'. + , marshalEndpointAddress + , unmarshalEndpointAddress + +#ifdef HAS_EVENT_MANAGER + -- * Useful types and functions for asynchronous implementations + , C'TransferType + + , threaded + + , allocaTransfer + , withCallback + + , SumLength(..), sumLength + , peekIsoPacketDescs + , initIsoPacketDesc + + , getCtx, getEventManager + + -- ** Locks + , Lock, newLock, acquire, release +#endif + ) where + +import System.USB.Base diff --git a/System/USB/Unsafe.hs b/System/USB/Unsafe.hs deleted file mode 100644 --- a/System/USB/Unsafe.hs +++ /dev/null @@ -1,21 +0,0 @@ --------------------------------------------------------------------------------- --- | --- 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/SystemEventManager.hs b/SystemEventManager.hs new file mode 100644 --- /dev/null +++ b/SystemEventManager.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE CPP, NoImplicitPrelude #-} + +#if MIN_VERSION_base(4,4,0) +module SystemEventManager ( getSystemEventManager ) where +import GHC.Event ( getSystemEventManager ) +#else + +{-# LANGUAGE UnicodeSyntax, ForeignFunctionInterface #-} + +module SystemEventManager ( getSystemEventManager ) where + +-- from base: +import Data.Function ( ($) ) +import Data.IORef ( IORef, newIORef, readIORef ) +import Data.Maybe ( Maybe(Nothing) ) +import Foreign.Ptr ( Ptr ) +import GHC.Conc.Sync ( sharedCAF ) +import System.Event ( EventManager ) +import System.IO ( IO ) +import System.IO.Unsafe ( unsafePerformIO ) + +getSystemEventManager ∷ IO (Maybe EventManager) +getSystemEventManager = readIORef eventManager + +eventManager ∷ IORef (Maybe EventManager) +eventManager = unsafePerformIO $ do + em ← newIORef Nothing + sharedCAF em getOrSetSystemEventThreadEventManagerStore +{-# NOINLINE eventManager #-} + +foreign import ccall unsafe "getOrSetSystemEventThreadEventManagerStore" + getOrSetSystemEventThreadEventManagerStore ∷ Ptr α → IO (Ptr α) +#endif diff --git a/Timeval.hs b/Timeval.hs new file mode 100644 --- /dev/null +++ b/Timeval.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE NoImplicitPrelude, UnicodeSyntax #-} + +-- | A short module to work with C's struct timeval. + +-- Copied from the package "time" - Data.Time.Clock.CTimeval + +module Timeval ( withTimeval ) where + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +-- from base: +import Control.Monad ( return ) +import Foreign.C.Types ( CLong ) +import Foreign.Marshal.Utils ( with ) +import Foreign.Ptr ( Ptr, castPtr ) +import Foreign.Storable ( Storable(..) ) +import Prelude ( (*), quotRem, fromIntegral, undefined, Int ) +import System.IO ( IO ) + +-- from base-unicode-symbols: +import Data.Function.Unicode ( (∘) ) + +-- from bindings-libusb: +import Bindings.Libusb.PollingAndTiming ( C'timeval ) + +-------------------------------------------------------------------------------- +-- Timeval +-------------------------------------------------------------------------------- + +data CTimeval = MkCTimeval CLong CLong + +instance Storable CTimeval where + sizeOf _ = (sizeOf (undefined ∷ CLong)) * 2 + alignment _ = alignment (undefined ∷ CLong) + peek p = do + s ← peekElemOff (castPtr p) 0 + mus ← peekElemOff (castPtr p) 1 + return (MkCTimeval s mus) + poke p (MkCTimeval s mus) = do + pokeElemOff (castPtr p) 0 s + pokeElemOff (castPtr p) 1 mus + +-- Every things done so far in libusb was in milliseconds. So this +-- function should accept a time in milliseconds too ! +withTimeval ∷ Int → (Ptr C'timeval → IO α) → IO α +withTimeval milliseconds action = + let (seconds, mseconds) = milliseconds `quotRem` 1000 + timeval = MkCTimeval (fromIntegral seconds) + (fromIntegral (1000 * mseconds)) -- micro-seconds + in with timeval (action ∘ castPtr) diff --git a/Utils.hs b/Utils.hs --- a/Utils.hs +++ b/Utils.hs @@ -1,4 +1,8 @@ -{-# LANGUAGE CPP, NoImplicitPrelude, UnicodeSyntax, BangPatterns #-} +{-# LANGUAGE CPP + , NoImplicitPrelude + , UnicodeSyntax + , BangPatterns + #-} module Utils where @@ -76,6 +80,3 @@ go shftL ds | shftL < 0 = ds | otherwise = let !d = (abcd `shiftL` shftL) `shiftR` shftR in go (shftL - bitsInDigit) (d : ds) - - --- The End --------------------------------------------------------------------- diff --git a/usb.cabal b/usb.cabal --- a/usb.cabal +++ b/usb.cabal @@ -1,78 +1,101 @@ name: usb -version: 0.8 +version: 1.0 cabal-version: >=1.6 build-type: Custom license: BSD3 license-file: LICENSE -copyright: 2009–2010 Bas van Dijk +copyright: 2009–2011 Bas van Dijk author: Bas van Dijk maintainer: Bas van Dijk -stability: experimental +homepage: https://github.com/basvandijk/usb/ +bug-reports: https://github.com/basvandijk/usb/issues category: System synopsis: Communicate with USB devices -description: This library allows you to communicate with USB devices from +description: This library enables you to communicate with USB devices from userspace. It is implemented as a high-level wrapper around @bindings-libusb@ which is a low-level binding to the C library: @libusb-1.*@. - . - 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: . - + The USB transfer functions in this library have a simple synchronous + interface (they block) but are implemented using the @libusb@ + asynchronous interface. They integrate with the GHC event manager + making them efficient (no busy-loops) and interruptible (throwing an + exception to the thread executing a transfer immediately cancels the + transfer). . - 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: - + If the GHC event manager is not available (because you're either not + using GHC or because you're on Windows) the library degrades + gracefully to the @libusb@ synchronous implementation. + . + 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 @usb-example@ + package at: + . + + . + or 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-iteratee@ package which + provides @iteratee@ enumerators for enumerating bulk, interrupt + and isochronous 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: + +extra-source-files: README.markdown, NEWS + source-repository head - Type: darcs - Location: http://code.haskell.org/~basvandijk/code/usb + Type: git + Location: git://github.com/basvandijk/usb.git Library GHC-Options: -Wall - build-depends: base >= 4 && < 4.4 + build-depends: base >= 4 && < 4.5 , base-unicode-symbols >= 0.1.1 && < 0.3 - , bindings-libusb >= 1.3 && < 1.5 + , bindings-libusb >= 1.4.4 && < 1.5 , bytestring >= 0.9 && < 0.10 , text >= 0.5 && < 0.12 + exposed-modules: System.USB - System.USB.Initialization - System.USB.Enumeration - System.USB.DeviceHandling - System.USB.Descriptors - System.USB.IO.Synchronous - System.USB.IO.StandardDeviceRequests - System.USB.Exceptions - System.USB.Unsafe - other-modules: System.USB.Internal - Utils + System.USB.Initialization + System.USB.Enumeration + System.USB.DeviceHandling + System.USB.Descriptors + System.USB.IO + System.USB.IO.StandardDeviceRequests + System.USB.Exceptions + System.USB.Internal + other-modules: System.USB.Base, Utils + + if impl(ghc>7) && !os(windows) + cpp-options: -DHAS_EVENT_MANAGER + other-modules: Poll, Event, SystemEventManager, Timeval + build-depends: containers >= 0.1 && < 0.5