-- | Create virtual input devices.
module Evdev.Uinput (
    Device,
    newDevice,
    writeEvent,
    writeBatch,
    defaultDeviceOpts,
    DeviceOpts (..),
    LL.AbsInfo (..),
    deviceSyspath,
    deviceDevnode,
) where

import Control.Monad
import Data.Tuple.Extra
import Foreign

import Data.ByteString.Char8 (ByteString)

import Evdev hiding (Device, newDevice)
import Evdev.Codes
import qualified Evdev.LowLevel as LL
import Util

-- | A `uinput` device.
newtype Device = Device LL.UDevice

-- | Create a new `uinput` device.
newDevice ::
    -- | Device name
    ByteString ->
    DeviceOpts ->
    IO Device
newDevice :: ByteString -> DeviceOpts -> IO Device
newDevice ByteString
name DeviceOpts{[(RepeatEvent, Int)]
[(AbsoluteAxis, AbsInfo)]
[SoundEvent]
[LEDEvent]
[MiscEvent]
[SwitchEvent]
[RelativeAxis]
[Key]
[EventCode]
Maybe Int
Maybe ByteString
ffStats :: DeviceOpts -> [EventCode]
powers :: DeviceOpts -> [EventCode]
ffs :: DeviceOpts -> [EventCode]
reps :: DeviceOpts -> [(RepeatEvent, Int)]
sounds :: DeviceOpts -> [SoundEvent]
leds :: DeviceOpts -> [LEDEvent]
switchs :: DeviceOpts -> [SwitchEvent]
miscs :: DeviceOpts -> [MiscEvent]
absAxes :: DeviceOpts -> [(AbsoluteAxis, AbsInfo)]
relAxes :: DeviceOpts -> [RelativeAxis]
keys :: DeviceOpts -> [Key]
idVersion :: DeviceOpts -> Maybe Int
idBustype :: DeviceOpts -> Maybe Int
idVendor :: DeviceOpts -> Maybe Int
idProduct :: DeviceOpts -> Maybe Int
uniq :: DeviceOpts -> Maybe ByteString
phys :: DeviceOpts -> Maybe ByteString
ffStats :: [EventCode]
powers :: [EventCode]
ffs :: [EventCode]
reps :: [(RepeatEvent, Int)]
sounds :: [SoundEvent]
leds :: [LEDEvent]
switchs :: [SwitchEvent]
miscs :: [MiscEvent]
absAxes :: [(AbsoluteAxis, AbsInfo)]
relAxes :: [RelativeAxis]
keys :: [Key]
idVersion :: Maybe Int
idBustype :: Maybe Int
idVendor :: Maybe Int
idProduct :: Maybe Int
uniq :: Maybe ByteString
phys :: Maybe ByteString
..} = do
    Device
dev <- IO Device
LL.libevdev_new
    Device -> ByteString -> IO ()
LL.setDeviceName Device
dev ByteString
name

    let maybeSet :: (LL.Device -> a -> IO ()) -> Maybe a -> IO ()
        maybeSet :: (Device -> a -> IO ()) -> Maybe a -> IO ()
maybeSet Device -> a -> IO ()
setter Maybe a
x = IO () -> (a -> IO ()) -> Maybe a -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (Device -> a -> IO ()
setter Device
dev) Maybe a
x
    (Device -> ByteString -> IO ()) -> Maybe ByteString -> IO ()
forall a. (Device -> a -> IO ()) -> Maybe a -> IO ()
maybeSet Device -> ByteString -> IO ()
LL.setDevicePhys Maybe ByteString
phys
    (Device -> ByteString -> IO ()) -> Maybe ByteString -> IO ()
forall a. (Device -> a -> IO ()) -> Maybe a -> IO ()
maybeSet Device -> ByteString -> IO ()
LL.setDeviceUniq Maybe ByteString
uniq
    (Device -> Int -> IO ()) -> Maybe Int -> IO ()
forall a. (Device -> a -> IO ()) -> Maybe a -> IO ()
maybeSet Device -> Int -> IO ()
LL.libevdev_set_id_product Maybe Int
idProduct
    (Device -> Int -> IO ()) -> Maybe Int -> IO ()
forall a. (Device -> a -> IO ()) -> Maybe a -> IO ()
maybeSet Device -> Int -> IO ()
LL.libevdev_set_id_vendor Maybe Int
idVendor
    (Device -> Int -> IO ()) -> Maybe Int -> IO ()
forall a. (Device -> a -> IO ()) -> Maybe a -> IO ()
maybeSet Device -> Int -> IO ()
LL.libevdev_set_id_bustype Maybe Int
idBustype
    (Device -> Int -> IO ()) -> Maybe Int -> IO ()
forall a. (Device -> a -> IO ()) -> Maybe a -> IO ()
maybeSet Device -> Int -> IO ()
LL.libevdev_set_id_version Maybe Int
idVersion

    let enable :: Ptr () -> EventType -> [Word16] -> IO ()
        enable :: Ptr () -> EventType -> [Word16] -> IO ()
enable Ptr ()
ptr EventType
t [Word16]
cs = do
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Word16] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Word16]
cs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO Errno -> IO (CErrCallRes Errno)
forall a. CErrCall a => IO a -> IO (CErrCallRes a)
cec (IO Errno -> IO (CErrCallRes Errno))
-> IO Errno -> IO (CErrCallRes Errno)
forall a b. (a -> b) -> a -> b
$ Device -> Word16 -> IO Errno
LL.enableType Device
dev Word16
t'
            [Word16] -> (Word16 -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Word16]
cs ((Word16 -> IO ()) -> IO ()) -> (Word16 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Word16
c -> IO Errno -> IO (CErrCallRes Errno)
forall a. CErrCall a => IO a -> IO (CErrCallRes a)
cec (IO Errno -> IO (CErrCallRes Errno))
-> IO Errno -> IO (CErrCallRes Errno)
forall a b. (a -> b) -> a -> b
$ Device -> Word16 -> Word16 -> Ptr () -> IO Errno
LL.enableCode Device
dev Word16
t' Word16
c Ptr ()
ptr
          where
            t' :: Word16
t' = EventType -> Word16
forall c a. (Num c, Enum a) => a -> c
fromEnum' EventType
t

    ((EventType, [Word16]) -> IO ())
-> [(EventType, [Word16])] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
        ((EventType -> [Word16] -> IO ()) -> (EventType, [Word16]) -> IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((EventType -> [Word16] -> IO ())
 -> (EventType, [Word16]) -> IO ())
-> (EventType -> [Word16] -> IO ())
-> (EventType, [Word16])
-> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr () -> EventType -> [Word16] -> IO ()
enable Ptr ()
forall a. Ptr a
nullPtr)
        [ (EventType
EvKey, (Key -> Word16) -> [Key] -> [Word16]
forall a b. (a -> b) -> [a] -> [b]
map Key -> Word16
forall c a. (Num c, Enum a) => a -> c
fromEnum' [Key]
keys)
        , (EventType
EvRel, (RelativeAxis -> Word16) -> [RelativeAxis] -> [Word16]
forall a b. (a -> b) -> [a] -> [b]
map RelativeAxis -> Word16
forall c a. (Num c, Enum a) => a -> c
fromEnum' [RelativeAxis]
relAxes)
        , (EventType
EvMsc, (MiscEvent -> Word16) -> [MiscEvent] -> [Word16]
forall a b. (a -> b) -> [a] -> [b]
map MiscEvent -> Word16
forall c a. (Num c, Enum a) => a -> c
fromEnum' [MiscEvent]
miscs)
        , (EventType
EvSw, (SwitchEvent -> Word16) -> [SwitchEvent] -> [Word16]
forall a b. (a -> b) -> [a] -> [b]
map SwitchEvent -> Word16
forall c a. (Num c, Enum a) => a -> c
fromEnum' [SwitchEvent]
switchs)
        , (EventType
EvLed, (LEDEvent -> Word16) -> [LEDEvent] -> [Word16]
forall a b. (a -> b) -> [a] -> [b]
map LEDEvent -> Word16
forall c a. (Num c, Enum a) => a -> c
fromEnum' [LEDEvent]
leds)
        , (EventType
EvSnd, (SoundEvent -> Word16) -> [SoundEvent] -> [Word16]
forall a b. (a -> b) -> [a] -> [b]
map SoundEvent -> Word16
forall c a. (Num c, Enum a) => a -> c
fromEnum' [SoundEvent]
sounds)
        , (EventType
EvFf, (EventCode -> Word16) -> [EventCode] -> [Word16]
forall a b. (a -> b) -> [a] -> [b]
map EventCode -> Word16
forall c a. (Num c, Enum a) => a -> c
fromEnum' [EventCode]
ffs)
        , (EventType
EvPwr, (EventCode -> Word16) -> [EventCode] -> [Word16]
forall a b. (a -> b) -> [a] -> [b]
map EventCode -> Word16
forall c a. (Num c, Enum a) => a -> c
fromEnum' [EventCode]
powers)
        , (EventType
EvFfStatus, (EventCode -> Word16) -> [EventCode] -> [Word16]
forall a b. (a -> b) -> [a] -> [b]
map EventCode -> Word16
forall c a. (Num c, Enum a) => a -> c
fromEnum' [EventCode]
ffStats)
        ]

    [(RepeatEvent, Int)] -> ((RepeatEvent, Int) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(RepeatEvent, Int)]
reps (((RepeatEvent, Int) -> IO ()) -> IO ())
-> ((RepeatEvent, Int) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(RepeatEvent
rep, Int
n) -> do
        ForeignPtr Int
pf <- IO (ForeignPtr Int)
forall a. Storable a => IO (ForeignPtr a)
mallocForeignPtr
        ForeignPtr Int -> (Ptr Int -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Int
pf \Ptr Int
p -> do
            Ptr Int -> Int -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Int
p Int
n
            Ptr () -> EventType -> [Word16] -> IO ()
enable (Ptr Int -> Ptr ()
forall a b. Ptr a -> Ptr b
castPtr Ptr Int
p) EventType
EvRep [RepeatEvent -> Word16
forall c a. (Num c, Enum a) => a -> c
fromEnum' RepeatEvent
rep]

    [(AbsoluteAxis, AbsInfo)]
-> ((AbsoluteAxis, AbsInfo) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(AbsoluteAxis, AbsInfo)]
absAxes (((AbsoluteAxis, AbsInfo) -> IO ()) -> IO ())
-> ((AbsoluteAxis, AbsInfo) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(AbsoluteAxis
axis, AbsInfo
absInfo) ->
        AbsInfo -> (Ptr () -> IO ()) -> IO ()
forall a. AbsInfo -> (Ptr () -> IO a) -> IO a
LL.withAbsInfo AbsInfo
absInfo ((Ptr () -> IO ()) -> IO ()) -> (Ptr () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr ()
ptr ->
            Ptr () -> EventType -> [Word16] -> IO ()
enable Ptr ()
ptr EventType
EvAbs [AbsoluteAxis -> Word16
forall c a. (Num c, Enum a) => a -> c
fromEnum' AbsoluteAxis
axis]

    (UDevice -> Device) -> IO UDevice -> IO Device
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UDevice -> Device
Device (IO UDevice -> IO Device) -> IO UDevice -> IO Device
forall a b. (a -> b) -> a -> b
$ IO (Errno, UDevice) -> IO (CErrCallRes (Errno, UDevice))
forall a. CErrCall a => IO a -> IO (CErrCallRes a)
cec (IO (Errno, UDevice) -> IO (CErrCallRes (Errno, UDevice)))
-> IO (Errno, UDevice) -> IO (CErrCallRes (Errno, UDevice))
forall a b. (a -> b) -> a -> b
$ Device -> Fd -> IO (Errno, UDevice)
LL.createFromDevice Device
dev (Fd -> IO (Errno, UDevice)) -> Fd -> IO (Errno, UDevice)
forall a b. (a -> b) -> a -> b
$ UInputOpenMode -> Fd
forall c a. (Num c, Enum a) => a -> c
fromEnum' UInputOpenMode
LL.UOMManaged
  where
    cec :: CErrCall a => IO a -> IO (CErrCallRes a)
    cec :: IO a -> IO (CErrCallRes a)
cec = String -> () -> IO a -> IO (CErrCallRes a)
forall a info.
(CErrCall a, CErrInfo info) =>
String -> info -> IO a -> IO (CErrCallRes a)
cErrCall String
"newDevice" ()

data DeviceOpts = DeviceOpts
    { DeviceOpts -> Maybe ByteString
phys :: Maybe ByteString
    , DeviceOpts -> Maybe ByteString
uniq :: Maybe ByteString
    , DeviceOpts -> Maybe Int
idProduct :: Maybe Int
    , DeviceOpts -> Maybe Int
idVendor :: Maybe Int
    , DeviceOpts -> Maybe Int
idBustype :: Maybe Int
    , DeviceOpts -> Maybe Int
idVersion :: Maybe Int
    , DeviceOpts -> [Key]
keys :: [Key]
    , DeviceOpts -> [RelativeAxis]
relAxes :: [RelativeAxis]
    , DeviceOpts -> [(AbsoluteAxis, AbsInfo)]
absAxes :: [(AbsoluteAxis, LL.AbsInfo)]
    , DeviceOpts -> [MiscEvent]
miscs :: [MiscEvent]
    , DeviceOpts -> [SwitchEvent]
switchs :: [SwitchEvent]
    , DeviceOpts -> [LEDEvent]
leds :: [LEDEvent]
    , DeviceOpts -> [SoundEvent]
sounds :: [SoundEvent]
    , DeviceOpts -> [(RepeatEvent, Int)]
reps :: [(RepeatEvent, Int)]
    , DeviceOpts -> [EventCode]
ffs :: [EventCode]
    , DeviceOpts -> [EventCode]
powers :: [EventCode]
    , DeviceOpts -> [EventCode]
ffStats :: [EventCode]
    }
defaultDeviceOpts :: DeviceOpts
defaultDeviceOpts :: DeviceOpts
defaultDeviceOpts =
    DeviceOpts :: Maybe ByteString
-> Maybe ByteString
-> Maybe Int
-> Maybe Int
-> Maybe Int
-> Maybe Int
-> [Key]
-> [RelativeAxis]
-> [(AbsoluteAxis, AbsInfo)]
-> [MiscEvent]
-> [SwitchEvent]
-> [LEDEvent]
-> [SoundEvent]
-> [(RepeatEvent, Int)]
-> [EventCode]
-> [EventCode]
-> [EventCode]
-> DeviceOpts
DeviceOpts
        { uniq :: Maybe ByteString
uniq = Maybe ByteString
forall a. Maybe a
Nothing
        , phys :: Maybe ByteString
phys = Maybe ByteString
forall a. Maybe a
Nothing
        , idProduct :: Maybe Int
idProduct = Maybe Int
forall a. Maybe a
Nothing
        , idVendor :: Maybe Int
idVendor = Maybe Int
forall a. Maybe a
Nothing
        , idBustype :: Maybe Int
idBustype = Maybe Int
forall a. Maybe a
Nothing
        , idVersion :: Maybe Int
idVersion = Maybe Int
forall a. Maybe a
Nothing
        , keys :: [Key]
keys = []
        , relAxes :: [RelativeAxis]
relAxes = []
        , absAxes :: [(AbsoluteAxis, AbsInfo)]
absAxes = []
        , miscs :: [MiscEvent]
miscs = []
        , switchs :: [SwitchEvent]
switchs = []
        , leds :: [LEDEvent]
leds = []
        , sounds :: [SoundEvent]
sounds = []
        , reps :: [(RepeatEvent, Int)]
reps = []
        , ffs :: [EventCode]
ffs = []
        , powers :: [EventCode]
powers = []
        , ffStats :: [EventCode]
ffStats = []
        }

-- | Write a single event. Doesn't issue a sync event, so: @writeEvent dev e /= writeBatch dev [e]@.
writeEvent :: Device -> EventData -> IO ()
writeEvent :: Device -> EventData -> IO ()
writeEvent (Device UDevice
dev) EventData
e = do
    String -> UDevice -> IO Errno -> IO (CErrCallRes Errno)
forall a info.
(CErrCall a, CErrInfo info) =>
String -> info -> IO a -> IO (CErrCallRes a)
cErrCall String
"writeEvent" UDevice
dev (IO Errno -> IO (CErrCallRes Errno))
-> IO Errno -> IO (CErrCallRes Errno)
forall a b. (a -> b) -> a -> b
$ (Word16 -> Word16 -> Int32 -> IO Errno)
-> (Word16, Word16, Int32) -> IO Errno
forall a b c d. (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 (UDevice -> Word16 -> Word16 -> Int32 -> IO Errno
LL.writeEvent UDevice
dev) ((Word16, Word16, Int32) -> IO Errno)
-> (Word16, Word16, Int32) -> IO Errno
forall a b. (a -> b) -> a -> b
$ EventData -> (Word16, Word16, Int32)
toCEventData EventData
e

-- | Write several events followed by a 'SynReport'.
writeBatch :: Foldable t => Device -> t EventData -> IO ()
writeBatch :: Device -> t EventData -> IO ()
writeBatch Device
dev t EventData
es = do
    t EventData -> (EventData -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ t EventData
es ((EventData -> IO ()) -> IO ()) -> (EventData -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Device -> EventData -> IO ()
writeEvent Device
dev
    Device -> EventData -> IO ()
writeEvent Device
dev (EventData -> IO ()) -> EventData -> IO ()
forall a b. (a -> b) -> a -> b
$ SyncEvent -> EventData
SyncEvent SyncEvent
SynReport

deviceSyspath :: Device -> IO (Maybe ByteString)
deviceSyspath :: Device -> IO (Maybe ByteString)
deviceSyspath = UDevice -> IO (Maybe ByteString)
LL.getSyspath (UDevice -> IO (Maybe ByteString))
-> (Device -> UDevice) -> Device -> IO (Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \(Device UDevice
d) -> UDevice
d
deviceDevnode :: Device -> IO (Maybe ByteString)
deviceDevnode :: Device -> IO (Maybe ByteString)
deviceDevnode = UDevice -> IO (Maybe ByteString)
LL.getDevnode (UDevice -> IO (Maybe ByteString))
-> (Device -> UDevice) -> Device -> IO (Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \(Device UDevice
d) -> UDevice
d