Linux.hs

module System.Hardware.Blink1.Linux
  ( Blink1Raw
  , openRawDev
  , openRawHID
  , openRawHIDs
  ) where

import Control.Exception (onException, bracket)
import Control.Monad
import Data.List (isPrefixOf, genericLength)
import Foreign.C.Error (errnoToIOError, eFTYPE) -- hack
import Numeric (readHex)
import System.IO.Error (ioError, mkIOError, fullErrorType, doesNotExistErrorType)
import System.Posix.IO
import System.Posix.IOCtl
import System.Posix.Directory (openDirStream, readDirStream, closeDirStream)
import System.Posix.Types (Fd)
import Foreign.Marshal.Array

import System.Linux.HIDRaw
import System.Hardware.Blink1.Types
import System.Hardware.Blink1.Class

newtype Blink1Raw = Blink1Raw Fd

-- | Open the given blink(1) hidraw device
openRawDev :: FilePath -> IO Blink1Raw
openRawDev f = do
  d <- openFd df ReadWrite Nothing defaultFileFlags
  i <- devInfo d `onException` closeFd d
  when (devVendor i /= blink1Vendor || devProduct i /= blink1Product) $ do
    closeFd d
    ioError $ errnoToIOError "not Blink1" eFTYPE Nothing (Just f)
  return $ Blink1Raw d
  where df = case f of { '/':_ -> f ; _ -> "/dev/" ++ f }

findRawDev :: MonadPlus m => IO (m String)
findRawDev = pds dp hiddir where
  hiddir = "/sys/bus/hid/devices"
  pds f d = bracket (openDirStream d) closeDirStream r where
    r d = do
      e <- readDirStream d
      if null e then return mzero else liftM2 mplus (f e) (r d)
  dp f | null (do
      (_,':':vs) <- readHex f
      (v,':':ps) <- readHex vs
      guard (v == blink1Vendor)
      (p,'.':_) <- readHex ps
      guard (p == blink1Product)) = return mzero
    | otherwise = pds fp (hiddir ++ '/' : f ++ "/hidraw")
  fp f = return $ guard ("hidraw" `isPrefixOf` f) >> return f

-- | Search for and open the first blink(1) hidraw device
openRawHID :: IO Blink1Raw
openRawHID = maybe 
  (ioError $ mkIOError doesNotExistErrorType "Blink1.openRawHID" Nothing Nothing) 
  openRawDev =<< findRawDev
  
-- | Search for and open all blink(1) hidraw devices
openRawHIDs :: IO [Blink1Raw]
openRawHIDs = mapM openRawDev =<< findRawDev
  
closeRaw :: Blink1Raw -> IO ()
closeRaw (Blink1Raw d) = closeFd d

instance Blink1 Blink1Raw where
  writeBlink1 (Blink1Raw d) x = do -- setFeature d x
    let l = genericLength x
    r <- withArray x $ \p -> fdWriteBuf d p l
    when (r /= l) $ ioError $ mkIOError fullErrorType "Blink1Raw: short write" Nothing Nothing
  readBlink1 (Blink1Raw d) n = getFeature d n