usb-safe 0.3 → 0.4
raw patch · 2 files changed
+1360/−1564 lines, 2 filesdep +regionsdep −monads-fd
Dependencies added: regions
Dependencies removed: monads-fd
Files
- System/USB/Safe.hs +1335/−1558
- usb-safe.cabal +25/−6
System/USB/Safe.hs view
@@ -1,1561 +1,1338 @@---- For each language extension I explain why I need it at the first place I need--- it. So just do a textual search for them and you will see why I need so many--- of them:--{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE UnicodeSyntax #-}------------------------------------------------------------------------------------- |--- Module : System.USB.Safe--- Copyright : (c) 2009 Bas van Dijk--- License : BSD3 (see the file LICENSE)--- Maintainer : Bas van Dijk <v.dijk.bas@gmail.com>------ This modules provides the following guarantees for working with USB devices:------ * You can't reference handles to devices that are closed. In other words: no--- I/O with closed handles is possible.------ * The programmer specifies the /region/ in which devices should remain--- open. On exit from the region the opened devices are automatically closed.------ * You can't reference handles to configurations that have not been set.------ * You can't reference handles to interfaces that have not been claimed.------ * You can't reference handles to alternates that have not been set.------ * You can't reference endpoints that don't belong to a setted alternate.------ * You can't read from an endpoint with an 'Out' transfer direction.------ * You can't write to an endpoint with an 'In' transfer direction.------ * You can't read from or write to endpoints with the unsupported transfer--- types 'Control' and 'Isochronous'. Only I/O with endpoints with the 'Bulk'--- and 'Interrupt' transfer types is allowed.------ This modules makes use of a technique called /Lightweight monadic regions/--- invented by Oleg Kiselyov and Chung-chieh Shan------ See: <http://okmij.org/ftp/Haskell/regions.html#light-weight>--------------------------------------------------------------------------------------module System.USB.Safe- ( -- * Device regions- DeviceRegionT- , runDeviceRegionT-- , TopDeviceRegion- , runTopDeviceRegion-- , forkTopDeviceRegion-- , mapDeviceRegionT- , liftCatch-- -- * Opening devices- , DeviceHandle- , openDevice- , dupDeviceHandle- , withDevice- , getDevice-- , resetDevice-- -- * Configurations- , Config- , getConfigs- , getConfigDesc- , dupConfig-- -- ** Setting configurations- , ConfigHandle- , SettingAlreadySet- , withConfig- , NoActiveConfig- , withActiveConfig-- -- * Interfaces- , Interface- , getInterfaces- , getInterfaceDescs-- -- ** Claiming and releasing interfaces- , InterfaceHandle- , withInterface-- -- * Alternates- , Alternate- , getAlternates- , getInterfaceDesc-- -- ** Setting alternates- , AlternateHandle- , withAlternate- , withActiveAlternate-- -- * Endpoints- , Endpoint- , getEndpoints-- -- ** Filtering endpoints- , FilteredEndpoint- , filterEndpoints-- , getEndpointDesc- , clearHalt-- -- *** Transfer directions- , In- , Out-- -- *** Transfer types- , Control- , Isochronous- , Bulk- , Interrupt-- -- * Endpoint I/O- , ReadAction- , ReadEndpoint(..)-- , WriteAction- , WriteEndpoint(..)-- -- ** Control transfers- , RequestType(..)- , control- , readControl- , writeControl-- -- * String descriptors- , getLanguages- , getStrDesc- , getStrDescFirstLang-- -- * USB kernel drivers- , kernelDriverActive- , detachKernelDriver- , attachKernelDriver- , withDetachedKernelDriver- ) where-------------------------------------------------------------------------------------- Imports------------------------------------------------------------------------------------- from base:-import Control.Concurrent ( forkIO, ThreadId )-import Control.Concurrent.MVar ( MVar, newMVar, takeMVar, putMVar, withMVar)--import Control.Monad ( when, liftM4 )--import Control.Exception ( Exception, throwIO )-import Data.Typeable ( Typeable )--import Data.IORef ( IORef, newIORef- , readIORef, modifyIORef, atomicModifyIORef- )--import Data.Word ( Word8, Word16 )-import Data.List ( filter, find )-import Data.Maybe ( fromJust )---- from bytestring:-import Data.ByteString ( ByteString )---- from transformers:-import Control.Monad.Trans ( MonadTrans, lift, MonadIO, liftIO )--import qualified Control.Monad.Trans.Reader as Reader ( liftCatch )-import Control.Monad.Trans.Reader ( ReaderT, runReaderT- , mapReaderT- )--- from monads-fd:-import Control.Monad.Cont.Class ( MonadCont )-import Control.Monad.Error.Class ( MonadError, throwError, catchError )-import Control.Monad.RWS.Class ( MonadRWS )-import Control.Monad.Reader.Class ( MonadReader, ask, local )-import Control.Monad.State.Class ( MonadState, get, put )-import Control.Monad.Writer.Class ( MonadWriter, tell, listen, pass )---- from MonadCatchIO-transformers:-import Control.Monad.CatchIO ( MonadCatchIO, block, bracket, bracket_ )---- from unicode-symbols:-import Prelude.Unicode ( (∘), (≡), (∧) )---- from usb:-import qualified System.USB.Enumeration as USB ( Device, deviceDesc )-import qualified System.USB.DeviceHandling as USB ( DeviceHandle- , openDevice, closeDevice- , getDevice-- , getConfig, setConfig-- , InterfaceNumber- , claimInterface, releaseInterface-- , setInterfaceAltSetting-- , clearHalt- , resetDevice-- , kernelDriverActive- , detachKernelDriver- , attachKernelDriver- )-import qualified System.USB.Descriptors as USB ( deviceConfigs-- , ConfigDesc- , configValue- , configInterfaces-- , Interface-- , InterfaceDesc- , interfaceNumber- , interfaceAltSetting- , interfaceEndpoints-- , EndpointDesc- , endpointAddress- , endpointAttribs-- , EndpointAddress- , transferDirection-- , TransferDirection(In, Out)- , TransferType( Control- , Isochronous- , Bulk- , Interrupt- )-- , getLanguages- , LangId- , StrIx- , getStrDesc- , getStrDescFirstLang- )-import qualified System.USB.IO.Synchronous as USB ( ReadAction, WriteAction-- , Timeout, Size-- , RequestType(Class, Vendor)- , Recipient-- , control- , readControl, writeControl-- , getInterfaceAltSetting-- , readBulk, readInterrupt-- , writeBulk, writeInterrupt- )-------------------------------------------------------------------------------------- * Device regions-----------------------------------------------------------------------------------{-| A monad transformer in which 'USB.Device's can be opened wich are-automatically closed on exit from the region.--Note that regions can be nested. @pr@ (for parent region) is a monad which is-usually the region which is running this region. However when you are running a-'TopDeviceRegion' the parent region will be 'IO'.--}--- Note that for the kind signature on 'pr' I need: 'KindSignatures'--- Note that because I use unicode symbols I need: 'UnicodeSyntax'--newtype DeviceRegionT s (pr ∷ * → *) α = DeviceRegionT- (ReaderT (IORef [OpenedDevice]) pr α)-- deriving ( Monad- , MonadTrans- , MonadIO- , MonadCatchIO- , MonadCont- )-- -- Note to automatically derive these instances I need:- -- 'GeneralizedNewtypeDeriving' which lets you derive instances of the type- -- you've wrapped.--{-| Regions need to know the list of devices that have been opened in and-duplicated to the region. Regions also need to be able to update that list when-new devices are registered.--There are to logical choices for representing this @[OpenedDevice]@ state:--* @StateT [OpenedDevice]@--* @ReaderT (IORef [OpenedDevice])@--The former has the advantage of being able to be run in any monad while the-latter can only be executed in the @IO@ monad because of the @IORef@. The latter-however may be more efficient because the state doesn't need to be passed-around.--Because eventually all regions have to be run in the @IO@ monad anyway I have-choosen the latter for its better efficiency.--}-unDeviceRegionT ∷ DeviceRegionT s pr α- → ReaderT (IORef [OpenedDevice]) pr α-unDeviceRegionT (DeviceRegionT reader) = reader--data OpenedDevice = OpenedDevice USB.DeviceHandle- RefCntIORef- ConfigAlreadySetMVar- AlternateAlreadySetMVar--{-| Because regions can be nested and device handles can be duplicated from a-child region to a parent region we need to keep a reference count per opened-device.--The reference count is:--* initialized at 1 when a device is created in 'openDevice',--* incremented when we duplicate a device handle in 'dupDeviceHandle',--* decremented on exit from a region in 'runWith'.--Only when the reference count reaches 0 the device is actually closed.--Note that the reference count @IORef@ is shared between threads. I make sure the-modifications happen atomically using: 'atomicModifyIORef'.--}-type RefCntIORef = IORef Int---- | @MVar@ which keeps track of wheter a configuration has been set.--- See: 'withConfig'.-type ConfigAlreadySetMVar = MVar Bool---- | @MVar@ which keeps track of wheter an alternate has been set.--- See: 'withAlternate'.-type AlternateAlreadySetMVar = MVar Bool--{-| Execute a region inside its parent region @pr@.--All 'USB.Device's which have been opened in the given region using 'openDevice',-and which haven't been duplicated using 'dupDeviceHandle', will be closed on-exit from this function wether by normal termination or by raising an exception.--Also all devices which have been duplicated to this region from a child region-are closed on exit if they haven't been duplicated themselves.--Note the type variable @s@ of the region wich is only quantified over the region-itself. This ensures that no values, that have a type which has @s@ in it, can-be returned from this function. (Note the similarity with the @ST@ monad.)--'DeviceHandle's are parameterized by the region in which they were created.-So device handles which were created by @openDevice@ in the given region have-this @s@ in their type. This ensures that these device handles, which may have-been closed on exit from this function, can't be returned by this function. This-ensures you can never do any IO with closed device handles.--Note that it is possible to run a region inside another region.--/TODO: Say something more about this nesting of regions.../--}--- Note for the inner ∀ quantifier I need: 'RankNTypes'-runDeviceRegionT ∷ MonadCatchIO pr ⇒ (∀ s. DeviceRegionT s pr α) → pr α-runDeviceRegionT m = runWith [] m--{-| A region which has 'IO' as its parent region which enables it to be directly-executed in 'IO' by 'runTopDeviceRegion' or concurrently executed in another-region by 'forkTopDeviceRegion'.--}-type TopDeviceRegion s = DeviceRegionT s IO---- | Convenience funtion for running a /top-level/ region in 'IO'.------ Note that: @runTopDeviceRegion = 'runDeviceRegionT'@-runTopDeviceRegion ∷ (∀ s. TopDeviceRegion s α) → IO α-runTopDeviceRegion = runDeviceRegionT--{-| Return a region which executes the given /top-level/ region in a new thread.--Note that the forked region has the same type variable @s@ as the resulting-region. This means that all 'DeviceHandle's which can be referenced in the-resulting region can also be referenced in the forked region.--}-forkTopDeviceRegion ∷ MonadIO pr- ⇒ TopDeviceRegion s ()- → DeviceRegionT s pr ThreadId-forkTopDeviceRegion m = DeviceRegionT $ do- openedDevicesIORef ← ask- liftIO $ do openedDevices ← readIORef openedDevicesIORef- block $ do mapM_ incrementRefCnt openedDevices- forkIO $ runWith openedDevices m--runWith ∷ MonadCatchIO pr ⇒ [OpenedDevice] → DeviceRegionT s pr α → pr α-runWith openedDevices m =- bracket (liftIO $ newIORef openedDevices)- (\openedDevicesIORef → liftIO $ readIORef openedDevicesIORef >>=- mapM_ closeOpenedDevice)- (runReaderT $ unDeviceRegionT m)- where- closeOpenedDevice (OpenedDevice devHndlI refCntIORef _ _) = do- refCnt ← decrement refCntIORef- when (refCnt ≡ 0) $ USB.closeDevice devHndlI-- decrement refCntIORef = atomicModifyIORef refCntIORef $ \refCnt →- let predRefCnt = pred refCnt- in (predRefCnt, predRefCnt)--incrementRefCnt ∷ OpenedDevice → IO ()-incrementRefCnt (OpenedDevice _ refCntIORef _ _) =- atomicModifyIORef refCntIORef $ \refCnt →- (succ refCnt, ())---- | Transform the computation inside a region.-mapDeviceRegionT ∷ (m α → n β) → DeviceRegionT s m α → DeviceRegionT s n β-mapDeviceRegionT f = DeviceRegionT ∘ mapReaderT f ∘ unDeviceRegionT---- | Lift a 'catchError' operation to the new monad.-liftCatch ∷ (pr α → (e → pr α) → pr α) -- ^ @catch@ on the argument monad.- → DeviceRegionT s pr α -- ^ Computation to attempt.- → (e → DeviceRegionT s pr α) -- ^ Exception handler.- → DeviceRegionT s pr α-liftCatch f m h = DeviceRegionT $ Reader.liftCatch f- (unDeviceRegionT m)- (unDeviceRegionT ∘ h)-------------------------------------------------------------------------------------- * Opening devices------------------------------------------------------------------------------------- | A handle to an opened 'USB.Device' parameterized by the region @r@ in which--- it was created.-newtype DeviceHandle (r ∷ * → *) = DeviceHandle OpenedDevice--internalDeviceHandle ∷ DeviceHandle r → USB.DeviceHandle-internalDeviceHandle (DeviceHandle (OpenedDevice devHndlI _ _ _)) = devHndlI--{-| Open a device in a region.--Note that the returned device handle is parameterized by the region in which-it was created. This is to ensure that device handles can never escape their-region and to support operations on device handles that are used in a child-region of the region in which the device was created.--This is a non-blocking function; no requests are sent over the bus.--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 ∷ MonadCatchIO pr- ⇒ USB.Device- → DeviceRegionT s pr- (DeviceHandle (DeviceRegionT s pr))-openDevice dev = DeviceRegionT $ block $ newOpenedDevice >>= registerOpenedDevice- where- newOpenedDevice = liftIO $ liftM4 OpenedDevice (USB.openDevice dev)- (newIORef 1)- (newMVar False)- (newMVar False)--{-| Duplicate a device handle in the parent region.--For example, suppose you run the following region:--@-runDeviceRegionT $ do-@--Inside this region you run a nested /child/ region like:--@- d1hDup <- runDeviceRegionT $ do-@--Now in this child region you open the device @d1@:--@- d1h <- openDevice d1-@--Note that @d1h :: DeviceHandle (DeviceRegion cs (DeviceRegion ps ppr))@ where-@cs@ is bound by the inner (child) @runDeviceRegionT@ and @ps@ is bound by the-outer (parent) @runDeviceRegionT@.--Suppose you want to use the resulting device handle @d1h@ in the /parent/ device-region. You can't simply @return d1h@ because then the type variable @cs@,-escapes the inner region.--However, if you duplicate the device handle you can safely return it.--@- d1hDup <- dupDeviceHandle d1h- return d1hDup-@--Note that @d1hDup :: DeviceHandle (DeviceRegionT ps ppr)@--Back in the parent region you can safely operate on @d1hDup@.--}-dupDeviceHandle ∷ MonadCatchIO ppr- ⇒ DeviceHandle (DeviceRegionT cs (DeviceRegionT ps ppr))- -- ^ A device handle created in @DeviceRegionT cs ...@ which- -- must have a parent region @DeviceRegionT ps ppr@.- → DeviceRegionT cs (DeviceRegionT ps ppr)- (DeviceHandle (DeviceRegionT ps ppr))- -- ^ Yield a computation in @DeviceRegionT cs@ that returns- -- the duplicated device handle that can now be used in the- -- parent region @DeviceRegionT ps ppr@.-dupDeviceHandle (DeviceHandle openedDevice) = DeviceRegionT $- block $ do liftIO $ incrementRefCnt openedDevice- lift $ DeviceRegionT $ registerOpenedDevice openedDevice--registerOpenedDevice ∷ MonadIO pr1- ⇒ OpenedDevice- → ReaderT (IORef [OpenedDevice])- pr1- (DeviceHandle pr2)-registerOpenedDevice openedDevice = do- openedDevicesIORef ← ask- liftIO $ modifyIORef openedDevicesIORef (openedDevice:)- return $ DeviceHandle openedDevice--{-| A convenience function which opens the given device, applies the given-function to the resulting device handle and runs the resulting region.--Note that: @withDevice dev f = @'runDeviceRegionT'@ $ @'openDevice'@ dev >>= f@--}-withDevice ∷ MonadCatchIO pr- ⇒ USB.Device- → (∀ s. DeviceHandle (DeviceRegionT s pr)- → DeviceRegionT s pr α- ) → pr α-withDevice dev f = runDeviceRegionT $ openDevice dev >>= f---- | Retrieve the device from the device handle.-getDevice ∷ DeviceHandle region → USB.Device-getDevice = USB.getDevice ∘ internalDeviceHandle-------------------------------------------------------------------------------------- * monads-fd instances------------------------------------------------------------------------------------- TODO: Should I also provide monads-tf instances? Can I provide both?--instance MonadError e pr ⇒ MonadError e (DeviceRegionT s pr) where- throwError = lift ∘ throwError- catchError = liftCatch catchError--instance MonadRWS r w st pr ⇒ MonadRWS r w st (DeviceRegionT s pr)--instance MonadReader r pr ⇒ MonadReader r (DeviceRegionT s pr) where- ask = lift ask- local = mapDeviceRegionT ∘ local--instance MonadState st pr ⇒ MonadState st (DeviceRegionT s pr) where- get = lift get- put = lift ∘ put--instance MonadWriter w pr ⇒ MonadWriter w (DeviceRegionT s pr) where- tell = lift ∘ tell- listen = mapDeviceRegionT listen- pass = mapDeviceRegionT pass-------------------------------------------------------------------------------------- * ParentOf-----------------------------------------------------------------------------------{-| The @ParentOf@ class declares the parent/child relationship between regions.--A region is the parent of another region if they're either equivalent like:--@-DeviceRegionT ps parenRegion `ParentOf` DeviceRegionT ps parenRegion-@--or if it is the parent of the parent of the child like:--@-DeviceRegionT ps ppr `ParentOf` DeviceRegionT cs- (DeviceRegionT pcs- (DeviceRegionT ppcs- (DeviceRegionT ps ppr)))-@--}--- Note that to declare this class with multiple parameters I need:--- 'MultiParamTypeClasses'--class (Monad pr, Monad cr) ⇒ pr `ParentOf` cr---- Note that because 'r' apears twice in the instance's head I need:--- 'FlexibleInstances'--instance Monad r ⇒ ParentOf r r---- Note that because the type constructor 'DeviceRegionT' apears in the--- instance's context I need: 'FlexibleContexts' or 'UndecidableInstances'---- And note that because of the type variable 's' and 'pcr' not occuring in the--- instance's head I need: 'UndecidableInstances'--instance ( Monad cr- , cr `TypeCast2` (DeviceRegionT s pcr)- , pr `ParentOf` pcr- )- ⇒ ParentOf pr cr-------------------------------------------------------------------------------------- Type casting------------------------------------------------------------------------------------- Note that to declare these classes with functional dependencies I need:--- 'FunctionalDependencies'--class TypeCast2 (a ∷ * → *) (b ∷ * → *) | a → b, b → a-class TypeCast2' t (a ∷ * → *) (b ∷ * → *) | t a → b, t b → a-class TypeCast2'' t (a ∷ * → *) (b ∷ * → *) | t a → b, t b → a--instance TypeCast2' () a b ⇒ TypeCast2 a b-instance TypeCast2'' t a b ⇒ TypeCast2' t a b-instance TypeCast2'' () a a-------------------------------------------------------------------------------------- * Resetting devices-----------------------------------------------------------------------------------{-| 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.--Note the @pr \`ParentOf\` cr@ which ensures that this function-can be executed in any child region of the region in which the given device-handle was created.--You can only reset a device when all computations passed to 'withConfig' or-'withActiveConfig' have been terminated. If you call @resetDevice@ and such a-computation is still running a 'SettingAlreadySet' exception is thrown.--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.--/TODO: Think about how to handle the implications of the the previous paragraph!/--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.-- * 'SettingAlreadySet' if a configuration has been set using 'withConfig' or- 'withActiveConfig'.-- * Another 'USBException'.--}-resetDevice ∷ (pr `ParentOf` cr, MonadIO cr)- ⇒ DeviceHandle pr → cr ()-resetDevice (DeviceHandle (OpenedDevice devHndlI _ configAlreadySetMVar _)) =- liftIO $ withMVar configAlreadySetMVar $ \configAlreadySet →- if configAlreadySet- then throwIO SettingAlreadySet- else USB.resetDevice devHndlI-------------------------------------------------------------------------------------- * Configurations------------------------------------------------------------------------------------- | A supported configuration of a 'USB.Device' parameterized by the region @r@--- in which it was created.-data Config (r ∷ * → *) = Config (DeviceHandle r) USB.ConfigDesc--{-| Retrieve the supported configurations from the device handle.--Note that the configuration is parameterized by the same region @r@ in which the-device handle was created. This ensures you can never use a configuration-outside that region.--}-getConfigs ∷ DeviceHandle r → [Config r]-getConfigs devHndl = map (Config devHndl)- ∘ getConfigDescs- ∘ internalDeviceHandle- $ devHndl--getConfigDescs ∷ USB.DeviceHandle → [USB.ConfigDesc]-getConfigDescs = USB.deviceConfigs ∘ USB.deviceDesc ∘ USB.getDevice---- | Retrieve the configuration descriptor from the given configuration.-getConfigDesc ∷ Config r → USB.ConfigDesc-getConfigDesc (Config _ configDesc) = configDesc--{-| Duplicate a configuration in the parent region.--Also see: 'dupDeviceHandle'.--}-dupConfig ∷ MonadCatchIO ppr- ⇒ Config (DeviceRegionT cs (DeviceRegionT ps ppr))- -- ^ A configuration created in @DeviceRegionT cs ...@ which- -- must have a parent region @DeviceRegionT ps ppr@.- → DeviceRegionT cs (DeviceRegionT ps ppr)- (Config (DeviceRegionT ps ppr))- -- ^ Yield a computation in @DeviceRegionT cs@ that returns- -- the duplicated configuration that can now be used in the- -- parent region @DeviceRegionT ps ppr@.-dupConfig (Config devHndlC cfg) = do- devHndlP ← dupDeviceHandle devHndlC- return $ Config devHndlP cfg-------------------------------------------------------------------------------------- ** Setting configurations-----------------------------------------------------------------------------------{-| A handle to an active 'Config' parameterized by the region @r@ in which it-was created.--You get a handle to a configuration using 'withConfig' or-'withActiveConfig'. The type variable @sCfg@ is used to ensure that you can't-return this handle from these functions.--}-newtype ConfigHandle sCfg (r ∷ * → *) = ConfigHandle (Config r)--{-| This exception can be thrown in:--* 'resetDevice'--* 'withConfig'--* 'withActiveConfig'--* 'withAlternate'--* 'withActiveAlternate'--to indicate that the device was already configured with a setting.--}-data SettingAlreadySet = SettingAlreadySet deriving (Show, Typeable)--- Note to derive 'Typeable' I need: 'DeriveDataTypeable'--instance Exception SettingAlreadySet--{-| Set the active configuration for a device and then apply the given function-to the resulting configuration handle.--USB devices support multiple configurations of which only one can be active at-any given time. When a configuration is set using 'withConfig' or-'withActiveConfig' no threads can set a new configuration until the computation-passed to these functions terminates. If you do try to set one a-'SettingAlreadySet' exception will be thrown.--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 want to use the current active configuration use 'withActiveConfig'.--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 other applications or drivers have-claimed interfaces.--This is a blocking function.--Exceptions:-- * 'BusyException' if interfaces are currently claimed.-- * 'NoDeviceException' if the device has been disconnected-- * 'SettingAlreadySet' if a configuration has already been set using- 'withConfig' or 'withActiveConfig'.-- * Another 'USBException'.--}-withConfig ∷ (pr `ParentOf` cr, MonadCatchIO cr)- ⇒ Config pr- → (∀ sCfg. ConfigHandle sCfg pr → cr α)- → cr α-withConfig config@(Config- (DeviceHandle- (OpenedDevice devHndlI _ configAlreadySetMVar _))- configDesc) f =- withUnsettedMVar configAlreadySetMVar $ do- liftIO $ USB.setConfig devHndlI $ USB.configValue configDesc- f $ ConfigHandle config--withUnsettedMVar ∷ MonadCatchIO m ⇒ MVar Bool → m α → m α-withUnsettedMVar settingAlreadySetMVar =- bracket_ (liftIO $ do settingAlreadySet ← takeMVar settingAlreadySetMVar- if settingAlreadySet- then do putMVar settingAlreadySetMVar settingAlreadySet- throwIO SettingAlreadySet- else putMVar settingAlreadySetMVar True)- (liftIO $ do _ ← takeMVar settingAlreadySetMVar- putMVar settingAlreadySetMVar False)--{-| This exception can be thrown in 'withActiveConfig' to indicate that the-device is currently not configured.--}-data NoActiveConfig = NoActiveConfig deriving (Show, Typeable)--instance Exception NoActiveConfig--{-| Apply the given function to the configuration handle of the current active-configuration of the given device handle.--This function needs to determine the current active configuration. This-information may be cached by the operating system. If it isn't cached this-function will block while a control transfer is submitted to retrieve the-information.--/TODO: I'm not yet sure if this is the best way of handling already configured devices./-/So this may change in the future!/--Exceptions:-- * 'NoDeviceException' if the device has been disconnected.-- * 'SettingAlreadySet' if a configuration has already been set using- 'withConfig' or 'withActiveConfig'.-- * 'NoActiveConfig' if the device is not configured.-- * Aanother 'USBException'.--}-withActiveConfig ∷ (pr `ParentOf` cr, MonadCatchIO cr)- ⇒ DeviceHandle pr- → (∀ sCfg. ConfigHandle sCfg pr → cr α)- → cr α-withActiveConfig devHndl@(DeviceHandle- (OpenedDevice devHndlI _ configAlreadySetMVar _ )) f =- withUnsettedMVar configAlreadySetMVar $ do- activeConfigDesc ← liftIO $ getActiveConfigDesc devHndlI- f $ ConfigHandle $ Config devHndl activeConfigDesc--getActiveConfigDesc ∷ USB.DeviceHandle → IO USB.ConfigDesc-getActiveConfigDesc devHndlI =- do activeConfigValue ← USB.getConfig devHndlI- when (activeConfigValue ≡ 0) $ throwIO NoActiveConfig- let isActive = (activeConfigValue ≡) ∘ USB.configValue- return $ fromJust $ find isActive $ getConfigDescs devHndlI-------------------------------------------------------------------------------------- * Interfaces-----------------------------------------------------------------------------------{-| A supported interface of a 'Config' parameterized by the region @r@ in which-it was created and the @sCfg@ of the configuration it is derived from.--}-newtype Interface sCfg (r ∷ * → *) = Interface Intrf--data Intrf = Intrf USB.DeviceHandle- USB.InterfaceNumber- USB.Interface- AlternateAlreadySetMVar--{-| Retrieve the supported interfaces from the configuration handle.--Note that the interface is parameterized by the same type variables as the-configuration handle. This ensures you can never use an interface outside the-scope of the function passed to 'withConfig' or 'withActiveConfig'.--}-getInterfaces ∷ ConfigHandle sCfg r → [Interface sCfg r]-getInterfaces (ConfigHandle- (Config- (DeviceHandle- (OpenedDevice devHndlI _ _ alternateAlreadySetMVar))- configDesc)) =- map newInterface $ USB.configInterfaces configDesc- where- newInterface alts = Interface- $ Intrf devHndlI- (USB.interfaceNumber $ head alts)- alts- alternateAlreadySetMVar---- | Retrieve the alternate interface descriptors of the interface.------ Note that: @type 'USB.Interface' = ['USB.InterfaceDesc']@.-getInterfaceDescs ∷ Interface sCfg r → USB.Interface-getInterfaceDescs (Interface (Intrf _ _ alts _)) = alts-------------------------------------------------------------------------------------- ** Claiming and releasing interfaces-----------------------------------------------------------------------------------{-| A handle to a /claimed/ 'Interface' parameterized with the region @r@ in-which it was created.--You get a handle to an interface using 'withInterface'. The type variable-@sIntrf@ is used to ensure that you can't return this handle from this function.--}-newtype InterfaceHandle sIntrf (r ∷ * → *) = InterfaceHandle Intrf--{-| Claim the given interface, then apply the given function to the resulting-interface handle and finally release the interface on exit from the function-wether by normal termination or by raising an exception.--Note that it is allowed to claim an already-claimed interface.--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:-- * 'BusyException' if the interface is already claimed.-- * 'NoDeviceException' if the device has been disconnected.-- * Another 'USBException'.--}-withInterface ∷ (pr `ParentOf` cr, MonadCatchIO cr)- ⇒ Interface sCfg pr- → (∀ sIntrf. InterfaceHandle sIntrf pr → cr α)- → cr α-withInterface (Interface intrf@(Intrf devHndlI ifNum _ _)) f =- bracket_ (liftIO $ USB.claimInterface devHndlI ifNum)- (liftIO $ USB.releaseInterface devHndlI ifNum)- (f $ InterfaceHandle intrf)-------------------------------------------------------------------------------------- * Alternates------------------------------------------------------------------------------------- | A supported 'Interface' alternate setting parameterized by the region @r@--- in which it was created and the @sIntrf@ of the interface it is derived from.-newtype Alternate sIntrf (r ∷ * → *) = Alternate Alt--data Alt = Alt USB.DeviceHandle- USB.InterfaceDesc- AlternateAlreadySetMVar--{-| Retrieve the supported alternate settings from the interface handle.--Note that the alternate setting is parameterized by the same type variables as-the interface handle. This ensures you can never use an alternate setting-outside the scope of the function passed to 'withInterface'.--}-getAlternates ∷ InterfaceHandle sIntrf r → [Alternate sIntrf r]-getAlternates (InterfaceHandle (Intrf devHndlI _ alts alternateAlreadySetMVar)) =- map (\alt → Alternate $ Alt devHndlI alt alternateAlreadySetMVar) alts---- | Retrieve the interface descriptor of this alternate setting.-getInterfaceDesc ∷ Alternate sIntrf r → USB.InterfaceDesc-getInterfaceDesc (Alternate (Alt _ ifDesc _)) = ifDesc-------------------------------------------------------------------------------------- ** Setting alternates-----------------------------------------------------------------------------------{-| A handle to a setted alternate setting parameterized by the region @r@ in-which it was created.--You get a handle to an alternate using 'withAlternate' or-'withActiveAlternate'. The type variable @sAlt@ is used to ensure that you can't-return this handle from these functions.--}-newtype AlternateHandle sAlt (r ∷ * → *) = AlternateHandle Alt--{-| Activate an alternate setting for an interface and then apply the given-function to the resulting alternate handle.--Simillary to configurations, interfaces support multiple alternate settings of-which only one can be active at any given time. When an alternate is set using-'withAlternate' or 'withActiveAlternate' no threads can set a new alternate-until the computation passed to these functions terminates. If you do try to set-one a 'SettingAlreadySet' exception will be thrown.--The operating system may already have set an alternate for the interface. If you-want to use this current active alternate use 'withActiveAlternate'.--This is a blocking function.--Exceptions:-- * 'NoDeviceException' if the device has been disconnected.-- * 'SettingAlreadySet' if an alternate has already been set using- 'withAlternate' or 'withActiveAlternate'.-- * Another 'USBException'.--}-withAlternate ∷ (pr `ParentOf` cr, MonadCatchIO cr)- ⇒ Alternate sIntrf pr- → (∀ sAlt. AlternateHandle sAlt pr → cr α) → cr α-withAlternate (Alternate alt@(Alt devHndlI- ifDesc- alternateAlreadySetMVar- )- ) f =- withUnsettedMVar alternateAlreadySetMVar $ do- liftIO $ USB.setInterfaceAltSetting- devHndlI- (USB.interfaceNumber ifDesc)- (USB.interfaceAltSetting ifDesc)- f $ AlternateHandle alt--{-| Apply the given function to the alternate handle of the current active-alternate of the give interface handle.--To determine the current active alternate this function will block while a-control transfer is submitted to retrieve the information.--/TODO: I'm not yet sure if this is the best way of handling already configured devices./-/So this may change in the future!/--Exceptions:-- * 'NoDeviceException' if the device has been disconnected.-- * 'SettingAlreadySet' if an alternate has already been set using- 'withAlternate' or 'withActiveAlternate'.-- * Aanother 'USBException'.---}-withActiveAlternate ∷ (pr `ParentOf` cr, MonadCatchIO cr)- ⇒ InterfaceHandle sIntrf pr- → (∀ sAlt. AlternateHandle sAlt pr → cr α) → cr α-withActiveAlternate (InterfaceHandle- (Intrf devHndlI ifNum alts alternateAlreadySetMVar)) f =- withUnsettedMVar alternateAlreadySetMVar $ do- activeAltValue ← liftIO $ USB.getInterfaceAltSetting devHndlI ifNum 5000- let isActive = (activeAltValue ≡) ∘ USB.interfaceAltSetting- f $ AlternateHandle $ Alt devHndlI- (fromJust $ find isActive alts)- alternateAlreadySetMVar-------------------------------------------------------------------------------------- * Endpoints------------------------------------------------------------------------------------- | A supported endpoint from an 'Alternate' parameterized by the region @r@ in--- which it was created and the @sAlt@ of the alternate it is derived from.-data Endpoint sAlt (r ∷ * → *) = Endpoint USB.DeviceHandle- USB.EndpointDesc--{-| Retrieve the supported endpoints from the alternate handle.--Note that the endpoint is parameterized by the same type variables as the-alternate handle. This ensures you can never use an endpoint outside the scope-of the function passed to 'withAlternate' or 'withActiveAlternate'.--}-getEndpoints ∷ AlternateHandle sAlt r → [Endpoint sAlt r]-getEndpoints (AlternateHandle (Alt devHndlI ifDesc _)) =- map (Endpoint devHndlI) $ USB.interfaceEndpoints ifDesc-------------------------------------------------------------------------------------- ** Filtering endpoints-----------------------------------------------------------------------------------{-| I/O operations on endpoints are type-safe. You can only read from an-endpoint with an 'In' transfer direction and you can only write to an endpoint-with an 'Out' transfer direction.--Reading and writing also have different implementations for the different-endpoint transfer types like: 'Bulk' and 'Interrupt'. I/O with endpoints of-other transfer types like 'Control' and 'Isochronous' is not possible.--This type lifts the transfer direction and transfer type information to the-type-level so that I/O operations like 'readEndpoint' and 'writeEndpoint' can-specify which endpoints they support.--The reason it is called a @FilteredEndpoint@ is that to create it you have to-/filter/ a list of 'Endpoint's with 'filterEndpoints'.--}-newtype FilteredEndpoint transDir- transType- sAlt (r ∷ * → *) = FilteredEndpoint (Endpoint sAlt r)--{-| The 'Endpoint' type is not rich enough to encode the transfer direction and-transfer type. In order to introduce this type information we have to filter the-list of endpoints and get back a list of filtered endpoints which have the-specified transfer direction and transfer type and also expres this information-in their type.--}-filterEndpoints ∷ ∀ transDir- transType- sAlt r. ( TransferDirection transDir- , TransferType transType- )- ⇒ [Endpoint sAlt r] → [FilteredEndpoint transDir- transType- sAlt r- ]-filterEndpoints = map FilteredEndpoint ∘ filter eqTransDirAndTransType- where- eqTransDirAndTransType (Endpoint _ endpointDesc) =- (undefined ∷ transDir) `eqTransDir` transDirUSB- ∧ (undefined ∷ transType) `eqTransType` transTypeUSB- -- Note that to use the 'transDir' and 'transType' types inside this- -- function you need: 'ScopedTypeVariables'- where- transDirUSB = USB.transferDirection $ USB.endpointAddress endpointDesc- transTypeUSB = USB.endpointAttribs endpointDesc---- | Retrieve the endpoint descriptor from the given endpoint handle.-getEndpointDesc ∷ FilteredEndpoint transDir transType sAlt r- → USB.EndpointDesc-getEndpointDesc (FilteredEndpoint (Endpoint _ endpointDesc)) = endpointDesc--{-| 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:-- * 'NoDeviceException' if the device has been disconnected.-- * Another 'USBException'.--}-clearHalt ∷ (pr `ParentOf` cr, MonadIO cr)- ⇒ FilteredEndpoint transDir transType sAlt pr → cr ()-clearHalt (FilteredEndpoint (Endpoint devHndlI endpointDesc)) =- liftIO $ USB.clearHalt devHndlI $ USB.endpointAddress endpointDesc-------------------------------------------------------------------------------------- *** Transfer directions-----------------------------------------------------------------------------------class TransferDirection transDir where- eqTransDir ∷ transDir → USB.TransferDirection → Bool---- | Out transfer direction (host -> device) used for writing.-data Out; instance TransferDirection Out where eqTransDir _ = (≡ USB.Out)---- | In transfer direction (device -> host) used for reading.-data In; instance TransferDirection In where eqTransDir _ = (≡ USB.In)---- Note that because these data types don't have definitions I need:--- 'EmptyDataDecls'-------------------------------------------------------------------------------------- *** Transfer types-----------------------------------------------------------------------------------class TransferType transType where- eqTransType ∷ transType → USB.TransferType → Bool---- | @Control@ endpoints don't support read and write operations.-data Control--instance TransferType Control where- eqTransType _ = (≡ USB.Control)---- | @Isochronous@ endpoints don't support read and write operations.-data Isochronous--instance TransferType Isochronous where- eqTransType _ (USB.Isochronous _ _) = True- eqTransType _ _ = False---- | @Bulk@ endpoints support read and write operations.-data Bulk--instance TransferType Bulk where- eqTransType _ = (≡ USB.Bulk)---- | @Interrupt@ endpoints support read and write operations.-data Interrupt--instance TransferType Interrupt where- eqTransType _ = (≡ USB.Interrupt)-------------------------------------------------------------------------------------- * Endpoint I/O-----------------------------------------------------------------------------------{-| Handy type synonym for read transfers.--A @ReadAction@ is a function which takes a timeout and a size which defines how-many bytes to read. The function returns an action which, when executed,-performs the actual read and returns the bytestring that was read paired with an-indication if the transfer timed out.--}-type ReadAction r = USB.Timeout → USB.Size → r (ByteString, Bool)--{-| Class of transfer types that support reading.--(Only 'Bulk' and 'Interrupt' transfer types are supported.)--}-class TransferType transType => ReadEndpoint transType where- -- | Read bytes from an 'In' endpoint.- readEndpoint ∷ (pr `ParentOf` cr, MonadIO cr)- ⇒ FilteredEndpoint In transType sAlt pr → ReadAction cr--instance ReadEndpoint Bulk where- readEndpoint = readEndpointWith USB.readBulk--instance ReadEndpoint Interrupt where- readEndpoint = readEndpointWith USB.readInterrupt--readEndpointWith ∷ (pr `ParentOf` cr, MonadIO cr)- ⇒ (USB.DeviceHandle → USB.EndpointAddress → USB.ReadAction)- → FilteredEndpoint In transType sAlt pr → ReadAction cr-readEndpointWith f (FilteredEndpoint (Endpoint devHndlI endpointDesc)) =- \timeout size → liftIO $ f devHndlI- (USB.endpointAddress endpointDesc)- timeout- size------------------------------------------------------------------------------------{-| Handy type synonym for write transfers.--A @WriteAction@ is a function which takes a timeout and the bytestring to-write. The function returns an action which, when exectued, returns the number-of bytes that were actually written paired with an indication if the transfer-timed out.--}-type WriteAction r = USB.Timeout → ByteString → r (USB.Size, Bool)--{-| Class of transfer types that support writing--(Only 'Bulk' and 'Interrupt' transfer types are supported.)--}-class TransferType transType => WriteEndpoint transType where- -- | Write bytes to an 'Out' endpoint.- writeEndpoint ∷ (pr `ParentOf` cr, MonadIO cr)- ⇒ FilteredEndpoint Out transType sAlt pr → WriteAction cr--instance WriteEndpoint Bulk where- writeEndpoint = writeEndpointWith USB.writeBulk--instance WriteEndpoint Interrupt where- writeEndpoint = writeEndpointWith USB.writeInterrupt--writeEndpointWith ∷ (pr `ParentOf` cr, MonadIO cr)- ⇒ (USB.DeviceHandle → USB.EndpointAddress → USB.WriteAction)- → FilteredEndpoint Out transType sAlt pr → WriteAction cr-writeEndpointWith f (FilteredEndpoint (Endpoint devHndlI endpointDesc)) =- \timeout bs → liftIO $ f devHndlI- (USB.endpointAddress endpointDesc)- timeout- bs------------------------------------------------------------------------------------- ** Control transfers-----------------------------------------------------------------------------------{-| Control transfers can have three request types: @Standard@, @Class@ and-@Vendor@. We disallow @Standard@ requests however because with them you can-destroy the safety guarantees that this module provides.--}-data RequestType = Class | Vendor--reqTypeToInternal ∷ RequestType → USB.RequestType-reqTypeToInternal Class = USB.Class-reqTypeToInternal Vendor = USB.Vendor--{-| Perform a USB /control/ request that does not transfer data.--The /value/ and /index/ values should be given in host-endian byte order.--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 ∷ (pr `ParentOf` cr, MonadIO cr)- ⇒ DeviceHandle pr -- ^ A handle for the device to communicate with.- → RequestType -- ^ The type of request.- → USB.Recipient -- ^ The recipient of the request.- → Word8 -- ^ Request.- → Word16 -- ^ Value.- → Word16 -- ^ Index.- → USB.Timeout -- ^ Timeout (in milliseconds) that this function should- -- wait before giving up due to no response being- -- received. For no timeout, use value 0.- → cr ()-control devHndl reqType reqRecipient request value index timeout =- liftIO $ USB.control (internalDeviceHandle devHndl)- (reqTypeToInternal reqType)- reqRecipient- request- value- index- timeout--{-| Perform a USB /control/ read.--The /value/ and /index/ values should be given in host-endian byte order.--Exceptions:-- * 'PipeException' if the control request was not supported by the device-- * 'NoDeviceException' if the device has been disconnected.-- * Another 'USBException'.--}-readControl ∷ (pr `ParentOf` cr, MonadIO cr)- ⇒ DeviceHandle pr -- ^ A handle for the device to communicate with.- → RequestType -- ^ The type of request.- → USB.Recipient -- ^ The recipient of the request.- → Word8 -- ^ Request.- → Word16 -- ^ Value.- → Word16 -- ^ Index.- → ReadAction cr-readControl devHndl reqType reqRecipient request value index = \timeout size →- liftIO $ USB.readControl (internalDeviceHandle devHndl)- (reqTypeToInternal reqType)- reqRecipient- request- value- index- timeout- size--{-| Perform a USB /control/ write.--The /value/ and /index/ values should be given in host-endian byte order.--Exceptions:-- * 'PipeException' if the control request was not supported by the device-- * 'NoDeviceException' if the device has been disconnected.-- * Another 'USBException'.--}-writeControl ∷ (pr `ParentOf` cr, MonadIO cr)- ⇒ DeviceHandle pr -- ^ A handle for the device to communicate with.- → RequestType -- ^ The type of request.- → USB.Recipient -- ^ The recipient of the request.- → Word8 -- ^ Request.- → Word16 -- ^ Value.- → Word16 -- ^ Index.- → WriteAction cr-writeControl devHndl reqType reqRecipient request value index = \timeout input →- liftIO $ USB.writeControl (internalDeviceHandle devHndl)- (reqTypeToInternal reqType)- reqRecipient- request- value- index- timeout- input-------------------------------------------------------------------------------------- *** Standard Device Requests-----------------------------------------------------------------------------------{- TODO: Think about which of these to export:--setHalt ∷ DeviceHandle → EndpointAddress → Timeout → IO ()--clearRemoteWakeup ∷ DeviceHandle → Timeout → IO ()--setRemoteWakeup ∷ DeviceHandle → Timeout → IO ()--setStandardTestMode ∷ DeviceHandle → TestMode → Timeout → IO ()--getInterfaceAltSetting ∷ DeviceHandle- → InterfaceNumber- → Timeout- → IO InterfaceAltSetting--getDeviceStatus ∷ DeviceHandle → Timeout → IO DeviceStatus--getEndpointStatus ∷ DeviceHandle- → EndpointAddress- → Timeout- → IO Bool--setDeviceAddress ∷ DeviceHandle → Word16 → Timeout → IO ()--synchFrame ∷ DeviceHandle → EndpointAddress → Timeout → IO Int--}------------------------------------------------------------------------------------- * String descriptors-----------------------------------------------------------------------------------{-| Retrieve a list of supported languages.--This function may throw 'USBException's.--}-getLanguages ∷ (pr `ParentOf` cr, MonadIO cr)- ⇒ DeviceHandle pr → cr [USB.LangId]-getLanguages devHndl =- liftIO $ USB.getLanguages (internalDeviceHandle devHndl)--{-| Retrieve a string descriptor from a device.--This is a convenience function which formulates the appropriate control message-to retrieve the descriptor. The string returned is Unicode, as detailed in the-USB specifications.--This function may throw 'USBException's.--/TODO: The following can be made more type-safe!/--When I call 'getStrDesc' I would like the type system to guarantee that the-given @StrIx@ and @LangId@ actually belong to the given @DeviceHandle@. In other-words I would like to get a type error when they are some arbitrary number or-come from another device.--}-getStrDesc ∷ (pr `ParentOf` cr, MonadIO cr)- ⇒ DeviceHandle pr → USB.StrIx → USB.LangId → USB.Size → cr String-getStrDesc devHndl strIx langId size =- liftIO $ USB.getStrDesc (internalDeviceHandle devHndl)- strIx- langId- size--{-| Retrieve a string descriptor from a device using the first supported-language.--This is a convenience function which formulates the appropriate control message-to retrieve the descriptor. The string returned is Unicode, as detailed in the-USB specifications.--This function may throw 'USBException's.--}-getStrDescFirstLang ∷ (pr `ParentOf` cr, MonadIO cr)- ⇒ DeviceHandle pr → USB.StrIx → USB.Size → cr String-getStrDescFirstLang devHndl descStrIx size =- liftIO $ USB.getStrDescFirstLang (internalDeviceHandle devHndl)- descStrIx- size-------------------------------------------------------------------------------------- * 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 ∷ (pr `ParentOf` cr, MonadIO cr)- ⇒ DeviceHandle pr → USB.InterfaceNumber → cr Bool-kernelDriverActive devHndl =- liftIO ∘ USB.kernelDriverActive (internalDeviceHandle devHndl)--{-| 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 ∷ (pr `ParentOf` cr, MonadIO cr)- ⇒ DeviceHandle pr → USB.InterfaceNumber → cr ()-detachKernelDriver devHndl =- liftIO ∘ USB.detachKernelDriver (internalDeviceHandle devHndl)--{-| 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 ∷ (pr `ParentOf` cr, MonadIO cr)- ⇒ DeviceHandle pr → USB.InterfaceNumber → cr ()-attachKernelDriver devHndl =- liftIO ∘ USB.attachKernelDriver (internalDeviceHandle devHndl)--{-| 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 ∷ (pr `ParentOf` cr, MonadCatchIO cr)- ⇒ DeviceHandle pr → USB.InterfaceNumber → cr α → cr α-withDetachedKernelDriver devHndl ifNum action =- ifM (kernelDriverActive devHndl ifNum)- (bracket_ (detachKernelDriver devHndl ifNum)- (attachKernelDriver devHndl ifNum)+{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}++-------------------------------------------------------------------------------+-- |+-- Module : System.USB.Safe+-- Copyright : (c) 2009 Bas van Dijk+-- License : BSD3 (see the file LICENSE)+-- Maintainer : Bas van Dijk <v.dijk.bas@gmail.com>+--+-- This modules provides the following guarantees for working with USB devices:+--+-- * You can't reference handles to devices that are closed. In other words: no+-- I/O with closed handles is possible.+--+-- * The programmer can specify the /region/ in which devices should remain+-- open. On exit from the region the opened devices will be closed+-- automatically.+--+-- * You can't reference handles to configurations that have not been set.+--+-- * You can't reference handles to interfaces that have not been claimed.+--+-- * Just like with devices, the programmer can specify the region in which+-- interfaces should remain claimed. On exit from the region the claimed+-- interfaces will be released automatically.+--+-- * You can't reference handles to alternates that have not been set.+--+-- * You can't reference endpoints that don't belong to a setted alternate.+--+-- * You can't read from an endpoint with an 'Out' transfer direction.+--+-- * You can't write to an endpoint with an 'In' transfer direction.+--+-- * You can't read from or write to endpoints with the unsupported transfer+-- types 'Control' and 'Isochronous'. Only I/O with endpoints with the+-- supported 'Bulk' and 'Interrupt' transfer types is allowed.+--+-- This modules makes use of a technique called /Lightweight monadic regions/+-- invented by Oleg Kiselyov and Chung-chieh Shan+--+-- See: <http://okmij.org/ftp/Haskell/regions.html#light-weight>+--+-- This technique is implemented in the @regions@ package of which the+-- @Control.Monad.Trans.Region@ module is re-exported by this module.+--+-- See the @usb-safe-examples@ package for examples how to use this library:+--+-- @darcs get@ <http://code.haskell.org/~basvandijk/code/usb-safe-examples>+--+--------------------------------------------------------------------------------++module System.USB.Safe+ ( -- * Device regions+ module Control.Monad.Trans.Region+ , DeviceRegionT+ , TopDeviceRegion++ -- ** Regional device handles+ , RegionalDeviceHandle+ , getDevice++ -- * Getting descriptors+ , GetDescriptor+ , getDesc++ -- * Resetting devices+ , resetDevice++ -- * Configurations+ , Config+ , getConfigs++ -- ** Setting configurations+ , ConfigHandle+ , setConfig, SettingAlreadySet+ , useActiveConfig, NoActiveConfig+ , setConfigWhich, NotFound++ -- * Interfaces+ , Interface+ , getInterfaces++ -- ** Claiming interfaces+ , IfRegionT+ , RegionalIfHandle+ , claim++ -- * Alternates+ , Alternate+ , getAlternates++ -- ** Setting alternates+ , AlternateHandle+ , setAlternate+ , useActiveAlternate+ , setAlternateWhich++ -- * Endpoints+ , Endpoint+ , getEndpoints++ , clearHalt++ -- *** Transfer directions+ , TransferDirection(..)+ , OUT+ , IN++ -- *** Transfer types+ , TransferType(..)+ , CONTROL+ , ISOCHRONOUS+ , BULK+ , INTERRUPT++ -- * Endpoint I/O+ , ReadAction+ , WriteAction+ , readEndpoint+ , writeEndpoint++ -- ** Control transfers+ , RequestType(..)+ , control+ , readControl+ , writeControl++ -- * String descriptors+ , getLanguages+ , getStrDesc+ , getStrDescFirstLang++ -- * USB kernel drivers+ , kernelDriverActive+ , detachKernelDriver+ , attachKernelDriver+ , withDetachedKernelDriver+ ) where+++--------------------------------------------------------------------------------+-- Imports+--------------------------------------------------------------------------------++-- from base:+import Control.Concurrent.MVar ( MVar, newMVar, takeMVar, putMVar, withMVar)++import Control.Monad ( when, liftM2 )++import Control.Exception ( Exception, throwIO )+import Data.Typeable ( Typeable )++import Data.Word ( Word8, Word16 )+import Data.List ( filter, find )+import Data.Maybe ( fromJust )++-- from bytestring:+import Data.ByteString ( ByteString )++-- from transformers:+import Control.Monad.Trans ( MonadIO, liftIO )++-- from MonadCatchIO-transformers:+import Control.Monad.CatchIO ( MonadCatchIO, bracket_, throw )+-- from unicode-symbols:+import Prelude.Unicode ( (∘), (≡), (∧) )++-- from usb:+import qualified System.USB.Enumeration as USB ( Device, deviceDesc )+import qualified System.USB.DeviceHandling as USB ( DeviceHandle+ , openDevice, closeDevice+ , getDevice++ , getConfig, setConfig++ , InterfaceNumber+ , claimInterface+ , releaseInterface++ , setInterfaceAltSetting++ , clearHalt+ , resetDevice++ , kernelDriverActive+ , detachKernelDriver+ , attachKernelDriver+ )+import qualified System.USB.Descriptors as USB ( DeviceDesc+ , deviceConfigs++ , ConfigDesc+ , configValue+ , configInterfaces++ , Interface++ , InterfaceDesc+ , interfaceNumber+ , interfaceAltSetting+ , interfaceEndpoints++ , EndpointDesc+ , endpointAddress+ , endpointAttribs++ , EndpointAddress+ , transferDirection++ , TransferDirection(In, Out)+ , TransferType( Control+ , Isochronous+ , Bulk+ , Interrupt+ )++ , getLanguages+ , LangId+ , StrIx+ , getStrDesc+ , getStrDescFirstLang+ )+import qualified System.USB.IO.Synchronous as USB ( Timeout, Size++ , RequestType(Class, Vendor)+ , Recipient++ , control+ , readControl, writeControl++ , getInterfaceAltSetting++ , readBulk, readInterrupt+ , writeBulk, writeInterrupt+ )+-- from regions:+import Control.Monad.Trans.Region++import Control.Monad.Trans.Region.Internal ( Resource+ , Handle+ , openResource+ , closeResource++ , internalHandle++ , Dup++ , ParentOf+ )++--------------------------------------------------------------------------------+-- * Device regions+--------------------------------------------------------------------------------++instance Resource USB.Device where++ data Handle USB.Device = DeviceHandle+ { internalDevHndl ∷ USB.DeviceHandle+ , configAlreadySetMVar ∷ MVar Bool+ -- ^ A mutable shared variable which keeps track of wheter a+ -- configuration has been set. See: 'setConfig'.+ }++ openResource dev = liftM2 DeviceHandle (USB.openDevice dev)+ (newMVar False)++ closeResource = USB.closeDevice ∘ internalDevHndl++getInternalDevHndl ∷ RegionalDeviceHandle r → USB.DeviceHandle+getInternalDevHndl = internalDevHndl ∘ internalHandle++{-| Handy type synonym for a region in which USB devices can be opened which are+automatically closed when the region terminates.++You can run a device region with 'runRegionT'.+-}+type DeviceRegionT s pr α = RegionT USB.Device s pr α++{-| Handy type synonym for a device region which has 'IO' as its parent region+which enables it to be:++ * directly executed in 'IO' using 'runTopRegion',++ * concurrently executed in a new thread by 'forkTopRegion'.+-}+type TopDeviceRegion s α = TopRegion USB.Device s α++--------------------------------------------------------------------------------+-- ** Regional device handles+--------------------------------------------------------------------------------++{-| Handy type synonym for a regional handle to an opened USB device.++A regional handle to an opened USB device can be created by applying 'open' or+'with' to the USB device you wish to open.++Note that you can also /duplicate/ a regional device handle by applying 'dup' to+it.+-}+type RegionalDeviceHandle r = RegionalHandle USB.Device r++-- | Convenience function for retrieving the device from the given regional+-- handle.+getDevice ∷ RegionalDeviceHandle r → USB.Device+getDevice = USB.getDevice ∘ getInternalDevHndl+++--------------------------------------------------------------------------------+-- * Getting descriptors+--------------------------------------------------------------------------------++class GetDescriptor α desc | α → desc, desc → α where+ -- | Get the descriptor of a given USB entity.+ getDesc ∷ α → desc++instance GetDescriptor USB.Device USB.DeviceDesc where+ getDesc = USB.deviceDesc+++--------------------------------------------------------------------------------+-- * Resetting devices+--------------------------------------------------------------------------------++{-| 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.++Note the constraint: @pr \`ParentOf\` cr@. This allows this function to be+executed in any child region @cr@ of the parent region @pr@ in which the given+regional handle was created.++You can only reset a device when all computations passed to 'setConfig',+'useActiveConfig' and 'setConfigWhich' have been terminated. If you call+@resetDevice@ and such a computation is still running a 'SettingAlreadySet'+exception is thrown.++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.++/TODO: Think about how to handle the implications of the the previous paragraph!/++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.++ * 'SettingAlreadySet' if a configuration has been set using 'setConfig',+ 'useActiveConfig' and 'setConfigWhich'.++ * Another 'USBException'.+-}+resetDevice ∷ (pr `ParentOf` cr, MonadIO cr)+ ⇒ RegionalDeviceHandle pr → cr ()+resetDevice (internalHandle → DeviceHandle { internalDevHndl+ , configAlreadySetMVar+ }) =+ liftIO $ withMVar configAlreadySetMVar $ \configAlreadySet →+ if configAlreadySet+ then throwIO SettingAlreadySet+ else USB.resetDevice internalDevHndl+++--------------------------------------------------------------------------------+-- * Configurations+--------------------------------------------------------------------------------++{-| A supported configuration of a USB device parameterized by the region @r@ in+which it was created.++Note that, just like a regional device handle, a configuration can be duplicated+to a parent region using 'dup'.+-}+data Config (r ∷ * → *) = Config (RegionalDeviceHandle r)+ USB.ConfigDesc++{-| Retrieve the supported configurations from the given regional handle.++Note that the configuration is parameterized by the same region @r@ in which the+regional handle was created. This ensures you can never use a configuration+outside that region.+-}+getConfigs ∷ RegionalDeviceHandle r → [Config r]+getConfigs regionalDevHndl = map (Config regionalDevHndl)+ ∘ getConfigDescs+ ∘ getInternalDevHndl+ $ regionalDevHndl++getConfigDescs ∷ USB.DeviceHandle → [USB.ConfigDesc]+getConfigDescs = USB.deviceConfigs ∘ USB.deviceDesc ∘ USB.getDevice++instance GetDescriptor (Config r) USB.ConfigDesc where+ getDesc (Config _ configDesc) = configDesc++instance Dup Config USB.Device where+ dup (Config regionalDevHndlC configDesc) = do+ regionalDevHndlP ← dup regionalDevHndlC+ return $ Config regionalDevHndlP configDesc+++--------------------------------------------------------------------------------+-- ** Setting configurations+--------------------------------------------------------------------------------++{-| A handle to an active 'Config' which you can get using: 'setConfig',+'useActiveConfig' or 'setConfigWhich'. The type variable @sCfg@ is used to+ensure that you can't return this handle from these functions.+-}+data ConfigHandle sCfg = ConfigHandle (Handle USB.Device)+ USB.ConfigDesc++{-| Set the active configuration for a device and then apply the given function+to the resulting configuration handle.++USB devices support multiple configurations of which only one can be active at+any given time. When a configuration is set using 'setConfig', 'useActiveConfig'+or 'setConfigWhich' no threads can set a new configuration until the computation+passed to these functions terminates. If you do try to set one a+'SettingAlreadySet' exception will be thrown.++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 want to use the current active configuration use 'useActiveConfig'.++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 other applications or drivers have+claimed interfaces.++This is a blocking function.++Exceptions:++ * 'BusyException' if interfaces are currently claimed.++ * 'NoDeviceException' if the device has been disconnected++ * 'SettingAlreadySet' if a configuration has already been set using+ 'setConfig', 'useActiveConfig' or 'setConfigWhich'.++ * Another 'USBException'.+-}+setConfig ∷ (pr `ParentOf` cr, MonadCatchIO cr)+ ⇒ Config pr -- ^ The configuration you wish to set.+ → (∀ sCfg. ConfigHandle sCfg → cr α) -- ^ Continuation function.+ → cr α+setConfig (Config (internalHandle → devHndl@(DeviceHandle internalDevHndl+ configAlreadySetMVar))+ configDesc+ ) f =+ withUnsettedMVar configAlreadySetMVar $ do+ liftIO $ USB.setConfig internalDevHndl $ USB.configValue configDesc+ f $ ConfigHandle devHndl configDesc++-- | If the given @MVar@ was set a 'SettingAlreadySet' exception will be+-- thrown. If not it will be set before the given computation will be performed.+withUnsettedMVar ∷ MonadCatchIO m ⇒ MVar Bool → m α → m α+withUnsettedMVar settingAlreadySetMVar =+ bracket_ (liftIO $ do settingAlreadySet ← takeMVar settingAlreadySetMVar+ if settingAlreadySet+ then do putMVar settingAlreadySetMVar settingAlreadySet+ throwIO SettingAlreadySet+ else putMVar settingAlreadySetMVar True)+ (liftIO $ do _ ← takeMVar settingAlreadySetMVar+ putMVar settingAlreadySetMVar False)++{-| This exception can be thrown in:++* 'resetDevice'++* 'setConfig', 'useActiveConfig' or 'setConfigWhich'++* 'setAlternate', 'useActiveAlternate' or 'setAlternateWhich'++to indicate that the device was already configured with a setting.+-}+data SettingAlreadySet = SettingAlreadySet deriving (Show, Typeable)++instance Exception SettingAlreadySet++{-| Apply the given function to the configuration handle of the current active+configuration of the given device handle.++This function needs to determine the current active configuration. This+information may be cached by the operating system. If it isn't cached this+function will block while a control transfer is submitted to retrieve the+information.++Exceptions:++ * 'NoDeviceException' if the device has been disconnected.++ * 'SettingAlreadySet' if a configuration has already been set using+ 'setConfig', 'useActiveConfig' or 'setConfigWhich'.++ * 'NoActiveConfig' if the device is not configured.++ * Aanother 'USBException'.+-}+useActiveConfig ∷ (pr `ParentOf` cr, MonadCatchIO cr)+ ⇒ RegionalDeviceHandle pr -- ^ Regional handle to the device+ -- from which you want to use the+ -- active configuration.+ → (∀ sCfg. ConfigHandle sCfg → cr α) -- ^ Continuation function+ → cr α+useActiveConfig (internalHandle → devHndl@(DeviceHandle { internalDevHndl+ , configAlreadySetMVar+ })+ ) f =+ withUnsettedMVar configAlreadySetMVar $ do+ activeConfigValue ← liftIO $ USB.getConfig internalDevHndl+ when (activeConfigValue ≡ 0) $ throw NoActiveConfig+ let activeConfigDesc = fromJust $ find isActive $ getConfigDescs internalDevHndl+ isActive = (activeConfigValue ≡) ∘ USB.configValue+ f $ ConfigHandle devHndl activeConfigDesc++{-| This exception can be thrown in 'useActiveConfig' to indicate that the+device is currently not configured.+-}+data NoActiveConfig = NoActiveConfig deriving (Show, Typeable)++instance Exception NoActiveConfig++{-| Convenience function which finds the first configuration of the given device+handle which satisfies the given predicate on its descriptor, then sets that+configuration and applies the given function to the resulting configuration+handle.++This function calls 'setConfig' so do see its documentation.++Exceptions:++ * 'NotFound' if no configuration is found that satisfies the given+ predicate.++ * 'BusyException' if interfaces are currently claimed.++ * 'NoDeviceException' if the device has been disconnected++ * 'SettingAlreadySet' if a configuration has already been set using+ 'setConfig', 'useActiveConfig' or 'setConfigWhich'.++ * Another 'USBException'.+-}+setConfigWhich ∷ (pr `ParentOf` cr, MonadCatchIO cr)+ ⇒ RegionalDeviceHandle pr -- ^ Regional handle to the device for+ -- which you want to set a+ -- configuration.+ → (USB.ConfigDesc → Bool) -- ^ Predicate on the configuration+ -- descriptor.+ → (∀ sCfg. ConfigHandle sCfg → cr α) -- ^ Continuation function.+ → cr α+setConfigWhich regionalDevHndl p f =+ case find (p ∘ getDesc) $ getConfigs regionalDevHndl of+ Nothing → throw NotFound+ Just config → setConfig config f++-- | This exception will be thrown in 'setConfigWhich' or 'setAlternateWhich' to+-- indicate that no setting was found which satisfies the given predicate.+data NotFound = NotFound deriving (Show, Typeable)++instance Exception NotFound+++--------------------------------------------------------------------------------+-- * Interfaces+--------------------------------------------------------------------------------++{-| A supported interface of a configuration which you can retrieve using+ 'getInterfaces'.++To retrieve the 'USB.Interface' descriptors of an interface use 'getDesc'.+-}+data Interface sCfg = Interface { ifDevHndlI ∷ USB.DeviceHandle+ , ifNum ∷ USB.InterfaceNumber+ , ifDescs ∷ USB.Interface+ }++{-| Retrieve the supported interfaces from the configuration handle.++Note that the interface is parameterized by the @sCfg@ of the configuration+handle it is derived from. This ensures that it can never be returned from the+functions that created this configuration handle: 'setConfig', 'useActiveConfig'+and 'setConfigWhich'.++The latter is useful because outside those functions the active configuration+may change. If at that moment you still have an interface of the old+configuration claiming it would be an error.+-}+getInterfaces ∷ ConfigHandle sCfg → [Interface sCfg]+getInterfaces (ConfigHandle (DeviceHandle {internalDevHndl}) configDesc) =+ map newInterface $ USB.configInterfaces configDesc+ where+ newInterface alts = Interface internalDevHndl+ (USB.interfaceNumber $ head alts)+ alts++instance GetDescriptor (Interface sCfg) USB.Interface where+ getDesc = ifDescs+++--------------------------------------------------------------------------------+-- ** Interface regions+--------------------------------------------------------------------------------++instance Resource (Interface sCfg) where++ data Handle (Interface sCfg) = InterfaceHandle+ { interface ∷ Interface sCfg+ , alternateAlreadySetMVar ∷ MVar Bool+ -- ^ A mutable shared variable which keeps track of wheter an+ -- alternate has been set. See: 'setAlternate'.+ }++ openResource (Interface {ifDevHndlI, ifNum, ifDescs}) = do+ USB.claimInterface ifDevHndlI ifNum+ alternateAlreadySetMVar ← newMVar False+ return $ InterfaceHandle (Interface ifDevHndlI+ ifNum+ ifDescs+ )+ alternateAlreadySetMVar++ closeResource (interface → Interface {ifDevHndlI, ifNum}) =+ USB.releaseInterface ifDevHndlI ifNum++{-| Handy type synonym for a region in which interfaces can be claimed which are+automatically released when the region terminates.++You can run an interface region with 'runRegionT'.+-}+type IfRegionT sCfg s pr α = RegionT (Interface sCfg) s pr α++{-| Handy type synonym for a regional handle to a claimed interface.++A regional handle to a claimed interface can be created by applying 'claim' or+'with' to the interface you wish to claim.+-}+type RegionalIfHandle sCfg r = RegionalHandle (Interface sCfg) r++{-| Claim the given interface in the interface region.++Note that: @claim = @'open' which just reads better when applied to an+interface.++Note that it is allowed to claim an already-claimed interface.++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:++ * 'BusyException' if the interface is already claimed.++ * 'NoDeviceException' if the device has been disconnected.++ * Another 'USBException'.+-}+claim ∷ MonadCatchIO pr+ ⇒ Interface sCfg -- ^ Interface you wish to claim+ → IfRegionT sCfg s pr+ (RegionalIfHandle sCfg+ (RegionT (Interface sCfg) s pr))+claim = open++{-| Convenience function which finds the first interfaces of the given+configuration handle which satisfies the given predicate on its descriptor, then+claims that interfaces and applies the given function on the resulting regional+handle.+-}+withInterfaceWhich ∷ MonadCatchIO pr+ ⇒ ConfigHandle sCfg+ → (USB.Interface → Bool)+ → (∀ s. RegionalIfHandle sCfg (RegionT (Interface sCfg) s pr)+ → IfRegionT sCfg s pr α+ )+ → pr α+withInterfaceWhich confHndl p f =+ case find (p ∘ getDesc) $ getInterfaces confHndl of+ Nothing → throw NotFound+ Just intrf → with intrf f++--------------------------------------------------------------------------------+-- * Alternates+--------------------------------------------------------------------------------++-- | A supported 'Interface' alternate setting.+data Alternate sCfg (r ∷ * → *) = Alternate (RegionalIfHandle sCfg r)+ USB.InterfaceDesc++{-| Retrieve the supported alternate settings from the interface handle.++Note that the alternate setting is parameterized by the same type variables as+the interface handle. This ensures you can never use an alternate setting+outside the region in which the interface handle was created.+-}+getAlternates ∷ RegionalIfHandle sCfg r → [Alternate sCfg r]+getAlternates regionalIfHandle@(internalHandle+ → (interface → Interface {ifDescs})) =+ map (Alternate regionalIfHandle) ifDescs++instance GetDescriptor (Alternate sIntrf r) USB.InterfaceDesc where+ getDesc (Alternate _ ifDesc) = ifDesc++instance Dup (Alternate sCfg) (Interface sCfg) where+ dup (Alternate regionalIfHndlC ifDesc) = do+ regionalIfHndlP ← dup regionalIfHndlC+ return $ Alternate regionalIfHndlP ifDesc+++--------------------------------------------------------------------------------+-- ** Setting alternates+--------------------------------------------------------------------------------++{-| A handle to a setted alternate setting.++You get a handle to an alternate using 'setAlternate', 'useActiveAlternate' or+'setAlternateWhich'. The type variable @sAlt@ is used to ensure that you can't+return this handle from these functions.+-}+data AlternateHandle sCfg sAlt (r ∷ * → *) = AlternateHandle+ (Handle (Interface sCfg))+ USB.InterfaceDesc++{-| Activate an alternate setting for an interface and then apply the given+function to the resulting alternate handle.++Simillary to configurations, interfaces support multiple alternate settings of+which only one can be active at any given time. When an alternate is set using+'setAlternate', 'useActiveAlternate' or 'setAlternateWhich' no threads can set a+new alternate until the computation passed to these functions terminates. If you+do try to set one a 'SettingAlreadySet' exception will be thrown.++The operating system may already have set an alternate for the interface. If you+want to use this current active alternate use 'useActiveAlternate'.++This is a blocking function.++Exceptions:++ * 'NoDeviceException' if the device has been disconnected.++ * 'SettingAlreadySet' if an alternate has already been set using+ 'setAlternate', 'useActiveAlternate' or 'setAlternateWhich'.++ * Another 'USBException'.+-}+setAlternate ∷ (pr `ParentOf` cr, MonadCatchIO cr)+ ⇒ Alternate sCfg pr -- ^ The alternate you wish to set.+ → (∀ sAlt. AlternateHandle sCfg sAlt pr → cr α)+ -- ^ Continuation function.+ → cr α+setAlternate (Alternate ( internalHandle+ → ifHndl@(InterfaceHandle (Interface {ifDevHndlI})+ alternateAlreadySetMVar+ )+ )+ ifDesc+ ) f =+ withUnsettedMVar alternateAlreadySetMVar $ do+ liftIO $ USB.setInterfaceAltSetting+ ifDevHndlI+ (USB.interfaceNumber ifDesc)+ (USB.interfaceAltSetting ifDesc)+ f $ AlternateHandle ifHndl ifDesc+++{-| Apply the given function to the alternate handle of the current active+alternate of the give interface handle.++To determine the current active alternate this function will block while a+control transfer is submitted to retrieve the information.++Exceptions:++ * 'NoDeviceException' if the device has been disconnected.++ * 'SettingAlreadySet' if an alternate has already been set using+ 'setAlternate', 'useActiveAlternate' or 'setAlternateWhich'.++ * Aanother 'USBException'.++-}+useActiveAlternate ∷ (pr `ParentOf` cr, MonadCatchIO cr)+ ⇒ RegionalIfHandle sCfg pr -- ^ Regional handle to the+ -- interface from which you want+ -- to use the active alternate.+ → (∀ sAlt. AlternateHandle sCfg sAlt pr → cr α)+ -- ^ Continuation function.+ → cr α+useActiveAlternate (internalHandle → ifHndl@(InterfaceHandle+ (Interface { ifDevHndlI+ , ifNum+ , ifDescs+ }+ )+ alternateAlreadySetMVar+ )+ ) f =+ withUnsettedMVar alternateAlreadySetMVar $ do+ let timeout = 5000 -- ms+ activeAltValue ← liftIO $ USB.getInterfaceAltSetting ifDevHndlI+ ifNum+ timeout+ let activeAlt = fromJust $ find isActive ifDescs+ isActive = (activeAltValue ≡) ∘ USB.interfaceAltSetting+ f $ AlternateHandle ifHndl activeAlt+++{-| Convenience function which finds the first alternate of the given interface+handle which satisfies the given predicate on its descriptor, then sets that+alternate and applies the given function to the resulting alternate handle.++This function calls 'setAlternate' so do see its documentation.++Exceptions:++ * 'NotFound' if no alternate is found that satisfies the given+ predicate.++ * 'NoDeviceException' if the device has been disconnected.++ * 'SettingAlreadySet' if an alternate has already been set using+ 'setAlternate', 'useActiveAlternate' or 'setAlternateWhich'.++ * Another 'USBException'.+-}+setAlternateWhich ∷ (pr `ParentOf` cr, MonadCatchIO cr)+ ⇒ RegionalIfHandle sCfg pr -- ^ Regional handle to the+ -- interface for which you want+ -- to set an alternate.+ → (USB.InterfaceDesc → Bool) -- ^ Predicate on the interface+ -- descriptor.+ → (∀ sAlt. AlternateHandle sCfg sAlt pr → cr α)+ -- ^ Continuation function+ → cr α+setAlternateWhich regionalIfHndl p f =+ case find (p ∘ getDesc) $ getAlternates regionalIfHndl of+ Nothing → throw NotFound+ Just alt → setAlternate alt f+++--------------------------------------------------------------------------------+-- * Endpoints+--------------------------------------------------------------------------------++{-| I/O operations on endpoints are type-safe. You can only read from an+endpoint with an 'IN' transfer direction and you can only write to an endpoint+with an 'OUT' transfer direction.++Reading and writing also have different implementations for the different+endpoint transfer types like: 'BULK' and 'INTERRUPT'. I/O with endpoints of+other transfer types like 'CONTROL' and 'ISOCHRONOUS' is not possible.++This type lifts the transfer direction and transfer type information to the+type-level so that I/O operations like 'readEndpoint' and 'writeEndpoint' can+specify which endpoints they support.++You can retrieve the endpoints of an alternate by using 'getEndpoints'.+-}+data Endpoint transDir+ transType+ sAlt+ (r ∷ * → *) = Endpoint USB.DeviceHandle+ USB.EndpointDesc++eqDir ∷ TransferDirection transDir → USB.TransferDirection → Bool+Out `eqDir` USB.Out = True+In `eqDir` USB.In = True+_ `eqDir` _ = False++eqType ∷ TransferType transType → USB.TransferType → Bool+Control `eqType` USB.Control = True+Isochronous `eqType` (USB.Isochronous _ _) = True+Bulk `eqType` USB.Bulk = True+Interrupt `eqType` USB.Interrupt = True+_ `eqType` _ = False++-- | Retrieve all the endpoints from the given alternate handle which are of the+-- given transfer direction and transfer type.+getEndpoints ∷ ∀ transDir+ transType+ sCfg sAlt r+ . AlternateHandle sCfg sAlt r -- ^ Handle to the alternate from+ -- which you want to retrieve its+ -- endpoints.+ → TransferDirection transDir -- ^ Filter all endpoints which have+ -- this transfer direction.+ → TransferType transType -- ^ Filter all endpoints which have+ -- this transfer type.+ → [Endpoint transDir transType sAlt r]+getEndpoints (AlternateHandle+ (InterfaceHandle {interface = Interface {ifDevHndlI}})+ ifDesc+ ) transDir transType = map (Endpoint ifDevHndlI)+ $ filter eqDirAndType+ $ USB.interfaceEndpoints ifDesc+ where+ eqDirAndType endpointDesc =+ transDir `eqDir` transDirUSB+ ∧ transType `eqType` transTypeUSB+ where+ transDirUSB = USB.transferDirection $ USB.endpointAddress endpointDesc+ transTypeUSB = USB.endpointAttribs endpointDesc++instance GetDescriptor (Endpoint transDir transType sAlt r)+ USB.EndpointDesc where+ getDesc (Endpoint _ endpointDesc) = endpointDesc++{-| 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:++ * 'NoDeviceException' if the device has been disconnected.++ * Another 'USBException'.+-}+clearHalt ∷ (pr `ParentOf` cr, MonadIO cr)+ ⇒ Endpoint transDir transType sAlt pr → cr ()+clearHalt (Endpoint internalDevHndl endpointDesc) =+ liftIO $ USB.clearHalt internalDevHndl $ USB.endpointAddress endpointDesc++--------------------------------------------------------------------------------+-- *** Transfer directions+--------------------------------------------------------------------------------++data TransferDirection transDir where+ Out ∷ TransferDirection OUT+ In ∷ TransferDirection IN++-- | Out transfer direction (host -> device) used for writing.+data OUT++-- | In transfer direction (device -> host) used for reading.+data IN++--------------------------------------------------------------------------------+-- *** Transfer types+--------------------------------------------------------------------------------++data TransferType transType where+ Control ∷ TransferType CONTROL+ Isochronous ∷ TransferType ISOCHRONOUS+ Bulk ∷ TransferType BULK+ Interrupt ∷ TransferType INTERRUPT++data CONTROL+data ISOCHRONOUS+data BULK+data INTERRUPT+++--------------------------------------------------------------------------------+-- * Endpoint I/O+--------------------------------------------------------------------------------++{-| Handy type synonym for read transfers.++A @ReadAction@ is a function which takes a timeout and a size which defines how+many bytes to read. The function returns an action which, when executed,+performs the actual read and returns the bytestring that was read paired with an+indication if the transfer timed out.+-}+type ReadAction r = USB.Timeout → USB.Size → r (ByteString, Bool)++-- | Class of transfer types that support reading.+class ReadEndpoint transType where+ -- | Read bytes from an 'IN' endpoint with either a 'BULK' or 'INTERRUPT'+ -- transfer type.+ readEndpoint ∷ (pr `ParentOf` cr, MonadIO cr)+ ⇒ Endpoint IN transType sAlt pr → ReadAction cr++instance ReadEndpoint BULK where+ readEndpoint = transferWith USB.readBulk++instance ReadEndpoint INTERRUPT where+ readEndpoint = transferWith USB.readInterrupt++transferWith ∷ (pr `ParentOf` cr, MonadIO cr)+ ⇒ ( USB.DeviceHandle → USB.EndpointAddress+ → USB.Timeout → α → IO (β, Bool)+ )+ → ( Endpoint transDir transType sAlt pr+ → USB.Timeout → α → cr (β, Bool)+ )+transferWith f (Endpoint internalDevHndl endpointDesc) =+ \timeout sbs → liftIO $ f internalDevHndl+ (USB.endpointAddress endpointDesc)+ timeout+ sbs++--------------------------------------------------------------------------------++{-| Handy type synonym for write transfers.++A @WriteAction@ is a function which takes a timeout and the bytestring to+write. The function returns an action which, when exectued, returns the number+of bytes that were actually written paired with an indication if the transfer+timed out.+-}+type WriteAction r = USB.Timeout → ByteString → r (USB.Size, Bool)++-- | Class of transfer types that support writing+class WriteEndpoint transType where+ -- | Write bytes to an 'OUT' endpoint with either a 'BULK' or 'INTERRUPT'+ -- transfer type.+ writeEndpoint ∷ (pr `ParentOf` cr, MonadIO cr)+ ⇒ Endpoint OUT transType sAlt pr → WriteAction cr++instance WriteEndpoint BULK where+ writeEndpoint = transferWith USB.writeBulk++instance WriteEndpoint INTERRUPT where+ writeEndpoint = transferWith USB.writeInterrupt+++--------------------------------------------------------------------------------+-- ** Control transfers+--------------------------------------------------------------------------------++{-| Control transfers can have three request types: @Standard@, @Class@ and+@Vendor@. We disallow @Standard@ requests however because with them you can+destroy the safety guarantees that this module provides.+-}+data RequestType = Class | Vendor++reqTypeToInternal ∷ RequestType → USB.RequestType+reqTypeToInternal Class = USB.Class+reqTypeToInternal Vendor = USB.Vendor++{-| Perform a USB /control/ request that does not transfer data.++The /value/ and /index/ values should be given in host-endian byte order.++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 ∷ (pr `ParentOf` cr, MonadIO cr)+ ⇒ RegionalDeviceHandle pr -- ^ A handle for the device to communicate+ -- with.+ → RequestType -- ^ The type of request.+ → USB.Recipient -- ^ The recipient of the request.+ → Word8 -- ^ Request.+ → Word16 -- ^ Value.+ → Word16 -- ^ Index.+ → USB.Timeout -- ^ Timeout (in milliseconds) that this+ -- function should wait before giving up due+ -- to no response being received. For no+ -- timeout, use value 0.+ → cr ()+control regionalDevHndl reqType reqRecipient request value index timeout =+ liftIO $ USB.control (getInternalDevHndl regionalDevHndl)+ (reqTypeToInternal reqType)+ reqRecipient+ request+ value+ index+ timeout++{-| Perform a USB /control/ read.++The /value/ and /index/ values should be given in host-endian byte order.++Exceptions:++ * 'PipeException' if the control request was not supported by the device++ * 'NoDeviceException' if the device has been disconnected.++ * Another 'USBException'.+-}+readControl ∷ (pr `ParentOf` cr, MonadIO cr)+ ⇒ RegionalDeviceHandle pr -- ^ A handle for the device to+ -- communicate with.+ → RequestType -- ^ The type of request.+ → USB.Recipient -- ^ The recipient of the request.+ → Word8 -- ^ Request.+ → Word16 -- ^ Value.+ → Word16 -- ^ Index.+ → ReadAction cr+readControl regionalDevHndl reqType reqRecipient request value index = \timeout size →+ liftIO $ USB.readControl (getInternalDevHndl regionalDevHndl)+ (reqTypeToInternal reqType)+ reqRecipient+ request+ value+ index+ timeout+ size++{-| Perform a USB /control/ write.++The /value/ and /index/ values should be given in host-endian byte order.++Exceptions:++ * 'PipeException' if the control request was not supported by the device++ * 'NoDeviceException' if the device has been disconnected.++ * Another 'USBException'.+-}+writeControl ∷ (pr `ParentOf` cr, MonadIO cr)+ ⇒ RegionalDeviceHandle pr -- ^ A handle for the device to+ -- communicate with.+ → RequestType -- ^ The type of request.+ → USB.Recipient -- ^ The recipient of the request.+ → Word8 -- ^ Request.+ → Word16 -- ^ Value.+ → Word16 -- ^ Index.+ → WriteAction cr+writeControl regionalDevHndl reqType reqRecipient request value index = \timeout input →+ liftIO $ USB.writeControl (getInternalDevHndl regionalDevHndl)+ (reqTypeToInternal reqType)+ reqRecipient+ request+ value+ index+ timeout+ input+++--------------------------------------------------------------------------------+-- *** Standard Device Requests+--------------------------------------------------------------------------------++{- TODO: Think about which of these to export:++setHalt ∷ DeviceHandle → EndpointAddress → Timeout → IO ()++clearRemoteWakeup ∷ DeviceHandle → Timeout → IO ()++setRemoteWakeup ∷ DeviceHandle → Timeout → IO ()++setStandardTestMode ∷ DeviceHandle → TestMode → Timeout → IO ()++getInterfaceAltSetting ∷ DeviceHandle+ → InterfaceNumber+ → Timeout+ → IO InterfaceAltSetting++getDeviceStatus ∷ DeviceHandle → Timeout → IO DeviceStatus++getEndpointStatus ∷ DeviceHandle+ → EndpointAddress+ → Timeout+ → IO Bool++setDeviceAddress ∷ DeviceHandle → Word16 → Timeout → IO ()++synchFrame ∷ DeviceHandle → EndpointAddress → Timeout → IO Int+-}++--------------------------------------------------------------------------------+-- * String descriptors+--------------------------------------------------------------------------------++{-| Retrieve a list of supported languages.++This function may throw 'USBException's.+-}+getLanguages ∷ (pr `ParentOf` cr, MonadIO cr)+ ⇒ RegionalDeviceHandle pr → cr [USB.LangId]+getLanguages devHndl =+ liftIO $ USB.getLanguages (getInternalDevHndl devHndl)++{-| Retrieve a string descriptor from a device.++This is a convenience function which formulates the appropriate control message+to retrieve the descriptor. The string returned is Unicode, as detailed in the+USB specifications.++This function may throw 'USBException's.++/TODO: The following can be made more type-safe!/++When I call 'getStrDesc' I would like the type system to guarantee that the+given @StrIx@ and @LangId@ actually belong to the given @Handle@. In other+words I would like to get a type error when they are some arbitrary number or+come from another device.+-}+getStrDesc ∷ (pr `ParentOf` cr, MonadIO cr)+ ⇒ RegionalDeviceHandle pr+ → USB.StrIx+ → USB.LangId+ → USB.Size+ → cr String+getStrDesc devHndl strIx langId size =+ liftIO $ USB.getStrDesc (getInternalDevHndl devHndl)+ strIx+ langId+ size++{-| Retrieve a string descriptor from a device using the first supported+language.++This is a convenience function which formulates the appropriate control message+to retrieve the descriptor. The string returned is Unicode, as detailed in the+USB specifications.++This function may throw 'USBException's.+-}+getStrDescFirstLang ∷ (pr `ParentOf` cr, MonadIO cr)+ ⇒ RegionalDeviceHandle pr+ → USB.StrIx+ → USB.Size+ → cr String+getStrDescFirstLang devHndl descStrIx size =+ liftIO $ USB.getStrDescFirstLang (getInternalDevHndl devHndl)+ descStrIx+ size+++--------------------------------------------------------------------------------+-- * 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 ∷ (pr `ParentOf` cr, MonadIO cr)+ ⇒ RegionalDeviceHandle pr → USB.InterfaceNumber → cr Bool+kernelDriverActive regionalDevHndl =+ liftIO ∘ USB.kernelDriverActive (getInternalDevHndl regionalDevHndl)++{-| 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 ∷ (pr `ParentOf` cr, MonadIO cr)+ ⇒ RegionalDeviceHandle pr → USB.InterfaceNumber → cr ()+detachKernelDriver regionalDevHndl =+ liftIO ∘ USB.detachKernelDriver (getInternalDevHndl regionalDevHndl)++{-| 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 ∷ (pr `ParentOf` cr, MonadIO cr)+ ⇒ RegionalDeviceHandle pr → USB.InterfaceNumber → cr ()+attachKernelDriver regionalDevHndl =+ liftIO ∘ USB.attachKernelDriver (getInternalDevHndl regionalDevHndl)++{-| 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 ∷ (pr `ParentOf` cr, MonadCatchIO cr)+ ⇒ RegionalDeviceHandle pr+ → USB.InterfaceNumber+ → cr α+ → cr α+withDetachedKernelDriver regionalDevHndl ifNum action =+ ifM (kernelDriverActive regionalDevHndl ifNum)+ (bracket_ (detachKernelDriver regionalDevHndl ifNum)+ (attachKernelDriver regionalDevHndl ifNum) action) action
usb-safe.cabal view
@@ -1,5 +1,5 @@ name: usb-safe-version: 0.3+version: 0.4 cabal-version: >=1.6 build-type: Simple license: BSD3@@ -9,9 +9,9 @@ maintainer: Bas van Dijk <v.dijk.bas@gmail.com> stability: experimental category: System-synopsis: Wrapper around the usb package adding extra type-safety+synopsis: Type-safe communication with USB devices. description:- The usb library provides a standard Haskell abstracting layer over+ The usb library provides a standard Haskell abstraction layer over bindings-libusb providing: abstract types instead of Ptrs, automatic marshalling and unmarshalling, automatic garbage collection, exceptions instead of integer return codes, etc..@@ -36,7 +36,7 @@ . * The programmer specifies the region in which devices should remain open. On- exit from the region the opened devices are automatically closed.+ exit from the region the opened devices will be closed automatically. . @@ -48,6 +48,12 @@ . + * Just like with devices, the programmer can specify the region in+ which interfaces should remain claimed. On exit from the region+ the claimed interfaces will be released automatically.++ .+ * You can't reference handles to alternates that have not been set. .@@ -78,6 +84,20 @@ <http://okmij.org/ftp/Haskell/regions.html#light-weight> + .++ This technique is implemented in the @regions@ package which is+ re-exported from @usb-safe@.++ .++ See the @usb-safe-examples@ package for examples how to use this library:++ .++ @darcs get@ <http://code.haskell.org/~basvandijk/code/usb-safe-examples>++ source-repository head Type: darcs Location: http://code.haskell.org/~basvandijk/code/usb-safe@@ -88,8 +108,7 @@ , usb == 0.3.* , bytestring == 0.9.* , unicode-symbols == 0.1.*+ , regions == 0.1.* , transformers >= 0.1.4 && < 0.2 , MonadCatchIO-transformers == 0.0.2.*- , monads-fd == 0.0.* exposed-modules: System.USB.Safe-