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

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

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

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

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

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

--TODO perhaps streamly-fsnotify ought to use RawFilePath?
-- | 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 :: 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 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 -> -- success - return new device
                        (Device -> Maybe 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
                        (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 -> -- success - no longer watch for changes
                            (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
_ -> -- fail - continue to watch
                            (Maybe Device
forall a. Maybe a
Nothing, Set RawFilePath
watching)
                else -- this isn't an event we care about
                    (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 -> -- device is gone - no longer watch for changes
                (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


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

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

-- like tryIOError, but also prints the error to stderr
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

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

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