{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DeriveDataTypeable #-}

module System.USB.Internal where


--------------------------------------------------------------------------------
-- Imports
--------------------------------------------------------------------------------

-- from base:
import Prelude                 ( Num, (+), (-), fromInteger, (^)
                               , Integral, fromIntegral, div
                               , Enum, fromEnum, toEnum
                               , error
                               )
import Foreign                 ( unsafePerformIO )
import Foreign.C.Types         ( CUChar, CInt, CUInt )
import Foreign.Marshal.Alloc   ( alloca )
import Foreign.Marshal.Array   ( peekArray, allocaArray )
import Foreign.Storable        ( peek, peekElemOff )
import Foreign.Ptr             ( Ptr, castPtr, plusPtr, nullPtr )
import Foreign.ForeignPtr      ( ForeignPtr, newForeignPtr, withForeignPtr)
import Control.Exception       ( Exception
                               , throwIO
                               , bracket, bracket_
                               , block, unblock
                               , onException
                               )
import Control.Monad           ( Monad, return, (>>=), fail
                               , (>>), (=<<), when, forM, liftM, mapM
                               , fmap
                               )
import Control.Arrow           ( (&&&) )
import Data.Function           ( ($), flip )
import Data.Data               ( Data )
import Data.Typeable           ( Typeable )
import Data.Maybe              ( fromMaybe )
import Data.List               ( lookup )
import Data.Int                ( Int )
import Data.Word               ( Word8, Word16 )
import Data.Char               ( String )
import Data.Eq                 ( Eq, (==) )
import Data.Ord                ( Ord, (<), (>) )
import Data.Bool               ( Bool(False, True)
                               , not, otherwise
                               )
import Data.Bits               ( Bits
                               , (.|.), (.&.)
                               , setBit, testBit
                               , shiftR, shiftL
                               , bitSize
                               )
import System.IO               ( IO )
import Text.Show               ( Show )

-- from base-unicode-symbols:
import Prelude.Unicode         ( (β‹…) )
import Data.Function.Unicode   ( (∘) )
import Data.Bool.Unicode       ( (∧), (∨) )
import Data.Eq.Unicode         ( (β‰), (β‰) )
import Data.Ord.Unicode        ( (β‰), (β‰) )

-- from bytestring:
import qualified Data.ByteString          as B  ( ByteString
                                                , packCStringLen
                                                , drop
                                                , head
                                                , length
                                                , unpack
                                                )
import qualified Data.ByteString.Internal as BI ( createAndTrim
                                                , createAndTrim'
                                                , toForeignPtr
                                                )

-- from text:
import qualified Data.Text          as T  ( unpack )
import qualified Data.Text.Encoding as TE ( decodeUtf16LE )

-- from bindings-libusb:
import Bindings.Libusb


--------------------------------------------------------------------------------
-- * Initialization
--------------------------------------------------------------------------------

{-| Abstract type representing a USB session.

The concept of individual sessions allows your program to use multiple threads
that can independently use this library without interfering with eachother.

Sessions are created and initialized by 'newCtx' and are automatically closed
when garbage collected.

The only functions that receive a @Ctx@ are 'setDebug' and 'getDevices'.
-}
newtype Ctx = Ctx { unCtx ∷ ForeignPtr C'libusb_context }

withCtxPtr ∷ Ctx β†’ (Ptr C'libusb_context β†’ IO Ξ±) β†’ IO Ξ±
withCtxPtr = withForeignPtr ∘ unCtx

-- | Create and initialize a new USB context.
--
-- This function may throw 'USBException's.
newCtx ∷ IO Ctx
newCtx = alloca $ \ctxPtrPtr β†’ do
           handleUSBException $ c'libusb_init ctxPtrPtr
           peek ctxPtrPtr >>= fmap Ctx ∘ newForeignPtr p'libusb_exit

{-| Set message verbosity.

The default level is 'PrintNothing', which means no messages are ever
printed. If you choose to increase the message verbosity level, ensure that your
application does not close the stdout/stderr file descriptors.

You are advised to set level 'PrintWarnings'. libusb is conservative with its
message logging and most of the time, will only log messages that explain error
conditions and other oddities. This will help you debug your software.

If the LIBUSB_DEBUG environment variable was set when libusb was initialized,
this function does nothing: the message verbosity is fixed to the value in the
environment variable.

If libusb was compiled without any message logging, this function does nothing:
you'll never get any messages.

If libusb was compiled with verbose debug message logging, this function does
nothing: you'll always get messages from all levels.
-}
setDebug ∷ Ctx β†’ Verbosity β†’ IO ()
setDebug ctx verbosity =
    withCtxPtr ctx $ \ctxPtr β†’
      c'libusb_set_debug ctxPtr $ genFromEnum verbosity

-- | Message verbosity
data Verbosity =
          PrintNothing  -- ^ No messages are ever printed by the library
        | PrintErrors   -- ^ Error messages are printed to stderr
        | PrintWarnings -- ^ Warning and error messages are printed to stderr
        | PrintInfo     -- ^ Informational messages are printed to stdout,
                        --   warning and error messages are printed to stderr
          deriving Enum


--------------------------------------------------------------------------------
-- * Enumeration
--------------------------------------------------------------------------------

{-| Abstract type representing a USB device detected on the system, usually
originating from 'getDevices'.

Certain operations can be performed on a device, but in order to do any I/O you
will have to first obtain a 'DeviceHandle' using 'openDevice'. Alternatively you
can use the /usb-safe/ package which provides type-safe device handling. See:

<http://hackage.haskell.org/package/usb-safe>

Just because you have a reference to a device does not mean it is necessarily
usable. The device may have been unplugged, you may not have permission to
operate such device, or another program or driver may be using the device.

To get additional information about a device you can retrieve its descriptor
using 'deviceDesc'.
-}
data Device = Device
    { _ctx ∷ Ctx -- ^ This reference to the 'Ctx' is needed so that it won't get
                 --   garbage collected so the finalizer "p'libusb_exit" only
                 --   gets run when all references to 'Devices' are gone.

    , getDevFrgnPtr ∷ ForeignPtr C'libusb_device

    , deviceDesc    ∷ DeviceDesc -- ^ Get the USB device descriptor for a given
                                 --   device.
    }

withDevicePtr ∷ Device β†’ (Ptr C'libusb_device β†’ IO Ξ±) β†’ IO Ξ±
withDevicePtr = withForeignPtr ∘ getDevFrgnPtr

{-| Returns a list of USB devices currently attached to the system.

This is your entry point into finding a USB device to operate.

Exceptions:

 * 'NoMemException' on a memory allocation failure.

-}

{- 
Visual description of the 'devPtrArrayPtr':

                              D
                              ^           D
                          D   β”‚           ^ 
                          ^   β”‚           β”‚
                          β”‚   β”‚           β”‚
devPtrArrayPtr:         ┏━┷━┳━┷━┳━━━┳━━━┳━┷━┓
                 P ───> ┃ P ┃ P ┃ P ┃ P ┃ P ┃
                        ┗━━━┻━━━┻━┯━┻━┯━┻━━━┛
                                  β”‚   β”‚
P = pointer                       v   β”‚
D = device structure              D   β”‚
                                      v
                                      D
-}
getDevices ∷ Ctx β†’ IO [Device]
getDevices ctx =
  withCtxPtr ctx $ \ctxPtr β†’
    alloca $ \devPtrArrayPtr β†’ block $ do

      numDevs ← c'libusb_get_device_list ctxPtr devPtrArrayPtr
      devPtrArray ← peek devPtrArrayPtr

      let freeDevPtrArray = c'libusb_free_device_list devPtrArray 0

      devs ← flip onException freeDevPtrArray $ unblock $
        case numDevs of
          n | n β‰ c'LIBUSB_ERROR_NO_MEM β†’ throwIO NoMemException
            | n < 0 β†’ unknownLibUsbError
            | otherwise β†’ alloca $ \devDescPtr β†’ do
              devPtrs ← peekArray (fromIntegral numDevs) devPtrArray
              forM devPtrs $ \devPtr β†’ do
                devFrgnPtr ← newForeignPtr p'libusb_unref_device devPtr

                handleUSBException $ c'libusb_get_device_descriptor
                                       devPtr
                                       devDescPtr
                devDesc ← convertDeviceDesc devPtr =<< peek devDescPtr

                return $ Device ctx devFrgnPtr devDesc

      freeDevPtrArray
      return devs

-- | Get the number of the bus that a device is connected to.
busNumber ∷ Device β†’ Word8
busNumber dev = -- Getting the bus number from libusb is a side-effect free
                -- operation. The bus number is a static variable in the device
                -- structure. That's why it's safe to use:
                unsafePerformIO
              $ withDevicePtr dev
              $ c'libusb_get_bus_number

-- | Get the address of the device on the bus it is connected to.
deviceAddress ∷ Device β†’ Word8
deviceAddress dev = -- Getting the device address from libusb is a side-effect
                    -- free operation. The device address is a static variable
                    -- in the device structure. That's why it's safe to use:
                    unsafePerformIO
                  $ withDevicePtr dev
                  $ c'libusb_get_device_address


--------------------------------------------------------------------------------
-- * Device handling
--------------------------------------------------------------------------------

--------------------------------------------------------------------------------
-- ** Opening & closing devices
--------------------------------------------------------------------------------

{-| Abstract type representing a handle on a USB device, usually originating
from 'openDevice'.

A device handle is used to perform I/O and other operations. When finished with
a device handle, you should close it by applying 'closeDevice' to it.
-}
data DeviceHandle = DeviceHandle
    { getDevice ∷ Device -- This reference is needed for keeping the 'Device'
                         -- and therefor the 'Ctx' alive.
                         -- ^ Retrieve the 'Device' from the 'DeviceHandle'.
    , getDevHndlPtr ∷ Ptr C'libusb_device_handle
    }

{-| Open a device and obtain a device handle.

A handle allows you to perform I/O on the device in question.

This is a non-blocking function; no requests are sent over the bus.

It is advised to use 'withDeviceHandle' because it automatically closes the
device when the computation terminates.

Exceptions:

 * 'NoMemException' if there is a memory allocation failure.

 * 'AccessException' if the user has insufficient permissions.

 * 'NoDeviceException' if the device has been disconnected.

 * Another 'USBException'.
-}
openDevice ∷ Device β†’ IO DeviceHandle
openDevice dev = withDevicePtr dev $ \devPtr β†’
                   alloca $ \devHndlPtrPtr β†’ do
                     handleUSBException $ c'libusb_open devPtr devHndlPtrPtr
                     liftM (DeviceHandle dev) $ peek devHndlPtrPtr


{-| Close a device handle.

Should be called on all open handles before your application exits.

This is a non-blocking function; no requests are sent over the bus.
-}
closeDevice ∷ DeviceHandle β†’ IO ()
closeDevice = c'libusb_close ∘ getDevHndlPtr

{-| @withDeviceHandle dev act@ opens the 'Device' @dev@ and passes
the resulting handle to the computation @act@. The handle will be closed on exit
from @withDeviceHandle@ whether by normal termination or by raising an
exception.
-}
withDeviceHandle ∷ Device β†’ (DeviceHandle β†’ IO Ξ±) β†’ IO Ξ±
withDeviceHandle dev = bracket (openDevice dev) closeDevice

--------------------------------------------------------------------------------
-- ** Getting & setting the configuration
--------------------------------------------------------------------------------

-- | Identifier for configurations.
--
-- Can be retrieved by 'getConfig' or by 'configValue'.
type ConfigValue = Word8

{-| Determine the bConfigurationValue of the currently active
configuration.

You could formulate your own control request to obtain this information, but
this function has the advantage that it may be able to retrieve the information
from operating system caches (no I/O involved).

If the OS does not cache this information, then this function will block while a
control transfer is submitted to retrieve the information.

This function will return a value of 0 if the device is in unconfigured state.

Exceptions:

 * 'NoDeviceException' if the device has been disconnected.

 * Aanother 'USBException'.
-}
getConfig ∷ DeviceHandle β†’ IO ConfigValue
getConfig devHndl =
    alloca $ \configPtr β†’ do
        handleUSBException $ c'libusb_get_configuration (getDevHndlPtr devHndl)
                                                        configPtr
        fmap fromIntegral $ peek configPtr

{-| Set the active configuration for a device.

The operating system may or may not have already set an active configuration on
the device. It is up to your application to ensure the correct configuration is
selected before you attempt to claim interfaces and perform other operations.

If you call this function on a device already configured with the selected
configuration, then this function will act as a lightweight device reset: it
will issue a SET_CONFIGURATION request using the current configuration, causing
most USB-related device state to be reset (altsetting reset to zero, endpoint
halts cleared, toggles reset).

You cannot change/reset configuration if your application has claimed interfaces
- you should free them with 'releaseInterface' first. You cannot change/reset
configuration if other applications or drivers have claimed interfaces.

A configuration value of -1 will put the device in unconfigured state. The USB
specifications state that a configuration value of 0 does this, however buggy
devices exist which actually have a configuration 0.

You should always use this function rather than formulating your own
SET_CONFIGURATION control request. This is because the underlying operating
system needs to know when such changes happen.

This is a blocking function.

Exceptions:

 * 'NotFoundException' if the requested configuration does not exist.

 * 'BusyException' if interfaces are currently claimed.

 * 'NoDeviceException' if the device has been disconnected

 * Another 'USBException'.
-}
setConfig ∷ DeviceHandle β†’ ConfigValue β†’ IO ()
setConfig devHndl
    = handleUSBException
    ∘ c'libusb_set_configuration (getDevHndlPtr devHndl)
    ∘ fromIntegral

--------------------------------------------------------------------------------
-- ** Claiming & releasing interfaces
--------------------------------------------------------------------------------

{-| Identifier for interfaces.

Can be retrieved by 'interfaceNumber'.
-}
type InterfaceNumber = Word8

{-| Claim an interface on a given device handle.

You must claim the interface you wish to use before you can perform I/O on any
of its endpoints.

It is legal to attempt to claim an already-claimed interface, in which case this
function just returns without doing anything.

Claiming of interfaces is a purely logical operation; it does not cause any
requests to be sent over the bus. Interface claiming is used to instruct the
underlying operating system that your application wishes to take ownership of
the interface.

This is a non-blocking function.

Exceptions:

 * 'NotFoundException' if the requested interface does not exist.

 * 'BusyException' if the interface is already claimed.

 * 'NoDeviceException' if the device has been disconnected.

 * Another 'USBException'.
-}

claimInterface ∷ DeviceHandle β†’ InterfaceNumber β†’ IO ()
claimInterface (DeviceHandle _ devHndlPtr) ifNum =
    handleUSBException $ c'libusb_claim_interface devHndlPtr
                                                  (fromIntegral ifNum)

{-| Release an interface previously claimed with 'claimInterface'.

You should release all claimed interfaces before closing a device handle.

This is a blocking function. A SET_INTERFACE control request will be sent to the
device, resetting interface state to the first alternate setting.

Exceptions:

 * 'NotFoundException' if the interface was not claimed.

 * 'NoDeviceException' if the device has been disconnected

 * Another 'USBException'.
-}
releaseInterface ∷ DeviceHandle β†’ InterfaceNumber β†’ IO ()
releaseInterface (DeviceHandle _ devHndlPtr) ifNum =
  handleUSBException $ c'libusb_release_interface devHndlPtr
                                                  (fromIntegral ifNum)

{-| @withClaimedInterface@ claims the interface on the given device handle then
executes the given computation. On exit from @withClaimedInterface@, the
interface is released whether by normal termination or by raising an exception.
-}
withClaimedInterface ∷ DeviceHandle β†’ InterfaceNumber β†’ IO Ξ± β†’ IO Ξ±
withClaimedInterface devHndl ifNum = bracket_ (claimInterface   devHndl ifNum)
                                              (releaseInterface devHndl ifNum)

--------------------------------------------------------------------------------
-- ** Setting interface alternate settings
--------------------------------------------------------------------------------

-- | Identifier for interface alternate settings.
--
-- Can be retrieved by 'interfaceAltSetting'.
type InterfaceAltSetting = Word8

{-| Activate an alternate setting for an interface.

The interface must have been previously claimed with 'claimInterface' or
'withInterfaceHandle'.

You should always use this function rather than formulating your own
SET_INTERFACE control request. This is because the underlying operating system
needs to know when such changes happen.

This is a blocking function.

Exceptions:

 * 'NotFoundException' if the interface was not claimed or the requested
   alternate setting does not exist.

 * 'NoDeviceException' if the device has been disconnected.

 * Another 'USBException'.
-}
setInterfaceAltSetting ∷ DeviceHandle
                       β†’ InterfaceNumber
                       β†’ InterfaceAltSetting
                       β†’ IO ()
setInterfaceAltSetting devHndl ifNum alternateSetting =
    handleUSBException $
      c'libusb_set_interface_alt_setting (getDevHndlPtr devHndl)
                                         (fromIntegral ifNum)
                                         (fromIntegral alternateSetting)

--------------------------------------------------------------------------------
-- ** Clearing & Resetting devices
--------------------------------------------------------------------------------

{-| Clear the halt/stall condition for an endpoint.

Endpoints with halt status are unable to receive or transmit data until the halt
condition is stalled.

You should cancel all pending transfers before attempting to clear the halt
condition.

This is a blocking function.

Exceptions:

 * 'NotFoundException' if the endpoint does not exist.

 * 'NoDeviceException' if the device has been disconnected.

 * Another 'USBException'.
-}
clearHalt ∷ DeviceHandle β†’ EndpointAddress β†’ IO ()
clearHalt devHndl
    = handleUSBException
    ∘ c'libusb_clear_halt (getDevHndlPtr devHndl)
    ∘ marshalEndpointAddress

{-| Perform a USB port reset to reinitialize a device.

The system will attempt to restore the previous configuration and alternate
settings after the reset has completed.

If the reset fails, the descriptors change, or the previous state cannot be
restored, the device will appear to be disconnected and reconnected. This means
that the device handle is no longer valid (you should close it) and rediscover
the device. A 'NotFoundException' is raised to indicate that this is the
case.

This is a blocking function which usually incurs a noticeable delay.

Exceptions:

 * 'NotFoundException' if re-enumeration is required, or if the
   device has been disconnected.

 * Another 'USBException'.
-}
resetDevice ∷ DeviceHandle β†’ IO ()
resetDevice = handleUSBException ∘ c'libusb_reset_device ∘ getDevHndlPtr

--------------------------------------------------------------------------------
-- ** USB kernel drivers
--------------------------------------------------------------------------------

{-| Determine if a kernel driver is active on an interface.

If a kernel driver is active, you cannot claim the interface, and libusb will be
unable to perform I/O.

Exceptions:

 * 'NoDeviceException' if the device has been disconnected.

 * Another 'USBException'.
-}
kernelDriverActive ∷ DeviceHandle β†’ InterfaceNumber β†’ IO Bool
kernelDriverActive devHndl ifNum = do
  r ← c'libusb_kernel_driver_active (getDevHndlPtr devHndl)
                                     (fromIntegral ifNum)
  case r of
    0 β†’ return False
    1 β†’ return True
    _ β†’ throwIO $ convertUSBException r

{-| Detach a kernel driver from an interface.

If successful, you will then be able to claim the interface and perform I/O.

Exceptions:

 * 'NotFoundException' if no kernel driver was active.

 * 'InvalidParamException' if the interface does not exist.

 * 'NoDeviceException' if the device has been disconnected.

 * Another 'USBException'.
-}
detachKernelDriver ∷ DeviceHandle β†’ InterfaceNumber β†’ IO ()
detachKernelDriver devHndl ifNum =
    handleUSBException $ c'libusb_detach_kernel_driver (getDevHndlPtr devHndl)
                                                       (fromIntegral ifNum)

{-| Re-attach an interface's kernel driver, which was previously
detached using 'detachKernelDriver'.

Exceptions:

 * 'NotFoundException' if no kernel driver was active.

 * 'InvalidParamException' if the interface does not exist.

 * 'NoDeviceException' if the device has been disconnected.

 * 'BusyException' if the driver cannot be attached because the interface
   is claimed by a program or driver.

 * Another 'USBException'.
-}
attachKernelDriver ∷ DeviceHandle β†’ InterfaceNumber β†’ IO ()
attachKernelDriver devHndl ifNum =
    handleUSBException $ c'libusb_attach_kernel_driver (getDevHndlPtr devHndl)
                                                       (fromIntegral ifNum)

{-| If a kernel driver is active on the specified interface the driver is
detached and the given action is executed. If the action terminates, whether by
normal termination or by raising an exception, the kernel driver is attached
again. If a kernel driver is not active on the specified interface the action is
just executed.

Exceptions:

 * 'NoDeviceException' if the device has been disconnected.

 * Another 'USBException'.
-}
withDetachedKernelDriver ∷ DeviceHandle β†’ InterfaceNumber β†’ IO Ξ± β†’ IO Ξ±
withDetachedKernelDriver devHndl ifNum action =
    ifM (kernelDriverActive devHndl ifNum)
        (bracket_ (detachKernelDriver devHndl ifNum)
                  (attachKernelDriver devHndl ifNum)
                  action)
        action


--------------------------------------------------------------------------------
-- * Descriptors
--------------------------------------------------------------------------------

--------------------------------------------------------------------------------
-- ** Device descriptor
--------------------------------------------------------------------------------

{-| A structure representing the standard USB device descriptor.

This descriptor is documented in section 9.6.1 of the USB 2.0 specification.

This structure can be retrieved by 'deviceDesc'.
-}
data DeviceDesc = DeviceDesc
    { deviceUSBSpecReleaseNumber ∷ BCD4      -- ^ USB specification release
                                             --   number in binary-coded
                                             --   decimal.

    , deviceClass                ∷ Word8     -- ^ USB-IF class code for the
                                             --   device.
    , deviceSubClass             ∷ Word8     -- ^ USB-IF subclass code for the
                                             --   device, qualified by the
                                             --   'deviceClass' value.

    , deviceProtocol             ∷ Word8     -- ^ USB-IF protocol code for the
                                             --   device, qualified by the
                                             --   'deviceClass' and
                                             --   'deviceSubClass' values.

    , deviceMaxPacketSize0       ∷ Word8     -- ^ Maximum packet size for
                                             --   endpoint 0.

    , deviceVendorId             ∷ VendorId  -- ^ USB-IF vendor ID.
    , deviceProductId            ∷ ProductId -- ^ USB-IF product ID.

    , deviceReleaseNumber        ∷ BCD4      -- ^ Device release number in
                                             --   binary-coded decimal.

    , deviceManufacturerStrIx    ∷ StrIx     -- ^ Index of string descriptor
                                             --   describing manufacturer.
    , deviceProductStrIx         ∷ StrIx     -- ^ Index of string descriptor
                                             --   describing product.
    , deviceSerialNumberStrIx    ∷ StrIx     -- ^ Index of string descriptor
                                             --   containing device serial
                                             --   number.

    , deviceNumConfigs           ∷ Word8     -- ^ Number of possible
                                             --   configurations.

    , deviceConfigs              ∷ [ConfigDesc] -- ^ List of configurations
                                                --   supported by the device.
    } deriving (Show, Eq, Data, Typeable)

type VendorId  = Word16
type ProductId = Word16

convertDeviceDesc ∷ Ptr C'libusb_device
                  β†’ C'libusb_device_descriptor
                  β†’ IO DeviceDesc
convertDeviceDesc devPtr d = do
    let numConfigs = c'libusb_device_descriptor'bNumConfigurations d

    configs ← mapM (getConfigDesc devPtr) [0..numConfigs-1]

    return DeviceDesc
      { deviceUSBSpecReleaseNumber = unmarshalBCD4 $
                                     c'libusb_device_descriptor'bcdUSB d
      , deviceClass                = c'libusb_device_descriptor'bDeviceClass d
      , deviceSubClass             = c'libusb_device_descriptor'bDeviceSubClass d
      , deviceProtocol             = c'libusb_device_descriptor'bDeviceProtocol d
      , deviceMaxPacketSize0       = c'libusb_device_descriptor'bMaxPacketSize0 d
      , deviceVendorId             = c'libusb_device_descriptor'idVendor d
      , deviceProductId            = c'libusb_device_descriptor'idProduct d
      , deviceReleaseNumber        = unmarshalBCD4 $
                                     c'libusb_device_descriptor'bcdDevice d
      , deviceManufacturerStrIx    = c'libusb_device_descriptor'iManufacturer d
      , deviceProductStrIx         = c'libusb_device_descriptor'iProduct d
      , deviceSerialNumberStrIx    = c'libusb_device_descriptor'iSerialNumber d
      , deviceNumConfigs           = numConfigs
      , deviceConfigs              = configs
      }

--------------------------------------------------------------------------------
-- ** Configuration descriptor
--------------------------------------------------------------------------------

{-| A structure representing the standard USB configuration descriptor.

This descriptor is documented in section 9.6.3 of the USB 2.0 specification.

This structure can be retrieved by 'deviceConfigs'.
-}
data ConfigDesc = ConfigDesc
    { configValue          ∷ ConfigValue -- ^ Identifier value for the
                                         --   configuration.

    , configStrIx          ∷ StrIx       -- ^ Index of string descriptor
                                         --   describing the configuration.
    , configAttribs        ∷ ConfigAttribs
                                         -- ^ Configuration characteristics.
    , configMaxPower       ∷ Word8       -- ^ Maximum power consumption of the
                                         --   USB device from the bus in the
                                         --   configuration when the device is
                                         --   fully operational.  Expressed in
                                         --   2 mA units (i.e., 50 = 100 mA).

    , configNumInterfaces  ∷ Word8       -- ^ Number of interfaces supported by
                                         --   the configuration.
    , configInterfaces     ∷ [Interface] -- ^ List of interfaces supported by
                                         --   the configuration.
                                         --   Note that the length of this list
                                         --   should equal
                                         --   'configNumInterfaces'.

    , configExtra          ∷ B.ByteString
                                         -- ^ Extra descriptors. If libusb
                                         --   encounters unknown configuration
                                         --   descriptors, it will store them
                                         --   here, should you wish to parse
                                         --   them.
    } deriving (Show, Eq, Data, Typeable)

-- | An interface is represented as a list of alternate interface settings.
type Interface = [InterfaceDesc]

--------------------------------------------------------------------------------
-- *** Configuration attributes
--------------------------------------------------------------------------------

type ConfigAttribs = DeviceStatus

data DeviceStatus = DeviceStatus
    { remoteWakeup ∷ Bool -- ^ The Remote Wakeup field indicates whether the
                          --   device is currently enabled to request remote
                          --   wakeup. The default mode for devices that
                          --   support remote wakeup is disabled.
    , selfPowered  ∷ Bool -- ^ The Self Powered field indicates whether the
                          --   device is currently self-powered
    } deriving (Show, Eq, Data, Typeable)

unmarshalConfigAttribs ∷ Word8 β†’ ConfigAttribs
unmarshalConfigAttribs a =
    DeviceStatus { remoteWakeup = testBit a 5
                 , selfPowered  = testBit a 6
                 }

--------------------------------------------------------------------------------

getConfigDesc ∷ Ptr C'libusb_device β†’ Word8 β†’ IO ConfigDesc
getConfigDesc devPtr ix =
    alloca $ \configDescPtrPtr β†’
      bracket ( do handleUSBException $ c'libusb_get_config_descriptor
                                          devPtr
                                          ix
                                          configDescPtrPtr
                   peek configDescPtrPtr
              )
              c'libusb_free_config_descriptor
              ((convertConfigDesc =<<) ∘ peek)

--------------------------------------------------------------------------------

convertConfigDesc ∷ C'libusb_config_descriptor β†’ IO ConfigDesc
convertConfigDesc c = do
    let numInterfaces = c'libusb_config_descriptor'bNumInterfaces c

    interfaces ← peekArray (fromIntegral numInterfaces)
                            (c'libusb_config_descriptor'interface c) >>=
                  mapM convertInterface

    extra ← B.packCStringLen
               ( castPtr      $ c'libusb_config_descriptor'extra        c
               , fromIntegral $ c'libusb_config_descriptor'extra_length c
               )

    return ConfigDesc
      { configValue         = c'libusb_config_descriptor'bConfigurationValue c
      , configStrIx         = c'libusb_config_descriptor'iConfiguration      c
      , configAttribs       = unmarshalConfigAttribs $
                              c'libusb_config_descriptor'bmAttributes        c
      , configMaxPower      = c'libusb_config_descriptor'MaxPower            c
      , configNumInterfaces = numInterfaces
      , configInterfaces    = interfaces
      , configExtra         = extra
      }

convertInterface∷ C'libusb_interface β†’ IO [InterfaceDesc]
convertInterface i =
    peekArray (fromIntegral $ c'libusb_interface'num_altsetting i)
              (c'libusb_interface'altsetting i) >>=
    mapM convertInterfaceDesc

--------------------------------------------------------------------------------
-- ** Interface descriptor
--------------------------------------------------------------------------------

{-| A structure representing the standard USB interface descriptor.

This descriptor is documented in section 9.6.5 of the USB 2.0 specification.

This structure can be retrieved using 'configInterfaces'.
-}
data InterfaceDesc = InterfaceDesc
    { interfaceNumber       ∷ InterfaceNumber     -- ^ Number of the
                                                  --   interface.
    , interfaceAltSetting   ∷ InterfaceAltSetting -- ^ Value used to select
                                                  --   the alternate setting
                                                  --   for the interface.
    , interfaceClass        ∷ Word8               -- ^ USB-IF class code for
                                                  --   the interface.
    , interfaceSubClass     ∷ Word8               -- ^ USB-IF subclass code for
                                                  --   the interface,
                                                  --   qualified by the
                                                  --   'interfaceClass' value.
    , interfaceProtocol     ∷ Word8               -- ^ USB-IF protocol code for
                                                  --   the interface,
                                                  --   qualified by the
                                                  --   'interfaceClass' and
                                                  --   'interfaceSubClass'
                                                  --   values.
    , interfaceStrIx        ∷ StrIx               -- ^ Index of string
                                                  --   descriptor describing
                                                  --   the interface.
    , interfaceEndpoints    ∷ [EndpointDesc]      -- ^ List of endpoints
                                                  --   supported by the
                                                  --   interface.
    , interfaceExtra        ∷ B.ByteString        -- ^ Extra descriptors. If
                                                  --   libusb encounters
                                                  --   unknown interface
                                                  --   descriptors, it will
                                                  --   store them here, should
                                                  --   you wish to parse them.
    } deriving (Show, Eq, Data, Typeable)

--------------------------------------------------------------------------------

convertInterfaceDesc ∷ C'libusb_interface_descriptor β†’ IO InterfaceDesc
convertInterfaceDesc i = do
  let n = c'libusb_interface_descriptor'bNumEndpoints i

  endpoints ← peekArray (fromIntegral n)
                         (c'libusb_interface_descriptor'endpoint i) >>=
               mapM convertEndpointDesc

  extra ← B.packCStringLen
             ( castPtr      $ c'libusb_interface_descriptor'extra        i
             , fromIntegral $ c'libusb_interface_descriptor'extra_length i
             )

  return InterfaceDesc
    { interfaceNumber     = c'libusb_interface_descriptor'bInterfaceNumber   i
    , interfaceAltSetting = c'libusb_interface_descriptor'bAlternateSetting  i
    , interfaceClass      = c'libusb_interface_descriptor'bInterfaceClass    i
    , interfaceSubClass   = c'libusb_interface_descriptor'bInterfaceSubClass i
    , interfaceStrIx      = c'libusb_interface_descriptor'iInterface         i
    , interfaceProtocol   = c'libusb_interface_descriptor'bInterfaceProtocol i
    , interfaceEndpoints  = endpoints
    , interfaceExtra      = extra
    }

--------------------------------------------------------------------------------
-- ** Endpoint descriptor
--------------------------------------------------------------------------------

{-| A structure representing the standard USB endpoint descriptor.

This descriptor is documented in section 9.6.3 of the USB 2.0 specification. All
multiple-byte fields are represented in host-endian format.
-}
data EndpointDesc = EndpointDesc
    { endpointAddress        ∷ EndpointAddress
                                      -- ^ The address of the endpoint described
                                      --   by the descriptor.
    , endpointAttribs        ∷ EndpointAttribs
                                      -- ^ Attributes which apply to the
                                      --   endpoint when it is configured using
                                      --   the 'configValue'.
    , endpointMaxPacketSize  ∷ MaxPacketSize
                                      -- ^ Maximum packet size the endpoint is
                                      --   capable of sending/receiving.
    , endpointInterval       ∷ Word8  -- ^ Interval for polling endpoint for
                                      --   data transfers. Expressed in frames
                                      --   or microframes depending on the
                                      --   device operating speed (i.e., either
                                      --   1 millisecond or 125 ΞΌs units).
    , endpointRefresh        ∷ Word8  -- ^ /For audio devices only:/ the rate at
                                      --   which synchronization feedback is
                                      --   provided.
    , endpointSynchAddress   ∷ Word8  -- ^ /For audio devices only:/ the address
                                      --   if the synch endpoint.
    , endpointExtra          ∷ B.ByteString
                                      -- ^ Extra descriptors. If libusb
                                      --   encounters unknown endpoint
                                      --   descriptors, it will store
                                      --   them here, should you wish to
                                      --   parse them.
    } deriving (Show, Eq, Data, Typeable)

--------------------------------------------------------------------------------

convertEndpointDesc ∷ C'libusb_endpoint_descriptor
                    β†’ IO EndpointDesc
convertEndpointDesc e = do
  extra ← B.packCStringLen
             ( castPtr      $ c'libusb_endpoint_descriptor'extra        e
             , fromIntegral $ c'libusb_endpoint_descriptor'extra_length e
             )

  return EndpointDesc
    { endpointAddress       = unmarshalEndpointAddress $
                              c'libusb_endpoint_descriptor'bEndpointAddress e
    , endpointAttribs       = unmarshalEndpointAttribs $
                              c'libusb_endpoint_descriptor'bmAttributes     e
    , endpointMaxPacketSize = unmarshalMaxPacketSize $
                              c'libusb_endpoint_descriptor'wMaxPacketSize   e
    , endpointInterval      = c'libusb_endpoint_descriptor'bInterval        e
    , endpointRefresh       = c'libusb_endpoint_descriptor'bRefresh         e
    , endpointSynchAddress  = c'libusb_endpoint_descriptor'bSynchAddress    e
    , endpointExtra         = extra
    }

--------------------------------------------------------------------------------
-- *** Endpoint address
--------------------------------------------------------------------------------

-- | The address of an endpoint.
data EndpointAddress = EndpointAddress
    { endpointNumber    ∷ Int -- ^ Must be >= 0 and <= 15
    , transferDirection ∷ TransferDirection
    } deriving (Show, Eq, Data, Typeable)

-- | The direction of data transfer relative to the host.
data TransferDirection = Out -- ^ Out transfer direction (host β†’ device) used
                             --   for writing.
                       | In  -- ^ In transfer direction (device β†’ host) used
                             --   for reading.
                 deriving (Show, Eq, Data, Typeable)

unmarshalEndpointAddress ∷ Word8 β†’ EndpointAddress
unmarshalEndpointAddress a =
    EndpointAddress { endpointNumber    = fromIntegral $ bits 0 3 a
                    , transferDirection = if testBit a 7
                                          then In
                                          else Out
                    }

marshalEndpointAddress ∷ (Bits a, Num a)
                       β‡’ EndpointAddress β†’ a
marshalEndpointAddress (EndpointAddress num transDir)
    | between num 0 15 = let n = fromIntegral num
                         in case transDir of
                              Out β†’ n
                              In  β†’ setBit n 7
    | otherwise =
        error "marshalEndpointAddress: endpointNumber not >= 0 and <= 15"

--------------------------------------------------------------------------------
-- *** Endpoint attributes
--------------------------------------------------------------------------------

type EndpointAttribs = TransferType

data TransferType = Control
                  | Isochronous Synchronization Usage
                  | Bulk
                  | Interrupt
                    deriving (Show, Eq, Data, Typeable)

data Synchronization = NoSynchronization
                     | Asynchronous
                     | Adaptive
                     | Synchronous
                       deriving (Enum, Show, Eq, Data, Typeable)

data Usage = Data
           | Feedback
           | Implicit
             deriving (Enum, Show, Eq, Data, Typeable)

unmarshalEndpointAttribs ∷ Word8 β†’ EndpointAttribs
unmarshalEndpointAttribs a =
    case bits 0 1 a of
      0 β†’ Control
      1 β†’ Isochronous (genToEnum $ bits 2 3 a)
                       (genToEnum $ bits 4 5 a)
      2 β†’ Bulk
      3 β†’ Interrupt
      _ β†’ error "unmarshalEndpointAttribs: this can't happen!"

--------------------------------------------------------------------------------
-- *** Endpoint max packet size
--------------------------------------------------------------------------------

data MaxPacketSize = MaxPacketSize
    { maxPacketSize            ∷ Size
    , transactionOpportunities ∷ TransactionOpportunities
    } deriving (Show, Eq, Data, Typeable)

-- | Number of additional transactions.
data TransactionOpportunities = Zero | One | Two
                                deriving (Enum, Show, Eq, Data, Typeable)

unmarshalMaxPacketSize ∷ Word16 β†’ MaxPacketSize
unmarshalMaxPacketSize m =
    MaxPacketSize
    { maxPacketSize            = fromIntegral $ bits 0  10 m
    , transactionOpportunities = genToEnum    $ bits 11 12 m
    }

--------------------------------------------------------------------------------
-- ** String descriptors
--------------------------------------------------------------------------------

strDescHeaderSize ∷ Size
strDescHeaderSize = 2

{-| Retrieve a list of supported languages.

This function may throw 'USBException's.
-}
getLanguages ∷ DeviceHandle β†’ IO [LangId]
getLanguages devHndl =
    let maxSize = 255 -- Some devices choke on size > 255
    in allocaArray maxSize $ \dataPtr β†’ do
      reportedSize ← putStrDesc devHndl 0 0 maxSize dataPtr
      fmap (fmap unmarshalLangId) $
           peekArray ((reportedSize - strDescHeaderSize) `div` 2)
                     (castPtr $ dataPtr `plusPtr` strDescHeaderSize)


{-| @putStrDesc devHndl strIx langId maxSize dataPtr@ retrieves the
string descriptor @strIx@ in the language @langId@ from the @devHndl@
and writes at most @maxSize@ bytes from that string descriptor to the
location that @dataPtr@ points to. So ensure there is at least space
for @maxSize@ bytes there. Next, the header of the string descriptor
is checked for correctness. If it's incorrect an 'IOException' is
thrown. Finally, the size reported in the header is returned.
-}
putStrDesc ∷ DeviceHandle
           β†’ StrIx
           β†’ Word16
           β†’ Size
           β†’ Ptr CUChar
           β†’ IO Size
putStrDesc devHndl strIx langId maxSize dataPtr = do
    actualSize ← checkUSBException $ c'libusb_get_string_descriptor
                                        (getDevHndlPtr devHndl)
                                        strIx
                                        langId
                                        dataPtr
                                        (fromIntegral maxSize)
    -- if there're enough bytes, parse the header
    when (actualSize < strDescHeaderSize) $ throwIO IOException
    reportedSize ← peek dataPtr
    descType ← peekElemOff dataPtr 1

    -- Check header correctness:
    when ( descType β‰ c'LIBUSB_DT_STRING
         ∨ reportedSize > fromIntegral actualSize
         ) $ throwIO IOException

    return $ fromIntegral reportedSize

{-| The language ID consists of the primary language identifier and the
sublanguage identififier as described in:

<http://www.usb.org/developers/docs/USB_LANGIDs.pdf>

For a mapping between IDs and languages see the /usb-id-database/ package at:

<http://hackage.haskell.org/package/usb-id-database>

To see which 'LangId's are supported by a device see 'getLanguages'.
-}
type LangId = (PrimaryLangId, SubLangId)
type PrimaryLangId = Word16
type SubLangId     = Word16

unmarshalLangId ∷ Word16 β†’ LangId
unmarshalLangId = bits 0 9 &&& bits 10 15

marshalLangId ∷ LangId β†’ Word16
marshalLangId (p, s) = p .|. s `shiftL`10

-- | Type of indici of string descriptors.
--
-- Can be retrieved by all the *StrIx functions.
type StrIx = Word8

{-| Retrieve a string descriptor from a device.

This is a convenience function which formulates the appropriate control message
to retrieve the descriptor. The string returned is Unicode, as detailed in the
USB specifications.

This function may throw 'USBException's.
-}
getStrDesc ∷ DeviceHandle β†’ StrIx β†’ LangId β†’ Size β†’ IO String
getStrDesc devHndl strIx langId size =
    fmap (T.unpack ∘ TE.decodeUtf16LE ∘ B.drop strDescHeaderSize) $
         BI.createAndTrim size $ putStrDesc
                                   devHndl
                                   strIx
                                   (marshalLangId langId)
                                   size
                               ∘ castPtr

{-| Retrieve a string descriptor from a device using the first supported
language.

This is a convenience function which formulates the appropriate control message
to retrieve the descriptor. The string returned is Unicode, as detailed in the
USB specifications.

This function may throw 'USBException's.
-}
getStrDescFirstLang ∷ DeviceHandle β†’ StrIx β†’ Size β†’ IO String
getStrDescFirstLang devHndl strIx size =
    do langIds ← getLanguages devHndl
       case langIds of
         []         β†’ throwIO IOException
         langId : _ β†’ getStrDesc devHndl strIx langId size


--------------------------------------------------------------------------------
-- * Asynchronous device I/O
--------------------------------------------------------------------------------

-- TODO: Not implemented yet. I'm not sure if I should implement it because you
-- can simulate asynchronous IO using threads.


--------------------------------------------------------------------------------
-- * Synchronous device I/O
--------------------------------------------------------------------------------

{-| Handy type synonym for read transfers.

A @ReadAction@ is a function which takes a 'Timeout' and a 'Size' which defines
how many bytes to read. The function returns an 'IO' action which, when
executed, performs the actual read and returns the 'B.ByteString' that was read
paired with an indication if the transfer timed out.
-}
type ReadAction  = Timeout β†’ Size β†’ IO (B.ByteString, Bool)

{-| Handy type synonym for write transfers.

A @WriteAction@ is a function which takes a 'Timeout' and the 'B.ByteString' to
write. The function returns an 'IO' action which, when exectued, returns the
number of bytes that were actually written paired with an indication if the
transfer timed out.
-}
type WriteAction = Timeout β†’ B.ByteString β†’ IO (Size, Bool)

-- | A timeout in millseconds. A timeout defines how long a transfer should wait
-- before giving up due to no response being received. For no timeout, use value
-- 0.
type Timeout = Int

-- | Number of bytes transferred.
type Size = Int

 -------------------------------------------------------------------------------
-- ** Control transfers
-------------------------------------------------------------------------------

data RequestType = Standard
                 | Class
                 | Vendor
                   deriving (Enum, Show, Eq, Data, Typeable)

data Recipient = ToDevice
               | ToInterface
               | ToEndpoint
               | ToOther
                 deriving (Enum, Show, Eq, Data, Typeable)

marshalRequestType ∷ RequestType β†’ Recipient β†’ Word8
marshalRequestType t r = genFromEnum t `shiftL` 5 .|. genFromEnum r

{-| Perform a USB /control/ request that does not transfer data.

The /value/ and /index/ values should be given in host-endian byte order.

Exceptions:

 * 'TimeoutException' if the transfer timed out.

 * 'PipeException' if the control request was not supported by the device

 * 'NoDeviceException' if the device has been disconnected.

 *  Another 'USBException'.
-}
control ∷ DeviceHandle -- ^ A handle for the device to communicate with.
        β†’ RequestType  -- ^ The type of request.
        β†’ Recipient    -- ^ The recipient of the request.
        β†’ Word8        -- ^ Request.
        β†’ Word16       -- ^ Value.
        β†’ Word16       -- ^ Index.
        β†’ Timeout      -- ^ Timeout (in milliseconds) that this function should
                        --   wait before giving up due to no response being
                        --   received.  For no timeout, use value 0.
        β†’ IO ()
control devHndl reqType reqRecipient request value index timeout =
      ignore ∘ checkUSBException $ c'libusb_control_transfer
                                     (getDevHndlPtr devHndl)
                                     (marshalRequestType reqType reqRecipient)
                                     request
                                     value
                                     index
                                     nullPtr
                                     0
                                     (fromIntegral timeout)

{-| Perform a USB /control/ read.

The /value/ and /index/ values should be given in host-endian byte order.

Exceptions:

 * 'PipeException' if the control request was not supported by the device

 * 'NoDeviceException' if the device has been disconnected.

 *  Another 'USBException'.
-}
readControl ∷ DeviceHandle -- ^ A handle for the device to communicate with.
            β†’ RequestType  -- ^ The type of request.
            β†’ Recipient    -- ^ The recipient of the request.
            β†’ Word8        -- ^ Request.
            β†’ Word16       -- ^ Value.
            β†’ Word16       -- ^ Index.
            β†’ ReadAction
readControl devHndl reqType reqRecipient request value index = \timeout size β†’
    BI.createAndTrim' size $ \dataPtr β†’ do
      err ← c'libusb_control_transfer
              (getDevHndlPtr devHndl)
              (setBit (marshalRequestType reqType reqRecipient)
                      7
              )
              request
              value
              index
              (castPtr dataPtr)
              (fromIntegral size)
              (fromIntegral timeout)
      let timedOut = err β‰ c'LIBUSB_ERROR_TIMEOUT
      if err < 0 ∧ not timedOut
        then throwIO $ convertUSBException err
        else return (0, fromIntegral err, timedOut)

{-| Perform a USB /control/ write.

The /value/ and /index/ values should be given in host-endian byte order.

Exceptions:

 * 'PipeException' if the control request was not supported by the device

 * 'NoDeviceException' if the device has been disconnected.

 *  Another 'USBException'.
-}
writeControl ∷ DeviceHandle -- ^ A handle for the device to communicate with.
             β†’ RequestType  -- ^ The type of request.
             β†’ Recipient    -- ^ The recipient of the request.
             β†’ Word8        -- ^ Request.
             β†’ Word16       -- ^ Value.
             β†’ Word16       -- ^ Index.
             β†’ WriteAction
writeControl devHndl reqType reqRecipient request value index = \timeout input β†’
    input `writeWith` \size dataPtr β†’ do
      err ← c'libusb_control_transfer
              (getDevHndlPtr devHndl)
              (marshalRequestType reqType reqRecipient)
              request
              value
              index
              (castPtr dataPtr)
              (fromIntegral size)
              (fromIntegral timeout)
      let timedOut = err β‰ c'LIBUSB_ERROR_TIMEOUT
      if err < 0 ∧ not timedOut
        then throwIO $ convertUSBException err
        else return (fromIntegral err, timedOut)

--------------------------------------------------------------------------------
-- *** Standard Device Requests
-------------------------------------------------------------------------------

-- See: USB 2.0 Spec. section 9.4

-- Standard Feature Selectors:
-- See: USB 2.0 Spec. table 9-6
haltFeature, remoteWakeupFeature, testModeFeature ∷ Word16
remoteWakeupFeature = 1
haltFeature         = 0
testModeFeature     = 2

-- | See: USB 2.0 Spec. section 9.4.9
setHalt ∷ DeviceHandle β†’ EndpointAddress β†’ Timeout β†’ IO ()
setHalt devHndl endpointAddr =
    control devHndl
            Standard
            ToEndpoint
            c'LIBUSB_REQUEST_SET_FEATURE
            haltFeature
            (marshalEndpointAddress endpointAddr)

-- | See: USB 2.0 Spec. section 9.4.1
clearRemoteWakeup ∷ DeviceHandle β†’ Timeout β†’ IO ()
clearRemoteWakeup devHndl =
    control devHndl
            Standard
            ToDevice
            c'LIBUSB_REQUEST_CLEAR_FEATURE
            remoteWakeupFeature
            0

-- | See: USB 2.0 Spec. section 9.4.9
setRemoteWakeup ∷ DeviceHandle β†’ Timeout β†’ IO ()
setRemoteWakeup devHndl =
    control devHndl
            Standard
            ToDevice
            c'LIBUSB_REQUEST_SET_FEATURE
            remoteWakeupFeature
            0

-- | See: USB 2.0 Spec. section 9.4.9
-- TODO: What about vendor-specific test modes?
setStandardTestMode ∷ DeviceHandle β†’ TestMode β†’ Timeout β†’ IO ()
setStandardTestMode devHndl testMode =
    control devHndl
            Standard
            ToDevice
            c'LIBUSB_REQUEST_SET_FEATURE
            testModeFeature
            (genFromEnum testMode + 1 `shiftL` 8)

-- | See: USB 2.0 Spec. table 9-7
data TestMode = Test_J
              | Test_K
              | Test_SE0_NAK
              | Test_Packet
              | Test_Force_Enable
                deriving (Show, Enum, Data, Typeable)

-- | See: USB 2.0 Spec. section 9.4.4
getInterfaceAltSetting ∷ DeviceHandle
                       β†’ InterfaceNumber
                       β†’ Timeout
                       β†’ IO InterfaceAltSetting
getInterfaceAltSetting devHndl ifNum timeout = do
  (bs, _) ← readControl devHndl
                        Standard
                        ToInterface
                        c'LIBUSB_REQUEST_GET_INTERFACE
                        0
                        (fromIntegral ifNum)
                        1
                        timeout
  if B.length bs β‰ 1
    then throwIO IOException
    else return $ B.head bs

-- | See: USB 2.0 Spec. section 9.4.5
getDeviceStatus ∷ DeviceHandle β†’ Timeout β†’ IO DeviceStatus
getDeviceStatus devHndl timeout = do
  (bs, _) ← readControl devHndl
                        Standard
                        ToDevice
                        c'LIBUSB_REQUEST_GET_STATUS
                        0
                        0
                        2
                        timeout
  if B.length bs β‰ 2
    then throwIO IOException
    else return $ unmarshalDeviceStatus $ B.head bs
  where
    unmarshalDeviceStatus ∷ Word8 β†’ DeviceStatus
    unmarshalDeviceStatus a =
        DeviceStatus { remoteWakeup = testBit a 1
                     , selfPowered  = testBit a 0
                     }

-- | See: USB 2.0 Spec. section 9.4.5
getEndpointStatus ∷ DeviceHandle
                  β†’ EndpointAddress
                  β†’ Timeout
                  β†’ IO Bool
getEndpointStatus devHndl endpointAddr timeout = do
  (bs, _) ← readControl devHndl
                        Standard
                        ToEndpoint
                        c'LIBUSB_REQUEST_GET_STATUS
                        0
                        (marshalEndpointAddress endpointAddr)
                        2
                        timeout
  if B.length bs β‰ 2
    then throwIO IOException
    else return $ B.head bs β‰ 1

-- | See: USB 2.0 Spec. section 9.4.6
setDeviceAddress ∷ DeviceHandle β†’ Word16 β†’ Timeout β†’ IO ()
setDeviceAddress devHndl deviceAddr =
    control devHndl
            Standard
            ToDevice
            c'LIBUSB_REQUEST_SET_ADDRESS
            deviceAddr
            0

-- TODO: setDescriptor See: USB 2.0 Spec. section 9.4.8

-- | See: USB 2.0 Spec. section 9.4.11
synchFrame ∷ DeviceHandle β†’ EndpointAddress β†’ Timeout β†’ IO Int
synchFrame devHndl endpointAddr timeout = do
  (bs, _) ← readControl devHndl
                        Standard
                        ToEndpoint
                        c'LIBUSB_REQUEST_SYNCH_FRAME
                        0
                        (marshalEndpointAddress endpointAddr)
                        2
                        timeout
  if B.length bs β‰ 2
    then throwIO IOException
    else return $ let [h, l] = B.unpack bs
                  in fromIntegral h β‹… 256 + fromIntegral l

--------------------------------------------------------------------------------
-- ** Bulk transfers
--------------------------------------------------------------------------------

{-| Perform a USB /bulk/ read.

Exceptions:

 * 'PipeException' if the endpoint halted.

 * 'OverflowException' if the device offered more data,
   see /Packets and overflows/ in the libusb documentation:
   <http://libusb.sourceforge.net/api-1.0/packetoverflow.html>.

 * 'NoDeviceException' if the device has been disconnected.

 * Another 'USBException'.
-}
readBulk ∷ 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.
         β†’ ReadAction
readBulk = readTransfer c'libusb_bulk_transfer

{-| Perform a USB /bulk/ write.

Exceptions:

 * 'PipeException' if the endpoint halted.

 * 'OverflowException' if the device offered more data,
   see /Packets and overflows/ in the libusb documentation:
   <http://libusb.sourceforge.net/api-1.0/packetoverflow.html>.

 * 'NoDeviceException' if the device has been disconnected.

 * Another 'USBException'.
-}
writeBulk ∷ DeviceHandle    -- ^ A handle for the device to communicate with.
          β†’ EndpointAddress -- ^ The address of a valid 'Out' 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.
          β†’ WriteAction
writeBulk = writeTransfer c'libusb_bulk_transfer

--------------------------------------------------------------------------------
-- ** Interrupt transfers
--------------------------------------------------------------------------------

{-| Perform a USB /interrupt/ read.

Exceptions:

 * 'PipeException' if the endpoint halted.

 * 'OverflowException' if the device offered more data,
   see /Packets and overflows/ in the libusb documentation:
   <http://libusb.sourceforge.net/api-1.0/packetoverflow.html>.

 * 'NoDeviceException' if the device has been disconnected.

 * Another 'USBException'.
-}
readInterrupt ∷ 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.
              β†’ ReadAction
readInterrupt = readTransfer c'libusb_interrupt_transfer

{-| Perform a USB /interrupt/ write.

Exceptions:

 * 'PipeException' if the endpoint halted.

 * 'OverflowException' if the device offered more data,
   see /Packets and overflows/ in the libusb documentation:
   <http://libusb.sourceforge.net/api-1.0/packetoverflow.html>.

 * 'NoDeviceException' if the device has been disconnected.

 * Another 'USBException'.
-}
writeInterrupt ∷ DeviceHandle    -- ^ A handle for the device to communicate
                                 --   with.
               β†’ EndpointAddress -- ^ The address of a valid 'Out' 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.
               β†’ WriteAction
writeInterrupt = writeTransfer c'libusb_interrupt_transfer

--------------------------------------------------------------------------------

type C'TransferFunc = Ptr C'libusb_device_handle -- devHndlPtr
                    β†’ CUChar                     -- endpoint address
                    β†’ Ptr CUChar                 -- dataPtr
                    β†’ CInt                       -- size
                    β†’ Ptr CInt                   -- transferredPtr
                    β†’ CUInt                      -- timeout
                    β†’ IO CInt                    -- error

readTransfer ∷ C'TransferFunc β†’ DeviceHandle
                              β†’ EndpointAddress
                              β†’ ReadAction
readTransfer c'transfer devHndl endpointAddr = \timeout size β†’
    BI.createAndTrim' size $ \dataPtr β†’ do
        (transferred, timedOut) ← transfer c'transfer
                                           devHndl
                                           endpointAddr
                                           timeout
                                           size
                                           dataPtr
        return (0, transferred, timedOut)

writeTransfer ∷ C'TransferFunc β†’ DeviceHandle
                               β†’ EndpointAddress
                               β†’ WriteAction
writeTransfer c'transfer devHndl endpointAddr = \timeout input β†’
    input `writeWith` transfer c'transfer
                               devHndl
                               endpointAddr
                               timeout

transfer ∷ C'TransferFunc β†’ DeviceHandle
                          β†’ EndpointAddress
                          β†’ Timeout β†’ Size β†’ Ptr Word8 β†’ IO (Size, Bool)
transfer c'transfer devHndl
                    endpointAddr
                    timeout size dataPtr =
    alloca $ \transferredPtr β†’ do
      err ← c'transfer (getDevHndlPtr devHndl)
                        (marshalEndpointAddress endpointAddr)
                        (castPtr dataPtr)
                        (fromIntegral size)
                        transferredPtr
                        (fromIntegral timeout)
      let timedOut = err β‰ c'LIBUSB_ERROR_TIMEOUT
      if err β‰ c'LIBUSB_SUCCESS ∧ not timedOut
        then throwIO $ convertUSBException err
        else do transferred ← peek transferredPtr
                return (fromIntegral transferred, timedOut)


--------------------------------------------------------------------------------
-- * Exceptions
--------------------------------------------------------------------------------

-- | @handleUSBException action@ executes @action@. If @action@ returned an
-- error code other than 'c\'LIBUSB_SUCCESS', the error is converted to a
-- 'USBException' and thrown.
handleUSBException ∷ IO CInt β†’ IO ()
handleUSBException action = do err ← action
                               when (err β‰ c'LIBUSB_SUCCESS)
                                    (throwIO $ convertUSBException err)

-- | @checkUSBException action@ executes @action@. If @action@ returned a
-- negative integer the integer is converted to a 'USBException' and thrown. If
-- not, the integer is returned.
checkUSBException ∷ IO CInt β†’ IO Int
checkUSBException action = do r ← action
                              if r < 0
                                then throwIO $ convertUSBException r
                                else return $ fromIntegral r

-- | Convert a 'C\'libusb_error' to a 'USBException'. If the C'libusb_error is
-- unknown an 'error' is thrown.
convertUSBException ∷ CInt β†’ USBException
convertUSBException err = fromMaybe unknownLibUsbError $
                            lookup err libusb_error_to_USBException

unknownLibUsbError ∷ error
unknownLibUsbError = error "Unknown Libusb error"

-- | Association list mapping 'C'libusb_error's to 'USBException's.
libusb_error_to_USBException ∷ [(CInt, USBException)]
libusb_error_to_USBException =
    [ (c'LIBUSB_ERROR_IO,            IOException)
    , (c'LIBUSB_ERROR_INVALID_PARAM, InvalidParamException)
    , (c'LIBUSB_ERROR_ACCESS,        AccessException)
    , (c'LIBUSB_ERROR_NO_DEVICE,     NoDeviceException)
    , (c'LIBUSB_ERROR_NOT_FOUND,     NotFoundException)
    , (c'LIBUSB_ERROR_BUSY,          BusyException)
    , (c'LIBUSB_ERROR_TIMEOUT,       TimeoutException)
    , (c'LIBUSB_ERROR_OVERFLOW,      OverflowException)
    , (c'LIBUSB_ERROR_PIPE,          PipeException)
    , (c'LIBUSB_ERROR_INTERRUPTED,   InterruptedException)
    , (c'LIBUSB_ERROR_NO_MEM,        NoMemException)
    , (c'LIBUSB_ERROR_NOT_SUPPORTED, NotSupportedException)
    , (c'LIBUSB_ERROR_OTHER,         OtherException)
    ]

-- | Type of USB exceptions.
data USBException =
   IOException           -- ^ Input/output exception.
 | InvalidParamException -- ^ Invalid parameter.
 | AccessException       -- ^ Access denied (insufficient permissions).
 | NoDeviceException     -- ^ No such device (it may have been disconnected).
 | NotFoundException     -- ^ Entity not found.
 | BusyException         -- ^ Resource busy.
 | TimeoutException      -- ^ Operation timed out.
 | OverflowException     -- ^ Overflow.
 | PipeException         -- ^ Pipe exception.
 | InterruptedException  -- ^ System call interrupted (perhaps due to signal).
 | NoMemException        -- ^ Insufficient memory.
 | NotSupportedException -- ^ Operation not supported or unimplemented on this
                         --   platform.
 | OtherException        -- ^ Other exception.
   deriving (Eq, Show, Data, Typeable)

instance Exception USBException


--------------------------------------------------------------------------------
-- * Binary Coded Decimals
--------------------------------------------------------------------------------

-- | A decoded 16 bits Binary Coded Decimal using 4 bits for each digit.
type BCD4 = (Int, Int, Int, Int)

-- | Decode a @Word16@ as a Binary Coded Decimal using 4 bits per digit.
unmarshalBCD4 ∷ Word16 β†’ BCD4
unmarshalBCD4 bcd = let [a, b, c, d] = fmap fromIntegral $ decodeBCD 4 bcd
                    in (a, b, c, d)

{-| @decodeBCD bitsInDigit n@ decodes the Binary Coded Decimal @n@ to a list of
its encoded digits. @bitsInDigit@, which is usually 4, is the number of bits
used to encode a single digit. See:
<http://en.wikipedia.org/wiki/Binary-coded_decimal>
-}
decodeBCD ∷ Bits Ξ± β‡’ Int β†’ Ξ± β†’ [Ξ±]
decodeBCD bitsInDigit n = go shftR []
    where
      shftR = bitSize n - bitsInDigit

      go shftL ds | shftL < 0 = ds
                  | otherwise = go (shftL - bitsInDigit)
                                   (((n `shiftL` shftL) `shiftR` shftR) : ds)


--------------------------------------------------------------------------------
-- * Utils
--------------------------------------------------------------------------------

-- | @bits s e b@ extract bit @s@ to @e@ (including) from @b@.
bits ∷ Bits Ξ± β‡’ Int β†’ Int β†’ Ξ± β†’ Ξ±
bits s e b = (2 ^ (e - s + 1) - 1) .&. (b `shiftR` s)

-- | @between n b e@ tests if @n@ is between the given bounds @b@ and @e@
-- (including).
between ∷ Ord Ξ± β‡’ Ξ± β†’ Ξ± β†’ Ξ± β†’ Bool
between n b e = n β‰ b ∧ n β‰ e

-- | Execute the given action but ignore the result.
ignore ∷ Monad m β‡’ m Ξ± β†’ m ()
ignore = (>> return ())

-- | A generalized 'toEnum' that works on any 'Integral' type.
genToEnum ∷ (Integral i, Enum e) β‡’ i β†’ e
genToEnum = toEnum ∘ fromIntegral

-- | A generalized 'fromEnum' that returns any 'Integral' type.
genFromEnum ∷ (Integral i, Enum e) β‡’ e β†’ i
genFromEnum = fromIntegral ∘ fromEnum

-- | @input `writeWith` doWrite@ first converts the @input@ @ByteString@ to an
-- array of @Word8@s, then @doWrite@ is executed by pointing it to the size of
-- this array and the array itself. Finally, the result of @doWrite@ is
-- returned.
--
-- /Make sure not to return the pointer to the array from @doWrite@!/
--
-- /Note that the converion from the @ByteString@ to the @Word8@ array is O(1)./
writeWith ∷ B.ByteString β†’ (Size β†’ Ptr Word8 β†’ IO Ξ±) β†’ IO Ξ±
input `writeWith` doWrite =
    let (dataFrgnPtr, _, size) = BI.toForeignPtr input
    in withForeignPtr dataFrgnPtr $ doWrite size

-- | Monadic if...then...else...
ifM ∷ Monad m β‡’ m Bool β†’ m Ξ± β†’ m Ξ± β†’ m Ξ±
ifM cM tM eM = do c ← cM
                  if c
                    then tM
                    else eM


-- The End ---------------------------------------------------------------------