usb-iteratee (empty) → 0.4
raw patch · 6 files changed
+623/−0 lines, 6 filesdep +basedep +base-unicode-symbolsdep +bindings-libusbbuild-type:Customsetup-changed
Dependencies added: base, base-unicode-symbols, bindings-libusb, iteratee, monad-control, transformers, usb
Files
- LICENSE +31/−0
- NEWS +63/−0
- README.markdown +4/−0
- Setup.hs +47/−0
- System/USB/IO/Iteratee.hs +442/−0
- usb-iteratee.cabal +36/−0
+ LICENSE view
@@ -0,0 +1,31 @@+Copyright (c) 2011 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.
+ NEWS view
@@ -0,0 +1,63 @@+0.3++(Released on: Wed Mar 9 12:22:02 UTC 2011)++* Replaced monad-peel with monad-control++* Support iteratee-0.8.*++* Support usb-0.9+++0.2.0.2++(Released on: Mon Jan 17 22:04:41 UTC 2011)++* Support iteratee-0.7 and usb-0.7+++0.2.0.1++(Released on: Sat Nov 13 21:20:29 UTC 2010)++* Support iteratee-0.6.+++0.2++(Released on: Sat Nov 6 15:57:38 UTC 2010)++* Released during BelHac 2010!++* Support iteratee-0.5.++* Use MonadPeelIO instead of MonadCatchIO.+++0.1.0.3++(Released on: Thu Oct 21 21:41:01 UTC 2010)++* Tested with GHC-7 and base-4.3+++0.1.0.2++(Released on: Sat Sep 11 14:19:49 UTC 2010)++* Support usb-0.6+++0.1.0.1++(Released on: Wed Sep 1 20:12:06 UTC 2010)++* Support iteratee-0.4.*+ (Both the 0.3.* and 0.4.* versions are supported)+++0.1++(Released on: Mon Jul 26 05:49:04 UTC 2010)++* Initial release
+ README.markdown view
@@ -0,0 +1,4 @@+This packages provides [iteratee] enumerators for the [usb] package.++[iteratee]: http://hackage.haskell.org/package/iteratee+[usb]: http://hackage.haskell.org/package/usb
+ Setup.hs view
@@ -0,0 +1,47 @@+#! /usr/bin/env runhaskell++{-# LANGUAGE NoImplicitPrelude, UnicodeSyntax #-}++module Main (main) where+++-------------------------------------------------------------------------------+-- Imports+-------------------------------------------------------------------------------++-- from base+import Control.Monad ( (>>), return )+import System.IO ( IO )++-- from cabal+import Distribution.Simple ( defaultMainWithHooks+ , simpleUserHooks+ , UserHooks(haddockHook)+ , Args+ )++import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) )+import Distribution.Simple.Program ( userSpecifyArgs )+import Distribution.Simple.Setup ( HaddockFlags )+import Distribution.PackageDescription ( PackageDescription(..) )+++-------------------------------------------------------------------------------+-- Cabal setup program with support for 'cabal test' and+-- which sets the CPP define '__HADDOCK __' when haddock is run.+-------------------------------------------------------------------------------++main ∷ IO ()+main = defaultMainWithHooks hooks+ where+ hooks = simpleUserHooks { haddockHook = haddockHook' }++-- Define __HADDOCK__ for CPP when running haddock.+haddockHook' ∷ PackageDescription → LocalBuildInfo → UserHooks → HaddockFlags → IO ()+haddockHook' pkg lbi =+ haddockHook simpleUserHooks pkg (lbi { withPrograms = p })+ where+ p = userSpecifyArgs "haddock" ["--optghc=-D__HADDOCK__"] (withPrograms lbi)+++-- The End ---------------------------------------------------------------------
+ System/USB/IO/Iteratee.hs view
@@ -0,0 +1,442 @@+{-# LANGUAGE CPP+ , UnicodeSyntax+ , NoImplicitPrelude+ , FlexibleContexts+ , ScopedTypeVariables+ #-}++--------------------------------------------------------------------------------+-- |+-- Module : System.USB.IO.Iteratee+-- Copyright : (c) 2011 Bas van Dijk+-- License : BSD3 (see the file LICENSE)+-- Maintainer : Bas van Dijk <v.dijk.bas@gmail.com>+--+-- Iteratee enumerators for endpoints.+--+--------------------------------------------------------------------------------++module System.USB.IO.Iteratee+ ( enumReadBulk+ , enumReadInterrupt+#ifdef HAS_EVENT_MANAGER+ , enumReadIsochronous+#endif+ ) where+++--------------------------------------------------------------------------------+-- Imports+--------------------------------------------------------------------------------++-- from base:+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++-- from base-unicode-symbols:+import Data.Eq.Unicode ( (≡), (≢) )+import Data.Bool.Unicode ( (∧) )++-- from bindings-libusb:+import Bindings.Libusb ( c'libusb_bulk_transfer+ , c'libusb_interrupt_transfer+ , c'LIBUSB_SUCCESS+ , c'LIBUSB_ERROR_TIMEOUT+ )++-- from monad-control:+import Control.Monad.IO.Control ( MonadControlIO, controlIO )++-- from usb:+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++-- from iteratee:+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) )++-- from base:+import Control.Exception ( toException )++-- from base-unicode-symbols:+import Data.Function.Unicode ( (∘) )++#ifdef HAS_EVENT_MANAGER+--------------------------------------------------------------------------------+-- from base:+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 )++-- from iteratee:+import Data.Iteratee.Base ( Iteratee )++-- from bindings-libusb:+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+ )++-- from usb:+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++--------------------------------------------------------------------------------+-- Enumerators+--------------------------------------------------------------------------------++-- | Iteratee enumerator for reading /bulk/ endpoints.+enumReadBulk ∷ (ReadableChunk s Word8, NullPoint s, MonadControlIO 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.+ → Size -- ^ Chunk size. A good value for this would be+ -- the @'maxPacketSize' . 'endpointMaxPacketSize'@.+ → Timeout -- ^ Timeout (in milliseconds) that this function+ -- should wait for each chunk before giving up+ -- due to no response being received.+ → Enumerator s m α+enumReadBulk+#ifdef HAS_EVENT_MANAGER+ | threaded = enumReadAsync c'LIBUSB_TRANSFER_TYPE_BULK+#endif+ | otherwise = enumReadSync c'libusb_bulk_transfer++-- | Iteratee enumerator for reading /interrupt/ endpoints.+enumReadInterrupt ∷ (ReadableChunk s Word8, NullPoint s, MonadControlIO 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.+ → Size -- ^ Chunk size. A good value for this would+ -- be the @'maxPacketSize' . 'endpointMaxPacketSize'@.+ → Timeout -- ^ Timeout (in milliseconds) that this+ -- function should wait for each chunk+ -- before giving up due to no response+ -- being received.+ → 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+--------------------------------------------------------------------------------+-- Asynchronous+--------------------------------------------------------------------------------++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 α -- To continue+ → Run s m α -- To stop+ → 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 -- unused+ , c'libusb_transfer'endpoint = marshalEndpointAddress endpointAddr+ , c'libusb_transfer'type = transType+ , c'libusb_transfer'timeout = fromIntegral timeout+ , c'libusb_transfer'status = 0 -- output+ , c'libusb_transfer'length = fromIntegral chunkSize+ , c'libusb_transfer'actual_length = 0 -- output+ , c'libusb_transfer'callback = cbPtr+ , c'libusb_transfer'user_data = nullPtr -- unused+ , 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."++--------------------------------------------------------------------------------+-- Isochronous+--------------------------------------------------------------------------------++-- | Iteratee enumerator for reading /isochronous/ endpoints.+--+-- /WARNING:/ You need to enable the threaded runtime (@-threaded@) for this+-- function to work correctly. It throws a runtime error otherwise!+enumReadIsochronous ∷ ∀ s m α+ . (ReadableChunk s Word8, MonadControlIO m)+ ⇒ DeviceHandle -- ^ A handle for the device to communicate with.+ → EndpointAddress -- ^ The address of a valid 'In' and 'Isochronous'+ -- endpoint to communicate with. Make sure the+ -- endpoint belongs to the current alternate+ -- setting of a claimed interface which belongs+ -- to the device.+ → [Size] -- ^ Sizes of isochronous packets. A good+ -- value for these would be the+ -- 'maxIsoPacketSize'+ → Timeout -- ^ Timeout (in milliseconds) that this+ -- function should wait for each chunk+ -- before giving up due to no response+ -- being received.+ → 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++--------------------------------------------------------------------------------+-- Synchronous+--------------------------------------------------------------------------------++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
+ usb-iteratee.cabal view
@@ -0,0 +1,36 @@+name: usb-iteratee+version: 0.4+cabal-version: >=1.6+build-type: Custom+license: BSD3+license-file: LICENSE+copyright: 2011 Bas van Dijk <v.dijk.bas@gmail.com>+author: Bas van Dijk <v.dijk.bas@gmail.com>+maintainer: Bas van Dijk <v.dijk.bas@gmail.com>+homepage: https://github.com/basvandijk/usb-iteratee/+bug-reports: https://github.com/basvandijk/usb-iteratee/issues+stability: experimental+category: System+synopsis: Iteratee enumerators for the usb package+description: This packages provides @iteratee@ enumerators for the @usb@ package.++extra-source-files: README.markdown, NEWS++source-repository head+ Type: git+ Location: git://github.com/basvandijk/usb-iteratee.git++Library+ GHC-Options: -Wall++ build-depends: base >= 4 && < 4.5+ , base-unicode-symbols >= 0.1.1 && < 0.3+ , bindings-libusb >= 1.3 && < 1.5+ , iteratee >= 0.4 && < 0.9+ , transformers >= 0.2 && < 0.3+ , monad-control >= 0.2 && < 0.3+ , usb >= 1.0 && < 1.1+ exposed-modules: System.USB.IO.Iteratee++ if impl(ghc>7) && !os(windows)+ cpp-options: -DHAS_EVENT_MANAGER