diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright (c) 2009 Bas van Dijk + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * The name of Bas van Dijk and the names of contributors may NOT + be used to endorse or promote products derived from this + software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/System/USB/Safe.hs b/System/USB/Safe.hs new file mode 100644 --- /dev/null +++ b/System/USB/Safe.hs @@ -0,0 +1,1476 @@ + +-- Maybe in 10 years time the following list of 13 language extensions can be +-- replaced by the single {-# LANGUAGE Agda #-} ;-) + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE UnicodeSyntax #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : System.USB.Safe +-- Copyright : (c) 2009 Bas van Dijk +-- License : BSD3 (see the file LICENSE) +-- Maintainer : Bas van Dijk +-- +-- 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: +-- +-------------------------------------------------------------------------------- + +module System.USB.Safe + ( -- * Device regions + DeviceRegionT + , runDeviceRegionT + , forkDeviceRegionT + + , 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 + , EndpointHandle + , 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. +-} +newtype DeviceRegionT s m α = DeviceRegionT (ReaderT (IORef [OpenedDevice]) m α) + deriving ( Monad + , MonadTrans + , MonadIO + , MonadCatchIO + , MonadCont + ) + +{-| 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 m α → ReaderT (IORef [OpenedDevice]) m α +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. + +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 parameterised with 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.../ +-} +runDeviceRegionT ∷ MonadCatchIO m ⇒ (∀ s. DeviceRegionT s m α) → m α +runDeviceRegionT m = runWith [] m + +{-| Execute the given 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. +-} +forkDeviceRegionT ∷ MonadIO m + ⇒ DeviceRegionT s IO () + → DeviceRegionT s m ThreadId +forkDeviceRegionT m = DeviceRegionT $ do + openedDevicesIORef ← ask + liftIO $ do openedDevices ← readIORef openedDevicesIORef + block $ do mapM_ incrementRefCnt openedDevices + forkIO $ runWith openedDevices m + +runWith ∷ MonadCatchIO m ⇒ [OpenedDevice] → DeviceRegionT s m α → m α +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 ∷ (m α → (e → m α) → m α) -- ^ @catch@ on the argument monad. + → DeviceRegionT s m α -- ^ Computation to attempt. + → (e → DeviceRegionT s m α) -- ^ Exception handler. + → DeviceRegionT s m α +liftCatch f m h = DeviceRegionT $ Reader.liftCatch f + (unDeviceRegionT m) + (unDeviceRegionT ∘ h) + + +-------------------------------------------------------------------------------- +-- * Opening devices +-------------------------------------------------------------------------------- + +-- | A handle to an opened 'USB.Device'. +newtype DeviceHandle (m ∷ * → *) = DeviceHandle OpenedDevice + +internalDeviceHandle ∷ DeviceHandle m → USB.DeviceHandle +internalDeviceHandle (DeviceHandle (OpenedDevice devHndlI _ _ _)) = devHndlI + +{-| Open a device in a region. + +Note that the returned device handle is parameterised with 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 m + ⇒ USB.Device → DeviceRegionT s m (DeviceHandle (DeviceRegionT s m)) +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 sC (DeviceRegion sP m))@ where @sC@ +is bound by the inner @runDeviceRegionT@ and @sP@ is bound by the outer +@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 @sC@, +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 sP m)@ + +Back in the parent region you can safely operate on @d1hDup@. +-} +dupDeviceHandle ∷ MonadCatchIO m + ⇒ DeviceHandle (DeviceRegionT sC (DeviceRegionT sP m)) + -- ^ A device handle created in @DeviceRegionT sC ...@ which + -- must have a parent region @DeviceRegionT sP m@. + → DeviceRegionT sC (DeviceRegionT sP m) + (DeviceHandle (DeviceRegionT sP m)) + -- ^ Yield a computation in @DeviceRegionT sC@ that returns + -- the duplicated device handle that can now be used in the + -- parent region @DeviceRegionT sP m@. +dupDeviceHandle (DeviceHandle openedDevice) = DeviceRegionT $ + block $ do liftIO $ incrementRefCnt openedDevice + lift $ DeviceRegionT $ registerOpenedDevice openedDevice + +registerOpenedDevice ∷ MonadIO m + ⇒ OpenedDevice + → ReaderT (IORef [OpenedDevice]) m (DeviceHandle m1) +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 m + ⇒ USB.Device + → (∀ s. DeviceHandle (DeviceRegionT s m) → DeviceRegionT s m α) + → m α +withDevice dev f = runDeviceRegionT $ openDevice dev >>= f + +-- | Retrieve the device from the device handle. +getDevice ∷ DeviceHandle m → USB.Device +getDevice = USB.getDevice ∘ internalDeviceHandle + + +-------------------------------------------------------------------------------- +-- * monads-fd instances +-------------------------------------------------------------------------------- + +-- TODO: Should I also provide monads-tf instances? Can I provide both? + +instance (MonadError e m) ⇒ MonadError e (DeviceRegionT s m) where + throwError = lift ∘ throwError + catchError = liftCatch catchError + +instance MonadRWS r w st m ⇒ MonadRWS r w st (DeviceRegionT s m) + +instance MonadReader r m ⇒ MonadReader r (DeviceRegionT s m) where + ask = lift ask + local = mapDeviceRegionT ∘ local + +instance MonadState st m ⇒ MonadState st (DeviceRegionT s m) where + get = lift get + put = lift ∘ put + +instance MonadWriter w m ⇒ MonadWriter w (DeviceRegionT s m) where + tell = lift ∘ tell + listen = mapDeviceRegionT listen + pass = mapDeviceRegionT pass + + +-------------------------------------------------------------------------------- +-- * ParentOf +-------------------------------------------------------------------------------- + +{-| The @ParentOf@ class declares the parent/child relationship between regions. + +A region @p@ is the parent of region @c@ if they're either equivalent like: + +@ +DeviceRegionT sP mP `ParentOf` DeviceRegionT sP mP +@ + +or if @p@ is the parent of the parent of the child like: + +@ +DeviceRegionT sP mP `ParentOf` DeviceRegionT sC''' + (DeviceRegionT sC'' + (... + (DeviceRegionT sC' + (DeviceRegionT sP mP)))) +@ +-} +class (Monad mP, Monad mC) ⇒ mP `ParentOf` mC + +instance Monad m ⇒ ParentOf m m + +instance (Monad mC, TypeCast2 mC (DeviceRegionT s mC'), mP `ParentOf` mC') + ⇒ ParentOf mP mC + + +-------------------------------------------------------------------------------- +-- Type casting +-------------------------------------------------------------------------------- + +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. + +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 ∷ (mP `ParentOf` mC, MonadIO mC) + ⇒ DeviceHandle mP → mC () +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'. +data Config (m ∷ * → *) = Config (DeviceHandle m) USB.ConfigDesc + +{-| Retrieve the supported configurations from the device handle. + +Note that the configuration is parameterised by the same region in which the +device handle was created. This ensures you can never use a configuration +outside that region. +-} +getConfigs ∷ DeviceHandle m → [Config m] +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 m → USB.ConfigDesc +getConfigDesc (Config _ configDesc) = configDesc + +{-| Duplicate a configuration in the parent region. + +Also see: 'dupDeviceHandle'. +-} +dupConfig ∷ MonadCatchIO m + ⇒ Config (DeviceRegionT sC (DeviceRegionT sP m)) + → DeviceRegionT sC (DeviceRegionT sP m) + (Config (DeviceRegionT sP m)) +dupConfig (Config devHndlC cfg) = do + devHndlP ← dupDeviceHandle devHndlC + return $ Config devHndlP cfg + + +-------------------------------------------------------------------------------- +-- ** Setting configurations +-------------------------------------------------------------------------------- + +-- | A handle to an active 'Config'. +newtype ConfigHandle s (m ∷ * → *) = ConfigHandle (Config m) + +{-| 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) + +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. + + * Another 'USBException'. +-} +withConfig ∷ (mP `ParentOf` mC, MonadCatchIO mC) + ⇒ Config mP + → (∀ s. ConfigHandle s mP → mC α) + → mC α +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 a → m a +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 currently 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 ∷ (mP `ParentOf` mC, MonadCatchIO mC) + ⇒ DeviceHandle mP + → (∀ s. ConfigHandle s mP → mC α) + → mC α +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'. +newtype Interface s (m ∷ * → *) = 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 parameterised 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 s m → [Interface s m] +getInterfaces (ConfigHandle + (Config + (DeviceHandle + (OpenedDevice devHndlI _ _ alternateAlreadySetMVar)) + configDesc)) = + map (\alts → Interface $ Intrf devHndlI + (USB.interfaceNumber $ head alts) + alts + alternateAlreadySetMVar + ) $ USB.configInterfaces configDesc + +-- | Retrieve the alternate interface descriptors of the interface. +getInterfaceDescs ∷ Interface s m → USB.Interface +getInterfaceDescs (Interface (Intrf _ _ alts _)) = alts + + +-------------------------------------------------------------------------------- +-- ** Claiming and releasing interfaces +-------------------------------------------------------------------------------- + +-- | A handle to a claimed 'Interface'. +newtype InterfaceHandle s (m ∷ * → *) = 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 ∷ (mP `ParentOf` mC, MonadCatchIO mC) + ⇒ Interface s mP + → (∀ s2. InterfaceHandle s2 mP → mC α) + → mC α +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. +newtype Alternate s (m ∷ * → *) = 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 parameterised 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 s m → [Alternate s m] +getAlternates (InterfaceHandle (Intrf devHndlI _ alts alternateAlreadySetMVar)) = + map (\alt → Alternate $ Alt devHndlI alt alternateAlreadySetMVar) alts + +-- | Retrieve the interface descriptor of this alternate setting. +getInterfaceDesc ∷ Alternate s m → USB.InterfaceDesc +getInterfaceDesc (Alternate (Alt _ ifDesc _)) = ifDesc + + +-------------------------------------------------------------------------------- +-- ** Setting alternates +-------------------------------------------------------------------------------- + +-- | A handle to a setted alternate setting. +newtype AlternateHandle s (m ∷ * → *) = 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 currently 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 ∷ (mP `ParentOf` mC, MonadCatchIO mC) + ⇒ Alternate s mP + → (∀ s2. AlternateHandle s2 mP → mC α) → mC α +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 currently 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 ∷ (mP `ParentOf` mC, MonadCatchIO mC) + ⇒ InterfaceHandle s mP + → (∀ s2. AlternateHandle s2 mP → mC α) → mC α +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'. +data Endpoint s (m ∷ * → *) = Endpoint USB.DeviceHandle + USB.EndpointDesc + +{-| Retrieve the supported endpoints from the alternate handle. + +Note that the endpoint is parameterised 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 s m → [Endpoint s m] +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 can specify which endpoints they support. +-} +newtype EndpointHandle transDir + transType + s (m ∷ * → *) = EndpointHandle (Endpoint s m) + +{-| 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 endpoint handles which have the +specified transfer direction and transfer type and also expres this in their +type. +-} +filterEndpoints ∷ ∀ transDir + transType + s m. ( TransferDirection transDir + , TransferType transType + ) + ⇒ [Endpoint s m] → [EndpointHandle transDir + transType + s m + ] +filterEndpoints = map EndpointHandle ∘ filter eqTransDirAndTransType + where + eqTransDirAndTransType (Endpoint _ endpointDesc) = + (undefined ∷ transDir) `eqTransDir` transDirUSB + ∧ (undefined ∷ transType) `eqTransType` transTypeUSB + where + transDirUSB = USB.transferDirection $ USB.endpointAddress endpointDesc + transTypeUSB = USB.endpointAttribs endpointDesc + +-- | Retrieve the endpoint descriptor from the given endpoint handle. +getEndpointDesc ∷ EndpointHandle transDir transType s m + → USB.EndpointDesc +getEndpointDesc (EndpointHandle (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 ∷ (mP `ParentOf` mC, MonadIO mC) + ⇒ EndpointHandle transDir transType s mP → mC () +clearHalt (EndpointHandle (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) + + +-------------------------------------------------------------------------------- +-- *** 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 m = USB.Timeout → USB.Size → m (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 ∷ (mP `ParentOf` mC, MonadIO mC) + ⇒ EndpointHandle In transType s mP → ReadAction mC + +instance ReadEndpoint Bulk where + readEndpoint = readEndpointWith USB.readBulk + +instance ReadEndpoint Interrupt where + readEndpoint = readEndpointWith USB.readInterrupt + +readEndpointWith ∷ (mP `ParentOf` mC, MonadIO mC) + ⇒ (USB.DeviceHandle → USB.EndpointAddress → USB.ReadAction) + → EndpointHandle In transType s mP → ReadAction mC +readEndpointWith f (EndpointHandle (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 m = USB.Timeout → ByteString → m (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 ∷ (mP `ParentOf` mC, MonadIO mC) + ⇒ EndpointHandle Out transType s mP → WriteAction mC + +instance WriteEndpoint Bulk where + writeEndpoint = writeEndpointWith USB.writeBulk + +instance WriteEndpoint Interrupt where + writeEndpoint = writeEndpointWith USB.writeInterrupt + +writeEndpointWith ∷ (mP `ParentOf` mC, MonadIO mC) + ⇒ (USB.DeviceHandle → USB.EndpointAddress → USB.WriteAction) + → EndpointHandle Out transType s mP → WriteAction mC +writeEndpointWith f (EndpointHandle (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 +destrow 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 ∷ (mP `ParentOf` mC, MonadIO mC) + ⇒ DeviceHandle mP -- ^ 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. + → mC () +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 ∷ (mP `ParentOf` mC, MonadIO mC) + ⇒ DeviceHandle mP -- ^ 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 mC +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 ∷ (mP `ParentOf` mC, MonadIO mC) + ⇒ DeviceHandle mP -- ^ 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 mC +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 ∷ (mP `ParentOf` mC, MonadIO mC) + ⇒ DeviceHandle mP → mC [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 ∷ (mP `ParentOf` mC, MonadIO mC) + ⇒ DeviceHandle mP → USB.StrIx → USB.LangId → USB.Size → mC 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 ∷ (mP `ParentOf` mC, MonadIO mC) + ⇒ DeviceHandle mP → USB.StrIx → USB.Size → mC 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 ∷ (mP `ParentOf` mC, MonadIO mC) + ⇒ DeviceHandle mP → USB.InterfaceNumber → mC 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 ∷ (mP `ParentOf` mC, MonadIO mC) + ⇒ DeviceHandle mP → USB.InterfaceNumber → mC () +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 ∷ (mP `ParentOf` mC, MonadIO mC) + ⇒ DeviceHandle mP → USB.InterfaceNumber → mC () +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 ∷ (mP `ParentOf` mC, MonadCatchIO mC) + ⇒ DeviceHandle mP → USB.InterfaceNumber → mC α → mC α +withDetachedKernelDriver devHndl ifNum action = + ifM (kernelDriverActive devHndl ifNum) + (bracket_ (detachKernelDriver devHndl ifNum) + (attachKernelDriver devHndl ifNum) + action) + action + + +-------------------------------------------------------------------------------- +-- * Utils +-------------------------------------------------------------------------------- + +-- | Monadic @if ... then ... else ...@ +ifM ∷ Monad m ⇒ m Bool → m α → m α → m α +ifM cM tM eM = do c ← cM + if c + then tM + else eM + + +-- The End --------------------------------------------------------------------- diff --git a/usb-safe.cabal b/usb-safe.cabal new file mode 100644 --- /dev/null +++ b/usb-safe.cabal @@ -0,0 +1,28 @@ +name: usb-safe +version: 0.1 +cabal-version: >=1.6 +build-type: Simple +license: BSD3 +license-file: LICENSE +copyright: 2009 Bas van Dijk +author: Bas van Dijk +maintainer: Bas van Dijk +stability: experimental +category: System +synopsis: Wrapper around the usb package adding extra type-safety + +source-repository head + Type: darcs + Location: http://code.haskell.org/~basvandijk/code/usb-safe + +Library + GHC-Options: -O2 -Wall + build-depends: base >= 4 && < 4.2 + , usb == 0.3.* + , bytestring == 0.9.* + , unicode-symbols == 0.1.* + , transformers >= 0.1.4 && < 0.2 + , MonadCatchIO-transformers == 0.0.2.* + , monads-fd == 0.0.* + exposed-modules: System.USB.Safe +