diff --git a/System/USB/Safe.hs b/System/USB/Safe.hs --- a/System/USB/Safe.hs +++ b/System/USB/Safe.hs @@ -17,7 +17,7 @@ ------------------------------------------------------------------------------- -- | -- Module : System.USB.Safe --- Copyright : (c) 2009 Bas van Dijk +-- Copyright : (c) 2009–2010 Bas van Dijk -- License : BSD3 (see the file LICENSE) -- Maintainer : Bas van Dijk -- @@ -90,6 +90,7 @@ -- ** Regional device handles , RegionalDeviceHandle , getDevice + , withDeviceWhich, NotFound(NotFound) -- * Getting descriptors , GetDescriptor @@ -104,9 +105,9 @@ -- ** Setting configurations , ConfigHandle - , setConfig, SettingAlreadySet - , useActiveConfig, NoActiveConfig - , setConfigWhich, NotFound + , setConfig, SettingAlreadySet(SettingAlreadySet) + , useActiveConfig, NoActiveConfig(NoActiveConfig) + , setConfigWhich -- * Interfaces , Interface @@ -115,7 +116,6 @@ -- ** Claiming interfaces , RegionalIfHandle , claim - , withInterfaceWhich -- * Alternates @@ -131,20 +131,19 @@ -- * Endpoints , Endpoint , getEndpoints - , clearHalt -- *** Transfer directions , TransferDirection(..) - , OUT - , IN + , Out + , In -- *** Transfer types , TransferType(..) - , CONTROL - , ISOCHRONOUS - , BULK - , INTERRUPT + , Control + , Isochronous + , Bulk + , Interrupt -- * Endpoint I/O , ReadAction @@ -177,13 +176,15 @@ -- from base: import Prelude ( fromInteger ) +import Control.Applicative ( (<*>) ) import Control.Concurrent.MVar ( MVar, newMVar, takeMVar, putMVar, withMVar ) import Control.Monad ( Monad, return, (>>=), fail - , (>>), when, liftM2 + , (>>), when ) import Control.Exception ( Exception, throwIO ) import Data.Typeable ( Typeable ) import Data.Function ( ($) ) +import Data.Functor ( (<$>) ) import Data.Word ( Word8, Word16 ) import Data.Char ( String ) import Data.Bool ( Bool( True, False ) ) @@ -192,98 +193,70 @@ import Text.Show ( Show ) import System.IO ( IO ) --- 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 base-unicode-symbols: import Data.Bool.Unicode ( (∧) ) import Data.Eq.Unicode ( (≡) ) import Data.Function.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 +-- from bytestring: +import Data.ByteString ( ByteString ) - , Interface +-- from transformers: +import Control.Monad.IO.Class ( MonadIO, liftIO ) - , InterfaceDesc - , interfaceNumber - , interfaceAltSetting - , interfaceEndpoints +-- from MonadCatchIO-transformers: +import Control.Monad.CatchIO ( MonadCatchIO, bracket_, throw ) - , EndpointDesc - , endpointAddress - , endpointAttribs +-- from regions: +import Control.Resource ( Resource(..) ) - , EndpointAddress - , transferDirection +import Control.Monad.Trans.Region.Unsafe ( internalHandle ) +import qualified Control.Monad.Trans.Region as Region ( open ) +import Control.Monad.Trans.Region -- (re-exported entirely) - , TransferDirection(In, Out) - , TransferType( Control - , Isochronous - , Bulk - , Interrupt - ) +-- from usb: +import qualified System.USB.Initialization as USB + ( Ctx ) - , getLanguages - , LangId - , StrIx - , getStrDesc - , getStrDescFirstLang - ) -import qualified System.USB.IO.Synchronous as USB ( Timeout, Size +import qualified System.USB.Enumeration as USB + ( Device, getDevices, deviceDesc ) - , RequestType(Class, Vendor) - , Recipient +import qualified System.USB.DeviceHandling as USB + ( DeviceHandle, openDevice, closeDevice, getDevice + , getConfig, setConfig + , InterfaceNumber, claimInterface, releaseInterface + , setInterfaceAltSetting + , clearHalt, resetDevice + , kernelDriverActive, detachKernelDriver, attachKernelDriver + ) - , control - , readControl, writeControl +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 + ) - , getInterfaceAltSetting +import qualified System.USB.IO.Synchronous as USB + ( Timeout, Size + , RequestType(Class, Vendor) + , Recipient + , control, readControl, writeControl + , getInterfaceAltSetting + , readBulk, readInterrupt + , writeBulk, writeInterrupt + ) - , readBulk, readInterrupt - , writeBulk, writeInterrupt - ) #ifdef __HADDOCK__ -import System.USB.Exceptions ( USBException(..) ) +import System.USB.Exceptions ( USBException(..) ) #endif --- from regions: -import Control.Resource ( Resource, Handle, openResource, closeResource ) -import Control.Monad.Trans.Region.Unsafe ( internalHandle ) -import Control.Monad.Trans.Region -- (re-exported entirely) - -------------------------------------------------------------------------------- -- * Device regions -------------------------------------------------------------------------------- @@ -297,10 +270,8 @@ -- configuration has been set. See: 'setConfig'. } - openResource dev = liftM2 DeviceHandle (USB.openDevice dev) - (newMVar False) - - closeResource = USB.closeDevice ∘ internalDevHndl + open dev = DeviceHandle <$> USB.openDevice dev <*> newMVar False + close = USB.closeDevice ∘ internalDevHndl -------------------------------------------------------------------------------- @@ -327,7 +298,55 @@ getDevice ∷ RegionalDeviceHandle r → USB.Device getDevice = USB.getDevice ∘ getInternalDevHndl +{-| Convenience function which finds the first device attached to the system +which satisfies the given predicate on its descriptor, then opens that device +and applies the given continuation function to the resulting device handle. +Exceptions: + + * 'NotFound' if no device is found which satisfies the given predicate. + + * 'NoMemException' if there is a memory allocation failure. + + * 'AccessException' if the user has insufficient permissions. + + * 'NoDeviceException' if the device has been disconnected. + + * Another 'USBException'. +-} +withDeviceWhich ∷ ∀ pr α + . MonadCatchIO pr + ⇒ USB.Ctx + → (USB.DeviceDesc → Bool) -- ^ Predicate on the device descriptor. + → (∀ s. RegionalDeviceHandle (RegionT s pr) → RegionT s pr α) + -- ^ Continuation function + → pr α +withDeviceWhich ctx p f = do devs ← liftIO $ USB.getDevices ctx + useWhich devs with p f + +-- | Internally used function which searches through the given list of USB +-- entities (like Devices, Configs, Interfaces or Alternates) for the first +-- entity which satisfies the given predicate on its descriptor. Then opens or +-- sets that entity by applying the given open or set function to the entity. +useWhich ∷ ∀ k desc e (m ∷ * → *) α + . (GetDescriptor e desc, MonadIO m) + ⇒ [e] -- ^ + → (e → k → m α) -- ^ With + → (desc → Bool) -- ^ Predicate on descriptor + → k -- ^ Continuation function + → m α +useWhich ds w p f = case find (p ∘ getDesc) ds of + Nothing → throw NotFound + Just d → w d f + +-- | This exception can be thrown in 'withDeviceWhich', 'setConfigWhich', +-- 'withInterfaceWhich' or 'setAlternateWhich' to indicate that no value was +-- found which satisfied the given predicate. +data NotFound = NotFound deriving (Show, Typeable) + +instance Exception NotFound + + -------------------------------------------------------------------------------- -- * Getting descriptors -------------------------------------------------------------------------------- @@ -439,8 +458,10 @@ -------------------------------------------------------------------------------- {-| 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. +'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 @@ -486,10 +507,11 @@ ⇒ Config pr -- ^ The configuration you wish to set. → (∀ sCfg. ConfigHandle sCfg → cr α) -- ^ Continuation function. → cr α -setConfig (Config (internalHandle → devHndl@(DeviceHandle internalDevHndl - configAlreadySetMVar)) - configDesc - ) f = +setConfig (Config (internalHandle → devHndl@(DeviceHandle { internalDevHndl + , configAlreadySetMVar + })) + configDesc) + f = withUnsettedMVar configAlreadySetMVar $ do liftIO $ USB.setConfig internalDevHndl $ USB.configValue configDesc f $ ConfigHandle devHndl configDesc @@ -550,8 +572,8 @@ → cr α useActiveConfig (internalHandle → devHndl@(DeviceHandle { internalDevHndl , configAlreadySetMVar - }) - ) f = + })) + f = withUnsettedMVar configAlreadySetMVar $ do activeConfigValue ← liftIO $ USB.getConfig internalDevHndl when (activeConfigValue ≡ 0) $ throw NoActiveConfig @@ -596,16 +618,7 @@ -- 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 +setConfigWhich h = useWhich (getConfigs h) setConfig -------------------------------------------------------------------------------- @@ -658,28 +671,24 @@ -- alternate has been set. See: 'setAlternate'. } - openResource (Interface {ifDevHndlI, ifNum, ifDescs}) = do + open (i@Interface {ifDevHndlI, ifNum}) = do USB.claimInterface ifDevHndlI ifNum - alternateAlreadySetMVar ← newMVar False - return $ InterfaceHandle (Interface ifDevHndlI - ifNum - ifDescs - ) - alternateAlreadySetMVar + InterfaceHandle i <$> newMVar False - closeResource (interface → Interface {ifDevHndlI, ifNum}) = + close (interface → Interface {ifDevHndlI, ifNum}) = USB.releaseInterface ifDevHndlI ifNum {-| 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. +A regional handle to a claimed interface can be created by applying 'claim' +(@= 'Region.open'@) 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 +Note that: @claim = @'Region.open' which just reads better when applied to an interface. Note that it is allowed to claim an already-claimed interface. @@ -693,7 +702,7 @@ Exceptions: - * 'BusyException' if the interface is already claimed. + * 'BusyException' if another program or driver has claimed the interface. * 'NoDeviceException' if the device has been disconnected. @@ -705,12 +714,24 @@ → RegionT s pr (RegionalIfHandle sCfg (RegionT s pr)) -claim = open +claim = Region.open + {-| Convenience function which finds the first interface of the given configuration handle which satisfies the given predicate on its descriptors, then claims that interfaces and applies the given continuation function to the resulting regional handle. + +Exceptions: + + * 'NotFound' if no interface was found that satisfies the fiven predicate. + + * 'BusyException' if another program or driver has claimed the interface. + + * 'NoDeviceException' if the device has been disconnected. + + * Another 'USBException'. + -} withInterfaceWhich ∷ ∀ pr sCfg α . MonadCatchIO pr @@ -721,10 +742,7 @@ → RegionT s pr α ) -- ^ Continuation function. → pr α -withInterfaceWhich confHndl p f = - case find (p ∘ getDesc) $ getInterfaces confHndl of - Nothing → throw NotFound - Just intrf → with intrf f +withInterfaceWhich h = useWhich (getInterfaces h) with -------------------------------------------------------------------------------- @@ -877,18 +895,15 @@ -} setAlternateWhich ∷ ∀ pr cr sCfg α . (pr `ParentOf` cr, MonadCatchIO cr) - ⇒ RegionalIfHandle sCfg pr -- ^ Regional handle to the - -- interface for which you want - -- to set an alternate. + ⇒ 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 + -- ^ Continuation function → cr α -setAlternateWhich regionalIfHndl p f = - case find (p ∘ getDesc) $ getAlternates regionalIfHndl of - Nothing → throw NotFound - Just alt → setAlternate alt f +setAlternateWhich h = useWhich (getAlternates h) setAlternate -------------------------------------------------------------------------------- @@ -896,12 +911,12 @@ -------------------------------------------------------------------------------- {-| 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. +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. +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 @@ -984,29 +999,29 @@ -------------------------------------------------------------------------------- data TransferDirection transDir where - Out ∷ TransferDirection OUT - In ∷ TransferDirection IN + Out ∷ TransferDirection Out + In ∷ TransferDirection In -- | Out transfer direction (host -> device) used for writing. -data OUT +data Out -- | In transfer direction (device -> host) used for reading. -data IN +data In -------------------------------------------------------------------------------- -- *** Transfer types -------------------------------------------------------------------------------- data TransferType transType where - Control ∷ TransferType CONTROL - Isochronous ∷ TransferType ISOCHRONOUS - Bulk ∷ TransferType BULK - Interrupt ∷ TransferType INTERRUPT + Control ∷ TransferType Control + Isochronous ∷ TransferType Isochronous + Bulk ∷ TransferType Bulk + Interrupt ∷ TransferType Interrupt -data CONTROL -data ISOCHRONOUS -data BULK -data INTERRUPT +data Control +data Isochronous +data Bulk +data Interrupt -------------------------------------------------------------------------------- @@ -1024,7 +1039,7 @@ -- | Class of transfer types that support reading. class ReadEndpoint transType where - {-| Read bytes from an 'IN' endpoint with either a 'BULK' or 'INTERRUPT' + {-| Read bytes from an 'In' endpoint with either a 'Bulk' or 'Interrupt' transfer type. Exceptions: @@ -1040,13 +1055,13 @@ * Another 'USBException'. -} readEndpoint ∷ (pr `ParentOf` cr, MonadIO cr) - ⇒ Endpoint IN transType sAlt pr + ⇒ Endpoint In transType sAlt pr → ReadAction cr -instance ReadEndpoint BULK where +instance ReadEndpoint Bulk where readEndpoint = transferWith USB.readBulk -instance ReadEndpoint INTERRUPT where +instance ReadEndpoint Interrupt where readEndpoint = transferWith USB.readInterrupt transferWith ∷ (pr `ParentOf` cr, MonadIO cr) @@ -1075,7 +1090,7 @@ -- | Class of transfer types that support writing class WriteEndpoint transType where - {-| Write bytes to an 'OUT' endpoint with either a 'BULK' or 'INTERRUPT' + {-| Write bytes to an 'Out' endpoint with either a 'Bulk' or 'Interrupt' transfer type. Exceptions: @@ -1087,13 +1102,13 @@ * Another 'USBException'. -} writeEndpoint ∷ (pr `ParentOf` cr, MonadIO cr) - ⇒ Endpoint OUT transType sAlt pr + ⇒ Endpoint Out transType sAlt pr → WriteAction cr -instance WriteEndpoint BULK where +instance WriteEndpoint Bulk where writeEndpoint = transferWith USB.writeBulk -instance WriteEndpoint INTERRUPT where +instance WriteEndpoint Interrupt where writeEndpoint = transferWith USB.writeInterrupt diff --git a/usb-safe.cabal b/usb-safe.cabal --- a/usb-safe.cabal +++ b/usb-safe.cabal @@ -1,100 +1,66 @@ name: usb-safe -version: 0.5.1.1 +version: 0.6 cabal-version: >=1.6 build-type: Custom license: BSD3 license-file: LICENSE -copyright: 2010 Bas van Dijk -author: Bas van Dijk +copyright: 2009–2010 Bas van Dijk +author: Bas van Dijk maintainer: Bas van Dijk stability: experimental category: System, Monadic Regions synopsis: Type-safe communication with USB devices. description: - The usb library provides a standard Haskell abstraction layer over - bindings-libusb providing: abstract types instead of Ptrs, automatic + The @usb@ package provides a standard Haskell abstraction layer over + @bindings-libusb@ providing: abstract types instead of @Ptr@s, automatic marshalling and unmarshalling, automatic garbage collection, exceptions instead of integer return codes, etc.. - . - While all that is very nice there are still some things that you can do wrong. For example doing I/O with a closed device or reading from or writing to an endpoint which doesn't belong to the claimed interface. Or reading from an Out endpoint or writing to an In endpoint. - . - - usb-safe provides the following guarantees: - + @usb-safe@ provides the following guarantees: . - * 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 + * The programmer specifies 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 Bulk and Interrupt transfer types is allowed. - . - The primary technique used in usb-safe is called \"Lightweight monadic regions\" which was invented by Oleg Kiselyov and Chung-chieh Shan. See: - . - - . - 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@ source-repository head @@ -103,11 +69,11 @@ Library GHC-Options: -Wall -fno-warn-orphans - build-depends: base >= 4 && < 4.3 - , base-unicode-symbols >= 0.1.1 && < 0.2 - , usb == 0.3.* - , bytestring == 0.9.* - , regions == 0.4.* - , transformers >= 0.1.4 && < 0.2 - , MonadCatchIO-transformers == 0.0.2.0 && < 0.1 + build-depends: base >= 4 && < 4.3 + , base-unicode-symbols >= 0.1.1 && < 0.3 + , usb >= 0.3 && < 0.4 + , bytestring >= 0.9 && < 0.10 + , regions >= 0.5 && < 0.6 + , transformers >= 0.2 && < 0.3 + , MonadCatchIO-transformers >= 0.2 && < 0.3 exposed-modules: System.USB.Safe