module PowerMate (
getUSBName,
searchForDevice, openDevice,
readEvent, readEventWithSkip,
Event(..),
Status(..), statusInit,
writeStatus
) where
import Foreign
import Foreign.C.Error (throwErrnoIf)
import Foreign.C.Types
import System.Posix.Types (Fd)
import System.Posix.IO
import System.IO
import System.Environment
import Data.List (isPrefixOf, find)
import Control.Monad (filterM, liftM)
import Control.Exception (bracket)
import System.Directory (getDirectoryContents)
import Foreign.C.String (withCAString, peekCString)
import Debug.Trace (trace)
import Data.Bits (testBit)
foreign import ccall "sys/ioctl.h ioctl" ioctlChar ::
Fd -> CInt -> Ptr CChar -> IO CInt
data Status = Status {
brightness, pulse_speed, pulse_mode :: Int,
pulse_asleep, pulse_awake :: Bool
}
statusInit = Status 0 0 0 False False
ioctlName :: Fd -> IO String
ioctlName fd = do
withCAString (take 255 (repeat '\0')) $ \buf -> do
throwErrnoIf (< 0) "ioctl" $ ioctlChar fd 2164212998 buf
peekCString buf
getUSBName :: FilePath -> IO String
getUSBName filename = do
bracket (openFd filename ReadOnly Nothing defaultFileFlags) closeFd ioctlName
searchForDevice :: IO (Maybe FilePath)
searchForDevice = do
files <- getDirectoryContents basedir
let goodfiles = filter ("event" `isPrefixOf`) files
let paths = [basedir ++ "/" ++ file | file <- goodfiles]
inputs <- filterM deviceIsGood paths
return $ case inputs of
[] -> Nothing
(x:_) -> Just x
where basedir = "/dev/input"
deviceIsGood path = do
putStr (path ++ ": ")
hFlush stdout
name <- getUSBName path
putStrLn name
return $ nameIsGood name
nameIsGood "Griffin PowerMate" = True
nameIsGood _ = False
openDevice :: FilePath -> IO Handle
openDevice file = do
handle <- openBinaryFile file ReadWriteMode
hSetBuffering handle NoBuffering
return handle
data Event = Button Bool | Rotate Int | StatusChange Status
decodeEvent :: (Word16, Word16, Word32) -> Maybe Event
decodeEvent (1, _, value) = Just $ Button (value == 1)
decodeEvent (2, _, value) = Just $ Rotate (fromIntegral value)
decodeEvent (4, _, value) = Just $ StatusChange (decodePulseLED value)
decodeEvent (0, 0, 0) = Nothing
decodeEvent (typ, code, value) = trace ("Unhandled event: " ++ show typ ++ "," ++ show code ++ "," ++ show value) Nothing
eventSize = (16)
readEvent :: Handle -> IO (Maybe Event)
readEvent handle = do
allocaBytes eventSize $ \buf -> do
readsize <- hGetBuf handle buf eventSize
typ <- (\hsc_ptr -> peekByteOff hsc_ptr 8) buf :: IO Word16
code <- (\hsc_ptr -> peekByteOff hsc_ptr 10) buf :: IO Word16
value <- (\hsc_ptr -> peekByteOff hsc_ptr 12) buf :: IO Word32
return $ decodeEvent (typ, code, value)
readEventWithSkip :: Handle -> Maybe Event -> IO (Maybe Event)
readEventWithSkip handle prev = do
event <- readEvent handle
let actualevent = case event of
Nothing -> prev
_ -> event
more <- hReady handle
if more then readEventWithSkip handle actualevent
else return actualevent
writeEvent :: Handle -> Word16 -> Word16 -> Word32 -> IO ()
writeEvent handle typ code value = do
allocaBytes eventSize $ \buf -> do
(\hsc_ptr -> pokeByteOff hsc_ptr 8) buf typ
(\hsc_ptr -> pokeByteOff hsc_ptr 10) buf code
(\hsc_ptr -> pokeByteOff hsc_ptr 12) buf value
hPutBuf handle buf eventSize
encodePulseLED :: Status -> Word32
encodePulseLED status =
enc_brightness .|. enc_speed .|. enc_mode .|. enc_asleep .|. enc_awake where
enc_brightness = fromIntegral (brightness status)
enc_speed = fromIntegral (pulse_speed status) `shiftL` 8
enc_mode = fromIntegral (pulse_mode status) `shiftL` 17
enc_asleep = boolBit (pulse_asleep status) `shiftL` 19
enc_awake = boolBit (pulse_awake status) `shiftL` 20
boolBit True = 1
boolBit False = 0
decodePulseLED :: Word32 -> Status
decodePulseLED word = Status { brightness=b, pulse_speed=ps, pulse_mode=pm,
pulse_asleep=pas, pulse_awake=paw } where
b = fromIntegral $ word .&. 0xFF
ps = fromIntegral $ (word `shiftR` 8) .&. 0x1FF
pm = fromIntegral $ (word `shiftR` 17) .&. 0x3
pas = Data.Bits.testBit word 19
paw = Data.Bits.testBit word 20
showBinary :: Word32 -> String
showBinary word = concatMap showBit [31,30..0] where
showBit n = if Data.Bits.testBit word n then "1" else "0"
writeStatus :: Handle -> Status -> IO ()
writeStatus handle status = writeEvent handle typ code value where
typ = 4
code = 1
value = encodePulseLED status