evdev 2.0.0.1 → 2.1.0

raw patch · 8 files changed

+556/−122 lines, 8 filesdep +evdevdep +filepath-bytestringdep +rawfilepathdep ~bytestringdep ~timePVP ok

version bump matches the API change (PVP)

Dependencies added: evdev, filepath-bytestring, rawfilepath, tasty, tasty-hunit, tasty-quickcheck

Dependency ranges changed: bytestring, time

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• README.md +16/−1
• evdev.cabal +48/−22
• src/Evdev.hs +114/−72
• src/Evdev/LowLevel.chs +111/−27
• src/Evdev/Uinput.hs +137/−0
• src/Util.hs +40/−0
• test/Test.hs +83/−0

@@ -1,5 +1,12 @@ # Revision history for evdev +## 2.1.0 -- 2021-02-12+* Add `Evdev.Uinput` module, for creating virtual devices.+* More functions for querying device properties.+* Remove some invalid instances for `EventCode` and `EventValue`.+* Make it possible for user to create a device from a specified file descriptor.+    * Opens up non-blocking IO, amongst other possibilities.+ ## 2.0.0.0 -- 2020-05-30 * This is really what should have been the `1.0` release, had I had a better understanding of the PVP when starting off. * Split Streamly integration into a separate package, `evdev-streamly`.

@@ -5,6 +5,21 @@  It aims to expose the full set of functionality exposed by `libevdev`, while providing stronger types, and a higher level of abstraction - no worrying about memory management, ordering of operations etc. +For a higher-level, more functional API based on event streams, see [evdev-streamly](http://hackage.haskell.org/package/evdev-streamly).++This package uses `ByteString`s (a.k.a `RawFilePath`s) ubiquitously. You may want to substitute use of packages like `filepath`, `directory`, `unix` and `process` with `ByteString`-friendly alternatives:+- [rawfilepath](https://hackage.haskell.org/package/rawfilepath)+- [filepath-bytestring](https://hackage.haskell.org/package/filepath-bytestring)++# Permissions+ Your user will need to be a member of the `input` group in order to read from devices. Try `usermod -a -G input [username]`. -For a higher-level, more functional API based on event streams, see [evdev-streamly](http://hackage.haskell.org/package/evdev-streamly).+To create virtual devices (i.e. to use the `Evdev.UInput` module) you will need permission to write to `/dev/uinput`. This can usually be achieved by creating a group specially for uinput permissions:+```+sudo groupadd uinput+sudo usermod -a -G uinput $USER+echo 'KERNEL=="uinput", GROUP="uinput", MODE:="0660", OPTIONS+="static_node=uinput"' | sudo tee -a /etc/udev/rules+```+Log out and back in for this to take effect.+<!--TODO mention udevadm,modprobe, as in #14 -->

@@ -1,6 +1,6 @@ cabal-version:       3.0 name:                evdev-version:             2.0.0.1+version:             2.1.0 author:              George Thomas maintainer:          George Thomas description:         Provides access to the Linux event device interface.@@ -17,37 +17,63 @@     type: git     location: git://github.com/georgefst/evdev.git +common common+    build-depends:+        base >= 4.11 && < 5,+        bytestring ^>= {0.10, 0.11},+        containers ^>= 0.6.2,+        extra ^>= {1.6.18, 1.7},+        filepath-bytestring ^>= 1.4.2,+        monad-loops ^>= 0.4.3,+        rawfilepath ^>= 0.2.4,+        time ^>= {1.9.3, 1.10, 1.11},+        unix ^>= 2.7.2,+    default-language: Haskell2010+    default-extensions:+        BlockArguments+        DerivingStrategies+        FlexibleContexts+        FlexibleInstances+        GeneralizedNewtypeDeriving+        LambdaCase+        NamedFieldPuns+        NumericUnderscores+        OverloadedStrings+        RecordWildCards+        ScopedTypeVariables+        TupleSections+        TypeApplications+        TypeFamilies+        ViewPatterns+    ghc-options:+        -Wall+ library+    import: common     exposed-modules:         Evdev         Evdev.Codes+        Evdev.Uinput     other-modules:         Evdev.LowLevel+        Util     hs-source-dirs: src     c-sources:         src-c/evdev-hs.c     pkgconfig-depends:         libevdev-    ghc-options:-        -Wall-    build-depends:-        base                 >= 4.11 && < 5,-        bytestring           ^>= 0.10,-        containers           ^>= 0.6.2,-        extra                ^>= {1.6.18, 1.7},-        monad-loops          ^>= 0.4.3,-        time                 ^>= {1.9.3, 1.10},-        unix                 ^>= 2.7.2,     build-tool-depends:         c2hs:c2hs-    default-language: Haskell2010-    default-extensions:-        DerivingStrategies-        FlexibleContexts-        GeneralizedNewtypeDeriving-        LambdaCase-        NumericUnderscores-        OverloadedStrings-        ScopedTypeVariables-        TupleSections-        ViewPatterns++test-suite test+    import: common+    type: exitcode-stdio-1.0+    main-is: Test.hs+    hs-source-dirs: test+    build-depends:+        evdev,+        tasty ^>= 1.4.1,+        tasty-hunit ^>= 0.10.0.3,+        tasty-quickcheck ^>= 0.10.1.1,+    ghc-options:+        -threaded

@@ -11,7 +11,15 @@     deviceName,     devicePath,     deviceProperties,+    deviceEventTypes,+    deviceHasEvent,     deviceFd,+    devicePhys,+    deviceUniq,+    deviceProduct,+    deviceVendor,+    deviceBustype,+    deviceVersion,     -- ** Grabbing     grabDevice,     ungrabDevice,@@ -23,21 +31,25 @@     EventCode(..),     EventValue(..), -    -- * Lower-level types+    -- * Lower-level+    newDeviceFromFd,+    nextEventMay,+    -- ** C-style types     -- | These correspond more directly to C's /input_event/ and /timeval/.     -- They are used internally, but may be useful for advanced users.     LL.CEvent(..),     toCEvent,     fromCEvent,+    toCEventData,+    fromCEventData,     LL.CTimeVal(..),     toCTimeVal,     fromCTimeVal, ) where  import Control.Arrow ((&&&))-import Control.Monad (filterM,join)-import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as BS+import Control.Monad (filterM, join)+import Data.ByteString.Char8 (ByteString, pack) import Data.Int (Int32) import Data.List.Extra (enumerate) import Data.Map ((!?), Map)@@ -47,20 +59,25 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.Time.Clock (DiffTime)+import Data.Tuple.Extra (uncurry3) import Data.Word (Word16) import Foreign ((.|.)) import Foreign.C (CUInt)-import Foreign.C.Error (Errno(Errno),errnoToIOError)-import System.Posix.ByteString (Fd,RawFilePath)-import System.Posix.IO.ByteString (fdToHandle)+import System.Posix.Process (getProcessID)+import System.Posix.Files (readSymbolicLink)+import System.Posix.ByteString (Fd, RawFilePath)+import System.Posix.IO.ByteString (OpenMode (ReadOnly), defaultFileFlags, openFd)  import qualified Evdev.LowLevel as LL import Evdev.Codes+import Util  -- 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. -- | An input device.-data Device = Device { cDevice :: LL.Device, devicePath :: RawFilePath }+data Device = Device { cDevice :: LL.Device, devicePath :: ByteString }++ instance Show Device where     show = show . devicePath @@ -71,7 +88,6 @@     }     deriving (Eq, Ord, Show) ---TODO name? -- | An input event, without the timestamp. -- Each constructor corresponds to one [event type](https://www.kernel.org/doc/html/latest/input/event-codes.html#event-types), except for 'UnknownEvent'. data EventData@@ -90,16 +106,14 @@     | UnknownEvent Word16 EventCode EventValue {- ^ We include this primarily so that 'fromCEvent' can be well-defined -         let us know if you ever actually see one emitted by a device, as it would likely         indicate a shortcoming in the library. -}-    deriving (Eq, Ord, Read, Show)+    deriving (Eq, Ord, Show)  -- | A direct representation of the /code/ field of the C /input_event/, for when there is no obvious meaningful sum type. newtype EventCode = EventCode Word16-    deriving stock (Eq, Ord, Read, Show)-    deriving newtype (Enum, Integral, Real, Num) --TODO all this baggage to make 'toEnum'' slightly easier?+    deriving (Eq, Ord, Show, Enum) -- | A direct representation of the /value/ field of the C /input_event/, for when there is no obvious meaningful sum type. newtype EventValue = EventValue Int32-    deriving stock (Eq, Ord, Read, Show)-    deriving newtype (Enum, Integral, Real, Num)+    deriving (Eq, Ord, Show, Enum)  -- | The status of a key. data KeyEvent@@ -114,6 +128,9 @@ defaultReadFlags :: Set LL.ReadFlag defaultReadFlags = Set.fromList [LL.Normal, LL.Blocking] +nonBlockingReadFlags :: Set LL.ReadFlag+nonBlockingReadFlags = Set.fromList [LL.Normal]+ -- | Prevent other clients (including kernel-internal ones) from receiving events. Often a bad idea. grabDevice :: Device -> IO () grabDevice = grabDevice' LL.LibevdevGrab@@ -124,48 +141,52 @@ -- | Get the next event from the device. nextEvent :: Device -> IO Event nextEvent dev =-    fromCEvent <$> throwCErrors "nextEvent" (Right dev) (LL.nextEvent (cDevice dev) (convertFlags defaultReadFlags))+    fromCEvent <$> cErrCall "nextEvent" dev (LL.nextEvent (cDevice dev) (convertFlags defaultReadFlags)) +{- | Get the next event from the device, if one is available.+Designed for use with devices created from a non-blocking file descriptor. Otherwise equal to @fmap Just . nextEvent@.+-}+nextEventMay :: Device -> IO (Maybe Event)+nextEventMay dev =+    fmap fromCEvent <$> cErrCall "nextEventMay" dev (LL.nextEventMay (cDevice dev) (convertFlags nonBlockingReadFlags))+ fromCEvent :: LL.CEvent -> Event-fromCEvent (LL.CEvent t (EventCode -> c) (EventValue -> v) time) = Event event $ fromCTimeVal time-  where-    event = fromMaybe unknown $ toEnum' t >>= \case-        EvSyn -> SyncEvent     <$> toEnum' c-        EvKey -> KeyEvent      <$> toEnum' c <*> toEnum' v-        EvRel -> RelativeEvent <$> toEnum' c <*> pure v-        EvAbs -> AbsoluteEvent <$> toEnum' c <*> pure v-        EvMsc -> MiscEvent     <$> toEnum' c <*> pure v-        EvSw  -> SwitchEvent   <$> toEnum' c <*> pure v-        EvLed -> LEDEvent      <$> toEnum' c <*> pure v-        EvSnd -> SoundEvent    <$> toEnum' c <*> pure v-        EvRep -> RepeatEvent   <$> toEnum' c <*> pure v-        EvFf  -> Just $ ForceFeedbackEvent c v-        EvPwr -> Just $ PowerEvent c v-        EvFfStatus -> Just $ ForceFeedbackStatusEvent c v-    unknown = UnknownEvent t c v+fromCEvent (LL.CEvent t c v time) = Event (fromCEventData (t,c,v)) $ fromCTimeVal time +fromCEventData :: (Word16, Word16, Int32) -> EventData+fromCEventData (t, EventCode -> c, EventValue -> v) = fromMaybe (UnknownEvent t c v) $ toEnum' t >>= \case+    EvSyn -> SyncEvent     <$> toEnum' c+    EvKey -> KeyEvent      <$> toEnum' c <*> toEnum' v+    EvRel -> RelativeEvent <$> toEnum' c <*> pure v+    EvAbs -> AbsoluteEvent <$> toEnum' c <*> pure v+    EvMsc -> MiscEvent     <$> toEnum' c <*> pure v+    EvSw  -> SwitchEvent   <$> toEnum' c <*> pure v+    EvLed -> LEDEvent      <$> toEnum' c <*> pure v+    EvSnd -> SoundEvent    <$> toEnum' c <*> pure v+    EvRep -> RepeatEvent   <$> toEnum' c <*> pure v+    EvFf  -> Just $ ForceFeedbackEvent c v+    EvPwr -> Just $ PowerEvent c v+    EvFfStatus -> Just $ ForceFeedbackStatusEvent c v+ toCEvent :: Event -> LL.CEvent-toCEvent (Event e time) = case e of+toCEvent (Event e time) = uncurry3 LL.CEvent (toCEventData e) $ toCTimeVal time++toCEventData :: EventData -> (Word16, Word16, Int32)+toCEventData = \case     -- from kernel docs, 'EV_SYN event values are undefined' - we always seem to see 0, so may as well use that-    SyncEvent                (fe -> c) -> LL.CEvent (fe EvSyn) c 0 cTime-    KeyEvent                 (fe -> c) (fe -> v) -> LL.CEvent (fe EvKey) c v cTime-    RelativeEvent            (fe -> c) (fe -> v) -> LL.CEvent (fe EvRel) c v cTime-    AbsoluteEvent            (fe -> c) (fe -> v) -> LL.CEvent (fe EvAbs) c v cTime-    MiscEvent                (fe -> c) (fe -> v) -> LL.CEvent (fe EvMsc) c v cTime-    SwitchEvent              (fe -> c) (fe -> v) -> LL.CEvent (fe EvSw)  c v cTime-    LEDEvent                 (fe -> c) (fe -> v) -> LL.CEvent (fe EvLed) c v cTime-    SoundEvent               (fe -> c) (fe -> v) -> LL.CEvent (fe EvSnd) c v cTime-    RepeatEvent              (fe -> c) (fe -> v) -> LL.CEvent (fe EvRep) c v cTime-    ForceFeedbackEvent       (fe -> c) (fe -> v) -> LL.CEvent (fe EvFf)  c v cTime-    PowerEvent               (fe -> c) (fe -> v) -> LL.CEvent (fe EvPwr) c v cTime-    ForceFeedbackStatusEvent (fe -> c) (fe -> v) -> LL.CEvent (fe EvFfStatus) c v cTime-    UnknownEvent             (fe -> t) (fe -> c) (fe -> v) -> LL.CEvent t c v cTime-  where-    --TODO this isn't entirely safe in general, though it's really no worse than 'fromEnum'-    -- if we could tell C2HS which int type each #defined enum corresponded to, we could check this statically-    fe :: (Enum a, Integral b) => a -> b-    fe = fromIntegral . fromEnum-    cTime = toCTimeVal time+    SyncEvent                (fromEnum' -> c) -> (fromEnum' EvSyn, c, 0)+    KeyEvent                 (fromEnum' -> c) (fromEnum' -> v) -> (fromEnum' EvKey, c, v)+    RelativeEvent            (fromEnum' -> c) (fromEnum' -> v) -> (fromEnum' EvRel, c, v)+    AbsoluteEvent            (fromEnum' -> c) (fromEnum' -> v) -> (fromEnum' EvAbs, c, v)+    MiscEvent                (fromEnum' -> c) (fromEnum' -> v) -> (fromEnum' EvMsc, c, v)+    SwitchEvent              (fromEnum' -> c) (fromEnum' -> v) -> (fromEnum' EvSw,  c, v)+    LEDEvent                 (fromEnum' -> c) (fromEnum' -> v) -> (fromEnum' EvLed, c, v)+    SoundEvent               (fromEnum' -> c) (fromEnum' -> v) -> (fromEnum' EvSnd, c, v)+    RepeatEvent              (fromEnum' -> c) (fromEnum' -> v) -> (fromEnum' EvRep, c, v)+    ForceFeedbackEvent       (fromEnum' -> c) (fromEnum' -> v) -> (fromEnum' EvFf,  c, v)+    PowerEvent               (fromEnum' -> c) (fromEnum' -> v) -> (fromEnum' EvPwr, c, v)+    ForceFeedbackStatusEvent (fromEnum' -> c) (fromEnum' -> v) -> (fromEnum' EvFfStatus, c, v)+    UnknownEvent             (fromEnum' -> t) (fromEnum' -> c) (fromEnum' -> v) -> (t, c, v)  fromCTimeVal :: LL.CTimeVal -> DiffTime fromCTimeVal (LL.CTimeVal s us) =@@ -178,10 +199,22 @@  -- | Create a device from a valid path - usually /\/dev\/input\/eventX/ for some /X/. newDevice :: RawFilePath -> IO Device-newDevice path = do-    dev <- throwCErrors "newDevice" (Left path) $ LL.newDevice path-    return $ Device dev path+newDevice path = newDeviceFromFd =<< openFd path ReadOnly Nothing defaultFileFlags +{- | Generalisation of 'newDevice'.+Note that:++> newDevice path = newDeviceFromFd =<< openFd path ReadOnly Nothing defaultFileFlags++__WARNING__: Don't attempt to reuse the 'Fd' - it will be closed when the 'Device' is garbage collected.+-}+newDeviceFromFd :: Fd -> IO Device+newDeviceFromFd fd = do+    dev <- cErrCall "newDeviceFromFd" () $ LL.newDeviceFromFd fd+    pid <- getProcessID+    path <- readSymbolicLink $ "/proc/" <> show pid <> "/fd/" <> show fd+    return $ Device{cDevice = dev, devicePath = pack path}+ -- | The usual directory containing devices (/"\/dev\/input"/). evdevDir :: RawFilePath evdevDir = "/dev/input"@@ -191,30 +224,36 @@  deviceFd :: Device -> IO Fd deviceFd = LL.deviceFd . cDevice+devicePhys :: Device -> IO ByteString+devicePhys = join . LL.devicePhys . cDevice+deviceUniq :: Device -> IO ByteString+deviceUniq = join . LL.deviceUniq . cDevice+deviceProduct :: Device -> IO Int+deviceProduct = LL.deviceProduct . cDevice+deviceVendor :: Device -> IO Int+deviceVendor = LL.deviceVendor . cDevice+deviceBustype :: Device -> IO Int+deviceBustype = LL.deviceBustype . cDevice+deviceVersion :: Device -> IO Int+deviceVersion = LL.deviceVersion . cDevice  deviceProperties :: Device -> IO [DeviceProperty] deviceProperties dev = filterM (LL.hasProperty $ cDevice dev) enumerate +deviceEventTypes :: Device -> IO [EventType]+deviceEventTypes dev = filterM (LL.hasEventType $ cDevice dev) enumerate -{- Util -}+--TODO this is an imperfect API since '_val' is ignored entirely+deviceHasEvent :: Device -> EventData -> IO Bool+deviceHasEvent dev e = LL.hasEventCode (cDevice dev) typ code+  where (typ,code,_val) = toCEventData e --- run the action, throwing a relevant exception if the C errno is not 0-throwCErrors :: String -> Either ByteString Device -> IO (Errno, a) -> IO a-throwCErrors func pathOrDev x = do-    (errno, res) <- x-    case errno of-        Errno 0 -> return res-        Errno n -> do-            (handle,path) <- case pathOrDev of-                Left path -> return (Nothing,path)-                Right dev -> do-                    h <- fdToHandle =<< deviceFd dev-                    return (Just h, devicePath dev)-            ioError $ errnoToIOError func (Errno $ abs n) handle (Just $ BS.unpack path) -grabDevice' :: LL.GrabMode -> Device -> IO ()-grabDevice' mode dev = throwCErrors "grabDevice" (Right dev) $ LL.grabDevice (cDevice dev) mode+{- Util -} +grabDevice' :: LL.GrabMode -> Device -> IO ()+grabDevice' mode dev = cErrCall "grabDevice" dev $+    LL.grabDevice (cDevice dev) mode  {- TODO this is a workaround until c2hs has a better story for enum conversions@@ -231,9 +270,12 @@         this doesn't necessarily consider enum defines though - discussion is around capturing the semantics of actual C enums     alternatively, monomorphic functions for each type, as with c2hs's with* functions -}-toEnum' :: forall k a. (Integral k, Bounded a, Enum a) => k -> Maybe a+toEnum' :: forall k a. (Ord k, Enum k, Bounded a, Enum a) => k -> Maybe a toEnum' = (enumMap !?)   where     --TODO HashMap, IntMap?     enumMap :: Map k a-    enumMap = Map.fromList $ map (fromIntegral . fromEnum &&& id) enumerate+    enumMap = Map.fromList $ map (toEnum . fromEnum &&& id) enumerate++instance CErrInfo Device where+    cErrInfo = return . Just . devicePath

@@ -1,21 +1,20 @@ module Evdev.LowLevel where -import Control.Monad.Loops (iterateWhile)-import Data.ByteString (ByteString,packCString)+import Control.Monad (join)+import Data.ByteString (ByteString,packCString,useAsCString) import Data.Coerce (coerce) import Data.Int (Int32,Int64) import Data.Word (Word16)-import Foreign (Ptr,allocaBytes)-import Foreign.C (CInt(..),CLong(..),CUInt(..),CUShort(..))-import Foreign.C.Error (Errno(Errno))-import System.Posix.ByteString (RawFilePath)-import System.Posix.IO.ByteString (OpenMode(ReadOnly),defaultFileFlags,openFd)+import Foreign (Ptr,allocaBytes,mallocBytes,mallocForeignPtrBytes,newForeignPtr_,nullPtr,peek,withForeignPtr)+import Foreign.C (CInt(..),CLong(..),CUInt(..),CUShort(..),CString)+import Foreign.C.Error (Errno(Errno), eOK, eAGAIN) import System.Posix.Types (Fd(Fd))  import Evdev.Codes  #include <errno.h> #include <libevdev-1.0/libevdev/libevdev.h>+#include <libevdev-1.0/libevdev/libevdev-uinput.h> #include <linux/input.h>  {#enum libevdev_read_flag as ReadFlag {@@ -35,6 +34,12 @@ void libevdev_hs_close(struct libevdev *dev); #endc +{#pointer *libevdev_uinput as UDevice foreign finalizer libevdev_uinput_destroy newtype #}++--TODO '{#enum libevdev_uinput_open_mode {} #}' results in malformed output - c2hs bug+{#enum libevdev_uinput_open_mode as UInputOpenMode {LIBEVDEV_UINPUT_OPEN_MANAGED as UOMManaged} #}++ data CEvent = CEvent     { cEventType :: Word16     , cEventCode :: Word16@@ -50,51 +55,130 @@     deriving (Eq, Ord, Read, Show)  -{- Conversions -}+{- Complex stuff -}  {#fun libevdev_next_event { `Device', `CUInt', `Ptr ()' } -> `Errno' Errno #} nextEvent :: Device -> CUInt -> IO (Errno, CEvent) nextEvent dev flags = allocaBytes {#sizeof input_event #} $ \evPtr ->-    (,) <$> iterateWhile (== Errno (-{#const EAGAIN #})) (libevdev_next_event dev flags evPtr)-        <*> ( CEvent-            <$> (coerce <$> {#get input_event->type #} evPtr)-            <*> (coerce <$> {#get input_event->code #} evPtr)-            <*> (coerce <$> {#get input_event->value #} evPtr)-            <*> ( CTimeVal-                <$> (coerce <$> {#get input_event->time.tv_sec #} evPtr)-                <*> (coerce <$> {#get input_event->time.tv_usec #} evPtr)+    (,) <$> libevdev_next_event dev flags evPtr <*> getEvent evPtr+nextEventMay :: Device -> CUInt -> IO (Errno, Maybe CEvent)+nextEventMay dev flags = allocaBytes {#sizeof input_event #} $ \evPtr -> do+    err <- libevdev_next_event dev flags evPtr+    if err /= eOK+        then return+            ( if negateErrno err == eAGAIN then eOK else err+            , Nothing             )+        else (eOK,) . Just <$> getEvent evPtr+getEvent :: Ptr () -> IO CEvent+getEvent evPtr = CEvent+    <$> (coerce <$> {#get input_event->type #} evPtr)+    <*> (coerce <$> {#get input_event->code #} evPtr)+    <*> (coerce <$> {#get input_event->value #} evPtr)+    <*> ( CTimeVal+        <$> (coerce <$> {#get input_event->time.tv_sec #} evPtr)+        <*> (coerce <$> {#get input_event->time.tv_usec #} evPtr)         )  {#fun libevdev_grab { `Device', `GrabMode' } -> `Errno' Errno #}-grabDevice :: Device -> GrabMode -> IO (Errno, ())-grabDevice = fmap (,()) .: libevdev_grab+grabDevice :: Device -> GrabMode -> IO Errno+grabDevice = libevdev_grab  --TODO use 'libevdev_new_from_fd' when https://github.com/haskell/c2hs/issues/236 fixed {#fun libevdev_new {} -> `Device' #} {#fun libevdev_set_fd { `Device', unFd `Fd' } -> `Errno' Errno #}-newDevice :: RawFilePath -> IO (Errno, Device)-newDevice path = do-    fd <- openFd path ReadOnly Nothing defaultFileFlags-    dev <- libevdev_new-    err <- libevdev_set_fd dev fd-    return (err, dev)+newDeviceFromFd :: Fd -> IO (Errno, Device)+newDeviceFromFd fd = libevdev_new >>= \dev -> (, dev) <$> libevdev_set_fd dev fd +--TODO 'useAsCString' copies, which seems unnecessary due to the 'const' in the C function+{#fun libevdev_set_name { `Device', `CString' } -> `()' #}+setDeviceName :: Device -> ByteString -> IO ()+setDeviceName dev name = useAsCString name $ libevdev_set_name dev+{#fun libevdev_set_phys { `Device', `CString' } -> `()' #}+setDevicePhys :: Device -> ByteString -> IO ()+setDevicePhys dev phys = useAsCString phys $ libevdev_set_phys dev+{#fun libevdev_set_uniq { `Device', `CString' } -> `()' #}+setDeviceUniq :: Device -> ByteString -> IO ()+setDeviceUniq dev uniq = useAsCString uniq $ libevdev_set_uniq dev +--TODO c2hs can't seem to help us here due to the nested pointer+foreign import ccall safe "Evdev/LowLevel.chs.h libevdev_uinput_create_from_device"+  libevdev_uinput_create_from_device :: Ptr Device -> CInt -> Ptr (Ptr UDevice) -> IO CInt+createFromDevice :: Device -> Fd -> IO (Errno, UDevice)+createFromDevice dev (Fd fd) = withDevice dev $ \devP -> do+    devFPP <- mallocForeignPtrBytes 0+    (e,x) <- withForeignPtr devFPP $ \devPP ->+        (,) <$> libevdev_uinput_create_from_device devP fd devPP <*> peek devPP+    devFP <- newForeignPtr_ x+    return (Errno e, UDevice devFP)++--TODO since the same technique produces just one 'IO' for  'deviceName', is this another c2hs bug?+{#fun libevdev_uinput_get_syspath  { `UDevice' } -> `IO (Maybe ByteString)' packCString' #}+getSyspath :: UDevice -> IO (Maybe ByteString)+getSyspath = join . libevdev_uinput_get_syspath+{#fun libevdev_uinput_get_devnode  { `UDevice' } -> `IO (Maybe ByteString)' packCString' #}+getDevnode :: UDevice -> IO (Maybe ByteString)+getDevnode = join . libevdev_uinput_get_devnode++data AbsInfo = AbsInfo+    { absValue :: Int32+    , absMinimum :: Int32+    , absMaximum :: Int32+    , absFuzz :: Int32+    , absFlat :: Int32+    , absResolution :: Int32+    }+withAbsInfo :: AbsInfo -> (Ptr () -> IO a) -> IO a+withAbsInfo AbsInfo{..} f = do+    p <- mallocBytes {#sizeof input_absinfo#}+    {#set input_absinfo.value#} p $ CInt absValue+    {#set input_absinfo.minimum#} p $ CInt absMinimum+    {#set input_absinfo.maximum#} p $ CInt absMaximum+    {#set input_absinfo.fuzz#} p $ CInt absFuzz+    {#set input_absinfo.flat#} p $ CInt absFlat+    {#set input_absinfo.resolution#} p $ CInt absResolution+    pf <- newForeignPtr_ p+    withForeignPtr pf f++ {- Simpler functions -} -{#fun libevdev_has_property as hasProperty { `Device', devPropToInt `DeviceProperty' } -> `Bool' #}+{#fun libevdev_has_property as hasProperty { `Device', convertEnum `DeviceProperty' } -> `Bool' #}+{#fun libevdev_has_event_type as hasEventType { `Device', convertEnum `EventType' } -> `Bool' #}+{#fun libevdev_has_event_code as hasEventCode { `Device', `Word16', `Word16' } -> `Bool' #} {#fun libevdev_get_fd as deviceFd { `Device' } -> `Fd' Fd #} {#fun libevdev_get_name as deviceName { `Device' } -> `IO ByteString' packCString #}+{#fun libevdev_get_phys as devicePhys { `Device' } -> `IO ByteString' packCString #}+{#fun libevdev_get_uniq as deviceUniq { `Device' } -> `IO ByteString' packCString #}+{#fun libevdev_get_id_product as deviceProduct { `Device' } -> `Int' #}+{#fun libevdev_get_id_vendor as deviceVendor { `Device' } -> `Int' #}+{#fun libevdev_get_id_bustype as deviceBustype { `Device' } -> `Int' #}+{#fun libevdev_get_id_version as deviceVersion { `Device' } -> `Int' #}+{#fun libevdev_set_id_product { `Device', `Int' } -> `()' #}+{#fun libevdev_set_id_vendor { `Device', `Int' } -> `()' #}+{#fun libevdev_set_id_bustype { `Device', `Int' } -> `()' #}+{#fun libevdev_set_id_version { `Device', `Int' } -> `()' #}+{#fun libevdev_enable_event_type as enableType { `Device', `Word16' } -> `Errno' Errno #}+{#fun libevdev_enable_event_code as enableCode { `Device', `Word16', `Word16', `Ptr ()' } -> `Errno' Errno #}+{#fun libevdev_uinput_write_event as writeEvent { `UDevice', `Word16', `Word16', `Int32' } -> `Errno' Errno #}   {- Util -} -devPropToInt :: DeviceProperty -> CUInt-devPropToInt = fromIntegral . fromEnum+convertEnum :: (Enum a, Integral b) => a -> b+convertEnum = fromIntegral . fromEnum  (.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d (.:) = (.) . (.)  unFd :: Fd -> CInt unFd (Fd n) = n++handleNull :: b -> (Ptr a -> b) -> Ptr a -> b+handleNull def f p = if p == nullPtr then def else f p++packCString' :: CString -> IO (Maybe ByteString)+packCString' = handleNull (return Nothing) (fmap Just . packCString)++negateErrno :: Errno -> Errno+negateErrno (Errno cint) = Errno (-cint)

@@ -0,0 +1,137 @@+-- | 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 name DeviceOpts{..} = do+    dev <- LL.libevdev_new+    LL.setDeviceName dev name++    let maybeSet :: (LL.Device -> a -> IO ()) -> Maybe a -> IO ()+        maybeSet setter x = maybe (pure ()) (setter dev) x+    maybeSet LL.setDevicePhys phys+    maybeSet LL.setDeviceUniq uniq+    maybeSet LL.libevdev_set_id_product idProduct+    maybeSet LL.libevdev_set_id_vendor idVendor+    maybeSet LL.libevdev_set_id_bustype idBustype+    maybeSet LL.libevdev_set_id_version idVersion++    let enable :: Ptr () -> EventType -> [Word16] -> IO ()+        enable ptr t cs = do+            unless (null cs) $ cec $ LL.enableType dev t'+            forM_ cs $ \c -> cec $ LL.enableCode dev t' c ptr+          where+            t' = fromEnum' t++    mapM_+        (uncurry $ enable nullPtr)+        [ (EvKey, map fromEnum' keys)+        , (EvRel, map fromEnum' relAxes)+        , (EvMsc, map fromEnum' miscs)+        , (EvSw, map fromEnum' switchs)+        , (EvLed, map fromEnum' leds)+        , (EvSnd, map fromEnum' sounds)+        , (EvFf, map fromEnum' ffs)+        , (EvPwr, map fromEnum' powers)+        , (EvFfStatus, map fromEnum' ffStats)+        ]++    forM_ reps $ \(rep, n) -> do+        pf <- mallocForeignPtr+        withForeignPtr pf \p -> do+            poke p n+            enable (castPtr p) EvRep [fromEnum' rep]++    forM_ absAxes $ \(axis, absInfo) ->+        LL.withAbsInfo absInfo $ \ptr ->+            enable ptr EvAbs [fromEnum' axis]++    fmap Device $ cec $ LL.createFromDevice dev $ fromEnum' LL.UOMManaged+  where+    cec :: CErrCall a => IO a -> IO (CErrCallRes a)+    cec = cErrCall "newDevice" ()++data DeviceOpts = DeviceOpts+    { phys :: Maybe ByteString+    , uniq :: Maybe ByteString+    , idProduct :: Maybe Int+    , idVendor :: Maybe Int+    , idBustype :: Maybe Int+    , idVersion :: Maybe Int+    , keys :: [Key]+    , relAxes :: [RelativeAxis]+    , absAxes :: [(AbsoluteAxis, LL.AbsInfo)]+    , miscs :: [MiscEvent]+    , switchs :: [SwitchEvent]+    , leds :: [LEDEvent]+    , sounds :: [SoundEvent]+    , reps :: [(RepeatEvent, Int)]+    , ffs :: [EventCode]+    , powers :: [EventCode]+    , ffStats :: [EventCode]+    }+defaultDeviceOpts :: DeviceOpts+defaultDeviceOpts =+    DeviceOpts+        { uniq = Nothing+        , phys = Nothing+        , idProduct = Nothing+        , idVendor = Nothing+        , idBustype = Nothing+        , idVersion = Nothing+        , keys = []+        , relAxes = []+        , absAxes = []+        , miscs = []+        , switchs = []+        , leds = []+        , sounds = []+        , reps = []+        , ffs = []+        , powers = []+        , ffStats = []+        }++-- | Write a single event. Doesn't issue a sync event, so: @writeEvent dev e /= writeBatch dev [e]@.+writeEvent :: Device -> EventData -> IO ()+writeEvent (Device dev) e = do+    cErrCall "writeEvent" dev $ uncurry3 (LL.writeEvent dev) $ toCEventData e++-- | Write several events followed by a 'SynReport'.+writeBatch :: Foldable t => Device -> t EventData -> IO ()+writeBatch dev es = do+    forM_ es $ writeEvent dev+    writeEvent dev $ SyncEvent SynReport++deviceSyspath :: Device -> IO (Maybe ByteString)+deviceSyspath = LL.getSyspath . \(Device d) -> d+deviceDevnode :: Device -> IO (Maybe ByteString)+deviceDevnode = LL.getDevnode . \(Device d) -> d

@@ -0,0 +1,40 @@+module Util where++import qualified Data.ByteString.Char8 as BS+import Foreign.C.Error (Errno (Errno), errnoToIOError)+import System.Posix.ByteString (RawFilePath)++import qualified Evdev.LowLevel as LL++fromEnum' :: (Num c, Enum a) => a -> c+fromEnum' = fromIntegral . fromEnum++--TODO careful - for some C calls (eg. libevdev_enable_event_code),+-- int returned doesn't necessarily correspond to a particular error number+--TODO this kinda seems like overkill, but things were getting ugly without it...+class CErrInfo a where+    cErrInfo :: a -> IO (Maybe RawFilePath)+instance CErrInfo () where+    cErrInfo () = return Nothing+instance CErrInfo RawFilePath where+    cErrInfo = pure . pure+instance CErrInfo LL.UDevice where+    cErrInfo = LL.getSyspath++-- for c actions which return an error value (0 for success)+-- run the action, throwing a relevant exception if the C errno is not 0+class CErrCall a where+    type CErrCallRes a+    cErrCall :: CErrInfo info => String -> info -> IO a -> IO (CErrCallRes a)+instance CErrCall Errno where+    type CErrCallRes Errno = ()+    cErrCall func path x = cErrCall func path $ (,()) <$> x+instance CErrCall (Errno, a) where+    type CErrCallRes (Errno, a) = a+    cErrCall func info x = do+        (errno, res) <- x+        case errno of+            Errno 0 -> return res+            Errno n -> do+                path' <- cErrInfo info+                ioError $ errnoToIOError func (Errno $ abs n) Nothing $ BS.unpack <$> path'

@@ -0,0 +1,83 @@+module Main where++import Control.Concurrent+import Control.Exception+import Control.Monad+import Control.Monad.Loops+import Data.Either.Extra+import Data.Foldable.Extra+import Data.Functor+import Data.Maybe+import Data.Time+import Evdev+import Evdev.Codes+import qualified Evdev.Uinput as Uinput+import RawFilePath+import System.FilePath.ByteString+import System.IO.Error+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck++main :: IO ()+main = defaultMain $ testGroup "Tests" [smoke, inverses]++{- | Just checks that we can create a virtual device, find it, see that it has the expected properties,+and read the expected events.+-}+smoke :: TestTree+smoke = testCase "Smoke" do+    start <- newEmptyMVar+    let duName = "evdev-test-device"+        keys = [Key1 .. Key0]+        evs = concatMap ((<$> [Pressed, Released]) . KeyEvent) keys+    du <- Uinput.newDevice duName Uinput.defaultDeviceOpts{Uinput.keys}+    void $ forkIO do+        takeMVar start -- wait until reading device is initialised+        Uinput.writeBatch du evs+    listDirectory evdevDir+        >>= traverse (fmap eitherToMaybe . try @IOError . (retryIf isPermissionError . newDevice) . (evdevDir </>))+        >>= findM (fmap (== duName) . deviceName) . catMaybes+        >>= \case+            Nothing -> assertFailure "Couldn't find device with correct name"+            Just d -> do+                putMVar start ()+                (@?= [EvSyn, EvKey]) =<< deviceEventTypes d+                evs' <- whileJust ((\x -> guard (x /= last evs) $> x) . eventData <$> nextEvent d) pure+                filter (/= SyncEvent SynReport) evs' @?= init evs++inverses :: TestTree+inverses =+    localOption (QuickCheckTests 1000) . testGroup "Inverses" $+        [ testGroup+            "TimeVal"+            [ testProperty "1" \(s, us) ->+                let tv = CTimeVal s us+                 in s < 0 || us < 0 || us >= 1_000_000 || toCTimeVal (fromCTimeVal tv) == tv+            , testProperty "2" \n ->+                let -- 'toCTimeVal' goes from picoseconds to microseconds+                    resolutionFactor = 1_000_000+                 in abs (diffTimeToPicoseconds (fromCTimeVal . toCTimeVal $ picosecondsToDiffTime n) - n)+                        < resolutionFactor+            ]+        , testProperty "EventData" \x@(t, c, _v) ->+            let x'@(t', c', v') = toCEventData (fromCEventData x)+                syncValueZero =+                    -- 'toCEventData' takes all values for sync events to 0 - fine as they don't mean anything+                    and+                        [ t == t'+                        , fromEnum t == fromEnum EvSyn+                        , c == c'+                        , v' == 0+                        ]+             in x' == x || syncValueZero+        ]++--TODO make delay and max retries configurable, add to library?+retryIf :: forall a e. Exception e => (e -> Bool) -> IO a -> IO a+retryIf p x = go 100+  where+    go :: Word -> IO a+    go tries =+        x `catch` \e ->+            if p e && tries /= 0 then threadDelay 10_000 >> go (tries - 1) else throw e