evdev 1.1.0.1 → 1.2.0.0

raw patch · 3 files changed

+89/−9 lines, 3 filesdep +pathsdep +streamly-fsnotifyPVP ok

version bump matches the API change (PVP)

Dependencies added: paths, streamly-fsnotify

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• evdev.cabal +3/−1
• src/Evdev/Stream.hs +81/−8

@@ -15,3 +15,8 @@ ## 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,6 +1,6 @@ cabal-version:       2.2 name:                evdev-version:             1.1.0.1+version:             1.2.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.@@ -37,6 +37,8 @@                        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

@@ -2,15 +2,24 @@     allDevices,     allEvents,     makeDevices,+    newDevices,     readEvents,     readEventsMany,-    ) where+) where -import Control.Exception-import Control.Monad+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 ((</>)) @@ -25,10 +34,15 @@ 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+    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. -- | Will throw an exception if a path doesn't correspond to a valid input device.@@ -39,9 +53,68 @@ allEvents :: IsStream t => t IO (Device, Event) allEvents = readEventsMany allDevices --- | All valid devices (in /dev/input).+-- | All valid existing devices (in /dev/input). allDevices :: (IsStream t, Monad (t IO)) => t IO Device allDevices =-    let maybeNewDevice path = catchJust (guard . isIllegalOperation) (Just <$> newDevice path) (\() -> return Nothing)-        paths = S.filterM doesFileExist $ S.map (evdevDir </>) $ S.fromFoldable =<< S.yieldM (listDirectory evdevDir)-    in  S.mapMaybeM maybeNewDevice paths+    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