diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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`. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. + diff --git a/evdev.cabal b/evdev.cabal --- a/evdev.cabal +++ b/evdev.cabal @@ -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 diff --git a/src/Evdev.hs b/src/Evdev.hs --- a/src/Evdev.hs +++ b/src/Evdev.hs @@ -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 diff --git a/src/Evdev/LowLevel.chs b/src/Evdev/LowLevel.chs --- a/src/Evdev/LowLevel.chs +++ b/src/Evdev/LowLevel.chs @@ -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 #include +#include #include {#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) diff --git a/src/Evdev/Uinput.hs b/src/Evdev/Uinput.hs new file mode 100644 --- /dev/null +++ b/src/Evdev/Uinput.hs @@ -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 diff --git a/src/Util.hs b/src/Util.hs new file mode 100644 --- /dev/null +++ b/src/Util.hs @@ -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' diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -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