diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for evdev-streamly + +## 0.1.0.0 -- 2020-05-30 + +* Split out from `evdev` package. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2019, George Thomas + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of George Thomas nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,14 @@ +Evdev + Streamly +================ + +This library provides provides a high level [Streamly](https://hackage.haskell.org/package/streamly)-based interface to [evdev](http://hackage.haskell.org/package/evdev), for working with streams of input events. + +It doesn't re-export anything, so you will almost certainly also need to depend directly on both of those packages. + +Many of the functions in this library make use of concurrency, so you will probably want `--ghc-options=-threaded` for any executables you build, in order to enable the threaded runtime, and get the expected behaviour. This should be on by default in a near-future version of GHC. + +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. diff --git a/evdev-streamly.cabal b/evdev-streamly.cabal new file mode 100644 --- /dev/null +++ b/evdev-streamly.cabal @@ -0,0 +1,49 @@ +cabal-version: 3.0 +name: evdev-streamly +version: 0.0.1.0 +author: George Thomas +maintainer: George Thomas +synopsis: Bridge for working with evdev and streamly +description: + Functions for working with streams of input events. + Often much more pleasant than working in a more imperative style. +homepage: https://github.com/georgefst/evdev +license: BSD-3-Clause +license-file: LICENSE +category: Streamly, System +extra-source-files: + CHANGELOG.md + README.md + +source-repository head + type: git + location: git://github.com/georgefst/evdev.git + +library + exposed-modules: + Evdev.Stream + hs-source-dirs: src + ghc-options: + -Wall + build-depends: + base >= 4.11 && < 5, + bytestring ^>= 0.10, + containers ^>= 0.6.2, + evdev ^>= 2.0, + extra ^>= {1.6.18, 1.7}, + posix-paths ^>= 0.2.1, + rawfilepath ^>= 0.2.4, + streamly ^>= {0.6.1, 0.7}, + streamly-fsnotify ^>= 1.1.1, + unix ^>= 2.7.2, + default-language: Haskell2010 + default-extensions: + DerivingStrategies + FlexibleContexts + GeneralizedNewtypeDeriving + LambdaCase + NumericUnderscores + OverloadedStrings + ScopedTypeVariables + TupleSections + ViewPatterns diff --git a/src/Evdev/Stream.hs b/src/Evdev/Stream.hs new file mode 100644 --- /dev/null +++ b/src/Evdev/Stream.hs @@ -0,0 +1,127 @@ +-- | Functions for working with streams of input events. +-- 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 (RawFilePath,doesFileExist,listDirectory) +import qualified Streamly.FSNotify as N +import Streamly.FSNotify (FSEntryType(NotDir),watchDirectory) +import System.Posix.FilePath (()) + +import Streamly +import qualified Streamly.Prelude as S + +import Evdev + +--TODO provide a 'group' operation on streams, representing packets as sets + +-- | Read all events from a device. +readEvents :: Device -> SerialT IO Event +readEvents = S.repeatM . nextEvent + +-- | 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' = unfoldM . printIOError' . nextEvent + readEvents' :: Device -> SerialT IO Event + +-- | 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 + +--TODO perhaps streamly-fsnotify ought to use RawFilePath? +-- | 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 RawFilePath -> N.Event -> IO (Maybe Device, Set RawFilePath) + watch watching = \case + N.Added (BS.pack -> 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 (BS.pack -> 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 (BS.pack -> p) _ NotDir -> -- device is gone - no longer watch for changes + return (Nothing, Set.delete p watching) + _ -> return (Nothing, watching) + tryNewDevice = printIOError . newDevice + in do + (_,es) <- S.yieldM $ watchDirectory (BS.unpack evdevDir) N.everything + scanMaybe watch Set.empty 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