diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,7 +3,3 @@ ## 0.1.0.0 -- 2019-07-20 * First version. Released on an unsuspecting world. - -## 0.1.0.1 -- 2019-10-06 - -* Documentation update only. diff --git a/evdev.cabal b/evdev.cabal --- a/evdev.cabal +++ b/evdev.cabal @@ -1,9 +1,9 @@ cabal-version: 2.4 name: evdev -version: 0.1.0.1 +version: 0.2.0.0 author: George Thomas maintainer: George Thomas -description: Allows use of the linux event device interface, with an optional high-level Streamly API. +description: Provides access to the Linux event device interface, with an optional high-level Streamly-based API. synopsis: Bindings to libevdev homepage: https://github.com/georgefst/evdev license: BSD-3-Clause @@ -22,19 +22,20 @@ Evdev.Stream hs-source-dirs: src ghc-options: -Wall - build-depends: base >= 4.13.0 && < 4.14, - bytestring >= 0.10.9 && < 0.11, - composition >= 1.0.2 && < 1.1, - containers >= 0.6.2 && < 0.7, - either >= 5.0.1 && < 5.1, - time >= 1.9.3 && < 1.10, - unix >= 2.7.2 && < 2.8, - process >= 1.6.5 && < 1.7, - extra >= 1.6.18 && < 1.7, - hinotify >= 0.4 && < 0.5, - posix-paths >= 0.2.1 && < 0.3, - rawfilepath >= 0.2.4 && < 0.3, - streamly >= 0.6.1 && < 0.7, + build-depends: base ^>= 4.12.0 || ^>= 4.13, + bytestring ^>= 0.10, + composition ^>= 1.0, + 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, build-tool-depends: c2hs:c2hs default-language: Haskell2010 default-extensions: FlexibleContexts diff --git a/src/Evdev.hs b/src/Evdev.hs --- a/src/Evdev.hs +++ b/src/Evdev.hs @@ -1,4 +1,32 @@ -module Evdev where +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, + newDevice, + maybeNewDevice, + evdevDir, + getDeviceName, + Device (devicePath), + Event, + EventCode(..), + EventValue(..), + KeyEventType(..), + ReadFlags (..), +) where import Control.Exception import Data.Int @@ -6,6 +34,7 @@ import Data.Either.Combinators import Data.Time.Clock import Data.Tuple.Extra +import Safe import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as BS @@ -16,7 +45,8 @@ import System.Posix.ByteString (RawFilePath) import qualified Evdev.LowLevel as LL -import Evdev.Codes --TODO combine modules? +import Evdev.LowLevel (ReadFlags(..)) +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. @@ -35,24 +65,24 @@ prettyEvent :: Event -> String prettyEvent x = showTime (evTime x) ++ ":" ++ " " ++ case x of SyncEvent t -> show t - KeyEvent k t -> intercalate " " [show k, show t] - RelativeEvent c v -> intercalate " " [show c, showE v] - AbsoluteEvent c v -> intercalate " " [show c, showE v] - MiscEvent c v -> intercalate " " [show c, showE v] - SwitchEvent c v -> intercalate " " [show c, showE v] - LEDEvent c v -> intercalate " " [show c, showE v] - SoundEvent c v -> intercalate " " [show c, showE v] - RepeatEvent c v -> intercalate " " [show c, showE v] - ForceFeedbackEvent c v -> intercalate " " [showE c, showE v] - PowerEvent c v -> intercalate " " [showE c, showE v] - ForceFeedbackStatusEvent c v -> intercalate " " [showE c, showE v] - _ -> error $ "show: unrecognised Event: " ++ intercalate " " + 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 e => e -> String + 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 tail $ span (/= '.') $ init $ show t + let (n,r) = second tailSafe $ span (/= '.') $ initSafe $ show t in n ++ "." ++ take 6 (r ++ ['0'..]) ++ "s" pattern SyncEvent :: SyncEventType -> Event @@ -100,18 +130,18 @@ | Repeated deriving (Enum, Eq, Ord, Read, Show) -convertFlags :: Set LL.ReadFlags -> CUInt +convertFlags :: Set ReadFlags -> CUInt convertFlags = fromIntegral . foldr ((.|.) . fromEnum) 0 -defaultReadFlags :: Set LL.ReadFlags -defaultReadFlags = [LL.Normal,LL.Blocking] +defaultReadFlags :: Set ReadFlags +defaultReadFlags = [Normal,Blocking] grabDevice :: Device -> IO () grabDevice = grabDevice' LL.LibevdevGrab ungrabDevice :: Device -> IO () ungrabDevice = grabDevice' LL.LibevdevUngrab -nextEvent :: Device -> Set LL.ReadFlags -> IO Event +nextEvent :: Device -> Set ReadFlags -> IO Event nextEvent dev flags = do (t,c,v,time) <- LL.convertEvent =<< throwCErrors "nextEvent" (devicePath dev) (LL.nextEvent (cDevice dev) (convertFlags flags)) @@ -131,11 +161,11 @@ getDeviceName :: Device -> IO ByteString getDeviceName = fmap BS.pack . LL.deviceName . cDevice -tryIO :: IO a -> IO (Either IOException a) -tryIO = try - {- Util -} + +tryIO :: IO a -> IO (Either IOException a) +tryIO = try -- run the action, throwing an error if the C errno is not 0 throwCErrors :: String -> RawFilePath -> IO (Errno, a) -> IO a diff --git a/src/Evdev/Stream.hs b/src/Evdev/Stream.hs --- a/src/Evdev/Stream.hs +++ b/src/Evdev/Stream.hs @@ -1,67 +1,50 @@ -module Evdev.Stream where +module Evdev.Stream ( + allDevicePaths, + allEvents, + filteredEvents, + makeDevices, + readEvents, + readEventsMany, + ) where -import Control.Concurrent -import Control.Exception.Extra import Control.Monad -import Control.Monad.IO.Class -import Data.Either.Combinators -import GHC.IO.Exception (IOErrorType(PermissionDenied),ioe_type) import RawFilePath.Directory (doesFileExist,listDirectory) -import System.INotify (addWatch,initINotify) -import qualified System.INotify as I import System.Posix.ByteString (RawFilePath) -import System.Posix.FilePath ((),combine) +import System.Posix.FilePath (()) import Streamly import qualified Streamly.Prelude as S import Evdev -allEvents :: IsStream t => t IO (Device, Event) + +allEvents :: (IsStream t, Monad (t IO)) => t IO (Device, Event) allEvents = filteredEvents $ const True -filteredEvents :: IsStream t => (Device -> Bool) -> t IO (Device, Event) -filteredEvents p = readEventsMany $ S.filter p $ makeDevices $ existingDevicePaths <> newDevicePaths +filteredEvents :: (IsStream t, Monad (t IO)) => (Device -> Bool) -> t IO (Device, Event) +filteredEvents p = readEventsMany $ S.filter p $ makeDevices allDevicePaths --- reads until encountering an IOException readEvents :: IsStream t => Device -> t IO Event -readEvents dev = serially $ unfoldrM' $ fmap rightToMaybe $ tryIO $ nextEvent dev defaultReadFlags +readEvents dev = S.repeatM $ nextEvent dev defaultReadFlags readEventsMany :: IsStream t => AsyncT IO Device -> t IO (Device, Event) -readEventsMany = asyncly . join . (S.map $ \d -> (S.map (d,) $ readEvents d)) +readEventsMany ds = asyncly $ do + d <- ds + S.map (d,) $ readEvents d -makeDevices :: (Functor (t IO), IsStream t) => t IO RawFilePath -> t IO Device +makeDevices :: (IsStream t, Functor (t IO)) => t IO RawFilePath -> t IO Device makeDevices = S.mapMaybeM maybeNewDevice -existingDevicePaths :: (IsStream t, MonadIO (t IO)) => t IO RawFilePath -existingDevicePaths = S.fromFoldable =<< S.yieldM (lsFiles evdevDir) - -newDevicePaths :: (MonadIO (t IO), IsStream t) => t IO RawFilePath -newDevicePaths = - let watcher mvar = \case - I.Created False path -> do -- file (not directory) created - let fullPath = evdevDir path - handleBoolRetry ((== PermissionDenied) . ioe_type) 100 $ putMVar mvar fullPath - _ -> return () - in do - mvar <- liftIO newEmptyMVar - iNot <- liftIO initINotify - _ <- liftIO $ addWatch iNot [I.Create] evdevDir (watcher mvar) - serially $ S.repeatM $ takeMVar mvar - - --- retry the action after encountering an exception satisfying p -handleBoolRetry :: Exception e => (e -> Bool) -> Int -> IO a -> IO a -handleBoolRetry p t x = handleBool p (const $ threadDelay t >> handleBoolRetry p t x) x +--TODO use Streamly directly +allDevicePaths :: (IsStream t, Monad (t IO)) => t IO RawFilePath +allDevicePaths = do + fs <- S.yieldM $ lsFiles evdevDir + S.fromFoldable fs {- Util -} --- a specialization of S.unfoldrM which doesn't make use of any value from the previous round -unfoldrM' :: (IsStream t, MonadAsync m) => m (Maybe a) -> t m a -unfoldrM' x = S.unfoldrM (const $ fmap (,undefined) <$> x) undefined - -- lists files only, and returns full paths. lsFiles :: RawFilePath -> IO [RawFilePath] -lsFiles = filterM doesFileExist <=< ((fmap . map . combine) <*> listDirectory) +lsFiles p = filterM doesFileExist =<< (map (p ) <$> listDirectory p)