-- | 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,
    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

--TODO provide a 'group' operation on streams, representing packets as sets

-- | Read all events from a device.
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

-- | 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 :: 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
        -- catch all IO errors
        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

-- | Create devices for all paths in the stream.
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

-- | All events on all valid devices (in /\/dev\/input/).
-- Prints any exceptions.
--
-- > allEvents == readEventsMany allDevices
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

--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 :: 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

--TODO perhaps streamly-fsnotify ought to use RawFilePath?
--TODO fix this - we don't always seem to get notified of permission changes -
    -- indeed when we don't, we actually find that 'stat' and 'ls -l' show different permissions to:
    -- 'fmap (flip showOct "" . fileMode) . getFileStatus'
-- | 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 :: forall (t :: (* -> *) -> * -> *).
(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 :: 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 -> -- success - return new device
                        (forall a. a -> Maybe a
Just Device
d, Set RawFilePath
watching)
                    Left IOError
e -> -- fail - if it's only a permission error then watch for changes on device
                        (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 -> -- success - no longer watch for changes
                            (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
_ -> -- fail - continue to watch
                            (forall a. Maybe a
Nothing, Set RawFilePath
watching)
                else -- this isn't an event we care about
                    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 -> -- device is gone - no longer watch for changes
                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

--TODO just fix 'newDevices'
-- | This is a workaround for bugginess in 'newDevices' when it comes to waiting for permissions on a new device
-- - it just waits the number of microseconds given before trying to read from the device.
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


{- 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 :: 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))

-- 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 :: 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

--TODO get rid - this isn't a great approach for a library
-- like tryIOError, but also prints the error to stderr
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

-- variant of printIOError which doesn't care what the exception was
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

-- apply the function iff the guard passes
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