module System.HID (
init
, exit
, DeviceInfo
(
devPath
, devVendorID
, devProductID
, devSerialNumber
, devReleaseNumber
, devManufacturerString
, devProductString
, devUsagePage
, devUsage
, devInterfaceNumber
)
, enumerate
, detectDevices
, Device
, vendorProductSerialDevice
, pathDevice
, writeOutputReport
, sendFeatureReport
, readInputReport
, readInputReportTimeout
, getFeatureReport
, getManufacturer
, getProductName
, getSerialNumber
, getIndexedString
, setBlocking
, getError
) where
import Control.Monad.IO.Class
import qualified Data.ByteString as BS
import Data.Maybe
import Data.Word
import Foreign.Concurrent
import Foreign.ForeignPtr ( ForeignPtr, withForeignPtr )
import Foreign.C.String
import Foreign.Marshal
import Foreign.Ptr
import Foreign.Storable
import Prelude hiding ( init, product )
import System.HID.Internal.Functions
import System.HID.Internal.Types
import System.HID.Internal.Utils
maxReadBytes :: Int
maxReadBytes = 524288
init :: (MonadIO m) => m Bool
init = liftIO $ fmap fromHIDRet hidInit
exit :: (MonadIO m) => m Bool
exit = liftIO $ fmap fromHIDRet hidExit
data DeviceInfo = DeviceInfo {
devPath :: String
, devVendorID :: Word16
, devProductID :: Word16
, devSerialNumber :: String
, devReleaseNumber :: Word16
, devManufacturerString :: String
, devProductString :: String
, devUsagePage :: Word16
, devUsage :: Word16
, devInterfaceNumber :: Int
} deriving (Eq,Show)
enumerate :: (MonadIO m) => Word32 -> Word32 -> m [DeviceInfo]
enumerate vendorID productID = do
devs <- liftIO (hidEnumerate (fromIntegral vendorID) (fromIntegral productID)) >>= scanDevs
traverse extractDeviceInfo devs
detectDevices :: (MonadIO m) => m [DeviceInfo]
detectDevices = enumerate 0 0
extractDeviceInfo :: (MonadIO m) => Ptr HIDDeviceInfo -> m DeviceInfo
extractDeviceInfo p = liftIO $ do
HIDDeviceInfo cpath cvid cpid cserial crelease cmanu cproduct cusagep cusage cifnb _ <- peek p
path <- if cpath == nullPtr then pure "" else peekCString cpath
serial <- if cserial == nullPtr then pure "" else peekCWString cserial
manu <- if cmanu == nullPtr then pure "" else peekCWString cmanu
product <- if cproduct == nullPtr then pure "" else peekCWString cproduct
pure $ DeviceInfo path (fromIntegral cvid)
(fromIntegral cpid) serial
(fromIntegral crelease) manu product
(fromIntegral cusagep) (fromIntegral cusage)
(fromIntegral cifnb)
scanDevs :: (MonadIO m) => Ptr HIDDeviceInfo -> m [Ptr HIDDeviceInfo]
scanDevs hidDeviceInfo
| hidDeviceInfo == nullPtr = pure []
| otherwise =
fmap (hidDeviceInfo :) $ liftIO (peek hidDeviceInfo) >>= scanDevs . hidNext
newtype Device = Device { unDevice :: ForeignPtr HIDDevice }
vendorProductSerialDevice :: (MonadIO m) => Word16 -> Word16 -> Maybe String -> m (Maybe Device)
vendorProductSerialDevice vendorID productID optSerial =
liftIO $ case optSerial of
Just serial -> do
withCWString serial $ \cserial -> do
hidDev <- hidOpen (fromIntegral vendorID) (fromIntegral productID) cserial
if hidDev == nullPtr then pure Nothing else fmap Just $ wrapHIDDevice hidDev
Nothing -> do
hidDev <- hidOpen (fromIntegral vendorID) (fromIntegral productID) nullPtr
if hidDev == nullPtr then pure Nothing else fmap Just $ wrapHIDDevice hidDev
pathDevice :: (MonadIO m) => String -> m (Maybe Device)
pathDevice path = do
liftIO . withCString path $ \cpath -> do
hidDev <- hidOpenPath cpath
if hidDev == nullPtr then pure Nothing else fmap Just $ wrapHIDDevice hidDev
wrapHIDDevice :: (MonadIO m) => Ptr HIDDevice -> m Device
wrapHIDDevice p = liftIO . fmap Device $ newForeignPtr p (hidClose p)
writeOutputReport :: (MonadIO m) => Device -> BS.ByteString -> m Int
writeOutputReport dev bs = liftIO . fmap fromIntegral $
withForeignPtr (unDevice dev) $ \hidDev ->
withArrayLen (BS.unpack bs) $ \bytes cdata ->
hidWrite hidDev (castPtr cdata) (fromIntegral bytes)
sendFeatureReport :: (MonadIO m) => Device -> BS.ByteString -> m Int
sendFeatureReport dev bs = liftIO . fmap fromIntegral $
withForeignPtr (unDevice dev) $ \hidDev ->
withArrayLen (BS.unpack bs) $ \bytes cdata ->
hidSendFeatureReport hidDev (castPtr cdata) (fromIntegral bytes)
readInputReport :: (MonadIO m) => Device -> m (Maybe BS.ByteString)
readInputReport dev = liftIO $ do
withForeignPtr (unDevice dev) $ \hidDev ->
allocaBytes maxReadBytes $ \inputData -> do
r <- hidRead hidDev inputData (fromIntegral maxReadBytes)
if r < 0 then
pure Nothing
else do
bs <- fmap (BS.pack) $ peekArray (fromIntegral r) (castPtr inputData)
pure $ Just bs
readInputReportTimeout :: (MonadIO m) => Device -> Int -> m (Maybe BS.ByteString)
readInputReportTimeout dev tms = liftIO $ do
withForeignPtr (unDevice dev) $ \hidDev ->
allocaBytes maxReadBytes $ \inputData -> do
r <- hidReadTimeout hidDev inputData (fromIntegral maxReadBytes) (fromIntegral tms)
if r < 0 then
pure Nothing
else do
bs <- fmap (BS.pack) $ peekArray (fromIntegral r) (castPtr inputData)
pure $ Just bs
getFeatureReport :: (MonadIO m) => Device -> m (Maybe BS.ByteString)
getFeatureReport dev = liftIO $ do
withForeignPtr (unDevice dev) $ \hidDev ->
allocaBytes maxReadBytes $ \inputData -> do
r <- hidGetFeatureReport hidDev inputData (fromIntegral maxReadBytes)
if r < 0 then
pure Nothing
else do
bs <- fmap (BS.pack) $ peekArray (fromIntegral r) (castPtr inputData)
pure $ Just bs
getManufacturer :: (MonadIO m) => Device -> m String
getManufacturer dev = liftIO $ do
withForeignPtr (unDevice dev) $ \hidDev ->
withCWString (replicate maxReadBytes '\0') $ \inputData -> do
_ <- hidGetManufacturerString hidDev inputData (fromIntegral maxReadBytes)
peekCWString inputData
getProductName :: (MonadIO m) => Device -> m String
getProductName dev = liftIO $ do
withForeignPtr (unDevice dev) $ \hidDev ->
withCWString (replicate maxReadBytes '\0') $ \inputData -> do
_ <- hidGetProductString hidDev inputData (fromIntegral maxReadBytes)
peekCWString inputData
getSerialNumber :: (MonadIO m) => Device -> m String
getSerialNumber dev = liftIO $ do
withForeignPtr (unDevice dev) $ \hidDev ->
withCWString (replicate maxReadBytes '\0') $ \inputData -> do
_ <- hidGetSerialNumberString hidDev inputData (fromIntegral maxReadBytes)
peekCWString inputData
getIndexedString :: (MonadIO m) => Device -> Int -> m String
getIndexedString dev index = liftIO $ do
withForeignPtr (unDevice dev) $ \hidDev ->
withCWString (replicate maxReadBytes '\0') $ \inputData -> do
_ <- hidGetIndexedString hidDev (fromIntegral index) inputData (fromIntegral maxReadBytes)
peekCWString inputData
setBlocking :: (MonadIO m) => Device -> Bool -> m Bool
setBlocking dev blocking = liftIO $
withForeignPtr (unDevice dev) $ \hidDev ->
fmap fromHIDRet $ hidSetNonblocking hidDev (fromBool $ not blocking)
getError :: (MonadIO m) => Device -> m String
getError dev = liftIO $ withForeignPtr (unDevice dev) $ \hidDev ->
hidError hidDev >>= peekCWString