diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,27 +1,27 @@ # Revision history for evdev -## 0.1.0.0 -- 2019-07-20 - -* First version. Released on an unsuspecting world. - -## 1.0.0.0 -- 2019-12-15 - -* First stable release. +## 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`. +* Safety improvements - `UnknownEvent` is used to handle a number of what were previously potential crashes. +* Lots of other, minor improvements, including simplifying the API in places, and exposing lower-level functionality where it is likely to be useful. -## 1.1.0.0 -- 2019-12-16 +## 1.3.0.0 -- 2020-03-03 +* Fix memory management issues and file descriptor leaks. +* Rename 'ReadFlags' to 'ReadFlag' as the type clearly represents just one flag. -* Hide LowLevel. +## 1.2.0.0 -- 2019-12-19 +* Add `newDevices` stream. +* More robust error handling when reading from multiple devices. ## 1.1.0.1 -- 2019-12-18 - * Add `pkgconfig-depends` field to cabal file. -## 1.2.0.0 -- 2019-12-19 - -* Add `newDevices` stream. -* More robust error handling when reading from multiple devices. +## 1.1.0.0 -- 2019-12-16 +* Hide LowLevel. -## 1.3.0.0 -- 2020-03-03 +## 1.0.0.0 -- 2019-12-15 +* First stable release. -* Fix memory management issues and file descriptor leaks. -* Rename 'ReadFlags' to 'ReadFlag' as the type clearly represents just one flag. +## 0.1.0.0 -- 2019-07-20 +* First version. Released on an unsuspecting world. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,22 +1,9 @@ -Haskell evdev library -===================== - -http://hackage.haskell.org/package/evdev +Evdev +===== This library provides access to the Linux [evdev](https://en.wikipedia.org/wiki/Evdev) interface, for reading input events from devices. It uses [c2hs](https://github.com/haskell/c2hs/wiki/User-Guide)-generated bindings to [libevdev](https://www.freedesktop.org/wiki/Software/libevdev/), which should be available on almost any modern Linux distro. -Modules -------- -- `Evdev` provides the basic functionality for initialising devices, reading events etc. -- `Evdev.Codes` contains datatypes corresponding to the constants in `input-event-codes.h`, such as keys and device properties. -- `Evdev.Stream` provides a higher-level [Streamly](https://hackage.haskell.org/package/streamly)-based interface, for obtaining a stream of events. - - -Why streamly? -------------- -Compared to other Haskell streaming libraries, I've found `streamly` to have a remarkably easy-to-use API, and the best, simplest support for concurrency. For example, merging concurrent streams of events, from different devices, is trivial. - -If you wish to use this library alongside `conduit`, `pipes` etc. then see [here](https://hackage.haskell.org/package/streamly-0.7.0/docs/Streamly-Tutorial.html#g:39) for a guide on interoperation. +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. Getting started --------------- @@ -26,12 +13,7 @@ The [evdev-examples](https://github.com/georgefst/evdev/tree/master/evdev-examples) folder contains a basic `evtest` clone, with the added ability to read events from multiple devices concurrently. -See [Hackage](http://hackage.haskell.org/package/evdev) for further documentation. - -Still to come -------------- -Haddock documentation for the non-stream interface. I intend to redesign the interface in some minor ways first. Until then, everything maps quite directly to the C library, while taking care of the nitty-gritty low-level stuff. - -There are many more methods in the C library that I'd like to expose. So far the emphasis has very much been on squeezing out the functionality I personally needed. +Streamly +-------- -Some of the streaming functions print exceptions straight to `stderr`. Again, this was convenient at the time, but it would be cleaner to allow specifying a `Writer`, or passing callbacks. +For a higher-level, more functional API based on event streams, see [evdev-streamly](http://hackage.haskell.org/package/evdev-streamly). diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/evdev.cabal b/evdev.cabal --- a/evdev.cabal +++ b/evdev.cabal @@ -1,57 +1,53 @@ -cabal-version: 2.2 +cabal-version: 3.0 name: evdev -version: 1.3.0.0 +version: 2.0.0.0 author: George Thomas maintainer: George Thomas -description: Provides access to the Linux event device interface, with an optional high-level Streamly-based API. +description: Provides access to the Linux event device interface. synopsis: Bindings to libevdev homepage: https://github.com/georgefst/evdev license: BSD-3-Clause license-file: LICENSE category: System -extra-source-files: CHANGELOG.md - README.md +extra-source-files: + CHANGELOG.md + README.md source-repository head - type: git - location: git://github.com/georgefst/evdev.git + type: git + location: git://github.com/georgefst/evdev.git library - exposed-modules: Evdev - Evdev.Codes - Evdev.Stream - other-modules: Evdev.LowLevel - hs-source-dirs: src - ghc-options: -Wall - build-depends: base ^>= 4.11 || ^>= 4.12 || ^>= 4.13, - bytestring ^>= 0.10, - containers ^>= 0.6.2, - either ^>= 5.0.1, - time ^>= 1.9.3, - unix ^>= 2.7.2, - process ^>= 1.6.5, - extra ^>= 1.6.18, - hinotify ^>= 0.4, - posix-paths ^>= 0.2.1, - rawfilepath ^>= 0.2.4, - streamly ^>= 0.6.1 || ^>= 0.7, - safe ^>= 0.3.18, - monad-loops ^>= 0.4.3, - streamly-fsnotify ^>= 1.0, - paths ^>= 0.2, - build-tool-depends: c2hs:c2hs - default-language: Haskell2010 - default-extensions: FlexibleContexts - GeneralizedNewtypeDeriving - LambdaCase - NumericUnderscores - OverloadedLists - OverloadedStrings - PatternSynonyms - TupleSections - ViewPatterns - includes: libevdev-1.0/libevdev/libevdev.h - linux/input.h - errno.h - c-sources: src-c/evdev-hs.c - pkgconfig-depends: libevdev + exposed-modules: + Evdev + Evdev.Codes + other-modules: + Evdev.LowLevel + 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 diff --git a/src/Evdev.hs b/src/Evdev.hs --- a/src/Evdev.hs +++ b/src/Evdev.hs @@ -1,160 +1,188 @@ +{-# OPTIONS_GHC -fno-state-hack #-} + +-- | The main module for working with devices and events. module Evdev ( - pattern SyncEvent, - pattern KeyEvent, - pattern RelativeEvent, - pattern AbsoluteEvent, - pattern MiscEvent, - pattern SwitchEvent, - pattern LEDEvent, - pattern SoundEvent, - pattern RepeatEvent, - pattern ForceFeedbackEvent, - pattern PowerEvent, - pattern ForceFeedbackStatusEvent, - prettyEvent, - defaultReadFlags, - grabDevice, - ungrabDevice, - nextEvent, + -- * Devices + Device, newDevice, + nextEvent, evdevDir, + -- ** Properties deviceName, - deviceFd, devicePath, deviceProperties, - Device, - Event(..), --TODO provide access to Word16 etc... + deviceFd, + -- ** Grabbing + grabDevice, + ungrabDevice, + + -- * Events + Event(..), + EventData(..), + KeyEvent(..), EventCode(..), EventValue(..), - KeyEventType(..), - ReadFlag(..), + + -- * Lower-level 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, + LL.CTimeVal(..), + toCTimeVal, + fromCTimeVal, ) where -import Control.Arrow (second) +import Control.Arrow ((&&&)) import Control.Monad (filterM,join) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as BS import Data.Int (Int32) import Data.List.Extra (enumerate) +import Data.Map ((!?), Map) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import Data.Ratio ((%)) import Data.Set (Set) -import Data.Time.Clock (DiffTime,picosecondsToDiffTime) +import qualified Data.Set as Set +import Data.Time.Clock (DiffTime) import Data.Word (Word16) import Foreign ((.|.)) -import Foreign.C (CInt(..),CUInt(..),CUShort(..)) +import Foreign.C (CUInt) import Foreign.C.Error (Errno(Errno),errnoToIOError) -import Safe (initSafe,tailSafe) import System.Posix.ByteString (Fd,RawFilePath) import System.Posix.IO.ByteString (fdToHandle) import qualified Evdev.LowLevel as LL -import Evdev.LowLevel (ReadFlag(..)) import Evdev.Codes -- 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 } instance Show Device where show = show . devicePath -data Event = Event { - evType :: EventType, - evCode :: EventCode, - evValue :: EventValue, - evTime :: DiffTime} +-- | An input event, including the timestamp. +data Event = Event + { eventData :: EventData + , eventTime :: 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 -> unwords [show k, show t] - RelativeEvent c v -> unwords [show c, showE v] - AbsoluteEvent c v -> unwords [show c, showE v] - MiscEvent c v -> unwords [show c, showE v] - SwitchEvent c v -> unwords [show c, showE v] - LEDEvent c v -> unwords [show c, showE v] - SoundEvent c v -> unwords [show c, showE v] - RepeatEvent c v -> unwords [show c, showE v] - ForceFeedbackEvent c v -> unwords [showE c, showE v] - PowerEvent c v -> unwords [showE c, showE v] - ForceFeedbackStatusEvent c v -> unwords [showE c, showE v] - _ -> error $ "show: unrecognised Event: " ++ unwords - [showE $ evType x, showE $ evCode x, showE $ evValue x] - where - showE :: Enum x => x -> String - showE = show . fromEnum - showTime t = -- fix time string to always have same length after '.', by adding 0s - let (n,r) = second tailSafe $ span (/= '.') $ initSafe $ show t - in n ++ "." ++ take 6 (r ++ ['0'..]) ++ "s" - -pattern SyncEvent :: SyncEventType -> Event -pattern SyncEvent c <- Event EvSyn (convertEnum -> c) _ _ - -pattern KeyEvent :: Key -> KeyEventType -> Event -pattern KeyEvent c v <- Event EvKey (convertEnum -> c) (convertEnum -> v) _ - -pattern RelativeEvent :: RelativeAxis -> EventValue -> Event -pattern RelativeEvent c v <- Event EvRel (convertEnum -> c) v _ - -pattern AbsoluteEvent :: AbsoluteAxis -> EventValue -> Event -pattern AbsoluteEvent c v <- Event EvAbs (convertEnum -> c) v _ - -pattern MiscEvent :: MiscEventType -> EventValue -> Event -pattern MiscEvent c v <- Event EvMsc (convertEnum -> c) v _ - -pattern SwitchEvent :: SwitchEventType -> EventValue -> Event -pattern SwitchEvent c v <- Event EvSw (convertEnum -> c) v _ - -pattern LEDEvent :: LEDEventType -> EventValue -> Event -pattern LEDEvent c v <- Event EvLed (convertEnum -> c) v _ - -pattern SoundEvent :: SoundEventType -> EventValue -> Event -pattern SoundEvent c v <- Event EvSnd (convertEnum -> c) v _ - -pattern RepeatEvent :: RepeatEventType -> EventValue -> Event -pattern RepeatEvent c v <- Event EvRep (convertEnum -> 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 _ +--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 + = SyncEvent SyncEvent + | KeyEvent Key KeyEvent + | RelativeEvent RelativeAxis EventValue + | AbsoluteEvent AbsoluteAxis EventValue + | MiscEvent MiscEvent EventValue + | SwitchEvent SwitchEvent EventValue + | LEDEvent LEDEvent EventValue + | SoundEvent SoundEvent EventValue + | RepeatEvent RepeatEvent EventValue + | ForceFeedbackEvent EventCode EventValue + | PowerEvent EventCode EventValue + | ForceFeedbackStatusEvent EventCode EventValue + | 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) -newtype EventCode = EventCode Word16 deriving (Enum, Eq, Ord, Read, Show) -newtype EventValue = EventValue Int32 deriving (Enum, Eq, Ord, Read, 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? +-- | 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) -data KeyEventType +-- | The status of a key. +data KeyEvent = Released | Pressed | Repeated - deriving (Enum, Eq, Ord, Read, Show) + deriving (Bounded, Enum, Eq, Ord, Read, Show) -convertFlags :: Set ReadFlag -> CUInt +convertFlags :: Set LL.ReadFlag -> CUInt convertFlags = fromIntegral . foldr ((.|.) . fromEnum) 0 -defaultReadFlags :: Set ReadFlag -defaultReadFlags = [Normal,Blocking] +defaultReadFlags :: Set LL.ReadFlag +defaultReadFlags = Set.fromList [LL.Normal, LL.Blocking] +-- | Prevent other clients (including kernel-internal ones) from receiving events. Often a bad idea. grabDevice :: Device -> IO () grabDevice = grabDevice' LL.LibevdevGrab +-- | Release a grabbed device. ungrabDevice :: Device -> IO () ungrabDevice = grabDevice' LL.LibevdevUngrab -nextEvent :: Device -> Set ReadFlag -> IO Event -nextEvent dev flags = do - (CUShort t, CUShort c, CInt v, s, us) <- - throwCErrors "nextEvent" (Right dev) $ LL.nextEvent (cDevice dev) (convertFlags flags) - return $ Event (convertEnum t) (EventCode c) (EventValue v) $ - picosecondsToDiffTime $ 1_000_000_000_000 * fromIntegral s + 1_000_000 * fromIntegral us +-- | 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 :: 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 + +toCEvent :: Event -> LL.CEvent +toCEvent (Event e time) = case e of + -- 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 + +fromCTimeVal :: LL.CTimeVal -> DiffTime +fromCTimeVal (LL.CTimeVal s us) = + fromRational $ fromIntegral s + (fromIntegral us % 1_000_000) + +--TODO QuickCheck inverse +toCTimeVal :: DiffTime -> LL.CTimeVal +toCTimeVal t = LL.CTimeVal n (round $ f * 1_000_000) + where (n,f) = properFraction t + +-- | 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 +-- | The usual directory containing devices (/"\/dev\/input"/). evdevDir :: RawFilePath evdevDir = "/dev/input" @@ -187,15 +215,25 @@ grabDevice' :: LL.GrabMode -> Device -> IO () grabDevice' mode dev = throwCErrors "grabDevice" (Right dev) $ LL.grabDevice (cDevice dev) mode ---TODO ensure all uses are safe - -- really, fromEnum should be :: e -> Integer - -- and toEnum :: Integral a => a -> Maybe e - -- the issues with Enum are great enough that it may be worth considering using something more bespoke than c2hs - -- or it could be worth a PR - -- auto-generate safe *toInt/*fromInt based on the current logic - -- then implement Enum instance in terms of those - -- note that we also use to/from-Enum in LowLevel --- obviously this isn't safe in general --- we use it only after matching on 'EventType', to get the corresponding 'EventCode' and 'EventValue' -convertEnum :: (Enum a, Enum b) => a -> b -convertEnum = toEnum . fromEnum + +{- +TODO this is a workaround until c2hs has a better story for enum conversions + when we remove it we can get rid of '-fno-state-hack' + +based on profiling, and Debug.Trace, it seems that 'enumMap' is computed no more times than necessary + (6 - number of combinations of a and k that it is called with) + but based on https://www.reddit.com/r/haskell/comments/grskne/help_reasoning_about_performance_memoization/, + it's possible that behaviour is worse without profiling on (argh...) + +open c2hs issue + we perhaps essentially want the `CEnum` class proposed at: https://github.com/haskell/c2hs/issues/78 + but perhaps belonging (at least initially) in c2hs rather than base, for expediency + 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' = (enumMap !?) + where + --TODO HashMap, IntMap? + enumMap :: Map k a + enumMap = Map.fromList $ map (fromIntegral . fromEnum &&& id) enumerate diff --git a/src/Evdev/Codes.chs b/src/Evdev/Codes.chs --- a/src/Evdev/Codes.chs +++ b/src/Evdev/Codes.chs @@ -1,17 +1,19 @@ +{- +TODO haddock doesn't quite work correctly with LINE pragmas + https://github.com/haskell/haddock/issues/441 + for now we can work around this by deleting the pragmas before upload to hackage + +seems to be on its way to being fixed with `.hie` files (enable `-fwrite-ide-info`) + https://github.com/haskell/haddock/commit/8bc3c2990475a254e168fbdb005af93f9397b19c +-} + +-- | Datatypes corresponding to the constants in [input-event-codes.h](https://github.com/torvalds/linux/blob/master/include/uapi/linux/input-event-codes.h). +-- See [the Linux Kernel documentation](https://www.kernel.org/doc/html/latest/input/event-codes.html) for full details, noting that all names have been mechanically transformed into CamelCase. module Evdev.Codes where #include -{#enum define DeviceProperty { - INPUT_PROP_POINTER as InputPropPointer, - INPUT_PROP_DIRECT as InputPropDirect, - INPUT_PROP_BUTTONPAD as InputPropButtonpad, - INPUT_PROP_SEMI_MT as InputPropSemiMt, - INPUT_PROP_TOPBUTTONPAD as InputPropTopbuttonpad, - INPUT_PROP_POINTING_STICK as InputPropPointingStick, - INPUT_PROP_ACCELEROMETER as InputPropAccelerometer} - deriving (Bounded, Eq, Ord, Read, Show) #} - +-- | Each of these corresponds to one of the contructors of 'Evdev.EventData'. So you're unlikely to need to use these directly (C doesn't have ADTs - we do). {#enum define EventType { EV_SYN as EvSyn, EV_KEY as EvKey, @@ -27,13 +29,15 @@ EV_FF_STATUS as EvFfStatus} deriving (Bounded, Eq, Ord, Read, Show) #} -{#enum define SyncEventType { - SYN_REPORT as SynReport, +-- | Synchronization events +{#enum define SyncEvent { + SYN_REPORT as SynReport, -- | Used to separate packets of simultaneous events SYN_CONFIG as SynConfig, SYN_MT_REPORT as SynMtReport, - SYN_DROPPED as SynDropped} + SYN_DROPPED as SynDropped} --TODO handle SYN_DROPPED automatically for streams deriving (Bounded, Eq, Ord, Read, Show) #} +-- | Keys and buttons {#enum define Key { KEY_RESERVED as KeyReserved, KEY_ESC as KeyEsc, @@ -577,6 +581,7 @@ BTN_TRIGGER_HAPPY40 as BtnTriggerHappy40} deriving (Bounded, Eq, Ord, Read, Show) #} +-- | Relative changes {#enum define RelativeAxis { REL_X as RelX, REL_Y as RelY, @@ -590,6 +595,7 @@ REL_MISC as RelMisc} deriving (Bounded, Eq, Ord, Read, Show) #} +-- | Absolute changes {#enum define AbsoluteAxis { ABS_X as AbsX, ABS_Y as AbsY, @@ -635,7 +641,8 @@ ABS_MT_TOOL_Y as AbsMtToolY} deriving (Bounded, Eq, Ord, Read, Show) #} -{#enum define SwitchEventType { +-- | Stateful binary switches +{#enum define SwitchEvent { SW_LID as SwLid, SW_TABLET_MODE as SwTabletMode, SW_HEADPHONE_INSERT as SwHeadphoneInsert, @@ -654,7 +661,8 @@ SW_MUTE_DEVICE as SwMuteDevice} deriving (Bounded, Eq, Ord, Read, Show) #} -{#enum define MiscEventType { +-- | Miscellaneous +{#enum define MiscEvent { MSC_SERIAL as MscSerial, MSC_PULSELED as MscPulseled, MSC_GESTURE as MscGesture, @@ -663,7 +671,8 @@ MSC_TIMESTAMP as MscTimestamp} deriving (Bounded, Eq, Ord, Read, Show) #} -{#enum define LEDEventType { +-- | LEDs +{#enum define LEDEvent { LED_NUML as LedNuml, LED_CAPSL as LedCapsl, LED_SCROLLL as LedScrolll, @@ -677,13 +686,26 @@ LED_CHARGING as LedCharging} deriving (Bounded, Eq, Ord, Read, Show) #} -{#enum define RepeatEventType { +-- | Specifying autorepeating events +{#enum define RepeatEvent { REP_DELAY as RepDelay, REP_PERIOD as RepPeriod} deriving (Bounded, Eq, Ord, Read, Show) #} -{#enum define SoundEventType { +-- | For simple sound output devices +{#enum define SoundEvent { SND_CLICK as SndClick, SND_BELL as SndBell, SND_TONE as SndTone} + deriving (Bounded, Eq, Ord, Read, Show) #} + +-- | Device properties +{#enum define DeviceProperty { + INPUT_PROP_POINTER as InputPropPointer, + INPUT_PROP_DIRECT as InputPropDirect, + INPUT_PROP_BUTTONPAD as InputPropButtonpad, + INPUT_PROP_SEMI_MT as InputPropSemiMt, + INPUT_PROP_TOPBUTTONPAD as InputPropTopbuttonpad, + INPUT_PROP_POINTING_STICK as InputPropPointingStick, + INPUT_PROP_ACCELEROMETER as InputPropAccelerometer} deriving (Bounded, Eq, Ord, Read, Show) #} diff --git a/src/Evdev/LowLevel.chs b/src/Evdev/LowLevel.chs --- a/src/Evdev/LowLevel.chs +++ b/src/Evdev/LowLevel.chs @@ -2,8 +2,11 @@ import Control.Monad.Loops (iterateWhile) import Data.ByteString (ByteString,packCString) +import Data.Coerce (coerce) +import Data.Int (Int32,Int64) +import Data.Word (Word16) import Foreign (Ptr,allocaBytes) -import Foreign.C (CInt(..),CUInt(..),CUShort(..),CLong) +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) @@ -32,20 +35,35 @@ void libevdev_hs_close(struct libevdev *dev); #endc +data CEvent = CEvent + { cEventType :: Word16 + , cEventCode :: Word16 + , cEventValue :: Int32 + , cEventTime :: CTimeVal + } + deriving (Eq, Ord, Read, Show) +data CTimeVal = CTimeVal + { tvSec :: Int64 + , tvUsec :: Int64 + } + deriving (Eq, Ord, Read, Show) + + {- Conversions -} {#fun libevdev_next_event { `Device', `CUInt', `Ptr ()' } -> `Errno' Errno #} -nextEvent :: Device -> CUInt -> IO (Errno, (CUShort,CUShort,CInt,CLong,CLong)) --TODO not CLong on all platforms +nextEvent :: Device -> CUInt -> IO (Errno, CEvent) nextEvent dev flags = allocaBytes {#sizeof input_event #} $ \evPtr -> (,) <$> iterateWhile (== Errno (-{#const EAGAIN #})) (libevdev_next_event dev flags evPtr) - <*> ( - (,,,,) - <$> {#get input_event->type #} evPtr - <*> {#get input_event->code #} evPtr - <*> {#get input_event->value #} evPtr - <*> {#get input_event->time.tv_sec #} evPtr - <*> {#get input_event->time.tv_usec #} 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 #} @@ -65,14 +83,15 @@ {- Simpler functions -} -{#fun libevdev_has_property as hasProperty { `Device', convertEnum `DeviceProperty' } -> `Bool' #} +{#fun libevdev_has_property as hasProperty { `Device', devPropToInt `DeviceProperty' } -> `Bool' #} {#fun libevdev_get_fd as deviceFd { `Device' } -> `Fd' Fd #} {#fun libevdev_get_name as deviceName { `Device' } -> `IO ByteString' packCString #} + {- Util -} -convertEnum :: DeviceProperty -> CUInt -convertEnum = fromIntegral . fromEnum +devPropToInt :: DeviceProperty -> CUInt +devPropToInt = fromIntegral . fromEnum (.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d (.:) = (.) . (.) diff --git a/src/Evdev/Stream.hs b/src/Evdev/Stream.hs deleted file mode 100644 --- a/src/Evdev/Stream.hs +++ /dev/null @@ -1,127 +0,0 @@ --- | The high-level, stream-based API. --- Unless stated otherwise, these functions will throw exceptions if the underlying C calls fail. -module Evdev.Stream ( - allDevices, - allEvents, - makeDevices, - newDevices, - readEvents, - readEventsMany, -) where - -import Data.Bool -import Data.Either.Extra -import Data.Functor -import System.IO -import System.IO.Error - -import Data.Set (Set) -import qualified Data.Set as Set -import qualified Data.ByteString.Char8 as BS -import RawFilePath.Directory (doesFileExist,listDirectory) -import qualified Streamly.FSNotify as N -import Streamly.FSNotify (EventPredicate(EventPredicate),FSEntryType(NotDir),watchDirectory) -import System.Path (Absolute,Path,fromFilePath,toFilePath) -import System.Posix.ByteString (RawFilePath) -import System.Posix.FilePath (()) - -import Streamly -import qualified Streamly.Prelude as S - -import Evdev - - --- | Read all events from a device. -readEvents :: Device -> SerialT IO Event -readEvents dev = S.repeatM $ nextEvent dev defaultReadFlags - --- | Concurrently read events from multiple devices. --- If a read fails on one, the exception is printed to stderr and the stream continues to read from the others. -readEventsMany :: IsStream t => AsyncT IO Device -> t IO (Device, Event) -readEventsMany ds = asyncly $ do - d <- ds - S.map (d,) $ serially $ readEvents' d - where - -- catch all IO errors - readEvents' :: Device -> SerialT IO Event - readEvents' dev = unfoldM $ printIOError' $ nextEvent dev defaultReadFlags - --- | Create devices for all paths in the stream. -makeDevices :: IsStream t => t IO RawFilePath -> t IO Device -makeDevices = S.mapM newDevice - --- | All events on all valid devices (in /\/dev\/input/). --- Prints any exceptions. --- --- > allEvents == readEventsMany allDevices -allEvents :: IsStream t => t IO (Device, Event) -allEvents = readEventsMany allDevices - ---TODO call this 'oldDevices' or 'existingDevices', and have 'allDevices' include 'newDevices'? --- | All valid existing devices (in /\/dev\/input/). --- If a device can't be initialised for an individual path, then the exception is printed, --- and the function continues to try to initialise the others. -allDevices :: (IsStream t, Monad (t IO)) => t IO Device -allDevices = - let paths = S.filterM doesFileExist $ S.map (evdevDir ) $ S.fromFoldable =<< S.yieldM (listDirectory evdevDir) - in S.mapMaybeM (printIOError' . newDevice) paths - --- | All new devices created (in /\/dev\/input/). --- Watches for new file paths (using \inotify\), and those corresponding to valid devices are added to the stream. -newDevices :: (IsStream t, Monad (t IO)) => t IO Device -newDevices = - let -- 'watching' keeps track of the set of paths which have been added, but don't yet have the right permissions - watch :: Set (Path Absolute) -> N.Event -> IO (Maybe Device, Set (Path Absolute)) - watch watching = \case - N.Added p _ NotDir -> - tryNewDevice p <&> \case - Right d -> -- success - return new device - (Just d, watching) - Left e -> -- fail - if it's only a permission error then watch for changes on device - (Nothing, applyWhen (isPermissionError e) (Set.insert p) watching) - N.Modified p _ NotDir -> - if p `elem` watching then - tryNewDevice p <&> \case - Right d -> -- success - no longer watch for changes - (Just d, Set.delete p watching) - Left _ -> -- fail - continue to watch - (Nothing, watching) - else -- this isn't an event we care about - return (Nothing, watching) - N.Removed p _ NotDir -> -- device is gone - no longer watch for changes - return (Nothing, Set.delete p watching) - _ -> return (Nothing, watching) - tryNewDevice = printIOError . newDevice . BS.pack . toFilePath - in do - (_,es) <- S.yieldM $ watchDirectory (fromFilePath $ BS.unpack evdevDir) (EventPredicate $ const True) - scanMaybe watch [] es - - -{- Util -} - --- specialized form of S.scanlM' --- for each a, f updates s, and possibly produces a new b, to add to the output stream --- I really can't think of a good name for this... --- TODO perhaps some way to use State monad instead? -scanMaybe :: (IsStream t, Monad m) => (s -> a -> m (Maybe b, s)) -> s -> t m a -> t m b -scanMaybe f e = S.mapMaybe fst . S.scanlM' (f . snd) (Nothing, e) - --- specialised form of S.unfoldrM --- this should perhaps be in streamly (it's in monad-loops) ---TODO this is rather ugly - can it be done in terms of the Unfold type? -unfoldM :: (IsStream t, MonadAsync m) => m (Maybe a) -> t m a -unfoldM x = S.unfoldrM (const $ fmap (,undefined) <$> x) undefined - --- like tryIOError, but also prints the error to stderr -printIOError :: IO a -> IO (Either IOError a) -printIOError f = (Right <$> f) `catchIOError` \err -> do - hPrint stderr err - return $ Left err - --- variant of printIOError which doesn't care what the exception was -printIOError' :: IO a -> IO (Maybe a) -printIOError' = fmap eitherToMaybe . printIOError - --- apply the function iff the guard passes -applyWhen :: Bool -> (a -> a) -> a -> a -applyWhen = flip $ bool id