diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright (c) 2010 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,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 --------------------------------------------------------------------- diff --git a/System/USB/IO/Synchronous/Enumerator.hs b/System/USB/IO/Synchronous/Enumerator.hs new file mode 100644 --- /dev/null +++ b/System/USB/IO/Synchronous/Enumerator.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE CPP, UnicodeSyntax, NoImplicitPrelude, FlexibleContexts #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : System.USB.IO.Synchronous.Enumerator +-- Copyright : (c) 2009–2010 Bas van Dijk +-- License : BSD3 (see the file LICENSE) +-- Maintainer : Bas van Dijk +-- +-- Iteratee enumerators for endpoints. +-- +-------------------------------------------------------------------------------- + +module System.USB.IO.Synchronous.Enumerator + ( enumReadBulk + , enumReadInterrupt + ) where + + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +-- from base: +import Prelude ( fromInteger, fromIntegral ) +import Data.Function ( ($) ) +import Data.Word ( Word8 ) +import Data.Maybe ( Maybe(Nothing, Just) ) +import Control.Monad ( return, (>>=), fail ) +import Text.Show ( show ) +import Foreign.Storable ( peek ) +import Foreign.Ptr ( castPtr ) + +-- 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 transformers: +import Control.Monad.IO.Class ( liftIO ) + +-- from MonadCatchIO-transformers: +import Control.Monad.CatchIO ( MonadCatchIO ) + +-- from MonadCatchIO-transformers-foreign: +import Control.Monad.CatchIO.Foreign ( alloca, allocaBytes ) + +-- from iteratee: +import Data.Iteratee.Base ( EnumeratorGM + , StreamG(Chunk) + , IterGV(Done, Cont) + , runIter + , enumErr + , throwErr + ) +import Data.Iteratee.Base.StreamChunk ( ReadableChunk(readFromPtr) ) + +-- from usb: +import System.USB.DeviceHandling ( DeviceHandle ) +import System.USB.Descriptors ( EndpointAddress ) +import System.USB.IO.Synchronous ( Timeout, Size ) + +import System.USB.Unsafe ( C'TransferFunc + , getDevHndlPtr + , marshalEndpointAddress + , convertUSBException + ) + +#ifdef __HADDOCK__ +import System.USB.Descriptors ( maxPacketSize, endpointMaxPacketSize ) +#endif + + +-------------------------------------------------------------------------------- +-- Enumerators +-------------------------------------------------------------------------------- + +enumReadBulk ∷ (ReadableChunk s Word8, 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. + → 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. For no + -- timeout, use value 0. + → EnumeratorGM s Word8 m α +enumReadBulk = enumRead c'libusb_bulk_transfer + +enumReadInterrupt ∷ (ReadableChunk s Word8, 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. + → 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. For no timeout, use + -- value 0. + → EnumeratorGM s Word8 m α +enumReadInterrupt = enumRead c'libusb_interrupt_transfer + + +-------------------------------------------------------------------------------- + +enumRead ∷ (ReadableChunk s Word8, MonadCatchIO m) + ⇒ C'TransferFunc → ( DeviceHandle + → EndpointAddress + → Size + → Timeout + → EnumeratorGM s Word8 m α + ) +enumRead c'transfer = \devHndl + endpoint + chunkSize + timeout → \iter → + alloca $ \transferredPtr → + allocaBytes chunkSize $ \dataPtr → + let loop i1 = do + err ← liftIO $ c'transfer (getDevHndlPtr devHndl) + (marshalEndpointAddress endpoint) + (castPtr dataPtr) + (fromIntegral chunkSize) + 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 + if t ≡ 0 + then return i1 + else do + 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 + + +-- The End --------------------------------------------------------------------- diff --git a/usb-enumerator.cabal b/usb-enumerator.cabal new file mode 100644 --- /dev/null +++ b/usb-enumerator.cabal @@ -0,0 +1,29 @@ +name: usb-enumerator +version: 0.1 +cabal-version: >=1.6 +build-type: Custom +license: BSD3 +license-file: LICENSE +copyright: 2010 Bas van Dijk +author: Bas van Dijk +maintainer: Bas van Dijk +stability: experimental +category: System +synopsis: Iteratee enumerators for the usb package +description: This packages provides iteratee enumerators for the @usb@ package. + +source-repository head + Type: darcs + Location: http://code.haskell.org/~basvandijk/code/usb-enumerator + +Library + GHC-Options: -Wall + build-depends: base >= 4 && < 4.3 + , base-unicode-symbols >= 0.1.1 && < 0.3 + , bindings-libusb >= 1.3 && < 1.5 + , iteratee >= 0.3.5 && < 0.4 + , transformers >= 0.2 && < 0.3 + , MonadCatchIO-transformers >= 0.2 && < 0.3 + , MonadCatchIO-transformers-foreign >= 0.1 && < 0.2 + , usb >= 0.5 && < 0.6 + exposed-modules: System.USB.IO.Synchronous.Enumerator