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
readEvents :: Device -> SerialT IO Event
readEvents dev = S.repeatM $ nextEvent dev defaultReadFlags
readEventsMany :: IsStream t => AsyncT IO Device -> t IO (Device, Event)
readEventsMany ds = asyncly $ do
d <- ds
S.map (d,) $ serially $ readEvents' d
where
readEvents' :: Device -> SerialT IO Event
readEvents' dev = unfoldM $ printIOError' $ nextEvent dev defaultReadFlags
makeDevices :: IsStream t => t IO RawFilePath -> t IO Device
makeDevices = S.mapM newDevice
allEvents :: IsStream t => t IO (Device, Event)
allEvents = readEventsMany allDevices
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
newDevices :: (IsStream t, Monad (t IO)) => t IO Device
newDevices =
let
watch :: Set (Path Absolute) -> N.Event -> IO (Maybe Device, Set (Path Absolute))
watch watching = \case
N.Added p _ NotDir ->
tryNewDevice p <&> \case
Right d ->
(Just d, watching)
Left e ->
(Nothing, applyWhen (isPermissionError e) (Set.insert p) watching)
N.Modified p _ NotDir ->
if p `elem` watching then
tryNewDevice p <&> \case
Right d ->
(Just d, Set.delete p watching)
Left _ ->
(Nothing, watching)
else
return (Nothing, watching)
N.Removed p _ NotDir ->
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
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)
unfoldM :: (IsStream t, MonadAsync m) => m (Maybe a) -> t m a
unfoldM x = S.unfoldrM (const $ fmap (,undefined) <$> x) undefined
printIOError :: IO a -> IO (Either IOError a)
printIOError f = (Right <$> f) `catchIOError` \err -> do
hPrint stderr err
return $ Left err
printIOError' :: IO a -> IO (Maybe a)
printIOError' = fmap eitherToMaybe . printIOError
applyWhen :: Bool -> (a -> a) -> a -> a
applyWhen = flip $ bool id