usb-0.3: System/USB/IO/Synchronous/Enumerator.hs
{-# LANGUAGE ScopedTypeVariables #-}
--------------------------------------------------------------------------------
-- |
-- Module : System.USB.IO.Synchronous.Enumerator
-- Copyright : (c) 2009 Bas van Dijk
-- License : BSD3 (see the file LICENSE)
-- Maintainer : Bas van Dijk <v.dijk.bas@gmail.com>
--
-- /Experimental/ enumerators for endpoints.
--
--------------------------------------------------------------------------------
module System.USB.IO.Synchronous.Enumerator
( enumReadBulk
, enumReadInterrupt
) where
--------------------------------------------------------------------------------
-- from myself:
import System.USB.Internal
-- from base:
import Foreign.Marshal.Alloc ( malloc, mallocBytes, free )
import Foreign.Storable ( Storable, peek, sizeOf )
import Foreign.Ptr ( Ptr, castPtr )
-- from bindings-libusb:
import Bindings.Libusb
-- from transformers:
import Control.Monad.Trans ( liftIO )
-- from MonadCatchIO-transformers:
import Control.Monad.CatchIO ( MonadCatchIO, bracket )
-- from iteratee:
import Data.Iteratee.Base ( EnumeratorGM
, StreamG( Chunk )
, IterGV( Done, Cont )
, runIter
, enumErr
, throwErr
)
import Data.Iteratee.Base.StreamChunk ( ReadableChunk (readFromPtr) )
--------------------------------------------------------------------------------
enumReadBulk :: (ReadableChunk s el, MonadCatchIO m)
=> DeviceHandle -- ^ A handle for the device to communicate
-- with.
-> EndpointAddress -- ^ The address of a valid 'In' and 'Bulk'
-- endpoint to communicate with. Make sure
-- the endpoint belongs to the current
-- alternate setting of a claimed interface
-- which belongs to the device.
-> Timeout -- ^ Timeout (in milliseconds) that this
-- function should wait for each chunk
-- before giving up due to no response
-- being received. For no timeout, use
-- value 0.
-> Size -- ^ Chunk size. A good value for this would
-- be the 'endpointMaxPacketSize'.
-> EnumeratorGM s el m a
enumReadBulk = enumRead c'libusb_bulk_transfer
enumReadInterrupt :: (ReadableChunk s el, MonadCatchIO m)
=> DeviceHandle -- ^ A handle for the device to
-- communicate with.
-> EndpointAddress -- ^ The address of a valid 'In' and
-- 'Interrupt' endpoint to communicate
-- with. Make sure the endpoint
-- belongs to the current alternate
-- setting of a claimed interface
-- which belongs to the device.
-> Timeout -- ^ Timeout (in milliseconds) that this
-- function should wait for each chunk
-- before giving up due to no response
-- being received. For no timeout,
-- use value 0.
-> Size -- ^ Chunk size. A good value for this
-- would be the 'endpointMaxPacketSize'.
-> EnumeratorGM s el m a
enumReadInterrupt = enumRead c'libusb_interrupt_transfer
--------------------------------------------------------------------------------
enumRead :: forall s el m a. (ReadableChunk s el, MonadCatchIO m)
=> C'TransferFunc -> DeviceHandle
-> EndpointAddress
-> Timeout
-> Size
-> EnumeratorGM s el m a
enumRead c'transfer devHndl
endpoint
timeout
chunkSize
iter =
genAlloca $ \transferredPtr ->
let bufferSize = chunkSize * sizeOf (undefined :: el)
in genAllocaBytes bufferSize $ \dataPtr ->
let loop i1 = do
err <- liftIO $ c'transfer (getDevHndlPtr devHndl)
(marshalEndpointAddress endpoint)
(castPtr dataPtr)
(fromIntegral bufferSize)
transferredPtr
(fromIntegral timeout)
if err /= c'LIBUSB_SUCCESS &&
err /= c'LIBUSB_ERROR_TIMEOUT
then enumErr (show $ convertUSBException err) i1
else do
t <- liftIO $ peek transferredPtr
s <- liftIO $ readFromPtr dataPtr $ fromIntegral t
r <- runIter i1 $ Chunk s
case r of
Done x _ -> return $ return x
Cont i2 Nothing -> loop i2
Cont _ (Just e) -> return $ throwErr e
in loop iter
--------------------------------------------------------------------------------
genAlloca :: (Storable a, MonadCatchIO m) => (Ptr a -> m b) -> m b
genAlloca = bracketIO malloc free
genAllocaBytes :: (Storable a, MonadCatchIO m) => Int -> (Ptr a -> m b) -> m b
genAllocaBytes n = bracketIO (mallocBytes n) free
bracketIO :: MonadCatchIO m => IO a -> (a -> IO c) -> (a -> m b) -> m b
bracketIO before after = bracket (liftIO before) (liftIO . after)
-- The End ---------------------------------------------------------------------