module System.USB.IO.Iteratee
( enumReadBulk
, enumReadInterrupt
#ifdef HAS_EVENT_MANAGER
, enumReadIsochronous
#endif
) where
import Prelude ( fromIntegral )
import Data.Function ( ($) )
import Data.Word ( Word8 )
import Data.Maybe ( Maybe(Nothing, Just) )
import Control.Monad ( (>>=), return )
import Foreign.Storable ( peek )
import Foreign.Ptr ( castPtr )
import Foreign.Marshal.Alloc ( alloca, allocaBytes )
#if __GLASGOW_HASKELL__ < 700
import Prelude ( fromInteger )
import Control.Monad ( fail )
#endif
import Data.Eq.Unicode ( (≡), (≢) )
import Data.Bool.Unicode ( (∧) )
import Bindings.Libusb ( c'libusb_bulk_transfer
, c'libusb_interrupt_transfer
, c'LIBUSB_SUCCESS
, c'LIBUSB_ERROR_TIMEOUT
)
import Control.Monad.IO.Control ( MonadControlIO, controlIO )
import System.USB.DeviceHandling ( DeviceHandle )
import System.USB.Descriptors ( EndpointAddress )
import System.USB.IO ( Timeout, Size )
import System.USB.Internal ( C'TransferFunc
, withDevHndlPtr
, marshalEndpointAddress
, convertUSBException
)
#ifdef __HADDOCK__
import System.USB.Descriptors ( maxPacketSize, endpointMaxPacketSize
, TransferDirection(In)
, TransferType(Bulk, Interrupt)
)
#endif
import Data.Iteratee.Base ( Stream(EOF, Chunk), runIter, idoneM )
import Data.Iteratee.Iteratee ( Enumerator, throwErr )
import Data.Iteratee.Base.ReadableChunk ( ReadableChunk(readFromPtr) )
import Data.NullPoint ( NullPoint(empty) )
import Control.Exception ( toException )
import Data.Function.Unicode ( (∘) )
#ifdef HAS_EVENT_MANAGER
import Data.Bool ( otherwise, not )
import Data.Int ( Int )
import Data.Function ( id )
import Data.List ( (++), map )
import Foreign.Ptr ( Ptr, nullPtr, plusPtr )
import Foreign.Storable ( poke )
import System.IO ( IO )
import Text.Show ( show )
import Prelude ( (*), error, String )
import Control.Exception ( SomeException, onException, mask, uninterruptibleMask_ )
import
#if MIN_VERSION_base(4,4,0)
GHC.Event
#else
System.Event
#endif
( registerTimeout, unregisterTimeout )
import Data.Iteratee.Base ( Iteratee )
import Bindings.Libusb ( c'LIBUSB_TRANSFER_TYPE_BULK
, c'LIBUSB_TRANSFER_TYPE_INTERRUPT
, c'LIBUSB_TRANSFER_TYPE_ISOCHRONOUS
, c'LIBUSB_TRANSFER_COMPLETED
, c'LIBUSB_TRANSFER_TIMED_OUT
, c'LIBUSB_TRANSFER_ERROR
, c'LIBUSB_TRANSFER_NO_DEVICE
, c'LIBUSB_TRANSFER_OVERFLOW
, c'LIBUSB_TRANSFER_STALL
, c'LIBUSB_TRANSFER_CANCELLED
, C'libusb_iso_packet_descriptor(..)
, C'libusb_transfer(..)
, c'libusb_submit_transfer
, c'libusb_cancel_transfer
, p'libusb_transfer'status
, p'libusb_transfer'actual_length
)
import System.USB.DeviceHandling ( getDevice )
import System.USB.Exceptions ( USBException(..), ioException )
#ifdef __HADDOCK__
import System.USB.Descriptors ( TransferType(Isochronous), maxIsoPacketSize )
#endif
import System.USB.IO ( noTimeout )
import System.USB.Internal ( threaded
, C'TransferType
, allocaTransfer, withCallback
, newLock, acquire, release
, SumLength(..), sumLength
, peekIsoPacketDescs
, initIsoPacketDesc
, getCtx, getEventManager
)
#endif
enumReadBulk ∷ (ReadableChunk s Word8, NullPoint s, MonadControlIO m)
⇒ DeviceHandle
→ EndpointAddress
→ Size
→ Timeout
→ Enumerator s m α
enumReadBulk
#ifdef HAS_EVENT_MANAGER
| threaded = enumReadAsync c'LIBUSB_TRANSFER_TYPE_BULK
#endif
| otherwise = enumReadSync c'libusb_bulk_transfer
enumReadInterrupt ∷ (ReadableChunk s Word8, NullPoint s, MonadControlIO m)
⇒ DeviceHandle
→ EndpointAddress
→ Size
→ Timeout
→ Enumerator s m α
enumReadInterrupt
#ifdef HAS_EVENT_MANAGER
| threaded = enumReadAsync c'LIBUSB_TRANSFER_TYPE_INTERRUPT
#endif
| otherwise = enumReadSync c'libusb_interrupt_transfer
type Run s m α = Stream s → IO (Restore s m α)
type Restore s m α = m (Iteratee s m α)
#ifdef HAS_EVENT_MANAGER
enumReadAsync ∷ ∀ s m α
. (ReadableChunk s Word8, NullPoint s, MonadControlIO m)
⇒ C'TransferType
→ DeviceHandle → EndpointAddress → Size → Timeout
→ Enumerator s m α
enumReadAsync transType = \devHndl endpointAddr chunkSize timeout →
enum transType
0 []
devHndl endpointAddr
timeout
chunkSize
withResult withResult
where
withResult ∷ WithResult s m α
withResult transPtr bufferPtr cont stop = do
n ← peek $ p'libusb_transfer'actual_length transPtr
if n ≡ 0
then stop $ Chunk empty
else readFromPtr bufferPtr (fromIntegral n) >>= cont ∘ Chunk
type WithResult s m α = Ptr C'libusb_transfer → Ptr Word8
→ Run s m α
→ Run s m α
→ IO (Restore s m α)
enum ∷ ∀ m s α
. MonadControlIO m
⇒ C'TransferType
→ Int → [C'libusb_iso_packet_descriptor]
→ DeviceHandle → EndpointAddress
→ Timeout
→ Size
→ WithResult s m α → WithResult s m α
→ Enumerator s m α
enum transType
nrOfIsoPackets isoPackageDescs
devHndl endpointAddr
timeout
chunkSize
onCompletion onTimeout = \iter →
controlIO $ \runInIO →
withDevHndlPtr devHndl $ \devHndlPtr →
allocaBytes chunkSize $ \bufferPtr →
allocaTransfer nrOfIsoPackets $ \transPtr → do
lock ← newLock
let Just (evtMgr, mbHandleEvents) = getEventManager $
getCtx $
getDevice devHndl
waitForTermination =
case mbHandleEvents of
Just handleEvents | timeout ≢ noTimeout → do
tk ← registerTimeout evtMgr (timeout * 1000) handleEvents
acquire lock
`onException`
(uninterruptibleMask_ $ do
unregisterTimeout evtMgr tk
_err ← c'libusb_cancel_transfer transPtr
acquire lock)
_ → acquire lock
`onException`
(uninterruptibleMask_ $ do
_err ← c'libusb_cancel_transfer transPtr
acquire lock)
withCallback (\_ → release lock) $ \cbPtr → do
poke transPtr $ C'libusb_transfer
{ c'libusb_transfer'dev_handle = devHndlPtr
, c'libusb_transfer'flags = 0
, c'libusb_transfer'endpoint = marshalEndpointAddress endpointAddr
, c'libusb_transfer'type = transType
, c'libusb_transfer'timeout = fromIntegral timeout
, c'libusb_transfer'status = 0
, c'libusb_transfer'length = fromIntegral chunkSize
, c'libusb_transfer'actual_length = 0
, c'libusb_transfer'callback = cbPtr
, c'libusb_transfer'user_data = nullPtr
, c'libusb_transfer'buffer = castPtr bufferPtr
, c'libusb_transfer'num_iso_packets = fromIntegral nrOfIsoPackets
, c'libusb_transfer'iso_packet_desc = isoPackageDescs
}
let go ∷ Enumerator s m α
go i = runIter i idoneM on_cont
on_cont ∷ (Stream s → Iteratee s m α)
→ Maybe SomeException
→ m (Iteratee s m α)
on_cont _ (Just e) = return $ throwErr e
on_cont k Nothing =
controlIO $ \runInIO' →
mask $ \restore → do
let stop, cont ∷ Run s m α
stop = return ∘ return ∘ k
cont = runInIO' ∘ go ∘ k
ex ∷ USBException → IO (Restore s m α)
ex = stop ∘ EOF ∘ Just ∘ toException
err ← c'libusb_submit_transfer transPtr
if err ≢ c'LIBUSB_SUCCESS
then ex $ convertUSBException err
else do
waitForTermination
restore $ do
status ← peek $ p'libusb_transfer'status transPtr
let run withResult = withResult transPtr bufferPtr cont stop
case status of
ts | ts ≡ c'LIBUSB_TRANSFER_COMPLETED → run onCompletion
| ts ≡ c'LIBUSB_TRANSFER_TIMED_OUT → run onTimeout
| ts ≡ c'LIBUSB_TRANSFER_ERROR → ex ioException
| ts ≡ c'LIBUSB_TRANSFER_NO_DEVICE → ex NoDeviceException
| ts ≡ c'LIBUSB_TRANSFER_OVERFLOW → ex OverflowException
| ts ≡ c'LIBUSB_TRANSFER_STALL → ex PipeException
| ts ≡ c'LIBUSB_TRANSFER_CANCELLED →
moduleError "transfer status can't be Cancelled!"
| otherwise → moduleError $ "Unknown transfer status: "
++ show ts ++ "!"
runInIO $ go iter
moduleError ∷ String → error
moduleError msg = error $ thisModule ++ ": " ++ msg
thisModule ∷ String
thisModule = "System.USB.IO.Iteratee"
needThreadedRTSError ∷ String → error
needThreadedRTSError msg = moduleError $ msg ++
" is only supported when using the threaded runtime. " ++
"Please build your program with -threaded."
enumReadIsochronous ∷ ∀ s m α
. (ReadableChunk s Word8, MonadControlIO m)
⇒ DeviceHandle
→ EndpointAddress
→ [Size]
→ Timeout
→ Enumerator [s] m α
enumReadIsochronous devHndl endpointAddr sizes timeout
| not threaded = needThreadedRTSError "enumReadIsochronous"
| otherwise = enum c'LIBUSB_TRANSFER_TYPE_ISOCHRONOUS
nrOfIsoPackets (map initIsoPacketDesc sizes)
devHndl endpointAddr
timeout
totalSize
onCompletion onTimeout
where
SumLength totalSize nrOfIsoPackets = sumLength sizes
onCompletion, onTimeout ∷ WithResult [s] m α
onCompletion transPtr bufferPtr cont _ =
peekIsoPacketDescs nrOfIsoPackets transPtr >>= go bufferPtr id
where
go _ ss [] = cont $ Chunk $ ss []
go ptr ss (C'libusb_iso_packet_descriptor l a _ : ds) = do
s ← readFromPtr ptr (fromIntegral a)
go (ptr `plusPtr` fromIntegral l) (ss ∘ (s:)) ds
onTimeout _ _ _ stop = stop ∘ EOF ∘ Just ∘ toException $ TimeoutException
#endif
enumReadSync ∷ ∀ s m α
. (ReadableChunk s Word8, NullPoint s, MonadControlIO m)
⇒ C'TransferFunc → ( DeviceHandle
→ EndpointAddress
→ Size
→ Timeout
→ Enumerator s m α
)
enumReadSync c'transfer = \devHndl
endpoint
chunkSize
timeout → \iter →
controlIO $ \runInIO →
withDevHndlPtr devHndl $ \devHndlPtr →
alloca $ \transferredPtr →
allocaBytes chunkSize $ \dataPtr →
let go ∷ Enumerator s m α
go i = runIter i idoneM on_cont
on_cont ∷ (Stream s → Iteratee s m α) → Maybe SomeException → m (Iteratee s m α)
on_cont _ (Just e) = return $ throwErr e
on_cont k Nothing =
controlIO $ \runInIO' → do
let stop, cont ∷ Run s m α
stop = return ∘ return ∘ k
cont = runInIO' ∘ go ∘ k
err ← c'transfer devHndlPtr
(marshalEndpointAddress endpoint)
(castPtr dataPtr)
(fromIntegral chunkSize)
transferredPtr
(fromIntegral timeout)
if err ≢ c'LIBUSB_SUCCESS ∧
err ≢ c'LIBUSB_ERROR_TIMEOUT
then stop ∘ EOF ∘ Just ∘ toException $ convertUSBException err
else do
t ← peek transferredPtr
if t ≡ 0
then stop $ Chunk empty
else readFromPtr dataPtr (fromIntegral t) >>= cont ∘ Chunk
in runInIO $ go iter