evdev-0.1.0.0: src/Evdev.hs

module Evdev where

import Control.Exception
import Data.Int
import Data.List.Extra
import Data.Either.Combinators
import Data.Time.Clock
import Data.Tuple.Extra

import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as BS
import Data.Set (Set)
import Foreign ((.|.))
import Foreign.C (CUInt)
import Foreign.C.Error (Errno(Errno),errnoToIOError)
import System.Posix.ByteString (RawFilePath)

import qualified Evdev.LowLevel as LL
import Evdev.Codes --TODO combine modules?

-- stores path that was originally used, as it seems impossible to recover this later
-- We don't allow the user to access the underlying low-level C device.
data Device = Device { cDevice :: LL.Device, devicePath :: RawFilePath }
instance Show Device where
    show = show . devicePath

data Event = Event {
    evType :: EventType,
    evCode :: EventCode,
    evValue :: EventValue,
    evTime :: DiffTime}
    deriving (Eq, Ord, Show)

-- aligns with the pattern synonyms below
prettyEvent :: Event -> String
prettyEvent x = showTime (evTime x) ++ ":" ++ " " ++ case x of
        SyncEvent t -> show t
        KeyEvent k t -> intercalate " " [show k, show t]
        RelativeEvent c v -> intercalate " " [show c, showE v]
        AbsoluteEvent c v -> intercalate " " [show c, showE v]
        MiscEvent c v -> intercalate " " [show c, showE v]
        SwitchEvent c v -> intercalate " " [show c, showE v]
        LEDEvent c v -> intercalate " " [show c, showE v]
        SoundEvent c v -> intercalate " " [show c, showE v]
        RepeatEvent c v -> intercalate " " [show c, showE v]
        ForceFeedbackEvent c v -> intercalate " " [showE c, showE v]
        PowerEvent c v -> intercalate " " [showE c, showE v]
        ForceFeedbackStatusEvent c v -> intercalate " " [showE c, showE v]
        _ -> error $ "show: unrecognised Event: " ++ intercalate " "
            [showE $ evType x, showE $ evCode x, showE $ evValue x]
        where
            showE :: Enum e => e -> String
            showE = show . fromEnum
            showTime t = -- fix time string to always have same length after '.', by adding 0s
                let (n,r) = second tail $ span (/= '.') $ init $ show t
                in  n ++ "." ++ take 6 (r ++ ['0'..]) ++ "s"

pattern SyncEvent :: SyncEventType -> Event
pattern SyncEvent c <- Event EvSyn (toEnum . fromEnum -> c) _ _

pattern KeyEvent :: Key -> KeyEventType -> Event
pattern KeyEvent c v <- Event EvKey (toEnum . fromEnum -> c) (toEnum . fromEnum -> v) _

pattern RelativeEvent :: RelativeAxis -> EventValue -> Event
pattern RelativeEvent c v <- Event EvRel (toEnum . fromEnum -> c) v _

pattern AbsoluteEvent :: AbsoluteAxis -> EventValue -> Event
pattern AbsoluteEvent c v <- Event EvAbs (toEnum . fromEnum -> c) v _

pattern MiscEvent :: MiscEventType -> EventValue -> Event
pattern MiscEvent c v <- Event EvMsc (toEnum . fromEnum -> c) v _

pattern SwitchEvent :: SwitchEventType -> EventValue -> Event
pattern SwitchEvent c v <- Event EvSw (toEnum . fromEnum -> c) v _

pattern LEDEvent :: LEDEventType -> EventValue -> Event
pattern LEDEvent c v <- Event EvLed (toEnum . fromEnum -> c) v _

pattern SoundEvent :: SoundEventType -> EventValue -> Event
pattern SoundEvent c v <- Event EvSnd (toEnum . fromEnum -> c) v _

pattern RepeatEvent :: RepeatEventType -> EventValue -> Event
pattern RepeatEvent c v <- Event EvRep (toEnum . fromEnum -> c) v _

pattern ForceFeedbackEvent :: EventCode -> EventValue -> Event
pattern ForceFeedbackEvent c v <- Event EvFf c v _

pattern PowerEvent :: EventCode -> EventValue -> Event
pattern PowerEvent c v <- Event EvPwr c v _

pattern ForceFeedbackStatusEvent :: EventCode -> EventValue -> Event
pattern ForceFeedbackStatusEvent c v <- Event EvFfStatus c v _

newtype EventCode = EventCode Int16 deriving (Enum, Eq, Ord, Read, Show)
newtype EventValue = EventValue Int32 deriving (Enum, Eq, Ord, Read, Show)

data KeyEventType
    = Released
    | Pressed
    | Repeated
    deriving (Enum, Eq, Ord, Read, Show)

convertFlags :: Set LL.ReadFlags -> CUInt
convertFlags = fromIntegral . foldr ((.|.) . fromEnum) 0

defaultReadFlags :: Set LL.ReadFlags
defaultReadFlags = [LL.Normal,LL.Blocking]

grabDevice :: Device -> IO ()
grabDevice = grabDevice' LL.LibevdevGrab
ungrabDevice :: Device -> IO ()
ungrabDevice = grabDevice' LL.LibevdevUngrab

nextEvent :: Device -> Set LL.ReadFlags -> IO Event
nextEvent dev flags = do
    (t,c,v,time) <- LL.convertEvent =<<
        throwCErrors "nextEvent" (devicePath dev) (LL.nextEvent (cDevice dev) (convertFlags flags))
    return $ Event (toEnum t) (EventCode c) (EventValue v) time

newDevice :: RawFilePath -> IO Device
newDevice path = do
    dev <- throwCErrors "newDevice" path $ LL.newDevice path
    return $ Device dev path

maybeNewDevice :: RawFilePath -> IO (Maybe Device)
maybeNewDevice = fmap rightToMaybe . tryIO . newDevice

evdevDir :: RawFilePath
evdevDir = "/dev/input"

getDeviceName :: Device -> IO ByteString
getDeviceName = fmap BS.pack . LL.deviceName . cDevice

tryIO :: IO a -> IO (Either IOException a)
tryIO = try


{- Util -}

-- run the action, throwing an error if the C errno is not 0
throwCErrors :: String -> RawFilePath -> IO (Errno, a) -> IO a
throwCErrors loc path x = do
    (errno, res) <- x
    case errno of
        Errno 0 -> return res
        _ -> ioError $ errnoToIOError loc errno Nothing (Just $ BS.unpack path)

grabDevice' :: LL.GrabMode -> Device -> IO ()
grabDevice' mode dev = throwCErrors "grabDevice" (devicePath dev) $ LL.grabDevice (cDevice dev) mode