{-# LANGUAGE CPP
           , UnicodeSyntax
           , NoImplicitPrelude
           , FlexibleContexts
           , ScopedTypeVariables
  #-}

#if __GLASGOW_HASKELL__ >= 704
{-# LANGUAGE Trustworthy #-}
#endif

#ifdef HAS_EVENT_MANAGER
{-# LANGUAGE PatternGuards #-}
#endif

--------------------------------------------------------------------------------
-- |
-- 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.Exception                ( toException )
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.Function.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.Trans.Control      ( MonadBaseControl, StM, control )

-- 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) )

#ifdef HAS_EVENT_MANAGER
--------------------------------------------------------------------------------
-- from base:
import Data.Bool         ( otherwise )
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, mask )

-- 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

                       , p'libusb_transfer'status
                       , p'libusb_transfer'actual_length
                       )

-- from usb:
import System.USB.Exceptions     ( USBException(..), ioException )
#ifdef __HADDOCK__
import System.USB.Descriptors    ( TransferType(Isochronous), maxIsoPacketSize )
#endif
import System.USB.Internal       ( getWait, Wait
                                 , C'TransferType
                                 , allocaTransfer, withCallback
                                 , newLock, release
                                 , SumLength(..), sumLength
                                 , peekIsoPacketDescs
                                 , initIsoPacketDesc
                                 )
#endif

--------------------------------------------------------------------------------
-- Enumerators
--------------------------------------------------------------------------------

-- | Iteratee enumerator for reading /bulk/ endpoints.
enumReadBulk  (ReadableChunk s Word8, NullPoint s, MonadBaseControl IO 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 devHndl
#ifdef HAS_EVENT_MANAGER
    | Just wait  getWait devHndl =
        enumReadAsync wait c'LIBUSB_TRANSFER_TYPE_BULK devHndl
#endif
    | otherwise = enumReadSync c'libusb_bulk_transfer devHndl

-- | Iteratee enumerator for reading /interrupt/ endpoints.
enumReadInterrupt  (ReadableChunk s Word8, NullPoint s, MonadBaseControl IO 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 devHndl
#ifdef HAS_EVENT_MANAGER
    | Just wait  getWait devHndl =
        enumReadAsync wait c'LIBUSB_TRANSFER_TYPE_INTERRUPT devHndl
#endif
    | otherwise = enumReadSync c'libusb_interrupt_transfer devHndl

type Run s m α = Stream s  IO (StM m (Iteratee s m α))

#ifdef HAS_EVENT_MANAGER
--------------------------------------------------------------------------------
-- Asynchronous
--------------------------------------------------------------------------------

enumReadAsync   s m α
              . (ReadableChunk s Word8, NullPoint s, MonadBaseControl IO m)
               Wait
               C'TransferType
               DeviceHandle  EndpointAddress  Size  Timeout
               Enumerator s m α
enumReadAsync wait transType = \devHndl endpointAddr chunkSize timeout 
  enum wait
       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 (StM m (Iteratee s m α))

enum   m s α
     . MonadBaseControl IO m
      Wait
      C'TransferType
      Int  [C'libusb_iso_packet_descriptor]
      DeviceHandle  EndpointAddress
      Timeout
      Size
      WithResult s m α  WithResult s m α
      Enumerator s m α
enum wait
     transType
     nrOfIsoPackets isoPackageDescs
     devHndl endpointAddr
     timeout
     chunkSize
     onCompletion onTimeout = \iter 
  control $ \runInIO 
    withDevHndlPtr devHndl $ \devHndlPtr 
      allocaBytes chunkSize $ \bufferPtr 
        allocaTransfer nrOfIsoPackets $ \transPtr  do
          lock  newLock
          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 waitForTermination  IO ()
                waitForTermination = wait timeout lock transPtr

                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  =
                  control $ \runInIO' 
                    mask $ \restore  do

                      let stop, cont  Run s m α
                          stop = runInIO'  return  k
                          cont = runInIO'  go      k

                          ex  USBException  IO (StM m (Iteratee 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, MonadBaseControl IO 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
    | Just wait  getWait devHndl =
        enum wait
             c'LIBUSB_TRANSFER_TYPE_ISOCHRONOUS
             nrOfIsoPackets (map initIsoPacketDesc sizes)
             devHndl endpointAddr
             timeout
             totalSize
             onCompletion onTimeout
    | otherwise = needThreadedRTSError "enumReadIsochronous"
    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, MonadBaseControl IO m)
              C'TransferFunc  ( DeviceHandle
                                 EndpointAddress
                                 Size
                                 Timeout
                                 Enumerator s m α
                                )
enumReadSync c'transfer = \devHndl
                           endpoint
                           chunkSize
                           timeout  \iter 
    control $ \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  =
                  control $ \runInIO'  do

                    let stop, cont  Run s m α
                        stop = runInIO'  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