module Evdev.Stream (
allDevices,
allEvents,
makeDevices,
newDevices,
newDevices',
readEvents,
readEventsMany,
) where
import Data.Bool
import Data.Either.Extra
import Data.Functor
import System.IO
import System.IO.Error
import Control.Concurrent (threadDelay)
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.FilePath.ByteString ((</>))
import Streamly.Prelude (AsyncT, IsStream, MonadAsync, SerialT)
import qualified Streamly.Prelude as S
import Evdev
readEvents :: Device -> SerialT IO Event
readEvents :: Device -> SerialT IO Event
readEvents = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(IsStream t, MonadAsync m) =>
m a -> t m a
S.repeatM 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 :: forall (t :: (* -> *) -> * -> *).
IsStream t =>
AsyncT IO Device -> t IO (Device, Event)
readEventsMany AsyncT IO Device
ds = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
IsStream t =>
AsyncT m a -> t m a
S.fromAsync forall a b. (a -> b) -> a -> b
$ do
Device
d <- AsyncT IO Device
ds
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
(IsStream t, Monad m) =>
(a -> b) -> t m a -> t m b
S.map (Device
d,) forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
IsStream t =>
SerialT m a -> t m a
S.fromSerial forall a b. (a -> b) -> a -> b
$ Device -> SerialT IO Event
readEvents' Device
d
where
readEvents' :: Device -> SerialT IO Event
readEvents' = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(IsStream t, MonadAsync m) =>
m (Maybe a) -> t m a
unfoldM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IO a -> IO (Maybe a)
printIOError' 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 :: forall (t :: (* -> *) -> * -> *).
IsStream t =>
t IO RawFilePath -> t IO Device
makeDevices = 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 :: forall (t :: (* -> *) -> * -> *).
IsStream t =>
t IO (Device, Event)
allEvents = forall (t :: (* -> *) -> * -> *).
IsStream t =>
AsyncT IO Device -> t IO (Device, Event)
readEventsMany forall (t :: (* -> *) -> * -> *).
(IsStream t, Monad (t IO)) =>
t IO Device
allDevices
allDevices :: (IsStream t, Monad (t IO)) => t IO Device
allDevices :: forall (t :: (* -> *) -> * -> *).
(IsStream t, Monad (t IO)) =>
t IO Device
allDevices =
let paths :: t IO RawFilePath
paths = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(IsStream t, Monad m) =>
(a -> m Bool) -> t m a -> t m a
S.filterM RawFilePath -> IO Bool
doesFileExist forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
(IsStream t, Monad m) =>
(a -> b) -> t m a -> t m b
S.map (RawFilePath
evdevDir RawFilePath -> RawFilePath -> RawFilePath
</>) forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (f :: * -> *) a (m :: * -> *).
(IsStream t, Foldable f) =>
f a -> t m a
S.fromFoldable
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) (t :: (* -> *) -> * -> *) a.
(Monad m, IsStream t) =>
m a -> t m a
S.fromEffect (forall a. [a] -> [a]
reverse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RawFilePath -> IO [RawFilePath]
listDirectory RawFilePath
evdevDir)
in forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
(IsStream t, MonadAsync m, Functor (t m)) =>
(a -> m (Maybe b)) -> t m a -> t m b
S.mapMaybeM (forall a. IO a -> IO (Maybe a)
printIOError' 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 :: forall (t :: (* -> *) -> * -> *).
(IsStream t, Monad (t IO)) =>
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 forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
Right Device
d ->
(forall a. a -> Maybe a
Just Device
d, Set RawFilePath
watching)
Left IOError
e ->
(forall a. Maybe a
Nothing, forall a. Bool -> (a -> a) -> a -> a
applyWhen (IOError -> Bool
isPermissionError IOError
e) (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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Set RawFilePath
watching then
RawFilePath -> IO (Either IOError Device)
tryNewDevice RawFilePath
p forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
Right Device
d ->
(forall a. a -> Maybe a
Just Device
d, forall a. Ord a => a -> Set a -> Set a
Set.delete RawFilePath
p Set RawFilePath
watching)
Left IOError
_ ->
(forall a. Maybe a
Nothing, Set RawFilePath
watching)
else
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, Set RawFilePath
watching)
N.Removed (FilePath -> RawFilePath
BS.pack -> RawFilePath
p) UTCTime
_ FSEntryType
NotDir ->
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, forall a. Ord a => a -> Set a -> Set a
Set.delete RawFilePath
p Set RawFilePath
watching)
Event
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, Set RawFilePath
watching)
tryNewDevice :: RawFilePath -> IO (Either IOError Device)
tryNewDevice = forall a. IO a -> IO (Either IOError a)
printIOError forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawFilePath -> IO Device
newDevice
in do
(StopWatching IO
_,t IO Event
es) <- forall (m :: * -> *) (t :: (* -> *) -> * -> *) a.
(Monad m, IsStream t) =>
m a -> t m a
S.fromEffect forall a b. (a -> b) -> a -> b
$ 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
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 forall a. Set a
Set.empty t IO Event
es
newDevices' :: (IsStream t, Monad (t IO)) => Int -> t IO Device
newDevices' :: forall (t :: (* -> *) -> * -> *).
(IsStream t, Monad (t IO)) =>
Int -> t IO Device
newDevices' Int
delay =
let f :: Event -> IO (Maybe Device)
f = \case
N.Added (FilePath -> RawFilePath
BS.pack -> RawFilePath
p) UTCTime
_ FSEntryType
NotDir -> do
Int -> IO ()
threadDelay Int
delay
forall a b. Either a b -> Maybe b
eitherToMaybe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RawFilePath -> IO (Either IOError Device)
tryNewDevice RawFilePath
p
Event
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
tryNewDevice :: RawFilePath -> IO (Either IOError Device)
tryNewDevice = forall a. IO a -> IO (Either IOError a)
printIOError forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawFilePath -> IO Device
newDevice
in do
(StopWatching IO
_,t IO Event
es) <- forall (m :: * -> *) (t :: (* -> *) -> * -> *) a.
(Monad m, IsStream t) =>
m a -> t m a
S.fromEffect forall a b. (a -> b) -> a -> b
$ 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
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
(IsStream t, MonadAsync m, Functor (t m)) =>
(a -> m (Maybe b)) -> t m a -> t m b
S.mapMaybeM Event -> IO (Maybe Device)
f t IO Event
es
scanMaybe :: (IsStream t, Monad m) => (s -> a -> m (Maybe b, s)) -> s -> t m a -> t m b
scanMaybe :: forall (t :: (* -> *) -> * -> *) (m :: * -> *) s a b.
(IsStream t, Monad m) =>
(s -> a -> m (Maybe b, s)) -> s -> t m a -> t m b
scanMaybe s -> a -> m (Maybe b, s)
f s
e = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
(IsStream t, Monad m) =>
(a -> Maybe b) -> t m a -> t m b
S.mapMaybe forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) b a.
(IsStream t, Monad m) =>
(b -> a -> m b) -> m b -> t m a -> t m b
S.scanlM' (s -> a -> m (Maybe b, s)
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) (forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Maybe a
Nothing, s
e))
unfoldM :: (IsStream t, MonadAsync m) => m (Maybe a) -> t m a
unfoldM :: forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(IsStream t, MonadAsync m) =>
m (Maybe a) -> t m a
unfoldM m (Maybe a)
x = forall (t :: (* -> *) -> * -> *) (m :: * -> *) b a.
(IsStream t, MonadAsync m) =>
(b -> m (Maybe (a, b))) -> b -> t m a
S.unfoldrM (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,forall a. HasCallStack => a
undefined) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Maybe a)
x) forall a. HasCallStack => a
undefined
printIOError :: IO a -> IO (Either IOError a)
printIOError :: forall a. IO a -> IO (Either IOError a)
printIOError IO a
f = (forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
f) forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` \IOError
err -> do
forall a. Show a => Handle -> a -> IO ()
hPrint Handle
stderr IOError
err
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left IOError
err
printIOError' :: IO a -> IO (Maybe a)
printIOError' :: forall a. IO a -> IO (Maybe a)
printIOError' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. Either a b -> Maybe b
eitherToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IO a -> IO (Either IOError a)
printIOError
applyWhen :: Bool -> (a -> a) -> a -> a
applyWhen :: forall a. Bool -> (a -> a) -> a -> a
applyWhen = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> a -> b
$ forall a. a -> a -> Bool -> a
bool forall a. a -> a
id