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
readEvents :: Device -> SerialT IO Event
readEvents :: Device -> SerialT IO Event
readEvents = IO Event -> SerialT IO Event
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(IsStream t, MonadAsync m) =>
m a -> t m a
S.repeatM (IO Event -> SerialT IO Event)
-> (Device -> IO Event) -> Device -> SerialT IO Event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Device -> IO Event
nextEvent
readEventsMany :: IsStream t => AsyncT IO Device -> t IO (Device, Event)
readEventsMany :: AsyncT IO Device -> t IO (Device, Event)
readEventsMany AsyncT IO Device
ds = AsyncT IO (Device, Event) -> t IO (Device, Event)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
IsStream t =>
AsyncT m a -> t m a
asyncly (AsyncT IO (Device, Event) -> t IO (Device, Event))
-> AsyncT IO (Device, Event) -> t IO (Device, Event)
forall a b. (a -> b) -> a -> b
$ do
Device
d <- AsyncT IO Device
ds
(Event -> (Device, Event))
-> AsyncT IO Event -> AsyncT IO (Device, Event)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
(IsStream t, Monad m) =>
(a -> b) -> t m a -> t m b
S.map (Device
d,) (AsyncT IO Event -> AsyncT IO (Device, Event))
-> AsyncT IO Event -> AsyncT IO (Device, Event)
forall a b. (a -> b) -> a -> b
$ SerialT IO Event -> AsyncT IO Event
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
IsStream t =>
SerialT m a -> t m a
serially (SerialT IO Event -> AsyncT IO Event)
-> SerialT IO Event -> AsyncT IO Event
forall a b. (a -> b) -> a -> b
$ Device -> SerialT IO Event
readEvents' Device
d
where
readEvents' :: Device -> SerialT IO Event
readEvents' = IO (Maybe Event) -> SerialT IO Event
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(IsStream t, MonadAsync m) =>
m (Maybe a) -> t m a
unfoldM (IO (Maybe Event) -> SerialT IO Event)
-> (Device -> IO (Maybe Event)) -> Device -> SerialT IO Event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO Event -> IO (Maybe Event)
forall a. IO a -> IO (Maybe a)
printIOError' (IO Event -> IO (Maybe Event))
-> (Device -> IO Event) -> Device -> IO (Maybe Event)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Device -> IO Event
nextEvent
readEvents' :: Device -> SerialT IO Event
makeDevices :: IsStream t => t IO RawFilePath -> t IO Device
makeDevices :: t IO RawFilePath -> t IO Device
makeDevices = (RawFilePath -> IO Device) -> t IO RawFilePath -> t IO Device
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
(IsStream t, MonadAsync m) =>
(a -> m b) -> t m a -> t m b
S.mapM RawFilePath -> IO Device
newDevice
allEvents :: IsStream t => t IO (Device, Event)
allEvents :: t IO (Device, Event)
allEvents = AsyncT IO Device -> t IO (Device, Event)
forall (t :: (* -> *) -> * -> *).
IsStream t =>
AsyncT IO Device -> t IO (Device, Event)
readEventsMany AsyncT IO Device
forall (t :: (* -> *) -> * -> *).
(IsStream t, Monad (t IO)) =>
t IO Device
allDevices
allDevices :: (IsStream t, Monad (t IO)) => t IO Device
allDevices :: t IO Device
allDevices =
let paths :: t IO RawFilePath
paths = (RawFilePath -> IO Bool) -> t IO RawFilePath -> t IO RawFilePath
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(IsStream t, Monad m) =>
(a -> m Bool) -> t m a -> t m a
S.filterM RawFilePath -> IO Bool
doesFileExist (t IO RawFilePath -> t IO RawFilePath)
-> t IO RawFilePath -> t IO RawFilePath
forall a b. (a -> b) -> a -> b
$ (RawFilePath -> RawFilePath)
-> t IO RawFilePath -> t IO RawFilePath
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
(IsStream t, Monad m) =>
(a -> b) -> t m a -> t m b
S.map (RawFilePath
evdevDir RawFilePath -> RawFilePath -> RawFilePath
</>) (t IO RawFilePath -> t IO RawFilePath)
-> t IO RawFilePath -> t IO RawFilePath
forall a b. (a -> b) -> a -> b
$ [RawFilePath] -> t IO RawFilePath
forall (t :: (* -> *) -> * -> *) (f :: * -> *) a (m :: * -> *).
(IsStream t, Foldable f) =>
f a -> t m a
S.fromFoldable ([RawFilePath] -> t IO RawFilePath)
-> t IO [RawFilePath] -> t IO RawFilePath
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [RawFilePath] -> t IO [RawFilePath]
forall (m :: * -> *) (t :: (* -> *) -> * -> *) a.
(Monad m, IsStream t) =>
m a -> t m a
S.yieldM (RawFilePath -> IO [RawFilePath]
listDirectory RawFilePath
evdevDir)
in (RawFilePath -> IO (Maybe Device))
-> t IO RawFilePath -> t IO Device
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
(IsStream t, MonadAsync m, Functor (t m)) =>
(a -> m (Maybe b)) -> t m a -> t m b
S.mapMaybeM (IO Device -> IO (Maybe Device)
forall a. IO a -> IO (Maybe a)
printIOError' (IO Device -> IO (Maybe Device))
-> (RawFilePath -> IO Device) -> RawFilePath -> IO (Maybe Device)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawFilePath -> IO Device
newDevice) t IO RawFilePath
paths
newDevices :: (IsStream t, Monad (t IO)) => t IO Device
newDevices :: t IO Device
newDevices =
let
watch :: Set RawFilePath -> N.Event -> IO (Maybe Device, Set RawFilePath)
watch :: Set RawFilePath -> Event -> IO (Maybe Device, Set RawFilePath)
watch Set RawFilePath
watching = \case
N.Added (FilePath -> RawFilePath
BS.pack -> RawFilePath
p) UTCTime
_ FSEntryType
NotDir ->
RawFilePath -> IO (Either IOError Device)
tryNewDevice RawFilePath
p IO (Either IOError Device)
-> (Either IOError Device -> (Maybe Device, Set RawFilePath))
-> IO (Maybe Device, Set RawFilePath)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
Right Device
d ->
(Device -> Maybe Device
forall a. a -> Maybe a
Just Device
d, Set RawFilePath
watching)
Left IOError
e ->
(Maybe Device
forall a. Maybe a
Nothing, Bool
-> (Set RawFilePath -> Set RawFilePath)
-> Set RawFilePath
-> Set RawFilePath
forall a. Bool -> (a -> a) -> a -> a
applyWhen (IOError -> Bool
isPermissionError IOError
e) (RawFilePath -> Set RawFilePath -> Set RawFilePath
forall a. Ord a => a -> Set a -> Set a
Set.insert RawFilePath
p) Set RawFilePath
watching)
N.Modified (FilePath -> RawFilePath
BS.pack -> RawFilePath
p) UTCTime
_ FSEntryType
NotDir ->
if RawFilePath
p RawFilePath -> Set RawFilePath -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Set RawFilePath
watching then
RawFilePath -> IO (Either IOError Device)
tryNewDevice RawFilePath
p IO (Either IOError Device)
-> (Either IOError Device -> (Maybe Device, Set RawFilePath))
-> IO (Maybe Device, Set RawFilePath)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
Right Device
d ->
(Device -> Maybe Device
forall a. a -> Maybe a
Just Device
d, RawFilePath -> Set RawFilePath -> Set RawFilePath
forall a. Ord a => a -> Set a -> Set a
Set.delete RawFilePath
p Set RawFilePath
watching)
Left IOError
_ ->
(Maybe Device
forall a. Maybe a
Nothing, Set RawFilePath
watching)
else
(Maybe Device, Set RawFilePath)
-> IO (Maybe Device, Set RawFilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Device
forall a. Maybe a
Nothing, Set RawFilePath
watching)
N.Removed (FilePath -> RawFilePath
BS.pack -> RawFilePath
p) UTCTime
_ FSEntryType
NotDir ->
(Maybe Device, Set RawFilePath)
-> IO (Maybe Device, Set RawFilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Device
forall a. Maybe a
Nothing, RawFilePath -> Set RawFilePath -> Set RawFilePath
forall a. Ord a => a -> Set a -> Set a
Set.delete RawFilePath
p Set RawFilePath
watching)
Event
_ -> (Maybe Device, Set RawFilePath)
-> IO (Maybe Device, Set RawFilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Device
forall a. Maybe a
Nothing, Set RawFilePath
watching)
tryNewDevice :: RawFilePath -> IO (Either IOError Device)
tryNewDevice = IO Device -> IO (Either IOError Device)
forall a. IO a -> IO (Either IOError a)
printIOError (IO Device -> IO (Either IOError Device))
-> (RawFilePath -> IO Device)
-> RawFilePath
-> IO (Either IOError Device)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawFilePath -> IO Device
newDevice
in do
(StopWatching IO
_,t IO Event
es) <- IO (StopWatching IO, t IO Event)
-> t IO (StopWatching IO, t IO Event)
forall (m :: * -> *) (t :: (* -> *) -> * -> *) a.
(Monad m, IsStream t) =>
m a -> t m a
S.yieldM (IO (StopWatching IO, t IO Event)
-> t IO (StopWatching IO, t IO Event))
-> IO (StopWatching IO, t IO Event)
-> t IO (StopWatching IO, t IO Event)
forall a b. (a -> b) -> a -> b
$ FilePath -> EventPredicate -> IO (StopWatching IO, t IO Event)
forall (t :: (* -> *) -> * -> *) (m :: * -> *).
(IsStream t, MonadAsync m) =>
FilePath -> EventPredicate -> m (StopWatching m, t m Event)
watchDirectory (RawFilePath -> FilePath
BS.unpack RawFilePath
evdevDir) EventPredicate
N.everything
(Set RawFilePath -> Event -> IO (Maybe Device, Set RawFilePath))
-> Set RawFilePath -> t IO Event -> t IO Device
forall (t :: (* -> *) -> * -> *) (m :: * -> *) s a b.
(IsStream t, Monad m) =>
(s -> a -> m (Maybe b, s)) -> s -> t m a -> t m b
scanMaybe Set RawFilePath -> Event -> IO (Maybe Device, Set RawFilePath)
watch Set RawFilePath
forall a. Set a
Set.empty t IO Event
es
scanMaybe :: (IsStream t, Monad m) => (s -> a -> m (Maybe b, s)) -> s -> t m a -> t m b
scanMaybe :: (s -> a -> m (Maybe b, s)) -> s -> t m a -> t m b
scanMaybe s -> a -> m (Maybe b, s)
f s
e = ((Maybe b, s) -> Maybe b) -> t m (Maybe b, s) -> t m b
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
(IsStream t, Monad m) =>
(a -> Maybe b) -> t m a -> t m b
S.mapMaybe (Maybe b, s) -> Maybe b
forall a b. (a, b) -> a
fst (t m (Maybe b, s) -> t m b)
-> (t m a -> t m (Maybe b, s)) -> t m a -> t m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Maybe b, s) -> a -> m (Maybe b, s))
-> (Maybe b, s) -> t m a -> t m (Maybe b, s)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) b a.
(IsStream t, Monad m) =>
(b -> a -> m b) -> b -> t m a -> t m b
S.scanlM' (s -> a -> m (Maybe b, s)
f (s -> a -> m (Maybe b, s))
-> ((Maybe b, s) -> s) -> (Maybe b, s) -> a -> m (Maybe b, s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe b, s) -> s
forall a b. (a, b) -> b
snd) (Maybe b
forall a. Maybe a
Nothing, s
e)
unfoldM :: (IsStream t, MonadAsync m) => m (Maybe a) -> t m a
unfoldM :: m (Maybe a) -> t m a
unfoldM m (Maybe a)
x = (Any -> m (Maybe (a, Any))) -> Any -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) b a.
(IsStream t, MonadAsync m) =>
(b -> m (Maybe (a, b))) -> b -> t m a
S.unfoldrM (m (Maybe (a, Any)) -> Any -> m (Maybe (a, Any))
forall a b. a -> b -> a
const (m (Maybe (a, Any)) -> Any -> m (Maybe (a, Any)))
-> m (Maybe (a, Any)) -> Any -> m (Maybe (a, Any))
forall a b. (a -> b) -> a -> b
$ (a -> (a, Any)) -> Maybe a -> Maybe (a, Any)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,Any
forall a. HasCallStack => a
undefined) (Maybe a -> Maybe (a, Any)) -> m (Maybe a) -> m (Maybe (a, Any))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Maybe a)
x) Any
forall a. HasCallStack => a
undefined
printIOError :: IO a -> IO (Either IOError a)
printIOError :: IO a -> IO (Either IOError a)
printIOError IO a
f = (a -> Either IOError a
forall a b. b -> Either a b
Right (a -> Either IOError a) -> IO a -> IO (Either IOError a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
f) IO (Either IOError a)
-> (IOError -> IO (Either IOError a)) -> IO (Either IOError a)
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` \IOError
err -> do
Handle -> IOError -> IO ()
forall a. Show a => Handle -> a -> IO ()
hPrint Handle
stderr IOError
err
Either IOError a -> IO (Either IOError a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either IOError a -> IO (Either IOError a))
-> Either IOError a -> IO (Either IOError a)
forall a b. (a -> b) -> a -> b
$ IOError -> Either IOError a
forall a b. a -> Either a b
Left IOError
err
printIOError' :: IO a -> IO (Maybe a)
printIOError' :: IO a -> IO (Maybe a)
printIOError' = (Either IOError a -> Maybe a)
-> IO (Either IOError a) -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either IOError a -> Maybe a
forall a b. Either a b -> Maybe b
eitherToMaybe (IO (Either IOError a) -> IO (Maybe a))
-> (IO a -> IO (Either IOError a)) -> IO a -> IO (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> IO (Either IOError a)
forall a. IO a -> IO (Either IOError a)
printIOError
applyWhen :: Bool -> (a -> a) -> a -> a
applyWhen :: Bool -> (a -> a) -> a -> a
applyWhen = ((a -> a) -> Bool -> a -> a) -> Bool -> (a -> a) -> a -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip (((a -> a) -> Bool -> a -> a) -> Bool -> (a -> a) -> a -> a)
-> ((a -> a) -> Bool -> a -> a) -> Bool -> (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ (a -> a) -> (a -> a) -> Bool -> a -> a
forall a. a -> a -> Bool -> a
bool a -> a
forall a. a -> a
id